diff options
Diffstat (limited to 'plugins')
238 files changed, 10984 insertions, 15064 deletions
diff --git a/plugins/.merlin b/plugins/.merlin.in index 2ba6169622..2ba6169622 100644 --- a/plugins/.merlin +++ b/plugins/.merlin.in diff --git a/plugins/btauto/Algebra.v b/plugins/btauto/Algebra.v index ee7341a4a2..638a4cef21 100644 --- a/plugins/btauto/Algebra.v +++ b/plugins/btauto/Algebra.v @@ -1,4 +1,4 @@ -Require Import Bool PArith DecidableClass Omega ROmega. +Require Import Bool PArith DecidableClass Omega Lia. Ltac bool := repeat match goal with @@ -10,7 +10,7 @@ end. Arguments decide P /H. -Hint Extern 5 => progress bool. +Hint Extern 5 => progress bool : core. Ltac define t x H := set (x := t) in *; assert (H : t = x) by reflexivity; clearbody x. @@ -84,9 +84,9 @@ Ltac case_decide := match goal with let H := fresh "H" in define (@decide P D) b H; destruct b; try_decide | [ |- context [Pos.compare ?x ?y] ] => - destruct (Pos.compare_spec x y); try (exfalso; zify; romega) + destruct (Pos.compare_spec x y); try lia | [ X : context [Pos.compare ?x ?y] |- _ ] => - destruct (Pos.compare_spec x y); try (exfalso; zify; romega) + destruct (Pos.compare_spec x y); try lia end. Section Definitions. @@ -147,7 +147,7 @@ Qed. (** * The core reflexive part. *) -Hint Constructors valid. +Hint Constructors valid : core. Fixpoint beq_poly pl pr := match pl with @@ -315,7 +315,7 @@ Section Validity. (* Decision procedure of validity *) -Hint Constructors valid linear. +Hint Constructors valid linear : core. Lemma valid_le_compat : forall k l p, valid k p -> (k <= l)%positive -> valid l p. Proof. @@ -325,13 +325,13 @@ Qed. Lemma linear_le_compat : forall k l p, linear k p -> (k <= l)%positive -> linear l p. Proof. -intros k l p H; revert l; induction H; constructor; eauto; zify; romega. +intros k l p H; revert l; induction H; constructor; eauto; lia. Qed. Lemma linear_valid_incl : forall k p, linear k p -> valid k p. Proof. intros k p H; induction H; constructor; auto. -eapply valid_le_compat; eauto; zify; romega. +eapply valid_le_compat; eauto; lia. Qed. End Validity. @@ -417,18 +417,18 @@ Qed. Hint Extern 5 => match goal with | [ |- (Pos.max ?x ?y <= ?z)%positive ] => - apply Pos.max_case_strong; intros; zify; romega + apply Pos.max_case_strong; intros; lia | [ |- (?z <= Pos.max ?x ?y)%positive ] => - apply Pos.max_case_strong; intros; zify; romega + apply Pos.max_case_strong; intros; lia | [ |- (Pos.max ?x ?y < ?z)%positive ] => - apply Pos.max_case_strong; intros; zify; romega + apply Pos.max_case_strong; intros; lia | [ |- (?z < Pos.max ?x ?y)%positive ] => - apply Pos.max_case_strong; intros; zify; romega + apply Pos.max_case_strong; intros; lia | _ => zify; omega -end. -Hint Resolve Pos.le_max_r Pos.le_max_l. +end : core. +Hint Resolve Pos.le_max_r Pos.le_max_l : core. -Hint Constructors valid linear. +Hint Constructors valid linear : core. (* Compatibility of validity w.r.t algebraic operations *) @@ -445,8 +445,8 @@ intros kl kr pl pr Hl Hr; revert kr pr Hr; induction Hl; intros kr pr Hr; simpl. now rewrite <- (Pos.max_id i); intuition. destruct (Pos.compare_spec i i0); subst; try case_decide; repeat (constructor; intuition). + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. - + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; zify; romega. - + apply (valid_le_compat (Pos.max (Pos.succ i0) (Pos.succ i0))); [now auto|]; rewrite Pos.max_id; zify; romega. + + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; lia. + + apply (valid_le_compat (Pos.max (Pos.succ i0) (Pos.succ i0))); [now auto|]; rewrite Pos.max_id; lia. + apply (valid_le_compat (Pos.max (Pos.succ i) i0)); intuition. + apply (valid_le_compat (Pos.max i (Pos.succ i0))); intuition. } @@ -456,7 +456,7 @@ Lemma poly_mul_cst_valid_compat : forall k v p, valid k p -> valid k (poly_mul_c Proof. intros k v p H; induction H; simpl; [now auto|]. case_decide; [|now auto]. -eapply (valid_le_compat i); [now auto|zify; romega]. +eapply (valid_le_compat i); [now auto|lia]. Qed. Lemma poly_mul_mon_null_compat : forall i p, null (poly_mul_mon i p) -> null p. diff --git a/plugins/btauto/Reflect.v b/plugins/btauto/Reflect.v index 3bd7cd622c..98f5ab067a 100644 --- a/plugins/btauto/Reflect.v +++ b/plugins/btauto/Reflect.v @@ -1,4 +1,4 @@ -Require Import Bool DecidableClass Algebra Ring PArith ROmega Omega. +Require Import Bool DecidableClass Algebra Ring PArith Omega. Section Bool. @@ -77,10 +77,10 @@ intros var f; induction f; simpl poly_of_formula; simpl formula_eval; auto. end. Qed. -Hint Extern 5 => change 0 with (min 0 0). -Local Hint Resolve poly_add_valid_compat poly_mul_valid_compat. -Local Hint Constructors valid. -Hint Extern 5 => zify; omega. +Hint Extern 5 => change 0 with (min 0 0) : core. +Local Hint Resolve poly_add_valid_compat poly_mul_valid_compat : core. +Local Hint Constructors valid : core. +Hint Extern 5 => zify; omega : core. (* Compatibility with validity *) @@ -396,3 +396,16 @@ lazymatch goal with end | _ => fail "Cannot recognize a boolean equality" end. *) + +Register formula_var as plugins.btauto.f_var. +Register formula_btm as plugins.btauto.f_btm. +Register formula_top as plugins.btauto.f_top. +Register formula_cnj as plugins.btauto.f_cnj. +Register formula_dsj as plugins.btauto.f_dsj. +Register formula_neg as plugins.btauto.f_neg. +Register formula_xor as plugins.btauto.f_xor. +Register formula_ifb as plugins.btauto.f_ifb. + +Register formula_eval as plugins.btauto.eval. +Register boolean_witness as plugins.btauto.witness. +Register reduce_poly_of_formula_sound_alt as plugins.btauto.soundness. diff --git a/plugins/btauto/g_btauto.ml4 b/plugins/btauto/g_btauto.mlg index 3ae0f45cb7..312ef1e555 100644 --- a/plugins/btauto/g_btauto.ml4 +++ b/plugins/btauto/g_btauto.mlg @@ -8,11 +8,15 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Ltac_plugin +} + DECLARE PLUGIN "btauto_plugin" TACTIC EXTEND btauto -| [ "btauto" ] -> [ Refl_btauto.Btauto.tac ] +| [ "btauto" ] -> { Refl_btauto.Btauto.tac } END diff --git a/plugins/btauto/plugin_base.dune b/plugins/btauto/plugin_base.dune new file mode 100644 index 0000000000..6a024358c3 --- /dev/null +++ b/plugins/btauto/plugin_base.dune @@ -0,0 +1,5 @@ +(library + (name btauto_plugin) + (public_name coq.plugins.btauto) + (synopsis "Coq's btauto plugin") + (libraries coq.plugins.ltac)) diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index a09abfa193..07f50f6cd5 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -1,16 +1,16 @@ -let contrib_name = "btauto" +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) -let init_constant dir s = - let find_constant contrib dir s = - Universes.constr_of_global (Coqlib.find_reference contrib dir s) - in - find_constant contrib_name dir s +open Constr -let get_constant dir s = lazy (Universes.constr_of_global @@ Coqlib.coq_reference contrib_name dir s) - -let get_inductive dir s = - let glob_ref () = Coqlib.find_reference contrib_name ("Coq" :: dir) s in - Lazy.from_fun (fun () -> Globnames.destIndRef (glob_ref ())) +let bt_lib_constr n = lazy (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref n) let decomp_term sigma (c : Constr.t) = Constr.kind (EConstr.Unsafe.to_constr (Termops.strip_outer_cast sigma (EConstr.of_constr c))) @@ -19,27 +19,23 @@ let lapp c v = Constr.mkApp (Lazy.force c, v) let (===) = Constr.equal + module CoqList = struct - let path = ["Init"; "Datatypes"] - let typ = get_constant path "list" - let _nil = get_constant path "nil" - let _cons = get_constant path "cons" + let _nil = bt_lib_constr "core.list.nil" + let _cons = bt_lib_constr "core.list.cons" let cons ty h t = lapp _cons [|ty; h ; t|] let nil ty = lapp _nil [|ty|] let rec of_list ty = function | [] -> nil ty | t::q -> cons ty t (of_list ty q) - let type_of_list ty = lapp typ [|ty|] end module CoqPositive = struct - let path = ["Numbers"; "BinNums"] - let typ = get_constant path "positive" - let _xH = get_constant path "xH" - let _xO = get_constant path "xO" - let _xI = get_constant path "xI" + let _xH = bt_lib_constr "num.pos.xH" + let _xO = bt_lib_constr "num.pos.xO" + let _xI = bt_lib_constr "num.pos.xI" (* A coq nat from an int *) let rec of_int n = @@ -79,14 +75,14 @@ end module Bool = struct - let typ = get_constant ["Init"; "Datatypes"] "bool" - let ind = get_inductive ["Init"; "Datatypes"] "bool" - let trueb = get_constant ["Init"; "Datatypes"] "true" - let falseb = get_constant ["Init"; "Datatypes"] "false" - let andb = get_constant ["Init"; "Datatypes"] "andb" - let orb = get_constant ["Init"; "Datatypes"] "orb" - let xorb = get_constant ["Init"; "Datatypes"] "xorb" - let negb = get_constant ["Init"; "Datatypes"] "negb" + let ind = lazy (Globnames.destIndRef (Coqlib.lib_ref "core.bool.type")) + let typ = bt_lib_constr "core.bool.type" + let trueb = bt_lib_constr "core.bool.true" + let falseb = bt_lib_constr "core.bool.false" + let andb = bt_lib_constr "core.bool.andb" + let orb = bt_lib_constr "core.bool.orb" + let xorb = bt_lib_constr "core.bool.xorb" + let negb = bt_lib_constr "core.bool.negb" type t = | Var of int @@ -106,7 +102,7 @@ module Bool = struct let negb = Lazy.force negb in let rec aux c = match decomp_term sigma c with - | Term.App (head, args) -> + | App (head, args) -> if head === andb && Array.length args = 2 then Andb (aux args.(0), aux args.(1)) else if head === orb && Array.length args = 2 then @@ -116,9 +112,9 @@ module Bool = struct else if head === negb && Array.length args = 1 then Negb (aux args.(0)) else Var (Env.add env c) - | Term.Case (info, r, arg, pats) -> + | Case (info, r, arg, pats) -> let is_bool = - let i = info.Term.ci_ind in + let i = info.ci_ind in Names.eq_ind i (Lazy.force ind) in if is_bool then @@ -138,21 +134,20 @@ module Btauto = struct open Pp - let eq = get_constant ["Init"; "Logic"] "eq" - - let f_var = get_constant ["btauto"; "Reflect"] "formula_var" - let f_btm = get_constant ["btauto"; "Reflect"] "formula_btm" - let f_top = get_constant ["btauto"; "Reflect"] "formula_top" - let f_cnj = get_constant ["btauto"; "Reflect"] "formula_cnj" - let f_dsj = get_constant ["btauto"; "Reflect"] "formula_dsj" - let f_neg = get_constant ["btauto"; "Reflect"] "formula_neg" - let f_xor = get_constant ["btauto"; "Reflect"] "formula_xor" - let f_ifb = get_constant ["btauto"; "Reflect"] "formula_ifb" + let eq = bt_lib_constr "core.eq.type" - let eval = get_constant ["btauto"; "Reflect"] "formula_eval" - let witness = get_constant ["btauto"; "Reflect"] "boolean_witness" + let f_var = bt_lib_constr "plugins.btauto.f_var" + let f_btm = bt_lib_constr "plugins.btauto.f_btm" + let f_top = bt_lib_constr "plugins.btauto.f_top" + let f_cnj = bt_lib_constr "plugins.btauto.f_cnj" + let f_dsj = bt_lib_constr "plugins.btauto.f_dsj" + let f_neg = bt_lib_constr "plugins.btauto.f_neg" + let f_xor = bt_lib_constr "plugins.btauto.f_xor" + let f_ifb = bt_lib_constr "plugins.btauto.f_ifb" - let soundness = get_constant ["btauto"; "Reflect"] "reduce_poly_of_formula_sound_alt" + let eval = bt_lib_constr "plugins.btauto.eval" + let witness = bt_lib_constr "plugins.btauto.witness" + let soundness = bt_lib_constr "plugins.btauto.soundness" let rec convert = function | Bool.Var n -> lapp f_var [|CoqPositive.of_int n|] @@ -176,9 +171,9 @@ module Btauto = struct let _, var = Tacmach.pf_reduction_of_red_expr gl (Genredexpr.CbvVm None) var in let var = EConstr.Unsafe.to_constr var in let rec to_list l = match decomp_term (Tacmach.project gl) l with - | Term.App (c, _) + | App (c, _) when c === (Lazy.force CoqList._nil) -> [] - | Term.App (c, [|_; h; t|]) + | App (c, [|_; h; t|]) when c === (Lazy.force CoqList._cons) -> if h === (Lazy.force Bool.trueb) then (true :: to_list t) else if h === (Lazy.force Bool.falseb) then (false :: to_list t) @@ -212,13 +207,13 @@ module Btauto = struct Tacticals.tclFAIL 0 msg gl let try_unification env = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let eq = Lazy.force eq in let concl = EConstr.Unsafe.to_constr concl in let t = decomp_term (Tacmach.New.project gl) concl in match t with - | Term.App (c, [|typ; p; _|]) when c === eq -> + | App (c, [|typ; p; _|]) when c === eq -> (* should be an equality [@eq poly ?p (Cst false)] *) let tac = Tacticals.New.tclORELSE0 Tactics.reflexivity (Proofview.V82.tactic (print_counterexample p env)) in tac @@ -228,7 +223,7 @@ module Btauto = struct end let tac = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let concl = EConstr.Unsafe.to_constr concl in let sigma = Tacmach.New.project gl in @@ -236,7 +231,7 @@ module Btauto = struct let bool = Lazy.force Bool.typ in let t = decomp_term sigma concl in match t with - | Term.App (c, [|typ; tl; tr|]) + | App (c, [|typ; tl; tr|]) when typ === bool && c === eq -> let env = Env.empty () in let fl = Bool.quote env sigma tl in diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/btauto/refl_btauto.mli index 44560ac18e..5478fddba5 100644 --- a/plugins/fourier/g_fourier.ml4 +++ b/plugins/btauto/refl_btauto.mli @@ -8,11 +8,4 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Ltac_plugin -open FourierR - -DECLARE PLUGIN "fourier_plugin" - -TACTIC EXTEND fourier - [ "fourierz" ] -> [ fourier () ] -END +module Btauto : sig val tac : unit Proofview.tactic end diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 5a48189260..a6f432b5bd 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -9,7 +9,7 @@ (************************************************************************) (* This file implements the basic congruence-closure algorithm by *) -(* Downey,Sethi and Tarjan. *) +(* Downey, Sethi and Tarjan. *) (* Plus some e-matching and constructor handling by P. Corbineau *) open CErrors @@ -18,7 +18,6 @@ open Names open Sorts open Constr open Vars -open Evd open Goptions open Tacmach open Util @@ -27,6 +26,10 @@ let init_size=5 let cc_verbose=ref false +let print_constr t = + let sigma, env = Pfedit.get_current_context () in + Printer.pr_econstr_env env sigma t + let debug x = if !cc_verbose then Feedback.msg_debug (x ()) @@ -131,8 +134,8 @@ type cinfo= ci_nhyps: int} (* # projectable args *) let family_eq f1 f2 = match f1, f2 with - | Prop Pos, Prop Pos - | Prop Null, Prop Null + | Set, Set + | Prop, Prop | Type _, Type _ -> true | _ -> false @@ -272,7 +275,8 @@ type state = mutable rew_depth:int; mutable changed:bool; by_type: Int.Set.t Typehash.t; - mutable gls:Goal.goal Evd.sigma} + mutable env:Environ.env; + sigma:Evd.evar_map} let dummy_node = { @@ -307,7 +311,8 @@ let empty depth gls:state = rew_depth=depth; by_type=Constrhash.create init_size; changed=false; - gls=gls + env=pf_env gls; + sigma=project gls } let forest state = state.uf @@ -328,9 +333,6 @@ let get_representative uf i= let get_constructors uf i= uf.map.(i).constructors -let find_pac uf i pac = - PacMap.find pac (get_constructors uf i) - let rec find_oldest_pac uf i pac= try PacMap.find pac (get_constructors uf i) with Not_found -> @@ -426,7 +428,7 @@ let cc_product s1 s2 = mkLambda(_B_,mkSort(s2),_body_)) let rec constr_of_term = function - Symb s-> applist_projection s [] + Symb s-> s | Product(s1,s2) -> cc_product s1 s2 | Eps id -> mkVar id | Constructor cinfo -> mkConstructU cinfo.ci_constr @@ -434,25 +436,7 @@ let rec constr_of_term = function make_app [(constr_of_term s2)] s1 and make_app l=function Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1 - | other -> - applist_proj other l -and applist_proj c l = - match c with - | Symb s -> applist_projection s l - | _ -> Term.applistc (constr_of_term c) l -and applist_projection c l = - match Constr.kind c with - | Const c when Environ.is_projection (fst c) (Global.env()) -> - let p = Projection.make (fst c) false in - (match l with - | [] -> (* Expand the projection *) - let ty = Typeops.type_of_constant_in (Global.env ()) c in (* FIXME constraints *) - let pb = Environ.lookup_projection p (Global.env()) in - let ctx,_ = Term.decompose_prod_n_assum (pb.Declarations.proj_npars + 1) ty in - Term.it_mkLambda_or_LetIn (mkProj(p,mkRel 1)) ctx - | hd :: tl -> - Term.applistc (mkProj (p, hd)) tl) - | _ -> Term.applistc c l + | other -> Term.applist (constr_of_term other,l) let rec canonize_name sigma c = let c = EConstr.Unsafe.to_constr c in @@ -474,10 +458,10 @@ let rec canonize_name sigma c = | LetIn (na,b,t,ct) -> mkLetIn (na, func b,func t,func ct) | App (ct,l) -> - mkApp (func ct,Array.smartmap func l) + mkApp (func ct,Array.Smart.map func l) | Proj(p,c) -> let p' = Projection.map (fun kn -> - Constant.make1 (Constant.canonical kn)) p in + MutInd.make1 (MutInd.canonical kn)) p in (mkProj (p', func c)) | _ -> c @@ -500,10 +484,10 @@ let rec inst_pattern subst = function args t let pr_idx_term uf i = str "[" ++ int i ++ str ":=" ++ - Termops.print_constr (EConstr.of_constr (constr_of_term (term uf i))) ++ str "]" + print_constr (EConstr.of_constr (constr_of_term (term uf i))) ++ str "]" let pr_term t = str "[" ++ - Termops.print_constr (EConstr.of_constr (constr_of_term t)) ++ str "]" + print_constr (EConstr.of_constr (constr_of_term t)) ++ str "]" let rec add_term state t= let uf=state.uf in @@ -511,8 +495,8 @@ let rec add_term state t= Not_found -> let b=next uf in let trm = constr_of_term t in - let typ = pf_unsafe_type_of state.gls (EConstr.of_constr trm) in - let typ = canonize_name (project state.gls) typ in + let typ = Typing.unsafe_type_of state.env state.sigma (EConstr.of_constr trm) in + let typ = canonize_name state.sigma typ in let new_node= match t with Symb _ | Product (_,_) -> @@ -618,7 +602,7 @@ let add_inst state (inst,int_subst) = begin debug (fun () -> (str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++ - (str " [" ++ Termops.print_constr (EConstr.of_constr prf) ++ str " : " ++ + (str " [" ++ print_constr (EConstr.of_constr prf) ++ str " : " ++ pr_term s ++ str " == " ++ pr_term t ++ str "]")); add_equality state prf s t end @@ -626,7 +610,7 @@ let add_inst state (inst,int_subst) = begin debug (fun () -> (str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++ - (str " [" ++ Termops.print_constr (EConstr.of_constr prf) ++ str " : " ++ + (str " [" ++ print_constr (EConstr.of_constr prf) ++ str " : " ++ pr_term s ++ str " <> " ++ pr_term t ++ str "]")); add_disequality state (Hyp prf) s t end @@ -820,11 +804,10 @@ let one_step state = 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 [Context.Named.Declaration.LocalAssum (id,typ)] in - state.gls<- gls; - id + let ids = Environ.ids_of_named_context_val (Environ.named_context_val state.env) in + let id = Namegen.next_ident_away __eps__ ids in + state.env<- EConstr.push_named (Context.Named.Declaration.LocalAssum (id,typ)) state.env; + id let complete_one_class state i= match (get_representative state.uf i).inductive_status with @@ -832,9 +815,9 @@ let complete_one_class state i= let rec app t typ n = if n<=0 then t else let _,etyp,rest= destProd typ in - let id = new_state_var etyp state in + let id = new_state_var (EConstr.of_constr etyp) state in app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in - let _c = pf_unsafe_type_of state.gls + let _c = Typing.unsafe_type_of state.env state.sigma (EConstr.of_constr (constr_of_term (term state.uf pac.cnode))) in let _c = EConstr.Unsafe.to_constr _c in let _args = diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index 4ebc6a135a..d52e83dc31 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -145,8 +145,6 @@ val tail_pac : pa_constructor -> pa_constructor val find : forest -> int -> int -val find_pac : forest -> int -> pa_constructor -> int - val find_oldest_pac : forest -> int -> pa_constructor -> int val term : forest -> int -> term diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index d19817e74e..055d36747d 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -28,17 +28,13 @@ open Proofview.Notations module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration -let reference dir s = lazy (Coqlib.coq_reference "CC" dir s) - -let _f_equal = reference ["Init";"Logic"] "f_equal" -let _eq_rect = reference ["Init";"Logic"] "eq_rect" -let _refl_equal = reference ["Init";"Logic"] "eq_refl" -let _sym_eq = reference ["Init";"Logic"] "eq_sym" -let _trans_eq = reference ["Init";"Logic"] "eq_trans" -let _eq = reference ["Init";"Logic"] "eq" -let _False = reference ["Init";"Logic"] "False" -let _True = reference ["Init";"Logic"] "True" -let _I = reference ["Init";"Logic"] "I" +let _f_equal = lazy (Coqlib.lib_ref "core.eq.congr") +let _eq_rect = lazy (Coqlib.lib_ref "core.eq.rect") +let _refl_equal = lazy (Coqlib.lib_ref "core.eq.refl") +let _sym_eq = lazy (Coqlib.lib_ref "core.eq.sym") +let _trans_eq = lazy (Coqlib.lib_ref "core.eq.trans") +let _eq = lazy (Coqlib.lib_ref "core.eq.type") +let _False = lazy (Coqlib.lib_ref "core.False.type") let whd env sigma t = Reductionops.clos_whd_flags CClosure.betaiotazeta env sigma t @@ -49,7 +45,7 @@ let whd_delta env sigma t = (* decompose member of equality in an applicative format *) (** FIXME: evar leak *) -let sf_of env sigma c = e_sort_of env (ref sigma) c +let sf_of env sigma c = snd (sort_of env sigma c) let rec decompose_term env sigma t= match EConstr.kind sigma (whd env sigma t) with @@ -84,13 +80,13 @@ let rec decompose_term env sigma t= let canon_const = Constant.make1 (Constant.canonical c) in (Symb (Constr.mkConstU (canon_const,u))) | Proj (p, c) -> - let canon_const kn = Constant.make1 (Constant.canonical kn) in - let p' = Projection.map canon_const p in + let canon_mind kn = MutInd.make1 (MutInd.canonical kn) in + let p' = Projection.map canon_mind p in let c = Retyping.expand_projection env sigma p' c [] in decompose_term env sigma c | _ -> let t = Termops.strip_outer_cast sigma t in - if closed0 sigma t then Symb (EConstr.to_constr sigma t) else raise Not_found + if closed0 sigma t then Symb (EConstr.to_constr ~abort_on_undefined_evars:false sigma t) else raise Not_found (* decompose equality in members and type *) open Termops @@ -264,9 +260,8 @@ let app_global_with_holes f args n = let ans = mkApp (fc, args) in let (sigma, holes) = gen_holes env sigma t n [] in let ans = applist (ans, holes) in - let evdref = ref sigma in - let () = Typing.e_check env evdref ans concl in - (!evdref, ans) + let sigma = Typing.check env sigma ans concl in + (sigma, ans) end end @@ -424,7 +419,7 @@ let build_term_to_complete uf pac = let cc_tactic depth additionnal_terms = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in - Coqlib.check_required_library Coqlib.logic_module_name; + Coqlib.(check_required_library logic_module_name); let _ = debug (fun () -> Pp.str "Reading subgoal ...") in let state = make_prb gl depth additionnal_terms in let _ = debug (fun () -> Pp.str "Problem built, solving ...") in @@ -444,7 +439,7 @@ let cc_tactic depth additionnal_terms = let open Glob_term in let env = Proofview.Goal.env gl in let terms_to_complete = List.map (build_term_to_complete uf) (epsilons uf) in - let hole = DAst.make @@ GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None) in + let hole = DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None) in let pr_missing (c, missing) = let c = Detyping.detype Detyping.Now ~lax:true false Id.Set.empty env sigma c in let holes = List.init missing (fun _ -> hole) in diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.mlg index fb013ac131..685059294f 100644 --- a/plugins/cc/g_congruence.ml4 +++ b/plugins/cc/g_congruence.mlg @@ -8,22 +8,26 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Ltac_plugin open Cctac open Stdarg +} + DECLARE PLUGIN "cc_plugin" (* Tactic registration *) TACTIC EXTEND cc - [ "congruence" ] -> [ congruence_tac 1000 [] ] - |[ "congruence" integer(n) ] -> [ congruence_tac n [] ] - |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 1000 l ] +| [ "congruence" ] -> { congruence_tac 1000 [] } +| [ "congruence" integer(n) ] -> { congruence_tac n [] } +| [ "congruence" "with" ne_constr_list(l) ] -> { congruence_tac 1000 l } |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> - [ congruence_tac n l ] + { congruence_tac n l } END TACTIC EXTEND f_equal - [ "f_equal" ] -> [ f_equal ] +| [ "f_equal" ] -> { f_equal } END diff --git a/plugins/cc/plugin_base.dune b/plugins/cc/plugin_base.dune new file mode 100644 index 0000000000..2a92996d2a --- /dev/null +++ b/plugins/cc/plugin_base.dune @@ -0,0 +1,5 @@ +(library + (name cc_plugin) + (public_name coq.plugins.cc) + (synopsis "Coq's congruence closure plugin") + (libraries coq.plugins.ltac)) diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index 8a55538bde..480819ebe1 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -61,7 +61,7 @@ let start_deriving f suchthat lemma = | Proved (opaque, None, obj) -> match Proof_global.(obj.entries) with | [_;f_def;lemma_def] -> - opaque <> Vernacexpr.Transparent , f_def , lemma_def + opaque <> Proof_global.Transparent , f_def , lemma_def | _ -> assert false in (** The opacity of [f_def] is adjusted to be [false], as it diff --git a/plugins/derive/g_derive.ml4 b/plugins/derive/g_derive.mlg index a59324149c..df4b647642 100644 --- a/plugins/derive/g_derive.ml4 +++ b/plugins/derive/g_derive.mlg @@ -8,13 +8,21 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Stdarg +} + DECLARE PLUGIN "derive_plugin" -let classify_derive_command _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]),VtLater) +{ + +let classify_derive_command _ = Vernacextend.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]),VtLater) + +} -VERNAC COMMAND EXTEND Derive CLASSIFIED BY classify_derive_command +VERNAC COMMAND EXTEND Derive CLASSIFIED BY { classify_derive_command } | [ "Derive" ident(f) "SuchThat" constr(suchthat) "As" ident(lemma) ] -> - [ Derive.start_deriving f suchthat lemma ] + { Derive.start_deriving f suchthat lemma } END diff --git a/plugins/derive/plugin_base.dune b/plugins/derive/plugin_base.dune new file mode 100644 index 0000000000..ba9cd595ce --- /dev/null +++ b/plugins/derive/plugin_base.dune @@ -0,0 +1,5 @@ +(library + (name derive_plugin) + (public_name coq.plugins.derive) + (synopsis "Coq's derive plugin") + (libraries coq.plugins.ltac)) diff --git a/plugins/extraction/ExtrHaskellString.v b/plugins/extraction/ExtrHaskellString.v index ac1f6f9130..a4a40d3c5a 100644 --- a/plugins/extraction/ExtrHaskellString.v +++ b/plugins/extraction/ExtrHaskellString.v @@ -35,6 +35,8 @@ Extract Inductive ascii => "Prelude.Char" (Data.Bits.testBit (Data.Char.ord a) 6) (Data.Bits.testBit (Data.Char.ord a) 7))". Extract Inlined Constant Ascii.ascii_dec => "(Prelude.==)". +Extract Inlined Constant Ascii.eqb => "(Prelude.==)". Extract Inductive string => "Prelude.String" [ "([])" "(:)" ]. Extract Inlined Constant String.string_dec => "(Prelude.==)". +Extract Inlined Constant String.eqb => "(Prelude.==)". diff --git a/plugins/extraction/ExtrOcamlString.v b/plugins/extraction/ExtrOcamlString.v index 030b486b26..a2a6a8fe67 100644 --- a/plugins/extraction/ExtrOcamlString.v +++ b/plugins/extraction/ExtrOcamlString.v @@ -33,6 +33,7 @@ Extract Constant shift => "fun b c -> Char.chr (((Char.code c) lsl 1) land 255 + if b then 1 else 0)". Extract Inlined Constant ascii_dec => "(=)". +Extract Inlined Constant Ascii.eqb => "(=)". Extract Inductive string => "char list" [ "[]" "(::)" ]. diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index f235bb8986..bdeb6fca60 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -112,17 +112,12 @@ 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 -[@@@ocaml.warning "-3"] (* String.(un)capitalize_ascii since 4.03.0 GPR#124 *) -let capitalize = String.capitalize -let uncapitalize = String.uncapitalize -[@@@ocaml.warning "+3"] - -let lowercase_id id = Id.of_string (uncapitalize (ascii_of_id id)) +let lowercase_id id = Id.of_string (String.uncapitalize_ascii (ascii_of_id id)) let uppercase_id id = 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 (capitalize s) + else Id.of_string (String.capitalize_ascii s) type kind = Term | Type | Cons | Mod @@ -593,7 +588,7 @@ let pp_global k r = let ls = ref_renaming (k,r) in assert (List.length ls > 1); let s = List.hd ls in - let mp,_,l = repr_of_r r in + let mp,l = repr_of_r r in if ModPath.equal mp (top_visible_mp ()) then (* simpliest situation: definition of r (or use in the same context) *) (* we update the visible environment *) diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli index 78545c8bdf..07237d7504 100644 --- a/plugins/extraction/common.mli +++ b/plugins/extraction/common.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Globnames open Miniml (** By default, in module Format, you can do horizontal placing of blocks @@ -54,7 +53,7 @@ val opened_libraries : unit -> ModPath.t list type kind = Term | Type | Cons | Mod -val pp_global : kind -> global_reference -> string +val pp_global : kind -> GlobRef.t -> string val pp_module : ModPath.t -> string val top_visible_mp : unit -> ModPath.t diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 397cb29208..b0f6301192 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -30,7 +30,7 @@ open Common let toplevel_env () = let get_reference = function | (_,kn), Lib.Leaf o -> - let mp,_,l = KerName.repr kn in + let mp,l = KerName.repr kn in begin match Libobject.object_tag o with | "CONSTANT" -> let constant = Global.lookup_constant (Constant.make1 kn) in @@ -79,7 +79,7 @@ module type VISIT = sig (* Add reference / ... in the visit lists. These functions silently add the mp of their arg in the mp list *) - val add_ref : global_reference -> unit + val add_ref : GlobRef.t -> unit val add_kn : KerName.t -> unit val add_decl_deps : ml_decl -> unit val add_spec_deps : ml_spec -> unit @@ -124,7 +124,7 @@ module Visit : VISIT = struct end let add_field_label mp = function - | (lab, (SFBconst _|SFBmind _)) -> Visit.add_kn (KerName.make2 mp lab) + | (lab, (SFBconst _|SFBmind _)) -> Visit.add_kn (KerName.make mp lab) | (lab, (SFBmodule _|SFBmodtype _)) -> Visit.add_mp_all (MPdot (mp,lab)) let rec add_labels mp = function @@ -208,10 +208,10 @@ let env_for_mtb_with_def env mp me reso idl = Modops.add_structure mp before reso env let make_cst resolver mp l = - Mod_subst.constant_of_delta_kn resolver (KerName.make2 mp l) + Mod_subst.constant_of_delta_kn resolver (KerName.make mp l) let make_mind resolver mp l = - Mod_subst.mind_of_delta_kn resolver (KerName.make2 mp l) + Mod_subst.mind_of_delta_kn resolver (KerName.make mp l) (* From a [structure_body] (i.e. a list of [structure_field_body]) to specifications. *) @@ -596,19 +596,18 @@ let warns () = let rec locate_ref = function | [] -> [],[] - | r::l -> - let q = qualid_of_reference r in - let mpo = try Some (Nametab.locate_module q.CAst.v) with Not_found -> None + | qid::l -> + let mpo = try Some (Nametab.locate_module qid) with Not_found -> None and ro = - try Some (Smartlocate.global_with_alias r) + try Some (Smartlocate.global_with_alias qid) with Nametab.GlobalizationError _ | UserError _ -> None in match mpo, ro with - | None, None -> Nametab.error_global_not_found q + | None, None -> Nametab.error_global_not_found qid | 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_ambiguous_name (q.CAst.v,mp,r); + warning_ambiguous_name (qid,mp,r); let refs,mps = locate_ref l in refs,mp::mps (*s Recursive extraction in the Coq toplevel. The vernacular command is @@ -646,7 +645,7 @@ let separate_extraction lr = is \verb!Extraction! [qualid]. *) let simple_extraction r = - Vernacentries.dump_global CAst.(make (Misctypes.AN r)); + Vernacentries.dump_global CAst.(make (Constrexpr.AN r)); match locate_ref [r] with | ([], [mp]) as p -> full_extr None p | [r],[] -> @@ -711,10 +710,10 @@ let structure_for_compute env sg c = init false false ~compute:true; let ast, mlt = Extraction.extract_constr env sg c in let ast = Mlutil.normalize ast in - let refs = ref Refset.empty in - let add_ref r = refs := Refset.add r !refs in + let refs = ref GlobRef.Set.empty in + let add_ref r = refs := GlobRef.Set.add r !refs in let () = ast_iter_references add_ref add_ref add_ref ast in - let refs = Refset.elements !refs in + let refs = GlobRef.Set.elements !refs in let struc = optimize_struct (refs,[]) (mono_environment refs []) in (flatten_structure struc), ast, mlt diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index 591d3bb86e..54fde2ca46 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -12,21 +12,20 @@ open Names open Libnames -open Globnames -val simple_extraction : reference -> unit -val full_extraction : string option -> reference list -> unit -val separate_extraction : reference list -> unit +val simple_extraction : qualid -> unit +val full_extraction : string option -> qualid list -> unit +val separate_extraction : qualid list -> unit val extraction_library : bool -> Id.t -> unit (* For the test-suite : extraction to a temporary file + ocamlc on it *) -val extract_and_compile : reference list -> unit +val extract_and_compile : qualid list -> unit (* For debug / external output via coqtop.byte + Drop : *) val mono_environment : - global_reference list -> ModPath.t list -> Miniml.ml_structure + GlobRef.t list -> ModPath.t list -> Miniml.ml_structure (* Used by the Relation Extraction plugin *) diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index f25f636249..67c605ea1d 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -431,7 +431,7 @@ and extract_really_ind env kn mib = let packets = Array.mapi (fun i mip -> - let (_,u),_ = Universes.fresh_inductive_instance env (kn,i) in + let (_,u),_ = UnivGen.fresh_inductive_instance env (kn,i) in let ar = Inductive.type_of_inductive env ((mib,mip),u) in let ar = EConstr.of_constr ar in let info = (fst (flag_of_type env sg ar) = Info) in @@ -488,7 +488,7 @@ and extract_really_ind env kn mib = Int.equal (List.length l) 1 && not (type_mem_kn kn (List.hd l)) then raise (I Singleton); if List.is_empty l then raise (I Standard); - if Option.is_empty mib.mind_record then raise (I Standard); + if mib.mind_record == Declarations.NotRecord then raise (I Standard); (* Now we're sure it's a record. *) (* First, we find its field names. *) let rec names_prod t = match Constr.kind t with @@ -1065,9 +1065,14 @@ let extract_constant env kn cb = (match cb.const_body with | Undef _ -> warn_info (); mk_typ_ax () | Def c -> - (match cb.const_proj with + (match Recordops.find_primitive_projection kn with | None -> mk_typ (get_body c) - | Some pb -> mk_typ (EConstr.of_constr pb.proj_body)) + | Some p -> + let p = Projection.make p false in + let ind = Projection.inductive p in + let bodies = Inductiveops.legacy_match_projection env ind in + let body = bodies.(Projection.arg p) in + mk_typ (EConstr.of_constr body)) | OpaqueDef c -> add_opaque r; if access_opaque () then mk_typ (get_opaque env c) @@ -1076,9 +1081,14 @@ let extract_constant env kn cb = (match cb.const_body with | Undef _ -> warn_info (); mk_ax () | Def c -> - (match cb.const_proj with + (match Recordops.find_primitive_projection kn with | None -> mk_def (get_body c) - | Some pb -> mk_def (EConstr.of_constr pb.proj_body)) + | Some p -> + let p = Projection.make p false in + let ind = Projection.inductive p in + let bodies = Inductiveops.legacy_match_projection env ind in + let body = bodies.(Projection.arg p) in + mk_def (EConstr.of_constr body)) | OpaqueDef c -> add_opaque r; if access_opaque () then mk_def (get_opaque env c) diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.mlg index 93909f3e64..1445dffefa 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.mlg @@ -8,14 +8,19 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Pcoq.Prim +} + DECLARE PLUGIN "extraction_plugin" +{ + (* ML names *) open Ltac_plugin -open Genarg open Stdarg open Pp open Names @@ -24,23 +29,31 @@ open Extract_env let pr_mlname _ _ _ s = spc () ++ qs s +} + ARGUMENT EXTEND mlname TYPED AS string - PRINTED BY pr_mlname -| [ preident(id) ] -> [ id ] -| [ string(s) ] -> [ s ] + PRINTED BY { pr_mlname } +| [ preident(id) ] -> { id } +| [ string(s) ] -> { s } END +{ + let pr_int_or_id _ _ _ = function | ArgInt i -> int i | ArgId id -> Id.print id +} + ARGUMENT EXTEND int_or_id - PRINTED BY pr_int_or_id -| [ preident(id) ] -> [ ArgId (Id.of_string id) ] -| [ integer(i) ] -> [ ArgInt i ] + PRINTED BY { pr_int_or_id } +| [ preident(id) ] -> { ArgId (Id.of_string id) } +| [ integer(i) ] -> { ArgInt i } END +{ + let pr_language = function | Ocaml -> str "OCaml" | Haskell -> str "Haskell" @@ -52,117 +65,119 @@ let warn_deprecated_ocaml_spelling = (fun () -> strbrk ("The spelling \"OCaml\" should be used instead of \"Ocaml\".")) +} + VERNAC ARGUMENT EXTEND language -PRINTED BY pr_language -| [ "Ocaml" ] -> [ let _ = warn_deprecated_ocaml_spelling () in Ocaml ] -| [ "OCaml" ] -> [ Ocaml ] -| [ "Haskell" ] -> [ Haskell ] -| [ "Scheme" ] -> [ Scheme ] -| [ "JSON" ] -> [ JSON ] +PRINTED BY { pr_language } +| [ "Ocaml" ] -> { let _ = warn_deprecated_ocaml_spelling () in Ocaml } +| [ "OCaml" ] -> { Ocaml } +| [ "Haskell" ] -> { Haskell } +| [ "Scheme" ] -> { Scheme } +| [ "JSON" ] -> { JSON } END (* Extraction commands *) VERNAC COMMAND EXTEND Extraction CLASSIFIED AS QUERY (* Extraction in the Coq toplevel *) -| [ "Extraction" global(x) ] -> [ simple_extraction x ] -| [ "Recursive" "Extraction" ne_global_list(l) ] -> [ full_extraction None l ] +| [ "Extraction" global(x) ] -> { simple_extraction x } +| [ "Recursive" "Extraction" ne_global_list(l) ] -> { full_extraction None l } (* Monolithic extraction to a file *) | [ "Extraction" string(f) ne_global_list(l) ] - -> [ full_extraction (Some f) l ] + -> { full_extraction (Some f) l } (* Extraction to a temporary file and OCaml compilation *) | [ "Extraction" "TestCompile" ne_global_list(l) ] - -> [ extract_and_compile l ] + -> { extract_and_compile l } END VERNAC COMMAND EXTEND SeparateExtraction CLASSIFIED AS QUERY (* Same, with content splitted in several files *) | [ "Separate" "Extraction" ne_global_list(l) ] - -> [ separate_extraction l ] + -> { separate_extraction l } END (* Modular extraction (one Coq library = one ML module) *) VERNAC COMMAND EXTEND ExtractionLibrary CLASSIFIED AS QUERY | [ "Extraction" "Library" ident(m) ] - -> [ extraction_library false m ] + -> { extraction_library false m } END VERNAC COMMAND EXTEND RecursiveExtractionLibrary CLASSIFIED AS QUERY | [ "Recursive" "Extraction" "Library" ident(m) ] - -> [ extraction_library true m ] + -> { extraction_library true m } END (* Target Language *) VERNAC COMMAND EXTEND ExtractionLanguage CLASSIFIED AS SIDEFF | [ "Extraction" "Language" language(l) ] - -> [ extraction_language l ] + -> { extraction_language l } END VERNAC COMMAND EXTEND ExtractionInline CLASSIFIED AS SIDEFF (* Custom inlining directives *) | [ "Extraction" "Inline" ne_global_list(l) ] - -> [ extraction_inline true l ] + -> { extraction_inline true l } END VERNAC COMMAND EXTEND ExtractionNoInline CLASSIFIED AS SIDEFF | [ "Extraction" "NoInline" ne_global_list(l) ] - -> [ extraction_inline false l ] + -> { extraction_inline false l } END VERNAC COMMAND EXTEND PrintExtractionInline CLASSIFIED AS QUERY | [ "Print" "Extraction" "Inline" ] - -> [Feedback. msg_info (print_extraction_inline ()) ] + -> {Feedback. msg_info (print_extraction_inline ()) } END VERNAC COMMAND EXTEND ResetExtractionInline CLASSIFIED AS SIDEFF | [ "Reset" "Extraction" "Inline" ] - -> [ reset_extraction_inline () ] + -> { reset_extraction_inline () } END VERNAC COMMAND EXTEND ExtractionImplicit CLASSIFIED AS SIDEFF (* Custom implicit arguments of some csts/inds/constructors *) | [ "Extraction" "Implicit" global(r) "[" int_or_id_list(l) "]" ] - -> [ extraction_implicit r l ] + -> { extraction_implicit r l } END VERNAC COMMAND EXTEND ExtractionBlacklist CLASSIFIED AS SIDEFF (* Force Extraction to not use some filenames *) | [ "Extraction" "Blacklist" ne_ident_list(l) ] - -> [ extraction_blacklist l ] + -> { extraction_blacklist l } END VERNAC COMMAND EXTEND PrintExtractionBlacklist CLASSIFIED AS QUERY | [ "Print" "Extraction" "Blacklist" ] - -> [ Feedback.msg_info (print_extraction_blacklist ()) ] + -> { Feedback.msg_info (print_extraction_blacklist ()) } END VERNAC COMMAND EXTEND ResetExtractionBlacklist CLASSIFIED AS SIDEFF | [ "Reset" "Extraction" "Blacklist" ] - -> [ reset_extraction_blacklist () ] + -> { reset_extraction_blacklist () } END (* Overriding of a Coq object by an ML one *) VERNAC COMMAND EXTEND ExtractionConstant CLASSIFIED AS SIDEFF | [ "Extract" "Constant" global(x) string_list(idl) "=>" mlname(y) ] - -> [ extract_constant_inline false x idl y ] + -> { extract_constant_inline false x idl y } END VERNAC COMMAND EXTEND ExtractionInlinedConstant CLASSIFIED AS SIDEFF | [ "Extract" "Inlined" "Constant" global(x) "=>" mlname(y) ] - -> [ extract_constant_inline true x [] y ] + -> { extract_constant_inline true x [] y } END VERNAC COMMAND EXTEND ExtractionInductive CLASSIFIED AS SIDEFF | [ "Extract" "Inductive" global(x) "=>" mlname(id) "[" mlname_list(idl) "]" string_opt(o) ] - -> [ extract_inductive x id idl o ] + -> { extract_inductive x id idl o } END (* Show the extraction of the current proof *) VERNAC COMMAND EXTEND ShowExtraction CLASSIFIED AS QUERY | [ "Show" "Extraction" ] - -> [ show_extraction () ] + -> { show_extraction () } END diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index e6234c1452..97fe9f24d5 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -21,10 +21,8 @@ open Mlutil open Common (*s Haskell renaming issues. *) -[@@@ocaml.warning "-3"] (* String.(un)capitalize_ascii since 4.03.0 GPR#124 *) -let pr_lower_id id = str (String.uncapitalize (Id.to_string id)) -let pr_upper_id id = str (String.capitalize (Id.to_string id)) -[@@@ocaml.warning "+3"] +let pr_lower_id id = str (String.uncapitalize_ascii (Id.to_string id)) +let pr_upper_id id = str (String.capitalize_ascii (Id.to_string id)) let keywords = List.fold_right (fun s -> Id.Set.add (Id.of_string s)) diff --git a/plugins/extraction/miniml.ml b/plugins/extraction/miniml.ml index e1e49d9269..ce920ad6a0 100644 --- a/plugins/extraction/miniml.ml +++ b/plugins/extraction/miniml.ml @@ -11,7 +11,6 @@ (*s Target language for extraction: a core ML called MiniML. *) open Names -open Globnames (* The [signature] type is used to know how many arguments a CIC object expects, and what these arguments will become in the ML @@ -26,7 +25,7 @@ open Globnames type kill_reason = | Ktype | Kprop - | Kimplicit of global_reference * int (* n-th arg of a cst or construct *) + | Kimplicit of GlobRef.t * int (* n-th arg of a cst or construct *) type sign = Keep | Kill of kill_reason @@ -39,7 +38,7 @@ type signature = sign list type ml_type = | Tarr of ml_type * ml_type - | Tglob of global_reference * ml_type list + | Tglob of GlobRef.t * ml_type list | Tvar of int | Tvar' of int (* same as Tvar, used to avoid clash *) | Tmeta of ml_meta (* used during ML type reconstruction *) @@ -60,7 +59,7 @@ type inductive_kind = | Singleton | Coinductive | Standard - | Record of global_reference option list (* None for anonymous field *) + | Record of GlobRef.t option list (* None for anonymous field *) (* A [ml_ind_packet] is the miniml counterpart of a [one_inductive_body]. If the inductive is logical ([ip_logical = false]), then all other fields @@ -118,8 +117,8 @@ and ml_ast = | MLapp of ml_ast * ml_ast list | MLlam of ml_ident * ml_ast | MLletin of ml_ident * ml_ast * ml_ast - | MLglob of global_reference - | MLcons of ml_type * global_reference * ml_ast list + | MLglob of GlobRef.t + | MLcons of ml_type * GlobRef.t * ml_ast list | MLtuple of ml_ast list | MLcase of ml_type * ml_ast * ml_branch array | MLfix of int * Id.t array * ml_ast array @@ -129,24 +128,24 @@ and ml_ast = | MLmagic of ml_ast and ml_pattern = - | Pcons of global_reference * ml_pattern list + | Pcons of GlobRef.t * ml_pattern list | Ptuple of ml_pattern list | Prel of int (** Cf. the idents in the branch. [Prel 1] is the last one. *) | Pwild - | Pusual of global_reference (** Shortcut for Pcons (r,[Prel n;...;Prel 1]) **) + | Pusual of GlobRef.t (** Shortcut for Pcons (r,[Prel n;...;Prel 1]) **) (*s ML declarations. *) type ml_decl = | Dind of MutInd.t * ml_ind - | Dtype of global_reference * Id.t list * ml_type - | Dterm of global_reference * ml_ast * ml_type - | Dfix of global_reference array * ml_ast array * ml_type array + | Dtype of GlobRef.t * Id.t list * ml_type + | Dterm of GlobRef.t * ml_ast * ml_type + | Dfix of GlobRef.t array * ml_ast array * ml_type array type ml_spec = | Sind of MutInd.t * ml_ind - | Stype of global_reference * Id.t list * ml_type option - | Sval of global_reference * ml_type + | Stype of GlobRef.t * Id.t list * ml_type option + | Sval of GlobRef.t * ml_type type ml_specif = | Spec of ml_spec diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index e1e49d9269..ce920ad6a0 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -11,7 +11,6 @@ (*s Target language for extraction: a core ML called MiniML. *) open Names -open Globnames (* The [signature] type is used to know how many arguments a CIC object expects, and what these arguments will become in the ML @@ -26,7 +25,7 @@ open Globnames type kill_reason = | Ktype | Kprop - | Kimplicit of global_reference * int (* n-th arg of a cst or construct *) + | Kimplicit of GlobRef.t * int (* n-th arg of a cst or construct *) type sign = Keep | Kill of kill_reason @@ -39,7 +38,7 @@ type signature = sign list type ml_type = | Tarr of ml_type * ml_type - | Tglob of global_reference * ml_type list + | Tglob of GlobRef.t * ml_type list | Tvar of int | Tvar' of int (* same as Tvar, used to avoid clash *) | Tmeta of ml_meta (* used during ML type reconstruction *) @@ -60,7 +59,7 @@ type inductive_kind = | Singleton | Coinductive | Standard - | Record of global_reference option list (* None for anonymous field *) + | Record of GlobRef.t option list (* None for anonymous field *) (* A [ml_ind_packet] is the miniml counterpart of a [one_inductive_body]. If the inductive is logical ([ip_logical = false]), then all other fields @@ -118,8 +117,8 @@ and ml_ast = | MLapp of ml_ast * ml_ast list | MLlam of ml_ident * ml_ast | MLletin of ml_ident * ml_ast * ml_ast - | MLglob of global_reference - | MLcons of ml_type * global_reference * ml_ast list + | MLglob of GlobRef.t + | MLcons of ml_type * GlobRef.t * ml_ast list | MLtuple of ml_ast list | MLcase of ml_type * ml_ast * ml_branch array | MLfix of int * Id.t array * ml_ast array @@ -129,24 +128,24 @@ and ml_ast = | MLmagic of ml_ast and ml_pattern = - | Pcons of global_reference * ml_pattern list + | Pcons of GlobRef.t * ml_pattern list | Ptuple of ml_pattern list | Prel of int (** Cf. the idents in the branch. [Prel 1] is the last one. *) | Pwild - | Pusual of global_reference (** Shortcut for Pcons (r,[Prel n;...;Prel 1]) **) + | Pusual of GlobRef.t (** Shortcut for Pcons (r,[Prel n;...;Prel 1]) **) (*s ML declarations. *) type ml_decl = | Dind of MutInd.t * ml_ind - | Dtype of global_reference * Id.t list * ml_type - | Dterm of global_reference * ml_ast * ml_type - | Dfix of global_reference array * ml_ast array * ml_type array + | Dtype of GlobRef.t * Id.t list * ml_type + | Dterm of GlobRef.t * ml_ast * ml_type + | Dfix of GlobRef.t array * ml_ast array * ml_type array type ml_spec = | Sind of MutInd.t * ml_ind - | Stype of global_reference * Id.t list * ml_type option - | Sval of global_reference * ml_type + | Stype of GlobRef.t * Id.t list * ml_type option + | Sval of GlobRef.t * ml_type type ml_specif = | Spec of ml_spec diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 0656d487ad..9f5c1f1a17 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -59,7 +59,7 @@ let rec eq_ml_type t1 t2 = match t1, t2 with | Tarr (tl1, tr1), Tarr (tl2, tr2) -> eq_ml_type tl1 tl2 && eq_ml_type tr1 tr2 | Tglob (gr1, t1), Tglob (gr2, t2) -> - eq_gr gr1 gr2 && List.equal eq_ml_type t1 t2 + GlobRef.equal gr1 gr2 && List.equal eq_ml_type t1 t2 | Tvar i1, Tvar i2 -> Int.equal i1 i2 | Tvar' i1, Tvar' i2 -> Int.equal i1 i2 | Tmeta m1, Tmeta m2 -> eq_ml_meta m1 m2 @@ -120,7 +120,7 @@ let rec mgu = function | None -> m.contents <- Some t) | Tarr(a, b), Tarr(a', b') -> mgu (a, a'); mgu (b, b') - | Tglob (r,l), Tglob (r',l') when Globnames.eq_gr r r' -> + | Tglob (r,l), Tglob (r',l') when GlobRef.equal r r' -> List.iter mgu (List.combine l l') | Tdummy _, Tdummy _ -> () | Tvar i, Tvar j when Int.equal i j -> () @@ -270,7 +270,7 @@ let rec var2var' = function | Tglob (r,l) -> Tglob (r, List.map var2var' l) | a -> a -type abbrev_map = global_reference -> ml_type option +type abbrev_map = GlobRef.t -> ml_type option (*s Delta-reduction of type constants everywhere in a ML type [t]. [env] is a function of type [ml_type_env]. *) @@ -381,9 +381,9 @@ let rec eq_ml_ast t1 t2 = match t1, t2 with eq_ml_ident na1 na2 && eq_ml_ast t1 t2 | MLletin (na1, c1, t1), MLletin (na2, c2, t2) -> eq_ml_ident na1 na2 && eq_ml_ast c1 c2 && eq_ml_ast t1 t2 -| MLglob gr1, MLglob gr2 -> eq_gr gr1 gr2 +| MLglob gr1, MLglob gr2 -> GlobRef.equal gr1 gr2 | MLcons (t1, gr1, c1), MLcons (t2, gr2, c2) -> - eq_ml_type t1 t2 && eq_gr gr1 gr2 && List.equal eq_ml_ast c1 c2 + eq_ml_type t1 t2 && GlobRef.equal gr1 gr2 && List.equal eq_ml_ast c1 c2 | MLtuple t1, MLtuple t2 -> List.equal eq_ml_ast t1 t2 | MLcase (t1, c1, p1), MLcase (t2, c2, p2) -> @@ -398,13 +398,13 @@ let rec eq_ml_ast t1 t2 = match t1, t2 with and eq_ml_pattern p1 p2 = match p1, p2 with | Pcons (gr1, p1), Pcons (gr2, p2) -> - eq_gr gr1 gr2 && List.equal eq_ml_pattern p1 p2 + GlobRef.equal gr1 gr2 && List.equal eq_ml_pattern p1 p2 | Ptuple p1, Ptuple p2 -> List.equal eq_ml_pattern p1 p2 | Prel i1, Prel i2 -> Int.equal i1 i2 | Pwild, Pwild -> true -| Pusual gr1, Pusual gr2 -> eq_gr gr1 gr2 +| Pusual gr1, Pusual gr2 -> GlobRef.equal gr1 gr2 | _ -> false and eq_ml_branch (id1, p1, t1) (id2, p2, t2) = @@ -541,24 +541,24 @@ let dump_unused_vars a = | MLcase (t,e,br) -> let e' = ren env e in - let br' = Array.smartmap (ren_branch env) br in + let br' = Array.Smart.map (ren_branch env) br in if e' == e && br' == br then a else MLcase (t,e',br') | MLfix (i,ids,v) -> let env' = List.init (Array.length ids) (fun _ -> ref false) @ env in - let v' = Array.smartmap (ren env') v in + let v' = Array.Smart.map (ren env') v in if v' == v then a else MLfix (i,ids,v') | MLapp (b,l) -> - let b' = ren env b and l' = List.smartmap (ren env) l in + let b' = ren env b and l' = List.Smart.map (ren env) l in if b' == b && l' == l then a else MLapp (b',l') | MLcons(t,r,l) -> - let l' = List.smartmap (ren env) l in + let l' = List.Smart.map (ren env) l in if l' == l then a else MLcons (t,r,l') | MLtuple l -> - let l' = List.smartmap (ren env) l in + let l' = List.Smart.map (ren env) l in if l' == l then a else MLtuple l' | MLmagic b -> @@ -984,7 +984,7 @@ let rec iota_red i lift br ((typ,r,a) as cons) = if i >= Array.length br then raise Impossible; let (ids,p,c) = br.(i) in match p with - | Pusual r' | Pcons (r',_) when not (Globnames.eq_gr r' r) -> iota_red (i+1) lift br cons + | Pusual r' | Pcons (r',_) when not (GlobRef.equal r' r) -> iota_red (i+1) lift br cons | Pusual r' -> let c = named_lams (List.rev ids) c in let c = ast_lift lift c diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli index 55a1ee893e..d23fdb3d53 100644 --- a/plugins/extraction/mlutil.mli +++ b/plugins/extraction/mlutil.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Globnames open Miniml open Table @@ -59,7 +58,7 @@ val type_recomp : ml_type list * ml_type -> ml_type val var2var' : ml_type -> ml_type -type abbrev_map = global_reference -> ml_type option +type abbrev_map = GlobRef.t -> ml_type option val type_expand : abbrev_map -> ml_type -> ml_type val type_simpl : ml_type -> ml_type @@ -117,7 +116,7 @@ val dump_unused_vars : ml_ast -> ml_ast val normalize : ml_ast -> ml_ast val optimize_fix : ml_ast -> ml_ast -val inline : global_reference -> ml_ast -> bool +val inline : GlobRef.t -> ml_ast -> bool val is_basic_pattern : ml_pattern -> bool val has_deep_pattern : ml_branch array -> bool diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index f33a59edf9..b398bc07a0 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -76,7 +76,7 @@ let struct_iter do_decl do_spec do_mp s = (*s Apply some fonctions upon all references in [ml_type], [ml_ast], [ml_decl], [ml_spec] and [ml_structure]. *) -type do_ref = global_reference -> unit +type do_ref = GlobRef.t -> unit let record_iter_references do_term = function | Record l -> List.iter (Option.iter do_term) l diff --git a/plugins/extraction/modutil.mli b/plugins/extraction/modutil.mli index 6a81f27054..f45773f095 100644 --- a/plugins/extraction/modutil.mli +++ b/plugins/extraction/modutil.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Globnames open Miniml (*s Functions upon ML modules. *) @@ -17,7 +16,7 @@ open Miniml val struct_ast_search : (ml_ast -> bool) -> ml_structure -> bool val struct_type_search : (ml_type -> bool) -> ml_structure -> bool -type do_ref = global_reference -> unit +type do_ref = GlobRef.t -> unit val type_iter_references : do_ref -> ml_type -> unit val ast_iter_references : do_ref -> do_ref -> do_ref -> ml_ast -> unit @@ -30,7 +29,7 @@ val mtyp_of_mexpr : ml_module_expr -> ml_module_type val msid_of_mt : ml_module_type -> ModPath.t -val get_decl_in_structure : global_reference -> ml_structure -> ml_decl +val get_decl_in_structure : GlobRef.t -> ml_structure -> ml_decl (* Some transformations of ML terms. [optimize_struct] simplify all beta redexes (when the argument does not occur, it is just @@ -39,5 +38,5 @@ val get_decl_in_structure : global_reference -> ml_structure -> ml_decl optimizations. The first argument is the list of objects we want to appear. *) -val optimize_struct : global_reference list * ModPath.t list -> +val optimize_struct : GlobRef.t list * ModPath.t list -> ml_structure -> ml_structure diff --git a/plugins/extraction/plugin_base.dune b/plugins/extraction/plugin_base.dune new file mode 100644 index 0000000000..037b0d5053 --- /dev/null +++ b/plugins/extraction/plugin_base.dune @@ -0,0 +1,5 @@ +(library + (name extraction_plugin) + (public_name coq.plugins.extraction) + (synopsis "Coq's extraction plugin") + (libraries num coq.plugins.ltac)) diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 54c6d9d729..f6eea3c5c4 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -22,16 +22,11 @@ open Util open Pp open Miniml -[@@@ocaml.warning "-3"] (* String.capitalize_ascii since 4.03.0 GPR#124 *) -let capitalize = String.capitalize -[@@@ocaml.warning "+3"] - - (** Sets and maps for [global_reference] that use the "user" [kernel_name] instead of the canonical one *) -module Refmap' = Refmap_env -module Refset' = Refset_env +module Refmap' = GlobRef.Map_env +module Refset' = GlobRef.Set_env (*S Utilities about [module_path] and [kernel_names] and [global_reference] *) @@ -41,16 +36,16 @@ let occur_kn_in_ref kn = function | ConstRef _ | VarRef _ -> false let repr_of_r = function - | ConstRef kn -> Constant.repr3 kn + | ConstRef kn -> Constant.repr2 kn | IndRef (kn,_) - | ConstructRef ((kn,_),_) -> MutInd.repr3 kn + | ConstructRef ((kn,_),_) -> MutInd.repr2 kn | VarRef v -> KerName.repr (Lib.make_kn v) let modpath_of_r r = - let mp,_,_ = repr_of_r r in mp + let mp,_ = repr_of_r r in mp let label_of_r r = - let _,_,l = repr_of_r r in l + let _,l = repr_of_r r in l let rec base_mp = function | MPdot (mp,l) -> base_mp mp @@ -61,7 +56,7 @@ let is_modfile = function | _ -> false let raw_string_of_modfile = function - | MPfile f -> capitalize (Id.to_string (List.hd (DirPath.repr f))) + | MPfile f -> String.capitalize_ascii (Id.to_string (List.hd (DirPath.repr f))) | _ -> assert false let is_toplevel mp = @@ -100,7 +95,7 @@ let rec parse_labels2 ll mp1 = function let labels_of_ref r = let mp_top = Lib.current_mp () in - let mp,_,l = repr_of_r r in + let mp,l = repr_of_r r in parse_labels2 [l] mp_top mp @@ -194,7 +189,7 @@ let init_recursors () = recursors := KNset.empty let add_recursors env ind = let kn = MutInd.canonical ind in let mk_kn id = - KerName.make (KerName.modpath kn) DirPath.empty (Label.of_id id) + KerName.make (KerName.modpath kn) (Label.of_id id) in let mib = Environ.lookup_mind ind env in Array.iter @@ -213,12 +208,12 @@ let is_recursor = function (* NB: here, working modulo name equivalence is ok *) -let projs = ref (Refmap.empty : (inductive*int) Refmap.t) -let init_projs () = projs := Refmap.empty -let add_projection n kn ip = projs := Refmap.add (ConstRef kn) (ip,n) !projs -let is_projection r = Refmap.mem r !projs -let projection_arity r = snd (Refmap.find r !projs) -let projection_info r = Refmap.find r !projs +let projs = ref (GlobRef.Map.empty : (inductive*int) GlobRef.Map.t) +let init_projs () = projs := GlobRef.Map.empty +let add_projection n kn ip = projs := GlobRef.Map.add (ConstRef kn) (ip,n) !projs +let is_projection r = GlobRef.Map.mem r !projs +let projection_arity r = snd (GlobRef.Map.find r !projs) +let projection_info r = GlobRef.Map.find r !projs (*s Table of used axioms *) @@ -292,7 +287,7 @@ let safe_pr_long_global r = try Printer.pr_global r with Not_found -> match r with | ConstRef kn -> - let mp,_,l = Constant.repr3 kn in + let mp,l = Constant.repr2 kn in str ((ModPath.to_string mp)^"."^(Label.to_string l)) | _ -> assert false @@ -451,7 +446,7 @@ let error_MPfile_as_mod mp b = let argnames_of_global r = let env = Global.env () in - let typ, _ = Global.type_of_global_in_context env r in + let typ, _ = Typeops.type_of_global_in_context env r in let rels,_ = decompose_prod (Reduction.whd_all env typ) in List.rev_map fst rels @@ -652,14 +647,13 @@ let add_inline_entries b l = (* Registration of operations for rollback. *) -let inline_extraction : bool * global_reference list -> obj = +let inline_extraction : bool * GlobRef.t list -> obj = declare_object {(default_object "Extraction Inline") with cache_function = (fun (_,(b,l)) -> add_inline_entries b l); load_function = (fun _ (_,(b,l)) -> add_inline_entries b l); classify_function = (fun o -> Substitute o); - discharge_function = - (fun (_,(b,l)) -> Some (b, List.map pop_global_reference l)); + discharge_function = (fun (_,x) -> Some x); subst_function = (fun (s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l))) } @@ -736,7 +730,7 @@ let add_implicits r l = (* Registration of operations for rollback. *) -let implicit_extraction : global_reference * int_or_id list -> obj = +let implicit_extraction : GlobRef.t * int_or_id list -> obj = declare_object {(default_object "Extraction Implicit") with cache_function = (fun (_,(r,l)) -> add_implicits r l); @@ -784,7 +778,7 @@ let file_of_modfile mp = let add_blacklist_entries l = blacklist_table := - List.fold_right (fun s -> Id.Set.add (Id.of_string (capitalize s))) + List.fold_right (fun s -> Id.Set.add (Id.of_string (String.capitalize_ascii s))) l !blacklist_table (* Registration of operations for rollback. *) @@ -857,7 +851,7 @@ let find_custom_match pv = (* Registration of operations for rollback. *) -let in_customs : global_reference * string list * string -> obj = +let in_customs : GlobRef.t * string list * string -> obj = declare_object {(default_object "ML extractions") with cache_function = (fun (_,(r,ids,s)) -> add_custom r ids s); @@ -867,7 +861,7 @@ let in_customs : global_reference * string list * string -> obj = (fun (s,(r,ids,str)) -> (fst (subst_global s r), ids, str)) } -let in_custom_matchs : global_reference * string -> obj = +let in_custom_matchs : GlobRef.t * string -> obj = declare_object {(default_object "ML extractions custom matchs") with cache_function = (fun (_,(r,s)) -> add_custom_match r s); @@ -884,7 +878,7 @@ let extract_constant_inline inline r ids s = match g with | ConstRef kn -> let env = Global.env () in - let typ, _ = Global.type_of_global_in_context env (ConstRef kn) in + let typ, _ = Typeops.type_of_global_in_context env (ConstRef kn) in let typ = Reduction.whd_all env typ in if Reduction.is_arity env typ then begin diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index 906dfd96ec..acc1bfee8a 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -10,31 +10,30 @@ open Names open Libnames -open Globnames open Miniml open Declarations -module Refset' : CSig.SetS with type elt = global_reference -module Refmap' : CSig.MapS with type key = global_reference +module Refset' : CSig.SetS with type elt = GlobRef.t +module Refmap' : CSig.MapS with type key = GlobRef.t -val safe_basename_of_global : global_reference -> Id.t +val safe_basename_of_global : GlobRef.t -> Id.t (*s Warning and Error messages. *) val warning_axioms : unit -> unit val warning_opaques : bool -> unit -val warning_ambiguous_name : ?loc:Loc.t -> qualid * ModPath.t * global_reference -> unit +val warning_ambiguous_name : ?loc:Loc.t -> qualid * ModPath.t * GlobRef.t -> unit val warning_id : string -> unit -val error_axiom_scheme : global_reference -> int -> 'a -val error_constant : global_reference -> 'a -val error_inductive : global_reference -> 'a +val error_axiom_scheme : GlobRef.t -> int -> 'a +val error_constant : GlobRef.t -> 'a +val error_inductive : GlobRef.t -> 'a val error_nb_cons : unit -> 'a val error_module_clash : ModPath.t -> ModPath.t -> 'a val error_no_module_expr : ModPath.t -> 'a -val error_singleton_become_prop : Id.t -> global_reference option -> 'a +val error_singleton_become_prop : Id.t -> GlobRef.t option -> 'a val error_unknown_module : qualid -> 'a val error_scheme : unit -> 'a -val error_not_visible : global_reference -> 'a +val error_not_visible : GlobRef.t -> 'a val error_MPfile_as_mod : ModPath.t -> bool -> 'a val check_inside_module : unit -> unit val check_inside_section : unit -> unit @@ -44,12 +43,12 @@ val err_or_warn_remaining_implicit : kill_reason -> unit val info_file : string -> unit -(*s utilities about [module_path] and [kernel_names] and [global_reference] *) +(*s utilities about [module_path] and [kernel_names] and [GlobRef.t] *) -val occur_kn_in_ref : MutInd.t -> global_reference -> bool -val repr_of_r : global_reference -> ModPath.t * DirPath.t * Label.t -val modpath_of_r : global_reference -> ModPath.t -val label_of_r : global_reference -> Label.t +val occur_kn_in_ref : MutInd.t -> GlobRef.t -> bool +val repr_of_r : GlobRef.t -> ModPath.t * Label.t +val modpath_of_r : GlobRef.t -> ModPath.t +val label_of_r : GlobRef.t -> Label.t val base_mp : ModPath.t -> ModPath.t val is_modfile : ModPath.t -> bool val string_of_modfile : ModPath.t -> string @@ -61,7 +60,7 @@ val prefixes_mp : ModPath.t -> MPset.t val common_prefix_from_list : ModPath.t -> ModPath.t list -> ModPath.t option val get_nth_label_mp : int -> ModPath.t -> Label.t -val labels_of_ref : global_reference -> ModPath.t * Label.t list +val labels_of_ref : GlobRef.t -> ModPath.t * Label.t list (*s Some table-related operations *) @@ -83,27 +82,27 @@ val add_ind : MutInd.t -> mutual_inductive_body -> ml_ind -> unit val lookup_ind : MutInd.t -> mutual_inductive_body -> ml_ind option val add_inductive_kind : MutInd.t -> inductive_kind -> unit -val is_coinductive : global_reference -> bool +val is_coinductive : GlobRef.t -> bool val is_coinductive_type : ml_type -> bool (* What are the fields of a record (empty for a non-record) *) val get_record_fields : - global_reference -> global_reference option list -val record_fields_of_type : ml_type -> global_reference option list + GlobRef.t -> GlobRef.t option list +val record_fields_of_type : ml_type -> GlobRef.t option list val add_recursors : Environ.env -> MutInd.t -> unit -val is_recursor : global_reference -> bool +val is_recursor : GlobRef.t -> bool val add_projection : int -> Constant.t -> inductive -> unit -val is_projection : global_reference -> bool -val projection_arity : global_reference -> int -val projection_info : global_reference -> inductive * int (* arity *) +val is_projection : GlobRef.t -> bool +val projection_arity : GlobRef.t -> int +val projection_info : GlobRef.t -> inductive * int (* arity *) -val add_info_axiom : global_reference -> unit -val remove_info_axiom : global_reference -> unit -val add_log_axiom : global_reference -> unit +val add_info_axiom : GlobRef.t -> unit +val remove_info_axiom : GlobRef.t -> unit +val add_log_axiom : GlobRef.t -> unit -val add_opaque : global_reference -> unit -val remove_opaque : global_reference -> unit +val add_opaque : GlobRef.t -> unit +val remove_opaque : GlobRef.t -> unit val reset_tables : unit -> unit @@ -172,22 +171,22 @@ val is_extrcompute : unit -> bool (*s Table for custom inlining *) -val to_inline : global_reference -> bool -val to_keep : global_reference -> bool +val to_inline : GlobRef.t -> bool +val to_keep : GlobRef.t -> bool (*s Table for implicits arguments *) -val implicits_of_global : global_reference -> Int.Set.t +val implicits_of_global : GlobRef.t -> Int.Set.t (*s Table for user-given custom ML extractions. *) (* UGLY HACK: registration of a function defined in [extraction.ml] *) val type_scheme_nb_args_hook : (Environ.env -> Constr.t -> int) Hook.t -val is_custom : global_reference -> bool -val is_inline_custom : global_reference -> bool -val find_custom : global_reference -> string -val find_type_custom : global_reference -> string list * string +val is_custom : GlobRef.t -> bool +val is_inline_custom : GlobRef.t -> bool +val find_custom : GlobRef.t -> string +val find_type_custom : GlobRef.t -> string list * string val is_custom_match : ml_branch array -> bool val find_custom_match : ml_branch array -> string @@ -195,17 +194,17 @@ val find_custom_match : ml_branch array -> string (*s Extraction commands. *) val extraction_language : lang -> unit -val extraction_inline : bool -> reference list -> unit +val extraction_inline : bool -> qualid list -> unit val print_extraction_inline : unit -> Pp.t val reset_extraction_inline : unit -> unit val extract_constant_inline : - bool -> reference -> string list -> string -> unit + bool -> qualid -> string list -> string -> unit val extract_inductive : - reference -> string -> string list -> string option -> unit + qualid -> string -> string list -> string option -> unit type int_or_id = ArgInt of int | ArgId of Id.t -val extraction_implicit : reference -> int_or_id list -> unit +val extraction_implicit : qualid -> int_or_id list -> unit (*s Table of blacklisted filenames *) diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 047fc9fbfd..a60a966cec 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -211,7 +211,7 @@ type left_pattern= | Lexists of pinductive | LA of constr*left_arrow_pattern -type t={id:global_reference; +type t={id:GlobRef.t; constr:constr; pat:(left_pattern,right_pattern) sum; atoms:atoms} diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli index 2962d9230d..e2c6f1c4b1 100644 --- a/plugins/firstorder/formula.mli +++ b/plugins/firstorder/formula.mli @@ -8,9 +8,9 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Names open Constr open EConstr -open Globnames val qflag : bool ref @@ -35,7 +35,7 @@ type atoms = {positive:constr list;negative:constr list} type side = Hyp | Concl | Hint -val dummy_id: global_reference +val dummy_id: GlobRef.t val build_atoms : Environ.env -> Evd.evar_map -> counter -> side -> constr -> bool * atoms @@ -65,13 +65,13 @@ type left_pattern= | Lexists of pinductive | LA of constr*left_arrow_pattern -type t={id: global_reference; +type t={id: GlobRef.t; constr: constr; pat: (left_pattern,right_pattern) sum; atoms: atoms} (*exception Is_atom of constr*) -val build_formula : Environ.env -> Evd.evar_map -> side -> global_reference -> types -> +val build_formula : Environ.env -> Evd.evar_map -> side -> GlobRef.t -> types -> counter -> (t,types) sum diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.mlg index 30deb6f49a..a212d13453 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.mlg @@ -8,6 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ open Ltac_plugin open Formula @@ -17,15 +18,19 @@ open Goptions open Tacmach.New open Tacticals.New open Tacinterp -open Libnames open Stdarg open Tacarg +open Attributes open Pcoq.Prim +} + DECLARE PLUGIN "ground_plugin" (* declaring search depth as a global option *) +{ + let ground_depth=ref 3 let _= @@ -61,28 +66,28 @@ let default_intuition_tac = 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.tag (entry, [])) + Tacexpr.TacML (CAst.make (entry, [])) let (set_default_solver, default_solver, print_default_solver) = Tactic_option.declare_tactic_option ~default:default_intuition_tac "Firstorder default solver" -VERNAC COMMAND FUNCTIONAL EXTEND Firstorder_Set_Solver CLASSIFIED AS SIDEFF -| [ "Set" "Firstorder" "Solver" tactic(t) ] -> [ - fun ~atts ~st -> let open Vernacinterp in +} + +VERNAC COMMAND EXTEND Firstorder_Set_Solver CLASSIFIED AS SIDEFF +| #[ locality; ] [ "Set" "Firstorder" "Solver" tactic(t) ] -> { set_default_solver - (Locality.make_section_locality atts.locality) - (Tacintern.glob_tactic t); - st - ] + (Locality.make_section_locality locality) + (Tacintern.glob_tactic t) + } END VERNAC COMMAND EXTEND Firstorder_Print_Solver CLASSIFIED AS QUERY -| [ "Print" "Firstorder" "Solver" ] -> [ +| [ "Print" "Firstorder" "Solver" ] -> { Feedback.msg_info - (Pp.(++) (Pp.str"Firstorder solver tactic is ") (print_default_solver ())) ] + (Pp.(++) (Pp.str"Firstorder solver tactic is ") (print_default_solver ())) } END -let fail_solver=tclFAIL 0 (Pp.str "GTauto failed") +{ let gen_ground_tac flag taco ids bases = let backup= !qflag in @@ -110,11 +115,11 @@ let gen_ground_tac flag taco ids bases = (* special for compatibility with Intuition -let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str +let constant str = Coqlib.get_constr str let defined_connectives=lazy - [[],EvalConstRef (destConst (constant "not")); - [],EvalConstRef (destConst (constant "iff"))] + [[],EvalConstRef (destConst (constant "core.not.type")); + [],EvalConstRef (destConst (constant "core.iff.type"))] let normalize_evaluables= onAllHypsAndConcl @@ -124,10 +129,9 @@ let normalize_evaluables= unfold_in_hyp (Lazy.force defined_connectives) (Tacexpr.InHypType id)) *) -open Genarg open Ppconstr open Printer -let pr_firstorder_using_raw _ _ _ = Pptactic.pr_auto_using pr_reference +let pr_firstorder_using_raw _ _ _ = Pptactic.pr_auto_using pr_qualid 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 @@ -135,34 +139,33 @@ 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 - GLOB_TYPED AS reference_list - GLOB_PRINTED BY pr_firstorder_using_glob -| [ "using" reference(a) ] -> [ [a] ] -| [ "using" reference(a) "," ne_reference_list_sep(l,",") ] -> [ a::l ] -| [ "using" reference(a) reference(b) reference_list(l) ] -> [ + TYPED AS reference list + PRINTED BY { pr_firstorder_using_typed } + RAW_PRINTED BY { pr_firstorder_using_raw } + GLOB_PRINTED BY { pr_firstorder_using_glob } +| [ "using" reference(a) ] -> { [a] } +| [ "using" reference(a) "," ne_reference_list_sep(l,",") ] -> { a::l } +| [ "using" reference(a) reference(b) reference_list(l) ] -> { warn_deprecated_syntax (); a::b::l - ] -| [ ] -> [ [] ] + } +| [ ] -> { [] } END TACTIC EXTEND firstorder - [ "firstorder" tactic_opt(t) firstorder_using(l) ] -> - [ gen_ground_tac true (Option.map (tactic_of_value ist) t) l [] ] +| [ "firstorder" tactic_opt(t) firstorder_using(l) ] -> + { gen_ground_tac true (Option.map (tactic_of_value ist) t) l [] } | [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] -> - [ gen_ground_tac true (Option.map (tactic_of_value ist) t) [] l ] + { gen_ground_tac true (Option.map (tactic_of_value ist) t) [] l } | [ "firstorder" tactic_opt(t) firstorder_using(l) "with" ne_preident_list(l') ] -> - [ gen_ground_tac true (Option.map (tactic_of_value ist) t) l l' ] + { gen_ground_tac true (Option.map (tactic_of_value ist) t) l l' } END TACTIC EXTEND gintuition - [ "gintuition" tactic_opt(t) ] -> - [ gen_ground_tac false (Option.map (tactic_of_value ist) t) [] [] ] +| [ "gintuition" tactic_opt(t) ] -> + { gen_ground_tac false (Option.map (tactic_of_value ist) t) [] [] } END diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 4e3ba57308..6a80525200 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -13,23 +13,21 @@ open Formula open Sequent open Rules open Instances -open Constr open Tacmach.New open Tacticals.New +open Globnames let update_flags ()= - let predref=ref Names.Cpred.empty in - let f coe= - try - let kn= fst (destConst (Classops.get_coercion_value coe)) in - predref:=Names.Cpred.add kn !predref - with DestKO -> () + let open TransparentState in + let f accu coe = match coe.Classops.coe_value with + | ConstRef kn -> { accu with tr_cst = Names.Cpred.remove kn accu.tr_cst } + | _ -> accu in - List.iter f (Classops.coercions ()); + let flags = List.fold_left f TransparentState.full (Classops.coercions ()) in red_flags:= CClosure.RedFlags.red_add_transparent CClosure.betaiotazeta - (Names.Id.Pred.full,Names.Cpred.complement !predref) + flags let ground_tac solver startseq = Proofview.Goal.enter begin fun gl -> diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index e8c0b927dc..286021d68e 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -22,7 +22,6 @@ open Reductionops open Formula open Sequent open Names -open Misctypes open Context.Rel.Declaration let compare_instance inst1 inst2= @@ -39,11 +38,11 @@ let compare_gr id1 id2 = if id1==id2 then 0 else if id1==dummy_id then 1 else if id2==dummy_id then -1 - else Globnames.RefOrdered.compare id1 id2 + else GlobRef.Ordered.compare id1 id2 module OrderedInstance= struct - type t=instance * Globnames.global_reference + type t=instance * GlobRef.t let compare (inst1,id1) (inst2,id2)= (compare_instance =? compare_gr) inst2 inst1 id2 id1 (* we want a __decreasing__ total order *) @@ -184,12 +183,12 @@ let right_instance_tac inst continue seq= [introf; Proofview.Goal.enter begin fun gl -> let id0 = List.nth (pf_ids_of_hyps gl) 0 in - split (ImplicitBindings [mkVar id0]) + split (Tactypes.ImplicitBindings [mkVar id0]) end; tclSOLVE [wrap 0 true continue (deepen seq)]]; tclTRY assumption] | Real ((0,t),_) -> - (tclTHEN (split (ImplicitBindings [t])) + (tclTHEN (split (Tactypes.ImplicitBindings [t])) (tclSOLVE [wrap 0 true continue (deepen seq)])) | Real ((m,t),_) -> tclFAIL 0 (Pp.str "not implemented ... yet") diff --git a/plugins/firstorder/instances.mli b/plugins/firstorder/instances.mli index 61786ffdc9..9f9ade3aab 100644 --- a/plugins/firstorder/instances.mli +++ b/plugins/firstorder/instances.mli @@ -8,13 +8,13 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Globnames +open Names open Rules val collect_quantified : Evd.evar_map -> Sequent.t -> Formula.t list * Sequent.t val give_instances : Evd.evar_map -> Formula.t list -> Sequent.t -> - (Unify.instance * global_reference) list + (Unify.instance * GlobRef.t) list val quantified_tac : Formula.t list -> seqtac with_backtracking diff --git a/plugins/firstorder/plugin_base.dune b/plugins/firstorder/plugin_base.dune new file mode 100644 index 0000000000..d88daa23fc --- /dev/null +++ b/plugins/firstorder/plugin_base.dune @@ -0,0 +1,5 @@ +(library + (name ground_plugin) + (public_name coq.plugins.firstorder) + (synopsis "Coq's first order logic solver plugin") + (libraries coq.plugins.ltac)) diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index cfcd656191..832a98b7f8 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -21,7 +21,6 @@ open Termops open Formula open Sequent open Globnames -open Locus module NamedDecl = Context.Named.Declaration @@ -29,12 +28,12 @@ type tactic = unit Proofview.tactic type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic -type lseqtac= global_reference -> seqtac +type lseqtac= GlobRef.t -> seqtac type 'a with_backtracking = tactic -> 'a let wrap n b continue seq = - Proofview.Goal.nf_enter begin fun gls -> + Proofview.Goal.enter begin fun gls -> Control.check_for_interrupt (); let nc = Proofview.Goal.hyps gls in let env=pf_env gls in @@ -56,10 +55,6 @@ let wrap n b continue seq = continue seq2 end -let basename_of_global=function - VarRef id->id - | _->assert false - let clear_global=function VarRef id-> clear [id] | _->tclIDTAC @@ -230,20 +225,3 @@ let ll_forall_tac prod backtrack id continue seq= backtrack (* rules for instantiation with unification moved to instances.ml *) - -(* special for compatibility with old Intuition *) - -let constant str = Universes.constr_of_global - @@ Coqlib.coq_reference "User" ["Init";"Logic"] str - -let defined_connectives=lazy - [AllOccurrences,EvalConstRef (fst (Constr.destConst (constant "not"))); - AllOccurrences,EvalConstRef (fst (Constr.destConst (constant "iff")))] - -let normalize_evaluables= - Proofview.Goal.enter begin fun gl -> - unfold_in_concl (Lazy.force defined_connectives) <*> - tclMAP - (fun id -> unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly)) - (pf_ids_of_hyps gl) - end diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli index 859388b303..97bc992b26 100644 --- a/plugins/firstorder/rules.mli +++ b/plugins/firstorder/rules.mli @@ -11,21 +11,18 @@ open Names open Constr open EConstr -open Globnames type tactic = unit Proofview.tactic type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic -type lseqtac= global_reference -> seqtac +type lseqtac= GlobRef.t -> seqtac type 'a with_backtracking = tactic -> 'a val wrap : int -> bool -> seqtac -val basename_of_global: global_reference -> Id.t - -val clear_global: global_reference -> tactic +val clear_global: GlobRef.t -> tactic val axiom_tac : constr -> Sequent.t -> tactic @@ -41,7 +38,7 @@ val left_and_tac : pinductive -> lseqtac with_backtracking val left_or_tac : pinductive -> lseqtac with_backtracking -val left_false_tac : global_reference -> tactic +val left_false_tac : GlobRef.t -> tactic val ll_ind_tac : pinductive -> constr list -> lseqtac with_backtracking @@ -52,5 +49,3 @@ val forall_tac : seqtac with_backtracking val left_exists_tac : pinductive -> lseqtac with_backtracking val ll_forall_tac : types -> lseqtac with_backtracking - -val normalize_evaluables : tactic diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 2859917978..5958fe8203 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -8,13 +8,13 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open EConstr -open CErrors open Util +open Pp +open CErrors +open Names +open EConstr open Formula open Unify -open Globnames -open Pp let newcnt ()= let cnt=ref (-1) in @@ -56,13 +56,13 @@ struct (priority e1.pat) - (priority e2.pat) end -type h_item = global_reference * (int*Constr.t) option +type h_item = GlobRef.t * (int*Constr.t) option module Hitem= struct type t = h_item let compare (id1,co1) (id2,co2)= - let c = Globnames.RefOrdered.compare id1 id2 in + let c = GlobRef.Ordered.compare id1 id2 in if c = 0 then let cmp (i1, c1) (i2, c2) = let c = Int.compare i1 i2 in @@ -77,17 +77,17 @@ module CM=Map.Make(Constr) module History=Set.Make(Hitem) let cm_add sigma typ nam cm= - let typ = EConstr.to_constr sigma typ in + let typ = EConstr.to_constr ~abort_on_undefined_evars:false sigma typ in try let l=CM.find typ cm in CM.add typ (nam::l) cm with Not_found->CM.add typ [nam] cm let cm_remove sigma typ nam cm= - let typ = EConstr.to_constr sigma typ in + let typ = EConstr.to_constr ~abort_on_undefined_evars:false sigma typ in try let l=CM.find typ cm in - let l0=List.filter (fun id-> not (Globnames.eq_gr id nam)) l in + let l0=List.filter (fun id-> not (GlobRef.equal id nam)) l in match l0 with []->CM.remove typ cm | _ ->CM.add typ l0 cm @@ -97,7 +97,7 @@ module HP=Heap.Functional(OrderedFormula) type t= {redexes:HP.t; - context:(global_reference list) CM.t; + context:(GlobRef.t list) CM.t; latoms:constr list; gl:types; glatom:constr option; @@ -117,7 +117,7 @@ let lookup sigma item seq= let p (id2,o)= match o with None -> false - | Some (m2, t2)-> Globnames.eq_gr id id2 && m2>m && more_general sigma (m2, EConstr.of_constr t2) (m, EConstr.of_constr t) in + | Some (m2, t2)-> GlobRef.equal id id2 && m2>m && more_general sigma (m2, EConstr.of_constr t2) (m, EConstr.of_constr t) in History.exists p seq.history let add_formula env sigma side nam t seq = @@ -152,7 +152,7 @@ let re_add_formula_list sigma lf seq= redexes=List.fold_right HP.add lf seq.redexes; context=List.fold_right do_one lf seq.context} -let find_left sigma t seq=List.hd (CM.find (EConstr.to_constr sigma t) seq.context) +let find_left sigma t seq=List.hd (CM.find (EConstr.to_constr ~abort_on_undefined_evars:false sigma t) seq.context) (*let rev_left seq= try @@ -187,9 +187,9 @@ let empty_seq depth= let expand_constructor_hints = List.map_append (function - | IndRef ind -> + | GlobRef.IndRef ind -> List.init (Inductiveops.nconstructors ind) - (fun i -> ConstructRef (ind,i+1)) + (fun i -> GlobRef.ConstructRef (ind,i+1)) | gr -> [gr]) @@ -197,7 +197,7 @@ let extend_with_ref_list env sigma l seq = let l = expand_constructor_hints l in let f gr (seq, sigma) = let sigma, c = Evd.fresh_global env sigma gr in - let sigma, typ= Typing.type_of env sigma (EConstr.of_constr c) in + let sigma, typ= Typing.type_of env sigma c in (add_formula env sigma Hyp gr typ seq, sigma) in List.fold_right f l (seq, sigma) @@ -229,7 +229,9 @@ let extend_with_auto_hints env sigma l seq = let print_cmap map= let print_entry c l s= - let xc=Constrextern.extern_constr false (Global.env ()) Evd.empty (EConstr.of_constr c) in + let env = Global.env () in + let sigma = Evd.from_env env in + let xc=Constrextern.extern_constr false env sigma (EConstr.of_constr c) in str "| " ++ prlist Printer.pr_global l ++ str " : " ++ diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli index c4ed3e21fd..709b278ec4 100644 --- a/plugins/firstorder/sequent.mli +++ b/plugins/firstorder/sequent.mli @@ -8,26 +8,26 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Names open EConstr open Formula -open Globnames module CM: CSig.MapS with type key=Constr.t -type h_item = global_reference * (int*Constr.t) option +type h_item = GlobRef.t * (int*Constr.t) option module History: Set.S with type elt = h_item -val cm_add : Evd.evar_map -> constr -> global_reference -> global_reference list CM.t -> - global_reference list CM.t +val cm_add : Evd.evar_map -> constr -> GlobRef.t -> GlobRef.t list CM.t -> + GlobRef.t list CM.t -val cm_remove : Evd.evar_map -> constr -> global_reference -> global_reference list CM.t -> - global_reference list CM.t +val cm_remove : Evd.evar_map -> constr -> GlobRef.t -> GlobRef.t list CM.t -> + GlobRef.t list CM.t module HP: Heap.S with type elt=Formula.t type t = {redexes:HP.t; - context: global_reference list CM.t; + context: GlobRef.t list CM.t; latoms:constr list; gl:types; glatom:constr option; @@ -41,20 +41,20 @@ val record: h_item -> t -> t val lookup: Evd.evar_map -> h_item -> t -> bool -val add_formula : Environ.env -> Evd.evar_map -> side -> global_reference -> constr -> t -> t +val add_formula : Environ.env -> Evd.evar_map -> side -> GlobRef.t -> constr -> t -> t val re_add_formula_list : Evd.evar_map -> Formula.t list -> t -> t -val find_left : Evd.evar_map -> constr -> t -> global_reference +val find_left : Evd.evar_map -> constr -> t -> GlobRef.t val take_formula : Evd.evar_map -> t -> Formula.t * t val empty_seq : int -> t -val extend_with_ref_list : Environ.env -> Evd.evar_map -> global_reference list -> +val extend_with_ref_list : Environ.env -> Evd.evar_map -> GlobRef.t list -> t -> t * Evd.evar_map val extend_with_auto_hints : Environ.env -> Evd.evar_map -> Hints.hint_db_name list -> t -> t * Evd.evar_map -val print_cmap: global_reference list CM.t -> Pp.t +val print_cmap: GlobRef.t list CM.t -> Pp.t diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index b869c04a21..d63fe9d799 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -9,7 +9,7 @@ (************************************************************************) open Util -open Term +open Constr open EConstr open Vars open Termops @@ -56,12 +56,12 @@ let unif evd t1 t2= | Meta i,_ -> let t=subst_meta !sigma nt2 in if Int.Set.is_empty (free_rels evd t) && - not (dependent evd (EConstr.mkMeta i) t) then + not (occur_metavariable evd i t) then bind i t else raise (UFAIL(nt1,nt2)) | _,Meta i -> let t=subst_meta !sigma nt1 in if Int.Set.is_empty (free_rels evd t) && - not (dependent evd (EConstr.mkMeta i) t) then + not (occur_metavariable evd i t) then bind i t else raise (UFAIL(nt1,nt2)) | Cast(_,_,_),_->Queue.add (strip_outer_cast evd nt1,nt2) bige | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast evd nt2) bige diff --git a/plugins/fourier/Fourier.v b/plugins/fourier/Fourier.v deleted file mode 100644 index 07f32be8e6..0000000000 --- a/plugins/fourier/Fourier.v +++ /dev/null @@ -1,20 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* "Fourier's method to solve linear inequations/equations systems.".*) - -Require Export Field. -Require Export DiscrR. -Require Export Fourier_util. -Declare ML Module "fourier_plugin". - -Ltac fourier := abstract (compute [IZR IPR IPR_2] in *; fourierz; field; discrR). - -Ltac fourier_eq := apply Rge_antisym; fourier. diff --git a/plugins/fourier/Fourier_util.v b/plugins/fourier/Fourier_util.v deleted file mode 100644 index d3159698b1..0000000000 --- a/plugins/fourier/Fourier_util.v +++ /dev/null @@ -1,222 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Export Rbase. -Comments "Lemmas used by the tactic Fourier". - -Open Scope R_scope. - -Lemma Rfourier_lt : forall x1 y1 a:R, x1 < y1 -> 0 < a -> a * x1 < a * y1. -intros; apply Rmult_lt_compat_l; assumption. -Qed. - -Lemma Rfourier_le : forall x1 y1 a:R, x1 <= y1 -> 0 < a -> a * x1 <= a * y1. -red. -intros. -case H; auto with real. -Qed. - -Lemma Rfourier_lt_lt : - forall x1 y1 x2 y2 a:R, - x1 < y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. -intros x1 y1 x2 y2 a H H0 H1; try assumption. -apply Rplus_lt_compat. -try exact H. -apply Rfourier_lt. -try exact H0. -try exact H1. -Qed. - -Lemma Rfourier_lt_le : - forall x1 y1 x2 y2 a:R, - x1 < y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. -intros x1 y1 x2 y2 a H H0 H1; try assumption. -case H0; intros. -apply Rplus_lt_compat. -try exact H. -apply Rfourier_lt; auto with real. -rewrite H2. -rewrite (Rplus_comm y1 (a * y2)). -rewrite (Rplus_comm x1 (a * y2)). -apply Rplus_lt_compat_l. -try exact H. -Qed. - -Lemma Rfourier_le_lt : - forall x1 y1 x2 y2 a:R, - x1 <= y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. -intros x1 y1 x2 y2 a H H0 H1; try assumption. -case H; intros. -apply Rfourier_lt_le; auto with real. -rewrite H2. -apply Rplus_lt_compat_l. -apply Rfourier_lt; auto with real. -Qed. - -Lemma Rfourier_le_le : - forall x1 y1 x2 y2 a:R, - x1 <= y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 <= y1 + a * y2. -intros x1 y1 x2 y2 a H H0 H1; try assumption. -case H0; intros. -red. -left; try assumption. -apply Rfourier_le_lt; auto with real. -rewrite H2. -case H; intros. -red. -left; try assumption. -rewrite (Rplus_comm x1 (a * y2)). -rewrite (Rplus_comm y1 (a * y2)). -apply Rplus_lt_compat_l. -try exact H3. -rewrite H3. -red. -right; try assumption. -auto with real. -Qed. - -Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x. -intros x H; try assumption. -rewrite Rplus_comm. -apply Rle_lt_0_plus_1. -red; auto with real. -Qed. - -Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. -intros x y H H0; try assumption. -replace 0 with (x * 0). -apply Rmult_lt_compat_l; auto with real. -ring. -Qed. - -Lemma Rlt_zero_1 : 0 < 1. -exact Rlt_0_1. -Qed. - -Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x. -intros x H; try assumption. -case H; intros. -red. -left; try assumption. -apply Rlt_zero_pos_plus1; auto with real. -rewrite <- H0. -replace (1 + 0) with 1. -red; left. -exact Rlt_zero_1. -ring. -Qed. - -Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y. -intros x y H H0; try assumption. -case H; intros. -red; left. -apply Rlt_mult_inv_pos; auto with real. -rewrite <- H1. -red; right; ring. -Qed. - -Lemma Rle_zero_1 : 0 <= 1. -red; left. -exact Rlt_zero_1. -Qed. - -Lemma Rle_not_lt : forall n d:R, 0 <= n * / d -> ~ 0 < - n * / d. -intros n d H; red; intros H0; try exact H0. -generalize (Rgt_not_le 0 (n * / d)). -intros H1; elim H1; try assumption. -replace (n * / d) with (- - (n * / d)). -replace 0 with (- -0). -replace (- (n * / d)) with (- n * / d). -replace (-0) with 0. -red. -apply Ropp_gt_lt_contravar. -red. -exact H0. -ring. -ring. -ring. -ring. -Qed. - -Lemma Rnot_lt0 : forall x:R, ~ 0 < 0 * x. -intros x; try assumption. -replace (0 * x) with 0. -apply Rlt_irrefl. -ring. -Qed. - -Lemma Rlt_not_le_frac_opp : forall n d:R, 0 < n * / d -> ~ 0 <= - n * / d. -intros n d H; try assumption. -apply Rgt_not_le. -replace 0 with (-0). -replace (- n * / d) with (- (n * / d)). -apply Ropp_lt_gt_contravar. -try exact H. -ring. -ring. -Qed. - -Lemma Rnot_lt_lt : forall x y:R, ~ 0 < y - x -> ~ x < y. -unfold not; intros. -apply H. -apply Rplus_lt_reg_l with x. -replace (x + 0) with x. -replace (x + (y - x)) with y. -try exact H0. -ring. -ring. -Qed. - -Lemma Rnot_le_le : forall x y:R, ~ 0 <= y - x -> ~ x <= y. -unfold not; intros. -apply H. -case H0; intros. -left. -apply Rplus_lt_reg_l with x. -replace (x + 0) with x. -replace (x + (y - x)) with y. -try exact H1. -ring. -ring. -right. -rewrite H1; ring. -Qed. - -Lemma Rfourier_gt_to_lt : forall x y:R, y > x -> x < y. -unfold Rgt; intros; assumption. -Qed. - -Lemma Rfourier_ge_to_le : forall x y:R, y >= x -> x <= y. -intros x y; exact (Rge_le y x). -Qed. - -Lemma Rfourier_eqLR_to_le : forall x y:R, x = y -> x <= y. -exact Req_le. -Qed. - -Lemma Rfourier_eqRL_to_le : forall x y:R, y = x -> x <= y. -exact Req_le_sym. -Qed. - -Lemma Rfourier_not_ge_lt : forall x y:R, (x >= y -> False) -> x < y. -exact Rnot_ge_lt. -Qed. - -Lemma Rfourier_not_gt_le : forall x y:R, (x > y -> False) -> x <= y. -exact Rnot_gt_le. -Qed. - -Lemma Rfourier_not_le_gt : forall x y:R, (x <= y -> False) -> x > y. -exact Rnot_le_lt. -Qed. - -Lemma Rfourier_not_lt_ge : forall x y:R, (x < y -> False) -> x >= y. -exact Rnot_lt_ge. -Qed. diff --git a/plugins/fourier/fourier.ml b/plugins/fourier/fourier.ml deleted file mode 100644 index bee2b3b581..0000000000 --- a/plugins/fourier/fourier.ml +++ /dev/null @@ -1,204 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* Méthode d'élimination de Fourier *) -(* Référence: -Auteur(s) : Fourier, Jean-Baptiste-Joseph - -Titre(s) : Oeuvres de Fourier [Document électronique]. Tome second. Mémoires publiés dans divers recueils / publ. par les soins de M. Gaston Darboux,... - -Publication : Numérisation BnF de l'édition de Paris : Gauthier-Villars, 1890 - -Pages: 326-327 - -http://gallica.bnf.fr/ -*) - -(* Un peu de calcul sur les rationnels... -Les opérations rendent des rationnels normalisés, -i.e. le numérateur et le dénominateur sont premiers entre eux. -*) -type rational = {num:int; - den:int} -;; -let print_rational x = - print_int x.num; - print_string "/"; - print_int x.den -;; - -let rec pgcd x y = if y = 0 then x else pgcd y (x mod y);; - - -let r0 = {num=0;den=1};; -let r1 = {num=1;den=1};; - -let rnorm x = let x = (if x.den<0 then {num=(-x.num);den=(-x.den)} else x) in - if x.num=0 then r0 - else (let d=pgcd x.num x.den in - let d= (if d<0 then -d else d) in - {num=(x.num)/d;den=(x.den)/d});; - -let rop x = rnorm {num=(-x.num);den=x.den};; - -let rplus x y = rnorm {num=x.num*y.den + y.num*x.den;den=x.den*y.den};; - -let rminus x y = rnorm {num=x.num*y.den - y.num*x.den;den=x.den*y.den};; - -let rmult x y = rnorm {num=x.num*y.num;den=x.den*y.den};; - -let rinv x = rnorm {num=x.den;den=x.num};; - -let rdiv x y = rnorm {num=x.num*y.den;den=x.den*y.num};; - -let rinf x y = x.num*y.den < y.num*x.den;; -let rinfeq x y = x.num*y.den <= y.num*x.den;; - -(* {coef;hist;strict}, où coef=[c1; ...; cn; d], représente l'inéquation -c1x1+...+cnxn < d si strict=true, <= sinon, -hist donnant les coefficients (positifs) d'une combinaison linéaire qui permet d'obtenir l'inéquation à partir de celles du départ. -*) - -type ineq = {coef:rational list; - hist:rational list; - strict:bool};; - -let pop x l = l:=x::(!l);; - -(* sépare la liste d'inéquations s selon que leur premier coefficient est -négatif, nul ou positif. *) -let partitionne s = - let lpos=ref [] in - let lneg=ref [] in - let lnul=ref [] in - List.iter (fun ie -> match ie.coef with - [] -> raise (Failure "empty ineq") - |(c::r) -> if rinf c r0 - then pop ie lneg - else if rinf r0 c then pop ie lpos - else pop ie lnul) - s; - [!lneg;!lnul;!lpos] -;; -(* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!): -(add_hist [(equation 1, s1);...;(équation n, sn)]) -= -[{équation 1, [1;0;...;0], s1}; - {équation 2, [0;1;...;0], s2}; - ... - {équation n, [0;0;...;1], sn}] -*) -let add_hist le = - let n = List.length le in - let i = ref 0 in - List.map (fun (ie,s) -> - let h = ref [] in - for _k = 1 to (n - (!i) - 1) do pop r0 h; done; - pop r1 h; - for _k = 1 to !i do pop r0 h; done; - i:=!i+1; - {coef=ie;hist=(!h);strict=s}) - le -;; -(* additionne deux inéquations *) -let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef; - hist=List.map2 rplus ie1.hist ie2.hist; - strict=ie1.strict || ie2.strict} -;; -(* multiplication d'une inéquation par un rationnel (positif) *) -let ie_emult a ie = {coef=List.map (fun x -> rmult a x) ie.coef; - hist=List.map (fun x -> rmult a x) ie.hist; - strict= ie.strict} -;; -(* on enlève le premier coefficient *) -let ie_tl ie = {coef=List.tl ie.coef;hist=ie.hist;strict=ie.strict} -;; -(* le premier coefficient: "tête" de l'inéquation *) -let hd_coef ie = List.hd ie.coef -;; - -(* calcule toutes les combinaisons entre inéquations de tête négative et inéquations de tête positive qui annulent le premier coefficient. -*) -let deduce_add lneg lpos = - let res=ref [] in - List.iter (fun i1 -> - List.iter (fun i2 -> - let a = rop (hd_coef i1) in - let b = hd_coef i2 in - pop (ie_tl (ie_add (ie_emult b i1) - (ie_emult a i2))) res) - lpos) - lneg; - !res -;; -(* élimination de la première variable à partir d'une liste d'inéquations: -opération qu'on itère dans l'algorithme de Fourier. -*) -let deduce1 s = - match (partitionne s) with - [lneg;lnul;lpos] -> - let lnew = deduce_add lneg lpos in - (List.map ie_tl lnul)@lnew - |_->assert false -;; -(* algorithme de Fourier: on élimine successivement toutes les variables. -*) -let deduce lie = - let n = List.length (fst (List.hd lie)) in - let lie=ref (add_hist lie) in - for _i = 1 to n - 1 do - lie:= deduce1 !lie; - done; - !lie -;; - -(* donne [] si le système a des solutions, -sinon donne [c,s,lc] -où lc est la combinaison linéaire des inéquations de départ -qui donne 0 < c si s=true - ou 0 <= c sinon -cette inéquation étant absurde. -*) - -exception Contradiction of (rational * bool * rational list) list - -let unsolvable lie = - let lr = deduce lie in - let check = function - | {coef=[c];hist=lc;strict=s} -> - if (rinf c r0 && (not s)) || (rinfeq c r0 && s) - then raise (Contradiction [c,s,lc]) - |_->assert false - in - try List.iter check lr; [] - with Contradiction l -> l - -(* Exemples: - -let test1=[[r1;r1;r0],true;[rop r1;r1;r1],false;[r0;rop r1;rop r1],false];; -deduce test1;; -unsolvable test1;; - -let test2=[ -[r1;r1;r0;r0;r0],false; -[r0;r1;r1;r0;r0],false; -[r0;r0;r1;r1;r0],false; -[r0;r0;r0;r1;r1],false; -[r1;r0;r0;r0;r1],false; -[rop r1;rop r1;r0;r0;r0],false; -[r0;rop r1;rop r1;r0;r0],false; -[r0;r0;rop r1;rop r1;r0],false; -[r0;r0;r0;rop r1;rop r1],false; -[rop r1;r0;r0;r0;rop r1],false -];; -deduce test2;; -unsolvable test2;; - -*) diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml deleted file mode 100644 index b1c003de20..0000000000 --- a/plugins/fourier/fourierR.ml +++ /dev/null @@ -1,644 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - - - -(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients -des inéquations et équations sont entiers. En attendant la tactique Field. -*) - -open Constr -open Tactics -open Names -open Globnames -open Fourier -open Contradiction -open Proofview.Notations - -(****************************************************************************** -Opérations sur les combinaisons linéaires affines. -La partie homogène d'une combinaison linéaire est en fait une table de hash -qui donne le coefficient d'un terme du calcul des constructions, -qui est zéro si le terme n'y est pas. -*) - -module Constrhash = Hashtbl.Make(Constr) - -type flin = {fhom: rational Constrhash.t; - fcste:rational};; - -let flin_zero () = {fhom=Constrhash.create 50;fcste=r0};; - -let flin_coef f x = try Constrhash.find f.fhom x with Not_found -> r0;; - -let flin_add f x c = - let cx = flin_coef f x in - Constrhash.replace f.fhom x (rplus cx c); - f -;; -let flin_add_cste f c = - {fhom=f.fhom; - fcste=rplus f.fcste c} -;; - -let flin_one () = flin_add_cste (flin_zero()) r1;; - -let flin_plus f1 f2 = - let f3 = flin_zero() in - Constrhash.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; - Constrhash.iter (fun x c -> let _=flin_add f3 x c in ()) f2.fhom; - flin_add_cste (flin_add_cste f3 f1.fcste) f2.fcste; -;; - -let flin_minus f1 f2 = - let f3 = flin_zero() in - Constrhash.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; - Constrhash.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom; - flin_add_cste (flin_add_cste f3 f1.fcste) (rop f2.fcste); -;; -let flin_emult a f = - let f2 = flin_zero() in - Constrhash.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom; - flin_add_cste f2 (rmult a f.fcste); -;; - -(*****************************************************************************) - -type ineq = Rlt | Rle | Rgt | Rge - -let string_of_R_constant kn = - match Constant.repr3 kn with - | ModPath.MPfile dir, sec_dir, id when - sec_dir = DirPath.empty && - DirPath.to_string dir = "Coq.Reals.Rdefinitions" - -> Label.to_string id - | _ -> "constant_not_of_R" - -let rec string_of_R_constr c = - match Constr.kind c with - Cast (c,_,_) -> string_of_R_constr c - |Const (c,_) -> string_of_R_constant c - | _ -> "not_of_constant" - -exception NoRational - -let rec rational_of_constr c = - match Constr.kind c with - | Cast (c,_,_) -> (rational_of_constr c) - | App (c,args) -> - (match (string_of_R_constr c) with - | "Ropp" -> - rop (rational_of_constr args.(0)) - | "Rinv" -> - rinv (rational_of_constr args.(0)) - | "Rmult" -> - rmult (rational_of_constr args.(0)) - (rational_of_constr args.(1)) - | "Rdiv" -> - rdiv (rational_of_constr args.(0)) - (rational_of_constr args.(1)) - | "Rplus" -> - rplus (rational_of_constr args.(0)) - (rational_of_constr args.(1)) - | "Rminus" -> - rminus (rational_of_constr args.(0)) - (rational_of_constr args.(1)) - | _ -> raise NoRational) - | Const (kn,_) -> - (match (string_of_R_constant kn) with - "R1" -> r1 - |"R0" -> r0 - | _ -> raise NoRational) - | _ -> raise NoRational -;; - -exception NoLinear - -let rec flin_of_constr c = - try( - match Constr.kind c with - | Cast (c,_,_) -> (flin_of_constr c) - | App (c,args) -> - (match (string_of_R_constr c) with - "Ropp" -> - flin_emult (rop r1) (flin_of_constr args.(0)) - | "Rplus"-> - flin_plus (flin_of_constr args.(0)) - (flin_of_constr args.(1)) - | "Rminus"-> - flin_minus (flin_of_constr args.(0)) - (flin_of_constr args.(1)) - | "Rmult"-> - (try - let a = rational_of_constr args.(0) in - try - let b = rational_of_constr args.(1) in - flin_add_cste (flin_zero()) (rmult a b) - with NoRational -> - flin_add (flin_zero()) args.(1) a - with NoRational -> - flin_add (flin_zero()) args.(0) - (rational_of_constr args.(1))) - | "Rinv"-> - let a = rational_of_constr args.(0) in - flin_add_cste (flin_zero()) (rinv a) - | "Rdiv"-> - (let b = rational_of_constr args.(1) in - try - let a = rational_of_constr args.(0) in - flin_add_cste (flin_zero()) (rdiv a b) - with NoRational -> - flin_add (flin_zero()) args.(0) (rinv b)) - |_-> raise NoLinear) - | Const (c,_) -> - (match (string_of_R_constant c) with - "R1" -> flin_one () - |"R0" -> flin_zero () - |_-> raise NoLinear) - |_-> raise NoLinear) - with NoRational | NoLinear -> flin_add (flin_zero()) c r1 -;; - -let flin_to_alist f = - let res=ref [] in - Constrhash.iter (fun x c -> res:=(c,x)::(!res)) f; - !res -;; - -(* Représentation des hypothèses qui sont des inéquations ou des équations. -*) -type hineq={hname:constr; (* le nom de l'hypothèse *) - htype:string; (* Rlt, Rgt, Rle, Rge, eqTLR ou eqTRL *) - hleft:constr; - hright:constr; - hflin:flin; - hstrict:bool} -;; - -(* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0 -*) - -exception NoIneq - -let ineq1_of_constr (h,t) = - let h = EConstr.Unsafe.to_constr h in - let t = EConstr.Unsafe.to_constr t in - match (Constr.kind t) with - | App (f,args) -> - (match Constr.kind f with - | Const (c,_) when Array.length args = 2 -> - let t1= args.(0) in - let t2= args.(1) in - (match (string_of_R_constant c) with - |"Rlt" -> [{hname=h; - htype="Rlt"; - hleft=t1; - hright=t2; - hflin= flin_minus (flin_of_constr t1) - (flin_of_constr t2); - hstrict=true}] - |"Rgt" -> [{hname=h; - htype="Rgt"; - hleft=t2; - hright=t1; - hflin= flin_minus (flin_of_constr t2) - (flin_of_constr t1); - hstrict=true}] - |"Rle" -> [{hname=h; - htype="Rle"; - hleft=t1; - hright=t2; - hflin= flin_minus (flin_of_constr t1) - (flin_of_constr t2); - hstrict=false}] - |"Rge" -> [{hname=h; - htype="Rge"; - hleft=t2; - hright=t1; - hflin= flin_minus (flin_of_constr t2) - (flin_of_constr t1); - hstrict=false}] - |_-> raise NoIneq) - | Ind ((kn,i),_) -> - if not (eq_gr (IndRef(kn,i)) Coqlib.glob_eq) then raise NoIneq; - let t0= args.(0) in - let t1= args.(1) in - let t2= args.(2) in - (match (Constr.kind t0) with - | Const (c,_) -> - (match (string_of_R_constant c) with - | "R"-> - [{hname=h; - htype="eqTLR"; - hleft=t1; - hright=t2; - hflin= flin_minus (flin_of_constr t1) - (flin_of_constr t2); - hstrict=false}; - {hname=h; - htype="eqTRL"; - hleft=t2; - hright=t1; - hflin= flin_minus (flin_of_constr t2) - (flin_of_constr t1); - hstrict=false}] - |_-> raise NoIneq) - |_-> raise NoIneq) - |_-> raise NoIneq) - |_-> raise NoIneq -;; - -(* Applique la méthode de Fourier à une liste d'hypothèses (type hineq) -*) - -let fourier_lineq lineq1 = - let nvar=ref (-1) in - let hvar=Constrhash.create 50 in (* la table des variables des inéquations *) - List.iter (fun f -> - Constrhash.iter (fun x _ -> if not (Constrhash.mem hvar x) then begin - nvar:=(!nvar)+1; - Constrhash.add hvar x (!nvar) - end) - f.hflin.fhom) - lineq1; - let sys= List.map (fun h-> - let v=Array.make ((!nvar)+1) r0 in - Constrhash.iter (fun x c -> v.(Constrhash.find hvar x)<-c) - h.hflin.fhom; - ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict)) - lineq1 in - unsolvable sys -;; - -(*********************************************************************) -(* Defined constants *) - -let get = Lazy.force -let cget = get -let eget c = EConstr.of_constr (Lazy.force c) -let constant path s = Universes.constr_of_global @@ - Coqlib.coq_reference "Fourier" path s - -(* Standard library *) -open Coqlib -let coq_sym_eqT = lazy (build_coq_eq_sym ()) -let coq_False = lazy (Universes.constr_of_global @@ build_coq_False ()) -let coq_not = lazy (Universes.constr_of_global @@ build_coq_not ()) -let coq_eq = lazy (Universes.constr_of_global @@ build_coq_eq ()) - -(* Rdefinitions *) -let constant_real = constant ["Reals";"Rdefinitions"] - -let coq_Rlt = lazy (constant_real "Rlt") -let coq_Rgt = lazy (constant_real "Rgt") -let coq_Rle = lazy (constant_real "Rle") -let coq_Rge = lazy (constant_real "Rge") -let coq_R = lazy (constant_real "R") -let coq_Rminus = lazy (constant_real "Rminus") -let coq_Rmult = lazy (constant_real "Rmult") -let coq_Rplus = lazy (constant_real "Rplus") -let coq_Ropp = lazy (constant_real "Ropp") -let coq_Rinv = lazy (constant_real "Rinv") -let coq_R0 = lazy (constant_real "R0") -let coq_R1 = lazy (constant_real "R1") - -(* RIneq *) -let coq_Rinv_1 = lazy (constant ["Reals";"RIneq"] "Rinv_1") - -(* Fourier_util *) -let constant_fourier = constant ["fourier";"Fourier_util"] - -let coq_Rlt_zero_1 = lazy (constant_fourier "Rlt_zero_1") -let coq_Rlt_zero_pos_plus1 = lazy (constant_fourier "Rlt_zero_pos_plus1") -let coq_Rle_zero_pos_plus1 = lazy (constant_fourier "Rle_zero_pos_plus1") -let coq_Rlt_mult_inv_pos = lazy (constant_fourier "Rlt_mult_inv_pos") -let coq_Rle_zero_zero = lazy (constant_fourier "Rle_zero_zero") -let coq_Rle_zero_1 = lazy (constant_fourier "Rle_zero_1") -let coq_Rle_mult_inv_pos = lazy (constant_fourier "Rle_mult_inv_pos") -let coq_Rnot_lt0 = lazy (constant_fourier "Rnot_lt0") -let coq_Rle_not_lt = lazy (constant_fourier "Rle_not_lt") -let coq_Rfourier_gt_to_lt = lazy (constant_fourier "Rfourier_gt_to_lt") -let coq_Rfourier_ge_to_le = lazy (constant_fourier "Rfourier_ge_to_le") -let coq_Rfourier_eqLR_to_le = lazy (constant_fourier "Rfourier_eqLR_to_le") -let coq_Rfourier_eqRL_to_le = lazy (constant_fourier "Rfourier_eqRL_to_le") - -let coq_Rfourier_not_ge_lt = lazy (constant_fourier "Rfourier_not_ge_lt") -let coq_Rfourier_not_gt_le = lazy (constant_fourier "Rfourier_not_gt_le") -let coq_Rfourier_not_le_gt = lazy (constant_fourier "Rfourier_not_le_gt") -let coq_Rfourier_not_lt_ge = lazy (constant_fourier "Rfourier_not_lt_ge") -let coq_Rfourier_lt = lazy (constant_fourier "Rfourier_lt") -let coq_Rfourier_le = lazy (constant_fourier "Rfourier_le") -let coq_Rfourier_lt_lt = lazy (constant_fourier "Rfourier_lt_lt") -let coq_Rfourier_lt_le = lazy (constant_fourier "Rfourier_lt_le") -let coq_Rfourier_le_lt = lazy (constant_fourier "Rfourier_le_lt") -let coq_Rfourier_le_le = lazy (constant_fourier "Rfourier_le_le") -let coq_Rnot_lt_lt = lazy (constant_fourier "Rnot_lt_lt") -let coq_Rnot_le_le = lazy (constant_fourier "Rnot_le_le") -let coq_Rlt_not_le_frac_opp = lazy (constant_fourier "Rlt_not_le_frac_opp") - -(****************************************************************************** -Construction de la preuve en cas de succès de la méthode de Fourier, -i.e. on obtient une contradiction. -*) -let is_int x = (x.den)=1 -;; - -(* fraction = couple (num,den) *) -let rational_to_fraction x= (x.num,x.den) -;; - -(* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1))) -*) -let int_to_real n = - let nn=abs n in - if nn=0 - then get coq_R0 - else - (let s=ref (get coq_R1) in - for _i = 1 to (nn-1) do s:=mkApp (get coq_Rplus,[|get coq_R1;!s|]) done; - if n<0 then mkApp (get coq_Ropp, [|!s|]) else !s) -;; -(* -1/2 -> (Rmult (Ropp R1) (Rinv (Rplus R1 R1))) -*) -let rational_to_real x = - let (n,d)=rational_to_fraction x in - mkApp (get coq_Rmult, - [|int_to_real n;mkApp(get coq_Rinv,[|int_to_real d|])|]) -;; - -(* preuve que 0<n*1/d -*) -let tac_zero_inf_pos gl (n,d) = - let get = eget in - let tacn=ref (apply (get coq_Rlt_zero_1)) in - let tacd=ref (apply (get coq_Rlt_zero_1)) in - for _i = 1 to n - 1 do - tacn:=(Tacticals.New.tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacn); done; - for _i = 1 to d - 1 do - tacd:=(Tacticals.New.tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done; - (Tacticals.New.tclTHENS (apply (get coq_Rlt_mult_inv_pos)) [!tacn;!tacd]) -;; - -(* preuve que 0<=n*1/d -*) -let tac_zero_infeq_pos gl (n,d)= - let get = eget in - let tacn=ref (if n=0 - then (apply (get coq_Rle_zero_zero)) - else (apply (get coq_Rle_zero_1))) in - let tacd=ref (apply (get coq_Rlt_zero_1)) in - for _i = 1 to n - 1 do - tacn:=(Tacticals.New.tclTHEN (apply (get coq_Rle_zero_pos_plus1)) !tacn); done; - for _i = 1 to d - 1 do - tacd:=(Tacticals.New.tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done; - (Tacticals.New.tclTHENS (apply (get coq_Rle_mult_inv_pos)) [!tacn;!tacd]) -;; - -(* preuve que 0<(-n)*(1/d) => False -*) -let tac_zero_inf_false gl (n,d) = - let get = eget in -if n=0 then (apply (get coq_Rnot_lt0)) - else - (Tacticals.New.tclTHEN (apply (get coq_Rle_not_lt)) - (tac_zero_infeq_pos gl (-n,d))) -;; - -(* preuve que 0<=(-n)*(1/d) => False -*) -let tac_zero_infeq_false gl (n,d) = - let get = eget in - (Tacticals.New.tclTHEN (apply (get coq_Rlt_not_le_frac_opp)) - (tac_zero_inf_pos gl (-n,d))) -;; - -let exact = exact_check;; - -let tac_use h = - let get = eget in - let tac = exact (EConstr.of_constr h.hname) in - match h.htype with - "Rlt" -> tac - |"Rle" -> tac - |"Rgt" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_gt_to_lt)) tac) - |"Rge" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_ge_to_le)) tac) - |"eqTLR" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_eqLR_to_le)) tac) - |"eqTRL" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_eqRL_to_le)) tac) - |_->assert false -;; - -(* -let is_ineq (h,t) = - match (Constr.kind t) with - App (f,args) -> - (match (string_of_R_constr f) with - "Rlt" -> true - | "Rgt" -> true - | "Rle" -> true - | "Rge" -> true -(* Wrong:not in Rdefinitions: *) | "eqT" -> - (match (string_of_R_constr args.(0)) with - "R" -> true - | _ -> false) - | _ ->false) - |_->false -;; -*) - -let list_of_sign s = - 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 - mkApp(List.hd l, Array.of_list (List.tl l)) -;; - -exception GoalDone - -(* Résolution d'inéquations linéaires dans R *) -let rec fourier () = - Proofview.Goal.nf_enter begin fun gl -> - let concl = Proofview.Goal.concl gl in - let sigma = Tacmach.New.project gl in - Coqlib.check_required_library ["Coq";"fourier";"Fourier"]; - let goal = Termops.strip_outer_cast sigma concl in - let goal = EConstr.Unsafe.to_constr goal in - let fhyp=Id.of_string "new_hyp_for_fourier" in - (* si le but est une inéquation, on introduit son contraire, - et le but à prouver devient False *) - try - match (Constr.kind goal) with - App (f,args) -> - let get = eget in - (match (string_of_R_constr f) with - "Rlt" -> - (Tacticals.New.tclTHEN - (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_ge_lt)) - (intro_using fhyp)) - (fourier ())) - |"Rle" -> - (Tacticals.New.tclTHEN - (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_gt_le)) - (intro_using fhyp)) - (fourier ())) - |"Rgt" -> - (Tacticals.New.tclTHEN - (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_le_gt)) - (intro_using fhyp)) - (fourier ())) - |"Rge" -> - (Tacticals.New.tclTHEN - (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_lt_ge)) - (intro_using fhyp)) - (fourier ())) - |_-> raise GoalDone) - |_-> raise GoalDone - with GoalDone -> - (* les hypothèses *) - let hyps = List.map (fun (h,t)-> (EConstr.mkVar h,t)) - (list_of_sign (Proofview.Goal.hyps gl)) in - let lineq =ref [] in - List.iter (fun h -> try (lineq:=(ineq1_of_constr h)@(!lineq)) - with NoIneq -> ()) - hyps; - (* lineq = les inéquations découlant des hypothèses *) - if !lineq=[] then CErrors.user_err Pp.(str "No inequalities"); - let res=fourier_lineq (!lineq) in - let tac=ref (Proofview.tclUNIT ()) in - if res=[] - then CErrors.user_err Pp.(str "fourier failed") - (* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *) - else (match res with - [(cres,sres,lc)]-> - (* lc=coefficients multiplicateurs des inéquations - qui donnent 0<cres ou 0<=cres selon sres *) - (*print_string "Fourier's method can prove the goal...";flush stdout;*) - let lutil=ref [] in - List.iter - (fun (h,c) -> - if c<>r0 - then (lutil:=(h,c)::(!lutil)(*; - print_rational(c);print_string " "*))) - (List.combine (!lineq) lc); - (* on construit la combinaison linéaire des inéquation *) - (match (!lutil) with - (h1,c1)::lutil -> - let s=ref (h1.hstrict) in - let t1=ref (mkAppL [|get coq_Rmult; - rational_to_real c1; - h1.hleft|]) in - let t2=ref (mkAppL [|get coq_Rmult; - rational_to_real c1; - h1.hright|]) in - List.iter (fun (h,c) -> - s:=(!s)||(h.hstrict); - t1:=(mkAppL [|get coq_Rplus; - !t1; - mkAppL [|get coq_Rmult; - rational_to_real c; - h.hleft|] |]); - t2:=(mkAppL [|get coq_Rplus; - !t2; - mkAppL [|get coq_Rmult; - rational_to_real c; - h.hright|] |])) - lutil; - let ineq=mkAppL [|if (!s) then get coq_Rlt else get coq_Rle; - !t1; - !t2 |] in - let tc=rational_to_real cres in - (* puis sa preuve *) - let get = eget in - let tac1=ref (if h1.hstrict - then (Tacticals.New.tclTHENS (apply (get coq_Rfourier_lt)) - [tac_use h1; - tac_zero_inf_pos gl - (rational_to_fraction c1)]) - else (Tacticals.New.tclTHENS (apply (get coq_Rfourier_le)) - [tac_use h1; - tac_zero_inf_pos gl - (rational_to_fraction c1)])) in - s:=h1.hstrict; - List.iter (fun (h,c)-> - (if (!s) - then (if h.hstrict - then tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_lt_lt)) - [!tac1;tac_use h; - tac_zero_inf_pos gl - (rational_to_fraction c)]) - else tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_lt_le)) - [!tac1;tac_use h; - tac_zero_inf_pos gl - (rational_to_fraction c)])) - else (if h.hstrict - then tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_le_lt)) - [!tac1;tac_use h; - tac_zero_inf_pos gl - (rational_to_fraction c)]) - else tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_le_le)) - [!tac1;tac_use h; - tac_zero_inf_pos gl - (rational_to_fraction c)]))); - s:=(!s)||(h.hstrict)) - lutil; - let tac2= if sres - then tac_zero_inf_false gl (rational_to_fraction cres) - else tac_zero_infeq_false gl (rational_to_fraction cres) - in - tac:=(Tacticals.New.tclTHENS (cut (EConstr.of_constr ineq)) - [Tacticals.New.tclTHEN (change_concl - (EConstr.of_constr (mkAppL [| cget coq_not; ineq|] - ))) - (Tacticals.New.tclTHEN (apply (if sres then get coq_Rnot_lt_lt - else get coq_Rnot_le_le)) - (Tacticals.New.tclTHENS (Equality.replace - (EConstr.of_constr (mkAppL [|cget coq_Rminus;!t2;!t1|] - )) - (EConstr.of_constr tc)) - [tac2; - (Tacticals.New.tclTHENS - (Equality.replace - (EConstr.of_constr (mkApp (cget coq_Rinv, - [|cget coq_R1|]))) - (get coq_R1)) -(* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *) - - [Tacticals.New.tclORELSE - (* TODO : Ring.polynom []*) (Proofview.tclUNIT ()) - (Proofview.tclUNIT ()); - Tacticals.New.pf_constr_of_global (cget coq_sym_eqT) >>= fun symeq -> - (Tacticals.New.tclTHEN (apply symeq) - (apply (get coq_Rinv_1)))] - - ) - ])); - !tac1]); - tac:=(Tacticals.New.tclTHENS (cut (get coq_False)) - [Tacticals.New.tclTHEN intro (contradiction None); - !tac]) - |_-> assert false) |_-> assert false - ); -(* ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *) - !tac -(* ((tclABSTRACT None !tac) gl) *) - end -;; - -(* -let fourier_tac x gl = - fourier gl -;; - -let v_fourier = add_tactic "Fourier" fourier_tac -*) - diff --git a/plugins/fourier/fourier_plugin.mlpack b/plugins/fourier/fourier_plugin.mlpack deleted file mode 100644 index b6262f8aeb..0000000000 --- a/plugins/fourier/fourier_plugin.mlpack +++ /dev/null @@ -1,3 +0,0 @@ -Fourier -FourierR -G_fourier diff --git a/plugins/fourier/plugin_base.dune b/plugins/fourier/plugin_base.dune new file mode 100644 index 0000000000..8cc76f6f9e --- /dev/null +++ b/plugins/fourier/plugin_base.dune @@ -0,0 +1,5 @@ +(library + (name fourier_plugin) + (public_name coq.plugins.fourier) + (synopsis "Coq's fourier plugin") + (libraries coq.plugins.ltac)) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index d04887a489..ef1d1af199 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -131,8 +131,7 @@ let finish_proof dynamic_infos g = g -let refine c = - Tacmach.refine c +let refine c = Refiner.refiner ~check:true EConstr.Unsafe.(to_constr c) let thin l = Proofview.V82.of_tactic (Tactics.clear l) @@ -229,10 +228,6 @@ let isAppConstruct ?(env=Global.env ()) sigma t = true with Not_found -> false -let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) - Reductionops.clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty - - exception NoChange let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = @@ -243,7 +238,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = raise NoChange; end in - let eq_constr c1 c2 = Evarconv.e_conv env (ref sigma) c1 c2 in + let eq_constr c1 c2 = Option.has_some (Evarconv.conv env sigma c1 c2) in if not (noccurn sigma 1 end_of_type) then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) if not (isApp sigma t) then nochange "not an equality"; @@ -414,13 +409,13 @@ let rewrite_until_var arg_num eq_ids : tactic = let rec_pte_id = Id.of_string "Hrec" let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = - let coq_False = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_False ()) in - let coq_True = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_True ()) in - let coq_I = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_I ()) in + let coq_False = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type") in + let coq_True = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.type") in + let coq_I = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") in let rec scan_type context type_of_hyp : tactic = if isLetIn sigma type_of_hyp then let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in - let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in + let reduced_type_of_hyp = Reductionops.nf_betaiotazeta env sigma real_type_of_hyp in (* length of context didn't change ? *) let new_context,new_typ_of_hyp = decompose_prod_n_assum sigma (List.length context) reduced_type_of_hyp @@ -598,7 +593,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = Proofview.V82.of_tactic (intro_using heq_id); onLastHypId (fun heq_id -> tclTHENLIST [ (* Then the new hypothesis *) - tclMAP (fun id -> Proofview.V82.of_tactic (introduction ~check:false id)) dyn_infos.rec_hyps; + tclMAP (fun id -> Proofview.V82.of_tactic (introduction id)) dyn_infos.rec_hyps; observe_tac "after_introduction" (fun g' -> (* We get infos on the equations introduced*) let new_term_value_eq = pf_unsafe_type_of g' (mkVar heq_id) in @@ -638,11 +633,11 @@ let my_orelse tac1 tac2 g = (* 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 = +let instantiate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = let args = Array.of_list (List.map mkVar args_id) in - let instanciate_one_hyp hid = + let instantiate_one_hyp hid = my_orelse - ( (* we instanciate the hyp if possible *) + ( (* we instantiate the hyp if possible *) fun g -> let prov_hid = pf_get_new_id hid g in let c = mkApp(mkVar hid,args) in @@ -678,7 +673,7 @@ let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = tclTHENLIST [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps; - tclMAP instanciate_one_hyp hyps; + tclMAP instantiate_one_hyp hyps; (fun g -> let all_g_hyps_id = List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty @@ -722,11 +717,11 @@ let build_proof tclTHENLIST [Proofview.V82.of_tactic (Simple.case t); (fun g' -> let g'_nb_prod = nb_prod (project g') (pf_concl g') in - let nb_instanciate_partial = g'_nb_prod - g_nb_prod in + let nb_instantiate_partial = g'_nb_prod - g_nb_prod in observe_tac "treat_new_case" (treat_new_case ptes_infos - nb_instanciate_partial + nb_instantiate_partial (build_proof do_finalize) t dyn_infos) @@ -760,7 +755,7 @@ let build_proof nb_rec_hyps = List.length new_hyps } in -(* observe_tac "Lambda" *) (instanciate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' +(* observe_tac "Lambda" *) (instantiate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' (* build_proof do_finalize new_infos g' *) ) g | _ -> @@ -800,7 +795,7 @@ let build_proof g | LetIn _ -> let new_infos = - { dyn_infos with info = nf_betaiotazeta dyn_infos.info } + { dyn_infos with info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } in tclTHENLIST @@ -834,7 +829,7 @@ let build_proof | LetIn _ -> let new_infos = { dyn_infos with - info = nf_betaiotazeta dyn_infos.info + info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } in @@ -977,7 +972,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num (* observe (str "body " ++ pr_lconstr bodies.(num)); *) let f_body_with_params_and_other_fun = substl fnames_with_params bodies.(num) in (* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *) - let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in + let eq_rhs = Reductionops.nf_betaiotazeta (Global.env ()) evd (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in (* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) let (type_ctxt,type_of_f),evd = let evd,t = Typing.type_of ~refresh:true (Global.env ()) evd f @@ -1008,12 +1003,12 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num Ensures by: obvious i*) (mk_equation_id f_id) - (Decl_kinds.Global, Flags.is_universe_polymorphism (), (Decl_kinds.Proof Decl_kinds.Theorem)) + (Decl_kinds.Global, false, (Decl_kinds.Proof Decl_kinds.Theorem)) evd lemma_type (Lemmas.mk_hook (fun _ _ -> ())); ignore (Pfedit.by (Proofview.V82.tactic prove_replacement)); - Lemmas.save_proof (Vernacexpr.(Proved(Transparent,None))); + Lemmas.save_proof (Vernacexpr.(Proved(Proof_global.Transparent,None))); evd @@ -1050,9 +1045,9 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a (Global.env ()) !evd (Constrintern.locate_reference (qualid_of_ident equation_lemma_id)) in - let res = EConstr.of_constr res in - evd:=evd'; - let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd res in + evd:=evd'; + let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd res in + evd := sigma; res in let nb_intro_to_do = nb_prod (project g) (pf_concl g) in @@ -1099,10 +1094,12 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let get_body const = match Global.body_of_constant const with | Some (body, _) -> + let env = Global.env () in + let sigma = Evd.from_env env in Tacred.cbv_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - (Global.env ()) - (Evd.empty) + env + sigma (EConstr.of_constr body) | None -> user_err Pp.(str "Cannot define a principle over an axiom ") in @@ -1118,7 +1115,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam in (full_params, (* real params *) princ_params, (* the params of the principle which are not params of the function *) - substl (* function instanciated with real params *) + substl (* function instantiated with real params *) (List.map var_of_decl full_params) f_body ) @@ -1128,7 +1125,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let f_body = compose_lam f_ctxt_other f_body in (princ_info.params, (* real params *) [],(* all params are full params *) - substl (* function instanciated with real params *) + substl (* function instantiated with real params *) (List.map var_of_decl princ_info.params) f_body ) @@ -1242,7 +1239,7 @@ 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) ) (Proofview.V82.of_tactic (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 this_fix_info.name (this_fix_info.idx +1))) else Proofview.V82.of_tactic (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) other_fix_infos 0) @@ -1319,7 +1316,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) (* ); *) - (* observe_tac "instancing" *) (instanciate_hyps_with_args prove_tac + (* observe_tac "instancing" *) (instantiate_hyps_with_args prove_tac (List.rev_map id_of_decl princ_info.branches) (List.rev args_id)) ] @@ -1340,7 +1337,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam nb_rec_hyps = -100; rec_hyps = []; info = - Reductionops.nf_betaiota (pf_env g) Evd.empty + Reductionops.nf_betaiota (pf_env g) (project g) (applist(fbody_with_full_params, (List.rev_map var_of_decl princ_params)@ (List.rev_map mkVar args_id) @@ -1369,7 +1366,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam do_prove dyn_infos in - instanciate_hyps_with_args prove_tac + instantiate_hyps_with_args prove_tac (List.rev_map id_of_decl princ_info.branches) (List.rev args_id) ] @@ -1489,7 +1486,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = Eauto.eauto_with_bases (true,5) [(fun _ sigma -> (sigma, Lazy.force refl_equal))] - [Hints.Hint_db.empty empty_transparent_state false] + [Hints.Hint_db.empty TransparentState.empty false] ) ) ) @@ -1603,7 +1600,7 @@ let prove_principle_for_gen match !tcc_lemma_ref with | Undefined -> user_err Pp.(str "No tcc proof !!") | Value lemma -> EConstr.of_constr lemma - | Not_needed -> EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_I ()) + | Not_needed -> EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") in (* let rec list_diff del_list check_list = *) (* match del_list with *) @@ -1657,7 +1654,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 " *) (Proofview.V82.of_tactic (fix (Some fix_id) (List.length args_ids + 1))); + (* observe_tac "h_fix " *) (Proofview.V82.of_tactic (fix 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)); @@ -1726,8 +1723,8 @@ let prove_principle_for_gen ptes_info (body_info rec_hyps) in - (* observe_tac "instanciate_hyps_with_args" *) - (instanciate_hyps_with_args + (* observe_tac "instantiate_hyps_with_args" *) + (instantiate_hyps_with_args make_proof (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) (List.rev args_ids) diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 7a9bbd92cf..5ba9735690 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -1,3 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + open Printer open CErrors open Term @@ -266,7 +276,7 @@ let change_property_sort evd toSort princ princName = (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident princName)) in let init = let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in - mkApp(princName_as_constr, + mkApp(EConstr.Unsafe.to_constr princName_as_constr, Array.init nargs (fun i -> mkRel (nargs - i ))) in @@ -291,12 +301,13 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin let new_princ_name = next_ident_away_in_goal (Id.of_string "___________princ_________") Id.Set.empty in - let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd (EConstr.of_constr new_principle_type) in + let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd (EConstr.of_constr new_principle_type) in + evd := sigma; let hook = Lemmas.mk_hook (hook new_principle_type) in begin Lemmas.start_proof new_princ_name - (Decl_kinds.Global,Flags.is_universe_polymorphism (),(Decl_kinds.Proof Decl_kinds.Theorem)) + (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) !evd (EConstr.of_constr new_principle_type) hook @@ -309,10 +320,16 @@ 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, CEphemeron.create hook - end - + let open Proof_global in + let { id; entries; persistence } = fst @@ close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) in + match entries with + | [entry] -> + discard_current (); + (id,(entry,persistence)), CEphemeron.create hook + | _ -> + CErrors.anomaly Pp.(str "[build_functional_principle] close_proof returned more than one proof term") + end let generate_functional_principle (evd: Evd.evar_map ref) interactive_proof @@ -321,8 +338,8 @@ let generate_functional_principle (evd: Evd.evar_map ref) try let f = funs.(i) in - let env = Global.env () in - let type_sort = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd InType in + let sigma, type_sort = Evd.fresh_sort_in_family !evd InType in + evd := sigma; let new_sorts = match sorts with | None -> Array.make (Array.length funs) (type_sort) @@ -343,17 +360,14 @@ let generate_functional_principle (evd: Evd.evar_map ref) (* let id_of_f = Label.to_id (con_label f) in *) let register_with_sort fam_sort = let evd' = Evd.from_env (Global.env ()) in - let evd',s = Evd.fresh_sort_in_family env evd' fam_sort in + let evd',s = Evd.fresh_sort_in_family evd' fam_sort in let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in let evd',value = change_property_sort evd' s new_principle_type new_princ_name in let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr value)) in (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let univs = - let poly = Flags.is_universe_polymorphism () in - Evd.const_univ_entry ~poly evd' - in + let univs = Evd.const_univ_entry ~poly:false evd' in let ce = Declare.definition_entry ~univs value in - ignore( + ignore( Declare.declare_constant name (DefinitionEntry ce, @@ -394,7 +408,7 @@ let generate_functional_principle (evd: Evd.evar_map ref) exception Not_Rec -let get_funs_constant mp dp = +let get_funs_constant mp = let get_funs_constant const e : (Names.Constant.t*int) array = match Constr.kind ((strip_lam e)) with | Fix((_,(na,_,_))) -> @@ -402,7 +416,7 @@ let get_funs_constant mp dp = (fun i na -> match na with | Name id -> - let const = Constant.make3 mp dp (Label.of_id id) in + let const = Constant.make2 mp (Label.of_id id) in const,i | Anonymous -> anomaly (Pp.str "Anonymous fix.") @@ -474,13 +488,13 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ let env = Global.env () in let funs = List.map fst fas in let first_fun = List.hd funs in - let funs_mp,funs_dp,_ = KerName.repr (Constant.canonical (fst first_fun)) in + let funs_mp = KerName.modpath (Constant.canonical (fst first_fun)) in let first_fun_kn = try fst (find_Function_infos (fst first_fun)).graph_ind with Not_found -> raise No_graph_found in - let this_block_funs_indexes = get_funs_constant funs_mp funs_dp (fst first_fun) in + let this_block_funs_indexes = get_funs_constant funs_mp (fst first_fun) in let this_block_funs = Array.map (fun (c,_) -> (c,snd first_fun)) this_block_funs_indexes in let prop_sort = InProp in let funs_indexes = @@ -507,8 +521,9 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ let i = ref (-1) in let sorts = List.rev_map (fun (_,x) -> - Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd x - ) + let sigma, fs = Evd.fresh_sort_in_family !evd x in + evd := sigma; fs + ) fas in (* We create the first priciple by tactic *) @@ -626,18 +641,25 @@ let build_scheme fas = Smartlocate.global_with_alias f with Not_found -> user_err ~hdr:"FunInd.build_scheme" - (str "Cannot find " ++ Libnames.pr_reference f) + (str "Cannot find " ++ Libnames.pr_qualid f) in - let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in + let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in let _ = evd := evd' in - let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd (EConstr.of_constr f) in - (destConst f,sort) - ) + let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd f in + evd := sigma; + let c, u = + try EConstr.destConst !evd f + with DestKO -> + user_err Pp.(pr_econstr_env (Global.env ()) !evd f ++spc () ++ str "should be the named of a globally defined function") + in + (c, EConstr.EInstance.kind !evd u), sort + ) fas ) in let bodies_types = make_scheme evd pconstants in + List.iter2 (fun (princ_id,_,_) def_entry -> ignore @@ -657,19 +679,23 @@ let build_case_scheme fa = (* in *) let funs = let (_,f,_) = fa in - try fst (Global.constr_of_global_in_context (Global.env ()) (Smartlocate.global_with_alias f)) + try (let open GlobRef in + match Smartlocate.global_with_alias f with + | ConstRef c -> c + | IndRef _ | ConstructRef _ | VarRef _ -> assert false) with Not_found -> user_err ~hdr:"FunInd.build_case_scheme" - (str "Cannot find " ++ Libnames.pr_reference f) in - let first_fun,u = destConst funs in - let funs_mp,funs_dp,_ = Constant.repr3 first_fun in + (str "Cannot find " ++ Libnames.pr_qualid f) in + let sigma, (_,u) = Evd.fresh_constant_instance env sigma funs in + let first_fun = funs in + let funs_mp = Constant.modpath first_fun in let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in - let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in + let this_block_funs_indexes = get_funs_constant funs_mp first_fun in let this_block_funs = Array.map (fun (c,_) -> (c,u)) this_block_funs_indexes in let prop_sort = InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in - List.assoc_f Constant.equal (fst (destConst funs)) this_block_funs_indexes + List.assoc_f Constant.equal funs this_block_funs_indexes in let (ind, sf) = let ind = first_fun_kn,funs_indexes in @@ -681,7 +707,7 @@ let build_case_scheme fa = let scheme_type = EConstr.Unsafe.to_constr ((Typing.unsafe_type_of env sigma) (EConstr.of_constr scheme)) in let sorts = (fun (_,_,x) -> - Universes.new_sort_in_family x + fst @@ UnivGen.fresh_sort_in_family x ) fa in @@ -699,7 +725,7 @@ let build_case_scheme fa = (Some princ_name) this_block_funs 0 - (prove_princ_for_struct (ref (Evd.from_env (Global.env ()))) false 0 [|fst (destConst funs)|]) + (prove_princ_for_struct (ref (Evd.from_env (Global.env ()))) false 0 [|funs|]) in () diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index 33aeafef81..97f9acdb3a 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -36,5 +36,5 @@ exception No_graph_found val make_scheme : Evd.evar_map ref -> (pconstant*Sorts.family) list -> Safe_typing.private_constants Entries.definition_entry list -val build_scheme : (Id.t*Libnames.reference*Sorts.family) list -> unit -val build_case_scheme : (Id.t*Libnames.reference*Sorts.family) -> unit +val build_scheme : (Id.t*Libnames.qualid*Sorts.family) list -> unit +val build_case_scheme : (Id.t*Libnames.qualid*Sorts.family) -> unit diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.mlg index 90af20b4ca..8f0440a2a4 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.mlg @@ -7,22 +7,28 @@ (* * GNU Lesser General Public License Version 2.1 *) (* * (see LICENSE file for the text of the license) *) (************************************************************************) + +{ + open Ltac_plugin open Util open Pp open Constrexpr open Indfun_common open Indfun -open Genarg open Stdarg -open Misctypes -open Pcoq +open Tacarg +open Tactypes open Pcoq.Prim open Pcoq.Constr open Pltac +} + DECLARE PLUGIN "recdef_plugin" +{ + let pr_fun_ind_using prc prlc _ opt_c = match opt_c with | None -> mt () @@ -38,29 +44,32 @@ let pr_fun_ind_using_typed prc prlc _ opt_c = match opt_c with | None -> mt () | Some b -> - let (_, b) = b (Global.env ()) Evd.empty in + let env = Global.env () in + let evd = Evd.from_env env in + let (_, b) = b env evd in spc () ++ hov 2 (str "using" ++ spc () ++ Miscprint.pr_with_bindings 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 - GLOB_TYPED AS constr_with_bindings_opt - GLOB_PRINTED BY pr_fun_ind_using -| [ "using" constr_with_bindings(c) ] -> [ Some c ] -| [ ] -> [ None ] + PRINTED BY { pr_fun_ind_using_typed } + RAW_PRINTED BY { pr_fun_ind_using } + GLOB_PRINTED BY { pr_fun_ind_using } +| [ "using" constr_with_bindings(c) ] -> { Some c } +| [ ] -> { None } END TACTIC EXTEND newfuninv - [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] -> - [ +| [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] -> + { Proofview.V82.tactic (Invfun.invfun hyp fname) - ] + } END +{ + let pr_intro_as_pat _prc _ _ pat = match pat with | Some pat -> @@ -72,58 +81,71 @@ let out_disjunctive = CAst.map (function | IntroAction (IntroOrAndPattern l) -> l | _ -> CErrors.user_err Pp.(str "Disjunctive or conjunctive intro pattern expected.")) -ARGUMENT EXTEND with_names TYPED AS intropattern_opt PRINTED BY pr_intro_as_pat -| [ "as" simple_intropattern(ipat) ] -> [ Some ipat ] -| [] ->[ None ] +} + +ARGUMENT EXTEND with_names TYPED AS intropattern option PRINTED BY { pr_intro_as_pat } +| [ "as" simple_intropattern(ipat) ] -> { Some ipat } +| [] -> { None } END +{ + let functional_induction b c x pat = Proofview.V82.tactic (functional_induction true c x (Option.map out_disjunctive pat)) +} TACTIC EXTEND newfunind - ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> - [ +| ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> + { let c = match cl with | [] -> assert false | [c] -> c | c::cl -> EConstr.applist(c,cl) in - Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl ] + Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl } END (***** debug only ***) TACTIC EXTEND snewfunind - ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> - [ +| ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> + { let c = match cl with | [] -> assert false | [c] -> c | c::cl -> EConstr.applist(c,cl) in - Extratactics.onSomeWithHoles (fun x -> functional_induction false c x pat) princl ] + Extratactics.onSomeWithHoles (fun x -> functional_induction false c x pat) princl } END +{ let pr_constr_comma_sequence prc _ _ = prlist_with_sep pr_comma prc +} + ARGUMENT EXTEND constr_comma_sequence' - TYPED AS constr_list - PRINTED BY pr_constr_comma_sequence -| [ constr(c) "," constr_comma_sequence'(l) ] -> [ c::l ] -| [ constr(c) ] -> [ [c] ] + TYPED AS constr list + PRINTED BY { pr_constr_comma_sequence } +| [ constr(c) "," constr_comma_sequence'(l) ] -> { c::l } +| [ constr(c) ] -> { [c] } END +{ + let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using prc +} + ARGUMENT EXTEND auto_using' - TYPED AS constr_list - PRINTED BY pr_auto_using -| [ "using" constr_comma_sequence'(l) ] -> [ l ] -| [ ] -> [ [] ] + TYPED AS constr list + PRINTED BY { pr_auto_using } +| [ "using" constr_comma_sequence'(l) ] -> { l } +| [ ] -> { [] } END -module Gram = Pcoq.Gram -module Vernac = Pcoq.Vernac_ +{ + +module Vernac = Pvernac.Vernac_ module Tactic = Pltac type function_rec_definition_loc_argtype = (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) Loc.located @@ -134,65 +156,77 @@ let (wit_function_rec_definition_loc : function_rec_definition_loc_argtype Genar let function_rec_definition_loc = Pcoq.create_generic_entry Pcoq.utactic "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc) -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: function_rec_definition_loc ; function_rec_definition_loc: - [ [ g = Vernac.rec_definition -> Loc.tag ~loc:!@loc g ]] + [ [ g = Vernac.rec_definition -> { Loc.tag ~loc g } ]] ; END +{ + let () = let raw_printer _ _ _ (loc,body) = Ppvernac.pr_rec_definition body in Pptactic.declare_extra_vernac_genarg_pprule wit_function_rec_definition_loc raw_printer +} + (* TASSI: n'importe quoi ! *) VERNAC COMMAND EXTEND Function - ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] - => [ let hard = List.exists (function +| ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] + => { let hard = List.exists (function | _,((_,(_,(CMeasureRec _|CWfRec _)),_,_,_),_) -> true | _,((_,(_,CStructRec),_,_,_),_) -> false) recsl in match Vernac_classifier.classify_vernac (Vernacexpr.(VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)))) with - | Vernacexpr.VtSideff ids, _ when hard -> - Vernacexpr.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater) - | x -> x ] - -> [ do_generate_principle false (List.map snd recsl) ] + | Vernacextend.VtSideff ids, _ when hard -> + Vernacextend.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater) + | x -> x } + -> { do_generate_principle false (List.map snd recsl) } END +{ + let pr_fun_scheme_arg (princ_name,fun_name,s) = Names.Id.print princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++ - Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++ - Termops.pr_sort_family s + Libnames.pr_qualid fun_name ++ spc() ++ str "Sort " ++ + Sorts.pr_sort_family s + +} VERNAC ARGUMENT EXTEND fun_scheme_arg -PRINTED BY pr_fun_scheme_arg -| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort_family(s) ] -> [ (princ_name,fun_name,s) ] +PRINTED BY { pr_fun_scheme_arg } +| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort_family(s) ] -> { (princ_name,fun_name,s) } END +{ let warning_error names e = let (e, _) = ExplainErr.process_vernac_interp_error (e, Exninfo.null) in match e with | Building_graph e -> - let names = pr_enum Libnames.pr_reference names in + let names = pr_enum Libnames.pr_qualid names in let error = if do_observe () then (spc () ++ CErrors.print e) else mt () in warn_cannot_define_graph (names,error) | Defining_principle e -> - let names = pr_enum Libnames.pr_reference names in + let names = pr_enum Libnames.pr_qualid names in let error = if do_observe () then CErrors.print e else mt () in warn_cannot_define_principle (names,error) | _ -> raise e +} VERNAC COMMAND EXTEND NewFunctionalScheme - ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] - => [ Vernacexpr.VtSideff(List.map pi1 fas), Vernacexpr.VtLater ] +| ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] + => { Vernacextend.(VtSideff(List.map pi1 fas), VtLater) } -> - [ + { begin try Functional_principles_types.build_scheme fas @@ -220,17 +254,17 @@ VERNAC COMMAND EXTEND NewFunctionalScheme warning_error names e end - ] + } END (***** debug only ***) VERNAC COMMAND EXTEND NewFunctionalCase - ["Functional" "Case" fun_scheme_arg(fas) ] - => [ Vernacexpr.VtSideff[pi1 fas], Vernacexpr.VtLater ] - -> [ Functional_principles_types.build_case_scheme fas ] +| ["Functional" "Case" fun_scheme_arg(fas) ] + => { Vernacextend.(VtSideff[pi1 fas], VtLater) } + -> { Functional_principles_types.build_case_scheme fas } END (***** debug only ***) VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY -["Generate" "graph" "for" reference(c)] -> [ make_graph (Smartlocate.global_with_alias c) ] +| ["Generate" "graph" "for" reference(c)] -> { make_graph (Smartlocate.global_with_alias c) } END diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 49f7aae435..98aaa081c3 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -10,7 +10,6 @@ open Indfun_common open CErrors open Util open Glob_termops -open Misctypes module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration @@ -260,11 +259,8 @@ let mk_result ctxt value avoid = Some functions to deal with overlapping patterns **************************************************) -let coq_True_ref = - lazy (Coqlib.coq_reference "" ["Init";"Logic"] "True") - -let coq_False_ref = - lazy (Coqlib.coq_reference "" ["Init";"Logic"] "False") +let coq_True_ref = lazy (Coqlib.lib_ref "core.True.type") +let coq_False_ref = lazy (Coqlib.lib_ref "core.False.type") (* [make_discr_match_el \[e1,...en\]] builds match e1,...,en with @@ -591,7 +587,6 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = *) build_entry_lc env funnames avoid (mkGApp(b,args)) | GRec _ -> user_err Pp.(str "Not handled GRec") - | GProj _ -> user_err Pp.(str "Funind does not support primitive projections") | GProd _ -> user_err Pp.(str "Cannot apply a type") end (* end of the application treatement *) @@ -697,7 +692,6 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = | GRec _ -> user_err Pp.(str "Not handled GRec") | GCast(b,_) -> build_entry_lc env funnames avoid b - | GProj(_,_) -> user_err Pp.(str "Funind does not support primitive projections") and build_entry_lc_from_case env funname make_discr (el:tomatch_tuples) (brl:Glob_term.cases_clauses) avoid : @@ -885,7 +879,7 @@ let is_res r = match DAst.get r with | _ -> false let is_gr c gr = match DAst.get c with -| GRef (r, _) -> Globnames.eq_gr r gr +| GRef (r, _) -> GlobRef.equal r gr | _ -> false let is_gvar c = match DAst.get c with @@ -894,7 +888,7 @@ let is_gvar c = match DAst.get c with let same_raw_term rt1 rt2 = match DAst.get rt1, DAst.get rt2 with - | GRef(r1,_), GRef (r2,_) -> Globnames.eq_gr r1 r2 + | GRef(r1,_), GRef (r2,_) -> GlobRef.equal r1 r2 | GHole _, GHole _ -> true | _ -> false let decompose_raw_eq lhs rhs = @@ -960,7 +954,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = assert false end | GApp(eq_as_ref,[ty; id ;rt]) - when is_gvar id && is_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous + when is_gvar id && is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") && n == Anonymous -> let loc1 = rt.CAst.loc in let loc2 = eq_as_ref.CAst.loc in @@ -1081,7 +1075,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = else new_b, Id.Set.add id id_to_exclude *) | GApp(eq_as_ref,[ty;rt1;rt2]) - when is_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous + when is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") && n == Anonymous -> begin try @@ -1092,7 +1086,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = List.fold_left (fun acc (lhs,rhs) -> mkGProd(Anonymous, - mkGApp(mkGRef(Lazy.force Coqlib.coq_eq_ref),[mkGHole ();lhs;rhs]),acc) + mkGApp(mkGRef Coqlib.(lib_ref "core.eq.type"),[mkGHole ();lhs;rhs]),acc) ) b l @@ -1247,7 +1241,7 @@ let rec compute_cst_params relnames params gt = DAst.with_val (function discrimination ones *) | GSort _ -> params | GHole _ -> params - | GIf _ | GRec _ | GCast _ | GProj _ -> + | GIf _ | GRec _ | GCast _ -> raise (UserError(Some "compute_cst_params", str "Not handled case")) ) gt and compute_cst_params_from_app acc (params,rtl) = @@ -1470,7 +1464,7 @@ let do_build_inductive (rel_constructors) in let rel_ind i ext_rel_constructors = - (((CAst.make @@ relnames.(i)), None), + ((CAst.make @@ relnames.(i)), rel_params, Some rel_arities.(i), ext_rel_constructors),[] @@ -1500,19 +1494,19 @@ let do_build_inductive let _time2 = System.get_time () in try with_full_print - (Flags.silently (ComInductive.do_mutual_inductive rel_inds (Flags.is_universe_polymorphism ()) false false)) + (Flags.silently (ComInductive.do_mutual_inductive ~template:None None rel_inds false false false ~uniform:ComInductive.NonUniformParameters)) Declarations.Finite with | UserError(s,msg) as e -> let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) let repacked_rel_inds = - List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) + List.map (fun ((a , b , c , l),ntn) -> ((false,(a,None)) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) rel_inds in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(GlobalNonCumulativity,false,Declarations.Finite,repacked_rel_inds))) + Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) ++ fnl () ++ msg in @@ -1522,12 +1516,12 @@ let do_build_inductive let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) let repacked_rel_inds = - List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) + List.map (fun ((a , b , c , l),ntn) -> ((false,(a,None)) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) rel_inds in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(GlobalNonCumulativity,false,Declarations.Finite,repacked_rel_inds))) + Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) ++ fnl () ++ CErrors.print reraise in diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 40ea40b6b3..5b45a8dbed 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -1,10 +1,10 @@ open Pp +open Constr open Glob_term open CErrors open Util open Names open Decl_kinds -open Misctypes (* Some basic functions to rebuild glob_constr @@ -16,8 +16,8 @@ let mkGApp(rt,rtl) = DAst.make @@ GApp(rt,rtl) let mkGLambda(n,t,b) = DAst.make @@ GLambda(n,Explicit,t,b) let mkGProd(n,t,b) = DAst.make @@ GProd(n,Explicit,t,b) let mkGLetIn(n,b,t,c) = DAst.make @@ GLetIn(n,b,t,c) -let mkGCases(rto,l,brl) = DAst.make @@ GCases(Term.RegularStyle,rto,l,brl) -let mkGHole () = DAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None) +let mkGCases(rto,l,brl) = DAst.make @@ GCases(RegularStyle,rto,l,brl) +let mkGHole () = DAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Namegen.IntroAnonymous,None) (* Some basic functions to decompose glob_constrs @@ -38,11 +38,11 @@ let glob_decompose_app = (* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *) let glob_make_eq ?(typ= mkGHole ()) t1 t2 = - mkGApp(mkGRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1]) + mkGApp(mkGRef (Coqlib.lib_ref "core.eq.type"),[typ;t2;t1]) (* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *) let glob_make_neq t1 t2 = - mkGApp(mkGRef (Lazy.force Coqlib.coq_not_ref),[glob_make_eq t1 t2]) + mkGApp(mkGRef (Coqlib.lib_ref "core.not.type"),[glob_make_eq t1 t2]) let remove_name_from_mapping mapping na = match na with @@ -108,8 +108,7 @@ let change_vars = | GHole _ as x -> x | GCast(b,c) -> GCast(change_vars mapping b, - Miscops.map_cast_type (change_vars mapping) c) - | GProj(p,c) -> GProj(p, change_vars mapping c) + Glob_ops.map_cast_type (change_vars mapping) c) ) rt and change_vars_br mapping ({CAst.loc;v=(idl,patl,res)} as br) = let new_mapping = List.fold_right Id.Map.remove idl mapping in @@ -289,12 +288,11 @@ let rec alpha_rt excluded rt = | GHole _ as rt -> rt | GCast (b,c) -> GCast(alpha_rt excluded b, - Miscops.map_cast_type (alpha_rt excluded) c) + Glob_ops.map_cast_type (alpha_rt excluded) c) | GApp(f,args) -> GApp(alpha_rt excluded f, List.map (alpha_rt excluded) args ) - | GProj(p,c) -> GProj(p, alpha_rt excluded c) in new_rt @@ -346,7 +344,6 @@ let is_free_in id = | GHole _ -> false | GCast (b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t | GCast (b,CastCoerce) -> is_free_in b - | GProj (_,c) -> is_free_in c ) x and is_free_in_br {CAst.v=(ids,_,rt)} = (not (Id.List.mem id ids)) && is_free_in rt @@ -439,9 +436,7 @@ let replace_var_by_term x_id term = | GHole _ as rt -> rt | GCast(b,c) -> GCast(replace_var_by_pattern b, - Miscops.map_cast_type replace_var_by_pattern c) - | GProj(p,c) -> - GProj(p,replace_var_by_pattern c) + Glob_ops.map_cast_type replace_var_by_pattern c) ) x and replace_var_by_pattern_br ({CAst.loc;v=(idl,patl,res)} as br) = if List.exists (fun id -> Id.compare id x_id == 0) idl @@ -541,11 +536,10 @@ let expand_as = | GRec _ -> user_err Pp.(str "Not handled GRec") | GCast(b,c) -> GCast(expand_as map b, - Miscops.map_cast_type (expand_as map) c) + Glob_ops.map_cast_type (expand_as map) c) | GCases(sty,po,el,brl) -> GCases(sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, List.map (expand_as_br map) brl) - | GProj(p,c) -> GProj(p, expand_as map c) ) and expand_as_br map {CAst.loc; v=(idl,cpl,rt)} = CAst.make ?loc (idl,cpl, expand_as (List.fold_left add_as map cpl) rt) @@ -563,7 +557,8 @@ let resolve_and_replace_implicits ?(flags=Pretyping.all_and_fail_flags) ?(expect (* FIXME : JF (30/03/2017) I'm not completely sure to have split understand as needed. If someone knows how to prevent solved existantial removal in understand, please do not hesitate to change the computation of [ctx] here *) let ctx,_,_ = Pretyping.ise_pretype_gen flags env sigma Glob_ops.empty_lvar expected_type rt in - let ctx, f = Evarutil.nf_evars_and_universes ctx in + let ctx = Evd.minimize_universes ctx in + let f c = EConstr.of_constr (Evarutil.nf_evars_universes ctx (EConstr.Unsafe.to_constr c)) in (* then we map [rt] to replace the implicit holes by their values *) let rec change rt = @@ -575,7 +570,7 @@ If someone knows how to prevent solved existantial removal in understand, pleas (fun _ evi _ -> match evi.evar_source with | (loc_evi,ImplicitArg(gr_evi,p_evi,b_evi)) -> - if Globnames.eq_gr grk gr_evi && pk=p_evi && bk=b_evi && rt.CAst.loc = loc_evi + if GlobRef.equal grk gr_evi && pk=p_evi && bk=b_evi && rt.CAst.loc = loc_evi then raise (Found evi) | _ -> () ) @@ -586,8 +581,8 @@ If someone knows how to prevent solved existantial removal in understand, pleas with Found evi -> (* we found the evar corresponding to this hole *) match evi.evar_body with | Evar_defined c -> - (* we just have to lift the solution in glob_term *) - Detyping.detype Detyping.Now false Id.Set.empty env ctx (EConstr.of_constr (f c)) + (* we just have to lift the solution in glob_term *) + Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) | Evar_empty -> rt (* the hole was not solved : we do nothing *) ) | (GHole(BinderType na,_,_)) -> (* we only want to deal with implicit arguments *) @@ -609,7 +604,7 @@ If someone knows how to prevent solved existantial removal in understand, pleas match evi.evar_body with | Evar_defined c -> (* we just have to lift the solution in glob_term *) - Detyping.detype Detyping.Now false Id.Set.empty env ctx (EConstr.of_constr (f c)) + Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) | Evar_empty -> rt (* the hole was not solved : we d when falseo nothing *) in res diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index 7088ae596b..481a8be3ba 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -13,7 +13,7 @@ val pattern_to_term : cases_pattern -> glob_constr Some basic functions to rebuild glob_constr In each of them the location is Util.Loc.ghost *) -val mkGRef : Globnames.global_reference -> glob_constr +val mkGRef : GlobRef.t -> glob_constr val mkGVar : Id.t -> glob_constr val mkGApp : glob_constr*(glob_constr list) -> glob_constr val mkGLambda : Name.t * glob_constr * glob_constr -> glob_constr diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 9c350483b3..35acbea488 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -10,7 +10,7 @@ open Libnames open Globnames open Glob_term open Declarations -open Misctypes +open Tactypes open Decl_kinds module RelDecl = Context.Rel.Declaration @@ -77,8 +77,7 @@ let functional_induction with_clean c princl pat = user_err (str "Cannot find induction principle for " ++ Printer.pr_leconstr_env (Tacmach.pf_env g) sigma (mkConst c') ) in - let princ = EConstr.of_constr princ in - (princ,NoBindings,Tacmach.pf_unsafe_type_of g' princ,g') + (princ,NoBindings,Tacmach.pf_unsafe_type_of g' princ,g') | _ -> raise (UserError(None,str "functional induction must be used with a function" )) end | Some ((princ,binding)) -> @@ -91,10 +90,19 @@ let functional_induction with_clean c princl pat = if princ_infos.Tactics.farg_in_concl then [c] else [] in + if List.length args + List.length c_list = 0 + then user_err Pp.(str "Cannot recognize a valid functional scheme" ); let encoded_pat_as_patlist = - List.make (List.length args + List.length c_list - 1) None @ [pat] in - List.map2 (fun c pat -> ((None,Ltac_plugin.Tacexpr.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)) )),(None,pat),None)) - (args@c_list) encoded_pat_as_patlist + List.make (List.length args + List.length c_list - 1) None @ [pat] + in + List.map2 + (fun c pat -> + ((None, + Tactics.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)))), + (None,pat), + None)) + (args@c_list) + encoded_pat_as_patlist in let princ' = Some (princ,bindings) in let princ_vars = @@ -214,7 +222,6 @@ let is_rec names = | GCases(_,_,el,brl) -> List.exists (fun (e,_) -> lookup names e) el || List.exists (lookup_br names) brl - | GProj(_,c) -> lookup names c and lookup_br names {CAst.v=(idl,_,rt)} = let new_names = List.fold_right Id.Set.remove idl names in lookup new_names rt @@ -252,7 +259,6 @@ let derive_inversion fix_names = let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident id)) in - let c = EConstr.of_constr c in let (cst, u) = destConst evd c in evd, (cst, EInstance.kind evd u) :: l ) @@ -274,8 +280,7 @@ let derive_inversion fix_names = (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident (mk_rel_id id))) in - let id = EConstr.of_constr id in - evd,(fst (destInd evd id))::l + evd,(fst (destInd evd id))::l ) fix_names (evd',[]) @@ -356,17 +361,17 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error (*i The next call to mk_rel_id is valid since we have just construct the graph Ensures by : do_built i*) - let f_R_mut = CAst.make @@ Ident (mk_rel_id (List.nth names 0)) in + let f_R_mut = qualid_of_ident @@ mk_rel_id (List.nth names 0) in let ind_kn = fst (locate_with_msg - (pr_reference f_R_mut++str ": Not an inductive type!") + (pr_qualid f_R_mut++str ": Not an inductive type!") locate_ind f_R_mut) in let fname_kn (((fname,_),_,_,_,_),_) = - let f_ref = CAst.map (fun n -> Ident n) fname in - locate_with_msg - (pr_reference f_ref++str ": Not an inductive type!") + let f_ref = qualid_of_ident ?loc:fname.CAst.loc fname.CAst.v in + locate_with_msg + (pr_qualid f_ref++str ": Not an inductive type!") locate_constant f_ref in @@ -379,7 +384,8 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error let evd = ref (Evd.from_env env) in let evd',uprinc = Evd.fresh_global env !evd princ in let _ = evd := evd' in - let princ_type = Typing.e_type_of ~refresh:true env evd (EConstr.of_constr uprinc) in + let sigma, princ_type = Typing.type_of ~refresh:true env !evd uprinc in + evd := sigma; let princ_type = EConstr.Unsafe.to_constr princ_type in Functional_principles_types.generate_functional_principle evd @@ -408,7 +414,7 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp ComDefinition.do_definition ~program_mode:false fname - (Decl_kinds.Global,(Flags.is_universe_polymorphism ()),Decl_kinds.Definition) pl + (Decl_kinds.Global,false,Decl_kinds.Definition) pl bl None body (Some ret_type) (Lemmas.mk_hook (fun _ _ -> ())); let evd,rev_pconstants = List.fold_left @@ -416,7 +422,6 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in - let c = EConstr.of_constr c in let (cst, u) = destConst evd c in let u = EInstance.kind evd u in evd,((cst, u) :: l) @@ -426,14 +431,13 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp in evd,List.rev rev_pconstants | _ -> - ComFixpoint.do_fixpoint Global (Flags.is_universe_polymorphism ()) fixpoint_exprl; + ComFixpoint.do_fixpoint Global false fixpoint_exprl; let evd,rev_pconstants = List.fold_left (fun (evd,l) ((({CAst.v=fname},_),_,_,_,_),_) -> let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in - let c = EConstr.of_constr c in let (cst, u) = destConst evd c in let u = EInstance.kind evd u in evd,((cst, u) :: l) @@ -472,7 +476,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas let unbounded_eq = let f_app_args = CAst.make @@ Constrexpr.CAppExpl( - (None,CAst.make @@ Ident fname,None) , + (None,qualid_of_ident fname,None) , (List.map (function | {CAst.v=Anonymous} -> assert false @@ -482,7 +486,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas ) ) in - CAst.make @@ Constrexpr.CApp ((None,Constrexpr_ops.mkRefC (CAst.make @@ Qualid (qualid_of_string "Logic.eq"))), + CAst.make @@ Constrexpr.CApp ((None,Constrexpr_ops.mkRefC (qualid_of_string "Logic.eq")), [(f_app_args,None);(body,None)]) in let eq = Constrexpr_ops.mkCProdN args unbounded_eq in @@ -539,9 +543,9 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas | None -> let ltof = let make_dir l = DirPath.make (List.rev_map Id.of_string l) in - CAst.make @@ Libnames.Qualid (Libnames.qualid_of_path - (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof"))) - in + Libnames.qualid_of_path + (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof")) + in let fun_from_mes = let applied_mes = Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC wf_arg]) in @@ -722,12 +726,10 @@ let do_generate_principle pconstants on_error register_built interactive_proof () let rec add_args id new_args = CAst.map (function - | CRef (r,_) as b -> - begin match r with - | {CAst.v=Libnames.Ident fname} when Id.equal fname id -> - CAppExpl((None,r,None),new_args) - | _ -> b - end + | CRef (qid,_) as b -> + if qualid_is_ident qid && Id.equal (qualid_basename qid) id then + CAppExpl((None,qid,None),new_args) + else b | CFix _ | CCoFix _ -> anomaly ~label:"add_args " (Pp.str "todo.") | CProdN(nal,b1) -> CProdN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) @@ -741,13 +743,10 @@ let rec add_args id new_args = CAst.map (function add_args id new_args b1) | CLetIn(na,b1,t,b2) -> CLetIn(na,add_args id new_args b1,Option.map (add_args id new_args) t,add_args id new_args b2) - | CAppExpl((pf,r,us),exprl) -> - begin - match r with - | {CAst.v=Libnames.Ident fname} when Id.equal fname id -> - CAppExpl((pf,r,us),new_args@(List.map (add_args id new_args) exprl)) - | _ -> CAppExpl((pf,r,us),List.map (add_args id new_args) exprl) - end + | CAppExpl((pf,qid,us),exprl) -> + if qualid_is_ident qid && Id.equal (qualid_basename qid) id then + CAppExpl((pf,qid,us),new_args@(List.map (add_args id new_args) exprl)) + else CAppExpl((pf,qid,us),List.map (add_args id new_args) exprl) | CApp((pf,b),bl) -> CApp((pf,add_args id new_args b), List.map (fun (e,o) -> add_args id new_args e,o) bl) @@ -777,13 +776,12 @@ let rec add_args id new_args = CAst.map (function | CSort _ as b -> b | CCast(b1,b2) -> CCast(add_args id new_args b1, - Miscops.map_cast_type (add_args id new_args) b2) + Glob_ops.map_cast_type (add_args id new_args) b2) | CRecord pars -> CRecord (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.") | CDelimiters _ -> anomaly ~label:"add_args " (Pp.str "CDelimiters.") - | CProj _ -> user_err Pp.(str "Funind does not support primitive projections") ) exception Stop of Constrexpr.constr_expr @@ -842,7 +840,7 @@ let rec get_args b t : Constrexpr.local_binder_expr list * | _ -> [],b,t -let make_graph (f_ref:global_reference) = +let make_graph (f_ref : GlobRef.t) = let c,c_body = match f_ref with | ConstRef c -> @@ -883,7 +881,7 @@ let make_graph (f_ref:global_reference) = | Constrexpr.CLocalAssum (nal,_,_) -> List.map (fun {CAst.loc;v=n} -> CAst.make ?loc @@ - CRef(CAst.make ?loc @@ Libnames.Ident(Nameops.Name.get_id n),None)) + CRef(Libnames.qualid_of_ident ?loc @@ Nameops.Name.get_id n,None)) nal | Constrexpr.CLocalPattern _ -> assert false ) @@ -900,11 +898,11 @@ let make_graph (f_ref:global_reference) = let id = Label.to_id (Constant.label c) in [((CAst.make id,None),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]] in - let mp,dp,_ = Constant.repr3 c in + let mp = Constant.modpath c in do_generate_principle [c,Univ.Instance.empty] error_error false false expr_list; (* We register the infos *) List.iter - (fun ((({CAst.v=id},_),_,_,_,_),_) -> add_Function false (Constant.make3 mp dp (Label.of_id id))) + (fun ((({CAst.v=id},_),_,_,_,_),_) -> add_Function false (Constant.make2 mp (Label.of_id id))) expr_list) let do_generate_principle = do_generate_principle [] warning_error true diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index dcc1c2ea6a..f209fb19fd 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -1,4 +1,5 @@ -open Misctypes +open Names +open Tactypes val warn_cannot_define_graph : ?loc:Loc.t -> Pp.t * Pp.t -> unit @@ -18,4 +19,4 @@ val functional_induction : Goal.goal Evd.sigma -> Goal.goal list Evd.sigma -val make_graph : Globnames.global_reference -> unit +val make_graph : GlobRef.t -> unit diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index a0b9217c75..b68b34ca35 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -27,13 +27,7 @@ let array_get_start a = (Array.length a - 1) (fun i -> a.(i)) -let id_of_name = function - Name id -> id - | _ -> raise Not_found - -let locate ref = - let {CAst.v=qid} = qualid_of_reference ref in - Nametab.locate qid +let locate qid = Nametab.locate qid let locate_ind ref = match locate ref with @@ -107,17 +101,9 @@ let const_of_id id = CErrors.user_err ~hdr:"IndFun.const_of_id" (str "cannot find " ++ Id.print id) -let def_of_const t = - match Constr.kind t with - Term.Const sp -> - (try (match Environ.constant_opt_value_in (Global.env()) sp with - | Some c -> c - | _ -> assert false) - with Not_found -> assert false) - |_ -> assert false - +[@@@ocaml.warning "-3"] let coq_constant s = - Universes.constr_of_global @@ + UnivGen.constr_of_monomorphic_global @@ Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules s;; @@ -161,17 +147,6 @@ let save with_clean id const (locality,_,kind) hook = CEphemeron.iter_opt hook (fun f -> Lemmas.call_hook fix_exn f l r); definition_message id - - -let cook_proof _ = - let (id,(entry,_,strength)) = Pfedit.cook_proof () in - (id,(entry,strength)) - -let get_proof_clean do_reduce = - let result = cook_proof do_reduce in - Proof_global.discard_current (); - result - let with_full_print f a = let old_implicit_args = Impargs.is_implicit_args () and old_strict_implicit_args = Impargs.is_strict_implicit_args () @@ -269,12 +244,12 @@ let subst_Function (subst,finfos) = in let function_constant' = do_subst_con finfos.function_constant in let graph_ind' = do_subst_ind finfos.graph_ind in - let equation_lemma' = Option.smartmap do_subst_con finfos.equation_lemma in - let correctness_lemma' = Option.smartmap do_subst_con finfos.correctness_lemma in - let completeness_lemma' = Option.smartmap do_subst_con finfos.completeness_lemma in - let rect_lemma' = Option.smartmap do_subst_con finfos.rect_lemma in - let rec_lemma' = Option.smartmap do_subst_con finfos.rec_lemma in - let prop_lemma' = Option.smartmap do_subst_con finfos.prop_lemma in + let equation_lemma' = Option.Smart.map do_subst_con finfos.equation_lemma in + let correctness_lemma' = Option.Smart.map do_subst_con finfos.correctness_lemma in + let completeness_lemma' = Option.Smart.map do_subst_con finfos.completeness_lemma in + let rect_lemma' = Option.Smart.map do_subst_con finfos.rect_lemma in + let rec_lemma' = Option.Smart.map do_subst_con finfos.rec_lemma in + let prop_lemma' = Option.Smart.map do_subst_con finfos.prop_lemma in if function_constant' == finfos.function_constant && graph_ind' == finfos.graph_ind && equation_lemma' == finfos.equation_lemma && @@ -299,36 +274,7 @@ let subst_Function (subst,finfos) = let classify_Function infos = Libobject.Substitute infos -let discharge_Function (_,finfos) = - let function_constant' = Lib.discharge_con finfos.function_constant - and graph_ind' = Lib.discharge_inductive finfos.graph_ind - and equation_lemma' = Option.smartmap Lib.discharge_con finfos.equation_lemma - and correctness_lemma' = Option.smartmap Lib.discharge_con finfos.correctness_lemma - and completeness_lemma' = Option.smartmap Lib.discharge_con finfos.completeness_lemma - and rect_lemma' = Option.smartmap Lib.discharge_con finfos.rect_lemma - and rec_lemma' = Option.smartmap Lib.discharge_con finfos.rec_lemma - and prop_lemma' = Option.smartmap Lib.discharge_con finfos.prop_lemma - in - if function_constant' == finfos.function_constant && - graph_ind' == finfos.graph_ind && - equation_lemma' == finfos.equation_lemma && - correctness_lemma' == finfos.correctness_lemma && - completeness_lemma' == finfos.completeness_lemma && - rect_lemma' == finfos.rect_lemma && - rec_lemma' == finfos.rec_lemma && - prop_lemma' == finfos.prop_lemma - then Some finfos - else - Some { function_constant = function_constant' ; - graph_ind = graph_ind' ; - equation_lemma = equation_lemma' ; - correctness_lemma = correctness_lemma' ; - completeness_lemma = completeness_lemma'; - rect_lemma = rect_lemma'; - rec_lemma = rec_lemma'; - prop_lemma = prop_lemma' ; - is_general = finfos.is_general - } +let discharge_Function (_,finfos) = Some finfos let pr_ocst c = let sigma, env = Pfedit.get_current_context () in @@ -341,7 +287,7 @@ let pr_info f_info = str "function_constant_type := " ++ (try Printer.pr_lconstr_env env sigma - (fst (Global.type_of_global_in_context env (ConstRef f_info.function_constant))) + (fst (Typeops.type_of_global_in_context env (ConstRef f_info.function_constant))) 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 () ++ @@ -471,16 +417,16 @@ let jmeq () = try Coqlib.check_required_library Coqlib.jmeq_module_name; EConstr.of_constr @@ - Universes.constr_of_global @@ - Coqlib.coq_reference "Function" ["Logic";"JMeq"] "JMeq" + UnivGen.constr_of_monomorphic_global @@ + Coqlib.lib_ref "core.JMeq.type" with e when CErrors.noncritical e -> raise (ToShow e) let jmeq_refl () = try Coqlib.check_required_library Coqlib.jmeq_module_name; EConstr.of_constr @@ - Universes.constr_of_global @@ - Coqlib.coq_reference "Function" ["Logic";"JMeq"] "JMeq_refl" + UnivGen.constr_of_monomorphic_global @@ + Coqlib.lib_ref "core.JMeq.refl" with e when CErrors.noncritical e -> raise (ToShow e) let h_intros l = @@ -492,8 +438,10 @@ let well_founded = function () -> EConstr.of_constr (coq_constant "well_founded" let acc_rel = function () -> EConstr.of_constr (coq_constant "Acc") let acc_inv_id = function () -> EConstr.of_constr (coq_constant "Acc_inv") -let well_founded_ltof () = EConstr.of_constr @@ Universes.constr_of_global @@ - Coqlib.coq_reference "" ["Arith";"Wf_nat"] "well_founded_ltof" +[@@@ocaml.warning "-3"] +let well_founded_ltof () = EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global @@ + Coqlib.find_reference "IndFun" ["Coq"; "Arith";"Wf_nat"] "well_founded_ltof" +[@@@ocaml.warning "+3"] let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 5cc7163aa3..c9d153d89f 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -18,13 +18,11 @@ val get_name : Id.t list -> ?default:string -> Name.t -> Name.t val array_get_start : 'a array -> 'a array -val id_of_name : Name.t -> Id.t - -val locate_ind : Libnames.reference -> inductive -val locate_constant : Libnames.reference -> Constant.t +val locate_ind : Libnames.qualid -> inductive +val locate_constant : Libnames.qualid -> Constant.t val locate_with_msg : - Pp.t -> (Libnames.reference -> 'a) -> - Libnames.reference -> 'a + Pp.t -> (Libnames.qualid -> 'a) -> + Libnames.qualid -> 'a val filter_map : ('a -> bool) -> ('a -> 'b) -> 'a list -> 'b list val list_union_eq : @@ -38,24 +36,14 @@ val chop_rlambda_n : int -> Glob_term.glob_constr -> val chop_rprod_n : int -> Glob_term.glob_constr -> (Name.t*Glob_term.glob_constr) list * Glob_term.glob_constr -val def_of_const : Constr.t -> Constr.t val eq : EConstr.constr Lazy.t val refl_equal : EConstr.constr Lazy.t -val const_of_id: Id.t -> Globnames.global_reference(* constantyes *) +val const_of_id: Id.t -> GlobRef.t(* constantyes *) val jmeq : unit -> EConstr.constr val jmeq_refl : unit -> EConstr.constr val save : bool -> Id.t -> Safe_typing.private_constants Entries.definition_entry -> Decl_kinds.goal_kind -> - unit Lemmas.declaration_hook CEphemeron.key -> unit - -(* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and - abort the proof -*) -val get_proof_clean : bool -> - Names.Id.t * - (Safe_typing.private_constants Entries.definition_entry * Decl_kinds.goal_kind) - - + Lemmas.declaration_hook CEphemeron.key -> unit (* [with_full_print f a] applies [f] to [a] in full printing environment. @@ -107,11 +95,11 @@ val h_intros: Names.Id.t list -> Tacmach.tactic val h_id : Names.Id.t val hrec_id : Names.Id.t val acc_inv_id : EConstr.constr Util.delayed -val ltof_ref : Globnames.global_reference Util.delayed +val ltof_ref : GlobRef.t Util.delayed val well_founded_ltof : EConstr.constr Util.delayed val acc_rel : EConstr.constr Util.delayed val well_founded : EConstr.constr Util.delayed -val evaluable_of_global_reference : Globnames.global_reference -> Names.evaluable_global_reference +val evaluable_of_global_reference : GlobRef.t -> Names.evaluable_global_reference val list_rewrite : bool -> (EConstr.constr*bool) list -> Tacmach.tactic val decompose_lam_n : Evd.evar_map -> int -> EConstr.t -> diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 2743a8a2f9..d1a227d517 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -23,7 +23,7 @@ open Tacticals open Tactics open Indfun_common open Tacmach -open Misctypes +open Tactypes open Termops open Context.Rel.Declaration @@ -63,12 +63,6 @@ let observe_tac s tac g = then do_observe_tac (str s) tac g else tac g -(* [nf_zeta] $\zeta$-normalization of a term *) -let nf_zeta = - Reductionops.clos_norm_flags (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 *\) *) @@ -81,10 +75,9 @@ let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl let make_eq () = try - EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq ())) - with _ -> assert false + EConstr.of_constr (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref "core.eq.type")) + with _ -> assert false - (* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. @@ -102,9 +95,9 @@ let generate_type evd g_to_f f graph i = let evd',graph = Evd.fresh_global (Global.env ()) !evd (Globnames.IndRef (fst (destInd !evd graph))) in - let graph = EConstr.of_constr graph in evd:=evd'; - let graph_arity = Typing.e_type_of (Global.env ()) evd graph in + let sigma, graph_arity = Typing.type_of (Global.env ()) !evd graph in + evd := sigma; let ctxt,_ = decompose_prod_assum !evd graph_arity in let fun_ctxt,res_type = match ctxt with @@ -172,7 +165,6 @@ let find_induction_principle evd f = | None -> raise Not_found | Some rect_lemma -> let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (Globnames.ConstRef rect_lemma) in - let rect_lemma = EConstr.of_constr rect_lemma in let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma in evd:=evd'; rect_lemma,typ @@ -221,7 +213,7 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i let mib,_ = Global.lookup_inductive graph_ind in (* and the principle to use in this lemma in $\zeta$ normal form *) let f_principle,princ_type = schemes.(i) in - let princ_type = nf_zeta princ_type in + let princ_type = Reductionops.nf_zeta (Global.env ()) evd princ_type in let princ_infos = Tactics.compute_elim_sig evd princ_type in (* The number of args of the function is then easily computable *) let nb_fun_args = nb_prod (project g) (pf_concl g) - 2 in @@ -240,7 +232,7 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i List.map (fun decl -> List.map - (fun id -> CAst.make @@ IntroNaming (IntroIdentifier id)) + (fun id -> CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (RelDecl.get_type decl))))) ) branches @@ -258,7 +250,7 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i List.fold_right (fun {CAst.v=pat} acc -> match pat with - | IntroNaming (IntroIdentifier id) -> id::acc + | IntroNaming (Namegen.IntroIdentifier id) -> id::acc | _ -> anomaly (Pp.str "Not an identifier.") ) (List.nth intro_pats (pred i)) @@ -352,7 +344,7 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i Locusops.onConcl); observe_tac ("toto ") tclIDTAC; - (* introducing the the result of the graph and the equality hypothesis *) + (* introducing the result of the graph and the equality hypothesis *) observe_tac "introducing" (tclMAP (fun x -> Proofview.V82.of_tactic (Simple.intro x)) [res;hres]); (* replacing [res] with its value *) observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))); @@ -399,7 +391,7 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i List.rev (fst (List.fold_left2 (fun (bindings,avoid) decl p -> let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in - (nf_zeta p)::bindings,id::avoid) + (Reductionops.nf_zeta (pf_env g) (project g) p)::bindings,id::avoid) ([],avoid) princ_infos.predicates (lemmas))) @@ -451,7 +443,7 @@ let generalize_dependent_of x hyp g = 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 + let kn = KerName.make mp (Label.make "tauto") in Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> let body = Tacenv.interp_ltac kn in Tacinterp.eval_tactic body @@ -513,7 +505,7 @@ and intros_with_rewrite_aux : Tacmach.tactic = intros_with_rewrite ] g end - | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_False ())) -> + | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type")) -> Proofview.V82.of_tactic tauto g | Case(_,_,v,_) -> tclTHENLIST[ @@ -632,12 +624,12 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti *) let lemmas = Array.map - (fun (_,(ctxt,concl)) -> nf_zeta (EConstr.it_mkLambda_or_LetIn concl ctxt)) + (fun (_,(ctxt,concl)) -> Reductionops.nf_zeta (pf_env g) (project g) (EConstr.it_mkLambda_or_LetIn concl ctxt)) lemmas_types_infos in (* We get the constant and the principle corresponding to this lemma *) let f = funcs.(i) in - let graph_principle = nf_zeta (EConstr.of_constr schemes.(i)) in + let graph_principle = Reductionops.nf_zeta (pf_env g) (project g) (EConstr.of_constr schemes.(i)) in let princ_type = pf_unsafe_type_of g graph_principle in let princ_infos = Tactics.compute_elim_sig (project g) princ_type in (* Then we get the number of argument of the function @@ -771,8 +763,9 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in graphs_constr.(i) <- graph; let type_of_lemma = EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in - let _ = Typing.e_type_of (Global.env ()) evd type_of_lemma in - let type_of_lemma = nf_zeta type_of_lemma in + let sigma, _ = Typing.type_of (Global.env ()) !evd type_of_lemma in + evd := sigma; + let type_of_lemma = Reductionops.nf_zeta (Global.env ()) !evd type_of_lemma in observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); type_of_lemma,type_info ) @@ -811,20 +804,19 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list let (typ,_) = lemmas_types_infos.(i) in Lemmas.start_proof lem_id - (Decl_kinds.Global,Flags.is_universe_polymorphism (),((Decl_kinds.Proof Decl_kinds.Theorem))) + (Decl_kinds.Global,false,((Decl_kinds.Proof Decl_kinds.Theorem))) !evd typ (Lemmas.mk_hook (fun _ _ -> ())); ignore (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") (proving_tac i)))); - (Lemmas.save_proof (Vernacexpr.(Proved(Transparent,None)))); + (Lemmas.save_proof (Vernacexpr.(Proved(Proof_global.Transparent,None)))); let finfo = find_Function_infos (fst f_as_constant) in (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) let _,lem_cst_constr = Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let lem_cst_constr = EConstr.of_constr lem_cst_constr in - let (lem_cst,_) = destConst !evd lem_cst_constr in + let (lem_cst,_) = destConst !evd lem_cst_constr in update_Function {finfo with correctness_lemma = Some lem_cst}; ) @@ -840,7 +832,7 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list let type_of_lemma = EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in - let type_of_lemma = nf_zeta type_of_lemma in + let type_of_lemma = Reductionops.nf_zeta env !evd type_of_lemma in observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env env !evd type_of_lemma); type_of_lemma,type_info ) @@ -874,18 +866,17 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list i*) let lem_id = mk_complete_id f_id in Lemmas.start_proof lem_id - (Decl_kinds.Global,Flags.is_universe_polymorphism (),(Decl_kinds.Proof Decl_kinds.Theorem)) sigma + (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) sigma (fst lemmas_types_infos.(i)) (Lemmas.mk_hook (fun _ _ -> ())); ignore (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") (proving_tac i)))) ; - (Lemmas.save_proof (Vernacexpr.(Proved(Transparent,None)))); + (Lemmas.save_proof (Vernacexpr.(Proved(Proof_global.Transparent,None)))); let finfo = find_Function_infos (fst f_as_constant) in let _,lem_cst_constr = Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let lem_cst_constr = EConstr.of_constr lem_cst_constr in - let (lem_cst,_) = destConst !evd lem_cst_constr in + let (lem_cst,_) = destConst !evd lem_cst_constr in update_Function {finfo with completeness_lemma = Some lem_cst} ) funs) @@ -969,7 +960,7 @@ let functional_inversion kn hid fconst f_correct : Tacmach.tactic = 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)); + Proofview.V82.of_tactic (Inv.inv Inv.FullInversion None (NamedHyp hid)); (fun g -> let new_ids = List.filter (fun id -> not (Id.Set.mem id old_ids)) (pf_ids_of_hyps g) in tclMAP (revert_graph kn pre_tac) (hid::new_ids) g diff --git a/plugins/funind/invfun.mli b/plugins/funind/invfun.mli index ad306ab257..3ddc609201 100644 --- a/plugins/funind/invfun.mli +++ b/plugins/funind/invfun.mli @@ -9,8 +9,8 @@ (************************************************************************) val invfun : - Misctypes.quantified_hypothesis -> - Globnames.global_reference option -> + Tactypes.quantified_hypothesis -> + Names.GlobRef.t option -> Evar.t Evd.sigma -> Evar.t list Evd.sigma val derive_correctness : (Evd.evar_map ref -> diff --git a/plugins/funind/plugin_base.dune b/plugins/funind/plugin_base.dune new file mode 100644 index 0000000000..002eb28eea --- /dev/null +++ b/plugins/funind/plugin_base.dune @@ -0,0 +1,5 @@ +(library + (name recdef_plugin) + (public_name coq.plugins.recdef) + (synopsis "Coq's functional induction plugin") + (libraries coq.plugins.extraction)) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index fb9ae64bf4..6e5e3f9353 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -24,6 +24,7 @@ open Globnames open Nameops open CErrors open Util +open UnivGen open Tacticals open Tacmach open Tactics @@ -37,7 +38,7 @@ open Glob_term open Pretyping open Termops open Constrintern -open Misctypes +open Tactypes open Genredexpr open Equality @@ -49,11 +50,12 @@ open Context.Rel.Declaration (* Ugly things which should not be here *) -let coq_constant m s = EConstr.of_constr @@ Universes.constr_of_global @@ - Coqlib.coq_reference "RecursiveDefinition" m s +[@@@ocaml.warning "-3"] +let coq_constant m s = EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global @@ + Coqlib.find_reference "RecursiveDefinition" m s -let arith_Nat = ["Arith";"PeanoNat";"Nat"] -let arith_Lt = ["Arith";"Lt"] +let arith_Nat = ["Coq"; "Arith";"PeanoNat";"Nat"] +let arith_Lt = ["Coq"; "Arith";"Lt"] let pr_leconstr_rd = let sigma, env = Pfedit.get_current_context () in @@ -61,8 +63,9 @@ let pr_leconstr_rd = let coq_init_constant s = EConstr.of_constr ( - Universes.constr_of_global @@ + UnivGen.constr_of_monomorphic_global @@ Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules s) +[@@@ocaml.warning "+3"] let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in @@ -72,7 +75,7 @@ let declare_fun f_id kind ?univs value = let ce = definition_entry ?univs value (*FIXME *) in ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; -let defined () = Lemmas.save_proof (Vernacexpr.(Proved (Transparent,None))) +let defined () = Lemmas.save_proof (Vernacexpr.(Proved (Proof_global.Transparent,None))) let def_of_const t = match (Constr.kind t) with @@ -94,30 +97,12 @@ let type_of_const sigma t = Typeops.type_of_constant_in (Global.env()) (sp, u) |_ -> assert false -let constr_of_global x = - fst (Global.constr_of_global_in_context (Global.env ()) x) - -let constant sl s = constr_of_global (find_reference sl s) +let constant sl s = UnivGen.constr_of_monomorphic_global (find_reference sl s) let const_of_ref = function ConstRef kn -> kn | _ -> anomaly (Pp.str "ConstRef expected.") - -let nf_zeta env = - Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - env - Evd.empty - - -let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) - Reductionops.clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty - - - - - - (* Generic values *) let pf_get_new_ids idl g = let ids = pf_ids_of_hyps g in @@ -143,6 +128,7 @@ let def_id = Id.of_string "def" let p_id = Id.of_string "p" let rec_res_id = Id.of_string "rec_res";; let lt = function () -> (coq_init_constant "lt") +[@@@ocaml.warning "-3"] let le = function () -> (Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules "le") let ex = function () -> (coq_init_constant "ex") let nat = function () -> (coq_init_constant "nat") @@ -163,7 +149,6 @@ let coq_S = function () -> (coq_init_constant "S") let lt_n_O = function () -> (coq_constant arith_Nat "nlt_0_r") let max_ref = function () -> (find_reference ["Recdef"] "max") let max_constr = function () -> EConstr.of_constr (constr_of_global (delayed_force max_ref)) -let coq_conj = function () -> find_reference Coqlib.logic_module_name "conj" let f_S t = mkApp(delayed_force coq_S, [|t|]);; @@ -181,7 +166,7 @@ let simpl_iter clause = clause (* Others ugly things ... *) -let (value_f: Constr.t list -> global_reference -> Constr.t) = +let (value_f: Constr.t list -> GlobRef.t -> Constr.t) = let open Term in let open Constr in fun al fterm -> @@ -215,7 +200,7 @@ let (value_f: Constr.t list -> global_reference -> Constr.t) = let body = EConstr.Unsafe.to_constr body in it_mkLambda_or_LetIn body context -let (declare_f : Id.t -> logical_kind -> Constr.t list -> global_reference -> global_reference) = +let (declare_f : Id.t -> logical_kind -> Constr.t list -> GlobRef.t -> GlobRef.t) = fun f_id kind input_type fterm_ref -> declare_fun f_id kind (value_f input_type fterm_ref);; @@ -356,7 +341,7 @@ type 'a infos = f_id : Id.t; (* function name *) f_constr : constr; (* function term *) f_terminate : constr; (* termination proof term *) - func : global_reference; (* functional reference *) + func : GlobRef.t; (* functional reference *) info : 'a; is_main_branch : bool; (* on the main branch or on a matched expression *) is_final : bool; (* final first order term or not *) @@ -713,7 +698,7 @@ let mkDestructEq : observe_tclTHENLIST (str "mkDestructEq") [Proofview.V82.of_tactic (generalize new_hyps); (fun g2 -> - let changefun patvars sigma = + let changefun patvars env sigma = pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2) in Proofview.V82.of_tactic (change_in_concl None changefun) g2); @@ -747,7 +732,7 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = with | UserError(Some "Refiner.thensn_tac3",_) | UserError(Some "Refiner.tclFAIL_s",_) -> - (observe_tac (str "is computable " ++ Printer.pr_leconstr_env (pf_env g) sigma new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} ) + (observe_tac (str "is computable " ++ Printer.pr_leconstr_env (pf_env g) sigma new_info.info) (next_step continuation_tac {new_info with info = Reductionops.nf_betaiotazeta (pf_env g) sigma new_info.info} ) )) g @@ -1152,7 +1137,7 @@ let termination_proof_header is_mes input_type ids args_id relation tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (Proofview.V82.of_tactic (clear [id]))) )) ; - observe_tac (str "fix") (Proofview.V82.of_tactic (fix (Some hrec) (nargs+1))); + observe_tac (str "fix") (Proofview.V82.of_tactic (fix 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) @@ -1241,8 +1226,8 @@ let get_current_subgoals_types () = exception EmptySubgoals let build_and_l sigma l = - let and_constr = Universes.constr_of_global @@ Coqlib.build_coq_and () in - let conj_constr = coq_conj () in + let and_constr = UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.and.type" in + let conj_constr = Coqlib.build_coq_conj () in let mk_and p1 p2 = mkApp(EConstr.of_constr and_constr,[|p1;p2|]) in let rec is_well_founded t = @@ -1306,9 +1291,9 @@ let build_new_goal_type () = let is_opaque_constant c = let cb = Global.lookup_constant c in match cb.Declarations.const_body with - | Declarations.OpaqueDef _ -> Vernacexpr.Opaque - | Declarations.Undef _ -> Vernacexpr.Opaque - | Declarations.Def _ -> Vernacexpr.Transparent + | Declarations.OpaqueDef _ -> Proof_global.Opaque + | Declarations.Undef _ -> Proof_global.Opaque + | Declarations.Def _ -> Proof_global.Transparent let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) @@ -1318,14 +1303,14 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp | None -> try add_suffix current_proof_name "_subproof" with e when CErrors.noncritical e -> - anomaly (Pp.str "open_new_goal with an unamed theorem.") + anomaly (Pp.str "open_new_goal with an unnamed theorem.") in let na = next_global_ident_away name Id.Set.empty in if Termops.occur_existential sigma gls_type then CErrors.user_err Pp.(str "\"abstract\" cannot handle existentials"); let hook _ _ = let opacity = - let na_ref = CAst.make @@ Libnames.Ident na in + let na_ref = qualid_of_ident na in let na_global = Smartlocate.global_with_alias na_ref in match na_global with ConstRef c -> is_opaque_constant c @@ -1374,7 +1359,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp Eauto.eauto_with_bases (true,5) [(fun _ sigma -> (sigma, (Lazy.force refl_equal)))] - [Hints.Hint_db.empty empty_transparent_state false] + [Hints.Hint_db.empty TransparentState.empty false] ] ) ) @@ -1456,7 +1441,7 @@ let com_terminate -let start_equation (f:global_reference) (term_f:global_reference) +let start_equation (f:GlobRef.t) (term_f:GlobRef.t) (cont_tactic:Id.t list -> tactic) g = let sigma = project g in let ids = pf_ids_of_hyps g in @@ -1473,7 +1458,7 @@ let start_equation (f:global_reference) (term_f:global_reference) observe_tac (str "prove_eq") (cont_tactic x)]) g;; let (com_eqn : int -> Id.t -> - global_reference -> global_reference -> global_reference + GlobRef.t -> GlobRef.t -> GlobRef.t -> Constr.t -> unit) = fun nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type -> let open CVars in @@ -1533,19 +1518,17 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let env = Global.env() in let evd = Evd.from_env env in let evd, function_type = interp_type_evars env evd type_of_f in - let function_type = EConstr.Unsafe.to_constr function_type in - let env = push_named (Context.Named.Declaration.LocalAssum (function_name,function_type)) env in + let env = EConstr.push_named (Context.Named.Declaration.LocalAssum (function_name,function_type)) env in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) let evd, ty = interp_type_evars env evd ~impls:rec_impls eq in - let ty = EConstr.Unsafe.to_constr ty in - let evd, nf = Evarutil.nf_evars_and_universes evd in - let equation_lemma_type = nf_betaiotazeta (EConstr.of_constr (nf ty)) in - let function_type = nf function_type in + let evd = Evd.minimize_universes evd in + let equation_lemma_type = Reductionops.nf_betaiotazeta env evd (Evarutil.nf_evar evd ty) in + let function_type = EConstr.to_constr ~abort_on_undefined_evars:false evd function_type in let equation_lemma_type = EConstr.Unsafe.to_constr equation_lemma_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) -> LocalAssum (x,y)) res_vars) env in - let eq' = nf_zeta env_eq' (EConstr.of_constr eq') in + let eq' = Reductionops.nf_zeta env_eq' evd (EConstr.of_constr eq') in let eq' = EConstr.Unsafe.to_constr 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'); *) @@ -1579,7 +1562,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let hook _ _ = let term_ref = Nametab.locate (qualid_of_ident term_id) in let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in - let _ = Extraction_plugin.Table.extraction_inline true [CAst.make @@ Ident term_id] in + let _ = Extraction_plugin.Table.extraction_inline true [qualid_of_ident 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); diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index b95d64ce9e..549f1fc0e4 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -14,6 +14,6 @@ bool -> int -> Constrexpr.constr_expr -> (pconstant -> Indfun_common.tcc_lemma_value ref -> pconstant -> - pconstant -> int -> EConstr.types -> int -> EConstr.constr -> 'a) -> Constrexpr.constr_expr list -> unit + pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) -> Constrexpr.constr_expr list -> unit diff --git a/plugins/ltac/coretactics.ml4 b/plugins/ltac/coretactics.mlg index 931633e1a8..d9338f0421 100644 --- a/plugins/ltac/coretactics.ml4 +++ b/plugins/ltac/coretactics.mlg @@ -8,155 +8,165 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Util open Locus -open Misctypes +open Tactypes open Genredexpr open Stdarg open Extraargs +open Tacarg open Names +open Logic + +let wit_hyp = wit_var + +} DECLARE PLUGIN "ltac_plugin" (** Basic tactics *) TACTIC EXTEND reflexivity - [ "reflexivity" ] -> [ Tactics.intros_reflexivity ] +| [ "reflexivity" ] -> { Tactics.intros_reflexivity } END TACTIC EXTEND exact - [ "exact" casted_constr(c) ] -> [ Tactics.exact_no_check c ] +| [ "exact" casted_constr(c) ] -> { Tactics.exact_no_check c } END TACTIC EXTEND assumption - [ "assumption" ] -> [ Tactics.assumption ] +| [ "assumption" ] -> { Tactics.assumption } END TACTIC EXTEND etransitivity - [ "etransitivity" ] -> [ Tactics.intros_transitivity None ] +| [ "etransitivity" ] -> { Tactics.intros_transitivity None } END TACTIC EXTEND cut - [ "cut" constr(c) ] -> [ Tactics.cut c ] +| [ "cut" constr(c) ] -> { Tactics.cut c } END TACTIC EXTEND exact_no_check - [ "exact_no_check" constr(c) ] -> [ Tactics.exact_no_check c ] +| [ "exact_no_check" constr(c) ] -> { Tactics.exact_no_check c } END TACTIC EXTEND vm_cast_no_check - [ "vm_cast_no_check" constr(c) ] -> [ Tactics.vm_cast_no_check c ] +| [ "vm_cast_no_check" constr(c) ] -> { Tactics.vm_cast_no_check c } END TACTIC EXTEND native_cast_no_check - [ "native_cast_no_check" constr(c) ] -> [ Tactics.native_cast_no_check c ] +| [ "native_cast_no_check" constr(c) ] -> { Tactics.native_cast_no_check c } END TACTIC EXTEND casetype - [ "casetype" constr(c) ] -> [ Tactics.case_type c ] +| [ "casetype" constr(c) ] -> { Tactics.case_type c } END TACTIC EXTEND elimtype - [ "elimtype" constr(c) ] -> [ Tactics.elim_type c ] +| [ "elimtype" constr(c) ] -> { Tactics.elim_type c } END TACTIC EXTEND lapply - [ "lapply" constr(c) ] -> [ Tactics.cut_and_apply c ] +| [ "lapply" constr(c) ] -> { Tactics.cut_and_apply c } END TACTIC EXTEND transitivity - [ "transitivity" constr(c) ] -> [ Tactics.intros_transitivity (Some c) ] +| [ "transitivity" constr(c) ] -> { Tactics.intros_transitivity (Some c) } END (** Left *) TACTIC EXTEND left - [ "left" ] -> [ Tactics.left_with_bindings false NoBindings ] +| [ "left" ] -> { Tactics.left_with_bindings false NoBindings } END TACTIC EXTEND eleft - [ "eleft" ] -> [ Tactics.left_with_bindings true NoBindings ] +| [ "eleft" ] -> { Tactics.left_with_bindings true NoBindings } END TACTIC EXTEND left_with - [ "left" "with" bindings(bl) ] -> [ +| [ "left" "with" bindings(bl) ] -> { Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.left_with_bindings false bl) - ] + } END TACTIC EXTEND eleft_with - [ "eleft" "with" bindings(bl) ] -> [ +| [ "eleft" "with" bindings(bl) ] -> { Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.left_with_bindings true bl) - ] + } END (** Right *) TACTIC EXTEND right - [ "right" ] -> [ Tactics.right_with_bindings false NoBindings ] +| [ "right" ] -> { Tactics.right_with_bindings false NoBindings } END TACTIC EXTEND eright - [ "eright" ] -> [ Tactics.right_with_bindings true NoBindings ] +| [ "eright" ] -> { Tactics.right_with_bindings true NoBindings } END TACTIC EXTEND right_with - [ "right" "with" bindings(bl) ] -> [ +| [ "right" "with" bindings(bl) ] -> { Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.right_with_bindings false bl) - ] + } END TACTIC EXTEND eright_with - [ "eright" "with" bindings(bl) ] -> [ +| [ "eright" "with" bindings(bl) ] -> { Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.right_with_bindings true bl) - ] + } END (** Constructor *) TACTIC EXTEND constructor - [ "constructor" ] -> [ Tactics.any_constructor false None ] -| [ "constructor" int_or_var(i) ] -> [ +| [ "constructor" ] -> { Tactics.any_constructor false None } +| [ "constructor" int_or_var(i) ] -> { Tactics.constructor_tac false None i NoBindings - ] -| [ "constructor" int_or_var(i) "with" bindings(bl) ] -> [ + } +| [ "constructor" int_or_var(i) "with" bindings(bl) ] -> { let tac bl = Tactics.constructor_tac false None i bl in Tacticals.New.tclDELAYEDWITHHOLES false bl tac - ] + } END TACTIC EXTEND econstructor - [ "econstructor" ] -> [ Tactics.any_constructor true None ] -| [ "econstructor" int_or_var(i) ] -> [ +| [ "econstructor" ] -> { Tactics.any_constructor true None } +| [ "econstructor" int_or_var(i) ] -> { Tactics.constructor_tac true None i NoBindings - ] -| [ "econstructor" int_or_var(i) "with" bindings(bl) ] -> [ + } +| [ "econstructor" int_or_var(i) "with" bindings(bl) ] -> { let tac bl = Tactics.constructor_tac true None i bl in Tacticals.New.tclDELAYEDWITHHOLES true bl tac - ] + } END (** Specialize *) TACTIC EXTEND specialize - [ "specialize" constr_with_bindings(c) ] -> [ +| [ "specialize" constr_with_bindings(c) ] -> { Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> Tactics.specialize c None) - ] -| [ "specialize" constr_with_bindings(c) "as" intropattern(ipat) ] -> [ + } +| [ "specialize" constr_with_bindings(c) "as" intropattern(ipat) ] -> { Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> Tactics.specialize c (Some ipat)) - ] + } END TACTIC EXTEND symmetry - [ "symmetry" ] -> [ Tactics.intros_symmetry {onhyps=Some[];concl_occs=AllOccurrences} ] +| [ "symmetry" ] -> { Tactics.intros_symmetry {onhyps=Some[];concl_occs=AllOccurrences} } END TACTIC EXTEND symmetry_in -| [ "symmetry" "in" in_clause(cl) ] -> [ Tactics.intros_symmetry cl ] +| [ "symmetry" "in" in_clause(cl) ] -> { Tactics.intros_symmetry cl } END (** Split *) +{ + let rec delayed_list = function | [] -> fun _ sigma -> (sigma, []) | x :: l -> @@ -165,155 +175,165 @@ let rec delayed_list = function let (sigma, l) = delayed_list l env sigma in (sigma, x :: l) +} + TACTIC EXTEND split - [ "split" ] -> [ Tactics.split_with_bindings false [NoBindings] ] +| [ "split" ] -> { Tactics.split_with_bindings false [NoBindings] } END TACTIC EXTEND esplit - [ "esplit" ] -> [ Tactics.split_with_bindings true [NoBindings] ] +| [ "esplit" ] -> { Tactics.split_with_bindings true [NoBindings] } END TACTIC EXTEND split_with - [ "split" "with" bindings(bl) ] -> [ +| [ "split" "with" bindings(bl) ] -> { Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.split_with_bindings false [bl]) - ] + } END TACTIC EXTEND esplit_with - [ "esplit" "with" bindings(bl) ] -> [ +| [ "esplit" "with" bindings(bl) ] -> { Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.split_with_bindings true [bl]) - ] + } END TACTIC EXTEND exists - [ "exists" ] -> [ Tactics.split_with_bindings false [NoBindings] ] -| [ "exists" ne_bindings_list_sep(bll, ",") ] -> [ +| [ "exists" ] -> { Tactics.split_with_bindings false [NoBindings] } +| [ "exists" ne_bindings_list_sep(bll, ",") ] -> { Tacticals.New.tclDELAYEDWITHHOLES false (delayed_list bll) (fun bll -> Tactics.split_with_bindings false bll) - ] + } END TACTIC EXTEND eexists - [ "eexists" ] -> [ Tactics.split_with_bindings true [NoBindings] ] -| [ "eexists" ne_bindings_list_sep(bll, ",") ] -> [ +| [ "eexists" ] -> { Tactics.split_with_bindings true [NoBindings] } +| [ "eexists" ne_bindings_list_sep(bll, ",") ] -> { Tacticals.New.tclDELAYEDWITHHOLES true (delayed_list bll) (fun bll -> Tactics.split_with_bindings true bll) - ] + } END (** Intro *) TACTIC EXTEND intros_until - [ "intros" "until" quantified_hypothesis(h) ] -> [ Tactics.intros_until h ] +| [ "intros" "until" quantified_hypothesis(h) ] -> { Tactics.intros_until h } END TACTIC EXTEND intro -| [ "intro" ] -> [ Tactics.intro_move None MoveLast ] -| [ "intro" ident(id) ] -> [ Tactics.intro_move (Some id) MoveLast ] -| [ "intro" ident(id) "at" "top" ] -> [ Tactics.intro_move (Some id) MoveFirst ] -| [ "intro" ident(id) "at" "bottom" ] -> [ Tactics.intro_move (Some id) MoveLast ] -| [ "intro" ident(id) "after" hyp(h) ] -> [ Tactics.intro_move (Some id) (MoveAfter h) ] -| [ "intro" ident(id) "before" hyp(h) ] -> [ Tactics.intro_move (Some id) (MoveBefore h) ] -| [ "intro" "at" "top" ] -> [ Tactics.intro_move None MoveFirst ] -| [ "intro" "at" "bottom" ] -> [ Tactics.intro_move None MoveLast ] -| [ "intro" "after" hyp(h) ] -> [ Tactics.intro_move None (MoveAfter h) ] -| [ "intro" "before" hyp(h) ] -> [ Tactics.intro_move None (MoveBefore h) ] +| [ "intro" ] -> { Tactics.intro_move None MoveLast } +| [ "intro" ident(id) ] -> { Tactics.intro_move (Some id) MoveLast } +| [ "intro" ident(id) "at" "top" ] -> { Tactics.intro_move (Some id) MoveFirst } +| [ "intro" ident(id) "at" "bottom" ] -> { Tactics.intro_move (Some id) MoveLast } +| [ "intro" ident(id) "after" hyp(h) ] -> { Tactics.intro_move (Some id) (MoveAfter h) } +| [ "intro" ident(id) "before" hyp(h) ] -> { Tactics.intro_move (Some id) (MoveBefore h) } +| [ "intro" "at" "top" ] -> { Tactics.intro_move None MoveFirst } +| [ "intro" "at" "bottom" ] -> { Tactics.intro_move None MoveLast } +| [ "intro" "after" hyp(h) ] -> { Tactics.intro_move None (MoveAfter h) } +| [ "intro" "before" hyp(h) ] -> { Tactics.intro_move None (MoveBefore h) } END (** Move *) TACTIC EXTEND move - [ "move" hyp(id) "at" "top" ] -> [ Tactics.move_hyp id MoveFirst ] -| [ "move" hyp(id) "at" "bottom" ] -> [ Tactics.move_hyp id MoveLast ] -| [ "move" hyp(id) "after" hyp(h) ] -> [ Tactics.move_hyp id (MoveAfter h) ] -| [ "move" hyp(id) "before" hyp(h) ] -> [ Tactics.move_hyp id (MoveBefore h) ] +| [ "move" hyp(id) "at" "top" ] -> { Tactics.move_hyp id MoveFirst } +| [ "move" hyp(id) "at" "bottom" ] -> { Tactics.move_hyp id MoveLast } +| [ "move" hyp(id) "after" hyp(h) ] -> { Tactics.move_hyp id (MoveAfter h) } +| [ "move" hyp(id) "before" hyp(h) ] -> { Tactics.move_hyp id (MoveBefore h) } END (** Rename *) TACTIC EXTEND rename -| [ "rename" ne_rename_list_sep(ids, ",") ] -> [ Tactics.rename_hyp ids ] +| [ "rename" ne_rename_list_sep(ids, ",") ] -> { Tactics.rename_hyp ids } END (** Revert *) TACTIC EXTEND revert - [ "revert" ne_hyp_list(hl) ] -> [ Tactics.revert hl ] +| [ "revert" ne_hyp_list(hl) ] -> { Tactics.revert hl } END (** Simple induction / destruct *) +{ + let simple_induct h = Tacticals.New.tclTHEN (Tactics.intros_until h) (Tacticals.New.onLastHyp Tactics.simplest_elim) +} + TACTIC EXTEND simple_induction - [ "simple" "induction" quantified_hypothesis(h) ] -> [ simple_induct h ] +| [ "simple" "induction" quantified_hypothesis(h) ] -> { simple_induct h } END +{ + let simple_destruct h = Tacticals.New.tclTHEN (Tactics.intros_until h) (Tacticals.New.onLastHyp Tactics.simplest_case) +} + TACTIC EXTEND simple_destruct - [ "simple" "destruct" quantified_hypothesis(h) ] -> [ simple_destruct h ] +| [ "simple" "destruct" quantified_hypothesis(h) ] -> { simple_destruct h } END (** Double induction *) TACTIC EXTEND double_induction - [ "double" "induction" quantified_hypothesis(h1) quantified_hypothesis(h2) ] -> - [ Elim.h_double_induction h1 h2 ] +| [ "double" "induction" quantified_hypothesis(h1) quantified_hypothesis(h2) ] -> + { Elim.h_double_induction h1 h2 } END (* Admit *) TACTIC EXTEND admit - [ "admit" ] -> [ Proofview.give_up ] +|[ "admit" ] -> { Proofview.give_up } END (* Fix *) TACTIC EXTEND fix - [ "fix" natural(n) ] -> [ Tactics.fix None n ] -| [ "fix" ident(id) natural(n) ] -> [ Tactics.fix (Some id) n ] +| [ "fix" ident(id) natural(n) ] -> { Tactics.fix id n } END (* Cofix *) TACTIC EXTEND cofix - [ "cofix" ] -> [ Tactics.cofix None ] -| [ "cofix" ident(id) ] -> [ Tactics.cofix (Some id) ] +| [ "cofix" ident(id) ] -> { Tactics.cofix id } END (* Clear *) TACTIC EXTEND clear - [ "clear" hyp_list(ids) ] -> [ +| [ "clear" hyp_list(ids) ] -> { if List.is_empty ids then Tactics.keep [] else Tactics.clear ids - ] -| [ "clear" "-" ne_hyp_list(ids) ] -> [ Tactics.keep ids ] + } +| [ "clear" "-" ne_hyp_list(ids) ] -> { Tactics.keep ids } END (* Clearbody *) TACTIC EXTEND clearbody - [ "clearbody" ne_hyp_list(ids) ] -> [ Tactics.clear_body ids ] +| [ "clearbody" ne_hyp_list(ids) ] -> { Tactics.clear_body ids } END (* Generalize dependent *) TACTIC EXTEND generalize_dependent - [ "generalize" "dependent" constr(c) ] -> [ Tactics.generalize_dep c ] +| [ "generalize" "dependent" constr(c) ] -> { Tactics.generalize_dep c } END (* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) +{ + open Tacexpr let initial_atomic () = let nocl = {onhyps=Some[];concl_occs=AllOccurrences} in let iter (s, t) = - let body = TacAtom (Loc.tag t) in + let body = TacAtom (CAst.make t) in Tacenv.register_ltac false false (Names.Id.of_string s) body in let () = List.iter iter @@ -328,7 +348,7 @@ let initial_atomic () = List.iter iter [ "idtac",TacId []; "fail", TacFail(TacLocal,ArgArg 0,[]); - "fresh", TacArg(Loc.tag @@ TacFreshId []) + "fresh", TacArg(CAst.make @@ TacFreshId []) ] let () = Mltop.declare_cache_obj initial_atomic "ltac_plugin" @@ -359,8 +379,10 @@ let initial_tacticals () = let varn n = Reference (ArgVar (CAst.make (idn n))) in let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in List.iter iter [ - "first", TacFun ([Name (idn 0)], TacML (None, (initial_entry "first", [varn 0]))); - "solve", TacFun ([Name (idn 0)], TacML (None, (initial_entry "solve", [varn 0]))); + "first", TacFun ([Name (idn 0)], TacML (CAst.make (initial_entry "first", [varn 0]))); + "solve", TacFun ([Name (idn 0)], TacML (CAst.make (initial_entry "solve", [varn 0]))); ] let () = Mltop.declare_cache_obj initial_tacticals "ltac_plugin" + +} diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index 9382f567b4..b0277e9cc2 100644 --- a/plugins/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -10,7 +10,7 @@ open Util open Names -open Term +open Constr open CErrors open Evar_refiner open Tacmach @@ -52,7 +52,7 @@ let instantiate_tac n c ido = match ido with ConclLocation () -> evar_list sigma (pf_concl gl) | HypLocation (id,hloc) -> - let decl = Environ.lookup_named_val id (Goal.V82.hyps sigma (sig_it gl)) in + let decl = Environ.lookup_named id (pf_env gl) in match hloc with InHyp -> (match decl with @@ -85,23 +85,21 @@ let let_evar name typ = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in - let sigma = ref sigma in - let _ = Typing.e_sort_of env sigma typ in - let sigma = !sigma in + let sigma, _ = Typing.sort_of env sigma typ in let id = match name with | Name.Anonymous -> let id = Namegen.id_of_name_using_hdchar env sigma typ name in Namegen.next_ident_away_in_goal id (Termops.vars_of_env env) | Name.Name id -> id in - let (sigma, evar) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in + let (sigma, evar) = Evarutil.new_evar env sigma ~src ~naming:(Namegen.IntroFresh id) typ in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (Tactics.letin_tac None (Name.Name id) evar None Locusops.nowhere) + (Tactics.pose_tac (Name.Name id) evar) end let hget_evar n = let open EConstr in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in let evl = evar_list sigma concl in diff --git a/plugins/ltac/extraargs.ml4 b/plugins/ltac/extraargs.ml4 deleted file mode 100644 index 702b830342..0000000000 --- a/plugins/ltac/extraargs.ml4 +++ /dev/null @@ -1,411 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Pp -open Genarg -open Stdarg -open Tacarg -open Pcoq.Prim -open Pcoq.Constr -open Names -open Tacmach -open Tacexpr -open Taccoerce -open Tacinterp -open Misctypes -open Locus - -(** Adding scopes for generic arguments not defined through ARGUMENT EXTEND *) - -let create_generic_quotation name e wit = - let inject (loc, v) = Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit) v) in - Tacentries.create_ltac_quotation name inject (e, None) - -let () = create_generic_quotation "integer" Pcoq.Prim.integer Stdarg.wit_int -let () = create_generic_quotation "string" Pcoq.Prim.string Stdarg.wit_string - -let () = create_generic_quotation "ident" Pcoq.Prim.ident Stdarg.wit_ident -let () = create_generic_quotation "reference" Pcoq.Prim.reference Stdarg.wit_ref -let () = create_generic_quotation "uconstr" Pcoq.Constr.lconstr Stdarg.wit_uconstr -let () = create_generic_quotation "constr" Pcoq.Constr.lconstr Stdarg.wit_constr -let () = create_generic_quotation "ipattern" Pltac.simple_intropattern Stdarg.wit_intro_pattern -let () = create_generic_quotation "open_constr" Pcoq.Constr.lconstr Stdarg.wit_open_constr -let () = - let inject (loc, v) = Tacexpr.Tacexp v in - Tacentries.create_ltac_quotation "ltac" inject (Pltac.tactic_expr, Some 5) - -(** Backward-compatible tactic notation entry names *) - -let () = - let register name entry = Tacentries.register_tactic_notation_entry name entry in - register "hyp" wit_var; - register "simple_intropattern" wit_intro_pattern; - register "integer" wit_integer; - register "reference" wit_ref; - () - -(* Rewriting orientation *) - -let _ = Metasyntax.add_token_obj "<-" -let _ = Metasyntax.add_token_obj "->" - -let pr_orient _prc _prlc _prt = function - | true -> Pp.mt () - | false -> Pp.str " <-" - -ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient -| [ "->" ] -> [ true ] -| [ "<-" ] -> [ false ] -| [ ] -> [ true ] -END - -let pr_int _ _ _ i = Pp.int i - -let _natural = Pcoq.Prim.natural - -ARGUMENT EXTEND natural TYPED AS int PRINTED BY pr_int -| [ _natural(i) ] -> [ i ] -END - -let pr_orient = pr_orient () () () - - -let pr_int_list = Pp.pr_sequence Pp.int -let pr_int_list_full _prc _prlc _prt l = pr_int_list l - -let pr_occurrences _prc _prlc _prt l = - match l with - | ArgArg x -> pr_int_list x - | ArgVar { CAst.loc = loc; v=id } -> Id.print id - -let occurrences_of = function - | [] -> NoOccurrences - | n::_ as nl when n < 0 -> AllOccurrencesBut (List.map abs nl) - | nl -> - if List.exists (fun n -> n < 0) nl then - CErrors.user_err Pp.(str "Illegal negative occurrence number."); - OnlyOccurrences nl - -let coerce_to_int v = match Value.to_int v with - | None -> raise (CannotCoerceTo "an integer") - | Some n -> n - -let int_list_of_VList v = match Value.to_list v with -| Some l -> List.map (fun n -> coerce_to_int n) l -| _ -> raise (CannotCoerceTo "an integer") - -let interp_occs ist gl l = - match l with - | ArgArg x -> x - | ArgVar ({ CAst.v = id } as locid) -> - (try int_list_of_VList (Id.Map.find id ist.lfun) - with Not_found | CannotCoerceTo _ -> [interp_int ist locid]) -let interp_occs ist gl l = - Tacmach.project gl , interp_occs ist gl l - -let glob_occs ist l = l - -let subst_occs evm l = l - -ARGUMENT EXTEND occurrences - TYPED AS int list - PRINTED BY pr_int_list_full - - INTERPRETED BY interp_occs - GLOBALIZED BY glob_occs - SUBSTITUTED BY subst_occs - - RAW_PRINTED BY pr_occurrences - GLOB_PRINTED BY pr_occurrences - -| [ ne_integer_list(l) ] -> [ ArgArg l ] -| [ var(id) ] -> [ ArgVar id ] -END - -let pr_occurrences = pr_occurrences () () () - -let pr_gen prc _prlc _prtac c = prc c - -let pr_globc _prc _prlc _prtac (_,glob) = - let _, env = Pfedit.get_current_context () in - Printer.pr_glob_constr_env env glob - -let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t) - -let glob_glob = Tacintern.intern_constr - -let pr_lconstr _ prc _ c = prc c - -let subst_glob = Tacsubst.subst_glob_constr_and_expr - -ARGUMENT EXTEND glob - PRINTED BY pr_globc - - INTERPRETED BY interp_glob - GLOBALIZED BY glob_glob - SUBSTITUTED BY subst_glob - - RAW_PRINTED BY pr_gen - GLOB_PRINTED BY pr_gen - [ constr(c) ] -> [ c ] -END - -let l_constr = Pcoq.Constr.lconstr - -ARGUMENT EXTEND lconstr - TYPED AS constr - PRINTED BY pr_lconstr - [ l_constr(c) ] -> [ c ] -END - -ARGUMENT EXTEND lglob - TYPED AS glob - PRINTED BY pr_globc - - INTERPRETED BY interp_glob - GLOBALIZED BY glob_glob - SUBSTITUTED BY subst_glob - - RAW_PRINTED BY pr_gen - GLOB_PRINTED BY pr_gen - [ lconstr(c) ] -> [ c ] -END - -let interp_casted_constr ist gl c = - interp_constr_gen (Pretyping.OfType (pf_concl gl)) ist (pf_env gl) (project gl) c - -ARGUMENT EXTEND casted_constr - TYPED AS constr - PRINTED BY pr_gen - INTERPRETED BY interp_casted_constr - [ constr(c) ] -> [ c ] -END - -type 'id gen_place= ('id * hyp_location_flag,unit) location - -type loc_place = lident gen_place -type place = Id.t gen_place - -let pr_gen_place pr_id = function - ConclLocation () -> Pp.mt () - | HypLocation (id,InHyp) -> str "in " ++ pr_id id - | HypLocation (id,InHypTypeOnly) -> - str "in (Type of " ++ pr_id id ++ str ")" - | HypLocation (id,InHypValueOnly) -> - str "in (Value of " ++ pr_id id ++ str ")" - -let pr_loc_place _ _ _ = pr_gen_place (fun { CAst.v = id } -> Id.print id) -let pr_place _ _ _ = pr_gen_place Id.print -let pr_hloc = pr_loc_place () () () - -let intern_place ist = function - ConclLocation () -> ConclLocation () - | HypLocation (id,hl) -> HypLocation (Tacintern.intern_hyp ist id,hl) - -let interp_place ist env sigma = function - ConclLocation () -> ConclLocation () - | HypLocation (id,hl) -> HypLocation (Tacinterp.interp_hyp ist env sigma id,hl) - -let interp_place ist gl p = - Tacmach.project gl , interp_place ist (Tacmach.pf_env gl) (Tacmach.project gl) p - -let subst_place subst pl = pl - -ARGUMENT EXTEND hloc - PRINTED BY pr_place - INTERPRETED BY interp_place - GLOBALIZED BY intern_place - SUBSTITUTED BY subst_place - RAW_PRINTED BY pr_loc_place - GLOB_PRINTED BY pr_loc_place - [ ] -> - [ ConclLocation () ] - | [ "in" "|-" "*" ] -> - [ ConclLocation () ] -| [ "in" ident(id) ] -> - [ HypLocation ((CAst.make id),InHyp) ] -| [ "in" "(" "Type" "of" ident(id) ")" ] -> - [ HypLocation ((CAst.make id),InHypTypeOnly) ] -| [ "in" "(" "Value" "of" ident(id) ")" ] -> - [ HypLocation ((CAst.make id),InHypValueOnly) ] - - END - -let pr_rename _ _ _ (n, m) = Id.print n ++ str " into " ++ Id.print m - -ARGUMENT EXTEND rename - TYPED AS ident * ident - PRINTED BY pr_rename -| [ ident(n) "into" ident(m) ] -> [ (n, m) ] -END - -(* Julien: Mise en commun des differentes version de replace with in by *) - -let pr_by_arg_tac _prc _prlc prtac opt_c = - match opt_c with - | None -> mt () - | Some t -> hov 2 (str "by" ++ spc () ++ prtac (3,Notation_term.E) t) - -ARGUMENT EXTEND by_arg_tac - TYPED AS tactic_opt - PRINTED BY pr_by_arg_tac -| [ "by" tactic3(c) ] -> [ Some c ] -| [ ] -> [ None ] -END - -let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c - -let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Ppconstr.pr_lident cl -let pr_in_top_clause _ _ _ cl = Pptactic.pr_in_clause Id.print cl -let in_clause' = Pltac.in_clause - -ARGUMENT EXTEND in_clause - TYPED AS clause_dft_concl - PRINTED BY pr_in_top_clause - RAW_TYPED AS clause_dft_concl - RAW_PRINTED BY pr_in_clause - GLOB_TYPED AS clause_dft_concl - GLOB_PRINTED BY pr_in_clause -| [ in_clause'(cl) ] -> [ cl ] -END - -let local_test_lpar_id_colon = - let err () = raise Stream.Failure in - Pcoq.Gram.Entry.of_parser "lpar_id_colon" - (fun strm -> - match Util.stream_nth 0 strm with - | Tok.KEYWORD "(" -> - (match Util.stream_nth 1 strm with - | Tok.IDENT _ -> - (match Util.stream_nth 2 strm with - | Tok.KEYWORD ":" -> () - | _ -> err ()) - | _ -> err ()) - | _ -> err ()) - -let pr_lpar_id_colon _ _ _ _ = mt () - -ARGUMENT EXTEND test_lpar_id_colon TYPED AS unit PRINTED BY pr_lpar_id_colon -| [ local_test_lpar_id_colon(x) ] -> [ () ] -END - -(* spiwack: the print functions are incomplete, but I don't know what they are - used for *) -let pr_r_nat_field natf = - str "nat " ++ - match natf with - | Retroknowledge.NatType -> str "type" - | Retroknowledge.NatPlus -> str "plus" - | Retroknowledge.NatTimes -> str "times" - -let pr_r_n_field nf = - str "binary N " ++ - match nf with - | Retroknowledge.NPositive -> str "positive" - | Retroknowledge.NType -> str "type" - | Retroknowledge.NTwice -> str "twice" - | Retroknowledge.NTwicePlusOne -> str "twice plus one" - | Retroknowledge.NPhi -> str "phi" - | Retroknowledge.NPhiInv -> str "phi inv" - | Retroknowledge.NPlus -> str "plus" - | Retroknowledge.NTimes -> str "times" - -let pr_r_int31_field i31f = - str "int31 " ++ - match i31f with - | Retroknowledge.Int31Bits -> str "bits" - | Retroknowledge.Int31Type -> str "type" - | Retroknowledge.Int31Twice -> str "twice" - | Retroknowledge.Int31TwicePlusOne -> str "twice plus one" - | Retroknowledge.Int31Phi -> str "phi" - | Retroknowledge.Int31PhiInv -> str "phi inv" - | Retroknowledge.Int31Plus -> str "plus" - | Retroknowledge.Int31Times -> str "times" - | Retroknowledge.Int31Constructor -> assert false - | Retroknowledge.Int31PlusC -> str "plusc" - | Retroknowledge.Int31PlusCarryC -> str "pluscarryc" - | Retroknowledge.Int31Minus -> str "minus" - | Retroknowledge.Int31MinusC -> str "minusc" - | Retroknowledge.Int31MinusCarryC -> str "minuscarryc" - | Retroknowledge.Int31TimesC -> str "timesc" - | Retroknowledge.Int31Div21 -> str "div21" - | Retroknowledge.Int31Div -> str "div" - | Retroknowledge.Int31Diveucl -> str "diveucl" - | Retroknowledge.Int31AddMulDiv -> str "addmuldiv" - | Retroknowledge.Int31Compare -> str "compare" - | Retroknowledge.Int31Head0 -> str "head0" - | Retroknowledge.Int31Tail0 -> str "tail0" - | Retroknowledge.Int31Lor -> str "lor" - | Retroknowledge.Int31Land -> str "land" - | Retroknowledge.Int31Lxor -> str "lxor" - -let pr_retroknowledge_field f = - match f with - (* | Retroknowledge.KEq -> str "equality" - | Retroknowledge.KNat natf -> pr_r_nat_field () () () natf - | Retroknowledge.KN nf -> pr_r_n_field () () () nf *) - | Retroknowledge.KInt31 (group, i31f) -> (pr_r_int31_field i31f) ++ - spc () ++ str "in " ++ qs group - -VERNAC ARGUMENT EXTEND retroknowledge_nat -PRINTED BY pr_r_nat_field -| [ "nat" "type" ] -> [ Retroknowledge.NatType ] -| [ "nat" "plus" ] -> [ Retroknowledge.NatPlus ] -| [ "nat" "times" ] -> [ Retroknowledge.NatTimes ] -END - - -VERNAC ARGUMENT EXTEND retroknowledge_binary_n -PRINTED BY pr_r_n_field -| [ "binary" "N" "positive" ] -> [ Retroknowledge.NPositive ] -| [ "binary" "N" "type" ] -> [ Retroknowledge.NType ] -| [ "binary" "N" "twice" ] -> [ Retroknowledge.NTwice ] -| [ "binary" "N" "twice" "plus" "one" ] -> [ Retroknowledge.NTwicePlusOne ] -| [ "binary" "N" "phi" ] -> [ Retroknowledge.NPhi ] -| [ "binary" "N" "phi" "inv" ] -> [ Retroknowledge.NPhiInv ] -| [ "binary" "N" "plus" ] -> [ Retroknowledge.NPlus ] -| [ "binary" "N" "times" ] -> [ Retroknowledge.NTimes ] -END - -VERNAC ARGUMENT EXTEND retroknowledge_int31 -PRINTED BY pr_r_int31_field -| [ "int31" "bits" ] -> [ Retroknowledge.Int31Bits ] -| [ "int31" "type" ] -> [ Retroknowledge.Int31Type ] -| [ "int31" "twice" ] -> [ Retroknowledge.Int31Twice ] -| [ "int31" "twice" "plus" "one" ] -> [ Retroknowledge.Int31TwicePlusOne ] -| [ "int31" "phi" ] -> [ Retroknowledge.Int31Phi ] -| [ "int31" "phi" "inv" ] -> [ Retroknowledge.Int31PhiInv ] -| [ "int31" "plus" ] -> [ Retroknowledge.Int31Plus ] -| [ "int31" "plusc" ] -> [ Retroknowledge.Int31PlusC ] -| [ "int31" "pluscarryc" ] -> [ Retroknowledge.Int31PlusCarryC ] -| [ "int31" "minus" ] -> [ Retroknowledge.Int31Minus ] -| [ "int31" "minusc" ] -> [ Retroknowledge.Int31MinusC ] -| [ "int31" "minuscarryc" ] -> [ Retroknowledge.Int31MinusCarryC ] -| [ "int31" "times" ] -> [ Retroknowledge.Int31Times ] -| [ "int31" "timesc" ] -> [ Retroknowledge.Int31TimesC ] -| [ "int31" "div21" ] -> [ Retroknowledge.Int31Div21 ] -| [ "int31" "div" ] -> [ Retroknowledge.Int31Div ] -| [ "int31" "diveucl" ] -> [ Retroknowledge.Int31Diveucl ] -| [ "int31" "addmuldiv" ] -> [ Retroknowledge.Int31AddMulDiv ] -| [ "int31" "compare" ] -> [ Retroknowledge.Int31Compare ] -| [ "int31" "head0" ] -> [ Retroknowledge.Int31Head0 ] -| [ "int31" "tail0" ] -> [ Retroknowledge.Int31Tail0 ] -| [ "int31" "lor" ] -> [ Retroknowledge.Int31Lor ] -| [ "int31" "land" ] -> [ Retroknowledge.Int31Land ] -| [ "int31" "lxor" ] -> [ Retroknowledge.Int31Lxor ] -END - -VERNAC ARGUMENT EXTEND retroknowledge_field -PRINTED BY pr_retroknowledge_field -(*| [ "equality" ] -> [ Retroknowledge.KEq ] -| [ retroknowledge_nat(n)] -> [ Retroknowledge.KNat n ] -| [ retroknowledge_binary_n (n)] -> [ Retroknowledge.KN n ]*) -| [ retroknowledge_int31 (i) "in" string(g)] -> [ Retroknowledge.KInt31(g,i) ] -END diff --git a/plugins/ltac/extraargs.mlg b/plugins/ltac/extraargs.mlg new file mode 100644 index 0000000000..156ee94a66 --- /dev/null +++ b/plugins/ltac/extraargs.mlg @@ -0,0 +1,353 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +{ + +open Pp +open Stdarg +open Tacarg +open Pcoq.Prim +open Pcoq.Constr +open Names +open Tacmach +open Tacexpr +open Taccoerce +open Tacinterp +open Locus + +(** Adding scopes for generic arguments not defined through ARGUMENT EXTEND *) + +let create_generic_quotation name e wit = + let inject (loc, v) = Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit) v) in + Tacentries.create_ltac_quotation name inject (e, None) + +let () = create_generic_quotation "integer" Pcoq.Prim.integer Stdarg.wit_int +let () = create_generic_quotation "string" Pcoq.Prim.string Stdarg.wit_string + +let () = create_generic_quotation "ident" Pcoq.Prim.ident Stdarg.wit_ident +let () = create_generic_quotation "reference" Pcoq.Prim.reference Stdarg.wit_ref +let () = create_generic_quotation "uconstr" Pcoq.Constr.lconstr Stdarg.wit_uconstr +let () = create_generic_quotation "constr" Pcoq.Constr.lconstr Stdarg.wit_constr +let () = create_generic_quotation "ipattern" Pltac.simple_intropattern wit_intro_pattern +let () = create_generic_quotation "open_constr" Pcoq.Constr.lconstr Stdarg.wit_open_constr +let () = + let inject (loc, v) = Tacexpr.Tacexp v in + Tacentries.create_ltac_quotation "ltac" inject (Pltac.tactic_expr, Some 5) + +(** Backward-compatible tactic notation entry names *) + +let () = + let register name entry = Tacentries.register_tactic_notation_entry name entry in + register "hyp" wit_var; + register "simple_intropattern" wit_intro_pattern; + register "integer" wit_integer; + register "reference" wit_ref; + () + +(* Rewriting orientation *) + +let _ = + Mltop.declare_cache_obj + (fun () -> Metasyntax.add_token_obj "<-"; + Metasyntax.add_token_obj "->") + "ltac_plugin" + +let pr_orient _prc _prlc _prt = function + | true -> Pp.mt () + | false -> Pp.str " <-" + +} + +ARGUMENT EXTEND orient TYPED AS bool PRINTED BY { pr_orient } +| [ "->" ] -> { true } +| [ "<-" ] -> { false } +| [ ] -> { true } +END + +{ + +let pr_int _ _ _ i = Pp.int i + +let _natural = Pcoq.Prim.natural + +} + +ARGUMENT EXTEND natural TYPED AS int PRINTED BY { pr_int } +| [ _natural(i) ] -> { i } +END + +{ + +let pr_orient = pr_orient () () () + +let pr_int_list = Pp.pr_sequence Pp.int +let pr_int_list_full _prc _prlc _prt l = pr_int_list l + +let pr_occurrences _prc _prlc _prt l = + match l with + | ArgArg x -> pr_int_list x + | ArgVar { CAst.loc = loc; v=id } -> Id.print id + +let occurrences_of = function + | [] -> NoOccurrences + | n::_ as nl when n < 0 -> AllOccurrencesBut (List.map abs nl) + | nl -> + if List.exists (fun n -> n < 0) nl then + CErrors.user_err Pp.(str "Illegal negative occurrence number."); + OnlyOccurrences nl + +let coerce_to_int v = match Value.to_int v with + | None -> raise (CannotCoerceTo "an integer") + | Some n -> n + +let int_list_of_VList v = match Value.to_list v with +| Some l -> List.map (fun n -> coerce_to_int n) l +| _ -> raise (CannotCoerceTo "an integer") + +let interp_occs ist gl l = + match l with + | ArgArg x -> x + | ArgVar ({ CAst.v = id } as locid) -> + (try int_list_of_VList (Id.Map.find id ist.lfun) + with Not_found | CannotCoerceTo _ -> [interp_int ist locid]) +let interp_occs ist gl l = + Tacmach.project gl , interp_occs ist gl l + +let glob_occs ist l = l + +let subst_occs evm l = l + +} + +ARGUMENT EXTEND occurrences + TYPED AS int list + PRINTED BY { pr_int_list_full } + + INTERPRETED BY { interp_occs } + GLOBALIZED BY { glob_occs } + SUBSTITUTED BY { subst_occs } + + RAW_PRINTED BY { pr_occurrences } + GLOB_PRINTED BY { pr_occurrences } + +| [ ne_integer_list(l) ] -> { ArgArg l } +| [ var(id) ] -> { ArgVar id } +END + +{ + +let pr_occurrences = pr_occurrences () () () + +let pr_gen prc _prlc _prtac c = prc c + +let pr_globc _prc _prlc _prtac (_,glob) = + let _, env = Pfedit.get_current_context () in + Printer.pr_glob_constr_env env glob + +let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t) + +let glob_glob = Tacintern.intern_constr + +let pr_lconstr _ prc _ c = prc c + +let subst_glob = Tacsubst.subst_glob_constr_and_expr + +} + +ARGUMENT EXTEND glob + PRINTED BY { pr_globc } + + INTERPRETED BY { interp_glob } + GLOBALIZED BY { glob_glob } + SUBSTITUTED BY { subst_glob } + + RAW_PRINTED BY { pr_gen } + GLOB_PRINTED BY { pr_gen } +| [ constr(c) ] -> { c } +END + +{ + +let l_constr = Pcoq.Constr.lconstr + +} + +ARGUMENT EXTEND lconstr + TYPED AS constr + PRINTED BY { pr_lconstr } +| [ l_constr(c) ] -> { c } +END + +ARGUMENT EXTEND lglob + TYPED AS glob + PRINTED BY { pr_globc } + + INTERPRETED BY { interp_glob } + GLOBALIZED BY { glob_glob } + SUBSTITUTED BY { subst_glob } + + RAW_PRINTED BY { pr_gen } + GLOB_PRINTED BY { pr_gen } +| [ lconstr(c) ] -> { c } +END + +{ + +let interp_casted_constr ist gl c = + interp_constr_gen (Pretyping.OfType (pf_concl gl)) ist (pf_env gl) (project gl) c + +} + +ARGUMENT EXTEND casted_constr + TYPED AS constr + PRINTED BY { pr_gen } + INTERPRETED BY { interp_casted_constr } +| [ constr(c) ] -> { c } +END + +{ + +type 'id gen_place= ('id * hyp_location_flag,unit) location + +type loc_place = lident gen_place +type place = Id.t gen_place + +let pr_gen_place pr_id = function + ConclLocation () -> Pp.mt () + | HypLocation (id,InHyp) -> str "in " ++ pr_id id + | HypLocation (id,InHypTypeOnly) -> + str "in (type of " ++ pr_id id ++ str ")" + | HypLocation (id,InHypValueOnly) -> + str "in (value of " ++ pr_id id ++ str ")" + +let pr_loc_place _ _ _ = pr_gen_place (fun { CAst.v = id } -> Id.print id) +let pr_place _ _ _ = pr_gen_place Id.print +let pr_hloc = pr_loc_place () () () + +let intern_place ist = function + ConclLocation () -> ConclLocation () + | HypLocation (id,hl) -> HypLocation (Tacintern.intern_hyp ist id,hl) + +let interp_place ist env sigma = function + ConclLocation () -> ConclLocation () + | HypLocation (id,hl) -> HypLocation (Tacinterp.interp_hyp ist env sigma id,hl) + +let interp_place ist gl p = + Tacmach.project gl , interp_place ist (Tacmach.pf_env gl) (Tacmach.project gl) p + +let subst_place subst pl = pl + +let warn_deprecated_instantiate_syntax = + CWarnings.create ~name:"deprecated-instantiate-syntax" ~category:"deprecated" + (fun (v,v',id) -> + let s = Id.to_string id in + Pp.strbrk + ("Syntax \"in (" ^ v ^ " of " ^ s ^ ")\" is deprecated; use \"in (" ^ v' ^ " of " ^ s ^ ")\".") + ) + +} + +ARGUMENT EXTEND hloc + PRINTED BY { pr_place } + INTERPRETED BY { interp_place } + GLOBALIZED BY { intern_place } + SUBSTITUTED BY { subst_place } + RAW_PRINTED BY { pr_loc_place } + GLOB_PRINTED BY { pr_loc_place } +| [ ] -> + { ConclLocation () } + | [ "in" "|-" "*" ] -> + { ConclLocation () } +| [ "in" ident(id) ] -> + { HypLocation ((CAst.make id),InHyp) } +| [ "in" "(" "Type" "of" ident(id) ")" ] -> + { warn_deprecated_instantiate_syntax ("Type","type",id); + HypLocation ((CAst.make id),InHypTypeOnly) } +| [ "in" "(" "Value" "of" ident(id) ")" ] -> + { warn_deprecated_instantiate_syntax ("Value","value",id); + HypLocation ((CAst.make id),InHypValueOnly) } +| [ "in" "(" "type" "of" ident(id) ")" ] -> + { HypLocation ((CAst.make id),InHypTypeOnly) } +| [ "in" "(" "value" "of" ident(id) ")" ] -> + { HypLocation ((CAst.make id),InHypValueOnly) } + + END + +{ + +let pr_rename _ _ _ (n, m) = Id.print n ++ str " into " ++ Id.print m + +} + +ARGUMENT EXTEND rename + TYPED AS (ident * ident) + PRINTED BY { pr_rename } +| [ ident(n) "into" ident(m) ] -> { (n, m) } +END + +(* Julien: Mise en commun des differentes version de replace with in by *) + +{ + +let pr_by_arg_tac _prc _prlc prtac opt_c = + match opt_c with + | None -> mt () + | Some t -> hov 2 (str "by" ++ spc () ++ prtac (3,Notation_gram.E) t) + +} + +ARGUMENT EXTEND by_arg_tac + TYPED AS tactic option + PRINTED BY { pr_by_arg_tac } +| [ "by" tactic3(c) ] -> { Some c } +| [ ] -> { None } +END + +{ + +let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c + +let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Ppconstr.pr_lident cl +let pr_in_top_clause _ _ _ cl = Pptactic.pr_in_clause Id.print cl +let in_clause' = Pltac.in_clause + +} + +ARGUMENT EXTEND in_clause + TYPED AS clause_dft_concl + PRINTED BY { pr_in_top_clause } + RAW_PRINTED BY { pr_in_clause } + GLOB_PRINTED BY { pr_in_clause } +| [ in_clause'(cl) ] -> { cl } +END + +{ + +let local_test_lpar_id_colon = + let err () = raise Stream.Failure in + Pcoq.Entry.of_parser "lpar_id_colon" + (fun strm -> + match Util.stream_nth 0 strm with + | Tok.KEYWORD "(" -> + (match Util.stream_nth 1 strm with + | Tok.IDENT _ -> + (match Util.stream_nth 2 strm with + | Tok.KEYWORD ":" -> () + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) + +let pr_lpar_id_colon _ _ _ _ = mt () + +} + +ARGUMENT EXTEND test_lpar_id_colon TYPED AS unit PRINTED BY { pr_lpar_id_colon } +| [ local_test_lpar_id_colon(x) ] -> { () } +END diff --git a/plugins/ltac/extraargs.mli b/plugins/ltac/extraargs.mli index e5a4f090ed..fa70235975 100644 --- a/plugins/ltac/extraargs.mli +++ b/plugins/ltac/extraargs.mli @@ -12,17 +12,16 @@ open Tacexpr open Names open Constrexpr open Glob_term -open Misctypes val wit_orient : bool Genarg.uniform_genarg_type -val orient : bool Pcoq.Gram.entry +val orient : bool Pcoq.Entry.t val pr_orient : bool -> Pp.t val wit_rename : (Id.t * Id.t) Genarg.uniform_genarg_type -val occurrences : (int list or_var) Pcoq.Gram.entry -val wit_occurrences : (int list or_var, int list or_var, int list) Genarg.genarg_type -val pr_occurrences : int list or_var -> Pp.t +val occurrences : (int list Locus.or_var) Pcoq.Entry.t +val wit_occurrences : (int list Locus.or_var, int list Locus.or_var, int list) Genarg.genarg_type +val pr_occurrences : int list Locus.or_var -> Pp.t val occurrences_of : int list -> Locus.occurrences val wit_natural : int Genarg.uniform_genarg_type @@ -47,8 +46,8 @@ val wit_casted_constr : Tacexpr.glob_constr_and_expr, EConstr.t) Genarg.genarg_type -val glob : constr_expr Pcoq.Gram.entry -val lglob : constr_expr Pcoq.Gram.entry +val glob : constr_expr Pcoq.Entry.t +val lglob : constr_expr Pcoq.Entry.t type 'id gen_place= ('id * Locus.hyp_location_flag,unit) location @@ -56,28 +55,23 @@ type loc_place = lident gen_place type place = Id.t gen_place val wit_hloc : (loc_place, loc_place, place) Genarg.genarg_type -val hloc : loc_place Pcoq.Gram.entry +val hloc : loc_place Pcoq.Entry.t val pr_hloc : loc_place -> Pp.t -val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.entry +val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Entry.t val wit_by_arg_tac : (raw_tactic_expr option, glob_tactic_expr option, Geninterp.Val.t option) Genarg.genarg_type val pr_by_arg_tac : - (int * Notation_term.parenRelation -> raw_tactic_expr -> Pp.t) -> + (int * Notation_gram.parenRelation -> raw_tactic_expr -> Pp.t) -> raw_tactic_expr option -> Pp.t -val test_lpar_id_colon : unit Pcoq.Gram.entry +val test_lpar_id_colon : unit Pcoq.Entry.t val wit_test_lpar_id_colon : (unit, unit, unit) Genarg.genarg_type -(** Spiwack: Primitive for retroknowledge registration *) - -val retroknowledge_field : Retroknowledge.field Pcoq.Gram.entry -val wit_retroknowledge_field : (Retroknowledge.field, unit, unit) Genarg.genarg_type - val wit_in_clause : (lident Locus.clause_expr, lident Locus.clause_expr, diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.mlg index 2e90ce90cc..603dd60cf2 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.mlg @@ -8,7 +8,10 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Pp +open Constr open Genarg open Stdarg open Tacarg @@ -23,12 +26,21 @@ open CErrors open Util open Termops open Equality -open Misctypes +open Namegen +open Tactypes +open Tactics open Proofview.Notations -open Vernacinterp +open Attributes +open Vernacextend + +let wit_hyp = wit_var + +} DECLARE PLUGIN "ltac_plugin" +{ + (**********************************************************************) (* replace, discriminate, injection, simplify_eq *) (* cutrewrite, dependent rewrite *) @@ -37,10 +49,9 @@ let with_delayed_uconstr ist c tac = let flags = { Pretyping.use_typeclasses = false; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = false; expand_evars = true - } in + } in let c = Tacinterp.type_uconstr ~flags ist c in Tacticals.New.tclDELAYEDWITHHOLES false c tac @@ -51,26 +62,30 @@ let replace_in_clause_maybe_by ist c1 c2 cl tac = let replace_term ist dir_opt c cl = with_delayed_uconstr ist c (fun c -> replace_term dir_opt c cl) +} + TACTIC EXTEND replace - ["replace" uconstr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] --> [ replace_in_clause_maybe_by ist c1 c2 cl tac ] +| ["replace" uconstr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] +-> { replace_in_clause_maybe_by ist c1 c2 cl tac } END TACTIC EXTEND replace_term_left - [ "replace" "->" uconstr(c) clause(cl) ] - -> [ replace_term ist (Some true) c cl ] +| [ "replace" "->" uconstr(c) clause(cl) ] + -> { replace_term ist (Some true) c cl } END TACTIC EXTEND replace_term_right - [ "replace" "<-" uconstr(c) clause(cl) ] - -> [ replace_term ist (Some false) c cl ] +| [ "replace" "<-" uconstr(c) clause(cl) ] + -> { replace_term ist (Some false) c cl } END TACTIC EXTEND replace_term - [ "replace" uconstr(c) clause(cl) ] - -> [ replace_term ist None c cl ] +| [ "replace" uconstr(c) clause(cl) ] + -> { replace_term ist None c cl } END +{ + let induction_arg_of_quantified_hyp = function | AnonHyp n -> None,ElimOnAnonHyp n | NamedHyp id -> None,ElimOnIdent (CAst.make id) @@ -91,28 +106,36 @@ let elimOnConstrWithHoles tac with_evars c = Tacticals.New.tclDELAYEDWITHHOLES with_evars c (fun c -> tac with_evars (Some (None,ElimOnConstr c))) +} + TACTIC EXTEND simplify_eq - [ "simplify_eq" ] -> [ dEq ~keep_proofs:None false None ] -| [ "simplify_eq" destruction_arg(c) ] -> [ mytclWithHoles (dEq ~keep_proofs:None) false c ] +| [ "simplify_eq" ] -> { dEq ~keep_proofs:None false None } +| [ "simplify_eq" destruction_arg(c) ] -> { mytclWithHoles (dEq ~keep_proofs:None) false c } END TACTIC EXTEND esimplify_eq -| [ "esimplify_eq" ] -> [ dEq ~keep_proofs:None true None ] -| [ "esimplify_eq" destruction_arg(c) ] -> [ mytclWithHoles (dEq ~keep_proofs:None) true c ] +| [ "esimplify_eq" ] -> { dEq ~keep_proofs:None true None } +| [ "esimplify_eq" destruction_arg(c) ] -> { mytclWithHoles (dEq ~keep_proofs:None) true c } END +{ + let discr_main c = elimOnConstrWithHoles discr_tac false c +} + TACTIC EXTEND discriminate -| [ "discriminate" ] -> [ discr_tac false None ] +| [ "discriminate" ] -> { discr_tac false None } | [ "discriminate" destruction_arg(c) ] -> - [ mytclWithHoles discr_tac false c ] + { mytclWithHoles discr_tac false c } END TACTIC EXTEND ediscriminate -| [ "ediscriminate" ] -> [ discr_tac true None ] +| [ "ediscriminate" ] -> { discr_tac true None } | [ "ediscriminate" destruction_arg(c) ] -> - [ mytclWithHoles discr_tac true c ] + { mytclWithHoles discr_tac true c } END +{ + let discrHyp id = Proofview.tclEVARMAP >>= fun sigma -> discr_main (fun env sigma -> (sigma, (EConstr.mkVar id, NoBindings))) @@ -120,39 +143,45 @@ let discrHyp id = let injection_main with_evars c = elimOnConstrWithHoles (injClause None None) with_evars c +} + TACTIC EXTEND injection -| [ "injection" ] -> [ injClause None None false None ] -| [ "injection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None None) false c ] +| [ "injection" ] -> { injClause None None false None } +| [ "injection" destruction_arg(c) ] -> { mytclWithHoles (injClause None None) false c } END TACTIC EXTEND einjection -| [ "einjection" ] -> [ injClause None None true None ] -| [ "einjection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None None) true c ] +| [ "einjection" ] -> { injClause None None true None } +| [ "einjection" destruction_arg(c) ] -> { mytclWithHoles (injClause None None) true c } END TACTIC EXTEND injection_as | [ "injection" "as" intropattern_list(ipat)] -> - [ injClause None (Some ipat) false None ] + { injClause None (Some ipat) false None } | [ "injection" destruction_arg(c) "as" intropattern_list(ipat)] -> - [ mytclWithHoles (injClause None (Some ipat)) false c ] + { mytclWithHoles (injClause None (Some ipat)) false c } END TACTIC EXTEND einjection_as | [ "einjection" "as" intropattern_list(ipat)] -> - [ injClause None (Some ipat) true None ] + { injClause None (Some ipat) true None } | [ "einjection" destruction_arg(c) "as" intropattern_list(ipat)] -> - [ mytclWithHoles (injClause None (Some ipat)) true c ] + { mytclWithHoles (injClause None (Some ipat)) true c } END TACTIC EXTEND simple_injection -| [ "simple" "injection" ] -> [ simpleInjClause None false None ] -| [ "simple" "injection" destruction_arg(c) ] -> [ mytclWithHoles (simpleInjClause None) false c ] +| [ "simple" "injection" ] -> { simpleInjClause None false None } +| [ "simple" "injection" destruction_arg(c) ] -> { mytclWithHoles (simpleInjClause None) false c } END +{ + let injHyp id = Proofview.tclEVARMAP >>= fun sigma -> injection_main false (fun env sigma -> (sigma, (EConstr.mkVar id, NoBindings))) +} + TACTIC EXTEND dependent_rewrite -| [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ] +| [ "dependent" "rewrite" orient(b) constr(c) ] -> { rewriteInConcl b c } | [ "dependent" "rewrite" orient(b) constr(c) "in" hyp(id) ] - -> [ rewriteInHyp b c id ] + -> { rewriteInHyp b c id } END (** To be deprecated?, "cutrewrite (t=u) as <-" is equivalent to @@ -160,43 +189,53 @@ END "cutrewrite (t=u) as ->" is equivalent to "enough (t=u) as ->". *) TACTIC EXTEND cut_rewrite -| [ "cutrewrite" orient(b) constr(eqn) ] -> [ cutRewriteInConcl b eqn ] +| [ "cutrewrite" orient(b) constr(eqn) ] -> { cutRewriteInConcl b eqn } | [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ] - -> [ cutRewriteInHyp b eqn id ] + -> { cutRewriteInHyp b eqn id } END (**********************************************************************) (* Decompose *) TACTIC EXTEND decompose_sum -| [ "decompose" "sum" constr(c) ] -> [ Elim.h_decompose_or c ] +| [ "decompose" "sum" constr(c) ] -> { Elim.h_decompose_or c } END TACTIC EXTEND decompose_record -| [ "decompose" "record" constr(c) ] -> [ Elim.h_decompose_and c ] +| [ "decompose" "record" constr(c) ] -> { Elim.h_decompose_and c } END (**********************************************************************) (* Contradiction *) +{ + open Contradiction +} + TACTIC EXTEND absurd - [ "absurd" constr(c) ] -> [ absurd c ] +| [ "absurd" constr(c) ] -> { absurd c } END +{ + let onSomeWithHoles tac = function | None -> tac None | Some c -> Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> tac (Some c)) +} + TACTIC EXTEND contradiction - [ "contradiction" constr_with_bindings_opt(c) ] -> - [ onSomeWithHoles contradiction c ] +| [ "contradiction" constr_with_bindings_opt(c) ] -> + { onSomeWithHoles contradiction c } END (**********************************************************************) (* AutoRewrite *) +{ + open Autorewrite let pr_orient _prc _prlc _prt = function @@ -206,50 +245,58 @@ let pr_orient _prc _prlc _prt = function let pr_orient_string _prc _prlc _prt (orient, s) = pr_orient _prc _prlc _prt orient ++ Pp.spc () ++ Pp.str s -ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY pr_orient_string -| [ orient(r) preident(i) ] -> [ r, i ] +} + +ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY { pr_orient_string } +| [ orient(r) preident(i) ] -> { r, i } END TACTIC EXTEND autorewrite | [ "autorewrite" "with" ne_preident_list(l) clause(cl) ] -> - [ auto_multi_rewrite l ( cl) ] + { auto_multi_rewrite l ( cl) } | [ "autorewrite" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> - [ + { auto_multi_rewrite_with (Tacinterp.tactic_of_value ist t) l cl - ] + } END TACTIC EXTEND autorewrite_star | [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) ] -> - [ auto_multi_rewrite ~conds:AllMatches l cl ] + { auto_multi_rewrite ~conds:AllMatches l cl } | [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> - [ auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.tactic_of_value ist t) l cl ] + { auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.tactic_of_value ist t) l cl } END (**********************************************************************) (* Rewrite star *) +{ + let rewrite_star ist clause orient occs c (tac : Geninterp.Val.t option) = let tac' = Option.map (fun t -> Tacinterp.tactic_of_value ist t, FirstSolved) tac in with_delayed_uconstr ist c (fun c -> general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true) +} + TACTIC EXTEND rewrite_star | [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> - [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] + { rewrite_star ist (Some id) o (occurrences_of occ) c tac } | [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] -> - [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] + { rewrite_star ist (Some id) o (occurrences_of occ) c tac } | [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) by_arg_tac(tac) ] -> - [ rewrite_star ist (Some id) o Locus.AllOccurrences c tac ] + { rewrite_star ist (Some id) o Locus.AllOccurrences c tac } | [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) by_arg_tac(tac) ] -> - [ rewrite_star ist None o (occurrences_of occ) c tac ] + { rewrite_star ist None o (occurrences_of occ) c tac } | [ "rewrite" "*" orient(o) uconstr(c) by_arg_tac(tac) ] -> - [ rewrite_star ist None o Locus.AllOccurrences c tac ] + { rewrite_star ist None o Locus.AllOccurrences c tac } END (**********************************************************************) (* Hint Rewrite *) +{ + let add_rewrite_hint ~poly bases ort t lcsr = let env = Global.env() in let sigma = Evd.from_env env in @@ -269,104 +316,33 @@ let add_rewrite_hint ~poly bases ort t lcsr = let add_hints base = add_rew_rules base eqs in List.iter add_hints bases -let classify_hint _ = Vernacexpr.VtSideff [], Vernacexpr.VtLater +let classify_hint _ = VtSideff [], VtLater -VERNAC COMMAND FUNCTIONAL EXTEND HintRewrite CLASSIFIED BY classify_hint - [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> - [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic bl o None l; st ] -| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) - ":" preident_list(bl) ] -> - [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic bl o (Some t) l; st ] -| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> - [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic ["core"] o None l; st ] -| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> - [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic ["core"] o (Some t) l; st ] -END - -(**********************************************************************) -(* Hint Resolve *) - -open Term -open EConstr -open Vars -open Coqlib +} -let project_hint ~poly pri l2r r = - let gr = Smartlocate.global_with_alias r in - let env = Global.env() in - let sigma = Evd.from_env env in - let sigma, c = Evd.fresh_global env sigma gr in - let c = EConstr.of_constr c in - let t = Retyping.get_type_of env sigma c in - let t = - Tacred.reduce_to_quantified_ref env sigma (Lazy.force coq_iff_ref) t in - let sign,ccl = decompose_prod_assum sigma t in - let (a,b) = match snd (decompose_app sigma ccl) with - | [a;b] -> (a,b) - | _ -> assert false in - let p = - if l2r then build_coq_iff_left_proj () else build_coq_iff_right_proj () in - let sigma, p = Evd.fresh_global env sigma p in - let p = EConstr.of_constr p in - let c = Reductionops.whd_beta sigma (mkApp (c, Context.Rel.to_extended_vect mkRel 0 sign)) in - let c = it_mkLambda_or_LetIn - (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in - let id = - Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) - in - let ctx = Evd.const_univ_entry ~poly sigma in - let c = EConstr.to_constr sigma c in - let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in - let info = {Vernacexpr.hint_priority = pri; hint_pattern = None} in - (info,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c)) - -let add_hints_iff ~atts l2r lc n bl = - let open Vernacinterp in - Hints.add_hints (Locality.make_module_locality atts.locality) bl - (Hints.HintsResolveEntry (List.map (project_hint ~poly:atts.polymorphic n l2r) lc)) - -VERNAC COMMAND FUNCTIONAL EXTEND HintResolveIffLR CLASSIFIED AS SIDEFF - [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) +VERNAC COMMAND EXTEND HintRewrite CLASSIFIED BY { classify_hint } +| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> + { add_rewrite_hint ~poly:polymorphic bl o None l } +| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ":" preident_list(bl) ] -> - [ fun ~atts ~st -> begin - add_hints_iff ~atts true lc n bl; - st - end - ] -| [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) ] -> - [ fun ~atts ~st -> begin - add_hints_iff ~atts true lc n ["core"]; - st - end - ] -END - -VERNAC COMMAND FUNCTIONAL EXTEND HintResolveIffRL CLASSIFIED AS SIDEFF - [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) - ":" preident_list(bl) ] -> - [ fun ~atts ~st -> begin - add_hints_iff ~atts false lc n bl; - st - end - ] -| [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) ] -> - [ fun ~atts ~st -> begin - add_hints_iff ~atts false lc n ["core"]; - st - end - ] + { add_rewrite_hint ~poly:polymorphic bl o (Some t) l } +| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> + { add_rewrite_hint ~poly:polymorphic ["core"] o None l } +| #[ polymorphic; ] [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> + { add_rewrite_hint ~poly:polymorphic ["core"] o (Some t) l } END (**********************************************************************) (* Refine *) +{ + open EConstr open Vars let constr_flags () = { Pretyping.use_typeclasses = true; - Pretyping.solve_unification_constraints = true; - Pretyping.use_hook = Pfedit.solve_by_implicit_tactic (); + Pretyping.solve_unification_constraints = Pfedit.use_unification_heuristics (); Pretyping.fail_evar = false; Pretyping.expand_evars = true } @@ -375,7 +351,7 @@ let refine_tac ist simple with_classes c = let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let flags = - { constr_flags () with Pretyping.use_typeclasses = with_classes } in + { (constr_flags ()) with Pretyping.use_typeclasses = with_classes } in let expected_type = Pretyping.OfType concl in let c = Tacinterp.type_uconstr ~flags ~expected_type ist c in let update = begin fun sigma -> @@ -388,125 +364,135 @@ let refine_tac ist simple with_classes c = Proofview.shelve_unifiable end +} + TACTIC EXTEND refine | [ "refine" uconstr(c) ] -> - [ refine_tac ist false true c ] + { refine_tac ist false true c } END TACTIC EXTEND simple_refine | [ "simple" "refine" uconstr(c) ] -> - [ refine_tac ist true true c ] + { refine_tac ist true true c } END TACTIC EXTEND notcs_refine | [ "notypeclasses" "refine" uconstr(c) ] -> - [ refine_tac ist false false c ] + { refine_tac ist false false c } END TACTIC EXTEND notcs_simple_refine | [ "simple" "notypeclasses" "refine" uconstr(c) ] -> - [ refine_tac ist true false c ] + { refine_tac ist true false c } END (* Solve unification constraints using heuristics or fail if any remain *) TACTIC EXTEND solve_constraints -[ "solve_constraints" ] -> [ Refine.solve_constraints ] +| [ "solve_constraints" ] -> { Refine.solve_constraints } END (**********************************************************************) (* Inversion lemmas (Leminv) *) +{ + open Inv open Leminv -let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater +let seff id = VtSideff [id], VtLater + +} (*VERNAC ARGUMENT EXTEND sort_family -| [ "Set" ] -> [ InSet ] -| [ "Prop" ] -> [ InProp ] -| [ "Type" ] -> [ InType ] +| [ "Set" ] -> { InSet } +| [ "Prop" ] -> { InProp } +| [ "Type" ] -> { InType } END*) -VERNAC COMMAND FUNCTIONAL EXTEND DeriveInversionClear -| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ] - => [ seff na ] - -> [ fun ~atts ~st -> - let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c s false inv_clear_tac; st ] +VERNAC COMMAND EXTEND DeriveInversionClear +| #[ polymorphic; ] [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ] + => { seff na } + -> { + add_inversion_lemma_exn ~poly:polymorphic na c s false inv_clear_tac } -| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => [ seff na ] - -> [ fun ~atts ~st -> - let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c Sorts.InProp false inv_clear_tac; st ] +| #[ polymorphic; ] [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => { seff na } + -> { + add_inversion_lemma_exn ~poly:polymorphic na c Sorts.InProp false inv_clear_tac } END -VERNAC COMMAND FUNCTIONAL EXTEND DeriveInversion -| [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ] - => [ seff na ] - -> [ fun ~atts ~st -> - let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c s false inv_tac; st ] +VERNAC COMMAND EXTEND DeriveInversion +| #[ polymorphic; ] [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ] + => { seff na } + -> { + add_inversion_lemma_exn ~poly:polymorphic na c s false inv_tac } -| [ "Derive" "Inversion" ident(na) "with" constr(c) ] => [ seff na ] - -> [ fun ~atts ~st -> - let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c Sorts.InProp false inv_tac; st ] +| #[ polymorphic; ] [ "Derive" "Inversion" ident(na) "with" constr(c) ] => { seff na } + -> { + add_inversion_lemma_exn ~poly:polymorphic na c Sorts.InProp false inv_tac } END -VERNAC COMMAND FUNCTIONAL EXTEND DeriveDependentInversion -| [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ] - => [ seff na ] - -> [ fun ~atts ~st -> - let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c s true dinv_tac; st ] +VERNAC COMMAND EXTEND DeriveDependentInversion +| #[ polymorphic; ] [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ] + => { seff na } + -> { + add_inversion_lemma_exn ~poly:polymorphic na c s true dinv_tac } END -VERNAC COMMAND FUNCTIONAL EXTEND DeriveDependentInversionClear -| [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ] - => [ seff na ] - -> [ fun ~atts ~st -> - let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c s true dinv_clear_tac; st ] +VERNAC COMMAND EXTEND DeriveDependentInversionClear +| #[ polymorphic; ] [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ] + => { seff na } + -> { + add_inversion_lemma_exn ~poly:polymorphic na c s true dinv_clear_tac } END (**********************************************************************) (* Subst *) TACTIC EXTEND subst -| [ "subst" ne_var_list(l) ] -> [ subst l ] -| [ "subst" ] -> [ subst_all () ] +| [ "subst" ne_var_list(l) ] -> { subst l } +| [ "subst" ] -> { subst_all () } END +{ + let simple_subst_tactic_flags = { only_leibniz = true; rewrite_dependent_proof = false } +} + TACTIC EXTEND simple_subst -| [ "simple" "subst" ] -> [ subst_all ~flags:simple_subst_tactic_flags () ] +| [ "simple" "subst" ] -> { subst_all ~flags:simple_subst_tactic_flags () } END +{ + open Evar_tactics +} + (**********************************************************************) (* Evar creation *) (* TODO: add support for some test similar to g_constr.name_colon so that expressions like "evar (list A)" do not raise a syntax error *) TACTIC EXTEND evar - [ "evar" test_lpar_id_colon "(" ident(id) ":" lconstr(typ) ")" ] -> [ let_evar (Name.Name id) typ ] -| [ "evar" constr(typ) ] -> [ let_evar Name.Anonymous typ ] +| [ "evar" test_lpar_id_colon "(" ident(id) ":" lconstr(typ) ")" ] -> { let_evar (Name.Name id) typ } +| [ "evar" constr(typ) ] -> { let_evar Name.Anonymous typ } END TACTIC EXTEND instantiate - [ "instantiate" "(" ident(id) ":=" lglob(c) ")" ] -> - [ Tacticals.New.tclTHEN (instantiate_tac_by_name id c) Proofview.V82.nf_evar_goals ] +| [ "instantiate" "(" ident(id) ":=" lglob(c) ")" ] -> + { Tacticals.New.tclTHEN (instantiate_tac_by_name id c) Proofview.V82.nf_evar_goals } | [ "instantiate" "(" integer(i) ":=" lglob(c) ")" hloc(hl) ] -> - [ Tacticals.New.tclTHEN (instantiate_tac i c hl) Proofview.V82.nf_evar_goals ] -| [ "instantiate" ] -> [ Proofview.V82.nf_evar_goals ] + { Tacticals.New.tclTHEN (instantiate_tac i c hl) Proofview.V82.nf_evar_goals } +| [ "instantiate" ] -> { Proofview.V82.nf_evar_goals } END (**********************************************************************) (** Nijmegen "step" tactic for setoid rewriting *) +{ + open Tactics open Glob_term open Libobject @@ -560,84 +546,44 @@ let add_transitivity_lemma left lem = let lem' = EConstr.to_constr sigma lem' in add_anonymous_leaf (inTransitivity (left,lem')) +} + (* Vernacular syntax *) TACTIC EXTEND stepl -| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.tactic_of_value ist tac) ] -| ["stepl" constr(c) ] -> [ step true c (Proofview.tclUNIT ()) ] +| ["stepl" constr(c) "by" tactic(tac) ] -> { step true c (Tacinterp.tactic_of_value ist tac) } +| ["stepl" constr(c) ] -> { step true c (Proofview.tclUNIT ()) } END TACTIC EXTEND stepr -| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.tactic_of_value ist tac) ] -| ["stepr" constr(c) ] -> [ step false c (Proofview.tclUNIT ()) ] +| ["stepr" constr(c) "by" tactic(tac) ] -> { step false c (Tacinterp.tactic_of_value ist tac) } +| ["stepr" constr(c) ] -> { step false c (Proofview.tclUNIT ()) } END VERNAC COMMAND EXTEND AddStepl CLASSIFIED AS SIDEFF | [ "Declare" "Left" "Step" constr(t) ] -> - [ add_transitivity_lemma true t ] + { add_transitivity_lemma true t } END VERNAC COMMAND EXTEND AddStepr CLASSIFIED AS SIDEFF | [ "Declare" "Right" "Step" constr(t) ] -> - [ add_transitivity_lemma false t ] -END - -let cache_implicit_tactic (_,tac) = match tac with - | Some tac -> Pfedit.declare_implicit_tactic (Tacinterp.eval_tactic tac) - | None -> Pfedit.clear_implicit_tactic () - -let subst_implicit_tactic (subst,tac) = - Option.map (Tacsubst.subst_tactic subst) tac - -let inImplicitTactic : glob_tactic_expr option -> obj = - declare_object {(default_object "IMPLICIT-TACTIC") with - open_function = (fun i o -> if Int.equal i 1 then cache_implicit_tactic o); - cache_function = cache_implicit_tactic; - subst_function = subst_implicit_tactic; - classify_function = (fun o -> Dispose)} - -let declare_implicit_tactic tac = - Lib.add_anonymous_leaf (inImplicitTactic (Some (Tacintern.glob_tactic tac))) - -let clear_implicit_tactic () = - Lib.add_anonymous_leaf (inImplicitTactic None) - -VERNAC COMMAND EXTEND ImplicitTactic CLASSIFIED AS SIDEFF -| [ "Declare" "Implicit" "Tactic" tactic(tac) ] -> [ declare_implicit_tactic tac ] -| [ "Clear" "Implicit" "Tactic" ] -> [ clear_implicit_tactic () ] + { add_transitivity_lemma false t } END - - - -(**********************************************************************) -(*spiwack : Vernac commands for retroknowledge *) - -VERNAC COMMAND EXTEND RetroknowledgeRegister CLASSIFIED AS SIDEFF - | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] -> - [ let tc,_ctx = Constrintern.interp_constr (Global.env ()) Evd.empty c in - let tb,_ctx(*FIXME*) = Constrintern.interp_constr (Global.env ()) Evd.empty b in - let tc = EConstr.to_constr Evd.empty tc in - let tb = EConstr.to_constr Evd.empty tb in - Global.register f tc tb ] -END - - - (**********************************************************************) (* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as defined by Conor McBride *) TACTIC EXTEND generalize_eqs -| ["generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false id ] +| ["generalize_eqs" hyp(id) ] -> { abstract_generalize ~generalize_vars:false id } END TACTIC EXTEND dep_generalize_eqs -| ["dependent" "generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false ~force_dep:true id ] +| ["dependent" "generalize_eqs" hyp(id) ] -> { abstract_generalize ~generalize_vars:false ~force_dep:true id } END TACTIC EXTEND generalize_eqs_vars -| ["generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~generalize_vars:true id ] +| ["generalize_eqs_vars" hyp(id) ] -> { abstract_generalize ~generalize_vars:true id } END TACTIC EXTEND dep_generalize_eqs_vars -| ["dependent" "generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~force_dep:true ~generalize_vars:true id ] +| ["dependent" "generalize_eqs_vars" hyp(id) ] -> { abstract_generalize ~force_dep:true ~generalize_vars:true id } END (** Tactic to automatically simplify hypotheses of the form [Π Δ, x_i = t_i -> T] @@ -645,7 +591,7 @@ END during dependent induction. For internal use. *) TACTIC EXTEND specialize_eqs -[ "specialize_eqs" hyp(id) ] -> [ specialize_eqs id ] +| [ "specialize_eqs" hyp(id) ] -> { specialize_eqs id } END (**********************************************************************) @@ -656,6 +602,8 @@ END (* Contributed by Chung-Kil Hur (Winter 2009) *) (**********************************************************************) +{ + let subst_var_with_hole occ tid t = let occref = if occ > 0 then ref occ else Find_subterm.error_invalid_occurrence [occ] in let locref = ref 0 in @@ -668,8 +616,11 @@ let subst_var_with_hole occ tid t = else (incr locref; DAst.make ~loc:(Loc.make_loc (!locref,0)) @@ - GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous), - Misctypes.IntroAnonymous, None))) + GHole (Evar_kinds.QuestionMark { + Evar_kinds.qm_obligation=Evar_kinds.Define true; + Evar_kinds.qm_name=Anonymous; + Evar_kinds.qm_record_field=None; + }, IntroAnonymous, None))) else x | _ -> map_glob_constr_left_to_right substrec x in let t' = substrec t @@ -680,13 +631,21 @@ let subst_hole_with_term occ tc t = let locref = ref 0 in let occref = ref occ in let rec substrec c = match DAst.get c with - | GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),Misctypes.IntroAnonymous,s) -> + | GHole (Evar_kinds.QuestionMark { + Evar_kinds.qm_obligation=Evar_kinds.Define true; + Evar_kinds.qm_name=Anonymous; + Evar_kinds.qm_record_field=None; + }, IntroAnonymous, s) -> decr occref; if Int.equal !occref 0 then tc else (incr locref; DAst.make ~loc:(Loc.make_loc (!locref,0)) @@ - GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),Misctypes.IntroAnonymous,s)) + GHole (Evar_kinds.QuestionMark { + Evar_kinds.qm_obligation=Evar_kinds.Define true; + Evar_kinds.qm_name=Anonymous; + Evar_kinds.qm_record_field=None; + },IntroAnonymous,s)) | _ -> map_glob_constr_left_to_right substrec c in substrec t @@ -727,9 +686,11 @@ let hResolve_auto id c t = in resolve_auto 1 +} + TACTIC EXTEND hresolve_core -| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> [ hResolve id c occ t ] -| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> [ hResolve_auto id c t ] +| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> { hResolve id c occ t } +| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> { hResolve_auto id c t } END (** @@ -737,7 +698,7 @@ END *) TACTIC EXTEND hget_evar -| [ "hget_evar" int_or_var(n) ] -> [ Evar_tactics.hget_evar n ] +| [ "hget_evar" int_or_var(n) ] -> { Evar_tactics.hget_evar n } END (**********************************************************************) @@ -750,6 +711,8 @@ END (* Contributed by Julien Forest and Pierre Courtieu (july 2010) *) (**********************************************************************) +{ + exception Found of unit Proofview.tactic let rewrite_except h = @@ -761,12 +724,7 @@ let rewrite_except h = end -let refl_equal = - let coq_base_constant s = - Coqlib.gen_reference_in_modules "RecursiveDefinition" - (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s in - function () -> (coq_base_constant "eq_refl") - +let refl_equal () = Coqlib.lib_ref "core.eq.type" (* This is simply an implementation of the case_eq tactic. this code should be replaced by a call to the tactic but I don't know how to @@ -781,7 +739,7 @@ let mkCaseEq a : unit Proofview.tactic = let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in (** FIXME: this looks really wrong. Does anybody really use this tactic? *) - let (_, c) = Tacred.pattern_occs [Locus.OnlyOccurrences [1], a] env Evd.empty concl in + let (_, c) = Tacred.pattern_occs [Locus.OnlyOccurrences [1], a] env (Evd.from_env env) concl in change_concl c end; simplest_case a] @@ -810,7 +768,7 @@ let case_eq_intros_rewrite x = let rec find_a_destructable_match sigma t = let cl = induction_arg_of_quantified_hyp (NamedHyp (Id.of_string "x")) in let cl = [cl, (None, None), None], None in - let dest = TacAtom (Loc.tag @@ TacInductionDestruct(false, false, cl)) in + let dest = TacAtom (CAst.make @@ TacInductionDestruct(false, false, cl)) in match EConstr.kind sigma t with | Case (_,_,x,_) when closed0 sigma x -> if isVar sigma x then @@ -836,9 +794,11 @@ let destauto_in id = destauto ctype end +} + TACTIC EXTEND destauto -| [ "destauto" ] -> [ Proofview.Goal.enter begin fun gl -> destauto (Proofview.Goal.concl gl) end ] -| [ "destauto" "in" hyp(id) ] -> [ destauto_in id ] +| [ "destauto" ] -> { Proofview.Goal.enter begin fun gl -> destauto (Proofview.Goal.concl gl) end } +| [ "destauto" "in" hyp(id) ] -> { destauto_in id } END (**********************************************************************) @@ -849,121 +809,116 @@ END (**********************************************************************) TACTIC EXTEND transparent_abstract -| [ "transparent_abstract" tactic3(t) ] -> [ Proofview.Goal.nf_enter begin fun gl -> - Tactics.tclABSTRACT ~opaque:false None (Tacinterp.tactic_of_value ist t) end ] -| [ "transparent_abstract" tactic3(t) "using" ident(id) ] -> [ Proofview.Goal.nf_enter begin fun gl -> - Tactics.tclABSTRACT ~opaque:false (Some id) (Tacinterp.tactic_of_value ist t) end ] +| [ "transparent_abstract" tactic3(t) ] -> { Proofview.Goal.enter begin fun gl -> + Abstract.tclABSTRACT ~opaque:false None (Tacinterp.tactic_of_value ist t) end } +| [ "transparent_abstract" tactic3(t) "using" ident(id) ] -> { Proofview.Goal.enter begin fun gl -> + Abstract.tclABSTRACT ~opaque:false (Some id) (Tacinterp.tactic_of_value ist t) end } END (* ********************************************************************* *) -let eq_constr x y = - Proofview.Goal.enter begin fun gl -> - let env = Tacmach.New.pf_env gl in - let evd = Tacmach.New.project gl in - match EConstr.eq_constr_universes env evd x y with - | Some _ -> Proofview.tclUNIT () - | None -> Tacticals.New.tclFAIL 0 (str "Not equal") - end - TACTIC EXTEND constr_eq -| [ "constr_eq" constr(x) constr(y) ] -> [ eq_constr x y ] +| [ "constr_eq" constr(x) constr(y) ] -> { Tactics.constr_eq ~strict:false x y } +END + +TACTIC EXTEND constr_eq_strict +| [ "constr_eq_strict" constr(x) constr(y) ] -> { Tactics.constr_eq ~strict:true x y } END TACTIC EXTEND constr_eq_nounivs -| [ "constr_eq_nounivs" constr(x) constr(y) ] -> [ +| [ "constr_eq_nounivs" constr(x) constr(y) ] -> { Proofview.tclEVARMAP >>= fun sigma -> - if eq_constr_nounivs sigma x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ] + if eq_constr_nounivs sigma x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") } END TACTIC EXTEND is_evar -| [ "is_evar" constr(x) ] -> [ +| [ "is_evar" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Evar _ -> Proofview.tclUNIT () | _ -> Tacticals.New.tclFAIL 0 (str "Not an evar") - ] + } END TACTIC EXTEND has_evar -| [ "has_evar" constr(x) ] -> [ +| [ "has_evar" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> if Evarutil.has_undefined_evars sigma x then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "No evars") -] +} END TACTIC EXTEND is_hyp -| [ "is_var" constr(x) ] -> [ +| [ "is_var" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Var _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (str "Not a variable or hypothesis") ] + | _ -> Tacticals.New.tclFAIL 0 (str "Not a variable or hypothesis") } END TACTIC EXTEND is_fix -| [ "is_fix" constr(x) ] -> [ +| [ "is_fix" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Fix _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a fix definition") ] -END;; + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a fix definition") } +END TACTIC EXTEND is_cofix -| [ "is_cofix" constr(x) ] -> [ +| [ "is_cofix" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | CoFix _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a cofix definition") ] -END;; + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a cofix definition") } +END TACTIC EXTEND is_ind -| [ "is_ind" constr(x) ] -> [ +| [ "is_ind" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Ind _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not an (co)inductive datatype") ] -END;; + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not an (co)inductive datatype") } +END TACTIC EXTEND is_constructor -| [ "is_constructor" constr(x) ] -> [ +| [ "is_constructor" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Construct _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constructor") ] -END;; + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constructor") } +END TACTIC EXTEND is_proj -| [ "is_proj" constr(x) ] -> [ +| [ "is_proj" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Proj _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a primitive projection") ] -END;; + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a primitive projection") } +END TACTIC EXTEND is_const -| [ "is_const" constr(x) ] -> [ +| [ "is_const" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Const _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constant") ] -END;; + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constant") } +END (* Command to grab the evars left unresolved at the end of a proof. *) (* spiwack: I put it in extratactics because it is somewhat tied with the semantics of the LCF-style tactics, hence with the classic tactic mode. *) VERNAC COMMAND EXTEND GrabEvars -[ "Grab" "Existential" "Variables" ] - => [ Vernac_classifier.classify_as_proofstep ] - -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p) ] +| [ "Grab" "Existential" "Variables" ] + => { classify_as_proofstep } + -> { Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p) } END (* Shelves all the goals under focus. *) TACTIC EXTEND shelve | [ "shelve" ] -> - [ Proofview.shelve ] + { Proofview.shelve } END (* Shelves the unifiable goals under focus, i.e. the goals which @@ -971,25 +926,25 @@ END considered). *) TACTIC EXTEND shelve_unifiable | [ "shelve_unifiable" ] -> - [ Proofview.shelve_unifiable ] + { Proofview.shelve_unifiable } END (* Unshelves the goal shelved by the tactic. *) TACTIC EXTEND unshelve | [ "unshelve" tactic1(t) ] -> - [ + { Proofview.with_shelf (Tacinterp.tactic_of_value ist t) >>= fun (gls, ()) -> let gls = List.map Proofview.with_empty_state gls in Proofview.Unsafe.tclGETGOALS >>= fun ogls -> Proofview.Unsafe.tclSETGOALS (gls @ ogls) - ] + } END (* Command to add every unshelved variables to the focus *) VERNAC COMMAND EXTEND Unshelve -[ "Unshelve" ] - => [ Vernac_classifier.classify_as_proofstep ] - -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p) ] +| [ "Unshelve" ] + => { classify_as_proofstep } + -> { Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p) } END (* Gives up on the goals under focus: the goals are considered solved, @@ -997,24 +952,26 @@ END these goals. *) TACTIC EXTEND give_up | [ "give_up" ] -> - [ Proofview.give_up ] + { Proofview.give_up } END (* cycles [n] goals *) TACTIC EXTEND cycle -| [ "cycle" int_or_var(n) ] -> [ Proofview.cycle n ] +| [ "cycle" int_or_var(n) ] -> { Proofview.cycle n } END (* swaps goals number [i] and [j] *) TACTIC EXTEND swap -| [ "swap" int_or_var(i) int_or_var(j) ] -> [ Proofview.swap i j ] +| [ "swap" int_or_var(i) int_or_var(j) ] -> { Proofview.swap i j } END (* reverses the list of focused goals *) TACTIC EXTEND revgoals -| [ "revgoals" ] -> [ Proofview.revgoals ] +| [ "revgoals" ] -> { Proofview.revgoals } END +{ + type cmp = | Eq | Lt | Le @@ -1043,29 +1000,35 @@ let pr_itest = pr_test_gen Pp.int let pr_itest' _prc _prlc _prt = pr_itest +} - -ARGUMENT EXTEND comparison PRINTED BY pr_cmp' -| [ "=" ] -> [ Eq ] -| [ "<" ] -> [ Lt ] -| [ "<=" ] -> [ Le ] -| [ ">" ] -> [ Gt ] -| [ ">=" ] -> [ Ge ] +ARGUMENT EXTEND comparison PRINTED BY { pr_cmp' } +| [ "=" ] -> { Eq } +| [ "<" ] -> { Lt } +| [ "<=" ] -> { Le } +| [ ">" ] -> { Gt } +| [ ">=" ] -> { Ge } END +{ + let interp_test ist gls = function | Test (c,x,y) -> project gls , Test(c,Tacinterp.interp_int_or_var ist x,Tacinterp.interp_int_or_var ist y) +} + ARGUMENT EXTEND test - PRINTED BY pr_itest' - INTERPRETED BY interp_test - RAW_PRINTED BY pr_test' - GLOB_PRINTED BY pr_test' -| [ int_or_var(x) comparison(c) int_or_var(y) ] -> [ Test(c,x,y) ] + PRINTED BY { pr_itest' } + INTERPRETED BY { interp_test } + RAW_PRINTED BY { pr_test' } + GLOB_PRINTED BY { pr_test' } +| [ int_or_var(x) comparison(c) int_or_var(y) ] -> { Test(c,x,y) } END +{ + let interp_cmp = function | Eq -> Int.equal | Lt -> ((<):int->int->bool) @@ -1083,11 +1046,14 @@ let guard tst = let msg = Pp.(str"Condition not satisfied:"++ws 1++(pr_itest tst)) in Tacticals.New.tclZEROMSG msg +} TACTIC EXTEND guard -| [ "guard" test(tst) ] -> [ guard tst ] +| [ "guard" test(tst) ] -> { guard tst } END +{ + let decompose l c = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in @@ -1099,16 +1065,20 @@ let decompose l c = Elim.h_decompose l c end +} + TACTIC EXTEND decompose -| [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> [ decompose l c ] +| [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> { decompose l c } END (** library/keys *) VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF -| [ "Declare" "Equivalent" "Keys" constr(c) constr(c') ] -> [ +| [ "Declare" "Equivalent" "Keys" constr(c) constr(c') ] -> { let get_key c = - let (evd, c) = Constrintern.interp_open_constr (Global.env ()) Evd.empty c in + let env = Global.env () in + let evd = Evd.from_env env in + let (evd, c) = Constrintern.interp_open_constr env evd c in let kind c = EConstr.kind evd c in Keys.constr_key kind c in @@ -1116,26 +1086,30 @@ VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF let k2 = get_key c' in match k1, k2 with | Some k1, Some k2 -> Keys.declare_equiv_keys k1 k2 - | _ -> () ] + | _ -> () } END VERNAC COMMAND EXTEND Print_keys CLASSIFIED AS QUERY -| [ "Print" "Equivalent" "Keys" ] -> [ Feedback.msg_info (Keys.pr_keys Printer.pr_global) ] +| [ "Print" "Equivalent" "Keys" ] -> { Feedback.msg_info (Keys.pr_keys Printer.pr_global) } END VERNAC COMMAND EXTEND OptimizeProof -| [ "Optimize" "Proof" ] => [ Vernac_classifier.classify_as_proofstep ] -> - [ Proof_global.compact_the_proof () ] -| [ "Optimize" "Heap" ] => [ Vernac_classifier.classify_as_proofstep ] -> - [ Gc.compact () ] +| [ "Optimize" "Proof" ] => { classify_as_proofstep } -> + { Proof_global.compact_the_proof () } +| [ "Optimize" "Heap" ] => { classify_as_proofstep } -> + { Gc.compact () } END (** tactic analogous to "OPTIMIZE HEAP" *) +{ + let tclOPTIMIZE_HEAP = Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> Gc.compact ())) +} + TACTIC EXTEND optimize_heap -| [ "optimize_heap" ] -> [ tclOPTIMIZE_HEAP ] +| [ "optimize_heap" ] -> { tclOPTIMIZE_HEAP } END diff --git a/plugins/ltac/g_auto.ml4 b/plugins/ltac/g_auto.mlg index 643f7e99f7..7be8f67616 100644 --- a/plugins/ltac/g_auto.ml4 +++ b/plugins/ltac/g_auto.mlg @@ -8,42 +8,53 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Pp -open Genarg +open Constr open Stdarg open Pcoq.Prim open Pcoq.Constr open Pltac open Hints +let wit_hyp = wit_var + +} + DECLARE PLUGIN "ltac_plugin" (* Hint bases *) TACTIC EXTEND eassumption -| [ "eassumption" ] -> [ Eauto.e_assumption ] +| [ "eassumption" ] -> { Eauto.e_assumption } END TACTIC EXTEND eexact -| [ "eexact" constr(c) ] -> [ Eauto.e_give_exact c ] +| [ "eexact" constr(c) ] -> { Eauto.e_give_exact c } END +{ + let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases +} + ARGUMENT EXTEND hintbases - TYPED AS preident_list_opt - PRINTED BY pr_hintbases -| [ "with" "*" ] -> [ None ] -| [ "with" ne_preident_list(l) ] -> [ Some l ] -| [ ] -> [ Some [] ] + TYPED AS preident list option + PRINTED BY { pr_hintbases } +| [ "with" "*" ] -> { None } +| [ "with" ne_preident_list(l) ] -> { Some l } +| [ ] -> { Some [] } END +{ + let eval_uconstrs ist cs = let flags = { Pretyping.use_typeclasses = false; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = false; expand_evars = true } in @@ -58,104 +69,108 @@ let pr_auto_using _ _ _ = Pptactic.pr_auto_using (let sigma, env = Pfedit.get_current_context () in Printer.pr_closed_glob_env env sigma) +} + ARGUMENT EXTEND auto_using - TYPED AS uconstr_list - PRINTED BY pr_auto_using - RAW_TYPED AS uconstr_list - RAW_PRINTED BY pr_auto_using_raw - GLOB_TYPED AS uconstr_list - GLOB_PRINTED BY pr_auto_using_glob -| [ "using" ne_uconstr_list_sep(l, ",") ] -> [ l ] -| [ ] -> [ [] ] + TYPED AS uconstr list + PRINTED BY { pr_auto_using } + RAW_PRINTED BY { pr_auto_using_raw } + GLOB_PRINTED BY { pr_auto_using_glob } +| [ "using" ne_uconstr_list_sep(l, ",") ] -> { l } +| [ ] -> { [] } END (** Auto *) TACTIC EXTEND trivial | [ "trivial" auto_using(lems) hintbases(db) ] -> - [ Auto.h_trivial (eval_uconstrs ist lems) db ] + { Auto.h_trivial (eval_uconstrs ist lems) db } END TACTIC EXTEND info_trivial | [ "info_trivial" auto_using(lems) hintbases(db) ] -> - [ Auto.h_trivial ~debug:Info (eval_uconstrs ist lems) db ] + { Auto.h_trivial ~debug:Info (eval_uconstrs ist lems) db } END TACTIC EXTEND debug_trivial | [ "debug" "trivial" auto_using(lems) hintbases(db) ] -> - [ Auto.h_trivial ~debug:Debug (eval_uconstrs ist lems) db ] + { Auto.h_trivial ~debug:Debug (eval_uconstrs ist lems) db } END TACTIC EXTEND auto | [ "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ Auto.h_auto n (eval_uconstrs ist lems) db ] + { Auto.h_auto n (eval_uconstrs ist lems) db } END TACTIC EXTEND info_auto | [ "info_auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ Auto.h_auto ~debug:Info n (eval_uconstrs ist lems) db ] + { Auto.h_auto ~debug:Info n (eval_uconstrs ist lems) db } END TACTIC EXTEND debug_auto | [ "debug" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db ] + { Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db } END (** Eauto *) TACTIC EXTEND prolog | [ "prolog" "[" uconstr_list(l) "]" int_or_var(n) ] -> - [ Eauto.prolog_tac (eval_uconstrs ist l) n ] + { Eauto.prolog_tac (eval_uconstrs ist l) n } END +{ + let make_depth n = snd (Eauto.make_dimension n None) +} + TACTIC EXTEND eauto | [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] + { Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db } END TACTIC EXTEND new_eauto | [ "new" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ match db with + { match db with | None -> Auto.new_full_auto (make_depth n) (eval_uconstrs ist lems) - | Some l -> Auto.new_auto (make_depth n) (eval_uconstrs ist lems) l ] + | Some l -> Auto.new_auto (make_depth n) (eval_uconstrs ist lems) l } END TACTIC EXTEND debug_eauto | [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ Eauto.gen_eauto ~debug:Debug (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] + { Eauto.gen_eauto ~debug:Debug (Eauto.make_dimension n p) (eval_uconstrs ist lems) db } END TACTIC EXTEND info_eauto | [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ Eauto.gen_eauto ~debug:Info (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] + { Eauto.gen_eauto ~debug:Info (Eauto.make_dimension n p) (eval_uconstrs ist lems) db } END TACTIC EXTEND dfs_eauto | [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ Eauto.gen_eauto (Eauto.make_dimension p None) (eval_uconstrs ist lems) db ] + { Eauto.gen_eauto (Eauto.make_dimension p None) (eval_uconstrs ist lems) db } END TACTIC EXTEND autounfold -| [ "autounfold" hintbases(db) clause_dft_concl(cl) ] -> [ Eauto.autounfold_tac db cl ] +| [ "autounfold" hintbases(db) clause_dft_concl(cl) ] -> { Eauto.autounfold_tac db cl } END TACTIC EXTEND autounfold_one | [ "autounfold_one" hintbases(db) "in" hyp(id) ] -> - [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) (Some (id, Locus.InHyp)) ] + { Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) (Some (id, Locus.InHyp)) } | [ "autounfold_one" hintbases(db) ] -> - [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None ] + { Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None } END TACTIC EXTEND unify -| ["unify" constr(x) constr(y) ] -> [ Tactics.unify x y ] -| ["unify" constr(x) constr(y) "with" preident(base) ] -> [ +| ["unify" constr(x) constr(y) ] -> { Tactics.unify x y } +| ["unify" constr(x) constr(y) "with" preident(base) ] -> { let table = try Some (Hints.searchtable_map base) with Not_found -> None in match table with | None -> @@ -164,65 +179,69 @@ TACTIC EXTEND unify | Some t -> let state = Hints.Hint_db.transparent_state t in Tactics.unify ~state x y - ] + } END TACTIC EXTEND convert_concl_no_check -| ["convert_concl_no_check" constr(x) ] -> [ Tactics.convert_concl_no_check x Term.DEFAULTcast ] +| ["convert_concl_no_check" constr(x) ] -> { Tactics.convert_concl_no_check x DEFAULTcast } END -let pr_pre_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Libnames.pr_reference +{ + +let pr_pre_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Libnames.pr_qualid let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Printer.pr_global let glob_hints_path_atom ist = Hints.glob_hints_path_atom +} + ARGUMENT EXTEND hints_path_atom - PRINTED BY pr_hints_path_atom + PRINTED BY { pr_hints_path_atom } - GLOBALIZED BY glob_hints_path_atom + GLOBALIZED BY { glob_hints_path_atom } - RAW_PRINTED BY pr_pre_hints_path_atom - GLOB_PRINTED BY pr_hints_path_atom -| [ ne_global_list(g) ] -> [ Hints.PathHints g ] -| [ "_" ] -> [ Hints.PathAny ] + RAW_PRINTED BY { pr_pre_hints_path_atom } + GLOB_PRINTED BY { pr_hints_path_atom } +| [ ne_global_list(g) ] -> { Hints.PathHints g } +| [ "_" ] -> { Hints.PathAny } END +{ + let pr_hints_path prc prx pry c = Hints.pp_hints_path c -let pr_pre_hints_path prc prx pry c = Hints.pp_hints_path_gen Libnames.pr_reference c +let pr_pre_hints_path prc prx pry c = Hints.pp_hints_path_gen Libnames.pr_qualid c let glob_hints_path ist = Hints.glob_hints_path +} + ARGUMENT EXTEND hints_path -PRINTED BY pr_hints_path +PRINTED BY { pr_hints_path } -GLOBALIZED BY glob_hints_path -RAW_PRINTED BY pr_pre_hints_path -GLOB_PRINTED BY pr_hints_path +GLOBALIZED BY { glob_hints_path } +RAW_PRINTED BY { pr_pre_hints_path } +GLOB_PRINTED BY { pr_hints_path } -| [ "(" hints_path(p) ")" ] -> [ p ] -| [ hints_path(p) "*" ] -> [ Hints.PathStar p ] -| [ "emp" ] -> [ Hints.PathEmpty ] -| [ "eps" ] -> [ Hints.PathEpsilon ] -| [ hints_path(p) "|" hints_path(q) ] -> [ Hints.PathOr (p, q) ] -| [ hints_path_atom(a) ] -> [ Hints.PathAtom a ] -| [ hints_path(p) hints_path(q) ] -> [ Hints.PathSeq (p, q) ] +| [ "(" hints_path(p) ")" ] -> { p } +| [ hints_path(p) "*" ] -> { Hints.PathStar p } +| [ "emp" ] -> { Hints.PathEmpty } +| [ "eps" ] -> { Hints.PathEpsilon } +| [ hints_path(p) "|" hints_path(q) ] -> { Hints.PathOr (p, q) } +| [ hints_path_atom(a) ] -> { Hints.PathAtom a } +| [ hints_path(p) hints_path(q) ] -> { Hints.PathSeq (p, q) } END ARGUMENT EXTEND opthints - TYPED AS preident_list_opt - PRINTED BY pr_hintbases -| [ ":" ne_preident_list(l) ] -> [ Some l ] -| [ ] -> [ None ] + TYPED AS preident list option + PRINTED BY { pr_hintbases } +| [ ":" ne_preident_list(l) ] -> { Some l } +| [ ] -> { None } END -VERNAC COMMAND FUNCTIONAL EXTEND HintCut CLASSIFIED AS SIDEFF -| [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [ - fun ~atts ~st -> begin - let open Vernacinterp in +VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF +| #[ locality = Attributes.locality; ] [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> { let entry = Hints.HintsCutEntry (Hints.glob_hints_path p) in - Hints.add_hints (Locality.make_section_locality atts.locality) + Hints.add_hints ~local:(Locality.make_section_locality locality) (match dbnames with None -> ["core"] | Some l -> l) entry; - st - end - ] + } END diff --git a/plugins/ltac/g_class.ml4 b/plugins/ltac/g_class.mlg index 1c2f90b670..9ecc36bdf3 100644 --- a/plugins/ltac/g_class.ml4 +++ b/plugins/ltac/g_class.mlg @@ -8,87 +8,103 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Class_tactics open Stdarg open Tacarg +} + DECLARE PLUGIN "ltac_plugin" (** Options: depth, debug and transparency settings. *) +{ + let set_transparency cl b = List.iter (fun r -> let gr = Smartlocate.global_with_alias r in let ev = Tacred.evaluable_of_global_reference (Global.env ()) gr in Classes.set_typeclass_transparency ev (Locality.make_section_locality None) b) cl +} + VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings CLASSIFIED AS SIDEFF -| [ "Typeclasses" "Transparent" reference_list(cl) ] -> [ - set_transparency cl true ] +| [ "Typeclasses" "Transparent" reference_list(cl) ] -> { + set_transparency cl true } END VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings CLASSIFIED AS SIDEFF -| [ "Typeclasses" "Opaque" reference_list(cl) ] -> [ - set_transparency cl false ] +| [ "Typeclasses" "Opaque" reference_list(cl) ] -> { + set_transparency cl false } END -open Genarg +{ let pr_debug _prc _prlc _prt b = if b then Pp.str "debug" else Pp.mt() -ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug -| [ "debug" ] -> [ true ] -| [ ] -> [ false ] +} + +ARGUMENT EXTEND debug TYPED AS bool PRINTED BY { pr_debug } +| [ "debug" ] -> { true } +| [ ] -> { false } END +{ + let pr_search_strategy _prc _prlc _prt = function | Some Dfs -> Pp.str "dfs" | Some Bfs -> Pp.str "bfs" | None -> Pp.mt () -ARGUMENT EXTEND eauto_search_strategy PRINTED BY pr_search_strategy -| [ "(bfs)" ] -> [ Some Bfs ] -| [ "(dfs)" ] -> [ Some Dfs ] -| [ ] -> [ None ] +} + +ARGUMENT EXTEND eauto_search_strategy PRINTED BY { pr_search_strategy } +| [ "(bfs)" ] -> { Some Bfs } +| [ "(dfs)" ] -> { Some Dfs } +| [ ] -> { None } END (* true = All transparent, false = Opaque if possible *) VERNAC COMMAND EXTEND Typeclasses_Settings CLASSIFIED AS SIDEFF - | [ "Typeclasses" "eauto" ":=" debug(d) eauto_search_strategy(s) int_opt(depth) ] -> [ + | [ "Typeclasses" "eauto" ":=" debug(d) eauto_search_strategy(s) int_opt(depth) ] -> { set_typeclasses_debug d; Option.iter set_typeclasses_strategy s; set_typeclasses_depth depth - ] + } END (** Compatibility: typeclasses eauto has 8.5 and 8.6 modes *) TACTIC EXTEND typeclasses_eauto | [ "typeclasses" "eauto" "bfs" int_or_var_opt(d) "with" ne_preident_list(l) ] -> - [ typeclasses_eauto ~strategy:Bfs ~depth:d l ] + { typeclasses_eauto ~strategy:Bfs ~depth:d l } | [ "typeclasses" "eauto" int_or_var_opt(d) "with" ne_preident_list(l) ] -> - [ typeclasses_eauto ~depth:d l ] - | [ "typeclasses" "eauto" int_or_var_opt(d) ] -> [ - typeclasses_eauto ~only_classes:true ~depth:d [Hints.typeclasses_db] ] + { typeclasses_eauto ~depth:d l } + | [ "typeclasses" "eauto" int_or_var_opt(d) ] -> { + typeclasses_eauto ~only_classes:true ~depth:d [Hints.typeclasses_db] } END TACTIC EXTEND head_of_constr - [ "head_of_constr" ident(h) constr(c) ] -> [ head_of_constr h c ] +| [ "head_of_constr" ident(h) constr(c) ] -> { head_of_constr h c } END TACTIC EXTEND not_evar - [ "not_evar" constr(ty) ] -> [ not_evar ty ] +| [ "not_evar" constr(ty) ] -> { not_evar ty } END TACTIC EXTEND is_ground - [ "is_ground" constr(ty) ] -> [ is_ground ty ] +| [ "is_ground" constr(ty) ] -> { is_ground ty } END TACTIC EXTEND autoapply - [ "autoapply" constr(c) "using" preident(i) ] -> [ autoapply c i ] +| [ "autoapply" constr(c) "using" preident(i) ] -> { autoapply c i } END +{ + (** TODO: DEPRECATE *) (* A progress test that allows to see if the evars have changed *) open Constr @@ -114,6 +130,8 @@ let progress_evars t = in t <*> check end +} + TACTIC EXTEND progress_evars - [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.tactic_of_value ist t) ] +| [ "progress_evars" tactic(t) ] -> { progress_evars (Tacinterp.tactic_of_value ist t) } END diff --git a/plugins/ltac/g_eqdecide.ml4 b/plugins/ltac/g_eqdecide.mlg index 2251a66204..e57afe3e33 100644 --- a/plugins/ltac/g_eqdecide.ml4 +++ b/plugins/ltac/g_eqdecide.mlg @@ -14,15 +14,19 @@ (* by Eduardo Gimenez *) (************************************************************************) +{ + open Eqdecide open Stdarg +} + DECLARE PLUGIN "ltac_plugin" TACTIC EXTEND decide_equality -| [ "decide" "equality" ] -> [ decideEqualityGoal ] +| [ "decide" "equality" ] -> { decideEqualityGoal } END TACTIC EXTEND compare -| [ "compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ] +| [ "compare" constr(c1) constr(c2) ] -> { compare c1 c2 } END diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4 deleted file mode 100644 index 0c42a8bb28..0000000000 --- a/plugins/ltac/g_ltac.ml4 +++ /dev/null @@ -1,521 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -DECLARE PLUGIN "ltac_plugin" - -open Util -open Pp -open Constrexpr -open Tacexpr -open Misctypes -open Genarg -open Genredexpr -open Tok (* necessary for camlp5 *) -open Names - -open Pcoq -open Pcoq.Constr -open Pcoq.Vernac_ -open Pcoq.Prim -open Pltac - -let fail_default_value = ArgArg 0 - -let arg_of_expr = function - TacArg (loc,a) -> a - | e -> Tacexp (e:raw_tactic_expr) - -let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () -let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n -let genarg_of_ipattern pat = in_gen (rawwit Stdarg.wit_intro_pattern) pat -let genarg_of_uconstr c = in_gen (rawwit Stdarg.wit_uconstr) c -let in_tac tac = in_gen (rawwit Tacarg.wit_ltac) tac - -let reference_to_id = CAst.map_with_loc (fun ?loc -> function - | Libnames.Ident id -> id - | Libnames.Qualid _ -> - CErrors.user_err ?loc - (str "This expression should be a simple identifier.")) - -let tactic_mode = Gram.entry_create "vernac:tactic_command" - -let new_entry name = - let e = Gram.entry_create name in - e - -let toplevel_selector = new_entry "vernac:toplevel_selector" -let tacdef_body = new_entry "tactic:tacdef_body" - -(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for - proof editing and changes nothing else). Then sets it as the default proof mode. *) -let _ = - let mode = { - Proof_global.name = "Classic"; - set = (fun () -> set_command_entry tactic_mode); - reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode); - } in - Proof_global.register_proof_mode mode - -(* Hack to parse "[ id" without dropping [ *) -let test_bracket_ident = - Gram.Entry.of_parser "test_bracket_ident" - (fun strm -> - match stream_nth 0 strm with - | KEYWORD "[" -> - (match stream_nth 1 strm with - | IDENT _ -> () - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) - -(* Tactics grammar rules *) - -let hint = G_proofs.hint - -GEXTEND Gram - GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg command hint - tactic_mode constr_may_eval constr_eval toplevel_selector - operconstr; - - tactic_then_last: - [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" -> - Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) - | -> [||] - ] ] - ; - tactic_then_gen: - [ [ ta = tactic_expr; "|"; (first,last) = tactic_then_gen -> (ta::first, last) - | ta = tactic_expr; ".."; l = tactic_then_last -> ([], Some (ta, l)) - | ".."; l = tactic_then_last -> ([], Some (TacId [], l)) - | ta = tactic_expr -> ([ta], None) - | "|"; (first,last) = tactic_then_gen -> (TacId [] :: first, last) - | -> ([TacId []], None) - ] ] - ; - tactic_then_locality: (* [true] for the local variant [TacThens] and [false] - for [TacExtend] *) - [ [ "[" ; l = OPT">" -> if Option.is_empty l then true else false ] ] - ; - tactic_expr: - [ "5" RIGHTA - [ te = binder_tactic -> te ] - | "4" LEFTA - [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> TacThen (ta0, ta1) - | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0,ta1) - | ta0 = tactic_expr; ";"; l = tactic_then_locality; (first,tail) = tactic_then_gen; "]" -> - match l , tail with - | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last)) - | true , Some (t,last) -> TacThens3parts (ta0, Array.of_list first, t, last) - | false , None -> TacThen (ta0,TacDispatch first) - | true , None -> TacThens (ta0,first) ] - | "3" RIGHTA - [ IDENT "try"; ta = tactic_expr -> TacTry ta - | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta) - | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> TacTimeout (n,ta) - | IDENT "time"; s = OPT string; ta = tactic_expr -> TacTime (s,ta) - | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta - | IDENT "progress"; ta = tactic_expr -> TacProgress ta - | IDENT "once"; ta = tactic_expr -> TacOnce ta - | IDENT "exactly_once"; ta = tactic_expr -> TacExactlyOnce ta - | IDENT "infoH"; ta = tactic_expr -> TacShowHyps ta -(*To do: put Abstract in Refiner*) - | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None) - | IDENT "abstract"; tc = NEXT; "using"; s = ident -> - TacAbstract (tc,Some s) - | sel = selector; ta = tactic_expr -> TacSelect (sel, ta) ] -(*End of To do*) - | "2" RIGHTA - [ ta0 = tactic_expr; "+"; ta1 = binder_tactic -> TacOr (ta0,ta1) - | ta0 = tactic_expr; "+"; ta1 = tactic_expr -> TacOr (ta0,ta1) - | IDENT "tryif" ; ta = tactic_expr ; - "then" ; tat = tactic_expr ; - "else" ; tae = tactic_expr -> TacIfThenCatch(ta,tat,tae) - | ta0 = tactic_expr; "||"; ta1 = binder_tactic -> TacOrelse (ta0,ta1) - | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ] - | "1" RIGHTA - [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" -> - TacMatchGoal (b,false,mrl) - | b = match_key; IDENT "reverse"; IDENT "goal"; "with"; - mrl = match_context_list; "end" -> - TacMatchGoal (b,true,mrl) - | b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" -> - TacMatch (b,c,mrl) - | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> - TacFirst l - | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> - TacSolve l - | IDENT "idtac"; l = LIST0 message_token -> TacId l - | g=failkw; n = [ n = int_or_var -> n | -> fail_default_value ]; - l = LIST0 message_token -> TacFail (g,n,l) - | st = simple_tactic -> st - | a = tactic_arg -> TacArg(Loc.tag ~loc:!@loc a) - | r = reference; la = LIST0 tactic_arg_compat -> - TacArg(Loc.tag ~loc:!@loc @@ TacCall (Loc.tag ~loc:!@loc (r,la))) ] - | "0" - [ "("; a = tactic_expr; ")" -> a - | "["; ">"; (tf,tail) = tactic_then_gen; "]" -> - begin match tail with - | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) - | None -> TacDispatch tf - end - | a = tactic_atom -> TacArg (Loc.tag ~loc:!@loc a) ] ] - ; - failkw: - [ [ IDENT "fail" -> TacLocal | IDENT "gfail" -> TacGlobal ] ] - ; - (* binder_tactic: level 5 of tactic_expr *) - binder_tactic: - [ RIGHTA - [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" -> - TacFun (it,body) - | "let"; isrec = [IDENT "rec" -> true | -> false]; - llc = LIST1 let_clause SEP "with"; "in"; - body = tactic_expr LEVEL "5" -> TacLetIn (isrec,llc,body) - | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ] - ; - (* Tactic arguments to the right of an application *) - tactic_arg_compat: - [ [ a = tactic_arg -> a - | c = Constr.constr -> (match c with { CAst.v = CRef (r,None) } -> Reference r | c -> ConstrMayEval (ConstrTerm c)) - (* Unambiguous entries: tolerated w/o "ltac:" modifier *) - | "()" -> TacGeneric (genarg_of_unit ()) ] ] - ; - (* Can be used as argument and at toplevel in tactic expressions. *) - tactic_arg: - [ [ c = constr_eval -> ConstrMayEval c - | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l - | IDENT "type_term"; c=uconstr -> TacPretype c - | IDENT "numgoals" -> TacNumgoals ] ] - ; - (* If a qualid is given, use its short name. TODO: have the shortest - non ambiguous name where dots are replaced by "_"? Probably too - verbose most of the time. *) - fresh_id: - [ [ s = STRING -> ArgArg s (*| id = ident -> ArgVar (!@loc,id)*) - | qid = qualid -> let (_pth,id) = Libnames.repr_qualid qid.CAst.v in - ArgVar (CAst.make ~loc:!@loc id) ] ] - ; - constr_eval: - [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> - ConstrEval (rtc,c) - | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" -> - ConstrContext (id,c) - | IDENT "type"; IDENT "of"; c = Constr.constr -> - ConstrTypeOf c ] ] - ; - constr_may_eval: (* For extensions *) - [ [ c = constr_eval -> c - | c = Constr.constr -> ConstrTerm c ] ] - ; - tactic_atom: - [ [ n = integer -> TacGeneric (genarg_of_int n) - | r = reference -> TacCall (Loc.tag ~loc:!@loc (r,[])) - | "()" -> TacGeneric (genarg_of_unit ()) ] ] - ; - match_key: - [ [ "match" -> Once - | "lazymatch" -> Select - | "multimatch" -> General ] ] - ; - input_fun: - [ [ "_" -> Name.Anonymous - | l = ident -> Name.Name l ] ] - ; - let_clause: - [ [ idr = identref; ":="; te = tactic_expr -> - (CAst.map (fun id -> Name id) idr, arg_of_expr te) - | na = ["_" -> CAst.make ~loc:!@loc Anonymous]; ":="; te = tactic_expr -> - (na, arg_of_expr te) - | idr = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> - (CAst.map (fun id -> Name id) idr, arg_of_expr (TacFun(args,te))) ] ] - ; - match_pattern: - [ [ IDENT "context"; oid = OPT Constr.ident; - "["; pc = Constr.lconstr_pattern; "]" -> - Subterm (oid, pc) - | pc = Constr.lconstr_pattern -> Term pc ] ] - ; - match_hyps: - [ [ na = name; ":"; mp = match_pattern -> Hyp (na, mp) - | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> Def (na, mpv, mpt) - | na = name; ":="; mpv = match_pattern -> - let t, ty = - match mpv with - | Term t -> (match t with - | { CAst.v = CCast (t, (CastConv ty | CastVM ty | CastNative ty)) } -> Term t, Some (Term ty) - | _ -> mpv, None) - | _ -> mpv, None - in Def (na, t, Option.default (Term (CAst.make @@ CHole (None, IntroAnonymous, None))) ty) - ] ] - ; - match_context_rule: - [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; - "=>"; te = tactic_expr -> Pat (largs, mp, te) - | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; - "]"; "=>"; te = tactic_expr -> Pat (largs, mp, te) - | "_"; "=>"; te = tactic_expr -> All te ] ] - ; - match_context_list: - [ [ mrl = LIST1 match_context_rule SEP "|" -> mrl - | "|"; mrl = LIST1 match_context_rule SEP "|" -> mrl ] ] - ; - match_rule: - [ [ mp = match_pattern; "=>"; te = tactic_expr -> Pat ([],mp,te) - | "_"; "=>"; te = tactic_expr -> All te ] ] - ; - match_list: - [ [ mrl = LIST1 match_rule SEP "|" -> mrl - | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ] - ; - message_token: - [ [ id = identref -> MsgIdent id - | s = STRING -> MsgString s - | n = integer -> MsgInt n ] ] - ; - - ltac_def_kind: - [ [ ":=" -> false - | "::=" -> true ] ] - ; - - (* Definitions for tactics *) - tacdef_body: - [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> - if redef then Tacexpr.TacticRedefinition (name, TacFun (it, body)) - else - let id = reference_to_id name in - Tacexpr.TacticDefinition (id, TacFun (it, body)) - | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> - if redef then Tacexpr.TacticRedefinition (name, body) - else - let id = reference_to_id name in - Tacexpr.TacticDefinition (id, body) - ] ] - ; - tactic: - [ [ tac = tactic_expr -> tac ] ] - ; - - range_selector: - [ [ n = natural ; "-" ; m = natural -> (n, m) - | n = natural -> (n, n) ] ] - ; - (* We unfold a range selectors list once so that we can make a special case - * for a unique SelectNth selector. *) - range_selector_or_nth: - [ [ n = natural ; "-" ; m = natural; - l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> - SelectList ((n, m) :: Option.default [] l) - | n = natural; - l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> - Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l ] ] - ; - selector_body: - [ [ l = range_selector_or_nth -> l - | test_bracket_ident; "["; id = ident; "]" -> SelectId id ] ] - ; - selector: - [ [ IDENT "only"; sel = selector_body; ":" -> sel ] ] - ; - toplevel_selector: - [ [ sel = selector_body; ":" -> sel - | IDENT "all"; ":" -> SelectAll ] ] - ; - tactic_mode: - [ [ g = OPT toplevel_selector; tac = G_vernac.query_command -> tac g - | g = OPT toplevel_selector; "{" -> Vernacexpr.VernacSubproof g ] ] - ; - command: - [ [ IDENT "Proof"; "with"; ta = Pltac.tactic; - l = OPT [ "using"; l = G_vernac.section_subset_expr -> l ] -> - Vernacexpr.VernacProof (Some (in_tac ta), l) - | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr; - ta = OPT [ "with"; ta = Pltac.tactic -> in_tac ta ] -> - Vernacexpr.VernacProof (ta,Some l) ] ] - ; - hint: - [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; - tac = Pltac.tactic -> - Vernacexpr.HintsExtern (n,c, in_tac tac) ] ] - ; - operconstr: LEVEL "0" - [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> - let arg = Genarg.in_gen (Genarg.rawwit Tacarg.wit_tactic) tac in - CAst.make ~loc:!@loc @@ CHole (None, IntroAnonymous, Some arg) ] ] - ; - END - -open Stdarg -open Tacarg -open Vernacexpr -open Vernac_classifier -open Goptions -open Libnames - -let print_info_trace = ref None - -let _ = declare_int_option { - optdepr = false; - optname = "print info trace"; - optkey = ["Info" ; "Level"]; - optread = (fun () -> !print_info_trace); - optwrite = fun n -> print_info_trace := n; -} - -let vernac_solve n info tcom b = - let status = Proof_global.with_current_proof (fun etac p -> - let with_end_tac = if b then Some etac else None in - let global = match n with SelectAll | SelectList _ -> true | _ -> false in - let info = Option.append info !print_info_trace in - let (p,status) = - Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p - in - (* in case a strict subtree was completed, - go back to the top of the prooftree *) - let p = Proof.maximal_unfocus Vernacentries.command_focus p in - p,status) in - if not status then Feedback.feedback Feedback.AddedAxiom - -let pr_ltac_selector s = Pptactic.pr_goal_selector ~toplevel:true s - -VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector -| [ toplevel_selector(s) ] -> [ s ] -END - -let pr_ltac_info n = str "Info" ++ spc () ++ int n - -VERNAC ARGUMENT EXTEND ltac_info PRINTED BY pr_ltac_info -| [ "Info" natural(n) ] -> [ n ] -END - -let pr_ltac_use_default b = - if b then (* Bug: a space is inserted before "..." *) str ".." else mt () - -VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY pr_ltac_use_default -| [ "." ] -> [ false ] -| [ "..." ] -> [ true ] -END - -let is_anonymous_abstract = function - | TacAbstract (_,None) -> true - | TacSolve [TacAbstract (_,None)] -> true - | _ -> false -let rm_abstract = function - | TacAbstract (t,_) -> t - | TacSolve [TacAbstract (t,_)] -> TacSolve [t] - | x -> x -let is_explicit_terminator = function TacSolve _ -> true | _ -> false - -VERNAC tactic_mode EXTEND VernacSolve -| [ - ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => - [ classify_as_proofstep ] -> [ - let g = Option.default (Proof_bullet.get_default_goal_selector ()) g in - vernac_solve g n t def - ] -| [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => - [ - let anon_abstracting_tac = is_anonymous_abstract t in - let solving_tac = is_explicit_terminator t in - let parallel = `Yes (solving_tac,anon_abstracting_tac) in - let pbr = if solving_tac then Some "par" else None in - VtProofStep{ parallel = parallel; proof_block_detection = pbr }, - VtLater - ] -> [ - let t = rm_abstract t in - vernac_solve SelectAll n t def - ] -END - -let pr_ltac_tactic_level n = str "(at level " ++ int n ++ str ")" - -VERNAC ARGUMENT EXTEND ltac_tactic_level PRINTED BY pr_ltac_tactic_level -| [ "(" "at" "level" natural(n) ")" ] -> [ n ] -END - -VERNAC ARGUMENT EXTEND ltac_production_sep -| [ "," string(sep) ] -> [ sep ] -END - -let pr_ltac_production_item = function -| Tacentries.TacTerm s -> quote (str s) -| Tacentries.TacNonTerm (_, ((arg, None), None)) -> str arg -| Tacentries.TacNonTerm (_, ((arg, Some _), None)) -> assert false -| Tacentries.TacNonTerm (_, ((arg, sep), Some id)) -> - let sep = match sep with - | None -> mt () - | Some sep -> str "," ++ spc () ++ quote (str sep) - in - str arg ++ str "(" ++ Id.print id ++ sep ++ str ")" - -VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY pr_ltac_production_item -| [ string(s) ] -> [ Tacentries.TacTerm s ] -| [ ident(nt) "(" ident(p) ltac_production_sep_opt(sep) ")" ] -> - [ Tacentries.TacNonTerm (Loc.tag ~loc ((Id.to_string nt, sep), Some p)) ] -| [ ident(nt) ] -> - [ Tacentries.TacNonTerm (Loc.tag ~loc ((Id.to_string nt, None), None)) ] -END - -VERNAC COMMAND FUNCTIONAL EXTEND VernacTacticNotation -| [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] => - [ VtSideff [], VtNow ] -> - [ fun ~atts ~st -> let open Vernacinterp in - let n = Option.default 0 n in - Tacentries.add_tactic_notation (Locality.make_module_locality atts.locality) n r e; - st - ] -END - -VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY -| [ "Print" "Ltac" reference(r) ] -> - [ Feedback.msg_notice (Tacintern.print_ltac (Libnames.qualid_of_reference r).CAst.v) ] -END - -VERNAC COMMAND EXTEND VernacLocateLtac CLASSIFIED AS QUERY -| [ "Locate" "Ltac" reference(r) ] -> - [ Tacentries.print_located_tactic r ] -END - -let pr_ltac_ref = Libnames.pr_reference - -let pr_tacdef_body tacdef_body = - let id, redef, body = - match tacdef_body with - | TacticDefinition ({CAst.v=id}, body) -> Id.print id, false, body - | TacticRedefinition (id, body) -> pr_ltac_ref id, true, body - in - let idl, body = - match body with - | Tacexpr.TacFun (idl,b) -> idl,b - | _ -> [], body in - id ++ - prlist (function Name.Anonymous -> str " _" - | Name.Name id -> spc () ++ Id.print id) idl - ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) - ++ Pptactic.pr_raw_tactic body - -VERNAC ARGUMENT EXTEND ltac_tacdef_body -PRINTED BY pr_tacdef_body -| [ tacdef_body(t) ] -> [ t ] -END - -VERNAC COMMAND FUNCTIONAL EXTEND VernacDeclareTacticDefinition -| [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => [ - VtSideff (List.map (function - | TacticDefinition ({CAst.v=r},_) -> r - | TacticRedefinition ({CAst.v=Ident r},_) -> r - | TacticRedefinition ({CAst.v=Qualid q},_) -> snd(repr_qualid q)) l), VtLater - ] -> [ fun ~atts ~st -> let open Vernacinterp in - Tacentries.register_ltac (Locality.make_module_locality atts.locality) l; - st - ] -END - -VERNAC COMMAND EXTEND VernacPrintLtacs CLASSIFIED AS QUERY -| [ "Print" "Ltac" "Signatures" ] -> [ Tacentries.print_ltacs () ] -END diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg new file mode 100644 index 0000000000..338839ee96 --- /dev/null +++ b/plugins/ltac/g_ltac.mlg @@ -0,0 +1,559 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +DECLARE PLUGIN "ltac_plugin" + +{ + +open Util +open Pp +open Glob_term +open Constrexpr +open Tacexpr +open Namegen +open Genarg +open Genredexpr +open Tok (* necessary for camlp5 *) +open Names +open Attributes + +open Pcoq +open Pcoq.Prim +open Pcoq.Constr +open Pvernac.Vernac_ +open Pltac + +let fail_default_value = Locus.ArgArg 0 + +let arg_of_expr = function + TacArg { CAst.v } -> v + | e -> Tacexp (e:raw_tactic_expr) + +let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () +let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n +let genarg_of_ipattern pat = in_gen (rawwit Tacarg.wit_intro_pattern) pat +let genarg_of_uconstr c = in_gen (rawwit Stdarg.wit_uconstr) c +let in_tac tac = in_gen (rawwit Tacarg.wit_ltac) tac + +let reference_to_id qid = + if Libnames.qualid_is_ident qid then + CAst.make ?loc:qid.CAst.loc @@ Libnames.qualid_basename qid + else + CErrors.user_err ?loc:qid.CAst.loc + (str "This expression should be a simple identifier.") + +let tactic_mode = Entry.create "vernac:tactic_command" + +let new_entry name = + let e = Entry.create name in + e + +let toplevel_selector = new_entry "vernac:toplevel_selector" +let tacdef_body = new_entry "tactic:tacdef_body" + +(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for + proof editing and changes nothing else). Then sets it as the default proof mode. *) +let _ = + let mode = { + Proof_global.name = "Classic"; + set = (fun () -> Pvernac.set_command_entry tactic_mode); + reset = (fun () -> Pvernac.(set_command_entry noedit_mode)); + } in + Proof_global.register_proof_mode mode + +(* Hack to parse "[ id" without dropping [ *) +let test_bracket_ident = + Pcoq.Entry.of_parser "test_bracket_ident" + (fun strm -> + match stream_nth 0 strm with + | KEYWORD "[" -> + (match stream_nth 1 strm with + | IDENT _ -> () + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + +(* Tactics grammar rules *) + +let hint = G_proofs.hint + +} + +GRAMMAR EXTEND Gram + GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg command hint + tactic_mode constr_may_eval constr_eval toplevel_selector + operconstr; + + tactic_then_last: + [ [ "|"; lta = LIST0 (OPT tactic_expr) SEP "|" -> + { Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) } + | -> { [||] } + ] ] + ; + tactic_then_gen: + [ [ ta = tactic_expr; "|"; tg = tactic_then_gen -> { let (first,last) = tg in (ta::first, last) } + | ta = tactic_expr; ".."; l = tactic_then_last -> { ([], Some (ta, l)) } + | ".."; l = tactic_then_last -> { ([], Some (TacId [], l)) } + | ta = tactic_expr -> { ([ta], None) } + | "|"; tg = tactic_then_gen -> { let (first,last) = tg in (TacId [] :: first, last) } + | -> { ([TacId []], None) } + ] ] + ; + tactic_then_locality: (* [true] for the local variant [TacThens] and [false] + for [TacExtend] *) + [ [ "[" ; l = OPT">" -> { if Option.is_empty l then true else false } ] ] + ; + tactic_expr: + [ "5" RIGHTA + [ te = binder_tactic -> { te } ] + | "4" LEFTA + [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> { TacThen (ta0, ta1) } + | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> { TacThen (ta0,ta1) } + | ta0 = tactic_expr; ";"; l = tactic_then_locality; tg = tactic_then_gen; "]" -> { + let (first,tail) = tg in + match l , tail with + | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last)) + | true , Some (t,last) -> TacThens3parts (ta0, Array.of_list first, t, last) + | false , None -> TacThen (ta0,TacDispatch first) + | true , None -> TacThens (ta0,first) } ] + | "3" RIGHTA + [ IDENT "try"; ta = tactic_expr -> { TacTry ta } + | IDENT "do"; n = int_or_var; ta = tactic_expr -> { TacDo (n,ta) } + | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> { TacTimeout (n,ta) } + | IDENT "time"; s = OPT string; ta = tactic_expr -> { TacTime (s,ta) } + | IDENT "repeat"; ta = tactic_expr -> { TacRepeat ta } + | IDENT "progress"; ta = tactic_expr -> { TacProgress ta } + | IDENT "once"; ta = tactic_expr -> { TacOnce ta } + | IDENT "exactly_once"; ta = tactic_expr -> { TacExactlyOnce ta } + | IDENT "infoH"; ta = tactic_expr -> { TacShowHyps ta } +(*To do: put Abstract in Refiner*) + | IDENT "abstract"; tc = NEXT -> { TacAbstract (tc,None) } + | IDENT "abstract"; tc = NEXT; "using"; s = ident -> + { TacAbstract (tc,Some s) } + | sel = selector; ta = tactic_expr -> { TacSelect (sel, ta) } ] +(*End of To do*) + | "2" RIGHTA + [ ta0 = tactic_expr; "+"; ta1 = binder_tactic -> { TacOr (ta0,ta1) } + | ta0 = tactic_expr; "+"; ta1 = tactic_expr -> { TacOr (ta0,ta1) } + | IDENT "tryif" ; ta = tactic_expr ; + "then" ; tat = tactic_expr ; + "else" ; tae = tactic_expr -> { TacIfThenCatch(ta,tat,tae) } + | ta0 = tactic_expr; "||"; ta1 = binder_tactic -> { TacOrelse (ta0,ta1) } + | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> { TacOrelse (ta0,ta1) } ] + | "1" RIGHTA + [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" -> + { TacMatchGoal (b,false,mrl) } + | b = match_key; IDENT "reverse"; IDENT "goal"; "with"; + mrl = match_context_list; "end" -> + { TacMatchGoal (b,true,mrl) } + | b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" -> + { TacMatch (b,c,mrl) } + | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + { TacFirst l } + | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + { TacSolve l } + | IDENT "idtac"; l = LIST0 message_token -> { TacId l } + | g=failkw; n = [ n = int_or_var -> { n } | -> { fail_default_value } ]; + l = LIST0 message_token -> { TacFail (g,n,l) } + | st = simple_tactic -> { st } + | a = tactic_arg -> { TacArg(CAst.make ~loc a) } + | r = reference; la = LIST0 tactic_arg_compat -> + { TacArg(CAst.make ~loc @@ TacCall (CAst.make ~loc (r,la))) } ] + | "0" + [ "("; a = tactic_expr; ")" -> { a } + | "["; ">"; tg = tactic_then_gen; "]" -> { + let (tf,tail) = tg in + begin match tail with + | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) + | None -> TacDispatch tf + end } + | a = tactic_atom -> { TacArg (CAst.make ~loc a) } ] ] + ; + failkw: + [ [ IDENT "fail" -> { TacLocal } | IDENT "gfail" -> { TacGlobal } ] ] + ; + (* binder_tactic: level 5 of tactic_expr *) + binder_tactic: + [ RIGHTA + [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" -> + { TacFun (it,body) } + | "let"; isrec = [IDENT "rec" -> { true } | -> { false } ]; + llc = LIST1 let_clause SEP "with"; "in"; + body = tactic_expr LEVEL "5" -> { TacLetIn (isrec,llc,body) } + | IDENT "info"; tc = tactic_expr LEVEL "5" -> { TacInfo tc } ] ] + ; + (* Tactic arguments to the right of an application *) + tactic_arg_compat: + [ [ a = tactic_arg -> { a } + | c = Constr.constr -> { (match c with { CAst.v = CRef (r,None) } -> Reference r | c -> ConstrMayEval (ConstrTerm c)) } + (* Unambiguous entries: tolerated w/o "ltac:" modifier *) + | "()" -> { TacGeneric (genarg_of_unit ()) } ] ] + ; + (* Can be used as argument and at toplevel in tactic expressions. *) + tactic_arg: + [ [ c = constr_eval -> { ConstrMayEval c } + | IDENT "fresh"; l = LIST0 fresh_id -> { TacFreshId l } + | IDENT "type_term"; c=uconstr -> { TacPretype c } + | IDENT "numgoals" -> { TacNumgoals } ] ] + ; + (* If a qualid is given, use its short name. TODO: have the shortest + non ambiguous name where dots are replaced by "_"? Probably too + verbose most of the time. *) + fresh_id: + [ [ s = STRING -> { Locus.ArgArg s (*| id = ident -> Locus.ArgVar (!@loc,id)*) } + | qid = qualid -> { Locus.ArgVar (CAst.make ~loc @@ Libnames.qualid_basename qid) } ] ] + ; + constr_eval: + [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> + { ConstrEval (rtc,c) } + | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" -> + { ConstrContext (id,c) } + | IDENT "type"; IDENT "of"; c = Constr.constr -> + { ConstrTypeOf c } ] ] + ; + constr_may_eval: (* For extensions *) + [ [ c = constr_eval -> { c } + | c = Constr.constr -> { ConstrTerm c } ] ] + ; + tactic_atom: + [ [ n = integer -> { TacGeneric (genarg_of_int n) } + | r = reference -> { TacCall (CAst.make ~loc (r,[])) } + | "()" -> { TacGeneric (genarg_of_unit ()) } ] ] + ; + match_key: + [ [ "match" -> { Once } + | "lazymatch" -> { Select } + | "multimatch" -> { General } ] ] + ; + input_fun: + [ [ "_" -> { Name.Anonymous } + | l = ident -> { Name.Name l } ] ] + ; + let_clause: + [ [ idr = identref; ":="; te = tactic_expr -> + { (CAst.map (fun id -> Name id) idr, arg_of_expr te) } + | na = ["_" -> { CAst.make ~loc Anonymous } ]; ":="; te = tactic_expr -> + { (na, arg_of_expr te) } + | idr = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> + { (CAst.map (fun id -> Name id) idr, arg_of_expr (TacFun(args,te))) } ] ] + ; + match_pattern: + [ [ IDENT "context"; oid = OPT Constr.ident; + "["; pc = Constr.lconstr_pattern; "]" -> + { Subterm (oid, pc) } + | pc = Constr.lconstr_pattern -> { Term pc } ] ] + ; + match_hyps: + [ [ na = name; ":"; mp = match_pattern -> { Hyp (na, mp) } + | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> { Def (na, mpv, mpt) } + | na = name; ":="; mpv = match_pattern -> + { let t, ty = + match mpv with + | Term t -> (match t with + | { CAst.v = CCast (t, (CastConv ty | CastVM ty | CastNative ty)) } -> Term t, Some (Term ty) + | _ -> mpv, None) + | _ -> mpv, None + in Def (na, t, Option.default (Term (CAst.make @@ CHole (None, IntroAnonymous, None))) ty) } + ] ] + ; + match_context_rule: + [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; + "=>"; te = tactic_expr -> { Pat (largs, mp, te) } + | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; + "]"; "=>"; te = tactic_expr -> { Pat (largs, mp, te) } + | "_"; "=>"; te = tactic_expr -> { All te } ] ] + ; + match_context_list: + [ [ mrl = LIST1 match_context_rule SEP "|" -> { mrl } + | "|"; mrl = LIST1 match_context_rule SEP "|" -> { mrl } ] ] + ; + match_rule: + [ [ mp = match_pattern; "=>"; te = tactic_expr -> { Pat ([],mp,te) } + | "_"; "=>"; te = tactic_expr -> { All te } ] ] + ; + match_list: + [ [ mrl = LIST1 match_rule SEP "|" -> { mrl } + | "|"; mrl = LIST1 match_rule SEP "|" -> { mrl } ] ] + ; + message_token: + [ [ id = identref -> { MsgIdent id } + | s = STRING -> { MsgString s } + | n = integer -> { MsgInt n } ] ] + ; + + ltac_def_kind: + [ [ ":=" -> { false } + | "::=" -> { true } ] ] + ; + + (* Definitions for tactics *) + tacdef_body: + [ [ name = Constr.global; it=LIST1 input_fun; + redef = ltac_def_kind; body = tactic_expr -> + { if redef then Tacexpr.TacticRedefinition (name, TacFun (it, body)) + else + let id = reference_to_id name in + Tacexpr.TacticDefinition (id, TacFun (it, body)) } + | name = Constr.global; redef = ltac_def_kind; + body = tactic_expr -> + { if redef then Tacexpr.TacticRedefinition (name, body) + else + let id = reference_to_id name in + Tacexpr.TacticDefinition (id, body) } + ] ] + ; + tactic: + [ [ tac = tactic_expr -> { tac } ] ] + ; + + range_selector: + [ [ n = natural ; "-" ; m = natural -> { (n, m) } + | n = natural -> { (n, n) } ] ] + ; + (* We unfold a range selectors list once so that we can make a special case + * for a unique SelectNth selector. *) + range_selector_or_nth: + [ [ n = natural ; "-" ; m = natural; + l = OPT [","; l = LIST1 range_selector SEP "," -> { l } ] -> + { Goal_select.SelectList ((n, m) :: Option.default [] l) } + | n = natural; + l = OPT [","; l = LIST1 range_selector SEP "," -> { l } ] -> + { let open Goal_select in + Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l } ] ] + ; + selector_body: + [ [ l = range_selector_or_nth -> { l } + | test_bracket_ident; "["; id = ident; "]" -> { Goal_select.SelectId id } ] ] + ; + selector: + [ [ IDENT "only"; sel = selector_body; ":" -> { sel } ] ] + ; + toplevel_selector: + [ [ sel = selector_body; ":" -> { sel } + | "!"; ":" -> { Goal_select.SelectAlreadyFocused } + | IDENT "all"; ":" -> { Goal_select.SelectAll } ] ] + ; + tactic_mode: + [ [ g = OPT toplevel_selector; tac = G_vernac.query_command -> { tac g } + | g = OPT toplevel_selector; "{" -> { Vernacexpr.VernacSubproof g } ] ] + ; + command: + [ [ IDENT "Proof"; "with"; ta = Pltac.tactic; + l = OPT [ "using"; l = G_vernac.section_subset_expr -> { l } ] -> + { Vernacexpr.VernacProof (Some (in_tac ta), l) } + | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr; + ta = OPT [ "with"; ta = Pltac.tactic -> { in_tac ta } ] -> + { Vernacexpr.VernacProof (ta,Some l) } ] ] + ; + hint: + [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; + tac = Pltac.tactic -> + { Hints.HintsExtern (n,c, in_tac tac) } ] ] + ; + operconstr: LEVEL "0" + [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> + { let arg = Genarg.in_gen (Genarg.rawwit Tacarg.wit_tactic) tac in + CAst.make ~loc @@ CHole (None, IntroAnonymous, Some arg) } ] ] + ; + END + +{ + +open Stdarg +open Tacarg +open Vernacextend +open Goptions +open Libnames + +let print_info_trace = ref None + +let _ = declare_int_option { + optdepr = false; + optname = "print info trace"; + optkey = ["Info" ; "Level"]; + optread = (fun () -> !print_info_trace); + optwrite = fun n -> print_info_trace := n; +} + +let vernac_solve n info tcom b = + let open Goal_select in + let status = Proof_global.with_current_proof (fun etac p -> + let with_end_tac = if b then Some etac else None in + let global = match n with SelectAll | SelectList _ -> true | _ -> false in + let info = Option.append info !print_info_trace in + let (p,status) = + Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p + in + (* in case a strict subtree was completed, + go back to the top of the prooftree *) + let p = Proof.maximal_unfocus Vernacentries.command_focus p in + p,status) in + if not status then Feedback.feedback Feedback.AddedAxiom + +let pr_ltac_selector s = Pptactic.pr_goal_selector ~toplevel:true s + +} + +VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY { pr_ltac_selector } +| [ toplevel_selector(s) ] -> { s } +END + +{ + +let pr_ltac_info n = str "Info" ++ spc () ++ int n + +} + +VERNAC ARGUMENT EXTEND ltac_info PRINTED BY { pr_ltac_info } +| [ "Info" natural(n) ] -> { n } +END + +{ + +let pr_ltac_use_default b = + if b then (* Bug: a space is inserted before "..." *) str ".." else mt () + +} + +VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY { pr_ltac_use_default } +| [ "." ] -> { false } +| [ "..." ] -> { true } +END + +{ + +let is_anonymous_abstract = function + | TacAbstract (_,None) -> true + | TacSolve [TacAbstract (_,None)] -> true + | _ -> false +let rm_abstract = function + | TacAbstract (t,_) -> t + | TacSolve [TacAbstract (t,_)] -> TacSolve [t] + | x -> x +let is_explicit_terminator = function TacSolve _ -> true | _ -> false + +} + +VERNAC { tactic_mode } EXTEND VernacSolve +| [ ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => + { classify_as_proofstep } -> { + let g = Option.default (Goal_select.get_default_goal_selector ()) g in + vernac_solve g n t def + } +| [ "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => + { + let anon_abstracting_tac = is_anonymous_abstract t in + let solving_tac = is_explicit_terminator t in + let parallel = `Yes (solving_tac,anon_abstracting_tac) in + let pbr = if solving_tac then Some "par" else None in + VtProofStep{ parallel = parallel; proof_block_detection = pbr }, + VtLater + } -> { + let t = rm_abstract t in + vernac_solve Goal_select.SelectAll n t def + } +END + +{ + +let pr_ltac_tactic_level n = str "(at level " ++ int n ++ str ")" + +} + +VERNAC ARGUMENT EXTEND ltac_tactic_level PRINTED BY { pr_ltac_tactic_level } +| [ "(" "at" "level" natural(n) ")" ] -> { n } +END + +VERNAC ARGUMENT EXTEND ltac_production_sep +| [ "," string(sep) ] -> { sep } +END + +{ + +let pr_ltac_production_item = function +| Tacentries.TacTerm s -> quote (str s) +| Tacentries.TacNonTerm (_, ((arg, None), None)) -> str arg +| Tacentries.TacNonTerm (_, ((arg, Some _), None)) -> assert false +| Tacentries.TacNonTerm (_, ((arg, sep), Some id)) -> + let sep = match sep with + | None -> mt () + | Some sep -> str "," ++ spc () ++ quote (str sep) + in + str arg ++ str "(" ++ Id.print id ++ sep ++ str ")" + +} + +VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY { pr_ltac_production_item } +| [ string(s) ] -> { Tacentries.TacTerm s } +| [ ident(nt) "(" ident(p) ltac_production_sep_opt(sep) ")" ] -> + { Tacentries.TacNonTerm (Loc.tag ~loc ((Id.to_string nt, sep), Some p)) } +| [ ident(nt) ] -> + { Tacentries.TacNonTerm (Loc.tag ~loc ((Id.to_string nt, None), None)) } +END + +VERNAC COMMAND EXTEND VernacTacticNotation +| #[ deprecation; locality; ] + [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] => + { VtSideff [], VtNow } -> + { + let n = Option.default 0 n in + Tacentries.add_tactic_notation (Locality.make_module_locality locality) n ?deprecation r e; + } +END + +VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY +| [ "Print" "Ltac" reference(r) ] -> + { Feedback.msg_notice (Tacintern.print_ltac r) } +END + +VERNAC COMMAND EXTEND VernacLocateLtac CLASSIFIED AS QUERY +| [ "Locate" "Ltac" reference(r) ] -> + { Tacentries.print_located_tactic r } +END + +{ + +let pr_ltac_ref = Libnames.pr_qualid + +let pr_tacdef_body tacdef_body = + let id, redef, body = + match tacdef_body with + | TacticDefinition ({CAst.v=id}, body) -> Id.print id, false, body + | TacticRedefinition (id, body) -> pr_ltac_ref id, true, body + in + let idl, body = + match body with + | Tacexpr.TacFun (idl,b) -> idl,b + | _ -> [], body in + id ++ + prlist (function Name.Anonymous -> str " _" + | Name.Name id -> spc () ++ Id.print id) idl + ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) + ++ Pptactic.pr_raw_tactic body + +} + +VERNAC ARGUMENT EXTEND ltac_tacdef_body +PRINTED BY { pr_tacdef_body } +| [ tacdef_body(t) ] -> { t } +END + +VERNAC COMMAND EXTEND VernacDeclareTacticDefinition +| #[ deprecation; locality; ] [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => { + VtSideff (List.map (function + | TacticDefinition ({CAst.v=r},_) -> r + | TacticRedefinition (qid,_) -> qualid_basename qid) l), VtLater + } -> { + Tacentries.register_ltac (Locality.make_module_locality locality) ?deprecation l; + } +END + +VERNAC COMMAND EXTEND VernacPrintLtacs CLASSIFIED AS QUERY +| [ "Print" "Ltac" "Signatures" ] -> { Tacentries.print_ltacs () } +END diff --git a/plugins/ltac/g_obligations.ml4 b/plugins/ltac/g_obligations.mlg index 352e92c2a3..ef18dd6cdc 100644 --- a/plugins/ltac/g_obligations.ml4 +++ b/plugins/ltac/g_obligations.mlg @@ -12,7 +12,8 @@ Syntax for the subtac terms and types. Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *) -open Libnames +{ + open Constrexpr open Constrexpr_ops open Stdarg @@ -44,12 +45,11 @@ let with_tac f tac = * Subtac. These entries are named Subtac.<foo> *) -module Gram = Pcoq.Gram module Tactic = Pltac open Pcoq -let sigref = mkRefC (CAst.make @@ Qualid (Libnames.qualid_of_string "Coq.Init.Specif.sig")) +let sigref loc = mkRefC (Libnames.qualid_of_string ~loc "Coq.Init.Specif.sig") type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type @@ -58,100 +58,107 @@ let wit_withtac : Tacexpr.raw_tactic_expr option Genarg.uniform_genarg_type = let withtac = Pcoq.create_generic_entry Pcoq.utactic "withtac" (Genarg.rawwit wit_withtac) -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: withtac; withtac: - [ [ "with"; t = Tactic.tactic -> Some t - | -> None ] ] + [ [ "with"; t = Tactic.tactic -> { Some t } + | -> { None } ] ] ; Constr.closed_binder: - [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> - let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in - [CLocalAssum ([id], default_binder_kind, typ)] + [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> { + let typ = mkAppC (sigref loc, [mkLambdaC ([id], default_binder_kind, t, c)]) in + [CLocalAssum ([id], default_binder_kind, typ)] } ] ]; END +{ + open Obligations let obligation obl tac = with_tac (fun t -> Obligations.obligation obl t) tac let next_obligation obl tac = with_tac (fun t -> Obligations.next_obligation obl t) tac -let classify_obbl _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) +let classify_obbl _ = Vernacextend.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) + +} -VERNAC COMMAND EXTEND Obligations CLASSIFIED BY classify_obbl +VERNAC COMMAND EXTEND Obligations CLASSIFIED BY { classify_obbl } | [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> - [ obligation (num, Some name, Some t) tac ] + { obligation (num, Some name, Some t) tac } | [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> - [ obligation (num, Some name, None) tac ] + { obligation (num, Some name, None) tac } | [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> - [ obligation (num, None, Some t) tac ] + { obligation (num, None, Some t) tac } | [ "Obligation" integer(num) withtac(tac) ] -> - [ obligation (num, None, None) tac ] + { obligation (num, None, None) tac } | [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> - [ next_obligation (Some name) tac ] -| [ "Next" "Obligation" withtac(tac) ] -> [ next_obligation None tac ] + { next_obligation (Some name) tac } +| [ "Next" "Obligation" withtac(tac) ] -> { next_obligation None tac } END VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF | [ "Solve" "Obligation" integer(num) "of" ident(name) "with" tactic(t) ] -> - [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ] + { try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) } | [ "Solve" "Obligation" integer(num) "with" tactic(t) ] -> - [ try_solve_obligation num None (Some (Tacinterp.interp t)) ] + { try_solve_obligation num None (Some (Tacinterp.interp t)) } END VERNAC COMMAND EXTEND Solve_Obligations CLASSIFIED AS SIDEFF | [ "Solve" "Obligations" "of" ident(name) "with" tactic(t) ] -> - [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ] + { try_solve_obligations (Some name) (Some (Tacinterp.interp t)) } | [ "Solve" "Obligations" "with" tactic(t) ] -> - [ try_solve_obligations None (Some (Tacinterp.interp t)) ] + { try_solve_obligations None (Some (Tacinterp.interp t)) } | [ "Solve" "Obligations" ] -> - [ try_solve_obligations None None ] + { try_solve_obligations None None } END VERNAC COMMAND EXTEND Solve_All_Obligations CLASSIFIED AS SIDEFF | [ "Solve" "All" "Obligations" "with" tactic(t) ] -> - [ solve_all_obligations (Some (Tacinterp.interp t)) ] + { solve_all_obligations (Some (Tacinterp.interp t)) } | [ "Solve" "All" "Obligations" ] -> - [ solve_all_obligations None ] + { solve_all_obligations None } END VERNAC COMMAND EXTEND Admit_Obligations CLASSIFIED AS SIDEFF -| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ] -| [ "Admit" "Obligations" ] -> [ admit_obligations None ] +| [ "Admit" "Obligations" "of" ident(name) ] -> { admit_obligations (Some name) } +| [ "Admit" "Obligations" ] -> { admit_obligations None } END -VERNAC COMMAND FUNCTIONAL EXTEND Set_Solver CLASSIFIED AS SIDEFF -| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ - fun ~atts ~st -> begin - let open Vernacinterp in +VERNAC COMMAND EXTEND Set_Solver CLASSIFIED AS SIDEFF +| #[ locality = Attributes.locality; ] [ "Obligation" "Tactic" ":=" tactic(t) ] -> { set_default_tactic - (Locality.make_section_locality atts.locality) + (Locality.make_section_locality locality) (Tacintern.glob_tactic t); - st - end] + } END +{ + open Pp +} + VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY -| [ "Show" "Obligation" "Tactic" ] -> [ - Feedback.msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) ] +| [ "Show" "Obligation" "Tactic" ] -> { + Feedback.msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) } END VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY -| [ "Obligations" "of" ident(name) ] -> [ show_obligations (Some name) ] -| [ "Obligations" ] -> [ show_obligations None ] +| [ "Obligations" "of" ident(name) ] -> { show_obligations (Some name) } +| [ "Obligations" ] -> { show_obligations None } END VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY -| [ "Preterm" "of" ident(name) ] -> [ Feedback.msg_info (show_term (Some name)) ] -| [ "Preterm" ] -> [ Feedback.msg_info (show_term None) ] +| [ "Preterm" "of" ident(name) ] -> { Feedback.msg_info (show_term (Some name)) } +| [ "Preterm" ] -> { Feedback.msg_info (show_term None) } END -open Pp +{ (* Declare a printer for the content of Program tactics *) let () = @@ -160,3 +167,5 @@ let () = | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic tac in Pptactic.declare_extra_vernac_genarg_pprule wit_withtac printer + +} diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4 deleted file mode 100644 index fbaa2e58f7..0000000000 --- a/plugins/ltac/g_rewrite.ml4 +++ /dev/null @@ -1,297 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* Syntax for rewriting with strategies *) - -open Names -open Misctypes -open Locus -open Constrexpr -open Glob_term -open Geninterp -open Extraargs -open Tacmach -open Rewrite -open Stdarg -open Pcoq.Vernac_ -open Pcoq.Prim -open Pcoq.Constr -open Pltac - -DECLARE PLUGIN "ltac_plugin" - -type constr_expr_with_bindings = constr_expr with_bindings -type glob_constr_with_bindings = Tacexpr.glob_constr_and_expr with_bindings -type glob_constr_with_bindings_sign = interp_sign * Tacexpr.glob_constr_and_expr with_bindings - -let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = - let _, env = Pfedit.get_current_context () in - Printer.pr_glob_constr_env env (fst (fst (snd ge))) -let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = - let _, env = Pfedit.get_current_context () in - Printer.pr_glob_constr_env env (fst (fst ge)) -let pr_constr_expr_with_bindings prc _ _ (ge : constr_expr_with_bindings) = prc (fst ge) -let interp_glob_constr_with_bindings ist gl c = Tacmach.project gl , (ist, c) -let glob_glob_constr_with_bindings ist l = Tacintern.intern_constr_with_bindings ist l -let subst_glob_constr_with_bindings s c = - Tacsubst.subst_glob_with_bindings s c - -ARGUMENT EXTEND glob_constr_with_bindings - PRINTED BY pr_glob_constr_with_bindings_sign - - INTERPRETED BY interp_glob_constr_with_bindings - GLOBALIZED BY glob_glob_constr_with_bindings - SUBSTITUTED BY subst_glob_constr_with_bindings - - RAW_PRINTED BY pr_constr_expr_with_bindings - GLOB_PRINTED BY pr_glob_constr_with_bindings - - [ constr_with_bindings(bl) ] -> [ bl ] -END - -type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast -type glob_strategy = (Tacexpr.glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast - -let interp_strategy ist gl s = - let sigma = project gl in - sigma, strategy_of_ast s -let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c) s -let subst_strategy s str = str - -let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>" -let pr_raw_strategy prc prlc _ (s : raw_strategy) = - let prr = Pptactic.pr_red_expr (prc, prlc, Pputils.pr_or_by_notation Libnames.pr_reference, prc) in - Rewrite.pr_strategy prc prr s -let pr_glob_strategy prc prlc _ (s : glob_strategy) = - let prr = Pptactic.pr_red_expr - (Ppconstr.pr_constr_expr, - Ppconstr.pr_lconstr_expr, - Pputils.pr_or_by_notation Libnames.pr_reference, - Ppconstr.pr_constr_expr) - in - Rewrite.pr_strategy prc prr s - -ARGUMENT EXTEND rewstrategy - PRINTED BY pr_strategy - - INTERPRETED BY interp_strategy - GLOBALIZED BY glob_strategy - SUBSTITUTED BY subst_strategy - - RAW_PRINTED BY pr_raw_strategy - GLOB_PRINTED BY pr_glob_strategy - - [ glob(c) ] -> [ StratConstr (c, true) ] - | [ "<-" constr(c) ] -> [ StratConstr (c, false) ] - | [ "subterms" rewstrategy(h) ] -> [ StratUnary (Subterms, h) ] - | [ "subterm" rewstrategy(h) ] -> [ StratUnary (Subterm, h) ] - | [ "innermost" rewstrategy(h) ] -> [ StratUnary(Innermost, h) ] - | [ "outermost" rewstrategy(h) ] -> [ StratUnary(Outermost, h) ] - | [ "bottomup" rewstrategy(h) ] -> [ StratUnary(Bottomup, h) ] - | [ "topdown" rewstrategy(h) ] -> [ StratUnary(Topdown, h) ] - | [ "id" ] -> [ StratId ] - | [ "fail" ] -> [ StratFail ] - | [ "refl" ] -> [ StratRefl ] - | [ "progress" rewstrategy(h) ] -> [ StratUnary (Progress, h) ] - | [ "try" rewstrategy(h) ] -> [ StratUnary (Try, h) ] - | [ "any" rewstrategy(h) ] -> [ StratUnary (Any, h) ] - | [ "repeat" rewstrategy(h) ] -> [ StratUnary (Repeat, h) ] - | [ rewstrategy(h) ";" rewstrategy(h') ] -> [ StratBinary (Compose, h, h') ] - | [ "(" rewstrategy(h) ")" ] -> [ h ] - | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ StratBinary (Choice, h, h') ] - | [ "old_hints" preident(h) ] -> [ StratHints (true, h) ] - | [ "hints" preident(h) ] -> [ StratHints (false, h) ] - | [ "terms" constr_list(h) ] -> [ StratTerms h ] - | [ "eval" red_expr(r) ] -> [ StratEval r ] - | [ "fold" constr(c) ] -> [ StratFold c ] -END - -(* By default the strategy for "rewrite_db" is top-down *) - -let db_strat db = StratUnary (Topdown, StratHints (false, db)) -let cl_rewrite_clause_db db = cl_rewrite_clause_strat (strategy_of_ast (db_strat db)) - -TACTIC EXTEND rewrite_strat -| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ] -| [ "rewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ] -| [ "rewrite_db" preident(db) "in" hyp(id) ] -> [ cl_rewrite_clause_db db (Some id) ] -| [ "rewrite_db" preident(db) ] -> [ cl_rewrite_clause_db db None ] -END - -let clsubstitute o c = - Proofview.Goal.enter begin fun gl -> - let is_tac id = match DAst.get (fst (fst (snd c))) with GVar id' when Id.equal id' id -> true | _ -> false in - let hyps = Tacmach.New.pf_ids_of_hyps gl in - Tacticals.New.tclMAP - (fun cl -> - match cl with - | Some id when is_tac id -> Tacticals.New.tclIDTAC - | _ -> cl_rewrite_clause c o AllOccurrences cl) - (None :: List.map (fun id -> Some id) hyps) - end - -TACTIC EXTEND substitute -| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ clsubstitute o c ] -END - - -(* Compatibility with old Setoids *) - -TACTIC EXTEND setoid_rewrite - [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ] - -> [ cl_rewrite_clause c o AllOccurrences None ] - | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> - [ cl_rewrite_clause c o AllOccurrences (Some id) ] - | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> - [ cl_rewrite_clause c o (occurrences_of occ) None ] - | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] -> - [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] - | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] -> - [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] -END - -VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF - | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> - [ declare_relation a aeq n (Some lemma1) (Some lemma2) None ] - - | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "as" ident(n) ] -> - [ declare_relation a aeq n (Some lemma1) None None ] - | [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> - [ declare_relation a aeq n None None None ] -END - -VERNAC COMMAND EXTEND AddRelation2 CLASSIFIED AS SIDEFF - [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) - "as" ident(n) ] -> - [ declare_relation a aeq n None (Some lemma2) None ] - | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation a aeq n None (Some lemma2) (Some lemma3) ] -END - -VERNAC COMMAND EXTEND AddRelation3 CLASSIFIED AS SIDEFF - [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation a aeq n (Some lemma1) None (Some lemma3) ] - | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) - "as" ident(n) ] -> - [ declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] - | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) - "as" ident(n) ] -> - [ declare_relation a aeq n None None (Some lemma3) ] -END - -type binders_argtype = local_binder_expr list - -let wit_binders = - (Genarg.create_arg "binders" : binders_argtype Genarg.uniform_genarg_type) - -let binders = Pcoq.create_generic_entry Pcoq.utactic "binders" (Genarg.rawwit wit_binders) - -let () = - let raw_printer _ _ _ l = Pp.pr_non_empty_arg Ppconstr.pr_binders l in - Pptactic.declare_extra_vernac_genarg_pprule wit_binders raw_printer - -open Pcoq - -GEXTEND Gram - GLOBAL: binders; - binders: - [ [ b = Pcoq.Constr.binders -> b ] ]; -END - -VERNAC COMMAND EXTEND AddParametricRelation CLASSIFIED AS SIDEFF - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) - "reflexivity" "proved" "by" constr(lemma1) - "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ] - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) - "reflexivity" "proved" "by" constr(lemma1) - "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n (Some lemma1) None None ] - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None None None ] -END - -VERNAC COMMAND EXTEND AddParametricRelation2 CLASSIFIED AS SIDEFF - [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) - "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None (Some lemma2) None ] - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) ] -END - -VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF - [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ] - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) - "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] - | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) - "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None None (Some lemma3) ] -END - -VERNAC COMMAND FUNCTIONAL EXTEND AddSetoid1 CLASSIFIED AS SIDEFF - [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> - [ fun ~atts ~st -> let open Vernacinterp in - add_setoid (not (Locality.make_section_locality atts.locality)) [] a aeq t n; - st - ] - | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> - [ fun ~atts ~st -> let open Vernacinterp in - add_setoid (not (Locality.make_section_locality atts.locality)) binders a aeq t n; - st - ] - | [ "Add" "Morphism" constr(m) ":" ident(n) ] - (* This command may or may not open a goal *) - => [ Vernacexpr.VtUnknown, Vernacexpr.VtNow ] - -> [ fun ~atts ~st -> let open Vernacinterp in - add_morphism_infer (not (Locality.make_section_locality atts.locality)) m n; - st - ] - | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] - => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] - -> [ fun ~atts ~st -> let open Vernacinterp in - add_morphism (not (Locality.make_section_locality atts.locality)) [] m s n; - st - ] - | [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) - "with" "signature" lconstr(s) "as" ident(n) ] - => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] - -> [ fun ~atts ~st -> let open Vernacinterp in - add_morphism (not (Locality.make_section_locality atts.locality)) binders m s n; - st - ] -END - -TACTIC EXTEND setoid_symmetry - [ "setoid_symmetry" ] -> [ setoid_symmetry ] - | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ] -END - -TACTIC EXTEND setoid_reflexivity -[ "setoid_reflexivity" ] -> [ setoid_reflexivity ] -END - -TACTIC EXTEND setoid_transitivity - [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ] -| [ "setoid_etransitivity" ] -> [ setoid_transitivity None ] -END - -VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY - [ "Print" "Rewrite" "HintDb" preident(s) ] -> - [ let sigma, env = Pfedit.get_current_context () in - Feedback.msg_notice (Autorewrite.print_rewrite_hintdb env sigma s) ] -END diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg new file mode 100644 index 0000000000..f7375a0f01 --- /dev/null +++ b/plugins/ltac/g_rewrite.mlg @@ -0,0 +1,317 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* Syntax for rewriting with strategies *) + +{ + +open Names +open Locus +open Constrexpr +open Glob_term +open Geninterp +open Extraargs +open Tacmach +open Rewrite +open Stdarg +open Tactypes +open Pcoq.Prim +open Pcoq.Constr +open Pvernac.Vernac_ +open Pltac +open Vernacextend + +let wit_hyp = wit_var + +} + +DECLARE PLUGIN "ltac_plugin" + +{ + +type constr_expr_with_bindings = constr_expr with_bindings +type glob_constr_with_bindings = Tacexpr.glob_constr_and_expr with_bindings +type glob_constr_with_bindings_sign = interp_sign * Tacexpr.glob_constr_and_expr with_bindings + +let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = + let _, env = Pfedit.get_current_context () in + Printer.pr_glob_constr_env env (fst (fst (snd ge))) +let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = + let _, env = Pfedit.get_current_context () in + Printer.pr_glob_constr_env env (fst (fst ge)) +let pr_constr_expr_with_bindings prc _ _ (ge : constr_expr_with_bindings) = prc (fst ge) +let interp_glob_constr_with_bindings ist gl c = Tacmach.project gl , (ist, c) +let glob_glob_constr_with_bindings ist l = Tacintern.intern_constr_with_bindings ist l +let subst_glob_constr_with_bindings s c = + Tacsubst.subst_glob_with_bindings s c + +} + +ARGUMENT EXTEND glob_constr_with_bindings + PRINTED BY { pr_glob_constr_with_bindings_sign } + + INTERPRETED BY { interp_glob_constr_with_bindings } + GLOBALIZED BY { glob_glob_constr_with_bindings } + SUBSTITUTED BY { subst_glob_constr_with_bindings } + + RAW_PRINTED BY { pr_constr_expr_with_bindings } + GLOB_PRINTED BY { pr_glob_constr_with_bindings } + +| [ constr_with_bindings(bl) ] -> { bl } +END + +{ + +type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast +type glob_strategy = (Tacexpr.glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast + +let interp_strategy ist gl s = + let sigma = project gl in + sigma, strategy_of_ast s +let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c) s +let subst_strategy s str = str + +let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>" +let pr_raw_strategy prc prlc _ (s : raw_strategy) = + let prr = Pptactic.pr_red_expr (prc, prlc, Pputils.pr_or_by_notation Libnames.pr_qualid, prc) in + Rewrite.pr_strategy prc prr s +let pr_glob_strategy prc prlc _ (s : glob_strategy) = + let prr = Pptactic.pr_red_expr + (Ppconstr.pr_constr_expr, + Ppconstr.pr_lconstr_expr, + Pputils.pr_or_by_notation Libnames.pr_qualid, + Ppconstr.pr_constr_expr) + in + Rewrite.pr_strategy prc prr s + +} + +ARGUMENT EXTEND rewstrategy + PRINTED BY { pr_strategy } + + INTERPRETED BY { interp_strategy } + GLOBALIZED BY { glob_strategy } + SUBSTITUTED BY { subst_strategy } + + RAW_PRINTED BY { pr_raw_strategy } + GLOB_PRINTED BY { pr_glob_strategy } + + | [ glob(c) ] -> { StratConstr (c, true) } + | [ "<-" constr(c) ] -> { StratConstr (c, false) } + | [ "subterms" rewstrategy(h) ] -> { StratUnary (Subterms, h) } + | [ "subterm" rewstrategy(h) ] -> { StratUnary (Subterm, h) } + | [ "innermost" rewstrategy(h) ] -> { StratUnary(Innermost, h) } + | [ "outermost" rewstrategy(h) ] -> { StratUnary(Outermost, h) } + | [ "bottomup" rewstrategy(h) ] -> { StratUnary(Bottomup, h) } + | [ "topdown" rewstrategy(h) ] -> { StratUnary(Topdown, h) } + | [ "id" ] -> { StratId } + | [ "fail" ] -> { StratFail } + | [ "refl" ] -> { StratRefl } + | [ "progress" rewstrategy(h) ] -> { StratUnary (Progress, h) } + | [ "try" rewstrategy(h) ] -> { StratUnary (Try, h) } + | [ "any" rewstrategy(h) ] -> { StratUnary (Any, h) } + | [ "repeat" rewstrategy(h) ] -> { StratUnary (Repeat, h) } + | [ rewstrategy(h) ";" rewstrategy(h') ] -> { StratBinary (Compose, h, h') } + | [ "(" rewstrategy(h) ")" ] -> { h } + | [ "choice" rewstrategy(h) rewstrategy(h') ] -> { StratBinary (Choice, h, h') } + | [ "old_hints" preident(h) ] -> { StratHints (true, h) } + | [ "hints" preident(h) ] -> { StratHints (false, h) } + | [ "terms" constr_list(h) ] -> { StratTerms h } + | [ "eval" red_expr(r) ] -> { StratEval r } + | [ "fold" constr(c) ] -> { StratFold c } +END + +(* By default the strategy for "rewrite_db" is top-down *) + +{ + +let db_strat db = StratUnary (Topdown, StratHints (false, db)) +let cl_rewrite_clause_db db = cl_rewrite_clause_strat (strategy_of_ast (db_strat db)) + +} + +TACTIC EXTEND rewrite_strat +| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> { cl_rewrite_clause_strat s (Some id) } +| [ "rewrite_strat" rewstrategy(s) ] -> { cl_rewrite_clause_strat s None } +| [ "rewrite_db" preident(db) "in" hyp(id) ] -> { cl_rewrite_clause_db db (Some id) } +| [ "rewrite_db" preident(db) ] -> { cl_rewrite_clause_db db None } +END + +{ + +let clsubstitute o c = + Proofview.Goal.enter begin fun gl -> + let is_tac id = match DAst.get (fst (fst (snd c))) with GVar id' when Id.equal id' id -> true | _ -> false in + let hyps = Tacmach.New.pf_ids_of_hyps gl in + Tacticals.New.tclMAP + (fun cl -> + match cl with + | Some id when is_tac id -> Tacticals.New.tclIDTAC + | _ -> cl_rewrite_clause c o AllOccurrences cl) + (None :: List.map (fun id -> Some id) hyps) + end + +} + +TACTIC EXTEND substitute +| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> { clsubstitute o c } +END + + +(* Compatibility with old Setoids *) + +TACTIC EXTEND setoid_rewrite + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ] + -> { cl_rewrite_clause c o AllOccurrences None } + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> + { cl_rewrite_clause c o AllOccurrences (Some id) } + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> + { cl_rewrite_clause c o (occurrences_of occ) None } + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] -> + { cl_rewrite_clause c o (occurrences_of occ) (Some id) } + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] -> + { cl_rewrite_clause c o (occurrences_of occ) (Some id) } +END + +VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> + { declare_relation atts a aeq n (Some lemma1) (Some lemma2) None } + + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "as" ident(n) ] -> + { declare_relation atts a aeq n (Some lemma1) None None } + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> + { declare_relation atts a aeq n None None None } +END + +VERNAC COMMAND EXTEND AddRelation2 CLASSIFIED AS SIDEFF + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + "as" ident(n) ] -> + { declare_relation atts a aeq n None (Some lemma2) None } + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + { declare_relation atts a aeq n None (Some lemma2) (Some lemma3) } +END + +VERNAC COMMAND EXTEND AddRelation3 CLASSIFIED AS SIDEFF + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + { declare_relation atts a aeq n (Some lemma1) None (Some lemma3) } + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + { declare_relation atts a aeq n (Some lemma1) (Some lemma2) (Some lemma3) } + | #[ atts = rewrite_attributes; ] [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + { declare_relation atts a aeq n None None (Some lemma3) } +END + +{ + +type binders_argtype = local_binder_expr list + +let wit_binders = + (Genarg.create_arg "binders" : binders_argtype Genarg.uniform_genarg_type) + +let binders = Pcoq.create_generic_entry Pcoq.utactic "binders" (Genarg.rawwit wit_binders) + +let () = + let raw_printer _ _ _ l = Pp.pr_non_empty_arg Ppconstr.pr_binders l in + Pptactic.declare_extra_vernac_genarg_pprule wit_binders raw_printer + +} + +GRAMMAR EXTEND Gram + GLOBAL: binders; + binders: + [ [ b = Pcoq.Constr.binders -> { b } ] ]; +END + +VERNAC COMMAND EXTEND AddParametricRelation CLASSIFIED AS SIDEFF + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> + { declare_relation atts ~binders:b a aeq n (Some lemma1) (Some lemma2) None } + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + "reflexivity" "proved" "by" constr(lemma1) + "as" ident(n) ] -> + { declare_relation atts ~binders:b a aeq n (Some lemma1) None None } + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> + { declare_relation atts ~binders:b a aeq n None None None } +END + +VERNAC COMMAND EXTEND AddParametricRelation2 CLASSIFIED AS SIDEFF + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + "as" ident(n) ] -> + { declare_relation atts ~binders:b a aeq n None (Some lemma2) None } + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + { declare_relation atts ~binders:b a aeq n None (Some lemma2) (Some lemma3) } +END + +VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + { declare_relation atts ~binders:b a aeq n (Some lemma1) None (Some lemma3) } + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + { declare_relation atts ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) } + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + { declare_relation atts ~binders:b a aeq n None None (Some lemma3) } +END + +VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF + | #[ atts = rewrite_attributes; ] [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + { + add_setoid atts [] a aeq t n; + } + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + { + add_setoid atts binders a aeq t n; + } + | #[ atts = rewrite_attributes; ] [ "Add" "Morphism" constr(m) ":" ident(n) ] + (* This command may or may not open a goal *) + => { VtUnknown, VtNow } + -> { + add_morphism_infer atts m n; + } + | #[ atts = rewrite_attributes; ] [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] + => { VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater } + -> { + add_morphism atts [] m s n; + } + | #[ atts = rewrite_attributes; ] [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) + "with" "signature" lconstr(s) "as" ident(n) ] + => { VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater } + -> { + add_morphism atts binders m s n; + } +END + +TACTIC EXTEND setoid_symmetry + | [ "setoid_symmetry" ] -> { setoid_symmetry } + | [ "setoid_symmetry" "in" hyp(n) ] -> { setoid_symmetry_in n } +END + +TACTIC EXTEND setoid_reflexivity +| [ "setoid_reflexivity" ] -> { setoid_reflexivity } +END + +TACTIC EXTEND setoid_transitivity +| [ "setoid_transitivity" constr(t) ] -> { setoid_transitivity (Some t) } +| [ "setoid_etransitivity" ] -> { setoid_transitivity None } +END + +VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY +| [ "Print" "Rewrite" "HintDb" preident(s) ] -> + { let sigma, env = Pfedit.get_current_context () in + Feedback.msg_notice (Autorewrite.print_rewrite_hintdb env sigma s) } +END diff --git a/plugins/ltac/g_tactic.ml4 b/plugins/ltac/g_tactic.mlg index 7534e27999..46ea3819ac 100644 --- a/plugins/ltac/g_tactic.ml4 +++ b/plugins/ltac/g_tactic.mlg @@ -8,15 +8,21 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Pp open CErrors open Util +open Names +open Namegen open Tacexpr open Genredexpr open Constrexpr open Libnames open Tok -open Misctypes +open Tactypes +open Tactics +open Inv open Locus open Decl_kinds @@ -33,7 +39,7 @@ let err () = raise Stream.Failure (* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) (* admissible notation "(x t)" *) let test_lpar_id_coloneq = - Gram.Entry.of_parser "lpar_id_coloneq" + Pcoq.Entry.of_parser "lpar_id_coloneq" (fun strm -> match stream_nth 0 strm with | KEYWORD "(" -> @@ -47,7 +53,7 @@ let test_lpar_id_coloneq = (* Hack to recognize "(x)" *) let test_lpar_id_rpar = - Gram.Entry.of_parser "lpar_id_coloneq" + Pcoq.Entry.of_parser "lpar_id_coloneq" (fun strm -> match stream_nth 0 strm with | KEYWORD "(" -> @@ -61,7 +67,7 @@ let test_lpar_id_rpar = (* idem for (x:=t) and (1:=t) *) let test_lpar_idnum_coloneq = - Gram.Entry.of_parser "test_lpar_idnum_coloneq" + Pcoq.Entry.of_parser "test_lpar_idnum_coloneq" (fun strm -> match stream_nth 0 strm with | KEYWORD "(" -> @@ -78,7 +84,7 @@ open Extraargs (* idem for (x1..xn:t) [n^2 complexity but exceptional use] *) let check_for_coloneq = - Gram.Entry.of_parser "lpar_id_colon" + Pcoq.Entry.of_parser "lpar_id_colon" (fun strm -> let rec skip_to_rpar p n = match List.last (Stream.npeek n strm) with @@ -102,7 +108,7 @@ let check_for_coloneq = | _ -> err ()) let lookup_at_as_comma = - Gram.Entry.of_parser "lookup_at_as_comma" + Pcoq.Entry.of_parser "lookup_at_as_comma" (fun strm -> match stream_nth 0 strm with | KEYWORD (","|"at"|"as") -> () @@ -154,7 +160,7 @@ let mkTacCase with_evar = function (* Reinterpret ident as notations for variables in the context *) (* because we don't know if they are quantified or not *) | [(clear,ElimOnIdent id),(None,None),None],None -> - TacCase (with_evar,(clear,(CAst.make @@ CRef (CAst.make ?loc:id.CAst.loc @@ Ident id.CAst.v,None),NoBindings))) + TacCase (with_evar,(clear,(CAst.make @@ CRef (qualid_of_ident ?loc:id.CAst.loc id.CAst.v,None),NoBindings))) | ic -> if List.exists (function ((_, ElimOnAnonHyp _),_,_) -> true | _ -> false) (fst ic) then @@ -211,488 +217,490 @@ let warn_deprecated_eqn_syntax = (* Auxiliary grammar rules *) -open Vernac_ +open Pvernac.Vernac_ + +} -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis bindings red_expr int_or_var open_constr uconstr simple_intropattern in_clause clause_dft_concl hypident destruction_arg; int_or_var: - [ [ n = integer -> ArgArg n - | id = identref -> ArgVar id ] ] + [ [ n = integer -> { ArgArg n } + | id = identref -> { ArgVar id } ] ] ; nat_or_var: - [ [ n = natural -> ArgArg n - | id = identref -> ArgVar id ] ] + [ [ n = natural -> { ArgArg n } + | id = identref -> { ArgVar id } ] ] ; (* An identifier or a quotation meta-variable *) id_or_meta: - [ [ id = identref -> id ] ] + [ [ id = identref -> { id } ] ] ; open_constr: - [ [ c = constr -> c ] ] + [ [ c = constr -> { c } ] ] ; uconstr: - [ [ c = constr -> c ] ] + [ [ c = constr -> { c } ] ] ; destruction_arg: - [ [ n = natural -> (None,ElimOnAnonHyp n) + [ [ n = natural -> { (None,ElimOnAnonHyp n) } | test_lpar_id_rpar; c = constr_with_bindings -> - (Some false,destruction_arg_of_constr c) - | c = constr_with_bindings_arg -> on_snd destruction_arg_of_constr c + { (Some false,destruction_arg_of_constr c) } + | c = constr_with_bindings_arg -> { on_snd destruction_arg_of_constr c } ] ] ; constr_with_bindings_arg: - [ [ ">"; c = constr_with_bindings -> (Some true,c) - | c = constr_with_bindings -> (None,c) ] ] + [ [ ">"; c = constr_with_bindings -> { (Some true,c) } + | c = constr_with_bindings -> { (None,c) } ] ] ; quantified_hypothesis: - [ [ id = ident -> NamedHyp id - | n = natural -> AnonHyp n ] ] + [ [ id = ident -> { NamedHyp id } + | n = natural -> { AnonHyp n } ] ] ; conversion: - [ [ c = constr -> (None, c) - | c1 = constr; "with"; c2 = constr -> (Some (AllOccurrences,c1),c2) + [ [ c = constr -> { (None, c) } + | c1 = constr; "with"; c2 = constr -> { (Some (AllOccurrences,c1),c2) } | c1 = constr; "at"; occs = occs_nums; "with"; c2 = constr -> - (Some (occs,c1), c2) ] ] + { (Some (occs,c1), c2) } ] ] ; occs_nums: - [ [ nl = LIST1 nat_or_var -> OnlyOccurrences nl + [ [ nl = LIST1 nat_or_var -> { OnlyOccurrences nl } | "-"; n = nat_or_var; nl = LIST0 int_or_var -> (* have used int_or_var instead of nat_or_var for compatibility *) - AllOccurrencesBut (List.map (map_int_or_var abs) (n::nl)) ] ] + { AllOccurrencesBut (List.map (map_int_or_var abs) (n::nl)) } ] ] ; occs: - [ [ "at"; occs = occs_nums -> occs | -> AllOccurrences ] ] + [ [ "at"; occs = occs_nums -> { occs } | -> { AllOccurrences } ] ] ; pattern_occ: - [ [ c = constr; nl = occs -> (nl,c) ] ] + [ [ c = constr; nl = occs -> { (nl,c) } ] ] ; ref_or_pattern_occ: (* If a string, it is interpreted as a ref (anyway a Coq string does not reduce) *) - [ [ c = smart_global; nl = occs -> nl,Inl c - | c = constr; nl = occs -> nl,Inr c ] ] + [ [ c = smart_global; nl = occs -> { nl,Inl c } + | c = constr; nl = occs -> { nl,Inr c } ] ] ; unfold_occ: - [ [ c = smart_global; nl = occs -> (nl,c) ] ] + [ [ c = smart_global; nl = occs -> { (nl,c) } ] ] ; intropatterns: - [ [ l = LIST0 nonsimple_intropattern -> l ]] + [ [ l = LIST0 nonsimple_intropattern -> { l } ] ] ; ne_intropatterns: - [ [ l = LIST1 nonsimple_intropattern -> l ]] + [ [ l = LIST1 nonsimple_intropattern -> { l } ] ] ; or_and_intropattern: - [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> IntroOrPattern tc - | "()" -> IntroAndPattern [] - | "("; si = simple_intropattern; ")" -> IntroAndPattern [si] + [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> { IntroOrPattern tc } + | "()" -> { IntroAndPattern [] } + | "("; si = simple_intropattern; ")" -> { IntroAndPattern [si] } | "("; si = simple_intropattern; ","; tc = LIST1 simple_intropattern SEP "," ; ")" -> - IntroAndPattern (si::tc) + { IntroAndPattern (si::tc) } | "("; si = simple_intropattern; "&"; tc = LIST1 simple_intropattern SEP "&" ; ")" -> (* (A & B & C) is translated into (A,(B,C)) *) - let rec pairify = function + { let rec pairify = function | ([]|[_]|[_;_]) as l -> l | t::q -> [t; CAst.make ?loc:(loc_of_ne_list q) (IntroAction (IntroOrAndPattern (IntroAndPattern (pairify q))))] - in IntroAndPattern (pairify (si::tc)) ] ] + in IntroAndPattern (pairify (si::tc)) } ] ] ; equality_intropattern: - [ [ "->" -> IntroRewrite true - | "<-" -> IntroRewrite false - | "[="; tc = intropatterns; "]" -> IntroInjection tc ] ] + [ [ "->" -> { IntroRewrite true } + | "<-" -> { IntroRewrite false } + | "[="; tc = intropatterns; "]" -> { IntroInjection tc } ] ] ; naming_intropattern: - [ [ prefix = pattern_ident -> IntroFresh prefix - | "?" -> IntroAnonymous - | id = ident -> IntroIdentifier id ] ] + [ [ prefix = pattern_ident -> { IntroFresh prefix } + | "?" -> { IntroAnonymous } + | id = ident -> { IntroIdentifier id } ] ] ; nonsimple_intropattern: - [ [ l = simple_intropattern -> l - | "*" -> CAst.make ~loc:!@loc @@ IntroForthcoming true - | "**" -> CAst.make ~loc:!@loc @@ IntroForthcoming false ]] + [ [ l = simple_intropattern -> { l } + | "*" -> { CAst.make ~loc @@ IntroForthcoming true } + | "**" -> { CAst.make ~loc @@ IntroForthcoming false } ] ] ; simple_intropattern: [ [ pat = simple_intropattern_closed; - l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> - let {CAst.loc=loc0;v=pat} = pat in + l = LIST0 ["%"; c = operconstr LEVEL "0" -> { c } ] -> + { let {CAst.loc=loc0;v=pat} = pat in let f c pat = let loc1 = Constrexpr_ops.constr_loc c in let loc = Loc.merge_opt loc0 loc1 in IntroAction (IntroApplyOn (CAst.(make ?loc:loc1 c),CAst.(make ?loc pat))) in - CAst.make ~loc:!@loc @@ List.fold_right f l pat ] ] + CAst.make ~loc @@ List.fold_right f l pat } ] ] ; simple_intropattern_closed: - [ [ pat = or_and_intropattern -> CAst.make ~loc:!@loc @@ IntroAction (IntroOrAndPattern pat) - | pat = equality_intropattern -> CAst.make ~loc:!@loc @@ IntroAction pat - | "_" -> CAst.make ~loc:!@loc @@ IntroAction IntroWildcard - | pat = naming_intropattern -> CAst.make ~loc:!@loc @@ IntroNaming pat ] ] + [ [ pat = or_and_intropattern -> { CAst.make ~loc @@ IntroAction (IntroOrAndPattern pat) } + | pat = equality_intropattern -> { CAst.make ~loc @@ IntroAction pat } + | "_" -> { CAst.make ~loc @@ IntroAction IntroWildcard } + | pat = naming_intropattern -> { CAst.make ~loc @@ IntroNaming pat } ] ] ; simple_binding: - [ [ "("; id = ident; ":="; c = lconstr; ")" -> CAst.make ~loc:!@loc (NamedHyp id, c) - | "("; n = natural; ":="; c = lconstr; ")" -> CAst.make ~loc:!@loc (AnonHyp n, c) ] ] + [ [ "("; id = ident; ":="; c = lconstr; ")" -> { CAst.make ~loc (NamedHyp id, c) } + | "("; n = natural; ":="; c = lconstr; ")" -> { CAst.make ~loc (AnonHyp n, c) } ] ] ; bindings: [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> - ExplicitBindings bl - | bl = LIST1 constr -> ImplicitBindings bl ] ] + { ExplicitBindings bl } + | bl = LIST1 constr -> { ImplicitBindings bl } ] ] ; constr_with_bindings: - [ [ c = constr; l = with_bindings -> (c, l) ] ] + [ [ c = constr; l = with_bindings -> { (c, l) } ] ] ; with_bindings: - [ [ "with"; bl = bindings -> bl | -> NoBindings ] ] + [ [ "with"; bl = bindings -> { bl } | -> { NoBindings } ] ] ; red_flags: - [ [ IDENT "beta" -> [FBeta] - | IDENT "iota" -> [FMatch;FFix;FCofix] - | IDENT "match" -> [FMatch] - | IDENT "fix" -> [FFix] - | IDENT "cofix" -> [FCofix] - | IDENT "zeta" -> [FZeta] - | IDENT "delta"; d = delta_flag -> [d] + [ [ IDENT "beta" -> { [FBeta] } + | IDENT "iota" -> { [FMatch;FFix;FCofix] } + | IDENT "match" -> { [FMatch] } + | IDENT "fix" -> { [FFix] } + | IDENT "cofix" -> { [FCofix] } + | IDENT "zeta" -> { [FZeta] } + | IDENT "delta"; d = delta_flag -> { [d] } ] ] ; delta_flag: - [ [ "-"; "["; idl = LIST1 smart_global; "]" -> FDeltaBut idl - | "["; idl = LIST1 smart_global; "]" -> FConst idl - | -> FDeltaBut [] + [ [ "-"; "["; idl = LIST1 smart_global; "]" -> { FDeltaBut idl } + | "["; idl = LIST1 smart_global; "]" -> { FConst idl } + | -> { FDeltaBut [] } ] ] ; strategy_flag: - [ [ s = LIST1 red_flags -> Redops.make_red_flag (List.flatten s) - | d = delta_flag -> all_with d + [ [ s = LIST1 red_flags -> { Redops.make_red_flag (List.flatten s) } + | d = delta_flag -> { all_with d } ] ] ; red_expr: - [ [ IDENT "red" -> Red false - | IDENT "hnf" -> Hnf - | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ -> Simpl (all_with d,po) - | IDENT "cbv"; s = strategy_flag -> Cbv s - | IDENT "cbn"; s = strategy_flag -> Cbn s - | IDENT "lazy"; s = strategy_flag -> Lazy s - | IDENT "compute"; delta = delta_flag -> Cbv (all_with delta) - | IDENT "vm_compute"; po = OPT ref_or_pattern_occ -> CbvVm po - | IDENT "native_compute"; po = OPT ref_or_pattern_occ -> CbvNative po - | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul - | IDENT "fold"; cl = LIST1 constr -> Fold cl - | IDENT "pattern"; pl = LIST1 pattern_occ SEP"," -> Pattern pl - | s = IDENT -> ExtraRedExpr s ] ] + [ [ IDENT "red" -> { Red false } + | IDENT "hnf" -> { Hnf } + | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ -> { Simpl (all_with d,po) } + | IDENT "cbv"; s = strategy_flag -> { Cbv s } + | IDENT "cbn"; s = strategy_flag -> { Cbn s } + | IDENT "lazy"; s = strategy_flag -> { Lazy s } + | IDENT "compute"; delta = delta_flag -> { Cbv (all_with delta) } + | IDENT "vm_compute"; po = OPT ref_or_pattern_occ -> { CbvVm po } + | IDENT "native_compute"; po = OPT ref_or_pattern_occ -> { CbvNative po } + | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> { Unfold ul } + | IDENT "fold"; cl = LIST1 constr -> { Fold cl } + | IDENT "pattern"; pl = LIST1 pattern_occ SEP"," -> { Pattern pl } + | s = IDENT -> { ExtraRedExpr s } ] ] ; hypident: [ [ id = id_or_meta -> - let id : Misctypes.lident = id in - id,InHyp + { let id : lident = id in + id,InHyp } | "("; IDENT "type"; IDENT "of"; id = id_or_meta; ")" -> - let id : Misctypes.lident = id in - id,InHypTypeOnly + { let id : lident = id in + id,InHypTypeOnly } | "("; IDENT "value"; IDENT "of"; id = id_or_meta; ")" -> - let id : Misctypes.lident = id in - id,InHypValueOnly + { let id : lident = id in + id,InHypValueOnly } ] ] ; hypident_occ: - [ [ (id,l)=hypident; occs=occs -> - let id : Misctypes.lident = id in - ((occs,id),l) ] ] + [ [ h=hypident; occs=occs -> + { let (id,l) = h in + let id : lident = id in + ((occs,id),l) } ] ] ; in_clause: [ [ "*"; occs=occs -> - {onhyps=None; concl_occs=occs} + { {onhyps=None; concl_occs=occs} } | "*"; "|-"; occs=concl_occ -> - {onhyps=None; concl_occs=occs} + { {onhyps=None; concl_occs=occs} } | hl=LIST0 hypident_occ SEP","; "|-"; occs=concl_occ -> - {onhyps=Some hl; concl_occs=occs} + { {onhyps=Some hl; concl_occs=occs} } | hl=LIST0 hypident_occ SEP"," -> - {onhyps=Some hl; concl_occs=NoOccurrences} ] ] + { {onhyps=Some hl; concl_occs=NoOccurrences} } ] ] ; clause_dft_concl: - [ [ "in"; cl = in_clause -> cl - | occs=occs -> {onhyps=Some[]; concl_occs=occs} - | -> all_concl_occs_clause ] ] + [ [ "in"; cl = in_clause -> { cl } + | occs=occs -> { {onhyps=Some[]; concl_occs=occs} } + | -> { all_concl_occs_clause } ] ] ; clause_dft_all: - [ [ "in"; cl = in_clause -> cl - | -> {onhyps=None; concl_occs=AllOccurrences} ] ] + [ [ "in"; cl = in_clause -> { cl } + | -> { {onhyps=None; concl_occs=AllOccurrences} } ] ] ; opt_clause: - [ [ "in"; cl = in_clause -> Some cl - | "at"; occs = occs_nums -> Some {onhyps=Some[]; concl_occs=occs} - | -> None ] ] + [ [ "in"; cl = in_clause -> { Some cl } + | "at"; occs = occs_nums -> { Some {onhyps=Some[]; concl_occs=occs} } + | -> { None } ] ] ; concl_occ: - [ [ "*"; occs = occs -> occs - | -> NoOccurrences ] ] + [ [ "*"; occs = occs -> { occs } + | -> { NoOccurrences } ] ] ; in_hyp_list: - [ [ "in"; idl = LIST1 id_or_meta -> idl - | -> [] ] ] + [ [ "in"; idl = LIST1 id_or_meta -> { idl } + | -> { [] } ] ] ; in_hyp_as: - [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (id,ipat) - | -> None ] ] + [ [ "in"; id = id_or_meta; ipat = as_ipat -> { Some (id,ipat) } + | -> { None } ] ] ; orient: - [ [ "->" -> true - | "<-" -> false - | -> true ]] + [ [ "->" -> { true } + | "<-" -> { false } + | -> { true } ] ] ; simple_binder: - [ [ na=name -> ([na],Default Explicit, CAst.make ~loc:!@loc @@ - CHole (Some (Evar_kinds.BinderType na.CAst.v), IntroAnonymous, None)) - | "("; nal=LIST1 name; ":"; c=lconstr; ")" -> (nal,Default Explicit,c) + [ [ na=name -> { ([na],Default Explicit, CAst.make ~loc @@ + CHole (Some (Evar_kinds.BinderType na.CAst.v), IntroAnonymous, None)) } + | "("; nal=LIST1 name; ":"; c=lconstr; ")" -> { (nal,Default Explicit,c) } ] ] ; fixdecl: [ [ "("; id = ident; bl=LIST0 simple_binder; ann=fixannot; - ":"; ty=lconstr; ")" -> (!@loc, id, bl, ann, ty) ] ] + ":"; ty=lconstr; ")" -> { (loc, id, bl, ann, ty) } ] ] ; fixannot: - [ [ "{"; IDENT "struct"; id=name; "}" -> Some id - | -> None ] ] + [ [ "{"; IDENT "struct"; id=name; "}" -> { Some id } + | -> { None } ] ] ; cofixdecl: [ [ "("; id = ident; bl=LIST0 simple_binder; ":"; ty=lconstr; ")" -> - (!@loc, id, bl, None, ty) ] ] + { (loc, id, bl, None, ty) } ] ] ; bindings_with_parameters: [ [ check_for_coloneq; "("; id = ident; bl = LIST0 simple_binder; - ":="; c = lconstr; ")" -> (id, mkCLambdaN_simple bl c) ] ] + ":="; c = lconstr; ")" -> { (id, mkCLambdaN_simple bl c) } ] ] ; eliminator: - [ [ "using"; el = constr_with_bindings -> el ] ] + [ [ "using"; el = constr_with_bindings -> { el } ] ] ; as_ipat: - [ [ "as"; ipat = simple_intropattern -> Some ipat - | -> None ] ] + [ [ "as"; ipat = simple_intropattern -> { Some ipat } + | -> { None } ] ] ; or_and_intropattern_loc: - [ [ ipat = or_and_intropattern -> ArgArg (CAst.make ~loc:!@loc ipat) - | locid = identref -> ArgVar locid ] ] + [ [ ipat = or_and_intropattern -> { ArgArg (CAst.make ~loc ipat) } + | locid = identref -> { ArgVar locid } ] ] ; as_or_and_ipat: - [ [ "as"; ipat = or_and_intropattern_loc -> Some ipat - | -> None ] ] + [ [ "as"; ipat = or_and_intropattern_loc -> { Some ipat } + | -> { None } ] ] ; eqn_ipat: - [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> Some (CAst.make ~loc:!@loc pat) + [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> { Some (CAst.make ~loc pat) } | IDENT "_eqn"; ":"; pat = naming_intropattern -> - let loc = !@loc in - warn_deprecated_eqn_syntax ~loc "H"; Some (CAst.make ~loc pat) + { warn_deprecated_eqn_syntax ~loc "H"; Some (CAst.make ~loc pat) } | IDENT "_eqn" -> - let loc = !@loc in - warn_deprecated_eqn_syntax ~loc "?"; Some (CAst.make ~loc IntroAnonymous) - | -> None ] ] + { warn_deprecated_eqn_syntax ~loc "?"; Some (CAst.make ~loc IntroAnonymous) } + | -> { None } ] ] ; as_name: - [ [ "as"; id = ident ->Names.Name.Name id | -> Names.Name.Anonymous ] ] + [ [ "as"; id = ident -> { Names.Name.Name id } | -> { Names.Name.Anonymous } ] ] ; by_tactic: - [ [ "by"; tac = tactic_expr LEVEL "3" -> Some tac - | -> None ] ] + [ [ "by"; tac = tactic_expr LEVEL "3" -> { Some tac } + | -> { None } ] ] ; rewriter : - [ [ "!"; c = constr_with_bindings_arg -> (RepeatPlus,c) - | ["?"| LEFTQMARK]; c = constr_with_bindings_arg -> (RepeatStar,c) - | n = natural; "!"; c = constr_with_bindings_arg -> (Precisely n,c) - | n = natural; ["?" | LEFTQMARK]; c = constr_with_bindings_arg -> (UpTo n,c) - | n = natural; c = constr_with_bindings_arg -> (Precisely n,c) - | c = constr_with_bindings_arg -> (Precisely 1, c) + [ [ "!"; c = constr_with_bindings_arg -> { (Equality.RepeatPlus,c) } + | ["?" -> { () } | LEFTQMARK -> { () } ]; c = constr_with_bindings_arg -> { (Equality.RepeatStar,c) } + | n = natural; "!"; c = constr_with_bindings_arg -> { (Equality.Precisely n,c) } + | n = natural; ["?" -> { () } | LEFTQMARK -> { () } ]; c = constr_with_bindings_arg -> { (Equality.UpTo n,c) } + | n = natural; c = constr_with_bindings_arg -> { (Equality.Precisely n,c) } + | c = constr_with_bindings_arg -> { (Equality.Precisely 1, c) } ] ] ; oriented_rewriter : - [ [ b = orient; p = rewriter -> let (m,c) = p in (b,m,c) ] ] + [ [ b = orient; p = rewriter -> { let (m,c) = p in (b,m,c) } ] ] ; induction_clause: [ [ c = destruction_arg; pat = as_or_and_ipat; eq = eqn_ipat; - cl = opt_clause -> (c,(eq,pat),cl) ] ] + cl = opt_clause -> { (c,(eq,pat),cl) } ] ] ; induction_clause_list: [ [ ic = LIST1 induction_clause SEP ","; el = OPT eliminator; cl_tolerance = opt_clause -> (* Condition for accepting "in" at the end by compatibility *) - match ic,el,cl_tolerance with + { match ic,el,cl_tolerance with | [c,pat,None],Some _,Some _ -> ([c,pat,cl_tolerance],el) | _,_,Some _ -> err () - | _,_,None -> (ic,el) ]] + | _,_,None -> (ic,el) } ] ] ; simple_tactic: [ [ (* Basic tactics *) IDENT "intros"; pl = ne_intropatterns -> - TacAtom (Loc.tag ~loc:!@loc @@ TacIntroPattern (false,pl)) + { TacAtom (CAst.make ~loc @@ TacIntroPattern (false,pl)) } | IDENT "intros" -> - TacAtom (Loc.tag ~loc:!@loc @@ TacIntroPattern (false,[CAst.make ~loc:!@loc @@IntroForthcoming false])) + { TacAtom (CAst.make ~loc @@ TacIntroPattern (false,[CAst.make ~loc @@IntroForthcoming false])) } | IDENT "eintros"; pl = ne_intropatterns -> - TacAtom (Loc.tag ~loc:!@loc @@ TacIntroPattern (true,pl)) + { TacAtom (CAst.make ~loc @@ TacIntroPattern (true,pl)) } | IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> TacAtom (Loc.tag ~loc:!@loc @@ TacApply (true,false,cl,inhyp)) + inhyp = in_hyp_as -> { TacAtom (CAst.make ~loc @@ TacApply (true,false,cl,inhyp)) } | IDENT "eapply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> TacAtom (Loc.tag ~loc:!@loc @@ TacApply (true,true,cl,inhyp)) + inhyp = in_hyp_as -> { TacAtom (CAst.make ~loc @@ TacApply (true,true,cl,inhyp)) } | IDENT "simple"; IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ","; - inhyp = in_hyp_as -> TacAtom (Loc.tag ~loc:!@loc @@ TacApply (false,false,cl,inhyp)) + inhyp = in_hyp_as -> { TacAtom (CAst.make ~loc @@ TacApply (false,false,cl,inhyp)) } | IDENT "simple"; IDENT "eapply"; cl = LIST1 constr_with_bindings_arg SEP","; - inhyp = in_hyp_as -> TacAtom (Loc.tag ~loc:!@loc @@ TacApply (false,true,cl,inhyp)) + inhyp = in_hyp_as -> { TacAtom (CAst.make ~loc @@ TacApply (false,true,cl,inhyp)) } | IDENT "elim"; cl = constr_with_bindings_arg; el = OPT eliminator -> - TacAtom (Loc.tag ~loc:!@loc @@ TacElim (false,cl,el)) + { TacAtom (CAst.make ~loc @@ TacElim (false,cl,el)) } | IDENT "eelim"; cl = constr_with_bindings_arg; el = OPT eliminator -> - TacAtom (Loc.tag ~loc:!@loc @@ TacElim (true,cl,el)) - | IDENT "case"; icl = induction_clause_list -> TacAtom (Loc.tag ~loc:!@loc @@ mkTacCase false icl) - | IDENT "ecase"; icl = induction_clause_list -> TacAtom (Loc.tag ~loc:!@loc @@ mkTacCase true icl) + { TacAtom (CAst.make ~loc @@ TacElim (true,cl,el)) } + | IDENT "case"; icl = induction_clause_list -> { TacAtom (CAst.make ~loc @@ mkTacCase false icl) } + | IDENT "ecase"; icl = induction_clause_list -> { TacAtom (CAst.make ~loc @@ mkTacCase true icl) } | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacMutualFix (id,n,List.map mk_fix_tac fd)) + { TacAtom (CAst.make ~loc @@ TacMutualFix (id,n,List.map mk_fix_tac fd)) } | "cofix"; id = ident; "with"; fd = LIST1 cofixdecl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacMutualCofix (id,List.map mk_cofix_tac fd)) + { TacAtom (CAst.make ~loc @@ TacMutualCofix (id,List.map mk_cofix_tac fd)) } - | IDENT "pose"; (id,b) = bindings_with_parameters -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,Names.Name.Name id,b,Locusops.nowhere,true,None)) + | IDENT "pose"; bl = bindings_with_parameters -> + { let (id,b) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (false,Names.Name.Name id,b,Locusops.nowhere,true,None)) } | IDENT "pose"; b = constr; na = as_name -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,na,b,Locusops.nowhere,true,None)) - | IDENT "epose"; (id,b) = bindings_with_parameters -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,Names.Name id,b,Locusops.nowhere,true,None)) + { TacAtom (CAst.make ~loc @@ TacLetTac (false,na,b,Locusops.nowhere,true,None)) } + | IDENT "epose"; bl = bindings_with_parameters -> + { let (id,b) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (true,Names.Name id,b,Locusops.nowhere,true,None)) } | IDENT "epose"; b = constr; na = as_name -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,na,b,Locusops.nowhere,true,None)) - | IDENT "set"; (id,c) = bindings_with_parameters; p = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,Names.Name.Name id,c,p,true,None)) + { TacAtom (CAst.make ~loc @@ TacLetTac (true,na,b,Locusops.nowhere,true,None)) } + | IDENT "set"; bl = bindings_with_parameters; p = clause_dft_concl -> + { let (id,c) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (false,Names.Name.Name id,c,p,true,None)) } | IDENT "set"; c = constr; na = as_name; p = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,na,c,p,true,None)) - | IDENT "eset"; (id,c) = bindings_with_parameters; p = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,Names.Name id,c,p,true,None)) + { TacAtom (CAst.make ~loc @@ TacLetTac (false,na,c,p,true,None)) } + | IDENT "eset"; bl = bindings_with_parameters; p = clause_dft_concl -> + { let (id,c) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (true,Names.Name id,c,p,true,None)) } | IDENT "eset"; c = constr; na = as_name; p = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,na,c,p,true,None)) + { TacAtom (CAst.make ~loc @@ TacLetTac (true,na,c,p,true,None)) } | IDENT "remember"; c = constr; na = as_name; e = eqn_ipat; p = clause_dft_all -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,na,c,p,false,e)) + { TacAtom (CAst.make ~loc @@ TacLetTac (false,na,c,p,false,e)) } | IDENT "eremember"; c = constr; na = as_name; e = eqn_ipat; p = clause_dft_all -> - TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,na,c,p,false,e)) + { TacAtom (CAst.make ~loc @@ TacLetTac (true,na,c,p,false,e)) } (* Alternative syntax for "pose proof c as id" *) | IDENT "assert"; test_lpar_id_coloneq; "("; lid = identref; ":="; c = lconstr; ")" -> - let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (false,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) + { let { CAst.loc = loc; v = id } = lid in + TacAtom (CAst.make ?loc @@ TacAssert (false,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "eassert"; test_lpar_id_coloneq; "("; lid = identref; ":="; c = lconstr; ")" -> - let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (true,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) + { let { CAst.loc = loc; v = id } = lid in + TacAtom (CAst.make ?loc @@ TacAssert (true,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } (* Alternative syntax for "assert c as id by tac" *) | IDENT "assert"; test_lpar_id_colon; "("; lid = identref; ":"; c = lconstr; ")"; tac=by_tactic -> - let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (false,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) + { let { CAst.loc = loc; v = id } = lid in + TacAtom (CAst.make ?loc @@ TacAssert (false,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "eassert"; test_lpar_id_colon; "("; lid = identref; ":"; c = lconstr; ")"; tac=by_tactic -> - let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (true,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) + { let { CAst.loc = loc; v = id } = lid in + TacAtom (CAst.make ?loc @@ TacAssert (true,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } (* Alternative syntax for "enough c as id by tac" *) | IDENT "enough"; test_lpar_id_colon; "("; lid = identref; ":"; c = lconstr; ")"; tac=by_tactic -> - let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (false,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) + { let { CAst.loc = loc; v = id } = lid in + TacAtom (CAst.make ?loc @@ TacAssert (false,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "eenough"; test_lpar_id_colon; "("; lid = identref; ":"; c = lconstr; ")"; tac=by_tactic -> - let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (true,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) + { let { CAst.loc = loc; v = id } = lid in + TacAtom (CAst.make ?loc @@ TacAssert (true,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "assert"; c = constr; ipat = as_ipat; tac = by_tactic -> - TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,true,Some tac,ipat,c)) + { TacAtom (CAst.make ~loc @@ TacAssert (false,true,Some tac,ipat,c)) } | IDENT "eassert"; c = constr; ipat = as_ipat; tac = by_tactic -> - TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,true,Some tac,ipat,c)) + { TacAtom (CAst.make ~loc @@ TacAssert (true,true,Some tac,ipat,c)) } | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> - TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,true,None,ipat,c)) + { TacAtom (CAst.make ~loc @@ TacAssert (false,true,None,ipat,c)) } | IDENT "epose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> - TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,true,None,ipat,c)) + { TacAtom (CAst.make ~loc @@ TacAssert (true,true,None,ipat,c)) } | IDENT "enough"; c = constr; ipat = as_ipat; tac = by_tactic -> - TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,false,Some tac,ipat,c)) + { TacAtom (CAst.make ~loc @@ TacAssert (false,false,Some tac,ipat,c)) } | IDENT "eenough"; c = constr; ipat = as_ipat; tac = by_tactic -> - TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,false,Some tac,ipat,c)) + { TacAtom (CAst.make ~loc @@ TacAssert (true,false,Some tac,ipat,c)) } | IDENT "generalize"; c = constr -> - TacAtom (Loc.tag ~loc:!@loc @@ TacGeneralize [((AllOccurrences,c),Names.Name.Anonymous)]) + { TacAtom (CAst.make ~loc @@ TacGeneralize [((AllOccurrences,c),Names.Name.Anonymous)]) } | IDENT "generalize"; c = constr; l = LIST1 constr -> - let gen_everywhere c = ((AllOccurrences,c),Names.Name.Anonymous) in - TacAtom (Loc.tag ~loc:!@loc @@ TacGeneralize (List.map gen_everywhere (c::l))) + { let gen_everywhere c = ((AllOccurrences,c),Names.Name.Anonymous) in + TacAtom (CAst.make ~loc @@ TacGeneralize (List.map gen_everywhere (c::l))) } | IDENT "generalize"; c = constr; lookup_at_as_comma; nl = occs; na = as_name; - l = LIST0 [","; c = pattern_occ; na = as_name -> (c,na)] -> - TacAtom (Loc.tag ~loc:!@loc @@ TacGeneralize (((nl,c),na)::l)) + l = LIST0 [","; c = pattern_occ; na = as_name -> { (c,na) } ] -> + { TacAtom (CAst.make ~loc @@ TacGeneralize (((nl,c),na)::l)) } (* Derived basic tactics *) | IDENT "induction"; ic = induction_clause_list -> - TacAtom (Loc.tag ~loc:!@loc @@ TacInductionDestruct (true,false,ic)) + { TacAtom (CAst.make ~loc @@ TacInductionDestruct (true,false,ic)) } | IDENT "einduction"; ic = induction_clause_list -> - TacAtom (Loc.tag ~loc:!@loc @@ TacInductionDestruct(true,true,ic)) + { TacAtom (CAst.make ~loc @@ TacInductionDestruct(true,true,ic)) } | IDENT "destruct"; icl = induction_clause_list -> - TacAtom (Loc.tag ~loc:!@loc @@ TacInductionDestruct(false,false,icl)) + { TacAtom (CAst.make ~loc @@ TacInductionDestruct(false,false,icl)) } | IDENT "edestruct"; icl = induction_clause_list -> - TacAtom (Loc.tag ~loc:!@loc @@ TacInductionDestruct(false,true,icl)) + { TacAtom (CAst.make ~loc @@ TacInductionDestruct(false,true,icl)) } (* Equality and inversion *) | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; - cl = clause_dft_concl; t=by_tactic -> TacAtom (Loc.tag ~loc:!@loc @@ TacRewrite (false,l,cl,t)) + cl = clause_dft_concl; t=by_tactic -> { TacAtom (CAst.make ~loc @@ TacRewrite (false,l,cl,t)) } | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ","; - cl = clause_dft_concl; t=by_tactic -> TacAtom (Loc.tag ~loc:!@loc @@ TacRewrite (true,l,cl,t)) + cl = clause_dft_concl; t=by_tactic -> { TacAtom (CAst.make ~loc @@ TacRewrite (true,l,cl,t)) } | IDENT "dependent"; k = - [ IDENT "simple"; IDENT "inversion" -> SimpleInversion - | IDENT "inversion" -> FullInversion - | IDENT "inversion_clear" -> FullInversionClear ]; + [ IDENT "simple"; IDENT "inversion" -> { SimpleInversion } + | IDENT "inversion" -> { FullInversion } + | IDENT "inversion_clear" -> { FullInversionClear } ]; hyp = quantified_hypothesis; - ids = as_or_and_ipat; co = OPT ["with"; c = constr -> c] -> - TacAtom (Loc.tag ~loc:!@loc @@ TacInversion (DepInversion (k,co,ids),hyp)) + ids = as_or_and_ipat; co = OPT ["with"; c = constr -> { c } ] -> + { TacAtom (CAst.make ~loc @@ TacInversion (DepInversion (k,co,ids),hyp)) } | IDENT "simple"; IDENT "inversion"; hyp = quantified_hypothesis; ids = as_or_and_ipat; cl = in_hyp_list -> - TacAtom (Loc.tag ~loc:!@loc @@ TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)) + { TacAtom (CAst.make ~loc @@ TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)) } | IDENT "inversion"; hyp = quantified_hypothesis; ids = as_or_and_ipat; cl = in_hyp_list -> - TacAtom (Loc.tag ~loc:!@loc @@ TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)) + { TacAtom (CAst.make ~loc @@ TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)) } | IDENT "inversion_clear"; hyp = quantified_hypothesis; ids = as_or_and_ipat; cl = in_hyp_list -> - TacAtom (Loc.tag ~loc:!@loc @@ TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)) + { TacAtom (CAst.make ~loc @@ TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)) } | IDENT "inversion"; hyp = quantified_hypothesis; "using"; c = constr; cl = in_hyp_list -> - TacAtom (Loc.tag ~loc:!@loc @@ TacInversion (InversionUsing (c,cl), hyp)) + { TacAtom (CAst.make ~loc @@ TacInversion (InversionUsing (c,cl), hyp)) } (* Conversion *) | IDENT "red"; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Red false, cl)) + { TacAtom (CAst.make ~loc @@ TacReduce (Red false, cl)) } | IDENT "hnf"; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Hnf, cl)) + { TacAtom (CAst.make ~loc @@ TacReduce (Hnf, cl)) } | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Simpl (all_with d, po), cl)) + { TacAtom (CAst.make ~loc @@ TacReduce (Simpl (all_with d, po), cl)) } | IDENT "cbv"; s = strategy_flag; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Cbv s, cl)) + { TacAtom (CAst.make ~loc @@ TacReduce (Cbv s, cl)) } | IDENT "cbn"; s = strategy_flag; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Cbn s, cl)) + { TacAtom (CAst.make ~loc @@ TacReduce (Cbn s, cl)) } | IDENT "lazy"; s = strategy_flag; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Lazy s, cl)) + { TacAtom (CAst.make ~loc @@ TacReduce (Lazy s, cl)) } | IDENT "compute"; delta = delta_flag; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Cbv (all_with delta), cl)) + { TacAtom (CAst.make ~loc @@ TacReduce (Cbv (all_with delta), cl)) } | IDENT "vm_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (CbvVm po, cl)) + { TacAtom (CAst.make ~loc @@ TacReduce (CbvVm po, cl)) } | IDENT "native_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (CbvNative po, cl)) + { TacAtom (CAst.make ~loc @@ TacReduce (CbvNative po, cl)) } | IDENT "unfold"; ul = LIST1 unfold_occ SEP ","; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Unfold ul, cl)) + { TacAtom (CAst.make ~loc @@ TacReduce (Unfold ul, cl)) } | IDENT "fold"; l = LIST1 constr; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Fold l, cl)) + { TacAtom (CAst.make ~loc @@ TacReduce (Fold l, cl)) } | IDENT "pattern"; pl = LIST1 pattern_occ SEP","; cl = clause_dft_concl -> - TacAtom (Loc.tag ~loc:!@loc @@ TacReduce (Pattern pl, cl)) + { TacAtom (CAst.make ~loc @@ TacReduce (Pattern pl, cl)) } (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *) - | IDENT "change"; (oc,c) = conversion; cl = clause_dft_concl -> - let p,cl = merge_occurrences (!@loc) cl oc in - TacAtom (Loc.tag ~loc:!@loc @@ TacChange (p,c,cl)) + | IDENT "change"; c = conversion; cl = clause_dft_concl -> + { let (oc, c) = c in + let p,cl = merge_occurrences loc cl oc in + TacAtom (CAst.make ~loc @@ TacChange (p,c,cl)) } ] ] ; -END;; +END diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack index ec96e1bbdd..e83eab20dc 100644 --- a/plugins/ltac/ltac_plugin.mlpack +++ b/plugins/ltac/ltac_plugin.mlpack @@ -7,10 +7,10 @@ Pltac Taccoerce Tactic_debug Tacintern -Tacentries Profile_ltac Tactic_matching Tacinterp +Tacentries Evar_tactics Tactic_option Extraargs diff --git a/plugins/ltac/pltac.ml b/plugins/ltac/pltac.ml index e9711268c2..759bb62fdd 100644 --- a/plugins/ltac/pltac.ml +++ b/plugins/ltac/pltac.ml @@ -11,11 +11,10 @@ open Pcoq (* Main entry for extensions *) -let simple_tactic = Gram.entry_create "tactic:simple_tactic" +let simple_tactic = Entry.create "tactic:simple_tactic" -let make_gen_entry _ name = Gram.entry_create ("tactic:" ^ name) +let make_gen_entry _ name = Entry.create ("tactic:" ^ name) -(* Entries that can be referred via the string -> Gram.entry table *) (* Typically for tactic user extensions *) let open_constr = make_gen_entry utactic "open_constr" @@ -23,7 +22,7 @@ let constr_with_bindings = make_gen_entry utactic "constr_with_bindings" let bindings = make_gen_entry utactic "bindings" -let hypident = Gram.entry_create "hypident" +let hypident = Entry.create "hypident" let constr_may_eval = make_gen_entry utactic "constr_may_eval" let constr_eval = make_gen_entry utactic "constr_eval" let uconstr = @@ -40,7 +39,7 @@ let clause_dft_concl = (* Main entries for ltac *) -let tactic_arg = Gram.entry_create "tactic:tactic_arg" +let tactic_arg = Entry.create "tactic:tactic_arg" let tactic_expr = make_gen_entry utactic "tactic_expr" let binder_tactic = make_gen_entry utactic "binder_tactic" diff --git a/plugins/ltac/pltac.mli b/plugins/ltac/pltac.mli index 6637de745e..9bff98b6c3 100644 --- a/plugins/ltac/pltac.mli +++ b/plugins/ltac/pltac.mli @@ -15,24 +15,24 @@ open Libnames open Constrexpr open Tacexpr open Genredexpr -open Misctypes +open Tactypes -val open_constr : constr_expr Gram.entry -val constr_with_bindings : constr_expr with_bindings Gram.entry -val bindings : constr_expr bindings Gram.entry -val hypident : (lident * Locus.hyp_location_flag) Gram.entry -val constr_may_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry -val constr_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry -val uconstr : constr_expr Gram.entry -val quantified_hypothesis : quantified_hypothesis Gram.entry -val destruction_arg : constr_expr with_bindings destruction_arg Gram.entry -val int_or_var : int or_var Gram.entry -val simple_tactic : raw_tactic_expr Gram.entry -val simple_intropattern : constr_expr intro_pattern_expr CAst.t Gram.entry -val in_clause : lident Locus.clause_expr Gram.entry -val clause_dft_concl : lident Locus.clause_expr Gram.entry -val tactic_arg : raw_tactic_arg Gram.entry -val tactic_expr : raw_tactic_expr Gram.entry -val binder_tactic : raw_tactic_expr Gram.entry -val tactic : raw_tactic_expr Gram.entry -val tactic_eoi : raw_tactic_expr Gram.entry +val open_constr : constr_expr Entry.t +val constr_with_bindings : constr_expr with_bindings Entry.t +val bindings : constr_expr bindings Entry.t +val hypident : (Names.lident * Locus.hyp_location_flag) Entry.t +val constr_may_eval : (constr_expr,qualid or_by_notation,constr_expr) may_eval Entry.t +val constr_eval : (constr_expr,qualid or_by_notation,constr_expr) may_eval Entry.t +val uconstr : constr_expr Entry.t +val quantified_hypothesis : quantified_hypothesis Entry.t +val destruction_arg : constr_expr with_bindings Tactics.destruction_arg Entry.t +val int_or_var : int Locus.or_var Entry.t +val simple_tactic : raw_tactic_expr Entry.t +val simple_intropattern : constr_expr intro_pattern_expr CAst.t Entry.t +val in_clause : Names.lident Locus.clause_expr Entry.t +val clause_dft_concl : Names.lident Locus.clause_expr Entry.t +val tactic_arg : raw_tactic_arg Entry.t +val tactic_expr : raw_tactic_expr Entry.t +val binder_tactic : raw_tactic_expr Entry.t +val tactic : raw_tactic_expr Entry.t +val tactic_eoi : raw_tactic_expr Entry.t diff --git a/plugins/ltac/plugin_base.dune b/plugins/ltac/plugin_base.dune new file mode 100644 index 0000000000..5611f5ba16 --- /dev/null +++ b/plugins/ltac/plugin_base.dune @@ -0,0 +1,13 @@ +(library + (name ltac_plugin) + (public_name coq.plugins.ltac) + (synopsis "Coq's LTAC tactic language") + (modules :standard \ tauto) + (libraries coq.stm)) + +(library + (name tauto_plugin) + (public_name coq.plugins.tauto) + (synopsis "Coq's tauto tactic") + (modules tauto) + (libraries coq.plugins.ltac)) diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 11bb7a2341..50cfb6d004 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -17,9 +17,8 @@ open Constrexpr open Genarg open Geninterp open Stdarg -open Libnames -open Notation_term -open Misctypes +open Notation_gram +open Tactypes open Locus open Decl_kinds open Genredexpr @@ -29,6 +28,7 @@ open Printer open Tacexpr open Tacarg +open Tactics module Tag = struct @@ -116,7 +116,7 @@ let string_of_genarg_arg (ArgumentType arg) = let keyword x = tag_keyword (str x) let primitive x = tag_primitive (str x) - let has_type (Val.Dyn (tag, x)) t = match Val.eq tag t with + let has_type (Val.Dyn (tag, _)) t = match Val.eq tag t with | None -> false | Some _ -> true @@ -149,9 +149,12 @@ let string_of_genarg_arg (ArgumentType arg) = let open Genprint in match generic_top_print (in_gen (Topwit wit) x) with | TopPrinterBasic pr -> pr () - | TopPrinterNeedsContext pr -> pr (Global.env()) Evd.empty + | TopPrinterNeedsContext pr -> + let env = Global.env() in + pr env (Evd.from_env env) | TopPrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> - printer (Global.env()) Evd.empty default_ensure_surrounded + let env = Global.env() in + printer env (Evd.from_env env) default_ensure_surrounded end | _ -> default @@ -186,7 +189,7 @@ let string_of_genarg_arg (ArgumentType arg) = | AN v -> f v | ByNotation (s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc) - let pr_located pr (loc,x) = pr x + let pr_located pr (_,x) = pr x let pr_evaluable_reference = function | EvalVarRef id -> pr_id id @@ -238,7 +241,7 @@ let string_of_genarg_arg (ArgumentType arg) = in pr_sequence (fun x -> x) l - let pr_extend_gen pr_gen lev { mltac_name = s; mltac_index = i } l = + let pr_extend_gen pr_gen _ { mltac_name = s; mltac_index = i } l = let name = str s.mltac_plugin ++ str "::" ++ str s.mltac_tactic ++ str "@" ++ int i @@ -258,7 +261,7 @@ let string_of_genarg_arg (ArgumentType arg) = | Extend.Uentry tag -> let ArgT.Any tag = tag in ArgT.repr tag - | Extend.Uentryl (tkn, lvl) -> "tactic" ^ string_of_int lvl + | Extend.Uentryl (_, lvl) -> "tactic" ^ string_of_int lvl let pr_alias_key key = try @@ -269,6 +272,8 @@ let string_of_genarg_arg (ArgumentType arg) = in pr_sequence pr prods with Not_found -> + (* FIXME: This key, moreover printed with a low-level printer, + has no meaning user-side *) KerName.print key let pr_alias_gen pr_gen lev key l = @@ -286,10 +291,10 @@ let string_of_genarg_arg (ArgumentType arg) = let p = pr_tacarg_using_rule pr_gen prods in if pp.pptac_level > lev then surround p else p with Not_found -> - let pr arg = str "_" in + let pr _ = str "_" in KerName.print key ++ spc() ++ pr_sequence pr l ++ str" (* Generic printer *)" - let pr_farg prtac arg = prtac (1, Any) (TacArg (Loc.tag arg)) + let pr_farg prtac arg = prtac (1, Any) (TacArg (CAst.make arg)) let is_genarg tag wit = let ArgT.Any tag = tag in @@ -339,15 +344,15 @@ let string_of_genarg_arg (ArgumentType arg) = pr_any_arg pr symb arg | _ -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" - let pr_raw_extend_rec prc prlc prtac prpat = + let pr_raw_extend_rec prtac = pr_extend_gen (pr_farg prtac) - let pr_glob_extend_rec prc prlc prtac prpat = + let pr_glob_extend_rec prtac = pr_extend_gen (pr_farg prtac) - let pr_raw_alias prc prlc prtac prpat lev key args = - pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.tag a)))) lev key args - let pr_glob_alias prc prlc prtac prpat lev key args = - pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.tag a)))) lev key args + let pr_raw_alias prtac lev key args = + pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (CAst.make a)))) lev key args + let pr_glob_alias prtac lev key args = + pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (CAst.make a)))) lev key args (**********************************************************************) (* The tactic printer *) @@ -490,7 +495,7 @@ let string_of_genarg_arg (ArgumentType arg) = let pr_orient b = if b then mt () else str "<- " - let pr_multi = function + let pr_multi = let open Equality in function | Precisely 1 -> mt () | Precisely n -> int n ++ str "!" | UpTo n -> int n ++ str "?" @@ -505,7 +510,7 @@ let string_of_genarg_arg (ArgumentType arg) = let pr_destruction_arg prc prlc (clear_flag,h) = pr_clear_flag clear_flag (pr_core_destruction_arg prc prlc) h - let pr_inversion_kind = function + let pr_inversion_kind = let open Inv in function | SimpleInversion -> primitive "simple inversion" | FullInversion -> primitive "inversion" | FullInversionClear -> primitive "inversion_clear" @@ -514,7 +519,8 @@ let string_of_genarg_arg (ArgumentType arg) = if Int.equal i j then int i else int i ++ str "-" ++ int j -let pr_goal_selector toplevel = function +let pr_goal_selector toplevel = let open Goal_select in function + | SelectAlreadyFocused -> str "!:" | SelectNth i -> int i ++ str ":" | SelectList l -> prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ str ":" | SelectId id -> str "[" ++ Id.print id ++ str "]:" @@ -573,7 +579,7 @@ let pr_goal_selector ~toplevel s = pr_gen arg else str name ++ str ":" ++ surround (pr_gen arg) - | _ -> pr_arg (TacArg (Loc.tag t)) in + | _ -> pr_arg (TacArg (CAst.make t)) in hov 0 (keyword k ++ spc () ++ pr_lname na ++ prlist pr_funvar bl ++ str " :=" ++ brk (1,1) ++ pr t) @@ -740,12 +746,12 @@ let pr_goal_selector ~toplevel s = (* Main tactic printer *) and pr_atom1 a = tag_atom a (match a with (* Basic tactics *) - | TacIntroPattern (ev,[]) as t -> + | TacIntroPattern (_,[]) as t -> pr_atom0 t | TacIntroPattern (ev,(_::_ as p)) -> hov 1 (primitive (if ev then "eintros" else "intros") ++ (match p with - | [{CAst.v=Misctypes.IntroForthcoming false}] -> mt () + | [{CAst.v=IntroForthcoming false}] -> mt () | _ -> spc () ++ prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p)) | TacApply (a,ev,cb,inhyp) -> hov 1 ( @@ -1039,30 +1045,30 @@ let pr_goal_selector ~toplevel s = | TacSelect (s, tac) -> pr_goal_selector ~toplevel:false s ++ spc () ++ pr_tac ltop tac, latom | TacId l -> keyword "idtac" ++ prlist (pr_arg (pr_message_token pr.pr_name)) l, latom - | TacAtom (loc,t) -> + | TacAtom { CAst.loc; v=t } -> pr_with_comments ?loc (hov 1 (pr_atom pr strip_prod_binders tag_atom t)), ltatom - | TacArg(_,Tacexp e) -> + | TacArg { CAst.v=Tacexp e } -> pr_tac inherited e, latom - | TacArg(_,ConstrMayEval (ConstrTerm c)) -> + | TacArg { CAst.v=ConstrMayEval (ConstrTerm c) } -> keyword "constr:" ++ pr.pr_constr c, latom - | TacArg(_,ConstrMayEval c) -> + | TacArg { CAst.v=ConstrMayEval c } -> pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c, leval - | TacArg(_,TacFreshId l) -> + | TacArg { CAst.v=TacFreshId l } -> primitive "fresh" ++ pr_fresh_ids l, latom - | TacArg(_,TacGeneric arg) -> + | TacArg { CAst.v=TacGeneric arg } -> pr.pr_generic arg, latom - | TacArg(_,TacCall(loc,(f,[]))) -> + | TacArg { CAst.v=TacCall {CAst.v=(f,[])} } -> pr.pr_reference f, latom - | TacArg(_,TacCall(loc,(f,l))) -> + | TacArg { CAst.v=TacCall {CAst.loc; v=(f,l)} } -> pr_with_comments ?loc (hov 1 ( pr.pr_reference f ++ spc () ++ prlist_with_sep spc pr_tacarg l)), lcall - | TacArg (_,a) -> + | TacArg { CAst.v=a } -> pr_tacarg a, latom - | TacML (loc,(s,l)) -> + | TacML { CAst.loc; v=(s,l) } -> pr_with_comments ?loc (pr.pr_extend 1 s l), lcall - | TacAlias (loc,(kn,l)) -> + | TacAlias { CAst.loc; v=(kn,l) } -> pr_with_comments ?loc (pr.pr_alias (level_of inherited) kn l), latom ) in @@ -1081,7 +1087,7 @@ let pr_goal_selector ~toplevel s = | TacNumgoals -> keyword "numgoals" | (TacCall _|Tacexp _ | TacGeneric _) as a -> - hov 0 (keyword "ltac:" ++ surround (pr_tac ltop (TacArg (Loc.tag a)))) + hov 0 (keyword "ltac:" ++ surround (pr_tac ltop (TacArg (CAst.make a)))) in pr_tac @@ -1105,12 +1111,12 @@ let pr_goal_selector ~toplevel s = pr_lconstr = pr_lconstr_expr; pr_pattern = pr_constr_pattern_expr; pr_lpattern = pr_lconstr_pattern_expr; - pr_constant = pr_or_by_notation pr_reference; - pr_reference = pr_reference; + pr_constant = pr_or_by_notation pr_qualid; + pr_reference = pr_qualid; pr_name = pr_lident; pr_generic = (fun arg -> Pputils.pr_raw_generic (Global.env ()) arg); - pr_extend = pr_raw_extend_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr; - pr_alias = pr_raw_alias pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr; + pr_extend = pr_raw_extend_rec pr_raw_tactic_level; + pr_alias = pr_raw_alias pr_raw_tactic_level; } in make_pr_tac pr raw_printers @@ -1139,12 +1145,8 @@ let pr_goal_selector ~toplevel s = pr_reference = pr_ltac_or_var (pr_located pr_ltac_constant); pr_name = pr_lident; pr_generic = (fun arg -> Pputils.pr_glb_generic (Global.env ()) arg); - pr_extend = pr_glob_extend_rec - (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) - prtac (pr_pat_and_constr_expr (pr_glob_constr_env env)); - pr_alias = pr_glob_alias - (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) - prtac (pr_pat_and_constr_expr (pr_glob_constr_env env)); + pr_extend = pr_glob_extend_rec prtac; + pr_alias = pr_glob_alias prtac; } in make_pr_tac pr glob_printers @@ -1165,8 +1167,8 @@ let pr_goal_selector ~toplevel s = | _ -> user_err Pp.(str "Cannot translate fix tactic: not enough products") in strip_ty [] n ty - let pr_atomic_tactic_level env sigma n t = - let prtac n (t:atomic_tactic_expr) = + let pr_atomic_tactic_level env sigma t = + let prtac (t:atomic_tactic_expr) = let pr = { pr_tactic = (fun _ _ -> str "<tactic>"); pr_constr = (fun c -> pr_econstr_env env sigma c); @@ -1185,18 +1187,15 @@ let pr_goal_selector ~toplevel s = in pr_atom pr strip_prod_binders_constr tag_atomic_tactic_expr t in - prtac n t + prtac t let pr_raw_generic = Pputils.pr_raw_generic let pr_glb_generic = Pputils.pr_glb_generic - let pr_raw_extend env = pr_raw_extend_rec - pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr + let pr_raw_extend _ = pr_raw_extend_rec pr_raw_tactic_level - let pr_glob_extend env = pr_glob_extend_rec - (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) - (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env)) + let pr_glob_extend env = pr_glob_extend_rec (pr_glob_tactic_level env) let pr_alias pr lev key args = pr_alias_gen (fun _ arg -> pr arg) lev key args @@ -1204,14 +1203,14 @@ let pr_goal_selector ~toplevel s = let pr_extend pr lev ml args = pr_extend_gen pr lev ml args - let pr_atomic_tactic env sigma c = pr_atomic_tactic_level env sigma ltop c + let pr_atomic_tactic env sigma c = pr_atomic_tactic_level env sigma c let declare_extra_genarg_pprule wit (f : 'a raw_extra_genarg_printer) (g : 'b glob_extra_genarg_printer) (h : 'c extra_genarg_printer) = begin match wit with - | ExtraArg s -> () + | ExtraArg _ -> () | _ -> user_err Pp.(str "Can declare a pretty-printing rule only for extra argument types.") end; let f x = @@ -1319,7 +1318,7 @@ let () = let open Genprint in register_basic_print0 wit_int_or_var (pr_or_var int) (pr_or_var int) int; register_basic_print0 wit_ref - pr_reference (pr_or_var (pr_located pr_global)) pr_global; + pr_qualid (pr_or_var (pr_located pr_global)) pr_global; register_basic_print0 wit_ident pr_id pr_id pr_id; register_basic_print0 wit_var pr_lident pr_lident pr_id; register_print0 @@ -1353,7 +1352,7 @@ let () = ; Genprint.register_print0 wit_red_expr - (lift (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr))) + (lift (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_qualid, pr_constr_pattern_expr))) (lift (pr_red_expr (pr_and_constr_expr pr_glob_constr_pptac, pr_and_constr_expr pr_lglob_constr_pptac, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr_pptac))) pr_red_expr_env ; diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 5951f2b119..6c09e447a5 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -14,11 +14,11 @@ open Genarg open Geninterp open Names -open Misctypes open Environ open Constrexpr -open Notation_term +open Notation_gram open Tacexpr +open Tactypes type 'a grammar_tactic_prod_item_expr = | TacTerm of string @@ -84,7 +84,7 @@ type pp_tactic = { pptac_prods : grammar_terminals; } -val pr_goal_selector : toplevel:bool -> goal_selector -> Pp.t +val pr_goal_selector : toplevel:bool -> Goal_select.t -> Pp.t val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit @@ -97,7 +97,7 @@ val pr_may_eval : ('a -> Pp.t) -> ('a -> Pp.t) -> ('b -> Pp.t) -> ('c -> Pp.t) -> ('a,'b,'c) Genredexpr.may_eval -> Pp.t -val pr_and_short_name : ('a -> Pp.t) -> 'a and_short_name -> Pp.t +val pr_and_short_name : ('a -> Pp.t) -> 'a Stdarg.and_short_name -> Pp.t val pr_or_by_notation : ('a -> Pp.t) -> 'a or_by_notation -> Pp.t val pr_evaluable_reference_env : env -> evaluable_global_reference -> Pp.t @@ -153,5 +153,5 @@ val pr_value : tolerability -> Val.t -> Pp.t val ltop : tolerability -val make_constr_printer : (env -> Evd.evar_map -> Notation_term.tolerability -> 'a -> Pp.t) -> +val make_constr_printer : (env -> Evd.evar_map -> tolerability -> 'a -> Pp.t) -> 'a Genprint.top_printer diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index d22bd4967a..3eb049dbab 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -251,7 +251,7 @@ let string_of_call ck = | Tacexpr.LtacVarCall (id, t) -> Names.Id.print id | Tacexpr.LtacAtomCall te -> (Pptactic.pr_glob_tactic (Global.env ()) - (Tacexpr.TacAtom (Loc.tag te))) + (Tacexpr.TacAtom (CAst.make te))) | Tacexpr.LtacConstrInterp (c, _) -> pr_glob_constr_env (Global.env ()) c | Tacexpr.LtacMLCall te -> @@ -260,7 +260,7 @@ let string_of_call ck = ) in let s = String.map (fun c -> if c = '\n' then ' ' else c) s in let s = try String.sub s 0 (CString.string_index_from s 0 "(*") with Not_found -> s in - CString.strip s + String.trim s let rec merge_sub_tree name tree acc = try diff --git a/plugins/ltac/profile_ltac_tactics.ml4 b/plugins/ltac/profile_ltac_tactics.mlg index 983e1578be..2713819c7b 100644 --- a/plugins/ltac/profile_ltac_tactics.ml4 +++ b/plugins/ltac/profile_ltac_tactics.mlg @@ -8,13 +8,19 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + (** Ltac profiling entrypoints *) open Profile_ltac open Stdarg +} + DECLARE PLUGIN "ltac_plugin" +{ + let tclSET_PROFILING b = Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> set_profiling b)) @@ -33,42 +39,44 @@ let tclRESTART_TIMER s = let tclFINISH_TIMING ?(prefix="Timer") (s : string option) = Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> finish_timing ~prefix s)) +} + TACTIC EXTEND start_ltac_profiling -| [ "start" "ltac" "profiling" ] -> [ tclSET_PROFILING true ] +| [ "start" "ltac" "profiling" ] -> { tclSET_PROFILING true } END TACTIC EXTEND stop_ltac_profiling -| [ "stop" "ltac" "profiling" ] -> [ tclSET_PROFILING false ] +| [ "stop" "ltac" "profiling" ] -> { tclSET_PROFILING false } END TACTIC EXTEND reset_ltac_profile -| [ "reset" "ltac" "profile" ] -> [ tclRESET_PROFILE ] +| [ "reset" "ltac" "profile" ] -> { tclRESET_PROFILE } END TACTIC EXTEND show_ltac_profile -| [ "show" "ltac" "profile" ] -> [ tclSHOW_PROFILE ~cutoff:!Flags.profile_ltac_cutoff ] -| [ "show" "ltac" "profile" "cutoff" int(n) ] -> [ tclSHOW_PROFILE ~cutoff:(float_of_int n) ] -| [ "show" "ltac" "profile" string(s) ] -> [ tclSHOW_PROFILE_TACTIC s ] +| [ "show" "ltac" "profile" ] -> { tclSHOW_PROFILE ~cutoff:!Flags.profile_ltac_cutoff } +| [ "show" "ltac" "profile" "cutoff" int(n) ] -> { tclSHOW_PROFILE ~cutoff:(float_of_int n) } +| [ "show" "ltac" "profile" string(s) ] -> { tclSHOW_PROFILE_TACTIC s } END TACTIC EXTEND restart_timer -| [ "restart_timer" string_opt(s) ] -> [ tclRESTART_TIMER s ] +| [ "restart_timer" string_opt(s) ] -> { tclRESTART_TIMER s } END TACTIC EXTEND finish_timing -| [ "finish_timing" string_opt(s) ] -> [ tclFINISH_TIMING ~prefix:"Timer" s ] -| [ "finish_timing" "(" string(prefix) ")" string_opt(s) ] -> [ tclFINISH_TIMING ~prefix s ] +| [ "finish_timing" string_opt(s) ] -> { tclFINISH_TIMING ~prefix:"Timer" s } +| [ "finish_timing" "(" string(prefix) ")" string_opt(s) ] -> { tclFINISH_TIMING ~prefix s } END VERNAC COMMAND EXTEND ResetLtacProfiling CLASSIFIED AS SIDEFF - [ "Reset" "Ltac" "Profile" ] -> [ reset_profile () ] +| [ "Reset" "Ltac" "Profile" ] -> { reset_profile () } END VERNAC COMMAND EXTEND ShowLtacProfile CLASSIFIED AS QUERY -| [ "Show" "Ltac" "Profile" ] -> [ print_results ~cutoff:!Flags.profile_ltac_cutoff ] -| [ "Show" "Ltac" "Profile" "CutOff" int(n) ] -> [ print_results ~cutoff:(float_of_int n) ] +| [ "Show" "Ltac" "Profile" ] -> { print_results ~cutoff:!Flags.profile_ltac_cutoff } +| [ "Show" "Ltac" "Profile" "CutOff" int(n) ] -> { print_results ~cutoff:(float_of_int n) } END VERNAC COMMAND EXTEND ShowLtacProfileTactic CLASSIFIED AS QUERY - [ "Show" "Ltac" "Profile" string(s) ] -> [ print_results_tactic s ] +| [ "Show" "Ltac" "Profile" string(s) ] -> { print_results_tactic s } END diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index d32a2faefc..fee469032c 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -26,7 +26,7 @@ open Classes open Constrexpr open Globnames open Evd -open Misctypes +open Tactypes open Locus open Locusops open Decl_kinds @@ -43,6 +43,14 @@ module NamedDecl = Context.Named.Declaration (** Typeclass-based generalized rewriting. *) +type rewrite_attributes = { polymorphic : bool; program : bool; global : bool } + +let rewrite_attributes = + let open Attributes.Notations in + Attributes.(polymorphic ++ program ++ locality) >>= fun ((polymorphic, program), locality) -> + let global = not (Locality.make_section_locality locality) in + Attributes.Notations.return { polymorphic; program; global } + (** Constants used by the tactic. *) let classes_dirpath = @@ -56,12 +64,14 @@ let init_setoid () = if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"] +let find_reference dir s = + Coqlib.find_reference "generalized rewriting" dir s +[@@warning "-3"] + let lazy_find_reference dir s = - let gr = lazy (Coqlib.coq_reference "generalized rewriting" dir s) in + let gr = lazy (find_reference dir s) in fun () -> Lazy.force gr -let find_reference dir s = Coqlib.coq_reference "generalized rewriting" dir s - type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) let find_global dir s = @@ -74,21 +84,21 @@ let find_global dir s = (** Global constants. *) -let coq_eq_ref = lazy_find_reference ["Init"; "Logic"] "eq" -let coq_eq = find_global ["Init"; "Logic"] "eq" -let coq_f_equal = find_global ["Init"; "Logic"] "f_equal" -let coq_all = find_global ["Init"; "Logic"] "all" -let impl = find_global ["Program"; "Basics"] "impl" +let coq_eq_ref () = Coqlib.lib_ref "core.eq.type" +let coq_eq = find_global ["Coq"; "Init"; "Logic"] "eq" +let coq_f_equal = find_global ["Coq"; "Init"; "Logic"] "f_equal" +let coq_all = find_global ["Coq"; "Init"; "Logic"] "all" +let impl = find_global ["Coq"; "Program"; "Basics"] "impl" -(** Bookkeeping which evars are constraints so that we can +(** Bookkeeping which evars are constraints so that we can remove them at the end of the tactic. *) let goalevars evars = fst evars let cstrevars evars = snd evars let new_cstr_evar (evd,cstrs) env t = - let s = Typeclasses.set_resolvable Evd.Store.empty false in - let (evd', t) = Evarutil.new_evar ~store:s env evd t in + (** We handle the typeclass resolution of constraints ourselves *) + let (evd', t) = Evarutil.new_evar env evd ~typeclass_candidate:false t in let ev, _ = destEvar evd' t in (evd', Evar.Set.add ev cstrs), t @@ -104,9 +114,8 @@ let extends_undefined evars evars' = let app_poly_check env evars f args = let (evars, cstrs), fc = f evars in - let evdref = ref evars in - let t = Typing.e_solve_evars env evdref (mkApp (fc, args)) in - (!evdref, cstrs), t + let evars, t = Typing.solve_evars env evars (mkApp (fc, args)) in + (evars, cstrs), t let app_poly_nocheck env evars f args = let evars, fc = f evars in @@ -155,7 +164,7 @@ end) = struct let respectful = find_global morphisms "respectful" let respectful_ref = lazy_find_reference morphisms "respectful" - let default_relation = find_global ["Classes"; "SetoidTactics"] "DefaultRelation" + let default_relation = find_global ["Coq"; "Classes"; "SetoidTactics"] "DefaultRelation" let coq_forall = find_global morphisms "forall_def" @@ -375,12 +384,12 @@ let type_app_poly env env evd f args = module PropGlobal = struct module Consts = struct - let relation_classes = ["Classes"; "RelationClasses"] - let morphisms = ["Classes"; "Morphisms"] - let relation = ["Relations";"Relation_Definitions"], "relation" + let relation_classes = ["Coq"; "Classes"; "RelationClasses"] + let morphisms = ["Coq"; "Classes"; "Morphisms"] + let relation = ["Coq"; "Relations";"Relation_Definitions"], "relation" let app_poly = app_poly_nocheck - let arrow = find_global ["Program"; "Basics"] "arrow" - let coq_inverse = find_global ["Program"; "Basics"] "flip" + let arrow = find_global ["Coq"; "Program"; "Basics"] "arrow" + let coq_inverse = find_global ["Coq"; "Program"; "Basics"] "flip" end module G = GlobalBindings(Consts) @@ -396,12 +405,12 @@ end module TypeGlobal = struct module Consts = struct - let relation_classes = ["Classes"; "CRelationClasses"] - let morphisms = ["Classes"; "CMorphisms"] + let relation_classes = ["Coq"; "Classes"; "CRelationClasses"] + let morphisms = ["Coq"; "Classes"; "CMorphisms"] let relation = relation_classes, "crelation" let app_poly = app_poly_check - let arrow = find_global ["Classes"; "CRelationClasses"] "arrow" - let coq_inverse = find_global ["Classes"; "CRelationClasses"] "flip" + let arrow = find_global ["Coq"; "Classes"; "CRelationClasses"] "arrow" + let coq_inverse = find_global ["Coq"; "Classes"; "CRelationClasses"] "flip" end module G = GlobalBindings(Consts) @@ -410,7 +419,7 @@ module TypeGlobal = struct let inverse env (evd,cstrs) car rel = - let (evd, sort) = Evarutil.new_Type ~rigid:Evd.univ_flexible env evd in + let (evd, sort) = Evarutil.new_Type ~rigid:Evd.univ_flexible evd in app_poly_check env (evd,cstrs) coq_inverse [| car ; car; sort; rel |] end @@ -428,7 +437,8 @@ let split_head = function | [] -> assert(false) let eq_pb (ty, env, x, y as pb) (ty', env', x', y' as pb') = - pb == pb' || (ty == ty' && Constr.equal x x' && Constr.equal y y') + let equal x y = Constr.equal (EConstr.Unsafe.to_constr x) (EConstr.Unsafe.to_constr y) in + pb == pb' || (ty == ty' && equal x x' && equal y y') let problem_inclusion x y = List.for_all (fun pb -> List.exists (fun pb' -> eq_pb pb pb') y) x @@ -518,12 +528,7 @@ let decompose_applied_relation env sigma (c,l) = let rewrite_db = "rewrite" -let conv_transparent_state = (Id.Pred.empty, Cpred.full) - -let _ = - Hints.add_hints_init - (fun () -> - Hints.create_hint_db false rewrite_db conv_transparent_state true) +let conv_transparent_state = TransparentState.cst_full let rewrite_transparent_state () = Hints.Hint_db.transparent_state (Hints.searchtable_map rewrite_db) @@ -532,8 +537,8 @@ let rewrite_core_unif_flags = { Unification.modulo_conv_on_closed_terms = None; Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.use_evars_eagerly_in_conv_on_closed_terms = true; - Unification.modulo_delta = empty_transparent_state; - Unification.modulo_delta_types = full_transparent_state; + Unification.modulo_delta = TransparentState.empty; + Unification.modulo_delta_types = TransparentState.full; Unification.check_applied_meta_types = true; Unification.use_pattern_unification = true; Unification.use_meta_bound_pattern_unification = true; @@ -580,12 +585,12 @@ let general_rewrite_unif_flags () = Unification.modulo_conv_on_closed_terms = Some ts; Unification.use_evars_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = ts; - Unification.modulo_delta_types = full_transparent_state; + Unification.modulo_delta_types = TransparentState.full; Unification.modulo_betaiota = true } in { Unification.core_unify_flags = core_flags; Unification.merge_unify_flags = core_flags; - Unification.subterm_unify_flags = { core_flags with Unification.modulo_delta = empty_transparent_state }; + Unification.subterm_unify_flags = { core_flags with Unification.modulo_delta = TransparentState.empty }; Unification.allow_K_in_toplevel_higher_order_unification = true; Unification.resolve_evars = true } @@ -626,18 +631,15 @@ let solve_remaining_by env sigma holes by = (** Evar should not be defined, but just in case *) | Some evi -> let env = Environ.reset_with_named_context evi.evar_hyps env in - let ty = EConstr.of_constr evi.evar_concl in + let ty = evi.evar_concl in let c, sigma = Pfedit.refine_by_tactic env sigma ty solve_tac in - Evd.define evk c sigma + Evd.define evk (EConstr.of_constr c) sigma in List.fold_left solve sigma indep let no_constraints cstrs = fun ev _ -> not (Evar.Set.mem ev cstrs) -let all_constraints cstrs = - fun ev _ -> Evar.Set.mem ev cstrs - let poly_inverse sort = if sort then PropGlobal.inverse else TypeGlobal.inverse @@ -745,9 +747,9 @@ let new_global (evars, cstrs) gr = (sigma, cstrs), c let make_eq sigma = - new_global sigma (Coqlib.build_coq_eq ()) + new_global sigma Coqlib.(lib_ref "core.eq.type") let make_eq_refl sigma = - new_global sigma (Coqlib.build_coq_eq_refl ()) + new_global sigma Coqlib.(lib_ref "core.eq.refl") let get_rew_prf evars r = match r.rew_prf with | RewPrf (rel, prf) -> evars, (rel, prf) @@ -1456,10 +1458,11 @@ let apply_strategy (s : strategy) env unfresh concl (prop, cstr) evars = res let solve_constraints env (evars,cstrs) = - let filter = all_constraints cstrs in - Typeclasses.resolve_typeclasses env ~filter ~split:false ~fail:true - (Typeclasses.mark_resolvables ~filter evars) - + let oldtcs = Evd.get_typeclass_evars evars in + let evars' = Evd.set_typeclass_evars evars cstrs in + let evars' = Typeclasses.resolve_typeclasses env ~filter:all_evars ~split:false ~fail:true evars' in + Evd.set_typeclass_evars evars' oldtcs + let nf_zeta = Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) @@ -1468,8 +1471,8 @@ exception RewriteFailure of Pp.t type result = (evar_map * constr option * types) option option let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : result = + let sigma, sort = Typing.sort_of env sigma concl in let evdref = ref sigma in - let sort = Typing.e_sort_of env evdref concl in let evars = (!evdref, Evar.Set.empty) in let evars, cstr = let prop, (evars, arrow) = @@ -1497,7 +1500,7 @@ let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : resul if not (Evd.is_defined acc ev) then user_err ~hdr:"rewrite" (str "Unsolved constraint remaining: " ++ spc () ++ - Termops.pr_evar_info (Evd.find acc ev)) + Termops.pr_evar_info env acc (Evd.find acc ev)) else Evd.remove acc ev) cstrs evars' in @@ -1773,80 +1776,78 @@ let rec strategy_of_ast = function (* By default the strategy for "rewrite_db" is top-down *) -let mkappc s l = CAst.make @@ CAppExpl ((None,CAst.make @@ Libnames.Ident (Id.of_string s),None),l) +let mkappc s l = CAst.make @@ CAppExpl ((None,qualid_of_ident (Id.of_string s),None),l) let declare_an_instance n s args = (((CAst.make @@ Name n),None), Explicit, - CAst.make @@ CAppExpl ((None, CAst.make @@ Qualid (qualid_of_string s),None), args)) + CAst.make @@ CAppExpl ((None, qualid_of_string s,None), args)) let declare_instance a aeq n s = declare_an_instance n s [a;aeq] -let anew_instance global binders instance fields = - let program_mode = Flags.is_program_mode () in - let poly = Flags.is_universe_polymorphism () in - new_instance ~program_mode poly +let anew_instance atts binders instance fields = + let program_mode = atts.program in + new_instance ~program_mode atts.polymorphic binders instance (Some (true, CAst.make @@ CRecord (fields))) - ~global ~generalize:false ~refine:false Hints.empty_hint_info + ~global:atts.global ~generalize:false ~refine:false Hints.empty_hint_info -let declare_instance_refl global binders a aeq n lemma = +let declare_instance_refl atts binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" - in anew_instance global binders instance - [(CAst.make @@ Ident (Id.of_string "reflexivity"),lemma)] + in anew_instance atts binders instance + [(qualid_of_ident (Id.of_string "reflexivity"),lemma)] -let declare_instance_sym global binders a aeq n lemma = +let declare_instance_sym atts binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric" - in anew_instance global binders instance - [(CAst.make @@ Ident (Id.of_string "symmetry"),lemma)] + in anew_instance atts binders instance + [(qualid_of_ident (Id.of_string "symmetry"),lemma)] -let declare_instance_trans global binders a aeq n lemma = +let declare_instance_trans atts binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" - in anew_instance global binders instance - [(CAst.make @@ Ident (Id.of_string "transitivity"),lemma)] + in anew_instance atts binders instance + [(qualid_of_ident (Id.of_string "transitivity"),lemma)] -let declare_relation ?locality ?(binders=[]) a aeq n refl symm trans = +let declare_relation atts ?(binders=[]) a aeq n refl symm trans = init_setoid (); - let global = not (Locality.make_section_locality locality) in let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" - in ignore(anew_instance global binders instance []); + in ignore(anew_instance atts binders instance []); match (refl,symm,trans) with (None, None, None) -> () | (Some lemma1, None, None) -> - ignore (declare_instance_refl global binders a aeq n lemma1) + ignore (declare_instance_refl atts binders a aeq n lemma1) | (None, Some lemma2, None) -> - ignore (declare_instance_sym global binders a aeq n lemma2) + ignore (declare_instance_sym atts binders a aeq n lemma2) | (None, None, Some lemma3) -> - ignore (declare_instance_trans global binders a aeq n lemma3) + ignore (declare_instance_trans atts binders a aeq n lemma3) | (Some lemma1, Some lemma2, None) -> - ignore (declare_instance_refl global binders a aeq n lemma1); - ignore (declare_instance_sym global binders a aeq n lemma2) + ignore (declare_instance_refl atts binders a aeq n lemma1); + ignore (declare_instance_sym atts binders a aeq n lemma2) | (Some lemma1, None, Some lemma3) -> - let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in - let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in + let _lemma_refl = declare_instance_refl atts binders a aeq n lemma1 in + let _lemma_trans = declare_instance_trans atts binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" in ignore( - anew_instance global binders instance - [(CAst.make @@ Ident (Id.of_string "PreOrder_Reflexive"), lemma1); - (CAst.make @@ Ident (Id.of_string "PreOrder_Transitive"),lemma3)]) + anew_instance atts binders instance + [(qualid_of_ident (Id.of_string "PreOrder_Reflexive"), lemma1); + (qualid_of_ident (Id.of_string "PreOrder_Transitive"),lemma3)]) | (None, Some lemma2, Some lemma3) -> - let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in - let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in + let _lemma_sym = declare_instance_sym atts binders a aeq n lemma2 in + let _lemma_trans = declare_instance_trans atts binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" in ignore( - anew_instance global binders instance - [(CAst.make @@ Ident (Id.of_string "PER_Symmetric"), lemma2); - (CAst.make @@ Ident (Id.of_string "PER_Transitive"),lemma3)]) + anew_instance atts binders instance + [(qualid_of_ident (Id.of_string "PER_Symmetric"), lemma2); + (qualid_of_ident (Id.of_string "PER_Transitive"),lemma3)]) | (Some lemma1, Some lemma2, Some lemma3) -> - let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in - let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in - let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in + let _lemma_refl = declare_instance_refl atts binders a aeq n lemma1 in + let _lemma_sym = declare_instance_sym atts binders a aeq n lemma2 in + let _lemma_trans = declare_instance_trans atts binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( - anew_instance global binders instance - [(CAst.make @@ Ident (Id.of_string "Equivalence_Reflexive"), lemma1); - (CAst.make @@ Ident (Id.of_string "Equivalence_Symmetric"), lemma2); - (CAst.make @@ Ident (Id.of_string "Equivalence_Transitive"), lemma3)]) + anew_instance atts binders instance + [(qualid_of_ident (Id.of_string "Equivalence_Reflexive"), lemma1); + (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), lemma2); + (qualid_of_ident (Id.of_string "Equivalence_Transitive"), lemma3)]) -let cHole = CAst.make @@ CHole (None, Misctypes.IntroAnonymous, None) +let cHole = CAst.make @@ CHole (None, Namegen.IntroAnonymous, None) let proper_projection sigma r ty = let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) in @@ -1862,7 +1863,6 @@ let declare_projection n instance_id r = let env = Global.env () in let sigma = Evd.from_env env in let sigma,c = Evd.fresh_global env sigma r in - let c = EConstr.of_constr c in let ty = Retyping.get_type_of env sigma c in let term = proper_projection sigma c ty in let sigma, typ = Typing.type_of env sigma term in @@ -1923,7 +1923,7 @@ let build_morphism_signature env sigma m = let evd = solve_constraints env !evd in let evd = Evd.minimize_universes evd in let m = Evarutil.nf_evars_universes evd (EConstr.Unsafe.to_constr morph) in - Pretyping.check_evars env Evd.empty evd (EConstr.of_constr m); + Pretyping.check_evars env (Evd.from_env env) evd (EConstr.of_constr m); Evd.evar_universe_context evd, m let default_morphism sign m = @@ -1941,50 +1941,49 @@ let warn_add_setoid_deprecated = CWarnings.create ~name:"add-setoid" ~category:"deprecated" (fun () -> Pp.(str "Add Setoid is deprecated, please use Add Parametric Relation.")) -let add_setoid global binders a aeq t n = +let add_setoid atts binders a aeq t n = warn_add_setoid_deprecated ?loc:a.CAst.loc (); init_setoid (); - let _lemma_refl = declare_instance_refl global binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in - let _lemma_sym = declare_instance_sym global binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in - let _lemma_trans = declare_instance_trans global binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in + let _lemma_refl = declare_instance_refl atts binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in + let _lemma_sym = declare_instance_sym atts binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in + let _lemma_trans = declare_instance_trans atts binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( - anew_instance global binders instance - [(CAst.make @@ Ident (Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); - (CAst.make @@ Ident (Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); - (CAst.make @@ Ident (Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) + anew_instance atts binders instance + [(qualid_of_ident (Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); + (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); + (qualid_of_ident (Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) let make_tactic name = let open Tacexpr in - let tacpath = Libnames.qualid_of_string name in - let tacname = CAst.make @@ Qualid tacpath in - TacArg (Loc.tag @@ (TacCall (Loc.tag (tacname, [])))) + let tacqid = Libnames.qualid_of_string name in + TacArg (CAst.make @@ (TacCall (CAst.make (tacqid, [])))) let warn_add_morphism_deprecated = CWarnings.create ~name:"add-morphism" ~category:"deprecated" (fun () -> Pp.(str "Add Morphism f : id is deprecated, please use Add Morphism f with signature (...) as id")) -let add_morphism_infer glob m n = +let add_morphism_infer atts m n = warn_add_morphism_deprecated ?loc:m.CAst.loc (); init_setoid (); - let poly = Flags.is_universe_polymorphism () in + (* NB: atts.program is ignored, program mode automatically set by vernacentries *) let instance_id = add_suffix n "_Proper" in let env = Global.env () in let evd = Evd.from_env env in let uctx, instance = build_morphism_signature env evd m in if Lib.is_modtype () then - let uctx = UState.const_univ_entry ~poly uctx in + let uctx = UState.const_univ_entry ~poly:atts.polymorphic uctx in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id (Entries.ParameterEntry (None,(instance,uctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) in add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info glob (ConstRef cst)); + (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info atts.global (ConstRef cst)); declare_projection n instance_id (ConstRef cst) else - let kind = Decl_kinds.Global, poly, + let kind = Decl_kinds.Global, atts.polymorphic, Decl_kinds.DefinitionBody Decl_kinds.Instance in let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in @@ -1992,7 +1991,7 @@ let add_morphism_infer glob m n = | Globnames.ConstRef cst -> add_instance (Typeclasses.new_instance (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info - glob (ConstRef cst)); + atts.global (ConstRef cst)); declare_projection n instance_id (ConstRef cst) | _ -> assert false in @@ -2002,19 +2001,17 @@ let add_morphism_infer glob m n = Lemmas.start_proof instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance) hook; ignore (Pfedit.by (Tacinterp.interp tac))) () -let add_morphism glob binders m s n = +let add_morphism atts binders m s n = init_setoid (); - let poly = Flags.is_universe_polymorphism () in let instance_id = add_suffix n "_Proper" in let instance = (((CAst.make @@ Name instance_id),None), Explicit, CAst.make @@ CAppExpl ( - (None, CAst.make @@ Qualid (Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None), + (None, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper",None), [cHole; s; m])) in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in - let program_mode = Flags.is_program_mode () in - ignore(new_instance ~program_mode ~global:glob poly binders instance + ignore(new_instance ~program_mode:atts.program ~global:atts.global atts.polymorphic binders instance (Some (true, CAst.make @@ CRecord [])) ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info) diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index 1e3d4733b5..4f46e78c71 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -12,13 +12,16 @@ open Names open Environ open EConstr open Constrexpr -open Tacexpr -open Misctypes open Evd +open Tactypes +open Tacexpr open Tacinterp (** TODO: document and clean me! *) +type rewrite_attributes +val rewrite_attributes : rewrite_attributes Attributes.attribute + type unary_strategy = Subterms | Subterm | Innermost | Outermost | Bottomup | Topdown | Progress | Try | Any | Repeat @@ -77,18 +80,18 @@ val cl_rewrite_clause : val is_applied_rewrite_relation : env -> evar_map -> rel_context -> constr -> types option -val declare_relation : ?locality:bool -> +val declare_relation : rewrite_attributes -> ?binders:local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> constr_expr option -> constr_expr option -> constr_expr option -> unit val add_setoid : - bool -> local_binder_expr list -> constr_expr -> constr_expr -> constr_expr -> + rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> constr_expr -> Id.t -> unit -val add_morphism_infer : bool -> constr_expr -> Id.t -> unit +val add_morphism_infer : rewrite_attributes -> constr_expr -> Id.t -> unit val add_morphism : - bool -> local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> unit + rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> unit val get_reflexive_proof : env -> evar_map -> constr -> constr -> evar_map * constr diff --git a/plugins/ltac/tacarg.ml b/plugins/ltac/tacarg.ml index 6eb482b1c3..8a25d4851f 100644 --- a/plugins/ltac/tacarg.ml +++ b/plugins/ltac/tacarg.ml @@ -19,6 +19,14 @@ let make0 ?dyn name = let () = Geninterp.register_val0 wit dyn in wit +let wit_intro_pattern = make0 "intropattern" +let wit_quant_hyp = make0 "quant_hyp" +let wit_constr_with_bindings = make0 "constr_with_bindings" +let wit_open_constr_with_bindings = make0 "open_constr_with_bindings" +let wit_bindings = make0 "bindings" +let wit_quantified_hypothesis = wit_quant_hyp +let wit_intropattern = wit_intro_pattern + let wit_tactic : (raw_tactic_expr, glob_tactic_expr, Val.t) genarg_type = make0 "tactic" diff --git a/plugins/ltac/tacarg.mli b/plugins/ltac/tacarg.mli index 5347eda7d7..bdb0be03cf 100644 --- a/plugins/ltac/tacarg.mli +++ b/plugins/ltac/tacarg.mli @@ -9,9 +9,33 @@ (************************************************************************) open Genarg -open Tacexpr +open EConstr open Constrexpr -open Misctypes +open Tactypes +open Tacexpr + +(** Tactic related witnesses, could also live in tactics/ if other users *) +val wit_intro_pattern : (constr_expr intro_pattern_expr CAst.t, glob_constr_and_expr intro_pattern_expr CAst.t, intro_pattern) genarg_type + +val wit_quant_hyp : quantified_hypothesis uniform_genarg_type + +val wit_constr_with_bindings : + (constr_expr with_bindings, + glob_constr_and_expr with_bindings, + constr with_bindings delayed_open) genarg_type + +val wit_open_constr_with_bindings : + (constr_expr with_bindings, + glob_constr_and_expr with_bindings, + constr with_bindings delayed_open) genarg_type + +val wit_bindings : + (constr_expr bindings, + glob_constr_and_expr bindings, + constr bindings delayed_open) genarg_type + +val wit_quantified_hypothesis : quantified_hypothesis uniform_genarg_type +val wit_intropattern : (constr_expr intro_pattern_expr CAst.t, glob_constr_and_expr intro_pattern_expr CAst.t, intro_pattern) genarg_type (** Generic arguments based on Ltac. *) @@ -23,7 +47,7 @@ val wit_tactic : (raw_tactic_expr, glob_tactic_expr, Geninterp.Val.t) genarg_typ val wit_ltac : (raw_tactic_expr, glob_tactic_expr, unit) genarg_type val wit_destruction_arg : - (constr_expr with_bindings Tacexpr.destruction_arg, - glob_constr_and_expr with_bindings Tacexpr.destruction_arg, - delayed_open_constr_with_bindings Tacexpr.destruction_arg) genarg_type + (constr_expr with_bindings Tactics.destruction_arg, + glob_constr_and_expr with_bindings Tactics.destruction_arg, + delayed_open_constr_with_bindings Tactics.destruction_arg) genarg_type diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 3812a2ba29..026c00b849 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -12,9 +12,11 @@ open Util open Names open Constr open EConstr -open Misctypes +open Namegen +open Tactypes open Genarg open Stdarg +open Tacarg open Geninterp open Pp @@ -163,8 +165,7 @@ let coerce_var_to_ident fresh env sigma v = (* Interprets, if possible, a constr to an identifier which may not be fresh but suitable to be given to the fresh tactic. Works for vars, constants, inductive, constructors and sorts. *) -let coerce_to_ident_not_fresh env sigma v = -let g = sigma in +let coerce_to_ident_not_fresh sigma v = let id_of_name = function | Name.Anonymous -> Id.of_string "x" | Name.Name x -> x in @@ -181,9 +182,9 @@ let id_of_name = function | Some c -> match EConstr.kind sigma c with | Var id -> id - | Meta m -> id_of_name (Evd.meta_name g m) + | Meta m -> id_of_name (Evd.meta_name sigma m) | Evar (kn,_) -> - begin match Evd.evar_ident kn g with + begin match Evd.evar_ident kn sigma with | None -> fail () | Some id -> id end @@ -197,15 +198,16 @@ let id_of_name = function let basename = Nametab.basename_of_global ref in basename | Sort s -> - begin + begin match ESorts.kind sigma s with - | Sorts.Prop _ -> Label.to_id (Label.make "Prop") - | Sorts.Type _ -> Label.to_id (Label.make "Type") - end + | Sorts.Prop -> Label.to_id (Label.make "Prop") + | Sorts.Set -> Label.to_id (Label.make "Set") + | Sorts.Type _ -> Label.to_id (Label.make "Type") + end | _ -> fail() -let coerce_to_intro_pattern env sigma v = +let coerce_to_intro_pattern sigma v = if has_type v (topwit wit_intro_pattern) then (out_gen (topwit wit_intro_pattern) v).CAst.v else if has_type v (topwit wit_var) then @@ -218,8 +220,8 @@ let coerce_to_intro_pattern env sigma v = IntroNaming (IntroIdentifier (destVar sigma c)) | _ -> raise (CannotCoerceTo "an introduction pattern") -let coerce_to_intro_pattern_naming env sigma v = - match coerce_to_intro_pattern env sigma v with +let coerce_to_intro_pattern_naming sigma v = + match coerce_to_intro_pattern sigma v with | IntroNaming pat -> pat | _ -> raise (CannotCoerceTo "a naming introduction pattern") @@ -252,7 +254,7 @@ let coerce_to_constr env v = (try [], constr_of_id env id with Not_found -> fail ()) else fail () -let coerce_to_uconstr env v = +let coerce_to_uconstr v = if has_type v (topwit wit_uconstr) then out_gen (topwit wit_uconstr) v else @@ -296,11 +298,11 @@ let coerce_to_constr_list env v = List.map map l | None -> raise (CannotCoerceTo "a term list") -let coerce_to_intro_pattern_list ?loc env sigma v = +let coerce_to_intro_pattern_list ?loc sigma v = match Value.to_list v with | None -> raise (CannotCoerceTo "an intro pattern list") | Some l -> - let map v = CAst.make ?loc @@ coerce_to_intro_pattern env sigma v in + let map v = CAst.make ?loc @@ coerce_to_intro_pattern sigma v in List.map map l let coerce_to_hyp env sigma v = @@ -325,7 +327,7 @@ let coerce_to_hyp_list env sigma v = | None -> raise (CannotCoerceTo "a variable list") (* Interprets a qualified name *) -let coerce_to_reference env sigma v = +let coerce_to_reference sigma v = match Value.to_constr v with | Some c -> begin @@ -353,7 +355,7 @@ let coerce_to_quantified_hypothesis sigma v = (* Quantified named or numbered hypothesis or hypothesis in context *) (* (as in Inversion) *) -let coerce_to_decl_or_quant_hyp env sigma v = +let coerce_to_decl_or_quant_hyp sigma v = if has_type v (topwit wit_int) then AnonHyp (out_gen (topwit wit_int) v) else @@ -365,7 +367,7 @@ let coerce_to_int_or_var_list v = match Value.to_list v with | None -> raise (CannotCoerceTo "an int list") | Some l -> - let map n = ArgArg (coerce_to_int n) in + let map n = Locus.ArgArg (coerce_to_int n) in List.map map l (** Abstract application, to print ltac functions *) diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli index 1fa5e3c076..d2ae92f6ce 100644 --- a/plugins/ltac/taccoerce.mli +++ b/plugins/ltac/taccoerce.mli @@ -11,9 +11,9 @@ open Util open Names open EConstr -open Misctypes open Genarg open Geninterp +open Tactypes (** Coercions from highest level generic arguments to actual data used by Ltac interpretation. Those functions examinate dynamic types and try to return @@ -51,12 +51,12 @@ val coerce_to_constr_context : Value.t -> constr val coerce_var_to_ident : bool -> Environ.env -> Evd.evar_map -> Value.t -> Id.t -val coerce_to_ident_not_fresh : Environ.env -> Evd.evar_map -> Value.t -> Id.t +val coerce_to_ident_not_fresh : Evd.evar_map -> Value.t -> Id.t -val coerce_to_intro_pattern : Environ.env -> Evd.evar_map -> Value.t -> Tacexpr.delayed_open_constr intro_pattern_expr +val coerce_to_intro_pattern : Evd.evar_map -> Value.t -> Tacexpr.delayed_open_constr intro_pattern_expr val coerce_to_intro_pattern_naming : - Environ.env -> Evd.evar_map -> Value.t -> intro_pattern_naming_expr + Evd.evar_map -> Value.t -> Namegen.intro_pattern_naming_expr val coerce_to_hint_base : Value.t -> string @@ -64,7 +64,7 @@ val coerce_to_int : Value.t -> int val coerce_to_constr : Environ.env -> Value.t -> Ltac_pretype.constr_under_binders -val coerce_to_uconstr : Environ.env -> Value.t -> Ltac_pretype.closed_glob_constr +val coerce_to_uconstr : Value.t -> Ltac_pretype.closed_glob_constr val coerce_to_closed_constr : Environ.env -> Value.t -> constr @@ -74,19 +74,19 @@ val coerce_to_evaluable_ref : val coerce_to_constr_list : Environ.env -> Value.t -> constr list val coerce_to_intro_pattern_list : - ?loc:Loc.t -> Environ.env -> Evd.evar_map -> Value.t -> Tacexpr.intro_patterns + ?loc:Loc.t -> Evd.evar_map -> Value.t -> Tacexpr.intro_patterns val coerce_to_hyp : Environ.env -> Evd.evar_map -> Value.t -> Id.t val coerce_to_hyp_list : Environ.env -> Evd.evar_map -> Value.t -> Id.t list -val coerce_to_reference : Environ.env -> Evd.evar_map -> Value.t -> Globnames.global_reference +val coerce_to_reference : Evd.evar_map -> Value.t -> GlobRef.t val coerce_to_quantified_hypothesis : Evd.evar_map -> Value.t -> quantified_hypothesis -val coerce_to_decl_or_quant_hyp : Environ.env -> Evd.evar_map -> Value.t -> quantified_hypothesis +val coerce_to_decl_or_quant_hyp : Evd.evar_map -> Value.t -> quantified_hypothesis -val coerce_to_int_or_var_list : Value.t -> int or_var list +val coerce_to_int_or_var_list : Value.t -> int Locus.or_var list (** {5 Missing generic arguments} *) diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index e510b9f591..ac2d88dec2 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -45,7 +45,7 @@ let coincide s pat off = let atactic n = if n = 5 then Aentry Pltac.binder_tactic - else Aentryl (Pltac.tactic_expr, n) + else Aentryl (Pltac.tactic_expr, string_of_int n) type entry_name = EntryName : 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, 'a) Extend.symbol -> entry_name @@ -177,7 +177,7 @@ let add_tactic_entry (kn, ml, tg) state = TacGeneric arg in let l = List.map map l in - (TacAlias (Loc.tag ~loc (kn,l)):raw_tactic_expr) + (TacAlias (CAst.make ~loc (kn,l)):raw_tactic_expr) in let () = if Int.equal tg.tacgram_level 0 && not (head_is_ident tg) then @@ -187,7 +187,7 @@ let add_tactic_entry (kn, ml, tg) state = | TacTerm s -> GramTerminal s | TacNonTerm (loc, (s, ido)) -> let EntryName (typ, e) = prod_item_of_symbol tg.tacgram_level s in - GramNonTerminal (Loc.tag ?loc @@ (Option.map (fun _ -> typ) ido, e)) + GramNonTerminal (Loc.tag ?loc @@ (typ, e)) in let prods = List.map map tg.tacgram_prods in let rules = make_rule mkact prods in @@ -252,7 +252,7 @@ type tactic_grammar_obj = { tacobj_key : KerName.t; tacobj_local : locality_flag; tacobj_tacgram : tactic_grammar; - tacobj_body : Id.t list * Tacexpr.glob_tactic_expr; + tacobj_body : Tacenv.alias_tactic; tacobj_forml : bool; } @@ -288,10 +288,11 @@ let load_tactic_notation i (_, tobj) = extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram let subst_tactic_notation (subst, tobj) = - let (ids, body) = tobj.tacobj_body in + let open Tacenv in + let alias = tobj.tacobj_body in { tobj with tacobj_key = Mod_subst.subst_kn subst tobj.tacobj_key; - tacobj_body = (ids, Tacsubst.subst_tactic subst body); + tacobj_body = { alias with alias_body = Tacsubst.subst_tactic subst alias.alias_body }; } let classify_tactic_notation tacobj = Substitute tacobj @@ -308,25 +309,26 @@ let cons_production_parameter = function | TacTerm _ -> None | TacNonTerm (_, (_, ido)) -> ido -let add_glob_tactic_notation local ~level prods forml ids tac = +let add_glob_tactic_notation local ~level ?deprecation prods forml ids tac = let parule = { tacgram_level = level; tacgram_prods = prods; } in + let open Tacenv in let tacobj = { tacobj_key = make_fresh_key prods; tacobj_local = local; tacobj_tacgram = parule; - tacobj_body = (ids, tac); + tacobj_body = { alias_args = ids; alias_body = tac; alias_deprecation = deprecation }; tacobj_forml = forml; } in Lib.add_anonymous_leaf (inTacticGrammar tacobj) -let add_tactic_notation local n prods e = +let add_tactic_notation local n ?deprecation prods e = let ids = List.map_filter cons_production_parameter prods in let prods = List.map interp_prod_item prods in let tac = Tacintern.glob_tactic_env ids (Global.env()) e in - add_glob_tactic_notation local ~level:n prods false ids tac + add_glob_tactic_notation local ~level:n ?deprecation prods false ids tac (**********************************************************************) (* ML Tactic entries *) @@ -347,11 +349,11 @@ let extend_atomic_tactic name entries = | TacNonTerm (_, (symb, _)) -> let EntryName (typ, e) = prod_item_of_symbol 0 symb in let Genarg.Rawwit wit = typ in - let inj x = TacArg (Loc.tag @@ TacGeneric (Genarg.in_gen typ x)) in + let inj x = TacArg (CAst.make @@ TacGeneric (Genarg.in_gen typ x)) in let default = epsilon_value inj e in match default with | None -> raise NonEmptyArgument - | Some def -> Tacintern.intern_tactic_or_tacarg Tacintern.fully_empty_glob_sign def + | Some def -> Tacintern.intern_tactic_or_tacarg (Genintern.empty_glob_sign Environ.empty_env) def in try Some (hd, List.map empty_value rem) with NonEmptyArgument -> None in @@ -361,12 +363,12 @@ let extend_atomic_tactic name entries = | Some (id, args) -> let args = List.map (fun a -> Tacexp a) args in let entry = { mltac_name = name; mltac_index = i } in - let body = TacML (Loc.tag (entry, args)) in + let body = TacML (CAst.make (entry, args)) in Tacenv.register_ltac false false (Names.Id.of_string id) body in List.iteri add_atomic entries -let add_ml_tactic_notation name ~level prods = +let add_ml_tactic_notation name ~level ?deprecation prods = let len = List.length prods in let iter i prods = let open Tacexpr in @@ -376,9 +378,9 @@ let add_ml_tactic_notation name ~level prods = in let ids = List.map_filter get_id prods in let entry = { mltac_name = name; mltac_index = len - i - 1 } in - let map id = Reference (Misctypes.ArgVar (CAst.make id)) in - let tac = TacML (Loc.tag (entry, List.map map ids)) in - add_glob_tactic_notation false ~level prods true ids tac + let map id = Reference (Locus.ArgVar (CAst.make id)) in + let tac = TacML (CAst.make (entry, List.map map ids)) in + add_glob_tactic_notation false ~level ?deprecation prods true ids tac in List.iteri iter (List.rev prods); (** We call [extend_atomic_tactic] only for "basic tactics" (the ones at @@ -398,7 +400,7 @@ let create_ltac_quotation name cast (e, l) = let () = ltac_quotations := String.Set.add name !ltac_quotations in let entry = match l with | None -> Aentry e - | Some l -> Aentryl (e, l) + | Some l -> Aentryl (e, string_of_int l) in (* let level = Some "1" in *) let level = None in @@ -430,7 +432,7 @@ let warn_unusable_identifier = (fun id -> strbrk "The Ltac name" ++ spc () ++ Id.print id ++ spc () ++ strbrk "may be unusable because of a conflict with a notation.") -let register_ltac local tacl = +let register_ltac local ?deprecation tacl = let map tactic_body = match tactic_body with | Tacexpr.TacticDefinition ({CAst.loc;v=id}, body) -> @@ -449,12 +451,12 @@ let register_ltac local tacl = in let () = if is_shadowed then warn_unusable_identifier id in NewTac id, body - | Tacexpr.TacticRedefinition (ident, body) -> + | Tacexpr.TacticRedefinition (qid, body) -> let kn = - try Tacenv.locate_tactic (qualid_of_reference ident).CAst.v + try Tacenv.locate_tactic qid with Not_found -> - CErrors.user_err ?loc:ident.CAst.loc - (str "There is no Ltac named " ++ pr_reference ident ++ str ".") + CErrors.user_err ?loc:qid.CAst.loc + (str "There is no Ltac named " ++ pr_qualid qid ++ str ".") in UpdateTac kn, body in @@ -483,10 +485,10 @@ let register_ltac local tacl = let defs = States.with_state_protection defs () in let iter (def, tac) = match def with | NewTac id -> - Tacenv.register_ltac false local id tac; + Tacenv.register_ltac false local id tac ?deprecation; Flags.if_verbose Feedback.msg_info (Id.print id ++ str " is defined") | UpdateTac kn -> - Tacenv.redefine_ltac local kn tac; + Tacenv.redefine_ltac local kn tac ?deprecation; let name = Tacenv.shortest_qualid_of_tactic kn in Flags.if_verbose Feedback.msg_info (Libnames.pr_qualid name ++ str " is redefined") in @@ -554,13 +556,14 @@ let () = ] in register_grammars_by_name "tactic" entries +let get_identifier i = + (** Workaround for badly-designed generic arguments lacking a closure *) + Names.Id.of_string_soft (Printf.sprintf "$%i" i) + type _ ty_sig = | TyNil : (Geninterp.interp_sign -> unit Proofview.tactic) ty_sig | TyIdent : string * 'r ty_sig -> 'r ty_sig -| TyArg : - (('a, 'b, 'c) Extend.ty_user_symbol * Id.t) Loc.located * 'r ty_sig -> ('c -> 'r) ty_sig -| TyAnonArg : - ('a, 'b, 'c) Extend.ty_user_symbol Loc.located * 'r ty_sig -> 'r ty_sig +| TyArg : ('a, 'b, 'c) Extend.ty_user_symbol * 'r ty_sig -> ('c -> 'r) ty_sig type ty_ml = TyML : 'r ty_sig * 'r -> ty_ml @@ -574,26 +577,16 @@ let rec untype_user_symbol : type a b c. (a,b,c) ty_user_symbol -> Genarg.ArgT.a | TUentry a -> Uentry (Genarg.ArgT.Any a) | TUentryl (a,i) -> Uentryl (Genarg.ArgT.Any a,i) -let rec clause_of_sign : type a. a ty_sig -> Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list = - fun sign -> match sign with +let rec clause_of_sign : type a. int -> a ty_sig -> Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list = + fun i sign -> match sign with | TyNil -> [] - | TyIdent (s, sig') -> TacTerm s :: clause_of_sign sig' - | TyArg ((loc,(a,id)),sig') -> - TacNonTerm (loc,(untype_user_symbol a,Some id)) :: clause_of_sign sig' - | TyAnonArg ((loc,a),sig') -> - TacNonTerm (loc,(untype_user_symbol a,None)) :: clause_of_sign sig' + | TyIdent (s, sig') -> TacTerm s :: clause_of_sign i sig' + | TyArg (a, sig') -> + let id = Some (get_identifier i) in + TacNonTerm (None, (untype_user_symbol a, id)) :: clause_of_sign (i + 1) sig' let clause_of_ty_ml = function - | TyML (t,_) -> clause_of_sign t - -let rec prj : type a b c. (a,b,c) Extend.ty_user_symbol -> (a,b,c) genarg_type = function - | TUentry a -> ExtraArg a - | TUentryl (a,l) -> ExtraArg a - | TUopt(o) -> OptArg (prj o) - | TUlist1 l -> ListArg (prj l) - | TUlist1sep (l,_) -> ListArg (prj l) - | TUlist0 l -> ListArg (prj l) - | TUlist0sep (l,_) -> ListArg (prj l) + | TyML (t,_) -> clause_of_sign 1 t let rec eval_sign : type a. a ty_sig -> a -> Geninterp.Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic = fun sign tac -> @@ -604,15 +597,14 @@ let rec eval_sign : type a. a ty_sig -> a -> Geninterp.Val.t list -> Geninterp.i | _ :: _ -> assert false end | TyIdent (s, sig') -> eval_sign sig' tac - | TyArg ((_loc,(a,id)), sig') -> + | TyArg (a, sig') -> let f = eval_sign sig' in begin fun tac vals ist -> match vals with | [] -> assert false | v :: vals -> - let v' = Taccoerce.Value.cast (topwit (prj a)) v in + let v' = Taccoerce.Value.cast (topwit (Egramml.proj_symbol a)) v in f (tac v') vals ist end tac - | TyAnonArg ((_loc,a), sig') -> eval_sign sig' tac let eval : ty_ml -> Geninterp.Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic = function | TyML (t,tac) -> eval_sign t tac @@ -624,14 +616,12 @@ let is_constr_entry = function let rec only_constr : type a. a ty_sig -> bool = function | TyNil -> true | TyIdent(_,_) -> false -| TyArg((_,(u,_)),s) -> if is_constr_entry u then only_constr s else false -| TyAnonArg((_,u),s) -> if is_constr_entry u then only_constr s else false +| TyArg (u, s) -> if is_constr_entry u then only_constr s else false -let rec mk_sign_vars : type a. a ty_sig -> Name.t list = function +let rec mk_sign_vars : type a. int -> a ty_sig -> Name.t list = fun i tu -> match tu with | TyNil -> [] -| TyIdent (_,s) -> mk_sign_vars s -| TyArg((_,(_,name)),s) -> Name name :: mk_sign_vars s -| TyAnonArg((_,_),s) -> Anonymous :: mk_sign_vars s +| TyIdent (_,s) -> mk_sign_vars i s +| TyArg (_, s) -> Name (get_identifier i) :: mk_sign_vars (i + 1) s let dummy_id = Id.of_string "_" @@ -652,7 +642,7 @@ let lift_constr_tac_to_ml_tac vars tac = end in tac -let tactic_extend plugin_name tacname ~level sign = +let tactic_extend plugin_name tacname ~level ?deprecation sign = let open Tacexpr in let ml_tactic_name = { mltac_tactic = tacname; @@ -662,12 +652,7 @@ let tactic_extend plugin_name tacname ~level sign = | [TyML (TyIdent (name, s),tac) as ml_tac] when only_constr s -> (** The extension is only made of a name followed by constr entries: we do not add any grammar nor printing rule and add it as a true Ltac definition. *) - (* - let patt = make_patt rem in - let vars = List.map make_var rem in - let vars = mlexpr_of_list (mlexpr_of_name mlexpr_of_ident) vars in - *) - let vars = mk_sign_vars s in + let vars = mk_sign_vars 1 s in let ml = { Tacexpr.mltac_name = ml_tactic_name; Tacexpr.mltac_index = 0 } in let tac = match s with | TyNil -> eval ml_tac @@ -679,12 +664,105 @@ let tactic_extend plugin_name tacname ~level sign = (** Arguments are not passed directly to the ML tactic in the TacML node, the ML tactic retrieves its arguments in the [ist] environment instead. This is the rôle of the [lift_constr_tac_to_ml_tac] function. *) - let body = Tacexpr.TacFun (vars, Tacexpr.TacML (Loc.tag (ml, [])))in + let body = Tacexpr.TacFun (vars, Tacexpr.TacML (CAst.make (ml, [])))in let id = Names.Id.of_string name in - let obj () = Tacenv.register_ltac true false id body in + let obj () = Tacenv.register_ltac true false id body ?deprecation in let () = Tacenv.register_ml_tactic ml_tactic_name [|tac|] in Mltop.declare_cache_obj obj plugin_name | _ -> - let obj () = add_ml_tactic_notation ml_tactic_name ~level (List.map clause_of_ty_ml sign) in + let obj () = add_ml_tactic_notation ml_tactic_name ~level ?deprecation (List.map clause_of_ty_ml sign) in Tacenv.register_ml_tactic ml_tactic_name @@ Array.of_list (List.map eval sign); Mltop.declare_cache_obj obj plugin_name + + +(** ARGUMENT EXTEND *) + +open Geninterp + +type ('a, 'b, 'c) argument_printer = + 'a Pptactic.raw_extra_genarg_printer * + 'b Pptactic.glob_extra_genarg_printer * + 'c Pptactic.extra_genarg_printer + +type ('a, 'b) argument_intern = +| ArgInternFun : ('a, 'b) Genintern.intern_fun -> ('a, 'b) argument_intern +| ArgInternWit : ('a, 'b, 'c) Genarg.genarg_type -> ('a, 'b) argument_intern + +type 'b argument_subst = +| ArgSubstFun : 'b Genintern.subst_fun -> 'b argument_subst +| ArgSubstWit : ('a, 'b, 'c) Genarg.genarg_type -> 'b argument_subst + +type ('b, 'c) argument_interp = +| ArgInterpRet : ('c, 'c) argument_interp +| ArgInterpFun : ('b, Val.t) interp_fun -> ('b, 'c) argument_interp +| ArgInterpWit : ('a, 'b, 'r) Genarg.genarg_type -> ('b, 'c) argument_interp +| ArgInterpLegacy : + (Geninterp.interp_sign -> Goal.goal Evd.sigma -> 'b -> Evd.evar_map * 'c) -> ('b, 'c) argument_interp + +type ('a, 'b, 'c) tactic_argument = { + arg_parsing : 'a Vernacextend.argument_rule; + arg_tag : 'c Val.tag option; + arg_intern : ('a, 'b) argument_intern; + arg_subst : 'b argument_subst; + arg_interp : ('b, 'c) argument_interp; + arg_printer : ('a, 'b, 'c) argument_printer; +} + +let intern_fun (type a b c) name (arg : (a, b, c) tactic_argument) : (a, b) Genintern.intern_fun = +match arg.arg_intern with +| ArgInternFun f -> f +| ArgInternWit wit -> + fun ist v -> + let ans = Genarg.out_gen (glbwit wit) (Tacintern.intern_genarg ist (Genarg.in_gen (rawwit wit) v)) in + (ist, ans) + +let subst_fun (type a b c) (arg : (a, b, c) tactic_argument) : b Genintern.subst_fun = +match arg.arg_subst with +| ArgSubstFun f -> f +| ArgSubstWit wit -> + fun s v -> + let ans = Genarg.out_gen (glbwit wit) (Tacsubst.subst_genarg s (Genarg.in_gen (glbwit wit) v)) in + ans + +let interp_fun (type a b c) name (arg : (a, b, c) tactic_argument) (tag : c Val.tag) : (b, Val.t) interp_fun = +match arg.arg_interp with +| ArgInterpRet -> (fun ist v -> Ftactic.return (Geninterp.Val.inject tag v)) +| ArgInterpFun f -> f +| ArgInterpWit wit -> + (fun ist x -> Tacinterp.interp_genarg ist (Genarg.in_gen (glbwit wit) x)) +| ArgInterpLegacy f -> + (fun ist v -> Ftactic.enter (fun gl -> + let (sigma, v) = Tacmach.New.of_old (fun gl -> f ist gl v) gl in + let v = Geninterp.Val.inject tag v in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Ftactic.return v) + )) + +let argument_extend (type a b c) ~name (arg : (a, b, c) tactic_argument) = + let wit = Genarg.create_arg name in + let () = Genintern.register_intern0 wit (intern_fun name arg) in + let () = Genintern.register_subst0 wit (subst_fun arg) in + let tag = match arg.arg_tag with + | None -> + let () = register_val0 wit None in + val_tag (topwit wit) + | Some tag -> + let () = register_val0 wit (Some tag) in + tag + in + let () = register_interp0 wit (interp_fun name arg tag) in + let entry = match arg.arg_parsing with + | Vernacextend.Arg_alias e -> + let () = Pcoq.register_grammar wit e in + e + | Vernacextend.Arg_rules rules -> + let e = Pcoq.create_generic_entry Pcoq.utactic name (Genarg.rawwit wit) in + let () = Pcoq.grammar_extend e None (None, [(None, None, rules)]) in + e + in + let (rpr, gpr, tpr) = arg.arg_printer in + let () = Pptactic.declare_extra_genarg_pprule wit rpr gpr tpr in + let () = create_ltac_quotation name + (fun (loc, v) -> Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit) v)) + (entry, None) + in + (wit, entry) diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli index 3f804ee8d1..309db539d0 100644 --- a/plugins/ltac/tacentries.mli +++ b/plugins/ltac/tacentries.mli @@ -12,10 +12,12 @@ open Vernacexpr open Tacexpr +open Attributes (** {5 Tactic Definitions} *) -val register_ltac : locality_flag -> Tacexpr.tacdef_body list -> unit +val register_ltac : locality_flag -> ?deprecation:deprecation -> + Tacexpr.tacdef_body list -> unit (** Adds new Ltac definitions to the environment. *) (** {5 Tactic Notations} *) @@ -34,8 +36,8 @@ type argument = Genarg.ArgT.any Extend.user_symbol leaves. *) val add_tactic_notation : - locality_flag -> int -> raw_argument grammar_tactic_prod_item_expr list -> - raw_tactic_expr -> unit + locality_flag -> int -> ?deprecation:deprecation -> raw_argument + grammar_tactic_prod_item_expr list -> raw_tactic_expr -> unit (** [add_tactic_notation local level prods expr] adds a tactic notation in the environment at level [level] with locality [local] made of the grammar productions [prods] and returning the body [expr] *) @@ -47,7 +49,7 @@ val register_tactic_notation_entry : string -> ('a, 'b, 'c) Genarg.genarg_type - to finding an argument by name (as in {!Genarg}) if there is none matching. *) -val add_ml_tactic_notation : ml_tactic_name -> level:int -> +val add_ml_tactic_notation : ml_tactic_name -> level:int -> ?deprecation:deprecation -> argument grammar_tactic_prod_item_expr list list -> unit (** A low-level variant of {!add_tactic_notation} used by the TACTIC EXTEND ML-side macro. *) @@ -55,7 +57,7 @@ val add_ml_tactic_notation : ml_tactic_name -> level:int -> (** {5 Tactic Quotations} *) val create_ltac_quotation : string -> - ('grm Loc.located -> raw_tactic_arg) -> ('grm Pcoq.Gram.entry * int option) -> unit + ('grm Loc.located -> raw_tactic_arg) -> ('grm Pcoq.Entry.t * int option) -> unit (** [create_ltac_quotation name f e] adds a quotation rule to Ltac, that is, Ltac grammar now accepts arguments of the form ["name" ":" "(" <e> ")"], and generates an argument using [f] on the entry parsed by [e]. *) @@ -65,17 +67,74 @@ val create_ltac_quotation : string -> val print_ltacs : unit -> unit (** Display the list of ltac definitions currently available. *) -val print_located_tactic : Libnames.reference -> unit +val print_located_tactic : Libnames.qualid -> unit (** Display the absolute name of a tactic. *) +(** {5 TACTIC EXTEND} *) + type _ ty_sig = | TyNil : (Geninterp.interp_sign -> unit Proofview.tactic) ty_sig | TyIdent : string * 'r ty_sig -> 'r ty_sig -| TyArg : - (('a, 'b, 'c) Extend.ty_user_symbol * Names.Id.t) Loc.located * 'r ty_sig -> ('c -> 'r) ty_sig -| TyAnonArg : - ('a, 'b, 'c) Extend.ty_user_symbol Loc.located * 'r ty_sig -> 'r ty_sig +| TyArg : ('a, 'b, 'c) Extend.ty_user_symbol * 'r ty_sig -> ('c -> 'r) ty_sig type ty_ml = TyML : 'r ty_sig * 'r -> ty_ml -val tactic_extend : string -> string -> level:Int.t -> ty_ml list -> unit +val tactic_extend : string -> string -> level:Int.t -> + ?deprecation:deprecation -> ty_ml list -> unit + +(** {5 ARGUMENT EXTEND} *) + +(** + + This is the main entry point for the ARGUMENT EXTEND macro that allows to + easily create user-made Ltac arguments. + + + Each argument has three type parameters. See {!Genarg} for more details. + There are two kinds of Ltac arguments, uniform and non-uniform. The former + have the same type at each level (raw, glob, top) while the latter may vary. + + When declaring an argument one must provide the following data: + - Internalization : raw -> glob + - Substitution : glob -> glob + - Interpretation : glob -> Ltac dynamic value + - Printing for every level + - An optional toplevel tag of type top (with the proviso that the + interpretation function only produces values with this tag) + + This data can be either given explicitly with the [Fun] constructors, or it + can be inherited from another argument with the [Wit] constructors. + +*) + +type ('a, 'b, 'c) argument_printer = + 'a Pptactic.raw_extra_genarg_printer * + 'b Pptactic.glob_extra_genarg_printer * + 'c Pptactic.extra_genarg_printer + +type ('a, 'b) argument_intern = +| ArgInternFun : ('a, 'b) Genintern.intern_fun -> ('a, 'b) argument_intern +| ArgInternWit : ('a, 'b, 'c) Genarg.genarg_type -> ('a, 'b) argument_intern + +type 'b argument_subst = +| ArgSubstFun : 'b Genintern.subst_fun -> 'b argument_subst +| ArgSubstWit : ('a, 'b, 'c) Genarg.genarg_type -> 'b argument_subst + +type ('b, 'c) argument_interp = +| ArgInterpRet : ('c, 'c) argument_interp +| ArgInterpFun : ('b, Geninterp.Val.t) Geninterp.interp_fun -> ('b, 'c) argument_interp +| ArgInterpWit : ('a, 'b, 'r) Genarg.genarg_type -> ('b, 'c) argument_interp +| ArgInterpLegacy : + (Geninterp.interp_sign -> Goal.goal Evd.sigma -> 'b -> Evd.evar_map * 'c) -> ('b, 'c) argument_interp + +type ('a, 'b, 'c) tactic_argument = { + arg_parsing : 'a Vernacextend.argument_rule; + arg_tag : 'c Geninterp.Val.tag option; + arg_intern : ('a, 'b) argument_intern; + arg_subst : 'b argument_subst; + arg_interp : ('b, 'c) argument_interp; + arg_printer : ('a, 'b, 'c) argument_printer; +} + +val argument_extend : name:string -> ('a, 'b, 'c) tactic_argument -> + ('a, 'b, 'c) Genarg.genarg_type * 'a Pcoq.Entry.t diff --git a/plugins/ltac/tacenv.ml b/plugins/ltac/tacenv.ml index d5ab2d690d..d5f22b2c72 100644 --- a/plugins/ltac/tacenv.ml +++ b/plugins/ltac/tacenv.ml @@ -52,7 +52,11 @@ let shortest_qualid_of_tactic kn = (** Tactic notations (TacAlias) *) type alias = KerName.t -type alias_tactic = Id.t list * glob_tactic_expr +type alias_tactic = + { alias_args: Id.t list; + alias_body: glob_tactic_expr; + alias_deprecation: Attributes.deprecation option; + } let alias_map = Summary.ref ~name:"tactic-alias" (KNmap.empty : alias_tactic KNmap.t) @@ -111,13 +115,13 @@ let interp_ml_tactic { mltac_name = s; mltac_index = i } = (* Summary and Object declaration *) -open Nametab open Libobject type ltac_entry = { tac_for_ml : bool; tac_body : glob_tactic_expr; tac_redef : ModPath.t list; + tac_deprecation : Attributes.deprecation option } let mactab = @@ -130,43 +134,51 @@ let interp_ltac r = (KNmap.find r !mactab).tac_body let is_ltac_for_ml_tactic r = (KNmap.find r !mactab).tac_for_ml -let add kn b t = - let entry = { tac_for_ml = b; tac_body = t; tac_redef = [] } in +let add ~deprecation kn b t = + let entry = { tac_for_ml = b; + tac_body = t; + tac_redef = []; + tac_deprecation = deprecation; + } in mactab := KNmap.add kn entry !mactab let replace kn path t = - let (path, _, _) = KerName.repr path in + let path = KerName.modpath path in let entry _ e = { e with tac_body = t; tac_redef = path :: e.tac_redef } in mactab := KNmap.modify kn entry !mactab -let load_md i ((sp, kn), (local, id, b, t)) = match id with +let tac_deprecation kn = + try (KNmap.find kn !mactab).tac_deprecation with Not_found -> None + +let load_md i ((sp, kn), (local, id, b, t, deprecation)) = match id with | None -> - let () = if not local then push_tactic (Until i) sp kn in - add kn b t + let () = if not local then push_tactic (Nametab.Until i) sp kn in + add ~deprecation kn b t | Some kn0 -> replace kn0 kn t -let open_md i ((sp, kn), (local, id, b, t)) = match id with +let open_md i ((sp, kn), (local, id, b, t, deprecation)) = match id with | None -> - let () = if not local then push_tactic (Exactly i) sp kn in - add kn b t + let () = if not local then push_tactic (Nametab.Exactly i) sp kn in + add ~deprecation kn b t | Some kn0 -> replace kn0 kn t -let cache_md ((sp, kn), (local, id ,b, t)) = match id with +let cache_md ((sp, kn), (local, id ,b, t, deprecation)) = match id with | None -> - let () = push_tactic (Until 1) sp kn in - add kn b t + let () = push_tactic (Nametab.Until 1) sp kn in + add ~deprecation kn b t | Some kn0 -> replace kn0 kn t let subst_kind subst id = match id with | None -> None | Some kn -> Some (Mod_subst.subst_kn subst kn) -let subst_md (subst, (local, id, b, t)) = - (local, subst_kind subst id, b, Tacsubst.subst_tactic subst t) +let subst_md (subst, (local, id, b, t, deprecation)) = + (local, subst_kind subst id, b, Tacsubst.subst_tactic subst t, deprecation) -let classify_md (local, _, _, _ as o) = Substitute o +let classify_md (local, _, _, _, _ as o) = Substitute o -let inMD : bool * ltac_constant option * bool * glob_tactic_expr -> obj = +let inMD : bool * ltac_constant option * bool * glob_tactic_expr * + Attributes.deprecation option -> obj = declare_object {(default_object "TAC-DEFINITION") with cache_function = cache_md; load_function = load_md; @@ -174,8 +186,8 @@ let inMD : bool * ltac_constant option * bool * glob_tactic_expr -> obj = subst_function = subst_md; classify_function = classify_md} -let register_ltac for_ml local id tac = - ignore (Lib.add_leaf id (inMD (local, None, for_ml, tac))) +let register_ltac for_ml local ?deprecation id tac = + ignore (Lib.add_leaf id (inMD (local, None, for_ml, tac, deprecation))) -let redefine_ltac local kn tac = - Lib.add_anonymous_leaf (inMD (local, Some kn, false, tac)) +let redefine_ltac local ?deprecation kn tac = + Lib.add_anonymous_leaf (inMD (local, Some kn, false, tac, deprecation)) diff --git a/plugins/ltac/tacenv.mli b/plugins/ltac/tacenv.mli index 3af2f2a460..5b98daf383 100644 --- a/plugins/ltac/tacenv.mli +++ b/plugins/ltac/tacenv.mli @@ -12,6 +12,7 @@ open Names open Libnames open Tacexpr open Geninterp +open Attributes (** This module centralizes the various ways of registering tactics. *) @@ -29,21 +30,26 @@ val shortest_qualid_of_tactic : ltac_constant -> qualid type alias = KerName.t (** Type of tactic alias, used in the [TacAlias] node. *) -type alias_tactic = Id.t list * glob_tactic_expr +type alias_tactic = + { alias_args: Id.t list; + alias_body: glob_tactic_expr; + alias_deprecation: deprecation option; + } (** Contents of a tactic notation *) val register_alias : alias -> alias_tactic -> unit (** Register a tactic alias. *) val interp_alias : alias -> alias_tactic -(** Recover the the body of an alias. Raises an anomaly if it does not exist. *) +(** Recover the body of an alias. Raises an anomaly if it does not exist. *) val check_alias : alias -> bool (** Returns [true] if an alias is defined, false otherwise. *) (** {5 Coq tactic definitions} *) -val register_ltac : bool -> bool -> Id.t -> glob_tactic_expr -> unit +val register_ltac : bool -> bool -> ?deprecation:deprecation -> Id.t -> + glob_tactic_expr -> unit (** Register a new Ltac with the given name and body. The first boolean indicates whether this is done from ML side, rather than @@ -51,7 +57,8 @@ val register_ltac : bool -> bool -> Id.t -> glob_tactic_expr -> unit definition. It also puts the Ltac name in the nametab, so that it can be used unqualified. *) -val redefine_ltac : bool -> KerName.t -> glob_tactic_expr -> unit +val redefine_ltac : bool -> ?deprecation:deprecation -> KerName.t -> + glob_tactic_expr -> unit (** Replace a Ltac with the given name and body. If the boolean flag is set to true, then this is a local redefinition. *) @@ -61,6 +68,9 @@ val interp_ltac : KerName.t -> glob_tactic_expr val is_ltac_for_ml_tactic : KerName.t -> bool (** Whether the tactic is defined from ML-side *) +val tac_deprecation : KerName.t -> deprecation option +(** The tactic deprecation notice, if any *) + type ltac_entry = { tac_for_ml : bool; (** Whether the tactic is defined from ML-side *) @@ -68,6 +78,8 @@ type ltac_entry = { (** The current body of the tactic *) tac_redef : ModPath.t list; (** List of modules redefining the tactic in reverse chronological order *) + tac_deprecation : deprecation option; + (** Deprecation notice to be printed when the tactic is used *) } val ltac_entries : unit -> ltac_entry KNmap.t diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 8b0c44041f..9435d0b911 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -15,7 +15,7 @@ open Libnames open Genredexpr open Genarg open Pattern -open Misctypes +open Tactypes open Locus type ltac_constant = KerName.t @@ -35,30 +35,11 @@ type advanced_flag = bool (* true = advanced false = basic *) type letin_flag = bool (* true = use local def false = use Leibniz *) type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) -type goal_selector = Vernacexpr.goal_selector = - | SelectNth of int - | SelectList of (int * int) list - | SelectId of Id.t - | SelectAll - -type 'a core_destruction_arg = 'a Misctypes.core_destruction_arg = - | ElimOnConstr of 'a - | ElimOnIdent of lident - | ElimOnAnonHyp of int - -type 'a destruction_arg = - clear_flag * 'a core_destruction_arg - -type inversion_kind = Misctypes.inversion_kind = - | SimpleInversion - | FullInversion - | FullInversionClear - type ('c,'d,'id) inversion_strength = | NonDepInversion of - inversion_kind * 'id list * 'd or_and_intro_pattern_expr CAst.t or_var option + Inv.inversion_kind * 'id list * 'd or_and_intro_pattern_expr CAst.t or_var option | DepInversion of - inversion_kind * 'c option * 'd or_and_intro_pattern_expr CAst.t or_var option + Inv.inversion_kind * 'c option * 'd or_and_intro_pattern_expr CAst.t or_var option | InversionUsing of 'c * 'id list type ('a,'b) location = HypLocation of 'a | ConclLocation of 'b @@ -69,8 +50,8 @@ type 'id message_token = | MsgIdent of 'id type ('dconstr,'id) induction_clause = - 'dconstr with_bindings destruction_arg * - (intro_pattern_naming_expr CAst.t option (* eqn:... *) + 'dconstr with_bindings Tactics.destruction_arg * + (Namegen.intro_pattern_naming_expr CAst.t option (* eqn:... *) * 'dconstr or_and_intro_pattern_expr CAst.t or_var option) (* as ... *) * 'id clause_expr option (* in ... *) @@ -112,7 +93,7 @@ type ml_tactic_entry = { (** Composite types *) -type glob_constr_and_expr = Tactypes.glob_constr_and_expr +type glob_constr_and_expr = Genintern.glob_constr_and_expr type open_constr_expr = unit * constr_expr type open_glob_constr = unit * glob_constr_and_expr @@ -129,7 +110,7 @@ type delayed_open_constr = EConstr.constr delayed_open type intro_pattern = delayed_open_constr intro_pattern_expr CAst.t type intro_patterns = delayed_open_constr intro_pattern_expr CAst.t list type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr CAst.t -type intro_pattern_naming = intro_pattern_naming_expr CAst.t +type intro_pattern_naming = Namegen.intro_pattern_naming_expr CAst.t (** Generic expressions for atomic tactics *) @@ -147,7 +128,7 @@ type 'a gen_atomic_tactic_expr = 'dtrm intro_pattern_expr CAst.t option * 'trm | TacGeneralize of ('trm with_occurrences * Name.t) list | TacLetTac of evars_flag * Name.t * 'trm * 'nam clause_expr * letin_flag * - intro_pattern_naming_expr CAst.t option + Namegen.intro_pattern_naming_expr CAst.t option (* Derived basic tactics *) | TacInductionDestruct of @@ -159,7 +140,7 @@ type 'a gen_atomic_tactic_expr = (* Equality and inversion *) | TacRewrite of evars_flag * - (bool * multi * 'dtrm with_bindings_arg) list * 'nam clause_expr * + (bool * Equality.multi * 'dtrm with_bindings_arg) list * 'nam clause_expr * (* spiwack: using ['dtrm] here is a small hack, may not be stable by a change in the representation of delayed terms. Because, in fact, it is the whole "with_bindings" @@ -186,7 +167,7 @@ type 'a gen_tactic_arg = | TacGeneric of 'lev generic_argument | ConstrMayEval of ('trm,'cst,'pat) may_eval | Reference of 'ref - | TacCall of ('ref * 'a gen_tactic_arg list) Loc.located + | TacCall of ('ref * 'a gen_tactic_arg list) CAst.t | TacFreshId of string or_var list | Tacexp of 'tacexpr | TacPretype of 'trm @@ -208,7 +189,7 @@ constraint 'a = < 'r : ltac refs, 'n : idents, 'l : levels *) and 'a gen_tactic_expr = - | TacAtom of ('a gen_atomic_tactic_expr) Loc.located + | TacAtom of ('a gen_atomic_tactic_expr) CAst.t | TacThen of 'a gen_tactic_expr * 'a gen_tactic_expr @@ -264,12 +245,12 @@ and 'a gen_tactic_expr = | TacMatchGoal of lazy_flag * direction_flag * ('p,'a gen_tactic_expr) match_rule list | TacFun of 'a gen_tactic_fun_ast - | TacArg of 'a gen_tactic_arg located - | TacSelect of goal_selector * 'a gen_tactic_expr + | TacArg of 'a gen_tactic_arg CAst.t + | TacSelect of Goal_select.t * 'a gen_tactic_expr (* For ML extensions *) - | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) Loc.located + | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) CAst.t (* For syntax extensions *) - | TacAlias of (KerName.t * 'a gen_tactic_arg list) Loc.located + | TacAlias of (KerName.t * 'a gen_tactic_arg list) CAst.t constraint 'a = < term:'t; @@ -300,7 +281,7 @@ constraint 'a = < type g_trm = glob_constr_and_expr type g_pat = glob_constr_pattern_and_expr -type g_cst = evaluable_global_reference and_short_name or_var +type g_cst = evaluable_global_reference Stdarg.and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = lident @@ -328,8 +309,8 @@ type glob_tactic_arg = type r_trm = constr_expr type r_pat = constr_pattern_expr -type r_cst = reference or_by_notation -type r_ref = reference +type r_cst = qualid or_by_notation +type r_ref = qualid type r_nam = lident type r_lev = rlevel @@ -393,5 +374,5 @@ type ltac_call_kind = type ltac_trace = ltac_call_kind Loc.located list type tacdef_body = - | TacticDefinition of lident * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) - | TacticRedefinition of reference * raw_tactic_expr (* indicates that user employed '::=' in Ltac body *) + | TacticDefinition of lident * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) + | TacticRedefinition of qualid * raw_tactic_expr (* indicates that user employed '::=' in Ltac body *) diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 8b0c44041f..1527724420 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -15,8 +15,8 @@ open Libnames open Genredexpr open Genarg open Pattern -open Misctypes open Locus +open Tactypes type ltac_constant = KerName.t @@ -35,30 +35,11 @@ type advanced_flag = bool (* true = advanced false = basic *) type letin_flag = bool (* true = use local def false = use Leibniz *) type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) -type goal_selector = Vernacexpr.goal_selector = - | SelectNth of int - | SelectList of (int * int) list - | SelectId of Id.t - | SelectAll - -type 'a core_destruction_arg = 'a Misctypes.core_destruction_arg = - | ElimOnConstr of 'a - | ElimOnIdent of lident - | ElimOnAnonHyp of int - -type 'a destruction_arg = - clear_flag * 'a core_destruction_arg - -type inversion_kind = Misctypes.inversion_kind = - | SimpleInversion - | FullInversion - | FullInversionClear - type ('c,'d,'id) inversion_strength = | NonDepInversion of - inversion_kind * 'id list * 'd or_and_intro_pattern_expr CAst.t or_var option + Inv.inversion_kind * 'id list * 'd or_and_intro_pattern_expr CAst.t or_var option | DepInversion of - inversion_kind * 'c option * 'd or_and_intro_pattern_expr CAst.t or_var option + Inv.inversion_kind * 'c option * 'd or_and_intro_pattern_expr CAst.t or_var option | InversionUsing of 'c * 'id list type ('a,'b) location = HypLocation of 'a | ConclLocation of 'b @@ -69,8 +50,8 @@ type 'id message_token = | MsgIdent of 'id type ('dconstr,'id) induction_clause = - 'dconstr with_bindings destruction_arg * - (intro_pattern_naming_expr CAst.t option (* eqn:... *) + 'dconstr with_bindings Tactics.destruction_arg * + (Namegen.intro_pattern_naming_expr CAst.t option (* eqn:... *) * 'dconstr or_and_intro_pattern_expr CAst.t or_var option) (* as ... *) * 'id clause_expr option (* in ... *) @@ -112,7 +93,7 @@ type ml_tactic_entry = { (** Composite types *) -type glob_constr_and_expr = Tactypes.glob_constr_and_expr +type glob_constr_and_expr = Genintern.glob_constr_and_expr type open_constr_expr = unit * constr_expr type open_glob_constr = unit * glob_constr_and_expr @@ -129,7 +110,7 @@ type delayed_open_constr = EConstr.constr delayed_open type intro_pattern = delayed_open_constr intro_pattern_expr CAst.t type intro_patterns = delayed_open_constr intro_pattern_expr CAst.t list type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr CAst.t -type intro_pattern_naming = intro_pattern_naming_expr CAst.t +type intro_pattern_naming = Namegen.intro_pattern_naming_expr CAst.t (** Generic expressions for atomic tactics *) @@ -147,7 +128,7 @@ type 'a gen_atomic_tactic_expr = 'dtrm intro_pattern_expr CAst.t option * 'trm | TacGeneralize of ('trm with_occurrences * Name.t) list | TacLetTac of evars_flag * Name.t * 'trm * 'nam clause_expr * letin_flag * - intro_pattern_naming_expr CAst.t option + Namegen.intro_pattern_naming_expr CAst.t option (* Derived basic tactics *) | TacInductionDestruct of @@ -159,7 +140,7 @@ type 'a gen_atomic_tactic_expr = (* Equality and inversion *) | TacRewrite of evars_flag * - (bool * multi * 'dtrm with_bindings_arg) list * 'nam clause_expr * + (bool * Equality.multi * 'dtrm with_bindings_arg) list * 'nam clause_expr * (* spiwack: using ['dtrm] here is a small hack, may not be stable by a change in the representation of delayed terms. Because, in fact, it is the whole "with_bindings" @@ -186,7 +167,7 @@ type 'a gen_tactic_arg = | TacGeneric of 'lev generic_argument | ConstrMayEval of ('trm,'cst,'pat) may_eval | Reference of 'ref - | TacCall of ('ref * 'a gen_tactic_arg list) Loc.located + | TacCall of ('ref * 'a gen_tactic_arg list) CAst.t | TacFreshId of string or_var list | Tacexp of 'tacexpr | TacPretype of 'trm @@ -208,7 +189,7 @@ constraint 'a = < 'r : ltac refs, 'n : idents, 'l : levels *) and 'a gen_tactic_expr = - | TacAtom of ('a gen_atomic_tactic_expr) Loc.located + | TacAtom of ('a gen_atomic_tactic_expr) CAst.t | TacThen of 'a gen_tactic_expr * 'a gen_tactic_expr @@ -264,12 +245,12 @@ and 'a gen_tactic_expr = | TacMatchGoal of lazy_flag * direction_flag * ('p,'a gen_tactic_expr) match_rule list | TacFun of 'a gen_tactic_fun_ast - | TacArg of 'a gen_tactic_arg located - | TacSelect of goal_selector * 'a gen_tactic_expr + | TacArg of 'a gen_tactic_arg CAst.t + | TacSelect of Goal_select.t * 'a gen_tactic_expr (* For ML extensions *) - | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) Loc.located + | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) CAst.t (* For syntax extensions *) - | TacAlias of (KerName.t * 'a gen_tactic_arg list) Loc.located + | TacAlias of (KerName.t * 'a gen_tactic_arg list) CAst.t constraint 'a = < term:'t; @@ -300,7 +281,7 @@ constraint 'a = < type g_trm = glob_constr_and_expr type g_pat = glob_constr_pattern_and_expr -type g_cst = evaluable_global_reference and_short_name or_var +type g_cst = evaluable_global_reference Stdarg.and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = lident @@ -328,8 +309,8 @@ type glob_tactic_arg = type r_trm = constr_expr type r_pat = constr_pattern_expr -type r_cst = reference or_by_notation -type r_ref = reference +type r_cst = qualid or_by_notation +type r_ref = qualid type r_nam = lident type r_lev = rlevel @@ -393,5 +374,5 @@ type ltac_call_kind = type ltac_trace = ltac_call_kind Loc.located list type tacdef_body = - | TacticDefinition of lident * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) - | TacticRedefinition of reference * raw_tactic_expr (* indicates that user employed '::=' in Ltac body *) + | TacticDefinition of lident * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) + | TacticRedefinition of qualid * raw_tactic_expr (* indicates that user employed '::=' in Ltac body *) diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 9ad9e1520e..85c6348b52 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -19,7 +19,6 @@ open Util open Names open Libnames open Globnames -open Nametab open Smartlocate open Constrexpr open Termops @@ -27,7 +26,9 @@ open Tacexpr open Genarg open Stdarg open Tacarg -open Misctypes +open Namegen +open Tactypes +open Tactics open Locus (** Globalization of tactic expressions : @@ -43,9 +44,9 @@ type glob_sign = Genintern.glob_sign = { (* ltac variables and the subset of vars introduced by Intro/Let/... *) genv : Environ.env; extra : Genintern.Store.t; + intern_sign : Genintern.intern_variable_status; } -let fully_empty_glob_sign = Genintern.empty_glob_sign Environ.empty_env let make_empty_glob_sign () = Genintern.empty_glob_sign (Global.env ()) (* We have identifier <| global_reference <| constr *) @@ -82,7 +83,8 @@ let intern_hyp ist ({loc;v=id} as locid) = else if find_ident id ist then make id else - Pretype_errors.error_var_not_found ?loc id + CErrors.user_err ?loc Pp.(str "Hypothesis" ++ spc () ++ Id.print id ++ spc() ++ + str "was not found in the current environment.") let intern_or_var f ist = function | ArgVar locid -> ArgVar (intern_hyp ist locid) @@ -91,88 +93,104 @@ let intern_or_var f ist = function let intern_int_or_var = intern_or_var (fun (n : int) -> n) let intern_string_or_var = intern_or_var (fun (s : string) -> s) -let intern_global_reference ist = function - | {CAst.loc;v=Ident id} when find_var id ist -> - ArgVar (make ?loc id) - | r -> - let {CAst.loc} as lqid = qualid_of_reference r in - try ArgArg (loc,locate_global_with_alias lqid) - with Not_found -> error_global_not_found lqid - -let intern_ltac_variable ist = function - | {loc;v=Ident id} -> - if find_var id ist then - (* A local variable of any type *) - ArgVar (make ?loc id) - else raise Not_found - | _ -> - raise Not_found - -let intern_constr_reference strict ist = function - | {v=Ident id} as r when not strict && find_hyp id ist -> - (DAst.make @@ GVar id), Some (make @@ CRef (r,None)) - | {v=Ident id} as r when find_var id ist -> - (DAst.make @@ GVar id), if strict then None else Some (make @@ CRef (r,None)) - | r -> - let {loc} as lqid = qualid_of_reference r in - DAst.make @@ GRef (locate_global_with_alias lqid,None), - if strict then None else Some (make @@ CRef (r,None)) +let intern_global_reference ist qid = + if qualid_is_ident qid && find_var (qualid_basename qid) ist then + ArgVar (make ?loc:qid.CAst.loc @@ qualid_basename qid) + else + try ArgArg (qid.CAst.loc,locate_global_with_alias qid) + with Not_found -> Nametab.error_global_not_found qid + +let intern_ltac_variable ist qid = + if qualid_is_ident qid && find_var (qualid_basename qid) ist then + (* A local variable of any type *) + ArgVar (make ?loc:qid.CAst.loc @@ qualid_basename qid) + else raise Not_found + +let intern_constr_reference strict ist qid = + let id = qualid_basename qid in + if qualid_is_ident qid && not strict && find_hyp (qualid_basename qid) ist then + (DAst.make @@ GVar id), Some (make @@ CRef (qid,None)) + else if qualid_is_ident qid && find_var (qualid_basename qid) ist then + (DAst.make @@ GVar id), if strict then None else Some (make @@ CRef (qid,None)) + else + DAst.make @@ GRef (locate_global_with_alias qid,None), + if strict then None else Some (make @@ CRef (qid,None)) (* Internalize an isolated reference in position of tactic *) -let intern_isolated_global_tactic_reference r = - let {loc;v=qid} = qualid_of_reference r in - TacCall (Loc.tag ?loc (ArgArg (loc,Tacenv.locate_tactic qid),[])) - -let intern_isolated_tactic_reference strict ist r = +let warn_deprecated_tactic = + CWarnings.create ~name:"deprecated-tactic" ~category:"deprecated" + (fun (qid,depr) -> str "Tactic " ++ pr_qualid qid ++ + strbrk " is deprecated" ++ + pr_opt (fun since -> str "since " ++ str since) depr.Attributes.since ++ + str "." ++ pr_opt (fun note -> str note) depr.Attributes.note) + +let warn_deprecated_alias = + CWarnings.create ~name:"deprecated-tactic-notation" ~category:"deprecated" + (fun (kn,depr) -> str "Tactic Notation " ++ Pptactic.pr_alias_key kn ++ + strbrk " is deprecated since" ++ + pr_opt (fun since -> str "since " ++ str since) depr.Attributes.since ++ + str "." ++ pr_opt (fun note -> str note) depr.Attributes.note) + +let intern_isolated_global_tactic_reference qid = + let loc = qid.CAst.loc in + let kn = Tacenv.locate_tactic qid in + Option.iter (fun depr -> warn_deprecated_tactic ?loc (qid,depr)) @@ + Tacenv.tac_deprecation kn; + TacCall (CAst.make ?loc (ArgArg (loc,kn),[])) + +let intern_isolated_tactic_reference strict ist qid = (* An ltac reference *) - try Reference (intern_ltac_variable ist r) + try Reference (intern_ltac_variable ist qid) with Not_found -> (* A global tactic *) - try intern_isolated_global_tactic_reference r + try intern_isolated_global_tactic_reference qid with Not_found -> (* Tolerance for compatibility, allow not to use "constr:" *) - try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) + try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist qid)) with Not_found -> (* Reference not found *) - error_global_not_found (qualid_of_reference r) + Nametab.error_global_not_found qid (* Internalize an applied tactic reference *) -let intern_applied_global_tactic_reference r = - let {loc;v=qid} = qualid_of_reference r in - ArgArg (loc,Tacenv.locate_tactic qid) +let intern_applied_global_tactic_reference qid = + let loc = qid.CAst.loc in + let kn = Tacenv.locate_tactic qid in + Option.iter (fun depr -> warn_deprecated_tactic ?loc (qid,depr)) @@ + Tacenv.tac_deprecation kn; + ArgArg (loc,kn) -let intern_applied_tactic_reference ist r = +let intern_applied_tactic_reference ist qid = (* An ltac reference *) - try intern_ltac_variable ist r + try intern_ltac_variable ist qid with Not_found -> (* A global tactic *) - try intern_applied_global_tactic_reference r + try intern_applied_global_tactic_reference qid with Not_found -> (* Reference not found *) - error_global_not_found (qualid_of_reference r) + Nametab.error_global_not_found qid (* Intern a reference parsed in a non-tactic entry *) -let intern_non_tactic_reference strict ist r = +let intern_non_tactic_reference strict ist qid = (* An ltac reference *) - try Reference (intern_ltac_variable ist r) + try Reference (intern_ltac_variable ist qid) with Not_found -> (* A constr reference *) - try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) + try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist qid)) with Not_found -> (* Tolerance for compatibility, allow not to use "ltac:" *) - try intern_isolated_global_tactic_reference r + try intern_isolated_global_tactic_reference qid with Not_found -> (* By convention, use IntroIdentifier for unbound ident, when not in a def *) - match r with - | {loc;v=Ident id} when not strict -> - let ipat = in_gen (glbwit wit_intro_pattern) (make ?loc @@ IntroNaming (IntroIdentifier id)) in + if qualid_is_ident qid && not strict then + let id = qualid_basename qid in + let ipat = in_gen (glbwit wit_intro_pattern) (make ?loc:qid.CAst.loc @@ IntroNaming (IntroIdentifier id)) in TacGeneric ipat - | _ -> - (* Reference not found *) - error_global_not_found (qualid_of_reference r) + else + (* Reference not found *) + Nametab.error_global_not_found qid let intern_message_token ist = function | (MsgString _ | MsgInt _ as x) -> x @@ -192,7 +210,7 @@ let intern_binding_name ist x = and if a term w/o ltac vars, check the name is indeed quantified *) x -let intern_constr_gen pattern_mode isarity {ltacvars=lfun; genv=env; extra} c = +let intern_constr_gen pattern_mode isarity {ltacvars=lfun; genv=env; extra; intern_sign} c = let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in let scope = if isarity then Pretyping.IsType else Pretyping.WithoutTypeConstraint in let ltacvars = { @@ -201,7 +219,7 @@ let intern_constr_gen pattern_mode isarity {ltacvars=lfun; genv=env; extra} c = ltac_extra = extra; } in let c' = - warn (Constrintern.intern_gen scope ~pattern_mode ~ltacvars env Evd.(from_env env)) c + warn (Constrintern.intern_core scope ~pattern_mode ~ltacvars env Evd.(from_env env) intern_sign) c in (c',if !strict_check then None else Some c) @@ -268,7 +286,7 @@ let intern_destruction_arg ist = function | clear,ElimOnIdent {loc;v=id} -> if !strict_check then (* If in a defined tactic, no intros-until *) - let c, p = intern_constr ist (make @@ CRef (make @@ Ident id, None)) in + let c, p = intern_constr ist (make @@ CRef (qualid_of_ident id, None)) in match DAst.get c with | GVar id -> clear,ElimOnIdent (make ?loc:c.loc id) | _ -> clear,ElimOnConstr ((c, p), NoBindings) @@ -276,16 +294,15 @@ let intern_destruction_arg ist = function clear,ElimOnIdent (make ?loc id) let short_name = function - | {v=AN {loc;v=Ident id}} when not !strict_check -> Some (make ?loc id) + | {v=AN qid} when qualid_is_ident qid && not !strict_check -> + Some (make ?loc:qid.CAst.loc @@ qualid_basename qid) | _ -> None -let intern_evaluable_global_reference ist r = - let lqid = qualid_of_reference r in - try evaluable_of_global_reference ist.genv (locate_global_with_alias ~head:true lqid) +let intern_evaluable_global_reference ist qid = + try evaluable_of_global_reference ist.genv (locate_global_with_alias ~head:true qid) with Not_found -> - match r with - | {loc;v=Ident id} when not !strict_check -> EvalVarRef id - | _ -> error_global_not_found lqid + if qualid_is_ident qid && not !strict_check then EvalVarRef (qualid_basename qid) + else Nametab.error_global_not_found qid let intern_evaluable_reference_or_by_notation ist = function | {v=AN r} -> intern_evaluable_global_reference ist r @@ -295,14 +312,19 @@ let intern_evaluable_reference_or_by_notation ist = function (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc) (* Globalize a reduction expression *) -let intern_evaluable ist = function - | {loc;v=AN {v=Ident id}} when find_var id ist -> ArgVar (make ?loc id) - | {loc;v=AN {v=Ident id}} when not !strict_check && find_hyp id ist -> - ArgArg (EvalVarRef id, Some (make ?loc id)) - | r -> - let e = intern_evaluable_reference_or_by_notation ist r in - let na = short_name r in - ArgArg (e,na) +let intern_evaluable ist r = + let f ist r = + let e = intern_evaluable_reference_or_by_notation ist r in + let na = short_name r in + ArgArg (e,na) + in + match r with + | {v=AN qid} when qualid_is_ident qid && find_var (qualid_basename qid) ist -> + ArgVar (make ?loc:qid.CAst.loc @@ qualid_basename qid) + | {v=AN qid} when qualid_is_ident qid && not !strict_check && find_hyp (qualid_basename qid) ist -> + let id = qualid_basename qid in + ArgArg (EvalVarRef id, Some (make ?loc:qid.CAst.loc id)) + | _ -> f ist r let intern_unfold ist (l,qid) = (l,intern_evaluable ist qid) @@ -355,7 +377,7 @@ let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = subterm matched when a pattern *) let r = match r with | {v=AN r} -> r - | {loc} -> make ?loc @@ Qualid (qualid_of_path (path_of_global (smart_global r))) in + | {loc} -> (qualid_of_path ?loc (Nametab.path_of_global (smart_global r))) in let sign = { Constrintern.ltac_vars = ist.ltacvars; ltac_bound = Id.Set.empty; @@ -565,10 +587,10 @@ let rec intern_atomic lf ist x = and intern_tactic onlytac ist tac = snd (intern_tactic_seq onlytac ist tac) and intern_tactic_seq onlytac ist = function - | TacAtom (loc,t) -> + | TacAtom { loc; v=t } -> let lf = ref ist.ltacvars in let t = intern_atomic lf ist t in - !lf, TacAtom (Loc.tag ?loc:(adjust_loc loc) t) + !lf, TacAtom (CAst.make ?loc:(adjust_loc loc) t) | TacFun tacfun -> ist.ltacvars, TacFun (intern_tactic_fun ist tacfun) | TacLetIn (isrec,l,u) -> let ltacvars = Id.Set.union (extract_let_names l) ist.ltacvars in @@ -637,25 +659,27 @@ and intern_tactic_seq onlytac ist = function | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_pure_tactic ist) l) | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_pure_tactic ist) l) | TacComplete tac -> ist.ltacvars, TacComplete (intern_pure_tactic ist tac) - | TacArg (loc,a) -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a + | TacArg { loc; v=a } -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a | TacSelect (sel, tac) -> ist.ltacvars, TacSelect (sel, intern_pure_tactic ist tac) (* For extensions *) - | TacAlias (loc,(s,l)) -> + | TacAlias { loc; v=(s,l) } -> + let alias = Tacenv.interp_alias s in + Option.iter (fun o -> warn_deprecated_alias ?loc (s,o)) @@ alias.Tacenv.alias_deprecation; let l = List.map (intern_tacarg !strict_check false ist) l in - ist.ltacvars, TacAlias (Loc.tag ?loc (s,l)) - | TacML (loc,(opn,l)) -> + ist.ltacvars, TacAlias (CAst.make ?loc (s,l)) + | TacML { loc; v=(opn,l) } -> let _ignore = Tacenv.interp_ml_tactic opn in - ist.ltacvars, TacML (loc, (opn,List.map (intern_tacarg !strict_check false ist) l)) + ist.ltacvars, TacML CAst.(make ?loc (opn,List.map (intern_tacarg !strict_check false ist) l)) and intern_tactic_as_arg loc onlytac ist a = match intern_tacarg !strict_check onlytac ist a with | TacCall _ | Reference _ - | TacGeneric _ as a -> TacArg (loc,a) + | TacGeneric _ as a -> TacArg CAst.(make ?loc a) | Tacexp a -> a | ConstrMayEval _ | TacFreshId _ | TacPretype _ | TacNumgoals as a -> - if onlytac then error_tactic_expected ?loc else TacArg (loc,a) + if onlytac then error_tactic_expected ?loc else TacArg CAst.(make ?loc a) and intern_tactic_or_tacarg ist = intern_tactic false ist @@ -668,9 +692,9 @@ and intern_tactic_fun ist (var,body) = and intern_tacarg strict onlytac ist = function | Reference r -> intern_non_tactic_reference strict ist r | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c) - | TacCall (loc,(f,[])) -> intern_isolated_tactic_reference strict ist f - | TacCall (loc,(f,l)) -> - TacCall (Loc.tag ?loc ( + | TacCall { loc; v=(f,[]) } -> intern_isolated_tactic_reference strict ist f + | TacCall { loc; v=(f,l) } -> + TacCall (CAst.make ?loc ( intern_applied_tactic_reference ist f, List.map (intern_tacarg !strict_check false ist) l)) | TacFreshId x -> TacFreshId (List.map (intern_string_or_var ist) x) diff --git a/plugins/ltac/tacintern.mli b/plugins/ltac/tacintern.mli index fb32508cc9..178f6af71d 100644 --- a/plugins/ltac/tacintern.mli +++ b/plugins/ltac/tacintern.mli @@ -12,7 +12,7 @@ open Names open Tacexpr open Genarg open Constrexpr -open Misctypes +open Tactypes (** Globalization of tactic expressions : Conversion from [raw_tactic_expr] to [glob_tactic_expr] *) @@ -21,12 +21,11 @@ type glob_sign = Genintern.glob_sign = { ltacvars : Id.Set.t; genv : Environ.env; extra : Genintern.Store.t; + intern_sign : Genintern.intern_variable_status; } -val fully_empty_glob_sign : glob_sign - val make_empty_glob_sign : unit -> glob_sign - (** same as [fully_empty_glob_sign], but with [Global.env()] as + (** build an empty [glob_sign] using [Global.env()] as environment *) (** Main globalization functions *) diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 6a4bf577b1..cb3a0aaed9 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -12,6 +12,7 @@ open Constrintern open Patternops open Pp open CAst +open Namegen open Genredexpr open Glob_term open Glob_ops @@ -22,7 +23,6 @@ open Names open Nameops open Libnames open Globnames -open Nametab open Refiner open Tacmach.New open Tactic_debug @@ -35,7 +35,8 @@ open Stdarg open Tacarg open Printer open Pretyping -open Misctypes +open Tactypes +open Tactics open Locus open Tacintern open Taccoerce @@ -140,16 +141,6 @@ let extract_trace ist = match TacStore.get ist.extra f_trace with | None -> [] | Some l -> l -module Value = struct - - include Taccoerce.Value - - let of_closure ist tac = - let closure = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in - of_tacvalue closure - -end - let print_top_val env v = Pptactic.pr_value Pptactic.ltop v let catching_error call_trace fail (e, info) = @@ -291,6 +282,12 @@ let debugging_exception_step ist signal_anomaly e pp = debugging_step ist (fun () -> pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ explain_exc e) +let ensure_freshness env = + (* We anonymize declarations which we know will not be used *) + (* This assumes that the original context had no rels *) + process_rel_context + (fun d e -> EConstr.push_rel (Context.Rel.Declaration.set_name Anonymous d) e) env + (* Raise Not_found if not in interpretation sign *) let try_interp_ltac_var coerce ist env {loc;v=id} = let v = Id.Map.find id ist.lfun in @@ -311,11 +308,11 @@ let interp_name ist env sigma = function | Name id -> Name (interp_ident ist env sigma id) let interp_intro_pattern_var loc ist env sigma id = - try try_interp_ltac_var (coerce_to_intro_pattern env sigma) ist (Some (env,sigma)) (make ?loc id) + try try_interp_ltac_var (coerce_to_intro_pattern sigma) ist (Some (env,sigma)) (make ?loc id) with Not_found -> IntroNaming (IntroIdentifier id) let interp_intro_pattern_naming_var loc ist env sigma id = - try try_interp_ltac_var (coerce_to_intro_pattern_naming env sigma) ist (Some (env,sigma)) (make ?loc id) + try try_interp_ltac_var (coerce_to_intro_pattern_naming sigma) ist (Some (env,sigma)) (make ?loc id) with Not_found -> IntroIdentifier id let interp_int ist ({loc;v=id} as locid) = @@ -356,11 +353,11 @@ let interp_hyp_list ist env sigma l = let interp_reference ist env sigma = function | ArgArg (_,r) -> r | ArgVar {loc;v=id} -> - try try_interp_ltac_var (coerce_to_reference env sigma) ist (Some (env,sigma)) (make ?loc id) + try try_interp_ltac_var (coerce_to_reference sigma) ist (Some (env,sigma)) (make ?loc id) with Not_found -> try VarRef (get_id (Environ.lookup_named id env)) - with Not_found -> error_global_not_found (make ?loc @@ qualid_of_ident id) + with Not_found -> Nametab.error_global_not_found (qualid_of_ident ?loc id) let try_interp_evaluable env (loc, id) = let v = Environ.lookup_named id env in @@ -376,14 +373,14 @@ let interp_evaluable ist env sigma = function with Not_found -> match r with | EvalConstRef _ -> r - | _ -> error_global_not_found (make ?loc @@ qualid_of_ident id) + | _ -> Nametab.error_global_not_found (qualid_of_ident ?loc id) end | ArgArg (r,None) -> r | ArgVar {loc;v=id} -> try try_interp_ltac_var (coerce_to_evaluable_ref env sigma) ist (Some (env,sigma)) (make ?loc id) with Not_found -> try try_interp_evaluable env (loc, id) - with Not_found -> error_global_not_found (make ?loc @@ qualid_of_ident id) + with Not_found -> Nametab.error_global_not_found (qualid_of_ident ?loc id) (* Interprets an hypothesis name *) let interp_occurrences ist occs = @@ -450,7 +447,7 @@ let default_fresh_id = Id.of_string "H" let interp_fresh_id ist env sigma l = let extract_ident ist env sigma id = - try try_interp_ltac_var (coerce_to_ident_not_fresh env sigma) + try try_interp_ltac_var (coerce_to_ident_not_fresh sigma) ist (Some (env,sigma)) (make id) with Not_found -> id in let ids = List.map_filter (function ArgVar {v=id} -> Some id | _ -> None) l in @@ -473,7 +470,7 @@ let interp_fresh_id ist env sigma l = (* Extract the uconstr list from lfun *) let extract_ltac_constr_context ist env sigma = let add_uconstr id v map = - try Id.Map.add id (coerce_to_uconstr env v) map + try Id.Map.add id (coerce_to_uconstr v) map with CannotCoerceTo _ -> map in let add_constr id v map = @@ -546,7 +543,6 @@ let interp_gen kind ist pattern_mode flags env sigma c = let constr_flags () = { use_typeclasses = true; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = true; expand_evars = true } @@ -561,21 +557,18 @@ let interp_type = interp_constr_gen IsType let open_constr_use_classes_flags () = { use_typeclasses = true; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = false; expand_evars = true } let open_constr_no_classes_flags () = { use_typeclasses = false; solve_unification_constraints = true; - use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = false; expand_evars = true } let pure_open_constr_flags = { use_typeclasses = false; solve_unification_constraints = true; - use_hook = None; fail_evar = false; expand_evars = false } @@ -642,7 +635,7 @@ let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) = Inr (pattern_of_constr env sigma (EConstr.to_constr sigma c)) in (try try_interp_ltac_var coerce_eval_ref_or_constr ist (Some (env,sigma)) (make ?loc id) with Not_found -> - error_global_not_found (make ?loc @@ qualid_of_ident id)) + Nametab.error_global_not_found (qualid_of_ident ?loc id)) | Inl (ArgArg _ as b) -> Inl (interp_evaluable ist env sigma b) | Inr c -> Inr (interp_typed_pattern ist env sigma c) in interp_occurrences ist occs, p @@ -689,13 +682,11 @@ let interp_may_eval f ist env sigma = function | ConstrContext ({loc;v=s},c) -> (try let (sigma,ic) = f ist env sigma c in - let ctxt = coerce_to_constr_context (Id.Map.find s ist.lfun) in + let ctxt = try_interp_ltac_var coerce_to_constr_context ist (Some (env, sigma)) (make ?loc s) in let ctxt = EConstr.Unsafe.to_constr ctxt in - let evdref = ref sigma in - let ic = EConstr.Unsafe.to_constr ic in + let ic = EConstr.Unsafe.to_constr ic in let c = subst_meta [Constr_matching.special_meta,ic] ctxt in - let c = Typing.e_solve_evars env evdref (EConstr.of_constr c) in - !evdref , c + Typing.solve_evars env sigma (EConstr.of_constr c) with | Not_found -> user_err ?loc ~hdr:"interp_may_eval" @@ -800,7 +791,7 @@ and interp_or_and_intro_pattern ist env sigma = function and interp_intro_pattern_list_as_list ist env sigma = function | [{loc;v=IntroNaming (IntroIdentifier id)}] as l -> - (try sigma, coerce_to_intro_pattern_list ?loc env sigma (Id.Map.find id ist.lfun) + (try sigma, coerce_to_intro_pattern_list ?loc sigma (Id.Map.find id ist.lfun) with Not_found | CannotCoerceTo _ -> List.fold_left_map (interp_intro_pattern ist env) sigma l) | l -> List.fold_left_map (interp_intro_pattern ist env) sigma l @@ -843,7 +834,7 @@ let interp_declared_or_quantified_hypothesis ist env sigma = function | AnonHyp n -> AnonHyp n | NamedHyp id -> try try_interp_ltac_var - (coerce_to_decl_or_quant_hyp env sigma) ist (Some (env,sigma)) (make id) + (coerce_to_decl_or_quant_hyp sigma) ist (Some (env,sigma)) (make id) with Not_found -> NamedHyp id let interp_binding ist env sigma {loc;v=(b,c)} = @@ -926,7 +917,7 @@ let interp_destruction_arg ist gl arg = if Tactics.is_quantified_hypothesis id gl then keep,ElimOnIdent (make ?loc id) else - let c = (DAst.make ?loc @@ GVar id,Some (make @@ CRef (make ?loc @@ Ident id,None))) in + let c = (DAst.make ?loc @@ GVar id,Some (make @@ CRef (qualid_of_ident ?loc id,None))) in let f env sigma = let (sigma,c) = interp_open_constr ist env sigma c in (sigma, (c,NoBindings)) @@ -992,7 +983,7 @@ let rec read_match_rule lfun ist env sigma = function | [] -> [] (* Fully evaluate an untyped constr *) -let type_uconstr ?(flags = {(constr_flags ()) with use_hook = None }) +let type_uconstr ?(flags = (constr_flags ())) ?(expected_type = WithoutTypeConstraint) ist c = begin fun env sigma -> let { closure; term } = c in @@ -1027,7 +1018,7 @@ let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftacti | TacLetIn (false,l,u) -> interp_letin ist l u | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist lz lr lmr | TacMatch (lz,c,lmr) -> interp_match ist lz c lmr - | TacArg (loc,a) -> interp_tacarg ist a + | TacArg {loc;v} -> interp_tacarg ist v | t -> (** Delayed evaluation *) Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], t))) @@ -1045,13 +1036,12 @@ let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftacti and eval_tactic ist tac : unit Proofview.tactic = match tac with - | TacAtom (loc,t) -> + | TacAtom {loc;v=t} -> let call = LtacAtomCall t in push_trace(loc,call) ist >>= fun trace -> Profile_ltac.do_profile "eval_tactic:2" trace (catch_error_tac trace (interp_atomic ist t)) - | TacFun _ | TacLetIn _ -> assert false - | TacMatchGoal _ | TacMatch _ -> assert false + | TacFun _ | TacLetIn _ | TacMatchGoal _ | TacMatch _ -> interp_tactic ist tac | TacId [] -> Proofview.tclLIFT (db_breakpoint (curr_debug ist) []) | TacId s -> let msgnl = @@ -1084,7 +1074,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with push_trace(None,call) ist >>= fun trace -> Profile_ltac.do_profile "eval_tactic:TacAbstract" trace (catch_error_tac trace begin - Proofview.Goal.enter begin fun gl -> Tactics.tclABSTRACT + Proofview.Goal.enter begin fun gl -> Abstract.tclABSTRACT (Option.map (interp_ident ist (pf_env gl) (project gl)) ido) (interp_tactic ist t) end end) | TacThen (t1,t) -> @@ -1126,18 +1116,18 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with eval_tactic ist tac | TacSelect (sel, tac) -> Tacticals.New.tclSELECT sel (interp_tactic ist tac) (* For extensions *) - | TacAlias (loc,(s,l)) -> - let (ids, body) = Tacenv.interp_alias s in + | TacAlias {loc; v=(s,l)} -> + let alias = Tacenv.interp_alias s in let (>>=) = Ftactic.bind in let interp_vars = Ftactic.List.map (fun v -> interp_tacarg ist v) l in let tac l = let addvar x v accu = Id.Map.add x v accu in - let lfun = List.fold_right2 addvar ids l ist.lfun in + let lfun = List.fold_right2 addvar alias.Tacenv.alias_args l ist.lfun in Ftactic.lift (push_trace (loc,LtacNotationCall s) ist) >>= fun trace -> let ist = { lfun = lfun; extra = TacStore.set ist.extra f_trace trace; } in - val_interp ist body >>= fun v -> + val_interp ist alias.Tacenv.alias_body >>= fun v -> Ftactic.lift (tactic_of_value ist v) in let tac = @@ -1149,7 +1139,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with some more elaborate solution will have to be used. *) in let tac = - let len1 = List.length ids in + let len1 = List.length alias.Tacenv.alias_args in let len2 = List.length l in if len1 = len2 then tac else Tacticals.New.tclZEROMSG (str "Arguments length mismatch: \ @@ -1157,7 +1147,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with in Ftactic.run tac (fun () -> Proofview.tclUNIT ()) - | TacML (loc,(opn,l)) -> + | TacML {loc; v=(opn,l)} -> push_trace (Loc.tag ?loc @@ LtacMLCall tac) ist >>= fun trace -> let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in let tac = Tacenv.interp_ml_tactic opn in @@ -1211,9 +1201,9 @@ and interp_tacarg ist arg : Val.t Ftactic.t = Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Ftactic.return (Value.of_constr c_interp)) end - | TacCall (loc,(r,[])) -> + | TacCall { v=(r,[]) } -> interp_ltac_reference true ist r - | TacCall (loc,(f,l)) -> + | TacCall { loc; v=(f,l) } -> let (>>=) = Ftactic.bind in interp_ltac_reference true ist f >>= fun fv -> Ftactic.List.map (fun a -> interp_tacarg ist a) l >>= fun largs -> @@ -1309,7 +1299,7 @@ and tactic_of_value ist vle = match appl with UnnamedAppl -> "An unnamed user-defined tactic" | GlbAppl apps -> - let nms = List.map (fun (kn,_) -> Names.KerName.to_string kn) apps in + let nms = List.map (fun (kn,_) -> string_of_qualid (Tacenv.shortest_qualid_of_tactic kn)) apps in match nms with [] -> assert false | kn::_ -> "The user-defined tactic \"" ^ kn ^ "\"" (* TODO: when do we not have a singleton? *) @@ -1347,7 +1337,7 @@ and interp_letrec ist llc u = Proofview.tclUNIT () >>= fun () -> (* delay for the effects of [lref], just in case. *) let lref = ref ist.lfun in let fold accu ({v=na}, b) = - let v = of_tacvalue (VRec (lref, TacArg (Loc.tag b))) in + let v = of_tacvalue (VRec (lref, TacArg (CAst.make b))) in Name.fold_right (fun id -> Id.Map.add id v) na accu in let lfun = List.fold_left fold ist.lfun llc in @@ -1480,7 +1470,7 @@ and interp_genarg ist x : Val.t Ftactic.t = independently of goals. *) and interp_genarg_constr_list ist x = - Ftactic.nf_enter begin fun gl -> + Ftactic.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let lc = Genarg.out_gen (glbwit (wit_list wit_constr)) x in @@ -1612,7 +1602,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacMutualFix (id,n,l) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual fix>") begin - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = pf_env gl in let f sigma (id,n,c) = let (sigma,c_interp) = interp_type ist env sigma c in @@ -1627,7 +1617,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacMutualCofix (id,l) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual cofix>") begin - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = pf_env gl in let f sigma (id,c) = let (sigma,c_interp) = interp_type ist env sigma c in @@ -1676,16 +1666,18 @@ and interp_atomic ist tac : unit Proofview.tactic = (* We try to fully-typecheck the term *) let flags = open_constr_use_classes_flags () in let (sigma,c_interp) = interp_open_constr ~flags ist env sigma c in - let let_tac b na c cl eqpat = - let id = Option.default (make IntroAnonymous) eqpat in - let with_eq = if b then None else Some (true,id) in - Tactics.letin_tac with_eq na c None cl - in let na = interp_name ist env sigma na in + let let_tac = + if b then Tactics.pose_tac na c_interp + else + let id = Option.default (make IntroAnonymous) eqpat in + let with_eq = Some (true, id) in + Tactics.letin_tac with_eq na c_interp None Locusops.nowhere + in Tacticals.New.tclWITHHOLES ev (name_atomic ~env (TacLetTac(ev,na,c_interp,clp,b,eqpat)) - (let_tac b na c_interp clp eqpat)) sigma + let_tac) sigma else (* We try to keep the pattern structure as much as possible *) let let_pat_tac b na c cl eqpat = @@ -1705,7 +1697,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacInductionDestruct (isrec,ev,(l,el)) -> (* spiwack: some unknown part of destruct needs the goal to be prenormalised. *) - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let sigma,l = @@ -1732,7 +1724,7 @@ and interp_atomic ist tac : unit Proofview.tactic = (* Conversion *) | TacReduce (r,cl) -> - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let (sigma,r_interp) = interp_red_expr ist (pf_env gl) (project gl) r in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl)) @@ -1749,15 +1741,15 @@ and interp_atomic ist tac : unit Proofview.tactic = | AllOccurrences | NoOccurrences -> true | _ -> false in - let c_interp patvars sigma = + let c_interp patvars env sigma = let lfun' = Id.Map.fold (fun id c lfun -> Id.Map.add id (Value.of_constr c) lfun) patvars ist.lfun in let ist = { ist with lfun = lfun' } in if is_onhyps && is_onconcl - then interp_type ist (pf_env gl) sigma c - else interp_constr ist (pf_env gl) sigma c + then interp_type ist env sigma c + else interp_constr ist env sigma c in Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl) end @@ -1770,11 +1762,12 @@ and interp_atomic ist tac : unit Proofview.tactic = let sigma = project gl in let op = interp_typed_pattern ist env sigma op in let to_catch = function Not_found -> true | e -> CErrors.is_anomaly e in - let c_interp patvars sigma = + let c_interp patvars env sigma = let lfun' = Id.Map.fold (fun id c lfun -> Id.Map.add id (Value.of_constr c) lfun) patvars ist.lfun in + let env = ensure_freshness env in let ist = { ist with lfun = lfun' } in try interp_constr ist env sigma c @@ -1862,6 +1855,31 @@ let eval_tactic_ist ist t = Proofview.tclLIFT db_initialize <*> interp_tactic ist t +(** FFI *) + +module Value = struct + + include Taccoerce.Value + + let of_closure ist tac = + let closure = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in + of_tacvalue closure + + (** Apply toplevel tactic values *) + let apply (f : value) (args: value list) = + let fold arg (i, vars, lfun) = + let id = Id.of_string ("x" ^ string_of_int i) in + let x = Reference (ArgVar CAst.(make 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 = { (default_ist ()) with lfun = lfun; } in + let tac = TacArg(CAst.make @@ TacCall (CAst.make (ArgVar CAst.(make @@ Id.of_string "F"),args))) in + eval_tactic_ist ist tac + +end + (* globalization + interpretation *) @@ -2002,7 +2020,7 @@ let interp_ltac_constr ist c k = Ftactic.run (interp_ltac_constr ist c) k let interp_redexp env sigma r = let ist = default_ist () in - let gist = { fully_empty_glob_sign with genv = env; } in + let gist = Genintern.empty_glob_sign env in interp_red_expr ist env sigma (intern_red_expr gist r) (***************************************************************************) @@ -2010,12 +2028,13 @@ let interp_redexp env sigma r = let _ = let eval lfun env sigma ty tac = - let ist = { lfun = lfun; extra = TacStore.empty; } in + let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in + let ist = { lfun = lfun; extra; } in let tac = interp_tactic ist tac in let (c, sigma) = Pfedit.refine_by_tactic env sigma ty tac in (EConstr.of_constr c, sigma) in - Pretyping.register_constr_interp0 wit_tactic eval + GlobEnv.register_constr_interp0 wit_tactic eval let vernac_debug b = set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff) diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index bd44bdbea4..f9883e4441 100644 --- a/plugins/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -14,7 +14,7 @@ open EConstr open Tacexpr open Genarg open Redexpr -open Misctypes +open Tactypes val ltac_trace_info : ltac_trace Exninfo.t @@ -28,6 +28,7 @@ sig val to_list : t -> t list option val of_closure : Geninterp.interp_sign -> glob_tactic_expr -> t val cast : 'a typed_abstract_argument_type -> Geninterp.Val.t -> 'a + val apply : t -> t list -> unit Proofview.tactic end (** Values for interpretation *) @@ -131,7 +132,7 @@ val interp_ltac_var : (value -> 'a) -> interp_sign -> val interp_int : interp_sign -> lident -> int -val interp_int_or_var : interp_sign -> int or_var -> int +val interp_int_or_var : interp_sign -> int Locus.or_var -> int val default_ist : unit -> Geninterp.interp_sign (** Empty ist with debug set on the current value. *) diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index a1d8b087e8..caaa547a07 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -14,7 +14,8 @@ open Mod_subst open Genarg open Stdarg open Tacarg -open Misctypes +open Tactypes +open Tactics open Globnames open Genredexpr open Patternops @@ -75,7 +76,7 @@ let subst_and_short_name f (c,n) = (* assert (n=None); *)(* since tacdef are strictly globalized *) (f c,None) -let subst_or_var f = function +let subst_or_var f = let open Locus in function | ArgVar _ as x -> x | ArgArg x -> ArgArg (f x) @@ -87,20 +88,9 @@ let subst_reference subst = (*CSC: subst_global_reference is used "only" for RefArgType, that propagates to the syntactic non-terminals "global", used in commands such as Print. It is also used for non-evaluable references. *) -open Pp -open Printer let subst_global_reference subst = - let subst_global ref = - let ref',t' = subst_global subst ref in - if not (is_global ref' t') then - (let sigma, env = Pfedit.get_current_context () in - Feedback.msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++ - str " expanded to \"" ++ pr_lconstr_env env sigma t' ++ str "\", but to " ++ - pr_global ref')); - ref' - in - subst_or_var (subst_located subst_global) + subst_or_var (subst_located (subst_global_reference subst)) let subst_evaluable subst = let subst_eval_ref = subst_evaluable_reference subst in @@ -112,7 +102,7 @@ let subst_glob_constr_or_pattern subst (bvars,c,p) = (bvars,subst_glob_constr subst c,subst_pattern subst p) let subst_redexp subst = - Miscops.map_red_expr_gen + Redops.map_red_expr_gen (subst_glob_constr subst) (subst_evaluable subst) (subst_glob_constr_or_pattern subst) @@ -183,7 +173,7 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with TacInversion (InversionUsing (subst_glob_constr subst c,cl),hyp) and subst_tactic subst (t:glob_tactic_expr) = match t with - | TacAtom (_loc,t) -> TacAtom (Loc.tag @@ subst_atomic subst t) + | TacAtom { CAst.v=t } -> TacAtom (CAst.make @@ subst_atomic subst t) | TacFun tacfun -> TacFun (subst_tactic_fun subst tacfun) | TacLetIn (r,l,u) -> let l = List.map (fun (n,b) -> (n,subst_tacarg subst b)) l in @@ -230,22 +220,22 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with | TacFirst l -> TacFirst (List.map (subst_tactic subst) l) | TacSolve l -> TacSolve (List.map (subst_tactic subst) l) | TacComplete tac -> TacComplete (subst_tactic subst tac) - | TacArg (_,a) -> TacArg (Loc.tag @@ subst_tacarg subst a) + | TacArg { CAst.v=a } -> TacArg (CAst.make @@ subst_tacarg subst a) | TacSelect (s, tac) -> TacSelect (s, subst_tactic subst tac) (* For extensions *) - | TacAlias (_,(s,l)) -> + | TacAlias { CAst.v=(s,l) } -> let s = subst_kn subst s in - TacAlias (Loc.tag (s,List.map (subst_tacarg subst) l)) - | TacML (loc,(opn,l)) -> TacML (loc, (opn,List.map (subst_tacarg subst) l)) + TacAlias (CAst.make (s,List.map (subst_tacarg subst) l)) + | TacML { CAst.loc; v=(opn,l)} -> TacML CAst.(make ?loc (opn,List.map (subst_tacarg subst) l)) and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body) and subst_tacarg subst = function | Reference r -> Reference (subst_reference subst r) | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c) - | TacCall (loc,(f,l)) -> - TacCall (Loc.tag ?loc (subst_reference subst f, List.map (subst_tacarg subst) l)) + | TacCall { CAst.loc; v=(f,l) } -> + TacCall CAst.(make ?loc (subst_reference subst f, List.map (subst_tacarg subst) l)) | TacFreshId _ as x -> x | TacPretype c -> TacPretype (subst_glob_constr subst c) | TacNumgoals -> TacNumgoals diff --git a/plugins/ltac/tacsubst.mli b/plugins/ltac/tacsubst.mli index 0a894791b0..d406686c56 100644 --- a/plugins/ltac/tacsubst.mli +++ b/plugins/ltac/tacsubst.mli @@ -11,7 +11,7 @@ open Tacexpr open Mod_subst open Genarg -open Misctypes +open Tactypes (** Substitution of tactics at module closing time *) diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index e55b49fb4e..877d4ee758 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -12,7 +12,6 @@ open Util open Names open Pp open Tacexpr -open Termops let (ltac_trace_info : ltac_trace Exninfo.t) = Exninfo.make () @@ -51,14 +50,14 @@ let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl()) let db_pr_goal gl = let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in - let penv = print_named_context env in - let pc = print_constr_env env (Tacmach.New.project gl) concl in + let penv = Termops.Internal.print_named_context env in + let pc = Printer.pr_econstr_env env (Tacmach.New.project gl) concl in str" " ++ hv 0 (penv ++ fnl () ++ str "============================" ++ fnl () ++ str" " ++ pc) ++ fnl () let db_pr_goal = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let pg = db_pr_goal gl in Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg)) end @@ -243,7 +242,7 @@ let db_constr debug env sigma c = let open Proofview.NonLogical in is_debug debug >>= fun db -> if db then - msg_tac_debug (str "Evaluated term: " ++ print_constr_env env sigma c) + msg_tac_debug (str "Evaluated term: " ++ Printer.pr_econstr_env env sigma c) else return () (* Prints the pattern rule *) @@ -268,7 +267,7 @@ let db_matched_hyp debug env sigma (id,_,c) ido = is_debug debug >>= fun db -> if db then msg_tac_debug (str "Hypothesis " ++ Id.print id ++ hyp_bound ido ++ - str " has been matched: " ++ print_constr_env env sigma c) + str " has been matched: " ++ Printer.pr_econstr_env env sigma c) else return () (* Prints the matched conclusion *) @@ -276,7 +275,7 @@ let db_matched_concl debug env sigma c = let open Proofview.NonLogical in is_debug debug >>= fun db -> if db then - msg_tac_debug (str "Conclusion has been matched: " ++ print_constr_env env sigma c) + msg_tac_debug (str "Conclusion has been matched: " ++ Printer.pr_econstr_env env sigma c) else return () (* Prints a success message when the goal has been matched *) @@ -366,7 +365,7 @@ let explain_ltac_call_trace last trace loc = Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" | Tacexpr.LtacAtomCall te -> quote (Pptactic.pr_glob_tactic (Global.env()) - (Tacexpr.TacAtom (Loc.tag te))) + (Tacexpr.TacAtom (CAst.make te))) | Tacexpr.LtacConstrInterp (c, { Ltac_pretype.ltac_constrs = vars }) -> quote (Printer.pr_glob_constr_env (Global.env()) c) ++ (if not (Id.Map.is_empty vars) then @@ -391,19 +390,14 @@ let explain_ltac_call_trace last trace loc = let skip_extensions trace = let rec aux = function - | (_,Tacexpr.LtacNameCall f as tac) :: _ - when Tacenv.is_ltac_for_ml_tactic f -> [tac] - | (_,Tacexpr.LtacNotationCall _ as tac) :: (_,Tacexpr.LtacMLCall _) :: _ -> + | (_,Tacexpr.LtacNotationCall _ as tac) :: (_,Tacexpr.LtacMLCall _) :: tail -> (* Case of an ML defined tactic with entry of the form <<"foo" args>> *) (* see tacextend.mlp *) - [tac] - | (_,Tacexpr.LtacMLCall _ as tac) :: _ -> [tac] + tac :: aux tail | t :: tail -> t :: aux tail | [] -> [] in List.rev (aux (List.rev trace)) -let finer_loc loc1 loc2 = Loc.merge_opt loc1 loc2 = loc2 - let extract_ltac_trace ?loc trace = let trace = skip_extensions trace in let (tloc,c),tail = List.sep_last trace in @@ -411,7 +405,7 @@ let extract_ltac_trace ?loc trace = (* We entered a user-defined tactic, we display the trace with location of the call *) let msg = hov 0 (explain_ltac_call_trace c tail loc ++ fnl()) in - (if finer_loc loc tloc then loc else tloc), Some msg + (if Loc.finer loc tloc then loc else tloc), Some msg else (* We entered a primitive tactic, we don't display trace but report on the finest location *) @@ -420,7 +414,7 @@ let extract_ltac_trace ?loc trace = let rec aux best_loc = function | (loc,_)::tail -> if Option.is_empty best_loc || - not (Option.is_empty loc) && finer_loc loc best_loc + not (Option.is_empty loc) && Loc.finer loc best_loc then aux loc tail else diff --git a/plugins/ltac/tactic_debug.mli b/plugins/ltac/tactic_debug.mli index 734e76b563..175341df09 100644 --- a/plugins/ltac/tactic_debug.mli +++ b/plugins/ltac/tactic_debug.mli @@ -76,7 +76,7 @@ val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t (** Prints a logic failure message for a rule *) val db_breakpoint : debug_info -> - Misctypes.lident message_token list -> unit Proofview.NonLogical.t + lident message_token list -> unit Proofview.NonLogical.t val extract_ltac_trace : ?loc:Loc.t -> Tacexpr.ltac_trace -> Pp.t option Loc.located diff --git a/plugins/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml index b6462c8106..c949589e22 100644 --- a/plugins/ltac/tactic_matching.ml +++ b/plugins/ltac/tactic_matching.ml @@ -46,7 +46,7 @@ let adjust : Constr_matching.bound_ident_map * Ltac_pretype.patvar_map -> (** Adds a binding to a {!Id.Map.t} if the identifier is [Some id] *) let id_map_try_add id x m = match id with - | Some id -> Id.Map.add id x m + | Some id -> Id.Map.add id (Lazy.force x) m | None -> m (** Adds a binding to a {!Id.Map.t} if the name is [Name id] *) diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index a51c09ca4f..561bfc5d7c 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -8,12 +8,11 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Term +open Constr open EConstr open Hipattern open Names open Geninterp -open Misctypes open Ltac_plugin open Tacexpr open Tacinterp @@ -94,7 +93,7 @@ let clear id = Tactics.clear [id] let assumption = Tactics.assumption -let split = Tactics.split_with_bindings false [Misctypes.NoBindings] +let split = Tactics.split_with_bindings false [Tactypes.NoBindings] (** Test *) @@ -175,7 +174,7 @@ let flatten_contravariant_disj _ ist = | Some (_,args) -> let map i arg = let typ = mkArrow arg c in - let ci = Tactics.constructor_tac false None (succ i) Misctypes.NoBindings in + let ci = Tactics.constructor_tac false None (succ i) Tactypes.NoBindings in let by = tclTHENLIST [intro; apply hyp; ci; assumption] in assert_ ~by typ in @@ -187,12 +186,12 @@ let flatten_contravariant_disj _ ist = let make_unfold name = let dir = DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"]) in let const = Constant.make2 (ModPath.MPfile dir) (Label.make name) in - (Locus.AllOccurrences, ArgArg (EvalConstRef const, None)) + Locus.(AllOccurrences, ArgArg (EvalConstRef const, None)) let u_not = make_unfold "not" let reduction_not_iff _ ist = - let make_reduce c = TacAtom (Loc.tag @@ TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in + let make_reduce c = TacAtom (CAst.make @@ TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in let tac = match !negation_unfolding with | true -> make_reduce [u_not] | false -> TacId [] @@ -245,7 +244,7 @@ let with_flags flags _ ist = let x = CAst.make @@ Id.of_string "x" in let arg = Val.Dyn (tag_tauto_flags, flags) in let ist = { ist with lfun = Id.Map.add x.CAst.v arg ist.lfun } in - eval_tactic_ist ist (TacArg (Loc.tag @@ TacCall (Loc.tag (ArgVar f, [Reference (ArgVar x)])))) + eval_tactic_ist ist (TacArg (CAst.make @@ TacCall (CAst.make (Locus.ArgVar f, [Reference (Locus.ArgVar x)])))) let register_tauto_tactic tac name0 args = let ids = List.map (fun id -> Id.of_string id) args in @@ -253,7 +252,7 @@ let register_tauto_tactic tac name0 args = let name = { mltac_plugin = tauto_plugin; mltac_tactic = name0; } in let entry = { mltac_name = name; mltac_index = 0 } in let () = Tacenv.register_ml_tactic name [| tac |] in - let tac = TacFun (ids, TacML (Loc.tag (entry, []))) in + let tac = TacFun (ids, TacML (CAst.make (entry, []))) in let obj () = Tacenv.register_ltac true true (Id.of_string name0) tac in Mltop.declare_cache_obj obj tauto_plugin diff --git a/plugins/micromega/Fourier.v b/plugins/micromega/Fourier.v new file mode 100644 index 0000000000..0153de1dab --- /dev/null +++ b/plugins/micromega/Fourier.v @@ -0,0 +1,5 @@ +Require Import Lra. +Require Export Fourier_util. + +#[deprecated(since = "8.9.0", note = "Use lra instead.")] +Ltac fourier := lra. diff --git a/plugins/micromega/Fourier_util.v b/plugins/micromega/Fourier_util.v new file mode 100644 index 0000000000..b62153dee4 --- /dev/null +++ b/plugins/micromega/Fourier_util.v @@ -0,0 +1,31 @@ +Require Export Rbase. +Require Import Lra. + +Open Scope R_scope. + +Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. +intros x y H H0; try assumption. +replace 0 with (x * 0). +apply Rmult_lt_compat_l; auto with real. +ring. +Qed. + +Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x. +intros x H; try assumption. +rewrite Rplus_comm. +apply Rle_lt_0_plus_1. +red; auto with real. +Qed. + +Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x. + intros; lra. +Qed. + +Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y. +intros x y H H0; try assumption. +case H; intros. +red; left. +apply Rlt_mult_inv_pos; auto with real. +rewrite <- H1. +red; right; ring. +Qed. diff --git a/plugins/micromega/Lia.v b/plugins/micromega/Lia.v index ae05cf5459..dd6319d5c4 100644 --- a/plugins/micromega/Lia.v +++ b/plugins/micromega/Lia.v @@ -32,7 +32,7 @@ Ltac zchange := Ltac zchecker_no_abstract := zchange ; vm_compute ; reflexivity. -Ltac zchecker_abstract := zchange ; vm_cast_no_check (eq_refl true). +Ltac zchecker_abstract := abstract (zchange ; vm_cast_no_check (eq_refl true)). Ltac zchecker := zchecker_no_abstract. diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index 158ddb589b..5f01f981ef 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -53,12 +53,11 @@ Extract Constant Rinv => "fun x -> 1 / x". (** In order to avoid annoying build dependencies the actual extraction is only performed as a test in the test suite. *) -(* Extraction "plugins/micromega/micromega.ml" *) -(* Recursive Extraction *) -(* List.map simpl_cone (*map_cone indexes*) *) -(* denorm Qpower vm_add *) -(* n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. *) - +(*Extraction "micromega.ml" +(*Recursive Extraction*) List.map simpl_cone (*map_cone indexes*) + denorm Qpower vm_add + normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. +*) (* Local Variables: *) (* coding: utf-8 *) (* End: *) diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v index ddf4064a03..2880a05d8d 100644 --- a/plugins/micromega/QMicromega.v +++ b/plugins/micromega/QMicromega.v @@ -179,6 +179,8 @@ Definition qunsat := check_inconsistent 0 Qeq_bool Qle_bool. Definition qdeduce := nformula_plus_nformula 0 Qplus Qeq_bool. +Definition normQ := norm 0 1 Qplus Qmult Qminus Qopp Qeq_bool. +Declare Equivalent Keys normQ RingMicromega.norm. Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness) : bool := diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v index 31f55ae9c3..458844e1b9 100644 --- a/plugins/micromega/Tauto.v +++ b/plugins/micromega/Tauto.v @@ -211,7 +211,7 @@ Set Implicit Arguments. (* BC *) simpl. case_eq (deduce t t) ; auto. - intros until 0. + intros *. case_eq (unsat t0) ; auto. unfold eval_clause. rewrite make_conj_cons. @@ -263,7 +263,7 @@ Set Implicit Arguments. Proof. induction cl. simpl. tauto. - intros until 0. + intros *. simpl. assert (HH := add_term_correct env a cl'). case_eq (add_term a cl'). diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index 892858e63f..f341a04e03 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -162,8 +162,8 @@ Declare Equivalent Keys psub RingMicromega.psub. Definition padd := padd Z0 Z.add Zeq_bool. Declare Equivalent Keys padd RingMicromega.padd. -Definition norm := norm 0 1 Z.add Z.mul Z.sub Z.opp Zeq_bool. -Declare Equivalent Keys norm RingMicromega.norm. +Definition normZ := norm 0 1 Z.add Z.mul Z.sub Z.opp Zeq_bool. +Declare Equivalent Keys normZ RingMicromega.norm. Definition eval_pol := eval_pol Z.add Z.mul (fun x => x). Declare Equivalent Keys eval_pol RingMicromega.eval_pol. @@ -180,7 +180,7 @@ Proof. apply (eval_pol_add Zsor ZSORaddon). Qed. -Lemma eval_pol_norm : forall env e, eval_expr env e = eval_pol env (norm e) . +Lemma eval_pol_norm : forall env e, eval_expr env e = eval_pol env (normZ e) . Proof. intros. apply (eval_pol_norm Zsor ZSORaddon). @@ -188,8 +188,8 @@ Qed. Definition xnormalise (t:Formula Z) : list (NFormula Z) := let (lhs,o,rhs) := t in - let lhs := norm lhs in - let rhs := norm rhs in + let lhs := normZ lhs in + let rhs := normZ rhs in match o with | OpEq => ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil @@ -225,8 +225,8 @@ Qed. Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) := let (lhs,o,rhs) := t in - let lhs := norm lhs in - let rhs := norm rhs in + let lhs := normZ lhs in + let rhs := normZ rhs in match o with | OpEq => (psub lhs rhs,Equal) :: nil | OpNEq => ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 9f39191f82..af292c088f 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -17,10 +17,9 @@ (* We take as input a list of polynomials [p1...pn] and return an unfeasibility certificate polynomial. *) -type var = int - - +let debug = false +open Util open Big_int open Num open Polynomial @@ -29,152 +28,79 @@ module Mc = Micromega module Ml2C = Mutils.CamlToCoq module C2Ml = Mutils.CoqToCaml +let use_simplex = ref true + open Mutils type 'a number_spec = { - bigint_to_number : big_int -> 'a; - number_to_num : 'a -> num; - zero : 'a; - unit : 'a; - mult : 'a -> 'a -> 'a; - eqb : 'a -> 'a -> bool -} + bigint_to_number : big_int -> 'a; + number_to_num : 'a -> num; + zero : 'a; + unit : 'a; + mult : 'a -> 'a -> 'a; + eqb : 'a -> 'a -> bool + } let z_spec = { - bigint_to_number = Ml2C.bigint ; - number_to_num = (fun x -> Big_int (C2Ml.z_big_int x)); - zero = Mc.Z0; - unit = Mc.Zpos Mc.XH; - mult = Mc.Z.mul; - eqb = Mc.zeq_bool -} - - -let q_spec = { - bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH}); - number_to_num = C2Ml.q_to_num; - zero = {Mc.qnum = Mc.Z0;Mc.qden = Mc.XH}; - unit = {Mc.qnum = (Mc.Zpos Mc.XH) ; Mc.qden = Mc.XH}; - mult = Mc.qmult; - eqb = Mc.qeq_bool -} + bigint_to_number = Ml2C.bigint ; + number_to_num = (fun x -> Big_int (C2Ml.z_big_int x)); + zero = Mc.Z0; + unit = Mc.Zpos Mc.XH; + mult = Mc.Z.mul; + eqb = Mc.zeq_bool + } -let r_spec = z_spec +let q_spec = { + bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH}); + number_to_num = C2Ml.q_to_num; + zero = {Mc.qnum = Mc.Z0;Mc.qden = Mc.XH}; + unit = {Mc.qnum = (Mc.Zpos Mc.XH) ; Mc.qden = Mc.XH}; + mult = Mc.qmult; + eqb = Mc.qeq_bool + } let 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 - - -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 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 + 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 let rec fixpoint f x = - let y' = f x in - if Pervasives.(=) y' x then y' - else fixpoint f y' + let y' = f x in + 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 + let simpl_cone = + Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb in + + let rec rec_simpl_cone = function + | Mc.PsatzMulE(t1, t2) -> + simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2)) + | Mc.PsatzAdd(t1,t2) -> + simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2)) + | x -> simpl_cone x in + rec_simpl_cone e let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c - -type cone_prod = - Const of cone -| Ideal of cone *cone -| Mult of cone * cone -| Other of cone -and cone = Mc.zWitness - - - -let factorise_linear_cone c = - - let rec cone_list c l = - match c with - | Mc.PsatzAdd (x,r) -> cone_list r (x::l) - | _ -> c :: l in - - let factorise c1 c2 = - match c1 , c2 with - | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') -> - if 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 - - (rebuild_cone (List.sort Pervasives.compare (cone_list c [])) None) @@ -192,1091 +118,917 @@ let factorise_linear_cone c = This is a linear problem: each monomial is considered as a variable. Hence, we can use fourier. - The variable c is at index 0 -*) - -open Mfourier + The variable c is at index 1 + *) (* fold_left followed by a rev ! *) -let constrain_monomial mn l = - let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in - if Pervasives.(=) mn Monomial.const - then - { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ; +let constrain_variable v l = + let coeffs = List.fold_left (fun acc p -> (Vect.get v p.coeffs)::acc) [] l in + { coeffs = Vect.from_list ((Big_int zero_big_int):: (Big_int zero_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)) ; + + + +let constrain_constant l = + let coeffs = List.fold_left (fun acc p -> minus_num p.cst ::acc) [] l in + { coeffs = Vect.from_list ((Big_int zero_big_int):: (Big_int unit_big_int):: (List.rev coeffs)) ; op = Eq ; cst = Big_int zero_big_int } - let positivity l = - let rec xpositivity i l = - match l with - | [] -> [] - | (_,Mc.Equal)::l -> xpositivity (i+1) l - | (_,_)::l -> - {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ; - op = Ge ; - cst = Int 0 } :: (xpositivity (i+1) l) - in - xpositivity 0 l + let rec xpositivity i l = + match l with + | [] -> [] + | c::l -> match c.op with + | Eq -> xpositivity (i+1) l + | _ -> + {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ; + op = Ge ; + cst = Int 0 } :: (xpositivity (i+1) l) + in + xpositivity 1 l -let string_of_op = function - | Mc.Strict -> "> 0" - | Mc.NonStrict -> ">= 0" - | Mc.Equal -> "= 0" - | Mc.NonEqual -> "<> 0" +let cstr_of_poly (p,o) = + let (c,l) = Vect.decomp_cst p in + {coeffs = l; op = o ; cst = minus_num c} -module MonSet = Set.Make(Monomial) + +let variables_of_cstr c = Vect.variables c.coeffs + (* If the certificate includes at least one strict inequality, the obtained polynomial can also be 0 *) -let build_linear_system l = - - (* Gather the monomials: HINT add up of the polynomials ==> This does not work anymore *) - let l' = List.map fst l in - - let monomials = - List.fold_left (fun acc p -> - Poly.fold (fun m _ acc -> MonSet.add m acc) p acc) - (MonSet.singleton Monomial.const) l' - in (* For each monomial, compute a constraint *) - let s0 = - MonSet.fold (fun mn res -> (constrain_monomial mn l')::res) monomials [] in - (* I need at least something strictly positive *) - let strict = { - coeffs = Vect.from_list ((Big_int unit_big_int):: - (List.map (fun (x,y) -> - match y with Mc.Strict -> - Big_int unit_big_int - | _ -> Big_int zero_big_int) l)); - op = Ge ; cst = Big_int unit_big_int } in + +let build_dual_linear_system l = + + let variables = + List.fold_left (fun acc p -> ISet.union acc (variables_of_cstr p)) ISet.empty l in + (* For each monomial, compute a constraint *) + let s0 = + ISet.fold (fun mn res -> (constrain_variable mn l)::res) variables [] in + let c = constrain_constant l in + + (* I need at least something strictly positive *) + let strict = { + coeffs = Vect.from_list ((Big_int zero_big_int) :: (Big_int unit_big_int):: + (List.map (fun c -> if is_strict c then Big_int unit_big_int else Big_int zero_big_int) l)); + op = Ge ; cst = Big_int unit_big_int } in (* Add the positivity constraint *) - {coeffs = Vect.from_list ([Big_int unit_big_int]) ; - op = Ge ; - cst = Big_int zero_big_int}::(strict::(positivity l)@s0) - - -let big_int_to_z = Ml2C.bigint - -(* For Q, this is a pity that the certificate has been scaled - -- at a lower layer, certificates are using nums... *) -let make_certificate n_spec (cert,li) = - let bint_to_cst = n_spec.bigint_to_number in - match cert with - | [] -> failwith "empty_certificate" - | e::cert' -> - (* let cst = match compare_big_int e zero_big_int with - | 0 -> Mc.PsatzZ - | 1 -> Mc.PsatzC (bint_to_cst e) - | _ -> failwith "positivity error" - in *) - let rec scalar_product cert l = - match cert with - | [] -> Mc.PsatzZ - | c::cert -> - match l with - | [] -> failwith "make_certificate(1)" - | i::l -> - let r = scalar_product cert l in - match compare_big_int c zero_big_int with - | -1 -> Mc.PsatzAdd ( - Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), - r) - | 0 -> r - | _ -> Mc.PsatzAdd ( - Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), - r) in - (factorise_linear_cone - (simplify_cone n_spec (scalar_product cert' li))) - - -exception Found of Monomial.t - -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 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 - - (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 ; *) - - 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 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)) + {coeffs = Vect.from_list ([Big_int zero_big_int ;Big_int unit_big_int]) ; + op = Ge ; + cst = Big_int zero_big_int}::(strict::(positivity l)@c::s0) + + +(** [direct_linear_prover l] does not handle strict inegalities *) +let fourier_linear_prover l = + match Mfourier.Fourier.find_point l with + | Inr prf -> + if debug then Printf.printf "AProof : %a\n" Mfourier.pp_proof prf ; + let cert = (*List.map (fun (x,n) -> x+1,n)*) (fst (List.hd (Mfourier.Proof.mk_proof l prf))) in + if debug then Printf.printf "CProof : %a" Vect.pp cert ; + (*Some (rats_to_ints (Vect.to_list cert))*) + Some (Vect.normalise cert) | Inl _ -> None - with Strict -> + + +let direct_linear_prover l = + if !use_simplex + then Simplex.find_unsat_certificate l + else fourier_linear_prover l + +let find_point l = + if !use_simplex + then Simplex.find_point l + else match Mfourier.Fourier.find_point l with + | Inr _ -> None + | Inl cert -> Some cert + +let optimise v l = + if !use_simplex + then Simplex.optimise v l + else Mfourier.Fourier.optimise v l + + + +let dual_raw_certificate l = + if debug + then begin + Printf.printf "dual_raw_certificate\n"; + List.iter (fun c -> Printf.fprintf stdout "%a\n" output_cstr c) l + end; + + let sys = build_dual_linear_system l in + + if debug then begin + Printf.printf "dual_system\n"; + List.iter (fun c -> Printf.fprintf stdout "%a\n" output_cstr c) sys + end; + + try + match find_point sys with + | None -> None + | Some cert -> + match Vect.choose cert with + | None -> failwith "dual_raw_certificate: empty_certificate" + | Some _ -> + (*Some (rats_to_ints (Vect.to_list (Vect.decr_var 2 (Vect.set 1 (Int 0) cert))))*) + Some (Vect.normalise (Vect.decr_var 2 (Vect.set 1 (Int 0) cert))) + (* should not use rats_to_ints *) + with x when CErrors.noncritical x -> + if debug + then (Printf.printf "dual raw certificate %s" (Printexc.to_string x); + flush stdout) ; + None + + + +let simple_linear_prover l = + try + direct_linear_prover l + with Strict -> (* Fourier elimination should handle > *) - dual_raw_certificate l + dual_raw_certificate l +open ProofFormat -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) - + +let env_of_list l = + snd (List.fold_left (fun (i,m) p -> (i+1,IMap.add i p m)) (0,IMap.empty) l) -let linear_prover n_spec l = - let build_system n_spec l = - let li = List.combine l (interval 0 (List.length l -1)) in - let (l1,l') = List.partition - (fun (x,_) -> if 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_cstr sys = + let (sysi,prfi) = List.split sys in + + + match simple_linear_prover sysi with + | None -> None + | Some cert -> Some (proof_of_farkas (env_of_list prfi) cert) + +let linear_prover_cstr = + if debug + then + fun sys -> + Printf.printf "<linear_prover"; flush stdout ; + let res = linear_prover_cstr sys in + Printf.printf ">"; flush stdout ; + res + else linear_prover_cstr -let linear_prover n_spec l = - try linear_prover n_spec l - 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 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 develop_constraint z_spec (e,k) = + (dev_form z_spec e, + match k with + | Mc.NonStrict -> Ge + | Mc.Equal -> Eq + | Mc.Strict -> Gt + | _ -> assert false + ) -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 +(** A single constraint can be unsat for the following reasons: + - 0 >= c for c a negative constant + - 0 = c for c a non-zero constant + - e = c when the coeffs of e are all integers and c is rational + *) +open ProofFormat +type checksat = + | Tauto (* Tautology *) + | Unsat of prf_rule (* Unsatisfiable *) + | Cut of cstr * prf_rule (* Cutting plane *) + | Normalise of cstr * prf_rule (* Coefficients may be normalised i.e relatively prime *) - (* 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 +exception FoundProof of prf_rule + + +(** [check_sat] + - detects constraints that are not satisfiable; + - normalises constraints and generate cuts. + *) + +let check_int_sat (cstr,prf) = + let {coeffs=coeffs ; op=op ; cst=cst} = cstr in + match Vect.choose coeffs with + | None -> + if eval_op op (Int 0) cst then Tauto else Unsat prf + | _ -> + let gcdi = Vect.gcd 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 = Vect.div 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 = Vect.div gcd coeffs; + op = op ; cst = ceiling_num (cst // gcd) + } in Cut(cstr,CutPrf prf) + | Gt -> failwith "check_sat : Unexpected operator" + + +let apply_and_normalise check f psys = + List.fold_left (fun acc pc' -> + match f pc' with + | None -> pc'::acc + | Some pc' -> + match check pc' with + | Tauto -> acc + | Unsat prf -> raise (FoundProof prf) + | Cut(c,p) -> (c,p)::acc + | Normalise (c,p) -> (c,p)::acc + ) [] psys + + +let simplify f sys = + let (sys',b) = + List.fold_left (fun (sys',b) c -> + match f c with + | None -> (c::sys',b) + | Some c' -> + (c'::sys',true) + ) ([],false) sys in + if b then Some sys' else None + +let saturate f sys = + List.fold_left (fun sys' c -> match f c with + | None -> sys' + | Some c' -> c'::sys' + ) [] sys + +let is_substitution strict ((p,o),prf) = + let pred v = if strict then v =/ Int 1 || v =/ Int (-1) else true 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 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 + | Eq -> LinPoly.search_linear pred p + | _ -> None - let sys = sys @ square in +let is_linear_for v pc = + LinPoly.is_linear (fst (fst pc)) || LinPoly.is_linear_for v (fst (fst pc)) - (* 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 non_linear_pivot sys pc v pc' = + if LinPoly.is_linear (fst (fst pc')) + then None (* There are other ways to deal with those *) + else WithProof.linear_pivot sys pc v pc' -let make_linear_system l = - let l' = List.map fst l in - let monomials = List.fold_left (fun acc p -> Poly.addition p acc) - (Poly.constant (Int 0)) l' in - let monomials = Poly.fold - (fun mn _ l -> if 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) +let is_linear_substitution sys ((p,o),prf) = + let pred v = v =/ Int 1 || v =/ Int (-1) in + match o with + | Eq -> begin + match + List.filter (fun v -> List.for_all (is_linear_for v) sys) (LinPoly.search_all_linear pred p) + with + | [] -> None + | v::_ -> Some v (* make a choice *) + end + | _ -> None -let pplus x y = Mc.PEadd(x,y) -let pmult x y = Mc.PEmul(x,y) -let pconst x = Mc.PEc x -let popp x = Mc.PEopp x -(* keep track of enumerated vectors *) -let rec mem p x l = - match l with [] -> false | e::l -> if p x e then true else mem p x l +let elim_simple_linear_equality sys0 = -let rec remove_assoc p x l = - match l with [] -> [] | e::l -> if p x (fst e) then - remove_assoc p x l else e::(remove_assoc p x l) + let elim sys = + let (oeq,sys') = extract (is_linear_substitution sys) sys in + match oeq with + | None -> None + | Some(v,pc) -> simplify (WithProof.linear_pivot sys0 pc v) sys' in -let eq x y = Int.equal (Vect.compare x y) 0 + iterate_until_stable elim sys0 -let remove e l = List.fold_left (fun l x -> if eq x e then l else x::l) [] l +let saturate_linear_equality_non_linear sys0 = + let (l,_) = extract_all (is_substitution false) sys0 in + let rec elim l acc = + match l with + | [] -> acc + | (v,pc)::l' -> + let nc = saturate (non_linear_pivot sys0 pc v) (sys0@acc) in + elim l' (nc@acc) in + elim l [] -(* The prover is (probably) incomplete -- - 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 +let develop_constraints prfdepth n_spec sys = + LinPoly.MonT.clear (); + max_nb_cstr := compute_max_nb_cstr sys prfdepth ; + let sys = List.map (develop_constraint n_spec) sys in + List.mapi (fun i (p,o) -> ((LinPoly.linpol_of_pol p,o),Hyp i)) sys -let op_of_op_compat = function - | Ge -> Mc.NonStrict - | Eq -> Mc.Equal +let square_of_var i = + let x = LinPoly.var i in + ((LinPoly.product x x,Ge),(Square x)) + +(** [nlinear_preprocess sys] augments the system [sys] by performing some limited non-linear reasoning. + For instance, it asserts that the x² ≥0 but also that if c₁ ≥ 0 ∈ sys and c₂ ≥ 0 ∈ sys then c₁ × c₂ ≥ 0. + The resulting system is linearised. + *) + +let nlinear_preprocess (sys:WithProof.t list) = + + let is_linear = List.for_all (fun ((p,_),_) -> LinPoly.is_linear p) sys in -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)) + if is_linear then sys + else + let collect_square = + List.fold_left (fun acc ((p,_),_) -> MonMap.union (fun k e1 e2 -> Some e1) acc (LinPoly.collect_square p)) MonMap.empty sys in + let sys = MonMap.fold (fun s m acc -> + let s = LinPoly.of_monomial s in + let m = LinPoly.of_monomial m in + ((m, Ge), (Square s))::acc) collect_square sys in -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 collect_vars = List.fold_left (fun acc p -> ISet.union acc (LinPoly.variables (fst (fst p)))) ISet.empty sys in + + let sys = ISet.fold (fun i acc -> square_of_var i :: acc) collect_vars sys in + + let sys = sys @ (all_pairs WithProof.product sys) in + if debug then begin + Printf.fprintf stdout "Preprocessed\n"; + List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; + end ; + + List.map (WithProof.annot "P") sys + -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 nlinear_prover prfdepth sys = + let sys = develop_constraints prfdepth q_spec sys in + let sys1 = elim_simple_linear_equality sys in + let sys2 = saturate_linear_equality_non_linear sys1 in + let sys = nlinear_preprocess sys1@sys2 in + let sys = List.map (fun ((p,o),prf) -> (cstr_of_poly (p,o), prf)) sys in + let id = (List.fold_left + (fun acc (_,r) -> max acc (ProofFormat.pr_rule_max_id r)) 0 sys) in + let env = CList.interval 0 id in + match linear_prover_cstr sys with + | None -> None + | Some cert -> + Some (cmpl_prf_rule Mc.normQ CamlToCoq.q env cert) +let linear_prover_with_cert prfdepth sys = + let sys = develop_constraints prfdepth q_spec sys in + (* let sys = nlinear_preprocess sys in *) + let sys = List.map (fun (c,p) -> cstr_of_poly c,p) sys in + + match linear_prover_cstr sys with + | None -> None + | Some cert -> + Some (cmpl_prf_rule Mc.normQ CamlToCoq.q (List.mapi (fun i e -> i) sys) cert) + +(* The prover is (probably) incomplete -- + only searching for naive cutting planes *) 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), + match t with + | Zero -> unit_big_int , Zero + | Const n -> (denominator n) , Const (Big_int (numerator n)) + | Var n -> unit_big_int , Var n + | 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" + | 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) let scale_term t = - let (s,t') = scale_term t in - s,t' - - -let get_index_of_ith_match f i l = - let rec get j res l = - match l with - | [] -> failwith "bad index" - | e::l -> if f e - then - (if 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 (s,t') = scale_term t in + s,t' let rec scale_certificate pos = match pos with - | Axiom_eq i -> unit_big_int , Axiom_eq i - | Axiom_le i -> unit_big_int , Axiom_le i - | Axiom_lt i -> unit_big_int , Axiom_lt i - | Monoid l -> unit_big_int , Monoid l - | Rational_eq n -> (denominator n) , Rational_eq (Big_int (numerator n)) - | Rational_le n -> (denominator n) , Rational_le (Big_int (numerator n)) - | Rational_lt n -> (denominator n) , Rational_lt (Big_int (numerator n)) - | Square t -> let s,t' = scale_term t in - mult_big_int s s , Square t' - | Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in - mult_big_int s1 s2 , Eqmul (y1,y2) - | Sum (y, z) -> let s1,y1 = scale_certificate y - and s2,y2 = scale_certificate z in - let g = gcd_big_int s1 s2 in - let s1' = div_big_int s1 g in - let s2' = div_big_int s2 g in - mult_big_int g (mult_big_int s1' s2'), - Sum (Product(Rational_le (Big_int s2'), y1), - Product (Rational_le (Big_int s1'), y2)) - | Product (y, z) -> - let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in - mult_big_int s1 s2 , Product (y1,y2) + | Axiom_eq i -> unit_big_int , Axiom_eq i + | Axiom_le i -> unit_big_int , Axiom_le i + | Axiom_lt i -> unit_big_int , Axiom_lt i + | Monoid l -> unit_big_int , Monoid l + | Rational_eq n -> (denominator n) , Rational_eq (Big_int (numerator n)) + | Rational_le n -> (denominator n) , Rational_le (Big_int (numerator n)) + | Rational_lt n -> (denominator n) , Rational_lt (Big_int (numerator n)) + | Square t -> let s,t' = scale_term t in + mult_big_int s s , Square t' + | Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in + mult_big_int s1 s2 , Eqmul (y1,y2) + | Sum (y, z) -> let s1,y1 = scale_certificate y + and s2,y2 = scale_certificate z in + let g = gcd_big_int s1 s2 in + let s1' = div_big_int s1 g in + let s2' = div_big_int s2 g in + mult_big_int g (mult_big_int s1' s2'), + Sum (Product(Rational_le (Big_int s2'), y1), + Product (Rational_le (Big_int s1'), y2)) + | Product (y, z) -> + let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in + mult_big_int s1 s2 , Product (y1,y2) open Micromega let rec term_to_q_expr = function - | Const n -> PEc (Ml2C.q n) - | Zero -> PEc ( Ml2C.q (Int 0)) - | Var s -> PEX (Ml2C.index - (int_of_string (String.sub s 1 (String.length s - 1)))) - | Mul(p1,p2) -> PEmul(term_to_q_expr p1, term_to_q_expr p2) - | Add(p1,p2) -> PEadd(term_to_q_expr p1, term_to_q_expr p2) - | Opp p -> PEopp (term_to_q_expr p) - | Pow(t,n) -> PEpow (term_to_q_expr t,Ml2C.n n) - | Sub(t1,t2) -> PEsub (term_to_q_expr t1, term_to_q_expr t2) - | _ -> failwith "term_to_q_expr: not implemented" + | 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) 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) + match l with + | [] -> Mc.PsatzZ + | [i] -> Mc.PsatzIn (Ml2C.nat i) + | i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l) let q_cert_of_pos pos = - let rec _cert_of_pos = function - Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) - | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) - | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) - | Monoid l -> product l - | Rational_eq n | Rational_le n | Rational_lt n -> - if 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) + let rec _cert_of_pos = function + Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) + | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) + | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) + | Monoid l -> product l + | Rational_eq n | Rational_le n | Rational_lt n -> + if 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) 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" + | 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) 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_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)) - | 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) - | 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) + let s,pos = (scale_certificate pos) in + let rec _cert_of_pos = function + Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) + | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) + | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) + | Monoid l -> product l + | Rational_eq n | Rational_le n | Rational_lt n -> + if 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) + | Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z) + | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in + simplify_cone z_spec (_cert_of_pos pos) (** All constraints (initial or derived) have an index and have a justification i.e., proof. Given a constraint, all the coefficients are always integers. -*) + *) open Mutils -open Mfourier open Num open Big_int open Polynomial -module Env = -struct - - type t = int list - - let id_of_hyp hyp l = - let rec xid_of_hyp i l = - match l with - | [] -> failwith "id_of_hyp" - | hyp'::l -> if 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 - - List.fold_left (fun acc (x,v) -> - let mn = LinPoly.MonT.retrieve x in - Mc.PEadd(Mc.PEmul(Mc.PEc (Ml2C.bigint (numerator v)), pol_of_mon mn),acc)) (Mc.PEc (Ml2C.bigint (numerator c))) p - - - - -let rec cmpl_prf_rule env = function - | Hyp i | Def i -> Mc.PsatzIn (Ml2C.nat (Env.id_of_hyp i env)) - | Cst i -> Mc.PsatzC (Ml2C.bigint i) - | Zero -> Mc.PsatzZ - | MulPrf(p1,p2) -> Mc.PsatzMulE(cmpl_prf_rule env p1, cmpl_prf_rule env p2) - | AddPrf(p1,p2) -> Mc.PsatzAdd(cmpl_prf_rule env p1 , cmpl_prf_rule env p2) - | MulC(lp,p) -> let lp = Mc.norm0 (coq_poly_of_linpol lp) in - Mc.PsatzMulC(lp,cmpl_prf_rule env p) - | Square lp -> Mc.PsatzSquare (Mc.norm0 (coq_poly_of_linpol lp)) - | _ -> failwith "Cuts should already be compiled" - - -let rec cmpl_proof env = function - | Done -> Mc.DoneProof - | Step(i,p,prf) -> - begin - match p with - | CutPrf p' -> - Mc.CutProof(cmpl_prf_rule env p', cmpl_proof (i::env) prf) - | _ -> Mc.RatProof(cmpl_prf_rule env p,cmpl_proof (i::env) prf) - end - | Enum(i,p1,_,p2,l) -> - Mc.EnumProof(cmpl_prf_rule env p1,cmpl_prf_rule env p2,List.map (cmpl_proof (i::env)) l) - - -let compile_proof env prf = - let id = 1 + proof_max_id prf in - let _,prf = normalise_proof id prf in - if debug then Printf.fprintf stdout "compiled proof %a\n" output_proof prf; - cmpl_proof env prf - -type prf_sys = (cstr_compat * prf_rule) list - - -let xlinear_prover sys = - match Fourier.find_point sys with - | Inr prf -> - if debug then Printf.printf "AProof : %a\n" pp_proof prf ; - let cert = (*List.map (fun (x,n) -> x+1,n)*) (fst (List.hd (Proof.mk_proof sys prf))) in - if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; - Some (rats_to_ints (Vect.to_list cert)) - | Inl _ -> None - - -let output_num o n = output_string o (string_of_num n) -let output_bigint o n = output_string o (string_of_big_int n) - -let proof_of_farkas prf cert = - (* Printf.printf "\nproof_of_farkas %a , %a \n" (pp_list output_prf_rule) prf (pp_list output_bigint) cert ; *) - let rec mk_farkas acc prf cert = - match prf, cert with - | _ , [] -> acc - | [] , _ -> failwith "proof_of_farkas : not enough hyps" - | p::prf,c::cert -> - mk_farkas (add_proof (mul_proof c p) acc) prf cert in - let res = mk_farkas Zero prf cert in - (*Printf.printf "==> %a" output_prf_rule res ; *) - res - - -let linear_prover sys = - let (sysi,prfi) = List.split sys in - match xlinear_prover sysi with - | None -> None - | Some cert -> Some (proof_of_farkas prfi cert) - -let linear_prover = - if debug - then - fun sys -> - Printf.printf "<linear_prover"; flush stdout ; - let res = linear_prover sys in - Printf.printf ">"; flush stdout ; - res - else linear_prover - - - - -(** A single constraint can be unsat for the following reasons: - - 0 >= c for c a negative constant - - 0 = c for c a non-zero constant - - e = c when the coeffs of e are all integers and c is rational -*) -type checksat = -| Tauto (* Tautology *) -| Unsat of prf_rule (* Unsatisfiable *) -| Cut of cstr_compat * prf_rule (* Cutting plane *) -| Normalise of cstr_compat * prf_rule (* coefficients are relatively prime *) - +type prf_sys = (cstr * prf_rule) list -(** [check_sat] - - detects constraints that are not satisfiable; - - normalises constraints and generate cuts. -*) - -let check_sat (cstr,prf) = - let {coeffs=coeffs ; op=op ; cst=cst} = cstr in - match coeffs with - | [] -> - if eval_op op (Int 0) cst then Tauto else Unsat prf - | _ -> - let gcdi = (gcd_list (List.map snd coeffs)) in - let gcd = Big_int gcdi in - if eq_num gcd (Int 1) - then Normalise(cstr,prf) - else - if 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 }, - - 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 *) - -exception FoundProof of prf_rule + let xpivot cv1 cv2 = + ( + {coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2) ; + op = opAdd op1 op2 ; + cst = n1 */ cv1 +/ n2 */ cv2 }, + + AddPrf(mul_cst_proof cv1 p1,mul_cst_proof cv2 p2)) in + + match Vect.get v v1 , Vect.get v v2 with + | Int 0 , _ | _ , Int 0 -> None + | a , 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 *) + 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_int_sat (c,p) with + | Tauto -> acc + | Unsat prf -> raise (FoundProof prf) + | Cut(c,p) -> (c,p)::acc + | Normalise (c,p) -> (c,p)::acc) [] sys (** [ext_gcd a b] is the extended Euclid algorithm. [ext_gcd a b = (x,y,g)] iff [ax+by=g] Source: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm -*) + *) let rec ext_gcd a b = - if 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'))) - -exception Result of (int * (proof * cstr_compat)) - -let split_equations psys = - List.partition (fun (c,p) -> c.op == Eq) - + 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 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 + if c1.op == Eq && c2.op == Eq + then Vect.exists2 (fun n1 n2 -> + Int.equal (compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int) 0) + 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 +let extract_coprime_equation psys = + extract2 extract_coprime psys -let apply_and_normalise f psys = - List.fold_left (fun acc pc' -> - match f pc' with - | None -> pc'::acc - | Some pc' -> - match check_sat pc' with - | Tauto -> acc - | Unsat prf -> raise (FoundProof prf) - | Cut(c,p) -> (c,p)::acc - | Normalise (c,p) -> (c,p)::acc - ) [] psys -let pivot_sys v pc psys = apply_and_normalise (pivot v pc) psys +let pivot_sys v pc psys = apply_and_normalise check_int_sat (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_cst_proof l1' p1) (mul_cst_proof l2' p2) in + + Some (pivot_sys v (cstr,prf) ((c1,p1)::sys)) (** If there is an equation [eq] of the form 1.x + e = c, do a pivot over x with equation [eq] *) let reduce_unary psys = - let is_unary_equation (cstr,prf) = - if cstr.op == Eq - then - try - Some (fst (List.find (fun (_,n) -> n =/ (Int 1) || n=/ (Int (-1))) cstr.coeffs)) - with Not_found -> None - else None in - - let (oeq,sys) = extract is_unary_equation psys in - match oeq with - | None -> None (* Nothing to do *) - | Some(v,pc) -> - Some(pivot_sys v pc sys) - -let reduce_non_lin_unary psys = - - let is_unary_equation (cstr,prf) = - if cstr.op == Eq - then - try - let x = fst (List.find (fun (x,n) -> (n =/ (Int 1) || n=/ (Int (-1))) && Monomial.is_var (LinPoly.MonT.retrieve x) ) cstr.coeffs) in - let x' = LinPoly.MonT.retrieve x in - if List.for_all (fun (y,_) -> 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 + Vect.find (fun v n -> if n =/ (Int 1) || n=/ (Int (-1)) then Some v else None) cstr.coeffs + 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_var_change psys = - let rec rel_prime vect = - match vect with - | [] -> None - | (x,v)::vect -> - let v = numerator v in - try - let (x',v') = List.find (fun (_,v') -> - let v' = numerator v' in - eq_big_int (gcd_big_int v v') unit_big_int) vect in - Some ((x,v),(x',numerator v')) - with Not_found -> rel_prime vect in - - let rel_prime (cstr,prf) = if cstr.op == Eq then rel_prime cstr.coeffs else None in - - let (oeq,sys) = extract rel_prime psys in - - match oeq with - | None -> None - | Some(((x,v),(x',v')),(c,p)) -> - let (l1,l2) = ext_gcd v v' in - let l1,l2 = Big_int l1 , Big_int l2 in - - let get v vect = - match Vect.get v vect with - | None -> Int 0 - | Some n -> n in - - let pivot_eq (c',p') = - let {coeffs = coeffs ; op = op ; cst = cst} = c' in - let vx = get x coeffs in - let vx' = get x' coeffs in - let m = minus_num (vx */ l1 +/ vx' */ l2) in - Some ({coeffs = - Vect.add (Vect.mul m c.coeffs) coeffs ; op = op ; cst = m */ c.cst +/ cst} , - AddPrf(MulC(([], m),p),p')) in - - Some (apply_and_normalise pivot_eq sys) - - - - -let reduce_pivot psys = - let is_equation (cstr,prf) = - if cstr.op == Eq - then - try - Some (fst (List.hd cstr.coeffs)) - with Not_found -> None - else None in - let (oeq,sys) = extract is_equation psys in - match oeq with - | None -> None (* Nothing to do *) - | Some(v,pc) -> - if debug then - Printf.printf "Bad news : loss of completeness %a=%s" Vect.pp_vect (fst pc).coeffs (string_of_num (fst pc).cst); - Some(pivot_sys v pc sys) + let rec rel_prime vect = + match Vect.choose vect with + | None -> None + | Some(x,v,vect) -> + let v = numerator v in + match Vect.find (fun x' v' -> + let v' = numerator v' in + if eq_big_int (gcd_big_int v v') unit_big_int + then Some(x',v') else None) vect with + | Some(x',v') -> Some ((x,v),(x', v')) + | None -> 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 pivot_eq (c',p') = + let {coeffs = coeffs ; op = op ; cst = cst} = c' in + let vx = Vect.get x coeffs in + let vx' = Vect.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((LinPoly.constant m),p),p')) in -let iterate_until_stable f x = - let rec iter x = - match f x with - | None -> x - | Some x' -> iter x' in - iter x + Some (apply_and_normalise check_int_sat pivot_eq sys) -let rec app_funs l x = - match l with - | [] -> None - | f::fl -> - match f x with - | None -> app_funs fl x - | Some x' -> Some x' let reduction_equations psys = - iterate_until_stable (app_funs - [reduce_unary ; reduce_coprime ; - reduce_var_change (*; reduce_pivot*)]) psys + 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 *) +(** [get_bound sys] returns upon success an interval (lb,e,ub) with proofs *) let get_bound sys = - let is_small (v,i) = - match Itv.range i with - | None -> false - | Some i -> i <=/ (Int 1) in - - let select_best (x1,i1) (x2,i2) = - if Itv.smaller_itv i1 i2 - then (x1,i1) else (x2,i2) in - - (* For lia, there are no equations => these precautions are not needed *) - (* For nlia, there are equations => do not enumerate over equations! *) - let all_planes sys = - let (eq,ineq) = List.partition (fun c -> c.op == Eq) sys in - match eq with - | [] -> List.rev_map (fun c -> c.coeffs) ineq - | _ -> - List.fold_left (fun acc c -> - if List.exists (fun c' -> Vect.equal c.coeffs c'.coeffs) eq - then acc else c.coeffs ::acc) [] ineq in - - let smallest_interval = - List.fold_left - (fun acc vect -> - if is_small acc - then acc - else - match Fourier.optimise vect sys with - | None -> acc - | Some i -> - if debug then Printf.printf "Found a new bound %a" Vect.pp_vect vect ; - select_best (vect,i) acc) (Vect.null, (None,None)) (all_planes sys) in - let smallest_interval = - match smallest_interval - with - | (x,(Some i, Some j)) -> Some(i,x,j) - | x -> None (* This should not be possible *) - in - match smallest_interval with - | Some (lb,e,ub) -> - let (lbn,lbd) = (sub_big_int (numerator lb) unit_big_int, denominator lb) in - let (ubn,ubd) = (add_big_int unit_big_int (numerator ub) , denominator ub) in - (match - (* x <= ub -> x > ub *) - xlinear_prover ({coeffs = Vect.mul (Big_int ubd) e ; op = Ge ; cst = Big_int ubn} :: sys), - (* lb <= x -> lb > x *) - xlinear_prover - ({coeffs = Vect.mul (minus_num (Big_int lbd)) e ; op = Ge ; cst = minus_num (Big_int lbn)} :: sys) - with - | Some cub , Some clb -> Some(List.tl clb,(lb,e,ub), List.tl cub) - | _ -> failwith "Interval without proof" - ) - | None -> None + let 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 optimise vect sys with + | None -> acc + | Some i -> + if debug then Printf.printf "Found a new bound %a in %a" Vect.pp vect Itv.pp i; + 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 *) + direct_linear_prover ({coeffs = Vect.mul (Big_int ubd) e ; op = Ge ; cst = Big_int ubn} :: sys), + (* lb <= x -> lb > x *) + direct_linear_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 (Vect.to_list clb),(lb,e,ub), List.tl (Vect.to_list 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 + List.for_all (fun (c,p) -> Vect.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 -> if can_enum then enum_proof id sys else None - with FoundProof prf -> + let rec enum_proof (id:int) (sys:prf_sys) : ProofFormat.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 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 (env_of_list prf) (Vect.from_list prf1),e, + proof_of_farkas (env_of_list prf) (Vect.from_list 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) : ProofFormat.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_cstr 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 -> - (*Printf.printf "direct proof %a\n" output_proof prf ; *) - let env = mapi (fun _ i -> i) sys in - let prf = compile_proof env prf in - (*try + let id = 1 + (List.fold_left + (fun acc (_,r) -> max acc (ProofFormat.pr_rule_max_id r)) 0 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 env = CList.interval 0 (id - 1) in + if debug then begin + Printf.fprintf stdout "direct proof %a\n" output_proof prf; + flush stdout; + end; + 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 } - + *) Some prf + +let xlia_simplex env sys = + match Simplex.integer_solver sys with + | None -> None + | Some prf -> + (*let _ = ProofFormat.eval_proof (env_of_list env) prf in *) + + let id = 1 + (List.fold_left + (fun acc (_,r) -> max acc (ProofFormat.pr_rule_max_id r)) 0 sys) in + let env = CList.interval 0 (id - 1) in + Some (compile_proof env prf) + +let xlia env0 en red sys = + if !use_simplex then xlia_simplex env0 sys + else xlia en red sys + + +let dump_file = ref None + +let gen_bench (tac, prover) can_enum prfdepth sys = + let res = prover can_enum prfdepth sys in + (match !dump_file with + | None -> () + | Some file -> + begin + let o = open_out (Filename.temp_file ~temp_dir:(Sys.getcwd ()) file ".v") in + let sys = develop_constraints prfdepth z_spec sys in + Printf.fprintf o "Require Import ZArith Lia. Open Scope Z_scope.\n"; + Printf.fprintf o "Goal %a.\n" (LinPoly.pp_goal "Z") (List.map fst sys) ; + begin + match res with + | None -> + Printf.fprintf o "Proof.\n intros. Fail %s.\nAbort.\n" tac + | Some res -> + Printf.fprintf o "Proof.\n intros. %s.\nQed.\n" tac + end + ; + flush o ; + close_out o ; + end); + res 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 sys = develop_constraints prfdepth z_spec sys in + if debug then begin + Printf.fprintf stdout "Input problem\n"; + List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; + end; + let sys' = List.map (fun ((p,o),prf) -> (cstr_of_poly (p,o), prf)) sys in + xlia (List.map fst sys) can_enum reduction_equations sys' + +let make_cstr_system sys = + List.map (fun ((p,o),prf) -> (cstr_of_poly (p,o), prf)) 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 = develop_constraints prfdepth z_spec sys in + let is_linear = List.for_all (fun ((p,_),_) -> LinPoly.is_linear p) sys in + + if debug then begin + Printf.fprintf stdout "Input problem\n"; + List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; + end; + + if is_linear + then xlia (List.map fst sys) enum reduction_equations (make_cstr_system sys) + else + (* + let sys1 = elim_every_substitution sys in + No: if a wrong equation is chosen, the proof may fail. + It would only be safe if the variable is linear... + *) + let sys1 = elim_simple_linear_equality sys in + let sys2 = saturate_linear_equality_non_linear sys1 in + let sys3 = nlinear_preprocess (sys1@sys2) in + + let sys4 = make_cstr_system ((*sys2@*)sys3) in + (* [reduction_equations] is too brutal - there should be some non-linear reasoning *) + xlia (List.map fst sys) enum reduction_equations sys4 + +(* For regression testing, if bench = true generate a Coq goal *) + +let lia can_enum prfdepth sys = + gen_bench ("lia",lia) can_enum prfdepth sys + +let nlia enum prfdepth sys = + gen_bench ("nia",nlia) enum prfdepth sys + - 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/certificate.mli b/plugins/micromega/certificate.mli new file mode 100644 index 0000000000..e925f1bc5e --- /dev/null +++ b/plugins/micromega/certificate.mli @@ -0,0 +1,42 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +module Mc = Micromega + + +(** [use_simplex] is bound to the Coq option Simplex. + If set, use the Simplex method, otherwise use Fourier *) +val use_simplex : bool ref + +(** [dump_file] is bound to the Coq option Dump Arith. + If set to some [file], arithmetic goals are dumped in filexxx.v *) +val dump_file : string option ref + +(** [q_cert_of_pos prf] converts a Sos proof into a rational Coq proof *) +val q_cert_of_pos : Sos_types.positivstellensatz -> Mc.q Mc.psatz + +(** [z_cert_of_pos prf] converts a Sos proof into an integer Coq proof *) +val z_cert_of_pos : Sos_types.positivstellensatz -> Mc.z Mc.psatz + +(** [lia enum depth sys] generates an unsat proof for the linear constraints in [sys]. + If the Simplex option is set, any failure to find a proof should be considered as a bug. *) +val lia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> Mc.zArithProof option + +(** [nlia enum depth sys] generates an unsat proof for the non-linear constraints in [sys]. + The solver is incomplete -- the problem is undecidable *) +val nlia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> Mc.zArithProof option + +(** [linear_prover_with_cert depth sys] generates an unsat proof for the linear constraints in [sys]. + Over the rationals, the solver is complete. *) +val linear_prover_with_cert : int -> (Mc.q Mc.pExpr * Mc.op1) list -> Mc.q Micromega.psatz option + +(** [nlinear depth sys] generates an unsat proof for the non-linear constraints in [sys]. + The solver is incompete -- the problem is decidable. *) +val nlinear_prover : int -> (Mc.q Mc.pExpr * Mc.op1) list -> Mc.q Mc.psatz option diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 168105e8fd..402e8b91e6 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -12,17 +12,18 @@ (* *) (* ** Toplevel definition of tactics ** *) (* *) -(* - Modules ISet, M, Mc, Env, Cache, CacheZ *) +(* - Modules M, Mc, Env, Cache, CacheZ *) (* *) (* Frédéric Besson (Irisa/Inria) 2006-20011 *) (* *) (************************************************************************) open Pp -open Mutils -open Goptions open Names +open Goptions +open Mutils open Constr +open Tactypes (** * Debug flag @@ -30,19 +31,6 @@ open Constr let debug = false -(** - * Time function - *) - -let time str f x = - let t0 = (Unix.times()).Unix.tms_utime in - let res = f x in - let t1 = (Unix.times()).Unix.tms_utime in - (*if debug then*) (Printf.printf "time %s %f\n" str (t1 -. t0) ; - flush stdout); - res - - (* Limit the proof search *) let max_depth = max_int @@ -56,7 +44,7 @@ let lia_enum = ref true let lia_proof_depth = ref max_depth let get_lia_option () = - (!lia_enum,!lia_proof_depth) + (!Certificate.use_simplex,!lia_enum,!lia_proof_depth) let get_lra_option () = !lra_proof_depth @@ -82,10 +70,32 @@ let _ = optread = (fun () -> !lia_enum); optwrite = (fun x -> lia_enum := x) } in + + let solver_opt = + { + optdepr = false; + optname = "Use the Simplex instead of Fourier elimination"; + optkey = ["Simplex"]; + optread = (fun () -> !Certificate.use_simplex); + optwrite = (fun x -> Certificate.use_simplex := x) + } in + + let dump_file_opt = + { + optdepr = false; + optname = "Generate Coq goals in file from calls to 'lia' 'nia'"; + optkey = ["Dump"; "Arith"]; + optread = (fun () -> !Certificate.dump_file); + optwrite = (fun x -> Certificate.dump_file := x) + } in + + let _ = declare_bool_option solver_opt in + let _ = declare_stringopt_option dump_file_opt 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). @@ -300,13 +310,7 @@ let rec add_term t0 = function xcnf true f -(** - * MODULE: Ordered set of integers. - *) -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. @@ -353,6 +357,8 @@ struct ["Coq";"Reals" ; "Rpow_def"]; ["LRing_normalise"]] +[@@@ocaml.warning "-3"] + let coq_modules = Coqlib.(init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules @ mic_modules) @@ -373,8 +379,10 @@ struct * ZMicromega.v *) - let gen_constant_in_modules s m n = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.gen_reference_in_modules s m n) + let gen_constant_in_modules s m n = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules s m n) let init_constant = gen_constant_in_modules "ZMicromega" Coqlib.init_modules + [@@@ocaml.warning "+3"] + let constant = gen_constant_in_modules "ZMicromega" coq_modules let bin_constant = gen_constant_in_modules "ZMicromega" bin_module let r_constant = gen_constant_in_modules "ZMicromega" r_modules @@ -395,16 +403,10 @@ struct let coq_O = lazy (init_constant "O") let coq_S = lazy (init_constant "S") - let coq_nat = lazy (init_constant "nat") let coq_N0 = lazy (bin_constant "N0") let coq_Npos = lazy (bin_constant "Npos") - let coq_pair = lazy (init_constant "pair") - let coq_None = lazy (init_constant "None") - let coq_option = lazy (init_constant "option") - - let coq_positive = lazy (bin_constant "positive") let coq_xH = lazy (bin_constant "xH") let coq_xO = lazy (bin_constant "xO") let coq_xI = lazy (bin_constant "xI") @@ -417,8 +419,6 @@ struct let coq_Q = lazy (constant "Q") let coq_R = lazy (constant "R") - let coq_Build_Witness = lazy (constant "Build_Witness") - let coq_Qmake = lazy (constant "Qmake") let coq_Rcst = lazy (constant "Rcst") @@ -455,8 +455,6 @@ struct let coq_Zmult = lazy (z_constant "Z.mul") let coq_Zpower = lazy (z_constant "Z.pow") - let coq_Qgt = lazy (constant "Qgt") - let coq_Qge = lazy (constant "Qge") let coq_Qle = lazy (constant "Qle") let coq_Qlt = lazy (constant "Qlt") let coq_Qeq = lazy (constant "Qeq") @@ -476,7 +474,6 @@ struct let coq_Rminus = lazy (r_constant "Rminus") let coq_Ropp = lazy (r_constant "Ropp") let coq_Rmult = lazy (r_constant "Rmult") - let coq_Rdiv = lazy (r_constant "Rdiv") let coq_Rinv = lazy (r_constant "Rinv") let coq_Rpower = lazy (r_constant "pow") let coq_IZR = lazy (r_constant "IZR") @@ -509,12 +506,6 @@ struct let coq_PsatzAdd = lazy (constant "PsatzAdd") let coq_PsatzC = lazy (constant "PsatzC") let coq_PsatzZ = lazy (constant "PsatzZ") - let coq_coneMember = lazy (constant "coneMember") - - let coq_make_impl = lazy - (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_impl") - let coq_make_conj = lazy - (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_conj") let coq_TT = lazy (gen_constant_in_modules "ZMicromega" @@ -552,13 +543,6 @@ struct let coq_QWitness = lazy (gen_constant_in_modules "QMicromega" [["Coq"; "micromega"; "QMicromega"]] "QWitness") - let coq_ZWitness = lazy - (gen_constant_in_modules "QMicromega" - [["Coq"; "micromega"; "ZMicromega"]] "ZWitness") - - let coq_N_of_Z = lazy - (gen_constant_in_modules "ZArithRing" - [["Coq";"setoid_ring";"ZArithRing"]] "N_of_Z") let coq_Build = lazy (gen_constant_in_modules "RingMicromega" @@ -577,34 +561,16 @@ struct * pp_* functions pretty-print Coq terms. *) - (* Error datastructures *) - - type parse_error = - | Ukn - | BadStr of string - | BadNum of int - | BadTerm of constr - | Msg of string - | Goal of (constr list ) * constr * parse_error - - let string_of_error = function - | Ukn -> "ukn" - | BadStr s -> s - | BadNum i -> string_of_int i - | BadTerm _ -> "BadTerm" - | Msg s -> s - | Goal _ -> "Goal" - exception ParseError (* A simple but useful getter function *) let get_left_construct sigma term = match EConstr.kind sigma term with - | Term.Construct((_,i),_) -> (i,[| |]) - | Term.App(l,rst) -> + | Construct((_,i),_) -> (i,[| |]) + | App(l,rst) -> (match EConstr.kind sigma l with - | Term.Construct((_,i),_) -> (i,rst) + | Construct((_,i),_) -> (i,rst) | _ -> raise ParseError ) | _ -> raise ParseError @@ -648,19 +614,6 @@ struct | Mc.N0 -> Lazy.force coq_N0 | Mc.Npos p -> EConstr.mkApp(Lazy.force coq_Npos,[| dump_positive p|]) - let rec dump_index x = - match x with - | Mc.XH -> Lazy.force coq_xH - | Mc.XO p -> EConstr.mkApp(Lazy.force coq_xO,[| dump_index p |]) - | Mc.XI p -> EConstr.mkApp(Lazy.force coq_xI,[| dump_index p |]) - - let pp_index o x = Printf.fprintf o "%i" (CoqToCaml.index x) - - let pp_n o x = output_string o (string_of_int (CoqToCaml.n x)) - - let dump_pair t1 t2 dump_t1 dump_t2 (x,y) = - EConstr.mkApp(Lazy.force coq_pair,[| t1 ; t2 ; dump_t1 x ; dump_t2 y|]) - let parse_z sigma term = let (i,c) = get_left_construct sigma term in match i with @@ -677,18 +630,13 @@ struct let pp_z o x = Printf.fprintf o "%s" (Big_int.string_of_big_int (CoqToCaml.z_big_int x)) - let dump_num bd1 = - EConstr.mkApp(Lazy.force coq_Qmake, - [|dump_z (CamlToCoq.bigint (numerator bd1)) ; - dump_positive (CamlToCoq.positive_big_int (denominator bd1)) |]) - let dump_q q = EConstr.mkApp(Lazy.force coq_Qmake, [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|]) let parse_q sigma term = match EConstr.kind sigma term with - | Term.App(c, args) -> if EConstr.eq_constr sigma c (Lazy.force coq_Qmake) then + | App(c, args) -> if EConstr.eq_constr sigma c (Lazy.force coq_Qmake) then {Mc.qnum = parse_z sigma args.(0) ; Mc.qden = parse_positive sigma args.(1) } else raise ParseError | _ -> raise ParseError @@ -719,29 +667,6 @@ struct | Mc.CInv t -> EConstr.mkApp(Lazy.force coq_CInv, [| dump_Rcst t |]) | Mc.COpp t -> EConstr.mkApp(Lazy.force coq_COpp, [| dump_Rcst t |]) - let rec parse_Rcst sigma term = - let (i,c) = get_left_construct sigma term in - match i with - | 1 -> Mc.C0 - | 2 -> Mc.C1 - | 3 -> Mc.CQ (parse_q sigma c.(0)) - | 4 -> Mc.CPlus(parse_Rcst sigma c.(0), parse_Rcst sigma c.(1)) - | 5 -> Mc.CMinus(parse_Rcst sigma c.(0), parse_Rcst sigma c.(1)) - | 6 -> Mc.CMult(parse_Rcst sigma c.(0), parse_Rcst sigma c.(1)) - | 7 -> Mc.CInv(parse_Rcst sigma c.(0)) - | 8 -> Mc.COpp(parse_Rcst sigma c.(0)) - | _ -> raise ParseError - - - - - let rec parse_list sigma parse_elt term = - let (i,c) = get_left_construct sigma term in - match i with - | 1 -> [] - | 2 -> parse_elt sigma c.(1) :: parse_list sigma parse_elt c.(2) - | i -> raise ParseError - let rec dump_list typ dump_elt l = match l with | [] -> EConstr.mkApp(Lazy.force coq_nil,[| typ |]) @@ -756,22 +681,8 @@ struct | e::l -> Printf.fprintf o "%a ,%a" elt e _pp l in Printf.fprintf o "%s%a%s" op _pp l cl - let pp_var = pp_positive - let dump_var = dump_positive - let pp_expr pp_z o e = - let rec pp_expr o e = - match e with - | Mc.PEX n -> Printf.fprintf o "V %a" pp_var n - | Mc.PEc z -> pp_z o z - | Mc.PEadd(e1,e2) -> Printf.fprintf o "(%a)+(%a)" pp_expr e1 pp_expr e2 - | Mc.PEmul(e1,e2) -> Printf.fprintf o "%a*(%a)" pp_expr e1 pp_expr e2 - | Mc.PEopp e -> Printf.fprintf o "-(%a)" pp_expr e - | Mc.PEsub(e1,e2) -> Printf.fprintf o "(%a)-(%a)" pp_expr e1 pp_expr e2 - | Mc.PEpow(e,n) -> Printf.fprintf o "(%a)^(%a)" pp_expr e pp_n n in - pp_expr o e - let dump_expr typ dump_z e = let rec dump_expr e = match e with @@ -854,18 +765,6 @@ struct | Mc.OpGt-> Lazy.force coq_OpGt | Mc.OpLt-> Lazy.force coq_OpLt - let pp_op o e= - match e with - | Mc.OpEq-> Printf.fprintf o "=" - | Mc.OpNEq-> Printf.fprintf o "<>" - | Mc.OpLe -> Printf.fprintf o "=<" - | Mc.OpGe -> Printf.fprintf o ">=" - | Mc.OpGt-> Printf.fprintf o ">" - | Mc.OpLt-> Printf.fprintf o "<" - - let pp_cstr pp_z o {Mc.flhs = l ; Mc.fop = op ; Mc.frhs = r } = - Printf.fprintf o"(%a %a %a)" (pp_expr pp_z) l pp_op op (pp_expr pp_z) r - let dump_cstr typ dump_constant {Mc.flhs = e1 ; Mc.fop = o ; Mc.frhs = e2} = EConstr.mkApp(Lazy.force coq_Build, [| typ; dump_expr typ dump_constant e1 ; @@ -904,8 +803,8 @@ struct let parse_zop gl (op,args) = let sigma = gl.sigma in match EConstr.kind sigma op with - | Term.Const (x,_) -> (assoc_const sigma op zop_table, args.(0) , args.(1)) - | Term.Ind((n,0),_) -> + | Const (x,_) -> (assoc_const sigma op zop_table, args.(0) , args.(1)) + | Ind((n,0),_) -> if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_Z) then (Mc.OpEq, args.(1), args.(2)) else raise ParseError @@ -914,8 +813,8 @@ struct let parse_rop gl (op,args) = let sigma = gl.sigma in match EConstr.kind sigma op with - | Term.Const (x,_) -> (assoc_const sigma op rop_table, args.(0) , args.(1)) - | Term.Ind((n,0),_) -> + | Const (x,_) -> (assoc_const sigma op rop_table, args.(0) , args.(1)) + | Ind((n,0),_) -> if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_R) then (Mc.OpEq, args.(1), args.(2)) else raise ParseError @@ -924,11 +823,6 @@ struct let parse_qop gl (op,args) = (assoc_const gl.sigma op qop_table, args.(0) , args.(1)) - let is_constant sigma t = (* This is an approx *) - match EConstr.kind sigma t with - | Term.Construct(i,_) -> true - | _ -> false - type 'a op = | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr) | Opp @@ -947,8 +841,6 @@ struct module Env = struct - type t = EConstr.constr list - let compute_rank_add env sigma v = let rec _add env n v = match env with @@ -1011,10 +903,10 @@ struct try (Mc.PEc (parse_constant term) , env) with ParseError -> match EConstr.kind sigma term with - | Term.App(t,args) -> + | App(t,args) -> ( match EConstr.kind sigma t with - | Term.Const c -> + | Const c -> ( match assoc_ops sigma t ops_spec with | Binop f -> combine env f (args.(0),args.(1)) | Opp -> let (expr,env) = parse_expr env args.(0) in @@ -1077,13 +969,13 @@ struct let rec rconstant sigma term = match EConstr.kind sigma term with - | Term.Const x -> + | Const x -> if EConstr.eq_constr sigma term (Lazy.force coq_R0) then Mc.C0 else if EConstr.eq_constr sigma term (Lazy.force coq_R1) then Mc.C1 else raise ParseError - | Term.App(op,args) -> + | App(op,args) -> begin try (* the evaluation order is important in the following *) @@ -1153,7 +1045,7 @@ struct if debug then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.pr_leconstr_env gl.env sigma cstr ++ fnl ()); match EConstr.kind sigma cstr with - | Term.App(op,args) -> + | App(op,args) -> let (op,lhs,rhs) = parse_op gl (op,args) in let (e1,env) = parse_expr sigma env lhs in let (e2,env) = parse_expr sigma env rhs in @@ -1168,17 +1060,6 @@ struct (* generic parsing of arithmetic expressions *) - let rec f2f = function - | TT -> Mc.TT - | FF -> Mc.FF - | X _ -> Mc.X - | A (x,_,_) -> Mc.A x - | C (a,b) -> Mc.Cj(f2f a,f2f b) - | D (a,b) -> Mc.D(f2f a,f2f b) - | N (a) -> Mc.N(f2f a) - | I(a,_,b) -> Mc.I(f2f a,f2f b) - - let mkC f1 f2 = C(f1,f2) let mkD f1 f2 = D(f1,f2) let mkIff f1 f2 = C(I(f1,None,f2),I(f2,None,f1)) @@ -1208,7 +1089,7 @@ struct let rec xparse_formula env tg term = match EConstr.kind sigma term with - | Term.App(l,rst) -> + | App(l,rst) -> (match rst with | [|a;b|] when EConstr.eq_constr sigma l (Lazy.force coq_and) -> let f,env,tg = xparse_formula env tg a in @@ -1225,7 +1106,7 @@ struct let g,env,tg = xparse_formula env tg b in mkformula_binary mkIff term f g,env,tg | _ -> parse_atom env tg term) - | Term.Prod(typ,a,b) when EConstr.Vars.noccurn sigma 1 b -> + | Prod(typ,a,b) when EConstr.Vars.noccurn sigma 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 @@ -1323,31 +1204,6 @@ let dump_qexpr = lazy 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 = EConstr.mkApp(add,[|x;y|]) in - let mk_mult x y = EConstr.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 @@ -1481,54 +1337,6 @@ end (** open M -let rec sig_of_cone = function - | Mc.PsatzIn n -> [CoqToCaml.nat n] - | Mc.PsatzMulE(w1,w2) -> (sig_of_cone w1)@(sig_of_cone w2) - | Mc.PsatzMulC(w1,w2) -> (sig_of_cone w2) - | Mc.PsatzAdd(w1,w2) -> (sig_of_cone w1)@(sig_of_cone w2) - | _ -> [] - -let same_proof sg cl1 cl2 = - let rec xsame_proof sg = - match sg with - | [] -> true - | n::sg -> - (try Int.equal (List.nth cl1 n) (List.nth cl2 n) with Invalid_argument _ -> false) - && (xsame_proof sg ) in - xsame_proof sg - -let tags_of_clause tgs wit clause = - let rec xtags tgs = function - | Mc.PsatzIn n -> Names.Id.Set.union tgs - (snd (List.nth clause (CoqToCaml.nat n) )) - | Mc.PsatzMulC(e,w) -> xtags tgs w - | Mc.PsatzMulE (w1,w2) | Mc.PsatzAdd(w1,w2) -> xtags (xtags tgs w1) w2 - | _ -> tgs in - xtags tgs wit - -(*let tags_of_cnf wits cnf = - List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl) - Names.Id.Set.empty wits cnf *) - -let find_witness prover polys1 = try_any prover polys1 - -let rec witness prover l1 l2 = - match l2 with - | [] -> Some [] - | e :: l2 -> - match find_witness prover (e::l1) with - | None -> None - | Some w -> - (match witness prover l1 l2 with - | None -> None - | Some l -> Some (w::l) - ) - -let rec apply_ids t ids = - match ids with - | [] -> t - | i::ids -> apply_ids (mkApp(t,[| mkVar i |])) ids - let coq_Node = lazy (gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node") @@ -1559,15 +1367,6 @@ let vm_of_list env = 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 = - match vm with - | Mc.Empty -> output_string o "[]" - | Mc.Leaf z -> Printf.fprintf o "[%a]" pp_z z - | Mc.Node(l,z,r) -> Printf.fprintf o "[%a, %a, %a]" pp_varmap l pp_z z pp_varmap r - - - let rec dump_proof_term = function | Micromega.DoneProof -> Lazy.force coq_doneProof | Micromega.RatProof(cone,rst) -> @@ -1662,45 +1461,11 @@ let qq_domain_spec = lazy { dump_proof = dump_psatz coq_Q dump_q } -let rcst_domain_spec = lazy { - typ = Lazy.force coq_R; - coeff = Lazy.force coq_Rcst; - dump_coeff = dump_Rcst; - proof_typ = Lazy.force coq_QWitness ; - dump_proof = dump_psatz coq_Q dump_q -} - (** 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 (fun c t -> Termops.dependent Evd.empty (** FIXME *) (EConstr.of_constr c) (EConstr.of_constr t)) l - - (** * Instanciate the current Coq goal with a Micromega formula, a varmap, and a * witness. @@ -1712,7 +1477,7 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in 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 begin fun gl -> + Proofview.Goal.enter begin fun gl -> Tacticals.New.tclTHENLIST [ Tactics.change_concl @@ -1778,13 +1543,6 @@ let witness_list prover l = let witness_list_tags = witness_list -(* *Deprecated* let is_singleton = function [] -> true | [e] -> true | _ -> false *) - -let pp_ml_list pp_elt o l = - output_string o "[" ; - List.iter (fun x -> Printf.fprintf o "%a ;" pp_elt x) l ; - output_string o "]" - (** * Prune the proof object, according to the 'diff' between two cnf formulas. *) @@ -1792,7 +1550,7 @@ let pp_ml_list pp_elt o l = let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = - let new_cl = Mutils.mapi (fun (f,_) i -> (f,i)) new_cl in + let new_cl = List.mapi (fun i (f,_) -> (f,i)) new_cl in let remap i = let formula = try fst (List.nth old_cl i) with Failure _ -> failwith "bad old index" in List.assoc formula new_cl in @@ -1972,7 +1730,7 @@ let micromega_gen (normalise:'cst atom -> 'cst mc_cnf) unsat deduce spec dumpexpr prover tac = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let concl = Tacmach.New.pf_concl gl in let hyps = Tacmach.New.pf_hyps_types gl in @@ -1991,7 +1749,7 @@ let micromega_gen 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 (CAst.make @@ Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in + let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in @@ -2050,7 +1808,7 @@ let micromega_order_changer cert env ff = let formula_typ = (EConstr.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 begin fun gl -> + Proofview.Goal.enter begin fun gl -> Tacticals.New.tclTHENLIST [ (Tactics.change_concl @@ -2080,7 +1838,7 @@ let micromega_genr prover tac = proof_typ = Lazy.force coq_QWitness ; dump_proof = dump_psatz coq_Q dump_q } in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let concl = Tacmach.New.pf_concl gl in let hyps = Tacmach.New.pf_hyps_types gl in @@ -2106,7 +1864,7 @@ let micromega_genr prover tac = 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 (CAst.make @@ Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in + let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in @@ -2158,7 +1916,11 @@ let lift_ratproof prover l = | Some c -> Some (Mc.RatProof( c,Mc.DoneProof)) type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list + +[@@@ocaml.warning "-37"] type csdp_certificate = S of Sos_types.positivstellensatz option | F of string +(* Used to read the result of the execution of csdpcert *) + type provername = string * int option (** @@ -2196,7 +1958,9 @@ let really_call_csdpcert : provername -> micromega_polys -> Sos_types.positivste ["plugins"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] in match ((command cmdname [|cmdname|] (provername,poly)) : csdp_certificate) with - | F str -> failwith str + | F str -> + if debug then Printf.fprintf stdout "really_call_csdpcert : %s\n" str; + raise (failwith str) | S res -> res (** @@ -2306,7 +2070,7 @@ let compact_pt pt f = let lift_pexpr_prover p l = p (List.map (fun (e,o) -> Mc.denorm e , o) l) module CacheZ = PHashtable(struct - type prover_option = bool * int + type prover_option = bool * bool* int type t = prover_option * ((Mc.z Mc.pol * Mc.op1) list) let equal = (=) @@ -2319,8 +2083,8 @@ module CacheQ = PHashtable(struct 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_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) @@ -2328,7 +2092,7 @@ let memo_nra = CacheQ.memo ".nra.cache" (fun (o,s) -> lift_pexpr_prover (Certifi let linear_prover_Q = { 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) ; + prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o ) l) ; hyps = hyps_of_cone ; compact = compact_cone ; pp_prf = pp_psatz pp_q ; @@ -2339,7 +2103,7 @@ let linear_prover_Q = { let linear_prover_R = { 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) ; + prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o ) l) ; hyps = hyps_of_cone ; compact = compact_cone ; pp_prf = pp_psatz pp_q ; @@ -2406,16 +2170,6 @@ let nlinear_Z = { pp_f = fun o x -> pp_pol pp_z o (fst x) } - - -let tauto_lia ff = - let prover = linear_Z in - let cnf_ff,_ = cnf Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce ff in - match witness_list_tags [prover] cnf_ff with - | None -> None - | Some l -> Some (List.map fst l) - - (** * Functions instantiating micromega_gen with the appropriate theories and * solvers diff --git a/plugins/micromega/coq_micromega.mli b/plugins/micromega/coq_micromega.mli new file mode 100644 index 0000000000..b91feb3984 --- /dev/null +++ b/plugins/micromega/coq_micromega.mli @@ -0,0 +1,22 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val psatz_Z : int -> unit Proofview.tactic -> unit Proofview.tactic +val psatz_Q : int -> unit Proofview.tactic -> unit Proofview.tactic +val psatz_R : int -> unit Proofview.tactic -> unit Proofview.tactic +val xlia : unit Proofview.tactic -> unit Proofview.tactic +val xnlia : unit Proofview.tactic -> unit Proofview.tactic +val nra : unit Proofview.tactic -> unit Proofview.tactic +val nqa : unit Proofview.tactic -> unit Proofview.tactic +val sos_Z : unit Proofview.tactic -> unit Proofview.tactic +val sos_Q : unit Proofview.tactic -> unit Proofview.tactic +val sos_R : unit Proofview.tactic -> unit Proofview.tactic +val lra_Q : unit Proofview.tactic -> unit Proofview.tactic +val lra_R : unit Proofview.tactic -> unit Proofview.tactic diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml index a1245b7cc3..9c1b4810d5 100644 --- a/plugins/micromega/csdpcert.ml +++ b/plugins/micromega/csdpcert.ml @@ -20,7 +20,6 @@ open Sos_types open Sos_lib module Mc = Micromega -module Ml2C = Mutils.CamlToCoq module C2Ml = Mutils.CoqToCaml type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list @@ -28,7 +27,6 @@ type csdp_certificate = S of Sos_types.positivstellensatz option | F of string type provername = string * int option -let debug = false let flags = [Open_append;Open_binary;Open_creat] let chan = open_out_gen flags 0o666 "trace" @@ -55,27 +53,6 @@ struct end open M -open Mutils - - - - -let canonical_sum_to_string = function s -> failwith "not implemented" - -let print_canonical_sum m = Format.print_string (canonical_sum_to_string m) - -let print_list_term o l = - output_string o "print_list_term\n"; - List.iter (fun (e,k) -> Printf.fprintf o "q: %s %s ;" - (string_of_poly (poly_of_term (expr_to_term e))) - (match k with - Mc.Equal -> "= " - | Mc.Strict -> "> " - | Mc.NonStrict -> ">= " - | _ -> failwith "not_implemented")) (List.map (fun (e, o) -> Mc.denorm e , o) l) ; - output_string o "\n" - - let partition_expr l = let rec f i = function | [] -> ([],[],[]) @@ -125,7 +102,7 @@ let real_nonlinear_prover d l = (sets_of_list neq) in let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d -> - list_try_find (fun m -> let (ci,cc) = + tryfind (fun m -> let (ci,cc) = real_positivnullstellensatz_general false d peq pge (poly_neg (fst m) ) in (ci,cc,snd m)) monoids) 0 in @@ -144,7 +121,7 @@ let real_nonlinear_prover d l = | l -> Monoid l in List.fold_right (fun x y -> Product(x,y)) lt sq in - let proof = list_fold_right_elements + let proof = end_itlist (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in S (Some proof) with @@ -158,7 +135,7 @@ let pure_sos l = (* If there is no strict inequality, I should nonetheless be able to try something - over Z > is equivalent to -1 >= *) try - let l = List.combine l (interval 0 (List.length l -1)) in + let l = List.combine l (CList.interval 0 (List.length l -1)) in let (lt,i) = try (List.find (fun (x,_) -> Pervasives.(=) (snd x) Mc.Strict) l) with Not_found -> List.hd l in let plt = poly_neg (poly_of_term (expr_to_term (fst lt))) in @@ -183,13 +160,6 @@ let run_prover prover pb = | "pure_sos", None -> pure_sos pb | prover, _ -> (Printf.printf "unknown prover: %s\n" prover; exit 1) - -let output_csdp_certificate o = function - | S None -> output_string o "S None" - | S (Some p) -> Printf.fprintf o "S (Some %a)" output_psatz p - | F s -> Printf.fprintf o "F %s" s - - let main () = try let (prover,poly) = (input_value stdin : provername * micromega_polys) in diff --git a/plugins/micromega/csdpcert.mli b/plugins/micromega/csdpcert.mli new file mode 100644 index 0000000000..7c3ee60040 --- /dev/null +++ b/plugins/micromega/csdpcert.mli @@ -0,0 +1,9 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.mlg index 81140a46a9..21f0414e9c 100644 --- a/plugins/micromega/g_micromega.ml4 +++ b/plugins/micromega/g_micromega.mlg @@ -16,70 +16,74 @@ (* *) (************************************************************************) +{ + open Ltac_plugin open Stdarg open Tacarg +} + DECLARE PLUGIN "micromega_plugin" TACTIC EXTEND RED -| [ "myred" ] -> [ Tactics.red_in_concl ] +| [ "myred" ] -> { Tactics.red_in_concl } END TACTIC EXTEND PsatzZ -| [ "psatz_Z" int_or_var(i) tactic(t) ] -> [ (Coq_micromega.psatz_Z i +| [ "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) ] + } +| [ "psatz_Z" tactic(t)] -> { (Coq_micromega.psatz_Z (-1)) (Tacinterp.tactic_of_value ist t) } END TACTIC EXTEND Lia -[ "xlia" tactic(t) ] -> [ (Coq_micromega.xlia (Tacinterp.tactic_of_value ist t)) ] +| [ "xlia" tactic(t) ] -> { (Coq_micromega.xlia (Tacinterp.tactic_of_value ist t)) } END TACTIC EXTEND Nia -[ "xnlia" tactic(t) ] -> [ (Coq_micromega.xnlia (Tacinterp.tactic_of_value ist t)) ] +| [ "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))] +| [ "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))] +| [ "xnqa" tactic(t) ] -> { (Coq_micromega.nqa (Tacinterp.tactic_of_value ist t))} END TACTIC EXTEND Sos_Z -| [ "sos_Z" tactic(t) ] -> [ (Coq_micromega.sos_Z (Tacinterp.tactic_of_value ist t)) ] +| [ "sos_Z" tactic(t) ] -> { (Coq_micromega.sos_Z (Tacinterp.tactic_of_value ist t)) } END TACTIC EXTEND Sos_Q -| [ "sos_Q" tactic(t) ] -> [ (Coq_micromega.sos_Q (Tacinterp.tactic_of_value ist t)) ] +| [ "sos_Q" tactic(t) ] -> { (Coq_micromega.sos_Q (Tacinterp.tactic_of_value ist t)) } END TACTIC EXTEND Sos_R -| [ "sos_R" tactic(t) ] -> [ (Coq_micromega.sos_R (Tacinterp.tactic_of_value ist t)) ] +| [ "sos_R" tactic(t) ] -> { (Coq_micromega.sos_R (Tacinterp.tactic_of_value ist t)) } END TACTIC EXTEND LRA_Q -[ "lra_Q" tactic(t) ] -> [ (Coq_micromega.lra_Q (Tacinterp.tactic_of_value ist t)) ] +| [ "lra_Q" tactic(t) ] -> { (Coq_micromega.lra_Q (Tacinterp.tactic_of_value ist t)) } END TACTIC EXTEND LRA_R -[ "lra_R" tactic(t) ] -> [ (Coq_micromega.lra_R (Tacinterp.tactic_of_value ist t)) ] +| [ "lra_R" tactic(t) ] -> { (Coq_micromega.lra_R (Tacinterp.tactic_of_value ist t)) } END TACTIC EXTEND PsatzR -| [ "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)) ] +| [ "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) 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)) ] +| [ "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/g_micromega.mli b/plugins/micromega/g_micromega.mli new file mode 100644 index 0000000000..7c3ee60040 --- /dev/null +++ b/plugins/micromega/g_micromega.mli @@ -0,0 +1,9 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) diff --git a/plugins/micromega/itv.ml b/plugins/micromega/itv.ml new file mode 100644 index 0000000000..dc1df7ec9f --- /dev/null +++ b/plugins/micromega/itv.ml @@ -0,0 +1,80 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Intervals (extracted from mfourier.ml) *) + +open Num + (** The type of intervals is *) + type interval = num option * num option + (** None models the absence of bound i.e. infinity *) + (** As a result, + - None , None -> \]-oo,+oo\[ + - None , Some v -> \]-oo,v\] + - Some v, None -> \[v,+oo\[ + - Some v, Some v' -> \[v,v'\] + Intervals needs to be explicitly normalised. + *) + + let pp o (n1,n2) = + (match n1 with + | None -> output_string o "]-oo" + | Some n -> Printf.fprintf o "[%s" (string_of_num n) + ); + output_string o ","; + (match n2 with + | None -> output_string o "+oo[" + | Some n -> Printf.fprintf o "%s]" (string_of_num n) + ) + + + + (** if then interval [itv] is empty, [norm_itv itv] returns [None] + otherwise, it returns [Some itv] *) + + let norm_itv itv = + match itv with + | Some a , Some b -> if a <=/ b then Some itv else None + | _ -> Some itv + +(** [inter i1 i2 = None] if the intersection of intervals is empty + [inter i1 i2 = Some i] if [i] is the intersection of the intervals [i1] and [i2] *) + let inter i1 i2 = + let (l1,r1) = i1 + and (l2,r2) = i2 in + + let inter f o1 o2 = + match o1 , o2 with + | None , None -> None + | Some _ , None -> o1 + | None , Some _ -> o2 + | Some n1 , Some n2 -> Some (f n1 n2) in + + norm_itv (inter max_num l1 l2 , inter min_num r1 r2) + + let range = function + | None,_ | _,None -> None + | Some i,Some j -> Some (floor_num j -/ceiling_num i +/ (Int 1)) + + + let smaller_itv i1 i2 = + match range i1 , range i2 with + | None , _ -> false + | _ , None -> true + | Some i , Some j -> i <=/ j + + +(** [in_bound bnd v] checks whether [v] is within the bounds [bnd] *) +let in_bound bnd v = + let (l,r) = bnd in + match l , r with + | None , None -> true + | None , Some a -> v <=/ a + | Some a , None -> a <=/ v + | Some a , Some b -> a <=/ v && v <=/ b diff --git a/plugins/micromega/itv.mli b/plugins/micromega/itv.mli new file mode 100644 index 0000000000..31f6a89fe2 --- /dev/null +++ b/plugins/micromega/itv.mli @@ -0,0 +1,18 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +open Num + +type interval = num option * num option +val pp : out_channel -> interval -> unit +val inter : interval -> interval -> interval option +val range : interval -> num option +val smaller_itv : interval -> interval -> bool +val in_bound : interval -> num -> bool +val norm_itv : interval -> interval option diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index 3779944154..baf8c82355 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -1,88 +1,23 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util open Num -module Utils = Mutils open Polynomial open Vect -let map_option = Utils.map_option -let from_option = Utils.from_option - let debug = false -type ('a,'b) lr = Inl of 'a | Inr of 'b let compare_float (p : float) q = Pervasives.compare p q (** Implementation of intervals *) -module Itv = -struct - - (** The type of intervals is *) - type interval = num option * num option - (** None models the absence of bound i.e. infinity *) - (** As a result, - - None , None -> \]-oo,+oo\[ - - None , Some v -> \]-oo,v\] - - Some v, None -> \[v,+oo\[ - - Some v, Some v' -> \[v,v'\] - Intervals needs to be explicitly normalised. - *) - - type who = Left | Right - - - (** if then interval [itv] is empty, [norm_itv itv] returns [None] - otherwise, it returns [Some itv] *) - - let norm_itv itv = - match itv with - | Some a , Some b -> if a <=/ b then Some itv else None - | _ -> Some itv - - (** [opp_itv itv] computes the opposite interval *) - let opp_itv itv = - let (l,r) = itv in - (map_option minus_num r, map_option minus_num l) - - - - -(** [inter i1 i2 = None] if the intersection of intervals is empty - [inter i1 i2 = Some i] if [i] is the intersection of the intervals [i1] and [i2] *) - let inter i1 i2 = - let (l1,r1) = i1 - and (l2,r2) = i2 in - - let inter f o1 o2 = - match o1 , o2 with - | None , None -> None - | Some _ , None -> o1 - | None , Some _ -> o2 - | Some n1 , Some n2 -> Some (f n1 n2) in - - norm_itv (inter max_num l1 l2 , inter min_num r1 r2) - - let range = function - | None,_ | _,None -> None - | Some i,Some j -> Some (floor_num j -/ceiling_num i +/ (Int 1)) - - - let smaller_itv i1 i2 = - match range i1 , range i2 with - | None , _ -> false - | _ , None -> true - | Some i , Some j -> i <=/ j - - -(** [in_bound bnd v] checks whether [v] is within the bounds [bnd] *) -let in_bound bnd v = - let (l,r) = bnd in - match l , r with - | None , None -> true - | None , Some a -> v <=/ a - | Some a , None -> a <=/ v - | Some a , Some b -> a <=/ v && v <=/ b - - -end open Itv type vector = Vect.t @@ -92,10 +27,6 @@ type vector = Vect.t module ISet = Set.Make(Int) - -module PSet = ISet - - module System = Hashtbl.Make(Vect) type proof = @@ -103,8 +34,6 @@ type proof = | Elim of var * proof * proof | And of proof * proof -let max_nb_cstr = ref max_int - type system = { sys : cstr_info ref System.t ; vars : ISet.t @@ -131,14 +60,6 @@ and cstr_info = { (** To be thrown when a system has no solution *) exception SystemContradiction of proof -let hyps prf = - let rec hyps prf acc = - match prf with - | Assum i -> ISet.add i acc - | Elim(_,prf1,prf2) - | And(prf1,prf2) -> hyps prf1 (hyps prf2 acc) in - hyps prf ISet.empty - (** Pretty printing *) let rec pp_proof o prf = @@ -147,33 +68,13 @@ let hyps prf = | Elim(v, prf1,prf2) -> Printf.fprintf o "E(%i,%a,%a)" v pp_proof prf1 pp_proof prf2 | And(prf1,prf2) -> Printf.fprintf o "A(%a,%a)" pp_proof prf1 pp_proof prf2 -let pp_bound o = function - | None -> output_string o "oo" - | Some a -> output_string o (string_of_num a) - -let pp_itv o (l,r) = Printf.fprintf o "(%a,%a)" pp_bound l pp_bound r - - -let pp_iset o s = - output_string o "{" ; - ISet.fold (fun i _ -> Printf.fprintf o "%i " i) s (); - output_string o "}" - -let pp_pset o s = - output_string o "{" ; - PSet.fold (fun i _ -> Printf.fprintf o "%i " i) s (); - output_string o "}" - - -let pp_info o i = pp_itv o i.bound - let pp_cstr o (vect,bnd) = let (l,r) = bnd in (match l with | None -> () | Some n -> Printf.fprintf o "%s <= " (string_of_num n)) ; - pp_vect o vect ; + Vect.pp o vect ; (match r with | None -> output_string o"\n" | Some n -> Printf.fprintf o "<=%s\n" (string_of_num n)) @@ -183,11 +84,6 @@ let pp_system o sys= System.iter (fun vect ibnd -> pp_cstr o (vect,(!ibnd).bound)) sys - - -let pp_split_cstr o (vl,v,c,_) = - Printf.fprintf o "(val x = %s ,%a,%s)" (string_of_num vl) pp_vect v (string_of_num c) - (** [merge_cstr_info] takes: - the intersection of bounds and - the union of proofs @@ -237,30 +133,23 @@ let normalise_cstr vect cinfo = match norm_itv cinfo.bound with | None -> Contradiction | Some (l,r) -> - match vect with - | [] -> if Itv.in_bound (l,r) (Int 0) then Redundant else Contradiction - | (_,n)::_ -> Cstr( - (if n <>/ Int 1 then List.map (fun (x,nx) -> (x,nx // n)) vect else vect), + match Vect.choose vect with + | None -> if Itv.in_bound (l,r) (Int 0) then Redundant else Contradiction + | Some (_,n,_) -> Cstr(Vect.div n vect, let divn x = x // n in if Int.equal (sign_num n) 1 - then{cinfo with bound = (map_option divn l , map_option divn r) } - else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (map_option divn r , map_option divn l)}) + then{cinfo with bound = (Option.map divn l , Option.map divn r) } + else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (Option.map divn r , Option.map divn l)}) -(** For compatibility, there is an external representation of constraints *) +(** For compatibility, there is an external representation of constraints *) -let eval_op = function - | Eq -> (=/) - | Ge -> (>=/) let count v = - let rec count n p v = - match v with - | [] -> (n,p) - | (_,vl)::v -> let sg = sign_num vl in - assert (sg <> 0) ; - if Int.equal sg 1 then count n (p+1) v else count (n+1) p v in - count 0 0 v + Vect.fold (fun (n,p) _ vl -> + let sg = sign_num vl in + assert (sg <> 0) ; + if Int.equal sg 1 then (n,p+1)else (n+1, p)) (0,0) v let norm_cstr {coeffs = v ; op = o ; cst = c} idx = @@ -269,7 +158,9 @@ let norm_cstr {coeffs = v ; op = o ; cst = c} idx = normalise_cstr v {pos = p ; neg = n ; bound = (match o with | Eq -> Some c , Some c - | Ge -> Some c , None) ; + | Ge -> Some c , None + | Gt -> raise Polynomial.Strict + ) ; prf = Assum idx } @@ -281,7 +172,7 @@ let load_system l = let sys = System.create 1000 in - let li = Mutils.mapi (fun e i -> (e,i)) l in + let li = List.mapi (fun i e -> (e,i)) l in let vars = List.fold_left (fun vrs (cstr,i) -> match norm_cstr cstr i with @@ -289,7 +180,7 @@ let load_system l = | Redundant -> vrs | Cstr(vect,info) -> xadd_cstr vect info sys ; - List.fold_left (fun s (v,_) -> ISet.add v s) vrs cstr.coeffs) ISet.empty li in + Vect.fold (fun s v _ -> ISet.add v s) vrs cstr.coeffs) ISet.empty li in {sys = sys ;vars = vars} @@ -307,27 +198,7 @@ let system_list sys = let add (v1,c1) (v2,c2) = assert (c1 <>/ Int 0 && c2 <>/ Int 0) ; - - let rec xadd v1 v2 = - match v1 , v2 with - | (x1,n1)::v1' , (x2,n2)::v2' -> - if Int.equal x1 x2 - then - let n' = (n1 // c1) +/ (n2 // c2) in - if n' =/ Int 0 then xadd v1' v2' - else - let res = xadd v1' v2' in - (x1,n') ::res - else if x1 < x2 - then let res = xadd v1' v2 in - (x1, n1 // c1)::res - else let res = xadd v1 v2' in - (x2, n2 // c2)::res - | [] , [] -> [] - | [] , _ -> List.map (fun (x,vl) -> (x,vl // c2)) v2 - | _ , [] -> List.map (fun (x,vl) -> (x,vl // c1)) v1 in - - let res = xadd v1 v2 in + let res = mul_add (Int 1 // c1) v1 (Int 1 // c2) v2 in (res, count res) let add (v1,c1) (v2,c2) = @@ -335,9 +206,6 @@ let add (v1,c1) (v2,c2) = (* Printf.printf "add(%a,%s,%a,%s) -> %a\n" pp_vect v1 (string_of_num c1) pp_vect v2 (string_of_num c2) pp_vect (fst res) ;*) res -type tlr = (num * vector * cstr_info) list -type tm = (vector * cstr_info ) list - (** To perform Fourier elimination, constraints are categorised depending on the sign of the variable to eliminate. *) (** [split x vect info (l,m,r)] @@ -349,9 +217,9 @@ type tm = (vector * cstr_info ) list let split x (vect: vector) info (l,m,r) = match get x vect with - | None -> (* The constraint does not mention [x], store it in m *) + | Int 0 -> (* The constraint does not mention [x], store it in m *) (l,(vect,info)::m,r) - | Some vl -> (* otherwise *) + | vl -> (* otherwise *) let cons_bound lst bd = match bd with @@ -381,8 +249,8 @@ let project vr sys = let {neg = n1 ; pos = p1 ; bound = bound1 ; prf = prf1} = info1 and {neg = n2 ; pos = p2 ; bound = bound2 ; prf = prf2} = info2 in - let bnd1 = from_option (fst bound1) - and bnd2 = from_option (fst bound2) in + let bnd1 = Option.get (fst bound1) + and bnd2 = Option.get (fst bound2) in let bound = (bnd1 // v1) +/ (bnd2 // minus_num v2) in let vres,(n,p) = add (vect1,v1) (vect2,minus_num v2) in (vres,{neg = n ; pos = p ; bound = (Some bound, None); prf = Elim(vr,info1.prf,info2.prf)}) in @@ -407,7 +275,8 @@ let project vr sys = let project_using_eq vr c vect bound prf (vect',info') = match get vr vect' with - | Some c2 -> + | Int 0 -> (vect',info') + | c2 -> let c1 = if c2 >=/ Int 0 then minus_num c else c in let c2 = abs_num c2 in @@ -419,13 +288,13 @@ let project_using_eq vr c vect bound prf (vect',info') = let bndres = let f x = cst +/ x // c2 in let (l,r) = info'.bound in - (map_option f l , map_option f r) in + (Option.map f l , Option.map f r) in (vres,{neg = n ; pos = p ; bound = bndres ; prf = Elim(vr,prf,info'.prf)}) - | None -> (vect',info') + let elim_var_using_eq vr vect cst prf sys = - let c = from_option (get vr vect) in + let c = get vr vect in let elim_var = project_using_eq vr c vect cst prf in @@ -444,9 +313,7 @@ let elim_var_using_eq vr vect cst prf sys = (** [size sys] computes the number of entries in the system of constraints *) let size sys = System.fold (fun v iref s -> s + (!iref).neg + (!iref).pos) sys 0 -module IMap = Map.Make(Int) - -let pp_map o map = IMap.fold (fun k elt () -> Printf.fprintf o "%i -> %s\n" k (string_of_num elt)) map () +module IMap = CMap.Make(Int) (** [eval_vect map vect] evaluates vector [vect] using the values of [map]. If [map] binds all the variables of [vect], we get @@ -454,16 +321,13 @@ let pp_map o map = IMap.fold (fun k elt () -> Printf.fprintf o "%i -> %s\n" k (s The function returns as second argument, a sub-vector consisting in the variables that are not in [map]. *) let eval_vect map vect = - let rec xeval_vect vect sum rst = - match vect with - | [] -> (sum,rst) - | (v,vl)::vect -> - try - let val_v = IMap.find v map in - xeval_vect vect (sum +/ (val_v */ vl)) rst - with - Not_found -> xeval_vect vect sum ((v,vl)::rst) in - xeval_vect vect (Int 0) [] + Vect.fold (fun (sum,rst) v vl -> + try + let val_v = IMap.find v map in + (sum +/ (val_v */ vl), rst) + with + Not_found -> (sum, Vect.set v vl rst)) (Int 0,Vect.null) vect + (** [restrict_bound n sum itv] returns the interval of [x] @@ -475,8 +339,8 @@ let restrict_bound n sum (itv:interval) = | 0 -> if in_bound itv sum then (None,None) (* redundant *) else failwith "SystemContradiction" - | 1 -> map_option f l , map_option f r - | _ -> map_option f r , map_option f l + | 1 -> Option.map f l , Option.map f r + | _ -> Option.map f r , Option.map f l (** [bound_of_variable map v sys] computes the interval of [v] in @@ -484,11 +348,13 @@ let restrict_bound n sum (itv:interval) = let bound_of_variable map v sys = System.fold (fun vect iref bnd -> let sum,rst = eval_vect map vect in - let vl = match get v rst with - | None -> Int 0 - | Some v -> v in + let vl = Vect.get v rst in match inter bnd (restrict_bound vl sum (!iref).bound) with - | None -> failwith "bound_of_variable: impossible" + | None -> + Printf.fprintf stdout "bound_of_variable: eval_vecr %a = %s,%a\n" + Vect.pp vect (Num.string_of_num sum) Vect.pp rst ; + Printf.fprintf stdout "current interval: %a\n" Itv.pp (!iref).bound; + failwith "bound_of_variable: impossible" | Some itv -> itv) sys (None,None) @@ -515,12 +381,13 @@ let solve_sys black_v choose_eq choose_variable sys sys_l = let rec solve_sys sys sys_l = if debug then Printf.printf "S #%i size %i\n" (System.length sys.sys) (size sys.sys); + if debug then Printf.printf "solve_sys :\n %a" pp_system sys.sys ; let eqs = choose_eq sys in try let (v,vect,cst,ln) = fst (List.find (fun ((v,_,_,_),_) -> v <> black_v) eqs) in if debug then - (Printf.printf "\nE %a = %s variable %i\n" pp_vect vect (string_of_num cst) v ; + (Printf.printf "\nE %a = %s variable %i\n" Vect.pp vect (string_of_num cst) v ; flush stdout); let sys' = elim_var_using_eq v vect cst ln sys in solve_sys sys' ((v,sys)::sys_l) @@ -560,9 +427,9 @@ struct match l with | [] -> (ltl, n,z,p) | (l1,info) ::rl -> - match l1 with - | [] -> xpart rl (([],info)::ltl) n (info.neg+info.pos+z) p - | (vr,vl)::rl1 -> + match Vect.choose l1 with + | None -> xpart rl ((Vect.null,info)::ltl) n (info.neg+info.pos+z) p + | Some(vr, vl, rl1) -> if Int.equal v vr then let cons_bound lst bd = @@ -613,31 +480,27 @@ struct |(Some a, Some b) -> a =/ b | _ -> false - let eq_bound bnd c = - match bnd with - |(Some a, Some b) -> a =/ b && c =/ b - | _ -> false - - let rec unroll_until v l = - match l with - | [] -> (false,[]) - | (i,_)::rl -> if Int.equal i v + match Vect.choose l with + | None -> (false,Vect.null) + | Some(i,_,rl) -> if Int.equal i v then (true,rl) else if i < v then unroll_until v rl else (false,l) + let rec choose_simple_equation eqs = match eqs with | [] -> None | (vect,a,prf,ln)::eqs -> - match vect with - | [i,_] -> Some (i,vect,a,prf,ln) - | _ -> choose_simple_equation eqs - + match Vect.choose vect with + | Some(i,v,rst) -> if Vect.is_null rst + then Some (i,vect,a,prf,ln) + else choose_simple_equation eqs + | _ -> choose_simple_equation eqs - let choose_primal_equation eqs sys_l = + let choose_primal_equation eqs (sys_l: (Vect.t *cstr_info) list) = (* Counts the number of equations referring to variable [v] -- It looks like nb_cst is dead... @@ -649,9 +512,9 @@ struct else nb_eq) 0 sys_l in let rec find_var vect = - match vect with - | [] -> None - | (i,_)::vect -> + match Vect.choose vect with + | None -> None + | Some(i,_,vect) -> let nb_eq = is_primal_equation_var i in if Int.equal nb_eq 2 then Some i else find_var vect in @@ -701,9 +564,9 @@ struct let cost_eq eq const prf ln acc_costs = let rec cost_eq eqr sysl costs = - match eqr with - | [] -> costs - | (v,_) ::eqr -> let (cst,tlsys) = estimate_cost v (ln-1) sysl 0 [] in + match Vect.choose eqr with + | None -> costs + | Some(v,_,eqr) -> let (cst,tlsys) = estimate_cost v (ln-1) sysl 0 [] in cost_eq eqr tlsys (((v,eq,const,prf),cst)::costs) in cost_eq eq sys_l acc_costs in @@ -755,10 +618,10 @@ struct in let map = rebuild_solution l IMap.empty in - let vect = List.rev (IMap.fold (fun v i vect -> (v,i)::vect) map []) in -(* Printf.printf "SOLUTION %a" pp_vect vect ; *) - let res = Inl vect in - res + let vect = IMap.fold (fun v i vect -> Vect.set v i vect) map Vect.null in + if debug then Printf.printf "SOLUTION %a" Vect.pp vect ; + let res = Inl vect in + res end @@ -798,8 +661,8 @@ struct and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in match Vect.get v v1 , Vect.get v v2 with - | None , _ | _ , None -> None - | Some a , Some b -> + | Int 0 , _ | _ , Int 0 -> None + | a , b -> if Int.equal ((sign_num a) * (sign_num b)) (-1) then Some (add (p1,abs_num a) (p2,abs_num b) , @@ -831,7 +694,7 @@ struct | Cstr(v,info) -> Inl ((prf,cstr,v,info)::acc)) (Inl []) l - type oproof = (vector * cstr_compat * num) option + type oproof = (vector * cstr * num) option let merge_proof (oleft:oproof) (prf,cstr,v,info) (oright:oproof) = let (l,r) = info.bound in @@ -852,9 +715,9 @@ struct if l <=/ r then Inl (oleft,oright) else (* There is a contradiction - it should show up by scaling up the vectors - any pivot should do*) - match cstrr.coeffs with - | [] -> Inr (add (prfl,Int 1) (prfr,Int 1), cstrr) (* this is wrong *) - | (v,_)::_ -> + match Vect.choose cstrr.coeffs with + | None -> Inr (add (prfl,Int 1) (prfr,Int 1), cstrr) (* this is wrong *) + | Some(v,_,_) -> match pivot v (prfl,cstrl) (prfr,cstrr) with | None -> failwith "merge_proof : pivot is not possible" | Some x -> Inr x @@ -867,7 +730,7 @@ let mk_proof hyps prf = let rec mk_proof prf = match prf with - | Assum i -> [ ([i, Int 1] , List.nth hyps i) ] + | Assum i -> [ (Vect.set i (Int 1) Vect.null , List.nth hyps i) ] | Elim(v,prf1,prf2) -> let prfsl = mk_proof prf1 diff --git a/plugins/micromega/mfourier.mli b/plugins/micromega/mfourier.mli new file mode 100644 index 0000000000..45a81cc118 --- /dev/null +++ b/plugins/micromega/mfourier.mli @@ -0,0 +1,38 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +module IMap : CSig.MapS with type key = int + +type proof + +module Fourier : sig + + + val find_point : Polynomial.cstr list -> + (Vect.t, proof) Util.union + + val optimise : Vect.t -> + Polynomial.cstr list -> + Itv.interval option + +end + +val pp_proof : out_channel -> proof -> unit + +module Proof : sig + + val mk_proof : Polynomial.cstr list -> + proof -> (Vect.t * Polynomial.cstr) list + + val add_op : Polynomial.op -> Polynomial.op -> Polynomial.op + +end + +exception TimeOut diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index 52c6ef983d..f67f1da146 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -1484,17 +1484,17 @@ let psub1 = let padd1 = padd0 Z0 Z.add zeq_bool -(** val norm0 : z pExpr -> z pol **) +(** val normZ : z pExpr -> z pol **) -let norm0 = +let normZ = norm Z0 (Zpos XH) Z.add Z.mul Z.sub Z.opp zeq_bool (** val xnormalise0 : z formula -> z nFormula list **) let xnormalise0 t0 = let { flhs = lhs; fop = o; frhs = rhs } = t0 in - let lhs0 = norm0 lhs in - let rhs0 = norm0 rhs in + let lhs0 = normZ lhs in + let rhs0 = normZ rhs in (match o with | OpEq -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::(((psub1 rhs0 @@ -1516,8 +1516,8 @@ let normalise t0 = let xnegate0 t0 = let { flhs = lhs; fop = o; frhs = rhs } = t0 in - let lhs0 = norm0 lhs in - let rhs0 = norm0 rhs in + let lhs0 = normZ lhs in + let rhs0 = normZ rhs in (match o with | OpEq -> ((psub1 lhs0 rhs0),Equal)::[] | OpNEq -> @@ -1707,6 +1707,12 @@ let qunsat = let qdeduce = nformula_plus_nformula { qnum = Z0; qden = XH } qplus qeq_bool +(** val normQ : q pExpr -> q pol **) + +let normQ = + norm { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult + qminus qopp qeq_bool + (** val qTautoChecker : q formula bFormula -> qWitness list -> bool **) let qTautoChecker f w = diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli index 9619781786..72c2bf7da3 100644 --- a/plugins/micromega/micromega.mli +++ b/plugins/micromega/micromega.mli @@ -151,8 +151,7 @@ val mkPinj : positive -> 'a1 pol -> 'a1 pol val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol -val mkPX : - 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val mkPX : 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol @@ -164,49 +163,27 @@ val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol -val paddI : - ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> - positive -> 'a1 pol -> 'a1 pol +val paddI : ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol -val psubI : - ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> - 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val psubI : ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol -val paddX : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol - -> positive -> 'a1 pol -> 'a1 pol +val paddX : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol -val psubX : - 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 - pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val psubX : 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol -val padd : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> - 'a1 pol +val padd : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol -val psub : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 - -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol +val psub : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol -val pmulC_aux : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 - pol +val pmulC_aux : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol -val pmulC : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 - -> 'a1 pol +val pmulC : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol -val pmulI : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> - 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val pmulI : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol -val pmul : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol +val pmul : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol -val psquare : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - bool) -> 'a1 pol -> 'a1 pol +val psquare : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol type 'c pExpr = | PEc of 'c @@ -220,16 +197,12 @@ 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 +val ppow_N : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol val norm_aux : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol type 'a bFormula = | TT @@ -251,32 +224,22 @@ val tt : 'a1 cnf val ff : 'a1 cnf -val add_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 - clause option +val add_term : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 clause option -val or_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause -> - 'a1 clause option +val or_clause : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause -> 'a1 clause option -val or_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> 'a1 - cnf +val or_clause_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> 'a1 cnf -val or_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 cnf +val or_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 cnf val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf -val xcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> - 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf +val xcnf : ('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 @@ -307,32 +270,24 @@ type 'c psatz = val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option -val map_option2 : - ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option +val map_option2 : ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option val pexpr_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - 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 +val nformula_plus_nformula : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option val eval_Psatz : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 nFormula option -val check_inconsistent : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool +val check_inconsistent : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool val check_normalised_formulas : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool type op2 = | OpEq @@ -345,36 +300,27 @@ type op2 = type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't 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 +val psub0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol -val padd0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> - 'a1 pol +val padd0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val xnormalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula - list + '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 @@ -384,9 +330,7 @@ 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 +val simpl_cone : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> 'a1 psatz type q = { qnum : z; qden : positive } @@ -431,7 +375,7 @@ val psub1 : z pol -> z pol -> z pol val padd1 : z pol -> z pol -> z pol -val norm0 : z pExpr -> z pol +val normZ : z pExpr -> z pol val xnormalise0 : z formula -> z nFormula list @@ -487,6 +431,8 @@ val qunsat : q nFormula -> bool val qdeduce : q nFormula -> q nFormula -> q nFormula option +val normQ : q pExpr -> q pol + val qTautoChecker : q formula bFormula -> qWitness list -> bool type rcst = diff --git a/plugins/micromega/micromega_plugin.mlpack b/plugins/micromega/micromega_plugin.mlpack index ed253da3fd..2baf6608a4 100644 --- a/plugins/micromega/micromega_plugin.mlpack +++ b/plugins/micromega/micromega_plugin.mlpack @@ -1,8 +1,11 @@ -Sos_types Mutils +Itv +Vect +Sos_types Micromega Polynomial Mfourier +Simplex Certificate Persistent_cache Coq_micromega diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index 82367c0b2e..809731ecc4 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -19,13 +19,23 @@ (* *) (************************************************************************) -let debug = false -let rec pp_list f o l = +module ISet = Set.Make(Int) + +module IMap = + struct + include Map.Make(Int) + + let from k m = + let (_,_,r) = split (k-1) m in + r + end + +let rec pp_list s f o l = match l with | [] -> () - | e::l -> f o e ; output_string o ";" ; pp_list f o l - + | [e] -> f o e + | e::l -> f o e ; output_string o s ; pp_list s f o l let finally f rst = try @@ -36,15 +46,6 @@ let finally f rst = with any -> raise reraise ); raise reraise -let map_option f x = - match x with - | None -> None - | Some v -> Some (f v) - -let from_option = function - | None -> failwith "from_option" - | Some v -> v - let rec try_any l x = match l with | [] -> None @@ -52,23 +53,7 @@ let rec try_any l x = | None -> try_any l x | x -> x -let iteri f l = - let rec xiter i l = - match l with - | [] -> () - | e::l -> f i e ; xiter (i+1) l in - xiter 0 l - -let all_sym_pairs f l = - let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in - - let rec xpairs acc l = - match l with - | [] -> acc - | e::l -> xpairs (pair_with acc e l) l in - xpairs [] l - -let all_pairs f 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 = @@ -77,14 +62,6 @@ let all_pairs f l = | e::lx -> xpairs (pair_with acc e l) lx in xpairs [] l - - -let rec map3 f l1 l2 l3 = - match l1 , l2 ,l3 with - | [] , [] , [] -> [] - | e1::l1 , e2::l2 , e3::l3 -> (f e1 e2 e3)::(map3 f l1 l2 l3) - | _ -> invalid_arg "map3" - let rec is_sublist f l1 l2 = match l1 ,l2 with | [] ,_ -> true @@ -93,26 +70,6 @@ let rec is_sublist f l1 l2 = if f e e' then is_sublist f l1' l2' else is_sublist f l1 l2' -let list_try_find f = - let rec try_find_f = function - | [] -> failwith "try_find" - | h::t -> try f h with Failure _ -> try_find_f t - in - try_find_f - -let list_fold_right_elements f l = - let rec aux = function - | [] -> invalid_arg "list_fold_right_elements" - | [x] -> x - | x::l -> f x (aux l) in - aux l - -let interval n m = - let rec interval_n (l,m) = - if n > m then l else interval_n (m::l,pred m) - in - interval_n ([],m) - let extract pred l = List.fold_left (fun (fd,sys) e -> match fd with @@ -125,6 +82,12 @@ let extract pred l = | _ -> (fd, e::sys) ) (None,[]) l +let extract_all pred l = + List.fold_left (fun (s1,s2) e -> + match pred e with + | None -> s1,e::s2 + | Some v -> (v,e)::s1 , s2) ([],[]) l + open Num open Big_int @@ -143,70 +106,21 @@ let numerator = function | Int i -> Big_int.big_int_of_int i | Big_int i -> i -let rec ppcm_list c l = - match l with - | [] -> c - | e::l -> ppcm_list (ppcm c (denominator e)) l +let iterate_until_stable f x = + let rec iter x = + match f x with + | None -> x + | Some x' -> iter x' in + iter x -let rec rec_gcd_list c l = +let rec app_funs l x = match l with - | [] -> c - | e::l -> rec_gcd_list (gcd_big_int c (numerator e)) l - -let gcd_list l = - let res = rec_gcd_list zero_big_int l in - if Int.equal (compare_big_int res zero_big_int) 0 - then unit_big_int else res - -let rats_to_ints l = - let c = ppcm_list unit_big_int l in - List.map (fun x -> (div_big_int (mult_big_int (numerator x) c) - (denominator x))) l - -(* Nasty reordering of lists - useful to trim certificate down *) -let mapi f l = - let rec xmapi i l = - match l with - | [] -> [] - | e::l -> (f e i)::(xmapi (i+1) l) in - xmapi 0 l - -let concatMapi f l = List.rev (mapi (fun e i -> (i,f e)) l) + | [] -> None + | f::fl -> + match f x with + | None -> app_funs fl x + | Some x' -> Some x' -(* assoc_pos j [a0...an] = [j,a0....an,j+n],j+n+1 *) -let assoc_pos j l = (mapi (fun e i -> e,i+j) l, j + (List.length l)) - -let assoc_pos_assoc l = - let rec xpos i l = - match l with - | [] -> [] - | (x,l) ::rst -> let (l',j) = assoc_pos i l in - (x,l')::(xpos j rst) in - xpos 0 l - -let filter_pos f l = - (* Could sort ... take care of duplicates... *) - let rec xfilter l = - match l with - | [] -> [] - | (x,e)::l -> - if List.exists (fun ee -> List.mem ee f) (List.map snd e) - then (x,e)::(xfilter l) - else xfilter l in - xfilter l - -let select_pos lpos l = - let rec xselect i lpos l = - match lpos with - | [] -> [] - | j::rpos -> - match l with - | [] -> failwith "select_pos" - | e::l -> - if Int.equal i j - then e:: (xselect (i+1) rpos l) - else xselect (i+1) lpos l in - xselect 0 lpos l (** * MODULE: Coq to Caml data-structure mappings @@ -238,12 +152,6 @@ struct | XI i -> 1+(2*(index i)) | XO i -> 2*(index i) - let z x = - match x with - | Z0 -> 0 - | Zpos p -> (positive p) - | Zneg p -> - (positive p) - open Big_int let rec positive_big_int p = @@ -258,8 +166,6 @@ struct | Zpos p -> (positive_big_int p) | Zneg p -> minus_big_int (positive_big_int p) - let num x = Num.Big_int (z_big_int x) - let q_to_num {qnum = x ; qden = y} = Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y))) @@ -352,17 +258,6 @@ struct let c = cmp e1 e2 in if Int.equal c 0 then compare_list cmp l1 l2 else c -(** - * hash_list takes a hash function and a list, and computes an integer which - * is the hash value of the list. - *) - let hash_list hash l = - let rec _hash_list l h = - match l with - | [] -> h lxor (Hashtbl.hash []) - | e::l -> _hash_list l ((hash e) lxor h) - in _hash_list l 0 - end (** diff --git a/plugins/micromega/mutils.mli b/plugins/micromega/mutils.mli new file mode 100644 index 0000000000..e92f086886 --- /dev/null +++ b/plugins/micromega/mutils.mli @@ -0,0 +1,85 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + + +module ISet : Set.S with type elt = int + +module IMap : +sig + include Map.S with type key = int + + (** [from k m] returns the submap of [m] with keys greater or equal k *) + val from : key -> 'elt t -> 'elt t + +end + +val numerator : Num.num -> Big_int.big_int +val denominator : Num.num -> Big_int.big_int + +module Cmp : sig + + val compare_list : ('a -> 'b -> int) -> 'a list -> 'b list -> int + val compare_lexical : (unit -> int) list -> int + +end + +module Tag : sig + + type t + + val pp : out_channel -> t -> unit + val next : t -> t + val from : int -> t + +end + +module TagSet : CSig.SetS with type elt = Tag.t + +val pp_list : string -> (out_channel -> 'a -> unit) -> out_channel -> 'a list -> unit + +module CamlToCoq : sig + + val positive : int -> Micromega.positive + val bigint : Big_int.big_int -> Micromega.z + val n : int -> Micromega.n + val nat : int -> Micromega.nat + val q : Num.num -> Micromega.q + val index : int -> Micromega.positive + val z : int -> Micromega.z + val positive_big_int : Big_int.big_int -> Micromega.positive + +end + +module CoqToCaml : sig + + val z_big_int : Micromega.z -> Big_int.big_int + val q_to_num : Micromega.q -> Num.num + val positive : Micromega.positive -> int + val n : Micromega.n -> int + val nat : Micromega.nat -> int + val index : Micromega.positive -> int + +end + +val ppcm : Big_int.big_int -> Big_int.big_int -> Big_int.big_int + +val all_pairs : ('a -> 'a -> 'b) -> 'a list -> 'b list +val try_any : (('a -> 'b option) * 'c) list -> 'a -> 'b option +val is_sublist : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + +val extract : ('a -> 'b option) -> 'a list -> ('b * 'a) option * 'a list + +val extract_all : ('a -> 'b option) -> 'a list -> ('b * 'a) list * 'a list + +val iterate_until_stable : ('a -> 'a option) -> 'a -> 'a + +val app_funs : ('a -> 'b option) list -> 'a -> 'b option + +val command : string -> string array -> 'a -> 'b diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index ee5a0458e8..0209030b64 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -19,11 +19,6 @@ module type PHashtable = type 'a t type key - val create : int -> string -> 'a t - (** [create i f] creates an empty persistent table - with initial size i associated with file [f] *) - - val open_in : string -> 'a t (** [open_in f] rebuilds a table from the records stored in file [f]. As marshaling is not type-safe, it migth segault. @@ -37,11 +32,6 @@ module type PHashtable = (and writes the binding to the file associated with [tbl].) If [key] is already bound, raises KeyAlreadyBound *) - val close : 'a t -> unit - (** [close tbl] is closing the table. - Once closed, a table cannot be used. - i.e, find,add will raise UnboundTable *) - val memo : string -> (key -> 'a) -> (key -> 'a) (** [memo cache f] returns a memo function for [f] using file [cache] as persistent table. Note that the cache will only be loaded when the function is used for the first time *) @@ -71,14 +61,6 @@ struct } -let create i f = - let flags = [O_WRONLY; O_TRUNC;O_CREAT] in - { - outch = out_channel_of_descr (openfile f flags 0o666); - status = Open ; - htbl = Table.create i - } - let finally f rst = try let res = f () in @@ -181,15 +163,6 @@ let open_in f = end -let close t = - let {outch = outch ; status = status ; htbl = tbl} = t in - match t.status with - | Closed -> () (* don't do it twice *) - | Open -> - close_out outch ; - Table.clear tbl ; - t.status <- Closed - let add t k e = let {outch = outch ; status = status ; htbl = tbl} = t in if status == Closed diff --git a/plugins/micromega/persistent_cache.mli b/plugins/micromega/persistent_cache.mli new file mode 100644 index 0000000000..4e7a388aaf --- /dev/null +++ b/plugins/micromega/persistent_cache.mli @@ -0,0 +1,37 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Hashtbl + +module type PHashtable = + sig + type 'a t + type key + + val open_in : string -> 'a t + (** [open_in f] rebuilds a table from the records stored in file [f]. + As marshaling is not type-safe, it migth segault. + *) + + val find : 'a t -> key -> 'a + (** find has the specification of Hashtable.find *) + + val add : 'a t -> key -> 'a -> unit + (** [add tbl key elem] adds the binding [key] [elem] to the table [tbl]. + (and writes the binding to the file associated with [tbl].) + If [key] is already bound, raises KeyAlreadyBound *) + + val memo : string -> (key -> 'a) -> (key -> 'a) + (** [memo cache f] returns a memo function for [f] using file [cache] as persistent table. + Note that the cache will only be loaded when the function is used for the first time *) + + end + +module PHashtable(Key:HashedType) : PHashtable with type key = Key.t diff --git a/plugins/micromega/plugin_base.dune b/plugins/micromega/plugin_base.dune new file mode 100644 index 0000000000..c2d396f0f9 --- /dev/null +++ b/plugins/micromega/plugin_base.dune @@ -0,0 +1,15 @@ +(library + (name micromega_plugin) + (public_name coq.plugins.micromega) + ; be careful not to link the executable to the plugin! + (modules (:standard \ csdpcert)) + (synopsis "Coq's micromega plugin") + (libraries num coq.plugins.ltac)) + +(executable + (name csdpcert) + (public_name csdpcert) + (package coq) + (modules csdpcert) + (flags :standard -open Micromega_plugin) + (libraries coq.plugins.micromega)) diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index db8b73a204..76e7769e82 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -10,7 +10,7 @@ (* *) (* Micromega: A reflexive tactic using the Positivstellensatz *) (* *) -(* Frédéric Besson (Irisa/Inria) 2006-20011 *) +(* Frédéric Besson (Irisa/Inria) 2006-20018 *) (* *) (************************************************************************) @@ -18,723 +18,881 @@ open Num module Utils = Mutils open Utils +module Mc = Micromega + +let max_nb_cstr = ref max_int + type var = int +let debug = false let (<+>) = add_num -let (<->) = minus_num let (<*>) = mult_num - module Monomial : sig - type t - val const : t - val is_const : t -> bool - val var : var -> t - val is_var : t -> bool - val find : var -> t -> int - val mult : var -> t -> t - val prod : t -> t -> t - val exp : t -> int -> t - val div : t -> t -> t * int - val compare : t -> t -> int - val pp : out_channel -> t -> unit - val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a - val sqrt : t -> t option + type t + val const : t + val is_const : t -> bool + val var : var -> t + val is_var : t -> bool + val get_var : t -> var option + val prod : t -> t -> t + val exp : t -> int -> t + val div : t -> t -> t * int + val compare : t -> t -> int + val pp : out_channel -> t -> unit + val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a + val sqrt : t -> t option + val variables : t -> ISet.t end - = -struct - (* A monomial is represented by a multiset of variables *) - module Map = Map.Make(Int) - open Map - - type t = int Map.t - - let pp o m = Map.iter - (fun k v -> - if v = 1 then Printf.fprintf o "x%i." k - else Printf.fprintf o "x%i^%i." k v) m - - - (* The monomial that corresponds to a constant *) - let const = Map.empty - - let sum_degree m = Map.fold (fun _ n s -> s + n) m 0 - - (* Total ordering of monomials *) - let compare: t -> t -> int = - fun m1 m2 -> - let s1 = sum_degree m1 - and s2 = sum_degree m2 in - if Int.equal s1 s2 then Map.compare Int.compare m1 m2 - else Int.compare s1 s2 - - let is_const m = (m = Map.empty) - - (* The monomial 'x' *) - let var x = Map.add x 1 Map.empty - - let is_var m = - try - not (Map.fold (fun _ i fk -> - if fk = true (* first key *) - then - if i = 1 then false - else raise Not_found - else raise Not_found) m true) - with Not_found -> false - - let sqrt m = - if is_const m then None - else - try - Some (Map.fold (fun v i acc -> - let i' = i / 2 in - if i mod 2 = 0 - then add v i' m - else raise Not_found) m const) - with Not_found -> None - - (* Get the degre of a variable in a monomial *) - let find x m = try find x m with Not_found -> 0 - - (* Multiply a monomial by a variable *) - let mult x m = add x ( (find x m) + 1) m - - (* Product of monomials *) - let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2 - - - let exp m n = - let rec exp acc n = - if n = 0 then acc - else exp (prod acc m) (n - 1) in - - exp const n - - - (* [div m1 m2 = mr,n] such that mr * (m2)^n = m1 *) - let div m1 m2 = - let n = fold (fun x i n -> let i' = find x m1 in - let nx = i' / i in - min n nx) m2 max_int in - - let mr = fold (fun x i' m -> - let i = find x m2 in - let ir = i' - i * n in - if ir = 0 then m - else add x ir m) m1 empty in - (mr,n) - - - let fold = fold + = struct + (* A monomial is represented by a multiset of variables *) + module Map = Map.Make(Int) + open Map + + type t = int Map.t + + let is_singleton m = + try + let (k,v) = choose m in + let (l,e,r) = split k m in + if is_empty l && is_empty r + then Some(k,v) else None + with Not_found -> None + + let pp o m = + let pp_elt o (k,v)= + if v = 1 then Printf.fprintf o "x%i" k + else Printf.fprintf o "x%i^%i" k v in + + let rec pp_list o l = + match l with + [] -> () + | [e] -> pp_elt o e + | e::l -> Printf.fprintf o "%a*%a" pp_elt e pp_list l in + + pp_list o (Map.bindings m) + + + + (* The monomial that corresponds to a constant *) + let const = Map.empty + + let sum_degree m = Map.fold (fun _ n s -> s + n) m 0 + + (* Total ordering of monomials *) + let compare: t -> t -> int = + fun m1 m2 -> + let s1 = sum_degree m1 + and s2 = sum_degree m2 in + if Int.equal s1 s2 then Map.compare Int.compare m1 m2 + else Int.compare s1 s2 + + let is_const m = (m = Map.empty) + + (* The monomial 'x' *) + let var x = Map.add x 1 Map.empty + + let is_var m = + match is_singleton m with + | None -> false + | Some (_,i) -> i = 1 + + let get_var m = + match is_singleton m with + | None -> None + | Some (k,i) -> if i = 1 then Some k else None + + + let sqrt m = + if is_const m then None + else + try + Some (Map.fold (fun v i acc -> + let i' = i / 2 in + if i mod 2 = 0 + then add v i' acc + else raise Not_found) m const) + with Not_found -> None + + + (* Get the degre of a variable in a monomial *) + let find x m = try find x m with Not_found -> 0 + + (* Product of monomials *) + let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2 + + let exp m n = + let rec exp acc n = + if n = 0 then acc + else exp (prod acc m) (n - 1) in + + exp const n + + (* [div m1 m2 = mr,n] such that mr * (m2)^n = m1 *) + let div m1 m2 = + let n = fold (fun x i n -> let i' = find x m1 in + let nx = i' / i in + min n nx) m2 max_int in + + let mr = fold (fun x i' m -> + let i = find x m2 in + let ir = i' - i * n in + if ir = 0 then m + else add x ir m) m1 empty in + (mr,n) + + + let variables m = fold (fun v i acc -> ISet.add v acc) m ISet.empty + + let fold = fold end +module MonMap = + struct + include Map.Make(Monomial) + + let union f = merge + (fun x v1 v2 -> + match v1 , v2 with + | None , None -> None + | Some v , None | None , Some v -> Some v + | Some v1 , Some v2 -> f x v1 v2) + end + +let pp_mon o (m, i) = + if Monomial.is_const m + then if eq_num (Int 0) i then () + else Printf.fprintf o "%s" (string_of_num i) + else + match i with + | Int 1 -> Monomial.pp o m + | Int -1 -> Printf.fprintf o "-%a" Monomial.pp m + | Int 0 -> () + | _ -> Printf.fprintf o "%s*%a" (string_of_num i) Monomial.pp m + + + module Poly : - (* A polynomial is a map of monomials *) - (* - This is probably a naive implementation +(* A polynomial is a map of monomials *) +(* + This is probably a naive implementation (expected to be fast enough - Coq is probably the bottleneck) *The new ring contribution is using a sparse Horner representation. - *) + *) sig - type t - val get : Monomial.t -> t -> num - val variable : var -> t - val add : Monomial.t -> num -> t -> t - val constant : num -> t - val mult : Monomial.t -> num -> t -> t - val product : t -> t -> t - val addition : t -> t -> t - val uminus : t -> t - val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a - val pp : out_channel -> t -> unit - val compare : t -> t -> int - val is_null : t -> bool - val is_linear : t -> bool -end = -struct - (*normalisation bug : 0*x ... *) - module P = Map.Make(Monomial) - open P - - type t = num P.t - - let pp o p = P.iter - (fun k v -> - if Monomial.compare Monomial.const k = 0 - then Printf.fprintf o "%s " (string_of_num v) - else Printf.fprintf o "%s*%a " (string_of_num v) Monomial.pp k) p - - (* Get the coefficient of monomial mn *) - let get : Monomial.t -> t -> num = - fun mn p -> try find mn p with Not_found -> (Int 0) - - - (* The polynomial 1.x *) - let variable : var -> t = - fun x -> add (Monomial.var x) (Int 1) empty - - (*The constant polynomial *) - let constant : num -> t = - fun c -> add (Monomial.const) c empty - - (* The addition of a monomial *) - - let add : Monomial.t -> num -> t -> t = - fun mn v p -> + type t + val pp : out_channel -> t -> unit + val get : Monomial.t -> t -> num + val variable : var -> t + val add : Monomial.t -> num -> t -> t + val constant : num -> t + val product : t -> t -> t + val addition : t -> t -> t + val uminus : t -> t + val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a + val factorise : var -> t -> t * t +end = struct + (*normalisation bug : 0*x ... *) + module P = Map.Make(Monomial) + open P + + type t = num P.t + + + let pp o p = P.iter (fun mn i -> Printf.fprintf o "%a + " pp_mon (mn, i)) p + + + (* Get the coefficient of monomial mn *) + let get : Monomial.t -> t -> num = + fun mn p -> try find mn p with Not_found -> (Int 0) + + + (* The polynomial 1.x *) + let variable : var -> t = + fun x -> add (Monomial.var x) (Int 1) empty + + (*The constant polynomial *) + let constant : num -> t = + fun c -> add (Monomial.const) c empty + + (* The addition of a monomial *) + + let add : Monomial.t -> num -> t -> t = + fun mn v p -> if sign_num v = 0 then p else let vl = (get mn p) <+> v in - if sign_num vl = 0 then - remove mn p - else add mn vl p + if sign_num vl = 0 then + remove mn p + else add mn vl p - (** Design choice: empty is not a polynomial - I do not remember why .... - **) + (** Design choice: empty is not a polynomial + I do not remember why .... + **) - (* The product by a monomial *) - let mult : Monomial.t -> num -> t -> t = - fun mn v p -> - if sign_num v = 0 + (* The product by a monomial *) + let mult : Monomial.t -> num -> t -> t = + fun mn v p -> + if sign_num v = 0 then constant (Int 0) else fold (fun mn' v' res -> P.add (Monomial.prod mn mn') (v<*>v') res) p empty - let addition : t -> t -> t = - fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2 - + let addition : t -> t -> t = + fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2 - let product : t -> t -> t = - fun p1 p2 -> - fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty + let product : t -> t -> t = + fun p1 p2 -> + fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty - let uminus : t -> t = - fun p -> map (fun v -> minus_num v) p - let fold = P.fold + let uminus : t -> t = + fun p -> map (fun v -> minus_num v) p - let is_null p = fold (fun mn vl b -> b && sign_num vl = 0) p true + let fold = P.fold - let compare = compare compare_num + let factorise x p = + let x = Monomial.var x in + P.fold (fun m v (px,cx) -> + let (m1,i) = Monomial.div m x in + if i = 0 + then (px, add m v cx) + else + let mx = Monomial.prod m1 (Monomial.exp x (i-1)) in + (add mx v px,cx) ) p (constant (Int 0) , constant (Int 0)) - let is_linear p = P.fold (fun m _ acc -> acc && (Monomial.is_const m || Monomial.is_var m)) p true - -(* let is_linear p = - let res = is_linear p in - Printf.printf "is_linear %a = %b\n" pp p res ; res -*) end -module Vect = - struct - (** [t] is the type of vectors. - A vector [(x1,v1) ; ... ; (xn,vn)] is such that: - - variables indexes are ordered (x1 <c ... < xn - - values are all non-zero - *) - type var = int - type t = (var * num) list - -(** [equal v1 v2 = true] if the vectors are syntactically equal. *) - - let rec equal v1 v2 = - match v1 , v2 with - | [] , [] -> true - | [] , _ -> false - | _::_ , [] -> false - | (i1,n1)::v1 , (i2,n2)::v2 -> - (Int.equal i1 i2) && n1 =/ n2 && equal v1 v2 - - let hash v = - let rec hash i = function - | [] -> i - | (vr,vl)::l -> hash (i + (Hashtbl.hash (vr, float_of_num vl))) l in - Hashtbl.hash (hash 0 v ) - - - let null = [] - - let pp_vect o vect = - List.iter (fun (v,n) -> Printf.printf "%sx%i + " (string_of_num n) v) vect - - let from_list (l: num list) = - let rec xfrom_list i l = - match l with - | [] -> [] - | e::l -> - if e <>/ Int 0 - then (i,e)::(xfrom_list (i+1) l) - else xfrom_list (i+1) l in - - xfrom_list 0 l - - let zero_num = Int 0 - let unit_num = Int 1 - - - let to_list m = - let rec xto_list i l = - match l with - | [] -> [] - | (x,v)::l' -> - if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in - xto_list 0 m - - - let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst - - let rec update i f t = - match t with - | [] -> cons i (f zero_num) [] - | (k,v)::l -> - match Int.compare i k with - | 0 -> cons k (f v) l - | -1 -> cons i (f zero_num) t - | 1 -> (k,v) ::(update i f l) - | _ -> failwith "compare_num" - - let rec set i n t = - match t with - | [] -> cons i n [] - | (k,v)::l -> - match Int.compare i k with - | 0 -> cons k n l - | -1 -> cons i n t - | 1 -> (k,v) :: (set i n l) - | _ -> failwith "compare_num" - - let gcd m = - let res = List.fold_left (fun x (i,e) -> Big_int.gcd_big_int x (Utils.numerator e)) Big_int.zero_big_int m in - if Big_int.compare_big_int res Big_int.zero_big_int = 0 - then Big_int.unit_big_int else res - - let mul z t = - match z with - | Int 0 -> [] - | Int 1 -> t - | _ -> List.map (fun (i,n) -> (i, mult_num z n)) t - - - let rec add v1 v2 = - match v1 , v2 with - | (x1,n1)::v1' , (x2,n2)::v2' -> - if x1 = x2 - then - let n' = n1 +/ n2 in - if n' =/ Int 0 then add v1' v2' - else - let res = add v1' v2' in - (x1,n') ::res - else if x1 < x2 - then let res = add v1' v2 in - (x1, n1)::res - else let res = add v1 v2' in - (x2, n2)::res - | [] , [] -> [] - | [] , _ -> v2 - | _ , [] -> v1 - - - - - let compare : t -> t -> int = Utils.Cmp.compare_list (fun x y -> Utils.Cmp.compare_lexical - [ - (fun () -> Int.compare (fst x) (fst y)); - (fun () -> compare_num (snd x) (snd y))]) - - (** [tail v vect] returns - - [None] if [v] is not a variable of the vector [vect] - - [Some(vl,rst)] where [vl] is the value of [v] in vector [vect] - and [rst] is the remaining of the vector - We exploit that vectors are ordered lists - *) - let rec tail (v:var) (vect:t) = - match vect with - | [] -> None - | (v',vl)::vect' -> - match Int.compare v' v with - | 0 -> Some (vl,vect) (* Ok, found *) - | -1 -> tail v vect' (* Might be in the tail *) - | _ -> None (* Hopeless *) - - let get v vect = - match tail v vect with - | None -> None - | Some(vl,_) -> Some vl - - - let rec fresh v = - match v with - | [] -> 1 - | [v,_] -> v + 1 - | _::v -> fresh v - - end type vector = Vect.t -type cstr_compat = {coeffs : vector ; op : op ; cst : num} -and op = |Eq | Ge +type cstr = {coeffs : vector ; op : op ; cst : num} +and op = |Eq | Ge | Gt -let string_of_op = function Eq -> "=" | Ge -> ">=" +exception Strict -let output_cstr o {coeffs = coeffs ; op = op ; cst = cst} = - Printf.fprintf o "%a %s %s" Vect.pp_vect coeffs (string_of_op op) (string_of_num cst) +let is_strict c = Pervasives.(=) c.op Gt -let opMult o1 o2 = - match o1, o2 with - | Eq , Eq -> Eq - | Eq , Ge | Ge , Eq -> Ge - | Ge , Ge -> Ge - -let opAdd o1 o2 = - match o1 , o2 with - | Eq , _ | _ , Eq -> Eq - | Ge , Ge -> Ge - - - - -open Big_int - -type index = int - -type prf_rule = - | Hyp of int - | Def of int - | Cst of big_int - | Zero - | Square of (Vect.t * num) - | MulC of (Vect.t * num) * prf_rule - | Gcd of big_int * prf_rule - | MulPrf of prf_rule * prf_rule - | AddPrf of prf_rule * prf_rule - | CutPrf of prf_rule - -type proof = - | Done - | Step of int * prf_rule * proof - | Enum of int * prf_rule * Vect.t * prf_rule * proof list - - -let rec output_prf_rule o = function - | Hyp i -> Printf.fprintf o "Hyp %i" i - | Def i -> Printf.fprintf o "Def %i" i - | Cst c -> Printf.fprintf o "Cst %s" (string_of_big_int c) - | Zero -> Printf.fprintf o "Zero" - | Square _ -> Printf.fprintf o "( )^2" - | MulC(p,pr) -> Printf.fprintf o "P * %a" output_prf_rule pr - | MulPrf(p1,p2) -> Printf.fprintf o "%a * %a" output_prf_rule p1 output_prf_rule p2 - | AddPrf(p1,p2) -> Printf.fprintf o "%a + %a" output_prf_rule p1 output_prf_rule p2 - | CutPrf(p) -> Printf.fprintf o "[%a]" output_prf_rule p - | Gcd(c,p) -> Printf.fprintf o "(%a)/%s" output_prf_rule p (string_of_big_int c) - -let rec output_proof o = function - | Done -> Printf.fprintf o "." - | Step(i,p,pf) -> Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf - | Enum(i,p1,v,p2,pl) -> Printf.fprintf o "%i{%a<=%a<=%a}%a" i - output_prf_rule p1 Vect.pp_vect v output_prf_rule p2 - (pp_list output_proof) pl - -let rec pr_rule_max_id = function - | Hyp i | Def i -> i - | Cst _ | Zero | Square _ -> -1 - | MulC(_,p) | CutPrf p | Gcd(_,p) -> pr_rule_max_id p - | MulPrf(p1,p2)| AddPrf(p1,p2) -> max (pr_rule_max_id p1) (pr_rule_max_id p2) - -let rec proof_max_id = function - | Done -> -1 - | Step(i,pr,prf) -> max i (max (pr_rule_max_id pr) (proof_max_id prf)) - | Enum(i,p1,_,p2,l) -> - let m = max (pr_rule_max_id p1) (pr_rule_max_id p2) in - List.fold_left (fun i prf -> max i (proof_max_id prf)) (max i m) l - -let rec pr_rule_def_cut id = function - | MulC(p,prf) -> - let (bds,id',prf') = pr_rule_def_cut id prf in - (bds, id', MulC(p,prf')) - | MulPrf(p1,p2) -> - let (bds1,id,p1) = pr_rule_def_cut id p1 in - let (bds2,id,p2) = pr_rule_def_cut id p2 in - (bds2@bds1,id,MulPrf(p1,p2)) - | AddPrf(p1,p2) -> - let (bds1,id,p1) = pr_rule_def_cut id p1 in - let (bds2,id,p2) = pr_rule_def_cut id p2 in - (bds2@bds1,id,AddPrf(p1,p2)) - | CutPrf p -> - let (bds,id,p) = pr_rule_def_cut id p in - ((id,p)::bds,id+1,Def id) - | Gcd(c,p) -> - let (bds,id,p) = pr_rule_def_cut id p in - ((id,p)::bds,id+1,Def id) - | Square _|Cst _|Def _|Hyp _|Zero as x -> ([],id,x) - - -(* Do not define top-level cuts *) -let pr_rule_def_cut id = function - | CutPrf p -> - let (bds,ids,p') = pr_rule_def_cut id p in - bds,ids, CutPrf p' - | p -> pr_rule_def_cut id p - - -let rec implicit_cut p = - match p with - | CutPrf p -> implicit_cut p - | _ -> p - - -let rec normalise_proof id prf = - match prf with - | Done -> (id,Done) - | Step(i,Gcd(c,p),Done) -> normalise_proof id (Step(i,p,Done)) - | Step(i,p,prf) -> - let bds,id,p' = pr_rule_def_cut id p in - let (id,prf) = normalise_proof id prf in - let prf = List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc)) - (Step(i,p',prf)) bds in - - (id,prf) - | Enum(i,p1,v,p2,pl) -> - (* Why do I have top-level cuts ? *) -(* let p1 = implicit_cut p1 in - let p2 = implicit_cut p2 in - let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in - (List.fold_left max 0 ids , - Enum(i,p1,v,p2,prfs)) -*) +let eval_op = function + | Eq -> (=/) + | Ge -> (>=/) + | Gt -> (>/) - let bds1,id,p1' = pr_rule_def_cut id (implicit_cut p1) in - let bds2,id,p2' = pr_rule_def_cut id (implicit_cut p2) in - let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in - (List.fold_left max 0 ids , - List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc)) - (Enum(i,p1',v,p2',prfs)) (bds2@bds1)) +let string_of_op = function Eq -> "=" | Ge -> ">=" | Gt -> ">" -let normalise_proof id prf = - let res = normalise_proof id prf in - if debug then Printf.printf "normalise_proof %a -> %a" output_proof prf output_proof (snd res) ; - res +let output_cstr o { coeffs ; op ; cst } = + Printf.fprintf o "%a %s %s" Vect.pp coeffs (string_of_op op) (string_of_num cst) +let opMult o1 o2 = + match o1, o2 with + | Eq , _ | _ , Eq -> Eq + | Ge , _ | _ , Ge -> Ge + | Gt , Gt -> Gt -let add_proof x y = - match x, y with - | Zero , p | p , Zero -> p - | _ -> AddPrf(x,y) +let opAdd o1 o2 = + match o1, o2 with + | Eq , x | x , Eq -> x + | Gt , x | x , Gt -> Gt + | Ge , Ge -> Ge -let mul_proof c p = - match sign_big_int c with - | 0 -> Zero (* This is likely to be a bug *) - | -1 -> MulC(([],Big_int c),p) (* [p] should represent an equality *) - | 1 -> - if eq_big_int c unit_big_int - then p - else MulPrf(Cst c,p) - | _ -> assert false -let mul_proof_ext (p,c) prf = - match p with - | [] -> mul_proof (numerator c) prf - | _ -> MulC((p,c),prf) - +module LinPoly = struct + (** A linear polynomial a0 + a1.x1 + ... + an.xn + By convention, the constant a0 is the coefficient of the variable 0. + *) + type t = Vect.t -(* - let rec scale_prf_rule = function - | Hyp i -> (unit_big_int, Hyp i) - | Def i -> (unit_big_int, Def i) - | Cst c -> (unit_big_int, Cst i) - | Zero -> (unit_big_int, Zero) - | Square p -> (unit_big_int,Square p) - | Div(c,pr) -> - let (bi,pr') = scale_prf_rule pr in - (mult_big_int c bi , pr') - | MulC(p,pr) -> - let bi,pr' = scale_prf_rule pr in - (bi,MulC p,pr') - | MulPrf(p1,p2) -> - let b1,p1 = scale_prf_rule p1 in - let b2,p2 = scale_prf_rule p2 in - - - | AddPrf(p1,p2) -> - let b1,p1 = scale_prf_rule p1 in - let b2,p2 = scale_prf_rule p2 in - let g = gcd_big_int -*) - - - - - -module LinPoly = -struct - type t = Vect.t * num - - module MonT = - struct + module MonT = struct module MonoMap = Map.Make(Monomial) module IntMap = Map.Make(Int) - + (** A hash table might be preferable but requires a hash function. *) let (index_of_monomial : int MonoMap.t ref) = ref (MonoMap.empty) let (monomial_of_index : Monomial.t IntMap.t ref) = ref (IntMap.empty) let fresh = ref 0 - let clear () = + let clear () = index_of_monomial := MonoMap.empty; - monomial_of_index := IntMap.empty ; + monomial_of_index := IntMap.empty ; fresh := 0 - let register m = + let register m = try - MonoMap.find m !index_of_monomial - with Not_found -> - begin - let res = !fresh in - index_of_monomial := MonoMap.add m res !index_of_monomial ; - monomial_of_index := IntMap.add res m !monomial_of_index ; - incr fresh ; res - end + MonoMap.find m !index_of_monomial + with Not_found -> + begin + let res = !fresh in + index_of_monomial := MonoMap.add m res !index_of_monomial ; + monomial_of_index := IntMap.add res m !monomial_of_index ; + incr fresh ; res + end let retrieve i = IntMap.find i !monomial_of_index + let _ = register Monomial.const - end + end - let normalise (v,c) = - (List.sort (fun x y -> Int.compare (fst x) (fst y)) v , c) + let var v = Vect.set (MonT.register (Monomial.var v)) (Int 1) Vect.null + let of_monomial m = + let v = MonT.register m in + Vect.set v (Int 1) Vect.null - let output_mon o (x,v) = - Printf.fprintf o "%s.%a +" (string_of_num v) Monomial.pp (MonT.retrieve x) + let linpol_of_pol p = + Poly.fold + (fun mon num vct -> + let vr = MonT.register mon in + Vect.set vr num vct) p Vect.null + let pol_of_linpol v = + Vect.fold (fun p vr n -> Poly.add (MonT.retrieve vr) n p) (Poly.constant (Int 0)) v + let coq_poly_of_linpol cst p = - let output_cstr o {coeffs = coeffs ; op = op ; cst = cst} = - Printf.fprintf o "%a %s %s" (pp_list output_mon) coeffs (string_of_op op) (string_of_num cst) + let pol_of_mon m = + Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(CamlToCoq.positive x),CamlToCoq.n v),p)) m (Mc.PEc (cst (Int 1))) in + Vect.fold (fun acc x v -> + let mn = MonT.retrieve x in + Mc.PEadd(Mc.PEmul(Mc.PEc (cst v), pol_of_mon mn),acc)) (Mc.PEc (cst (Int 0))) p + let pp_var o vr = + try + Monomial.pp o (MonT.retrieve vr) (* this is a non-linear variable *) + with Not_found -> Printf.fprintf o "v%i" vr - let linpol_of_pol p = - let (v,c) = - Poly.fold - (fun mon num (vct,cst) -> - if Monomial.is_const mon then (vct,num) - else - let vr = MonT.register mon in - ((vr,num)::vct,cst)) p ([], Int 0) in - normalise (v,c) - let mult v m (vect,c) = - if Monomial.is_const m - then - (Vect.mul v vect, v <*> c) - else - if sign_num v <> 0 - then - let hd = - if sign_num c <> 0 - then [MonT.register m,v <*> c] - else [] in - - let vect = hd @ (List.map (fun (x,n) -> - let x = MonT.retrieve x in - let x_m = MonT.register (Monomial.prod m x) in - (x_m, v <*> n)) vect ) in - normalise (vect , Int 0) - else ([],Int 0) + let pp o p = Vect.pp_gen pp_var o p + + let constant c = + if sign_num c = 0 + then Vect.null + else Vect.set 0 c Vect.null + + + let is_linear p = + Vect.for_all (fun v _ -> + let mn = (MonT.retrieve v) in + Monomial.is_var mn || Monomial.is_const mn) p + + + let factorise x p = + let (px,cx) = Poly.factorise x (pol_of_linpol p) in + (linpol_of_pol px, linpol_of_pol cx) + + + let is_linear_for x p = + let (a,b) = factorise x p in + Vect.is_constant a + + let search_linear p l = + + Vect.find (fun x v -> + if p v + then + let x' = MonT.retrieve x in + match Monomial.get_var x' with + | None -> None + | Some x -> if is_linear_for x l + then Some x + else None + else None) l + + + let search_all_linear p l = + Vect.fold (fun acc x v -> + if p v + then + let x' = MonT.retrieve x in + match Monomial.get_var x' with + | None -> acc + | Some x -> + if is_linear_for x l + then x::acc + else acc + else acc) [] l + + + let product p1 p2 = + linpol_of_pol (Poly.product (pol_of_linpol p1) (pol_of_linpol p2)) + + let addition p1 p2 = Vect.add p1 p2 + + let variables p = Vect.fold + (fun acc v _ -> + ISet.union (Monomial.variables (MonT.retrieve v)) acc) ISet.empty p + + + let pp_goal typ o l = + let vars = List.fold_left (fun acc p -> ISet.union acc (variables (fst p))) ISet.empty l in + let pp_vars o i = ISet.iter (fun v -> Printf.fprintf o "(x%i : %s) " v typ) vars in + + Printf.fprintf o "forall %a\n" pp_vars vars ; + List.iteri (fun i (p,op) -> Printf.fprintf o "(H%i : %a %s 0)\n" i pp p (string_of_op op)) l; + Printf.fprintf o ", False\n" + - let mult v m (vect,c) = - let (vect',c') = mult v m (vect,c) in - if debug then - Printf.printf "mult %s %a (%a,%s) -> (%a,%s)\n" (string_of_num v) Monomial.pp m - (pp_list output_mon) vect (string_of_num c) - (pp_list output_mon) vect' (string_of_num c') ; - (vect',c') - let make_lin_pol v mon = - if Monomial.is_const mon - then [] , v - else [MonT.register mon, v],Int 0 + let collect_square p = + Vect.fold (fun acc v _ -> + let m = (MonT.retrieve v) in + match Monomial.sqrt m with + | None -> acc + | Some s -> MonMap.add s m acc + ) MonMap.empty p - +end + +module ProofFormat = struct + open Big_int + + type prf_rule = + | Annot of string * prf_rule + | Hyp of int + | Def of int + | Cst of Num.num + | Zero + | Square of Vect.t + | MulC of Vect.t * prf_rule + | Gcd of Big_int.big_int * prf_rule + | MulPrf of prf_rule * prf_rule + | AddPrf of prf_rule * prf_rule + | CutPrf of prf_rule + + type proof = + | Done + | Step of int * prf_rule * proof + | Enum of int * prf_rule * Vect.t * prf_rule * proof list + + + let rec output_prf_rule o = function + | Annot(s,p) -> Printf.fprintf o "(%a)@%s" output_prf_rule p s + | Hyp i -> Printf.fprintf o "Hyp %i" i + | Def i -> Printf.fprintf o "Def %i" i + | Cst c -> Printf.fprintf o "Cst %s" (string_of_num c) + | Zero -> Printf.fprintf o "Zero" + | Square s -> Printf.fprintf o "(%a)^2" Poly.pp (LinPoly.pol_of_linpol s) + | MulC(p,pr) -> Printf.fprintf o "(%a) * %a" Poly.pp (LinPoly.pol_of_linpol p) output_prf_rule pr + | MulPrf(p1,p2) -> Printf.fprintf o "%a * %a" output_prf_rule p1 output_prf_rule p2 + | AddPrf(p1,p2) -> Printf.fprintf o "%a + %a" output_prf_rule p1 output_prf_rule p2 + | CutPrf(p) -> Printf.fprintf o "[%a]" output_prf_rule p + | Gcd(c,p) -> Printf.fprintf o "(%a)/%s" output_prf_rule p (string_of_big_int c) + + let rec output_proof o = function + | Done -> Printf.fprintf o "." + | Step(i,p,pf) -> Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf + | Enum(i,p1,v,p2,pl) -> Printf.fprintf o "%i{%a<=%a<=%a}%a" i + output_prf_rule p1 Vect.pp v output_prf_rule p2 + (pp_list ";" output_proof) pl + + let rec pr_rule_max_id = function + | Annot(_,p) -> pr_rule_max_id p + | Hyp i | Def i -> i + | Cst _ | Zero | Square _ -> -1 + | MulC(_,p) | CutPrf p | Gcd(_,p) -> pr_rule_max_id p + | MulPrf(p1,p2)| AddPrf(p1,p2) -> max (pr_rule_max_id p1) (pr_rule_max_id p2) + + let rec proof_max_id = function + | Done -> -1 + | Step(i,pr,prf) -> max i (max (pr_rule_max_id pr) (proof_max_id prf)) + | Enum(i,p1,_,p2,l) -> + let m = max (pr_rule_max_id p1) (pr_rule_max_id p2) in + List.fold_left (fun i prf -> max i (proof_max_id prf)) (max i m) l + + + let rec pr_rule_def_cut id = function + | Annot(_,p) -> pr_rule_def_cut id p + | MulC(p,prf) -> + let (bds,id',prf') = pr_rule_def_cut id prf in + (bds, id', MulC(p,prf')) + | MulPrf(p1,p2) -> + let (bds1,id,p1) = pr_rule_def_cut id p1 in + let (bds2,id,p2) = pr_rule_def_cut id p2 in + (bds2@bds1,id,MulPrf(p1,p2)) + | AddPrf(p1,p2) -> + let (bds1,id,p1) = pr_rule_def_cut id p1 in + let (bds2,id,p2) = pr_rule_def_cut id p2 in + (bds2@bds1,id,AddPrf(p1,p2)) + | CutPrf p -> + let (bds,id,p) = pr_rule_def_cut id p in + ((id,p)::bds,id+1,Def id) + | Gcd(c,p) -> + let (bds,id,p) = pr_rule_def_cut id p in + ((id,p)::bds,id+1,Def id) + | Square _|Cst _|Def _|Hyp _|Zero as x -> ([],id,x) + + + (* Do not define top-level cuts *) + let pr_rule_def_cut id = function + | CutPrf p -> + let (bds,ids,p') = pr_rule_def_cut id p in + bds,ids, CutPrf p' + | p -> pr_rule_def_cut id p + + + let rec implicit_cut p = + match p with + | CutPrf p -> implicit_cut p + | _ -> p + + + let rec pr_rule_collect_hyps pr = + match pr with + | Annot(_,pr) -> pr_rule_collect_hyps pr + | Hyp i | Def i -> ISet.add i ISet.empty + | Cst _ | Zero | Square _ -> ISet.empty + | MulC(_,pr) | Gcd(_,pr)| CutPrf pr -> pr_rule_collect_hyps pr + | MulPrf(p1,p2) | AddPrf(p1,p2) -> ISet.union (pr_rule_collect_hyps p1) (pr_rule_collect_hyps p2) + + let simplify_proof p = + let rec simplify_proof p = + match p with + | Done -> (Done, ISet.empty) + | Step(i,pr,Done) -> (p, ISet.add i (pr_rule_collect_hyps pr)) + | Step(i,pr,prf) -> + let (prf',hyps) = simplify_proof prf in + if not (ISet.mem i hyps) + then (prf',hyps) + else + (Step(i,pr,prf'), ISet.add i (ISet.union (pr_rule_collect_hyps pr) hyps)) + | Enum(i,p1,v,p2,pl) -> + let (pl,hl) = List.split (List.map simplify_proof pl) in + let hyps = List.fold_left ISet.union ISet.empty hl in + (Enum(i,p1,v,p2,pl),ISet.add i (ISet.union (ISet.union (pr_rule_collect_hyps p1) (pr_rule_collect_hyps p2)) hyps)) in + fst (simplify_proof p) + + + let rec normalise_proof id prf = + match prf with + | Done -> (id,Done) + | Step(i,Gcd(c,p),Done) -> normalise_proof id (Step(i,p,Done)) + | Step(i,p,prf) -> + let bds,id,p' = pr_rule_def_cut id p in + let (id,prf) = normalise_proof id prf in + let prf = List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc)) + (Step(i,p',prf)) bds in + + (id,prf) + | Enum(i,p1,v,p2,pl) -> + (* Why do I have top-level cuts ? *) + (* let p1 = implicit_cut p1 in + let p2 = implicit_cut p2 in + let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in + (List.fold_left max 0 ids , + Enum(i,p1,v,p2,prfs)) + *) + + let bds1,id,p1' = pr_rule_def_cut id (implicit_cut p1) in + let bds2,id,p2' = pr_rule_def_cut id (implicit_cut p2) in + let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in + (List.fold_left max 0 ids , + List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc)) + (Enum(i,p1',v,p2',prfs)) (bds2@bds1)) + + + let normalise_proof id prf = + let prf = simplify_proof prf in + let res = normalise_proof id prf in + if debug then Printf.printf "normalise_proof %a -> %a" output_proof prf output_proof (snd res) ; + res - let xpivot_eq (c,prf) x v (c',prf') = - if debug then Printf.printf "xpivot_eq {%a} %a %s {%a}\n" - output_cstr c - Monomial.pp (MonT.retrieve x) - (string_of_num v) output_cstr c' ; + let add_proof x y = + match x, y with + | Zero , p | p , Zero -> p + | _ -> AddPrf(x,y) - let {coeffs = coeffs ; op = op ; cst = cst} = c' in - let m = MonT.retrieve x in + let mul_cst_proof c p = + match sign_num c with + | 0 -> Zero (* This is likely to be a bug *) + | -1 -> MulC(LinPoly.constant c,p) (* [p] should represent an equality *) + | 1 -> + if eq_num (Int 1) c + then p + else MulPrf(Cst c,p) + | _ -> assert false - let apply_pivot (vqn,q,n) (c',prf') = - (* Morally, we have (Vect.get (q*x^n) c'.coeffs) = vmn with n >=0 *) - let cc' = abs_num v in - let cc_num = Int (- (sign_num v)) <*> vqn in - let cc_mon = Monomial.prod q (Monomial.exp m (n-1)) in + let mul_proof p1 p2 = + match p1 , p2 with + | Zero , _ | _ , Zero -> Zero + | Cst (Int 1) , p | p , Cst (Int 1) -> p + | _ , _ -> MulPrf(p1,p2) - let (c_coeff,c_cst) = mult cc_num cc_mon (c.coeffs, minus_num c.cst) in - - let c' = {coeffs = Vect.add (Vect.mul cc' c'.coeffs) c_coeff ; op = op ; cst = (minus_num c_cst) <+> (cc' <*> c'.cst)} in - let prf' = add_proof - (mul_proof_ext (make_lin_pol cc_num cc_mon) prf) - (mul_proof (numerator cc') prf') in - if debug then Printf.printf "apply_pivot -> {%a}\n" output_cstr c' ; - (c',prf') in + let proof_of_farkas env vect = + Vect.fold (fun prf x n -> + add_proof (mul_cst_proof n (IMap.find x env)) prf) Zero vect - let cmp (q,n) (q',n') = - if n < n' then -1 - else if n = n' then Monomial.compare q q' - else 1 in - - let find_pivot (c',prf') = - let (v,q,n) = List.fold_left - (fun (v,q,n) (x,v') -> - let x = MonT.retrieve x in - let (q',n') = Monomial.div x m in - if cmp (q,n) (q',n') = -1 then (v',q',n') else (v,q,n)) (Int 0, Monomial.const,0) c'.coeffs in - if n > 0 then Some (v,q,n) else None in + module Env = struct - let rec pivot (q,n) (c',prf') = - match find_pivot (c',prf') with - | None -> (c',prf') - | Some(v,q',n') -> - if cmp (q',n') (q,n) = -1 - then pivot (q',n') (apply_pivot (v,q',n') (c',prf')) - else (c',prf') in + let rec string_of_int_list l = + match l with + | [] -> "" + | i::l -> Printf.sprintf "%i,%s" i (string_of_int_list l) - pivot (Monomial.const,max_int) (c',prf') + let id_of_hyp hyp l = + let rec xid_of_hyp i l' = + match l' with + | [] -> failwith (Printf.sprintf "id_of_hyp %i %s" hyp (string_of_int_list l)) + | hyp'::l' -> if Pervasives.(=) hyp hyp' then i else xid_of_hyp (i+1) l' in + xid_of_hyp 0 l - let pivot_eq x (c,prf) = - match Vect.get x c.coeffs with - | None -> (fun x -> None) - | Some v -> fun cp' -> Some (xpivot_eq (c,prf) x v cp') + end + let cmpl_prf_rule norm (cst:num-> 'a) env prf = + let rec cmpl = + function + | Annot(s,p) -> cmpl p + | Hyp i | Def i -> Mc.PsatzIn (CamlToCoq.nat (Env.id_of_hyp i env)) + | Cst i -> Mc.PsatzC (cst i) + | Zero -> Mc.PsatzZ + | MulPrf(p1,p2) -> Mc.PsatzMulE(cmpl p1, cmpl p2) + | AddPrf(p1,p2) -> Mc.PsatzAdd(cmpl p1 , cmpl p2) + | MulC(lp,p) -> let lp = norm (LinPoly.coq_poly_of_linpol cst lp) in + Mc.PsatzMulC(lp,cmpl p) + | Square lp -> Mc.PsatzSquare (norm (LinPoly.coq_poly_of_linpol cst lp)) + | _ -> failwith "Cuts should already be compiled" in + cmpl prf + + + + + let cmpl_prf_rule_z env r = cmpl_prf_rule Mc.normZ (fun x -> CamlToCoq.bigint (numerator x)) env r + + let rec cmpl_proof env = function + | Done -> Mc.DoneProof + | Step(i,p,prf) -> + begin + match p with + | CutPrf p' -> + Mc.CutProof(cmpl_prf_rule_z env p', cmpl_proof (i::env) prf) + | _ -> Mc.RatProof(cmpl_prf_rule_z env p,cmpl_proof (i::env) prf) + end + | Enum(i,p1,_,p2,l) -> + Mc.EnumProof(cmpl_prf_rule_z env p1,cmpl_prf_rule_z 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 + cmpl_proof env prf + + let rec eval_prf_rule env = function + | Annot(s,p) -> eval_prf_rule env p + | Hyp i | Def i -> env i + | Cst n -> (Vect.set 0 n Vect.null, + match Num.compare_num n (Int 0) with + | 0 -> Ge + | 1 -> Gt + | _ -> failwith "eval_prf_rule : negative constant" + ) + | Zero -> (Vect.null, Ge) + | Square v -> (LinPoly.product v v,Ge) + | MulC(v, p) -> + let (p1,o) = eval_prf_rule env p in + begin match o with + | Eq -> (LinPoly.product v p1,Eq) + | _ -> + Printf.fprintf stdout "MulC(%a,%a) invalid 2d arg %a %s" Vect.pp v output_prf_rule p Vect.pp p1 (string_of_op o); + failwith "eval_prf_rule : not an equality" + end + | Gcd(g,p) -> let (v,op) = eval_prf_rule env p in + (Vect.div (Big_int g) v, op) + | MulPrf(p1,p2) -> + let (v1,o1) = eval_prf_rule env p1 in + let (v2,o2) = eval_prf_rule env p2 in + (LinPoly.product v1 v2, opMult o1 o2) + | AddPrf(p1,p2) -> + let (v1,o1) = eval_prf_rule env p1 in + let (v2,o2) = eval_prf_rule env p2 in + (LinPoly.addition v1 v2, opAdd o1 o2) + | CutPrf p -> eval_prf_rule env p + + + let is_unsat (p,o) = + let (c,r) = Vect.decomp_cst p in + if Vect.is_null r + then not (eval_op o c (Int 0)) + else false + + let rec eval_proof env p = + match p with + | Done -> failwith "Proof is not finished" + | Step(i, prf, rst) -> + let (p,o) = eval_prf_rule (fun i -> IMap.find i env) prf in + if is_unsat (p,o) then true + else + if Pervasives.(=) rst Done + then + begin + Printf.fprintf stdout "Last inference %a %s\n" LinPoly.pp p (string_of_op o); + false + end + else eval_proof (IMap.add i (p,o) env) rst + | Enum(i,r1,v,r2,l) -> let _ = eval_prf_rule (fun i -> IMap.find i env) r1 in + let _ = eval_prf_rule (fun i -> IMap.find i env) r2 in + (* Should check bounds *) + failwith "Not implemented" end + +module WithProof = struct + + type t = ((LinPoly.t * op) * ProofFormat.prf_rule) + + let annot s (p,prf) = (p, ProofFormat.Annot(s,prf)) + + let output o ((lp,op),prf) = + Printf.fprintf o "%a %s 0 by %a\n" LinPoly.pp lp (string_of_op op) ProofFormat.output_prf_rule prf + + exception InvalidProof + + let zero = ((Vect.null,Eq), ProofFormat.Zero) + + + let of_cstr (c,prf) = + (Vect.set 0 (Num.minus_num (c.cst)) c.coeffs,c.op), prf + + let product : t -> t -> t = fun ((p1,o1),prf1) ((p2,o2),prf2) -> + ((LinPoly.product p1 p2 , opMult o1 o2), ProofFormat.mul_proof prf1 prf2) + + let addition : t -> t -> t = fun ((p1,o1),prf1) ((p2,o2),prf2) -> + ((Vect.add p1 p2, opAdd o1 o2), ProofFormat.add_proof prf1 prf2) + + let mult p ((p1,o1),prf1) = + match o1 with + | Eq -> ((LinPoly.product p p1,o1), ProofFormat.MulC(p, prf1)) + | Gt| Ge -> let (n,r) = Vect.decomp_cst p in + if Vect.is_null r && n >/ Int 0 + then ((LinPoly.product p p1, o1), ProofFormat.mul_cst_proof n prf1) + else raise InvalidProof + + + let cutting_plane ((p,o),prf) = + let (c,p') = Vect.decomp_cst p in + let g = (Vect.gcd p') in + if (Big_int.eq_big_int Big_int.unit_big_int g) || c =/ Int 0 || + not (Big_int.eq_big_int (denominator c) Big_int.unit_big_int) + then None (* Nothing to do *) + else + let c1 = c // (Big_int g) in + let c1' = Num.floor_num c1 in + if c1 =/ c1' + then None + else + match o with + | Eq -> Some ((Vect.set 0 (Int (-1)) Vect.null,Eq), ProofFormat.Gcd(g,prf)) + | Gt -> failwith "cutting_plane ignore strict constraints" + | Ge -> + (* This is a non-trivial common divisor *) + Some ((Vect.set 0 c1' (Vect.div (Big_int g) p),o),ProofFormat.Gcd(g, prf)) + + + let construct_sign p = + let (c,p') = Vect.decomp_cst p in + if Vect.is_null p' + then + Some (begin match sign_num c with + | 0 -> (true, Eq, ProofFormat.Zero) + | 1 -> (true,Gt, ProofFormat.Cst c) + | _ (*-1*) -> (false,Gt, ProofFormat.Cst (minus_num c)) + end) + else None + + + let get_sign l p = + match construct_sign p with + | None -> begin + try + let ((p',o),prf) = + List.find (fun ((p',o),prf) -> Vect.equal p p') l in + Some (true,o,prf) + with Not_found -> + let p = Vect.uminus p in + try + let ((p',o),prf) = List.find (fun ((p',o),prf) -> Vect.equal p p') l in + Some (false,o,prf) + with Not_found -> None + end + | Some s -> Some s + + + let mult_sign : bool -> t -> t = fun b ((p,o),prf) -> + if b then ((p,o),prf) + else ((Vect.uminus p,o),prf) + + + let rec linear_pivot sys ((lp1,op1), prf1) x ((lp2,op2), prf2) = + + (* lp1 = a1.x + b1 *) + let (a1,b1) = LinPoly.factorise x lp1 in + + (* lp2 = a2.x + b2 *) + let (a2,b2) = LinPoly.factorise x lp2 in + + if Vect.is_null a2 + then (* We are done *) + Some ((lp2,op2),prf2) + else + match op1,op2 with + | Eq , (Ge|Gt) -> begin + match get_sign sys a1 with + | None -> None (* Impossible to pivot without sign information *) + | Some(b,o,prf) -> + let sa1 = mult_sign b ((a1,o),prf) in + let sa2 = if b then (Vect.uminus a2) else a2 in + + let ((lp2,op2),prf2) = + addition (product sa1 ((lp2,op2),prf2)) + (mult sa2 ((lp1,op1),prf1)) in + linear_pivot sys ((lp1,op1),prf1) x ((lp2,op2),prf2) + + end + | Eq , Eq -> + let ((lp2,op2),prf2) = addition (mult a1 ((lp2,op2),prf2)) + (mult (Vect.uminus a2) ((lp1,op1),prf1)) in + linear_pivot sys ((lp1,op1),prf1) x ((lp2,op2),prf2) + + | (Ge | Gt) , (Ge| Gt) -> begin + match get_sign sys a1 , get_sign sys a2 with + | Some(b1,o1,p1) , Some(b2,o2,p2) -> + if b1 <> b2 + then + let ((lp2,op2),prf2) = + addition (product (mult_sign b1 ((a1,o1), p1)) ((lp2,op2),prf2)) + (product (mult_sign b2 ((a2,o2), p2)) ((lp1,op1),prf1)) in + linear_pivot sys ((lp1,op1),prf1) x ((lp2,op2),prf2) + else None + | _ -> None + end + | (Ge|Gt) , Eq -> failwith "pivot: equality as second argument" + +end + + +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli new file mode 100644 index 0000000000..f5e9a9f34c --- /dev/null +++ b/plugins/micromega/polynomial.mli @@ -0,0 +1,324 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Mutils + +module Mc = Micromega + +val max_nb_cstr : int ref + +type var = int + +module Monomial : sig + (** A monomial is represented by a multiset of variables *) + type t + + (** [fold f m acc] + folds over the variables with multiplicities *) + val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a + + (** [const] + @return the empty monomial i.e. without any variable *) + val const : t + + (** [var x] + @return the monomial x^1 *) + val var : var -> t + + (** [sqrt m] + @return [Some r] iff r^2 = m *) + val sqrt : t -> t option + + (** [is_var m] + @return [true] iff m = x^1 for some variable x *) + val is_var : t -> bool + + (** [div m1 m2] + @return a pair [mr,n] such that mr * (m2)^n = m1 where n is maximum *) + val div : t -> t -> t * int + + (** [compare m1 m2] provides a total order over monomials*) + val compare : t -> t -> int + + (** [variables m] + @return the set of variables with (strictly) positive multiplicities *) + val variables : t -> ISet.t +end + +module MonMap : sig + include Map.S with type key = Monomial.t + + val union : (Monomial.t -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t +end + +module Poly : sig + (** Representation of polonomial with rational coefficient. + a1.m1 + ... + c where + - ai are rational constants (num type) + - mi are monomials + - c is a rational constant + + *) + + type t + + (** [constant c] + @return the constant polynomial c *) + val constant : Num.num -> t + + (** [variable x] + @return the polynomial 1.x^1 *) + val variable : var -> t + + (** [addition p1 p2] + @return the polynomial p1+p2 *) + val addition : t -> t -> t + + (** [product p1 p2] + @return the polynomial p1*p2 *) + val product : t -> t -> t + + (** [uminus p] + @return the polynomial -p i.e product by -1 *) + val uminus : t -> t + + (** [get mi p] + @return the coefficient ai of the monomial mi. *) + val get : Monomial.t -> t -> Num.num + + + (** [fold f p a] folds f over the monomials of p with non-zero coefficient *) + val fold : (Monomial.t -> Num.num -> 'a -> 'a) -> t -> 'a -> 'a + + (** [add m n p] + @return the polynomial n*m + p *) + val add : Monomial.t -> Num.num -> t -> t + +end + +type cstr = {coeffs : Vect.t ; op : op ; cst : Num.num} (** Representation of linear constraints *) +and op = Eq | Ge | Gt + +val eval_op : op -> Num.num -> Num.num -> bool + +(*val opMult : op -> op -> op*) + +val opAdd : op -> op -> op + +(** [is_strict c] + @return whether the constraint is strict i.e. c.op = Gt *) +val is_strict : cstr -> bool + +exception Strict + +module LinPoly : sig + (** Linear(ised) polynomials represented as a [Vect.t] + i.e a sorted association list. + The constant is the coefficient of the variable 0 + + Each linear polynomial can be interpreted as a multi-variate polynomial. + There is a bijection mapping between a linear variable and a monomial + (see module [MonT]) + *) + + type t = Vect.t + + (** Each variable of a linear polynomial is mapped to a monomial. + This is done using the monomial tables of the module MonT. *) + + module MonT : sig + (** [clear ()] clears the mapping. *) + val clear : unit -> unit + + (** [retrieve x] + @return the monomial corresponding to the variable [x] *) + val retrieve : int -> Monomial.t + + end + + (** [linpol_of_pol p] linearise the polynomial p *) + val linpol_of_pol : Poly.t -> t + + (** [var x] + @return 1.y where y is the variable index of the monomial x^1. + *) + val var : var -> t + + (** [coq_poly_of_linpol c p] + @param p is a multi-variate polynomial. + @param c maps a rational to a Coq polynomial coefficient. + @return the coq expression corresponding to polynomial [p].*) + val coq_poly_of_linpol : (Num.num -> 'a) -> t -> 'a Mc.pExpr + + (** [of_monomial m] + @returns 1.x where x is the variable (index) for monomial m *) + val of_monomial : Monomial.t -> t + + (** [variables p] + @return the set of variables of the polynomial p + interpreted as a multi-variate polynomial *) + val variables : t -> ISet.t + + (** [is_linear p] + @return whether the multi-variate polynomial is linear. *) + val is_linear : t -> bool + + (** [is_linear_for x p] + @return true if the polynomial is linear in x + i.e can be written c*x+r where c is a constant and r is independent from x *) + val is_linear_for : var -> t -> bool + + (** [constant c] + @return the constant polynomial c + *) + val constant : Num.num -> t + + (** [search_linear pred p] + @return a variable x such p = a.x + b such that + p is linear in x i.e x does not occur in b and + a is a constant such that [pred a] *) + + val search_linear : (Num.num -> bool) -> t -> var option + + (** [search_all_linear pred p] + @return all the variables x such p = a.x + b such that + p is linear in x i.e x does not occur in b and + a is a constant such that [pred a] *) + val search_all_linear : (Num.num -> bool) -> t -> var list + + (** [product p q] + @return the product of the polynomial [p*q] *) + val product : t -> t -> t + + (** [factorise x p] + @return [a,b] such that [p = a.x + b] + and [x] does not occur in [b] *) + val factorise : var -> t -> t * t + + (** [collect_square p] + @return a mapping m such that m[s] = s^2 + for every s^2 that is a monomial of [p] *) + val collect_square : t -> Monomial.t MonMap.t + + + (** [pp_var o v] pretty-prints a monomial indexed by v. *) + val pp_var : out_channel -> var -> unit + + (** [pp o p] pretty-prints a polynomial. *) + val pp : out_channel -> t -> unit + + (** [pp_goal typ o l] pretty-prints the list of constraints as a Coq goal. *) + val pp_goal : string -> out_channel -> (t * op) list -> unit + +end + +module ProofFormat : sig + (** Proof format used by the proof-generating procedures. + It is fairly close to Coq format but a bit more liberal. + + It is used for proofs over Z, Q, R. + However, certain constructions e.g. [CutPrf] are only relevant for Z. + *) + + type prf_rule = + | Annot of string * prf_rule + | Hyp of int + | Def of int + | Cst of Num.num + | Zero + | Square of Vect.t + | MulC of Vect.t * prf_rule + | Gcd of Big_int.big_int * prf_rule + | MulPrf of prf_rule * prf_rule + | AddPrf of prf_rule * prf_rule + | CutPrf of prf_rule + + type proof = + | Done + | Step of int * prf_rule * proof + | Enum of int * prf_rule * Vect.t * prf_rule * proof list + + val pr_rule_max_id : prf_rule -> int + + val proof_max_id : proof -> int + + val normalise_proof : int -> proof -> int * proof + + val output_prf_rule : out_channel -> prf_rule -> unit + + val output_proof : out_channel -> proof -> unit + + val add_proof : prf_rule -> prf_rule -> prf_rule + + val mul_cst_proof : Num.num -> prf_rule -> prf_rule + + val mul_proof : prf_rule -> prf_rule -> prf_rule + + val compile_proof : int list -> proof -> Micromega.zArithProof + + val cmpl_prf_rule : ('a Micromega.pExpr -> 'a Micromega.pol) -> + (Num.num -> 'a) -> (int list) -> prf_rule -> 'a Micromega.psatz + + val proof_of_farkas : prf_rule IMap.t -> Vect.t -> prf_rule + + val eval_prf_rule : (int -> LinPoly.t * op) -> prf_rule -> LinPoly.t * op + + val eval_proof : (LinPoly.t * op) IMap.t -> proof -> bool + +end + +val output_cstr : out_channel -> cstr -> unit + +val opMult : op -> op -> op + +(** [module WithProof] constructs polynomials packed with the proof that their sign is correct. *) +module WithProof : +sig + + type t = (LinPoly.t * op) * ProofFormat.prf_rule + + (** [InvalidProof] is raised if the operation is invalid. *) + exception InvalidProof + + val annot : string -> t -> t + + val of_cstr : cstr * ProofFormat.prf_rule -> t + + (** [out_channel chan c] pretty-prints the constraint [c] over the channel [chan] *) + val output : out_channel -> t -> unit + + (** [zero] represents the tautology (0=0) *) + val zero : t + + (** [product p q] + @return the polynomial p*q with its sign and proof *) + val product : t -> t -> t + + (** [addition p q] + @return the polynomial p+q with its sign and proof *) + val addition : t -> t -> t + + (** [mult p q] + @return the polynomial p*q with its sign and proof. + @raise InvalidProof if p is not a constant and p is not an equality *) + val mult : LinPoly.t -> t -> t + + (** [cutting_plane p] does integer reasoning and adjust the constant to be integral *) + val cutting_plane : t -> t option + + (** [linear_pivot sys p x q] + @return the polynomial [q] where [x] is eliminated using the polynomial [p] + The pivoting operation is only defined if + - p is linear in x i.e p = a.x+b and x neither occurs in a and b + - The pivoting also requires some sign conditions for [a] + *) + val linear_pivot : t list -> t -> Vect.var -> t -> t option + +end diff --git a/plugins/micromega/simplex.ml b/plugins/micromega/simplex.ml new file mode 100644 index 0000000000..8d8c6ea90b --- /dev/null +++ b/plugins/micromega/simplex.ml @@ -0,0 +1,621 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** A naive simplex *) +open Polynomial +open Num +open Util +open Mutils + +let debug = false + +type iset = unit IMap.t + +type tableau = Vect.t IMap.t (** Mapping basic variables to their equation. + All variables >= than a threshold rst are restricted.*) +module Restricted = + struct + type t = + { + base : int; (** All variables above [base] are restricted *) + exc : int option (** Except [exc] which is currently optimised *) + } + + let pp o {base;exc} = + Printf.fprintf o ">= %a " LinPoly.pp_var base; + match exc with + | None ->Printf.fprintf o "-" + | Some x ->Printf.fprintf o "-%a" LinPoly.pp_var base + + let is_exception (x:var) (r:t) = + match r.exc with + | None -> false + | Some x' -> x = x' + + let restrict x rst = + if is_exception x rst + then + {base = rst.base;exc= None} + else failwith (Printf.sprintf "Cannot restrict %i" x) + + + let is_restricted x r0 = + x >= r0.base && not (is_exception x r0) + + let make x = {base = x ; exc = None} + + let set_exc x rst = {base = rst.base ; exc = Some x} + + let fold rst f m acc = + IMap.fold (fun k v acc -> + if is_exception k rst then acc + else f k v acc) (IMap.from rst.base m) acc + + end + + + +let pp_row o v = LinPoly.pp o v + +let output_tableau o t = + IMap.iter (fun k v -> + Printf.fprintf o "%a = %a\n" LinPoly.pp_var k pp_row v) t + +let output_vars o m = + IMap.iter (fun k _ -> Printf.fprintf o "%a " LinPoly.pp_var k) m + + +(** A tableau is feasible iff for every basic restricted variable xi, + we have ci>=0. + + When all the non-basic variables are set to 0, the value of a basic + variable xi is necessarily ci. If xi is restricted, it is feasible + if ci>=0. + *) + + +let unfeasible (rst:Restricted.t) tbl = + Restricted.fold rst (fun k v m -> + if Vect.get_cst v >=/ Int 0 then m + else IMap.add k () m) tbl IMap.empty + + +let is_feasible rst tb = IMap.is_empty (unfeasible rst tb) + +(** Let a1.x1+...+an.xn be a vector of non-basic variables. + It is maximised if all the xi are restricted + and the ai are negative. + + If xi>= 0 (restricted) and ai is negative, + the maximum for ai.xi is obtained for xi = 0 + + Otherwise, it is possible to make ai.xi arbitrarily big: + - if xi is not restricted, take +/- oo depending on the sign of ai + - if ai is positive, take +oo + *) + +let is_maximised_vect rst v = + Vect.for_all (fun xi ai -> + if ai >/ Int 0 + then false + else Restricted.is_restricted xi rst) v + + +(** [is_maximised rst v] + @return None if the variable is not maximised + @return Some v where v is the maximal value + *) +let is_maximised rst v = + try + let (vl,v) = Vect.decomp_cst v in + if is_maximised_vect rst v + then Some vl + else None + with Not_found -> None + +(** A variable xi is unbounded if for every + equation xj= ...ai.xi ... + if ai < 0 then xj is not restricted. + As a result, even if we + increase the value of xi, it is always + possible to adjust the value of xj without + violating a restriction. + *) + +(* let is_unbounded rst tbl vr = + IMap.for_all (fun x v -> if Vect.get vr v </ Int 0 + then not (IMap.mem vr rst) + else true + ) tbl + *) + +type result = + | Max of num (** Maximum is reached *) + | Ubnd of var (** Problem is unbounded *) + | Feas (** Problem is feasible *) + +type pivot = + | Done of result + | Pivot of int * int * num + + + + +type simplex = + | Opt of tableau * result + +(** For a row, x = ao.xo+...+ai.xi + a valid pivot variable is such that it can improve the value of xi. + it is the case, if xi is unrestricted (increase if ai> 0, decrease if ai < 0) + xi is restricted but ai > 0 + +This is the entering variable. + *) + +let rec find_pivot_column (rst:Restricted.t) (r:Vect.t) = + match Vect.choose r with + | None -> failwith "find_pivot_column" + | Some(xi,ai,r') -> if ai </ Int 0 + then if Restricted.is_restricted xi rst + then find_pivot_column rst r' (* ai.xi cannot be improved *) + else (xi, -1) (* r is not restricted, sign of ai does not matter *) + else (* ai is positive, xi can be increased *) + (xi,1) + +(** Finding the variable leaving the basis is more subtle because we need to: + - increase the objective function + - make sure that the entering variable has a feasible value + - but also that after pivoting all the other basic variables are still feasible. + This explains why we choose the pivot with the smallest score + *) + +let min_score s (i1,sc1) = + match s with + | None -> Some (i1,sc1) + | Some(i0,sc0) -> + if sc0 </ sc1 then s + else if sc1 </ sc0 then Some (i1,sc1) + else if i0 < i1 then s else Some(i1,sc1) + +let find_pivot_row rst tbl j sgn = + Restricted.fold rst + (fun i' v res -> + let aij = Vect.get j v in + if (Int sgn) */ aij </ Int 0 + then (* This would improve *) + let score' = Num.abs_num ((Vect.get_cst v) // aij) in + min_score res (i',score') + else res) tbl None + +let safe_find err x t = + try + IMap.find x t + with Not_found -> + if debug + then Printf.fprintf stdout "safe_find %s x%i %a\n" err x output_tableau t; + failwith err + + +(** [find_pivot vr t] aims at improving the objective function of the basic variable vr *) +let find_pivot vr (rst:Restricted.t) tbl = + (* Get the objective of the basic variable vr *) + let v = safe_find "find_pivot" vr tbl in + match is_maximised rst v with + | Some mx -> Done (Max mx) (* Maximum is reached; we are done *) + | None -> + (* Extract the vector *) + let (_,v) = Vect.decomp_cst v in + let (j',sgn) = find_pivot_column rst v in + match find_pivot_row rst (IMap.remove vr tbl) j' sgn with + | None -> Done (Ubnd j') + | Some (i',sc) -> Pivot(i', j', sc) + +(** [solve_column c r e] + @param c is a non-basic variable + @param r is a basic variable + @param e is a vector such that r = e + and e is of the form ai.c+e' + @return the vector (-r + e').-1/ai i.e + c = (r - e')/ai + *) + +let solve_column (c : var) (r : var) (e : Vect.t) : Vect.t = + let a = Vect.get c e in + if a =/ Int 0 + then failwith "Cannot solve column" + else + let a' = (Int (-1) // a) in + Vect.mul a' (Vect.set r (Int (-1)) (Vect.set c (Int 0) e)) + +(** [pivot_row r c e] + @param c is such that c = e + @param r is a vector r = g.c + r' + @return g.e+r' *) + +let pivot_row (row: Vect.t) (c : var) (e : Vect.t) : Vect.t = + let g = Vect.get c row in + if g =/ Int 0 + then row + else Vect.mul_add g e (Int 1) (Vect.set c (Int 0) row) + +let pivot_with (m : tableau) (v: var) (p : Vect.t) = + IMap.map (fun (r:Vect.t) -> pivot_row r v p) m + +let pivot (m : tableau) (r : var) (c : var) = + let row = safe_find "pivot" r m in + let piv = solve_column c r row in + IMap.add c piv (pivot_with (IMap.remove r m) c piv) + + +let adapt_unbounded vr x rst tbl = + if Vect.get_cst (IMap.find vr tbl) >=/ Int 0 + then tbl + else pivot tbl vr x + +module BaseSet = Set.Make(struct type t = iset let compare = IMap.compare (fun x y -> 0) end) + +let get_base tbl = IMap.mapi (fun k _ -> ()) tbl + +let simplex opt vr rst tbl = + let b = ref BaseSet.empty in + +let rec simplex opt vr rst tbl = + + if debug then begin + let base = get_base tbl in + if BaseSet.mem base !b + then Printf.fprintf stdout "Cycling detected\n" + else b := BaseSet.add base !b + end; + + if debug && not (is_feasible rst tbl) + then + begin + let m = unfeasible rst tbl in + Printf.fprintf stdout "Simplex error\n"; + Printf.fprintf stdout "The current tableau is not feasible\n"; + Printf.fprintf stdout "Restricted >= %a\n" Restricted.pp rst ; + output_tableau stdout tbl; + Printf.fprintf stdout "Error for variables %a\n" output_vars m + end; + + if not opt && (Vect.get_cst (IMap.find vr tbl) >=/ Int 0) + then Opt(tbl,Feas) + else + match find_pivot vr rst tbl with + | Done r -> + begin match r with + | Max _ -> Opt(tbl, r) + | Ubnd x -> + let t' = adapt_unbounded vr x rst tbl in + Opt(t',r) + | Feas -> raise (Invalid_argument "find_pivot") + end + | Pivot(i,j,s) -> + if debug then begin + Printf.fprintf stdout "Find pivot for x%i(%s)\n" vr (string_of_num s); + Printf.fprintf stdout "Leaving variable x%i\n" i; + Printf.fprintf stdout "Entering variable x%i\n" j; + end; + let m' = pivot tbl i j in + simplex opt vr rst m' in + +simplex opt vr rst tbl + + + +type certificate = + | Unsat of Vect.t + | Sat of tableau * var option + +(** [normalise_row t v] + @return a row obtained by pivoting the basic variables of the vector v + *) + +let normalise_row (t : tableau) (v: Vect.t) = + Vect.fold (fun acc vr ai -> try + let e = IMap.find vr t in + Vect.add (Vect.mul ai e) acc + with Not_found -> Vect.add (Vect.set vr ai Vect.null) acc) + Vect.null v + +let normalise_row (t : tableau) (v: Vect.t) = + let v' = normalise_row t v in + if debug then Printf.fprintf stdout "Normalised Optimising %a\n" LinPoly.pp v'; + v' + +let add_row (nw :var) (t : tableau) (v : Vect.t) : tableau = + IMap.add nw (normalise_row t v) t + +(** [push_real] performs reasoning over the rationals *) +let push_real (opt : bool) (nw : var) (v : Vect.t) (rst: Restricted.t) (t : tableau) : certificate = + if debug + then begin Printf.fprintf stdout "Current Tableau\n%a\n" output_tableau t; + Printf.fprintf stdout "Optimising %a=%a\n" LinPoly.pp_var nw LinPoly.pp v + end; + match simplex opt nw rst (add_row nw t v) with + | Opt(t',r) -> (* Look at the optimal *) + match r with + | Ubnd x-> + if debug then Printf.printf "The objective is unbounded (variable %a)\n" LinPoly.pp_var x; + Sat (t',Some x) (* This is sat and we can extract a value *) + | Feas -> Sat (t',None) + | Max n -> + if debug then begin + Printf.printf "The objective is maximised %s\n" (string_of_num n); + Printf.printf "%a = %a\n" LinPoly.pp_var nw pp_row (IMap.find nw t') + end; + + if n >=/ Int 0 + then Sat (t',None) + else + let v' = safe_find "push_real" nw t' in + Unsat (Vect.set nw (Int 1) (Vect.set 0 (Int 0) (Vect.mul (Int (-1)) v'))) + + +(** One complication is that equalities needs some pre-processing.contents + *) +open Mutils +open Polynomial + +let fresh_var l = + 1 + + try + (ISet.max_elt (List.fold_left (fun acc c -> ISet.union acc (Vect.variables c.coeffs)) ISet.empty l)) + with Not_found -> 0 + + +(*type varmap = (int * bool) IMap.t*) + + +let make_certificate vm l = + Vect.normalise (Vect.fold (fun acc x n -> + let (x',b) = IMap.find x vm in + Vect.set x' (if b then n else Num.minus_num n) acc) Vect.null l) + + + + + +let eliminate_equalities (vr0:var) (l:Polynomial.cstr list) = + let rec elim idx vr vm l acc = + match l with + | [] -> (vr,vm,acc) + | c::l -> match c.op with + | Ge -> let v = Vect.set 0 (minus_num c.cst) c.coeffs in + elim (idx+1) (vr+1) (IMap.add vr (idx,true) vm) l ((vr,v)::acc) + | Eq -> let v1 = Vect.set 0 (minus_num c.cst) c.coeffs in + let v2 = Vect.mul (Int (-1)) v1 in + let vm = IMap.add vr (idx,true) (IMap.add (vr+1) (idx,false) vm) in + elim (idx+1) (vr+2) vm l ((vr,v1)::(vr+1,v2)::acc) + | Gt -> raise Strict in + elim 0 vr0 IMap.empty l [] + +let find_solution rst tbl = + IMap.fold (fun vr v res -> if Restricted.is_restricted vr rst + then res + else Vect.set vr (Vect.get_cst v) res) tbl Vect.null + +let choose_conflict (sol:Vect.t) (l: (var * Vect.t) list) = + let esol = Vect.set 0 (Int 1) sol in + let is_conflict (x,v) = + if Vect.dotproduct esol v >=/ Int 0 + then None else Some(x,v) in + let (c,r) = extract is_conflict l in + match c with + | Some (c,_) -> Some (c,r) + | None -> match l with + | [] -> None + | e::l -> Some(e,l) + +(*let remove_redundant rst t = + IMap.fold (fun k v m -> if Restricted.is_restricted k rst && Vect.for_all (fun x _ -> x == 0 || Restricted.is_restricted x rst) v + then begin + if debug then + Printf.printf "%a is redundant\n" LinPoly.pp_var k; + IMap.remove k m + end + else m) t t + *) + + +let rec solve opt l (rst:Restricted.t) (t:tableau) = + let sol = find_solution rst t in + match choose_conflict sol l with + | None -> Inl (rst,t,None) + | Some((vr,v),l) -> + match push_real opt vr v (Restricted.set_exc vr rst) t with + | Sat (t',x) -> + (* let t' = remove_redundant rst t' in*) + begin + match l with + | [] -> Inl(rst,t', x) + | _ -> solve opt l rst t' + end + | Unsat c -> Inr c + +let find_unsat_certificate (l : Polynomial.cstr list ) = + let vr = fresh_var l in + let (_,vm,l') = eliminate_equalities vr l in + + match solve false l' (Restricted.make vr) IMap.empty with + | Inr c -> Some (make_certificate vm c) + | Inl _ -> None + + + +let find_point (l : Polynomial.cstr list) = + let vr = fresh_var l in + let (_,vm,l') = eliminate_equalities vr l in + + match solve false l' (Restricted.make vr) IMap.empty with + | Inl (rst,t,_) -> Some (find_solution rst t) + | _ -> None + + + +let optimise obj l = + let vr0 = fresh_var l in + let (_,vm,l') = eliminate_equalities (vr0+1) l in + + let bound pos res = + match res with + | Opt(_,Max n) -> Some (if pos then n else minus_num n) + | Opt(_,Ubnd _) -> None + | Opt(_,Feas) -> None + in + + match solve false l' (Restricted.make vr0) IMap.empty with + | Inl (rst,t,_) -> + Some (bound false + (simplex true vr0 rst (add_row vr0 t (Vect.uminus obj))), + bound true + (simplex true vr0 rst (add_row vr0 t obj))) + | _ -> None + + + +open Polynomial + +let env_of_list l = + List.fold_left (fun (i,m) l -> (i+1, IMap.add i l m)) (0,IMap.empty) l + + +open ProofFormat + +let make_farkas_certificate (env: WithProof.t IMap.t) vm v = + Vect.fold (fun acc x n -> + add_proof acc + begin + try + let (x',b) = IMap.find x vm in + (mul_cst_proof + (if b then n else (Num.minus_num n)) + (snd (IMap.find x' env))) + with Not_found -> (* This is an introduced hypothesis *) + (mul_cst_proof n (snd (IMap.find x env))) + end) Zero v + +let make_farkas_proof (env: WithProof.t IMap.t) vm v = + Vect.fold (fun wp x n -> + WithProof.addition wp begin + try + let (x', b) = IMap.find x vm in + let n = if b then n else Num.minus_num n in + WithProof.mult (Vect.cst n) (IMap.find x' env) + with Not_found -> + WithProof.mult (Vect.cst n) (IMap.find x env) + end) WithProof.zero v + +(* +let incr_cut rmin x = + match rmin with + | None -> true + | Some r -> Int.compare x r = 1 + *) + +let cut env rmin sol vm (rst:Restricted.t) (x,v) = +(* if not (incr_cut rmin x) + then None + else *) + let (n,r) = Vect.decomp_cst v in + + let nf = Num.floor_num n in + if nf =/ n + then None (* The solution is integral *) + else + (* This is potentially a cut *) + let cut = Vect.normalise + (Vect.fold (fun acc x n -> + if Restricted.is_restricted x rst then + Vect.set x (n -/ (Num.floor_num n)) acc + else acc + ) Vect.null r) in + if debug then Printf.fprintf stdout "Cut vector for %a : %a\n" LinPoly.pp_var x LinPoly.pp cut ; + let cut = make_farkas_proof env vm cut in + + match WithProof.cutting_plane cut with + | None -> None + | Some (v,prf) -> + if debug then begin + Printf.printf "This is a cutting plane:\n" ; + Printf.printf "%a -> %a\n" WithProof.output cut WithProof.output (v,prf); + end; + if Pervasives.(=) (snd v) Eq + then (* Unsat *) Some (x,(v,prf)) + else if eval_op Ge (Vect.dotproduct (fst v) (Vect.set 0 (Int 1) sol)) (Int 0) + then begin + (* Can this happen? *) + if debug then Printf.printf "The cut is feasible - drop it\n"; + None + end + else Some(x,(v,prf)) + +let find_cut env u sol vm rst tbl = + (* find first *) + IMap.fold (fun x v acc -> + match acc with + | None -> cut env u sol vm rst (x,v) + | Some c -> acc) tbl None + +(* +let find_cut env u sol vm rst tbl = + IMap.fold (fun x v acc -> + match acc with + | Some c -> Some c + | None -> cut env u sol vm rst (x,v) + ) tbl None + *) + +let integer_solver lp = + let (l,_) = List.split lp in + let vr0 = fresh_var l in + let (vr,vm,l') = eliminate_equalities vr0 l in + + let _,env = env_of_list (List.map WithProof.of_cstr lp) in + + let insert_row vr v rst tbl = + match push_real true vr v rst tbl with + | Sat (t',x) -> Inl (Restricted.restrict vr rst,t',x) + | Unsat c -> Inr c in + + let rec isolve env cr vr res = + match res with + | Inr c -> Some (Step (vr, make_farkas_certificate env vm (Vect.normalise c),Done)) + | Inl (rst,tbl,x) -> + if debug then begin + Printf.fprintf stdout "Looking for a cut\n"; + Printf.fprintf stdout "Restricted %a ...\n" Restricted.pp rst; + Printf.fprintf stdout "Current Tableau\n%a\n" output_tableau tbl; + end; + let sol = find_solution rst tbl in + + match find_cut env cr (*x*) sol vm rst tbl with + | None -> None + | Some(cr,((v,op),cut)) -> + if Pervasives.(=) op Eq + then (* This is a contradiction *) + Some(Step(vr,CutPrf cut, Done)) + else + let res = insert_row vr v (Restricted.set_exc vr rst) tbl in + let prf = isolve (IMap.add vr ((v,op),Def vr) env) (Some cr) (vr+1) res in + match prf with + | None -> None + | Some p -> Some (Step(vr,CutPrf cut,p)) in + + let res = solve true l' (Restricted.make vr0) IMap.empty in + isolve env None vr res + +let integer_solver lp = + match integer_solver lp with + | None -> None + | Some prf -> if debug + then Printf.fprintf stdout "Proof %a\n" ProofFormat.output_proof prf ; + Some prf diff --git a/plugins/micromega/simplex.mli b/plugins/micromega/simplex.mli new file mode 100644 index 0000000000..9f87e745eb --- /dev/null +++ b/plugins/micromega/simplex.mli @@ -0,0 +1,18 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +open Polynomial + +val optimise : Vect.t -> cstr list -> (Num.num option * Num.num option) option + +val find_point : cstr list -> Vect.t option + +val find_unsat_certificate : cstr list -> Vect.t option + +val integer_solver : (cstr * ProofFormat.prf_rule) list -> ProofFormat.proof option diff --git a/plugins/micromega/sos.ml b/plugins/micromega/sos.ml index e1ceabe9e2..f2dfaa42a5 100644 --- a/plugins/micromega/sos.ml +++ b/plugins/micromega/sos.ml @@ -95,7 +95,7 @@ let dim (v:vector) = fst v;; let vector_const c n = if c =/ Int 0 then vector_0 n - else (n,itlist (fun k -> k |-> c) (1--n) undefined :vector);; + else (n,List.fold_right (fun k -> k |-> c) (1--n) undefined :vector);; let vector_cmul c (v:vector) = let n = dim v in @@ -104,7 +104,7 @@ let vector_cmul c (v:vector) = let vector_of_list l = let n = List.length l in - (n,itlist2 (|->) (1--n) l undefined :vector);; + (n,List.fold_right2 (|->) (1--n) l undefined :vector);; (* ------------------------------------------------------------------------- *) (* Matrices; again rows and columns indexed from 1. *) @@ -145,11 +145,6 @@ let diagonal (v:vector) = (* ------------------------------------------------------------------------- *) (* Monomials. *) (* ------------------------------------------------------------------------- *) - -let monomial_eval assig (m:monomial) = - foldl (fun a x k -> a */ power_num (apply assig x) (Int k)) - (Int 1) m;; - let monomial_1 = (undefined:monomial);; let monomial_var x = (x |=> 1 :monomial);; @@ -166,10 +161,6 @@ let monomial_variables m = dom m;; (* ------------------------------------------------------------------------- *) (* Polynomials. *) (* ------------------------------------------------------------------------- *) - -let eval assig (p:poly) = - foldl (fun a m c -> a +/ c */ monomial_eval assig m) (Int 0) p;; - let poly_0 = (undefined:poly);; let poly_isconst (p:poly) = foldl (fun a m c -> m = monomial_1 && a) true p;; @@ -242,7 +233,7 @@ let string_of_monomial m = if m = monomial_1 then "1" else let vps = List.fold_right (fun (x,k) a -> string_of_varpow x k :: a) (sort humanorder_varpow (graph m)) [] in - end_itlist (fun s t -> s^"*"^t) vps;; + String.concat "*" vps;; let string_of_cmonomial (c,m) = if m = monomial_1 then string_of_num c @@ -289,17 +280,9 @@ let rec poly_of_term t = match t with | Const n -> poly_const n | Var x -> poly_var x | Opp t1 -> poly_neg (poly_of_term t1) -| Inv t1 -> - let p = poly_of_term t1 in - if poly_isconst p then poly_const(Int 1 // eval undefined p) - else failwith "poly_of_term: inverse of non-constant polyomial" | Add (l, r) -> poly_add (poly_of_term l) (poly_of_term r) | Sub (l, r) -> poly_sub (poly_of_term l) (poly_of_term r) | Mul (l, r) -> poly_mul (poly_of_term l) (poly_of_term r) -| Div (l, r) -> - let p = poly_of_term l and q = poly_of_term r in - if poly_isconst q then poly_cmul (Int 1 // eval undefined q) p - else failwith "poly_of_term: division by non-constant polynomial" | Pow (t, n) -> poly_pow (poly_of_term t) n;; @@ -310,7 +293,7 @@ let rec poly_of_term t = match t with let sdpa_of_vector (v:vector) = let n = dim v in let strs = List.map (o (decimalize 20) (element v)) (1--n) in - end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";; + String.concat " " strs ^ "\n";; (* ------------------------------------------------------------------------- *) (* String for a matrix numbered k, in SDPA sparse format. *) @@ -321,7 +304,7 @@ let sdpa_of_matrix k (m:matrix) = let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a) (snd m) [] in let mss = sort (increasing fst) ms in - itlist (fun ((i,j),c) a -> + List.fold_right (fun ((i,j),c) a -> pfx ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c ^ "\n" ^ a) mss "";; @@ -340,7 +323,7 @@ let sdpa_of_problem comment obj mats = "1\n" ^ string_of_int n ^ "\n" ^ sdpa_of_vector obj ^ - itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) + List.fold_right2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) (1--List.length mats) mats "";; (* ------------------------------------------------------------------------- *) @@ -489,11 +472,11 @@ let scale_then = and maximal_element amat acc = foldl (fun maxa m c -> max_num maxa (abs_num c)) acc amat in fun solver obj mats -> - let cd1 = itlist common_denominator mats (Int 1) + let cd1 = List.fold_right common_denominator mats (Int 1) and cd2 = common_denominator (snd obj) (Int 1) in let mats' = List.map (mapf (fun x -> cd1 */ x)) mats and obj' = vector_cmul cd2 obj in - let max1 = itlist maximal_element mats' (Int 0) + let max1 = List.fold_right maximal_element mats' (Int 0) and max2 = maximal_element (snd obj') (Int 0) in let scal1 = pow2 (20-int_of_float(log(float_of_num max1) /. log 2.0)) and scal2 = pow2 (20-int_of_float(log(float_of_num max2) /. log 2.0)) in @@ -551,7 +534,7 @@ let minimal_convex_hull = | (m::ms) -> if in_convex_hull ms m then ms else ms@[m] in let augment m ms = funpow 3 augment1 (m::ms) in fun mons -> - let mons' = itlist augment (List.tl mons) [List.hd mons] in + let mons' = List.fold_right augment (List.tl mons) [List.hd mons] in funpow (List.length mons') augment1 mons';; (* ------------------------------------------------------------------------- *) @@ -612,11 +595,11 @@ let newton_polytope pol = let vars = poly_variables pol in let mons = List.map (fun m -> List.map (fun x -> monomial_degree x m) vars) (dom pol) and ds = List.map (fun x -> (degree x pol + 1) / 2) vars in - let all = itlist (fun n -> allpairs (fun h t -> h::t) (0--n)) ds [[]] + let all = List.fold_right (fun n -> allpairs (fun h t -> h::t) (0--n)) ds [[]] and mons' = minimal_convex_hull mons in let all' = List.filter (fun m -> in_convex_hull mons' (List.map (fun x -> 2 * x) m)) all in - List.map (fun m -> itlist2 (fun v i a -> if i = 0 then a else (v |-> i) a) + List.map (fun m -> List.fold_right2 (fun v i a -> if i = 0 then a else (v |-> i) a) vars m monomial_1) (List.rev all');; (* ------------------------------------------------------------------------- *) @@ -657,8 +640,8 @@ let deration d = foldl (fun a i c -> gcd_num a (numerator c)) (Int 0) (snd l) in (c // (a */ a)),mapa (fun x -> a */ x) l in let d' = List.map adj d in - let a = itlist ((o) lcm_num ( (o) denominator fst)) d' (Int 1) // - itlist ((o) gcd_num ( (o) numerator fst)) d' (Int 0) in + let a = List.fold_right ((o) lcm_num ( (o) denominator fst)) d' (Int 1) // + List.fold_right ((o) gcd_num ( (o) numerator fst)) d' (Int 0) in (Int 1 // a),List.map (fun (c,l) -> (a */ c,l)) d';; (* ------------------------------------------------------------------------- *) @@ -719,7 +702,7 @@ let sdpa_of_blockdiagonal k m = let ents = foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in let entss = sort (increasing fst) ents in - itlist (fun ((b,i,j),c) a -> + List.fold_right (fun ((b,i,j),c) a -> pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c ^ "\n" ^ a) entss "";; @@ -732,10 +715,10 @@ let sdpa_of_blockproblem comment nblocks blocksizes obj mats = "\"" ^ comment ^ "\"\n" ^ string_of_int m ^ "\n" ^ string_of_int nblocks ^ "\n" ^ - (end_itlist (fun s t -> s^" "^t) (List.map string_of_int blocksizes)) ^ + (String.concat " " (List.map string_of_int blocksizes)) ^ "\n" ^ sdpa_of_vector obj ^ - itlist2 (fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a) + List.fold_right2 (fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a) (1--List.length mats) mats "";; (* ------------------------------------------------------------------------- *) @@ -791,14 +774,14 @@ let blocks blocksizes bm = (fun a (b,i,j) c -> if b = b0 then ((i,j) |-> c) a else a) undefined bm in (((bs,bs),m):matrix)) - (zip blocksizes (1--List.length blocksizes));; + (List.combine blocksizes (1--List.length blocksizes));; (* ------------------------------------------------------------------------- *) (* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *) (* ------------------------------------------------------------------------- *) let real_positivnullstellensatz_general linf d eqs leqs pol = - let vars = itlist ((o) union poly_variables) (pol::eqs @ List.map fst leqs) [] in + let vars = List.fold_right ((o) union poly_variables) (pol::eqs @ List.map fst leqs) [] in let monoid = if linf then (poly_const num_1,Rational_lt num_1):: @@ -808,16 +791,16 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = let mk_idmultiplier k p = let e = d - multidegree p in let mons = enumerate_monomials e vars in - let nons = zip mons (1--List.length mons) in + let nons = List.combine mons (1--List.length mons) in mons, - itlist (fun (m,n) -> (m |-> ((-k,-n,n) |=> Int 1))) nons undefined in + List.fold_right (fun (m,n) -> (m |-> ((-k,-n,n) |=> Int 1))) nons undefined in let mk_sqmultiplier k (p,c) = let e = (d - multidegree p) / 2 in let mons = enumerate_monomials e vars in - let nons = zip mons (1--List.length mons) in + let nons = List.combine mons (1--List.length mons) in mons, - itlist (fun (m1,n1) -> - itlist (fun (m2,n2) a -> + List.fold_right (fun (m1,n1) -> + List.fold_right (fun (m2,n2) a -> let m = monomial_mul m1 m2 in if n1 > n2 then a else let c = if n1 = n2 then Int 1 else Int 2 in @@ -825,17 +808,17 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = (m |-> equation_add ((k,n1,n2) |=> c) e) a) nons) nons undefined in - let sqmonlist,sqs = unzip(List.map2 mk_sqmultiplier (1--List.length monoid) monoid) - and idmonlist,ids = unzip(List.map2 mk_idmultiplier (1--List.length eqs) eqs) in + let sqmonlist,sqs = List.split(List.map2 mk_sqmultiplier (1--List.length monoid) monoid) + and idmonlist,ids = List.split(List.map2 mk_idmultiplier (1--List.length eqs) eqs) in let blocksizes = List.map List.length sqmonlist in let bigsum = - itlist2 (fun p q a -> epoly_pmul p q a) eqs ids - (itlist2 (fun (p,c) s a -> epoly_pmul p s a) monoid sqs + List.fold_right2 (fun p q a -> epoly_pmul p q a) eqs ids + (List.fold_right2 (fun (p,c) s a -> epoly_pmul p s a) monoid sqs (epoly_of_poly(poly_neg pol))) in let eqns = foldl (fun a m e -> e::a) [] bigsum in let pvs,assig = eliminate_all_equations (0,0,0) eqns in let qvars = (0,0,0)::pvs in - let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in + let allassig = List.fold_right (fun v -> (v |-> (v |=> Int 1))) pvs assig in let mk_matrix v = foldl (fun m (b,i,j) ass -> if b < 0 then m else let c = tryapplyd ass v (Int 0) in @@ -858,8 +841,8 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = else ()); let vec = nice_vector d raw_vec in let blockmat = iter (1,dim vec) - (fun i a -> bmatrix_add (bmatrix_cmul (element vec i) (el i mats)) a) - (bmatrix_neg (el 0 mats)) in + (fun i a -> bmatrix_add (bmatrix_cmul (element vec i) (List.nth mats i)) a) + (bmatrix_neg (List.nth mats 0)) in let allmats = blocks blocksizes blockmat in vec,List.map diag allmats in let vec,ratdias = @@ -867,7 +850,7 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = else tryfind find_rounding (List.map Num.num_of_int (1--31) @ List.map pow2 (5--66)) in let newassigs = - itlist (fun k -> el (k - 1) pvs |-> element vec k) + List.fold_right (fun k -> List.nth pvs (k - 1) |-> element vec k) (1--dim vec) ((0,0,0) |=> Int(-1)) in let finalassigs = foldl (fun a v e -> (v |-> equation_eval newassigs e) a) newassigs @@ -877,17 +860,17 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = undefined p in let mk_sos mons = let mk_sq (c,m) = - c,itlist (fun k a -> (el (k - 1) mons |--> element m k) a) + c,List.fold_right (fun k a -> (List.nth mons (k - 1) |--> element m k) a) (1--List.length mons) undefined in List.map mk_sq in let sqs = List.map2 mk_sos sqmonlist ratdias and cfs = List.map poly_of_epoly ids in let msq = List.filter (fun (a,b) -> b <> []) (List.map2 (fun a b -> a,b) monoid sqs) in - let eval_sq sqs = itlist + let eval_sq sqs = List.fold_right (fun (c,q) -> poly_add (poly_cmul c (poly_mul q q))) sqs poly_0 in let sanity = - itlist (fun ((p,c),s) -> poly_add (poly_mul p (eval_sq s))) msq - (itlist2 (fun p q -> poly_add (poly_mul p q)) cfs eqs + List.fold_right (fun ((p,c),s) -> poly_add (poly_mul p (eval_sq s))) msq + (List.fold_right2 (fun p q -> poly_add (poly_mul p q)) cfs eqs (poly_neg pol)) in if not(is_undefined sanity) then raise Sanity else cfs,List.map (fun (a,b) -> snd a,b) msq;; @@ -913,8 +896,8 @@ let monomial_order = fun m1 m2 -> if m2 = monomial_1 then true else if m1 = monomial_1 then false else let mon1 = dest_monomial m1 and mon2 = dest_monomial m2 in - let deg1 = itlist ((o) (+) snd) mon1 0 - and deg2 = itlist ((o) (+) snd) mon2 0 in + let deg1 = List.fold_right ((o) (+) snd) mon1 0 + and deg2 = List.fold_right ((o) (+) snd) mon2 0 in if deg1 < deg2 then false else if deg1 > deg2 then true else lexorder mon1 mon2;; @@ -929,7 +912,7 @@ let term_of_varpow = let term_of_monomial = fun m -> if m = monomial_1 then Const num_1 else let m' = dest_monomial m in - let vps = itlist (fun (x,k) a -> term_of_varpow x k :: a) m' [] in + let vps = List.fold_right (fun (x,k) a -> term_of_varpow x k :: a) m' [] in end_itlist (fun s t -> Mul (s,t)) vps;; let term_of_cmonomial = @@ -953,202 +936,12 @@ let term_of_sos (pr,sqs) = else Product(pr,end_itlist (fun a b -> Sum(a,b)) (List.map term_of_sqterm sqs));; (* ------------------------------------------------------------------------- *) -(* Interface to HOL. *) -(* ------------------------------------------------------------------------- *) -(* -let REAL_NONLINEAR_PROVER translator (eqs,les,lts) = - let eq0 = map (poly_of_term o lhand o concl) eqs - and le0 = map (poly_of_term o lhand o concl) les - and lt0 = map (poly_of_term o lhand o concl) lts in - let eqp0 = map (fun (t,i) -> t,Axiom_eq i) (zip eq0 (0--(length eq0 - 1))) - and lep0 = map (fun (t,i) -> t,Axiom_le i) (zip le0 (0--(length le0 - 1))) - and ltp0 = map (fun (t,i) -> t,Axiom_lt i) (zip lt0 (0--(length lt0 - 1))) in - let keq,eq = partition (fun (p,_) -> multidegree p = 0) eqp0 - and klep,lep = partition (fun (p,_) -> multidegree p = 0) lep0 - and kltp,ltp = partition (fun (p,_) -> multidegree p = 0) ltp0 in - let trivial_axiom (p,ax) = - match ax with - Axiom_eq n when eval undefined p <>/ num_0 -> el n eqs - | Axiom_le n when eval undefined p </ num_0 -> el n les - | Axiom_lt n when eval undefined p <=/ num_0 -> el n lts - | _ -> failwith "not a trivial axiom" in - try let th = tryfind trivial_axiom (keq @ klep @ kltp) in - CONV_RULE (LAND_CONV REAL_POLY_CONV THENC REAL_RAT_RED_CONV) th - with Failure _ -> - let pol = itlist poly_mul (map fst ltp) (poly_const num_1) in - let leq = lep @ ltp in - let tryall d = - let e = multidegree pol in - let k = if e = 0 then 0 else d / e in - let eq' = map fst eq in - tryfind (fun i -> d,i,real_positivnullstellensatz_general false d eq' leq - (poly_neg(poly_pow pol i))) - (0--k) in - let d,i,(cert_ideal,cert_cone) = deepen tryall 0 in - let proofs_ideal = - map2 (fun q (p,ax) -> Eqmul(term_of_poly q,ax)) cert_ideal eq - and proofs_cone = map term_of_sos cert_cone - and proof_ne = - if ltp = [] then Rational_lt num_1 else - let p = end_itlist (fun s t -> Product(s,t)) (map snd ltp) in - funpow i (fun q -> Product(p,q)) (Rational_lt num_1) in - let proof = end_itlist (fun s t -> Sum(s,t)) - (proof_ne :: proofs_ideal @ proofs_cone) in - print_string("Translating proof certificate to HOL"); - print_newline(); - translator (eqs,les,lts) proof;; -*) -(* ------------------------------------------------------------------------- *) -(* A wrapper that tries to substitute away variables first. *) -(* ------------------------------------------------------------------------- *) -(* -let REAL_NONLINEAR_SUBST_PROVER = - let zero = `&0:real` - and mul_tm = `( * ):real->real->real` - and shuffle1 = - CONV_RULE(REWR_CONV(REAL_ARITH `a + x = (y:real) <=> x = y - a`)) - and shuffle2 = - CONV_RULE(REWR_CONV(REAL_ARITH `x + a = (y:real) <=> x = y - a`)) in - let rec substitutable_monomial fvs tm = - match tm with - Var(_,Tyapp("real",[])) when not (mem tm fvs) -> Int 1,tm - | Comb(Comb(Const("real_mul",_),c),(Var(_,_) as t)) - when is_ratconst c && not (mem t fvs) - -> rat_of_term c,t - | Comb(Comb(Const("real_add",_),s),t) -> - (try substitutable_monomial (union (frees t) fvs) s - with Failure _ -> substitutable_monomial (union (frees s) fvs) t) - | _ -> failwith "substitutable_monomial" - and isolate_variable v th = - match lhs(concl th) with - x when x = v -> th - | Comb(Comb(Const("real_add",_),(Var(_,Tyapp("real",[])) as x)),t) - when x = v -> shuffle2 th - | Comb(Comb(Const("real_add",_),s),t) -> - isolate_variable v(shuffle1 th) in - let make_substitution th = - let (c,v) = substitutable_monomial [] (lhs(concl th)) in - let th1 = AP_TERM (mk_comb(mul_tm,term_of_rat(Int 1 // c))) th in - let th2 = CONV_RULE(BINOP_CONV REAL_POLY_MUL_CONV) th1 in - CONV_RULE (RAND_CONV REAL_POLY_CONV) (isolate_variable v th2) in - fun translator -> - let rec substfirst(eqs,les,lts) = - try let eth = tryfind make_substitution eqs in - let modify = - CONV_RULE(LAND_CONV(SUBS_CONV[eth] THENC REAL_POLY_CONV)) in - substfirst(filter (fun t -> lhand(concl t) <> zero) (map modify eqs), - map modify les,map modify lts) - with Failure _ -> REAL_NONLINEAR_PROVER translator (eqs,les,lts) in - substfirst;; -*) -(* ------------------------------------------------------------------------- *) -(* Overall function. *) -(* ------------------------------------------------------------------------- *) -(* -let REAL_SOS = - let init = GEN_REWRITE_CONV ONCE_DEPTH_CONV [DECIMAL] - and pure = GEN_REAL_ARITH REAL_NONLINEAR_SUBST_PROVER in - fun tm -> let th = init tm in EQ_MP (SYM th) (pure(rand(concl th)));; -*) -(* ------------------------------------------------------------------------- *) -(* Add hacks for division. *) -(* ------------------------------------------------------------------------- *) -(* -let REAL_SOSFIELD = - let inv_tm = `inv:real->real` in - let prenex_conv = - TOP_DEPTH_CONV BETA_CONV THENC - PURE_REWRITE_CONV[FORALL_SIMP; EXISTS_SIMP; real_div; - REAL_INV_INV; REAL_INV_MUL; GSYM REAL_POW_INV] THENC - NNFC_CONV THENC DEPTH_BINOP_CONV `(/\)` CONDS_CELIM_CONV THENC - PRENEX_CONV - and setup_conv = NNF_CONV THENC WEAK_CNF_CONV THENC CONJ_CANON_CONV - and core_rule t = - try REAL_ARITH t - with Failure _ -> try REAL_RING t - with Failure _ -> REAL_SOS t - and is_inv = - let is_div = is_binop `(/):real->real->real` in - fun tm -> (is_div tm or (is_comb tm && rator tm = inv_tm)) && - not(is_ratconst(rand tm)) in - let BASIC_REAL_FIELD tm = - let is_freeinv t = is_inv t && free_in t tm in - let itms = setify(map rand (find_terms is_freeinv tm)) in - let hyps = map (fun t -> SPEC t REAL_MUL_RINV) itms in - let tm' = itlist (fun th t -> mk_imp(concl th,t)) hyps tm in - let itms' = map (curry mk_comb inv_tm) itms in - let gvs = map (genvar o type_of) itms' in - let tm'' = subst (zip gvs itms') tm' in - let th1 = setup_conv tm'' in - let cjs = conjuncts(rand(concl th1)) in - let ths = map core_rule cjs in - let th2 = EQ_MP (SYM th1) (end_itlist CONJ ths) in - rev_itlist (C MP) hyps (INST (zip itms' gvs) th2) in - fun tm -> - let th0 = prenex_conv tm in - let tm0 = rand(concl th0) in - let avs,bod = strip_forall tm0 in - let th1 = setup_conv bod in - let ths = map BASIC_REAL_FIELD (conjuncts(rand(concl th1))) in - EQ_MP (SYM th0) (GENL avs (EQ_MP (SYM th1) (end_itlist CONJ ths)));; -*) -(* ------------------------------------------------------------------------- *) -(* Integer version. *) -(* ------------------------------------------------------------------------- *) -(* -let INT_SOS = - let atom_CONV = - let pth = prove - (`(~(x <= y) <=> y + &1 <= x:int) /\ - (~(x < y) <=> y <= x) /\ - (~(x = y) <=> x + &1 <= y \/ y + &1 <= x) /\ - (x < y <=> x + &1 <= y)`, - REWRITE_TAC[INT_NOT_LE; INT_NOT_LT; INT_NOT_EQ; INT_LT_DISCRETE]) in - GEN_REWRITE_CONV I [pth] - and bub_CONV = GEN_REWRITE_CONV TOP_SWEEP_CONV - [int_eq; int_le; int_lt; int_ge; int_gt; - int_of_num_th; int_neg_th; int_add_th; int_mul_th; - int_sub_th; int_pow_th; int_abs_th; int_max_th; int_min_th] in - let base_CONV = TRY_CONV atom_CONV THENC bub_CONV in - let NNF_NORM_CONV = GEN_NNF_CONV false - (base_CONV,fun t -> base_CONV t,base_CONV(mk_neg t)) in - let init_CONV = - GEN_REWRITE_CONV DEPTH_CONV [FORALL_SIMP; EXISTS_SIMP] THENC - GEN_REWRITE_CONV DEPTH_CONV [INT_GT; INT_GE] THENC - CONDS_ELIM_CONV THENC NNF_NORM_CONV in - let p_tm = `p:bool` - and not_tm = `(~)` in - let pth = TAUT(mk_eq(mk_neg(mk_neg p_tm),p_tm)) in - fun tm -> - let th0 = INST [tm,p_tm] pth - and th1 = NNF_NORM_CONV(mk_neg tm) in - let th2 = REAL_SOS(mk_neg(rand(concl th1))) in - EQ_MP th0 (EQ_MP (AP_TERM not_tm (SYM th1)) th2);; -*) -(* ------------------------------------------------------------------------- *) -(* Natural number version. *) -(* ------------------------------------------------------------------------- *) -(* -let SOS_RULE tm = - let avs = frees tm in - let tm' = list_mk_forall(avs,tm) in - let th1 = NUM_TO_INT_CONV tm' in - let th2 = INT_SOS (rand(concl th1)) in - SPECL avs (EQ_MP (SYM th1) th2);; -*) -(* ------------------------------------------------------------------------- *) -(* Now pure SOS stuff. *) -(* ------------------------------------------------------------------------- *) - -(*prioritize_real();;*) - -(* ------------------------------------------------------------------------- *) (* Some combinatorial helper functions. *) (* ------------------------------------------------------------------------- *) let rec allpermutations l = if l = [] then [[]] else - itlist (fun h acc -> List.map (fun t -> h::t) + List.fold_right (fun h acc -> List.map (fun t -> h::t) (allpermutations (subtract l [h])) @ acc) l [];; let changevariables_monomial zoln (m:monomial) = @@ -1165,14 +958,14 @@ let changevariables zoln pol = let sdpa_of_vector (v:vector) = let n = dim v in let strs = List.map (o (decimalize 20) (element v)) (1--n) in - end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";; + String.concat " " strs ^ "\n";; let sdpa_of_matrix k (m:matrix) = let pfx = string_of_int k ^ " 1 " in let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a) (snd m) [] in let mss = sort (increasing fst) ms in - itlist (fun ((i,j),c) a -> + List.fold_right (fun ((i,j),c) a -> pfx ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c ^ "\n" ^ a) mss "";; @@ -1184,7 +977,7 @@ let sdpa_of_problem comment obj mats = "1\n" ^ string_of_int n ^ "\n" ^ sdpa_of_vector obj ^ - itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) + List.fold_right2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) (1--List.length mats) mats "";; let run_csdp dbg obj mats = @@ -1224,9 +1017,9 @@ let sumofsquares_general_symmetry tool pol = let sym_eqs = let invariants = List.filter (fun vars' -> - is_undefined(poly_sub pol (changevariables (zip vars vars') pol))) + is_undefined(poly_sub pol (changevariables (List.combine vars vars') pol))) (allpermutations vars) in - let lpns = zip lpps (1--List.length lpps) in + let lpns = List.combine lpps (1--List.length lpps) in let lppcs = List.filter (fun (m,(n1,n2)) -> n1 <= n2) (allpairs @@ -1234,8 +1027,8 @@ let sumofsquares_general_symmetry tool pol = let clppcs = end_itlist (@) (List.map (fun ((m1,m2),(n1,n2)) -> List.map (fun vars' -> - (changevariables_monomial (zip vars vars') m1, - changevariables_monomial (zip vars vars') m2),(n1,n2)) + (changevariables_monomial (List.combine vars vars') m1, + changevariables_monomial (List.combine vars vars') m2),(n1,n2)) invariants) lppcs) in let clppcs_dom = setify(List.map fst clppcs) in @@ -1247,7 +1040,7 @@ let sumofsquares_general_symmetry tool pol = [] -> raise Sanity | [h] -> acc | h::t -> List.map (fun k -> (k |-> Int(-1)) (h |=> Int 1)) t @ acc in - itlist mk_eq eqvcls [] in + List.fold_right mk_eq eqvcls [] in let eqs = foldl (fun a x y -> y::a) [] (itern 1 lpps (fun m1 n1 -> itern 1 lpps (fun m2 n2 f -> @@ -1259,7 +1052,7 @@ let sumofsquares_general_symmetry tool pol = undefined pol)) @ sym_eqs in let pvs,assig = eliminate_all_equations (0,0) eqs in - let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in + let allassig = List.fold_right (fun v -> (v |-> (v |=> Int 1))) pvs assig in let qvars = (0,0)::pvs in let diagents = end_itlist equation_add (List.map (fun i -> apply allassig (i,i)) (1--n)) in @@ -1281,18 +1074,18 @@ let sumofsquares_general_symmetry tool pol = else ()); let vec = nice_vector d raw_vec in let mat = iter (1,dim vec) - (fun i a -> matrix_add (matrix_cmul (element vec i) (el i mats)) a) - (matrix_neg (el 0 mats)) in + (fun i a -> matrix_add (matrix_cmul (element vec i) (List.nth mats i)) a) + (matrix_neg (List.nth mats 0)) in deration(diag mat) in let rat,dia = if pvs = [] then - let mat = matrix_neg (el 0 mats) in + let mat = matrix_neg (List.nth mats 0) in deration(diag mat) else tryfind find_rounding (List.map Num.num_of_int (1--31) @ List.map pow2 (5--66)) in let poly_of_lin(d,v) = - d,foldl(fun a i c -> (el (i - 1) lpps |-> c) a) undefined (snd v) in + d,foldl(fun a i c -> (List.nth lpps (i - 1) |-> c) a) undefined (snd v) in let lins = List.map poly_of_lin dia in let sqs = List.map (fun (d,l) -> poly_mul (poly_const d) (poly_pow l 2)) lins in let sos = poly_cmul rat (end_itlist poly_add sqs) in @@ -1300,325 +1093,3 @@ let sumofsquares_general_symmetry tool pol = let sumofsquares = sumofsquares_general_symmetry csdp;; -(* ------------------------------------------------------------------------- *) -(* Pure HOL SOS conversion. *) -(* ------------------------------------------------------------------------- *) -(* -let SOS_CONV = - let mk_square = - let pow_tm = `(pow)` and two_tm = `2` in - fun tm -> mk_comb(mk_comb(pow_tm,tm),two_tm) - and mk_prod = mk_binop `( * )` - and mk_sum = mk_binop `(+)` in - fun tm -> - let k,sos = sumofsquares(poly_of_term tm) in - let mk_sqtm(c,p) = - mk_prod (term_of_rat(k */ c)) (mk_square(term_of_poly p)) in - let tm' = end_itlist mk_sum (map mk_sqtm sos) in - let th = REAL_POLY_CONV tm and th' = REAL_POLY_CONV tm' in - TRANS th (SYM th');; -*) -(* ------------------------------------------------------------------------- *) -(* Attempt to prove &0 <= x by direct SOS decomposition. *) -(* ------------------------------------------------------------------------- *) -(* -let PURE_SOS_TAC = - let tac = - MATCH_ACCEPT_TAC(REWRITE_RULE[GSYM REAL_POW_2] REAL_LE_SQUARE) ORELSE - MATCH_ACCEPT_TAC REAL_LE_SQUARE ORELSE - (MATCH_MP_TAC REAL_LE_ADD THEN CONJ_TAC) ORELSE - (MATCH_MP_TAC REAL_LE_MUL THEN CONJ_TAC) ORELSE - CONV_TAC(RAND_CONV REAL_RAT_REDUCE_CONV THENC REAL_RAT_LE_CONV) in - REPEAT GEN_TAC THEN REWRITE_TAC[real_ge] THEN - GEN_REWRITE_TAC I [GSYM REAL_SUB_LE] THEN - CONV_TAC(RAND_CONV SOS_CONV) THEN - REPEAT tac THEN NO_TAC;; - -let PURE_SOS tm = prove(tm,PURE_SOS_TAC);; -*) -(* ------------------------------------------------------------------------- *) -(* Examples. *) -(* ------------------------------------------------------------------------- *) - -(***** - -time REAL_SOS - `a1 >= &0 /\ a2 >= &0 /\ - (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + &2) /\ - (a1 * b1 + a2 * b2 = &0) - ==> a1 * a2 - b1 * b2 >= &0`;; - -time REAL_SOS `&3 * x + &7 * a < &4 /\ &3 < &2 * x ==> a < &0`;; - -time REAL_SOS - `b pow 2 < &4 * a * c ==> ~(a * x pow 2 + b * x + c = &0)`;; - -time REAL_SOS - `(a * x pow 2 + b * x + c = &0) ==> b pow 2 >= &4 * a * c`;; - -time REAL_SOS - `&0 <= x /\ x <= &1 /\ &0 <= y /\ y <= &1 - ==> x pow 2 + y pow 2 < &1 \/ - (x - &1) pow 2 + y pow 2 < &1 \/ - x pow 2 + (y - &1) pow 2 < &1 \/ - (x - &1) pow 2 + (y - &1) pow 2 < &1`;; - -time REAL_SOS - `&0 <= b /\ &0 <= c /\ &0 <= x /\ &0 <= y /\ - (x pow 2 = c) /\ (y pow 2 = a pow 2 * c + b) - ==> a * c <= y * x`;; - -time REAL_SOS - `&0 <= x /\ &0 <= y /\ &0 <= z /\ x + y + z <= &3 - ==> x * y + x * z + y * z >= &3 * x * y * z`;; - -time REAL_SOS - `(x pow 2 + y pow 2 + z pow 2 = &1) ==> (x + y + z) pow 2 <= &3`;; - -time REAL_SOS - `(w pow 2 + x pow 2 + y pow 2 + z pow 2 = &1) - ==> (w + x + y + z) pow 2 <= &4`;; - -time REAL_SOS - `x >= &1 /\ y >= &1 ==> x * y >= x + y - &1`;; - -time REAL_SOS - `x > &1 /\ y > &1 ==> x * y > x + y - &1`;; - -time REAL_SOS - `abs(x) <= &1 - ==> abs(&64 * x pow 7 - &112 * x pow 5 + &56 * x pow 3 - &7 * x) <= &1`;; - -time REAL_SOS - `abs(x - z) <= e /\ abs(y - z) <= e /\ &0 <= u /\ &0 <= v /\ (u + v = &1) - ==> abs((u * x + v * y) - z) <= e`;; - -(* ------------------------------------------------------------------------- *) -(* One component of denominator in dodecahedral example. *) -(* ------------------------------------------------------------------------- *) - -time REAL_SOS - `&2 <= x /\ x <= &125841 / &50000 /\ - &2 <= y /\ y <= &125841 / &50000 /\ - &2 <= z /\ z <= &125841 / &50000 - ==> &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) >= &0`;; - -(* ------------------------------------------------------------------------- *) -(* Over a larger but simpler interval. *) -(* ------------------------------------------------------------------------- *) - -time REAL_SOS - `&2 <= x /\ x <= &4 /\ &2 <= y /\ y <= &4 /\ &2 <= z /\ z <= &4 - ==> &0 <= &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)`;; - -(* ------------------------------------------------------------------------- *) -(* We can do 12. I think 12 is a sharp bound; see PP's certificate. *) -(* ------------------------------------------------------------------------- *) - -time REAL_SOS - `&2 <= x /\ x <= &4 /\ &2 <= y /\ y <= &4 /\ &2 <= z /\ z <= &4 - ==> &12 <= &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)`;; - -(* ------------------------------------------------------------------------- *) -(* Gloptipoly example. *) -(* ------------------------------------------------------------------------- *) - -(*** This works but normalization takes minutes - -time REAL_SOS - `(x - y - &2 * x pow 4 = &0) /\ &0 <= x /\ x <= &2 /\ &0 <= y /\ y <= &3 - ==> y pow 2 - &7 * y - &12 * x + &17 >= &0`;; - - ***) - -(* ------------------------------------------------------------------------- *) -(* Inequality from sci.math (see "Leon-Sotelo, por favor"). *) -(* ------------------------------------------------------------------------- *) - -time REAL_SOS - `&0 <= x /\ &0 <= y /\ (x * y = &1) - ==> x + y <= x pow 2 + y pow 2`;; - -time REAL_SOS - `&0 <= x /\ &0 <= y /\ (x * y = &1) - ==> x * y * (x + y) <= x pow 2 + y pow 2`;; - -time REAL_SOS - `&0 <= x /\ &0 <= y ==> x * y * (x + y) pow 2 <= (x pow 2 + y pow 2) pow 2`;; - -(* ------------------------------------------------------------------------- *) -(* Some examples over integers and natural numbers. *) -(* ------------------------------------------------------------------------- *) - -time SOS_RULE `!m n. 2 * m + n = (n + m) + m`;; -time SOS_RULE `!n. ~(n = 0) ==> (0 MOD n = 0)`;; -time SOS_RULE `!m n. m < n ==> (m DIV n = 0)`;; -time SOS_RULE `!n:num. n <= n * n`;; -time SOS_RULE `!m n. n * (m DIV n) <= m`;; -time SOS_RULE `!n. ~(n = 0) ==> (0 DIV n = 0)`;; -time SOS_RULE `!m n p. ~(p = 0) /\ m <= n ==> m DIV p <= n DIV p`;; -time SOS_RULE `!a b n. ~(a = 0) ==> (n <= b DIV a <=> a * n <= b)`;; - -(* ------------------------------------------------------------------------- *) -(* This is particularly gratifying --- cf hideous manual proof in arith.ml *) -(* ------------------------------------------------------------------------- *) - -(*** This doesn't now seem to work as well as it did; what changed? - -time SOS_RULE - `!a b c d. ~(b = 0) /\ b * c < (a + 1) * d ==> c DIV d <= a DIV b`;; - - ***) - -(* ------------------------------------------------------------------------- *) -(* Key lemma for injectivity of Cantor-type pairing functions. *) -(* ------------------------------------------------------------------------- *) - -time SOS_RULE - `!x1 y1 x2 y2. ((x1 + y1) EXP 2 + x1 + 1 = (x2 + y2) EXP 2 + x2 + 1) - ==> (x1 + y1 = x2 + y2)`;; - -time SOS_RULE - `!x1 y1 x2 y2. ((x1 + y1) EXP 2 + x1 + 1 = (x2 + y2) EXP 2 + x2 + 1) /\ - (x1 + y1 = x2 + y2) - ==> (x1 = x2) /\ (y1 = y2)`;; - -time SOS_RULE - `!x1 y1 x2 y2. - (((x1 + y1) EXP 2 + 3 * x1 + y1) DIV 2 = - ((x2 + y2) EXP 2 + 3 * x2 + y2) DIV 2) - ==> (x1 + y1 = x2 + y2)`;; - -time SOS_RULE - `!x1 y1 x2 y2. - (((x1 + y1) EXP 2 + 3 * x1 + y1) DIV 2 = - ((x2 + y2) EXP 2 + 3 * x2 + y2) DIV 2) /\ - (x1 + y1 = x2 + y2) - ==> (x1 = x2) /\ (y1 = y2)`;; - -(* ------------------------------------------------------------------------- *) -(* Reciprocal multiplication (actually just ARITH_RULE does these). *) -(* ------------------------------------------------------------------------- *) - -time SOS_RULE `x <= 127 ==> ((86 * x) DIV 256 = x DIV 3)`;; - -time SOS_RULE `x < 2 EXP 16 ==> ((104858 * x) DIV (2 EXP 20) = x DIV 10)`;; - -(* ------------------------------------------------------------------------- *) -(* This is more impressive since it's really nonlinear. See REMAINDER_DECODE *) -(* ------------------------------------------------------------------------- *) - -time SOS_RULE `0 < m /\ m < n ==> ((m * ((n * x) DIV m + 1)) DIV n = x)`;; - -(* ------------------------------------------------------------------------- *) -(* Some conversion examples. *) -(* ------------------------------------------------------------------------- *) - -time SOS_CONV - `&2 * x pow 4 + &2 * x pow 3 * y - x pow 2 * y pow 2 + &5 * y pow 4`;; - -time SOS_CONV - `x pow 4 - (&2 * y * z + &1) * x pow 2 + - (y pow 2 * z pow 2 + &2 * y * z + &2)`;; - -time SOS_CONV `&4 * x pow 4 + - &4 * x pow 3 * y - &7 * x pow 2 * y pow 2 - &2 * x * y pow 3 + - &10 * y pow 4`;; - -time SOS_CONV `&4 * x pow 4 * y pow 6 + x pow 2 - x * y pow 2 + y pow 2`;; - -time SOS_CONV - `&4096 * (x pow 4 + x pow 2 + z pow 6 - &3 * x pow 2 * z pow 2) + &729`;; - -time SOS_CONV - `&120 * x pow 2 - &63 * x pow 4 + &10 * x pow 6 + - &30 * x * y - &120 * y pow 2 + &120 * y pow 4 + &31`;; - -time SOS_CONV - `&9 * x pow 2 * y pow 4 + &9 * x pow 2 * z pow 4 + &36 * x pow 2 * y pow 3 + - &36 * x pow 2 * y pow 2 - &48 * x * y * z pow 2 + &4 * y pow 4 + - &4 * z pow 4 - &16 * y pow 3 + &16 * y pow 2`;; - -time SOS_CONV - `(x pow 2 + y pow 2 + z pow 2) * - (x pow 4 * y pow 2 + x pow 2 * y pow 4 + - z pow 6 - &3 * x pow 2 * y pow 2 * z pow 2)`;; - -time SOS_CONV - `x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z + &3`;; - -(*** I think this will work, but normalization is slow - -time SOS_CONV - `&100 * (x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z) + &212`;; - - ***) - -time SOS_CONV - `&100 * ((&2 * x - &2) pow 2 + (x pow 3 - &8 * x - &2) pow 2) - &588`;; - -time SOS_CONV - `x pow 2 * (&120 - &63 * x pow 2 + &10 * x pow 4) + &30 * x * y + - &30 * y pow 2 * (&4 * y pow 2 - &4) + &31`;; - -(* ------------------------------------------------------------------------- *) -(* Example of basic rule. *) -(* ------------------------------------------------------------------------- *) - -time PURE_SOS - `!x. x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z + &3 - >= &1 / &7`;; - -time PURE_SOS - `&0 <= &98 * x pow 12 + - -- &980 * x pow 10 + - &3038 * x pow 8 + - -- &2968 * x pow 6 + - &1022 * x pow 4 + - -- &84 * x pow 2 + - &2`;; - -time PURE_SOS - `!x. &0 <= &2 * x pow 14 + - -- &84 * x pow 12 + - &1022 * x pow 10 + - -- &2968 * x pow 8 + - &3038 * x pow 6 + - -- &980 * x pow 4 + - &98 * x pow 2`;; - -(* ------------------------------------------------------------------------- *) -(* From Zeng et al, JSC vol 37 (2004), p83-99. *) -(* All of them work nicely with pure SOS_CONV, except (maybe) the one noted. *) -(* ------------------------------------------------------------------------- *) - -PURE_SOS - `x pow 6 + y pow 6 + z pow 6 - &3 * x pow 2 * y pow 2 * z pow 2 >= &0`;; - -PURE_SOS `x pow 4 + y pow 4 + z pow 4 + &1 - &4*x*y*z >= &0`;; - -PURE_SOS `x pow 4 + &2*x pow 2*z + x pow 2 - &2*x*y*z + &2*y pow 2*z pow 2 + -&2*y*z pow 2 + &2*z pow 2 - &2*x + &2* y*z + &1 >= &0`;; - -(**** This is harder. Interestingly, this fails the pure SOS test, it seems. - Yet only on rounding(!?) Poor Newton polytope optimization or something? - But REAL_SOS does finally converge on the second run at level 12! - -REAL_SOS -`x pow 4*y pow 4 - &2*x pow 5*y pow 3*z pow 2 + x pow 6*y pow 2*z pow 4 + &2*x -pow 2*y pow 3*z - &4* x pow 3*y pow 2*z pow 3 + &2*x pow 4*y*z pow 5 + z pow -2*y pow 2 - &2*z pow 4*y*x + z pow 6*x pow 2 >= &0`;; - - ****) - -PURE_SOS -`x pow 4 + &4*x pow 2*y pow 2 + &2*x*y*z pow 2 + &2*x*y*w pow 2 + y pow 4 + z -pow 4 + w pow 4 + &2*z pow 2*w pow 2 + &2*x pow 2*w + &2*y pow 2*w + &2*x*y + -&3*w pow 2 + &2*z pow 2 + &1 >= &0`;; - -PURE_SOS -`w pow 6 + &2*z pow 2*w pow 3 + x pow 4 + y pow 4 + z pow 4 + &2*x pow 2*w + -&2*x pow 2*z + &3*x pow 2 + w pow 2 + &2*z*w + z pow 2 + &2*z + &2*w + &1 >= -&0`;; - -*****) diff --git a/plugins/micromega/sos_lib.ml b/plugins/micromega/sos_lib.ml index 6b8b820ac6..6aebc4ca9a 100644 --- a/plugins/micromega/sos_lib.ml +++ b/plugins/micromega/sos_lib.ml @@ -9,8 +9,6 @@ open Num -let debugging = ref false;; - (* ------------------------------------------------------------------------- *) (* Comparisons that are reflexive on NaN and also short-circuiting. *) (* ------------------------------------------------------------------------- *) @@ -21,7 +19,6 @@ let (=?) = fun x y -> cmp x y = 0;; let (<?) = fun x y -> cmp x y < 0;; let (<=?) = fun x y -> cmp x y <= 0;; let (>?) = fun x y -> cmp x y > 0;; -let (>=?) = fun x y -> cmp x y >= 0;; (* ------------------------------------------------------------------------- *) (* Combinators. *) @@ -59,48 +56,29 @@ let lcm_num x y = (* ------------------------------------------------------------------------- *) -(* List basics. *) -(* ------------------------------------------------------------------------- *) - -let rec el n l = - if n = 0 then List.hd l else el (n - 1) (List.tl l);; - - -(* ------------------------------------------------------------------------- *) (* Various versions of list iteration. *) (* ------------------------------------------------------------------------- *) -let rec itlist f l b = - match l with - [] -> b - | (h::t) -> f h (itlist f t b);; - let rec end_itlist f l = match l with [] -> failwith "end_itlist" | [x] -> x | (h::t) -> f h (end_itlist f t);; -let rec itlist2 f l1 l2 b = - match (l1,l2) with - ([],[]) -> b - | (h1::t1,h2::t2) -> f h1 h2 (itlist2 f t1 t2 b) - | _ -> failwith "itlist2";; - (* ------------------------------------------------------------------------- *) (* All pairs arising from applying a function over two lists. *) (* ------------------------------------------------------------------------- *) let rec allpairs f l1 l2 = match l1 with - h1::t1 -> itlist (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2) + h1::t1 -> List.fold_right (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2) | [] -> [];; (* ------------------------------------------------------------------------- *) (* String operations (surely there is a better way...) *) (* ------------------------------------------------------------------------- *) -let implode l = itlist (^) l "";; +let implode l = List.fold_right (^) l "";; let explode s = let rec exap n l = @@ -110,13 +88,6 @@ let explode s = (* ------------------------------------------------------------------------- *) -(* Attempting function or predicate applications. *) -(* ------------------------------------------------------------------------- *) - -let can f x = try (f x; true) with Failure _ -> false;; - - -(* ------------------------------------------------------------------------- *) (* Repetition of a function. *) (* ------------------------------------------------------------------------- *) @@ -126,36 +97,20 @@ let rec funpow n f x = (* ------------------------------------------------------------------------- *) -(* Replication and sequences. *) +(* Sequences. *) (* ------------------------------------------------------------------------- *) -let rec replicate x n = - if n < 1 then [] - else x::(replicate x (n - 1));; - let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);; (* ------------------------------------------------------------------------- *) (* Various useful list operations. *) (* ------------------------------------------------------------------------- *) -let rec forall p l = - match l with - [] -> true - | h::t -> p(h) && forall p t;; - let rec tryfind f l = match l with [] -> failwith "tryfind" | (h::t) -> try f h with Failure _ -> tryfind f t;; -let index x = - let rec ind n l = - match l with - [] -> failwith "index" - | (h::t) -> if x =? h then n else ind (n + 1) t in - ind 0;; - (* ------------------------------------------------------------------------- *) (* "Set" operations on lists. *) (* ------------------------------------------------------------------------- *) @@ -168,46 +123,16 @@ let rec mem x lis = let insert x l = if mem x l then l else x::l;; -let union l1 l2 = itlist insert l1 l2;; +let union l1 l2 = List.fold_right insert l1 l2;; let subtract l1 l2 = List.filter (fun x -> not (mem x l2)) l1;; (* ------------------------------------------------------------------------- *) -(* Merging and bottom-up mergesort. *) -(* ------------------------------------------------------------------------- *) - -let rec merge ord l1 l2 = - match l1 with - [] -> l2 - | h1::t1 -> match l2 with - [] -> l1 - | h2::t2 -> if ord h1 h2 then h1::(merge ord t1 l2) - else h2::(merge ord l1 t2);; - - -(* ------------------------------------------------------------------------- *) (* Common measure predicates to use with "sort". *) (* ------------------------------------------------------------------------- *) let increasing f x y = f x <? f y;; -let decreasing f x y = f x >? f y;; - -(* ------------------------------------------------------------------------- *) -(* Zipping, unzipping etc. *) -(* ------------------------------------------------------------------------- *) - -let rec zip l1 l2 = - match (l1,l2) with - ([],[]) -> [] - | (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2) - | _ -> failwith "zip";; - -let rec unzip = - function [] -> [],[] - | ((a,b)::rest) -> let alist,blist = unzip rest in - (a::alist,b::blist);; - (* ------------------------------------------------------------------------- *) (* Iterating functions over lists. *) (* ------------------------------------------------------------------------- *) @@ -443,8 +368,6 @@ let apply f = applyd f (fun x -> failwith "apply");; let tryapplyd f a d = applyd f (fun x -> d) a;; -let defined f x = try apply f x; true with Failure _ -> false;; - (* ------------------------------------------------------------------------- *) (* Undefinition. *) (* ------------------------------------------------------------------------- *) @@ -490,8 +413,6 @@ let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);; let dom f = setify(foldl (fun a x y -> x::a) [] f);; -let ran f = setify(foldl (fun a x y -> y::a) [] f);; - (* ------------------------------------------------------------------------- *) (* More parser basics. *) (* ------------------------------------------------------------------------- *) @@ -499,7 +420,7 @@ let ran f = setify(foldl (fun a x y -> y::a) [] f);; exception Noparse;; -let isspace,issep,isbra,issymb,isalpha,isnum,isalnum = +let isspace,isnum = let charcode s = Char.code(String.get s 0) in let spaces = " \t\n\r" and separators = ",;" @@ -508,7 +429,7 @@ let isspace,issep,isbra,issymb,isalpha,isnum,isalnum = and alphas = "'abcdefghijklmnopqrstuvwxyz_ABCDEFGHIJKLMNOPQRSTUVWXYZ" and nums = "0123456789" in let allchars = spaces^separators^brackets^symbs^alphas^nums in - let csetsize = itlist ((o) max charcode) (explode allchars) 256 in + let csetsize = List.fold_right ((o) max charcode) (explode allchars) 256 in let ctable = Array.make csetsize 0 in do_list (fun c -> Array.set ctable (charcode c) 1) (explode spaces); do_list (fun c -> Array.set ctable (charcode c) 2) (explode separators); @@ -517,13 +438,8 @@ let isspace,issep,isbra,issymb,isalpha,isnum,isalnum = do_list (fun c -> Array.set ctable (charcode c) 16) (explode alphas); do_list (fun c -> Array.set ctable (charcode c) 32) (explode nums); let isspace c = Array.get ctable (charcode c) = 1 - and issep c = Array.get ctable (charcode c) = 2 - and isbra c = Array.get ctable (charcode c) = 4 - and issymb c = Array.get ctable (charcode c) = 8 - and isalpha c = Array.get ctable (charcode c) = 16 - and isnum c = Array.get ctable (charcode c) = 32 - and isalnum c = Array.get ctable (charcode c) >= 16 in - isspace,issep,isbra,issymb,isalpha,isnum,isalnum;; + and isnum c = Array.get ctable (charcode c) = 32 in + isspace,isnum;; let parser_or parser1 parser2 input = try parser1 input @@ -566,9 +482,6 @@ let rec atleast n prs i = (if n <= 0 then many prs else prs ++ atleast (n - 1) prs >> (fun (h,t) -> h::t)) i;; -let finished input = - if input = [] then 0,input else failwith "Unparsed input";; - (* ------------------------------------------------------------------------- *) let temp_path = Filename.get_temp_dir_name ();; @@ -589,7 +502,7 @@ let strings_of_file filename = (Pervasives.close_in fd; data);; let string_of_file filename = - end_itlist (fun s t -> s^"\n"^t) (strings_of_file filename);; + String.concat "\n" (strings_of_file filename);; let file_of_string filename s = let fd = Pervasives.open_out filename in diff --git a/plugins/micromega/sos_lib.mli b/plugins/micromega/sos_lib.mli new file mode 100644 index 0000000000..8b53b8151e --- /dev/null +++ b/plugins/micromega/sos_lib.mli @@ -0,0 +1,79 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val o : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b + +val num_1 : Num.num +val pow10 : int -> Num.num +val pow2 : int -> Num.num + +val implode : string list -> string +val explode : string -> string list + +val funpow : int -> ('a -> 'a) -> 'a -> 'a +val tryfind : ('a -> 'b) -> 'a list -> 'b + +type ('a,'b) func = + | Empty + | Leaf of int * ('a*'b) list + | Branch of int * int * ('a,'b) func * ('a,'b) func + +val undefined : ('a, 'b) func +val is_undefined : ('a, 'b) func -> bool +val (|->) : 'a -> 'b -> ('a, 'b) func -> ('a, 'b) func +val (|=>) : 'a -> 'b -> ('a, 'b) func +val choose : ('a, 'b) func -> 'a * 'b +val combine : ('a -> 'a -> 'a) -> ('a -> bool) -> ('b, 'a) func -> ('b, 'a) func -> ('b, 'a) func +val (--) : int -> int -> int list + +val tryapplyd : ('a, 'b) func -> 'a -> 'b -> 'b +val apply : ('a, 'b) func -> 'a -> 'b + +val foldl : ('a -> 'b -> 'c -> 'a) -> 'a -> ('b, 'c) func -> 'a +val foldr : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) func -> 'c -> 'c +val mapf : ('a -> 'b) -> ('c, 'a) func -> ('c, 'b) func + +val undefine : 'a -> ('a, 'b) func -> ('a, 'b) func + +val dom : ('a, 'b) func -> 'a list +val graph : ('a, 'b) func -> ('a * 'b) list + +val union : 'a list -> 'a list -> 'a list +val subtract : 'a list -> 'a list -> 'a list +val sort : ('a -> 'a -> bool) -> 'a list -> 'a list +val setify : 'a list -> 'a list +val increasing : ('a -> 'b) -> 'a -> 'a -> bool +val allpairs : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + +val gcd_num : Num.num -> Num.num -> Num.num +val lcm_num : Num.num -> Num.num -> Num.num +val numerator : Num.num -> Num.num +val denominator : Num.num -> Num.num +val end_itlist : ('a -> 'a -> 'a) -> 'a list -> 'a + +val (>>) : ('a -> 'b * 'c) -> ('b -> 'd) -> 'a -> 'd * 'c +val (++) : ('a -> 'b * 'c) -> ('c -> 'd * 'e) -> 'a -> ('b * 'd) * 'e + +val a : 'a -> 'a list -> 'a * 'a list +val many : ('a -> 'b * 'a) -> 'a -> 'b list * 'a +val some : ('a -> bool) -> 'a list -> 'a * 'a list +val possibly : ('a -> 'b * 'a) -> 'a -> 'b list * 'a +val isspace : string -> bool +val parser_or : ('a -> 'b) -> ('a -> 'b) -> 'a -> 'b +val isnum : string -> bool +val atleast : int -> ('a -> 'b * 'a) -> 'a -> 'b list * 'a +val listof : ('a -> 'b * 'c) -> ('c -> 'd * 'a) -> string -> 'a -> 'b list * 'c + +val temp_path : string +val string_of_file : string -> string +val file_of_string : string -> string -> unit + +val deepen_until : int -> (int -> 'a) -> int -> 'a +exception TooDeep diff --git a/plugins/micromega/sos_types.ml b/plugins/micromega/sos_types.ml index dde1e6c0b0..79d67b6ae9 100644 --- a/plugins/micromega/sos_types.ml +++ b/plugins/micromega/sos_types.ml @@ -11,19 +11,17 @@ (* The type of positivstellensatz -- used to communicate with sos *) open Num -type vname = string;; +type vname = string type term = | Zero | Const of Num.num | Var of vname -| Inv of term | Opp of term | Add of (term * term) | Sub of (term * term) | Mul of (term * term) -| Div of (term * term) -| Pow of (term * int);; +| Pow of (term * int) let rec output_term o t = @@ -31,12 +29,10 @@ let rec output_term o t = | Zero -> output_string o "0" | Const n -> output_string o (string_of_num n) | Var n -> Printf.fprintf o "v%s" n - | Inv t -> Printf.fprintf o "1/(%a)" output_term t | Opp t -> Printf.fprintf o "- (%a)" output_term t | Add(t1,t2) -> Printf.fprintf o "(%a)+(%a)" output_term t1 output_term t2 | Sub(t1,t2) -> Printf.fprintf o "(%a)-(%a)" output_term t1 output_term t2 | Mul(t1,t2) -> Printf.fprintf o "(%a)*(%a)" output_term t1 output_term t2 - | Div(t1,t2) -> Printf.fprintf o "(%a)/(%a)" output_term t1 output_term t2 | Pow(t1,i) -> Printf.fprintf o "(%a)^(%i)" output_term t1 i (* ------------------------------------------------------------------------- *) (* Data structure for Positivstellensatz refutations. *) diff --git a/plugins/micromega/sos_types.mli b/plugins/micromega/sos_types.mli index 050ff1e4f7..aa5fb08489 100644 --- a/plugins/micromega/sos_types.mli +++ b/plugins/micromega/sos_types.mli @@ -10,19 +10,17 @@ (* The type of positivstellensatz -- used to communicate with sos *) -type vname = string;; +type vname = string type term = | Zero | Const of Num.num | Var of vname -| Inv of term | Opp of term | Add of (term * term) | Sub of (term * term) | Mul of (term * term) -| Div of (term * term) -| Pow of (term * int);; +| Pow of (term * int) val output_term : out_channel -> term -> unit @@ -37,6 +35,6 @@ type positivstellensatz = | Monoid of int list | Eqmul of term * positivstellensatz | Sum of positivstellensatz * positivstellensatz - | Product of positivstellensatz * positivstellensatz;; + | Product of positivstellensatz * positivstellensatz val output_psatz : out_channel -> positivstellensatz -> unit diff --git a/plugins/micromega/vect.ml b/plugins/micromega/vect.ml new file mode 100644 index 0000000000..b188ab4278 --- /dev/null +++ b/plugins/micromega/vect.ml @@ -0,0 +1,295 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Num +open Mutils + +(** [t] is the type of vectors. + A vector [(x1,v1) ; ... ; (xn,vn)] is such that: + - variables indexes are ordered (x1 < ... < xn + - values are all non-zero + *) +type var = int +type t = (var * num) list + +(** [equal v1 v2 = true] if the vectors are syntactically equal. *) + +let rec equal v1 v2 = + match v1 , v2 with + | [] , [] -> true + | [] , _ -> false + | _::_ , [] -> false + | (i1,n1)::v1 , (i2,n2)::v2 -> + (Int.equal i1 i2) && n1 =/ n2 && equal v1 v2 + +let hash v = + let rec hash i = function + | [] -> i + | (vr,vl)::l -> hash (i + (Hashtbl.hash (vr, float_of_num vl))) l in + Hashtbl.hash (hash 0 v ) + + +let null = [] + +let is_null v = + match v with + | [] | [0,Int 0] -> true + | _ -> false + +let pp_var_num pp_var o (v,n) = + if Int.equal v 0 + then if eq_num (Int 0) n then () + else Printf.fprintf o "%s" (string_of_num n) + else + match n with + | Int 1 -> pp_var o v + | Int -1 -> Printf.fprintf o "-%a" pp_var v + | Int 0 -> () + | _ -> Printf.fprintf o "%s*%a" (string_of_num n) pp_var v + + +let rec pp_gen pp_var o v = + match v with + | [] -> output_string o "0" + | [e] -> pp_var_num pp_var o e + | e::l -> Printf.fprintf o "%a + %a" (pp_var_num pp_var) e (pp_gen pp_var) l + + +let pp_var o v = Printf.fprintf o "x%i" v + +let pp o v = pp_gen pp_var o v + + +let from_list (l: num list) = + let rec xfrom_list i l = + match l with + | [] -> [] + | e::l -> + if e <>/ Int 0 + then (i,e)::(xfrom_list (i+1) l) + else xfrom_list (i+1) l in + + xfrom_list 0 l + +let zero_num = Int 0 + + +let to_list m = + let rec xto_list i l = + match l with + | [] -> [] + | (x,v)::l' -> + if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in + xto_list 0 m + + +let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst + +let rec update i f t = + match t with + | [] -> cons i (f zero_num) [] + | (k,v)::l -> + match Int.compare i k with + | 0 -> cons k (f v) l + | -1 -> cons i (f zero_num) t + | 1 -> (k,v) ::(update i f l) + | _ -> failwith "compare_num" + +let rec set i n t = + match t with + | [] -> cons i n [] + | (k,v)::l -> + match Int.compare i k with + | 0 -> cons k n l + | -1 -> cons i n t + | 1 -> (k,v) :: (set i n l) + | _ -> failwith "compare_num" + +let cst n = if n =/ Int 0 then [] else [0,n] + + +let mul z t = + match z with + | Int 0 -> [] + | Int 1 -> t + | _ -> List.map (fun (i,n) -> (i, mult_num z n)) t + +let div z t = + if z <>/ Int 1 + then List.map (fun (x,nx) -> (x,nx // z)) t + else t + + +let uminus t = List.map (fun (i,n) -> i, minus_num n) t + + +let rec add (ve1:t) (ve2:t) = + match ve1 , ve2 with + | [] , v | v , [] -> v + | (v1,c1)::l1 , (v2,c2)::l2 -> + let cmp = Pervasives.compare v1 v2 in + if cmp == 0 then + let s = add_num c1 c2 in + if eq_num (Int 0) s + then add l1 l2 + else (v1,s)::(add l1 l2) + else if cmp < 0 then (v1,c1) :: (add l1 ve2) + else (v2,c2) :: (add l2 ve1) + + +let rec xmul_add (n1:num) (ve1:t) (n2:num) (ve2:t) = + match ve1 , ve2 with + | [] , _ -> mul n2 ve2 + | _ , [] -> mul n1 ve1 + | (v1,c1)::l1 , (v2,c2)::l2 -> + let cmp = Pervasives.compare v1 v2 in + if cmp == 0 then + let s = ( n1 */ c1) +/ (n2 */ c2) in + if eq_num (Int 0) s + then xmul_add n1 l1 n2 l2 + else (v1,s)::(xmul_add n1 l1 n2 l2) + else if cmp < 0 then (v1,n1 */ c1) :: (xmul_add n1 l1 n2 ve2) + else (v2,n2 */c2) :: (xmul_add n1 ve1 n2 l2) + +let mul_add n1 ve1 n2 ve2 = + if n1 =/ Int 1 && n2 =/ Int 1 + then add ve1 ve2 + else xmul_add n1 ve1 n2 ve2 + + +let compare : t -> t -> int = Mutils.Cmp.compare_list (fun x y -> Mutils.Cmp.compare_lexical + [ + (fun () -> Int.compare (fst x) (fst y)); + (fun () -> compare_num (snd x) (snd y))]) + +(** [tail v vect] returns + - [None] if [v] is not a variable of the vector [vect] + - [Some(vl,rst)] where [vl] is the value of [v] in vector [vect] + and [rst] is the remaining of the vector + We exploit that vectors are ordered lists + *) +let rec tail (v:var) (vect:t) = + match vect with + | [] -> None + | (v',vl)::vect' -> + match Int.compare v' v with + | 0 -> Some (vl,vect) (* Ok, found *) + | -1 -> tail v vect' (* Might be in the tail *) + | _ -> None (* Hopeless *) + +let get v vect = + match tail v vect with + | None -> Int 0 + | Some(vl,_) -> vl + +let is_constant v = + match v with + | [] | [0,_] -> true + | _ -> false + + + +let get_cst vect = + match vect with + | (0,v)::_ -> v + | _ -> Int 0 + +let choose v = + match v with + | [] -> None + | (vr,vl)::rst -> Some (vr,vl,rst) + + +let rec fresh v = + match v with + | [] -> 1 + | [v,_] -> v + 1 + | _::v -> fresh v + + +let variables v = + List.fold_left (fun acc (x,_) -> ISet.add x acc) ISet.empty v + +let decomp_cst v = + match v with + | (0,vl)::v -> vl,v + | _ -> Int 0,v + +let fold f acc v = + List.fold_left (fun acc (v,i) -> f acc v i) acc v + +let fold_error f acc v = + let rec fold acc v = + match v with + | [] -> Some acc + | (x,i)::v' -> match f acc x i with + | None -> None + | Some acc' -> fold acc' v' in + fold acc v + + + +let rec find p v = + match v with + | [] -> None + | (v,n)::v' -> match p v n with + | None -> find p v' + | Some r -> Some r + + +let for_all p l = + List.for_all (fun (v,n) -> p v n) l + + +let decr_var i v = List.map (fun (v,n) -> (v-i,n)) v +let incr_var i v = List.map (fun (v,n) -> (v+i,n)) v + +open Big_int + +let gcd v = + let res = fold (fun c _ n -> + assert (Int.equal (compare_big_int (denominator n) unit_big_int) 0); + gcd_big_int c (numerator n)) zero_big_int v in + if Int.equal (compare_big_int res zero_big_int) 0 + then unit_big_int else res + +let normalise v = + let ppcm = fold (fun c _ n -> ppcm c (denominator n)) unit_big_int v in + let gcd = + let gcd = fold (fun c _ n -> gcd_big_int c (numerator n)) zero_big_int v in + if Int.equal (compare_big_int gcd zero_big_int) 0 then unit_big_int else gcd in + List.map (fun (x,v) -> (x, v */ (Big_int ppcm) // (Big_int gcd))) v + +let rec exists2 p vect1 vect2 = + match vect1 , vect2 with + | _ , [] | [], _ -> None + | (v1,n1)::vect1' , (v2, n2) :: vect2' -> + if Int.equal v1 v2 + then + if p n1 n2 + then Some (v1,n1,n2) + else + exists2 p vect1' vect2' + else + if v1 < v2 + then exists2 p vect1' vect2 + else exists2 p vect1 vect2' + +let dotproduct v1 v2 = + let rec dot acc v1 v2 = + match v1, v2 with + | [] , _ | _ , [] -> acc + | (x1,n1)::v1', (x2,n2)::v2' -> + if x1 == x2 + then dot (acc +/ n1 */ n2) v1' v2' + else if x1 < x2 + then dot acc v1' v2 + else dot acc v1 v2' in + dot (Int 0) v1 v2 diff --git a/plugins/micromega/vect.mli b/plugins/micromega/vect.mli new file mode 100644 index 0000000000..da6b1e8e9b --- /dev/null +++ b/plugins/micromega/vect.mli @@ -0,0 +1,156 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Num +open Mutils + +type var = int (** Variables are simply (positive) integers. *) + +type t (** The type of vectors or equivalently linear expressions. + The current implementation is using association lists. + A list [(0,c),(x1,ai),...,(xn,an)] represents the linear expression + c + a1.xn + ... an.xn where ai are rational constants and xi are variables. + + Note that the variable 0 has a special meaning and represent a constant. + Moreover, the representation is spare and variables with a zero coefficient + are not represented. + *) + +(** {1 Generic functions} *) + +(** [hash] [equal] and [compare] so that Vect.t can be used as + keys for Set Map and Hashtbl *) + +val hash : t -> int +val equal : t -> t -> bool +val compare : t -> t -> int + +(** {1 Basic accessors and utility functions} *) + +(** [pp_gen pp_var o v] prints the representation of the vector [v] over the channel [o] *) +val pp_gen : (out_channel -> var -> unit) -> out_channel -> t -> unit + +(** [pp o v] prints the representation of the vector [v] over the channel [o] *) +val pp : out_channel -> t -> unit + +(** [variables v] returns the set of variables with non-zero coefficients *) +val variables : t -> ISet.t + +(** [get_cst v] returns c i.e. the coefficient of the variable zero *) +val get_cst : t -> num + +(** [decomp_cst v] returns the pair (c,a1.x1+...+an.xn) *) +val decomp_cst : t -> num * t + +(** [cst c] returns the vector v=c+0.x1+...+0.xn *) +val cst : num -> t + +(** [is_constant v] holds if [v] is a constant vector i.e. v=c+0.x1+...+0.xn + *) +val is_constant : t -> bool + +(** [null] is the empty vector i.e. 0+0.x1+...+0.xn *) +val null : t + +(** [is_null v] returns whether [v] is the [null] vector i.e [equal v null] *) +val is_null : t -> bool + +(** [get xi v] returns the coefficient ai of the variable [xi]. + [get] is also defined for the variable 0 *) +val get : var -> t -> num + +(** [set xi ai' v] returns the vector c+a1.x1+...ai'.xi+...+an.xn + i.e. the coefficient of the variable xi is set to ai' *) +val set : var -> num -> t -> t + +(** [update xi f v] returns c+a1.x1+...+f(ai).xi+...+an.xn *) +val update : var -> (num -> num) -> t -> t + +(** [fresh v] return the fresh variable with inded 1+ max (variables v) *) +val fresh : t -> int + +(** [choose v] decomposes a vector [v] depending on whether it is [null] or not. + @return None if v is [null] + @return Some(x,n,r) where v = r + n.x x is the smallest variable with non-zero coefficient n <> 0. + *) +val choose : t -> (var * num * t) option + +(** [from_list l] returns the vector c+a1.x1...an.xn from the list of coefficient [l=c;a1;...;an] *) +val from_list : num list -> t + +(** [to_list v] returns the list of all coefficient of the vector v i.e. [c;a1;...;an] + The list representation is (obviously) not sparsed + and therefore certain ai may be 0 *) +val to_list : t -> num list + +(** [decr_var i v] decrements the variables of the vector [v] by the amount [i]. + Beware, it is only defined if all the variables of v are greater than i + *) +val decr_var : int -> t -> t + +(** [incr_var i v] increments the variables of the vector [v] by the amount [i]. + *) +val incr_var : int -> t -> t + +(** [gcd v] returns gcd(num(c),num(a1),...,num(an)) where num extracts + the numerator of a rational value. *) +val gcd : t -> Big_int.big_int + +(** [normalise v] returns a vector with only integer coefficients *) +val normalise : t -> t + + +(** {1 Linear arithmetics} *) + +(** [add v1 v2] is vector addition. + @param v1 is of the form c +a1.x1 +...+an.xn + @param v2 is of the form c'+a1'.x1 +...+an'.xn + @return c1+c1'+ (a1+a1').x1 + ... + (an+an').xn + *) +val add : t -> t -> t + +(** [mul a v] is vector multiplication of vector [v] by a scalar [a]. + @return a.v = a.c+a.a1.x1+...+a.an.xn *) +val mul : num -> t -> t + +(** [mul_add c1 v1 c2 v2] returns the linear combination c1.v1+c2.v2 *) +val mul_add : num -> t -> num -> t -> t + +(** [div c1 v1] returns the mutiplication by the inverse of c1 i.e (1/c1).v1 *) +val div : num -> t -> t + +(** [uminus v] @return -v the opposite vector of v i.e. (-1).v *) +val uminus : t -> t + +(** {1 Iterators} *) + +(** [fold f acc v] returns f (f (f acc 0 c ) x1 a1 ) ... xn an *) +val fold : ('acc -> var -> num -> 'acc) -> 'acc -> t -> 'acc + +(** [fold_error f acc v] is the same as + [fold (fun acc x i -> match acc with None -> None | Some acc' -> f acc' x i) (Some acc) v] + but with early exit... + *) +val fold_error : ('acc -> var -> num -> 'acc option) -> 'acc -> t -> 'acc option + +(** [find f v] returns the first [f xi ai] such that [f xi ai <> None]. + If no such xi ai exists, it returns None *) +val find : (var -> num -> 'c option) -> t -> 'c option + +(** [for_all p v] returns /\_{i>=0} (f xi ai) *) +val for_all : (var -> num -> bool) -> t -> bool + +(** [exists2 p v v'] returns Some(xi,ai,ai') + if p(xi,ai,ai') holds and ai,ai' <> 0. + It returns None if no such pair of coefficient exists. *) +val exists2 : (num -> num -> bool) -> t -> t -> (var * num * num) option + +(** [dotproduct v1 v2] is the dot product of v1 and v2. *) +val dotproduct : t -> t -> num diff --git a/plugins/nsatz/g_nsatz.ml4 b/plugins/nsatz/g_nsatz.mlg index 4ac49adb90..16ff512e8d 100644 --- a/plugins/nsatz/g_nsatz.ml4 +++ b/plugins/nsatz/g_nsatz.mlg @@ -8,11 +8,15 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Ltac_plugin open Stdarg +} + DECLARE PLUGIN "nsatz_plugin" TACTIC EXTEND nsatz_compute -| [ "nsatz_compute" constr(lt) ] -> [ Nsatz.nsatz_compute (EConstr.Unsafe.to_constr lt) ] +| [ "nsatz_compute" constr(lt) ] -> { Nsatz.nsatz_compute (EConstr.Unsafe.to_constr lt) } END diff --git a/plugins/nsatz/nsatz.ml b/plugins/nsatz/nsatz.ml index 81b44ffad9..ef60a23e80 100644 --- a/plugins/nsatz/nsatz.ml +++ b/plugins/nsatz/nsatz.ml @@ -12,7 +12,6 @@ open CErrors open Util open Constr open Tactics -open Coqlib open Num open Utile @@ -136,36 +135,32 @@ let mul = function | (Const n,q) when eq_num n num_1 -> q | (p,q) -> Mul(p,q) -let gen_constant msg path s = Universes.constr_of_global @@ - coq_reference msg path s +let gen_constant n = lazy (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref n)) -let tpexpr = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PExpr") -let ttconst = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEc") -let ttvar = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEX") -let ttadd = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEadd") -let ttsub = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEsub") -let ttmul = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEmul") -let ttopp = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEopp") -let ttpow = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEpow") +let tpexpr = gen_constant "plugins.setoid_ring.pexpr" +let ttconst = gen_constant "plugins.setoid_ring.const" +let ttvar = gen_constant "plugins.setoid_ring.var" +let ttadd = gen_constant "plugins.setoid_ring.add" +let ttsub = gen_constant "plugins.setoid_ring.sub" +let ttmul = gen_constant "plugins.setoid_ring.mul" +let ttopp = gen_constant "plugins.setoid_ring.opp" +let ttpow = gen_constant "plugins.setoid_ring.pow" -let datatypes = ["Init";"Datatypes"] -let binnums = ["Numbers";"BinNums"] +let tlist = gen_constant "core.list.type" +let lnil = gen_constant "core.list.nil" +let lcons = gen_constant "core.list.cons" -let tlist = lazy (gen_constant "CC" datatypes "list") -let lnil = lazy (gen_constant "CC" datatypes "nil") -let lcons = lazy (gen_constant "CC" datatypes "cons") +let tz = gen_constant "num.Z.type" +let z0 = gen_constant "num.Z.Z0" +let zpos = gen_constant "num.Z.Zpos" +let zneg = gen_constant "num.Z.Zneg" -let tz = lazy (gen_constant "CC" binnums "Z") -let z0 = lazy (gen_constant "CC" binnums "Z0") -let zpos = lazy (gen_constant "CC" binnums "Zpos") -let zneg = lazy(gen_constant "CC" binnums "Zneg") +let pxI = gen_constant "num.pos.xI" +let pxO = gen_constant "num.pos.xO" +let pxH = gen_constant "num.pos.xH" -let pxI = lazy(gen_constant "CC" binnums "xI") -let pxO = lazy(gen_constant "CC" binnums "xO") -let pxH = lazy(gen_constant "CC" binnums "xH") - -let nN0 = lazy (gen_constant "CC" binnums "N0") -let nNpos = lazy(gen_constant "CC" binnums "Npos") +let nN0 = gen_constant "num.N.N0" +let nNpos = gen_constant "num.N.Npos" let mkt_app name l = mkApp (Lazy.force name, Array.of_list l) @@ -545,7 +540,7 @@ let nsatz lpol = let return_term t = let a = - mkApp(gen_constant "CC" ["Init";"Logic"] "eq_refl",[|tllp ();t|]) in + mkApp (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.eq.refl",[|tllp ();t|]) in let a = EConstr.of_constr a in generalize [a] diff --git a/plugins/nsatz/plugin_base.dune b/plugins/nsatz/plugin_base.dune new file mode 100644 index 0000000000..9da5b39972 --- /dev/null +++ b/plugins/nsatz/plugin_base.dune @@ -0,0 +1,5 @@ +(library + (name nsatz_plugin) + (public_name coq.plugins.nsatz) + (synopsis "Coq's nsatz solver plugin") + (libraries num coq.plugins.ltac)) diff --git a/plugins/nsatz/utile.ml b/plugins/nsatz/utile.ml index d3cfd75e56..1caa042db6 100644 --- a/plugins/nsatz/utile.ml +++ b/plugins/nsatz/utile.ml @@ -3,116 +3,7 @@ let pr x = if !Flags.debug then (Format.printf "@[%s@]" x; flush(stdout);)else () -let prn x = - if !Flags.debug then (Format.printf "@[%s\n@]" x; flush(stdout);) else () - let prt0 s = () (* print_string s;flush(stdout)*) -let prt s = - if !Flags.debug then (print_string (s^"\n");flush(stdout)) else () - let sinfo s = if !Flags.debug then Feedback.msg_debug (Pp.str s) let info s = if !Flags.debug then Feedback.msg_debug (Pp.str (s ())) - -(* Lists *) - -let rec list_mem_eq eq x l = - match l with - [] -> false - |y::l1 -> if (eq x y) then true else (list_mem_eq eq x l1) - -let set_of_list_eq eq l = - let res = ref [] in - List.iter (fun x -> if not (list_mem_eq eq x (!res)) then res:=x::(!res)) l; - List.rev !res - -(********************************************************************** - Eléments minimaux pour un ordre partiel de division. - E est un ensemble, avec une multiplication - et une division partielle div (la fonction div peut échouer), - constant est un prédicat qui définit un sous-ensemble C de E. -*) -(* - Etant donnée une partie A de E, on calcule une partie B de E disjointe de C - telle que: - - les éléments de A sont des produits d'éléments de B et d'un de C. - - B est minimale pour cette propriété. -*) - -let facteurs_liste div constant lp = - let lp = List.filter (fun x -> not (constant x)) lp in - let rec factor lmin lp = (* lmin: ne se divisent pas entre eux *) - match lp with - [] -> lmin - |p::lp1 -> - (let l1 = ref [] in - let p_dans_lmin = ref false in - List.iter (fun q -> try (let r = div p q in - if not (constant r) - then l1:=r::(!l1) - else p_dans_lmin:=true) - with e when CErrors.noncritical e -> ()) - lmin; - if !p_dans_lmin - then factor lmin lp1 - else if (!l1)=[] - (* aucun q de lmin ne divise p *) - then (let l1=ref lp1 in - let lmin1=ref [] in - List.iter (fun q -> try (let r = div q p in - if not (constant r) - then l1:=r::(!l1)) - with e when CErrors.noncritical e -> - lmin1:=q::(!lmin1)) - lmin; - factor (List.rev (p::(!lmin1))) !l1) - (* au moins un q de lmin divise p non trivialement *) - else factor lmin ((!l1)@lp1)) - in - factor [] lp - - -(* On suppose que tout élément de A est produit d'éléments de B et d'un de C: - A et B sont deux tableaux, rend un tableau de couples - (élément de C, listes d'indices l) - tels que A.(i) = l.(i)_1*Produit(B.(j), j dans l.(i)_2) - zero est un prédicat sur E tel que (zero x) => (constant x): - si (zero x) est vrai on ne decompose pas x - c est un élément quelconque de E. -*) -let factorise_tableau div zero c f l1 = - let res = Array.make (Array.length f) (c,[]) in - Array.iteri (fun i p -> - let r = ref p in - let li = ref [] in - if not (zero p) - then - Array.iteri (fun j q -> - try (while true do - let rr = div !r q in - li:=j::(!li); - r:=rr; - done) - with e when CErrors.noncritical e -> ()) - l1; - res.(i)<-(!r,!li)) - f; - (l1,res) - - -(* exemples: - -let l = [1;2;6;24;720] -and div1 = (fun a b -> if a mod b =0 then a/b else failwith "div") -and constant = (fun x -> x<2) -and zero = (fun x -> x=0) - - -let f = facteurs_liste div1 constant l - - -factorise_tableau div1 zero 0 (Array.of_list l) (Array.of_list f) - -*) - - diff --git a/plugins/nsatz/utile.mli b/plugins/nsatz/utile.mli index 9308577e0f..5af7ece5a3 100644 --- a/plugins/nsatz/utile.mli +++ b/plugins/nsatz/utile.mli @@ -1,19 +1,6 @@ (* Printing *) val pr : string -> unit -val prn : string -> unit val prt0 : 'a -> unit -val prt : string -> unit val info : (unit -> string) -> unit val sinfo : string -> unit - -(* Listes *) -val list_mem_eq : ('a -> 'b -> bool) -> 'a -> 'b list -> bool -val set_of_list_eq : ('a -> 'a -> bool) -> 'a list -> 'a list - - -val facteurs_liste : ('a -> 'a -> 'a) -> ('a -> bool) -> 'a list -> 'a list -val factorise_tableau : - ('a -> 'b -> 'a) -> - ('a -> bool) -> - 'a -> 'a array -> 'b array -> 'b array * ('a * int list) array diff --git a/plugins/omega/OmegaLemmas.v b/plugins/omega/OmegaLemmas.v index dc86a98998..81bf1fb83d 100644 --- a/plugins/omega/OmegaLemmas.v +++ b/plugins/omega/OmegaLemmas.v @@ -229,17 +229,11 @@ Definition fast_Zmult_comm (x y : Z) (P : Z -> Prop) Definition fast_Zopp_plus_distr (x y : Z) (P : Z -> Prop) (H : P (- x + - y)) := eq_ind_r P H (Z.opp_add_distr x y). -Definition fast_Zopp_involutive (x : Z) (P : Z -> Prop) (H : P x) := - eq_ind_r P H (Z.opp_involutive x). - Definition fast_Zopp_mult_distr_r (x y : Z) (P : Z -> Prop) (H : P (x * - y)) := eq_ind_r P H (Zopp_mult_distr_r x y). Definition fast_Zmult_plus_distr_l (n m p : Z) (P : Z -> Prop) (H : P (n * p + m * p)) := eq_ind_r P H (Z.mul_add_distr_r n m p). -Definition fast_Zmult_opp_comm (x y : Z) (P : Z -> Prop) - (H : P (x * - y)) := eq_ind_r P H (Z.mul_opp_comm x y). - Definition fast_Zmult_assoc_reverse (n m p : Z) (P : Z -> Prop) (H : P (n * (m * p))) := eq_ind_r P H (Zmult_assoc_reverse n m p). @@ -267,3 +261,47 @@ Proof. intros n; exists (Z.of_nat n); split; trivial. rewrite Z.mul_1_r, Z.add_0_r. apply Nat2Z.is_nonneg. Qed. + +Register fast_Zplus_assoc_reverse as plugins.omega.fast_Zplus_assoc_reverse. +Register fast_Zplus_assoc as plugins.omega.fast_Zplus_assoc. +Register fast_Zmult_assoc_reverse as plugins.omega.fast_Zmult_assoc_reverse. +Register fast_Zplus_permute as plugins.omega.fast_Zplus_permute. +Register fast_Zplus_comm as plugins.omega.fast_Zplus_comm. +Register fast_Zmult_comm as plugins.omega.fast_Zmult_comm. + +Register OMEGA1 as plugins.omega.OMEGA1. +Register OMEGA2 as plugins.omega.OMEGA2. +Register OMEGA3 as plugins.omega.OMEGA3. +Register OMEGA4 as plugins.omega.OMEGA4. +Register OMEGA5 as plugins.omega.OMEGA5. +Register OMEGA6 as plugins.omega.OMEGA6. +Register OMEGA7 as plugins.omega.OMEGA7. +Register OMEGA8 as plugins.omega.OMEGA8. +Register OMEGA9 as plugins.omega.OMEGA9. +Register fast_OMEGA10 as plugins.omega.fast_OMEGA10. +Register fast_OMEGA11 as plugins.omega.fast_OMEGA11. +Register fast_OMEGA12 as plugins.omega.fast_OMEGA12. +Register fast_OMEGA13 as plugins.omega.fast_OMEGA13. +Register fast_OMEGA14 as plugins.omega.fast_OMEGA14. +Register fast_OMEGA15 as plugins.omega.fast_OMEGA15. +Register fast_OMEGA16 as plugins.omega.fast_OMEGA16. +Register OMEGA17 as plugins.omega.OMEGA17. +Register OMEGA18 as plugins.omega.OMEGA18. +Register OMEGA19 as plugins.omega.OMEGA19. +Register OMEGA20 as plugins.omega.OMEGA20. + +Register fast_Zred_factor0 as plugins.omega.fast_Zred_factor0. +Register fast_Zred_factor1 as plugins.omega.fast_Zred_factor1. +Register fast_Zred_factor2 as plugins.omega.fast_Zred_factor2. +Register fast_Zred_factor3 as plugins.omega.fast_Zred_factor3. +Register fast_Zred_factor4 as plugins.omega.fast_Zred_factor4. +Register fast_Zred_factor5 as plugins.omega.fast_Zred_factor5. +Register fast_Zred_factor6 as plugins.omega.fast_Zred_factor6. + +Register fast_Zmult_plus_distr_l as plugins.omega.fast_Zmult_plus_distr_l. +Register fast_Zopp_plus_distr as plugins.omega.fast_Zopp_plus_distr. +Register fast_Zopp_mult_distr_r as plugins.omega.fast_Zopp_mult_distr_r. +Register fast_Zopp_eq_mult_neg_1 as plugins.omega.fast_Zopp_eq_mult_neg_1. + +Register new_var as plugins.omega.new_var. +Register intro_Z as plugins.omega.intro_Z. diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v index 59fd9b8017..94a3d40441 100644 --- a/plugins/omega/PreOmega.v +++ b/plugins/omega/PreOmega.v @@ -85,6 +85,7 @@ Ltac zify_binop t thm a b:= Ltac zify_op_1 := match goal with + | x := ?t : Z |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x | |- context [ Z.max ?a ?b ] => zify_binop Z.max Z.max_spec a b | H : context [ Z.max ?a ?b ] |- _ => zify_binop Z.max Z.max_spec a b | |- context [ Z.min ?a ?b ] => zify_binop Z.min Z.min_spec a b @@ -114,6 +115,7 @@ Ltac hide_Z_of_nat t := Ltac zify_nat_rel := match goal with (* I: equalities *) + | x := ?t : nat |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x | |- (@eq nat ?a ?b) => apply (Nat2Z.inj a b) (* shortcut *) | H : context [ @eq nat ?a ?b ] |- _ => rewrite <- (Nat2Z.inj_iff a b) in H | |- context [ @eq nat ?a ?b ] => rewrite <- (Nat2Z.inj_iff a b) @@ -181,7 +183,7 @@ Ltac zify_nat_op := let t := eval compute in (Z.of_nat (S a)) in change (Z.of_nat (S a)) with t in H | _ => rewrite (Nat2Z.inj_succ a) in H - | _ => (* if the [rewrite] fails (most likely a dependent occurence of [Z.of_nat (S a)]), + | _ => (* if the [rewrite] fails (most likely a dependent occurrence 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 @@ -192,7 +194,7 @@ Ltac zify_nat_op := let t := eval compute in (Z.of_nat (S a)) in change (Z.of_nat (S a)) with t | _ => rewrite (Nat2Z.inj_succ a) - | _ => (* if the [rewrite] fails (most likely a dependent occurence of [Z.of_nat (S a)]), + | _ => (* if the [rewrite] fails (most likely a dependent occurrence 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 @@ -223,6 +225,7 @@ Ltac hide_Zpos t := Ltac zify_positive_rel := match goal with (* I: equalities *) + | x := ?t : positive |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x | |- (@eq positive ?a ?b) => apply Pos2Z.inj | H : context [ @eq positive ?a ?b ] |- _ => rewrite <- (Pos2Z.inj_iff a b) in H | |- context [ @eq positive ?a ?b ] => rewrite <- (Pos2Z.inj_iff a b) @@ -348,6 +351,7 @@ Ltac hide_Z_of_N t := Ltac zify_N_rel := match goal with (* I: equalities *) + | x := ?t : N |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x | |- (@eq N ?a ?b) => apply (N2Z.inj a b) (* shortcut *) | H : context [ @eq N ?a ?b ] |- _ => rewrite <- (N2Z.inj_iff a b) in H | |- context [ @eq N ?a ?b ] => rewrite <- (N2Z.inj_iff a b) diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 51cd665f62..d8adb17710 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -18,8 +18,8 @@ open CErrors open Util open Names +open Constr open Nameops -open Term open EConstr open Tacticals.New open Tacmach.New @@ -29,7 +29,7 @@ open Libnames open Globnames open Nametab open Contradiction -open Misctypes +open Tactypes open Context.Named.Declaration module NamedDecl = Context.Named.Declaration @@ -38,17 +38,10 @@ open OmegaSolver (* Added by JCF, 09/03/98 *) -let elim_id id = - Proofview.Goal.enter begin fun gl -> - simplest_elim (mkVar id) - end -let resolve_id id = Proofview.Goal.enter begin fun gl -> - apply (mkVar id) -end +let elim_id id = simplest_elim (mkVar id) -let timing timer_name f arg = f arg +let resolve_id id = apply (mkVar id) -let display_time_flag = ref false let display_system_flag = ref false let display_action_flag = ref false let old_style_flag = ref false @@ -120,10 +113,6 @@ let new_identifier = let cpt = intref 0 in (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; Id.of_string s) -let new_identifier_state = - let cpt = intref 0 in - (fun () -> let s = make_ident "State" (Some !cpt) in incr cpt; s) - let new_identifier_var = let cpt = intref 0 in (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; Id.of_string s) @@ -159,7 +148,6 @@ let mk_then tacs = tclTHENLIST tacs 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 unfold s = Tactics.unfold_in_concl [Locus.AllOccurrences, Lazy.force s] let pf_nf gl c = pf_apply Tacred.simpl gl c @@ -171,10 +159,9 @@ let rev_assoc k = in loop -let tag_hypothesis,tag_of_hyp, hyp_of_tag, clear_tags = +let tag_hypothesis, hyp_of_tag, clear_tags = let l = ref ([]:(Id.t * int) list) in (fun h id -> l := (h,id):: !l), - (fun h -> try Id.List.assoc h !l with Not_found -> failwith "tag_hypothesis"), (fun h -> try rev_assoc h !l with Not_found -> failwith "tag_hypothesis"), (fun () -> l := []) @@ -199,178 +186,167 @@ let reset_all () = To use the constant Zplus, one must type "Lazy.force coq_Zplus" This is the right way to access to Coq constants in tactics ML code *) -open Coqlib - -let logic_dir = ["Coq";"Logic";"Decidable"] -let coq_modules = - init_modules @arith_modules @ [logic_dir] @ zarith_base_modules - @ [["Coq"; "omega"; "OmegaLemmas"]] - -let gen_constant_in_modules n m s = EConstr.of_constr (Universes.constr_of_global @@ gen_reference_in_modules n m s) -let init_constant = gen_constant_in_modules "Omega" init_modules -let constant = gen_constant_in_modules "Omega" coq_modules - -let z_constant = gen_constant_in_modules "Omega" [["Coq";"ZArith"]] -let zbase_constant = - gen_constant_in_modules "Omega" [["Coq";"ZArith";"BinInt"]] +let gen_constant k = lazy (k |> Coqlib.lib_ref |> UnivGen.constr_of_monomorphic_global + |> EConstr.of_constr) (* Zarith *) -let coq_xH = lazy (constant "xH") -let coq_xO = lazy (constant "xO") -let coq_xI = lazy (constant "xI") -let coq_Z0 = lazy (constant "Z0") -let coq_Zpos = lazy (constant "Zpos") -let coq_Zneg = lazy (constant "Zneg") -let coq_Z = lazy (constant "Z") -let coq_comparison = lazy (constant "comparison") -let coq_Gt = lazy (constant "Gt") -let coq_Zplus = lazy (zbase_constant "Z.add") -let coq_Zmult = lazy (zbase_constant "Z.mul") -let coq_Zopp = lazy (zbase_constant "Z.opp") -let coq_Zminus = lazy (zbase_constant "Z.sub") -let coq_Zsucc = lazy (zbase_constant "Z.succ") -let coq_Zpred = lazy (zbase_constant "Z.pred") -let coq_Z_of_nat = lazy (zbase_constant "Z.of_nat") -let coq_inj_plus = lazy (z_constant "Nat2Z.inj_add") -let coq_inj_mult = lazy (z_constant "Nat2Z.inj_mul") -let coq_inj_minus1 = lazy (z_constant "Nat2Z.inj_sub") -let coq_inj_minus2 = lazy (constant "inj_minus2") -let coq_inj_S = lazy (z_constant "Nat2Z.inj_succ") -let coq_inj_le = lazy (z_constant "Znat.inj_le") -let coq_inj_lt = lazy (z_constant "Znat.inj_lt") -let coq_inj_ge = lazy (z_constant "Znat.inj_ge") -let coq_inj_gt = lazy (z_constant "Znat.inj_gt") -let coq_inj_neq = lazy (z_constant "inj_neq") -let coq_inj_eq = lazy (z_constant "inj_eq") -let coq_fast_Zplus_assoc_reverse = lazy (constant "fast_Zplus_assoc_reverse") -let coq_fast_Zplus_assoc = lazy (constant "fast_Zplus_assoc") -let coq_fast_Zmult_assoc_reverse = lazy (constant "fast_Zmult_assoc_reverse") -let coq_fast_Zplus_permute = lazy (constant "fast_Zplus_permute") -let coq_fast_Zplus_comm = lazy (constant "fast_Zplus_comm") -let coq_fast_Zmult_comm = lazy (constant "fast_Zmult_comm") -let coq_Zmult_le_approx = lazy (constant "Zmult_le_approx") -let coq_OMEGA1 = lazy (constant "OMEGA1") -let coq_OMEGA2 = lazy (constant "OMEGA2") -let coq_OMEGA3 = lazy (constant "OMEGA3") -let coq_OMEGA4 = lazy (constant "OMEGA4") -let coq_OMEGA5 = lazy (constant "OMEGA5") -let coq_OMEGA6 = lazy (constant "OMEGA6") -let coq_OMEGA7 = lazy (constant "OMEGA7") -let coq_OMEGA8 = lazy (constant "OMEGA8") -let coq_OMEGA9 = lazy (constant "OMEGA9") -let coq_fast_OMEGA10 = lazy (constant "fast_OMEGA10") -let coq_fast_OMEGA11 = lazy (constant "fast_OMEGA11") -let coq_fast_OMEGA12 = lazy (constant "fast_OMEGA12") -let coq_fast_OMEGA13 = lazy (constant "fast_OMEGA13") -let coq_fast_OMEGA14 = lazy (constant "fast_OMEGA14") -let coq_fast_OMEGA15 = lazy (constant "fast_OMEGA15") -let coq_fast_OMEGA16 = lazy (constant "fast_OMEGA16") -let coq_OMEGA17 = lazy (constant "OMEGA17") -let coq_OMEGA18 = lazy (constant "OMEGA18") -let coq_OMEGA19 = lazy (constant "OMEGA19") -let coq_OMEGA20 = lazy (constant "OMEGA20") -let coq_fast_Zred_factor0 = lazy (constant "fast_Zred_factor0") -let coq_fast_Zred_factor1 = lazy (constant "fast_Zred_factor1") -let coq_fast_Zred_factor2 = lazy (constant "fast_Zred_factor2") -let coq_fast_Zred_factor3 = lazy (constant "fast_Zred_factor3") -let coq_fast_Zred_factor4 = lazy (constant "fast_Zred_factor4") -let coq_fast_Zred_factor5 = lazy (constant "fast_Zred_factor5") -let coq_fast_Zred_factor6 = lazy (constant "fast_Zred_factor6") -let coq_fast_Zmult_plus_distr_l = lazy (constant "fast_Zmult_plus_distr_l") -let coq_fast_Zmult_opp_comm = lazy (constant "fast_Zmult_opp_comm") -let coq_fast_Zopp_plus_distr = lazy (constant "fast_Zopp_plus_distr") -let coq_fast_Zopp_mult_distr_r = lazy (constant "fast_Zopp_mult_distr_r") -let coq_fast_Zopp_eq_mult_neg_1 = lazy (constant "fast_Zopp_eq_mult_neg_1") -let coq_fast_Zopp_involutive = lazy (constant "fast_Zopp_involutive") -let coq_Zegal_left = lazy (constant "Zegal_left") -let coq_Zne_left = lazy (constant "Zne_left") -let coq_Zlt_left = lazy (constant "Zlt_left") -let coq_Zge_left = lazy (constant "Zge_left") -let coq_Zgt_left = lazy (constant "Zgt_left") -let coq_Zle_left = lazy (constant "Zle_left") -let coq_new_var = lazy (constant "new_var") -let coq_intro_Z = lazy (constant "intro_Z") - -let coq_dec_eq = lazy (zbase_constant "Z.eq_decidable") -let coq_dec_Zne = lazy (constant "dec_Zne") -let coq_dec_Zle = lazy (zbase_constant "Z.le_decidable") -let coq_dec_Zlt = lazy (zbase_constant "Z.lt_decidable") -let coq_dec_Zgt = lazy (constant "dec_Zgt") -let coq_dec_Zge = lazy (constant "dec_Zge") - -let coq_not_Zeq = lazy (constant "not_Zeq") -let coq_not_Zne = lazy (constant "not_Zne") -let coq_Znot_le_gt = lazy (constant "Znot_le_gt") -let coq_Znot_lt_ge = lazy (constant "Znot_lt_ge") -let coq_Znot_ge_lt = lazy (constant "Znot_ge_lt") -let coq_Znot_gt_le = lazy (constant "Znot_gt_le") -let coq_neq = lazy (constant "neq") -let coq_Zne = lazy (constant "Zne") -let coq_Zle = lazy (zbase_constant "Z.le") -let coq_Zgt = lazy (zbase_constant "Z.gt") -let coq_Zge = lazy (zbase_constant "Z.ge") -let coq_Zlt = lazy (zbase_constant "Z.lt") +let coq_xH = gen_constant "num.pos.xH" +let coq_xO = gen_constant "num.pos.xO" +let coq_xI = gen_constant "num.pos.xI" +let coq_Z0 = gen_constant "num.Z.Z0" +let coq_Zpos = gen_constant "num.Z.Zpos" +let coq_Zneg = gen_constant "num.Z.Zneg" +let coq_Z = gen_constant "num.Z.type" +let coq_comparison = gen_constant "core.comparison.type" +let coq_Gt = gen_constant "core.comparison.Gt" +let coq_Zplus = gen_constant "num.Z.add" +let coq_Zmult = gen_constant "num.Z.mul" +let coq_Zopp = gen_constant "num.Z.opp" +let coq_Zminus = gen_constant "num.Z.sub" +let coq_Zsucc = gen_constant "num.Z.succ" +let coq_Zpred = gen_constant "num.Z.pred" +let coq_Z_of_nat = gen_constant "num.Z.of_nat" +let coq_inj_plus = gen_constant "num.Nat2Z.inj_add" +let coq_inj_mult = gen_constant "num.Nat2Z.inj_mul" +let coq_inj_minus1 = gen_constant "num.Nat2Z.inj_sub" +let coq_inj_minus2 = gen_constant "plugins.omega.inj_minus2" +let coq_inj_S = gen_constant "num.Nat2Z.inj_succ" +let coq_inj_eq = gen_constant "plugins.omega.inj_eq" +let coq_inj_neq = gen_constant "plugins.omega.inj_neq" +let coq_inj_le = gen_constant "plugins.omega.inj_le" +let coq_inj_lt = gen_constant "plugins.omega.inj_lt" +let coq_inj_ge = gen_constant "plugins.omega.inj_ge" +let coq_inj_gt = gen_constant "plugins.omega.inj_gt" +let coq_fast_Zplus_assoc_reverse = gen_constant "plugins.omega.fast_Zplus_assoc_reverse" +let coq_fast_Zplus_assoc = gen_constant "plugins.omega.fast_Zplus_assoc" +let coq_fast_Zmult_assoc_reverse = gen_constant "plugins.omega.fast_Zmult_assoc_reverse" +let coq_fast_Zplus_permute = gen_constant "plugins.omega.fast_Zplus_permute" +let coq_fast_Zplus_comm = gen_constant "plugins.omega.fast_Zplus_comm" +let coq_fast_Zmult_comm = gen_constant "plugins.omega.fast_Zmult_comm" +let coq_Zmult_le_approx = gen_constant "plugins.omega.Zmult_le_approx" +let coq_OMEGA1 = gen_constant "plugins.omega.OMEGA1" +let coq_OMEGA2 = gen_constant "plugins.omega.OMEGA2" +let coq_OMEGA3 = gen_constant "plugins.omega.OMEGA3" +let coq_OMEGA4 = gen_constant "plugins.omega.OMEGA4" +let coq_OMEGA5 = gen_constant "plugins.omega.OMEGA5" +let coq_OMEGA6 = gen_constant "plugins.omega.OMEGA6" +let coq_OMEGA7 = gen_constant "plugins.omega.OMEGA7" +let coq_OMEGA8 = gen_constant "plugins.omega.OMEGA8" +let coq_OMEGA9 = gen_constant "plugins.omega.OMEGA9" +let coq_fast_OMEGA10 = gen_constant "plugins.omega.fast_OMEGA10" +let coq_fast_OMEGA11 = gen_constant "plugins.omega.fast_OMEGA11" +let coq_fast_OMEGA12 = gen_constant "plugins.omega.fast_OMEGA12" +let coq_fast_OMEGA13 = gen_constant "plugins.omega.fast_OMEGA13" +let coq_fast_OMEGA14 = gen_constant "plugins.omega.fast_OMEGA14" +let coq_fast_OMEGA15 = gen_constant "plugins.omega.fast_OMEGA15" +let coq_fast_OMEGA16 = gen_constant "plugins.omega.fast_OMEGA16" +let coq_OMEGA17 = gen_constant "plugins.omega.OMEGA17" +let coq_OMEGA18 = gen_constant "plugins.omega.OMEGA18" +let coq_OMEGA19 = gen_constant "plugins.omega.OMEGA19" +let coq_OMEGA20 = gen_constant "plugins.omega.OMEGA20" +let coq_fast_Zred_factor0 = gen_constant "plugins.omega.fast_Zred_factor0" +let coq_fast_Zred_factor1 = gen_constant "plugins.omega.fast_Zred_factor1" +let coq_fast_Zred_factor2 = gen_constant "plugins.omega.fast_Zred_factor2" +let coq_fast_Zred_factor3 = gen_constant "plugins.omega.fast_Zred_factor3" +let coq_fast_Zred_factor4 = gen_constant "plugins.omega.fast_Zred_factor4" +let coq_fast_Zred_factor5 = gen_constant "plugins.omega.fast_Zred_factor5" +let coq_fast_Zred_factor6 = gen_constant "plugins.omega.fast_Zred_factor6" +let coq_fast_Zmult_plus_distr_l = gen_constant "plugins.omega.fast_Zmult_plus_distr_l" +let coq_fast_Zopp_plus_distr = gen_constant "plugins.omega.fast_Zopp_plus_distr" +let coq_fast_Zopp_mult_distr_r = gen_constant "plugins.omega.fast_Zopp_mult_distr_r" +let coq_fast_Zopp_eq_mult_neg_1 = gen_constant "plugins.omega.fast_Zopp_eq_mult_neg_1" +let coq_Zegal_left = gen_constant "plugins.omega.Zegal_left" +let coq_Zne_left = gen_constant "plugins.omega.Zne_left" +let coq_Zlt_left = gen_constant "plugins.omega.Zlt_left" +let coq_Zge_left = gen_constant "plugins.omega.Zge_left" +let coq_Zgt_left = gen_constant "plugins.omega.Zgt_left" +let coq_Zle_left = gen_constant "plugins.omega.Zle_left" +let coq_new_var = gen_constant "plugins.omega.new_var" +let coq_intro_Z = gen_constant "plugins.omega.intro_Z" + +let coq_dec_eq = gen_constant "num.Z.eq_decidable" +let coq_dec_Zne = gen_constant "plugins.omega.dec_Zne" +let coq_dec_Zle = gen_constant "num.Z.le_decidable" +let coq_dec_Zlt = gen_constant "num.Z.lt_decidable" +let coq_dec_Zgt = gen_constant "plugins.omega.dec_Zgt" +let coq_dec_Zge = gen_constant "plugins.omega.dec_Zge" + +let coq_not_Zeq = gen_constant "plugins.omega.not_Zeq" +let coq_not_Zne = gen_constant "plugins.omega.not_Zne" +let coq_Znot_le_gt = gen_constant "plugins.omega.Znot_le_gt" +let coq_Znot_lt_ge = gen_constant "plugins.omega.Znot_lt_ge" +let coq_Znot_ge_lt = gen_constant "plugins.omega.Znot_ge_lt" +let coq_Znot_gt_le = gen_constant "plugins.omega.Znot_gt_le" +let coq_neq = gen_constant "plugins.omega.neq" +let coq_Zne = gen_constant "plugins.omega.Zne" +let coq_Zle = gen_constant "num.Z.le" +let coq_Zlt = gen_constant "num.Z.lt" +let coq_Zge = gen_constant "num.Z.ge" +let coq_Zgt = gen_constant "num.Z.gt" (* Peano/Datatypes *) -let coq_le = lazy (init_constant "le") -let coq_lt = lazy (init_constant "lt") -let coq_ge = lazy (init_constant "ge") -let coq_gt = lazy (init_constant "gt") -let coq_minus = lazy (init_constant "Nat.sub") -let coq_plus = lazy (init_constant "Nat.add") -let coq_mult = lazy (init_constant "Nat.mul") -let coq_pred = lazy (init_constant "Nat.pred") -let coq_nat = lazy (init_constant "nat") -let coq_S = lazy (init_constant "S") -let coq_O = lazy (init_constant "O") +let coq_nat = gen_constant "num.nat.type" +let coq_O = gen_constant "num.nat.O" +let coq_S = gen_constant "num.nat.S" +let coq_le = gen_constant "num.nat.le" +let coq_lt = gen_constant "num.nat.lt" +let coq_ge = gen_constant "num.nat.ge" +let coq_gt = gen_constant "num.nat.gt" +let coq_plus = gen_constant "num.nat.add" +let coq_minus = gen_constant "num.nat.sub" +let coq_mult = gen_constant "num.nat.mul" +let coq_pred = gen_constant "num.nat.pred" (* Compare_dec/Peano_dec/Minus *) -let coq_pred_of_minus = lazy (constant "pred_of_minus") -let coq_le_gt_dec = lazy (constant "le_gt_dec") -let coq_dec_eq_nat = lazy (constant "dec_eq_nat") -let coq_dec_le = lazy (constant "dec_le") -let coq_dec_lt = lazy (constant "dec_lt") -let coq_dec_ge = lazy (constant "dec_ge") -let coq_dec_gt = lazy (constant "dec_gt") -let coq_not_eq = lazy (constant "not_eq") -let coq_not_le = lazy (constant "not_le") -let coq_not_lt = lazy (constant "not_lt") -let coq_not_ge = lazy (constant "not_ge") -let coq_not_gt = lazy (constant "not_gt") +let coq_pred_of_minus = gen_constant "num.nat.pred_of_minus" +let coq_le_gt_dec = gen_constant "num.nat.le_gt_dec" +let coq_dec_eq_nat = gen_constant "num.nat.eq_dec" +let coq_dec_le = gen_constant "num.nat.dec_le" +let coq_dec_lt = gen_constant "num.nat.dec_lt" +let coq_dec_ge = gen_constant "num.nat.dec_ge" +let coq_dec_gt = gen_constant "num.nat.dec_gt" +let coq_not_eq = gen_constant "num.nat.not_eq" +let coq_not_le = gen_constant "num.nat.not_le" +let coq_not_lt = gen_constant "num.nat.not_lt" +let coq_not_ge = gen_constant "num.nat.not_ge" +let coq_not_gt = gen_constant "num.nat.not_gt" (* Logic/Decidable *) -let coq_eq_ind_r = lazy (constant "eq_ind_r") - -let coq_dec_or = lazy (constant "dec_or") -let coq_dec_and = lazy (constant "dec_and") -let coq_dec_imp = lazy (constant "dec_imp") -let coq_dec_iff = lazy (constant "dec_iff") -let coq_dec_not = lazy (constant "dec_not") -let coq_dec_False = lazy (constant "dec_False") -let coq_dec_not_not = lazy (constant "dec_not_not") -let coq_dec_True = lazy (constant "dec_True") - -let coq_not_or = lazy (constant "not_or") -let coq_not_and = lazy (constant "not_and") -let coq_not_imp = lazy (constant "not_imp") -let coq_not_iff = lazy (constant "not_iff") -let coq_not_not = lazy (constant "not_not") -let coq_imp_simp = lazy (constant "imp_simp") -let coq_iff = lazy (constant "iff") -let coq_not = lazy (init_constant "not") -let coq_and = lazy (init_constant "and") -let coq_or = lazy (init_constant "or") -let coq_eq = lazy (init_constant "eq") -let coq_ex = lazy (init_constant "ex") -let coq_False = lazy (init_constant "False") -let coq_True = lazy (init_constant "True") +let coq_eq_ind_r = gen_constant "core.eq.ind_r" + +let coq_dec_or = gen_constant "core.dec.or" +let coq_dec_and = gen_constant "core.dec.and" +let coq_dec_imp = gen_constant "core.dec.imp" +let coq_dec_iff = gen_constant "core.dec.iff" +let coq_dec_not = gen_constant "core.dec.not" +let coq_dec_False = gen_constant "core.dec.False" +let coq_dec_not_not = gen_constant "core.dec.not_not" +let coq_dec_True = gen_constant "core.dec.True" + +let coq_not_or = gen_constant "core.dec.not_or" +let coq_not_and = gen_constant "core.dec.not_and" +let coq_not_imp = gen_constant "core.dec.not_imp" +let coq_not_iff = gen_constant "core.dec.not_iff" +let coq_not_not = gen_constant "core.dec.dec_not_not" +let coq_imp_simp = gen_constant "core.dec.imp_simp" +let coq_iff = gen_constant "core.iff.type" +let coq_not = gen_constant "core.not.type" +let coq_and = gen_constant "core.and.type" +let coq_or = gen_constant "core.or.type" +let coq_eq = gen_constant "core.eq.type" +let coq_ex = gen_constant "core.ex.type" +let coq_False = gen_constant "core.False.type" +let coq_True = gen_constant "core.True.type" (* uses build_coq_and, build_coq_not, build_coq_or, build_coq_ex *) (* For unfold *) -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) -> +let evaluable_ref_of_constr s c = + let env = Global.env () in + let evd = Evd.from_env env in + match EConstr.kind evd (Lazy.force c) with + | Const (kn,u) when Tacred.is_evaluable env (EvalConstRef kn) -> EvalConstRef kn | _ -> anomaly ~label:"Coq_omega" (Pp.str (s^" is not an evaluable constant.")) @@ -379,23 +355,18 @@ let sp_Zpred = lazy (evaluable_ref_of_constr "Z.pred" coq_Zpred) let sp_Zminus = lazy (evaluable_ref_of_constr "Z.sub" coq_Zminus) let sp_Zle = lazy (evaluable_ref_of_constr "Z.le" coq_Zle) let sp_Zgt = lazy (evaluable_ref_of_constr "Z.gt" coq_Zgt) -let sp_Zge = lazy (evaluable_ref_of_constr "Z.ge" coq_Zge) -let sp_Zlt = lazy (evaluable_ref_of_constr "Z.lt" coq_Zlt) let sp_not = lazy (evaluable_ref_of_constr "not" coq_not) -let mk_var v = mkVar (Id.of_string v) let mk_plus t1 t2 = mkApp (Lazy.force coq_Zplus, [| t1; t2 |]) let mk_times t1 t2 = mkApp (Lazy.force coq_Zmult, [| t1; t2 |]) let mk_minus t1 t2 = mkApp (Lazy.force coq_Zminus, [| t1;t2 |]) let mk_gen_eq ty t1 t2 = mkApp (Lazy.force coq_eq, [| ty; t1; t2 |]) let mk_eq t1 t2 = mk_gen_eq (Lazy.force coq_Z) t1 t2 -let mk_le t1 t2 = mkApp (Lazy.force coq_Zle, [| t1; t2 |]) let mk_gt t1 t2 = mkApp (Lazy.force coq_Zgt, [| t1; t2 |]) let mk_inv t = mkApp (Lazy.force coq_Zopp, [| t |]) let mk_and t1 t2 = mkApp (Lazy.force coq_and, [| t1; t2 |]) let mk_or t1 t2 = mkApp (Lazy.force coq_or, [| t1; t2 |]) let mk_not t = mkApp (Lazy.force coq_not, [| t |]) -let mk_eq_rel t1 t2 = mk_gen_eq (Lazy.force coq_comparison) t1 t2 let mk_inj t = mkApp (Lazy.force coq_Z_of_nat, [| t |]) let mk_integer n = @@ -419,10 +390,6 @@ type omega_constant = | Le | Lt | Ge | Gt | Other of string -type omega_proposition = - | Keq of constr * constr * constr - | Kn - type result = | Kvar of Id.t | Kapp of omega_constant * constr list @@ -519,12 +486,7 @@ let recognize_number sigma t = type constr_path = | P_APP of int (* Abstraction and product *) - | P_BODY | P_TYPE - (* Case *) - | P_BRANCH of int - | P_ARITY - | P_ARG let context sigma operation path (t : constr) = let rec loop i p0 t = @@ -534,25 +496,10 @@ let context sigma operation path (t : constr) = | ((P_APP n :: p), App (f,v)) -> let v' = Array.copy v in v'.(pred n) <- loop i p v'.(pred n); mkApp (f, v') - | ((P_BRANCH n :: p), Case (ci,q,c,v)) -> - (* avant, y avait mkApp... anyway, BRANCH seems nowhere used *) - let v' = Array.copy v in - v'.(n) <- loop i p v'.(n); (mkCase (ci,q,c,v')) - | ((P_ARITY :: p), App (f,l)) -> - mkApp (loop i p f,l) - | ((P_ARG :: p), App (f,v)) -> - let v' = Array.copy v in - v'.(0) <- loop i p v'.(0); mkApp (f,v') | (p, Fix ((_,n as ln),(tys,lna,v))) -> let l = Array.length v in let v' = Array.copy v in v'.(n)<- loop (Pervasives.(+) i l) p v.(n); (mkFix (ln,(tys,lna,v'))) - | ((P_BODY :: p), Prod (n,t,c)) -> - (mkProd (n,t,loop (succ i) p c)) - | ((P_BODY :: p), Lambda (n,t,c)) -> - (mkLambda (n,t,loop (succ i) p c)) - | ((P_BODY :: p), LetIn (n,b,t,c)) -> - (mkLetIn (n,b,t,loop (succ i) p c)) | ((P_TYPE :: p), Prod (n,t,c)) -> (mkProd (n,loop i p t,c)) | ((P_TYPE :: p), Lambda (n,t,c)) -> @@ -569,13 +516,7 @@ let occurrence sigma path (t : constr) = | (p, Cast (c,_,_)) -> loop p c | ([], _) -> t | ((P_APP n :: p), App (f,v)) -> loop p v.(pred n) - | ((P_BRANCH n :: p), Case (_,_,_,v)) -> loop p v.(n) - | ((P_ARITY :: p), App (f,_)) -> loop p f - | ((P_ARG :: p), App (f,v)) -> loop p v.(0) | (p, Fix((_,n) ,(_,_,v))) -> loop p v.(n) - | ((P_BODY :: p), Prod (n,t,c)) -> loop p c - | ((P_BODY :: p), Lambda (n,t,c)) -> loop p c - | ((P_BODY :: p), LetIn (n,b,t,c)) -> loop p c | ((P_TYPE :: p), Prod (n,term,c)) -> loop p term | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term @@ -591,7 +532,7 @@ let abstract_path sigma typ path t = let focused_simpl path = let open Tacmach.New in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.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 @@ -600,7 +541,6 @@ let focused_simpl path = focused_simpl path type oformula = | Oplus of oformula * oformula - | Oinv of oformula | Otimes of oformula * oformula | Oatom of Id.t | Oz of bigint @@ -610,7 +550,6 @@ let rec oprint = function | Oplus(t1,t2) -> print_string "("; oprint t1; print_string "+"; oprint t2; print_string ")" - | Oinv t -> print_string "~"; oprint t | Otimes (t1,t2) -> print_string "("; oprint t1; print_string "*"; oprint t2; print_string ")" @@ -621,7 +560,6 @@ let rec oprint = function let rec weight = function | Oatom c -> intern_id c | Oz _ -> -1 - | Oinv c -> weight c | Otimes(c,_) -> weight c | Oplus _ -> failwith "weight" | Oufo _ -> -1 @@ -629,7 +567,6 @@ let rec weight = function let rec val_of = function | Oatom c -> mkVar c | Oz c -> mk_integer c - | Oinv c -> mkApp (Lazy.force coq_Zopp, [| val_of c |]) | Otimes (t1,t2) -> mkApp (Lazy.force coq_Zmult, [| val_of t1; val_of t2 |]) | Oplus(t1,t2) -> mkApp (Lazy.force coq_Zplus, [| val_of t1; val_of t2 |]) | Oufo c -> c @@ -659,7 +596,7 @@ let new_hole env sigma c = let clever_rewrite_base_poly typ p result theorem = let open Tacmach.New in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.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 @@ -711,7 +648,7 @@ let refine_app gl t = let clever_rewrite p vpath t = let open Tacmach.New in - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.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 @@ -924,10 +861,6 @@ let rec scalar p n = function clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zmult_plus_distr_l) :: (tac1 @ tac2), Oplus(t1',t2') - | Oinv t -> - [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zmult_opp_comm); - focused_simpl (P_APP 2 :: p)], Otimes(t,Oz(neg n)) | Otimes(t1,Oz x) -> [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zmult_assoc_reverse); @@ -979,8 +912,6 @@ let rec negate p = function (Lazy.force coq_fast_Zopp_plus_distr) :: (tac1 @ tac2), Oplus(t1',t2') - | Oinv t -> - [clever_rewrite p [[P_APP 1;P_APP 1]] (Lazy.force coq_fast_Zopp_involutive)], t | Otimes(t1,Oz x) -> [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]] (Lazy.force coq_fast_Zopp_mult_distr_r); @@ -1766,7 +1697,7 @@ let onClearedName id tac = (* so renaming may be necessary *) tclTHEN (tclTRY (clear [id])) - (Proofview.Goal.nf_enter begin fun gl -> + (Proofview.Goal.enter begin fun gl -> let id = fresh_id Id.Set.empty id gl in tclTHEN (introduction id) (tac id) end) @@ -1774,7 +1705,7 @@ let onClearedName id tac = let onClearedName2 id tac = tclTHEN (tclTRY (clear [id])) - (Proofview.Goal.nf_enter begin fun gl -> + (Proofview.Goal.enter begin fun gl -> let id1 = fresh_id Id.Set.empty (add_suffix id "_left") gl in let id2 = fresh_id Id.Set.empty (add_suffix id "_right") gl in tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] @@ -1959,7 +1890,7 @@ let destructure_goal = try let dec = decidability t in tclTHEN - (Proofview.Goal.nf_enter begin fun gl -> + (Proofview.Goal.enter begin fun gl -> refine_app gl (mkApp (Lazy.force coq_dec_not_not, [| t; dec |])) end) intro diff --git a/plugins/omega/coq_omega.mli b/plugins/omega/coq_omega.mli new file mode 100644 index 0000000000..a657826caa --- /dev/null +++ b/plugins/omega/coq_omega.mli @@ -0,0 +1,11 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val omega_solver : unit Proofview.tactic diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.mlg index 170b937c99..85081b24a3 100644 --- a/plugins/omega/g_omega.ml4 +++ b/plugins/omega/g_omega.mlg @@ -18,6 +18,8 @@ DECLARE PLUGIN "omega_plugin" +{ + open Ltac_plugin open Names open Coq_omega @@ -25,7 +27,7 @@ open Stdarg let eval_tactic name = let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in - let kn = KerName.make2 (ModPath.MPfile dp) (Label.make name) in + let kn = KerName.make (ModPath.MPfile dp) (Label.make name) in let tac = Tacenv.interp_ltac kn in Tacinterp.eval_tactic tac @@ -43,14 +45,15 @@ let omega_tactic l = (Tacticals.New.tclREPEAT (Tacticals.New.tclTHENLIST tacs)) (omega_solver) +} TACTIC EXTEND omega -| [ "omega" ] -> [ omega_tactic [] ] +| [ "omega" ] -> { omega_tactic [] } END TACTIC EXTEND omega' | [ "omega" "with" ne_ident_list(l) ] -> - [ omega_tactic (List.map Names.Id.to_string l) ] -| [ "omega" "with" "*" ] -> [ omega_tactic ["nat";"positive";"N";"Z"] ] + { omega_tactic (List.map Names.Id.to_string l) } +| [ "omega" "with" "*" ] -> { omega_tactic ["nat";"positive";"N";"Z"] } END diff --git a/plugins/omega/omega.ml b/plugins/omega/omega.ml index 2510c16934..7bca7c7099 100644 --- a/plugins/omega/omega.ml +++ b/plugins/omega/omega.ml @@ -178,7 +178,7 @@ let rec display_action print_var = function | DIVIDE_AND_APPROX (e1,e2,k,d) -> Printf.printf "Inequation E%d is divided by %s and the constant coefficient is \ - rounded by substracting %s.\n" e1.id (sbi k) (sbi d) + rounded by subtracting %s.\n" e1.id (sbi k) (sbi d) | NOT_EXACT_DIVIDE (e,k) -> Printf.printf "Constant in equation E%d is not divisible by the pgcd \ diff --git a/plugins/omega/plugin_base.dune b/plugins/omega/plugin_base.dune new file mode 100644 index 0000000000..f512501c78 --- /dev/null +++ b/plugins/omega/plugin_base.dune @@ -0,0 +1,5 @@ +(library + (name omega_plugin) + (public_name coq.plugins.omega) + (synopsis "Coq's omega plugin") + (libraries coq.plugins.ltac)) diff --git a/plugins/quote/Quote.v b/plugins/quote/Quote.v deleted file mode 100644 index 2d3d9170c1..0000000000 --- a/plugins/quote/Quote.v +++ /dev/null @@ -1,86 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Declare ML Module "quote_plugin". - -(*********************************************************************** - The "abstract" type index is defined to represent variables. - - index : Set - index_eq : index -> bool - index_eq_prop: (n,m:index)(index_eq n m)=true -> n=m - index_lt : index -> bool - varmap : Type -> Type. - varmap_find : (A:Type)A -> index -> (varmap A) -> A. - - The first arg. of varmap_find is the default value to take - if the object is not found in the varmap. - - index_lt defines a total well-founded order, but we don't prove that. - -***********************************************************************) - -Set Implicit Arguments. - -Section variables_map. - -Variable A : Type. - -Inductive varmap : Type := - | Empty_vm : varmap - | Node_vm : A -> varmap -> varmap -> varmap. - -Inductive index : Set := - | Left_idx : index -> index - | Right_idx : index -> index - | End_idx : index. - -Fixpoint varmap_find (default_value:A) (i:index) (v:varmap) {struct v} : A := - match i, v with - | End_idx, Node_vm x _ _ => x - | Right_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v2 - | Left_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v1 - | _, _ => default_value - end. - -Fixpoint index_eq (n m:index) {struct m} : bool := - match n, m with - | End_idx, End_idx => true - | Left_idx n', Left_idx m' => index_eq n' m' - | Right_idx n', Right_idx m' => index_eq n' m' - | _, _ => false - end. - -Fixpoint index_lt (n m:index) {struct m} : bool := - match n, m with - | End_idx, Left_idx _ => true - | End_idx, Right_idx _ => true - | Left_idx n', Right_idx m' => true - | Right_idx n', Right_idx m' => index_lt n' m' - | Left_idx n', Left_idx m' => index_lt n' m' - | _, _ => false - end. - -Lemma index_eq_prop : forall n m:index, index_eq n m = true -> n = m. - simple induction n; simple induction m; simpl; intros. - rewrite (H i0 H1); reflexivity. - discriminate. - discriminate. - discriminate. - rewrite (H i0 H1); reflexivity. - discriminate. - discriminate. - discriminate. - reflexivity. -Qed. - -End variables_map. - -Unset Implicit Arguments. diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4 deleted file mode 100644 index c35e0fe126..0000000000 --- a/plugins/quote/g_quote.ml4 +++ /dev/null @@ -1,39 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Ltac_plugin -open Names -open Misctypes -open Tacexpr -open Geninterp -open Quote -open Stdarg -open Tacarg - -DECLARE PLUGIN "quote_plugin" - -let cont = Id.of_string "cont" -let x = Id.of_string "x" - -let make_cont (k : Val.t) (c : EConstr.t) = - let c = Tacinterp.Value.of_constr c in - let tac = TacCall (Loc.tag (ArgVar CAst.(make cont), [Reference (ArgVar CAst.(make 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.tag tac)) - -TACTIC EXTEND quote - [ "quote" ident(f) ] -> [ quote f [] ] -| [ "quote" ident(f) "[" ne_ident_list(lc) "]"] -> [ quote f lc ] -| [ "quote" ident(f) "in" constr(c) "using" tactic(k) ] -> - [ gen_quote (make_cont k) c f [] ] -| [ "quote" ident(f) "[" ne_ident_list(lc) "]" - "in" constr(c) "using" tactic(k) ] -> - [ gen_quote (make_cont k) c f lc ] -END diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml deleted file mode 100644 index 912429c310..0000000000 --- a/plugins/quote/quote.ml +++ /dev/null @@ -1,540 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* The `Quote' tactic *) - -(* The basic idea is to automatize the inversion of interpretation functions - in 2-level approach - - Examples are given in \texttt{theories/DEMOS/DemoQuote.v} - - Suppose you have a langage \texttt{L} of 'abstract terms' - and a type \texttt{A} of 'concrete terms' - and a function \texttt{f : L -> (varmap A L) -> A}. - - Then, the tactic \texttt{quote f} will replace an - expression \texttt{e} of type \texttt{A} by \texttt{(f vm t)} - such that \texttt{e} and \texttt{(f vm t)} are convertible. - - The problem is then inverting the function \texttt{f}. - - The tactic works when: - - \begin{itemize} - \item L is a simple inductive datatype. The constructors of L may - have one of the three following forms: - - \begin{enumerate} - \item ordinary recursive constructors like: \verb|Cplus : L -> L -> L| - \item variable leaf like: \verb|Cvar : index -> L| - \item constant leaf like \verb|Cconst : A -> L| - \end{enumerate} - - The definition of \texttt{L} must contain at most one variable - leaf and at most one constant leaf. - - When there are both a variable leaf and a constant leaf, there is - an ambiguity on inversion. The term t can be either the - interpretation of \texttt{(Cconst t)} or the interpretation of - (\texttt{Cvar}~$i$) in a variable map containing the binding $i - \rightarrow$~\texttt{t}. How to discriminate between these - choices? - - To solve the dilemma, one gives to \texttt{quote} a list of - \emph{constant constructors}: a term will be considered as a - constant if it is either a constant constructor or the - application of a constant constructor to constants. For example - the list \verb+[S, O]+ defines the closed natural - numbers. \texttt{(S (S O))} is a constant when \texttt{(S x)} is - not. - - The definition of constants vary for each application of the - tactic, so it can even be different for two applications of - \texttt{quote} with the same function. - - \item \texttt{f} is a quite simple fixpoint on - \texttt{L}. In particular, \texttt{f} must verify: - -\begin{verbatim} - (f (Cvar i)) = (varmap_find vm default_value i) -\end{verbatim} -\begin{verbatim} - (f (Cconst c)) = c -\end{verbatim} - - where \texttt{index} and \texttt{varmap\_find} are those defined - the \texttt{Quote} module. \emph{The tactic won't work with - user's own variables map!!} It is mandatory to use the - variable map defined in module \texttt{Quote}. - - \end{itemize} - - The method to proceed is then clear: - - \begin{itemize} - \item Start with an empty hashtable of "registed leafs" - that maps constr to integers and a "variable counter" equal to 0. - \item Try to match the term with every right hand side of the - definition of \texttt{f}. - - If there is one match, returns the correponding left hand - side and call yourself recursively to get the arguments of this - left hand side. - - If there is no match, we are at a leaf. That is the - interpretation of either a variable or a constant. - - If it is a constant, return \texttt{Cconst} applied to that - constant. - - If not, it is a variable. Look in the hashtable - if this leaf has been already encountered. If not, increment - the variable counter and add an entry to the hashtable; then - return \texttt{(Cvar !variables\_counter)} - \end{itemize} -*) - - -(*i*) -open CErrors -open Util -open Names -open Constr -open EConstr -open Pattern -open Patternops -open Constr_matching -open Tacmach -open Proofview.Notations -(*i*) - -(*s First, we need to access some Coq constants - We do that lazily, because this code can be linked before - the constants are loaded in the environment *) - -let constant dir s = - EConstr.of_constr @@ Universes.constr_of_global @@ - Coqlib.coq_reference "Quote" ("quote"::dir) s - -let coq_Empty_vm = lazy (constant ["Quote"] "Empty_vm") -let coq_Node_vm = lazy (constant ["Quote"] "Node_vm") -let coq_varmap_find = lazy (constant ["Quote"] "varmap_find") -let coq_Right_idx = lazy (constant ["Quote"] "Right_idx") -let coq_Left_idx = lazy (constant ["Quote"] "Left_idx") -let coq_End_idx = lazy (constant ["Quote"] "End_idx") - -(*s Then comes the stuff to decompose the body of interpetation function - and pre-compute the inversion data. - -For a function like: - -\begin{verbatim} - Fixpoint interp (vm:varmap Prop) (f:form) := - match f with - | f_and f1 f1 f2 => (interp f1) /\ (interp f2) - | f_or f1 f1 f2 => (interp f1) \/ (interp f2) - | f_var i => varmap_find Prop default_v i vm - | f_const c => c - end. -\end{verbatim} - -With the constant constructors \texttt{C1}, \dots, \texttt{Cn}, the -corresponding scheme will be: - -\begin{verbatim} - {normal_lhs_rhs = - [ "(f_and ?1 ?2)", "?1 /\ ?2"; - "(f_or ?1 ?2)", " ?1 \/ ?2";]; - return_type = "Prop"; - constants = Some [C1,...Cn]; - variable_lhs = Some "(f_var ?1)"; - constant_lhs = Some "(f_const ?1)" - } -\end{verbatim} - -If there is no constructor for variables in the type \texttt{form}, -then [variable_lhs] is [None]. Idem for constants and -[constant_lhs]. Both cannot be equal to [None]. - -The metas in the RHS must correspond to those in the LHS (one cannot -exchange ?1 and ?2 in the example above) - -*) - -module ConstrSet = Set.Make(Constr) - -type inversion_scheme = { - normal_lhs_rhs : (constr * constr_pattern) list; - variable_lhs : constr option; - return_type : constr; - constants : ConstrSet.t; - constant_lhs : constr option } - -(*s [compute_ivs gl f cs] computes the inversion scheme associated to - [f:constr] with constants list [cs:constr list] in the context of - goal [gl]. This function uses the auxiliary functions - [i_can't_do_that], [decomp_term], [compute_lhs] and [compute_rhs]. *) - -let i_can't_do_that () = user_err Pp.(str "Quote: not a simple fixpoint") - -let decomp_term sigma c = EConstr.kind sigma (Termops.strip_outer_cast sigma c) - -(*s [compute_lhs typ i nargsi] builds the term \texttt{(C ?nargsi ... - ?2 ?1)}, where \texttt{C} is the [i]-th constructor of inductive - type [typ] *) - -let coerce_meta_out id = - let s = Id.to_string id in - int_of_string (String.sub s 1 (String.length s - 1)) -let coerce_meta_in n = - Id.of_string ("M" ^ string_of_int n) - -let compute_lhs sigma typ i nargsi = - match EConstr.kind sigma typ with - | Ind((sp,0),u) -> - let argsi = Array.init nargsi (fun j -> mkMeta (nargsi - j)) in - mkApp (mkConstructU (((sp,0),i+1),u), argsi) - | _ -> i_can't_do_that () - -(*s This function builds the pattern from the RHS. Recursive calls are - replaced by meta-variables ?i corresponding to those in the LHS *) - -let compute_rhs env sigma bodyi index_of_f = - let rec aux c = - match EConstr.kind sigma c with - | App (j, args) when isRel sigma j && Int.equal (destRel sigma j) index_of_f (* recursive call *) -> - let i = destRel sigma (Array.last args) in - PMeta (Some (coerce_meta_in i)) - | App (f,args) -> - PApp (pattern_of_constr env sigma (EConstr.to_constr sigma f), Array.map aux args) - | Cast (c,_,_) -> aux c - | _ -> pattern_of_constr env sigma (EConstr.to_constr sigma c) - in - aux bodyi - -(*s Now the function [compute_ivs] itself *) - -let compute_ivs f cs gl = - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let (cst, u) = try destConst sigma f with DestKO -> i_can't_do_that () in - let u = EInstance.kind sigma u in - let body = Environ.constant_value_in (Global.env()) (cst, u) in - let body = EConstr.of_constr body in - match decomp_term sigma body with - | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) -> - let (args3, body3) = decompose_lam sigma body2 in - let nargs3 = List.length args3 in - let is_conv = Reductionops.is_conv env sigma in - begin match decomp_term sigma body3 with - | Case(_,p,c,lci) -> (* <p> Case c of c1 ... cn end *) - let n_lhs_rhs = ref [] - and v_lhs = ref (None : constr option) - and c_lhs = ref (None : constr option) in - Array.iteri - (fun i ci -> - let argsi, bodyi = decompose_lam sigma ci in - let nargsi = List.length argsi in - (* REL (narg3 + nargsi + 1) is f *) - (* REL nargsi+1 to REL nargsi + nargs3 are arguments of f *) - (* REL 1 to REL nargsi are argsi (reverse order) *) - (* First we test if the RHS is the RHS for constants *) - if isRel sigma bodyi && Int.equal (destRel sigma bodyi) 1 then - c_lhs := Some (compute_lhs sigma (snd (List.hd args3)) - i nargsi) - (* Then we test if the RHS is the RHS for variables *) - else begin match decompose_app sigma bodyi with - | vmf, [_; _; a3; a4 ] - when isRel sigma a3 && isRel sigma a4 && is_conv vmf - (Lazy.force coq_varmap_find) -> - v_lhs := Some (compute_lhs sigma - (snd (List.hd args3)) - i nargsi) - (* Third case: this is a normal LHS-RHS *) - | _ -> - n_lhs_rhs := - (compute_lhs sigma (snd (List.hd args3)) i nargsi, - compute_rhs env sigma bodyi (nargs3 + nargsi + 1)) - :: !n_lhs_rhs - end) - lci; - - if Option.is_empty !c_lhs && Option.is_empty !v_lhs then i_can't_do_that (); - - (* The Cases predicate is a lambda; we assume no dependency *) - let p = match EConstr.kind sigma p with - | Lambda (_,_,p) -> Termops.pop p - | _ -> p - in - - { normal_lhs_rhs = List.rev !n_lhs_rhs; - variable_lhs = !v_lhs; - return_type = p; - constants = List.fold_right ConstrSet.add cs ConstrSet.empty; - constant_lhs = !c_lhs } - - | _ -> i_can't_do_that () - end - |_ -> i_can't_do_that () - -(* TODO for that function: -\begin{itemize} -\item handle the case where the return type is an argument of the - function -\item handle the case of simple mutual inductive (for example terms - and lists of terms) formulas with the corresponding mutual - recursvive interpretation functions. -\end{itemize} -*) - -(*s Stuff to build variables map, currently implemented as complete -binary search trees (see file \texttt{Quote.v}) *) - -(* First the function to distinghish between constants (closed terms) - and variables (open terms) *) - -let rec closed_under sigma cset t = - (ConstrSet.mem (EConstr.Unsafe.to_constr t) cset) || - (match EConstr.kind sigma t with - | Cast(c,_,_) -> closed_under sigma cset c - | App(f,l) -> closed_under sigma cset f && Array.for_all (closed_under sigma cset) l - | _ -> false) - -(*s [btree_of_array [| c1; c2; c3; c4; c5 |]] builds the complete - binary search tree containing the [ci], that is: - -\begin{verbatim} - c1 - / \ - c2 c3 - / \ - c4 c5 -\end{verbatim} - -The second argument is a constr (the common type of the [ci]) -*) - -let btree_of_array a ty = - let size_of_a = Array.length a in - let semi_size_of_a = size_of_a lsr 1 in - let node = Lazy.force coq_Node_vm - and empty = mkApp (Lazy.force coq_Empty_vm, [| ty |]) in - let rec aux n = - if n > size_of_a - then empty - else if n > semi_size_of_a - then mkApp (node, [| ty; a.(n-1); empty; empty |]) - else mkApp (node, [| ty; a.(n-1); aux (2*n); aux (2*n+1) |]) - in - aux 1 - -(*s [btree_of_array] and [path_of_int] verify the following invariant:\\ - {\tt (varmap\_find A dv }[(path_of_int n)] [(btree_of_array a ty)] - = [a.(n)]\\ - [n] must be [> 0] *) - -let path_of_int n = - (* returns the list of digits of n in reverse order with - initial 1 removed *) - let rec digits_of_int n = - if 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 -> mkApp ((if b then Lazy.force coq_Right_idx - else Lazy.force coq_Left_idx), - [| c |])) - (List.rev (digits_of_int n)) - (Lazy.force coq_End_idx) - -(*s The tactic works with a list of subterms sharing the same - variables map. We need to sort terms in order to avoid than - strange things happen during replacement of terms by their - 'abstract' counterparties. *) - -(* [subterm t t'] tests if constr [t'] occurs in [t] *) -(* This function does not descend under binders (lambda and Cases) *) - -let rec subterm gl (t : constr) (t' : constr) = - (pf_conv_x gl t t') || - (match EConstr.kind (project gl) t with - | App (f,args) -> Array.exists (fun t -> subterm gl t t') args - | Cast(t,_,_) -> (subterm gl t t') - | _ -> false) - -(*s We want to sort the list according to reverse subterm order. *) -(* Since it's a partial order the algoritm of Sort.list won't work !! *) - -let rec sort_subterm gl l = - let sigma = project gl in - let rec insert c = function - | [] -> [c] - | (h::t as l) when EConstr.eq_constr sigma c h -> l (* Avoid doing the same work twice *) - | h::t -> if subterm gl c h then c::h::t else h::(insert c t) - in - match l with - | [] -> [] - | h::t -> insert h (sort_subterm gl t) - -module Constrhash = Hashtbl.Make(Constr) - -let subst_meta subst c = - let subst = List.map (fun (i, c) -> i, EConstr.Unsafe.to_constr c) subst in - EConstr.of_constr (Termops.subst_meta subst (EConstr.Unsafe.to_constr c)) - -(*s Now we are able to do the inversion itself. - We destructurate the term and use an imperative hashtable - to store leafs that are already encountered. - The type of arguments is:\\ - [ivs : inversion_scheme]\\ - [lc: constr list]\\ - [gl: goal sigma]\\ *) -let quote_terms env sigma ivs lc = - Coqlib.check_required_library ["Coq";"quote";"Quote"]; - let varhash = (Constrhash.create 17 : constr Constrhash.t) in - let varlist = ref ([] : constr list) in (* list of variables *) - let counter = ref 1 in (* number of variables created + 1 *) - let rec aux c = - let rec auxl l = - match l with - | (lhs, rhs)::tail -> - begin try - let s1 = Id.Map.bindings (matches env sigma rhs c) in - let s2 = List.map (fun (i,c_i) -> (coerce_meta_out i,aux c_i)) s1 - in - subst_meta s2 lhs - with PatternMatchingFailure -> auxl tail - end - | [] -> - begin match ivs.variable_lhs with - | None -> - begin match ivs.constant_lhs with - | Some c_lhs -> subst_meta [1, c] c_lhs - | None -> anomaly (Pp.str "invalid inversion scheme for quote.") - end - | Some var_lhs -> - begin match ivs.constant_lhs with - | Some c_lhs when closed_under sigma ivs.constants c -> - subst_meta [1, c] c_lhs - | _ -> - begin - try Constrhash.find varhash (EConstr.Unsafe.to_constr c) - with Not_found -> - let newvar = - subst_meta [1, (path_of_int !counter)] - var_lhs in - begin - incr counter; - varlist := c :: !varlist; - Constrhash.add varhash (EConstr.Unsafe.to_constr c) newvar; - newvar - end - end - end - end - in - auxl ivs.normal_lhs_rhs - in - let lp = List.map aux lc in - (lp, (btree_of_array (Array.of_list (List.rev !varlist)) - ivs.return_type )) - -(*s actually we could "quote" a list of terms instead of a single - term. Ring for example needs that, but Ring doesn't use Quote - yet. *) - -let pf_constrs_of_globals l = - let rec aux l acc = - match l with - [] -> Proofview.tclUNIT (List.rev acc) - | hd :: tl -> - Tacticals.New.pf_constr_of_global hd >>= fun g -> aux tl (g :: acc) - in aux l [] - -let quote f lid = - Proofview.Goal.enter begin fun gl -> - let fg = Tacmach.New.pf_global f gl in - let clg = List.map (fun id -> Tacmach.New.pf_global id gl) lid in - Tacticals.New.pf_constr_of_global fg >>= fun f -> - pf_constrs_of_globals clg >>= fun cl -> - Proofview.Goal.nf_enter begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let ivs = compute_ivs f (List.map (EConstr.to_constr sigma) cl) gl in - let concl = Proofview.Goal.concl gl in - let quoted_terms = quote_terms env sigma ivs [concl] in - let (p, vm) = match quoted_terms with - | [p], vm -> (p,vm) - | _ -> assert false - in - 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.enter begin fun gl -> - let fg = Tacmach.New.pf_global f gl in - let clg = List.map (fun id -> Tacmach.New.pf_global id gl) lid in - Tacticals.New.pf_constr_of_global fg >>= fun f -> - pf_constrs_of_globals clg >>= fun cl -> - Proofview.Goal.nf_enter begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let cl = List.map (EConstr.to_constr sigma) cl in - let ivs = compute_ivs f cl gl in - let quoted_terms = quote_terms env sigma ivs [c] in - let (p, vm) = match quoted_terms with - | [p], vm -> (p,vm) - | _ -> assert false - in - match ivs.variable_lhs with - | None -> cont (mkApp (f, [| p |])) - | Some _ -> cont (mkApp (f, [| vm; p |])) - end - end - -(*i - -Just testing ... - -#use "include.ml";; -open Quote;; - -let r = glob_constr_of_string;; - -let ivs = { - normal_lhs_rhs = - [ r "(f_and ?1 ?2)", r "?1/\?2"; - r "(f_not ?1)", r "~?1"]; - variable_lhs = Some (r "(f_atom ?1)"); - return_type = r "Prop"; - constants = ConstrSet.empty; - constant_lhs = (r "nat") -};; - -let t1 = r "True/\(True /\ ~False)";; -let t2 = r "True/\~~False";; - -quote_term ivs () t1;; -quote_term ivs () t2;; - -let ivs2 = - normal_lhs_rhs = - [ r "(f_and ?1 ?2)", r "?1/\?2"; - r "(f_not ?1)", r "~?1" - r "True", r "f_true"]; - variable_lhs = Some (r "(f_atom ?1)"); - return_type = r "Prop"; - constants = ConstrSet.empty; - constant_lhs = (r "nat") - -i*) diff --git a/plugins/quote/quote_plugin.mlpack b/plugins/quote/quote_plugin.mlpack deleted file mode 100644 index 2e9be09d8d..0000000000 --- a/plugins/quote/quote_plugin.mlpack +++ /dev/null @@ -1,2 +0,0 @@ -Quote -G_quote diff --git a/plugins/romega/README b/plugins/romega/README deleted file mode 100644 index 86c9e58afd..0000000000 --- a/plugins/romega/README +++ /dev/null @@ -1,6 +0,0 @@ -This work was done for the RNRT Project Calife. -As such it is distributed under the LGPL licence. - -Report bugs to : - pierre.cregut@francetelecom.com - diff --git a/plugins/romega/ROmega.v b/plugins/romega/ROmega.v deleted file mode 100644 index 657aae90e8..0000000000 --- a/plugins/romega/ROmega.v +++ /dev/null @@ -1,14 +0,0 @@ -(************************************************************************* - - PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D - Licence : LGPL version 2.1 - - *************************************************************************) - -Require Import ReflOmegaCore. -Require Export Setoid. -Require Export PreOmega. -Require Export ZArith_base. -Require Import OmegaPlugin. -Declare ML Module "romega_plugin". diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v deleted file mode 100644 index 51b99b9935..0000000000 --- a/plugins/romega/ReflOmegaCore.v +++ /dev/null @@ -1,1872 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************* - - PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D - Licence du projet : LGPL version 2.1 - - *************************************************************************) - -Require Import List Bool Sumbool EqNat Setoid Ring_theory Decidable ZArith_base. -Delimit Scope Int_scope with I. - -(** * Abstract Integers. *) - -Module Type Int. - - Parameter t : Set. - - Bind Scope Int_scope with t. - - Parameter Inline zero : t. - Parameter Inline one : t. - Parameter Inline plus : t -> t -> t. - Parameter Inline opp : t -> t. - Parameter Inline minus : t -> t -> t. - Parameter Inline mult : t -> t -> t. - - Notation "0" := zero : Int_scope. - Notation "1" := one : Int_scope. - Infix "+" := plus : Int_scope. - Infix "-" := minus : Int_scope. - Infix "*" := mult : Int_scope. - Notation "- x" := (opp x) : Int_scope. - - Open Scope Int_scope. - - (** First, Int is a ring: *) - Axiom ring : @ring_theory t 0 1 plus mult minus opp (@eq t). - - (** Int should also be ordered: *) - - Parameter Inline le : t -> t -> Prop. - Parameter Inline lt : t -> t -> Prop. - Parameter Inline ge : t -> t -> Prop. - Parameter Inline gt : t -> t -> Prop. - Notation "x <= y" := (le x y): Int_scope. - Notation "x < y" := (lt x y) : Int_scope. - Notation "x >= y" := (ge x y) : Int_scope. - Notation "x > y" := (gt x y): Int_scope. - Axiom le_lt_iff : forall i j, (i<=j) <-> ~(j<i). - Axiom ge_le_iff : forall i j, (i>=j) <-> (j<=i). - Axiom gt_lt_iff : forall i j, (i>j) <-> (j<i). - - (** Basic properties of this order *) - Axiom lt_trans : forall i j k, i<j -> j<k -> i<k. - Axiom lt_not_eq : forall i j, i<j -> i<>j. - - (** Compatibilities *) - Axiom lt_0_1 : 0<1. - Axiom plus_le_compat : forall i j k l, i<=j -> k<=l -> i+k<=j+l. - Axiom opp_le_compat : forall i j, i<=j -> (-j)<=(-i). - Axiom mult_lt_compat_l : - forall i j k, 0 < k -> i < j -> k*i<k*j. - - (** We should have a way to decide the equality and the order*) - Parameter compare : t -> t -> comparison. - Infix "?=" := compare (at level 70, no associativity) : Int_scope. - Axiom compare_Eq : forall i j, compare i j = Eq <-> i=j. - Axiom compare_Lt : forall i j, compare i j = Lt <-> i<j. - Axiom compare_Gt : forall i j, compare i j = Gt <-> i>j. - - (** Up to here, these requirements could be fulfilled - by any totally ordered ring. Let's now be int-specific: *) - Axiom le_lt_int : forall x y, x<y <-> x<=y+-(1). - - (** Btw, lt_0_1 could be deduced from this last axiom *) - - (** Now we also require a division function. - It is deliberately underspecified, since that's enough - for the proofs below. But the most appropriate variant - (and the one needed to stay in sync with the omega engine) - is "Floor" (the historical version of Coq's [Z.div]). *) - - Parameter diveucl : t -> t -> t * t. - Notation "i / j" := (fst (diveucl i j)). - Notation "i 'mod' j" := (snd (diveucl i j)). - Axiom diveucl_spec : - forall i j, j<>0 -> i = j * (i/j) + (i mod j). - -End Int. - - - -(** Of course, Z is a model for our abstract int *) - -Module Z_as_Int <: Int. - - Open Scope Z_scope. - - Definition t := Z. - Definition zero := 0. - Definition one := 1. - Definition plus := Z.add. - Definition opp := Z.opp. - Definition minus := Z.sub. - Definition mult := Z.mul. - - Lemma ring : @ring_theory t zero one plus mult minus opp (@eq t). - Proof. - constructor. - exact Z.add_0_l. - exact Z.add_comm. - exact Z.add_assoc. - exact Z.mul_1_l. - exact Z.mul_comm. - exact Z.mul_assoc. - exact Z.mul_add_distr_r. - unfold minus, Z.sub; auto. - exact Z.add_opp_diag_r. - Qed. - - Definition le := Z.le. - Definition lt := Z.lt. - Definition ge := Z.ge. - Definition gt := Z.gt. - Definition le_lt_iff := Z.le_ngt. - Definition ge_le_iff := Z.ge_le_iff. - Definition gt_lt_iff := Z.gt_lt_iff. - - Definition lt_trans := Z.lt_trans. - Definition lt_not_eq := Z.lt_neq. - - Definition lt_0_1 := Z.lt_0_1. - Definition plus_le_compat := Z.add_le_mono. - Definition mult_lt_compat_l := Zmult_lt_compat_l. - Lemma opp_le_compat i j : i<=j -> (-j)<=(-i). - Proof. apply -> Z.opp_le_mono. Qed. - - Definition compare := Z.compare. - Definition compare_Eq := Z.compare_eq_iff. - Lemma compare_Lt i j : compare i j = Lt <-> i<j. - Proof. reflexivity. Qed. - Lemma compare_Gt i j : compare i j = Gt <-> i>j. - Proof. reflexivity. Qed. - - Definition le_lt_int := Z.lt_le_pred. - - Definition diveucl := Z.div_eucl. - Definition diveucl_spec := Z.div_mod. - -End Z_as_Int. - - -(** * Properties of abstract integers *) - -Module IntProperties (I:Int). - Import I. - Local Notation int := I.t. - - (** Primo, some consequences of being a ring theory... *) - - Definition two := 1+1. - Notation "2" := two : Int_scope. - - (** Aliases for properties packed in the ring record. *) - - Definition plus_assoc := ring.(Radd_assoc). - Definition plus_comm := ring.(Radd_comm). - Definition plus_0_l := ring.(Radd_0_l). - Definition mult_assoc := ring.(Rmul_assoc). - Definition mult_comm := ring.(Rmul_comm). - Definition mult_1_l := ring.(Rmul_1_l). - Definition mult_plus_distr_r := ring.(Rdistr_l). - Definition opp_def := ring.(Ropp_def). - Definition minus_def := ring.(Rsub_def). - - Opaque plus_assoc plus_comm plus_0_l mult_assoc mult_comm mult_1_l - mult_plus_distr_r opp_def minus_def. - - (** More facts about [plus] *) - - Lemma plus_0_r : forall x, x+0 = x. - Proof. intros; rewrite plus_comm; apply plus_0_l. Qed. - - Lemma plus_permute : forall x y z, x+(y+z) = y+(x+z). - Proof. intros; do 2 rewrite plus_assoc; f_equal; apply plus_comm. Qed. - - Lemma plus_reg_l : forall x y z, x+y = x+z -> y = z. - Proof. - intros. - rewrite <- (plus_0_r y), <- (plus_0_r z), <-(opp_def x). - now rewrite plus_permute, plus_assoc, H, <- plus_assoc, plus_permute. - Qed. - - (** More facts about [mult] *) - - Lemma mult_plus_distr_l : forall x y z, x*(y+z)=x*y+x*z. - Proof. - intros. - rewrite (mult_comm x (y+z)), (mult_comm x y), (mult_comm x z). - apply mult_plus_distr_r. - Qed. - - Lemma mult_0_l x : 0*x = 0. - Proof. - assert (H := mult_plus_distr_r 0 1 x). - rewrite plus_0_l, mult_1_l, plus_comm in H. - apply plus_reg_l with x. - now rewrite <- H, plus_0_r. - Qed. - - Lemma mult_0_r x : x*0 = 0. - Proof. - rewrite mult_comm. apply mult_0_l. - Qed. - - Lemma mult_1_r x : x*1 = x. - Proof. - rewrite mult_comm. apply mult_1_l. - Qed. - - (** More facts about [opp] *) - - Definition plus_opp_r := opp_def. - - Lemma plus_opp_l : forall x, -x + x = 0. - Proof. intros; now rewrite plus_comm, opp_def. Qed. - - Lemma mult_opp_comm : forall x y, - x * y = x * - y. - Proof. - intros. - apply plus_reg_l with (x*y). - rewrite <- mult_plus_distr_l, <- mult_plus_distr_r. - now rewrite opp_def, opp_def, mult_0_l, mult_comm, mult_0_l. - Qed. - - Lemma opp_eq_mult_neg_1 : forall x, -x = x * -(1). - Proof. - intros; now rewrite mult_comm, mult_opp_comm, mult_1_l. - Qed. - - Lemma opp_involutive : forall x, -(-x) = x. - Proof. - intros. - apply plus_reg_l with (-x). - now rewrite opp_def, plus_comm, opp_def. - Qed. - - Lemma opp_plus_distr : forall x y, -(x+y) = -x + -y. - Proof. - intros. - apply plus_reg_l with (x+y). - rewrite opp_def. - rewrite plus_permute. - do 2 rewrite plus_assoc. - now rewrite (plus_comm (-x)), opp_def, plus_0_l, opp_def. - Qed. - - Lemma opp_mult_distr_r : forall x y, -(x*y) = x * -y. - Proof. - intros. - rewrite <- mult_opp_comm. - apply plus_reg_l with (x*y). - now rewrite opp_def, <-mult_plus_distr_r, opp_def, mult_0_l. - Qed. - - Lemma egal_left n m : 0 = n+-m <-> n = m. - Proof. - split; intros. - - apply plus_reg_l with (-m). - rewrite plus_comm, <- H. symmetry. apply plus_opp_l. - - symmetry. subst; apply opp_def. - Qed. - - (** Specialized distributivities *) - - Hint Rewrite mult_plus_distr_l mult_plus_distr_r mult_assoc : int. - Hint Rewrite <- plus_assoc : int. - - Hint Rewrite plus_0_l plus_0_r mult_0_l mult_0_r mult_1_l mult_1_r : int. - - Lemma OMEGA10 v c1 c2 l1 l2 k1 k2 : - v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2) = - (v * c1 + l1) * k1 + (v * c2 + l2) * k2. - Proof. - autorewrite with int; f_equal; now rewrite plus_permute. - Qed. - - Lemma OMEGA11 v1 c1 l1 l2 k1 : - v1 * (c1 * k1) + (l1 * k1 + l2) = (v1 * c1 + l1) * k1 + l2. - Proof. - now autorewrite with int. - Qed. - - Lemma OMEGA12 v2 c2 l1 l2 k2 : - v2 * (c2 * k2) + (l1 + l2 * k2) = l1 + (v2 * c2 + l2) * k2. - Proof. - autorewrite with int; now rewrite plus_permute. - Qed. - - Lemma sum1 a b c d : 0 = a -> 0 = b -> 0 = a * c + b * d. - Proof. - intros; subst. now autorewrite with int. - Qed. - - - (** Secondo, some results about order (and equality) *) - - Lemma lt_irrefl : forall n, ~ n<n. - Proof. - intros n H. - elim (lt_not_eq _ _ H); auto. - Qed. - - Lemma lt_antisym : forall n m, n<m -> m<n -> False. - Proof. - intros; elim (lt_irrefl _ (lt_trans _ _ _ H H0)); auto. - Qed. - - Lemma lt_le_weak : forall n m, n<m -> n<=m. - Proof. - intros; rewrite le_lt_iff; intro H'; eapply lt_antisym; eauto. - Qed. - - Lemma le_refl : forall n, n<=n. - Proof. - intros; rewrite le_lt_iff; apply lt_irrefl; auto. - Qed. - - Lemma le_antisym : forall n m, n<=m -> m<=n -> n=m. - Proof. - intros n m; do 2 rewrite le_lt_iff; intros. - rewrite <- compare_Lt in H0. - rewrite <- gt_lt_iff, <- compare_Gt in H. - rewrite <- compare_Eq. - destruct compare; intuition. - Qed. - - Lemma lt_eq_lt_dec : forall n m, { n<m }+{ n=m }+{ m<n }. - Proof. - intros. - generalize (compare_Lt n m)(compare_Eq n m)(compare_Gt n m). - destruct compare; [ left; right | left; left | right ]; intuition. - rewrite gt_lt_iff in H1; intuition. - Qed. - - Lemma lt_dec : forall n m: int, { n<m } + { ~n<m }. - Proof. - intros. - generalize (compare_Lt n m)(compare_Eq n m)(compare_Gt n m). - destruct compare; [ right | left | right ]; intuition discriminate. - Qed. - - Lemma lt_le_iff : forall n m, (n<m) <-> ~(m<=n). - Proof. - intros. - rewrite le_lt_iff. - destruct (lt_dec n m); intuition. - Qed. - - Lemma le_dec : forall n m: int, { n<=m } + { ~n<=m }. - Proof. - intros; destruct (lt_dec m n); [right|left]; rewrite le_lt_iff; intuition. - Qed. - - Lemma le_lt_dec : forall n m, { n<=m } + { m<n }. - Proof. - intros; destruct (le_dec n m); [left|right]; auto; now rewrite lt_le_iff. - Qed. - - - Definition beq i j := match compare i j with Eq => true | _ => false end. - - Infix "=?" := beq : Int_scope. - - Lemma beq_iff i j : (i =? j) = true <-> i=j. - Proof. - unfold beq. rewrite <- (compare_Eq i j). now destruct compare. - Qed. - - Lemma beq_reflect i j : reflect (i=j) (i =? j). - Proof. - apply iff_reflect. symmetry. apply beq_iff. - Qed. - - Lemma eq_dec : forall n m:int, { n=m } + { n<>m }. - Proof. - intros n m; generalize (beq_iff n m); destruct beq; [left|right]; intuition. - Qed. - - Definition blt i j := match compare i j with Lt => true | _ => false end. - - Infix "<?" := blt : Int_scope. - - Lemma blt_iff i j : (i <? j) = true <-> i<j. - Proof. - unfold blt. rewrite <- (compare_Lt i j). now destruct compare. - Qed. - - Lemma blt_reflect i j : reflect (i<j) (i <? j). - Proof. - apply iff_reflect. symmetry. apply blt_iff. - Qed. - - Lemma le_is_lt_or_eq : forall n m, n<=m -> { n<m } + { n=m }. - Proof. - intros n m Hnm. - destruct (eq_dec n m) as [H'|H']. - - right; intuition. - - left; rewrite lt_le_iff. - contradict H'. - now apply le_antisym. - Qed. - - Lemma le_neq_lt : forall n m, n<=m -> n<>m -> n<m. - Proof. - intros n m H. now destruct (le_is_lt_or_eq _ _ H). - Qed. - - Lemma le_trans : forall n m p, n<=m -> m<=p -> n<=p. - Proof. - intros n m p; rewrite 3 le_lt_iff; intros A B C. - destruct (lt_eq_lt_dec p m) as [[H|H]|H]; subst; auto. - generalize (lt_trans _ _ _ H C); intuition. - Qed. - - Lemma not_eq (a b:int) : ~ a <> b <-> a = b. - Proof. - destruct (eq_dec a b); intuition. - Qed. - - (** Order and operations *) - - Lemma le_0_neg n : n <= 0 <-> 0 <= -n. - Proof. - rewrite <- (mult_0_l (-(1))) at 2. - rewrite <- opp_eq_mult_neg_1. - split; intros. - - now apply opp_le_compat. - - rewrite <-(opp_involutive 0), <-(opp_involutive n). - now apply opp_le_compat. - Qed. - - Lemma plus_le_reg_r : forall n m p, n + p <= m + p -> n <= m. - Proof. - intros. - replace n with ((n+p)+-p). - replace m with ((m+p)+-p). - apply plus_le_compat; auto. - apply le_refl. - now rewrite <- plus_assoc, opp_def, plus_0_r. - now rewrite <- plus_assoc, opp_def, plus_0_r. - Qed. - - Lemma plus_le_lt_compat : forall n m p q, n<=m -> p<q -> n+p<m+q. - Proof. - intros. - apply le_neq_lt. - apply plus_le_compat; auto. - apply lt_le_weak; auto. - rewrite lt_le_iff in H0. - contradict H0. - apply plus_le_reg_r with m. - rewrite (plus_comm q m), <-H0, (plus_comm p m). - apply plus_le_compat; auto. - apply le_refl; auto. - Qed. - - Lemma plus_lt_compat : forall n m p q, n<m -> p<q -> n+p<m+q. - Proof. - intros. - apply plus_le_lt_compat; auto. - apply lt_le_weak; auto. - Qed. - - Lemma opp_lt_compat : forall n m, n<m -> -m < -n. - Proof. - intros n m; do 2 rewrite lt_le_iff; intros H; contradict H. - rewrite <-(opp_involutive m), <-(opp_involutive n). - apply opp_le_compat; auto. - Qed. - - Lemma lt_0_neg n : n < 0 <-> 0 < -n. - Proof. - rewrite <- (mult_0_l (-(1))) at 2. - rewrite <- opp_eq_mult_neg_1. - split; intros. - - now apply opp_lt_compat. - - rewrite <-(opp_involutive 0), <-(opp_involutive n). - now apply opp_lt_compat. - Qed. - - Lemma mult_lt_0_compat : forall n m, 0 < n -> 0 < m -> 0 < n*m. - Proof. - intros. - rewrite <- (mult_0_l n), mult_comm. - apply mult_lt_compat_l; auto. - Qed. - - Lemma mult_integral_r n m : 0 < n -> n * m = 0 -> m = 0. - Proof. - intros Hn H. - destruct (lt_eq_lt_dec 0 m) as [[Hm| <- ]|Hm]; auto; exfalso. - - generalize (mult_lt_0_compat _ _ Hn Hm). - rewrite H. - exact (lt_irrefl 0). - - rewrite lt_0_neg in Hm. - generalize (mult_lt_0_compat _ _ Hn Hm). - rewrite <- opp_mult_distr_r, opp_eq_mult_neg_1, H, mult_0_l. - exact (lt_irrefl 0). - Qed. - - Lemma mult_integral n m : n * m = 0 -> n = 0 \/ m = 0. - Proof. - intros H. - destruct (lt_eq_lt_dec 0 n) as [[Hn|Hn]|Hn]. - - right; apply (mult_integral_r n m); trivial. - - now left. - - right; apply (mult_integral_r (-n) m). - + now apply lt_0_neg. - + rewrite mult_comm, <- opp_mult_distr_r, mult_comm, H. - now rewrite opp_eq_mult_neg_1, mult_0_l. - Qed. - - Lemma mult_le_compat_l i j k : - 0<=k -> i<=j -> k*i <= k*j. - Proof. - intros Hk Hij. - apply le_is_lt_or_eq in Hk. apply le_is_lt_or_eq in Hij. - destruct Hk as [Hk | <-], Hij as [Hij | <-]; - rewrite ? mult_0_l; try apply le_refl. - now apply lt_le_weak, mult_lt_compat_l. - Qed. - - Lemma mult_le_compat i j k l : - i<=j -> k<=l -> 0<=i -> 0<=k -> i*k<=j*l. - Proof. - intros Hij Hkl Hi Hk. - apply le_trans with (i*l). - - now apply mult_le_compat_l. - - rewrite (mult_comm i), (mult_comm j). - apply mult_le_compat_l; trivial. - now apply le_trans with k. - Qed. - - Lemma sum5 a b c d : 0 <> c -> 0 <> a -> 0 = b -> 0 <> a * c + b * d. - Proof. - intros Hc Ha <-. autorewrite with int. contradict Hc. - symmetry in Hc. destruct (mult_integral _ _ Hc); congruence. - Qed. - - Lemma le_left n m : n <= m <-> 0 <= m + - n. - Proof. - split; intros. - - rewrite <- (opp_def m). - apply plus_le_compat. - apply le_refl. - apply opp_le_compat; auto. - - apply plus_le_reg_r with (-n). - now rewrite plus_opp_r. - Qed. - - Lemma OMEGA8 x y : 0 <= x -> 0 <= y -> x = - y -> x = 0. - Proof. - intros. - assert (y=-x). - subst x; symmetry; apply opp_involutive. - clear H1; subst y. - destruct (eq_dec 0 x) as [H'|H']; auto. - assert (H'':=le_neq_lt _ _ H H'). - generalize (plus_le_lt_compat _ _ _ _ H0 H''). - rewrite plus_opp_l, plus_0_l. - intros. - elim (lt_not_eq _ _ H1); auto. - Qed. - - Lemma sum2 a b c d : - 0 <= d -> 0 = a -> 0 <= b -> 0 <= a * c + b * d. - Proof. - intros Hd <- Hb. autorewrite with int. - rewrite <- (mult_0_l 0). - apply mult_le_compat; auto; apply le_refl. - Qed. - - Lemma sum3 a b c d : - 0 <= c -> 0 <= d -> 0 <= a -> 0 <= b -> 0 <= a * c + b * d. - Proof. - intros. - rewrite <- (plus_0_l 0). - apply plus_le_compat; auto. - rewrite <- (mult_0_l 0). - apply mult_le_compat; auto; apply le_refl. - rewrite <- (mult_0_l 0). - apply mult_le_compat; auto; apply le_refl. - Qed. - - (** Lemmas specific to integers (they use [le_lt_int]) *) - - Lemma lt_left n m : n < m <-> 0 <= m + -n + -(1). - Proof. - rewrite <- plus_assoc, (plus_comm (-n)), plus_assoc. - rewrite <- le_left. - apply le_lt_int. - Qed. - - Lemma OMEGA4 x y z : 0 < x -> x < y -> z * y + x <> 0. - Proof. - intros H H0 H'. - assert (0 < y) by now apply lt_trans with x. - destruct (lt_eq_lt_dec z 0) as [[G|G]|G]. - - - generalize (plus_le_lt_compat _ _ _ _ (le_refl (z*y)) H0). - rewrite H'. - rewrite <-(mult_1_l y) at 2. rewrite <-mult_plus_distr_r. - apply le_lt_iff. - rewrite mult_comm. rewrite <- (mult_0_r y). - apply mult_le_compat_l; auto using lt_le_weak. - apply le_0_neg. rewrite opp_plus_distr. - apply le_lt_int. now apply lt_0_neg. - - - apply (lt_not_eq 0 (z*y+x)); auto. - subst. now autorewrite with int. - - - apply (lt_not_eq 0 (z*y+x)); auto. - rewrite <- (plus_0_l 0). - auto using plus_lt_compat, mult_lt_0_compat. - Qed. - - Lemma OMEGA19 x : x<>0 -> 0 <= x + -(1) \/ 0 <= x * -(1) + -(1). - Proof. - intros. - do 2 rewrite <- le_lt_int. - rewrite <- opp_eq_mult_neg_1. - destruct (lt_eq_lt_dec 0 x) as [[H'|H']|H']. - auto. - congruence. - right. - rewrite <-(mult_0_l (-(1))), <-(opp_eq_mult_neg_1 0). - apply opp_lt_compat; auto. - Qed. - - Lemma mult_le_approx n m p : - 0 < n -> p < n -> 0 <= m * n + p -> 0 <= m. - Proof. - do 2 rewrite le_lt_iff; intros Hn Hpn H Hm. destruct H. - apply lt_0_neg, le_lt_int, le_left in Hm. - rewrite lt_0_neg. - rewrite opp_plus_distr, mult_comm, opp_mult_distr_r. - rewrite le_lt_int. apply lt_left. - rewrite le_lt_int. - apply le_trans with (n+-(1)); [ now apply le_lt_int | ]. - apply plus_le_compat; [ | apply le_refl ]. - rewrite <- (mult_1_r n) at 1. - apply mult_le_compat_l; auto using lt_le_weak. - Qed. - - (** Some decidabilities *) - - Lemma dec_eq : forall i j:int, decidable (i=j). - Proof. - red; intros; destruct (eq_dec i j); auto. - Qed. - - Lemma dec_ne : forall i j:int, decidable (i<>j). - Proof. - red; intros; destruct (eq_dec i j); auto. - Qed. - - Lemma dec_le : forall i j:int, decidable (i<=j). - Proof. - red; intros; destruct (le_dec i j); auto. - Qed. - - Lemma dec_lt : forall i j:int, decidable (i<j). - Proof. - red; intros; destruct (lt_dec i j); auto. - Qed. - - Lemma dec_ge : forall i j:int, decidable (i>=j). - Proof. - red; intros; rewrite ge_le_iff; destruct (le_dec j i); auto. - Qed. - - Lemma dec_gt : forall i j:int, decidable (i>j). - Proof. - red; intros; rewrite gt_lt_iff; destruct (lt_dec j i); auto. - Qed. - -End IntProperties. - - -(** * The Coq side of the romega tactic *) - -Module IntOmega (I:Int). -Import I. -Module IP:=IntProperties(I). -Import IP. -Local Notation int := I.t. - -(* ** Definition of reified integer expressions - - Terms are either: - - integers [Tint] - - variables [Tvar] - - operation over integers (addition, product, opposite, subtraction) - - Opposite and subtraction are translated in additions and products. - Note that we'll only deal with products for which at least one side - is [Tint]. *) - -Inductive term : Set := - | Tint : int -> term - | Tplus : term -> term -> term - | Tmult : term -> term -> term - | Tminus : term -> term -> term - | Topp : term -> term - | Tvar : N -> term. - -Bind Scope romega_scope with term. -Delimit Scope romega_scope with term. -Arguments Tint _%I. -Arguments Tplus (_ _)%term. -Arguments Tmult (_ _)%term. -Arguments Tminus (_ _)%term. -Arguments Topp _%term. - -Infix "+" := Tplus : romega_scope. -Infix "*" := Tmult : romega_scope. -Infix "-" := Tminus : romega_scope. -Notation "- x" := (Topp x) : romega_scope. -Notation "[ x ]" := (Tvar x) (at level 0) : romega_scope. - -(* ** Definition of reified goals - - Very restricted definition of handled predicates that should be extended - to cover a wider set of operations. - Taking care of negations and disequations require solving more than a - goal in parallel. This is a major improvement over previous versions. *) - -Inductive proposition : Set := - (** First, basic equations, disequations, inequations *) - | EqTerm : term -> term -> proposition - | NeqTerm : term -> term -> proposition - | LeqTerm : term -> term -> proposition - | GeqTerm : term -> term -> proposition - | GtTerm : term -> term -> proposition - | LtTerm : term -> term -> proposition - (** Then, the supported logical connectors *) - | TrueTerm : proposition - | FalseTerm : proposition - | Tnot : proposition -> proposition - | Tor : proposition -> proposition -> proposition - | Tand : proposition -> proposition -> proposition - | Timp : proposition -> proposition -> proposition - (** Everything else is left as a propositional atom (and ignored). *) - | Tprop : nat -> proposition. - -(** Definition of goals as a list of hypothesis *) -Notation hyps := (list proposition). - -(** Definition of lists of subgoals (set of open goals) *) -Notation lhyps := (list hyps). - -(** A single goal packed in a subgoal list *) -Notation singleton := (fun a : hyps => a :: nil). - -(** An absurd goal *) -Definition absurd := FalseTerm :: nil. - -(** ** Decidable equality on terms *) - -Fixpoint eq_term (t1 t2 : term) {struct t2} : bool := - match t1, t2 with - | Tint i1, Tint i2 => i1 =? i2 - | (t11 + t12), (t21 + t22) => eq_term t11 t21 && eq_term t12 t22 - | (t11 * t12), (t21 * t22) => eq_term t11 t21 && eq_term t12 t22 - | (t11 - t12), (t21 - t22) => eq_term t11 t21 && eq_term t12 t22 - | (- t1), (- t2) => eq_term t1 t2 - | [v1], [v2] => N.eqb v1 v2 - | _, _ => false - end%term. - -Infix "=?" := eq_term : romega_scope. - -Theorem eq_term_iff (t t' : term) : - (t =? t')%term = true <-> t = t'. -Proof. - revert t'. induction t; destruct t'; simpl in *; - rewrite ?andb_true_iff, ?beq_iff, ?N.eqb_eq, ?IHt, ?IHt1, ?IHt2; - intuition congruence. -Qed. - -Theorem eq_term_reflect (t t' : term) : reflect (t=t') (t =? t')%term. -Proof. - apply iff_reflect. symmetry. apply eq_term_iff. -Qed. - -(** ** Interpretations of terms (as integers). *) - -Fixpoint Nnth {A} (n:N)(l:list A)(default:A) := - match n, l with - | _, nil => default - | 0%N, x::_ => x - | _, _::l => Nnth (N.pred n) l default - end. - -Fixpoint interp_term (env : list int) (t : term) : int := - match t with - | Tint x => x - | (t1 + t2)%term => interp_term env t1 + interp_term env t2 - | (t1 * t2)%term => interp_term env t1 * interp_term env t2 - | (t1 - t2)%term => interp_term env t1 - interp_term env t2 - | (- t)%term => - interp_term env t - | [n]%term => Nnth n env 0 - end. - -(** ** Interpretation of predicats (as Coq propositions) *) - -Fixpoint interp_prop (envp : list Prop) (env : list int) - (p : proposition) : Prop := - match p with - | EqTerm t1 t2 => interp_term env t1 = interp_term env t2 - | NeqTerm t1 t2 => (interp_term env t1) <> (interp_term env t2) - | LeqTerm t1 t2 => interp_term env t1 <= interp_term env t2 - | GeqTerm t1 t2 => interp_term env t1 >= interp_term env t2 - | GtTerm t1 t2 => interp_term env t1 > interp_term env t2 - | LtTerm t1 t2 => interp_term env t1 < interp_term env t2 - | TrueTerm => True - | FalseTerm => False - | Tnot p' => ~ interp_prop envp env p' - | Tor p1 p2 => interp_prop envp env p1 \/ interp_prop envp env p2 - | Tand p1 p2 => interp_prop envp env p1 /\ interp_prop envp env p2 - | Timp p1 p2 => interp_prop envp env p1 -> interp_prop envp env p2 - | Tprop n => nth n envp True - end. - -(** ** Intepretation of hypothesis lists (as Coq conjunctions) *) - -Fixpoint interp_hyps (envp : list Prop) (env : list int) (l : hyps) - : Prop := - match l with - | nil => True - | p' :: l' => interp_prop envp env p' /\ interp_hyps envp env l' - end. - -(** ** Interpretation of conclusion + hypotheses - - Here we use Coq implications : it's less easy to manipulate, - but handy to relate to the Coq original goal (cf. the use of - [generalize], and lighter (no repetition of types in intermediate - conjunctions). *) - -Fixpoint interp_goal_concl (c : proposition) (envp : list Prop) - (env : list int) (l : hyps) : Prop := - match l with - | nil => interp_prop envp env c - | p' :: l' => - interp_prop envp env p' -> interp_goal_concl c envp env l' - end. - -Notation interp_goal := (interp_goal_concl FalseTerm). - -(** Equivalence between these two interpretations. *) - -Theorem goal_to_hyps : - forall (envp : list Prop) (env : list int) (l : hyps), - (interp_hyps envp env l -> False) -> interp_goal envp env l. -Proof. - induction l; simpl; auto. -Qed. - -Theorem hyps_to_goal : - forall (envp : list Prop) (env : list int) (l : hyps), - interp_goal envp env l -> interp_hyps envp env l -> False. -Proof. - induction l; simpl; auto. - intros H (H1,H2). auto. -Qed. - -(** ** Interpretations of list of goals - - Here again, two flavours... *) - -Fixpoint interp_list_hyps (envp : list Prop) (env : list int) - (l : lhyps) : Prop := - match l with - | nil => False - | h :: l' => interp_hyps envp env h \/ interp_list_hyps envp env l' - end. - -Fixpoint interp_list_goal (envp : list Prop) (env : list int) - (l : lhyps) : Prop := - match l with - | nil => True - | h :: l' => interp_goal envp env h /\ interp_list_goal envp env l' - end. - -(** Equivalence between the two flavours. *) - -Theorem list_goal_to_hyps : - forall (envp : list Prop) (env : list int) (l : lhyps), - (interp_list_hyps envp env l -> False) -> interp_list_goal envp env l. -Proof. - induction l; simpl; intuition. now apply goal_to_hyps. -Qed. - -Theorem list_hyps_to_goal : - forall (envp : list Prop) (env : list int) (l : lhyps), - interp_list_goal envp env l -> interp_list_hyps envp env l -> False. -Proof. - induction l; simpl; intuition. eapply hyps_to_goal; eauto. -Qed. - -(** ** Stabiliy and validity of operations *) - -(** An operation on terms is stable if the interpretation is unchanged. *) - -Definition term_stable (f : term -> term) := - forall (e : list int) (t : term), interp_term e t = interp_term e (f t). - -(** An operation on one hypothesis is valid if this hypothesis implies - the result of this operation. *) - -Definition valid1 (f : proposition -> proposition) := - forall (ep : list Prop) (e : list int) (p1 : proposition), - interp_prop ep e p1 -> interp_prop ep e (f p1). - -Definition valid2 (f : proposition -> proposition -> proposition) := - forall (ep : list Prop) (e : list int) (p1 p2 : proposition), - interp_prop ep e p1 -> - interp_prop ep e p2 -> interp_prop ep e (f p1 p2). - -(** Same for lists of hypotheses, and for list of goals *) - -Definition valid_hyps (f : hyps -> hyps) := - forall (ep : list Prop) (e : list int) (lp : hyps), - interp_hyps ep e lp -> interp_hyps ep e (f lp). - -Definition valid_list_hyps (f : hyps -> lhyps) := - forall (ep : list Prop) (e : list int) (lp : hyps), - interp_hyps ep e lp -> interp_list_hyps ep e (f lp). - -Definition valid_list_goal (f : hyps -> lhyps) := - forall (ep : list Prop) (e : list int) (lp : hyps), - interp_list_goal ep e (f lp) -> interp_goal ep e lp. - -(** Some results about these validities. *) - -Theorem valid_goal : - forall (ep : list Prop) (env : list int) (l : hyps) (a : hyps -> hyps), - valid_hyps a -> interp_goal ep env (a l) -> interp_goal ep env l. -Proof. - intros; simpl; apply goal_to_hyps; intro H1; - apply (hyps_to_goal ep env (a l) H0); apply H; assumption. -Qed. - -Theorem goal_valid : - forall f : hyps -> lhyps, valid_list_hyps f -> valid_list_goal f. -Proof. - unfold valid_list_goal; intros f H ep e lp H1; apply goal_to_hyps; - intro H2; apply list_hyps_to_goal with (1 := H1); - apply (H ep e lp); assumption. -Qed. - -Theorem append_valid : - forall (ep : list Prop) (e : list int) (l1 l2 : lhyps), - interp_list_hyps ep e l1 \/ interp_list_hyps ep e l2 -> - interp_list_hyps ep e (l1 ++ l2). -Proof. - induction l1; simpl in *. - - now intros l2 [H| H]. - - intros l2 [[H| H]| H]. - + auto. - + right; apply IHl1; now left. - + right; apply IHl1; now right. -Qed. - -(** ** Valid operations on hypotheses *) - -(** Extract an hypothesis from the list *) - -Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm. - -Theorem nth_valid : - forall (ep : list Prop) (e : list int) (i : nat) (l : hyps), - interp_hyps ep e l -> interp_prop ep e (nth_hyps i l). -Proof. - unfold nth_hyps. induction i; destruct l; simpl in *; try easy. - intros (H1,H2). now apply IHi. -Qed. - -(** Apply a valid operation on two hypotheses from the list, and - store the result in the list. *) - -Definition apply_oper_2 (i j : nat) - (f : proposition -> proposition -> proposition) (l : hyps) := - f (nth_hyps i l) (nth_hyps j l) :: l. - -Theorem apply_oper_2_valid : - forall (i j : nat) (f : proposition -> proposition -> proposition), - valid2 f -> valid_hyps (apply_oper_2 i j f). -Proof. - intros i j f Hf; unfold apply_oper_2, valid_hyps; simpl; - intros lp Hlp; split. - - apply Hf; apply nth_valid; assumption. - - assumption. -Qed. - -(** In-place modification of an hypothesis by application of - a valid operation. *) - -Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition) - (l : hyps) {struct i} : hyps := - match l with - | nil => nil - | p :: l' => - match i with - | O => f p :: l' - | S j => p :: apply_oper_1 j f l' - end - end. - -Theorem apply_oper_1_valid : - forall (i : nat) (f : proposition -> proposition), - valid1 f -> valid_hyps (apply_oper_1 i f). -Proof. - unfold valid_hyps. - induction i; intros f Hf ep e [ | p lp]; simpl; intuition. -Qed. - -(** ** A tactic for proving stability *) - -Ltac loop t := - match t with - (* Global *) - | (?X1 = ?X2) => loop X1 || loop X2 - | (_ -> ?X1) => loop X1 - (* Interpretations *) - | (interp_hyps _ _ ?X1) => loop X1 - | (interp_list_hyps _ _ ?X1) => loop X1 - | (interp_prop _ _ ?X1) => loop X1 - | (interp_term _ ?X1) => loop X1 - (* Propositions *) - | (EqTerm ?X1 ?X2) => loop X1 || loop X2 - | (LeqTerm ?X1 ?X2) => loop X1 || loop X2 - (* Terms *) - | (?X1 + ?X2)%term => loop X1 || loop X2 - | (?X1 - ?X2)%term => loop X1 || loop X2 - | (?X1 * ?X2)%term => loop X1 || loop X2 - | (- ?X1)%term => loop X1 - | (Tint ?X1) => loop X1 - (* Eliminations *) - | (if ?X1 =? ?X2 then _ else _) => - let H := fresh "H" in - case (beq_reflect X1 X2); intro H; - try (rewrite H in *; clear H); simpl; auto; Simplify - | (if ?X1 <? ?X2 then _ else _) => - case (blt_reflect X1 X2); intro; simpl; auto; Simplify - | (if (?X1 =? ?X2)%term then _ else _) => - let H := fresh "H" in - case (eq_term_reflect X1 X2); intro H; - try (rewrite H in *; clear H); simpl; auto; Simplify - | (if _ && _ then _ else _) => rewrite andb_if; Simplify - | (if negb _ then _ else _) => rewrite negb_if; Simplify - | match N.compare ?X1 ?X2 with _ => _ end => - destruct (N.compare_spec X1 X2); Simplify - | match ?X1 with _ => _ end => destruct X1; auto; Simplify - | _ => fail - end - -with Simplify := match goal with - | |- ?X1 => try loop X1 - | _ => idtac - end. - -(** ** Operations on equation bodies *) - -(** The operations below handle in priority _normalized_ terms, i.e. - terms of the form: - [([v1]*Tint k1 + ([v2]*Tint k2 + (... + Tint cst)))] - with [v1>v2>...] and all [ki<>0]. - See [normalize] below for a way to put terms in this form. - - These operations also produce a correct (but suboptimal) - result in case of non-normalized input terms, but this situation - should normally not happen when running [romega]. - - /!\ Do not modify this section (especially [fusion] and [normalize]) - without tweaking the corresponding functions in [refl_omega.ml]. -*) - -(** Multiplication and sum by two constants. Invariant: [k1<>0]. *) - -Fixpoint scalar_mult_add (t : term) (k1 k2 : int) : term := - match t with - | v1 * Tint x1 + l1 => - v1 * Tint (x1 * k1) + scalar_mult_add l1 k1 k2 - | Tint x => Tint (k1 * x + k2) - | _ => t * Tint k1 + Tint k2 (* shouldn't happen *) - end%term. - -Theorem scalar_mult_add_stable e t k1 k2 : - interp_term e (scalar_mult_add t k1 k2) = - interp_term e (t * Tint k1 + Tint k2). -Proof. - induction t; simpl; Simplify; simpl; auto. f_equal. apply mult_comm. - rewrite IHt2. simpl. apply OMEGA11. -Qed. - -(** Multiplication by a (non-nul) constant. *) - -Definition scalar_mult (t : term) (k : int) := scalar_mult_add t k 0. - -Theorem scalar_mult_stable e t k : - interp_term e (scalar_mult t k) = - interp_term e (t * Tint k). -Proof. - unfold scalar_mult. rewrite scalar_mult_add_stable. simpl. - apply plus_0_r. -Qed. - -(** Adding a constant - - Instead of using [scalar_norm_add t 1 k], the following - definition spares some computations. - *) - -Fixpoint scalar_add (t : term) (k : int) : term := - match t with - | m + l => m + scalar_add l k - | Tint x => Tint (x + k) - | _ => t + Tint k - end%term. - -Theorem scalar_add_stable e t k : - interp_term e (scalar_add t k) = interp_term e (t + Tint k). -Proof. - induction t; simpl; Simplify; simpl; auto. - rewrite IHt2. simpl. apply plus_assoc. -Qed. - -(** Division by a constant - - All the non-constant coefficients should be exactly dividable *) - -Fixpoint scalar_div (t : term) (k : int) : option (term * int) := - match t with - | v * Tint x + l => - let (q,r) := diveucl x k in - if (r =? 0)%I then - match scalar_div l k with - | None => None - | Some (u,c) => Some (v * Tint q + u, c) - end - else None - | Tint x => - let (q,r) := diveucl x k in - Some (Tint q, r) - | _ => None - end%term. - -Lemma scalar_div_stable e t k u c : k<>0 -> - scalar_div t k = Some (u,c) -> - interp_term e (u * Tint k + Tint c) = interp_term e t. -Proof. - revert u c. - induction t; simpl; Simplify; try easy. - - intros u c Hk. assert (H := diveucl_spec t0 k Hk). - simpl in H. - destruct diveucl as (q,r). simpl in H. rewrite H. - injection 1 as <- <-. simpl. f_equal. apply mult_comm. - - intros u c Hk. - destruct t1; simpl; Simplify; try easy. - destruct t1_2; simpl; Simplify; try easy. - assert (H := diveucl_spec t0 k Hk). - simpl in H. - destruct diveucl as (q,r). simpl in H. rewrite H. - case beq_reflect; [intros -> | easy]. - destruct (scalar_div t2 k) as [(u',c')|] eqn:E; [|easy]. - injection 1 as <- ->. simpl. - rewrite <- (IHt2 u' c Hk); simpl; auto. - rewrite plus_0_r , (mult_comm k q). symmetry. apply OMEGA11. -Qed. - - -(** Fusion of two equations. - - From two normalized equations, this fusion will produce - a normalized output corresponding to the coefficiented sum. - Invariant: [k1<>0] and [k2<>0]. -*) - -Fixpoint fusion (t1 t2 : term) (k1 k2 : int) : term := - match t1 with - | [v1] * Tint x1 + l1 => - (fix fusion_t1 t2 : term := - match t2 with - | [v2] * Tint x2 + l2 => - match N.compare v1 v2 with - | Eq => - let k := (k1 * x1 + k2 * x2)%I in - if (k =? 0)%I then fusion l1 l2 k1 k2 - else [v1] * Tint k + fusion l1 l2 k1 k2 - | Lt => [v2] * Tint (k2 * x2) + fusion_t1 l2 - | Gt => [v1] * Tint (k1 * x1) + fusion l1 t2 k1 k2 - end - | Tint x2 => [v1] * Tint (k1 * x1) + fusion l1 t2 k1 k2 - | _ => t1 * Tint k1 + t2 * Tint k2 (* shouldn't happen *) - end) t2 - | Tint x1 => scalar_mult_add t2 k2 (k1 * x1) - | _ => t1 * Tint k1 + t2 * Tint k2 (* shouldn't happen *) - end%term. - -Theorem fusion_stable e t1 t2 k1 k2 : - interp_term e (fusion t1 t2 k1 k2) = - interp_term e (t1 * Tint k1 + t2 * Tint k2). -Proof. - revert t2; induction t1; simpl; Simplify; simpl; auto. - - intros; rewrite scalar_mult_add_stable. simpl. - rewrite plus_comm. f_equal. apply mult_comm. - - intros. Simplify. induction t2; simpl; Simplify; simpl; auto. - + rewrite IHt1_2. simpl. rewrite (mult_comm k1); apply OMEGA11. - + rewrite IHt1_2. simpl. subst n0. - rewrite (mult_comm k1), (mult_comm k2) in H0. - rewrite <- OMEGA10, H0. now autorewrite with int. - + rewrite IHt1_2. simpl. subst n0. - rewrite (mult_comm k1), (mult_comm k2); apply OMEGA10. - + rewrite IHt2_2. simpl. rewrite (mult_comm k2); apply OMEGA12. - + rewrite IHt1_2. simpl. rewrite (mult_comm k1); apply OMEGA11. -Qed. - -(** Term normalization. - - Precondition: all [Tmult] should be on at least one [Tint]. - Postcondition: a normalized equivalent term (see below). -*) - -Fixpoint normalize t := - match t with - | Tint n => Tint n - | [n]%term => ([n] * Tint 1 + Tint 0)%term - | (t + t')%term => fusion (normalize t) (normalize t') 1 1 - | (- t)%term => scalar_mult (normalize t) (-(1)) - | (t - t')%term => fusion (normalize t) (normalize t') 1 (-(1)) - | (Tint k * t)%term | (t * Tint k)%term => - if k =? 0 then Tint 0 else scalar_mult (normalize t) k - | (t1 * t2)%term => (t1 * t2)%term (* shouldn't happen *) - end. - -Theorem normalize_stable : term_stable normalize. -Proof. - intros e t. - induction t; simpl; Simplify; simpl; - rewrite ?scalar_mult_stable; simpl in *; rewrite <- ?IHt1; - rewrite ?fusion_stable; simpl; autorewrite with int; auto. - - now f_equal. - - rewrite mult_comm. now f_equal. - - rewrite <- opp_eq_mult_neg_1, <-minus_def. now f_equal. - - rewrite <- opp_eq_mult_neg_1. now f_equal. -Qed. - -(** ** Normalization of a proposition. - - The only basic facts left after normalization are - [0 = ...] or [0 <> ...] or [0 <= ...]. - When a fact is in negative position, we factorize a [Tnot] - out of it, and normalize the reversed fact inside. - - /!\ Here again, do not change this code without corresponding - modifications in [refl_omega.ml]. -*) - -Fixpoint normalize_prop (negated:bool)(p:proposition) := - match p with - | EqTerm t1 t2 => - if negated then Tnot (NeqTerm (Tint 0) (normalize (t1-t2))) - else EqTerm (Tint 0) (normalize (t1-t2)) - | NeqTerm t1 t2 => - if negated then Tnot (EqTerm (Tint 0) (normalize (t1-t2))) - else NeqTerm (Tint 0) (normalize (t1-t2)) - | LeqTerm t1 t2 => - if negated then Tnot (LeqTerm (Tint 0) (normalize (t1-t2+Tint (-(1))))) - else LeqTerm (Tint 0) (normalize (t2-t1)) - | GeqTerm t1 t2 => - if negated then Tnot (LeqTerm (Tint 0) (normalize (t2-t1+Tint (-(1))))) - else LeqTerm (Tint 0) (normalize (t1-t2)) - | LtTerm t1 t2 => - if negated then Tnot (LeqTerm (Tint 0) (normalize (t1-t2))) - else LeqTerm (Tint 0) (normalize (t2-t1+Tint (-(1)))) - | GtTerm t1 t2 => - if negated then Tnot (LeqTerm (Tint 0) (normalize (t2-t1))) - else LeqTerm (Tint 0) (normalize (t1-t2+Tint (-(1)))) - | Tnot p => Tnot (normalize_prop (negb negated) p) - | Tor p p' => Tor (normalize_prop negated p) (normalize_prop negated p') - | Tand p p' => Tand (normalize_prop negated p) (normalize_prop negated p') - | Timp p p' => Timp (normalize_prop (negb negated) p) - (normalize_prop negated p') - | Tprop _ | TrueTerm | FalseTerm => p - end. - -Definition normalize_hyps := List.map (normalize_prop false). - -Local Ltac simp := cbn -[normalize]. - -Theorem normalize_prop_valid b e ep p : - interp_prop e ep (normalize_prop b p) <-> interp_prop e ep p. -Proof. - revert b. - induction p; intros; simp; try tauto. - - destruct b; simp; - rewrite <- ?normalize_stable; simpl; rewrite ?minus_def. - + rewrite not_eq. apply egal_left. - + apply egal_left. - - destruct b; simp; - rewrite <- ?normalize_stable; simpl; rewrite ?minus_def; - apply not_iff_compat, egal_left. - - destruct b; simp; - rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. - + symmetry. rewrite le_lt_iff. apply not_iff_compat, lt_left. - + now rewrite <- le_left. - - destruct b; simp; - rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. - + symmetry. rewrite ge_le_iff, le_lt_iff. - apply not_iff_compat, lt_left. - + rewrite ge_le_iff. now rewrite <- le_left. - - destruct b; simp; - rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. - + rewrite gt_lt_iff, lt_le_iff. apply not_iff_compat. - now rewrite <- le_left. - + symmetry. rewrite gt_lt_iff. apply lt_left. - - destruct b; simp; - rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. - + rewrite lt_le_iff. apply not_iff_compat. - now rewrite <- le_left. - + symmetry. apply lt_left. - - now rewrite IHp. - - now rewrite IHp1, IHp2. - - now rewrite IHp1, IHp2. - - now rewrite IHp1, IHp2. -Qed. - -Theorem normalize_hyps_valid : valid_hyps normalize_hyps. -Proof. - intros e ep l. induction l; simpl; intuition. - now rewrite normalize_prop_valid. -Qed. - -Theorem normalize_hyps_goal (ep : list Prop) (env : list int) (l : hyps) : - interp_goal ep env (normalize_hyps l) -> interp_goal ep env l. -Proof. - intros; apply valid_goal with (2 := H); apply normalize_hyps_valid. -Qed. - -(** ** A simple decidability checker - - For us, everything is considered decidable except - propositional atoms [Tprop _]. *) - -Fixpoint decidability (p : proposition) : bool := - match p with - | Tnot t => decidability t - | Tand t1 t2 => decidability t1 && decidability t2 - | Timp t1 t2 => decidability t1 && decidability t2 - | Tor t1 t2 => decidability t1 && decidability t2 - | Tprop _ => false - | _ => true - end. - -Theorem decidable_correct : - forall (ep : list Prop) (e : list int) (p : proposition), - decidability p = true -> decidable (interp_prop ep e p). -Proof. - induction p; simpl; intros Hp; try destruct (andb_prop _ _ Hp). - - apply dec_eq. - - apply dec_ne. - - apply dec_le. - - apply dec_ge. - - apply dec_gt. - - apply dec_lt. - - left; auto. - - right; unfold not; auto. - - apply dec_not; auto. - - apply dec_or; auto. - - apply dec_and; auto. - - apply dec_imp; auto. - - discriminate. -Qed. - -(** ** Omega steps - - The following inductive type describes steps as they can be - found in the trace coming from the decision procedure Omega. - We consider here only normalized equations [0=...], disequations - [0<>...] or inequations [0<=...]. - - First, the final steps leading to a contradiction: - - [O_BAD_CONSTANT i] : hypothesis i has a constant body - and this constant is not compatible with the kind of i. - - [O_NOT_EXACT_DIVIDE i k] : - equation i can be factorized as some [k*t+c] with [0<c<k]. - - Now, the intermediate steps leading to a new hypothesis: - - [O_DIVIDE i k cont] : - the body of hypothesis i could be factorized as [k*t+c] - with either [k<>0] and [c=0] for a (dis)equation, or - [0<k] and [c<k] for an inequation. We change in-place the - body of i for [t]. - - [O_SUM k1 i1 k2 i2 cont] : creates a new hypothesis whose - kind depends on the kind of hypotheses [i1] and [i2], and - whose body is [k1*body(i1) + k2*body(i2)]. Depending of the - situation, [k1] or [k2] might have to be positive or non-nul. - - [O_MERGE_EQ i j cont] : - inequations i and j have opposite bodies, we add an equation - with one these bodies. - - [O_SPLIT_INEQ i cont1 cont2] : - disequation i is split into a disjonction of inequations. -*) - -Definition idx := nat. (** Index of an hypothesis in the list *) - -Inductive t_omega : Set := - | O_BAD_CONSTANT : idx -> t_omega - | O_NOT_EXACT_DIVIDE : idx -> int -> t_omega - - | O_DIVIDE : idx -> int -> t_omega -> t_omega - | O_SUM : int -> idx -> int -> idx -> t_omega -> t_omega - | O_MERGE_EQ : idx -> idx -> t_omega -> t_omega - | O_SPLIT_INEQ : idx -> t_omega -> t_omega -> t_omega. - -(** ** Actual resolution steps of an omega normalized goal *) - -(** First, the final steps, leading to a contradiction *) - -(** [O_BAD_CONSTANT] *) - -Definition bad_constant (i : nat) (h : hyps) := - match nth_hyps i h with - | EqTerm (Tint Nul) (Tint n) => if n =? Nul then h else absurd - | NeqTerm (Tint Nul) (Tint n) => if n =? Nul then absurd else h - | LeqTerm (Tint Nul) (Tint n) => if n <? Nul then absurd else h - | _ => h - end. - -Theorem bad_constant_valid i : valid_hyps (bad_constant i). -Proof. - unfold valid_hyps, bad_constant; intros ep e lp H. - generalize (nth_valid ep e i lp H); Simplify. - rewrite le_lt_iff. intuition. -Qed. - -(** [O_NOT_EXACT_DIVIDE] *) - -Definition not_exact_divide (i : nat) (k : int) (l : hyps) := - match nth_hyps i l with - | EqTerm (Tint Nul) b => - match scalar_div b k with - | Some (body,c) => - if (Nul =? 0) && (0 <? c) && (c <? k) then absurd - else l - | None => l - end - | _ => l - end. - -Theorem not_exact_divide_valid i k : - valid_hyps (not_exact_divide i k). -Proof. - unfold valid_hyps, not_exact_divide; intros. - generalize (nth_valid ep e i lp). - destruct (nth_hyps i lp); simpl; auto. - destruct t0; auto. - destruct (scalar_div t1 k) as [(body,c)|] eqn:E; auto. - Simplify. - assert (k <> 0). - { intro. apply (lt_not_eq 0 k); eauto using lt_trans. } - apply (scalar_div_stable e) in E; auto. simpl in E. - intros H'; rewrite <- H' in E; auto. - exfalso. revert E. now apply OMEGA4. -Qed. - -(** Now, the steps generating a new equation. *) - -(** [O_DIVIDE] *) - -Definition divide (k : int) (prop : proposition) := - match prop with - | EqTerm (Tint o) b => - match scalar_div b k with - | Some (body,c) => - if (o =? 0) && (c =? 0) && negb (k =? 0) - then EqTerm (Tint 0) body - else TrueTerm - | None => TrueTerm - end - | NeqTerm (Tint o) b => - match scalar_div b k with - | Some (body,c) => - if (o =? 0) && (c =? 0) && negb (k =? 0) - then NeqTerm (Tint 0) body - else TrueTerm - | None => TrueTerm - end - | LeqTerm (Tint o) b => - match scalar_div b k with - | Some (body,c) => - if (o =? 0) && (0 <? k) && (c <? k) - then LeqTerm (Tint 0) body - else prop - | None => prop - end - | _ => TrueTerm - end. - -Theorem divide_valid k : valid1 (divide k). -Proof. - unfold valid1, divide; intros ep e p; - destruct p; simpl; auto; - destruct t0; simpl; auto; - destruct scalar_div as [(body,c)|] eqn:E; simpl; Simplify; auto. - - apply (scalar_div_stable e) in E; auto. simpl in E. - intros H'; rewrite <- H' in E. rewrite plus_0_r in E. - apply mult_integral in E. intuition. - - apply (scalar_div_stable e) in E; auto. simpl in E. - intros H' H''. now rewrite <- H'', mult_0_l, plus_0_l in E. - - assert (k <> 0). - { intro. apply (lt_not_eq 0 k); eauto using lt_trans. } - apply (scalar_div_stable e) in E; auto. simpl in E. rewrite <- E. - intro H'. now apply mult_le_approx with (3 := H'). -Qed. - -(** [O_SUM]. Invariant: [k1] and [k2] non-nul. *) - -Definition sum (k1 k2 : int) (prop1 prop2 : proposition) := - match prop1 with - | EqTerm (Tint o) b1 => - match prop2 with - | EqTerm (Tint o') b2 => - if (o =? 0) && (o' =? 0) - then EqTerm (Tint 0) (fusion b1 b2 k1 k2) - else TrueTerm - | LeqTerm (Tint o') b2 => - if (o =? 0) && (o' =? 0) && (0 <? k2) - then LeqTerm (Tint 0) (fusion b1 b2 k1 k2) - else TrueTerm - | NeqTerm (Tint o') b2 => - if (o =? 0) && (o' =? 0) && negb (k2 =? 0) - then NeqTerm (Tint 0) (fusion b1 b2 k1 k2) - else TrueTerm - | _ => TrueTerm - end - | LeqTerm (Tint o) b1 => - if (o =? 0) && (0 <? k1) - then match prop2 with - | EqTerm (Tint o') b2 => - if o' =? 0 then - LeqTerm (Tint 0) (fusion b1 b2 k1 k2) - else TrueTerm - | LeqTerm (Tint o') b2 => - if (o' =? 0) && (0 <? k2) - then LeqTerm (Tint 0) (fusion b1 b2 k1 k2) - else TrueTerm - | _ => TrueTerm - end - else TrueTerm - | NeqTerm (Tint o) b1 => - match prop2 with - | EqTerm (Tint o') b2 => - if (o =? 0) && (o' =? 0) && negb (k1 =? 0) - then NeqTerm (Tint 0) (fusion b1 b2 k1 k2) - else TrueTerm - | _ => TrueTerm - end - | _ => TrueTerm - end. - -Theorem sum_valid : - forall (k1 k2 : int), valid2 (sum k1 k2). -Proof. - unfold valid2; intros k1 k2 t ep e p1 p2; unfold sum; - Simplify; simpl; rewrite ?fusion_stable; - simpl; intros; auto. - - apply sum1; auto. - - rewrite plus_comm. apply sum5; auto. - - apply sum2; auto using lt_le_weak. - - apply sum5; auto. - - rewrite plus_comm. apply sum2; auto using lt_le_weak. - - apply sum3; auto using lt_le_weak. -Qed. - -(** [MERGE_EQ] *) - -Definition merge_eq (prop1 prop2 : proposition) := - match prop1 with - | LeqTerm (Tint o) b1 => - match prop2 with - | LeqTerm (Tint o') b2 => - if (o =? 0) && (o' =? 0) && - (b1 =? scalar_mult b2 (-(1)))%term - then EqTerm (Tint 0) b1 - else TrueTerm - | _ => TrueTerm - end - | _ => TrueTerm - end. - -Theorem merge_eq_valid : valid2 merge_eq. -Proof. - unfold valid2, merge_eq; intros ep e p1 p2; Simplify; simpl; auto. - rewrite scalar_mult_stable. simpl. - intros; symmetry ; apply OMEGA8 with (2 := H0). - - assumption. - - elim opp_eq_mult_neg_1; trivial. -Qed. - -(** [O_SPLIT_INEQ] (only step to produce two subgoals). *) - -Definition split_ineq (i : nat) (f1 f2 : hyps -> lhyps) (l : hyps) := - match nth_hyps i l with - | NeqTerm (Tint o) b1 => - if o =? 0 then - f1 (LeqTerm (Tint 0) (scalar_add b1 (-(1))) :: l) ++ - f2 (LeqTerm (Tint 0) (scalar_mult_add b1 (-(1)) (-(1))) :: l) - else l :: nil - | _ => l :: nil - end. - -Theorem split_ineq_valid : - forall (i : nat) (f1 f2 : hyps -> lhyps), - valid_list_hyps f1 -> - valid_list_hyps f2 -> valid_list_hyps (split_ineq i f1 f2). -Proof. - unfold valid_list_hyps, split_ineq; intros i f1 f2 H1 H2 ep e lp H; - generalize (nth_valid _ _ i _ H); case (nth_hyps i lp); - simpl; auto; intros t1 t2; case t1; simpl; - auto; intros z; simpl; auto; intro H3. - Simplify. - apply append_valid; elim (OMEGA19 (interp_term e t2)). - - intro H4; left; apply H1; simpl; rewrite scalar_add_stable; - simpl; auto. - - intro H4; right; apply H2; simpl; rewrite scalar_mult_add_stable; - simpl; auto. - - generalize H3; unfold not; intros E1 E2; apply E1; - symmetry ; trivial. -Qed. - -(** ** Replaying the resolution trace *) - -Fixpoint execute_omega (t : t_omega) (l : hyps) : lhyps := - match t with - | O_BAD_CONSTANT i => singleton (bad_constant i l) - | O_NOT_EXACT_DIVIDE i k => singleton (not_exact_divide i k l) - | O_DIVIDE i k cont => - execute_omega cont (apply_oper_1 i (divide k) l) - | O_SUM k1 i1 k2 i2 cont => - execute_omega cont (apply_oper_2 i1 i2 (sum k1 k2) l) - | O_MERGE_EQ i1 i2 cont => - execute_omega cont (apply_oper_2 i1 i2 merge_eq l) - | O_SPLIT_INEQ i cont1 cont2 => - split_ineq i (execute_omega cont1) (execute_omega cont2) l - end. - -Theorem omega_valid : forall tr : t_omega, valid_list_hyps (execute_omega tr). -Proof. - simple induction tr; unfold valid_list_hyps, valid_hyps; simpl. - - intros; left; now apply bad_constant_valid. - - intros; left; now apply not_exact_divide_valid. - - intros m k t' Ht' ep e lp H; apply Ht'; - apply - (apply_oper_1_valid m (divide k) - (divide_valid k) ep e lp H). - - intros k1 i1 k2 i2 t' Ht' ep e lp H; apply Ht'; - apply - (apply_oper_2_valid i1 i2 (sum k1 k2) (sum_valid k1 k2) ep e - lp H). - - intros i1 i2 t' Ht' ep e lp H; apply Ht'; - apply - (apply_oper_2_valid i1 i2 merge_eq merge_eq_valid ep e - lp H). - - intros i k1 H1 k2 H2 ep e lp H; - apply - (split_ineq_valid i (execute_omega k1) (execute_omega k2) H1 H2 ep e - lp H). -Qed. - - -(** ** Rules for decomposing the hypothesis - - This type allows navigation in the logical constructors that - form the predicats of the hypothesis in order to decompose them. - This allows in particular to extract one hypothesis from a conjunction. - NB: negations are now silently traversed. *) - -Inductive direction : Set := - | D_left : direction - | D_right : direction. - -(** This type allows extracting useful components from hypothesis, either - hypothesis generated by splitting a disjonction, or equations. - The last constructor indicates how to solve the obtained system - via the use of the trace type of Omega [t_omega] *) - -Inductive e_step : Set := - | E_SPLIT : nat -> list direction -> e_step -> e_step -> e_step - | E_EXTRACT : nat -> list direction -> e_step -> e_step - | E_SOLVE : t_omega -> e_step. - -(** Selection of a basic fact inside an hypothesis. *) - -Fixpoint extract_hyp_pos (s : list direction) (p : proposition) : - proposition := - match p, s with - | Tand x y, D_left :: l => extract_hyp_pos l x - | Tand x y, D_right :: l => extract_hyp_pos l y - | Tnot x, _ => extract_hyp_neg s x - | _, _ => p - end - - with extract_hyp_neg (s : list direction) (p : proposition) : - proposition := - match p, s with - | Tor x y, D_left :: l => extract_hyp_neg l x - | Tor x y, D_right :: l => extract_hyp_neg l y - | Timp x y, D_left :: l => - if decidability x then extract_hyp_pos l x else Tnot p - | Timp x y, D_right :: l => extract_hyp_neg l y - | Tnot x, _ => if decidability x then extract_hyp_pos s x else Tnot p - | _, _ => Tnot p - end. - -Theorem extract_valid : - forall s : list direction, valid1 (extract_hyp_pos s). -Proof. - assert (forall p s ep e, - (interp_prop ep e p -> - interp_prop ep e (extract_hyp_pos s p)) /\ - (interp_prop ep e (Tnot p) -> - interp_prop ep e (extract_hyp_neg s p))). - { induction p; destruct s; simpl; auto; split; try destruct d; try easy; - intros; (apply IHp || apply IHp1 || apply IHp2 || idtac); simpl; try tauto; - destruct decidability eqn:D; auto; - apply (decidable_correct ep e) in D; unfold decidable in D; - (apply IHp || apply IHp1); tauto. } - red. intros. now apply H. -Qed. - -(** Attempt to shorten error messages if romega goes rogue... - NB: [interp_list_goal _ _ BUG = False /\ True]. *) -Definition BUG : lhyps := nil :: nil. - -(** Split and extract in hypotheses *) - -Fixpoint decompose_solve (s : e_step) (h : hyps) : lhyps := - match s with - | E_SPLIT i dl s1 s2 => - match extract_hyp_pos dl (nth_hyps i h) with - | Tor x y => decompose_solve s1 (x :: h) ++ decompose_solve s2 (y :: h) - | Tnot (Tand x y) => - if decidability x - then - decompose_solve s1 (Tnot x :: h) ++ - decompose_solve s2 (Tnot y :: h) - else BUG - | Timp x y => - if decidability x then - decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (y :: h) - else BUG - | _ => BUG - end - | E_EXTRACT i dl s1 => - decompose_solve s1 (extract_hyp_pos dl (nth_hyps i h) :: h) - | E_SOLVE t => execute_omega t h - end. - -Theorem decompose_solve_valid (s : e_step) : - valid_list_goal (decompose_solve s). -Proof. - apply goal_valid. red. induction s; simpl; intros ep e lp H. - - assert (H' : interp_prop ep e (extract_hyp_pos l (nth_hyps n lp))). - { now apply extract_valid, nth_valid. } - destruct extract_hyp_pos; simpl in *; auto. - + destruct p; simpl; auto. - destruct decidability eqn:D; [ | simpl; auto]. - apply (decidable_correct ep e) in D. - apply append_valid. simpl in *. destruct D. - * right. apply IHs2. simpl; auto. - * left. apply IHs1. simpl; auto. - + apply append_valid. destruct H'. - * left. apply IHs1. simpl; auto. - * right. apply IHs2. simpl; auto. - + destruct decidability eqn:D; [ | simpl; auto]. - apply (decidable_correct ep e) in D. - apply append_valid. destruct D. - * right. apply IHs2. simpl; auto. - * left. apply IHs1. simpl; auto. - - apply IHs; simpl; split; auto. - now apply extract_valid, nth_valid. - - now apply omega_valid. -Qed. - -(** Reduction of subgoal list by discarding the contradictory subgoals. *) - -Definition valid_lhyps (f : lhyps -> lhyps) := - forall (ep : list Prop) (e : list int) (lp : lhyps), - interp_list_hyps ep e lp -> interp_list_hyps ep e (f lp). - -Fixpoint reduce_lhyps (lp : lhyps) : lhyps := - match lp with - | nil => nil - | (FalseTerm :: nil) :: lp' => reduce_lhyps lp' - | x :: lp' => BUG - end. - -Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps. -Proof. - unfold valid_lhyps; intros ep e lp; elim lp. - - simpl; auto. - - intros a l HR; elim a. - + simpl; tauto. - + intros a1 l1; case l1; case a1; simpl; tauto. -Qed. - -Theorem do_reduce_lhyps : - forall (envp : list Prop) (env : list int) (l : lhyps), - interp_list_goal envp env (reduce_lhyps l) -> interp_list_goal envp env l. -Proof. - intros envp env l H; apply list_goal_to_hyps; intro H1; - apply list_hyps_to_goal with (1 := H); apply reduce_lhyps_valid; - assumption. -Qed. - -(** Pushing the conclusion into the hypotheses. *) - -Definition concl_to_hyp (p : proposition) := - if decidability p then Tnot p else TrueTerm. - -Definition do_concl_to_hyp : - forall (envp : list Prop) (env : list int) (c : proposition) (l : hyps), - interp_goal envp env (concl_to_hyp c :: l) -> - interp_goal_concl c envp env l. -Proof. - induction l; simpl. - - unfold concl_to_hyp; simpl. - destruct decidability eqn:D; [ | simpl; tauto ]. - apply (decidable_correct envp env) in D. unfold decidable in D. - simpl. tauto. - - simpl in *; tauto. -Qed. - -(** The omega tactic : all steps together *) - -Definition omega_tactic (t1 : e_step) (c : proposition) (l : hyps) := - reduce_lhyps (decompose_solve t1 (normalize_hyps (concl_to_hyp c :: l))). - -Theorem do_omega : - forall (t : e_step) (envp : list Prop) - (env : list int) (c : proposition) (l : hyps), - interp_list_goal envp env (omega_tactic t c l) -> - interp_goal_concl c envp env l. -Proof. - unfold omega_tactic; intros t ep e c l H. - apply do_concl_to_hyp. - apply normalize_hyps_goal. - apply (decompose_solve_valid t). - now apply do_reduce_lhyps. -Qed. - -End IntOmega. - -(** For now, the above modular construction is instanciated on Z, - in order to retrieve the initial ROmega. *) - -Module ZOmega := IntOmega(Z_as_Int). diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml deleted file mode 100644 index ad3afafd85..0000000000 --- a/plugins/romega/const_omega.ml +++ /dev/null @@ -1,332 +0,0 @@ -(************************************************************************* - - PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D - Licence : LGPL version 2.1 - - *************************************************************************) - -open Names - -let module_refl_name = "ReflOmegaCore" -let module_refl_path = ["Coq"; "romega"; module_refl_name] - -type result = - | Kvar of string - | Kapp of string * EConstr.t list - | Kimp of EConstr.t * EConstr.t - | Kufo - -let meaningful_submodule = [ "Z"; "N"; "Pos" ] - -let string_of_global r = - let dp = Nametab.dirpath_of_global r in - let prefix = match Names.DirPath.repr dp with - | [] -> "" - | m::_ -> - let s = Names.Id.to_string m in - if Util.String.List.mem s meaningful_submodule then s^"." else "" - in - prefix^(Names.Id.to_string (Nametab.basename_of_global r)) - -let destructurate sigma t = - let c, args = EConstr.decompose_app sigma t in - let open Constr in - match EConstr.kind sigma c, args with - | Const (sp,_), args -> - Kapp (string_of_global (Globnames.ConstRef sp), args) - | Construct (csp,_) , args -> - Kapp (string_of_global (Globnames.ConstructRef csp), args) - | Ind (isp,_), args -> - Kapp (string_of_global (Globnames.IndRef isp), args) - | Var id, [] -> Kvar(Names.Id.to_string id) - | Prod (Anonymous,typ,body), [] -> Kimp(typ,body) - | _ -> Kufo - -exception DestConstApp - -let dest_const_apply sigma t = - let open Constr in - let f,args = EConstr.decompose_app sigma t in - let ref = - match EConstr.kind sigma f with - | Const (sp,_) -> Globnames.ConstRef sp - | Construct (csp,_) -> Globnames.ConstructRef csp - | Ind (isp,_) -> Globnames.IndRef isp - | _ -> raise DestConstApp - in Nametab.basename_of_global ref, args - -let logic_dir = ["Coq";"Logic";"Decidable"] - -let coq_modules = - Coqlib.init_modules @ [logic_dir] @ Coqlib.arith_modules @ Coqlib.zarith_base_modules - @ [["Coq"; "Lists"; "List"]] - @ [module_refl_path] - @ [module_refl_path@["ZOmega"]] - -let bin_module = [["Coq";"Numbers";"BinNums"]] -let z_module = [["Coq";"ZArith";"BinInt"]] - -let init_constant x = - EConstr.of_constr @@ - Universes.constr_of_global @@ - Coqlib.gen_reference_in_modules "Omega" Coqlib.init_modules x -let constant x = - EConstr.of_constr @@ - Universes.constr_of_global @@ - Coqlib.gen_reference_in_modules "Omega" coq_modules x -let z_constant x = - EConstr.of_constr @@ - Universes.constr_of_global @@ - Coqlib.gen_reference_in_modules "Omega" z_module x -let bin_constant x = - EConstr.of_constr @@ - Universes.constr_of_global @@ - Coqlib.gen_reference_in_modules "Omega" bin_module x - -(* Logic *) -let coq_refl_equal = lazy(init_constant "eq_refl") -let coq_and = lazy(init_constant "and") -let coq_not = lazy(init_constant "not") -let coq_or = lazy(init_constant "or") -let coq_True = lazy(init_constant "True") -let coq_False = lazy(init_constant "False") -let coq_I = lazy(init_constant "I") - -(* ReflOmegaCore/ZOmega *) - -let coq_t_int = lazy (constant "Tint") -let coq_t_plus = lazy (constant "Tplus") -let coq_t_mult = lazy (constant "Tmult") -let coq_t_opp = lazy (constant "Topp") -let coq_t_minus = lazy (constant "Tminus") -let coq_t_var = lazy (constant "Tvar") - -let coq_proposition = lazy (constant "proposition") -let coq_p_eq = lazy (constant "EqTerm") -let coq_p_leq = lazy (constant "LeqTerm") -let coq_p_geq = lazy (constant "GeqTerm") -let coq_p_lt = lazy (constant "LtTerm") -let coq_p_gt = lazy (constant "GtTerm") -let coq_p_neq = lazy (constant "NeqTerm") -let coq_p_true = lazy (constant "TrueTerm") -let coq_p_false = lazy (constant "FalseTerm") -let coq_p_not = lazy (constant "Tnot") -let coq_p_or = lazy (constant "Tor") -let coq_p_and = lazy (constant "Tand") -let coq_p_imp = lazy (constant "Timp") -let coq_p_prop = lazy (constant "Tprop") - -let coq_s_bad_constant = lazy (constant "O_BAD_CONSTANT") -let coq_s_divide = lazy (constant "O_DIVIDE") -let coq_s_not_exact_divide = lazy (constant "O_NOT_EXACT_DIVIDE") -let coq_s_sum = lazy (constant "O_SUM") -let coq_s_merge_eq = lazy (constant "O_MERGE_EQ") -let coq_s_split_ineq =lazy (constant "O_SPLIT_INEQ") - -(* construction for the [extract_hyp] tactic *) -let coq_direction = lazy (constant "direction") -let coq_d_left = lazy (constant "D_left") -let coq_d_right = lazy (constant "D_right") - -let coq_e_split = lazy (constant "E_SPLIT") -let coq_e_extract = lazy (constant "E_EXTRACT") -let coq_e_solve = lazy (constant "E_SOLVE") - -let coq_interp_sequent = lazy (constant "interp_goal_concl") -let coq_do_omega = lazy (constant "do_omega") - -(* Nat *) - -let coq_S = lazy(init_constant "S") -let coq_O = lazy(init_constant "O") - -let rec mk_nat = function - | 0 -> Lazy.force coq_O - | n -> EConstr.mkApp (Lazy.force coq_S, [| mk_nat (n-1) |]) - -(* Lists *) - -let mkListConst c = - let r = - Coqlib.coq_reference "" ["Init";"Datatypes"] c - in - let inst = - if Global.is_polymorphic r then - fun u -> EConstr.EInstance.make (Univ.Instance.of_array [|u|]) - else - fun _ -> EConstr.EInstance.empty - in - fun u -> EConstr.mkConstructU (Globnames.destConstructRef r, inst u) - -let coq_cons univ typ = EConstr.mkApp (mkListConst "cons" univ, [|typ|]) -let coq_nil univ typ = EConstr.mkApp (mkListConst "nil" univ, [|typ|]) - -let mk_list univ typ l = - let rec loop = function - | [] -> coq_nil univ typ - | (step :: l) -> - EConstr.mkApp (coq_cons univ typ, [| step; loop l |]) in - loop l - -let mk_plist = - let type1lev = Universes.new_univ_level () in - fun l -> mk_list type1lev EConstr.mkProp l - -let mk_list = mk_list Univ.Level.set - -type parse_term = - | Tplus of EConstr.t * EConstr.t - | Tmult of EConstr.t * EConstr.t - | Tminus of EConstr.t * EConstr.t - | Topp of EConstr.t - | Tsucc of EConstr.t - | Tnum of Bigint.bigint - | Tother - -type parse_rel = - | Req of EConstr.t * EConstr.t - | Rne of EConstr.t * EConstr.t - | Rlt of EConstr.t * EConstr.t - | Rle of EConstr.t * EConstr.t - | Rgt of EConstr.t * EConstr.t - | Rge of EConstr.t * EConstr.t - | Rtrue - | Rfalse - | Rnot of EConstr.t - | Ror of EConstr.t * EConstr.t - | Rand of EConstr.t * EConstr.t - | Rimp of EConstr.t * EConstr.t - | Riff of EConstr.t * EConstr.t - | Rother - -let parse_logic_rel sigma c = match destructurate sigma c with - | Kapp("True",[]) -> Rtrue - | Kapp("False",[]) -> Rfalse - | Kapp("not",[t]) -> Rnot t - | Kapp("or",[t1;t2]) -> Ror (t1,t2) - | Kapp("and",[t1;t2]) -> Rand (t1,t2) - | Kimp(t1,t2) -> Rimp (t1,t2) - | Kapp("iff",[t1;t2]) -> Riff (t1,t2) - | _ -> Rother - -(* Binary numbers *) - -let coq_Z = lazy (bin_constant "Z") -let coq_xH = lazy (bin_constant "xH") -let coq_xO = lazy (bin_constant "xO") -let coq_xI = lazy (bin_constant "xI") -let coq_Z0 = lazy (bin_constant "Z0") -let coq_Zpos = lazy (bin_constant "Zpos") -let coq_Zneg = lazy (bin_constant "Zneg") -let coq_N0 = lazy (bin_constant "N0") -let coq_Npos = lazy (bin_constant "Npos") - -let rec mk_positive n = - if Bigint.equal n Bigint.one then Lazy.force coq_xH - else - let (q,r) = Bigint.euclid n Bigint.two in - EConstr.mkApp - ((if Bigint.equal r Bigint.zero - then Lazy.force coq_xO else Lazy.force coq_xI), - [| mk_positive q |]) - -let mk_N = function - | 0 -> Lazy.force coq_N0 - | n -> EConstr.mkApp (Lazy.force coq_Npos, - [| mk_positive (Bigint.of_int n) |]) - -module type Int = sig - val typ : EConstr.t Lazy.t - val is_int_typ : Proofview.Goal.t -> EConstr.t -> bool - val plus : EConstr.t Lazy.t - val mult : EConstr.t Lazy.t - val opp : EConstr.t Lazy.t - val minus : EConstr.t Lazy.t - - val mk : Bigint.bigint -> EConstr.t - val parse_term : Evd.evar_map -> EConstr.t -> parse_term - val parse_rel : Proofview.Goal.t -> EConstr.t -> parse_rel - (* check whether t is built only with numbers and + * - *) - val get_scalar : Evd.evar_map -> EConstr.t -> Bigint.bigint option -end - -module Z : Int = struct - -let typ = coq_Z -let plus = lazy (z_constant "Z.add") -let mult = lazy (z_constant "Z.mul") -let opp = lazy (z_constant "Z.opp") -let minus = lazy (z_constant "Z.sub") - -let recognize_pos sigma t = - let rec loop t = - let f,l = dest_const_apply sigma t in - match Id.to_string f,l with - | "xI",[t] -> Bigint.add Bigint.one (Bigint.mult Bigint.two (loop t)) - | "xO",[t] -> Bigint.mult Bigint.two (loop t) - | "xH",[] -> Bigint.one - | _ -> raise DestConstApp - in - try Some (loop t) with DestConstApp -> None - -let recognize_Z sigma t = - try - let f,l = dest_const_apply sigma t in - match Id.to_string f,l with - | "Zpos",[t] -> recognize_pos sigma t - | "Zneg",[t] -> Option.map Bigint.neg (recognize_pos sigma t) - | "Z0",[] -> Some Bigint.zero - | _ -> None - with DestConstApp -> None - -let mk_Z n = - if Bigint.equal n Bigint.zero then Lazy.force coq_Z0 - else if Bigint.is_strictly_pos n then - EConstr.mkApp (Lazy.force coq_Zpos, [| mk_positive n |]) - else - EConstr.mkApp (Lazy.force coq_Zneg, [| mk_positive (Bigint.neg n) |]) - -let mk = mk_Z - -let parse_term sigma t = - match destructurate sigma t with - | Kapp("Z.add",[t1;t2]) -> Tplus (t1,t2) - | Kapp("Z.sub",[t1;t2]) -> Tminus (t1,t2) - | Kapp("Z.mul",[t1;t2]) -> Tmult (t1,t2) - | Kapp("Z.opp",[t]) -> Topp t - | Kapp("Z.succ",[t]) -> Tsucc t - | Kapp("Z.pred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one)) - | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> - (match recognize_Z sigma t with Some t -> Tnum t | None -> Tother) - | _ -> Tother - -let is_int_typ gl t = - Tacmach.New.pf_apply Reductionops.is_conv gl t (Lazy.force coq_Z) - -let parse_rel gl t = - let sigma = Proofview.Goal.sigma gl in - match destructurate sigma t with - | Kapp("eq",[typ;t1;t2]) when is_int_typ gl typ -> Req (t1,t2) - | Kapp("Zne",[t1;t2]) -> Rne (t1,t2) - | Kapp("Z.le",[t1;t2]) -> Rle (t1,t2) - | Kapp("Z.lt",[t1;t2]) -> Rlt (t1,t2) - | Kapp("Z.ge",[t1;t2]) -> Rge (t1,t2) - | Kapp("Z.gt",[t1;t2]) -> Rgt (t1,t2) - | _ -> parse_logic_rel sigma t - -let rec get_scalar sigma t = - match destructurate sigma t with - | Kapp("Z.add", [t1;t2]) -> - Option.lift2 Bigint.add (get_scalar sigma t1) (get_scalar sigma t2) - | Kapp ("Z.sub",[t1;t2]) -> - Option.lift2 Bigint.sub (get_scalar sigma t1) (get_scalar sigma t2) - | Kapp ("Z.mul",[t1;t2]) -> - Option.lift2 Bigint.mult (get_scalar sigma t1) (get_scalar sigma t2) - | Kapp("Z.opp", [t]) -> Option.map Bigint.neg (get_scalar sigma t) - | Kapp("Z.succ", [t]) -> Option.map Bigint.add_1 (get_scalar sigma t) - | Kapp("Z.pred", [t]) -> Option.map Bigint.sub_1 (get_scalar sigma t) - | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> recognize_Z sigma t - | _ -> None - -end diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli deleted file mode 100644 index 64668df007..0000000000 --- a/plugins/romega/const_omega.mli +++ /dev/null @@ -1,124 +0,0 @@ -(************************************************************************* - - PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D - Licence : LGPL version 2.1 - - *************************************************************************) - - -(** Coq objects used in romega *) - -(* from Logic *) -val coq_refl_equal : EConstr.t lazy_t -val coq_and : EConstr.t lazy_t -val coq_not : EConstr.t lazy_t -val coq_or : EConstr.t lazy_t -val coq_True : EConstr.t lazy_t -val coq_False : EConstr.t lazy_t -val coq_I : EConstr.t lazy_t - -(* from ReflOmegaCore/ZOmega *) - -val coq_t_int : EConstr.t lazy_t -val coq_t_plus : EConstr.t lazy_t -val coq_t_mult : EConstr.t lazy_t -val coq_t_opp : EConstr.t lazy_t -val coq_t_minus : EConstr.t lazy_t -val coq_t_var : EConstr.t lazy_t - -val coq_proposition : EConstr.t lazy_t -val coq_p_eq : EConstr.t lazy_t -val coq_p_leq : EConstr.t lazy_t -val coq_p_geq : EConstr.t lazy_t -val coq_p_lt : EConstr.t lazy_t -val coq_p_gt : EConstr.t lazy_t -val coq_p_neq : EConstr.t lazy_t -val coq_p_true : EConstr.t lazy_t -val coq_p_false : EConstr.t lazy_t -val coq_p_not : EConstr.t lazy_t -val coq_p_or : EConstr.t lazy_t -val coq_p_and : EConstr.t lazy_t -val coq_p_imp : EConstr.t lazy_t -val coq_p_prop : EConstr.t lazy_t - -val coq_s_bad_constant : EConstr.t lazy_t -val coq_s_divide : EConstr.t lazy_t -val coq_s_not_exact_divide : EConstr.t lazy_t -val coq_s_sum : EConstr.t lazy_t -val coq_s_merge_eq : EConstr.t lazy_t -val coq_s_split_ineq : EConstr.t lazy_t - -val coq_direction : EConstr.t lazy_t -val coq_d_left : EConstr.t lazy_t -val coq_d_right : EConstr.t lazy_t - -val coq_e_split : EConstr.t lazy_t -val coq_e_extract : EConstr.t lazy_t -val coq_e_solve : EConstr.t lazy_t - -val coq_interp_sequent : EConstr.t lazy_t -val coq_do_omega : EConstr.t lazy_t - -val mk_nat : int -> EConstr.t -val mk_N : int -> EConstr.t - -(** Precondition: the type of the list is in Set *) -val mk_list : EConstr.t -> EConstr.t list -> EConstr.t -val mk_plist : EConstr.types list -> EConstr.types - -(** Analyzing a coq term *) - -(* The generic result shape of the analysis of a term. - One-level depth, except when a number is found *) -type parse_term = - Tplus of EConstr.t * EConstr.t - | Tmult of EConstr.t * EConstr.t - | Tminus of EConstr.t * EConstr.t - | Topp of EConstr.t - | Tsucc of EConstr.t - | Tnum of Bigint.bigint - | Tother - -(* The generic result shape of the analysis of a relation. - One-level depth. *) -type parse_rel = - Req of EConstr.t * EConstr.t - | Rne of EConstr.t * EConstr.t - | Rlt of EConstr.t * EConstr.t - | Rle of EConstr.t * EConstr.t - | Rgt of EConstr.t * EConstr.t - | Rge of EConstr.t * EConstr.t - | Rtrue - | Rfalse - | Rnot of EConstr.t - | Ror of EConstr.t * EConstr.t - | Rand of EConstr.t * EConstr.t - | Rimp of EConstr.t * EConstr.t - | Riff of EConstr.t * EConstr.t - | Rother - -(* A module factorizing what we should now about the number representation *) -module type Int = - sig - (* the coq type of the numbers *) - val typ : EConstr.t Lazy.t - (* Is a constr expands to the type of these numbers *) - val is_int_typ : Proofview.Goal.t -> EConstr.t -> bool - (* the operations on the numbers *) - val plus : EConstr.t Lazy.t - val mult : EConstr.t Lazy.t - val opp : EConstr.t Lazy.t - val minus : EConstr.t Lazy.t - (* building a coq number *) - val mk : Bigint.bigint -> EConstr.t - (* parsing a term (one level, except if a number is found) *) - val parse_term : Evd.evar_map -> EConstr.t -> parse_term - (* parsing a relation expression, including = < <= >= > *) - val parse_rel : Proofview.Goal.t -> EConstr.t -> parse_rel - (* Is a particular term only made of numbers and + * - ? *) - val get_scalar : Evd.evar_map -> EConstr.t -> Bigint.bigint option - end - -(* Currently, we only use Z numbers *) -module Z : Int diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4 deleted file mode 100644 index 5b77d08dea..0000000000 --- a/plugins/romega/g_romega.ml4 +++ /dev/null @@ -1,51 +0,0 @@ -(************************************************************************* - - PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D - Licence : LGPL version 2.1 - - *************************************************************************) - - -DECLARE PLUGIN "romega_plugin" - -open Ltac_plugin -open Names -open Refl_omega -open Stdarg - -let eval_tactic name = - let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in - let kn = KerName.make2 (ModPath.MPfile dp) (Label.make name) in - let tac = Tacenv.interp_ltac kn in - Tacinterp.eval_tactic tac - -let romega_tactic unsafe l = - let tacs = List.map - (function - | "nat" -> eval_tactic "zify_nat" - | "positive" -> eval_tactic "zify_positive" - | "N" -> eval_tactic "zify_N" - | "Z" -> eval_tactic "zify_op" - | s -> CErrors.user_err Pp.(str ("No ROmega knowledge base for type "^s))) - (Util.List.sort_uniquize String.compare l) - in - Tacticals.New.tclTHEN - (Tacticals.New.tclREPEAT (Proofview.tclPROGRESS (Tacticals.New.tclTHENLIST tacs))) - (Tacticals.New.tclTHEN - (* because of the contradiction process in (r)omega, - we'd better leave as little as possible in the conclusion, - for an easier decidability argument. *) - (Tactics.intros) - (total_reflexive_omega_tactic unsafe)) - -TACTIC EXTEND romega -| [ "romega" ] -> [ romega_tactic false [] ] -| [ "unsafe_romega" ] -> [ romega_tactic true [] ] -END - -TACTIC EXTEND romega' -| [ "romega" "with" ne_ident_list(l) ] -> - [ romega_tactic false (List.map Names.Id.to_string l) ] -| [ "romega" "with" "*" ] -> [ romega_tactic false ["nat";"positive";"N";"Z"] ] -END diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml deleted file mode 100644 index d182497840..0000000000 --- a/plugins/romega/refl_omega.ml +++ /dev/null @@ -1,1070 +0,0 @@ -(************************************************************************* - - PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D - Licence : LGPL version 2.1 - - *************************************************************************) - -open Pp -open Util -open Const_omega -module OmegaSolver = Omega_plugin.Omega.MakeOmegaSolver (Bigint) -open OmegaSolver - -module Id = Names.Id -module IntSet = Int.Set -module IntHtbl = Hashtbl.Make(Int) - -(* \section{Useful functions and flags} *) -(* Especially useful debugging functions *) -let debug = ref false - -let show_goal = Tacticals.New.tclIDTAC - -let pp i = print_int i; print_newline (); flush stdout - -(* More readable than the prefix notation *) -let (>>) = Tacticals.New.tclTHEN - -(* \section{Types} - \subsection{How to walk in a term} - To represent how to get to a proposition. Only choice points are - kept (branch to choose in a disjunction and identifier of the disjunctive - connector) *) -type direction = Left of int | Right of int - -(* Step to find a proposition (operators are at most binary). A list is - a path *) -type occ_step = O_left | O_right | O_mono -type occ_path = occ_step list - -(* chemin identifiant une proposition sous forme du nom de l'hypothèse et - d'une liste de pas à partir de la racine de l'hypothèse *) -type occurrence = {o_hyp : Id.t; o_path : occ_path} - -type atom_index = int - -(* \subsection{reifiable formulas} *) -type oformula = - (* integer *) - | Oint of Bigint.bigint - (* recognized binary and unary operations *) - | Oplus of oformula * oformula - | Omult of oformula * oformula (* Invariant : one side is [Oint] *) - | Ominus of oformula * oformula - | Oopp of oformula - (* an atom in the environment *) - | Oatom of atom_index - -(* Operators for comparison recognized by Omega *) -type comparaison = Eq | Leq | Geq | Gt | Lt | Neq - -(* Representation of reified predicats (fragment of propositional calculus, - no quantifier here). *) -(* Note : in [Pprop p], the non-reified constr [p] should be closed - (it could contains some [Term.Var] but no [Term.Rel]). So no need to - lift when breaking or creating arrows. *) -type oproposition = - Pequa of EConstr.t * oequation (* constr = copy of the Coq formula *) - | Ptrue - | Pfalse - | Pnot of oproposition - | Por of int * oproposition * oproposition - | Pand of int * oproposition * oproposition - | Pimp of int * oproposition * oproposition - | Pprop of EConstr.t - -(* The equations *) -and oequation = { - e_comp: comparaison; (* comparaison *) - e_left: oformula; (* formule brute gauche *) - e_right: oformula; (* formule brute droite *) - e_origin: occurrence; (* l'hypothèse dont vient le terme *) - e_negated: bool; (* vrai si apparait en position nié - après normalisation *) - e_depends: direction list; (* liste des points de disjonction dont - dépend l'accès à l'équation avec la - direction (branche) pour y accéder *) - e_omega: OmegaSolver.afine (* normalized formula *) - } - -(* \subsection{Proof context} - This environment codes - \begin{itemize} - \item the terms and propositions that are given as - parameters of the reified proof (and are represented as variables in the - reified goals) - \item translation functions linking the decision procedure and the Coq proof - \end{itemize} *) - -type environment = { - (* La liste des termes non reifies constituant l'environnement global *) - mutable terms : EConstr.t list; - (* La meme chose pour les propositions *) - mutable props : EConstr.t list; - (* Traduction des indices utilisés ici en les indices finaux utilisés par - * la tactique Omega après dénombrement des variables utiles *) - real_indices : int IntHtbl.t; - mutable cnt_connectors : int; - equations : oequation IntHtbl.t; - constructors : occurrence IntHtbl.t -} - -(* \subsection{Solution tree} - Définition d'une solution trouvée par Omega sous la forme d'un identifiant, - d'un ensemble d'équation dont dépend la solution et d'une trace *) - -type solution = { - s_index : int; - s_equa_deps : IntSet.t; - s_trace : OmegaSolver.action list } - -(* Arbre de solution résolvant complètement un ensemble de systèmes *) -type solution_tree = - Leaf of solution - (* un noeud interne représente un point de branchement correspondant à - l'élimination d'un connecteur générant plusieurs buts - (typ. disjonction). Le premier argument - est l'identifiant du connecteur *) - | Tree of int * solution_tree * solution_tree - -(* Représentation de l'environnement extrait du but initial sous forme de - chemins pour extraire des equations ou d'hypothèses *) - -type context_content = - CCHyp of occurrence - | CCEqua of int - -(** Some dedicated equality tests *) - -let occ_step_eq s1 s2 = match s1, s2 with -| O_left, O_left | O_right, O_right | O_mono, O_mono -> true -| _ -> false - -let rec oform_eq f f' = match f,f' with - | Oint i, Oint i' -> Bigint.equal i i' - | Oplus (f1,f2), Oplus (f1',f2') - | Omult (f1,f2), Omult (f1',f2') - | Ominus (f1,f2), Ominus (f1',f2') -> oform_eq f1 f1' && oform_eq f2 f2' - | Oopp f, Oopp f' -> oform_eq f f' - | Oatom a, Oatom a' -> Int.equal a a' - | _ -> false - -let dir_eq d d' = match d, d' with - | Left i, Left i' | Right i, Right i' -> Int.equal i i' - | _ -> false - -(* \section{Specific utility functions to handle base types} *) -(* Nom arbitraire de l'hypothèse codant la négation du but final *) -let id_concl = Id.of_string "__goal__" - -(* Initialisation de l'environnement de réification de la tactique *) -let new_environment () = { - terms = []; props = []; cnt_connectors = 0; - real_indices = IntHtbl.create 7; - equations = IntHtbl.create 7; - constructors = IntHtbl.create 7; -} - -(* Génération d'un nom d'équation *) -let new_connector_id env = - env.cnt_connectors <- succ env.cnt_connectors; env.cnt_connectors - -(* Calcul de la branche complémentaire *) -let barre = function Left x -> Right x | Right x -> Left x - -(* Identifiant associé à une branche *) -let indice = function Left x | Right x -> x - -(* Affichage de l'environnement de réification (termes et propositions) *) -let print_env_reification env = - let rec loop c i = function - [] -> str " ===============================\n\n" - | t :: l -> - let sigma, env = Pfedit.get_current_context () in - let s = Printf.sprintf "(%c%02d)" c i in - spc () ++ str s ++ str " := " ++ Printer.pr_econstr_env env sigma t ++ fnl () ++ - loop c (succ i) l - 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 - Feedback.msg_debug (prop_info ++ fnl () ++ term_info) - -(* \subsection{Gestion des environnements de variable pour Omega} *) -(* generation d'identifiant d'equation pour Omega *) - -let new_omega_eq, rst_omega_eq = - let cpt = ref (-1) in - (function () -> incr cpt; !cpt), - (function () -> cpt:=(-1)) - -(* generation d'identifiant de variable pour Omega *) - -let new_omega_var, rst_omega_var, set_omega_maxvar = - let cpt = ref (-1) in - (function () -> incr cpt; !cpt), - (function () -> cpt:=(-1)), - (function n -> cpt:=n) - -(* Affichage des variables d'un système *) - -let display_omega_var i = Printf.sprintf "OV%d" i - -(* \subsection{Gestion des environnements de variable pour la réflexion} - Gestion des environnements de traduction entre termes des constructions - non réifiés et variables des termes reifies. Attention il s'agit de - l'environnement initial contenant tout. Il faudra le réduire après - calcul des variables utiles. *) - -let add_reified_atom sigma t env = - try List.index0 (EConstr.eq_constr sigma) t env.terms - with Not_found -> - let i = List.length env.terms in - env.terms <- env.terms @ [t]; i - -let get_reified_atom env = - try List.nth env.terms with Invalid_argument _ -> failwith "get_reified_atom" - -(** When the omega resolution has created a variable [v], we re-sync - the environment with this new variable. To be done in the right order. *) - -let set_reified_atom v t env = - assert (Int.equal v (List.length env.terms)); - env.terms <- env.terms @ [t] - -(* \subsection{Gestion de l'environnement de proposition pour Omega} *) -(* ajout d'une proposition *) -let add_prop sigma env t = - try List.index0 (EConstr.eq_constr sigma) t env.props - with Not_found -> - let i = List.length env.props in env.props <- env.props @ [t]; i - -(* accès a une proposition *) -let get_prop v env = - try List.nth v env with Invalid_argument _ -> failwith "get_prop" - -(* \subsection{Gestion du nommage des équations} *) -(* Ajout d'une equation dans l'environnement de reification *) -let add_equation env e = - let id = e.e_omega.id in - if IntHtbl.mem env.equations id then () else IntHtbl.add env.equations id e - -(* accès a une equation *) -let get_equation env id = - try IntHtbl.find env.equations id - with Not_found as e -> - Printf.printf "Omega Equation %d non trouvée\n" id; raise e - -(* Affichage des termes réifiés *) -let rec oprint ch = function - | Oint n -> Printf.fprintf ch "%s" (Bigint.to_string n) - | Oplus (t1,t2) -> Printf.fprintf ch "(%a + %a)" oprint t1 oprint t2 - | Omult (t1,t2) -> Printf.fprintf ch "(%a * %a)" oprint t1 oprint t2 - | Ominus(t1,t2) -> Printf.fprintf ch "(%a - %a)" oprint t1 oprint t2 - | Oopp t1 ->Printf.fprintf ch "~ %a" oprint t1 - | Oatom n -> Printf.fprintf ch "V%02d" n - -let print_comp = function - | Eq -> "=" | Leq -> "<=" | Geq -> ">=" - | Gt -> ">" | Lt -> "<" | Neq -> "!=" - -let rec pprint ch = function - Pequa (_,{ e_comp=comp; e_left=t1; e_right=t2 }) -> - Printf.fprintf ch "%a %s %a" oprint t1 (print_comp comp) oprint t2 - | Ptrue -> Printf.fprintf ch "TT" - | Pfalse -> Printf.fprintf ch "FF" - | Pnot t -> Printf.fprintf ch "not(%a)" pprint t - | Por (_,t1,t2) -> Printf.fprintf ch "(%a or %a)" pprint t1 pprint t2 - | Pand(_,t1,t2) -> Printf.fprintf ch "(%a and %a)" pprint t1 pprint t2 - | Pimp(_,t1,t2) -> Printf.fprintf ch "(%a => %a)" pprint t1 pprint t2 - | Pprop c -> Printf.fprintf ch "Prop" - -(* \subsection{Omega vers Oformula} *) - -let oformula_of_omega af = - let rec loop = function - | ({v=v; c=n}::r) -> Oplus(Omult(Oatom v,Oint n),loop r) - | [] -> Oint af.constant - in - loop af.body - -let app f v = EConstr.mkApp(Lazy.force f,v) - -(* \subsection{Oformula vers COQ reel} *) - -let coq_of_formula env t = - let rec loop = function - | Oplus (t1,t2) -> app Z.plus [| loop t1; loop t2 |] - | Oopp t -> app Z.opp [| loop t |] - | Omult(t1,t2) -> app Z.mult [| loop t1; loop t2 |] - | Oint v -> Z.mk v - | Oatom var -> - (* attention ne traite pas les nouvelles variables si on ne les - * met pas dans env.term *) - get_reified_atom env var - | Ominus(t1,t2) -> app Z.minus [| loop t1; loop t2 |] in - loop t - -(* \subsection{Oformula vers COQ reifié} *) - -let reified_of_atom env i = - try IntHtbl.find env.real_indices i - with Not_found -> - Printf.printf "Atome %d non trouvé\n" i; - IntHtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices; - raise Not_found - -let reified_binop = function - | Oplus _ -> app coq_t_plus - | Ominus _ -> app coq_t_minus - | Omult _ -> app coq_t_mult - | _ -> assert false - -let rec reified_of_formula env t = match t with - | Oplus (t1,t2) | Omult (t1,t2) | Ominus (t1,t2) -> - reified_binop t [| reified_of_formula env t1; reified_of_formula env t2 |] - | Oopp t -> app coq_t_opp [| reified_of_formula env t |] - | Oint v -> app coq_t_int [| Z.mk v |] - | Oatom i -> app coq_t_var [| mk_N (reified_of_atom env i) |] - -let reified_of_formula env f = - try reified_of_formula env f - with reraise -> oprint stderr f; raise reraise - -let reified_cmp = function - | Eq -> app coq_p_eq - | Leq -> app coq_p_leq - | Geq -> app coq_p_geq - | Gt -> app coq_p_gt - | Lt -> app coq_p_lt - | Neq -> app coq_p_neq - -let reified_conn = function - | Por _ -> app coq_p_or - | Pand _ -> app coq_p_and - | Pimp _ -> app coq_p_imp - | _ -> assert false - -let rec reified_of_oprop sigma env t = match t with - | Pequa (_,{ e_comp=cmp; e_left=t1; e_right=t2 }) -> - reified_cmp cmp [| reified_of_formula env t1; reified_of_formula env t2 |] - | Ptrue -> Lazy.force coq_p_true - | Pfalse -> Lazy.force coq_p_false - | Pnot t -> app coq_p_not [| reified_of_oprop sigma env t |] - | Por (_,t1,t2) | Pand (_,t1,t2) | Pimp (_,t1,t2) -> - reified_conn t - [| reified_of_oprop sigma env t1; reified_of_oprop sigma env t2 |] - | Pprop t -> app coq_p_prop [| mk_nat (add_prop sigma env t) |] - -let reified_of_proposition sigma env f = - try reified_of_oprop sigma env f - with reraise -> pprint stderr f; raise reraise - -let reified_of_eq env (l,r) = - app coq_p_eq [| reified_of_formula env l; reified_of_formula env r |] - -(* \section{Opérations sur les équations} -Ces fonctions préparent les traces utilisées par la tactique réfléchie -pour faire des opérations de normalisation sur les équations. *) - -(* \subsection{Extractions des variables d'une équation} *) -(* Extraction des variables d'une équation. *) -(* Chaque fonction retourne une liste triée sans redondance *) - -let (@@) = IntSet.union - -let rec vars_of_formula = function - | Oint _ -> IntSet.empty - | Oplus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) - | Omult (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) - | Ominus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) - | Oopp e -> vars_of_formula e - | Oatom i -> IntSet.singleton i - -let rec vars_of_equations = function - | [] -> IntSet.empty - | e::l -> - (vars_of_formula e.e_left) @@ - (vars_of_formula e.e_right) @@ - (vars_of_equations l) - -let rec vars_of_prop = function - | Pequa(_,e) -> vars_of_equations [e] - | Pnot p -> vars_of_prop p - | Por(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) - | Pand(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) - | Pimp(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) - | Pprop _ | Ptrue | Pfalse -> IntSet.empty - -(* Normalized formulas : - - - sorted list of monomials, largest index first, - with non-null coefficients - - a constant coefficient - - /!\ Keep in sync with the corresponding functions in ReflOmegaCore ! -*) - -type nformula = - { coefs : (atom_index * Bigint.bigint) list; - cst : Bigint.bigint } - -let scale n { coefs; cst } = - { coefs = List.map (fun (v,k) -> (v,k*n)) coefs; - cst = cst*n } - -let shuffle nf1 nf2 = - let rec merge l1 l2 = match l1,l2 with - | [],_ -> l2 - | _,[] -> l1 - | (v1,k1)::r1,(v2,k2)::r2 -> - if Int.equal v1 v2 then - let k = k1+k2 in - if Bigint.equal k Bigint.zero then merge r1 r2 - else (v1,k) :: merge r1 r2 - else if v1 > v2 then (v1,k1) :: merge r1 l2 - else (v2,k2) :: merge l1 r2 - in - { coefs = merge nf1.coefs nf2.coefs; - cst = nf1.cst + nf2.cst } - -let rec normalize = function - | Oplus(t1,t2) -> shuffle (normalize t1) (normalize t2) - | Ominus(t1,t2) -> normalize (Oplus (t1, Oopp(t2))) - | Oopp(t) -> scale negone (normalize t) - | Omult(t,Oint n) | Omult (Oint n, t) -> - if Bigint.equal n Bigint.zero then { coefs = []; cst = zero } - else scale n (normalize t) - | Omult _ -> assert false (* invariant on Omult *) - | Oint n -> { coefs = []; cst = n } - | Oatom v -> { coefs = [v,Bigint.one]; cst=Bigint.zero} - -(* From normalized formulas to omega representations *) - -let omega_of_nformula env kind nf = - { id = new_omega_eq (); - kind; - constant=nf.cst; - body = List.map (fun (v,c) -> { v; c }) nf.coefs } - - -let negate_oper = function - Eq -> Neq | Neq -> Eq | Leq -> Gt | Geq -> Lt | Lt -> Geq | Gt -> Leq - -let normalize_equation env (negated,depends,origin,path) oper t1 t2 = - let mk_step t kind = - let equa = omega_of_nformula env kind (normalize t) in - { e_comp = oper; e_left = t1; e_right = t2; - e_negated = negated; e_depends = depends; - e_origin = { o_hyp = origin; o_path = List.rev path }; - e_omega = equa } - in - try match (if negated then (negate_oper oper) else oper) with - | Eq -> mk_step (Oplus (t1,Oopp t2)) EQUA - | Neq -> mk_step (Oplus (t1,Oopp t2)) DISE - | Leq -> mk_step (Oplus (t2,Oopp t1)) INEQ - | Geq -> mk_step (Oplus (t1,Oopp t2)) INEQ - | Lt -> mk_step (Oplus (Oplus(t2,Oint negone),Oopp t1)) INEQ - | Gt -> mk_step (Oplus (Oplus(t1,Oint negone),Oopp t2)) INEQ - with e when Logic.catchable_exception e -> raise e - -(* \section{Compilation des hypothèses} *) - -let mkPor i x y = Por (i,x,y) -let mkPand i x y = Pand (i,x,y) -let mkPimp i x y = Pimp (i,x,y) - -let rec oformula_of_constr sigma env t = - match Z.parse_term sigma t with - | Tplus (t1,t2) -> binop sigma env (fun x y -> Oplus(x,y)) t1 t2 - | Tminus (t1,t2) -> binop sigma env (fun x y -> Ominus(x,y)) t1 t2 - | Tmult (t1,t2) -> - (match Z.get_scalar sigma t1 with - | Some n -> Omult (Oint n,oformula_of_constr sigma env t2) - | None -> - match Z.get_scalar sigma t2 with - | Some n -> Omult (oformula_of_constr sigma env t1, Oint n) - | None -> Oatom (add_reified_atom sigma t env)) - | Topp t -> Oopp(oformula_of_constr sigma env t) - | Tsucc t -> Oplus(oformula_of_constr sigma env t, Oint one) - | Tnum n -> Oint n - | Tother -> Oatom (add_reified_atom sigma t env) - -and binop sigma env c t1 t2 = - let t1' = oformula_of_constr sigma env t1 in - let t2' = oformula_of_constr sigma env t2 in - c t1' t2' - -and binprop sigma env (neg2,depends,origin,path) - add_to_depends neg1 gl c t1 t2 = - let i = new_connector_id env in - let depends1 = if add_to_depends then Left i::depends else depends in - let depends2 = if add_to_depends then Right i::depends else depends in - if add_to_depends then - IntHtbl.add env.constructors i {o_hyp = origin; o_path = List.rev path}; - let t1' = - oproposition_of_constr sigma env (neg1,depends1,origin,O_left::path) gl t1 in - let t2' = - oproposition_of_constr sigma env (neg2,depends2,origin,O_right::path) gl t2 in - (* On numérote le connecteur dans l'environnement. *) - c i t1' t2' - -and mk_equation sigma env ctxt c connector t1 t2 = - let t1' = oformula_of_constr sigma env t1 in - let t2' = oformula_of_constr sigma env t2 in - (* On ajoute l'equation dans l'environnement. *) - let omega = normalize_equation env ctxt connector t1' t2' in - add_equation env omega; - Pequa (c,omega) - -and oproposition_of_constr sigma env ((negated,depends,origin,path) as ctxt) gl c = - match Z.parse_rel gl c with - | Req (t1,t2) -> mk_equation sigma env ctxt c Eq t1 t2 - | Rne (t1,t2) -> mk_equation sigma env ctxt c Neq t1 t2 - | Rle (t1,t2) -> mk_equation sigma env ctxt c Leq t1 t2 - | Rlt (t1,t2) -> mk_equation sigma env ctxt c Lt t1 t2 - | Rge (t1,t2) -> mk_equation sigma env ctxt c Geq t1 t2 - | Rgt (t1,t2) -> mk_equation sigma env ctxt c Gt t1 t2 - | Rtrue -> Ptrue - | Rfalse -> Pfalse - | Rnot t -> - let ctxt' = (not negated, depends, origin,(O_mono::path)) in - Pnot (oproposition_of_constr sigma env ctxt' gl t) - | Ror (t1,t2) -> binprop sigma env ctxt (not negated) negated gl mkPor t1 t2 - | Rand (t1,t2) -> binprop sigma env ctxt negated negated gl mkPand t1 t2 - | Rimp (t1,t2) -> - binprop sigma env ctxt (not negated) (not negated) gl mkPimp t1 t2 - | Riff (t1,t2) -> - (* No lifting here, since Omega only works on closed propositions. *) - binprop sigma env ctxt negated negated gl mkPand - (EConstr.mkArrow t1 t2) (EConstr.mkArrow t2 t1) - | _ -> Pprop c - -(* Destructuration des hypothèses et de la conclusion *) - -let display_gl env t_concl t_lhyps = - Printf.printf "REIFED PROBLEM\n\n"; - Printf.printf " CONCL: %a\n" pprint t_concl; - List.iter - (fun (i,_,t) -> Printf.printf " %s: %a\n" (Id.to_string i) pprint t) - t_lhyps; - print_env_reification env - -type defined = Defined | Assumed - -let reify_hyp sigma env gl i = - let open Context.Named.Declaration in - let ctxt = (false,[],i,[]) in - match Tacmach.New.pf_get_hyp i gl with - | LocalDef (_,d,t) when Z.is_int_typ gl t -> - let dummy = Lazy.force coq_True in - let p = mk_equation sigma env ctxt dummy Eq (EConstr.mkVar i) d in - i,Defined,p - | LocalDef (_,_,t) | LocalAssum (_,t) -> - let p = oproposition_of_constr sigma env ctxt gl t in - i,Assumed,p - -let reify_gl env gl = - let sigma = Proofview.Goal.sigma gl in - let concl = Tacmach.New.pf_concl gl in - let hyps = Tacmach.New.pf_ids_of_hyps gl in - let ctxt_concl = (true,[],id_concl,[O_mono]) in - let t_concl = oproposition_of_constr sigma env ctxt_concl gl concl in - let t_lhyps = List.map (reify_hyp sigma env gl) hyps in - let () = if !debug then display_gl env t_concl t_lhyps in - t_concl, t_lhyps - -let rec destruct_pos_hyp eqns = function - | Pequa (_,e) -> [e :: eqns] - | Ptrue | Pfalse | Pprop _ -> [eqns] - | Pnot t -> destruct_neg_hyp eqns t - | Por (_,t1,t2) -> - let s1 = destruct_pos_hyp eqns t1 in - let s2 = destruct_pos_hyp eqns t2 in - s1 @ s2 - | Pand(_,t1,t2) -> - List.map_append - (fun le1 -> destruct_pos_hyp le1 t2) - (destruct_pos_hyp eqns t1) - | Pimp(_,t1,t2) -> - let s1 = destruct_neg_hyp eqns t1 in - let s2 = destruct_pos_hyp eqns t2 in - s1 @ s2 - -and destruct_neg_hyp eqns = function - | Pequa (_,e) -> [e :: eqns] - | Ptrue | Pfalse | Pprop _ -> [eqns] - | Pnot t -> destruct_pos_hyp eqns t - | Pand (_,t1,t2) -> - let s1 = destruct_neg_hyp eqns t1 in - let s2 = destruct_neg_hyp eqns t2 in - s1 @ s2 - | Por(_,t1,t2) -> - List.map_append - (fun le1 -> destruct_neg_hyp le1 t2) - (destruct_neg_hyp eqns t1) - | Pimp(_,t1,t2) -> - List.map_append - (fun le1 -> destruct_neg_hyp le1 t2) - (destruct_pos_hyp eqns t1) - -let rec destructurate_hyps = function - | [] -> [[]] - | (i,_,t) :: l -> - let l_syst1 = destruct_pos_hyp [] t in - let l_syst2 = destructurate_hyps l in - List.cartesian (@) l_syst1 l_syst2 - -(* \subsection{Affichage d'un système d'équation} *) - -(* Affichage des dépendances de système *) -let display_depend = function - Left i -> Printf.printf " L%d" i - | Right i -> Printf.printf " R%d" i - -let display_systems syst_list = - let display_omega om_e = - Printf.printf " E%d : %a %s 0\n" - om_e.id - (fun _ -> display_eq display_omega_var) - (om_e.body, om_e.constant) - (operator_of_eq om_e.kind) in - - let display_equation oformula_eq = - pprint stdout (Pequa (Lazy.force coq_I,oformula_eq)); print_newline (); - display_omega oformula_eq.e_omega; - Printf.printf " Depends on:"; - List.iter display_depend oformula_eq.e_depends; - Printf.printf "\n Path: %s" - (String.concat "" - (List.map (function O_left -> "L" | O_right -> "R" | O_mono -> "M") - oformula_eq.e_origin.o_path)); - Printf.printf "\n Origin: %s (negated : %s)\n\n" - (Id.to_string oformula_eq.e_origin.o_hyp) - (if oformula_eq.e_negated then "yes" else "no") in - - let display_system syst = - Printf.printf "=SYSTEM===================================\n"; - List.iter display_equation syst in - List.iter display_system syst_list - -(* Extraction des prédicats utilisées dans une trace. Permet ensuite le - calcul des hypothèses *) - -let rec hyps_used_in_trace = function - | [] -> IntSet.empty - | act :: l -> - match act with - | HYP e -> IntSet.add e.id (hyps_used_in_trace l) - | SPLIT_INEQ (_,(_,act1),(_,act2)) -> - hyps_used_in_trace act1 @@ hyps_used_in_trace act2 - | _ -> hyps_used_in_trace l - -(** Retreive variables declared as extra equations during resolution - and declare them into the environment. - We should consider these variables in their introduction order, - otherwise really bad things will happen. *) - -let state_cmp x y = Int.compare x.st_var y.st_var - -module StateSet = - Set.Make (struct type t = state_action let compare = state_cmp end) - -let rec stated_in_trace = function - | [] -> StateSet.empty - | [SPLIT_INEQ (_,(_,t1),(_,t2))] -> - StateSet.union (stated_in_trace t1) (stated_in_trace t2) - | STATE action :: l -> StateSet.add action (stated_in_trace l) - | _ :: l -> stated_in_trace l - -let rec stated_in_tree = function - | Tree(_,t1,t2) -> StateSet.union (stated_in_tree t1) (stated_in_tree t2) - | Leaf s -> stated_in_trace s.s_trace - -let mk_refl t = app coq_refl_equal [|Lazy.force Z.typ; t|] - -let digest_stated_equations env tree = - let do_equation st (vars,gens,eqns,ids) = - (** We turn the definition of [v] - - into a reified formula : *) - let v_def = oformula_of_omega st.st_def in - (** - into a concrete Coq formula - (this uses only older vars already in env) : *) - let coq_v = coq_of_formula env v_def in - (** We then update the environment *) - set_reified_atom st.st_var coq_v env; - (** The term we'll introduce *) - let term_to_generalize = mk_refl coq_v in - (** Its representation as equation (but not reified yet, - we lack the proper env to do that). *) - let term_to_reify = (v_def,Oatom st.st_var) in - (st.st_var::vars, - term_to_generalize::gens, - term_to_reify::eqns, - CCEqua st.st_def.id :: ids) - in - let (vars,gens,eqns,ids) = - StateSet.fold do_equation (stated_in_tree tree) ([],[],[],[]) - in - (List.rev vars, List.rev gens, List.rev eqns, List.rev ids) - -(* Calcule la liste des éclatements à réaliser sur les hypothèses - nécessaires pour extraire une liste d'équations donnée *) - -(* PL: experimentally, the result order of the following function seems - _very_ crucial for efficiency. No idea why. Do not remove the List.rev - or modify the current semantics of Util.List.union (some elements of first - arg, then second arg), unless you know what you're doing. *) - -let rec get_eclatement env = function - | [] -> [] - | i :: r -> - let l = try (get_equation env i).e_depends with Not_found -> [] in - List.union dir_eq (List.rev l) (get_eclatement env r) - -let select_smaller l = - let comp (_,x) (_,y) = Int.compare (List.length x) (List.length y) in - try List.hd (List.sort comp l) with Failure _ -> failwith "select_smaller" - -let filter_compatible_systems required systems = - let rec select = function - | [] -> [] - | (x::l) -> - if List.mem_f dir_eq x required then select l - else if List.mem_f dir_eq (barre x) required then raise Exit - else x :: select l - in - List.map_filter - (function (sol, splits) -> - try Some (sol, select splits) with Exit -> None) - systems - -let rec equas_of_solution_tree = function - | Tree(_,t1,t2) -> - (equas_of_solution_tree t1)@@(equas_of_solution_tree t2) - | Leaf s -> s.s_equa_deps - -(** [maximize_prop] pushes useless props in a new Pprop atom. - The reified formulas get shorter, but be careful with decidabilities. - For instance, anything that contains a Pprop is considered to be - undecidable in [ReflOmegaCore], whereas a Pfalse for instance at - the same spot will lead to a decidable formula. - In particular, do not use this function on the conclusion. - Even in hypotheses, we could probably build pathological examples - that romega won't handle correctly, but they should be pretty rare. -*) - -let maximize_prop equas c = - let rec loop c = match c with - | Pequa(t,e) -> if IntSet.mem e.e_omega.id equas then c else Pprop t - | Pnot t -> - (match loop t with - | Pprop p -> Pprop (app coq_not [|p|]) - | t' -> Pnot t') - | Por(i,t1,t2) -> - (match loop t1, loop t2 with - | Pprop p1, Pprop p2 -> Pprop (app coq_or [|p1;p2|]) - | t1', t2' -> Por(i,t1',t2')) - | Pand(i,t1,t2) -> - (match loop t1, loop t2 with - | Pprop p1, Pprop p2 -> Pprop (app coq_and [|p1;p2|]) - | t1', t2' -> Pand(i,t1',t2')) - | Pimp(i,t1,t2) -> - (match loop t1, loop t2 with - | Pprop p1, Pprop p2 -> Pprop (EConstr.mkArrow p1 p2) (* no lift (closed) *) - | t1', t2' -> Pimp(i,t1',t2')) - | Ptrue -> Pprop (app coq_True [||]) - | Pfalse -> Pprop (app coq_False [||]) - | Pprop _ -> c - in loop c - -let rec display_solution_tree ch = function - Leaf t -> - output_string ch - (Printf.sprintf "%d[%s]" - t.s_index - (String.concat " " (List.map string_of_int - (IntSet.elements t.s_equa_deps)))) - | Tree(i,t1,t2) -> - Printf.fprintf ch "S%d(%a,%a)" i - display_solution_tree t1 display_solution_tree t2 - -let rec solve_with_constraints all_solutions path = - let rec build_tree sol buf = function - [] -> Leaf sol - | (Left i :: remainder) -> - Tree(i, - build_tree sol (Left i :: buf) remainder, - solve_with_constraints all_solutions (List.rev(Right i :: buf))) - | (Right i :: remainder) -> - Tree(i, - solve_with_constraints all_solutions (List.rev (Left i :: buf)), - build_tree sol (Right i :: buf) remainder) in - let weighted = filter_compatible_systems path all_solutions in - let (winner_sol,winner_deps) = - try select_smaller weighted - with reraise -> - Printf.printf "%d - %d\n" - (List.length weighted) (List.length all_solutions); - List.iter display_depend path; raise reraise - in - build_tree winner_sol (List.rev path) winner_deps - -let find_path {o_hyp=id;o_path=p} env = - let rec loop_path = function - ([],l) -> Some l - | (x1::l1,x2::l2) when occ_step_eq x1 x2 -> loop_path (l1,l2) - | _ -> None in - let rec loop_id i = function - CCHyp{o_hyp=id';o_path=p'} :: l when Id.equal id id' -> - begin match loop_path (p',p) with - Some r -> i,r - | None -> loop_id (succ i) l - end - | _ :: l -> loop_id (succ i) l - | [] -> failwith "find_path" in - loop_id 0 env - -let mk_direction_list l = - let trans = function - | O_left -> Some (Lazy.force coq_d_left) - | O_right -> Some (Lazy.force coq_d_right) - | O_mono -> None (* No more [D_mono] constructor now *) - in - mk_list (Lazy.force coq_direction) (List.map_filter trans l) - - -(* \section{Rejouer l'historique} *) - -let hyp_idx env_hyp i = - let rec loop count = function - | [] -> failwith (Printf.sprintf "get_hyp %d" i) - | CCEqua i' :: _ when Int.equal i i' -> mk_nat count - | _ :: l -> loop (succ count) l - in loop 0 env_hyp - - -(* We now expand NEGATE_CONTRADICT and CONTRADICTION into - a O_SUM followed by a O_BAD_CONSTANT *) - -let sum_bad inv i1 i2 = - let open EConstr in - mkApp (Lazy.force coq_s_sum, - [| Z.mk Bigint.one; i1; - Z.mk (if inv then negone else Bigint.one); i2; - mkApp (Lazy.force coq_s_bad_constant, [| mk_nat 0 |])|]) - -let rec reify_trace env env_hyp = - let open EConstr in - function - | CONSTANT_NOT_NUL(e,_) :: [] - | CONSTANT_NEG(e,_) :: [] - | CONSTANT_NUL e :: [] -> - mkApp (Lazy.force coq_s_bad_constant,[| hyp_idx env_hyp e |]) - | NEGATE_CONTRADICT(e1,e2,direct) :: [] -> - sum_bad direct (hyp_idx env_hyp e1.id) (hyp_idx env_hyp e2.id) - | CONTRADICTION (e1,e2) :: [] -> - sum_bad false (hyp_idx env_hyp e1.id) (hyp_idx env_hyp e2.id) - | NOT_EXACT_DIVIDE (e1,k) :: [] -> - mkApp (Lazy.force coq_s_not_exact_divide, - [| hyp_idx env_hyp e1.id; Z.mk k |]) - | DIVIDE_AND_APPROX (e1,_,k,_) :: l - | EXACT_DIVIDE (e1,k) :: l -> - mkApp (Lazy.force coq_s_divide, - [| hyp_idx env_hyp e1.id; Z.mk k; - reify_trace env env_hyp l |]) - | MERGE_EQ(e3,e1,e2) :: l -> - mkApp (Lazy.force coq_s_merge_eq, - [| hyp_idx env_hyp e1.id; hyp_idx env_hyp e2; - reify_trace env (CCEqua e3:: env_hyp) l |]) - | SUM(e3,(k1,e1),(k2,e2)) :: l -> - mkApp (Lazy.force coq_s_sum, - [| Z.mk k1; hyp_idx env_hyp e1.id; - Z.mk k2; hyp_idx env_hyp e2.id; - reify_trace env (CCEqua e3 :: env_hyp) l |]) - | STATE {st_new_eq; st_def; st_orig; st_coef } :: l -> - (* we now produce a [O_SUM] here *) - mkApp (Lazy.force coq_s_sum, - [| Z.mk Bigint.one; hyp_idx env_hyp st_orig.id; - Z.mk st_coef; hyp_idx env_hyp st_def.id; - reify_trace env (CCEqua st_new_eq.id :: env_hyp) l |]) - | HYP _ :: l -> reify_trace env env_hyp l - | SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: _ -> - let r1 = reify_trace env (CCEqua e1 :: env_hyp) l1 in - let r2 = reify_trace env (CCEqua e2 :: env_hyp) l2 in - mkApp (Lazy.force coq_s_split_ineq, - [| hyp_idx env_hyp e.id; r1 ; r2 |]) - | (FORGET_C _ | FORGET _ | FORGET_I _) :: l -> reify_trace env env_hyp l - | WEAKEN _ :: l -> failwith "not_treated" - | _ -> failwith "bad history" - -let rec decompose_tree env ctxt = function - Tree(i,left,right) -> - let org = - try IntHtbl.find env.constructors i - with Not_found -> - failwith (Printf.sprintf "Cannot find constructor %d" i) in - let (index,path) = find_path org ctxt in - let left_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_left]} in - let right_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_right]} in - app coq_e_split - [| mk_nat index; - mk_direction_list path; - decompose_tree env (left_hyp::ctxt) left; - decompose_tree env (right_hyp::ctxt) right |] - | Leaf s -> - decompose_tree_hyps s.s_trace env ctxt (IntSet.elements s.s_equa_deps) -and decompose_tree_hyps trace env ctxt = function - [] -> app coq_e_solve [| reify_trace env ctxt trace |] - | (i::l) -> - let equation = - try IntHtbl.find env.equations i - with Not_found -> - failwith (Printf.sprintf "Cannot find equation %d" i) in - let (index,path) = find_path equation.e_origin ctxt in - let cont = - decompose_tree_hyps trace env - (CCEqua equation.e_omega.id :: ctxt) l in - app coq_e_extract [|mk_nat index; mk_direction_list path; cont |] - -let solve_system env index list_eq = - let system = List.map (fun eq -> eq.e_omega) list_eq in - let trace = - OmegaSolver.simplify_strong - (new_omega_eq,new_omega_var,display_omega_var) - system - in - (* Hypotheses used for this solution *) - let vars = hyps_used_in_trace trace in - let splits = get_eclatement env (IntSet.elements vars) in - if !debug then - begin - Printf.printf "SYSTEME %d\n" index; - display_action display_omega_var trace; - print_string "\n Depend :"; - IntSet.iter (fun i -> Printf.printf " %d" i) vars; - print_string "\n Split points :"; - List.iter display_depend splits; - Printf.printf "\n------------------------------------\n" - end; - {s_index = index; s_trace = trace; s_equa_deps = vars}, splits - -(* \section{La fonction principale} *) - (* Cette fonction construit la -trace pour la procédure de décision réflexive. A partir des résultats -de l'extraction des systèmes, elle lance la résolution par Omega, puis -l'extraction d'un ensemble minimal de solutions permettant la -résolution globale du système et enfin construit la trace qui permet -de faire rejouer cette solution par la tactique réflexive. *) - -let resolution unsafe sigma env (reified_concl,reified_hyps) systems_list = - if !debug then Printf.printf "\n====================================\n"; - let all_solutions = List.mapi (solve_system env) systems_list in - let solution_tree = solve_with_constraints all_solutions [] in - if !debug then begin - display_solution_tree stdout solution_tree; - print_newline() - end; - (** Collect all hypotheses and variables used in the solution tree *) - let useful_equa_ids = equas_of_solution_tree solution_tree in - let useful_hypnames, useful_vars = - IntSet.fold - (fun i (hyps,vars) -> - let e = get_equation env i in - Id.Set.add e.e_origin.o_hyp hyps, - vars_of_equations [e] @@ vars) - useful_equa_ids - (Id.Set.empty, vars_of_prop reified_concl) - in - let useful_hypnames = - Id.Set.elements (Id.Set.remove id_concl useful_hypnames) - in - - (** Parts coming from equations introduced by omega: *) - let stated_vars, l_generalize_arg, to_reify_stated, hyp_stated_vars = - digest_stated_equations env solution_tree - in - (** The final variables are either coming from: - - useful hypotheses (and conclusion) - - equations introduced during resolution *) - let all_vars_env = (IntSet.elements useful_vars) @ stated_vars - in - (** We prepare the renumbering from all variables to useful ones. - Since [all_var_env] is sorted, this renumbering will preserve - order: this way, the equations in ReflOmegaCore will have - the same normal forms as here. *) - let reduced_term_env = - let rec loop i = function - | [] -> [] - | var :: l -> - let t = get_reified_atom env var in - IntHtbl.add env.real_indices var i; t :: loop (succ i) l - in - mk_list (Lazy.force Z.typ) (loop 0 all_vars_env) - in - (** The environment [env] (and especially [env.real_indices]) is now - ready for the coming reifications: *) - let l_reified_stated = List.map (reified_of_eq env) to_reify_stated in - let reified_concl = reified_of_proposition sigma env reified_concl in - let l_reified_terms = - List.map - (fun id -> - match Id.Map.find id reified_hyps with - | Defined,p -> - reified_of_proposition sigma env p, mk_refl (EConstr.mkVar id) - | Assumed,p -> - reified_of_proposition sigma env (maximize_prop useful_equa_ids p), - EConstr.mkVar id - | exception Not_found -> assert false) - useful_hypnames - in - let l_reified_terms, l_reified_hypnames = List.split l_reified_terms in - let env_props_reified = mk_plist env.props in - let reified_goal = - mk_list (Lazy.force coq_proposition) - (l_reified_stated @ l_reified_terms) in - let reified = - app coq_interp_sequent - [| reified_concl;env_props_reified;reduced_term_env;reified_goal|] - in - let mk_occ id = {o_hyp=id;o_path=[]} in - let initial_context = - List.map (fun id -> CCHyp (mk_occ id)) useful_hypnames in - let context = - CCHyp (mk_occ id_concl) :: hyp_stated_vars @ initial_context in - let decompose_tactic = decompose_tree env context solution_tree in - - Tactics.generalize (l_generalize_arg @ l_reified_hypnames) >> - Tactics.convert_concl_no_check reified Term.DEFAULTcast >> - Tactics.apply (app coq_do_omega [|decompose_tactic|]) >> - show_goal >> - (if unsafe then - (* Trust the produced term. Faster, but might fail later at Qed. - Also handy when debugging, e.g. via a Show Proof after romega. *) - Tactics.convert_concl_no_check (Lazy.force coq_True) Term.VMcast - else - Tactics.normalise_vm_in_concl) >> - Tactics.apply (Lazy.force coq_I) - -let total_reflexive_omega_tactic unsafe = - Proofview.Goal.nf_enter begin fun gl -> - Coqlib.check_required_library ["Coq";"romega";"ROmega"]; - rst_omega_eq (); - rst_omega_var (); - try - let env = new_environment () in - let (concl,hyps) = reify_gl env gl in - (* Register all atom indexes created during reification as omega vars *) - set_omega_maxvar (pred (List.length env.terms)); - let full_reified_goal = (id_concl,Assumed,Pnot concl) :: hyps in - let systems_list = destructurate_hyps full_reified_goal in - let hyps = - List.fold_left (fun s (id,d,p) -> Id.Map.add id (d,p) s) Id.Map.empty hyps - in - if !debug then display_systems systems_list; - let sigma = Proofview.Goal.sigma gl in - resolution unsafe sigma env (concl,hyps) systems_list - with NO_CONTRADICTION -> CErrors.user_err Pp.(str "ROmega can't solve this system") - end - diff --git a/plugins/romega/romega_plugin.mlpack b/plugins/romega/romega_plugin.mlpack deleted file mode 100644 index 38d0e94111..0000000000 --- a/plugins/romega/romega_plugin.mlpack +++ /dev/null @@ -1,3 +0,0 @@ -Const_omega -Refl_omega -G_romega diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v index 600e8993b4..99c02995fb 100644 --- a/plugins/rtauto/Bintree.v +++ b/plugins/rtauto/Bintree.v @@ -319,6 +319,9 @@ Arguments F_empty [A]. Arguments F_push [A] a S _. Arguments In [A] x S F. +Register empty as plugins.rtauto.empty. +Register push as plugins.rtauto.push. + Section Map. Variables A B:Set. diff --git a/plugins/rtauto/Rtauto.v b/plugins/rtauto/Rtauto.v index 06cdf76b4e..f027a4a46e 100644 --- a/plugins/rtauto/Rtauto.v +++ b/plugins/rtauto/Rtauto.v @@ -387,3 +387,24 @@ exact (Reflect (empty \ A \ B \ C) Qed. Print toto. *) + +Register Reflect as plugins.rtauto.Reflect. + +Register Atom as plugins.rtauto.Atom. +Register Arrow as plugins.rtauto.Arrow. +Register Bot as plugins.rtauto.Bot. +Register Conjunct as plugins.rtauto.Conjunct. +Register Disjunct as plugins.rtauto.Disjunct. + +Register Ax as plugins.rtauto.Ax. +Register I_Arrow as plugins.rtauto.I_Arrow. +Register E_Arrow as plugins.rtauto.E_Arrow. +Register D_Arrow as plugins.rtauto.D_Arrow. +Register E_False as plugins.rtauto.E_False. +Register I_And as plugins.rtauto.I_And. +Register E_And as plugins.rtauto.E_And. +Register D_And as plugins.rtauto.D_And. +Register I_Or_l as plugins.rtauto.I_Or_l. +Register I_Or_r as plugins.rtauto.I_Or_r. +Register E_Or as plugins.rtauto.E_Or. +Register D_Or as plugins.rtauto.D_Or. diff --git a/plugins/rtauto/g_rtauto.ml4 b/plugins/rtauto/g_rtauto.mlg index aa67576348..9c9fdcfa2f 100644 --- a/plugins/rtauto/g_rtauto.ml4 +++ b/plugins/rtauto/g_rtauto.mlg @@ -8,12 +8,15 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ open Ltac_plugin +} + DECLARE PLUGIN "rtauto_plugin" TACTIC EXTEND rtauto - [ "rtauto" ] -> [ Proofview.V82.tactic (Refl_tauto.rtauto_tac) ] +| [ "rtauto" ] -> { Proofview.V82.tactic (Refl_tauto.rtauto_tac) } END diff --git a/plugins/rtauto/plugin_base.dune b/plugins/rtauto/plugin_base.dune new file mode 100644 index 0000000000..233845ae0f --- /dev/null +++ b/plugins/rtauto/plugin_base.dune @@ -0,0 +1,5 @@ +(library + (name rtauto_plugin) + (public_name coq.plugins.rtauto) + (synopsis "Coq's rtauto plugin") + (libraries coq.plugins.ltac)) diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 946b6dff42..840a05e02b 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -26,49 +26,39 @@ let step_count = ref 0 let node_count = ref 0 -let logic_constant s = Universes.constr_of_global @@ - Coqlib.coq_reference "refl_tauto" ["Init";"Logic"] s - -let li_False = lazy (destInd (logic_constant "False")) -let li_and = lazy (destInd (logic_constant "and")) -let li_or = lazy (destInd (logic_constant "or")) - -let pos_constant s = Universes.constr_of_global @@ - Coqlib.coq_reference "refl_tauto" ["Numbers";"BinNums"] s - -let l_xI = lazy (pos_constant "xI") -let l_xO = lazy (pos_constant "xO") -let l_xH = lazy (pos_constant "xH") - -let store_constant s = Universes.constr_of_global @@ - Coqlib.coq_reference "refl_tauto" ["rtauto";"Bintree"] s - -let l_empty = lazy (store_constant "empty") -let l_push = lazy (store_constant "push") - -let constant s = Universes.constr_of_global @@ - Coqlib.coq_reference "refl_tauto" ["rtauto";"Rtauto"] s - -let l_Reflect = lazy (constant "Reflect") - -let l_Atom = lazy (constant "Atom") -let l_Arrow = lazy (constant "Arrow") -let l_Bot = lazy (constant "Bot") -let l_Conjunct = lazy (constant "Conjunct") -let l_Disjunct = lazy (constant "Disjunct") - -let l_Ax = lazy (constant "Ax") -let l_I_Arrow = lazy (constant "I_Arrow") -let l_E_Arrow = lazy (constant "E_Arrow") -let l_D_Arrow = lazy (constant "D_Arrow") -let l_E_False = lazy (constant "E_False") -let l_I_And = lazy (constant "I_And") -let l_E_And = lazy (constant "E_And") -let l_D_And = lazy (constant "D_And") -let l_I_Or_l = lazy (constant "I_Or_l") -let l_I_Or_r = lazy (constant "I_Or_r") -let l_E_Or = lazy (constant "E_Or") -let l_D_Or = lazy (constant "D_Or") +let li_False = lazy (destInd (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type")) +let li_and = lazy (destInd (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.and.type")) +let li_or = lazy (destInd (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.or.type")) + +let gen_constant n = lazy (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref n)) + +let l_xI = gen_constant "num.pos.xI" +let l_xO = gen_constant "num.pos.xO" +let l_xH = gen_constant "num.pos.xH" + +let l_empty = gen_constant "plugins.rtauto.empty" +let l_push = gen_constant "plugins.rtauto.push" + +let l_Reflect = gen_constant "plugins.rtauto.Reflect" + +let l_Atom = gen_constant "plugins.rtauto.Atom" +let l_Arrow = gen_constant "plugins.rtauto.Arrow" +let l_Bot = gen_constant "plugins.rtauto.Bot" +let l_Conjunct = gen_constant "plugins.rtauto.Conjunct" +let l_Disjunct = gen_constant "plugins.rtauto.Disjunct" + +let l_Ax = gen_constant "plugins.rtauto.Ax" +let l_I_Arrow = gen_constant "plugins.rtauto.I_Arrow" +let l_E_Arrow = gen_constant "plugins.rtauto.E_Arrow" +let l_D_Arrow = gen_constant "plugins.rtauto.D_Arrow" +let l_E_False = gen_constant "plugins.rtauto.E_False" +let l_I_And = gen_constant "plugins.rtauto.I_And" +let l_E_And = gen_constant "plugins.rtauto.E_And" +let l_D_And = gen_constant "plugins.rtauto.D_And" +let l_I_Or_l = gen_constant "plugins.rtauto.I_Or_l" +let l_I_Or_r = gen_constant "plugins.rtauto.I_Or_r" +let l_E_Or = gen_constant "plugins.rtauto.E_Or" +let l_D_Or = gen_constant "plugins.rtauto.D_Or" let special_whd gl c = diff --git a/plugins/setoid_ring/Algebra_syntax.v b/plugins/setoid_ring/Algebra_syntax.v index e896554ea7..1204bbd2e1 100644 --- a/plugins/setoid_ring/Algebra_syntax.v +++ b/plugins/setoid_ring/Algebra_syntax.v @@ -1,3 +1,12 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) Class Zero (A : Type) := zero : A. Notation "0" := zero. diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index d9e32dbbf8..ce115f564f 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -19,6 +19,7 @@ Section MakeFieldPol. (* Field elements : R *) Variable R:Type. +Declare Scope R_scope. Bind Scope R_scope with R. Delimit Scope R_scope with ring. Local Open Scope R_scope. @@ -94,6 +95,7 @@ Let rdistr_r := ARdistr_r Rsth Reqe ARth. (* Coefficients : C *) Variable C: Type. +Declare Scope C_scope. Bind Scope C_scope with C. Delimit Scope C_scope with coef. @@ -139,6 +141,7 @@ Let rpow_pow := pow_th.(rpow_pow_N). (* Polynomial expressions : (PExpr C) *) +Declare Scope PE_scope. Bind Scope PE_scope with PExpr. Delimit Scope PE_scope with poly. diff --git a/plugins/setoid_ring/Integral_domain.v b/plugins/setoid_ring/Integral_domain.v index 0c16fe1a3b..98407cb6d7 100644 --- a/plugins/setoid_ring/Integral_domain.v +++ b/plugins/setoid_ring/Integral_domain.v @@ -1,3 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + Require Export Cring. diff --git a/plugins/setoid_ring/Ncring_initial.v b/plugins/setoid_ring/Ncring_initial.v index 523c7b02eb..1ca6227f25 100644 --- a/plugins/setoid_ring/Ncring_initial.v +++ b/plugins/setoid_ring/Ncring_initial.v @@ -79,8 +79,9 @@ Context {R:Type}`{Ring R}. | Z0 => 0 | Zneg p => -(gen_phiPOS p) end. - Local Notation "[ x ]" := (gen_phiZ x) : ZMORPHISM. - Local Open Scope ZMORPHISM. + Declare Scope ZMORPHISM. + Notation "[ x ]" := (gen_phiZ x) : ZMORPHISM. + Open Scope ZMORPHISM. Definition get_signZ z := match z with diff --git a/plugins/setoid_ring/RealField.v b/plugins/setoid_ring/RealField.v index facd2e0625..38bc58a659 100644 --- a/plugins/setoid_ring/RealField.v +++ b/plugins/setoid_ring/RealField.v @@ -1,3 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + Require Import Nnat. Require Import ArithRing. Require Export Ring Field. diff --git a/plugins/setoid_ring/Ring_base.v b/plugins/setoid_ring/Ring_base.v index a9b4d9d6f4..920b13ef49 100644 --- a/plugins/setoid_ring/Ring_base.v +++ b/plugins/setoid_ring/Ring_base.v @@ -12,7 +12,6 @@ ring tactic. Abstract rings need more theory, depending on ZArith_base. *) -Require Import Quote. Declare ML Module "newring_plugin". Require Export Ring_theory. Require Export Ring_tac. diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index 33df36d847..ccd82eabcd 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -919,6 +919,14 @@ Section MakeRingPol. | PEopp : PExpr -> PExpr | PEpow : PExpr -> N -> PExpr. + Register PExpr as plugins.setoid_ring.pexpr. + Register PEc as plugins.setoid_ring.const. + Register PEX as plugins.setoid_ring.var. + Register PEadd as plugins.setoid_ring.add. + Register PEsub as plugins.setoid_ring.sub. + Register PEmul as plugins.setoid_ring.mul. + Register PEopp as plugins.setoid_ring.opp. + Register PEpow as plugins.setoid_ring.pow. (** evaluation of polynomial expressions towards R *) Definition mk_X j := mkPinj_pred j mkX. diff --git a/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v index 36d1e7c542..26fef99bb2 100644 --- a/plugins/setoid_ring/Ring_tac.v +++ b/plugins/setoid_ring/Ring_tac.v @@ -1,3 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + Set Implicit Arguments. Require Import Setoid. Require Import BinPos. @@ -5,7 +15,6 @@ Require Import Ring_polynom. Require Import BinList. Require Export ListTactics. Require Import InitialRing. -Require Import Quote. Declare ML Module "newring_plugin". diff --git a/plugins/setoid_ring/Rings_Q.v b/plugins/setoid_ring/Rings_Q.v index fd76547132..ae91ee1664 100644 --- a/plugins/setoid_ring/Rings_Q.v +++ b/plugins/setoid_ring/Rings_Q.v @@ -1,3 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + Require Export Cring. Require Export Integral_domain. diff --git a/plugins/setoid_ring/Rings_R.v b/plugins/setoid_ring/Rings_R.v index fd219c2352..901b36ed3b 100644 --- a/plugins/setoid_ring/Rings_R.v +++ b/plugins/setoid_ring/Rings_R.v @@ -1,3 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + Require Export Cring. Require Export Integral_domain. diff --git a/plugins/setoid_ring/Rings_Z.v b/plugins/setoid_ring/Rings_Z.v index 605a23a987..75e77ab6ef 100644 --- a/plugins/setoid_ring/Rings_Z.v +++ b/plugins/setoid_ring/Rings_Z.v @@ -1,3 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + Require Export Cring. Require Export Integral_domain. Require Export Ncring_initial. diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.mlg index 5e4c9214a2..f59ca4cef4 100644 --- a/plugins/setoid_ring/g_newring.ml4 +++ b/plugins/setoid_ring/g_newring.mlg @@ -8,6 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Ltac_plugin open Pp open Util @@ -20,19 +22,18 @@ open Tacarg open Pcoq.Constr open Pltac +} + DECLARE PLUGIN "newring_plugin" TACTIC EXTEND protect_fv - [ "protect_fv" string(map) "in" ident(id) ] -> - [ protect_tac_in map id ] +| [ "protect_fv" string(map) "in" ident(id) ] -> + { protect_tac_in map id } | [ "protect_fv" string(map) ] -> - [ protect_tac 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 @@ -42,44 +43,50 @@ let pr_ring_mod = function | 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 "]" + | Const_tac (Closed l) -> str "closed" ++ spc () ++ str "[" ++ prlist_with_sep spc pr_qualid 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(Closed l,spec) -> str "power_tac" ++ pr_arg pr_constr_expr spec ++ spc () ++ str "[" ++ prlist_with_sep spc pr_qualid 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 ] + 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) ] + { 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 ] + { 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 ] + 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 add_theory id t l] - | [ "Print" "Rings" ] => [Vernac_classifier.classify_as_query] -> [ + { let l = match l with None -> [] | Some l -> l in add_theory id t l } + | [ "Print" "Rings" ] => { Vernacextend.classify_as_query } -> { Feedback.msg_notice (strbrk "The following ring structures have been declared:"); Spmap.iter (fun fn fi -> let sigma, env = Pfedit.get_current_context () in @@ -87,35 +94,43 @@ VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF (Ppconstr.pr_id (Libnames.basename fn)++spc()++ str"with carrier "++ pr_constr_env env sigma fi.ring_carrier++spc()++ str"and equivalence relation "++ pr_constr_env env sigma fi.ring_req)) - ) !from_name ] + ) !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 ] + { 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 ] + 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 ] + 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 add_field_theory id t l ] -| [ "Print" "Fields" ] => [Vernac_classifier.classify_as_query] -> [ + { let l = match l with None -> [] | Some l -> l in add_field_theory id t l } +| [ "Print" "Fields" ] => {Vernacextend.classify_as_query} -> { Feedback.msg_notice (strbrk "The following field structures have been declared:"); Spmap.iter (fun fn fi -> let sigma, env = Pfedit.get_current_context () in @@ -123,10 +138,10 @@ VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF (Ppconstr.pr_id (Libnames.basename fn)++spc()++ str"with carrier "++ pr_constr_env env sigma fi.field_carrier++spc()++ str"and equivalence relation "++ pr_constr_env env sigma fi.field_req)) - ) !field_from_name ] + ) !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 ] + { let (t,l) = List.sep_last lt in field_lookup f lH l t } END diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 99bb8440c6..4109e9cf38 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -8,6 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +module CVars = Vars open Ltac_plugin open Pp open Util @@ -20,6 +21,7 @@ open Environ open Libnames open Globnames open Glob_term +open Locus open Tacexpr open Coqlib open Mod_subst @@ -29,7 +31,6 @@ open Printer open Declare open Decl_kinds open Entries -open Misctypes open Newring_ast open Proofview.Notations @@ -40,11 +41,7 @@ let error msg = CErrors.user_err Pp.(str msg) type protect_flag = Eval|Prot|Rec -let tag_arg tag_rec map subs i c = - match map i with - Eval -> mk_clos subs c - | Prot -> mk_atom c - | Rec -> if Int.equal i (-1) then mk_clos subs c else tag_rec c +type protection = Evd.evar_map -> EConstr.t -> GlobRef.t -> (Int.t -> protect_flag) option let global_head_of_constr sigma c = let f, args = decompose_app sigma c in @@ -55,32 +52,24 @@ let global_of_constr_nofail c = try global_of_constr c with Not_found -> VarRef (Id.of_string "dummy") -let rec mk_clos_but f_map subs t = - let open Term in - match f_map (global_of_constr_nofail t) with - | Some map -> tag_arg (mk_clos_but f_map subs) map subs (-1) t - | None -> - (match Constr.kind t with - App(f,args) -> mk_clos_app_but f_map subs f args 0 - | Prod _ -> mk_clos_deep (mk_clos_but f_map) subs t - | _ -> mk_atom t) +let rec mk_clos_but f_map n t = + let (f, args) = Constr.decompose_appvect t in + match f_map (global_of_constr_nofail f) with + | Some tag -> + let map i t = tag_arg f_map n (tag i) t in + if Array.is_empty args then map (-1) f + else mk_red (FApp (map (-1) f, Array.mapi map args)) + | None -> mk_atom t -and mk_clos_app_but f_map subs f args n = - let open Constr in - if n >= Array.length args then mk_atom(mkApp(f, args)) - else - let fargs, args' = Array.chop n args in - let f' = mkApp(f,fargs) in - match f_map (global_of_constr_nofail f') with - | 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)) +and tag_arg f_map n tag c = match tag with +| Eval -> mk_clos (Esubst.subs_id n) c +| Prot -> mk_atom c +| Rec -> mk_clos_but f_map n c let interp_map l t = - try Some(List.assoc_f eq_gr t l) with Not_found -> None + try Some(List.assoc_f GlobRef.equal t l) with Not_found -> None -let protect_maps = ref String.Map.empty +let protect_maps : protection String.Map.t ref = ref String.Map.empty let add_map s m = protect_maps := String.Map.add s m !protect_maps let lookup_map map = try String.Map.find map !protect_maps @@ -90,8 +79,14 @@ let lookup_map map = let protect_red map env sigma c0 = let evars ev = Evarutil.safe_evar_value sigma ev in let c = EConstr.Unsafe.to_constr c0 in - EConstr.of_constr (kl (create_clos_infos ~evars all env) (create_tab ()) - (mk_clos_but (lookup_map map sigma c0) (Esubst.subs_id 0) c));; + let tab = create_tab () in + let infos = create_clos_infos ~evars all env in + let map = lookup_map map sigma c0 in + let rec eval n c = match Constr.kind c with + | Prod (na, t, u) -> Constr.mkProd (na, eval n t, eval (n + 1) u) + | _ -> kl infos tab (mk_clos_but map n c) + in + EConstr.of_constr (eval 0 c) let protect_tac map = Tactics.reduct_option (protect_red map,DEFAULTcast) None @@ -102,37 +97,39 @@ let protect_tac_in map id = (****************************************************************************) -let closed_term t l = - let open Quote_plugin in +let rec closed_under sigma cset t = + try + let (gr, _) = Termops.global_of_constr sigma t in + GlobRef.Set_env.mem gr cset + with Not_found -> + match EConstr.kind sigma t with + | Cast(c,_,_) -> closed_under sigma cset c + | App(f,l) -> closed_under sigma cset f && Array.for_all (closed_under sigma cset) l + | _ -> false + +let closed_term args _ = match args with +| [t; l] -> + let t = Option.get (Value.to_constr t) in + let l = List.map (fun c -> Value.cast (Genarg.topwit Stdarg.wit_ref) c) (Option.get (Value.to_list l)) in Proofview.tclEVARMAP >>= fun sigma -> - 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 sigma cs t then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (mt()) - -(* TACTIC EXTEND echo -| [ "echo" constr(t) ] -> - [ Pp.msg (Termops.print_constr t); Tacinterp.eval_tactic (TacId []) ] -END;;*) + let cs = List.fold_right GlobRef.Set_env.add l GlobRef.Set_env.empty in + if closed_under sigma cs t then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (mt()) +| _ -> assert false -(* -let closed_term_ast l = - TacFun([Some(Id.of_string"t")], - TacAtom(Loc.ghost,TacExtend(Loc.ghost,"closed_term", - [Genarg.in_gen Constrarg.wit_constr (mkVar(Id.of_string"t")); - Genarg.in_gen (Genarg.wit_list Constrarg.wit_ref) l]))) -*) -let closed_term_ast l = +let closed_term_ast = let tacname = { mltac_plugin = "newring_plugin"; mltac_tactic = "closed_term"; } in + let () = Tacenv.register_ml_tactic tacname [|closed_term|] in let tacname = { mltac_name = tacname; mltac_index = 0; } in + fun l -> let l = List.map (fun gr -> ArgArg(Loc.tag gr)) l in TacFun([Name(Id.of_string"t")], - TacML(Loc.tag (tacname, + TacML(CAst.make (tacname, [TacGeneric (Genarg.in_gen (Genarg.glbwit Stdarg.wit_constr) (DAst.make @@ GVar(Id.of_string"t"),None)); TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Stdarg.wit_ref)) l)]))) (* @@ -154,9 +151,8 @@ let ic_unsafe c = (*FIXME remove *) let decl_constant na univs c = let open Constr in - let env = Global.env () in - let vars = Univops.universes_of_constr env c in - let univs = Univops.restrict_universe_context univs vars in + let vars = CVars.universes_of_constr c in + let univs = UState.restrict_universe_context univs vars in let univs = Monomorphic_const_entry univs in mkConst(declare_constant (Id.of_string na) (DefinitionEntry (definition_entry ~opaque:true ~univs c), @@ -164,30 +160,15 @@ let decl_constant na univs c = (* Calling a global tactic *) let ltac_call tac (args:glob_tactic_arg list) = - TacArg(Loc.tag @@ TacCall (Loc.tag (ArgArg(Loc.tag @@ Lazy.force tac),args))) - -(* Calling a locally bound tactic *) -let ltac_lcall tac args = - TacArg(Loc.tag @@ TacCall (Loc.tag (ArgVar CAst.(make @@ Id.of_string tac),args))) - -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 CAst.(make 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) + TacArg(CAst.make @@ TacCall (CAst.make (ArgArg(Loc.tag @@ Lazy.force tac),args))) let dummy_goal env sigma = let (gl,_,sigma) = - Goal.V82.mk_goal sigma (named_context_val env) EConstr.mkProp Evd.Store.empty in + Goal.V82.mk_goal sigma (named_context_val env) EConstr.mkProp in {Evd.it = gl; Evd.sigma = sigma} -let constr_of v = match Value.to_constr v with - | Some c -> EConstr.Unsafe.to_constr c +let constr_of evd v = match Value.to_constr v with + | Some c -> EConstr.to_constr evd c | None -> failwith "Ring.exec_tactic: anomaly" let tactic_res = ref [||] @@ -216,40 +197,32 @@ let exec_tactic env evd n f args = (** Build the getter *) let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in let n = Genarg.in_gen (Genarg.glbwit Stdarg.wit_int) n in - let get_res = TacML (Loc.tag (get_res, [TacGeneric n])) in + let get_res = TacML (CAst.make (get_res, [TacGeneric n])) in let getter = Tacexp (TacFun (List.map (fun n -> Name n) lid, get_res)) in (** Evaluate the whole result *) let gl = dummy_goal env evd 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 - let nf c = nf (constr_of c) in + let evd = Evd.minimize_universes (Refiner.project gls) in + let nf c = constr_of evd c in Array.map nf !tactic_res, Evd.universe_context_set evd -let stdlib_modules = - [["Coq";"Setoids";"Setoid"]; - ["Coq";"Lists";"List"]; - ["Coq";"Init";"Datatypes"]; - ["Coq";"Init";"Logic"]; - ] +let gen_constant n = lazy (EConstr.of_constr (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref n))) +let gen_reference n = lazy (Coqlib.lib_ref n) -let coq_constant c = - lazy (EConstr.of_constr (Universes.constr_of_global @@ Coqlib.gen_reference_in_modules "Ring" stdlib_modules c)) -let coq_reference c = - lazy (Coqlib.gen_reference_in_modules "Ring" stdlib_modules c) +let coq_mk_Setoid = gen_constant "plugins.setoid_ring.Build_Setoid_Theory" +let coq_None = gen_reference "core.option.None" +let coq_Some = gen_reference "core.option.Some" +let coq_eq = gen_constant "core.eq.type" -let coq_mk_Setoid = coq_constant "Build_Setoid_Theory" -let coq_None = coq_reference "None" -let coq_Some = coq_reference "Some" -let coq_eq = coq_constant "eq" - -let coq_cons = coq_reference "cons" -let coq_nil = coq_reference "nil" +let coq_cons = gen_reference "core.list.cons" +let coq_nil = gen_reference "core.list.nil" let lapp f args = mkApp(Lazy.force f,args) -let plapp evd f args = - let fc = Evarutil.e_new_global evd (Lazy.force f) in - mkApp(fc,args) +let plapp evdref f args = + let evd, fc = Evarutil.new_global !evdref (Lazy.force f) in + evdref := evd; + mkApp(fc,args) let dest_rel0 sigma t = match EConstr.kind sigma t with @@ -278,17 +251,19 @@ let plugin_modules = ] let my_constant c = - lazy (EConstr.of_constr (Universes.constr_of_global @@ Coqlib.gen_reference_in_modules "Ring" plugin_modules c)) + lazy (EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.gen_reference_in_modules "Ring" plugin_modules c)) + [@@ocaml.warning "-3"] let my_reference c = lazy (Coqlib.gen_reference_in_modules "Ring" plugin_modules c) + [@@ocaml.warning "-3"] let znew_ring_path = DirPath.make (List.map Id.of_string ["InitialRing";plugin_dir;"Coq"]) let zltac s = - lazy(KerName.make (ModPath.MPfile znew_ring_path) DirPath.empty (Label.make s)) + lazy(KerName.make (ModPath.MPfile znew_ring_path) (Label.make s)) -let mk_cst l s = lazy (Coqlib.coq_reference "newring" l s);; -let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s ;; +let mk_cst l s = lazy (Coqlib.coq_reference "newring" l s) [@@ocaml.warning "-3"] +let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s (* Ring theory *) @@ -504,10 +479,12 @@ let ring_equality env evd (r,add,mul,opp,req) = let op_morph = 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.e_solve_evars env evd setoid in - let op_morph = Typing.e_solve_evars env evd op_morph in - (setoid,op_morph) + | None -> plapp evd coq_eq_smorph [|r;add;mul|] in + let sigma = !evd in + let sigma, setoid = Typing.solve_evars env sigma setoid in + let sigma, op_morph = Typing.solve_evars env sigma op_morph in + evd := sigma; + (setoid,op_morph) | _ -> let setoid = setoid_of_relation (Global.env ()) evd r req in let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in @@ -580,54 +557,59 @@ let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac = closed_term_ast (List.map Smartlocate.global_with_alias lc) | None -> let t = ArgArg(Loc.tag @@ Lazy.force ltac_inv_morph_nothing) in - TacArg(Loc.tag (TacCall(Loc.tag (t,[])))) + TacArg(CAst.make (TacCall(CAst.make (t,[])))) let make_hyp env evd c = let t = Retyping.get_type_of env !evd c in plapp evd coq_mkhypo [|t;c|] -let make_hyp_list env evd lH = - let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in +let make_hyp_list env evdref lH = + let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in + evdref := evd; let l = List.fold_right - (fun c l -> plapp evd coq_cons [|carrier; (make_hyp env evd c); l|]) lH - (plapp evd coq_nil [|carrier|]) + (fun c l -> plapp evdref coq_cons [|carrier; (make_hyp env evdref c); l|]) lH + (plapp evdref coq_nil [|carrier|]) in - let l' = Typing.e_solve_evars env evd l in + let sigma, l' = Typing.solve_evars env !evdref l in + evdref := sigma; let l' = EConstr.Unsafe.to_constr l' in - Evarutil.nf_evars_universes !evd l' + Evarutil.nf_evars_universes !evdref l' -let interp_power env evd pow = - let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in +let interp_power env evdref pow = + let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in + evdref := evd; match pow with | None -> let t = ArgArg(Loc.tag (Lazy.force ltac_inv_morph_nothing)) in - (TacArg(Loc.tag (TacCall(Loc.tag (t,[])))), plapp evd coq_None [|carrier|]) + (TacArg(CAst.make (TacCall(CAst.make (t,[])))), plapp evdref coq_None [|carrier|]) | Some (tac, spec) -> let tac = match tac with | CstTac t -> Tacintern.glob_tactic t | Closed lc -> closed_term_ast (List.map Smartlocate.global_with_alias lc) in - let spec = make_hyp env evd (ic_unsafe spec) in - (tac, plapp evd coq_Some [|carrier; spec|]) + let spec = make_hyp env evdref (ic_unsafe spec) in + (tac, plapp evdref coq_Some [|carrier; spec|]) -let interp_sign env evd sign = - let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in +let interp_sign env evdref sign = + let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in + evdref := evd; match sign with - | None -> plapp evd coq_None [|carrier|] + | None -> plapp evdref coq_None [|carrier|] | Some spec -> - let spec = make_hyp env evd (ic_unsafe spec) in - plapp evd coq_Some [|carrier;spec|] + let spec = make_hyp env evdref (ic_unsafe spec) in + plapp evdref coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) -let interp_div env evd div = - let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in +let interp_div env evdref div = + let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in + evdref := evd; match div with - | None -> plapp evd coq_None [|carrier|] + | None -> plapp evdref coq_None [|carrier|] | Some spec -> - let spec = make_hyp env evd (ic_unsafe spec) in - plapp evd coq_Some [|carrier;spec|] + let spec = make_hyp env evdref (ic_unsafe spec) in + plapp evdref coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) let add_theory0 name (sigma, rth) eqth morphth cst_tac (pre,post) power sign div = @@ -728,7 +710,9 @@ 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.e_solve_evars env evd l + in + let sigma, l = Typing.solve_evars env !evd l in + evd := sigma; l let carg c = Tacinterp.Value.of_constr (EConstr.of_constr c) let tacarg expr = @@ -760,7 +744,7 @@ let ring_lookup (f : Value.t) lH rl t = let rl = Value.of_constr (make_term_list env evdref (EConstr.of_constr e.ring_carrier) rl) in let lH = carg (make_hyp_list env evdref lH) in let ring = ltac_ring_structure e in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (ring@[lH;rl])) + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Value.apply f (ring@[lH;rl])) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end @@ -770,7 +754,7 @@ let new_field_path = DirPath.make (List.map Id.of_string ["Field_tac";plugin_dir;"Coq"]) let field_ltac s = - lazy(KerName.make (ModPath.MPfile new_field_path) DirPath.empty (Label.make s)) + lazy(KerName.make (ModPath.MPfile new_field_path) (Label.make s)) let _ = add_map "field" @@ -917,7 +901,7 @@ let ftheory_to_obj : field_info -> obj = let field_equality evd r inv req = match EConstr.kind !evd req with | App (f, [| _ |]) when eq_constr_nounivs !evd f (Lazy.force coq_eq) -> - let c = Universes.constr_of_global (Coqlib.build_coq_eq_data()).congr in + let c = UnivGen.constr_of_monomorphic_global Coqlib.(lib_ref "core.eq.congr") in let c = EConstr.of_constr c in mkApp(c,[|r;r;inv|]) | _ -> @@ -1046,6 +1030,6 @@ let field_lookup (f : Value.t) lH rl t = let rl = Value.of_constr (make_term_list env evdref (EConstr.of_constr e.field_carrier) rl) in let lH = carg (make_hyp_list env evdref lH) in let field = ltac_field_structure e in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (field@[lH;rl])) + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Value.apply f (field@[lH;rl])) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end diff --git a/plugins/setoid_ring/newring.mli b/plugins/setoid_ring/newring.mli index 1d1557b12f..fcd04a2e73 100644 --- a/plugins/setoid_ring/newring.mli +++ b/plugins/setoid_ring/newring.mli @@ -11,7 +11,6 @@ open Names open EConstr open Libnames -open Globnames open Constrexpr open Newring_ast @@ -19,8 +18,6 @@ val protect_tac_in : string -> Id.t -> unit Proofview.tactic val protect_tac : string -> unit Proofview.tactic -val closed_term : EConstr.constr -> global_reference list -> unit Proofview.tactic - val add_theory : Id.t -> constr_expr -> diff --git a/plugins/setoid_ring/newring_ast.ml b/plugins/setoid_ring/newring_ast.ml index 3eb68b5189..a83c79d11b 100644 --- a/plugins/setoid_ring/newring_ast.ml +++ b/plugins/setoid_ring/newring_ast.ml @@ -22,7 +22,7 @@ type 'constr coeff_spec = type cst_tac_spec = CstTac of raw_tactic_expr - | Closed of reference list + | Closed of qualid list type 'constr ring_mod = Ring_kind of 'constr coeff_spec diff --git a/plugins/setoid_ring/newring_ast.mli b/plugins/setoid_ring/newring_ast.mli index 3eb68b5189..a83c79d11b 100644 --- a/plugins/setoid_ring/newring_ast.mli +++ b/plugins/setoid_ring/newring_ast.mli @@ -22,7 +22,7 @@ type 'constr coeff_spec = type cst_tac_spec = CstTac of raw_tactic_expr - | Closed of reference list + | Closed of qualid list type 'constr ring_mod = Ring_kind of 'constr coeff_spec diff --git a/plugins/setoid_ring/plugin_base.dune b/plugins/setoid_ring/plugin_base.dune new file mode 100644 index 0000000000..d83857edad --- /dev/null +++ b/plugins/setoid_ring/plugin_base.dune @@ -0,0 +1,5 @@ +(library + (name newring_plugin) + (public_name coq.plugins.setoid_ring) + (synopsis "Coq's setoid ring plugin") + (libraries coq.plugins.ltac)) diff --git a/plugins/ssr/plugin_base.dune b/plugins/ssr/plugin_base.dune new file mode 100644 index 0000000000..a13524bb52 --- /dev/null +++ b/plugins/ssr/plugin_base.dune @@ -0,0 +1,7 @@ +(library + (name ssreflect_plugin) + (public_name coq.plugins.ssreflect) + (synopsis "Coq's ssreflect plugin") + (modules_without_implementation ssrast) + (flags :standard -open Gramlib) + (libraries coq.plugins.ssrmatching)) diff --git a/plugins/ssr/ssrast.mli b/plugins/ssr/ssrast.mli index 7f5f2f63d7..a786b9953d 100644 --- a/plugins/ssr/ssrast.mli +++ b/plugins/ssr/ssrast.mli @@ -37,7 +37,7 @@ type ssrmult = int * ssrmmod type ssrocc = (bool * int list) option (* index MAYBE REMOVE ONLY INTERNAL stuff between {} *) -type ssrindex = int Misctypes.or_var +type ssrindex = int Locus.or_var (* clear switch {H G} *) type ssrclear = ssrhyps @@ -84,11 +84,11 @@ type ssripat = | IPatId of (*TODO id_mod option * *) Id.t | IPatAnon of anon_iter (* inaccessible name *) (* TODO | IPatClearMark *) - | IPatDispatch of ssripatss (* /[..|..] *) + | IPatDispatch of bool (* ssr exception: accept a dispatch on the empty list even when there are subgoals *) * ssripatss (* (..|..) *) | IPatCase of (* ipats_mod option * *) ssripatss (* this is not equivalent to /case /[..|..] if there are already multiple goals *) | IPatInj of ssripatss | IPatRewrite of (*occurrence option * rewrite_pattern **) ssrocc * ssrdir - | IPatView of ssrview (* /view *) + | IPatView of bool * ssrview (* {}/view (true if the clear is present) *) | IPatClear of ssrclear (* {H1 H2} *) | IPatSimpl of ssrsimpl | IPatAbstractVars of Id.t list diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v index 7d05b64384..3a7cf41d43 100644 --- a/plugins/ssr/ssrbool.v +++ b/plugins/ssr/ssrbool.v @@ -10,264 +10,266 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(** #<style> .doc { font-family: monospace; white-space: pre; } </style># **) + Require Bool. Require Import ssreflect ssrfun. -(******************************************************************************) -(* A theory of boolean predicates and operators. A large part of this file is *) -(* concerned with boolean reflection. *) -(* Definitions and notations: *) -(* is_true b == the coercion of b : bool to Prop (:= b = true). *) -(* This is just input and displayed as `b''. *) -(* reflect P b == the reflection inductive predicate, asserting *) -(* that the logical proposition P : prop with the *) -(* formula b : bool. Lemmas asserting reflect P b *) -(* are often referred to as "views". *) -(* iffP, appP, sameP, rwP :: lemmas for direct manipulation of reflection *) -(* views: iffP is used to prove reflection from *) -(* logical equivalence, appP to compose views, and *) -(* sameP and rwP to perform boolean and setoid *) -(* rewriting. *) -(* elimT :: coercion reflect >-> Funclass, which allows the *) -(* direct application of `reflect' views to *) -(* boolean assertions. *) -(* decidable P <-> P is effectively decidable (:= {P} + {~ P}. *) -(* contra, contraL, ... :: contraposition lemmas. *) -(* altP my_viewP :: natural alternative for reflection; given *) -(* lemma myviewP: reflect my_Prop my_formula, *) -(* have [myP | not_myP] := altP my_viewP. *) -(* generates two subgoals, in which my_formula has *) -(* been replaced by true and false, resp., with *) -(* new assumptions myP : my_Prop and *) -(* not_myP: ~~ my_formula. *) -(* Caveat: my_formula must be an APPLICATION, not *) -(* a variable, constant, let-in, etc. (due to the *) -(* poor behaviour of dependent index matching). *) -(* boolP my_formula :: boolean disjunction, equivalent to *) -(* altP (idP my_formula) but circumventing the *) -(* dependent index capture issue; destructing *) -(* boolP my_formula generates two subgoals with *) -(* assumtions my_formula and ~~ myformula. As *) -(* with altP, my_formula must be an application. *) -(* \unless C, P <-> we can assume property P when a something that *) -(* holds under condition C (such as C itself). *) -(* := forall G : Prop, (C -> G) -> (P -> G) -> G. *) -(* This is just C \/ P or rather its impredicative *) -(* encoding, whose usage better fits the above *) -(* description: given a lemma UCP whose conclusion *) -(* is \unless C, P we can assume P by writing: *) -(* wlog hP: / P by apply/UCP; (prove C -> goal). *) -(* or even apply: UCP id _ => hP if the goal is C. *) -(* classically P <-> we can assume P when proving is_true b. *) -(* := forall b : bool, (P -> b) -> b. *) -(* This is equivalent to ~ (~ P) when P : Prop. *) -(* implies P Q == wrapper coinductive type that coerces to P -> Q *) -(* and can be used as a P -> Q view unambigously. *) -(* Useful to avoid spurious insertion of <-> views *) -(* when Q is a conjunction of foralls, as in Lemma *) -(* all_and2 below; conversely, avoids confusion in *) -(* apply views for impredicative properties, such *) -(* as \unless C, P. Also supports contrapositives. *) -(* a && b == the boolean conjunction of a and b. *) -(* a || b == the boolean disjunction of a and b. *) -(* a ==> b == the boolean implication of b by a. *) -(* ~~ a == the boolean negation of a. *) -(* a (+) b == the boolean exclusive or (or sum) of a and b. *) -(* [ /\ P1 , P2 & P3 ] == multiway logical conjunction, up to 5 terms. *) -(* [ \/ P1 , P2 | P3 ] == multiway logical disjunction, up to 4 terms. *) -(* [&& a, b, c & d] == iterated, right associative boolean conjunction *) -(* with arbitrary arity. *) -(* [|| a, b, c | d] == iterated, right associative boolean disjunction *) -(* with arbitrary arity. *) -(* [==> a, b, c => d] == iterated, right associative boolean implication *) -(* with arbitrary arity. *) -(* and3P, ... == specific reflection lemmas for iterated *) -(* connectives. *) -(* andTb, orbAC, ... == systematic names for boolean connective *) -(* properties (see suffix conventions below). *) -(* prop_congr == a tactic to move a boolean equality from *) -(* its coerced form in Prop to the equality *) -(* in bool. *) -(* bool_congr == resolution tactic for blindly weeding out *) -(* like terms from boolean equalities (can fail). *) -(* This file provides a theory of boolean predicates and relations: *) -(* pred T == the type of bool predicates (:= T -> bool). *) -(* simpl_pred T == the type of simplifying bool predicates, using *) -(* the simpl_fun from ssrfun.v. *) -(* rel T == the type of bool relations. *) -(* := T -> pred T or T -> T -> bool. *) -(* simpl_rel T == type of simplifying relations. *) -(* predType == the generic predicate interface, supported for *) -(* for lists and sets. *) -(* pred_class == a coercion class for the predType projection to *) -(* pred; declaring a coercion to pred_class is an *) -(* alternative way of equipping a type with a *) -(* predType structure, which interoperates better *) -(* with coercion subtyping. This is used, e.g., *) -(* for finite sets, so that finite groups inherit *) -(* the membership operation by coercing to sets. *) -(* If P is a predicate the proposition "x satisfies P" can be written *) -(* applicatively as (P x), or using an explicit connective as (x \in P); in *) -(* the latter case we say that P is a "collective" predicate. We use A, B *) -(* rather than P, Q for collective predicates: *) -(* x \in A == x satisfies the (collective) predicate A. *) -(* x \notin A == x doesn't satisfy the (collective) predicate A. *) -(* The pred T type can be used as a generic predicate type for either kind, *) -(* but the two kinds of predicates should not be confused. When a "generic" *) -(* pred T value of one type needs to be passed as the other the following *) -(* conversions should be used explicitly: *) -(* SimplPred P == a (simplifying) applicative equivalent of P. *) -(* mem A == an applicative equivalent of A: *) -(* mem A x simplifies to x \in A. *) -(* Alternatively one can use the syntax for explicit simplifying predicates *) -(* and relations (in the following x is bound in E): *) -(* [pred x | E] == simplifying (see ssrfun) predicate x => E. *) -(* [pred x : T | E] == predicate x => E, with a cast on the argument. *) -(* [pred : T | P] == constant predicate P on type T. *) -(* [pred x | E1 & E2] == [pred x | E1 && E2]; an x : T cast is allowed. *) -(* [pred x in A] == [pred x | x in A]. *) -(* [pred x in A | E] == [pred x | x in A & E]. *) -(* [pred x in A | E1 & E2] == [pred x in A | E1 && E2]. *) -(* [predU A & B] == union of two collective predicates A and B. *) -(* [predI A & B] == intersection of collective predicates A and B. *) -(* [predD A & B] == difference of collective predicates A and B. *) -(* [predC A] == complement of the collective predicate A. *) -(* [preim f of A] == preimage under f of the collective predicate A. *) -(* predU P Q, ... == union, etc of applicative predicates. *) -(* pred0 == the empty predicate. *) -(* predT == the total (always true) predicate. *) -(* if T : predArgType, then T coerces to predT. *) -(* {: T} == T cast to predArgType (e.g., {: bool * nat}) *) -(* In the following, x and y are bound in E: *) -(* [rel x y | E] == simplifying relation x, y => E. *) -(* [rel x y : T | E] == simplifying relation with arguments cast. *) -(* [rel x y in A & B | E] == [rel x y | [&& x \in A, y \in B & E]]. *) -(* [rel x y in A & B] == [rel x y | (x \in A) && (y \in B)]. *) -(* [rel x y in A | E] == [rel x y in A & A | E]. *) -(* [rel x y in A] == [rel x y in A & A]. *) -(* relU R S == union of relations R and S. *) -(* Explicit values of type pred T (i.e., lamdba terms) should always be used *) -(* applicatively, while values of collection types implementing the predType *) -(* interface, such as sequences or sets should always be used as collective *) -(* predicates. Defined constants and functions of type pred T or simpl_pred T *) -(* as well as the explicit simpl_pred T values described below, can generally *) -(* be used either way. Note however that x \in A will not auto-simplify when *) -(* A is an explicit simpl_pred T value; the generic simplification rule inE *) -(* must be used (when A : pred T, the unfold_in rule can be used). Constants *) -(* of type pred T with an explicit simpl_pred value do not auto-simplify when *) -(* used applicatively, but can still be expanded with inE. This behavior can *) -(* be controlled as follows: *) -(* Let A : collective_pred T := [pred x | ... ]. *) -(* The collective_pred T type is just an alias for pred T, but this cast *) -(* stops rewrite inE from expanding the definition of A, thus treating A *) -(* into an abstract collection (unfold_in or in_collective can be used to *) -(* expand manually). *) -(* Let A : applicative_pred T := [pred x | ...]. *) -(* This cast causes inE to turn x \in A into the applicative A x form; *) -(* A will then have to unfolded explicitly with the /A rule. This will *) -(* also apply to any definition that reduces to A (e.g., Let B := A). *) -(* Canonical A_app_pred := ApplicativePred A. *) -(* This declaration, given after definition of A, similarly causes inE to *) -(* turn x \in A into A x, but in addition allows the app_predE rule to *) -(* turn A x back into x \in A; it can be used for any definition of type *) -(* pred T, which makes it especially useful for ambivalent predicates *) -(* as the relational transitive closure connect, that are used in both *) -(* applicative and collective styles. *) -(* Purely for aesthetics, we provide a subtype of collective predicates: *) -(* qualifier q T == a pred T pretty-printing wrapper. An A : qualifier q T *) -(* coerces to pred_class and thus behaves as a collective *) -(* predicate, but x \in A and x \notin A are displayed as: *) -(* x \is A and x \isn't A when q = 0, *) -(* x \is a A and x \isn't a A when q = 1, *) -(* x \is an A and x \isn't an A when q = 2, respectively. *) -(* [qualify x | P] := Qualifier 0 (fun x => P), constructor for the above. *) -(* [qualify x : T | P], [qualify a x | P], [qualify an X | P], etc. *) -(* variants of the above with type constraints and different *) -(* values of q. *) -(* We provide an internal interface to support attaching properties (such as *) -(* being multiplicative) to predicates: *) -(* pred_key p == phantom type that will serve as a support for properties *) -(* to be attached to p : pred_class; instances should be *) -(* created with Fact/Qed so as to be opaque. *) -(* KeyedPred k_p == an instance of the interface structure that attaches *) -(* (k_p : pred_key P) to P; the structure projection is a *) -(* coercion to pred_class. *) -(* KeyedQualifier k_q == an instance of the interface structure that attaches *) -(* (k_q : pred_key q) to (q : qualifier n T). *) -(* DefaultPredKey p == a default value for pred_key p; the vernacular command *) -(* Import DefaultKeying attaches this key to all predicates *) -(* that are not explicitly keyed. *) -(* Keys can be used to attach properties to predicates, qualifiers and *) -(* generic nouns in a way that allows them to be used transparently. The key *) -(* projection of a predicate property structure such as unsignedPred should *) -(* be a pred_key, not a pred, and corresponding lemmas will have the form *) -(* Lemma rpredN R S (oppS : @opprPred R S) (kS : keyed_pred oppS) : *) -(* {mono -%R: x / x \in kS}. *) -(* Because x \in kS will be displayed as x \in S (or x \is S, etc), the *) -(* canonical instance of opprPred will not normally be exposed (it will also *) -(* be erased by /= simplification). In addition each predicate structure *) -(* should have a DefaultPredKey Canonical instance that simply issues the *) -(* property as a proof obligation (which can be caught by the Prop-irrelevant *) -(* feature of the ssreflect plugin). *) -(* Some properties of predicates and relations: *) -(* A =i B <-> A and B are extensionally equivalent. *) -(* {subset A <= B} <-> A is a (collective) subpredicate of B. *) -(* subpred P Q <-> P is an (applicative) subpredicate or Q. *) -(* subrel R S <-> R is a subrelation of S. *) -(* In the following R is in rel T: *) -(* reflexive R <-> R is reflexive. *) -(* irreflexive R <-> R is irreflexive. *) -(* symmetric R <-> R (in rel T) is symmetric (equation). *) -(* pre_symmetric R <-> R is symmetric (implication). *) -(* antisymmetric R <-> R is antisymmetric. *) -(* total R <-> R is total. *) -(* transitive R <-> R is transitive. *) -(* left_transitive R <-> R is a congruence on its left hand side. *) -(* right_transitive R <-> R is a congruence on its right hand side. *) -(* equivalence_rel R <-> R is an equivalence relation. *) -(* Localization of (Prop) predicates; if P1 is convertible to forall x, Qx, *) -(* P2 to forall x y, Qxy and P3 to forall x y z, Qxyz : *) -(* {for y, P1} <-> Qx{y / x}. *) -(* {in A, P1} <-> forall x, x \in A -> Qx. *) -(* {in A1 & A2, P2} <-> forall x y, x \in A1 -> y \in A2 -> Qxy. *) -(* {in A &, P2} <-> forall x y, x \in A -> y \in A -> Qxy. *) -(* {in A1 & A2 & A3, Q3} <-> forall x y z, *) -(* x \in A1 -> y \in A2 -> z \in A3 -> Qxyz. *) -(* {in A1 & A2 &, Q3} == {in A1 & A2 & A2, Q3}. *) -(* {in A1 && A3, Q3} == {in A1 & A1 & A3, Q3}. *) -(* {in A &&, Q3} == {in A & A & A, Q3}. *) -(* {in A, bijective f} == f has a right inverse in A. *) -(* {on C, P1} == forall x, (f x) \in C -> Qx *) -(* when P1 is also convertible to Pf f. *) -(* {on C &, P2} == forall x y, f x \in C -> f y \in C -> Qxy *) -(* when P2 is also convertible to Pf f. *) -(* {on C, P1' & g} == forall x, (f x) \in cd -> Qx *) -(* when P1' is convertible to Pf f *) -(* and P1' g is convertible to forall x, Qx. *) -(* {on C, bijective f} == f has a right inverse on C. *) -(* This file extends the lemma name suffix conventions of ssrfun as follows: *) -(* A -- associativity, as in andbA : associative andb. *) -(* AC -- right commutativity. *) -(* ACA -- self-interchange (inner commutativity), e.g., *) -(* orbACA : (a || b) || (c || d) = (a || c) || (b || d). *) -(* b -- a boolean argument, as in andbb : idempotent andb. *) -(* C -- commutativity, as in andbC : commutative andb, *) -(* or predicate complement, as in predC. *) -(* CA -- left commutativity. *) -(* D -- predicate difference, as in predD. *) -(* E -- elimination, as in negbFE : ~~ b = false -> b. *) -(* F or f -- boolean false, as in andbF : b && false = false. *) -(* I -- left/right injectivity, as in addbI : right_injective addb, *) -(* or predicate intersection, as in predI. *) -(* l -- a left-hand operation, as andb_orl : left_distributive andb orb. *) -(* N or n -- boolean negation, as in andbN : a && (~~ a) = false. *) -(* P -- a characteristic property, often a reflection lemma, as in *) -(* andP : reflect (a /\ b) (a && b). *) -(* r -- a right-hand operation, as orb_andr : rightt_distributive orb andb. *) -(* T or t -- boolean truth, as in andbT: right_id true andb. *) -(* U -- predicate union, as in predU. *) -(* W -- weakening, as in in1W : {in D, forall x, P} -> forall x, P. *) -(******************************************************************************) +(** + A theory of boolean predicates and operators. A large part of this file is + concerned with boolean reflection. + Definitions and notations: + is_true b == the coercion of b : bool to Prop (:= b = true). + This is just input and displayed as `b''. + reflect P b == the reflection inductive predicate, asserting + that the logical proposition P : prop with the + formula b : bool. Lemmas asserting reflect P b + are often referred to as "views". + iffP, appP, sameP, rwP :: lemmas for direct manipulation of reflection + views: iffP is used to prove reflection from + logical equivalence, appP to compose views, and + sameP and rwP to perform boolean and setoid + rewriting. + elimT :: coercion reflect >-> Funclass, which allows the + direct application of `reflect' views to + boolean assertions. + decidable P <-> P is effectively decidable (:= {P} + {~ P}. + contra, contraL, ... :: contraposition lemmas. + altP my_viewP :: natural alternative for reflection; given + lemma myviewP: reflect my_Prop my_formula, + have #[#myP | not_myP#]# := altP my_viewP. + generates two subgoals, in which my_formula has + been replaced by true and false, resp., with + new assumptions myP : my_Prop and + not_myP: ~~ my_formula. + Caveat: my_formula must be an APPLICATION, not + a variable, constant, let-in, etc. (due to the + poor behaviour of dependent index matching). + boolP my_formula :: boolean disjunction, equivalent to + altP (idP my_formula) but circumventing the + dependent index capture issue; destructing + boolP my_formula generates two subgoals with + assumtions my_formula and ~~ myformula. As + with altP, my_formula must be an application. + \unless C, P <-> we can assume property P when a something that + holds under condition C (such as C itself). + := forall G : Prop, (C -> G) -> (P -> G) -> G. + This is just C \/ P or rather its impredicative + encoding, whose usage better fits the above + description: given a lemma UCP whose conclusion + is \unless C, P we can assume P by writing: + wlog hP: / P by apply/UCP; (prove C -> goal). + or even apply: UCP id _ => hP if the goal is C. + classically P <-> we can assume P when proving is_true b. + := forall b : bool, (P -> b) -> b. + This is equivalent to ~ (~ P) when P : Prop. + implies P Q == wrapper variant type that coerces to P -> Q and + can be used as a P -> Q view unambigously. + Useful to avoid spurious insertion of <-> views + when Q is a conjunction of foralls, as in Lemma + all_and2 below; conversely, avoids confusion in + apply views for impredicative properties, such + as \unless C, P. Also supports contrapositives. + a && b == the boolean conjunction of a and b. + a || b == the boolean disjunction of a and b. + a ==> b == the boolean implication of b by a. + ~~ a == the boolean negation of a. + a (+) b == the boolean exclusive or (or sum) of a and b. + #[# /\ P1 , P2 & P3 #]# == multiway logical conjunction, up to 5 terms. + #[# \/ P1 , P2 | P3 #]# == multiway logical disjunction, up to 4 terms. + #[#&& a, b, c & d#]# == iterated, right associative boolean conjunction + with arbitrary arity. + #[#|| a, b, c | d#]# == iterated, right associative boolean disjunction + with arbitrary arity. + #[#==> a, b, c => d#]# == iterated, right associative boolean implication + with arbitrary arity. + and3P, ... == specific reflection lemmas for iterated + connectives. + andTb, orbAC, ... == systematic names for boolean connective + properties (see suffix conventions below). + prop_congr == a tactic to move a boolean equality from + its coerced form in Prop to the equality + in bool. + bool_congr == resolution tactic for blindly weeding out + like terms from boolean equalities (can fail). + This file provides a theory of boolean predicates and relations: + pred T == the type of bool predicates (:= T -> bool). + simpl_pred T == the type of simplifying bool predicates, using + the simpl_fun from ssrfun.v. + rel T == the type of bool relations. + := T -> pred T or T -> T -> bool. + simpl_rel T == type of simplifying relations. + predType == the generic predicate interface, supported for + for lists and sets. + pred_class == a coercion class for the predType projection to + pred; declaring a coercion to pred_class is an + alternative way of equipping a type with a + predType structure, which interoperates better + with coercion subtyping. This is used, e.g., + for finite sets, so that finite groups inherit + the membership operation by coercing to sets. + If P is a predicate the proposition "x satisfies P" can be written + applicatively as (P x), or using an explicit connective as (x \in P); in + the latter case we say that P is a "collective" predicate. We use A, B + rather than P, Q for collective predicates: + x \in A == x satisfies the (collective) predicate A. + x \notin A == x doesn't satisfy the (collective) predicate A. + The pred T type can be used as a generic predicate type for either kind, + but the two kinds of predicates should not be confused. When a "generic" + pred T value of one type needs to be passed as the other the following + conversions should be used explicitly: + SimplPred P == a (simplifying) applicative equivalent of P. + mem A == an applicative equivalent of A: + mem A x simplifies to x \in A. + Alternatively one can use the syntax for explicit simplifying predicates + and relations (in the following x is bound in E): + #[#pred x | E#]# == simplifying (see ssrfun) predicate x => E. + #[#pred x : T | E#]# == predicate x => E, with a cast on the argument. + #[#pred : T | P#]# == constant predicate P on type T. + #[#pred x | E1 & E2#]# == #[#pred x | E1 && E2#]#; an x : T cast is allowed. + #[#pred x in A#]# == #[#pred x | x in A#]#. + #[#pred x in A | E#]# == #[#pred x | x in A & E#]#. + #[#pred x in A | E1 & E2#]# == #[#pred x in A | E1 && E2#]#. + #[#predU A & B#]# == union of two collective predicates A and B. + #[#predI A & B#]# == intersection of collective predicates A and B. + #[#predD A & B#]# == difference of collective predicates A and B. + #[#predC A#]# == complement of the collective predicate A. + #[#preim f of A#]# == preimage under f of the collective predicate A. + predU P Q, ... == union, etc of applicative predicates. + pred0 == the empty predicate. + predT == the total (always true) predicate. + if T : predArgType, then T coerces to predT. + {: T} == T cast to predArgType (e.g., {: bool * nat}) + In the following, x and y are bound in E: + #[#rel x y | E#]# == simplifying relation x, y => E. + #[#rel x y : T | E#]# == simplifying relation with arguments cast. + #[#rel x y in A & B | E#]# == #[#rel x y | #[#&& x \in A, y \in B & E#]# #]#. + #[#rel x y in A & B#]# == #[#rel x y | (x \in A) && (y \in B) #]#. + #[#rel x y in A | E#]# == #[#rel x y in A & A | E#]#. + #[#rel x y in A#]# == #[#rel x y in A & A#]#. + relU R S == union of relations R and S. + Explicit values of type pred T (i.e., lamdba terms) should always be used + applicatively, while values of collection types implementing the predType + interface, such as sequences or sets should always be used as collective + predicates. Defined constants and functions of type pred T or simpl_pred T + as well as the explicit simpl_pred T values described below, can generally + be used either way. Note however that x \in A will not auto-simplify when + A is an explicit simpl_pred T value; the generic simplification rule inE + must be used (when A : pred T, the unfold_in rule can be used). Constants + of type pred T with an explicit simpl_pred value do not auto-simplify when + used applicatively, but can still be expanded with inE. This behavior can + be controlled as follows: + Let A : collective_pred T := #[#pred x | ... #]#. + The collective_pred T type is just an alias for pred T, but this cast + stops rewrite inE from expanding the definition of A, thus treating A + into an abstract collection (unfold_in or in_collective can be used to + expand manually). + Let A : applicative_pred T := #[#pred x | ... #]#. + This cast causes inE to turn x \in A into the applicative A x form; + A will then have to unfolded explicitly with the /A rule. This will + also apply to any definition that reduces to A (e.g., Let B := A). + Canonical A_app_pred := ApplicativePred A. + This declaration, given after definition of A, similarly causes inE to + turn x \in A into A x, but in addition allows the app_predE rule to + turn A x back into x \in A; it can be used for any definition of type + pred T, which makes it especially useful for ambivalent predicates + as the relational transitive closure connect, that are used in both + applicative and collective styles. + Purely for aesthetics, we provide a subtype of collective predicates: + qualifier q T == a pred T pretty-printing wrapper. An A : qualifier q T + coerces to pred_class and thus behaves as a collective + predicate, but x \in A and x \notin A are displayed as: + x \is A and x \isn't A when q = 0, + x \is a A and x \isn't a A when q = 1, + x \is an A and x \isn't an A when q = 2, respectively. + #[#qualify x | P#]# := Qualifier 0 (fun x => P), constructor for the above. + #[#qualify x : T | P#]#, #[#qualify a x | P#]#, #[#qualify an X | P#]#, etc. + variants of the above with type constraints and different + values of q. + We provide an internal interface to support attaching properties (such as + being multiplicative) to predicates: + pred_key p == phantom type that will serve as a support for properties + to be attached to p : pred_class; instances should be + created with Fact/Qed so as to be opaque. + KeyedPred k_p == an instance of the interface structure that attaches + (k_p : pred_key P) to P; the structure projection is a + coercion to pred_class. + KeyedQualifier k_q == an instance of the interface structure that attaches + (k_q : pred_key q) to (q : qualifier n T). + DefaultPredKey p == a default value for pred_key p; the vernacular command + Import DefaultKeying attaches this key to all predicates + that are not explicitly keyed. + Keys can be used to attach properties to predicates, qualifiers and + generic nouns in a way that allows them to be used transparently. The key + projection of a predicate property structure such as unsignedPred should + be a pred_key, not a pred, and corresponding lemmas will have the form + Lemma rpredN R S (oppS : @opprPred R S) (kS : keyed_pred oppS) : + {mono -%%R: x / x \in kS}. + Because x \in kS will be displayed as x \in S (or x \is S, etc), the + canonical instance of opprPred will not normally be exposed (it will also + be erased by /= simplification). In addition each predicate structure + should have a DefaultPredKey Canonical instance that simply issues the + property as a proof obligation (which can be caught by the Prop-irrelevant + feature of the ssreflect plugin). + Some properties of predicates and relations: + A =i B <-> A and B are extensionally equivalent. + {subset A <= B} <-> A is a (collective) subpredicate of B. + subpred P Q <-> P is an (applicative) subpredicate or Q. + subrel R S <-> R is a subrelation of S. + In the following R is in rel T: + reflexive R <-> R is reflexive. + irreflexive R <-> R is irreflexive. + symmetric R <-> R (in rel T) is symmetric (equation). + pre_symmetric R <-> R is symmetric (implication). + antisymmetric R <-> R is antisymmetric. + total R <-> R is total. + transitive R <-> R is transitive. + left_transitive R <-> R is a congruence on its left hand side. + right_transitive R <-> R is a congruence on its right hand side. + equivalence_rel R <-> R is an equivalence relation. + Localization of (Prop) predicates; if P1 is convertible to forall x, Qx, + P2 to forall x y, Qxy and P3 to forall x y z, Qxyz : + {for y, P1} <-> Qx{y / x}. + {in A, P1} <-> forall x, x \in A -> Qx. + {in A1 & A2, P2} <-> forall x y, x \in A1 -> y \in A2 -> Qxy. + {in A &, P2} <-> forall x y, x \in A -> y \in A -> Qxy. + {in A1 & A2 & A3, Q3} <-> forall x y z, + x \in A1 -> y \in A2 -> z \in A3 -> Qxyz. + {in A1 & A2 &, Q3} == {in A1 & A2 & A2, Q3}. + {in A1 && A3, Q3} == {in A1 & A1 & A3, Q3}. + {in A &&, Q3} == {in A & A & A, Q3}. + {in A, bijective f} == f has a right inverse in A. + {on C, P1} == forall x, (f x) \in C -> Qx + when P1 is also convertible to Pf f. + {on C &, P2} == forall x y, f x \in C -> f y \in C -> Qxy + when P2 is also convertible to Pf f. + {on C, P1' & g} == forall x, (f x) \in cd -> Qx + when P1' is convertible to Pf f + and P1' g is convertible to forall x, Qx. + {on C, bijective f} == f has a right inverse on C. + This file extends the lemma name suffix conventions of ssrfun as follows: + A -- associativity, as in andbA : associative andb. + AC -- right commutativity. + ACA -- self-interchange (inner commutativity), e.g., + orbACA : (a || b) || (c || d) = (a || c) || (b || d). + b -- a boolean argument, as in andbb : idempotent andb. + C -- commutativity, as in andbC : commutative andb, + or predicate complement, as in predC. + CA -- left commutativity. + D -- predicate difference, as in predD. + E -- elimination, as in negbFE : ~~ b = false -> b. + F or f -- boolean false, as in andbF : b && false = false. + I -- left/right injectivity, as in addbI : right_injective addb, + or predicate intersection, as in predI. + l -- a left-hand operation, as andb_orl : left_distributive andb orb. + N or n -- boolean negation, as in andbN : a && (~~ a) = false. + P -- a characteristic property, often a reflection lemma, as in + andP : reflect (a /\ b) (a && b). + r -- a right-hand operation, as orb_andr : rightt_distributive orb andb. + T or t -- boolean truth, as in andbT: right_id true andb. + U -- predicate union, as in predU. + W -- weakening, as in in1W : {in D, forall x, P} -> forall x, P. **) + Set Implicit Arguments. Unset Strict Implicit. @@ -288,23 +290,24 @@ Reserved Notation "x \notin A" Reserved Notation "p1 =i p2" (at level 70, format "'[hv' p1 '/ ' =i p2 ']'", no associativity). -(* We introduce a number of n-ary "list-style" notations that share a common *) -(* format, namely *) -(* [op arg1, arg2, ... last_separator last_arg] *) -(* This usually denotes a right-associative applications of op, e.g., *) -(* [&& a, b, c & d] denotes a && (b && (c && d)) *) -(* The last_separator must be a non-operator token. Here we use &, | or =>; *) -(* our default is &, but we try to match the intended meaning of op. The *) -(* separator is a workaround for limitations of the parsing engine; the same *) -(* limitations mean the separator cannot be omitted even when last_arg can. *) -(* The Notation declarations are complicated by the separate treatment for *) -(* some fixed arities (binary for bool operators, and all arities for Prop *) -(* operators). *) -(* We also use the square brackets in comprehension-style notations *) -(* [type var separator expr] *) -(* where "type" is the type of the comprehension (e.g., pred) and "separator" *) -(* is | or => . It is important that in other notations a leading square *) -(* bracket [ is always followed by an operator symbol or a fixed identifier. *) +(** + We introduce a number of n-ary "list-style" notations that share a common + format, namely + #[#op arg1, arg2, ... last_separator last_arg#]# + This usually denotes a right-associative applications of op, e.g., + #[#&& a, b, c & d#]# denotes a && (b && (c && d)) + The last_separator must be a non-operator token. Here we use &, | or =>; + our default is &, but we try to match the intended meaning of op. The + separator is a workaround for limitations of the parsing engine; the same + limitations mean the separator cannot be omitted even when last_arg can. + The Notation declarations are complicated by the separate treatment for + some fixed arities (binary for bool operators, and all arities for Prop + operators). + We also use the square brackets in comprehension-style notations + #[#type var separator expr#]# + where "type" is the type of the comprehension (e.g., pred) and "separator" + is | or => . It is important that in other notations a leading square + bracket #[# is always followed by an operator symbol or a fixed identifier. **) Reserved Notation "[ /\ P1 & P2 ]" (at level 0, only parsing). Reserved Notation "[ /\ P1 , P2 & P3 ]" (at level 0, format @@ -344,19 +347,19 @@ Reserved Notation "[ 'rel' x y => E ]" (at level 0, x, y at level 8, format Reserved Notation "[ 'rel' x y : T => E ]" (at level 0, x, y at level 8, format "'[hv' [ 'rel' x y : T => '/ ' E ] ']'"). -(* Shorter delimiter *) +(** Shorter delimiter **) Delimit Scope bool_scope with B. Open Scope bool_scope. -(* An alternative to xorb that behaves somewhat better wrt simplification. *) +(** An alternative to xorb that behaves somewhat better wrt simplification. **) Definition addb b := if b then negb else id. -(* Notation for && and || is declared in Init.Datatypes. *) +(** Notation for && and || is declared in Init.Datatypes. **) Notation "~~ b" := (negb b) : bool_scope. Notation "b ==> c" := (implb b c) : bool_scope. Notation "b1 (+) b2" := (addb b1 b2) : bool_scope. -(* Constant is_true b := b = true is defined in Init.Datatypes. *) +(** Constant is_true b := b = true is defined in Init.Datatypes. **) Coercion is_true : bool >-> Sortclass. (* Prop *) Lemma prop_congr : forall b b' : bool, b = b' -> b = b' :> Prop. @@ -364,21 +367,22 @@ Proof. by move=> b b' ->. Qed. Ltac prop_congr := apply: prop_congr. -(* Lemmas for trivial. *) +(** Lemmas for trivial. **) Lemma is_true_true : true. Proof. by []. Qed. Lemma not_false_is_true : ~ false. Proof. by []. Qed. Lemma is_true_locked_true : locked true. Proof. by unlock. Qed. -Hint Resolve is_true_true not_false_is_true is_true_locked_true. +Hint Resolve is_true_true not_false_is_true is_true_locked_true : core. -(* Shorter names. *) +(** Shorter names. **) Definition isT := is_true_true. Definition notF := not_false_is_true. -(* Negation lemmas. *) +(** Negation lemmas. **) -(* We generally take NEGATION as the standard form of a false condition: *) -(* negative boolean hypotheses should be of the form ~~ b, rather than ~ b or *) -(* b = false, as much as possible. *) +(** + We generally take NEGATION as the standard form of a false condition: + negative boolean hypotheses should be of the form ~~ b, rather than ~ b or + b = false, as much as possible. **) Lemma negbT b : b = false -> ~~ b. Proof. by case: b. Qed. Lemma negbTE b : ~~ b -> b = false. Proof. by case: b. Qed. @@ -426,8 +430,9 @@ Proof. by move/contra=> notb_notc /notb_notc/negbTE. Qed. Lemma contraFF (c b : bool) : (c -> b) -> b = false -> c = false. Proof. by move/contraFN=> bF_notc /bF_notc/negbTE. Qed. -(* Coercion of sum-style datatypes into bool, which makes it possible *) -(* to use ssr's boolean if rather than Coq's "generic" if. *) +(** + Coercion of sum-style datatypes into bool, which makes it possible + to use ssr's boolean if rather than Coq's "generic" if. **) Coercion isSome T (u : option T) := if u is Some _ then true else false. @@ -441,22 +446,23 @@ Prenex Implicits isSome is_inl is_left is_inleft. Definition decidable P := {P} + {~ P}. -(* Lemmas for ifs with large conditions, which allow reasoning about the *) -(* condition without repeating it inside the proof (the latter IS *) -(* preferable when the condition is short). *) -(* Usage : *) -(* if the goal contains (if cond then ...) = ... *) -(* case: ifP => Hcond. *) -(* generates two subgoal, with the assumption Hcond : cond = true/false *) -(* Rewrite if_same eliminates redundant ifs *) -(* Rewrite (fun_if f) moves a function f inside an if *) -(* Rewrite if_arg moves an argument inside a function-valued if *) +(** + Lemmas for ifs with large conditions, which allow reasoning about the + condition without repeating it inside the proof (the latter IS + preferable when the condition is short). + Usage : + if the goal contains (if cond then ...) = ... + case: ifP => Hcond. + generates two subgoal, with the assumption Hcond : cond = true/false + Rewrite if_same eliminates redundant ifs + Rewrite (fun_if f) moves a function f inside an if + Rewrite if_arg moves an argument inside a function-valued if **) Section BoolIf. Variables (A B : Type) (x : A) (f : A -> B) (b : bool) (vT vF : A). -CoInductive if_spec (not_b : Prop) : bool -> A -> Set := +Variant if_spec (not_b : Prop) : bool -> A -> Set := | IfSpecTrue of b : if_spec not_b true vT | IfSpecFalse of not_b : if_spec not_b false vF. @@ -483,13 +489,13 @@ Lemma if_arg (fT fF : A -> B) : (if b then fT else fF) x = if b then fT x else fF x. Proof. by case b. Qed. -(* Turning a boolean "if" form into an application. *) +(** Turning a boolean "if" form into an application. **) Definition if_expr := if b then vT else vF. Lemma ifE : (if b then vT else vF) = if_expr. Proof. by []. Qed. End BoolIf. -(* Core (internal) reflection lemmas, used for the three kinds of views. *) +(** Core (internal) reflection lemmas, used for the three kinds of views. **) Section ReflectCore. @@ -517,7 +523,7 @@ Proof. by case Hb => [? _ H ? | ? H _]; case: H. Qed. End ReflectCore. -(* Internal negated reflection lemmas *) +(** Internal negated reflection lemmas **) Section ReflectNegCore. Variables (P Q : Prop) (b c : bool). @@ -537,7 +543,7 @@ Proof. by rewrite -if_neg; apply: xorPif. Qed. End ReflectNegCore. -(* User-oriented reflection lemmas *) +(** User-oriented reflection lemmas **) Section Reflect. Variables (P Q : Prop) (b b' c : bool). @@ -584,8 +590,8 @@ Lemma rwP : P <-> b. Proof. by split; [apply: introT | apply: elimT]. Qed. Lemma rwP2 : reflect Q b -> (P <-> Q). Proof. by move=> Qb; split=> ?; [apply: appP | apply: elimT; case: Qb]. Qed. -(* Predicate family to reflect excluded middle in bool. *) -CoInductive alt_spec : bool -> Type := +(** Predicate family to reflect excluded middle in bool. **) +Variant alt_spec : bool -> Type := | AltTrue of P : alt_spec true | AltFalse of ~~ b : alt_spec false. @@ -600,10 +606,10 @@ Hint View for apply/ introTF|3 introNTF|3 introTFn|3 elimT|2 elimTn|2 elimN|2. Hint View for apply// equivPif|3 xorPif|3 equivPifn|3 xorPifn|3. -(* Allow the direct application of a reflection lemma to a boolean assertion. *) +(** Allow the direct application of a reflection lemma to a boolean assertion. **) Coercion elimT : reflect >-> Funclass. -CoInductive implies P Q := Implies of P -> Q. +Variant implies P Q := Implies of P -> Q. Lemma impliesP P Q : implies P Q -> P -> Q. Proof. by case. Qed. Lemma impliesPn (P Q : Prop) : implies P Q -> ~ Q -> ~ P. Proof. by case=> iP ? /iP. Qed. @@ -611,7 +617,7 @@ Coercion impliesP : implies >-> Funclass. Hint View for move/ impliesPn|2 impliesP|2. Hint View for apply/ impliesPn|2 impliesP|2. -(* Impredicative or, which can emulate a classical not-implies. *) +(** Impredicative or, which can emulate a classical not-implies. **) Definition unless condition property : Prop := forall goal : Prop, (condition -> goal) -> (property -> goal) -> goal. @@ -637,8 +643,9 @@ Proof. by split; apply=> [hC|hP]; [apply/unlessL/unlessL | apply/unlessR]. Qed. Lemma unless_contra b C : implies (~~ b -> C) (\unless C, b). Proof. by split; case: b => [_ | hC]; [apply/unlessR | apply/unlessL/hC]. Qed. -(* Classical reasoning becomes directly accessible for any bool subgoal. *) -(* Note that we cannot use "unless" here for lack of universe polymorphism. *) +(** + Classical reasoning becomes directly accessible for any bool subgoal. + Note that we cannot use "unless" here for lack of universe polymorphism. **) Definition classically P : Prop := forall b : bool, (P -> b) -> b. Lemma classicP (P : Prop) : classically P <-> ~ ~ P. @@ -669,11 +676,12 @@ move=> iPQ []// notPQ; apply/notPQ=> /iPQ-cQ. by case: notF; apply: cQ => hQ; apply: notPQ. Qed. -(* List notations for wider connectives; the Prop connectives have a fixed *) -(* width so as to avoid iterated destruction (we go up to width 5 for /\, and *) -(* width 4 for or). The bool connectives have arbitrary widths, but denote *) -(* expressions that associate to the RIGHT. This is consistent with the right *) -(* associativity of list expressions and thus more convenient in most proofs. *) +(** + List notations for wider connectives; the Prop connectives have a fixed + width so as to avoid iterated destruction (we go up to width 5 for /\, and + width 4 for or). The bool connectives have arbitrary widths, but denote + expressions that associate to the RIGHT. This is consistent with the right + associativity of list expressions and thus more convenient in most proofs. **) Inductive and3 (P1 P2 P3 : Prop) : Prop := And3 of P1 & P2 & P3. @@ -822,7 +830,7 @@ Arguments implyP [b1 b2]. Prenex Implicits idP idPn negP negPn negPf. Prenex Implicits andP and3P and4P and5P orP or3P or4P nandP norP implyP. -(* Shorter, more systematic names for the boolean connectives laws. *) +(** Shorter, more systematic names for the boolean connectives laws. **) Lemma andTb : left_id true andb. Proof. by []. Qed. Lemma andFb : left_zero false andb. Proof. by []. Qed. @@ -880,14 +888,14 @@ Proof. by case: a; case: b. Qed. Lemma negb_or (a b : bool) : ~~ (a || b) = ~~ a && ~~ b. Proof. by case: a; case: b. Qed. -(* Pseudo-cancellation -- i.e, absorbtion *) +(** Pseudo-cancellation -- i.e, absorbtion **) Lemma andbK a b : a && b || a = a. Proof. by case: a; case: b. Qed. Lemma andKb a b : a || b && a = a. Proof. by case: a; case: b. Qed. Lemma orbK a b : (a || b) && a = a. Proof. by case: a; case: b. Qed. Lemma orKb a b : a && (b || a) = a. Proof. by case: a; case: b. Qed. -(* Imply *) +(** Imply **) Lemma implybT b : b ==> true. Proof. by case: b. Qed. Lemma implybF b : (b ==> false) = ~~ b. Proof. by case: b. Qed. @@ -917,7 +925,7 @@ Proof. by case: a; case: b => // ->. Qed. Lemma implyb_id2l (a b c : bool) : (a -> b = c) -> (a ==> b) = (a ==> c). Proof. by case: a; case: b; case: c => // ->. Qed. -(* Addition (xor) *) +(** Addition (xor) **) Lemma addFb : left_id false addb. Proof. by []. Qed. Lemma addbF : right_id false addb. Proof. by case. Qed. @@ -946,9 +954,10 @@ Lemma addbP a b : reflect (~~ a = b) (a (+) b). Proof. by case: a; case: b; constructor. Qed. Arguments addbP [a b]. -(* Resolution tactic for blindly weeding out common terms from boolean *) -(* equalities. When faced with a goal of the form (andb/orb/addb b1 b2) = b3 *) -(* they will try to locate b1 in b3 and remove it. This can fail! *) +(** + Resolution tactic for blindly weeding out common terms from boolean + equalities. When faced with a goal of the form (andb/orb/addb b1 b2) = b3 + they will try to locate b1 in b3 and remove it. This can fail! **) Ltac bool_congr := match goal with @@ -963,100 +972,101 @@ Ltac bool_congr := | |- (~~ ?X1 = ?X2) => congr 1 negb end. -(******************************************************************************) -(* Predicates, i.e., packaged functions to bool. *) -(* - pred T, the basic type for predicates over a type T, is simply an alias *) -(* for T -> bool. *) -(* We actually distinguish two kinds of predicates, which we call applicative *) -(* and collective, based on the syntax used to test them at some x in T: *) -(* - For an applicative predicate P, one uses prefix syntax: *) -(* P x *) -(* Also, most operations on applicative predicates use prefix syntax as *) -(* well (e.g., predI P Q). *) -(* - For a collective predicate A, one uses infix syntax: *) -(* x \in A *) -(* and all operations on collective predicates use infix syntax as well *) -(* (e.g., [predI A & B]). *) -(* There are only two kinds of applicative predicates: *) -(* - pred T, the alias for T -> bool mentioned above *) -(* - simpl_pred T, an alias for simpl_fun T bool with a coercion to pred T *) -(* that auto-simplifies on application (see ssrfun). *) -(* On the other hand, the set of collective predicate types is open-ended via *) -(* - predType T, a Structure that can be used to put Canonical collective *) -(* predicate interpretation on other types, such as lists, tuples, *) -(* finite sets, etc. *) -(* Indeed, we define such interpretations for applicative predicate types, *) -(* which can therefore also be used with the infix syntax, e.g., *) -(* x \in predI P Q *) -(* Moreover these infix forms are convertible to their prefix counterpart *) -(* (e.g., predI P Q x which in turn simplifies to P x && Q x). The converse *) -(* is not true, however; collective predicate types cannot, in general, be *) -(* general, be used applicatively, because of the "uniform inheritance" *) -(* restriction on implicit coercions. *) -(* However, we do define an explicit generic coercion *) -(* - mem : forall (pT : predType), pT -> mem_pred T *) -(* where mem_pred T is a variant of simpl_pred T that preserves the infix *) -(* syntax, i.e., mem A x auto-simplifies to x \in A. *) -(* Indeed, the infix "collective" operators are notation for a prefix *) -(* operator with arguments of type mem_pred T or pred T, applied to coerced *) -(* collective predicates, e.g., *) -(* Notation "x \in A" := (in_mem x (mem A)). *) -(* This prevents the variability in the predicate type from interfering with *) -(* the application of generic lemmas. Moreover this also makes it much easier *) -(* to define generic lemmas, because the simplest type -- pred T -- can be *) -(* used as the type of generic collective predicates, provided one takes care *) -(* not to use it applicatively; this avoids the burden of having to declare a *) -(* different predicate type for each predicate parameter of each section or *) -(* lemma. *) -(* This trick is made possible by the fact that the constructor of the *) -(* mem_pred T type aligns the unification process, forcing a generic *) -(* "collective" predicate A : pred T to unify with the actual collective B, *) -(* which mem has coerced to pred T via an internal, hidden implicit coercion, *) -(* supplied by the predType structure for B. Users should take care not to *) -(* inadvertently "strip" (mem B) down to the coerced B, since this will *) -(* expose the internal coercion: Coq will display a term B x that cannot be *) -(* typed as such. The topredE lemma can be used to restore the x \in B *) -(* syntax in this case. While -topredE can conversely be used to change *) -(* x \in P into P x, it is safer to use the inE and memE lemmas instead, as *) -(* they do not run the risk of exposing internal coercions. As a consequence *) -(* it is better to explicitly cast a generic applicative pred T to simpl_pred *) -(* using the SimplPred constructor, when it is used as a collective predicate *) -(* (see, e.g., Lemma eq_big in bigop). *) -(* We also sometimes "instantiate" the predType structure by defining a *) -(* coercion to the sort of the predPredType structure. This works better for *) -(* types such as {set T} that have subtypes that coerce to them, since the *) -(* same coercion will be inserted by the application of mem. It also lets us *) -(* turn any Type aT : predArgType into the total predicate over that type, *) -(* i.e., fun _: aT => true. This allows us to write, e.g., #|'I_n| for the *) -(* cardinal of the (finite) type of integers less than n. *) -(* Collective predicates have a specific extensional equality, *) -(* - A =i B, *) -(* while applicative predicates use the extensional equality of functions, *) -(* - P =1 Q *) -(* The two forms are convertible, however. *) -(* We lift boolean operations to predicates, defining: *) -(* - predU (union), predI (intersection), predC (complement), *) -(* predD (difference), and preim (preimage, i.e., composition) *) -(* For each operation we define three forms, typically: *) -(* - predU : pred T -> pred T -> simpl_pred T *) -(* - [predU A & B], a Notation for predU (mem A) (mem B) *) -(* - xpredU, a Notation for the lambda-expression inside predU, *) -(* which is mostly useful as an argument of =1, since it exposes the head *) -(* head constant of the expression to the ssreflect matching algorithm. *) -(* The syntax for the preimage of a collective predicate A is *) -(* - [preim f of A] *) -(* Finally, the generic syntax for defining a simpl_pred T is *) -(* - [pred x : T | P(x)], [pred x | P(x)], [pred x in A | P(x)], etc. *) -(* We also support boolean relations, but only the applicative form, with *) -(* types *) -(* - rel T, an alias for T -> pred T *) -(* - simpl_rel T, an auto-simplifying version, and syntax *) -(* [rel x y | P(x,y)], [rel x y in A & B | P(x,y)], etc. *) -(* The notation [rel of fA] can be used to coerce a function returning a *) -(* collective predicate to one returning pred T. *) -(* Finally, note that there is specific support for ambivalent predicates *) -(* that can work in either style, as per this file's head descriptor. *) -(******************************************************************************) + +(** + Predicates, i.e., packaged functions to bool. + - pred T, the basic type for predicates over a type T, is simply an alias + for T -> bool. + We actually distinguish two kinds of predicates, which we call applicative + and collective, based on the syntax used to test them at some x in T: + - For an applicative predicate P, one uses prefix syntax: + P x + Also, most operations on applicative predicates use prefix syntax as + well (e.g., predI P Q). + - For a collective predicate A, one uses infix syntax: + x \in A + and all operations on collective predicates use infix syntax as well + (e.g., #[#predI A & B#]#). + There are only two kinds of applicative predicates: + - pred T, the alias for T -> bool mentioned above + - simpl_pred T, an alias for simpl_fun T bool with a coercion to pred T + that auto-simplifies on application (see ssrfun). + On the other hand, the set of collective predicate types is open-ended via + - predType T, a Structure that can be used to put Canonical collective + predicate interpretation on other types, such as lists, tuples, + finite sets, etc. + Indeed, we define such interpretations for applicative predicate types, + which can therefore also be used with the infix syntax, e.g., + x \in predI P Q + Moreover these infix forms are convertible to their prefix counterpart + (e.g., predI P Q x which in turn simplifies to P x && Q x). The converse + is not true, however; collective predicate types cannot, in general, be + general, be used applicatively, because of the "uniform inheritance" + restriction on implicit coercions. + However, we do define an explicit generic coercion + - mem : forall (pT : predType), pT -> mem_pred T + where mem_pred T is a variant of simpl_pred T that preserves the infix + syntax, i.e., mem A x auto-simplifies to x \in A. + Indeed, the infix "collective" operators are notation for a prefix + operator with arguments of type mem_pred T or pred T, applied to coerced + collective predicates, e.g., + Notation "x \in A" := (in_mem x (mem A)). + This prevents the variability in the predicate type from interfering with + the application of generic lemmas. Moreover this also makes it much easier + to define generic lemmas, because the simplest type -- pred T -- can be + used as the type of generic collective predicates, provided one takes care + not to use it applicatively; this avoids the burden of having to declare a + different predicate type for each predicate parameter of each section or + lemma. + This trick is made possible by the fact that the constructor of the + mem_pred T type aligns the unification process, forcing a generic + "collective" predicate A : pred T to unify with the actual collective B, + which mem has coerced to pred T via an internal, hidden implicit coercion, + supplied by the predType structure for B. Users should take care not to + inadvertently "strip" (mem B) down to the coerced B, since this will + expose the internal coercion: Coq will display a term B x that cannot be + typed as such. The topredE lemma can be used to restore the x \in B + syntax in this case. While -topredE can conversely be used to change + x \in P into P x, it is safer to use the inE and memE lemmas instead, as + they do not run the risk of exposing internal coercions. As a consequence + it is better to explicitly cast a generic applicative pred T to simpl_pred + using the SimplPred constructor, when it is used as a collective predicate + (see, e.g., Lemma eq_big in bigop). + We also sometimes "instantiate" the predType structure by defining a + coercion to the sort of the predPredType structure. This works better for + types such as {set T} that have subtypes that coerce to them, since the + same coercion will be inserted by the application of mem. It also lets us + turn any Type aT : predArgType into the total predicate over that type, + i.e., fun _: aT => true. This allows us to write, e.g., ##|'I_n| for the + cardinal of the (finite) type of integers less than n. + Collective predicates have a specific extensional equality, + - A =i B, + while applicative predicates use the extensional equality of functions, + - P =1 Q + The two forms are convertible, however. + We lift boolean operations to predicates, defining: + - predU (union), predI (intersection), predC (complement), + predD (difference), and preim (preimage, i.e., composition) + For each operation we define three forms, typically: + - predU : pred T -> pred T -> simpl_pred T + - #[#predU A & B#]#, a Notation for predU (mem A) (mem B) + - xpredU, a Notation for the lambda-expression inside predU, + which is mostly useful as an argument of =1, since it exposes the head + head constant of the expression to the ssreflect matching algorithm. + The syntax for the preimage of a collective predicate A is + - #[#preim f of A#]# + Finally, the generic syntax for defining a simpl_pred T is + - #[#pred x : T | P(x) #]#, #[#pred x | P(x) #]#, #[#pred x in A | P(x) #]#, etc. + We also support boolean relations, but only the applicative form, with + types + - rel T, an alias for T -> pred T + - simpl_rel T, an auto-simplifying version, and syntax + #[#rel x y | P(x,y) #]#, #[#rel x y in A & B | P(x,y) #]#, etc. + The notation #[#rel of fA#]# can be used to coerce a function returning a + collective predicate to one returning pred T. + Finally, note that there is specific support for ambivalent predicates + that can work in either style, as per this file's head descriptor. **) + Definition pred T := T -> bool. @@ -1094,8 +1104,9 @@ Coercion applicative_pred_of_simpl (p : simpl_pred) : applicative_pred := fun_of_simpl p. Coercion collective_pred_of_simpl (p : simpl_pred) : collective_pred := fun x => (let: SimplFun f := p in fun _ => f x) x. -(* Note: applicative_of_simpl is convertible to pred_of_simpl, while *) -(* collective_of_simpl is not. *) +(** + Note: applicative_of_simpl is convertible to pred_of_simpl, while + collective_of_simpl is not. **) Definition pred0 := SimplPred xpred0. Definition predT := SimplPred xpredT. @@ -1119,7 +1130,7 @@ Proof. by move=> *; apply/orP; left. Qed. Lemma subrelUr r1 r2 : subrel r2 (relU r1 r2). Proof. by move=> *; apply/orP; right. Qed. -CoInductive mem_pred := Mem of pred T. +Variant mem_pred := Mem of pred T. Definition isMem pT topred mem := mem = (fun p : pT => Mem [eta topred p]). @@ -1166,19 +1177,21 @@ Notation "[ 'rel' x y : T | E ]" := (SimplRel (fun x y : T => E%B)) Notation "[ 'predType' 'of' T ]" := (@clone_pred _ T _ id _ _ id) (at level 0, format "[ 'predType' 'of' T ]") : form_scope. -(* This redundant coercion lets us "inherit" the simpl_predType canonical *) -(* instance by declaring a coercion to simpl_pred. This hack is the only way *) -(* to put a predType structure on a predArgType. We use simpl_pred rather *) -(* than pred to ensure that /= removes the identity coercion. Note that the *) -(* coercion will never be used directly for simpl_pred, since the canonical *) -(* instance should always be resolved. *) +(** + This redundant coercion lets us "inherit" the simpl_predType canonical + instance by declaring a coercion to simpl_pred. This hack is the only way + to put a predType structure on a predArgType. We use simpl_pred rather + than pred to ensure that /= removes the identity coercion. Note that the + coercion will never be used directly for simpl_pred, since the canonical + instance should always be resolved. **) Notation pred_class := (pred_sort (predPredType _)). Coercion sort_of_simpl_pred T (p : simpl_pred T) : pred_class := p : pred T. -(* This lets us use some types as a synonym for their universal predicate. *) -(* Unfortunately, this won't work for existing types like bool, unless we *) -(* redefine bool, true, false and all bool ops. *) +(** + This lets us use some types as a synonym for their universal predicate. + Unfortunately, this won't work for existing types like bool, unless we + redefine bool, true, false and all bool ops. **) Definition predArgType := Type. Bind Scope type_scope with predArgType. Identity Coercion sort_of_predArgType : predArgType >-> Sortclass. @@ -1187,8 +1200,9 @@ Coercion pred_of_argType (T : predArgType) : simpl_pred T := predT. Notation "{ : T }" := (T%type : predArgType) (at level 0, format "{ : T }") : type_scope. -(* These must be defined outside a Section because "cooking" kills the *) -(* nosimpl tag. *) +(** + These must be defined outside a Section because "cooking" kills the + nosimpl tag. **) Definition mem T (pT : predType T) : pT -> mem_pred T := nosimpl (let: @PredType _ _ _ (exist _ mem _) := pT return pT -> _ in mem). @@ -1254,12 +1268,13 @@ Section simpl_mem. Variables (T : Type) (pT : predType T). Implicit Types (x : T) (p : pred T) (sp : simpl_pred T) (pp : pT). -(* Bespoke structures that provide fine-grained control over matching the *) -(* various forms of the \in predicate; note in particular the different forms *) -(* of hoisting that are used. We had to work around several bugs in the *) -(* implementation of unification, notably improper expansion of telescope *) -(* projections and overwriting of a variable assignment by a later *) -(* unification (probably due to conversion cache cross-talk). *) +(** + Bespoke structures that provide fine-grained control over matching the + various forms of the \in predicate; note in particular the different forms + of hoisting that are used. We had to work around several bugs in the + implementation of unification, notably improper expansion of telescope + projections and overwriting of a variable assignment by a later + unification (probably due to conversion cache cross-talk). **) Structure manifest_applicative_pred p := ManifestApplicativePred { manifest_applicative_pred_value :> pred T; _ : manifest_applicative_pred_value = p @@ -1305,10 +1320,11 @@ Lemma in_simpl x p (msp : manifest_simpl_pred p) : in_mem x (Mem [eta fun_of_simpl (msp : simpl_pred T)]) = p x. Proof. by case: msp => _ /= ->. Qed. -(* Because of the explicit eta expansion in the left-hand side, this lemma *) -(* should only be used in a right-to-left direction. The 8.3 hack allowing *) -(* partial right-to-left use does not work with the improved expansion *) -(* heuristics in 8.4. *) +(** + Because of the explicit eta expansion in the left-hand side, this lemma + should only be used in a right-to-left direction. The 8.3 hack allowing + partial right-to-left use does not work with the improved expansion + heuristics in 8.4. **) Lemma unfold_in x p : (x \in ([eta p] : pred T)) = p x. Proof. by []. Qed. @@ -1327,9 +1343,9 @@ Proof. by rewrite -mem_topred. Qed. End simpl_mem. -(* Qualifiers and keyed predicates. *) +(** Qualifiers and keyed predicates. **) -CoInductive qualifier (q : nat) T := Qualifier of predPredType T. +Variant qualifier (q : nat) T := Qualifier of predPredType T. Coercion has_quality n T (q : qualifier n T) : pred_class := fun x => let: Qualifier _ p := q in p x. @@ -1371,12 +1387,12 @@ Notation "[ 'qualify' 'an' x | P ]" := (Qualifier 2 (fun x => P%B)) Notation "[ 'qualify' 'an' x : T | P ]" := (Qualifier 2 (fun x : T => P%B)) (at level 0, x at level 99, only parsing) : form_scope. -(* Keyed predicates: support for property-bearing predicate interfaces. *) +(** Keyed predicates: support for property-bearing predicate interfaces. **) Section KeyPred. Variable T : Type. -CoInductive pred_key (p : predPredType T) := DefaultPredKey. +Variant pred_key (p : predPredType T) := DefaultPredKey. Variable p : predPredType T. Structure keyed_pred (k : pred_key p) := @@ -1388,13 +1404,14 @@ Definition KeyedPred := @PackKeyedPred k p (frefl _). Variable k_p : keyed_pred k. Lemma keyed_predE : k_p =i p. Proof. by case: k_p. Qed. -(* Instances that strip the mem cast; the first one has "pred_of_mem" as its *) -(* projection head value, while the second has "pred_of_simpl". The latter *) -(* has the side benefit of preempting accidental misdeclarations. *) -(* Note: pred_of_mem is the registered mem >-> pred_class coercion, while *) -(* simpl_of_mem; pred_of_simpl is the mem >-> pred >=> Funclass coercion. We *) -(* must write down the coercions explicitly as the Canonical head constant *) -(* computation does not strip casts !! *) +(** + Instances that strip the mem cast; the first one has "pred_of_mem" as its + projection head value, while the second has "pred_of_simpl". The latter + has the side benefit of preempting accidental misdeclarations. + Note: pred_of_mem is the registered mem >-> pred_class coercion, while + simpl_of_mem; pred_of_simpl is the mem >-> pred >=> Funclass coercion. We + must write down the coercions explicitly as the Canonical head constant + computation does not strip casts !! **) Canonical keyed_mem := @PackKeyedPred k (pred_of_mem (mem k_p)) keyed_predE. Canonical keyed_mem_simpl := @@ -1434,7 +1451,7 @@ Canonical default_keyed_qualifier T n (q : qualifier n T) := End DefaultKeying. -(* Skolemizing with conditions. *) +(** Skolemizing with conditions. **) Lemma all_tag_cond_dep I T (C : pred I) U : (forall x, T x) -> (forall x, C x -> {y : T x & U x y}) -> @@ -1461,8 +1478,9 @@ Proof. by move=> y0; apply: all_sig_cond_dep. Qed. Section RelationProperties. -(* Caveat: reflexive should not be used to state lemmas, as auto and trivial *) -(* will not expand the constant. *) +(** + Caveat: reflexive should not be used to state lemmas, as auto and trivial + will not expand the constant. **) Variable T : Type. @@ -1496,8 +1514,9 @@ Proof. by move=> x y /sym_left_transitive Rxy z; rewrite !(symR z) Rxy. Qed. End PER. -(* We define the equivalence property with prenex quantification so that it *) -(* can be localized using the {in ..., ..} form defined below. *) +(** + We define the equivalence property with prenex quantification so that it + can be localized using the {in ..., ..} form defined below. **) Definition equivalence_rel := forall x y z, R z z * (R x y -> R x z = R y z). @@ -1512,7 +1531,7 @@ End RelationProperties. Lemma rev_trans T (R : rel T) : transitive R -> transitive (fun x y => R y x). Proof. by move=> trR x y z Ryx Rzy; apply: trR Rzy Ryx. Qed. -(* Property localization *) +(** Property localization **) Local Notation "{ 'all1' P }" := (forall x, P x : Prop) (at level 0). Local Notation "{ 'all2' P }" := (forall x y, P x y : Prop) (at level 0). @@ -1626,11 +1645,12 @@ Notation "{ 'on' cd , 'bijective' f }" := (bijective_on (mem cd) f) (at level 0, f at level 8, format "{ 'on' cd , 'bijective' f }") : type_scope. -(* Weakening and monotonicity lemmas for localized predicates. *) -(* Note that using these lemmas in backward reasoning will force expansion of *) -(* the predicate definition, as Coq needs to expose the quantifier to apply *) -(* these lemmas. We define a few specialized variants to avoid this for some *) -(* of the ssrfun predicates. *) +(** + Weakening and monotonicity lemmas for localized predicates. + Note that using these lemmas in backward reasoning will force expansion of + the predicate definition, as Coq needs to expose the quantifier to apply + these lemmas. We define a few specialized variants to avoid this for some + of the ssrfun predicates. **) Section LocalGlobal. diff --git a/plugins/ssr/ssrbwd.ml b/plugins/ssr/ssrbwd.ml index 1c4508abf4..3e0fbc9a8c 100644 --- a/plugins/ssr/ssrbwd.ml +++ b/plugins/ssr/ssrbwd.ml @@ -104,8 +104,6 @@ let mkRAppView ist gl rv gv = let nb_view_imps = interp_view_nbimps ist gl rv in mkRApp rv (mkRHoles (abs nb_view_imps)) -let prof_apply_interp_with = mk_profiler "ssrapplytac.interp_with";; - let refine_interp_apply_view dbl ist gl gv = let pair i = List.map (fun x -> i, x) in let rv = pf_intern_term ist gl gv in @@ -113,7 +111,6 @@ let refine_interp_apply_view dbl ist gl gv = let interp_with (dbl, hint) = let i = if dbl = Ssrview.AdaptorDb.Equivalence then 2 else 1 in interp_refine ist gl (mkRApp hint (v :: mkRHoles i)) in - let interp_with x = prof_apply_interp_with.profile interp_with x in let rec loop = function | [] -> (try apply_rconstr ~ist rv gl with _ -> view_error "apply" gv) | h :: hs -> (try refine_with (snd (interp_with h)) gl with _ -> loop hs) in diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 19abf6780c..efc4a2c743 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -181,10 +181,9 @@ let option_assert_get o msg = (** Constructors for rawconstr *) open Glob_term open Globnames -open Misctypes open Decl_kinds -let mkRHole = DAst.make @@ GHole (Evar_kinds.InternalHole, IntroAnonymous, None) +let mkRHole = DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None) let rec mkRHoles n = if n > 0 then mkRHole :: mkRHoles (n - 1) else [] let rec isRHoles cl = match cl with @@ -202,8 +201,8 @@ let mkRInd mind = DAst.make @@ GRef (IndRef mind,None) let mkRLambda n s t = DAst.make @@ GLambda (n, Explicit, s, t) let rec mkRnat n = - if n <= 0 then DAst.make @@ GRef (Coqlib.glob_O, None) else - mkRApp (DAst.make @@ GRef (Coqlib.glob_S, None)) [mkRnat (n - 1)] + if n <= 0 then DAst.make @@ GRef (Coqlib.lib_ref "num.nat.O", None) else + mkRApp (DAst.make @@ GRef (Coqlib.lib_ref "num.nat.S", None)) [mkRnat (n - 1)] let glob_constr ist genv = function | _, Some ce -> @@ -228,8 +227,9 @@ let splay_open_constr gl (sigma, c) = Reductionops.splay_prod env sigma t let isAppInd env sigma c = - try ignore(Tacred.reduce_to_atomic_ind env sigma c); true - with CErrors.UserError _ -> false + let c = Reductionops.clos_whd_flags CClosure.all env sigma c in + let c, _ = decompose_app_vect sigma c in + EConstr.isInd sigma c (** Generic argument-based globbing/typing utilities *) @@ -242,7 +242,6 @@ let interp_refine ist gl rc = let flags = { Pretyping.use_typeclasses = true; solve_unification_constraints = true; - use_hook = None; fail_evar = false; expand_evars = true } in @@ -253,7 +252,7 @@ let interp_refine ist gl rc = let interp_open_constr ist gl gc = - let (sigma, (c, _)) = Tacinterp.interp_open_constr_with_bindings ist (pf_env gl) (project gl) (gc, Misctypes.NoBindings) in + let (sigma, (c, _)) = Tacinterp.interp_open_constr_with_bindings ist (pf_env gl) (project gl) (gc, Tactypes.NoBindings) in (project gl, (sigma, c)) let interp_term ist gl (_, c) = snd (interp_open_constr ist gl c) @@ -422,12 +421,12 @@ let mk_anon_id t gl_ids = (set s i (Char.chr (Char.code (get s i) + 1)); s) in Id.of_bytes (loop (n - 1)) -let convert_concl_no_check t = Tactics.convert_concl_no_check t Term.DEFAULTcast -let convert_concl t = Tactics.convert_concl t Term.DEFAULTcast +let convert_concl_no_check t = Tactics.convert_concl_no_check t DEFAULTcast +let convert_concl t = Tactics.convert_concl t DEFAULTcast let rename_hd_prod orig_name_ref gl = match EConstr.kind (project gl) (pf_concl gl) with - | Term.Prod(_,src,tgt) -> + | Prod(_,src,tgt) -> Proofview.V82.of_tactic (convert_concl_no_check (EConstr.mkProd (!orig_name_ref,src,tgt))) gl | _ -> CErrors.anomaly (str "gentac creates no product") @@ -469,7 +468,7 @@ let ssrevaltac ist gtac = Tacinterp.tactic_of_value ist gtac (* term mkApp (t', args) is convertible to t. *) (* This makes a useful shorthand for local definitions in proofs, *) (* i.e., pose succ := _ + 1 means pose succ := fun n : nat => n + 1, *) -(* and, in context of the the 4CT library, pose mid := maps id means *) +(* and, in context of the 4CT library, pose mid := maps id means *) (* pose mid := fun d : detaSet => @maps d d (@id (datum d)) *) (* Note that this facility does not extend to set, which tries *) (* instead to fill holes by matching a goal subterm. *) @@ -499,20 +498,37 @@ let pf_e_type_of gl t = let sigma, ty = Typing.type_of env sigma t in re_sig it sigma, ty +let pf_resolve_typeclasses ~where ~fail gl = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let filter = + let evset = Evarutil.undefined_evars_of_term sigma where in + fun k _ -> Evar.Set.mem k evset in + let sigma = Typeclasses.resolve_typeclasses ~filter ~fail env sigma in + re_sig it sigma + +let resolve_typeclasses ~where ~fail env sigma = + let filter = + let evset = Evarutil.undefined_evars_of_term sigma where in + fun k _ -> Evar.Set.mem k evset in + let sigma = Typeclasses.resolve_typeclasses ~filter ~fail env sigma in + sigma + + let nf_evar sigma t = EConstr.Unsafe.to_constr (Evarutil.nf_evar sigma (EConstr.of_constr t)) let pf_abs_evars2 gl rigid (sigma, c0) = - let c0 = EConstr.to_constr sigma c0 in + let c0 = EConstr.to_constr ~abort_on_undefined_evars:false sigma c0 in let sigma0, ucst = project gl, Evd.evar_universe_context sigma in let nenv = env_size (pf_env gl) in let abs_evar n k = let evi = Evd.find sigma k in - let dc = CList.firstn n (evar_filtered_context evi) in + let concl = EConstr.Unsafe.to_constr evi.evar_concl in + let dc = EConstr.Unsafe.to_named_context (CList.firstn n (evar_filtered_context evi)) in let abs_dc c = function | NamedDecl.LocalDef (x,b,t) -> mkNamedLetIn x b t (mkArrow t c) | NamedDecl.LocalAssum (x,t) -> mkNamedProd x t c in - let t = Context.Named.fold_inside abs_dc ~init:evi.evar_concl dc in + let t = Context.Named.fold_inside abs_dc ~init:concl dc in nf_evar sigma t in let rec put evlist c = match Constr.kind c with | Evar (k, a) -> @@ -568,11 +584,12 @@ let pf_abs_evars_pirrel gl (sigma, c0) = let nenv = env_size (pf_env gl) in let abs_evar n k = let evi = Evd.find sigma k in - let dc = CList.firstn n (evar_filtered_context evi) in + let concl = EConstr.Unsafe.to_constr evi.evar_concl in + let dc = EConstr.Unsafe.to_named_context (CList.firstn n (evar_filtered_context evi)) in let abs_dc c = function | NamedDecl.LocalDef (x,b,t) -> mkNamedLetIn x b t (mkArrow t c) | NamedDecl.LocalAssum (x,t) -> mkNamedProd x t c in - let t = Context.Named.fold_inside abs_dc ~init:evi.evar_concl dc in + let t = Context.Named.fold_inside abs_dc ~init:concl dc in nf_evar sigma0 (nf_evar sigma t) in let rec put evlist c = match Constr.kind c with | Evar (k, a) -> @@ -580,7 +597,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = let n = max 0 (Array.length a - nenv) in let k_ty = Retyping.get_sort_family_of - (pf_env gl) sigma (EConstr.of_constr (Evd.evar_concl (Evd.find sigma k))) in + (pf_env gl) sigma (Evd.evar_concl (Evd.find sigma k)) in let is_prop = k_ty = InProp in let t = abs_evar n k in (k, (n, t, is_prop)) :: put evlist t | _ -> Constr.fold put evlist c in @@ -728,13 +745,10 @@ let pf_abs_prod name gl c cl = pf_mkprod gl c ~name (Termops.subst_term (project (** look up a name in the ssreflect internals module *) let ssrdirpath = DirPath.make [Id.of_string "ssreflect"] let ssrqid name = Libnames.make_qualid ssrdirpath (Id.of_string name) -let ssrtopqid name = Libnames.qualid_of_ident (Id.of_string name) -let locate_reference qid = - Smartlocate.global_of_extended_global (Nametab.locate_extended qid) let mkSsrRef name = - try locate_reference (ssrqid name) with Not_found -> - try locate_reference (ssrtopqid name) with Not_found -> - CErrors.user_err (Pp.str "Small scale reflection library not loaded") + let qn = Format.sprintf "plugins.ssreflect.%s" name in + if Coqlib.has_ref qn then Coqlib.lib_ref qn else + CErrors.user_err Pp.(str "Small scale reflection library not loaded (" ++ str name ++ str ")") let mkSsrRRef name = (DAst.make @@ GRef (mkSsrRef name,None)), None let mkSsrConst name env sigma = EConstr.fresh_global env sigma (mkSsrRef name) @@ -745,7 +759,7 @@ let pf_mkSsrConst name gl = let pf_fresh_global name gl = let sigma, env, it = project gl, pf_env gl, sig_it gl in let sigma,t = Evd.fresh_global env sigma name in - t, re_sig it sigma + EConstr.Unsafe.to_constr t, re_sig it sigma let mkProt t c gl = let prot, gl = pf_mkSsrConst "protect_term" gl in @@ -761,7 +775,7 @@ let mkEtaApp c n imin = let mkRefl t c gl = let sigma = project gl in - let (sigma, refl) = EConstr.fresh_global (pf_env gl) sigma Coqlib.((build_coq_eq_data()).refl) in + let (sigma, refl) = EConstr.fresh_global (pf_env gl) sigma Coqlib.(lib_ref "core.eq.refl") in EConstr.mkApp (refl, [|t; c|]), { gl with sigma } let discharge_hyp (id', (id, mode)) gl = @@ -799,8 +813,11 @@ let rec is_name_in_ipats name = function List.exists (function SsrHyp(_,id) -> id = name) clr || is_name_in_ipats name tl | IPatId id :: tl -> id = name || is_name_in_ipats name tl - | (IPatCase l | IPatDispatch l) :: tl -> List.exists (is_name_in_ipats name) l || is_name_in_ipats name tl - | _ :: tl -> is_name_in_ipats name tl + | IPatAbstractVars ids :: tl -> + CList.mem_f Id.equal name ids || is_name_in_ipats name tl + | (IPatCase l | IPatDispatch (_,l) | IPatInj l) :: tl -> + List.exists (is_name_in_ipats name) l || is_name_in_ipats name tl + | (IPatView _ | IPatAnon _ | IPatSimpl _ | IPatRewrite _ | IPatTac _ | IPatNoop) :: tl -> is_name_in_ipats name tl | [] -> false let view_error s gv = @@ -842,7 +859,7 @@ let ssr_n_tac seed n gl = with Not_found -> if n = -1 then fail "The ssreflect library was not loaded" else fail ("The tactic "^name^" was not found") in - let tacexpr = Loc.tag @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in + let tacexpr = CAst.make @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in Proofview.V82.of_tactic (Tacinterp.eval_tactic (Tacexpr.TacArg tacexpr)) gl let donetac n gl = ssr_n_tac "done" n gl @@ -853,10 +870,10 @@ open Util (** Constructors for constr_expr *) let mkCProp loc = CAst.make ?loc @@ CSort GProp let mkCType loc = CAst.make ?loc @@ CSort (GType []) -let mkCVar ?loc id = CAst.make ?loc @@ CRef (CAst.make ?loc @@ Ident id, None) +let mkCVar ?loc id = CAst.make ?loc @@ CRef (qualid_of_ident ?loc id, None) let rec mkCHoles ?loc n = - if n <= 0 then [] else (CAst.make ?loc @@ CHole (None, IntroAnonymous, None)) :: mkCHoles ?loc (n - 1) -let mkCHole loc = CAst.make ?loc @@ CHole (None, IntroAnonymous, None) + if n <= 0 then [] else (CAst.make ?loc @@ CHole (None, Namegen.IntroAnonymous, None)) :: mkCHoles ?loc (n - 1) +let mkCHole loc = CAst.make ?loc @@ CHole (None, Namegen.IntroAnonymous, None) let mkCLambda ?loc name ty t = CAst.make ?loc @@ CLambdaN ([CLocalAssum([CAst.make ?loc name], Default Explicit, ty)], t) let mkCArrow ?loc ty t = CAst.make ?loc @@ @@ -938,7 +955,7 @@ let pf_saturate ?beta ?bi_types gl c ?ty m = let pf_partial_solution gl t evl = let sigma, g = project gl, sig_it gl in - let sigma = Goal.V82.partial_solution sigma g t in + let sigma = Goal.V82.partial_solution (pf_env gl) sigma g t in re_sig (List.map (fun x -> (fst (EConstr.destEvar sigma x))) evl) sigma let dependent_apply_error = @@ -979,11 +996,11 @@ let applyn ~with_evars ?beta ?(with_shelve=false) n t gl = if not (EConstr.Vars.closed0 sigma ty) then raise dependent_apply_error; let m = Evarutil.new_meta () in - loop (meta_declare m (EConstr.Unsafe.to_constr ty) sigma) bo ((EConstr.mkMeta m)::args) (n-1) + loop (meta_declare m ty sigma) bo ((EConstr.mkMeta m)::args) (n-1) | _ -> assert false in loop sigma t [] n in pp(lazy(str"Refiner.refiner " ++ Printer.pr_econstr_env (pf_env gl) (project gl) t)); - Tacmach.refine_no_check t gl + Refiner.refiner ~check:false EConstr.Unsafe.(to_constr t) gl let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc gl = let rec mkRels = function 1 -> [] | n -> mkRel n :: mkRels (n-1) in @@ -1000,81 +1017,6 @@ let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc gl = try applyn ~with_evars ~with_shelve:true ?beta n (EConstr.of_constr oc) gl with e when CErrors.noncritical e -> raise dependent_apply_error -(** 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 _ = - Goptions.declare_bool_option - { Goptions.optname = "ssreflect profiling"; - Goptions.optkey = ["SsrProfiling"]; - Goptions.optread = (fun _ -> !profile_now); - Goptions.optdepr = false; - Goptions.optwrite = (fun b -> - Ssrmatching.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 () = - 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 -;; -(* }}} *) - (* 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 *) @@ -1083,7 +1025,7 @@ let () = CLexer.set_keyword_state frozen_lexer ;; (** Basic tactics *) -let rec fst_prod red tac = Proofview.Goal.nf_enter begin fun gl -> +let rec fst_prod red tac = Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in match EConstr.kind (Proofview.Goal.sigma gl) concl with | Prod (id,_,tgt) | LetIn(id,_,_,tgt) -> tac id @@ -1150,8 +1092,8 @@ let tclDO n tac = let _, info = CErrors.push e in let e' = CErrors.UserError (l, prefix i ++ s) in Util.iraise (e', info) - | Ploc.Exc(loc, CErrors.UserError (l, s)) -> - raise (Ploc.Exc(loc, CErrors.UserError (l, prefix i ++ s))) in + | Gramlib.Ploc.Exc(loc, CErrors.UserError (l, s)) -> + raise (Gramlib.Ploc.Exc(loc, CErrors.UserError (l, prefix i ++ s))) in let rec loop i gl = if i = n then tac_err_at i gl else (tclTHEN (tac_err_at i) (loop (i + 1))) gl in @@ -1215,7 +1157,7 @@ let genclrtac cl cs clr = (fun type_err gl -> tclTHEN (tclTHEN (Proofview.V82.of_tactic (Tactics.elim_type (EConstr.of_constr - (Universes.constr_of_global @@ Coqlib.build_coq_False ())))) (old_cleartac clr)) + (UnivGen.constr_of_monomorphic_global @@ Coqlib.(lib_ref "core.False.type"))))) (old_cleartac clr)) (fun gl -> raise type_err) gl)) (old_cleartac clr) @@ -1360,7 +1302,7 @@ let tacTYPEOF c = Goal.enter_one ~__LOC__ (fun g -> (** This tactic creates a partial proof realizing the introduction rule, but does not check anything. *) -let unsafe_intro env store decl b = +let unsafe_intro env decl b = let open Context.Named.Declaration in Refine.refine ~typecheck:false begin fun sigma -> let ctx = Environ.named_context_val env in @@ -1369,7 +1311,7 @@ let unsafe_intro env store decl b = let ninst = EConstr.mkRel 1 :: inst in let nb = EConstr.Vars.subst1 (EConstr.mkVar (get_id decl)) b in let sigma, ev = - Evarutil.new_evar_instance nctx sigma nb ~principal:true ~store ninst in + Evarutil.new_evar_instance nctx sigma nb ~principal:true ninst in sigma, EConstr.mkNamedLambda_or_LetIn decl ev end @@ -1413,7 +1355,7 @@ let-in even after reduction, it fails. In case of success, the original name and final id are passed to the continuation [k] which gets evaluated. *) let tclINTRO ~id ~conclusion:k = Goal.enter begin fun gl -> let open Context in - let env, sigma, extra, g = Goal.(env gl, sigma gl, extra gl, concl gl) in + let env, sigma, g = Goal.(env gl, sigma gl, concl gl) in let decl, t, no_red = decompose_assum env sigma g in let original_name = Rel.Declaration.get_name decl in let already_used = Tacmach.New.pf_ids_of_hyps gl in @@ -1428,7 +1370,7 @@ let tclINTRO ~id ~conclusion:k = Goal.enter begin fun gl -> in if List.mem id already_used then errorstrm Pp.(Id.print id ++ str" already used"); - unsafe_intro env extra (set_decl_id id decl) t <*> + unsafe_intro env (set_decl_id id decl) t <*> (if no_red then tclUNIT () else tclFULL_BETAIOTA) <*> k ~orig_name:original_name ~new_name:id end @@ -1440,7 +1382,7 @@ let tclINTRO_ANON = tclINTRO ~id:None ~conclusion:return let tclRENAME_HD_PROD name = Goal.enter begin fun gl -> let convert_concl_no_check t = - Tactics.convert_concl_no_check t Term.DEFAULTcast in + Tactics.convert_concl_no_check t DEFAULTcast in let concl = Goal.concl gl in let sigma = Goal.sigma gl in match EConstr.kind sigma concl with @@ -1499,7 +1441,7 @@ let tclOPTION o d = let tacIS_INJECTION_CASE ?ty t = begin tclOPTION ty (tacTYPEOF t) >>= fun ty -> tacREDUCE_TO_QUANTIFIED_IND ty >>= fun ((mind,_),_) -> - tclUNIT (Globnames.eq_gr (Globnames.IndRef mind) (Coqlib.build_coq_eq ())) + tclUNIT (Coqlib.check_ind_ref "core.eq.type" mind) end let tclWITHTOP tac = Goal.enter begin fun gl -> diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index 2b8f1d5409..e25c93bf0a 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -164,7 +164,7 @@ val mk_lterm : constr_expr -> ssrterm val mk_ast_closure_term : [ `None | `Parens | `DoubleParens | `At ] -> Constrexpr.constr_expr -> ast_closure_term -val interp_ast_closure_term : Geninterp.interp_sign -> Proof_type.goal +val interp_ast_closure_term : Geninterp.interp_sign -> Goal.goal Evd.sigma -> ast_closure_term -> Evd.evar_map * ast_closure_term val subst_ast_closure_term : Mod_subst.substitution -> ast_closure_term -> ast_closure_term val glob_ast_closure_term : Genintern.glob_sign -> ast_closure_term -> ast_closure_term @@ -212,8 +212,7 @@ val pf_abs_prod : EConstr.t -> Goal.goal Evd.sigma * EConstr.types val mkSsrRRef : string -> Glob_term.glob_constr * 'a option -val mkSsrRef : string -> Globnames.global_reference -val mkSsrConst : +val mkSsrConst : string -> env -> evar_map -> evar_map * EConstr.t val pf_mkSsrConst : @@ -224,7 +223,7 @@ val new_wild_id : tac_ctx -> Names.Id.t * tac_ctx val pf_fresh_global : - Globnames.global_reference -> + GlobRef.t -> Goal.goal Evd.sigma -> Constr.constr * Goal.goal Evd.sigma @@ -336,6 +335,14 @@ val refine_with : ?beta:bool -> ?with_evars:bool -> evar_map * EConstr.t -> v82tac + +val pf_resolve_typeclasses : + where:EConstr.t -> + fail:bool -> Goal.goal Evd.sigma -> Goal.goal Evd.sigma +val resolve_typeclasses : + where:EConstr.t -> + fail:bool -> Environ.env -> Evd.evar_map -> Evd.evar_map + (*********************** Wrapped Coq tactics *****************************) val rewritetac : ssrdir -> EConstr.t -> tactic @@ -371,13 +378,6 @@ val pf_interp_gen_aux : val is_name_in_ipats : Id.t -> ssripats -> bool -type profiler = { - profile : 'a 'b. ('a -> 'b) -> 'a -> 'b; - reset : unit -> unit; - print : unit -> unit } - -val mk_profiler : string -> profiler - (** Basic tactics *) val introid : ?orig:Name.t ref -> Id.t -> v82tac diff --git a/plugins/ssr/ssreflect.v b/plugins/ssr/ssreflect.v index b0a9441385..01af67912a 100644 --- a/plugins/ssr/ssreflect.v +++ b/plugins/ssr/ssreflect.v @@ -10,50 +10,53 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(** #<style> .doc { font-family: monospace; white-space: pre; } </style># **) + Require Import Bool. (* For bool_scope delimiter 'bool'. *) Require Import ssrmatching. Declare ML Module "ssreflect_plugin". -(******************************************************************************) -(* This file is the Gallina part of the ssreflect plugin implementation. *) -(* Files that use the ssreflect plugin should always Require ssreflect and *) -(* either Import ssreflect or Import ssreflect.SsrSyntax. *) -(* Part of the contents of this file is technical and will only interest *) -(* advanced developers; in addition the following are defined: *) -(* [the str of v by f] == the Canonical s : str such that f s = v. *) -(* [the str of v] == the Canonical s : str that coerces to v. *) -(* argumentType c == the T such that c : forall x : T, P x. *) -(* returnType c == the R such that c : T -> R. *) -(* {type of c for s} == P s where c : forall x : T, P x. *) -(* phantom T v == singleton type with inhabitant Phantom T v. *) -(* phant T == singleton type with inhabitant Phant v. *) -(* =^~ r == the converse of rewriting rule r (e.g., in a *) -(* rewrite multirule). *) -(* unkeyed t == t, but treated as an unkeyed matching pattern by *) -(* the ssreflect matching algorithm. *) -(* nosimpl t == t, but on the right-hand side of Definition C := *) -(* nosimpl disables expansion of C by /=. *) -(* locked t == t, but locked t is not convertible to t. *) -(* locked_with k t == t, but not convertible to t or locked_with k' t *) -(* unless k = k' (with k : unit). Coq type-checking *) -(* will be much more efficient if locked_with with a *) -(* bespoke k is used for sealed definitions. *) -(* unlockable v == interface for sealed constant definitions of v. *) -(* Unlockable def == the unlockable that registers def : C = v. *) -(* [unlockable of C] == a clone for C of the canonical unlockable for the *) -(* definition of C (e.g., if it uses locked_with). *) -(* [unlockable fun C] == [unlockable of C] with the expansion forced to be *) -(* an explicit lambda expression. *) -(* -> The usage pattern for ADT operations is: *) -(* Definition foo_def x1 .. xn := big_foo_expression. *) -(* Fact foo_key : unit. Proof. by []. Qed. *) -(* Definition foo := locked_with foo_key foo_def. *) -(* Canonical foo_unlockable := [unlockable fun foo]. *) -(* This minimizes the comparison overhead for foo, while still allowing *) -(* rewrite unlock to expose big_foo_expression. *) -(* More information about these definitions and their use can be found in the *) -(* ssreflect manual, and in specific comments below. *) -(******************************************************************************) + +(** + This file is the Gallina part of the ssreflect plugin implementation. + Files that use the ssreflect plugin should always Require ssreflect and + either Import ssreflect or Import ssreflect.SsrSyntax. + Part of the contents of this file is technical and will only interest + advanced developers; in addition the following are defined: + #[#the str of v by f#]# == the Canonical s : str such that f s = v. + #[#the str of v#]# == the Canonical s : str that coerces to v. + argumentType c == the T such that c : forall x : T, P x. + returnType c == the R such that c : T -> R. + {type of c for s} == P s where c : forall x : T, P x. + phantom T v == singleton type with inhabitant Phantom T v. + phant T == singleton type with inhabitant Phant v. + =^~ r == the converse of rewriting rule r (e.g., in a + rewrite multirule). + unkeyed t == t, but treated as an unkeyed matching pattern by + the ssreflect matching algorithm. + nosimpl t == t, but on the right-hand side of Definition C := + nosimpl disables expansion of C by /=. + locked t == t, but locked t is not convertible to t. + locked_with k t == t, but not convertible to t or locked_with k' t + unless k = k' (with k : unit). Coq type-checking + will be much more efficient if locked_with with a + bespoke k is used for sealed definitions. + unlockable v == interface for sealed constant definitions of v. + Unlockable def == the unlockable that registers def : C = v. + #[#unlockable of C#]# == a clone for C of the canonical unlockable for the + definition of C (e.g., if it uses locked_with). + #[#unlockable fun C#]# == #[#unlockable of C#]# with the expansion forced to be + an explicit lambda expression. + -> The usage pattern for ADT operations is: + Definition foo_def x1 .. xn := big_foo_expression. + Fact foo_key : unit. Proof. by #[# #]#. Qed. + Definition foo := locked_with foo_key foo_def. + Canonical foo_unlockable := #[#unlockable fun foo#]#. + This minimizes the comparison overhead for foo, while still allowing + rewrite unlock to expose big_foo_expression. + More information about these definitions and their use can be found in the + ssreflect manual, and in specific comments below. **) + Set Implicit Arguments. @@ -62,15 +65,16 @@ Unset Printing Implicit Defensive. Module SsrSyntax. -(* Declare Ssr keywords: 'is' 'of' '//' '/=' and '//='. We also declare the *) -(* parsing level 8, as a workaround for a notation grammar factoring problem. *) -(* Arguments of application-style notations (at level 10) should be declared *) -(* at level 8 rather than 9 or the camlp5 grammar will not factor properly. *) +(** + Declare Ssr keywords: 'is' 'of' '//' '/=' and '//='. We also declare the + parsing level 8, as a workaround for a notation grammar factoring problem. + Arguments of application-style notations (at level 10) should be declared + at level 8 rather than 9 or the camlp5 grammar will not factor properly. **) Reserved Notation "(* x 'is' y 'of' z 'isn't' // /= //= *)" (at level 8). Reserved Notation "(* 69 *)" (at level 69). -(* Non ambiguous keyword to check if the SsrSyntax module is imported *) +(** Non ambiguous keyword to check if the SsrSyntax module is imported **) Reserved Notation "(* Use to test if 'SsrSyntax_is_Imported' *)" (at level 8). Reserved Notation "<hidden n >" (at level 200). @@ -81,11 +85,13 @@ End SsrSyntax. Export SsrMatchingSyntax. Export SsrSyntax. -(* Make the general "if" into a notation, so that we can override it below. *) -(* The notations are "only parsing" because the Coq decompiler will not *) -(* recognize the expansion of the boolean if; using the default printer *) -(* avoids a spurrious trailing %GEN_IF. *) +(** + Make the general "if" into a notation, so that we can override it below. + The notations are "only parsing" because the Coq decompiler will not + recognize the expansion of the boolean if; using the default printer + avoids a spurrious trailing %%GEN_IF. **) +Declare Scope general_if_scope. Delimit Scope general_if_scope with GEN_IF. Notation "'if' c 'then' v1 'else' v2" := @@ -101,8 +107,9 @@ Notation "'if' c 'as' x 'return' t 'then' v1 'else' v2" := (at level 200, c, t, v1, v2 at level 200, x ident, only parsing) : general_if_scope. -(* Force boolean interpretation of simple if expressions. *) +(** Force boolean interpretation of simple if expressions. **) +Declare Scope boolean_if_scope. Delimit Scope boolean_if_scope with BOOL_IF. Notation "'if' c 'return' t 'then' v1 'else' v2" := @@ -116,37 +123,41 @@ Notation "'if' c 'as' x 'return' t 'then' v1 'else' v2" := Open Scope boolean_if_scope. -(* To allow a wider variety of notations without reserving a large number of *) -(* of identifiers, the ssreflect library systematically uses "forms" to *) -(* enclose complex mixfix syntax. A "form" is simply a mixfix expression *) -(* enclosed in square brackets and introduced by a keyword: *) -(* [keyword ... ] *) -(* Because the keyword follows a bracket it does not need to be reserved. *) -(* Non-ssreflect libraries that do not respect the form syntax (e.g., the Coq *) -(* Lists library) should be loaded before ssreflect so that their notations *) -(* do not mask all ssreflect forms. *) +(** + To allow a wider variety of notations without reserving a large number of + of identifiers, the ssreflect library systematically uses "forms" to + enclose complex mixfix syntax. A "form" is simply a mixfix expression + enclosed in square brackets and introduced by a keyword: + #[#keyword ... #]# + Because the keyword follows a bracket it does not need to be reserved. + Non-ssreflect libraries that do not respect the form syntax (e.g., the Coq + Lists library) should be loaded before ssreflect so that their notations + do not mask all ssreflect forms. **) +Declare Scope form_scope. Delimit Scope form_scope with FORM. Open Scope form_scope. -(* Allow overloading of the cast (x : T) syntax, put whitespace around the *) -(* ":" symbol to avoid lexical clashes (and for consistency with the parsing *) -(* precedence of the notation, which binds less tightly than application), *) -(* and put printing boxes that print the type of a long definition on a *) -(* separate line rather than force-fit it at the right margin. *) +(** + Allow overloading of the cast (x : T) syntax, put whitespace around the + ":" symbol to avoid lexical clashes (and for consistency with the parsing + precedence of the notation, which binds less tightly than application), + and put printing boxes that print the type of a long definition on a + separate line rather than force-fit it at the right margin. **) Notation "x : T" := (x : T) (at level 100, right associativity, format "'[hv' x '/ ' : T ']'") : core_scope. -(* Allow the casual use of notations like nat * nat for explicit Type *) -(* declarations. Note that (nat * nat : Type) is NOT equivalent to *) -(* (nat * nat)%type, whose inferred type is legacy type "Set". *) +(** + Allow the casual use of notations like nat * nat for explicit Type + declarations. Note that (nat * nat : Type) is NOT equivalent to + (nat * nat)%%type, whose inferred type is legacy type "Set". **) Notation "T : 'Type'" := (T%type : Type) (at level 100, only parsing) : core_scope. -(* Allow similarly Prop annotation for, e.g., rewrite multirules. *) +(** Allow similarly Prop annotation for, e.g., rewrite multirules. **) Notation "P : 'Prop'" := (P%type : Prop) (at level 100, only parsing) : core_scope. -(* Constants for abstract: and [: name ] intro pattern *) +(** Constants for abstract: and #[#: name #]# intro pattern **) Definition abstract_lock := unit. Definition abstract_key := tt. @@ -156,35 +167,40 @@ Definition abstract (statement : Type) (id : nat) (lock : abstract_lock) := Notation "<hidden n >" := (abstract _ n _). Notation "T (* n *)" := (abstract T n abstract_key). -(* Constants for tactic-views *) +Register abstract_lock as plugins.ssreflect.abstract_lock. +Register abstract_key as plugins.ssreflect.abstract_key. +Register abstract as plugins.ssreflect.abstract. + +(** Constants for tactic-views **) Inductive external_view : Type := tactic_view of Type. -(* Syntax for referring to canonical structures: *) -(* [the struct_type of proj_val by proj_fun] *) -(* This form denotes the Canonical instance s of the Structure type *) -(* struct_type whose proj_fun projection is proj_val, i.e., such that *) -(* proj_fun s = proj_val. *) -(* Typically proj_fun will be A record field accessors of struct_type, but *) -(* this need not be the case; it can be, for instance, a field of a record *) -(* type to which struct_type coerces; proj_val will likewise be coerced to *) -(* the return type of proj_fun. In all but the simplest cases, proj_fun *) -(* should be eta-expanded to allow for the insertion of implicit arguments. *) -(* In the common case where proj_fun itself is a coercion, the "by" part *) -(* can be omitted entirely; in this case it is inferred by casting s to the *) -(* inferred type of proj_val. Obviously the latter can be fixed by using an *) -(* explicit cast on proj_val, and it is highly recommended to do so when the *) -(* return type intended for proj_fun is "Type", as the type inferred for *) -(* proj_val may vary because of sort polymorphism (it could be Set or Prop). *) -(* Note when using the [the _ of _] form to generate a substructure from a *) -(* telescopes-style canonical hierarchy (implementing inheritance with *) -(* coercions), one should always project or coerce the value to the BASE *) -(* structure, because Coq will only find a Canonical derived structure for *) -(* the Canonical base structure -- not for a base structure that is specific *) -(* to proj_value. *) +(** + Syntax for referring to canonical structures: + #[#the struct_type of proj_val by proj_fun#]# + This form denotes the Canonical instance s of the Structure type + struct_type whose proj_fun projection is proj_val, i.e., such that + proj_fun s = proj_val. + Typically proj_fun will be A record field accessors of struct_type, but + this need not be the case; it can be, for instance, a field of a record + type to which struct_type coerces; proj_val will likewise be coerced to + the return type of proj_fun. In all but the simplest cases, proj_fun + should be eta-expanded to allow for the insertion of implicit arguments. + In the common case where proj_fun itself is a coercion, the "by" part + can be omitted entirely; in this case it is inferred by casting s to the + inferred type of proj_val. Obviously the latter can be fixed by using an + explicit cast on proj_val, and it is highly recommended to do so when the + return type intended for proj_fun is "Type", as the type inferred for + proj_val may vary because of sort polymorphism (it could be Set or Prop). + Note when using the #[#the _ of _ #]# form to generate a substructure from a + telescopes-style canonical hierarchy (implementing inheritance with + coercions), one should always project or coerce the value to the BASE + structure, because Coq will only find a Canonical derived structure for + the Canonical base structure -- not for a base structure that is specific + to proj_value. **) Module TheCanonical. -CoInductive put vT sT (v1 v2 : vT) (s : sT) := Put. +Variant put vT sT (v1 v2 : vT) (s : sT) := Put. Definition get vT sT v s (p : @put vT sT v v s) := let: Put _ _ _ := p in s. @@ -203,11 +219,12 @@ Notation "[ 'the' sT 'of' v 'by' f ]" := Notation "[ 'the' sT 'of' v ]" := (get ((fun s : sT => Put v (*coerce*)s s) _)) (at level 0, only parsing) : form_scope. -(* The following are "format only" versions of the above notations. Since Coq *) -(* doesn't provide this facility, we fake it by splitting the "the" keyword. *) -(* We need to do this to prevent the formatter from being be thrown off by *) -(* application collapsing, coercion insertion and beta reduction in the right *) -(* hand side of the notations above. *) +(** + The following are "format only" versions of the above notations. Since Coq + doesn't provide this facility, we fake it by splitting the "the" keyword. + We need to do this to prevent the formatter from being be thrown off by + application collapsing, coercion insertion and beta reduction in the right + hand side of the notations above. **) Notation "[ 'th' 'e' sT 'of' v 'by' f ]" := (@get_by _ sT f v _ _) (at level 0, format "[ 'th' 'e' sT 'of' v 'by' f ]") : form_scope. @@ -215,37 +232,39 @@ Notation "[ 'th' 'e' sT 'of' v 'by' f ]" := (@get_by _ sT f v _ _) Notation "[ 'th' 'e' sT 'of' v ]" := (@get _ sT v _ _) (at level 0, format "[ 'th' 'e' sT 'of' v ]") : form_scope. -(* We would like to recognize -Notation "[ 'th' 'e' sT 'of' v : 'Type' ]" := (@get Type sT v _ _) - (at level 0, format "[ 'th' 'e' sT 'of' v : 'Type' ]") : form_scope. -*) - -(* Helper notation for canonical structure inheritance support. *) -(* This is a workaround for the poor interaction between delta reduction and *) -(* canonical projections in Coq's unification algorithm, by which transparent *) -(* definitions hide canonical instances, i.e., in *) -(* Canonical a_type_struct := @Struct a_type ... *) -(* Definition my_type := a_type. *) -(* my_type doesn't effectively inherit the struct structure from a_type. Our *) -(* solution is to redeclare the instance as follows *) -(* Canonical my_type_struct := Eval hnf in [struct of my_type]. *) -(* The special notation [str of _] must be defined for each Strucure "str" *) -(* with constructor "Str", typically as follows *) -(* Definition clone_str s := *) -(* let: Str _ x y ... z := s return {type of Str for s} -> str in *) -(* fun k => k _ x y ... z. *) -(* Notation "[ 'str' 'of' T 'for' s ]" := (@clone_str s (@Str T)) *) -(* (at level 0, format "[ 'str' 'of' T 'for' s ]") : form_scope. *) -(* Notation "[ 'str' 'of' T ]" := (repack_str (fun x => @Str T x)) *) -(* (at level 0, format "[ 'str' 'of' T ]") : form_scope. *) -(* The notation for the match return predicate is defined below; the eta *) -(* expansion in the second form serves both to distinguish it from the first *) -(* and to avoid the delta reduction problem. *) -(* There are several variations on the notation and the definition of the *) -(* the "clone" function, for telescopes, mixin classes, and join (multiple *) -(* inheritance) classes. We describe a different idiom for clones in ssrfun; *) -(* it uses phantom types (see below) and static unification; see fintype and *) -(* ssralg for examples. *) +(** + We would like to recognize +Notation " #[# 'th' 'e' sT 'of' v : 'Type' #]#" := (@get Type sT v _ _) + (at level 0, format " #[# 'th' 'e' sT 'of' v : 'Type' #]#") : form_scope. + **) + +(** + Helper notation for canonical structure inheritance support. + This is a workaround for the poor interaction between delta reduction and + canonical projections in Coq's unification algorithm, by which transparent + definitions hide canonical instances, i.e., in + Canonical a_type_struct := @Struct a_type ... + Definition my_type := a_type. + my_type doesn't effectively inherit the struct structure from a_type. Our + solution is to redeclare the instance as follows + Canonical my_type_struct := Eval hnf in #[#struct of my_type#]#. + The special notation #[#str of _ #]# must be defined for each Strucure "str" + with constructor "Str", typically as follows + Definition clone_str s := + let: Str _ x y ... z := s return {type of Str for s} -> str in + fun k => k _ x y ... z. + Notation " #[# 'str' 'of' T 'for' s #]#" := (@clone_str s (@Str T)) + (at level 0, format " #[# 'str' 'of' T 'for' s #]#") : form_scope. + Notation " #[# 'str' 'of' T #]#" := (repack_str (fun x => @Str T x)) + (at level 0, format " #[# 'str' 'of' T #]#") : form_scope. + The notation for the match return predicate is defined below; the eta + expansion in the second form serves both to distinguish it from the first + and to avoid the delta reduction problem. + There are several variations on the notation and the definition of the + the "clone" function, for telescopes, mixin classes, and join (multiple + inheritance) classes. We describe a different idiom for clones in ssrfun; + it uses phantom types (see below) and static unification; see fintype and + ssralg for examples. **) Definition argumentType T P & forall x : T, P x := T. Definition dependentReturnType T P & forall x : T, P x := P. @@ -254,92 +273,100 @@ Definition returnType aT rT & aT -> rT := rT. Notation "{ 'type' 'of' c 'for' s }" := (dependentReturnType c s) (at level 0, format "{ 'type' 'of' c 'for' s }") : type_scope. -(* A generic "phantom" type (actually, a unit type with a phantom parameter). *) -(* This type can be used for type definitions that require some Structure *) -(* on one of their parameters, to allow Coq to infer said structure so it *) -(* does not have to be supplied explicitly or via the "[the _ of _]" notation *) -(* (the latter interacts poorly with other Notation). *) -(* The definition of a (co)inductive type with a parameter p : p_type, that *) -(* needs to use the operations of a structure *) -(* Structure p_str : Type := p_Str {p_repr :> p_type; p_op : p_repr -> ...} *) -(* should be given as *) -(* Inductive indt_type (p : p_str) := Indt ... . *) -(* Definition indt_of (p : p_str) & phantom p_type p := indt_type p. *) -(* Notation "{ 'indt' p }" := (indt_of (Phantom p)). *) -(* Definition indt p x y ... z : {indt p} := @Indt p x y ... z. *) -(* Notation "[ 'indt' x y ... z ]" := (indt x y ... z). *) -(* That is, the concrete type and its constructor should be shadowed by *) -(* definitions that use a phantom argument to infer and display the true *) -(* value of p (in practice, the "indt" constructor often performs additional *) -(* functions, like "locking" the representation -- see below). *) -(* We also define a simpler version ("phant" / "Phant") of phantom for the *) -(* common case where p_type is Type. *) - -CoInductive phantom T (p : T) := Phantom. +(** + A generic "phantom" type (actually, a unit type with a phantom parameter). + This type can be used for type definitions that require some Structure + on one of their parameters, to allow Coq to infer said structure so it + does not have to be supplied explicitly or via the " #[#the _ of _ #]#" notation + (the latter interacts poorly with other Notation). + The definition of a (co)inductive type with a parameter p : p_type, that + needs to use the operations of a structure + Structure p_str : Type := p_Str {p_repr :> p_type; p_op : p_repr -> ...} + should be given as + Inductive indt_type (p : p_str) := Indt ... . + Definition indt_of (p : p_str) & phantom p_type p := indt_type p. + Notation "{ 'indt' p }" := (indt_of (Phantom p)). + Definition indt p x y ... z : {indt p} := @Indt p x y ... z. + Notation " #[# 'indt' x y ... z #]#" := (indt x y ... z). + That is, the concrete type and its constructor should be shadowed by + definitions that use a phantom argument to infer and display the true + value of p (in practice, the "indt" constructor often performs additional + functions, like "locking" the representation -- see below). + We also define a simpler version ("phant" / "Phant") of phantom for the + common case where p_type is Type. **) + +Variant phantom T (p : T) := Phantom. Arguments phantom : clear implicits. Arguments Phantom : clear implicits. -CoInductive phant (p : Type) := Phant. +Variant phant (p : Type) := Phant. -(* Internal tagging used by the implementation of the ssreflect elim. *) +(** Internal tagging used by the implementation of the ssreflect elim. **) Definition protect_term (A : Type) (x : A) : A := x. -(* The ssreflect idiom for a non-keyed pattern: *) -(* - unkeyed t wiil match any subterm that unifies with t, regardless of *) -(* whether it displays the same head symbol as t. *) -(* - unkeyed t a b will match any application of a term f unifying with t, *) -(* to two arguments unifying with with a and b, repectively, regardless of *) -(* apparent head symbols. *) -(* - unkeyed x where x is a variable will match any subterm with the same *) -(* type as x (when x would raise the 'indeterminate pattern' error). *) +Register protect_term as plugins.ssreflect.protect_term. + +(** + The ssreflect idiom for a non-keyed pattern: + - unkeyed t wiil match any subterm that unifies with t, regardless of + whether it displays the same head symbol as t. + - unkeyed t a b will match any application of a term f unifying with t, + to two arguments unifying with with a and b, repectively, regardless of + apparent head symbols. + - unkeyed x where x is a variable will match any subterm with the same + type as x (when x would raise the 'indeterminate pattern' error). **) Notation unkeyed x := (let flex := x in flex). -(* Ssreflect converse rewrite rule rule idiom. *) +(** Ssreflect converse rewrite rule rule idiom. **) Definition ssr_converse R (r : R) := (Logic.I, r). Notation "=^~ r" := (ssr_converse r) (at level 100) : form_scope. -(* Term tagging (user-level). *) -(* The ssreflect library uses four strengths of term tagging to restrict *) -(* convertibility during type checking: *) -(* nosimpl t simplifies to t EXCEPT in a definition; more precisely, given *) -(* Definition foo := nosimpl bar, foo (or foo t') will NOT be expanded by *) -(* the /= and //= switches unless it is in a forcing context (e.g., in *) -(* match foo t' with ... end, foo t' will be reduced if this allows the *) -(* match to be reduced). Note that nosimpl bar is simply notation for a *) -(* a term that beta-iota reduces to bar; hence rewrite /foo will replace *) -(* foo by bar, and rewrite -/foo will replace bar by foo. *) -(* CAVEAT: nosimpl should not be used inside a Section, because the end of *) -(* section "cooking" removes the iota redex. *) -(* locked t is provably equal to t, but is not convertible to t; 'locked' *) -(* provides support for selective rewriting, via the lock t : t = locked t *) -(* Lemma, and the ssreflect unlock tactic. *) -(* locked_with k t is equal but not convertible to t, much like locked t, *) -(* but supports explicit tagging with a value k : unit. This is used to *) -(* mitigate a flaw in the term comparison heuristic of the Coq kernel, *) -(* which treats all terms of the form locked t as equal and conpares their *) -(* arguments recursively, leading to an exponential blowup of comparison. *) -(* For this reason locked_with should be used rather than locked when *) -(* defining ADT operations. The unlock tactic does not support locked_with *) -(* but the unlock rewrite rule does, via the unlockable interface. *) -(* we also use Module Type ascription to create truly opaque constants, *) -(* because simple expansion of constants to reveal an unreducible term *) -(* doubles the time complexity of a negative comparison. Such opaque *) -(* constants can be expanded generically with the unlock rewrite rule. *) -(* See the definition of card and subset in fintype for examples of this. *) +(** + Term tagging (user-level). + The ssreflect library uses four strengths of term tagging to restrict + convertibility during type checking: + nosimpl t simplifies to t EXCEPT in a definition; more precisely, given + Definition foo := nosimpl bar, foo (or foo t') will NOT be expanded by + the /= and //= switches unless it is in a forcing context (e.g., in + match foo t' with ... end, foo t' will be reduced if this allows the + match to be reduced). Note that nosimpl bar is simply notation for a + a term that beta-iota reduces to bar; hence rewrite /foo will replace + foo by bar, and rewrite -/foo will replace bar by foo. + CAVEAT: nosimpl should not be used inside a Section, because the end of + section "cooking" removes the iota redex. + locked t is provably equal to t, but is not convertible to t; 'locked' + provides support for selective rewriting, via the lock t : t = locked t + Lemma, and the ssreflect unlock tactic. + locked_with k t is equal but not convertible to t, much like locked t, + but supports explicit tagging with a value k : unit. This is used to + mitigate a flaw in the term comparison heuristic of the Coq kernel, + which treats all terms of the form locked t as equal and conpares their + arguments recursively, leading to an exponential blowup of comparison. + For this reason locked_with should be used rather than locked when + defining ADT operations. The unlock tactic does not support locked_with + but the unlock rewrite rule does, via the unlockable interface. + we also use Module Type ascription to create truly opaque constants, + because simple expansion of constants to reveal an unreducible term + doubles the time complexity of a negative comparison. Such opaque + constants can be expanded generically with the unlock rewrite rule. + See the definition of card and subset in fintype for examples of this. **) Notation nosimpl t := (let: tt := tt in t). Lemma master_key : unit. Proof. exact tt. Qed. Definition locked A := let: tt := master_key in fun x : A => x. +Register master_key as plugins.ssreflect.master_key. +Register locked as plugins.ssreflect.locked. + Lemma lock A x : x = locked x :> A. Proof. unlock; reflexivity. Qed. -(* Needed for locked predicates, in particular for eqType's. *) +(** Needed for locked predicates, in particular for eqType's. **) Lemma not_locked_false_eq_true : locked false <> true. Proof. unlock; discriminate. Qed. -(* The basic closing tactic "done". *) +(** The basic closing tactic "done". **) Ltac done := trivial; hnf; intros; solve [ do ![solve [trivial | apply: sym_equal; trivial] @@ -347,7 +374,7 @@ Ltac done := | case not_locked_false_eq_true; assumption | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. -(* Quicker done tactic not including split, syntax: /0/ *) +(** Quicker done tactic not including split, syntax: /0/ **) Ltac ssrdone0 := trivial; hnf; intros; solve [ do ![solve [trivial | apply: sym_equal; trivial] @@ -355,7 +382,7 @@ Ltac ssrdone0 := | case not_locked_false_eq_true; assumption | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. -(* To unlock opaque constants. *) +(** To unlock opaque constants. **) Structure unlockable T v := Unlockable {unlocked : T; _ : unlocked = v}. Lemma unlock T x C : @unlocked T x C = x. Proof. by case: C. Qed. @@ -365,25 +392,26 @@ Notation "[ 'unlockable' 'of' C ]" := (@Unlockable _ _ C (unlock _)) Notation "[ 'unlockable' 'fun' C ]" := (@Unlockable _ (fun _ => _) C (unlock _)) (at level 0, format "[ 'unlockable' 'fun' C ]") : form_scope. -(* Generic keyed constant locking. *) +(** Generic keyed constant locking. **) -(* The argument order ensures that k is always compared before T. *) +(** The argument order ensures that k is always compared before T. **) Definition locked_with k := let: tt := k in fun T x => x : T. -(* This can be used as a cheap alternative to cloning the unlockable instance *) -(* below, but with caution as unkeyed matching can be expensive. *) +(** + This can be used as a cheap alternative to cloning the unlockable instance + below, but with caution as unkeyed matching can be expensive. **) Lemma locked_withE T k x : unkeyed (locked_with k x) = x :> T. Proof. by case: k. Qed. -(* Intensionaly, this instance will not apply to locked u. *) +(** Intensionaly, this instance will not apply to locked u. **) Canonical locked_with_unlockable T k x := @Unlockable T x (locked_with k x) (locked_withE k x). -(* More accurate variant of unlock, and safer alternative to locked_withE. *) +(** More accurate variant of unlock, and safer alternative to locked_withE. **) Lemma unlock_with T k x : unlocked (locked_with_unlockable k x) = x :> T. Proof. exact: unlock. Qed. -(* The internal lemmas for the have tactics. *) +(** The internal lemmas for the have tactics. **) Definition ssr_have Plemma Pgoal (step : Plemma) rest : Pgoal := rest step. Arguments ssr_have Plemma [Pgoal]. @@ -392,13 +420,19 @@ Definition ssr_have_let Pgoal Plemma step (rest : let x : Plemma := step in Pgoal) : Pgoal := rest. Arguments ssr_have_let [Pgoal]. +Register ssr_have as plugins.ssreflect.ssr_have. +Register ssr_have_let as plugins.ssreflect.ssr_have_let. + Definition ssr_suff Plemma Pgoal step (rest : Plemma) : Pgoal := step rest. Arguments ssr_suff Plemma [Pgoal]. Definition ssr_wlog := ssr_suff. Arguments ssr_wlog Plemma [Pgoal]. -(* Internal N-ary congruence lemmas for the congr tactic. *) +Register ssr_suff as plugins.ssreflect.ssr_suff. +Register ssr_wlog as plugins.ssreflect.ssr_wlog. + +(** Internal N-ary congruence lemmas for the congr tactic. **) Fixpoint nary_congruence_statement (n : nat) : (forall B, (B -> B -> Prop) -> Prop) -> Prop := @@ -422,7 +456,10 @@ Lemma ssr_congr_arrow Plemma Pgoal : Plemma = Pgoal -> Plemma -> Pgoal. Proof. by move->. Qed. Arguments ssr_congr_arrow : clear implicits. -(* View lemmas that don't use reflection. *) +Register nary_congruence as plugins.ssreflect.nary_congruence. +Register ssr_congr_arrow as plugins.ssreflect.ssr_congr_arrow. + +(** View lemmas that don't use reflection. **) Section ApplyIff. @@ -440,14 +477,15 @@ End ApplyIff. Hint View for move/ iffLRn|2 iffRLn|2 iffLR|2 iffRL|2. Hint View for apply/ iffRLn|2 iffLRn|2 iffRL|2 iffLR|2. -(* To focus non-ssreflect tactics on a subterm, eg vm_compute. *) -(* Usage: *) -(* elim/abstract_context: (pattern) => G defG. *) -(* vm_compute; rewrite {}defG {G}. *) -(* Note that vm_cast are not stored in the proof term *) -(* for reductions occuring in the context, hence *) -(* set here := pattern; vm_compute in (value of here) *) -(* blows up at Qed time. *) +(** + To focus non-ssreflect tactics on a subterm, eg vm_compute. + Usage: + elim/abstract_context: (pattern) => G defG. + vm_compute; rewrite {}defG {G}. + Note that vm_cast are not stored in the proof term + for reductions occuring in the context, hence + set here := pattern; vm_compute in (value of here) + blows up at Qed time. **) Lemma abstract_context T (P : T -> Type) x : (forall Q, Q = P -> Q x) -> P x. Proof. by move=> /(_ P); apply. Qed. diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 717657a247..2c9ec3a7cf 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -14,9 +14,9 @@ open Util open Names open Printer open Term +open Constr open Termops -open Globnames -open Misctypes +open Tactypes open Tacmach open Ssrmatching_plugin @@ -97,6 +97,11 @@ let subgoals_tys sigma (relctx, concl) = * generalize the equality in case eqid is not None * 4. build the tactic handle intructions and clears as required in ipats and * by eqid *) + +let get_eq_type gl = + let eq, gl = pf_fresh_global Coqlib.(lib_ref "core.eq.type") gl in + gl, EConstr.of_constr eq + let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac gl = (* some sanity checks *) let oc, orig_clr, occ, c_gen, gl = match what with @@ -114,8 +119,6 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac let orig_gl, concl, env = gl, pf_concl gl, pf_env gl in ppdebug(lazy(Pp.str(if is_case then "==CASE==" else "==ELIM=="))); let fire_subst gl t = Reductionops.nf_evar (project gl) t in - let eq, gl = pf_fresh_global (Coqlib.build_coq_eq ()) gl in - let eq = EConstr.of_constr eq in let is_undef_pat = function | sigma, T t -> EConstr.isEvar sigma (EConstr.of_constr t) | _ -> false in @@ -292,7 +295,8 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac let c, cl, ucst = match_pat env p occ h cl in let gl = pf_merge_uc ucst gl in let c = EConstr.of_constr c in - let gl = try pf_unify_HO gl inf_t c with _ -> error gl c inf_t in + let gl = try pf_unify_HO gl inf_t c + with exn when CErrors.noncritical exn -> error gl c inf_t in cl, gl, post with | NoMatch | NoProgress -> @@ -301,7 +305,8 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac let e = EConstr.of_constr e in let n, e, _, _ucst = pf_abs_evars gl (fst p, e) in let e, _, _, gl = pf_saturate ~beta:true gl e n in - let gl = try pf_unify_HO gl inf_t e with _ -> error gl e inf_t in + let gl = try pf_unify_HO gl inf_t e + with exn when CErrors.noncritical exn -> error gl e inf_t in cl, gl, post in let rec match_all concl gl patterns = @@ -319,6 +324,7 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac let k = List.length deps in let c = fire_subst gl (List.assoc (n_elim_args - k - 1) elim_args) in let gl, t = pfe_type_of gl c in + let gl, eq = get_eq_type gl in let gen_eq_tac, gl = let refl = EConstr.mkApp (eq, [|t; c; c|]) in let new_concl = EConstr.mkArrow refl (EConstr.Vars.lift 1 (pf_concl orig_gl)) in @@ -347,6 +353,7 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac ppdebug(lazy Pp.(str"elim_pred_ty=" ++ pp_term gl pty)); let gl = pf_unify_HO gl pred elim_pred in let elim = fire_subst gl elim in + let gl = pf_resolve_typeclasses ~where:elim ~fail:false gl in let gl, _ = pf_e_type_of gl elim in (* check that the patterns do not contain non instantiated dependent metas *) let () = @@ -356,7 +363,7 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac let ev = List.fold_left Evar.Set.union Evar.Set.empty patterns_ev in let ty_ev = Evar.Set.fold (fun i e -> let ex = i in - let i_ty = EConstr.of_constr (Evd.evar_concl (Evd.find (project gl) ex)) in + let i_ty = Evd.evar_concl (Evd.find (project gl) ex) in Evar.Set.union e (evars_of_term i_ty)) ev Evar.Set.empty in let inter = Evar.Set.inter ev ty_ev in @@ -391,13 +398,13 @@ let revtoptac n0 gl = let dc, cl = EConstr.decompose_prod_n_assum (project gl) n (pf_concl gl) in let dc' = dc @ [Context.Rel.Declaration.LocalAssum(Name rev_id, EConstr.it_mkProd_or_LetIn cl (List.rev dc))] in let f = EConstr.it_mkLambda_or_LetIn (mkEtaApp (EConstr.mkRel (n + 1)) (-n) 1) dc' in - refine (EConstr.mkApp (f, [|Evarutil.mk_new_meta ()|])) gl + Refiner.refiner ~check:true EConstr.Unsafe.(to_constr (EConstr.mkApp (f, [|Evarutil.mk_new_meta ()|]))) gl let equality_inj l b id c gl = let msg = ref "" in try Proofview.V82.of_tactic (Equality.inj None l b None c) gl with - | Ploc.Exc(_,CErrors.UserError (_,s)) + | Gramlib.Ploc.Exc(_,CErrors.UserError (_,s)) | CErrors.UserError (_,s) when msg := Pp.string_of_ppcmds s; !msg = "Not a projectable equality but a discriminable one." || @@ -418,7 +425,7 @@ let injectl2rtac sigma c = match EConstr.kind sigma c with let is_injection_case c gl = let gl, cty = pfe_type_of gl c in let (mind,_), _ = pf_reduce_to_quantified_ind gl cty in - eq_gr (IndRef mind) (Coqlib.build_coq_eq ()) + Coqlib.check_ind_ref "core.eq.type" mind let perform_injection c gl = let gl, cty = pfe_type_of gl c in diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 57635edac4..22475fef34 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -115,7 +115,8 @@ let newssrcongrtac arg ist gl = (* utils *) let fs gl t = Reductionops.nf_evar (project gl) t in let tclMATCH_GOAL (c, gl_c) proj t_ok t_fail gl = - match try Some (pf_unify_HO gl_c (pf_concl gl) c) with _ -> None with + match try Some (pf_unify_HO gl_c (pf_concl gl) c) + with exn when CErrors.noncritical exn -> None with | Some gl_c -> tclTHEN (Proofview.V82.of_tactic (convert_concl (fs gl_c c))) (t_ok (proj gl_c)) gl @@ -129,7 +130,7 @@ let newssrcongrtac arg ist gl = let ssr_congr lr = EConstr.mkApp (arr, lr) in (* here thw two cases: simple equality or arrow *) let equality, _, eq_args, gl' = - let eq, gl = pf_fresh_global (Coqlib.build_coq_eq ()) gl in + let eq, gl = pf_fresh_global Coqlib.(lib_ref "core.eq.type") gl in pf_saturate gl (EConstr.of_constr eq) 3 in tclMATCH_GOAL (equality, gl') (fun gl' -> fs gl' (List.assoc 0 eq_args)) (fun ty -> congrtac (arg, Detyping.detype Detyping.Now false Id.Set.empty (pf_env gl) (project gl) ty) ist) @@ -276,7 +277,7 @@ let unfoldintac occ rdx t (kt,_) gl = let foldtac occ rdx ft gl = let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in let sigma, t = ft in - let t = EConstr.to_constr sigma t in + let t = EConstr.to_constr ~abort_on_undefined_evars:false sigma t in let fold, conclude = match rdx with | Some (_, (In_T _ | In_X_In_T _)) | None -> let ise = Evd.create_evar_defs sigma in @@ -287,7 +288,10 @@ let foldtac occ rdx ft gl = (fun env c _ h -> try find_T env c h ~k:(fun env t _ _ -> t) with NoMatch ->c), (fun () -> try end_T () with NoMatch -> fake_pmatcher_end ()) | _ -> - (fun env c _ h -> try let sigma = unify_HO env sigma (EConstr.of_constr c) (EConstr.of_constr t) in EConstr.to_constr sigma (EConstr.of_constr t) + (fun env c _ h -> + try + let sigma = unify_HO env sigma (EConstr.of_constr c) (EConstr.of_constr t) in + EConstr.to_constr ~abort_on_undefined_evars:false sigma (EConstr.of_constr t) with _ -> errorstrm Pp.(str "fold pattern " ++ pr_constr_pat t ++ spc () ++ str "does not match redex " ++ pr_constr_pat c)), fake_pmatcher_end in @@ -333,9 +337,9 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = let elim, gl = pf_fresh_global (Indrec.lookup_eliminator ind sort) gl in if dir = R2L then elim, gl else (* taken from Coq's rewrite *) let elim, _ = destConst elim in - let mp,dp,l = Constant.repr3 (Constant.make1 (Constant.canonical elim)) in + let mp,l = Constant.repr2 (Constant.make1 (Constant.canonical elim)) in let l' = Label.of_id (Nameops.add_suffix (Label.to_id l) "_r") in - let c1' = Global.constant_of_delta_kn (Constant.canonical (Constant.make3 mp dp l')) in + let c1' = Global.constant_of_delta_kn (Constant.canonical (Constant.make2 mp l')) in mkConst c1', gl in let elim = EConstr.of_constr elim in let proof = EConstr.mkApp (elim, [| rdx_ty; new_rdx; pred; p; rdx; c |]) in @@ -359,7 +363,7 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = let evs = Evar.Set.elements (Evarutil.undefined_evars_of_term sigma t) in let open_evs = List.filter (fun k -> Sorts.InProp <> Retyping.get_sort_family_of - env sigma (EConstr.of_constr (Evd.evar_concl (Evd.find sigma k)))) + env sigma (Evd.evar_concl (Evd.find sigma k))) evs in if open_evs <> [] then Some name else None) (List.combine (Array.to_list args) names) @@ -369,10 +373,14 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = ;; let is_construct_ref sigma c r = - EConstr.isConstruct sigma c && eq_gr (ConstructRef (fst(EConstr.destConstruct sigma c))) r -let is_ind_ref sigma c r = EConstr.isInd sigma c && eq_gr (IndRef (fst(EConstr.destInd sigma c))) r + EConstr.isConstruct sigma c && GlobRef.equal (ConstructRef (fst(EConstr.destConstruct sigma c))) r +let is_ind_ref sigma c r = EConstr.isInd sigma c && GlobRef.equal (IndRef (fst(EConstr.destInd sigma c))) r let rwcltac cl rdx dir sr gl = + let sr = + let sigma, r = sr in + let sigma = resolve_typeclasses ~where:r ~fail:false (pf_env gl) sigma in + sigma, r in let n, r_n,_, ucst = pf_abs_evars gl sr in let r_n' = pf_abs_cterm gl n r_n in let r' = EConstr.Vars.subst_var pattern_id r_n' in @@ -382,7 +390,7 @@ let rwcltac cl rdx dir sr gl = ppdebug(lazy Pp.(str"r@rwcltac=" ++ pr_econstr_env (pf_env gl) (project gl) (snd sr))); let cvtac, rwtac, gl = if EConstr.Vars.closed0 (project gl) r' then - let env, sigma, c, c_eq = pf_env gl, fst sr, snd sr, Coqlib.build_coq_eq () in + let env, sigma, c, c_eq = pf_env gl, fst sr, snd sr, Coqlib.(lib_ref "core.eq.type") in let sigma, c_ty = Typing.type_of env sigma c in ppdebug(lazy Pp.(str"c_ty@rwcltac=" ++ pr_econstr_env env sigma c_ty)); match EConstr.kind_of_type sigma (Reductionops.whd_all env sigma c_ty) with @@ -414,31 +422,25 @@ let rwcltac cl rdx dir sr gl = then errorstrm Pp.(str "Rewriting impacts evars") else errorstrm Pp.(str "Dependent type error in rewrite of " ++ pr_constr_env (pf_env gl) (project gl) (Term.mkNamedLambda pattern_id (EConstr.Unsafe.to_constr rdxt) (EConstr.Unsafe.to_constr cl))) - | CErrors.UserError _ as e -> raise e - | e -> anomaly ("cvtac's exception: " ^ Printexc.to_string e); in tclTHEN cvtac' rwtac gl -let prof_rwcltac = mk_profiler "rwrxtac.rwcltac";; -let rwcltac cl rdx dir sr gl = - prof_rwcltac.profile (rwcltac cl rdx dir sr) gl -;; - +[@@@ocaml.warning "-3"] let lz_coq_prod = let prod = lazy (Coqlib.build_prod ()) in fun () -> Lazy.force prod let lz_setoid_relation = let sdir = ["Classes"; "RelationClasses"] in - let last_srel = ref (Environ.empty_env, None) in + let last_srel = ref None in fun env -> match !last_srel with - | env', srel when env' == env -> srel + | Some (env', srel) when env' == env -> srel | _ -> let srel = - try Some (Universes.constr_of_global @@ - Coqlib.coq_reference "Class_setoid" sdir "RewriteRelation") + try Some (UnivGen.constr_of_global @@ + Coqlib.find_reference "Class_setoid" ("Coq"::sdir) "RewriteRelation" [@ocaml.warning "-3"]) with _ -> None in - last_srel := (env, srel); srel + last_srel := Some (env, srel); srel let ssr_is_setoid env = match lz_setoid_relation env with @@ -448,8 +450,6 @@ let ssr_is_setoid env = Rewrite.is_applied_rewrite_relation env sigma [] (EConstr.mkApp (r, args)) <> None -let prof_rwxrtac_find_rule = mk_profiler "rwrxtac.find_rule";; - let closed0_check cl p gl = if closed0 cl then errorstrm Pp.(str"No occurrence of redex "++ pr_constr_env (pf_env gl) (project gl) p) @@ -478,11 +478,11 @@ let rwprocess_rule dir rule gl = | _ -> let ra = Array.append a [|r|] in function 1 -> let sigma, pi1 = Evd.fresh_global env sigma coq_prod.Coqlib.proj1 in - EConstr.mkApp (EConstr.of_constr pi1, ra), sigma + EConstr.mkApp (pi1, ra), sigma | _ -> let sigma, pi2 = Evd.fresh_global env sigma coq_prod.Coqlib.proj2 in - EConstr.mkApp (EConstr.of_constr pi2, ra), sigma in - if EConstr.eq_constr sigma a.(0) (EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_True ())) then + EConstr.mkApp (pi2, ra), sigma in + if EConstr.eq_constr sigma a.(0) (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.(lib_ref "core.True.type"))) then let s, sigma = sr sigma 2 in loop (converse_dir d) sigma s a.(1) rs 0 else @@ -549,7 +549,6 @@ let rwrxtac occ rdx_pat dir rule gl = d, (ise, Evd.evar_universe_context ise, Reductionops.nf_evar ise r) with _ -> rwtac rs in rwtac rules in - let find_rule rdx = prof_rwxrtac_find_rule.profile find_rule rdx in let sigma0, env0, concl0 = project gl, pf_env gl, pf_concl gl in let find_R, conclude = match rdx_pat with | Some (_, (In_T _ | In_X_In_T _)) | None -> @@ -557,7 +556,7 @@ let rwrxtac occ rdx_pat dir rule gl = let rpat env sigma0 (sigma, pats) (d, r, lhs, rhs) = let sigma, pat = let rw_progress rhs t evd = rw_progress rhs (EConstr.of_constr t) evd in - mk_tpattern env sigma0 (sigma,EConstr.to_constr sigma r) (rw_progress rhs) d (EConstr.to_constr sigma lhs) in + mk_tpattern env sigma0 (sigma, EConstr.to_constr ~abort_on_undefined_evars:false sigma r) (rw_progress rhs) d (EConstr.to_constr ~abort_on_undefined_evars:false sigma lhs) in sigma, pats @ [pat] in let rpats = List.fold_left (rpat env0 sigma0) (r_sigma,[]) rules in let find_R, end_R = mk_tpattern_matcher sigma0 occ ~upats_origin rpats in @@ -567,7 +566,7 @@ let rwrxtac occ rdx_pat dir rule gl = let r = ref None in (fun env c _ h -> do_once r (fun () -> find_rule (EConstr.of_constr c), c); mkRel h), (fun concl -> closed0_check concl e gl; - let (d,(ev,ctx,c)) , x = assert_done r in (d,(ev,ctx, EConstr.to_constr ev c)) , x) in + let (d,(ev,ctx,c)) , x = assert_done r in (d,(ev,ctx, EConstr.to_constr ~abort_on_undefined_evars:false ev c)) , x) in let concl0 = EConstr.Unsafe.to_constr concl0 in let concl = eval_pattern env0 sigma0 concl0 rdx_pat occ find_R in let (d, r), rdx = conclude concl in @@ -575,11 +574,6 @@ let rwrxtac occ rdx_pat dir rule gl = rwcltac (EConstr.of_constr concl) (EConstr.of_constr rdx) d r gl ;; -let prof_rwxrtac = mk_profiler "rwrxtac";; -let rwrxtac occ rdx_pat dir rule gl = - prof_rwxrtac.profile (rwrxtac occ rdx_pat dir rule) gl -;; - let ssrinstancesofrule ist dir arg gl = let sigma0, env0, concl0 = project gl, pf_env gl, pf_concl gl in let rule = interp_term ist gl arg in @@ -589,7 +583,10 @@ let ssrinstancesofrule ist dir arg gl = let rpat env sigma0 (sigma, pats) (d, r, lhs, rhs) = let sigma, pat = let rw_progress rhs t evd = rw_progress rhs (EConstr.of_constr t) evd in - mk_tpattern env sigma0 (sigma,EConstr.to_constr sigma r) (rw_progress rhs) d (EConstr.to_constr sigma lhs) in + mk_tpattern env sigma0 + (sigma,EConstr.to_constr ~abort_on_undefined_evars:false sigma r) + (rw_progress rhs) d + (EConstr.to_constr ~abort_on_undefined_evars:false sigma lhs) in sigma, pats @ [pat] in let rpats = List.fold_left (rpat env0 sigma0) (r_sigma,[]) rules in mk_tpattern_matcher ~all_instances:true ~raise_NoMatch:true sigma0 None ~upats_origin rpats in diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v index ac2c78249b..6535cad8b7 100644 --- a/plugins/ssr/ssrfun.v +++ b/plugins/ssr/ssrfun.v @@ -10,225 +10,230 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(** #<style> .doc { font-family: monospace; white-space: pre; } </style># **) + Require Import ssreflect. -(******************************************************************************) -(* This file contains the basic definitions and notations for working with *) -(* functions. The definitions provide for: *) -(* *) -(* - Pair projections: *) -(* p.1 == first element of a pair *) -(* p.2 == second element of a pair *) -(* These notations also apply to p : P /\ Q, via an and >-> pair coercion. *) -(* *) -(* - Simplifying functions, beta-reduced by /= and simpl: *) -(* [fun : T => E] == constant function from type T that returns E *) -(* [fun x => E] == unary function *) -(* [fun x : T => E] == unary function with explicit domain type *) -(* [fun x y => E] == binary function *) -(* [fun x y : T => E] == binary function with common domain type *) -(* [fun (x : T) y => E] \ *) -(* [fun (x : xT) (y : yT) => E] | == binary function with (some) explicit, *) -(* [fun x (y : T) => E] / independent domain types for each argument *) -(* *) -(* - Partial functions using option type: *) -(* oapp f d ox == if ox is Some x returns f x, d otherwise *) -(* odflt d ox == if ox is Some x returns x, d otherwise *) -(* obind f ox == if ox is Some x returns f x, None otherwise *) -(* omap f ox == if ox is Some x returns Some (f x), None otherwise *) -(* *) -(* - Singleton types: *) -(* all_equal_to x0 == x0 is the only value in its type, so any such value *) -(* can be rewritten to x0. *) -(* *) -(* - A generic wrapper type: *) -(* wrapped T == the inductive type with values Wrap x for x : T. *) -(* unwrap w == the projection of w : wrapped T on T. *) -(* wrap x == the canonical injection of x : T into wrapped T; it is *) -(* equivalent to Wrap x, but is declared as a (default) *) -(* Canonical Structure, which lets the Coq HO unification *) -(* automatically expand x into unwrap (wrap x). The delta *) -(* reduction of wrap x to Wrap can be exploited to *) -(* introduce controlled nondeterminism in Canonical *) -(* Structure inference, as in the implementation of *) -(* the mxdirect predicate in matrix.v. *) -(* *) -(* - Sigma types: *) -(* tag w == the i of w : {i : I & T i}. *) -(* tagged w == the T i component of w : {i : I & T i}. *) -(* Tagged T x == the {i : I & T i} with component x : T i. *) -(* tag2 w == the i of w : {i : I & T i & U i}. *) -(* tagged2 w == the T i component of w : {i : I & T i & U i}. *) -(* tagged2' w == the U i component of w : {i : I & T i & U i}. *) -(* Tagged2 T U x y == the {i : I & T i} with components x : T i and y : U i. *) -(* sval u == the x of u : {x : T | P x}. *) -(* s2val u == the x of u : {x : T | P x & Q x}. *) -(* The properties of sval u, s2val u are given by lemmas svalP, s2valP, and *) -(* s2valP'. We provide coercions sigT2 >-> sigT and sig2 >-> sig >-> sigT. *) -(* A suite of lemmas (all_sig, ...) let us skolemize sig, sig2, sigT, sigT2 *) -(* and pair, e.g., *) -(* have /all_sig[f fP] (x : T): {y : U | P y} by ... *) -(* yields an f : T -> U such that fP : forall x, P (f x). *) -(* - Identity functions: *) -(* id == NOTATION for the explicit identity function fun x => x. *) -(* @id T == notation for the explicit identity at type T. *) -(* idfun == an expression with a head constant, convertible to id; *) -(* idfun x simplifies to x. *) -(* @idfun T == the expression above, specialized to type T. *) -(* phant_id x y == the function type phantom _ x -> phantom _ y. *) -(* *** In addition to their casual use in functional programming, identity *) -(* functions are often used to trigger static unification as part of the *) -(* construction of dependent Records and Structures. For example, if we need *) -(* a structure sT over a type T, we take as arguments T, sT, and a "dummy" *) -(* function T -> sort sT: *) -(* Definition foo T sT & T -> sort sT := ... *) -(* We can avoid specifying sT directly by calling foo (@id T), or specify *) -(* the call completely while still ensuring the consistency of T and sT, by *) -(* calling @foo T sT idfun. The phant_id type allows us to extend this trick *) -(* to non-Type canonical projections. It also allows us to sidestep *) -(* dependent type constraints when building explicit records, e.g., given *) -(* Record r := R {x; y : T(x)}. *) -(* if we need to build an r from a given y0 while inferring some x0, such *) -(* that y0 : T(x0), we pose *) -(* Definition mk_r .. y .. (x := ...) y' & phant_id y y' := R x y'. *) -(* Calling @mk_r .. y0 .. id will cause Coq to use y' := y0, while checking *) -(* the dependent type constraint y0 : T(x0). *) -(* *) -(* - Extensional equality for functions and relations (i.e. functions of two *) -(* arguments): *) -(* f1 =1 f2 == f1 x is equal to f2 x for all x. *) -(* f1 =1 f2 :> A == ... and f2 is explicitly typed. *) -(* f1 =2 f2 == f1 x y is equal to f2 x y for all x y. *) -(* f1 =2 f2 :> A == ... and f2 is explicitly typed. *) -(* *) -(* - Composition for total and partial functions: *) -(* f^~ y == function f with second argument specialised to y, *) -(* i.e., fun x => f x y *) -(* CAVEAT: conditional (non-maximal) implicit arguments *) -(* of f are NOT inserted in this context *) -(* @^~ x == application at x, i.e., fun f => f x *) -(* [eta f] == the explicit eta-expansion of f, i.e., fun x => f x *) -(* CAVEAT: conditional (non-maximal) implicit arguments *) -(* of f are NOT inserted in this context. *) -(* fun=> v := the constant function fun _ => v. *) -(* f1 \o f2 == composition of f1 and f2. *) -(* Note: (f1 \o f2) x simplifies to f1 (f2 x). *) -(* f1 \; f2 == categorical composition of f1 and f2. This expands to *) -(* to f2 \o f1 and (f1 \; f2) x simplifies to f2 (f1 x). *) -(* pcomp f1 f2 == composition of partial functions f1 and f2. *) -(* *) -(* *) -(* - Properties of functions: *) -(* injective f <-> f is injective. *) -(* cancel f g <-> g is a left inverse of f / f is a right inverse of g. *) -(* pcancel f g <-> g is a left inverse of f where g is partial. *) -(* ocancel f g <-> g is a left inverse of f where f is partial. *) -(* bijective f <-> f is bijective (has a left and right inverse). *) -(* involutive f <-> f is involutive. *) -(* *) -(* - Properties for operations. *) -(* left_id e op <-> e is a left identity for op (e op x = x). *) -(* right_id e op <-> e is a right identity for op (x op e = x). *) -(* left_inverse e inv op <-> inv is a left inverse for op wrt identity e, *) -(* i.e., (inv x) op x = e. *) -(* right_inverse e inv op <-> inv is a right inverse for op wrt identity e *) -(* i.e., x op (i x) = e. *) -(* self_inverse e op <-> each x is its own op-inverse (x op x = e). *) -(* idempotent op <-> op is idempotent for op (x op x = x). *) -(* associative op <-> op is associative, i.e., *) -(* x op (y op z) = (x op y) op z. *) -(* commutative op <-> op is commutative (x op y = y op x). *) -(* left_commutative op <-> op is left commutative, i.e., *) -(* x op (y op z) = y op (x op z). *) -(* right_commutative op <-> op is right commutative, i.e., *) -(* (x op y) op z = (x op z) op y. *) -(* left_zero z op <-> z is a left zero for op (z op x = z). *) -(* right_zero z op <-> z is a right zero for op (x op z = z). *) -(* left_distributive op1 op2 <-> op1 distributes over op2 to the left: *) -(* (x op2 y) op1 z = (x op1 z) op2 (y op1 z). *) -(* right_distributive op1 op2 <-> op distributes over add to the right: *) -(* x op1 (y op2 z) = (x op1 z) op2 (x op1 z). *) -(* interchange op1 op2 <-> op1 and op2 satisfy an interchange law: *) -(* (x op2 y) op1 (z op2 t) = (x op1 z) op2 (y op1 t). *) -(* Note that interchange op op is a commutativity property. *) -(* left_injective op <-> op is injective in its left argument: *) -(* x op y = z op y -> x = z. *) -(* right_injective op <-> op is injective in its right argument: *) -(* x op y = x op z -> y = z. *) -(* left_loop inv op <-> op, inv obey the inverse loop left axiom: *) -(* (inv x) op (x op y) = y for all x, y, i.e., *) -(* op (inv x) is always a left inverse of op x *) -(* rev_left_loop inv op <-> op, inv obey the inverse loop reverse left *) -(* axiom: x op ((inv x) op y) = y, for all x, y. *) -(* right_loop inv op <-> op, inv obey the inverse loop right axiom: *) -(* (x op y) op (inv y) = x for all x, y. *) -(* rev_right_loop inv op <-> op, inv obey the inverse loop reverse right *) -(* axiom: (x op y) op (inv y) = x for all x, y. *) -(* Note that familiar "cancellation" identities like x + y - y = x or *) -(* x - y + y = x are respectively instances of right_loop and rev_right_loop *) -(* The corresponding lemmas will use the K and NK/VK suffixes, respectively. *) -(* *) -(* - Morphisms for functions and relations: *) -(* {morph f : x / a >-> r} <-> f is a morphism with respect to functions *) -(* (fun x => a) and (fun x => r); if r == R[x], *) -(* this states that f a = R[f x] for all x. *) -(* {morph f : x / a} <-> f is a morphism with respect to the *) -(* function expression (fun x => a). This is *) -(* shorthand for {morph f : x / a >-> a}; note *) -(* that the two instances of a are often *) -(* interpreted at different types. *) -(* {morph f : x y / a >-> r} <-> f is a morphism with respect to functions *) -(* (fun x y => a) and (fun x y => r). *) -(* {morph f : x y / a} <-> f is a morphism with respect to the *) -(* function expression (fun x y => a). *) -(* {homo f : x / a >-> r} <-> f is a homomorphism with respect to the *) -(* predicates (fun x => a) and (fun x => r); *) -(* if r == R[x], this states that a -> R[f x] *) -(* for all x. *) -(* {homo f : x / a} <-> f is a homomorphism with respect to the *) -(* predicate expression (fun x => a). *) -(* {homo f : x y / a >-> r} <-> f is a homomorphism with respect to the *) -(* relations (fun x y => a) and (fun x y => r). *) -(* {homo f : x y / a} <-> f is a homomorphism with respect to the *) -(* relation expression (fun x y => a). *) -(* {mono f : x / a >-> r} <-> f is monotone with respect to projectors *) -(* (fun x => a) and (fun x => r); if r == R[x], *) -(* this states that R[f x] = a for all x. *) -(* {mono f : x / a} <-> f is monotone with respect to the projector *) -(* expression (fun x => a). *) -(* {mono f : x y / a >-> r} <-> f is monotone with respect to relators *) -(* (fun x y => a) and (fun x y => r). *) -(* {mono f : x y / a} <-> f is monotone with respect to the relator *) -(* expression (fun x y => a). *) -(* *) -(* The file also contains some basic lemmas for the above concepts. *) -(* Lemmas relative to cancellation laws use some abbreviated suffixes: *) -(* K - a cancellation rule like esymK : cancel (@esym T x y) (@esym T y x). *) -(* LR - a lemma moving an operation from the left hand side of a relation to *) -(* the right hand side, like canLR: cancel g f -> x = g y -> f x = y. *) -(* RL - a lemma moving an operation from the right to the left, e.g., canRL. *) -(* Beware that the LR and RL orientations refer to an "apply" (back chaining) *) -(* usage; when using the same lemmas with "have" or "move" (forward chaining) *) -(* the directions will be reversed!. *) -(******************************************************************************) + +(** + This file contains the basic definitions and notations for working with + functions. The definitions provide for: + + - Pair projections: + p.1 == first element of a pair + p.2 == second element of a pair + These notations also apply to p : P /\ Q, via an and >-> pair coercion. + + - Simplifying functions, beta-reduced by /= and simpl: + #[#fun : T => E#]# == constant function from type T that returns E + #[#fun x => E#]# == unary function + #[#fun x : T => E#]# == unary function with explicit domain type + #[#fun x y => E#]# == binary function + #[#fun x y : T => E#]# == binary function with common domain type + #[#fun (x : T) y => E#]# \ + #[#fun (x : xT) (y : yT) => E#]# | == binary function with (some) explicit, + #[#fun x (y : T) => E#]# / independent domain types for each argument + + - Partial functions using option type: + oapp f d ox == if ox is Some x returns f x, d otherwise + odflt d ox == if ox is Some x returns x, d otherwise + obind f ox == if ox is Some x returns f x, None otherwise + omap f ox == if ox is Some x returns Some (f x), None otherwise + + - Singleton types: + all_equal_to x0 == x0 is the only value in its type, so any such value + can be rewritten to x0. + + - A generic wrapper type: + wrapped T == the inductive type with values Wrap x for x : T. + unwrap w == the projection of w : wrapped T on T. + wrap x == the canonical injection of x : T into wrapped T; it is + equivalent to Wrap x, but is declared as a (default) + Canonical Structure, which lets the Coq HO unification + automatically expand x into unwrap (wrap x). The delta + reduction of wrap x to Wrap can be exploited to + introduce controlled nondeterminism in Canonical + Structure inference, as in the implementation of + the mxdirect predicate in matrix.v. + + - Sigma types: + tag w == the i of w : {i : I & T i}. + tagged w == the T i component of w : {i : I & T i}. + Tagged T x == the {i : I & T i} with component x : T i. + tag2 w == the i of w : {i : I & T i & U i}. + tagged2 w == the T i component of w : {i : I & T i & U i}. + tagged2' w == the U i component of w : {i : I & T i & U i}. + Tagged2 T U x y == the {i : I & T i} with components x : T i and y : U i. + sval u == the x of u : {x : T | P x}. + s2val u == the x of u : {x : T | P x & Q x}. + The properties of sval u, s2val u are given by lemmas svalP, s2valP, and + s2valP'. We provide coercions sigT2 >-> sigT and sig2 >-> sig >-> sigT. + A suite of lemmas (all_sig, ...) let us skolemize sig, sig2, sigT, sigT2 + and pair, e.g., + have /all_sig#[#f fP#]# (x : T): {y : U | P y} by ... + yields an f : T -> U such that fP : forall x, P (f x). + - Identity functions: + id == NOTATION for the explicit identity function fun x => x. + @id T == notation for the explicit identity at type T. + idfun == an expression with a head constant, convertible to id; + idfun x simplifies to x. + @idfun T == the expression above, specialized to type T. + phant_id x y == the function type phantom _ x -> phantom _ y. + *** In addition to their casual use in functional programming, identity + functions are often used to trigger static unification as part of the + construction of dependent Records and Structures. For example, if we need + a structure sT over a type T, we take as arguments T, sT, and a "dummy" + function T -> sort sT: + Definition foo T sT & T -> sort sT := ... + We can avoid specifying sT directly by calling foo (@id T), or specify + the call completely while still ensuring the consistency of T and sT, by + calling @foo T sT idfun. The phant_id type allows us to extend this trick + to non-Type canonical projections. It also allows us to sidestep + dependent type constraints when building explicit records, e.g., given + Record r := R {x; y : T(x)}. + if we need to build an r from a given y0 while inferring some x0, such + that y0 : T(x0), we pose + Definition mk_r .. y .. (x := ...) y' & phant_id y y' := R x y'. + Calling @mk_r .. y0 .. id will cause Coq to use y' := y0, while checking + the dependent type constraint y0 : T(x0). + + - Extensional equality for functions and relations (i.e. functions of two + arguments): + f1 =1 f2 == f1 x is equal to f2 x for all x. + f1 =1 f2 :> A == ... and f2 is explicitly typed. + f1 =2 f2 == f1 x y is equal to f2 x y for all x y. + f1 =2 f2 :> A == ... and f2 is explicitly typed. + + - Composition for total and partial functions: + f^~ y == function f with second argument specialised to y, + i.e., fun x => f x y + CAVEAT: conditional (non-maximal) implicit arguments + of f are NOT inserted in this context + @^~ x == application at x, i.e., fun f => f x + #[#eta f#]# == the explicit eta-expansion of f, i.e., fun x => f x + CAVEAT: conditional (non-maximal) implicit arguments + of f are NOT inserted in this context. + fun=> v := the constant function fun _ => v. + f1 \o f2 == composition of f1 and f2. + Note: (f1 \o f2) x simplifies to f1 (f2 x). + f1 \; f2 == categorical composition of f1 and f2. This expands to + to f2 \o f1 and (f1 \; f2) x simplifies to f2 (f1 x). + pcomp f1 f2 == composition of partial functions f1 and f2. + + + - Properties of functions: + injective f <-> f is injective. + cancel f g <-> g is a left inverse of f / f is a right inverse of g. + pcancel f g <-> g is a left inverse of f where g is partial. + ocancel f g <-> g is a left inverse of f where f is partial. + bijective f <-> f is bijective (has a left and right inverse). + involutive f <-> f is involutive. + + - Properties for operations. + left_id e op <-> e is a left identity for op (e op x = x). + right_id e op <-> e is a right identity for op (x op e = x). + left_inverse e inv op <-> inv is a left inverse for op wrt identity e, + i.e., (inv x) op x = e. + right_inverse e inv op <-> inv is a right inverse for op wrt identity e + i.e., x op (i x) = e. + self_inverse e op <-> each x is its own op-inverse (x op x = e). + idempotent op <-> op is idempotent for op (x op x = x). + associative op <-> op is associative, i.e., + x op (y op z) = (x op y) op z. + commutative op <-> op is commutative (x op y = y op x). + left_commutative op <-> op is left commutative, i.e., + x op (y op z) = y op (x op z). + right_commutative op <-> op is right commutative, i.e., + (x op y) op z = (x op z) op y. + left_zero z op <-> z is a left zero for op (z op x = z). + right_zero z op <-> z is a right zero for op (x op z = z). + left_distributive op1 op2 <-> op1 distributes over op2 to the left: + (x op2 y) op1 z = (x op1 z) op2 (y op1 z). + right_distributive op1 op2 <-> op distributes over add to the right: + x op1 (y op2 z) = (x op1 z) op2 (x op1 z). + interchange op1 op2 <-> op1 and op2 satisfy an interchange law: + (x op2 y) op1 (z op2 t) = (x op1 z) op2 (y op1 t). + Note that interchange op op is a commutativity property. + left_injective op <-> op is injective in its left argument: + x op y = z op y -> x = z. + right_injective op <-> op is injective in its right argument: + x op y = x op z -> y = z. + left_loop inv op <-> op, inv obey the inverse loop left axiom: + (inv x) op (x op y) = y for all x, y, i.e., + op (inv x) is always a left inverse of op x + rev_left_loop inv op <-> op, inv obey the inverse loop reverse left + axiom: x op ((inv x) op y) = y, for all x, y. + right_loop inv op <-> op, inv obey the inverse loop right axiom: + (x op y) op (inv y) = x for all x, y. + rev_right_loop inv op <-> op, inv obey the inverse loop reverse right + axiom: (x op y) op (inv y) = x for all x, y. + Note that familiar "cancellation" identities like x + y - y = x or + x - y + y = x are respectively instances of right_loop and rev_right_loop + The corresponding lemmas will use the K and NK/VK suffixes, respectively. + + - Morphisms for functions and relations: + {morph f : x / a >-> r} <-> f is a morphism with respect to functions + (fun x => a) and (fun x => r); if r == R#[#x#]#, + this states that f a = R#[#f x#]# for all x. + {morph f : x / a} <-> f is a morphism with respect to the + function expression (fun x => a). This is + shorthand for {morph f : x / a >-> a}; note + that the two instances of a are often + interpreted at different types. + {morph f : x y / a >-> r} <-> f is a morphism with respect to functions + (fun x y => a) and (fun x y => r). + {morph f : x y / a} <-> f is a morphism with respect to the + function expression (fun x y => a). + {homo f : x / a >-> r} <-> f is a homomorphism with respect to the + predicates (fun x => a) and (fun x => r); + if r == R#[#x#]#, this states that a -> R#[#f x#]# + for all x. + {homo f : x / a} <-> f is a homomorphism with respect to the + predicate expression (fun x => a). + {homo f : x y / a >-> r} <-> f is a homomorphism with respect to the + relations (fun x y => a) and (fun x y => r). + {homo f : x y / a} <-> f is a homomorphism with respect to the + relation expression (fun x y => a). + {mono f : x / a >-> r} <-> f is monotone with respect to projectors + (fun x => a) and (fun x => r); if r == R#[#x#]#, + this states that R#[#f x#]# = a for all x. + {mono f : x / a} <-> f is monotone with respect to the projector + expression (fun x => a). + {mono f : x y / a >-> r} <-> f is monotone with respect to relators + (fun x y => a) and (fun x y => r). + {mono f : x y / a} <-> f is monotone with respect to the relator + expression (fun x y => a). + + The file also contains some basic lemmas for the above concepts. + Lemmas relative to cancellation laws use some abbreviated suffixes: + K - a cancellation rule like esymK : cancel (@esym T x y) (@esym T y x). + LR - a lemma moving an operation from the left hand side of a relation to + the right hand side, like canLR: cancel g f -> x = g y -> f x = y. + RL - a lemma moving an operation from the right to the left, e.g., canRL. + Beware that the LR and RL orientations refer to an "apply" (back chaining) + usage; when using the same lemmas with "have" or "move" (forward chaining) + the directions will be reversed!. **) + Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. +Declare Scope fun_scope. Delimit Scope fun_scope with FUN. Open Scope fun_scope. -(* Notations for argument transpose *) +(** Notations for argument transpose **) Notation "f ^~ y" := (fun x => f x y) (at level 10, y at level 8, no associativity, format "f ^~ y") : fun_scope. Notation "@^~ x" := (fun f => f x) (at level 10, x at level 8, no associativity, format "@^~ x") : fun_scope. +Declare Scope pair_scope. Delimit Scope pair_scope with PAIR. Open Scope pair_scope. -(* Notations for pair/conjunction projections *) +(** Notations for pair/conjunction projections **) Notation "p .1" := (fst p) (at level 2, left associativity, format "p .1") : pair_scope. Notation "p .2" := (snd p) @@ -239,8 +244,9 @@ Coercion pair_of_and P Q (PandQ : P /\ Q) := (proj1 PandQ, proj2 PandQ). Definition all_pair I T U (w : forall i : I, T i * U i) := (fun i => (w i).1, fun i => (w i).2). -(* Complements on the option type constructor, used below to *) -(* encode partial functions. *) +(** + Complements on the option type constructor, used below to + encode partial functions. **) Module Option. @@ -260,7 +266,7 @@ Notation obind := Option.bind. Notation omap := Option.map. Notation some := (@Some _) (only parsing). -(* Shorthand for some basic equality lemmas. *) +(** Shorthand for some basic equality lemmas. **) Notation erefl := refl_equal. Notation ecast i T e x := (let: erefl in _ = i := e return T in x). @@ -269,31 +275,32 @@ Definition nesym := sym_not_eq. Definition etrans := trans_eq. Definition congr1 := f_equal. Definition congr2 := f_equal2. -(* Force at least one implicit when used as a view. *) +(** Force at least one implicit when used as a view. **) Prenex Implicits esym nesym. -(* A predicate for singleton types. *) +(** A predicate for singleton types. **) Definition all_equal_to T (x0 : T) := forall x, unkeyed x = x0. Lemma unitE : all_equal_to tt. Proof. by case. Qed. -(* A generic wrapper type *) +(** A generic wrapper type **) Structure wrapped T := Wrap {unwrap : T}. Canonical wrap T x := @Wrap T x. Prenex Implicits unwrap wrap Wrap. -(* Syntax for defining auxiliary recursive function. *) -(* Usage: *) -(* Section FooDefinition. *) -(* Variables (g1 : T1) (g2 : T2). (globals) *) -(* Fixoint foo_auxiliary (a3 : T3) ... := *) -(* body, using [rec e3, ...] for recursive calls *) -(* where "[ 'rec' a3 , a4 , ... ]" := foo_auxiliary. *) -(* Definition foo x y .. := [rec e1, ...]. *) -(* + proofs about foo *) -(* End FooDefinition. *) +(** + Syntax for defining auxiliary recursive function. + Usage: + Section FooDefinition. + Variables (g1 : T1) (g2 : T2). (globals) + Fixoint foo_auxiliary (a3 : T3) ... := + body, using #[#rec e3, ... #]# for recursive calls + where " #[# 'rec' a3 , a4 , ... #]#" := foo_auxiliary. + Definition foo x y .. := #[#rec e1, ... #]#. + + proofs about foo + End FooDefinition. **) Reserved Notation "[ 'rec' a0 ]" (at level 0, format "[ 'rec' a0 ]"). @@ -319,14 +326,15 @@ Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , a9 ]" (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , a9 ]"). -(* Definitions and notation for explicit functions with simplification, *) -(* i.e., which simpl and /= beta expand (this is complementary to nosimpl). *) +(** + Definitions and notation for explicit functions with simplification, + i.e., which simpl and /= beta expand (this is complementary to nosimpl). **) Section SimplFun. Variables aT rT : Type. -CoInductive simpl_fun := SimplFun of aT -> rT. +Variant simpl_fun := SimplFun of aT -> rT. Definition fun_of_simpl f := fun x => let: SimplFun lam := f in lam x. @@ -362,11 +370,12 @@ Notation "[ 'fun' ( x : xT ) ( y : yT ) => E ]" := (fun x : xT => [fun y : yT => E]) (at level 0, x ident, y ident, only parsing) : fun_scope. -(* For delta functions in eqtype.v. *) +(** For delta functions in eqtype.v. **) Definition SimplFunDelta aT rT (f : aT -> aT -> rT) := [fun z => f z z]. -(* Extensional equality, for unary and binary functions, including syntactic *) -(* sugar. *) +(** + Extensional equality, for unary and binary functions, including syntactic + sugar. **) Section ExtensionalEquality. @@ -389,7 +398,7 @@ End ExtensionalEquality. Typeclasses Opaque eqfun. Typeclasses Opaque eqrel. -Hint Resolve frefl rrefl. +Hint Resolve frefl rrefl : core. Notation "f1 =1 f2" := (eqfun f1 f2) (at level 70, no associativity) : fun_scope. @@ -439,7 +448,7 @@ Notation "@ 'idfun' T " := (@id_head T explicit_id_key) Definition phant_id T1 T2 v1 v2 := phantom T1 v1 -> phantom T2 v2. -(* Strong sigma types. *) +(** Strong sigma types. **) Section Tag. @@ -473,9 +482,9 @@ Lemma all_tag2 I T U V : {f : forall i, T i & forall i, U i (f i) & forall i, V i (f i)}. Proof. by case/all_tag=> f /all_pair[]; exists f. Qed. -(* Refinement types. *) +(** Refinement types. **) -(* Prenex Implicits and renaming. *) +(** Prenex Implicits and renaming. **) Notation sval := (@proj1_sig _ _). Notation "@ 'sval'" := (@proj1_sig) (at level 10, format "@ 'sval'"). @@ -514,16 +523,16 @@ Section Morphism. Variables (aT rT sT : Type) (f : aT -> rT). -(* Morphism property for unary and binary functions *) +(** Morphism property for unary and binary functions **) Definition morphism_1 aF rF := forall x, f (aF x) = rF (f x). Definition morphism_2 aOp rOp := forall x y, f (aOp x y) = rOp (f x) (f y). -(* Homomorphism property for unary and binary relations *) +(** Homomorphism property for unary and binary relations **) Definition homomorphism_1 (aP rP : _ -> Prop) := forall x, aP x -> rP (f x). Definition homomorphism_2 (aR rR : _ -> _ -> Prop) := forall x y, aR x y -> rR (f x) (f y). -(* Stability property for unary and binary relations *) +(** Stability property for unary and binary relations **) Definition monomorphism_1 (aP rP : _ -> sT) := forall x, rP (f x) = aP x. Definition monomorphism_2 (aR rR : _ -> _ -> sT) := forall x y, rR (f x) (f y) = aR x y. @@ -600,16 +609,18 @@ Notation "{ 'mono' f : x y /~ a }" := (at level 0, f at level 99, x ident, y ident, format "{ 'mono' f : x y /~ a }") : type_scope. -(* In an intuitionistic setting, we have two degrees of injectivity. The *) -(* weaker one gives only simplification, and the strong one provides a left *) -(* inverse (we show in `fintype' that they coincide for finite types). *) -(* We also define an intermediate version where the left inverse is only a *) -(* partial function. *) +(** + In an intuitionistic setting, we have two degrees of injectivity. The + weaker one gives only simplification, and the strong one provides a left + inverse (we show in `fintype' that they coincide for finite types). + We also define an intermediate version where the left inverse is only a + partial function. **) Section Injections. -(* rT must come first so we can use @ to mitigate the Coq 1st order *) -(* unification bug (e..g., Coq can't infer rT from a "cancel" lemma). *) +(** + rT must come first so we can use @ to mitigate the Coq 1st order + unification bug (e..g., Coq can't infer rT from a "cancel" lemma). **) Variables (rT aT : Type) (f : aT -> rT). Definition injective := forall x1 x2, f x1 = f x2 -> x1 = x2. @@ -639,10 +650,10 @@ End Injections. Lemma Some_inj {T} : injective (@Some T). Proof. by move=> x y []. Qed. -(* Force implicits to use as a view. *) +(** Force implicits to use as a view. **) Prenex Implicits Some_inj. -(* cancellation lemmas for dependent type casts. *) +(** cancellation lemmas for dependent type casts. **) Lemma esymK T x y : cancel (@esym T x y) (@esym T y x). Proof. by case: y /. Qed. @@ -684,7 +695,7 @@ Section Bijections. Variables (A B : Type) (f : B -> A). -CoInductive bijective : Prop := Bijective g of cancel f g & cancel g f. +Variant bijective : Prop := Bijective g of cancel f g & cancel g f. Hypothesis bijf : bijective. diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 6e17e8e158..f67cf20e49 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -25,9 +25,7 @@ module RelDecl = Context.Rel.Declaration (** 8. Forward chaining tactics (pose, set, have, suffice, wlog) *) (** Defined identifier *) - -let settac id c = Tactics.letin_tac None (Name id) c None -let posetac id cl = Proofview.V82.of_tactic (settac id cl Locusops.nowhere) +let posetac id cl = Proofview.V82.of_tactic (Tactics.pose_tac (Name id) cl) let ssrposetac (id, (_, t)) gl = let ist, t = @@ -47,6 +45,7 @@ let ssrsettac id ((_, (pat, pty)), (_, occ)) gl = let cl = EConstr.Unsafe.to_constr cl in try fill_occ_pattern ~raise_NoMatch:true env sigma cl pat occ 1 with NoMatch -> redex_of_pattern ~resolve_typeclasses:true env pat, cl in + let gl = pf_merge_uc ucst gl in let c = EConstr.of_constr c in let cl = EConstr.of_constr cl in if Termops.occur_existential sigma c then errorstrm(str"The pattern"++spc()++ @@ -56,7 +55,6 @@ let ssrsettac id ((_, (pat, pty)), (_, occ)) gl = | Cast(t, DEFAULTcast, ty) -> t, (gl, ty) | _ -> c, pfe_type_of gl c in let cl' = EConstr.mkLetIn (Name id, c, cty, cl) in - let gl = pf_merge_uc ucst gl in Tacticals.tclTHEN (Proofview.V82.of_tactic (convert_concl cl')) (introid id) gl open Util @@ -68,25 +66,18 @@ open Ssripats let ssrhaveNOtcresolution = Summary.ref ~name:"SSR:havenotcresolution" false -let inHaveTCResolution = Libobject.declare_object { - (Libobject.default_object "SSRHAVETCRESOLUTION") with - Libobject.cache_function = (fun (_,v) -> ssrhaveNOtcresolution := v); - Libobject.load_function = (fun _ (_,v) -> ssrhaveNOtcresolution := v); - Libobject.classify_function = (fun v -> Libobject.Keep v); -} let _ = Goptions.declare_bool_option { Goptions.optname = "have type classes"; Goptions.optkey = ["SsrHave";"NoTCResolution"]; Goptions.optread = (fun _ -> !ssrhaveNOtcresolution); Goptions.optdepr = false; - Goptions.optwrite = (fun b -> - Lib.add_anonymous_leaf (inHaveTCResolution b)) } + Goptions.optwrite = (fun b -> ssrhaveNOtcresolution := b); + } open Constrexpr open Glob_term -open Misctypes let combineCG t1 t2 f g = match t1, t2 with | (x, (t1, None)), (_, (t2, None)) -> x, (g t1 t2, None) @@ -184,9 +175,7 @@ let havetac ist let gs = List.map (fun (_,a) -> Ssripats.Internal.pf_find_abstract_proof false gl (EConstr.Unsafe.to_constr a.(1))) skols_args in - let tacopen_skols gl = - let stuff, g = Refiner.unpackage gl in - Refiner.repackage stuff (gs @ [g]) in + let tacopen_skols gl = re_sig (gs @ [gl.Evd.it]) gl.Evd.sigma in let gl, ty = pf_e_type_of gl t in gl, ty, Proofview.V82.of_tactic (Tactics.apply t), id, Tacticals.tclTHEN (Tacticals.tclTHEN itac_c simpltac) diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 42566575c0..0553260472 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -12,6 +12,7 @@ open Ssrmatching_plugin open Util open Names +open Constr open Proofview open Proofview.Notations @@ -90,11 +91,11 @@ open State (** Warning: unlike [nb_deps_assums], it does not perform reduction *) let rec nb_assums cur env sigma t = match EConstr.kind sigma t with - | Term.Prod(name,ty,body) -> + | Prod(name,ty,body) -> nb_assums (cur+1) env sigma body - | Term.LetIn(name,ty,t1,t2) -> + | LetIn(name,ty,t1,t2) -> nb_assums (cur+1) env sigma t2 - | Term.Cast(t,_,_) -> + | Cast(t,_,_) -> nb_assums cur env sigma t | _ -> cur let nb_assums = nb_assums 0 @@ -118,13 +119,10 @@ let intro_end = Ssrcommon.tcl0G (isCLR_CONSUME) (** [=> _] *****************************************************************) -let intro_clear ids future_ipats = +let intro_clear ids = Goal.enter begin fun gl -> let _, clear_ids, ren = List.fold_left (fun (used_ids, clear_ids, ren) id -> - if not(Ssrcommon.is_name_in_ipats id future_ipats) then begin - used_ids, id :: clear_ids, ren - end else let new_id = Ssrcommon.mk_anon_id (Id.to_string id) used_ids in (new_id :: used_ids, new_id :: clear_ids, (id, new_id) :: ren)) (Tacmach.New.pf_ids_of_hyps gl, [], []) ids @@ -133,6 +131,12 @@ let intro_clear ids future_ipats = isCLR_PUSHL clear_ids end +let tacCHECK_HYPS_EXIST hyps = Goal.enter begin fun gl -> + let ctx = Goal.hyps gl in + List.iter (Ssrcommon.check_hyp_exists ctx) hyps; + tclUNIT () +end + (** [=> []] *****************************************************************) let tac_case t = Goal.enter begin fun _ -> @@ -145,6 +149,7 @@ let tac_case t = end (** [=> [: id]] ************************************************************) +[@@@ocaml.warning "-3"] let mk_abstract_id = let open Coqlib in let ssr_abstract_id = Summary.ref ~name:"SSR:abstractid" 0 in @@ -206,13 +211,16 @@ let tclLOG p t = tclUNIT () end -let rec ipat_tac1 future_ipats ipat : unit tactic = +let rec ipat_tac1 ipat : unit tactic = match ipat with - | IPatView l -> - Ssrview.tclIPAT_VIEWS ~views:l - ~conclusion:(fun ~to_clear:clr -> intro_clear clr future_ipats) - | IPatDispatch ipatss -> - tclEXTEND (List.map ipat_tac ipatss) (tclUNIT ()) [] + | IPatView (clear_if_id,l) -> + Ssrview.tclIPAT_VIEWS ~views:l ~clear_if_id + ~conclusion:(fun ~to_clear:clr -> intro_clear clr) + + | IPatDispatch(true,[[]]) -> + tclUNIT () + | IPatDispatch(_,ipatss) -> + tclDISPATCH (List.map ipat_tac ipatss) | IPatId id -> Ssrcommon.tclINTRO_ID id @@ -220,7 +228,8 @@ let rec ipat_tac1 future_ipats ipat : unit tactic = tclIORPAT (Ssrcommon.tclWITHTOP tac_case) ipatss | IPatInj ipatss -> tclIORPAT (Ssrcommon.tclWITHTOP - (fun t -> V82.tactic ~nf_evars:false (Ssrelim.perform_injection t))) ipatss + (fun t -> V82.tactic ~nf_evars:false (Ssrelim.perform_injection t))) + ipatss | IPatAnon Drop -> intro_drop | IPatAnon One -> Ssrcommon.tclINTRO_ANON @@ -229,7 +238,9 @@ let rec ipat_tac1 future_ipats ipat : unit tactic = | IPatNoop -> tclUNIT () | IPatSimpl Nop -> tclUNIT () - | IPatClear ids -> intro_clear (List.map Ssrcommon.hyp_id ids) future_ipats + | IPatClear ids -> + tacCHECK_HYPS_EXIST ids <*> + intro_clear (List.map Ssrcommon.hyp_id ids) | IPatSimpl (Simpl n) -> V82.tactic ~nf_evars:false (Ssrequality.simpltac (Simpl n)) @@ -250,7 +261,7 @@ and ipat_tac pl : unit tactic = match pl with | [] -> tclUNIT () | pat :: pl -> - Ssrcommon.tcl0G (tclLOG pat (ipat_tac1 pl)) <*> + Ssrcommon.tcl0G (tclLOG pat ipat_tac1) <*> isTICK pat <*> ipat_tac pl @@ -267,12 +278,27 @@ let split_at_first_case ipats = loop [] ipats let ssr_exception is_on = function - | Some (IPatCase l) when is_on -> Some (IPatDispatch l) + | Some (IPatCase l) when is_on -> Some (IPatDispatch(true, l)) | x -> x let option_to_list = function None -> [] | Some x -> [x] +(* Simple pass doing {x}/v -> /v{x} *) +let elaborate_ipats l = + let rec elab = function + | [] -> [] + | (IPatClear _ as p1) :: (IPatView _ as p2) :: rest -> p2 :: p1 :: elab rest + | IPatDispatch(s,p) :: rest -> IPatDispatch (s,List.map elab p) :: elab rest + | IPatCase p :: rest -> IPatCase (List.map elab p) :: elab rest + | IPatInj p :: rest -> IPatInj (List.map elab p) :: elab rest + | (IPatTac _ | IPatId _ | IPatSimpl _ | IPatClear _ | + IPatAnon _ | IPatView _ | IPatNoop | IPatRewrite _ | + IPatAbstractVars _) as x :: rest -> x :: elab rest + in + elab l + let main ?eqtac ~first_case_is_dispatch ipats = + let ipats = elaborate_ipats ipats in let ip_before, case, ip_after = split_at_first_case ipats in let case = ssr_exception first_case_is_dispatch case in let case = option_to_list case in @@ -353,12 +379,13 @@ let elim_intro_tac ipats ?ist what eqid ssrelim is_rec clr = let rec gen_eq_tac () = Goal.enter begin fun g -> let sigma, env, concl = Goal.(sigma g, env g, concl g) in let sigma, eq = - EConstr.fresh_global env sigma (Coqlib.build_coq_eq ()) in + EConstr.fresh_global env sigma (Coqlib.lib_ref "core.eq.type") in let ctx, last = EConstr.decompose_prod_assum sigma concl in let args = match EConstr.kind_of_type sigma last with | Term.AtomicType (hd, args) -> - assert(Ssrcommon.is_protect hd env sigma); - args + if Ssrcommon.is_protect hd env sigma then args + else Ssrcommon.errorstrm + (Pp.str "Too many names in intro pattern") | _ -> assert false in let case = args.(Array.length args-1) in if not(EConstr.Vars.closed0 sigma case) @@ -410,7 +437,7 @@ let tclLAST_GEN ~to_ind ((oclr, occ), t) conclusion = tclINDEPENDENTL begin Goal.enter_one begin fun g -> let pat = Ssrmatching.interp_cpattern sigma0 t None in let cl0, env, sigma, hyps = Goal.(concl g, env g, sigma g, hyps g) in - let cl = EConstr.to_constr sigma cl0 in + let cl = EConstr.to_constr ~abort_on_undefined_evars:false sigma cl0 in let (c, ucst), cl = try Ssrmatching.fill_occ_pattern ~raise_NoMatch:true env sigma cl pat occ 1 with Ssrmatching.NoMatch -> Ssrmatching.redex_of_pattern env pat, cl in @@ -547,7 +574,7 @@ let rec eqmoveipats eqpat = function let ssrsmovetac = Goal.enter begin fun g -> let sigma, concl = Goal.(sigma g, concl g) in match EConstr.kind sigma concl with - | Term.Prod _ | Term.LetIn _ -> tclUNIT () + | Prod _ | LetIn _ -> tclUNIT () | _ -> Tactics.hnf_in_concl end @@ -566,7 +593,7 @@ let ssrmovetac = function (tacVIEW_THEN_GRAB view ~conclusion) <*> tclIPAT (IPatClear clr :: ipats) | _::_ as view, (_, ({ gens = []; clr }, ipats)) -> - tclIPAT (IPatView view :: IPatClear clr :: ipats) + tclIPAT (IPatView (false,view) :: IPatClear clr :: ipats) | _, (Some pat, (dgens, ipats)) -> let dgentac = with_dgens dgens eqmovetac in dgentac <*> tclIPAT (eqmoveipats pat ipats) @@ -585,8 +612,8 @@ let rec is_Evar_or_CastedMeta sigma x = let occur_existential_or_casted_meta sigma c = let rec occrec c = match EConstr.kind sigma c with - | Term.Evar _ -> raise Not_found - | Term.Cast (m,_,_) when EConstr.isMeta sigma m -> raise Not_found + | Evar _ -> raise Not_found + | Cast (m,_,_) when EConstr.isMeta sigma m -> raise Not_found | _ -> EConstr.iter sigma occrec c in try occrec c; false @@ -615,8 +642,8 @@ let tacFIND_ABSTRACT_PROOF check_lock abstract_n = Goal.enter_one ~__LOC__ begin fun g -> let sigma, env = Goal.(sigma g, env g) in let l = Evd.fold_undefined (fun e ei l -> - match EConstr.kind sigma (EConstr.of_constr ei.Evd.evar_concl) with - | Term.App(hd, [|ty; n; lock|]) + match EConstr.kind sigma ei.Evd.evar_concl with + | App(hd, [|ty; n; lock|]) when (not check_lock || (occur_existential_or_casted_meta sigma ty && is_Evar_or_CastedMeta sigma lock)) && @@ -645,8 +672,8 @@ let ssrabstract dgens = let sigma, env, concl = Goal.(sigma g, env g, concl g) in let t = args_id.(0) in match EConstr.kind sigma t with - | (Term.Evar _ | Term.Meta _) -> Ssrcommon.tacUNIFY concl t <*> tclUNIT id - | Term.Cast(m,_,_) + | (Evar _ | Meta _) -> Ssrcommon.tacUNIFY concl t <*> tclUNIT id + | Cast(m,_,_) when EConstr.isEvar sigma m || EConstr.isMeta sigma m -> Ssrcommon.tacUNIFY concl t <*> tclUNIT id | _ -> diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.mlg index 0d82a9f096..2dff0cc84f 100644 --- a/plugins/ssr/ssrparser.ml4 +++ b/plugins/ssr/ssrparser.mlg @@ -10,25 +10,28 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) +{ + +let _vmcast = Constr.VMcast open Names open Pp open Pcoq open Ltac_plugin -open Genarg open Stdarg open Tacarg -open Term open Libnames open Tactics open Tacmach open Util +open Locus open Tacexpr open Tacinterp open Pltac open Extraargs open Ppconstr -open Misctypes +open Namegen +open Tactypes open Decl_kinds open Constrexpr open Constrexpr_ops @@ -59,29 +62,44 @@ let is_ssr_loaded () = (if CLexer.is_keyword "SsrSyntax_is_Imported" then ssr_loaded:=true; !ssr_loaded) +} + DECLARE PLUGIN "ssreflect_plugin" + +{ + (* 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.get_keyword_state () ;; -let tacltop = (5,Notation_term.E) +let tacltop = (5,Notation_gram.E) let pr_ssrtacarg _ _ prt = prt tacltop -ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY pr_ssrtacarg -| [ "YouShouldNotTypeThis" ] -> [ CErrors.anomaly (Pp.str "Grammar placeholder match") ] + +} + +ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY { pr_ssrtacarg } +| [ "YouShouldNotTypeThis" ] -> { CErrors.anomaly (Pp.str "Grammar placeholder match") } END -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: ssrtacarg; - ssrtacarg: [[ tac = tactic_expr LEVEL "5" -> tac ]]; + ssrtacarg: [[ tac = tactic_expr LEVEL "5" -> { tac } ]]; END +{ + (* Lexically closed tactic for tacticals. *) let pr_ssrtclarg _ _ prt tac = prt tacltop tac + +} + ARGUMENT EXTEND ssrtclarg TYPED AS ssrtacarg - PRINTED BY pr_ssrtclarg -| [ ssrtacarg(tac) ] -> [ tac ] + PRINTED BY { pr_ssrtclarg } +| [ ssrtacarg(tac) ] -> { tac } END +{ + open Genarg (** Adding a new uninterpreted generic argument type *) @@ -137,12 +155,15 @@ let intern_hyp ist (SsrHyp (loc, id) as hyp) = open Pcoq.Prim -ARGUMENT EXTEND ssrhyp TYPED AS ssrhyprep PRINTED BY pr_ssrhyp - INTERPRETED BY interp_hyp - GLOBALIZED BY intern_hyp - | [ ident(id) ] -> [ SsrHyp (Loc.tag ~loc id) ] +} + +ARGUMENT EXTEND ssrhyp TYPED AS ssrhyprep PRINTED BY { pr_ssrhyp } + INTERPRETED BY { interp_hyp } + GLOBALIZED BY { intern_hyp } + | [ ident(id) ] -> { SsrHyp (Loc.tag ~loc id) } END +{ let pr_hoi = hoik pr_hyp let pr_ssrhoi _ _ _ = pr_hoi @@ -161,27 +182,33 @@ let interp_ssrhoi ist gl = function let s, id' = interp_wit wit_ident ist gl id in s, Id (SsrHyp (loc, id')) -ARGUMENT EXTEND ssrhoi_hyp TYPED AS ssrhoirep PRINTED BY pr_ssrhoi - INTERPRETED BY interp_ssrhoi - GLOBALIZED BY intern_ssrhoi - | [ ident(id) ] -> [ Hyp (SsrHyp(Loc.tag ~loc id)) ] +} + +ARGUMENT EXTEND ssrhoi_hyp TYPED AS ssrhoirep PRINTED BY { pr_ssrhoi } + INTERPRETED BY { interp_ssrhoi } + GLOBALIZED BY { intern_ssrhoi } + | [ ident(id) ] -> { Hyp (SsrHyp(Loc.tag ~loc id)) } END -ARGUMENT EXTEND ssrhoi_id TYPED AS ssrhoirep PRINTED BY pr_ssrhoi - INTERPRETED BY interp_ssrhoi - GLOBALIZED BY intern_ssrhoi - | [ ident(id) ] -> [ Id (SsrHyp(Loc.tag ~loc id)) ] +ARGUMENT EXTEND ssrhoi_id TYPED AS ssrhoirep PRINTED BY { pr_ssrhoi } + INTERPRETED BY { interp_ssrhoi } + GLOBALIZED BY { intern_ssrhoi } + | [ ident(id) ] -> { Id (SsrHyp(Loc.tag ~loc id)) } END +{ let pr_ssrhyps _ _ _ = pr_hyps -ARGUMENT EXTEND ssrhyps TYPED AS ssrhyp list PRINTED BY pr_ssrhyps - INTERPRETED BY interp_hyps - | [ ssrhyp_list(hyps) ] -> [ check_hyps_uniq [] hyps; hyps ] +} + +ARGUMENT EXTEND ssrhyps TYPED AS ssrhyp list PRINTED BY { pr_ssrhyps } + INTERPRETED BY { interp_hyps } + | [ ssrhyp_list(hyps) ] -> { check_hyps_uniq [] hyps; hyps } END (** Rewriting direction *) +{ let pr_rwdir = function L2R -> mt() | R2L -> str "-" @@ -241,54 +268,57 @@ let negate_parser f x = | Some _ -> raise Stream.Failure let test_not_ssrslashnum = - Pcoq.Gram.Entry.of_parser + Pcoq.Entry.of_parser "test_not_ssrslashnum" (negate_parser test_ssrslashnum10) let test_ssrslashnum00 = - Pcoq.Gram.Entry.of_parser "test_ssrslashnum01" test_ssrslashnum00 + Pcoq.Entry.of_parser "test_ssrslashnum01" test_ssrslashnum00 let test_ssrslashnum10 = - Pcoq.Gram.Entry.of_parser "test_ssrslashnum10" test_ssrslashnum10 + Pcoq.Entry.of_parser "test_ssrslashnum10" test_ssrslashnum10 let test_ssrslashnum11 = - Pcoq.Gram.Entry.of_parser "test_ssrslashnum11" test_ssrslashnum11 + Pcoq.Entry.of_parser "test_ssrslashnum11" test_ssrslashnum11 let test_ssrslashnum01 = - Pcoq.Gram.Entry.of_parser "test_ssrslashnum01" test_ssrslashnum01 + Pcoq.Entry.of_parser "test_ssrslashnum01" test_ssrslashnum01 +} -ARGUMENT EXTEND ssrsimpl_ne TYPED AS ssrsimplrep PRINTED BY pr_ssrsimpl -| [ "//=" ] -> [ SimplCut (~-1,~-1) ] -| [ "/=" ] -> [ Simpl ~-1 ] +ARGUMENT EXTEND ssrsimpl_ne TYPED AS ssrsimplrep PRINTED BY { pr_ssrsimpl } +| [ "//=" ] -> { SimplCut (~-1,~-1) } +| [ "/=" ] -> { Simpl ~-1 } END -Pcoq.(Prim.( -GEXTEND Gram +(* Pcoq.Prim. *) +GRAMMAR EXTEND Gram GLOBAL: ssrsimpl_ne; ssrsimpl_ne: [ - [ test_ssrslashnum11; "/"; n = natural; "/"; m = natural; "=" -> SimplCut(n,m) - | test_ssrslashnum10; "/"; n = natural; "/" -> Cut n - | test_ssrslashnum10; "/"; n = natural; "=" -> Simpl n - | test_ssrslashnum10; "/"; n = natural; "/=" -> SimplCut (n,~-1) - | test_ssrslashnum10; "/"; n = natural; "/"; "=" -> SimplCut (n,~-1) - | test_ssrslashnum01; "//"; m = natural; "=" -> SimplCut (~-1,m) - | test_ssrslashnum00; "//" -> Cut ~-1 + [ test_ssrslashnum11; "/"; n = natural; "/"; m = natural; "=" -> { SimplCut(n,m) } + | test_ssrslashnum10; "/"; n = natural; "/" -> { Cut n } + | test_ssrslashnum10; "/"; n = natural; "=" -> { Simpl n } + | test_ssrslashnum10; "/"; n = natural; "/=" -> { SimplCut (n,~-1) } + | test_ssrslashnum10; "/"; n = natural; "/"; "=" -> { SimplCut (n,~-1) } + | test_ssrslashnum01; "//"; m = natural; "=" -> { SimplCut (~-1,m) } + | test_ssrslashnum00; "//" -> { Cut ~-1 } ]]; END -)) -ARGUMENT EXTEND ssrsimpl TYPED AS ssrsimplrep PRINTED BY pr_ssrsimpl -| [ ssrsimpl_ne(sim) ] -> [ sim ] -| [ ] -> [ Nop ] +ARGUMENT EXTEND ssrsimpl TYPED AS ssrsimplrep PRINTED BY { pr_ssrsimpl } +| [ ssrsimpl_ne(sim) ] -> { sim } +| [ ] -> { Nop } END +{ let pr_ssrclear _ _ _ = pr_clear mt -ARGUMENT EXTEND ssrclear_ne TYPED AS ssrhyps PRINTED BY pr_ssrclear -| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ check_hyps_uniq [] clr; clr ] +} + +ARGUMENT EXTEND ssrclear_ne TYPED AS ssrhyps PRINTED BY { pr_ssrclear } +| [ "{" ne_ssrhyp_list(clr) "}" ] -> { check_hyps_uniq [] clr; clr } END -ARGUMENT EXTEND ssrclear TYPED AS ssrclear_ne PRINTED BY pr_ssrclear -| [ ssrclear_ne(clr) ] -> [ clr ] -| [ ] -> [ [] ] +ARGUMENT EXTEND ssrclear TYPED AS ssrclear_ne PRINTED BY { pr_ssrclear } +| [ ssrclear_ne(clr) ] -> { clr } +| [ ] -> { [] } END (** Indexes *) @@ -299,26 +329,27 @@ END (* positive values, and allows the use of constr numerals, so that *) (* e.g., "let n := eval compute in (1 + 3) in (do n!clear)" works. *) +{ let pr_index = function - | Misctypes.ArgVar {CAst.v=id} -> pr_id id - | Misctypes.ArgArg n when n > 0 -> int n + | ArgVar {CAst.v=id} -> pr_id id + | ArgArg n when n > 0 -> int n | _ -> mt () let pr_ssrindex _ _ _ = pr_index -let noindex = Misctypes.ArgArg 0 +let noindex = ArgArg 0 let check_index ?loc i = if i > 0 then i else CErrors.user_err ?loc (str"Index not positive") let mk_index ?loc = function - | Misctypes.ArgArg i -> Misctypes.ArgArg (check_index ?loc i) + | ArgArg i -> ArgArg (check_index ?loc i) | iv -> iv let interp_index ist gl idx = Tacmach.project gl, match idx with - | Misctypes.ArgArg _ -> idx - | Misctypes.ArgVar id -> + | ArgArg _ -> idx + | ArgVar id -> let i = try let v = Id.Map.find id.CAst.v ist.Tacinterp.lfun in @@ -336,13 +367,15 @@ let interp_index ist gl idx = | None -> raise Not_found end end with _ -> CErrors.user_err ?loc:id.CAst.loc (str"Index not a number") in - Misctypes.ArgArg (check_index ?loc:id.CAst.loc i) + ArgArg (check_index ?loc:id.CAst.loc i) open Pltac -ARGUMENT EXTEND ssrindex TYPED AS ssrindex PRINTED BY pr_ssrindex - INTERPRETED BY interp_index -| [ int_or_var(i) ] -> [ mk_index ~loc i ] +} + +ARGUMENT EXTEND ssrindex PRINTED BY { pr_ssrindex } + INTERPRETED BY { interp_index } +| [ int_or_var(i) ] -> { mk_index ~loc i } END @@ -358,49 +391,61 @@ END (* default, but "{-}" prevents the implicit clear, and can be used to *) (* force dependent elimination -- see ndefectelimtac below. *) +{ let pr_ssrocc _ _ _ = pr_occ open Pcoq.Prim -ARGUMENT EXTEND ssrocc TYPED AS (bool * int list) option PRINTED BY pr_ssrocc -| [ natural(n) natural_list(occ) ] -> [ - Some (false, List.map (check_index ~loc) (n::occ)) ] -| [ "-" natural_list(occ) ] -> [ Some (true, occ) ] -| [ "+" natural_list(occ) ] -> [ Some (false, occ) ] +} + +ARGUMENT EXTEND ssrocc TYPED AS (bool * int list) option PRINTED BY { pr_ssrocc } +| [ natural(n) natural_list(occ) ] -> { + Some (false, List.map (check_index ~loc) (n::occ)) } +| [ "-" natural_list(occ) ] -> { Some (true, occ) } +| [ "+" natural_list(occ) ] -> { Some (false, occ) } END (* modality *) +{ let pr_mmod = function May -> str "?" | Must -> str "!" | Once -> mt () let wit_ssrmmod = add_genarg "ssrmmod" pr_mmod let ssrmmod = Pcoq.create_generic_entry Pcoq.utactic "ssrmmod" (Genarg.rawwit wit_ssrmmod);; -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: ssrmmod; - ssrmmod: [[ "!" -> Must | LEFTQMARK -> May | "?" -> May]]; + ssrmmod: [[ "!" -> { Must } | LEFTQMARK -> { May } | "?" -> { May } ]]; END (** Rewrite multiplier: !n ?n *) +{ + let pr_mult (n, m) = if n > 0 && m <> Once then int n ++ pr_mmod m else pr_mmod m let pr_ssrmult _ _ _ = pr_mult -ARGUMENT EXTEND ssrmult_ne TYPED AS int * ssrmmod PRINTED BY pr_ssrmult - | [ natural(n) ssrmmod(m) ] -> [ check_index ~loc n, m ] - | [ ssrmmod(m) ] -> [ notimes, m ] +} + +ARGUMENT EXTEND ssrmult_ne TYPED AS (int * ssrmmod) PRINTED BY { pr_ssrmult } + | [ natural(n) ssrmmod(m) ] -> { check_index ~loc n, m } + | [ ssrmmod(m) ] -> { notimes, m } END -ARGUMENT EXTEND ssrmult TYPED AS ssrmult_ne PRINTED BY pr_ssrmult - | [ ssrmult_ne(m) ] -> [ m ] - | [ ] -> [ nomult ] +ARGUMENT EXTEND ssrmult TYPED AS ssrmult_ne PRINTED BY { pr_ssrmult } + | [ ssrmult_ne(m) ] -> { m } + | [ ] -> { nomult } END +{ + (** Discharge occ switch (combined occurrence / clear switch *) let pr_docc = function @@ -409,11 +454,15 @@ let pr_docc = function let pr_ssrdocc _ _ _ = pr_docc -ARGUMENT EXTEND ssrdocc TYPED AS ssrclear option * ssrocc PRINTED BY pr_ssrdocc -| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ mkclr clr ] -| [ "{" ssrocc(occ) "}" ] -> [ mkocc occ ] +} + +ARGUMENT EXTEND ssrdocc TYPED AS (ssrclear option * ssrocc) PRINTED BY { pr_ssrdocc } +| [ "{" ssrocc(occ) "}" ] -> { mkocc occ } +| [ "{" ssrhyp_list(clr) "}" ] -> { mkclr clr } END +{ + (* Old kinds of terms *) let input_ssrtermkind strm = match Util.stream_nth 0 strm with @@ -421,7 +470,7 @@ let input_ssrtermkind strm = match Util.stream_nth 0 strm with | Tok.KEYWORD "@" -> xWithAt | _ -> xNoFlag -let ssrtermkind = Pcoq.Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind +let ssrtermkind = Pcoq.Entry.of_parser "ssrtermkind" input_ssrtermkind (* New kinds of terms *) @@ -432,7 +481,7 @@ let input_term_annotation strm = | Tok.KEYWORD "@" :: _ -> `At | _ -> `None let term_annotation = - Gram.Entry.of_parser "term_annotation" input_term_annotation + Pcoq.Entry.of_parser "term_annotation" input_term_annotation (* terms *) @@ -456,94 +505,103 @@ let interp_ssrterm _ gl t = Tacmach.project gl, t open Pcoq.Constr +} + ARGUMENT EXTEND ssrterm - PRINTED BY pr_ssrterm - INTERPRETED BY interp_ssrterm - GLOBALIZED BY glob_ssrterm SUBSTITUTED BY subst_ssrterm - RAW_PRINTED BY pr_ssrterm - GLOB_PRINTED BY pr_ssrterm -| [ "YouShouldNotTypeThis" constr(c) ] -> [ mk_lterm c ] + PRINTED BY { pr_ssrterm } + INTERPRETED BY { interp_ssrterm } + GLOBALIZED BY { glob_ssrterm } SUBSTITUTED BY { subst_ssrterm } + RAW_PRINTED BY { pr_ssrterm } + GLOB_PRINTED BY { pr_ssrterm } +| [ "YouShouldNotTypeThis" constr(c) ] -> { mk_lterm c } END - -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: ssrterm; - ssrterm: [[ k = ssrtermkind; c = Pcoq.Constr.constr -> mk_term k c ]]; + ssrterm: [[ k = ssrtermkind; c = Pcoq.Constr.constr -> { mk_term k c } ]]; END (* New terms *) +{ + let pp_ast_closure_term _ _ _ = pr_ast_closure_term +} + ARGUMENT EXTEND ast_closure_term - PRINTED BY pp_ast_closure_term - INTERPRETED BY interp_ast_closure_term - GLOBALIZED BY glob_ast_closure_term - SUBSTITUTED BY subst_ast_closure_term - RAW_PRINTED BY pp_ast_closure_term - GLOB_PRINTED BY pp_ast_closure_term - | [ term_annotation(a) constr(c) ] -> [ mk_ast_closure_term a c ] + PRINTED BY { pp_ast_closure_term } + INTERPRETED BY { interp_ast_closure_term } + GLOBALIZED BY { glob_ast_closure_term } + SUBSTITUTED BY { subst_ast_closure_term } + RAW_PRINTED BY { pp_ast_closure_term } + GLOB_PRINTED BY { pp_ast_closure_term } + | [ term_annotation(a) constr(c) ] -> { mk_ast_closure_term a c } END ARGUMENT EXTEND ast_closure_lterm - PRINTED BY pp_ast_closure_term - INTERPRETED BY interp_ast_closure_term - GLOBALIZED BY glob_ast_closure_term - SUBSTITUTED BY subst_ast_closure_term - RAW_PRINTED BY pp_ast_closure_term - GLOB_PRINTED BY pp_ast_closure_term - | [ term_annotation(a) lconstr(c) ] -> [ mk_ast_closure_term a c ] + PRINTED BY { pp_ast_closure_term } + INTERPRETED BY { interp_ast_closure_term } + GLOBALIZED BY { glob_ast_closure_term } + SUBSTITUTED BY { subst_ast_closure_term } + RAW_PRINTED BY { pp_ast_closure_term } + GLOB_PRINTED BY { pp_ast_closure_term } + | [ term_annotation(a) lconstr(c) ] -> { mk_ast_closure_term a c } END (* Old Views *) +{ + let pr_view = pr_list mt (fun c -> str "/" ++ pr_term c) let pr_ssrbwdview _ _ _ = pr_view +} + ARGUMENT EXTEND ssrbwdview TYPED AS ssrterm list - PRINTED BY pr_ssrbwdview -| [ "YouShouldNotTypeThis" ] -> [ [] ] + PRINTED BY { pr_ssrbwdview } +| [ "YouShouldNotTypeThis" ] -> { [] } END -Pcoq.( -GEXTEND Gram +(* Pcoq *) +GRAMMAR EXTEND Gram GLOBAL: ssrbwdview; ssrbwdview: [ - [ test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr -> [mk_term xNoFlag c] - | test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr; w = ssrbwdview -> - (mk_term xNoFlag c) :: w ]]; + [ test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr -> { [mk_term xNoFlag c] } + | test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr; w = ssrbwdview -> { + (mk_term xNoFlag c) :: w } ]]; END -) (* New Views *) +{ let pr_ssrfwdview _ _ _ = pr_view2 +} + ARGUMENT EXTEND ssrfwdview TYPED AS ast_closure_term list - PRINTED BY pr_ssrfwdview -| [ "YouShouldNotTypeThis" ] -> [ [] ] + PRINTED BY { pr_ssrfwdview } +| [ "YouShouldNotTypeThis" ] -> { [] } END -Pcoq.( -GEXTEND Gram +(* Pcoq *) +GRAMMAR EXTEND Gram GLOBAL: ssrfwdview; ssrfwdview: [ [ test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr -> - [mk_ast_closure_term `None c] + { [mk_ast_closure_term `None c] } | test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr; w = ssrfwdview -> - (mk_ast_closure_term `None c) :: w ]]; + { (mk_ast_closure_term `None c) :: w } ]]; END -) -(* }}} *) - (* ipats *) +{ let remove_loc x = x.CAst.v -let ipat_of_intro_pattern p = Misctypes.( +let ipat_of_intro_pattern p = Tactypes.( let rec ipat_of_intro_pattern = function | IntroNaming (IntroIdentifier id) -> IPatId id | IntroAction IntroWildcard -> IPatAnon Drop @@ -574,9 +632,9 @@ let rec map_ipat map_id map_ssrhyp map_ast_closure_term = function | IPatAbstractVars l -> IPatAbstractVars (List.map map_id l) | IPatClear clr -> IPatClear (List.map map_ssrhyp clr) | IPatCase iorpat -> IPatCase (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat) - | IPatDispatch iorpat -> IPatDispatch (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat) + | IPatDispatch (s,iorpat) -> IPatDispatch (s,List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat) | IPatInj iorpat -> IPatInj (List.map (List.map (map_ipat map_id map_ssrhyp map_ast_closure_term)) iorpat) - | IPatView v -> IPatView (List.map map_ast_closure_term v) + | IPatView (clr,v) -> IPatView (clr,List.map map_ast_closure_term v) | IPatTac _ -> assert false (*internal usage only *) let wit_ssripatrep = add_genarg "ssripatrep" pr_ipat @@ -585,37 +643,25 @@ let pr_ssripat _ _ _ = pr_ipat let pr_ssripats _ _ _ = pr_ipats let pr_ssriorpat _ _ _ = pr_iorpat -(* -let intern_ipat ist ipat = - let rec check_pat = function - | IPatClear clr -> ignore (List.map (intern_hyp ist) clr) - | IPatCase iorpat -> List.iter (List.iter check_pat) iorpat - | IPatDispatch iorpat -> List.iter (List.iter check_pat) iorpat - | IPatInj iorpat -> List.iter (List.iter check_pat) iorpat - | _ -> () in - check_pat ipat; ipat -*) - let intern_ipat ist = map_ipat (fun id -> id) - (intern_hyp ist) (* TODO: check with ltac, old code was ignoring the result *) + (intern_hyp ist) (glob_ast_closure_term ist) let intern_ipats ist = List.map (intern_ipat ist) let interp_intro_pattern = interp_wit wit_intro_pattern -let interp_introid ist gl id = Misctypes.( +let interp_introid ist gl id = try IntroNaming (IntroIdentifier (hyp_id (snd (interp_hyp ist gl (SsrHyp (Loc.tag id)))))) with _ -> (snd (interp_intro_pattern ist gl (CAst.make @@ IntroNaming (IntroIdentifier id)))).CAst.v -) let get_intro_id = function | IntroNaming (IntroIdentifier id) -> id | _ -> assert false -let rec add_intro_pattern_hyps ipat hyps = Misctypes.( +let rec add_intro_pattern_hyps ipat hyps = let {CAst.loc=loc;v=ipat} = ipat in match ipat with | IntroNaming (IntroIdentifier id) -> @@ -634,7 +680,6 @@ let rec add_intro_pattern_hyps ipat hyps = Misctypes.( | IntroForthcoming _ -> (* As in ipat_of_intro_pattern, was unable to determine which kind of ipat interp_introid could return [HH] *) assert false -) (* We interp the ipat using the standard ltac machinery for ids, since * we have no clue what a name could be bound to (maybe another ipat) *) @@ -652,12 +697,12 @@ let interp_ipat ist gl = check_hyps_uniq [] clr'; IPatClear clr' | IPatCase(iorpat) -> IPatCase(List.map (List.map interp) iorpat) - | IPatDispatch(iorpat) -> - IPatDispatch(List.map (List.map interp) iorpat) + | IPatDispatch(s,iorpat) -> + IPatDispatch(s,List.map (List.map interp) iorpat) | IPatInj iorpat -> IPatInj (List.map (List.map interp) iorpat) | IPatAbstractVars l -> IPatAbstractVars (List.map get_intro_id (List.map (interp_introid ist gl) l)) - | IPatView l -> IPatView (List.map (fun x -> snd(interp_ast_closure_term ist + | IPatView (clr,l) -> IPatView (clr,List.map (fun x -> snd(interp_ast_closure_term ist gl x)) l) | (IPatSimpl _ | IPatAnon _ | IPatRewrite _ | IPatNoop) as x -> x | IPatTac _ -> assert false (*internal usage only *) @@ -674,69 +719,79 @@ let pushIPatNoop = function | pats :: orpat -> (IPatNoop :: pats) :: orpat | [] -> [] -ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY pr_ssripats - INTERPRETED BY interp_ipats - GLOBALIZED BY intern_ipats - | [ "_" ] -> [ [IPatAnon Drop] ] - | [ "*" ] -> [ [IPatAnon All] ] +} + +ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY { pr_ssripats } + INTERPRETED BY { interp_ipats } + GLOBALIZED BY { intern_ipats } + | [ "_" ] -> { [IPatAnon Drop] } + | [ "*" ] -> { [IPatAnon All] } (* - | [ "^" "*" ] -> [ [IPatFastMode] ] - | [ "^" "_" ] -> [ [IPatSeed `Wild] ] - | [ "^_" ] -> [ [IPatSeed `Wild] ] - | [ "^" "?" ] -> [ [IPatSeed `Anon] ] - | [ "^?" ] -> [ [IPatSeed `Anon] ] - | [ "^" ident(id) ] -> [ [IPatSeed (`Id(id,`Pre))] ] - | [ "^" "~" ident(id) ] -> [ [IPatSeed (`Id(id,`Post))] ] - | [ "^~" ident(id) ] -> [ [IPatSeed (`Id(id,`Post))] ] + | [ "^" "*" ] -> { [IPatFastMode] } + | [ "^" "_" ] -> { [IPatSeed `Wild] } + | [ "^_" ] -> { [IPatSeed `Wild] } + | [ "^" "?" ] -> { [IPatSeed `Anon] } + | [ "^?" ] -> { [IPatSeed `Anon] } + | [ "^" ident(id) ] -> { [IPatSeed (`Id(id,`Pre))] } + | [ "^" "~" ident(id) ] -> { [IPatSeed (`Id(id,`Post))] } + | [ "^~" ident(id) ] -> { [IPatSeed (`Id(id,`Post))] } *) - | [ ident(id) ] -> [ [IPatId id] ] - | [ "?" ] -> [ [IPatAnon One] ] + | [ ident(id) ] -> { [IPatId id] } + | [ "?" ] -> { [IPatAnon One] } (* TODO | [ "+" ] -> [ [IPatAnon Temporary] ] *) - | [ ssrsimpl_ne(sim) ] -> [ [IPatSimpl sim] ] - | [ ssrdocc(occ) "->" ] -> [ match occ with + | [ ssrsimpl_ne(sim) ] -> { [IPatSimpl sim] } + | [ ssrdocc(occ) "->" ] -> { match occ with + | Some [], _ -> CErrors.user_err ~loc (str"occ_switch expected") | None, occ -> [IPatRewrite (occ, L2R)] - | Some clr, _ -> [IPatClear clr; IPatRewrite (allocc, L2R)]] - | [ ssrdocc(occ) "<-" ] -> [ match occ with + | Some clr, _ -> [IPatClear clr; IPatRewrite (allocc, L2R)] } + | [ ssrdocc(occ) "<-" ] -> { match occ with + | Some [], _ -> CErrors.user_err ~loc (str"occ_switch expected") | None, occ -> [IPatRewrite (occ, R2L)] - | Some clr, _ -> [IPatClear clr; IPatRewrite (allocc, R2L)]] - | [ ssrdocc(occ) ] -> [ match occ with + | Some clr, _ -> [IPatClear clr; IPatRewrite (allocc, R2L)] } + | [ ssrdocc(occ) ssrfwdview(v) ] -> { match occ with + | Some [], _ -> [IPatView (true,v)] + | Some cl, _ -> check_hyps_uniq [] cl; [IPatClear cl;IPatView (false,v)] + | _ -> CErrors.user_err ~loc (str"Only identifiers are allowed here") } + | [ ssrdocc(occ) ] -> { match occ with | Some cl, _ -> check_hyps_uniq [] cl; [IPatClear cl] - | _ -> CErrors.user_err ~loc (str"Only identifiers are allowed here")] - | [ "->" ] -> [ [IPatRewrite (allocc, L2R)] ] - | [ "<-" ] -> [ [IPatRewrite (allocc, R2L)] ] - | [ "-" ] -> [ [IPatNoop] ] - | [ "-/" "=" ] -> [ [IPatNoop;IPatSimpl(Simpl ~-1)] ] - | [ "-/=" ] -> [ [IPatNoop;IPatSimpl(Simpl ~-1)] ] - | [ "-/" "/" ] -> [ [IPatNoop;IPatSimpl(Cut ~-1)] ] - | [ "-//" ] -> [ [IPatNoop;IPatSimpl(Cut ~-1)] ] - | [ "-/" integer(n) "/" ] -> [ [IPatNoop;IPatSimpl(Cut n)] ] - | [ "-/" "/=" ] -> [ [IPatNoop;IPatSimpl(SimplCut (~-1,~-1))] ] - | [ "-//" "=" ] -> [ [IPatNoop;IPatSimpl(SimplCut (~-1,~-1))] ] - | [ "-//=" ] -> [ [IPatNoop;IPatSimpl(SimplCut (~-1,~-1))] ] - | [ "-/" integer(n) "/=" ] -> [ [IPatNoop;IPatSimpl(SimplCut (n,~-1))] ] + | _ -> CErrors.user_err ~loc (str"Only identifiers are allowed here") } + | [ "->" ] -> { [IPatRewrite (allocc, L2R)] } + | [ "<-" ] -> { [IPatRewrite (allocc, R2L)] } + | [ "-" ] -> { [IPatNoop] } + | [ "-/" "=" ] -> { [IPatNoop;IPatSimpl(Simpl ~-1)] } + | [ "-/=" ] -> { [IPatNoop;IPatSimpl(Simpl ~-1)] } + | [ "-/" "/" ] -> { [IPatNoop;IPatSimpl(Cut ~-1)] } + | [ "-//" ] -> { [IPatNoop;IPatSimpl(Cut ~-1)] } + | [ "-/" integer(n) "/" ] -> { [IPatNoop;IPatSimpl(Cut n)] } + | [ "-/" "/=" ] -> { [IPatNoop;IPatSimpl(SimplCut (~-1,~-1))] } + | [ "-//" "=" ] -> { [IPatNoop;IPatSimpl(SimplCut (~-1,~-1))] } + | [ "-//=" ] -> { [IPatNoop;IPatSimpl(SimplCut (~-1,~-1))] } + | [ "-/" integer(n) "/=" ] -> { [IPatNoop;IPatSimpl(SimplCut (n,~-1))] } | [ "-/" integer(n) "/" integer (m) "=" ] -> - [ [IPatNoop;IPatSimpl(SimplCut(n,m))] ] - | [ ssrfwdview(v) ] -> [ [IPatView v] ] - | [ "[" ":" ident_list(idl) "]" ] -> [ [IPatAbstractVars idl] ] - | [ "[:" ident_list(idl) "]" ] -> [ [IPatAbstractVars idl] ] + { [IPatNoop;IPatSimpl(SimplCut(n,m))] } + | [ ssrfwdview(v) ] -> { [IPatView (false,v)] } + | [ "[" ":" ident_list(idl) "]" ] -> { [IPatAbstractVars idl] } + | [ "[:" ident_list(idl) "]" ] -> { [IPatAbstractVars idl] } END -ARGUMENT EXTEND ssripats TYPED AS ssripat PRINTED BY pr_ssripats - | [ ssripat(i) ssripats(tl) ] -> [ i @ tl ] - | [ ] -> [ [] ] +ARGUMENT EXTEND ssripats TYPED AS ssripat PRINTED BY { pr_ssripats } + | [ ssripat(i) ssripats(tl) ] -> { i @ tl } + | [ ] -> { [] } END -ARGUMENT EXTEND ssriorpat TYPED AS ssripat list PRINTED BY pr_ssriorpat -| [ ssripats(pats) "|" ssriorpat(orpat) ] -> [ pats :: orpat ] -| [ ssripats(pats) "|-" ">" ssriorpat(orpat) ] -> [ pats :: pushIPatRewrite orpat ] -| [ ssripats(pats) "|-" ssriorpat(orpat) ] -> [ pats :: pushIPatNoop orpat ] -| [ ssripats(pats) "|->" ssriorpat(orpat) ] -> [ pats :: pushIPatRewrite orpat ] -| [ ssripats(pats) "||" ssriorpat(orpat) ] -> [ pats :: [] :: orpat ] -| [ ssripats(pats) "|||" ssriorpat(orpat) ] -> [ pats :: [] :: [] :: orpat ] -| [ ssripats(pats) "||||" ssriorpat(orpat) ] -> [ [pats; []; []; []] @ orpat ] -| [ ssripats(pats) ] -> [ [pats] ] +ARGUMENT EXTEND ssriorpat TYPED AS ssripat list PRINTED BY { pr_ssriorpat } +| [ ssripats(pats) "|" ssriorpat(orpat) ] -> { pats :: orpat } +| [ ssripats(pats) "|-" ">" ssriorpat(orpat) ] -> { pats :: pushIPatRewrite orpat } +| [ ssripats(pats) "|-" ssriorpat(orpat) ] -> { pats :: pushIPatNoop orpat } +| [ ssripats(pats) "|->" ssriorpat(orpat) ] -> { pats :: pushIPatRewrite orpat } +| [ ssripats(pats) "||" ssriorpat(orpat) ] -> { pats :: [] :: orpat } +| [ ssripats(pats) "|||" ssriorpat(orpat) ] -> { pats :: [] :: [] :: orpat } +| [ ssripats(pats) "||||" ssriorpat(orpat) ] -> { [pats; []; []; []] @ orpat } +| [ ssripats(pats) ] -> { [pats] } END +{ + let reject_ssrhid strm = match Util.stream_nth 0 strm with | Tok.KEYWORD "[" -> @@ -745,45 +800,46 @@ let reject_ssrhid strm = | _ -> ()) | _ -> () -let test_nohidden = Pcoq.Gram.Entry.of_parser "test_ssrhid" reject_ssrhid +let test_nohidden = Pcoq.Entry.of_parser "test_ssrhid" reject_ssrhid + +} -ARGUMENT EXTEND ssrcpat TYPED AS ssripatrep PRINTED BY pr_ssripat - | [ "YouShouldNotTypeThis" ssriorpat(x) ] -> [ IPatCase(x) ] +ARGUMENT EXTEND ssrcpat TYPED AS ssripatrep PRINTED BY { pr_ssripat } + | [ "YouShouldNotTypeThis" ssriorpat(x) ] -> { IPatCase(x) } END -Pcoq.( -GEXTEND Gram +(* Pcoq *) +GRAMMAR EXTEND Gram GLOBAL: ssrcpat; ssrcpat: [ - [ test_nohidden; "["; iorpat = ssriorpat; "]" -> + [ test_nohidden; "["; iorpat = ssriorpat; "]" -> { (* check_no_inner_seed !@loc false iorpat; IPatCase (understand_case_type iorpat) *) - IPatCase iorpat + IPatCase iorpat } (* | test_nohidden; "("; iorpat = ssriorpat; ")" -> (* check_no_inner_seed !@loc false iorpat; IPatCase (understand_case_type iorpat) *) IPatDispatch iorpat *) - | test_nohidden; "[="; iorpat = ssriorpat; "]" -> + | test_nohidden; "[="; iorpat = ssriorpat; "]" -> { (* check_no_inner_seed !@loc false iorpat; *) - IPatInj iorpat ]]; + IPatInj iorpat } ]]; END -);; -Pcoq.( -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: ssripat; - ssripat: [[ pat = ssrcpat -> [pat] ]]; + ssripat: [[ pat = ssrcpat -> { [pat] } ]]; END -) -ARGUMENT EXTEND ssripats_ne TYPED AS ssripat PRINTED BY pr_ssripats - | [ ssripat(i) ssripats(tl) ] -> [ i @ tl ] +ARGUMENT EXTEND ssripats_ne TYPED AS ssripat PRINTED BY { pr_ssripats } + | [ ssripat(i) ssripats(tl) ] -> { i @ tl } END (* subsets of patterns *) +{ + (* TODO: review what this function does, it looks suspicious *) let check_ssrhpats loc w_binders ipats = let err_loc s = CErrors.user_err ~loc ~hdr:"ssreflect" s in @@ -821,80 +877,97 @@ let pr_hpats (((clr, ipat), binders), simpl) = let pr_ssrhpats _ _ _ = pr_hpats let pr_ssrhpats_wtransp _ _ _ (_, x) = pr_hpats x -ARGUMENT EXTEND ssrhpats TYPED AS ((ssrclear * ssripat) * ssripat) * ssripat -PRINTED BY pr_ssrhpats - | [ ssripats(i) ] -> [ check_ssrhpats loc true i ] +} + +ARGUMENT EXTEND ssrhpats TYPED AS (((ssrclear * ssripat) * ssripat) * ssripat) +PRINTED BY { pr_ssrhpats } + | [ ssripats(i) ] -> { check_ssrhpats loc true i } END ARGUMENT EXTEND ssrhpats_wtransp - TYPED AS bool * (((ssrclear * ssripats) * ssripats) * ssripats) - PRINTED BY pr_ssrhpats_wtransp - | [ ssripats(i) ] -> [ false,check_ssrhpats loc true i ] - | [ ssripats(i) "@" ssripats(j) ] -> [ true,check_ssrhpats loc true (i @ j) ] + TYPED AS (bool * (((ssrclear * ssripats) * ssripats) * ssripats)) + PRINTED BY { pr_ssrhpats_wtransp } + | [ ssripats(i) ] -> { false,check_ssrhpats loc true i } + | [ ssripats(i) "@" ssripats(j) ] -> { true,check_ssrhpats loc true (i @ j) } END ARGUMENT EXTEND ssrhpats_nobs -TYPED AS ((ssrclear * ssripats) * ssripats) * ssripats PRINTED BY pr_ssrhpats - | [ ssripats(i) ] -> [ check_ssrhpats loc false i ] +TYPED AS (((ssrclear * ssripats) * ssripats) * ssripats) PRINTED BY { pr_ssrhpats } + | [ ssripats(i) ] -> { check_ssrhpats loc false i } END -ARGUMENT EXTEND ssrrpat TYPED AS ssripatrep PRINTED BY pr_ssripat - | [ "->" ] -> [ IPatRewrite (allocc, L2R) ] - | [ "<-" ] -> [ IPatRewrite (allocc, R2L) ] +ARGUMENT EXTEND ssrrpat TYPED AS ssripatrep PRINTED BY { pr_ssripat } + | [ "->" ] -> { IPatRewrite (allocc, L2R) } + | [ "<-" ] -> { IPatRewrite (allocc, R2L) } END +{ + let pr_intros sep intrs = if intrs = [] then mt() else sep () ++ str "=>" ++ pr_ipats intrs let pr_ssrintros _ _ _ = pr_intros mt +} + ARGUMENT EXTEND ssrintros_ne TYPED AS ssripat - PRINTED BY pr_ssrintros - | [ "=>" ssripats_ne(pats) ] -> [ pats ] -(* TODO | [ "=>" ">" ssripats_ne(pats) ] -> [ IPatFastMode :: pats ] + PRINTED BY { pr_ssrintros } + | [ "=>" ssripats_ne(pats) ] -> { pats } +(* TODO | [ "=>" ">" ssripats_ne(pats) ] -> { IPatFastMode :: pats } | [ "=>>" ssripats_ne(pats) ] -> [ IPatFastMode :: pats ] *) END -ARGUMENT EXTEND ssrintros TYPED AS ssrintros_ne PRINTED BY pr_ssrintros - | [ ssrintros_ne(intrs) ] -> [ intrs ] - | [ ] -> [ [] ] +ARGUMENT EXTEND ssrintros TYPED AS ssrintros_ne PRINTED BY { pr_ssrintros } + | [ ssrintros_ne(intrs) ] -> { intrs } + | [ ] -> { [] } END +{ + let pr_ssrintrosarg _ _ prt (tac, ipats) = prt tacltop tac ++ pr_intros spc ipats -ARGUMENT EXTEND ssrintrosarg TYPED AS tactic * ssrintros - PRINTED BY pr_ssrintrosarg -| [ "YouShouldNotTypeThis" ssrtacarg(arg) ssrintros_ne(ipats) ] -> [ arg, ipats ] +} + +ARGUMENT EXTEND ssrintrosarg TYPED AS (tactic * ssrintros) + PRINTED BY { pr_ssrintrosarg } +| [ "YouShouldNotTypeThis" ssrtacarg(arg) ssrintros_ne(ipats) ] -> { arg, ipats } END TACTIC EXTEND ssrtclintros | [ "YouShouldNotTypeThis" ssrintrosarg(arg) ] -> - [ let tac, intros = arg in - ssrevaltac ist tac <*> tclIPATssr intros ] + { let tac, intros = arg in + ssrevaltac ist tac <*> tclIPATssr intros } END +{ + (** Defined identifier *) let pr_ssrfwdid id = pr_spc () ++ pr_id id let pr_ssrfwdidx _ _ _ = pr_ssrfwdid +} + (* We use a primitive parser for the head identifier of forward *) (* tactis to avoid syntactic conflicts with basic Coq tactics. *) -ARGUMENT EXTEND ssrfwdid TYPED AS ident PRINTED BY pr_ssrfwdidx - | [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +ARGUMENT EXTEND ssrfwdid TYPED AS ident PRINTED BY { pr_ssrfwdidx } + | [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END +{ + let accept_ssrfwdid strm = match stream_nth 0 strm with | Tok.IDENT id -> accept_before_syms_or_any_id [":"; ":="; "("] strm | _ -> raise Stream.Failure +let test_ssrfwdid = Pcoq.Entry.of_parser "test_ssrfwdid" accept_ssrfwdid -let test_ssrfwdid = Gram.Entry.of_parser "test_ssrfwdid" accept_ssrfwdid +} -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: ssrfwdid; - ssrfwdid: [[ test_ssrfwdid; id = Prim.ident -> id ]]; + ssrfwdid: [[ test_ssrfwdid; id = Prim.ident -> { id } ]]; END @@ -905,6 +978,7 @@ GEXTEND Gram (* The latter two are used in forward-chaining tactics (have, suffice, wlog) *) (* and subgoal reordering tacticals (; first & ; last), respectively. *) +{ let pr_ortacs prt = let rec pr_rec = function @@ -919,14 +993,18 @@ let pr_ortacs prt = | [] -> mt() let pr_ssrortacs _ _ = pr_ortacs -ARGUMENT EXTEND ssrortacs TYPED AS tactic option list PRINTED BY pr_ssrortacs -| [ ssrtacarg(tac) "|" ssrortacs(tacs) ] -> [ Some tac :: tacs ] -| [ ssrtacarg(tac) "|" ] -> [ [Some tac; None] ] -| [ ssrtacarg(tac) ] -> [ [Some tac] ] -| [ "|" ssrortacs(tacs) ] -> [ None :: tacs ] -| [ "|" ] -> [ [None; None] ] +} + +ARGUMENT EXTEND ssrortacs TYPED AS tactic option list PRINTED BY { pr_ssrortacs } +| [ ssrtacarg(tac) "|" ssrortacs(tacs) ] -> { Some tac :: tacs } +| [ ssrtacarg(tac) "|" ] -> { [Some tac; None] } +| [ ssrtacarg(tac) ] -> { [Some tac] } +| [ "|" ssrortacs(tacs) ] -> { None :: tacs } +| [ "|" ] -> { [None; None] } END +{ + let pr_hintarg prt = function | true, tacs -> hv 0 (str "[ " ++ pr_ortacs prt tacs ++ str " ]") | false, [Some tac] -> prt tacltop tac @@ -934,26 +1012,30 @@ let pr_hintarg prt = function let pr_ssrhintarg _ _ = pr_hintarg +} -ARGUMENT EXTEND ssrhintarg TYPED AS bool * ssrortacs PRINTED BY pr_ssrhintarg -| [ "[" "]" ] -> [ nullhint ] -| [ "[" ssrortacs(tacs) "]" ] -> [ mk_orhint tacs ] -| [ ssrtacarg(arg) ] -> [ mk_hint arg ] +ARGUMENT EXTEND ssrhintarg TYPED AS (bool * ssrortacs) PRINTED BY { pr_ssrhintarg } +| [ "[" "]" ] -> { nullhint } +| [ "[" ssrortacs(tacs) "]" ] -> { mk_orhint tacs } +| [ ssrtacarg(arg) ] -> { mk_hint arg } END -ARGUMENT EXTEND ssrortacarg TYPED AS ssrhintarg PRINTED BY pr_ssrhintarg -| [ "[" ssrortacs(tacs) "]" ] -> [ mk_orhint tacs ] +ARGUMENT EXTEND ssrortacarg TYPED AS ssrhintarg PRINTED BY { pr_ssrhintarg } +| [ "[" ssrortacs(tacs) "]" ] -> { mk_orhint tacs } END +{ let pr_hint prt arg = if arg = nohint then mt() else str "by " ++ pr_hintarg prt arg let pr_ssrhint _ _ = pr_hint -ARGUMENT EXTEND ssrhint TYPED AS ssrhintarg PRINTED BY pr_ssrhint -| [ ] -> [ nohint ] +} + +ARGUMENT EXTEND ssrhint TYPED AS ssrhintarg PRINTED BY { pr_ssrhint } +| [ ] -> { nohint } END -(** The "in" pseudo-tactical *)(* {{{ **********************************************) +(** The "in" pseudo-tactical *) (* We can't make "in" into a general tactical because this would create a *) (* crippling conflict with the ltac let .. in construct. Hence, we add *) @@ -966,7 +1048,10 @@ END (* assumptions. This is especially difficult for discharged "let"s, which *) (* the default simpl and unfold tactics would erase blindly. *) +{ + open Ssrmatching_plugin.Ssrmatching +open Ssrmatching_plugin.G_ssrmatching let pr_wgen = function | (clr, Some((id,k),None)) -> spc() ++ pr_clear mt clr ++ str k ++ pr_hoi id @@ -976,22 +1061,26 @@ let pr_wgen = function | (clr, None) -> spc () ++ pr_clear mt clr let pr_ssrwgen _ _ _ = pr_wgen +} + (* no globwith for char *) ARGUMENT EXTEND ssrwgen - TYPED AS ssrclear * ((ssrhoi_hyp * string) * cpattern option) option - PRINTED BY pr_ssrwgen -| [ ssrclear_ne(clr) ] -> [ clr, None ] -| [ ssrhoi_hyp(hyp) ] -> [ [], Some((hyp, " "), None) ] -| [ "@" ssrhoi_hyp(hyp) ] -> [ [], Some((hyp, "@"), None) ] + TYPED AS (ssrclear * ((ssrhoi_hyp * string) * cpattern option) option) + PRINTED BY { pr_ssrwgen } +| [ ssrclear_ne(clr) ] -> { clr, None } +| [ ssrhoi_hyp(hyp) ] -> { [], Some((hyp, " "), None) } +| [ "@" ssrhoi_hyp(hyp) ] -> { [], Some((hyp, "@"), None) } | [ "(" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> - [ [], Some ((id," "),Some p) ] -| [ "(" ssrhoi_id(id) ")" ] -> [ [], Some ((id,"("), None) ] + { [], Some ((id," "),Some p) } +| [ "(" ssrhoi_id(id) ")" ] -> { [], Some ((id,"("), None) } | [ "(@" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> - [ [], Some ((id,"@"),Some p) ] + { [], Some ((id,"@"),Some p) } | [ "(" "@" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> - [ [], Some ((id,"@"),Some p) ] + { [], Some ((id,"@"),Some p) } END +{ + let pr_clseq = function | InGoal | InHyps -> mt () | InSeqGoal -> str "|- *" @@ -1005,13 +1094,17 @@ let wit_ssrclseq = add_genarg "ssrclseq" pr_clseq let pr_clausehyps = pr_list pr_spc pr_wgen let pr_ssrclausehyps _ _ _ = pr_clausehyps +} + ARGUMENT EXTEND ssrclausehyps -TYPED AS ssrwgen list PRINTED BY pr_ssrclausehyps -| [ ssrwgen(hyp) "," ssrclausehyps(hyps) ] -> [ hyp :: hyps ] -| [ ssrwgen(hyp) ssrclausehyps(hyps) ] -> [ hyp :: hyps ] -| [ ssrwgen(hyp) ] -> [ [hyp] ] +TYPED AS ssrwgen list PRINTED BY { pr_ssrclausehyps } +| [ ssrwgen(hyp) "," ssrclausehyps(hyps) ] -> { hyp :: hyps } +| [ ssrwgen(hyp) ssrclausehyps(hyps) ] -> { hyp :: hyps } +| [ ssrwgen(hyp) ] -> { [hyp] } END +{ + (* type ssrclauses = ssrahyps * ssrclseq *) let pr_clauses (hyps, clseq) = @@ -1019,20 +1112,22 @@ let pr_clauses (hyps, clseq) = else str "in " ++ pr_clausehyps hyps ++ pr_clseq clseq let pr_ssrclauses _ _ _ = pr_clauses -ARGUMENT EXTEND ssrclauses TYPED AS ssrwgen list * ssrclseq - PRINTED BY pr_ssrclauses - | [ "in" ssrclausehyps(hyps) "|-" "*" ] -> [ hyps, InHypsSeqGoal ] - | [ "in" ssrclausehyps(hyps) "|-" ] -> [ hyps, InHypsSeq ] - | [ "in" ssrclausehyps(hyps) "*" ] -> [ hyps, InHypsGoal ] - | [ "in" ssrclausehyps(hyps) ] -> [ hyps, InHyps ] - | [ "in" "|-" "*" ] -> [ [], InSeqGoal ] - | [ "in" "*" ] -> [ [], InAll ] - | [ "in" "*" "|-" ] -> [ [], InAllHyps ] - | [ ] -> [ [], InGoal ] -END +} +ARGUMENT EXTEND ssrclauses TYPED AS (ssrwgen list * ssrclseq) + PRINTED BY { pr_ssrclauses } + | [ "in" ssrclausehyps(hyps) "|-" "*" ] -> { hyps, InHypsSeqGoal } + | [ "in" ssrclausehyps(hyps) "|-" ] -> { hyps, InHypsSeq } + | [ "in" ssrclausehyps(hyps) "*" ] -> { hyps, InHypsGoal } + | [ "in" ssrclausehyps(hyps) ] -> { hyps, InHyps } + | [ "in" "|-" "*" ] -> { [], InSeqGoal } + | [ "in" "*" ] -> { [], InAll } + | [ "in" "*" "|-" ] -> { [], InAllHyps } + | [ ] -> { [], InGoal } +END +{ (** Definition value formatting *) @@ -1075,7 +1170,7 @@ let rec format_constr_expr h0 c0 = let open CAst in match h0, c0 with | BFdef :: h, { v = CLetIn({CAst.v=x}, v, oty, c) } -> let bs, c' = format_constr_expr h c in Bdef (x, oty, v) :: bs, c' - | [BFcast], { v = CCast (c, CastConv t) } -> + | [BFcast], { v = CCast (c, Glob_term.CastConv t) } -> [Bcast t], c | BFrec (has_str, has_cast) :: h, { v = CFix ( _, [_, (Some locn, CStructRec), bl, t, c]) } -> @@ -1104,7 +1199,7 @@ let wit_ssrfwdfmt = add_genarg "ssrfwdfmt" pr_fwdfmt let mkFwdVal fk c = ((fk, []), c) let mkssrFwdVal fk c = ((fk, []), (c,None)) -let dC t = CastConv t +let dC t = Glob_term.CastConv t let same_ist { interp_env = x } { interp_env = y } = match x,y with @@ -1146,10 +1241,12 @@ let pr_unguarded prc prlc = prlc let pr_fwd = pr_fwd_guarded pr_unguarded pr_unguarded let pr_ssrfwd _ _ _ = pr_fwd - -ARGUMENT EXTEND ssrfwd TYPED AS (ssrfwdfmt * ast_closure_lterm) PRINTED BY pr_ssrfwd - | [ ":=" ast_closure_lterm(c) ] -> [ mkFwdVal FwdPose c ] - | [ ":" ast_closure_lterm (t) ":=" ast_closure_lterm(c) ] -> [ mkFwdCast FwdPose ~loc t ~c ] + +} + +ARGUMENT EXTEND ssrfwd TYPED AS (ssrfwdfmt * ast_closure_lterm) PRINTED BY { pr_ssrfwd } + | [ ":=" ast_closure_lterm(c) ] -> { mkFwdVal FwdPose c } + | [ ":" ast_closure_lterm (t) ":=" ast_closure_lterm(c) ] -> { mkFwdCast FwdPose ~loc t ~c } END (** Independent parsing for binders *) @@ -1157,53 +1254,63 @@ END (* The pose, pose fix, and pose cofix tactics use these internally to *) (* parse argument fragments. *) +{ + let pr_ssrbvar prc _ _ v = prc v -ARGUMENT EXTEND ssrbvar TYPED AS constr PRINTED BY pr_ssrbvar -| [ ident(id) ] -> [ mkCVar ~loc id ] -| [ "_" ] -> [ mkCHole (Some loc) ] +} + +ARGUMENT EXTEND ssrbvar TYPED AS constr PRINTED BY { pr_ssrbvar } +| [ ident(id) ] -> { mkCVar ~loc id } +| [ "_" ] -> { mkCHole (Some loc) } END +{ + let bvar_lname = let open CAst in function - | { v = CRef ({loc;v=Ident id}, _) } -> CAst.make ?loc @@ Name id + | { v = CRef (qid, _) } when qualid_is_ident qid -> + CAst.make ?loc:qid.CAst.loc @@ Name (qualid_basename qid) | { loc = loc } -> CAst.make ?loc Anonymous let pr_ssrbinder prc _ _ (_, c) = prc c -ARGUMENT EXTEND ssrbinder TYPED AS ssrfwdfmt * constr PRINTED BY pr_ssrbinder +} + +ARGUMENT EXTEND ssrbinder TYPED AS (ssrfwdfmt * constr) PRINTED BY { pr_ssrbinder } | [ ssrbvar(bv) ] -> - [ let { CAst.loc=xloc } as x = bvar_lname bv in + { let { CAst.loc=xloc } as x = bvar_lname bv in (FwdPose, [BFvar]), - CAst.make ~loc @@ CLambdaN ([CLocalAssum([x],Default Explicit,mkCHole xloc)],mkCHole (Some loc)) ] + CAst.make ~loc @@ CLambdaN ([CLocalAssum([x],Default Explicit,mkCHole xloc)],mkCHole (Some loc)) } | [ "(" ssrbvar(bv) ")" ] -> - [ let { CAst.loc=xloc } as x = bvar_lname bv in + { let { CAst.loc=xloc } as x = bvar_lname bv in (FwdPose, [BFvar]), - CAst.make ~loc @@ CLambdaN ([CLocalAssum([x],Default Explicit,mkCHole xloc)],mkCHole (Some loc)) ] + CAst.make ~loc @@ CLambdaN ([CLocalAssum([x],Default Explicit,mkCHole xloc)],mkCHole (Some loc)) } | [ "(" ssrbvar(bv) ":" lconstr(t) ")" ] -> - [ let x = bvar_lname bv in + { let x = bvar_lname bv in (FwdPose, [BFdecl 1]), - CAst.make ~loc @@ CLambdaN ([CLocalAssum([x], Default Explicit, t)], mkCHole (Some loc)) ] + CAst.make ~loc @@ CLambdaN ([CLocalAssum([x], Default Explicit, t)], mkCHole (Some loc)) } | [ "(" ssrbvar(bv) ne_ssrbvar_list(bvs) ":" lconstr(t) ")" ] -> - [ let xs = List.map bvar_lname (bv :: bvs) in + { let xs = List.map bvar_lname (bv :: bvs) in let n = List.length xs in (FwdPose, [BFdecl n]), - CAst.make ~loc @@ CLambdaN ([CLocalAssum (xs, Default Explicit, t)], mkCHole (Some loc)) ] + CAst.make ~loc @@ CLambdaN ([CLocalAssum (xs, Default Explicit, t)], mkCHole (Some loc)) } | [ "(" ssrbvar(id) ":" lconstr(t) ":=" lconstr(v) ")" ] -> - [ (FwdPose,[BFdef]), CAst.make ~loc @@ CLetIn (bvar_lname id, v, Some t, mkCHole (Some loc)) ] + { (FwdPose,[BFdef]), CAst.make ~loc @@ CLetIn (bvar_lname id, v, Some t, mkCHole (Some loc)) } | [ "(" ssrbvar(id) ":=" lconstr(v) ")" ] -> - [ (FwdPose,[BFdef]), CAst.make ~loc @@ CLetIn (bvar_lname id, v, None, mkCHole (Some loc)) ] + { (FwdPose,[BFdef]), CAst.make ~loc @@ CLetIn (bvar_lname id, v, None, mkCHole (Some loc)) } END -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: ssrbinder; ssrbinder: [ - [ ["of" | "&"]; c = operconstr LEVEL "99" -> - let loc = !@loc in + [ ["of" -> { () } | "&" -> { () } ]; c = operconstr LEVEL "99" -> { (FwdPose, [BFvar]), - CAst.make ~loc @@ CLambdaN ([CLocalAssum ([CAst.make ~loc Anonymous],Default Explicit,c)],mkCHole (Some loc)) ] + CAst.make ~loc @@ CLambdaN ([CLocalAssum ([CAst.make ~loc Anonymous],Default Explicit,c)],mkCHole (Some loc)) } ] ]; END +{ + let rec binders_fmts = function | ((_, h), _) :: bs -> h @ binders_fmts bs | _ -> [] @@ -1221,8 +1328,8 @@ let push_binders c2 bs = | [] -> c | _ -> anomaly "binder not a lambda nor a let in" in match c2 with - | { loc; v = CCast (ct, CastConv cty) } -> - CAst.make ?loc @@ (CCast (loop false ct bs, CastConv (loop true cty bs))) + | { loc; v = CCast (ct, Glob_term.CastConv cty) } -> + CAst.make ?loc @@ (CCast (loop false ct bs, Glob_term.CastConv (loop true cty bs))) | ct -> loop false ct bs let rec fix_binders = let open CAst in function @@ -1236,34 +1343,44 @@ let pr_ssrstruct _ _ _ = function | Some id -> str "{struct " ++ pr_id id ++ str "}" | None -> mt () -ARGUMENT EXTEND ssrstruct TYPED AS ident option PRINTED BY pr_ssrstruct -| [ "{" "struct" ident(id) "}" ] -> [ Some id ] -| [ ] -> [ None ] +} + +ARGUMENT EXTEND ssrstruct TYPED AS ident option PRINTED BY { pr_ssrstruct } +| [ "{" "struct" ident(id) "}" ] -> { Some id } +| [ ] -> { None } END (** The "pose" tactic *) (* The plain pose form. *) +{ + let bind_fwd bs ((fk, h), c) = (fk,binders_fmts bs @ h), { c with body = push_binders c.body bs } -ARGUMENT EXTEND ssrposefwd TYPED AS ssrfwd PRINTED BY pr_ssrfwd - | [ ssrbinder_list(bs) ssrfwd(fwd) ] -> [ bind_fwd bs fwd ] +} + +ARGUMENT EXTEND ssrposefwd TYPED AS ssrfwd PRINTED BY { pr_ssrfwd } + | [ ssrbinder_list(bs) ssrfwd(fwd) ] -> { bind_fwd bs fwd } END (* The pose fix form. *) +{ + let pr_ssrfixfwd _ _ _ (id, fwd) = str " fix " ++ pr_id id ++ pr_fwd fwd let bvar_locid = function - | { CAst.v = CRef ({CAst.loc=loc;v=Ident id}, _) } -> CAst.make ?loc id + | { CAst.v = CRef (qid, _) } when qualid_is_ident qid -> + CAst.make ?loc:qid.CAst.loc (qualid_basename qid) | _ -> CErrors.user_err (Pp.str "Missing identifier after \"(co)fix\"") +} -ARGUMENT EXTEND ssrfixfwd TYPED AS ident * ssrfwd PRINTED BY pr_ssrfixfwd +ARGUMENT EXTEND ssrfixfwd TYPED AS (ident * ssrfwd) PRINTED BY { pr_ssrfixfwd } | [ "fix" ssrbvar(bv) ssrbinder_list(bs) ssrstruct(sid) ssrfwd(fwd) ] -> - [ let { CAst.v=id } as lid = bvar_locid bv in + { let { CAst.v=id } as lid = bvar_locid bv in let (fk, h), ac = fwd in let c = ac.body in let has_cast, t', c' = match format_constr_expr h c with @@ -1281,17 +1398,21 @@ ARGUMENT EXTEND ssrfixfwd TYPED AS ident * ssrfwd PRINTED BY pr_ssrfixfwd loop (names_of_local_assums lb) in let h' = BFrec (has_struct, has_cast) :: binders_fmts bs in let fix = CAst.make ~loc @@ CFix (lid, [lid, (Some i, CStructRec), lb, t', c']) in - id, ((fk, h'), { ac with body = fix }) ] + id, ((fk, h'), { ac with body = fix }) } END (* The pose cofix form. *) +{ + let pr_ssrcofixfwd _ _ _ (id, fwd) = str " cofix " ++ pr_id id ++ pr_fwd fwd -ARGUMENT EXTEND ssrcofixfwd TYPED AS ssrfixfwd PRINTED BY pr_ssrcofixfwd +} + +ARGUMENT EXTEND ssrcofixfwd TYPED AS ssrfixfwd PRINTED BY { pr_ssrcofixfwd } | [ "cofix" ssrbvar(bv) ssrbinder_list(bs) ssrfwd(fwd) ] -> - [ let { CAst.v=id } as lid = bvar_locid bv in + { let { CAst.v=id } as lid = bvar_locid bv in let (fk, h), ac = fwd in let c = ac.body in let has_cast, t', c' = match format_constr_expr h c with @@ -1300,36 +1421,45 @@ ARGUMENT EXTEND ssrcofixfwd TYPED AS ssrfixfwd PRINTED BY pr_ssrcofixfwd let h' = BFrec (false, has_cast) :: binders_fmts bs in let cofix = CAst.make ~loc @@ CCoFix (lid, [lid, fix_binders bs, t', c']) in id, ((fk, h'), { ac with body = cofix }) - ] + } END +{ + (* This does not print the type, it should be fixed... *) let pr_ssrsetfwd _ _ _ (((fk,_),(t,_)), docc) = pr_gen_fwd (fun _ _ -> pr_cpattern) (fun _ -> mt()) (fun _ -> mt()) fk ([Bcast ()],t) +} + ARGUMENT EXTEND ssrsetfwd -TYPED AS (ssrfwdfmt * (lcpattern * ast_closure_lterm option)) * ssrdocc -PRINTED BY pr_ssrsetfwd +TYPED AS ((ssrfwdfmt * (lcpattern * ast_closure_lterm option)) * ssrdocc) +PRINTED BY { pr_ssrsetfwd } | [ ":" ast_closure_lterm(t) ":=" "{" ssrocc(occ) "}" cpattern(c) ] -> - [ mkssrFwdCast FwdPose loc t c, mkocc occ ] + { mkssrFwdCast FwdPose loc t c, mkocc occ } | [ ":" ast_closure_lterm(t) ":=" lcpattern(c) ] -> - [ mkssrFwdCast FwdPose loc t c, nodocc ] + { mkssrFwdCast FwdPose loc t c, nodocc } | [ ":=" "{" ssrocc(occ) "}" cpattern(c) ] -> - [ mkssrFwdVal FwdPose c, mkocc occ ] -| [ ":=" lcpattern(c) ] -> [ mkssrFwdVal FwdPose c, nodocc ] + { mkssrFwdVal FwdPose c, mkocc occ } +| [ ":=" lcpattern(c) ] -> { mkssrFwdVal FwdPose c, nodocc } END +{ let pr_ssrhavefwd _ _ prt (fwd, hint) = pr_fwd fwd ++ pr_hint prt hint -ARGUMENT EXTEND ssrhavefwd TYPED AS ssrfwd * ssrhint PRINTED BY pr_ssrhavefwd -| [ ":" ast_closure_lterm(t) ssrhint(hint) ] -> [ mkFwdHint ":" t, hint ] -| [ ":" ast_closure_lterm(t) ":=" ast_closure_lterm(c) ] -> [ mkFwdCast FwdHave ~loc t ~c, nohint ] -| [ ":" ast_closure_lterm(t) ":=" ] -> [ mkFwdHintNoTC ":" t, nohint ] -| [ ":=" ast_closure_lterm(c) ] -> [ mkFwdVal FwdHave c, nohint ] +} + +ARGUMENT EXTEND ssrhavefwd TYPED AS (ssrfwd * ssrhint) PRINTED BY { pr_ssrhavefwd } +| [ ":" ast_closure_lterm(t) ssrhint(hint) ] -> { mkFwdHint ":" t, hint } +| [ ":" ast_closure_lterm(t) ":=" ast_closure_lterm(c) ] -> { mkFwdCast FwdHave ~loc t ~c, nohint } +| [ ":" ast_closure_lterm(t) ":=" ] -> { mkFwdHintNoTC ":" t, nohint } +| [ ":=" ast_closure_lterm(c) ] -> { mkFwdVal FwdHave c, nohint } END +{ + let intro_id_to_binder = List.map (function | IPatId id -> let { CAst.loc=xloc } as x = bvar_lname (mkCVar id) in @@ -1349,28 +1479,35 @@ let binder_to_intro_id = CAst.(List.map (function let pr_ssrhavefwdwbinders _ _ prt (tr,((hpats, (fwd, hint)))) = pr_hpats hpats ++ pr_fwd fwd ++ pr_hint prt hint +} + ARGUMENT EXTEND ssrhavefwdwbinders - TYPED AS bool * (ssrhpats * (ssrfwd * ssrhint)) - PRINTED BY pr_ssrhavefwdwbinders + TYPED AS (bool * (ssrhpats * (ssrfwd * ssrhint))) + PRINTED BY { pr_ssrhavefwdwbinders } | [ ssrhpats_wtransp(trpats) ssrbinder_list(bs) ssrhavefwd(fwd) ] -> - [ let tr, pats = trpats in + { let tr, pats = trpats in let ((clr, pats), binders), simpl = pats in let allbs = intro_id_to_binder binders @ bs in let allbinders = binders @ List.flatten (binder_to_intro_id bs) in let hint = bind_fwd allbs (fst fwd), snd fwd in - tr, ((((clr, pats), allbinders), simpl), hint) ] + tr, ((((clr, pats), allbinders), simpl), hint) } END +{ let pr_ssrdoarg prc _ prt (((n, m), tac), clauses) = pr_index n ++ pr_mmod m ++ pr_hintarg prt tac ++ pr_clauses clauses +} + ARGUMENT EXTEND ssrdoarg - TYPED AS ((ssrindex * ssrmmod) * ssrhintarg) * ssrclauses - PRINTED BY pr_ssrdoarg -| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] + TYPED AS (((ssrindex * ssrmmod) * ssrhintarg) * ssrclauses) + PRINTED BY { pr_ssrdoarg } +| [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END +{ + (* type ssrseqarg = ssrindex * (ssrtacarg * ssrtac option) *) let pr_seqtacarg prt = function @@ -1383,13 +1520,17 @@ let pr_ssrseqarg _ _ prt = function | ArgArg 0, tac -> pr_seqtacarg prt tac | i, tac -> pr_index i ++ str " " ++ pr_seqtacarg prt tac +} + (* We must parse the index separately to resolve the conflict with *) (* an unindexed tactic. *) -ARGUMENT EXTEND ssrseqarg TYPED AS ssrindex * (ssrhintarg * tactic option) - PRINTED BY pr_ssrseqarg -| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +ARGUMENT EXTEND ssrseqarg TYPED AS (ssrindex * (ssrhintarg * tactic option)) + PRINTED BY { pr_ssrseqarg } +| [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END +{ + let sq_brace_tacnames = ["first"; "solve"; "do"; "rewrite"; "have"; "suffices"; "wlog"] (* "by" is a keyword *) @@ -1399,47 +1540,57 @@ let accept_ssrseqvar strm = accept_before_syms_or_ids ["["] ["first";"last"] strm | _ -> raise Stream.Failure -let test_ssrseqvar = Gram.Entry.of_parser "test_ssrseqvar" accept_ssrseqvar +let test_ssrseqvar = Pcoq.Entry.of_parser "test_ssrseqvar" accept_ssrseqvar let swaptacarg (loc, b) = (b, []), Some (TacId []) let check_seqtacarg dir arg = match snd arg, dir with - | ((true, []), Some (TacAtom (loc, _))), L2R -> + | ((true, []), Some (TacAtom { CAst.loc })), L2R -> CErrors.user_err ?loc (str "expected \"last\"") - | ((false, []), Some (TacAtom (loc, _))), R2L -> + | ((false, []), Some (TacAtom { CAst.loc })), R2L -> CErrors.user_err ?loc (str "expected \"first\"") | _, _ -> arg -let ssrorelse = Gram.entry_create "ssrorelse" -GEXTEND Gram +let ssrorelse = Entry.create "ssrorelse" + +} + +GRAMMAR EXTEND Gram GLOBAL: ssrorelse ssrseqarg; ssrseqidx: [ - [ test_ssrseqvar; id = Prim.ident -> ArgVar (CAst.make ~loc:!@loc id) - | n = Prim.natural -> ArgArg (check_index ~loc:!@loc n) + [ test_ssrseqvar; id = Prim.ident -> { ArgVar (CAst.make ~loc id) } + | n = Prim.natural -> { ArgArg (check_index ~loc n) } ] ]; - ssrswap: [[ IDENT "first" -> !@loc, true | IDENT "last" -> !@loc, false ]]; - ssrorelse: [[ "||"; tac = tactic_expr LEVEL "2" -> tac ]]; + ssrswap: [[ IDENT "first" -> { loc, true } | IDENT "last" -> { loc, false } ]]; + ssrorelse: [[ "||"; tac = tactic_expr LEVEL "2" -> { tac } ]]; ssrseqarg: [ - [ arg = ssrswap -> noindex, swaptacarg arg - | i = ssrseqidx; tac = ssrortacarg; def = OPT ssrorelse -> i, (tac, def) - | i = ssrseqidx; arg = ssrswap -> i, swaptacarg arg - | tac = tactic_expr LEVEL "3" -> noindex, (mk_hint tac, None) + [ arg = ssrswap -> { noindex, swaptacarg arg } + | i = ssrseqidx; tac = ssrortacarg; def = OPT ssrorelse -> { i, (tac, def) } + | i = ssrseqidx; arg = ssrswap -> { i, swaptacarg arg } + | tac = tactic_expr LEVEL "3" -> { noindex, (mk_hint tac, None) } ] ]; END +{ + let tactic_expr = Pltac.tactic_expr +} + (** 1. Utilities *) (** Tactic-level diagnosis *) (* debug *) +{ + (* Let's play with the new proof engine API *) let old_tac = V82.tactic +} -(** Name generation *)(* {{{ *******************************************************) +(** Name generation *) (* Since Coq now does repeated internal checks of its external lexical *) (* rules, we now need to carve ssreflect reserved identifiers out of *) @@ -1450,6 +1601,8 @@ let old_tac = V82.tactic (* when the ssreflect Module is present this is normally an error, *) (* but we provide a compatibility flag to reduce this to a warning. *) +{ + let ssr_reserved_ids = Summary.ref ~name:"SSR:idents" true let _ = @@ -1475,23 +1628,25 @@ let ssr_id_of_string loc s = ^ "Scripts with explicit references to anonymous variables are fragile.")) end; Id.of_string s -let ssr_null_entry = Gram.Entry.of_parser "ssr_null" (fun _ -> ()) +let ssr_null_entry = Pcoq.Entry.of_parser "ssr_null" (fun _ -> ()) -let (!@) = Pcoq.to_coqloc +} -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: Prim.ident; - Prim.ident: [[ s = IDENT; ssr_null_entry -> ssr_id_of_string !@loc s ]]; + Prim.ident: [[ s = IDENT; ssr_null_entry -> { ssr_id_of_string loc s } ]]; END +{ + let perm_tag = "_perm_Hyp_" let _ = add_internal_name (is_tagged perm_tag) - -(* }}} *) + +} (* We must not anonymize context names discharged by the "in" tactical. *) -(** Tactical extensions. *)(* {{{ **************************************************) +(** Tactical extensions. *) (* The TACTIC EXTEND facility can't be used for defining new user *) (* tacticals, because: *) @@ -1501,6 +1656,8 @@ let _ = add_internal_name (is_tagged perm_tag) (* don't start with a token, then redefine the grammar and *) (* printer using GEXTEND and set_pr_ssrtac, respectively. *) +{ + type ssrargfmt = ArgSsr of string | ArgSep of string let ssrtac_name name = { @@ -1520,22 +1677,22 @@ let set_pr_ssrtac name prec afmt = (* FIXME *) () (* | ArgCoq at -> Egramml.GramTerminal "COQ_ARG") afmt in let tacname = ssrtac_name name in () *) -let ssrtac_atom ?loc name args = TacML (Loc.tag ?loc (ssrtac_entry name 0, args)) +let ssrtac_atom ?loc name args = TacML (CAst.make ?loc (ssrtac_entry name 0, args)) let ssrtac_expr ?loc name args = ssrtac_atom ?loc name args let tclintros_expr ?loc tac ipats = let args = [Tacexpr.TacGeneric (in_gen (rawwit wit_ssrintrosarg) (tac, ipats))] in ssrtac_expr ?loc "tclintros" args -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: tactic_expr; tactic_expr: LEVEL "1" [ RIGHTA - [ tac = tactic_expr; intros = ssrintros_ne -> tclintros_expr ~loc:!@loc tac intros + [ tac = tactic_expr; intros = ssrintros_ne -> { tclintros_expr ~loc tac intros } ] ]; END -(* }}} *) - (** Bracketing tactical *) @@ -1545,10 +1702,10 @@ END (* expressions so that the pretty-print always reflects the input. *) (* (Removing user-specified parentheses is dubious anyway). *) -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: tactic_expr; - ssrparentacarg: [[ "("; tac = tactic_expr; ")" -> Loc.tag ~loc:!@loc (Tacexp tac) ]]; - tactic_expr: LEVEL "0" [[ arg = ssrparentacarg -> TacArg arg ]]; + ssrparentacarg: [[ "("; tac = tactic_expr; ")" -> { CAst.make ~loc (Tacexp tac) } ]]; + tactic_expr: LEVEL "0" [[ arg = ssrparentacarg -> { TacArg arg } ]]; END (** The internal "done" and "ssrautoprop" tactics. *) @@ -1560,12 +1717,14 @@ END (* to allow for user extensions. "ssrautoprop" defaults to *) (* trivial. *) +{ + let ssrautoprop gl = try let tacname = try Tacenv.locate_tactic (qualid_of_ident (Id.of_string "ssrautoprop")) with Not_found -> Tacenv.locate_tactic (ssrqid "ssrautoprop") in - let tacexpr = Loc.tag @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in + let tacexpr = CAst.make @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in V82.of_tactic (eval_tactic (Tacexpr.TacArg tacexpr)) gl with Not_found -> V82.of_tactic (Auto.full_trivial []) gl @@ -1586,17 +1745,18 @@ let tclBY tac = Tacticals.tclTHEN tac (donetac ~-1) open Ssrfwd +} + TACTIC EXTEND ssrtclby -| [ "by" ssrhintarg(tac) ] -> [ V82.tactic (hinttac ist true tac) ] +| [ "by" ssrhintarg(tac) ] -> { V82.tactic (hinttac ist true tac) } END -(* }}} *) (* We can't parse "by" in ARGUMENT EXTEND because it will only be made *) (* into a keyword in ssreflect.v; so we anticipate this in GEXTEND. *) -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: ssrhint simple_tactic; - ssrhint: [[ "by"; arg = ssrhintarg -> arg ]]; + ssrhint: [[ "by"; arg = ssrhintarg -> { arg } ]]; END (** The "do" tactical. ********************************************************) @@ -1605,32 +1765,37 @@ END type ssrdoarg = ((ssrindex * ssrmmod) * ssrhint) * ssrclauses *) TACTIC EXTEND ssrtcldo -| [ "YouShouldNotTypeThis" "do" ssrdoarg(arg) ] -> [ V82.tactic (ssrdotac ist arg) ] +| [ "YouShouldNotTypeThis" "do" ssrdoarg(arg) ] -> { V82.tactic (ssrdotac ist arg) } END -set_pr_ssrtac "tcldo" 3 [ArgSep "do "; ArgSsr "doarg"] + +{ + +let _ = set_pr_ssrtac "tcldo" 3 [ArgSep "do "; ArgSsr "doarg"] let ssrdotac_expr ?loc n m tac clauses = let arg = ((n, m), tac), clauses in ssrtac_expr ?loc "tcldo" [Tacexpr.TacGeneric (in_gen (rawwit wit_ssrdoarg) arg)] -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: tactic_expr; ssrdotac: [ - [ tac = tactic_expr LEVEL "3" -> mk_hint tac - | tacs = ssrortacarg -> tacs + [ tac = tactic_expr LEVEL "3" -> { mk_hint tac } + | tacs = ssrortacarg -> { tacs } ] ]; tactic_expr: LEVEL "3" [ RIGHTA [ IDENT "do"; m = ssrmmod; tac = ssrdotac; clauses = ssrclauses -> - ssrdotac_expr ~loc:!@loc noindex m tac clauses + { ssrdotac_expr ~loc noindex m tac clauses } | IDENT "do"; tac = ssrortacarg; clauses = ssrclauses -> - ssrdotac_expr ~loc:!@loc noindex Once tac clauses + { ssrdotac_expr ~loc noindex Once tac clauses } | IDENT "do"; n = int_or_var; m = ssrmmod; tac = ssrdotac; clauses = ssrclauses -> - ssrdotac_expr ~loc:!@loc (mk_index ~loc:!@loc n) m tac clauses + { ssrdotac_expr ~loc (mk_index ~loc n) m tac clauses } ] ]; END -(* }}} *) +{ (* We can't actually parse the direction separately because this *) (* would introduce conflicts with the basic ltac syntax. *) @@ -1638,15 +1803,20 @@ let pr_ssrseqdir _ _ _ = function | L2R -> str ";" ++ spc () ++ str "first " | R2L -> str ";" ++ spc () ++ str "last " -ARGUMENT EXTEND ssrseqdir TYPED AS ssrdir PRINTED BY pr_ssrseqdir -| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +} + +ARGUMENT EXTEND ssrseqdir TYPED AS ssrdir PRINTED BY { pr_ssrseqdir } +| [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END TACTIC EXTEND ssrtclseq | [ "YouShouldNotTypeThis" ssrtclarg(tac) ssrseqdir(dir) ssrseqarg(arg) ] -> - [ V82.tactic (tclSEQAT ist tac dir arg) ] + { V82.tactic (tclSEQAT ist tac dir arg) } END -set_pr_ssrtac "tclseq" 5 [ArgSsr "tclarg"; ArgSsr "seqdir"; ArgSsr "seqarg"] + +{ + +let _ = set_pr_ssrtac "tclseq" 5 [ArgSsr "tclarg"; ArgSsr "seqdir"; ArgSsr "seqarg"] let tclseq_expr ?loc tac dir arg = let arg1 = in_gen (rawwit wit_ssrtclarg) tac in @@ -1654,25 +1824,26 @@ let tclseq_expr ?loc tac dir arg = let arg3 = in_gen (rawwit wit_ssrseqarg) (check_seqtacarg dir arg) in ssrtac_expr ?loc "tclseq" (List.map (fun x -> Tacexpr.TacGeneric x) [arg1; arg2; arg3]) -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: tactic_expr; ssr_first: [ - [ tac = ssr_first; ipats = ssrintros_ne -> tclintros_expr ~loc:!@loc tac ipats - | "["; tacl = LIST0 tactic_expr SEP "|"; "]" -> TacFirst tacl + [ tac = ssr_first; ipats = ssrintros_ne -> { tclintros_expr ~loc tac ipats } + | "["; tacl = LIST0 tactic_expr SEP "|"; "]" -> { TacFirst tacl } ] ]; ssr_first_else: [ - [ tac1 = ssr_first; tac2 = ssrorelse -> TacOrelse (tac1, tac2) - | tac = ssr_first -> tac ]]; + [ tac1 = ssr_first; tac2 = ssrorelse -> { TacOrelse (tac1, tac2) } + | tac = ssr_first -> { tac } ]]; tactic_expr: LEVEL "4" [ LEFTA [ tac1 = tactic_expr; ";"; IDENT "first"; tac2 = ssr_first_else -> - TacThen (tac1, tac2) + { TacThen (tac1, tac2) } | tac = tactic_expr; ";"; IDENT "first"; arg = ssrseqarg -> - tclseq_expr ~loc:!@loc tac L2R arg + { tclseq_expr ~loc tac L2R arg } | tac = tactic_expr; ";"; IDENT "last"; arg = ssrseqarg -> - tclseq_expr ~loc:!@loc tac R2L arg + { tclseq_expr ~loc tac R2L arg } ] ]; END -(* }}} *) (** 5. Bookkeeping tactics (clear, move, case, elim) *) @@ -1682,15 +1853,24 @@ END (* type ssrgen = ssrdocc * ssrterm *) +{ + let pr_gen (docc, dt) = pr_docc docc ++ pr_cpattern dt let pr_ssrgen _ _ _ = pr_gen -ARGUMENT EXTEND ssrgen TYPED AS ssrdocc * cpattern PRINTED BY pr_ssrgen -| [ ssrdocc(docc) cpattern(dt) ] -> [ docc, dt ] -| [ cpattern(dt) ] -> [ nodocc, dt ] +} + +ARGUMENT EXTEND ssrgen TYPED AS (ssrdocc * cpattern) PRINTED BY { pr_ssrgen } +| [ ssrdocc(docc) cpattern(dt) ] -> { + match docc with + | Some [], _ -> CErrors.user_err ~loc (str"Clear flag {} not allowed here") + | _ -> docc, dt } +| [ cpattern(dt) ] -> { nodocc, dt } END +{ + let has_occ ((_, occ), _) = occ <> None (** Generalization (discharge) sequence *) @@ -1726,39 +1906,47 @@ let cons_dep (gensl, clr) = if List.length gensl = 1 then ([] :: gensl, clr) else CErrors.user_err (Pp.str "multiple dependents switches '/'") -ARGUMENT EXTEND ssrdgens_tl TYPED AS ssrgen list list * ssrclear - PRINTED BY pr_ssrdgens +} + +ARGUMENT EXTEND ssrdgens_tl TYPED AS (ssrgen list list * ssrclear) + PRINTED BY { pr_ssrdgens } | [ "{" ne_ssrhyp_list(clr) "}" cpattern(dt) ssrdgens_tl(dgens) ] -> - [ cons_gen (mkclr clr, dt) dgens ] + { cons_gen (mkclr clr, dt) dgens } | [ "{" ne_ssrhyp_list(clr) "}" ] -> - [ [[]], clr ] + { [[]], clr } | [ "{" ssrocc(occ) "}" cpattern(dt) ssrdgens_tl(dgens) ] -> - [ cons_gen (mkocc occ, dt) dgens ] + { cons_gen (mkocc occ, dt) dgens } | [ "/" ssrdgens_tl(dgens) ] -> - [ cons_dep dgens ] + { cons_dep dgens } | [ cpattern(dt) ssrdgens_tl(dgens) ] -> - [ cons_gen (nodocc, dt) dgens ] + { cons_gen (nodocc, dt) dgens } | [ ] -> - [ [[]], [] ] + { [[]], [] } END -ARGUMENT EXTEND ssrdgens TYPED AS ssrdgens_tl PRINTED BY pr_ssrdgens -| [ ":" ssrgen(gen) ssrdgens_tl(dgens) ] -> [ cons_gen gen dgens ] +ARGUMENT EXTEND ssrdgens TYPED AS ssrdgens_tl PRINTED BY { pr_ssrdgens } +| [ ":" ssrgen(gen) ssrdgens_tl(dgens) ] -> { cons_gen gen dgens } END (** Equations *) (* argument *) +{ + let pr_eqid = function Some pat -> str " " ++ pr_ipat pat | None -> mt () let pr_ssreqid _ _ _ = pr_eqid +} + (* We must use primitive parsing here to avoid conflicts with the *) (* basic move, case, and elim tactics. *) -ARGUMENT EXTEND ssreqid TYPED AS ssripatrep option PRINTED BY pr_ssreqid -| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +ARGUMENT EXTEND ssreqid TYPED AS ssripatrep option PRINTED BY { pr_ssreqid } +| [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END +{ + let accept_ssreqid strm = match Util.stream_nth 0 strm with | Tok.IDENT _ -> accept_before_syms [":"] strm @@ -1767,26 +1955,28 @@ let accept_ssreqid strm = accept_before_syms [":"] strm | _ -> raise Stream.Failure -let test_ssreqid = Gram.Entry.of_parser "test_ssreqid" accept_ssreqid +let test_ssreqid = Pcoq.Entry.of_parser "test_ssreqid" accept_ssreqid -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: ssreqid; ssreqpat: [ - [ id = Prim.ident -> IPatId id - | "_" -> IPatAnon Drop - | "?" -> IPatAnon One - | occ = ssrdocc; "->" -> (match occ with + [ id = Prim.ident -> { IPatId id } + | "_" -> { IPatAnon Drop } + | "?" -> { IPatAnon One } + | occ = ssrdocc; "->" -> { match occ with | None, occ -> IPatRewrite (occ, L2R) - | _ -> CErrors.user_err ~loc:!@loc (str"Only occurrences are allowed here")) - | occ = ssrdocc; "<-" -> (match occ with + | _ -> CErrors.user_err ~loc (str"Only occurrences are allowed here") } + | occ = ssrdocc; "<-" -> { match occ with | None, occ -> IPatRewrite (occ, R2L) - | _ -> CErrors.user_err ~loc:!@loc (str "Only occurrences are allowed here")) - | "->" -> IPatRewrite (allocc, L2R) - | "<-" -> IPatRewrite (allocc, R2L) + | _ -> CErrors.user_err ~loc (str "Only occurrences are allowed here") } + | "->" -> { IPatRewrite (allocc, L2R) } + | "<-" -> { IPatRewrite (allocc, R2L) } ]]; ssreqid: [ - [ test_ssreqid; pat = ssreqpat -> Some pat - | test_ssreqid -> None + [ test_ssreqid; pat = ssreqpat -> { Some pat } + | test_ssreqid -> { None } ]]; END @@ -1799,22 +1989,26 @@ END (* type ssrarg = ssrbwdview * (ssreqid * (ssrdgens * ssripats)) *) +{ + let pr_ssrarg _ _ _ (view, (eqid, (dgens, ipats))) = let pri = pr_intros (gens_sep dgens) in pr_view2 view ++ pr_eqid eqid ++ pr_dgens pr_gen dgens ++ pri ipats -ARGUMENT EXTEND ssrarg TYPED AS ssrfwdview * (ssreqid * (ssrdgens * ssrintros)) - PRINTED BY pr_ssrarg +} + +ARGUMENT EXTEND ssrarg TYPED AS (ssrfwdview * (ssreqid * (ssrdgens * ssrintros))) + PRINTED BY { pr_ssrarg } | [ ssrfwdview(view) ssreqid(eqid) ssrdgens(dgens) ssrintros(ipats) ] -> - [ view, (eqid, (dgens, ipats)) ] + { view, (eqid, (dgens, ipats)) } | [ ssrfwdview(view) ssrclear(clr) ssrintros(ipats) ] -> - [ view, (None, (([], clr), ipats)) ] + { view, (None, (([], clr), ipats)) } | [ ssreqid(eqid) ssrdgens(dgens) ssrintros(ipats) ] -> - [ [], (eqid, (dgens, ipats)) ] + { [], (eqid, (dgens, ipats)) } | [ ssrclear_ne(clr) ssrintros(ipats) ] -> - [ [], (None, (([], clr), ipats)) ] + { [], (None, (([], clr), ipats)) } | [ ssrintros_ne(ipats) ] -> - [ [], (None, (([], []), ipats)) ] + { [], (None, (([], []), ipats)) } END (** The "clear" tactic *) @@ -1822,11 +2016,13 @@ END (* We just add a numeric version that clears the n top assumptions. *) TACTIC EXTEND ssrclear - | [ "clear" natural(n) ] -> [ tclIPAT (List.init n (fun _ -> IPatAnon Drop)) ] + | [ "clear" natural(n) ] -> { tclIPAT (List.init n (fun _ -> IPatAnon Drop)) } END (** The "move" tactic *) +{ + (* TODO: review this, in particular the => _ and => [] cases *) let rec improper_intros = function | IPatSimpl _ :: ipats -> improper_intros ipats @@ -1844,149 +2040,179 @@ let check_movearg = function CErrors.user_err (Pp.str "no proper intro pattern for equation in move tactic") | arg -> arg -ARGUMENT EXTEND ssrmovearg TYPED AS ssrarg PRINTED BY pr_ssrarg -| [ ssrarg(arg) ] -> [ check_movearg arg ] +} + +ARGUMENT EXTEND ssrmovearg TYPED AS ssrarg PRINTED BY { pr_ssrarg } +| [ ssrarg(arg) ] -> { check_movearg arg } END +{ + let movearg_of_parsed_movearg (v,(eq,(dg,ip))) = (v,(eq,(ssrdgens_of_parsed_dgens dg,ip))) +} + TACTIC EXTEND ssrmove | [ "move" ssrmovearg(arg) ssrrpat(pat) ] -> - [ ssrmovetac (movearg_of_parsed_movearg arg) <*> tclIPAT [pat] ] + { ssrmovetac (movearg_of_parsed_movearg arg) <*> tclIPAT [pat] } | [ "move" ssrmovearg(arg) ssrclauses(clauses) ] -> - [ tclCLAUSES (ssrmovetac (movearg_of_parsed_movearg arg)) clauses ] -| [ "move" ssrrpat(pat) ] -> [ tclIPAT [pat] ] -| [ "move" ] -> [ ssrsmovetac ] + { tclCLAUSES (ssrmovetac (movearg_of_parsed_movearg arg)) clauses } +| [ "move" ssrrpat(pat) ] -> { tclIPAT [pat] } +| [ "move" ] -> { ssrsmovetac } END +{ + let check_casearg = function | view, (_, (([_; gen :: _], _), _)) when view <> [] && has_occ gen -> CErrors.user_err (Pp.str "incompatible view and occurrence switch in dependent case tactic") | arg -> arg -ARGUMENT EXTEND ssrcasearg TYPED AS ssrarg PRINTED BY pr_ssrarg -| [ ssrarg(arg) ] -> [ check_casearg arg ] +} + +ARGUMENT EXTEND ssrcasearg TYPED AS ssrarg PRINTED BY { pr_ssrarg } +| [ ssrarg(arg) ] -> { check_casearg arg } END TACTIC EXTEND ssrcase | [ "case" ssrcasearg(arg) ssrclauses(clauses) ] -> - [ tclCLAUSES (ssrcasetac (movearg_of_parsed_movearg arg)) clauses ] -| [ "case" ] -> [ ssrscasetoptac ] + { tclCLAUSES (ssrcasetac (movearg_of_parsed_movearg arg)) clauses } +| [ "case" ] -> { ssrscasetoptac } END (** The "elim" tactic *) TACTIC EXTEND ssrelim | [ "elim" ssrarg(arg) ssrclauses(clauses) ] -> - [ tclCLAUSES (ssrelimtac (movearg_of_parsed_movearg arg)) clauses ] -| [ "elim" ] -> [ ssrselimtoptac ] + { tclCLAUSES (ssrelimtac (movearg_of_parsed_movearg arg)) clauses } +| [ "elim" ] -> { ssrselimtoptac } END (** 6. Backward chaining tactics: apply, exact, congr. *) (** The "apply" tactic *) +{ + let pr_agen (docc, dt) = pr_docc docc ++ pr_term dt let pr_ssragen _ _ _ = pr_agen let pr_ssragens _ _ _ = pr_dgens pr_agen -ARGUMENT EXTEND ssragen TYPED AS ssrdocc * ssrterm PRINTED BY pr_ssragen -| [ "{" ne_ssrhyp_list(clr) "}" ssrterm(dt) ] -> [ mkclr clr, dt ] -| [ ssrterm(dt) ] -> [ nodocc, dt ] +} + +ARGUMENT EXTEND ssragen TYPED AS (ssrdocc * ssrterm) PRINTED BY { pr_ssragen } +| [ "{" ne_ssrhyp_list(clr) "}" ssrterm(dt) ] -> { mkclr clr, dt } +| [ ssrterm(dt) ] -> { nodocc, dt } END -ARGUMENT EXTEND ssragens TYPED AS ssragen list list * ssrclear -PRINTED BY pr_ssragens +ARGUMENT EXTEND ssragens TYPED AS (ssragen list list * ssrclear) +PRINTED BY { pr_ssragens } | [ "{" ne_ssrhyp_list(clr) "}" ssrterm(dt) ssragens(agens) ] -> - [ cons_gen (mkclr clr, dt) agens ] -| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ [[]], clr] + { cons_gen (mkclr clr, dt) agens } +| [ "{" ne_ssrhyp_list(clr) "}" ] -> { [[]], clr} | [ ssrterm(dt) ssragens(agens) ] -> - [ cons_gen (nodocc, dt) agens ] -| [ ] -> [ [[]], [] ] + { cons_gen (nodocc, dt) agens } +| [ ] -> { [[]], [] } END +{ + let mk_applyarg views agens intros = views, (agens, intros) let pr_ssraarg _ _ _ (view, (dgens, ipats)) = let pri = pr_intros (gens_sep dgens) in pr_view view ++ pr_dgens pr_agen dgens ++ pri ipats +} + ARGUMENT EXTEND ssrapplyarg -TYPED AS ssrbwdview * (ssragens * ssrintros) -PRINTED BY pr_ssraarg +TYPED AS (ssrbwdview * (ssragens * ssrintros)) +PRINTED BY { pr_ssraarg } | [ ":" ssragen(gen) ssragens(dgens) ssrintros(intros) ] -> - [ mk_applyarg [] (cons_gen gen dgens) intros ] + { mk_applyarg [] (cons_gen gen dgens) intros } | [ ssrclear_ne(clr) ssrintros(intros) ] -> - [ mk_applyarg [] ([], clr) intros ] + { mk_applyarg [] ([], clr) intros } | [ ssrintros_ne(intros) ] -> - [ mk_applyarg [] ([], []) intros ] + { mk_applyarg [] ([], []) intros } | [ ssrbwdview(view) ":" ssragen(gen) ssragens(dgens) ssrintros(intros) ] -> - [ mk_applyarg view (cons_gen gen dgens) intros ] + { mk_applyarg view (cons_gen gen dgens) intros } | [ ssrbwdview(view) ssrclear(clr) ssrintros(intros) ] -> - [ mk_applyarg view ([], clr) intros ] + { mk_applyarg view ([], clr) intros } END TACTIC EXTEND ssrapply -| [ "apply" ssrapplyarg(arg) ] -> [ +| [ "apply" ssrapplyarg(arg) ] -> { let views, (gens_clr, intros) = arg in - inner_ssrapplytac views gens_clr ist <*> tclIPATssr intros ] -| [ "apply" ] -> [ apply_top_tac ] + inner_ssrapplytac views gens_clr ist <*> tclIPATssr intros } +| [ "apply" ] -> { apply_top_tac } END (** The "exact" tactic *) +{ + let mk_exactarg views dgens = mk_applyarg views dgens [] -ARGUMENT EXTEND ssrexactarg TYPED AS ssrapplyarg PRINTED BY pr_ssraarg +} + +ARGUMENT EXTEND ssrexactarg TYPED AS ssrapplyarg PRINTED BY { pr_ssraarg } | [ ":" ssragen(gen) ssragens(dgens) ] -> - [ mk_exactarg [] (cons_gen gen dgens) ] + { mk_exactarg [] (cons_gen gen dgens) } | [ ssrbwdview(view) ssrclear(clr) ] -> - [ mk_exactarg view ([], clr) ] + { mk_exactarg view ([], clr) } | [ ssrclear_ne(clr) ] -> - [ mk_exactarg [] ([], clr) ] + { mk_exactarg [] ([], clr) } END +{ + let vmexacttac pf = - Goal.nf_enter begin fun gl -> - exact_no_check (EConstr.mkCast (pf, VMcast, Tacmach.New.pf_concl gl)) + Goal.enter begin fun gl -> + exact_no_check (EConstr.mkCast (pf, _vmcast, Tacmach.New.pf_concl gl)) end +} + TACTIC EXTEND ssrexact -| [ "exact" ssrexactarg(arg) ] -> [ +| [ "exact" ssrexactarg(arg) ] -> { let views, (gens_clr, _) = arg in - V82.tactic (tclBY (V82.of_tactic (inner_ssrapplytac views gens_clr ist))) ] -| [ "exact" ] -> [ - V82.tactic (Tacticals.tclORELSE (donetac ~-1) (tclBY (V82.of_tactic apply_top_tac))) ] -| [ "exact" "<:" lconstr(pf) ] -> [ vmexacttac pf ] + V82.tactic (tclBY (V82.of_tactic (inner_ssrapplytac views gens_clr ist))) } +| [ "exact" ] -> { + V82.tactic (Tacticals.tclORELSE (donetac ~-1) (tclBY (V82.of_tactic apply_top_tac))) } +| [ "exact" "<:" lconstr(pf) ] -> { vmexacttac pf } END (** The "congr" tactic *) (* type ssrcongrarg = open_constr * (int * constr) *) +{ + let pr_ssrcongrarg _ _ _ ((n, f), dgens) = (if n <= 0 then mt () else str " " ++ int n) ++ str " " ++ pr_term f ++ pr_dgens pr_gen dgens -ARGUMENT EXTEND ssrcongrarg TYPED AS (int * ssrterm) * ssrdgens - PRINTED BY pr_ssrcongrarg -| [ natural(n) constr(c) ssrdgens(dgens) ] -> [ (n, mk_term xNoFlag c), dgens ] -| [ natural(n) constr(c) ] -> [ (n, mk_term xNoFlag c),([[]],[]) ] -| [ constr(c) ssrdgens(dgens) ] -> [ (0, mk_term xNoFlag c), dgens ] -| [ constr(c) ] -> [ (0, mk_term xNoFlag c), ([[]],[]) ] +} + +ARGUMENT EXTEND ssrcongrarg TYPED AS ((int * ssrterm) * ssrdgens) + PRINTED BY { pr_ssrcongrarg } +| [ natural(n) constr(c) ssrdgens(dgens) ] -> { (n, mk_term xNoFlag c), dgens } +| [ natural(n) constr(c) ] -> { (n, mk_term xNoFlag c),([[]],[]) } +| [ constr(c) ssrdgens(dgens) ] -> { (0, mk_term xNoFlag c), dgens } +| [ constr(c) ] -> { (0, mk_term xNoFlag c), ([[]],[]) } END TACTIC EXTEND ssrcongr | [ "congr" ssrcongrarg(arg) ] -> -[ let arg, dgens = arg in +{ let arg, dgens = arg in V82.tactic begin match dgens with | [gens], clr -> Tacticals.tclTHEN (genstac (gens,clr)) (newssrcongrtac arg ist) | _ -> errorstrm (str"Dependent family abstractions not allowed in congr") - end] + end } END (** 7. Rewriting tactics (rewrite, unlock) *) @@ -1995,6 +2221,8 @@ END (** Rewrite clear/occ switches *) +{ + let pr_rwocc = function | None, None -> mt () | None, occ -> pr_occ occ @@ -2002,14 +2230,18 @@ let pr_rwocc = function let pr_ssrrwocc _ _ _ = pr_rwocc -ARGUMENT EXTEND ssrrwocc TYPED AS ssrdocc PRINTED BY pr_ssrrwocc -| [ "{" ssrhyp_list(clr) "}" ] -> [ mkclr clr ] -| [ "{" ssrocc(occ) "}" ] -> [ mkocc occ ] -| [ ] -> [ noclr ] +} + +ARGUMENT EXTEND ssrrwocc TYPED AS ssrdocc PRINTED BY { pr_ssrrwocc } +| [ "{" ssrhyp_list(clr) "}" ] -> { mkclr clr } +| [ "{" ssrocc(occ) "}" ] -> { mkocc occ } +| [ ] -> { noclr } END (** Rewrite rules *) +{ + let pr_rwkind = function | RWred s -> pr_simpl s | RWdef -> str "/" @@ -2026,29 +2258,33 @@ let pr_ssrrule _ _ _ = pr_rule let noruleterm loc = mk_term xNoFlag (mkCProp loc) -ARGUMENT EXTEND ssrrule_ne TYPED AS ssrrwkind * ssrterm PRINTED BY pr_ssrrule - | [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +} + +ARGUMENT EXTEND ssrrule_ne TYPED AS (ssrrwkind * ssrterm) PRINTED BY { pr_ssrrule } + | [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: ssrrule_ne; ssrrule_ne : [ [ test_not_ssrslashnum; x = - [ "/"; t = ssrterm -> RWdef, t - | t = ssrterm -> RWeq, t - | s = ssrsimpl_ne -> RWred s, noruleterm (Some !@loc) - ] -> x - | s = ssrsimpl_ne -> RWred s, noruleterm (Some !@loc) + [ "/"; t = ssrterm -> { RWdef, t } + | t = ssrterm -> { RWeq, t } + | s = ssrsimpl_ne -> { RWred s, noruleterm (Some loc) } + ] -> { x } + | s = ssrsimpl_ne -> { RWred s, noruleterm (Some loc) } ]]; END -ARGUMENT EXTEND ssrrule TYPED AS ssrrule_ne PRINTED BY pr_ssrrule - | [ ssrrule_ne(r) ] -> [ r ] - | [ ] -> [ RWred Nop, noruleterm (Some loc) ] +ARGUMENT EXTEND ssrrule TYPED AS ssrrule_ne PRINTED BY { pr_ssrrule } + | [ ssrrule_ne(r) ] -> { r } + | [ ] -> { RWred Nop, noruleterm (Some loc) } END (** Rewrite arguments *) +{ + let pr_option f = function None -> mt() | Some x -> f x let pr_pattern_squarep= pr_option (fun r -> str "[" ++ pr_rpattern r ++ str "]") let pr_ssrpattern_squarep _ _ _ = pr_pattern_squarep @@ -2057,58 +2293,66 @@ let pr_rwarg ((d, m), ((docc, rx), r)) = let pr_ssrrwarg _ _ _ = pr_rwarg +} + ARGUMENT EXTEND ssrpattern_squarep -TYPED AS rpattern option PRINTED BY pr_ssrpattern_squarep - | [ "[" rpattern(rdx) "]" ] -> [ Some rdx ] - | [ ] -> [ None ] +TYPED AS rpattern option PRINTED BY { pr_ssrpattern_squarep } + | [ "[" rpattern(rdx) "]" ] -> { Some rdx } + | [ ] -> { None } END ARGUMENT EXTEND ssrpattern_ne_squarep -TYPED AS rpattern option PRINTED BY pr_ssrpattern_squarep - | [ "[" rpattern(rdx) "]" ] -> [ Some rdx ] +TYPED AS rpattern option PRINTED BY { pr_ssrpattern_squarep } + | [ "[" rpattern(rdx) "]" ] -> { Some rdx } END ARGUMENT EXTEND ssrrwarg - TYPED AS (ssrdir * ssrmult) * ((ssrdocc * rpattern option) * ssrrule) - PRINTED BY pr_ssrrwarg + TYPED AS ((ssrdir * ssrmult) * ((ssrdocc * rpattern option) * ssrrule)) + PRINTED BY { pr_ssrrwarg } | [ "-" ssrmult(m) ssrrwocc(docc) ssrpattern_squarep(rx) ssrrule_ne(r) ] -> - [ mk_rwarg (R2L, m) (docc, rx) r ] + { mk_rwarg (R2L, m) (docc, rx) r } | [ "-/" ssrterm(t) ] -> (* just in case '-/' should become a token *) - [ mk_rwarg (R2L, nomult) norwocc (RWdef, t) ] + { mk_rwarg (R2L, nomult) norwocc (RWdef, t) } | [ ssrmult_ne(m) ssrrwocc(docc) ssrpattern_squarep(rx) ssrrule_ne(r) ] -> - [ mk_rwarg (L2R, m) (docc, rx) r ] + { mk_rwarg (L2R, m) (docc, rx) r } | [ "{" ne_ssrhyp_list(clr) "}" ssrpattern_ne_squarep(rx) ssrrule_ne(r) ] -> - [ mk_rwarg norwmult (mkclr clr, rx) r ] + { mk_rwarg norwmult (mkclr clr, rx) r } | [ "{" ne_ssrhyp_list(clr) "}" ssrrule(r) ] -> - [ mk_rwarg norwmult (mkclr clr, None) r ] + { mk_rwarg norwmult (mkclr clr, None) r } | [ "{" ssrocc(occ) "}" ssrpattern_squarep(rx) ssrrule_ne(r) ] -> - [ mk_rwarg norwmult (mkocc occ, rx) r ] + { mk_rwarg norwmult (mkocc occ, rx) r } | [ "{" "}" ssrpattern_squarep(rx) ssrrule_ne(r) ] -> - [ mk_rwarg norwmult (nodocc, rx) r ] + { mk_rwarg norwmult (nodocc, rx) r } | [ ssrpattern_ne_squarep(rx) ssrrule_ne(r) ] -> - [ mk_rwarg norwmult (noclr, rx) r ] + { mk_rwarg norwmult (noclr, rx) r } | [ ssrrule_ne(r) ] -> - [ mk_rwarg norwmult norwocc r ] + { mk_rwarg norwmult norwocc r } END TACTIC EXTEND ssrinstofruleL2R -| [ "ssrinstancesofruleL2R" ssrterm(arg) ] -> [ V82.tactic (ssrinstancesofrule ist L2R arg) ] +| [ "ssrinstancesofruleL2R" ssrterm(arg) ] -> { V82.tactic (ssrinstancesofrule ist L2R arg) } END TACTIC EXTEND ssrinstofruleR2L -| [ "ssrinstancesofruleR2L" ssrterm(arg) ] -> [ V82.tactic (ssrinstancesofrule ist R2L arg) ] +| [ "ssrinstancesofruleR2L" ssrterm(arg) ] -> { V82.tactic (ssrinstancesofrule ist R2L arg) } END (** Rewrite argument sequence *) (* type ssrrwargs = ssrrwarg list *) +{ + let pr_ssrrwargs _ _ _ rwargs = pr_list spc pr_rwarg rwargs -ARGUMENT EXTEND ssrrwargs TYPED AS ssrrwarg list PRINTED BY pr_ssrrwargs - | [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +} + +ARGUMENT EXTEND ssrrwargs TYPED AS ssrrwarg list PRINTED BY { pr_ssrrwargs } + | [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END +{ + let ssr_rw_syntax = Summary.ref ~name:"SSR:rewrite" true let _ = @@ -2119,57 +2363,70 @@ let _ = Goptions.optdepr = false; Goptions.optwrite = (fun b -> ssr_rw_syntax := b) } +let lbrace = Char.chr 123 +(** Workaround to a limitation of coqpp *) + let test_ssr_rw_syntax = let test strm = if not !ssr_rw_syntax then raise Stream.Failure else if is_ssr_loaded () then () else match Util.stream_nth 0 strm with - | Tok.KEYWORD key when List.mem key.[0] ['{'; '['; '/'] -> () + | Tok.KEYWORD key when List.mem key.[0] [lbrace; '['; '/'] -> () | _ -> raise Stream.Failure in - Gram.Entry.of_parser "test_ssr_rw_syntax" test + Pcoq.Entry.of_parser "test_ssr_rw_syntax" test -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: ssrrwargs; - ssrrwargs: [[ test_ssr_rw_syntax; a = LIST1 ssrrwarg -> a ]]; + ssrrwargs: [[ test_ssr_rw_syntax; a = LIST1 ssrrwarg -> { a } ]]; END (** The "rewrite" tactic *) TACTIC EXTEND ssrrewrite | [ "rewrite" ssrrwargs(args) ssrclauses(clauses) ] -> - [ tclCLAUSES (old_tac (ssrrewritetac ist args)) clauses ] + { tclCLAUSES (old_tac (ssrrewritetac ist args)) clauses } END (** The "unlock" tactic *) +{ + let pr_unlockarg (occ, t) = pr_occ occ ++ pr_term t let pr_ssrunlockarg _ _ _ = pr_unlockarg -ARGUMENT EXTEND ssrunlockarg TYPED AS ssrocc * ssrterm - PRINTED BY pr_ssrunlockarg - | [ "{" ssrocc(occ) "}" ssrterm(t) ] -> [ occ, t ] - | [ ssrterm(t) ] -> [ None, t ] +} + +ARGUMENT EXTEND ssrunlockarg TYPED AS (ssrocc * ssrterm) + PRINTED BY { pr_ssrunlockarg } + | [ "{" ssrocc(occ) "}" ssrterm(t) ] -> { occ, t } + | [ ssrterm(t) ] -> { None, t } END +{ + let pr_ssrunlockargs _ _ _ args = pr_list spc pr_unlockarg args +} + ARGUMENT EXTEND ssrunlockargs TYPED AS ssrunlockarg list - PRINTED BY pr_ssrunlockargs - | [ ssrunlockarg_list(args) ] -> [ args ] + PRINTED BY { pr_ssrunlockargs } + | [ ssrunlockarg_list(args) ] -> { args } END TACTIC EXTEND ssrunlock | [ "unlock" ssrunlockargs(args) ssrclauses(clauses) ] -> - [ tclCLAUSES (old_tac (unlocktac ist args)) clauses ] + { tclCLAUSES (old_tac (unlocktac ist args)) clauses } END (** 8. Forward chaining tactics (pose, set, have, suffice, wlog) *) TACTIC EXTEND ssrpose -| [ "pose" ssrfixfwd(ffwd) ] -> [ V82.tactic (ssrposetac ffwd) ] -| [ "pose" ssrcofixfwd(ffwd) ] -> [ V82.tactic (ssrposetac ffwd) ] -| [ "pose" ssrfwdid(id) ssrposefwd(fwd) ] -> [ V82.tactic (ssrposetac (id, fwd)) ] +| [ "pose" ssrfixfwd(ffwd) ] -> { V82.tactic (ssrposetac ffwd) } +| [ "pose" ssrcofixfwd(ffwd) ] -> { V82.tactic (ssrposetac ffwd) } +| [ "pose" ssrfwdid(id) ssrposefwd(fwd) ] -> { V82.tactic (ssrposetac (id, fwd)) } END (** The "set" tactic *) @@ -2178,7 +2435,7 @@ END TACTIC EXTEND ssrset | [ "set" ssrfwdid(id) ssrsetfwd(fwd) ssrclauses(clauses) ] -> - [ tclCLAUSES (old_tac (ssrsettac id fwd)) clauses ] + { tclCLAUSES (old_tac (ssrsettac id fwd)) clauses } END (** The "have" tactic *) @@ -2189,160 +2446,183 @@ END (* Pltac. *) (* The standard TACTIC EXTEND does not work for abstract *) -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: tactic_expr; tactic_expr: LEVEL "3" [ RIGHTA [ IDENT "abstract"; gens = ssrdgens -> - ssrtac_expr ~loc:!@loc "abstract" - [Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit_ssrdgens) gens)] ]]; + { ssrtac_expr ~loc "abstract" + [Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit_ssrdgens) gens)] } ]]; END TACTIC EXTEND ssrabstract -| [ "abstract" ssrdgens(gens) ] -> [ +| [ "abstract" ssrdgens(gens) ] -> { if List.length (fst gens) <> 1 then errorstrm (str"dependents switches '/' not allowed here"); - Ssripats.ssrabstract (ssrdgens_of_parsed_dgens gens) ] + Ssripats.ssrabstract (ssrdgens_of_parsed_dgens gens) } END TACTIC EXTEND ssrhave | [ "have" ssrhavefwdwbinders(fwd) ] -> - [ V82.tactic (havetac ist fwd false false) ] + { V82.tactic (havetac ist fwd false false) } END TACTIC EXTEND ssrhavesuff | [ "have" "suff" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> - [ V82.tactic (havetac ist (false,(pats,fwd)) true false) ] + { V82.tactic (havetac ist (false,(pats,fwd)) true false) } END TACTIC EXTEND ssrhavesuffices | [ "have" "suffices" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> - [ V82.tactic (havetac ist (false,(pats,fwd)) true false) ] + { V82.tactic (havetac ist (false,(pats,fwd)) true false) } END TACTIC EXTEND ssrsuffhave | [ "suff" "have" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> - [ V82.tactic (havetac ist (false,(pats,fwd)) true true) ] + { V82.tactic (havetac ist (false,(pats,fwd)) true true) } END TACTIC EXTEND ssrsufficeshave | [ "suffices" "have" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> - [ V82.tactic (havetac ist (false,(pats,fwd)) true true) ] + { V82.tactic (havetac ist (false,(pats,fwd)) true true) } END (** The "suffice" tactic *) +{ + let pr_ssrsufffwdwbinders _ _ prt (hpats, (fwd, hint)) = pr_hpats hpats ++ pr_fwd fwd ++ pr_hint prt hint +} + ARGUMENT EXTEND ssrsufffwd - TYPED AS ssrhpats * (ssrfwd * ssrhint) PRINTED BY pr_ssrsufffwdwbinders + TYPED AS (ssrhpats * (ssrfwd * ssrhint)) PRINTED BY { pr_ssrsufffwdwbinders } | [ ssrhpats(pats) ssrbinder_list(bs) ":" ast_closure_lterm(t) ssrhint(hint) ] -> - [ let ((clr, pats), binders), simpl = pats in + { let ((clr, pats), binders), simpl = pats in let allbs = intro_id_to_binder binders @ bs in let allbinders = binders @ List.flatten (binder_to_intro_id bs) in let fwd = mkFwdHint ":" t in - (((clr, pats), allbinders), simpl), (bind_fwd allbs fwd, hint) ] + (((clr, pats), allbinders), simpl), (bind_fwd allbs fwd, hint) } END TACTIC EXTEND ssrsuff -| [ "suff" ssrsufffwd(fwd) ] -> [ V82.tactic (sufftac ist fwd) ] +| [ "suff" ssrsufffwd(fwd) ] -> { V82.tactic (sufftac ist fwd) } END TACTIC EXTEND ssrsuffices -| [ "suffices" ssrsufffwd(fwd) ] -> [ V82.tactic (sufftac ist fwd) ] +| [ "suffices" ssrsufffwd(fwd) ] -> { V82.tactic (sufftac ist fwd) } END (** The "wlog" (Without Loss Of Generality) tactic *) (* type ssrwlogfwd = ssrwgen list * ssrfwd *) +{ + let pr_ssrwlogfwd _ _ _ (gens, t) = str ":" ++ pr_list mt pr_wgen gens ++ spc() ++ pr_fwd t -ARGUMENT EXTEND ssrwlogfwd TYPED AS ssrwgen list * ssrfwd - PRINTED BY pr_ssrwlogfwd -| [ ":" ssrwgen_list(gens) "/" ast_closure_lterm(t) ] -> [ gens, mkFwdHint "/" t] +} + +ARGUMENT EXTEND ssrwlogfwd TYPED AS (ssrwgen list * ssrfwd) + PRINTED BY { pr_ssrwlogfwd } +| [ ":" ssrwgen_list(gens) "/" ast_closure_lterm(t) ] -> { gens, mkFwdHint "/" t} END TACTIC EXTEND ssrwlog | [ "wlog" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> - [ V82.tactic (wlogtac ist pats fwd hint false `NoGen) ] + { V82.tactic (wlogtac ist pats fwd hint false `NoGen) } END TACTIC EXTEND ssrwlogs | [ "wlog" "suff" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> - [ V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] + { V82.tactic (wlogtac ist pats fwd hint true `NoGen) } END TACTIC EXTEND ssrwlogss | [ "wlog" "suffices" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> - [ V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] + { V82.tactic (wlogtac ist pats fwd hint true `NoGen) } END TACTIC EXTEND ssrwithoutloss | [ "without" "loss" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> - [ V82.tactic (wlogtac ist pats fwd hint false `NoGen) ] + { V82.tactic (wlogtac ist pats fwd hint false `NoGen) } END TACTIC EXTEND ssrwithoutlosss | [ "without" "loss" "suff" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> - [ V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] + { V82.tactic (wlogtac ist pats fwd hint true `NoGen) } END TACTIC EXTEND ssrwithoutlossss | [ "without" "loss" "suffices" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> - [ V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] + { V82.tactic (wlogtac ist pats fwd hint true `NoGen) } END +{ + (* Generally have *) let pr_idcomma _ _ _ = function | None -> mt() | Some None -> str"_, " | Some (Some id) -> pr_id id ++ str", " -ARGUMENT EXTEND ssr_idcomma TYPED AS ident option option PRINTED BY pr_idcomma - | [ ] -> [ None ] +} + +ARGUMENT EXTEND ssr_idcomma TYPED AS ident option option PRINTED BY { pr_idcomma } + | [ ] -> { None } END +{ + let accept_idcomma strm = match stream_nth 0 strm with | Tok.IDENT _ | Tok.KEYWORD "_" -> accept_before_syms [","] strm | _ -> raise Stream.Failure -let test_idcomma = Gram.Entry.of_parser "test_idcomma" accept_idcomma +let test_idcomma = Pcoq.Entry.of_parser "test_idcomma" accept_idcomma -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: ssr_idcomma; ssr_idcomma: [ [ test_idcomma; - ip = [ id = IDENT -> Some (Id.of_string id) | "_" -> None ]; "," -> - Some ip + ip = [ id = IDENT -> { Some (Id.of_string id) } | "_" -> { None } ]; "," -> + { Some ip } ] ]; END +{ + let augment_preclr clr1 (((clr0, x),y),z) = (((clr1 @ clr0, x),y),z) +} + TACTIC EXTEND ssrgenhave | [ "gen" "have" ssrclear(clr) ssr_idcomma(id) ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> - [ let pats = augment_preclr clr pats in - V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) ] + { let pats = augment_preclr clr pats in + V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) } END TACTIC EXTEND ssrgenhave2 | [ "generally" "have" ssrclear(clr) ssr_idcomma(id) ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> - [ let pats = augment_preclr clr pats in - V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) ] + { let pats = augment_preclr clr pats in + V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) } 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.set_keyword_state frozen_lexer ;; +} (* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/plugins/ssr/ssrparser.mli b/plugins/ssr/ssrparser.mli index 2ac7c7e264..862a93765d 100644 --- a/plugins/ssr/ssrparser.mli +++ b/plugins/ssr/ssrparser.mli @@ -12,13 +12,13 @@ open Ltac_plugin -val ssrtacarg : Tacexpr.raw_tactic_expr Pcoq.Gram.entry +val ssrtacarg : Tacexpr.raw_tactic_expr Pcoq.Entry.t val wit_ssrtacarg : (Tacexpr.raw_tactic_expr, Tacexpr.glob_tactic_expr, Geninterp.Val.t) Genarg.genarg_type -val pr_ssrtacarg : 'a -> 'b -> (Notation_term.tolerability -> 'c) -> 'c +val pr_ssrtacarg : 'a -> 'b -> (Notation_gram.tolerability -> 'c) -> 'c -val ssrtclarg : Tacexpr.raw_tactic_expr Pcoq.Gram.entry +val ssrtclarg : Tacexpr.raw_tactic_expr Pcoq.Entry.t val wit_ssrtclarg : (Tacexpr.raw_tactic_expr, Tacexpr.glob_tactic_expr, Geninterp.Val.t) Genarg.genarg_type -val pr_ssrtclarg : 'a -> 'b -> (Notation_term.tolerability -> 'c -> 'd) -> 'c -> 'd +val pr_ssrtclarg : 'a -> 'b -> (Notation_gram.tolerability -> 'c -> 'd) -> 'c -> 'd val add_genarg : string -> ('a -> Pp.t) -> 'a Genarg.uniform_genarg_type diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index 11369228cb..824666ba9c 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -101,13 +101,14 @@ let rec pr_ipat p = | IPatSimpl sim -> pr_simpl sim | IPatClear clr -> pr_clear mt clr | IPatCase iorpat -> hov 1 (str "[" ++ pr_iorpat iorpat ++ str "]") - | IPatDispatch iorpat -> hov 1 (str "/[" ++ pr_iorpat iorpat ++ str "]") + | IPatDispatch(_,iorpat) -> hov 1 (str "/[" ++ pr_iorpat iorpat ++ str "]") | IPatInj iorpat -> hov 1 (str "[=" ++ pr_iorpat iorpat ++ str "]") | IPatRewrite (occ, dir) -> pr_occ occ ++ pr_dir dir | IPatAnon All -> str "*" | IPatAnon Drop -> str "_" | IPatAnon One -> str "?" - | IPatView v -> pr_view2 v + | IPatView (false,v) -> pr_view2 v + | IPatView (true,v) -> str"{}" ++ pr_view2 v | IPatNoop -> str "-" | IPatAbstractVars l -> str "[:" ++ pr_list spc Id.print l ++ str "]" | IPatTac _ -> str "<tac>" diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index 9cc4f5cece..f12f9fac0f 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -11,10 +11,9 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) open Names +open Constr open Termops open Tacmach -open Misctypes -open Locusops open Ssrast open Ssrcommon @@ -24,7 +23,7 @@ module NamedDecl = Context.Named.Declaration (** Tacticals (+, -, *, done, by, do, =>, first, and last). *) -let get_index = function ArgArg i -> i | _ -> +let get_index = function Locus.ArgArg i -> i | _ -> anomaly "Uninterpreted index" (* Toplevel constr must be globalized twice ! *) @@ -32,9 +31,8 @@ let get_index = function ArgArg i -> i | _ -> let tclPERM perm tac gls = let subgls = tac gls in - let sigma, subgll = Refiner.unpackage subgls in - let subgll' = perm subgll in - Refiner.repackage sigma subgll' + let subgll' = perm subgls.Evd.it in + re_sig subgll' subgls.Evd.sigma let rot_hyps dir i hyps = let n = List.length hyps in @@ -83,8 +81,7 @@ let pf_clauseids gl gens clseq = let hidden_clseq = function InHyps | InHypsSeq | InAllHyps -> true | _ -> false -let settac id c = Tactics.letin_tac None (Name id) c None -let posetac id cl = Proofview.V82.of_tactic (settac id cl nowhere) +let posetac id cl = Proofview.V82.of_tactic (Tactics.pose_tac (Name id) cl) let hidetacs clseq idhide cl0 = if not (hidden_clseq clseq) then [] else @@ -104,10 +101,10 @@ let endclausestac id_map clseq gl_id cl0 gl = | ids, dc' -> forced && ids = [] && (not hide_goal || dc' = [] && c_hidden) in let rec unmark c = match EConstr.kind (project gl) c with - | Term.Var id when hidden_clseq clseq && id = gl_id -> cl0 - | Term.Prod (Name id, t, c') when List.mem_assoc id id_map -> + | Var id when hidden_clseq clseq && id = gl_id -> cl0 + | Prod (Name id, t, c') when List.mem_assoc id id_map -> EConstr.mkProd (Name (orig_id id), unmark t, unmark c') - | Term.LetIn (Name id, v, t, c') when List.mem_assoc id id_map -> + | LetIn (Name id, v, t, c') when List.mem_assoc id id_map -> EConstr.mkLetIn (Name (orig_id id), unmark v, unmark t, unmark c') | _ -> EConstr.map (project gl) unmark c in let utac hyp = diff --git a/plugins/ssr/ssrtacticals.mli b/plugins/ssr/ssrtacticals.mli index a5636ad0f0..684e002352 100644 --- a/plugins/ssr/ssrtacticals.mli +++ b/plugins/ssr/ssrtacticals.mli @@ -17,7 +17,7 @@ val tclSEQAT : Tacinterp.interp_sign -> Tacinterp.Value.t -> Ssrast.ssrdir -> - int Misctypes.or_var * + int Locus.or_var * (('a * Tacinterp.Value.t option list) * Tacinterp.Value.t option) -> Tacmach.tactic @@ -37,7 +37,7 @@ val hinttac : val ssrdotac : Tacinterp.interp_sign -> - ((int Misctypes.or_var * Ssrast.ssrmmod) * + ((int Locus.or_var * Ssrast.ssrmmod) * (bool * Tacinterp.Value.t option list)) * ((Ssrast.ssrhyps * ((Ssrast.ssrhyp_or_id * string) * diff --git a/plugins/ssr/ssrvernac.ml4 b/plugins/ssr/ssrvernac.mlg index 05dbf0a86d..4ed75cdbe4 100644 --- a/plugins/ssr/ssrvernac.ml4 +++ b/plugins/ssr/ssrvernac.mlg @@ -10,6 +10,8 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) +{ + open Names module CoqConstr = Constr open CoqConstr @@ -19,17 +21,13 @@ open Constrexpr_ops open Pcoq open Pcoq.Prim open Pcoq.Constr -open Pcoq.Vernac_ +open Pvernac.Vernac_ open Ltac_plugin open Notation_ops open Notation_term open Glob_term -open Globnames open Stdarg -open Genarg -open Misctypes open Decl_kinds -open Libnames open Pp open Ppconstr open Printer @@ -39,9 +37,12 @@ open Evar_kinds open Ssrprinters open Ssrcommon open Ssrparser + +} + DECLARE PLUGIN "ssreflect_plugin" -let (!@) = Pcoq.to_coqloc +{ (* 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 *) @@ -49,7 +50,7 @@ let frozen_lexer = CLexer.get_keyword_state () ;; (* global syntactic changes and vernacular commands *) -(** Alternative notations for "match" and anonymous arguments. *)(* {{{ ************) +(** Alternative notations for "match" and anonymous arguments. *)(* ************) (* Syntax: *) (* if <term> is <pattern> then ... else ... *) @@ -74,60 +75,62 @@ let frozen_lexer = CLexer.get_keyword_state () ;; (* as this can't be done from an ML extension file, the new *) (* syntax will only work when ssreflect.v is imported. *) -let no_ct = None, None and no_rt = None in +let no_ct = None, None and no_rt = None let aliasvar = function | [[{ CAst.v = CPatAlias (_, na); loc }]] -> Some na - | _ -> None in -let mk_cnotype mp = aliasvar mp, None in -let mk_ctype mp t = aliasvar mp, Some t in -let mk_rtype t = Some t in -let mk_dthen ?loc (mp, ct, rt) c = (CAst.make ?loc (mp, c)), ct, rt in + | _ -> None +let mk_cnotype mp = aliasvar mp, None +let mk_ctype mp t = aliasvar mp, Some t +let mk_rtype t = Some t +let mk_dthen ?loc (mp, ct, rt) c = (CAst.make ?loc (mp, c)), ct, rt let mk_let ?loc rt ct mp c1 = - CAst.make ?loc @@ CCases (LetPatternStyle, rt, ct, [CAst.make ?loc (mp, c1)]) in -let mk_pat c (na, t) = (c, na, t) in -GEXTEND Gram + CAst.make ?loc @@ CCases (LetPatternStyle, rt, ct, [CAst.make ?loc (mp, c1)]) +let mk_pat c (na, t) = (c, na, t) + +} + +GRAMMAR EXTEND Gram GLOBAL: binder_constr; - ssr_rtype: [[ "return"; t = operconstr LEVEL "100" -> mk_rtype t ]]; - ssr_mpat: [[ p = pattern -> [[p]] ]]; + ssr_rtype: [[ "return"; t = operconstr LEVEL "100" -> { mk_rtype t } ]]; + ssr_mpat: [[ p = pattern -> { [[p]] } ]]; ssr_dpat: [ - [ mp = ssr_mpat; "in"; t = pattern; rt = ssr_rtype -> mp, mk_ctype mp t, rt - | mp = ssr_mpat; rt = ssr_rtype -> mp, mk_cnotype mp, rt - | mp = ssr_mpat -> mp, no_ct, no_rt + [ mp = ssr_mpat; "in"; t = pattern; rt = ssr_rtype -> { mp, mk_ctype mp t, rt } + | mp = ssr_mpat; rt = ssr_rtype -> { mp, mk_cnotype mp, rt } + | mp = ssr_mpat -> { mp, no_ct, no_rt } ] ]; - ssr_dthen: [[ dp = ssr_dpat; "then"; c = lconstr -> mk_dthen ~loc:!@loc dp c ]]; - ssr_elsepat: [[ "else" -> [[CAst.make ~loc:!@loc @@ CPatAtom None]] ]]; - ssr_else: [[ mp = ssr_elsepat; c = lconstr -> CAst.make ~loc:!@loc (mp, c) ]]; + ssr_dthen: [[ dp = ssr_dpat; "then"; c = lconstr -> { mk_dthen ~loc dp c } ]]; + ssr_elsepat: [[ "else" -> { [[CAst.make ~loc @@ CPatAtom None]] } ]]; + ssr_else: [[ mp = ssr_elsepat; c = lconstr -> { CAst.make ~loc (mp, c) } ]]; binder_constr: [ [ "if"; c = operconstr LEVEL "200"; "is"; db1 = ssr_dthen; b2 = ssr_else -> - let b1, ct, rt = db1 in CAst.make ~loc:!@loc @@ CCases (MatchStyle, rt, [mk_pat c ct], [b1; b2]) + { let b1, ct, rt = db1 in CAst.make ~loc @@ CCases (MatchStyle, rt, [mk_pat c ct], [b1; b2]) } | "if"; c = operconstr LEVEL "200";"isn't";db1 = ssr_dthen; b2 = ssr_else -> - let b1, ct, rt = db1 in + { let b1, ct, rt = db1 in let b1, b2 = let open CAst in let {loc=l1; v=(p1, r1)}, {loc=l2; v=(p2, r2)} = b1, b2 in (make ?loc:l1 (p1, r2), make ?loc:l2 (p2, r1)) in - CAst.make ~loc:!@loc @@ CCases (MatchStyle, rt, [mk_pat c ct], [b1; b2]) + CAst.make ~loc @@ CCases (MatchStyle, rt, [mk_pat c ct], [b1; b2]) } | "let"; ":"; mp = ssr_mpat; ":="; c = lconstr; "in"; c1 = lconstr -> - mk_let ~loc:!@loc no_rt [mk_pat c no_ct] mp c1 + { mk_let ~loc no_rt [mk_pat c no_ct] mp c1 } | "let"; ":"; mp = ssr_mpat; ":="; c = lconstr; rt = ssr_rtype; "in"; c1 = lconstr -> - mk_let ~loc:!@loc rt [mk_pat c (mk_cnotype mp)] mp c1 + { mk_let ~loc rt [mk_pat c (mk_cnotype mp)] mp c1 } | "let"; ":"; mp = ssr_mpat; "in"; t = pattern; ":="; c = lconstr; rt = ssr_rtype; "in"; c1 = lconstr -> - mk_let ~loc:!@loc rt [mk_pat c (mk_ctype mp t)] mp c1 + { mk_let ~loc rt [mk_pat c (mk_ctype mp t)] mp c1 } ] ]; END -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: closed_binder; closed_binder: [ - [ ["of" | "&"]; c = operconstr LEVEL "99" -> - [CLocalAssum ([CAst.make ~loc:!@loc Anonymous], Default Explicit, c)] + [ ["of" -> { () } | "&" -> { () } ]; c = operconstr LEVEL "99" -> + { [CLocalAssum ([CAst.make ~loc Anonymous], Default Explicit, c)] } ] ]; END -(* }}} *) -(** Vernacular commands: Prenex Implicits and Search *)(* {{{ **********************) +(** Vernacular commands: Prenex Implicits and Search *)(***********************) (* This should really be implemented as an extension to the implicit *) (* arguments feature, but unfortuately that API is sealed. The current *) @@ -141,44 +144,46 @@ END (* Prenex Implicits for all the visible constants that had been *) (* declared as Prenex Implicits. *) +{ + let declare_one_prenex_implicit locality f = let fref = try Smartlocate.global_with_alias f - with _ -> errorstrm (pr_reference f ++ str " is not declared") in + with _ -> errorstrm (pr_qualid f ++ str " is not declared") in let rec loop = function | a :: args' when Impargs.is_status_implicit a -> (ExplByName (Impargs.name_of_implicit a), (true, true, true)) :: loop args' | args' when List.exists Impargs.is_status_implicit args' -> - errorstrm (str "Expected prenex implicits for " ++ pr_reference f) + errorstrm (str "Expected prenex implicits for " ++ pr_qualid f) | _ -> [] in let impls = match Impargs.implicits_of_global fref with | [cond,impls] -> impls - | [] -> errorstrm (str "Expected some implicits for " ++ pr_reference f) + | [] -> errorstrm (str "Expected some implicits for " ++ pr_qualid f) | _ -> errorstrm (str "Multiple implicits not supported") in match loop impls with | [] -> - errorstrm (str "Expected some implicits for " ++ pr_reference f) + errorstrm (str "Expected some implicits for " ++ pr_qualid f) | impls -> Impargs.declare_manual_implicits locality fref ~enriching:false [impls] -VERNAC COMMAND FUNCTIONAL EXTEND Ssrpreneximplicits CLASSIFIED AS SIDEFF - | [ "Prenex" "Implicits" ne_global_list(fl) ] - -> [ fun ~atts ~st -> - let open Vernacinterp in - let locality = Locality.make_section_locality atts.locality in +} + +VERNAC COMMAND EXTEND Ssrpreneximplicits CLASSIFIED AS SIDEFF + | #[ locality = Attributes.locality; ] [ "Prenex" "Implicits" ne_global_list(fl) ] + -> { + let locality = Locality.make_section_locality locality in List.iter (declare_one_prenex_implicit locality) fl; - st - ] + } END (* Vernac grammar visibility patch *) -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: gallina_ext; gallina_ext: [ [ IDENT "Import"; IDENT "Prenex"; IDENT "Implicits" -> - Vernacexpr.VernacUnsetOption (false, ["Printing"; "Implicit"; "Defensive"]) + { Vernacexpr.VernacUnsetOption (false, ["Printing"; "Implicit"; "Defensive"]) } ] ] ; END @@ -187,6 +192,8 @@ END (* Main prefilter *) +{ + type raw_glob_search_about_item = | RGlobSearchSubPattern of constr_expr | RGlobSearchString of Loc.t * string * string option @@ -220,8 +227,8 @@ let interp_search_notation ?loc tag okey = (Bytes.set s' i' '_'; loop (j + 1) (i' + 2)) else (String.blit s i s' i' m; loop (j + 1) (i' + m + 1)) in loop 0 1 in - let trim_ntn (pntn, m) = Bytes.sub_string pntn 1 (max 0 m) in - let pr_ntn ntn = str "(" ++ str ntn ++ str ")" in + let trim_ntn (pntn, m) = (InConstrEntrySomeLevel,Bytes.sub_string pntn 1 (max 0 m)) in + let pr_ntn ntn = str "(" ++ Notation.pr_notation ntn ++ str ")" in let pr_and_list pr = function | [x] -> pr x | x :: lx -> pr_list pr_comma pr lx ++ pr_comma () ++ str "and " ++ pr x @@ -296,7 +303,7 @@ let interp_search_notation ?loc tag okey = let scs' = List.remove (=) sc !scs in let w = pr_ntn ntn ++ str " is also defined " ++ pr_scs scs' in Feedback.msg_warning (hov 4 w) - else if String.string_contains ~where:ntn ~what:" .. " then + else if String.string_contains ~where:(snd ntn) ~what:" .. " then err (pr_ntn ntn ++ str " is an n-ary notation"); let nvars = List.filter (fun (_,(_,typ)) -> typ = NtnTypeConstr) nvars in let rec sub () = function @@ -306,24 +313,32 @@ let interp_search_notation ?loc tag okey = let _, npat = Patternops.pattern_of_glob_constr (sub () body) in Search.GlobSearchSubPattern npat +} + ARGUMENT EXTEND ssr_search_item TYPED AS ssr_searchitem - PRINTED BY pr_ssr_search_item - | [ string(s) ] -> [ RGlobSearchString (loc,s,None) ] - | [ string(s) "%" preident(key) ] -> [ RGlobSearchString (loc,s,Some key) ] - | [ constr_pattern(p) ] -> [ RGlobSearchSubPattern p ] + PRINTED BY { pr_ssr_search_item } + | [ string(s) ] -> { RGlobSearchString (loc,s,None) } + | [ string(s) "%" preident(key) ] -> { RGlobSearchString (loc,s,Some key) } + | [ constr_pattern(p) ] -> { RGlobSearchSubPattern p } END +{ + let pr_ssr_search_arg _ _ _ = let pr_item (b, p) = str (if b then "-" else "") ++ pr_search_item p in pr_list spc pr_item +} + ARGUMENT EXTEND ssr_search_arg TYPED AS (bool * ssr_searchitem) list - PRINTED BY pr_ssr_search_arg - | [ "-" ssr_search_item(p) ssr_search_arg(a) ] -> [ (false, p) :: a ] - | [ ssr_search_item(p) ssr_search_arg(a) ] -> [ (true, p) :: a ] - | [ ] -> [ [] ] + PRINTED BY { pr_ssr_search_arg } + | [ "-" ssr_search_item(p) ssr_search_arg(a) ] -> { (false, p) :: a } + | [ ssr_search_item(p) ssr_search_arg(a) ] -> { (true, p) :: a } + | [ ] -> { [] } END +{ + (* Main type conclusion pattern filter *) let rec splay_search_pattern na = function @@ -344,7 +359,7 @@ let coerce_search_pattern_to_sort hpat = Pattern.PApp (fp, args') in let hr, na = splay_search_pattern 0 hpat in let dc, ht = - let hr, _ = Global.type_of_global_in_context (Global.env ()) hr (** FIXME *) in + let hr, _ = Typeops.type_of_global_in_context env hr (** FIXME *) in Reductionops.splay_prod env sigma (EConstr.of_constr hr) in let np = List.length dc in if np < na then CErrors.user_err (Pp.str "too many arguments in head search pattern") else @@ -361,13 +376,12 @@ let coerce_search_pattern_to_sort hpat = true, cp with _ -> false, [] in let coerce hp coe_index = - let coe = Classops.get_coercion_value coe_index in + let coe_ref = coe_index.Classops.coe_value in try - let coe_ref = global_of_constr coe in let n_imps = Option.get (Classops.hide_coercion coe_ref) in mkPApp (Pattern.PRef coe_ref) n_imps [|hp|] - with _ -> - errorstrm (str "need explicit coercion " ++ pr_constr_env env sigma coe ++ spc () + with Not_found | Option.IsNone -> + errorstrm (str "need explicit coercion " ++ pr_global coe_ref ++ spc () ++ str "to interpret head search pattern as type") in filter_head, List.fold_left coerce hpat' coe_path @@ -377,7 +391,10 @@ let interp_head_pat hpat = | Cast (c', _, _) -> loop c' | Prod (_, _, c') -> loop c' | LetIn (_, _, _, c') -> loop c' - | _ -> Constr_matching.is_matching (Global.env()) Evd.empty p (EConstr.of_constr c) in + | _ -> + let env = Global.env () in + let sigma = Evd.from_env env in + Constr_matching.is_matching env sigma p (EConstr.of_constr c) in filter_head, loop let all_true _ = true @@ -413,28 +430,31 @@ let interp_search_arg arg = (* Module path postfilter *) -let pr_modloc (b, m) = if b then str "-" ++ pr_reference m else pr_reference m +let pr_modloc (b, m) = if b then str "-" ++ pr_qualid m else pr_qualid m let wit_ssrmodloc = add_genarg "ssrmodloc" pr_modloc let pr_ssr_modlocs _ _ _ ml = if ml = [] then str "" else spc () ++ str "in " ++ pr_list spc pr_modloc ml -ARGUMENT EXTEND ssr_modlocs TYPED AS ssrmodloc list PRINTED BY pr_ssr_modlocs - | [ ] -> [ [] ] +} + +ARGUMENT EXTEND ssr_modlocs TYPED AS ssrmodloc list PRINTED BY { pr_ssr_modlocs } + | [ ] -> { [] } END -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: ssr_modlocs; - modloc: [[ "-"; m = global -> true, m | m = global -> false, m]]; - ssr_modlocs: [[ "in"; ml = LIST1 modloc -> ml ]]; + modloc: [[ "-"; m = global -> { true, m } | m = global -> { false, m } ]]; + ssr_modlocs: [[ "in"; ml = LIST1 modloc -> { ml } ]]; END +{ + let interp_modloc mr = - let interp_mod (_, mr) = - let {CAst.loc=loc; v=qid} = qualid_of_reference mr in + let interp_mod (_, qid) = try Nametab.full_name_module qid with Not_found -> - CErrors.user_err ?loc (str "No Module " ++ pr_qualid qid) in + CErrors.user_err ?loc:qid.CAst.loc (str "No Module " ++ pr_qualid qid) in let mr_out, mr_in = List.partition fst mr in let interp_bmod b = function | [] -> fun _ _ _ -> true @@ -448,20 +468,20 @@ let ssrdisplaysearch gr env t = let pr_res = pr_global gr ++ spc () ++ str " " ++ pr_lconstr_env env Evd.empty t in Feedback.msg_info (hov 2 pr_res ++ fnl ()) +} + VERNAC COMMAND EXTEND SsrSearchPattern CLASSIFIED AS QUERY | [ "Search" ssr_search_arg(a) ssr_modlocs(mr) ] -> - [ let hpat = interp_search_arg a in + { let hpat = interp_search_arg a in let in_mod = interp_modloc mr in let post_filter gr env typ = in_mod gr env typ && hpat gr env typ in let display gr env typ = if post_filter gr env typ then ssrdisplaysearch gr env typ in - Search.generic_search None display ] + Search.generic_search None display } END -(* }}} *) - -(** View hint database and View application. *)(* {{{ ******************************) +(** View hint database and View application. *)(* ******************************) (* There are three databases of lemmas used to mediate the application *) (* of reflection lemmas: one for forward chaining, one for backward *) @@ -469,6 +489,8 @@ END (* View hints *) +{ + let pr_raw_ssrhintref prc _ _ = let open CAst in function | { v = CAppExpl ((None, r,x), args) } when isCHoles args -> prc (CAst.make @@ CRef (r,x)) ++ str "|" ++ int (List.length args) @@ -492,14 +514,19 @@ let mkhintref ?loc c n = match c.CAst.v with | CRef (r,x) -> CAst.make ?loc @@ CAppExpl ((None, r, x), mkCHoles ?loc n) | _ -> mkAppC (c, mkCHoles ?loc n) +} + ARGUMENT EXTEND ssrhintref - PRINTED BY pr_ssrhintref - RAW_TYPED AS constr RAW_PRINTED BY pr_raw_ssrhintref - GLOB_TYPED AS constr GLOB_PRINTED BY pr_glob_ssrhintref - | [ constr(c) ] -> [ c ] - | [ constr(c) "|" natural(n) ] -> [ mkhintref ~loc c n ] + TYPED AS constr + PRINTED BY { pr_ssrhintref } + RAW_PRINTED BY { pr_raw_ssrhintref } + GLOB_PRINTED BY { pr_glob_ssrhintref } + | [ constr(c) ] -> { c } + | [ constr(c) "|" natural(n) ] -> { mkhintref ~loc c n } END +{ + (* View purpose *) let pr_viewpos = function @@ -510,70 +537,82 @@ let pr_viewpos = function let pr_ssrviewpos _ _ _ = pr_viewpos -ARGUMENT EXTEND ssrviewpos PRINTED BY pr_ssrviewpos - | [ "for" "move" "/" ] -> [ Some Ssrview.AdaptorDb.Forward ] - | [ "for" "apply" "/" ] -> [ Some Ssrview.AdaptorDb.Backward ] - | [ "for" "apply" "/" "/" ] -> [ Some Ssrview.AdaptorDb.Equivalence ] - | [ "for" "apply" "//" ] -> [ Some Ssrview.AdaptorDb.Equivalence ] - | [ ] -> [ None ] +} + +ARGUMENT EXTEND ssrviewpos PRINTED BY { pr_ssrviewpos } + | [ "for" "move" "/" ] -> { Some Ssrview.AdaptorDb.Forward } + | [ "for" "apply" "/" ] -> { Some Ssrview.AdaptorDb.Backward } + | [ "for" "apply" "/" "/" ] -> { Some Ssrview.AdaptorDb.Equivalence } + | [ "for" "apply" "//" ] -> { Some Ssrview.AdaptorDb.Equivalence } + | [ ] -> { None } END +{ + let pr_ssrviewposspc _ _ _ i = pr_viewpos i ++ spc () -ARGUMENT EXTEND ssrviewposspc TYPED AS ssrviewpos PRINTED BY pr_ssrviewposspc - | [ ssrviewpos(i) ] -> [ i ] +} + +ARGUMENT EXTEND ssrviewposspc TYPED AS ssrviewpos PRINTED BY { pr_ssrviewposspc } + | [ ssrviewpos(i) ] -> { i } END +{ + let print_view_hints kind l = let pp_viewname = str "Hint View" ++ pr_viewpos (Some kind) ++ str " " in let pp_hints = pr_list spc pr_rawhintref l in Feedback.msg_info (pp_viewname ++ hov 0 pp_hints ++ Pp.cut ()) +} + VERNAC COMMAND EXTEND PrintView CLASSIFIED AS QUERY | [ "Print" "Hint" "View" ssrviewpos(i) ] -> - [ match i with + { match i with | Some k -> print_view_hints k (Ssrview.AdaptorDb.get k) | None -> List.iter (fun k -> print_view_hints k (Ssrview.AdaptorDb.get k)) [ Ssrview.AdaptorDb.Forward; Ssrview.AdaptorDb.Backward; Ssrview.AdaptorDb.Equivalence ] - ] + } END +{ + let glob_view_hints lvh = List.map (Constrintern.intern_constr (Global.env ()) (Evd.from_env (Global.env ()))) lvh +} + VERNAC COMMAND EXTEND HintView CLASSIFIED AS SIDEFF | [ "Hint" "View" ssrviewposspc(n) ne_ssrhintref_list(lvh) ] -> - [ let hints = glob_view_hints lvh in + { let hints = glob_view_hints lvh in match n with | None -> Ssrview.AdaptorDb.declare Ssrview.AdaptorDb.Forward hints; Ssrview.AdaptorDb.declare Ssrview.AdaptorDb.Backward hints | Some k -> - Ssrview.AdaptorDb.declare k hints ] + Ssrview.AdaptorDb.declare k hints } END -(* }}} *) - (** Canonical Structure alias *) -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: gallina_ext; gallina_ext: (* Canonical structure *) [[ IDENT "Canonical"; qid = Constr.global -> - Vernacexpr.VernacCanonical (CAst.make @@ AN qid) + { Vernacexpr.VernacCanonical (CAst.make @@ AN qid) } | IDENT "Canonical"; ntn = Prim.by_notation -> - Vernacexpr.VernacCanonical (CAst.make @@ ByNotation ntn) + { Vernacexpr.VernacCanonical (CAst.make @@ ByNotation ntn) } | IDENT "Canonical"; qid = Constr.global; d = G_vernac.def_body -> - let s = coerce_reference_to_id qid in + { let s = coerce_reference_to_id qid in Vernacexpr.VernacDefinition ((Decl_kinds.NoDischarge,Decl_kinds.CanonicalStructure), - ((CAst.make (Name s)),None), d) + ((CAst.make (Name s)),None), d) } ]]; END @@ -591,30 +630,34 @@ END (* Coq v8.3 defines "by" as a keyword, some hacks are not needed any *) (* longer and thus comment out. Such comments are marked with v8.3 *) +{ + open Pltac -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: hypident; hypident: [ - [ "("; IDENT "type"; "of"; id = Prim.identref; ")" -> id, Locus.InHypTypeOnly - | "("; IDENT "value"; "of"; id = Prim.identref; ")" -> id, Locus.InHypValueOnly + [ "("; IDENT "type"; "of"; id = Prim.identref; ")" -> { id, Locus.InHypTypeOnly } + | "("; IDENT "value"; "of"; id = Prim.identref; ")" -> { id, Locus.InHypValueOnly } ] ]; END -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: hloc; hloc: [ [ "in"; "("; "Type"; "of"; id = ident; ")" -> - Tacexpr.HypLocation (CAst.make id, Locus.InHypTypeOnly) + { Tacexpr.HypLocation (CAst.make id, Locus.InHypTypeOnly) } | "in"; "("; IDENT "Value"; "of"; id = ident; ")" -> - Tacexpr.HypLocation (CAst.make id, Locus.InHypValueOnly) + { Tacexpr.HypLocation (CAst.make id, Locus.InHypValueOnly) } ] ]; END -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: constr_eval; constr_eval: [ - [ IDENT "type"; "of"; c = Constr.constr -> Genredexpr.ConstrTypeOf c ] + [ IDENT "type"; "of"; c = Constr.constr -> { Genredexpr.ConstrTypeOf c }] ]; END @@ -622,6 +665,10 @@ END (* 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.set_keyword_state frozen_lexer ;; +} + (* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index aa614fbc11..3f974ea063 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -67,9 +67,9 @@ end module State : sig (* View storage API *) - val vsINIT : EConstr.t -> unit tactic - val vsPUSH : (EConstr.t -> EConstr.t tactic) -> unit tactic - val vsCONSUME : (Id.t option -> EConstr.t -> unit tactic) -> unit tactic + val vsINIT : EConstr.t * Id.t list -> unit tactic + val vsPUSH : (EConstr.t -> (EConstr.t * Id.t list) tactic) -> unit tactic + val vsCONSUME : (name:Id.t option -> EConstr.t -> to_clear:Id.t list -> unit tactic) -> unit tactic val vsASSERT_EMPTY : unit tactic end = struct (* {{{ *) @@ -78,6 +78,7 @@ type vstate = { subject_name : Id.t option; (* top *) (* None if views are being applied to a term *) view : EConstr.t; (* v2 (v1 top) *) + to_clear : Id.t list; } include Ssrcommon.MakeState(struct @@ -85,13 +86,14 @@ include Ssrcommon.MakeState(struct let init = None end) -let vsINIT view = tclSET (Some { subject_name = None; view }) +let vsINIT (view, to_clear) = + tclSET (Some { subject_name = None; view; to_clear }) let vsPUSH k = tacUPDATE (fun s -> match s with - | Some { subject_name; view } -> - k view >>= fun view -> - tclUNIT (Some { subject_name; view }) + | Some { subject_name; view; to_clear } -> + k view >>= fun (view, clr) -> + tclUNIT (Some { subject_name; view; to_clear = to_clear @ clr }) | None -> Goal.enter_one ~__LOC__ begin fun gl -> let concl = Goal.concl gl in @@ -102,15 +104,15 @@ let vsPUSH k = | _ -> mk_anon_id "view_subject" (Tacmach.New.pf_ids_of_hyps gl) in let view = EConstr.mkVar id in Ssrcommon.tclINTRO_ID id <*> - k view >>= fun view -> - tclUNIT (Some { subject_name = Some id; view }) + k view >>= fun (view, to_clear) -> + tclUNIT (Some { subject_name = Some id; view; to_clear }) end) let vsCONSUME k = tclGET (fun s -> match s with - | Some { subject_name; view } -> + | Some { subject_name; view; to_clear } -> tclSET None <*> - k subject_name view + k ~name:subject_name view ~to_clear | None -> anomaly "vsCONSUME: empty storage") let vsASSERT_EMPTY = @@ -157,7 +159,7 @@ let tclINJ_CONSTR_IST ist p = let mkGHole = DAst.make - (Glob_term.GHole(Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None)) + (Glob_term.GHole(Evar_kinds.InternalHole, Namegen.IntroAnonymous, None)) let rec mkGHoles n = if n > 0 then mkGHole :: mkGHoles (n - 1) else [] let mkGApp f args = if args = [] then f @@ -187,6 +189,16 @@ end * modular, see the 2 functions below that would need to "uncommit" *) let tclKeepOpenConstr (_env, sigma, t) = Unsafe.tclEVARS sigma <*> tclUNIT t +let tclADD_CLEAR_IF_ID (env, ist, t) x = + Ssrprinters.ppdebug (lazy + Pp.(str"tclADD_CLEAR_IF_ID: " ++ Printer.pr_econstr_env env ist t)); + let hd, _ = EConstr.decompose_app ist t in + match EConstr.kind ist hd with + | Constr.Var id when Ssrcommon.not_section_id id -> tclUNIT (x, [id]) + | _ -> tclUNIT (x,[]) + +let tclPAIR p x = tclUNIT (x, p) + (* The ssr heuristic : *) (* Estimate a bound on the number of arguments of a raw constr. *) (* This is not perfect, because the unifier may fail to *) @@ -203,14 +215,15 @@ let guess_max_implicits ist glob = (fun _ -> tclUNIT 5) let pad_to_inductive ist glob = Goal.enter_one ~__LOC__ begin fun goal -> - interp_glob ist glob >>= fun (env, sigma, term) -> + interp_glob ist glob >>= fun (env, sigma, term as ot) -> let term_ty = Retyping.get_type_of env sigma term in let ctx, i = Reductionops.splay_prod env sigma term_ty in let rel_ctx = List.map (fun (a,b) -> Context.Rel.Declaration.LocalAssum(a,b)) ctx in - if Ssrcommon.isAppInd (EConstr.push_rel_context rel_ctx env) sigma i - then tclUNIT (mkGApp glob (mkGHoles (List.length ctx))) - else Tacticals.New.tclZEROMSG Pp.(str"not an inductive") + if not (Ssrcommon.isAppInd (EConstr.push_rel_context rel_ctx env) sigma i) + then Tacticals.New.tclZEROMSG Pp.(str"not an inductive") + else tclUNIT (mkGApp glob (mkGHoles (List.length ctx))) + >>= tclADD_CLEAR_IF_ID ot end (* There are two ways of "applying" a view to term: *) @@ -221,7 +234,7 @@ end (* They require guessing the view hints and the number of *) (* implicits, respectively, which we do by brute force. *) (* Builds v p *) -let interp_view ist v p = +let interp_view ~clear_if_id ist v p = let is_specialize hd = match DAst.get hd with Glob_term.GHole _ -> true | _ -> false in (* We cast the pile of views p into a term p_id *) @@ -230,42 +243,48 @@ let interp_view ist v p = match DAst.get v with | Glob_term.GApp (hd, rargs) when is_specialize hd -> Ssrprinters.ppdebug (lazy Pp.(str "specialize")); - interp_glob ist (mkGApp p_id rargs) >>= tclKeepOpenConstr + interp_glob ist (mkGApp p_id rargs) + >>= tclKeepOpenConstr >>= tclPAIR [] | _ -> Ssrprinters.ppdebug (lazy Pp.(str "view")); (* We find out how to build (v p) eventually using an adaptor *) let adaptors = AdaptorDb.(get Forward) in Proofview.tclORELSE - (pad_to_inductive ist v >>= fun vpad -> + (pad_to_inductive ist v >>= fun (vpad,clr) -> Ssrcommon.tclFIRSTa (List.map - (fun a -> interp_glob ist (mkGApp a [vpad; p_id])) adaptors)) + (fun a -> interp_glob ist (mkGApp a [vpad; p_id])) adaptors) + >>= tclPAIR clr) (fun _ -> guess_max_implicits ist v >>= fun n -> Ssrcommon.tclFIRSTi (fun n -> - interp_glob ist (mkGApp v (mkGHoles n @ [p_id]))) n) - >>= tclKeepOpenConstr + interp_glob ist (mkGApp v (mkGHoles n @ [p_id]))) n + >>= fun x -> tclADD_CLEAR_IF_ID x x) + >>= fun (ot,clr) -> + if clear_if_id + then tclKeepOpenConstr ot >>= tclPAIR clr + else tclKeepOpenConstr ot >>= tclPAIR [] (* we store in the state (v top), then (v1 (v2 top))... *) -let pile_up_view (ist, v) = +let pile_up_view ~clear_if_id (ist, v) = let ist = Ssrcommon.option_assert_get ist (Pp.str"not a term") in - State.vsPUSH (fun p -> interp_view ist v p) + State.vsPUSH (fun p -> interp_view ~clear_if_id ist v p) let finalize_view s0 ?(simple_types=true) p = Goal.enter_one ~__LOC__ begin fun g -> let env = Goal.env g in let sigma = Goal.sigma g in - let evars_of_p = Evd.evars_of_term (EConstr.to_constr sigma p) in + let evars_of_p = Evd.evars_of_term (EConstr.to_constr ~abort_on_undefined_evars:false sigma p) in let filter x _ = Evar.Set.mem x evars_of_p in let sigma = Typeclasses.resolve_typeclasses ~fail:false ~filter env sigma in let p = Reductionops.nf_evar sigma p in let get_body = function Evd.Evar_defined x -> x | _ -> assert false in let evars_of_econstr sigma t = - Evd.evars_of_term (EConstr.to_constr sigma (EConstr.of_constr t)) in + Evarutil.undefined_evars_of_term sigma (EConstr.of_constr t) in let rigid_of s = List.fold_left (fun l k -> if Evd.is_defined sigma k then let bo = get_body Evd.(evar_body (find sigma k)) in - k :: l @ Evar.Set.elements (evars_of_econstr sigma bo) + k :: l @ Evar.Set.elements (evars_of_econstr sigma (EConstr.Unsafe.to_constr bo)) else l ) [] s in let und0 = (* Unassigned evars in the initial goal *) @@ -292,7 +311,7 @@ let pose_proof subject_name p = <*> Tactics.New.reduce_after_refine -let rec apply_all_views ending vs s0 = +let rec apply_all_views ~clear_if_id ending vs s0 = match vs with | [] -> ending s0 | v :: vs -> @@ -301,31 +320,35 @@ let rec apply_all_views ending vs s0 = | `Tac tac -> Ssrprinters.ppdebug (lazy Pp.(str"..a tactic")); ending s0 <*> Tacinterp.eval_tactic tac <*> - Ssrcommon.tacSIGMA >>= apply_all_views ending vs + Ssrcommon.tacSIGMA >>= apply_all_views ~clear_if_id ending vs | `Term v -> Ssrprinters.ppdebug (lazy Pp.(str"..a term")); - pile_up_view v <*> apply_all_views ending vs s0 + pile_up_view ~clear_if_id v <*> + apply_all_views ~clear_if_id ending vs s0 (* Entry points *********************************************************) -let tclIPAT_VIEWS ~views:vs ~conclusion:tac = +let tclIPAT_VIEWS ~views:vs ?(clear_if_id=false) ~conclusion:tac = let end_view_application s0 = - State.vsCONSUME (fun name t -> - finalize_view s0 t >>= pose_proof name <*> - tac ~to_clear:(Option.cata (fun x -> [x]) [] name)) in + State.vsCONSUME (fun ~name t ~to_clear -> + let to_clear = Option.cata (fun x -> [x]) [] name @ to_clear in + finalize_view s0 t >>= pose_proof name <*> tac ~to_clear) in tclINDEPENDENT begin State.vsASSERT_EMPTY <*> - Ssrcommon.tacSIGMA >>= apply_all_views end_view_application vs <*> + Ssrcommon.tacSIGMA >>= + apply_all_views ~clear_if_id end_view_application vs <*> State.vsASSERT_EMPTY end let tclWITH_FWD_VIEWS ~simple_types ~subject ~views:vs ~conclusion:tac = let ending_tac s0 = - State.vsCONSUME (fun _ t -> finalize_view s0 ~simple_types t >>= tac) in + State.vsCONSUME (fun ~name:_ t ~to_clear:_ -> + finalize_view s0 ~simple_types t >>= tac) in tclINDEPENDENT begin State.vsASSERT_EMPTY <*> - State.vsINIT subject <*> - Ssrcommon.tacSIGMA >>= apply_all_views ending_tac vs <*> + State.vsINIT (subject,[]) <*> + Ssrcommon.tacSIGMA >>= + apply_all_views ~clear_if_id:false ending_tac vs <*> State.vsASSERT_EMPTY end diff --git a/plugins/ssr/ssrview.mli b/plugins/ssr/ssrview.mli index be51fe7f9b..b128a95da7 100644 --- a/plugins/ssr/ssrview.mli +++ b/plugins/ssr/ssrview.mli @@ -20,9 +20,11 @@ module AdaptorDb : sig end -(* Apply views to the top of the stack (intro pattern) *) +(* Apply views to the top of the stack (intro pattern). If clear_if_id is + * true (default false) then views that happen to be a variable are considered + * as to be cleared (see the to_clear argument to the continuation) *) val tclIPAT_VIEWS : - views:ast_closure_term list -> + views:ast_closure_term list -> ?clear_if_id:bool -> conclusion:(to_clear:Names.Id.t list -> unit Proofview.tactic) -> unit Proofview.tactic diff --git a/plugins/ssrmatching/g_ssrmatching.mlg b/plugins/ssrmatching/g_ssrmatching.mlg new file mode 100644 index 0000000000..4ddaeb49fd --- /dev/null +++ b/plugins/ssrmatching/g_ssrmatching.mlg @@ -0,0 +1,119 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +{ + +open Ltac_plugin +open Pcoq.Constr +open Ssrmatching +open Ssrmatching.Internal + +(* 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.get_keyword_state () ;; + +} + +DECLARE PLUGIN "ssrmatching_plugin" + +{ + +let pr_rpattern _ _ _ = pr_rpattern + +} + +ARGUMENT EXTEND rpattern + TYPED AS rpatternty + PRINTED BY { pr_rpattern } + INTERPRETED BY { interp_rpattern } + GLOBALIZED BY { glob_rpattern } + SUBSTITUTED BY { subst_rpattern } + | [ lconstr(c) ] -> { mk_rpattern (T (mk_lterm c None)) } + | [ "in" lconstr(c) ] -> { mk_rpattern (In_T (mk_lterm c None)) } + | [ lconstr(x) "in" lconstr(c) ] -> + { mk_rpattern (X_In_T (mk_lterm x None, mk_lterm c None)) } + | [ "in" lconstr(x) "in" lconstr(c) ] -> + { mk_rpattern (In_X_In_T (mk_lterm x None, mk_lterm c None)) } + | [ lconstr(e) "in" lconstr(x) "in" lconstr(c) ] -> + { mk_rpattern (E_In_X_In_T (mk_lterm e None, mk_lterm x None, mk_lterm c None)) } + | [ lconstr(e) "as" lconstr(x) "in" lconstr(c) ] -> + { mk_rpattern (E_As_X_In_T (mk_lterm e None, mk_lterm x None, mk_lterm c None)) } +END + +{ + +let pr_ssrterm _ _ _ = pr_ssrterm + +} + +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 None } +END + +{ + +let input_ssrtermkind strm = match Util.stream_nth 0 strm with + | Tok.KEYWORD "(" -> '(' + | Tok.KEYWORD "@" -> '@' + | _ -> ' ' +let ssrtermkind = Pcoq.Entry.of_parser "ssrtermkind" input_ssrtermkind + +} + +GRAMMAR EXTEND Gram + GLOBAL: cpattern; + cpattern: [[ k = ssrtermkind; c = constr -> { + let pattern = mk_term k c None in + if loc_of_cpattern pattern <> Some loc && k = '(' + then mk_term 'x' c None + 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 None } +END + +GRAMMAR EXTEND Gram + GLOBAL: lcpattern; + lcpattern: [[ k = ssrtermkind; c = lconstr -> { + let pattern = mk_term k c None in + if loc_of_cpattern pattern <> Some loc && k = '(' + then mk_term 'x' c None + else pattern } ]]; +END + +ARGUMENT EXTEND ssrpatternarg TYPED AS rpattern PRINTED BY { pr_rpattern } +| [ rpattern(pat) ] -> { pat } +END + +TACTIC EXTEND ssrinstoftpat +| [ "ssrinstancesoftpat" cpattern(arg) ] -> { Proofview.V82.tactic (ssrinstancesof 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.set_keyword_state frozen_lexer ;; + +} diff --git a/plugins/ssrmatching/g_ssrmatching.mli b/plugins/ssrmatching/g_ssrmatching.mli new file mode 100644 index 0000000000..588a1a3eac --- /dev/null +++ b/plugins/ssrmatching/g_ssrmatching.mli @@ -0,0 +1,17 @@ +(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *) +(* Distributed under the terms of CeCILL-B. *) + +open Genarg +open Ssrmatching + +(** CS cpattern: (f _), (X in t), (t in X in t), (t as X in t) *) +val cpattern : cpattern Pcoq.Entry.t +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.Entry.t +val wit_lcpattern : cpattern uniform_genarg_type + +(** 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.Entry.t +val wit_rpattern : rpattern uniform_genarg_type diff --git a/plugins/ssrmatching/plugin_base.dune b/plugins/ssrmatching/plugin_base.dune new file mode 100644 index 0000000000..06f67c3774 --- /dev/null +++ b/plugins/ssrmatching/plugin_base.dune @@ -0,0 +1,5 @@ +(library + (name ssrmatching_plugin) + (public_name coq.plugins.ssrmatching) + (synopsis "Coq ssrmatching plugin") + (libraries coq.plugins.ltac)) diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml index 2ba6acc036..8cb0a8b463 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml @@ -10,10 +10,6 @@ (* 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.get_keyword_state () ;; - open Ltac_plugin open Names open Pp @@ -22,8 +18,6 @@ open Stdarg open Term module CoqConstr = Constr open CoqConstr -open Pcoq -open Pcoq.Constr open Vars open Libnames open Tactics @@ -40,14 +34,12 @@ open Pretyping open Ppconstr open Printer open Globnames -open Misctypes +open Namegen open Decl_kinds open Evar_kinds open Constrexpr open Constrexpr_ops -DECLARE PLUGIN "ssrmatching_plugin" - let errorstrm = CErrors.user_err ~hdr:"ssrmatching" let loc_error loc msg = CErrors.user_err ?loc ~hdr:msg (str msg) let ppnl = Feedback.msg_info @@ -131,9 +123,12 @@ let add_genarg tag pr = (** Constructors for cast type *) let dC t = CastConv t (** Constructors for constr_expr *) -let isCVar = function { CAst.v = CRef ({CAst.v=Ident _},_) } -> true | _ -> false -let destCVar = function { CAst.v = CRef ({CAst.v=Ident id},_) } -> id | _ -> - CErrors.anomaly (str"not a CRef.") +let isCVar = function { CAst.v = CRef (qid,_) } -> qualid_is_ident qid | _ -> false +let destCVar = function + | { CAst.v = CRef (qid,_) } when qualid_is_ident qid -> + qualid_basename qid + | _ -> + CErrors.anomaly (str"not a CRef.") let isGLambda c = match DAst.get c with GLambda (Name _, _, _, _) -> true | _ -> false let destGLambda c = match DAst.get c with GLambda (Name id, _, _, c) -> (id, c) | _ -> CErrors.anomaly (str "not a GLambda") @@ -179,82 +174,6 @@ let nf_evar sigma c = (* }}} *) -(** 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.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. *) @@ -283,7 +202,7 @@ exception NoProgress (* 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 + let evars = existential_opt_value0 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 = @@ -291,12 +210,10 @@ let unif_EQ_args env sigma pa a = 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_HO env ise p c = + try Evarconv.the_conv_x env p c ise + with Evarconv.UnableToUnify(ise, err) -> + raise Pretype_errors.(PretypeError(env,ise,CannotUnify(p,c,Some err))) let unif_HO_args env ise0 pa i ca = let n = Array.length pa in @@ -312,20 +229,22 @@ let unif_HO_args env ise0 pa i ca = (* 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 env = + let oracle = Environ.oracle env in + let ts = Conv_oracle.get_transp_state oracle in let flags = - { (Unification.default_no_delta_unify_flags ()).Unification.core_unify_flags + { (Unification.default_no_delta_unify_flags ts).Unification.core_unify_flags with Unification.modulo_conv_on_closed_terms = None; Unification.modulo_eta = true; Unification.modulo_betaiota = true; - Unification.modulo_delta_types = Conv_oracle.get_transp_state (Environ.oracle env)} + Unification.modulo_delta_types = ts } 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 + (Unification.default_no_delta_unify_flags ts).Unification.resolve_evars } let unif_FO env ise p c = Unification.w_unify env ise Reduction.CONV ~flags:(flags_FO env) @@ -337,7 +256,7 @@ let nf_open_term sigma0 ise c = let s = ise and s' = ref sigma0 in let rec nf c' = match kind c' with | Evar ex -> - begin try nf (existential_value s ex) with _ -> + begin try nf (existential_value0 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)); @@ -347,17 +266,23 @@ let nf_open_term sigma0 ise c = 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' + | Evar_defined c' -> + let c' = EConstr.of_constr (nf (EConstr.Unsafe.to_constr c')) in + s' := Evd.define k c' !s' | _ -> () in let c' = nf c in let _ = Evd.fold copy_def sigma0 () in !s', Evd.evar_universe_context s, EConstr.of_constr c' -let unif_end env sigma0 ise0 pt ok = +let unif_end ?(solve_TC=true) env sigma0 ise0 pt ok = let ise = Evarconv.solve_unif_constraints_with_heuristics env ise0 in + let tcs = Evd.get_typeclass_evars ise in let s, uc, t = nf_open_term sigma0 ise pt in let ise1 = create_evar_defs s in + let ise1 = Evd.set_typeclass_evars ise1 (Evar.Set.filter (fun ev -> Evd.is_undefined ise1 ev) tcs) in let ise1 = Evd.set_universe_context ise1 uc in - let ise2 = Typeclasses.resolve_typeclasses ~fail:true env ise1 in + let ise2 = + if solve_TC then Typeclasses.resolve_typeclasses ~fail:true env ise1 + else ise1 in if not (ok ise) then raise NoProgress else if ise2 == ise1 then (s, uc, t) else @@ -366,7 +291,7 @@ let unif_end env sigma0 ise0 pt ok = 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 + let sigma, uc, _ = unif_end ~solve_TC:false env sigma0 sigma t2 (fun _ -> true) in Evd.set_universe_context sigma uc let pf_unify_HO gl t1 t2 = @@ -446,7 +371,7 @@ let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = let nenv = env_size env + if hack then 1 else 0 in let rec put c = match kind c with | Evar (k, a as ex) -> - begin try put (existential_value !sigma ex) + begin try put (existential_value0 !sigma ex) with NotInstantiatedEvar -> if Evd.mem sigma0 k then map put c else let evi = Evd.find !sigma k in @@ -457,11 +382,13 @@ let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = | 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 + Context.Named.fold_inside abs_dc + ~init:([], (put @@ EConstr.Unsafe.to_constr evi.evar_concl)) + (EConstr.Unsafe.to_named_context dc) in let m = Evarutil.new_meta () in - ise := meta_declare m t !ise; - sigma := Evd.define k (applistc (mkMeta m) a) !sigma; - put (existential_value !sigma ex) + ise := meta_declare m (EConstr.of_constr t) !ise; + sigma := Evd.define k (EConstr.of_constr (applistc (mkMeta m) a)) !sigma; + put (existential_value0 !sigma ex) end | _ -> map put c in let c1 = put c0 in !ise, c1 @@ -541,7 +468,7 @@ let splay_app ise = | 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) + (try loop (existential_value0 ise ex) a with _ -> c, a) | _ -> c, a in fun c -> match kind c with | App (f, a) -> loop f a @@ -552,8 +479,8 @@ 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 equal u.up_f f -> na - | KpatFixed when equal u.up_f f -> na + | KpatConst when eq_constr_nounivs u.up_f f -> na + | KpatFixed when eq_constr_nounivs u.up_f f -> na | KpatEvar k when isEvar_k k f -> na | KpatLet when isLetIn f -> na | KpatLam when isLambda f -> na @@ -573,8 +500,8 @@ 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 -> equal u.up_f f - | KpatFixed -> equal u.up_f f + | KpatConst -> eq_constr_nounivs u.up_f f + | KpatFixed -> eq_constr_nounivs u.up_f f | KpatEvar k -> isEvar_k k f | KpatLet -> isLetIn f | KpatLam -> isLambda f @@ -642,11 +569,6 @@ let match_upats_FO upats env sigma0 ise orig_c = 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 @@ -698,15 +620,10 @@ let match_upats_HO ~on_instance 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 +let fixed_upat evd = function | {up_k = KpatFlex | KpatEvar _ | KpatProj _} -> false -| {up_t = t} -> not (occur_existential Evd.empty (EConstr.of_constr t)) (** FIXME *) +| {up_t = t} -> not (occur_existential evd (EConstr.of_constr t)) (** FIXME *) let do_once r f = match !r with Some _ -> () | None -> r := Some (f ()) @@ -755,8 +672,8 @@ let mk_tpattern_matcher ?(all_instances=false) let match_let f = match kind f with | LetIn (_, v, _, b) -> unif_EQ env sigma pv v && unif_EQ env' sigma pb b | _ -> false in match_let - | KpatFixed -> equal u.up_f - | KpatConst -> equal u.up_f + | KpatFixed -> eq_constr_nounivs u.up_f + | KpatConst -> eq_constr_nounivs u.up_f | KpatLam -> fun c -> (match kind c with | Lambda _ -> unif_EQ env sigma u.up_f c @@ -765,7 +682,7 @@ let mk_tpattern_matcher ?(all_instances=false) 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 ") ++ + (if fixed_upat ise 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() @@ -852,7 +769,7 @@ let rec uniquize = function 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 + str(String.plural !nocc " occurrence") ++ 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 () ++ @@ -898,7 +815,6 @@ let pr_pattern_aux pr_constr = function let pp_pattern (sigma, p) = pr_pattern_aux (fun t -> pr_constr_pat (EConstr.Unsafe.to_constr (pi3 (nf_open_term sigma sigma (EConstr.of_constr t))))) p let pr_cpattern = pr_term -let pr_rpattern _ _ _ = pr_pattern let wit_rpatternty = add_genarg "rpatternty" pr_pattern @@ -929,7 +845,7 @@ let glob_cpattern gs p = | k, (v, Some t), _ as orig -> if k = 'x' then glob_ssrterm gs ('(', (v, Some t), None) else match t.CAst.v with - | CNotation("( _ in _ )", ([t1; t2], [], [], [])) -> + | CNotation((InConstrEntrySomeLevel,"( _ 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 -> @@ -937,11 +853,11 @@ let glob_cpattern gs p = | (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], [], [], [])) -> + | CNotation((InConstrEntrySomeLevel,"( _ in _ in _ )"), ([t1; t2; t3], [], [], [])) -> check_var t2; encode k "In" [fst (glob t1); bind_in t2 t3] - | CNotation("( _ as _ )", ([t1; t2], [], [], [])) -> + | CNotation((InConstrEntrySomeLevel,"( _ as _ )"), ([t1; t2], [], [], [])) -> encode k "As" [fst (glob t1); fst (glob t2)] - | CNotation("( _ as _ in _ )", ([t1; t2; t3], [], [], [])) -> + | CNotation((InConstrEntrySomeLevel,"( _ as _ in _ )"), ([t1; t2; t3], [], [], [])) -> check_var t2; encode k "As" [fst (glob t1); bind_in t2 t3] | _ -> glob_ssrterm gs orig ;; @@ -978,27 +894,7 @@ let interp_rpattern s = function | E_As_X_In_T(e,x,t) -> E_As_X_In_T (interp_ssrterm s e,interp_ssrterm s x,interp_ssrterm s t) -let interp_rpattern ist gl t = Tacmach.project gl, interp_rpattern ist t - -ARGUMENT EXTEND rpattern - TYPED AS rpatternty - PRINTED BY pr_rpattern - INTERPRETED BY interp_rpattern - GLOBALIZED BY glob_rpattern - SUBSTITUTED BY subst_rpattern - | [ lconstr(c) ] -> [ T (mk_lterm c None) ] - | [ "in" lconstr(c) ] -> [ In_T (mk_lterm c None) ] - | [ lconstr(x) "in" lconstr(c) ] -> - [ X_In_T (mk_lterm x None, mk_lterm c None) ] - | [ "in" lconstr(x) "in" lconstr(c) ] -> - [ In_X_In_T (mk_lterm x None, mk_lterm c None) ] - | [ lconstr(e) "in" lconstr(x) "in" lconstr(c) ] -> - [ E_In_X_In_T (mk_lterm e None, mk_lterm x None, mk_lterm c None) ] - | [ lconstr(e) "as" lconstr(x) "in" lconstr(c) ] -> - [ E_As_X_In_T (mk_lterm e None, mk_lterm x None, mk_lterm c None) ] -END - - +let interp_rpattern0 ist gl t = Tacmach.project gl, interp_rpattern ist t type cpattern = char * glob_constr_and_expr * Geninterp.interp_sign option let tag_of_cpattern = pi1 @@ -1013,8 +909,10 @@ type pattern = Evd.evar_map * (constr, constr) ssrpattern let id_of_cpattern (_, (c1, c2), _) = let open CAst in match DAst.get c1, c2 with - | _, Some { v = CRef ({CAst.v=Ident x}, _) } -> Some x - | _, Some { v = CAppExpl ((_, {CAst.v=Ident x}, _), []) } -> Some x + | _, Some { v = CRef (qid, _) } when qualid_is_ident qid -> + Some (qualid_basename qid) + | _, Some { v = CAppExpl ((_, qid, _), []) } when qualid_is_ident qid -> + Some (qualid_basename qid) | GRef (VarRef x, _), None -> Some x | _ -> None let id_of_Cterm t = match id_of_cpattern t with @@ -1040,52 +938,9 @@ let interp_wit wit ist gl x = let interp_open_constr ist gl gc = interp_wit wit_open_constr ist gl gc let pf_intern_term gl (_, c, ist) = glob_constr ist (pf_env gl) (project gl) c -let pr_ssrterm _ _ _ = pr_term -let input_ssrtermkind strm = match stream_nth 0 strm with - | Tok.KEYWORD "(" -> '(' - | Tok.KEYWORD "@" -> '@' - | _ -> ' ' -let ssrtermkind = Pcoq.Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind let interp_ssrterm ist gl t = Tacmach.project gl, interp_ssrterm ist 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 None ] -END - -GEXTEND Gram - GLOBAL: cpattern; - cpattern: [[ k = ssrtermkind; c = constr -> - let pattern = mk_term k c None in - if loc_ofCG pattern <> Some !@loc && k = '(' - then mk_term 'x' c None - 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 None ] -END - -GEXTEND Gram - GLOBAL: lcpattern; - lcpattern: [[ k = ssrtermkind; c = lconstr -> - let pattern = mk_term k c None in - if loc_ofCG pattern <> Some !@loc && k = '(' - then mk_term 'x' c None - else pattern ]]; -END - let interp_term gl = function | (_, c, Some ist) -> on_snd EConstr.Unsafe.to_constr (interp_open_constr ist gl c) @@ -1095,17 +950,16 @@ 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 sigma = Evd.clear_metas sigma in let ans = - try Some (Evarutil.clear_hyps_in_evi env evdref (Environ.named_context_val env) cl ids) + try Some (Evarutil.clear_hyps_in_evi env sigma (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 + | Some (sigma, hyps, concl) -> + let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps concl in + let sigma = Goal.V82.partial_solution_to env sigma goal gl ev in sigma (* @@ -1255,7 +1109,7 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = let fs sigma x = 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 + let e_body = match e_body with Evar_defined c -> EConstr.Unsafe.to_constr c | _ -> errorstrm (str "Matching the pattern " ++ pr_constr_env env0 sigma0 p ++ str " did not instantiate ?" ++ int (Evar.repr e) ++ spc () ++ str "Does the variable bound by the \"in\" construct occur "++ @@ -1406,10 +1260,6 @@ let is_wildcard ((_, (l, r), _) : cpattern) : bool = match DAst.get l, r with (* "ssrpattern" *) -ARGUMENT EXTEND ssrpatternarg TYPED AS rpattern PRINTED BY pr_rpattern -| [ rpattern(pat) ] -> [ pat ] -END - let pr_rpattern = pr_pattern let pf_merge_uc uc gl = @@ -1418,6 +1268,9 @@ let pf_merge_uc uc gl = let pf_unsafe_merge_uc uc gl = re_sig (sig_it gl) (Evd.set_universe_context (project gl) uc) +(** All the pattern types reuse the same dynamic toplevel tag *) +let wit_ssrpatternarg = wit_rpatternty + let interp_rpattern = interp_rpattern ~wit_ssrpatternarg let ssrpatterntac _ist arg gl = @@ -1426,7 +1279,7 @@ let ssrpatterntac _ist arg gl = let concl0 = pf_concl gl in let concl0 = EConstr.Unsafe.to_constr concl0 in let (t, uc), concl_x = - fill_occ_pattern (Global.env()) sigma0 concl0 pat noindex 1 in + fill_occ_pattern (pf_env gl) sigma0 concl0 pat noindex 1 in let t = EConstr.of_constr t in let concl_x = EConstr.of_constr concl_x in let gl, tty = pf_type_of gl t in @@ -1444,7 +1297,7 @@ let () = let () = Tacenv.register_ml_tactic name [|mltac|] in let tac = TacFun ([Name (Id.of_string "pattern")], - TacML (Loc.tag ({ mltac_name = name; mltac_index = 0 }, []))) in + TacML (CAst.make ({ 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" @@ -1469,14 +1322,20 @@ let ssrinstancesof arg gl = done; raise NoMatch with NoMatch -> ppnl (str"END INSTANCES"); tclIDTAC gl -TACTIC EXTEND ssrinstoftpat -| [ "ssrinstancesoftpat" cpattern(arg) ] -> [ Proofview.V82.tactic (ssrinstancesof 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.set_keyword_state frozen_lexer ;; +module Internal = +struct + let wit_rpatternty = wit_rpatternty + let glob_rpattern = glob_rpattern + let subst_rpattern = subst_rpattern + let interp_rpattern = interp_rpattern0 + let pr_rpattern = pr_rpattern + let mk_rpattern x = x + let mk_lterm = mk_lterm + let mk_term = mk_term + let glob_cpattern = glob_cpattern + let subst_ssrterm = subst_ssrterm + let interp_ssrterm = interp_ssrterm + let pr_ssrterm = pr_term +end (* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index c55081e0f7..93a8c48435 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -2,7 +2,6 @@ (* Distributed under the terms of CeCILL-B. *) open Goal -open Genarg open Environ open Evd open Constr @@ -19,24 +18,12 @@ open Tacexpr type cpattern val pr_cpattern : cpattern -> Pp.t -(** 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.t -(** 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 @@ -214,7 +201,7 @@ 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]. + [solve_unif_constraints_with_heuristics]. In case of failure they raise [NoMatch] *) val unify_HO : env -> evar_map -> EConstr.constr -> EConstr.constr -> evar_map @@ -234,8 +221,25 @@ val pf_unsafe_merge_uc : UState.t -> 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 +val ssrinstancesof : cpattern -> Tacmach.tactic + +(** Functions used for grammar extensions. Do not use. *) + +module Internal : +sig + val wit_rpatternty : (rpattern, rpattern, rpattern) Genarg.genarg_type + val glob_rpattern : Genintern.glob_sign -> rpattern -> rpattern + val subst_rpattern : Mod_subst.substitution -> rpattern -> rpattern + val interp_rpattern : Geninterp.interp_sign -> Goal.goal Evd.sigma -> rpattern -> Evd.evar_map * rpattern + val pr_rpattern : rpattern -> Pp.t + val mk_rpattern : (cpattern, cpattern) ssrpattern -> rpattern + val mk_lterm : Constrexpr.constr_expr -> Geninterp.interp_sign option -> cpattern + val mk_term : char -> Constrexpr.constr_expr -> Geninterp.interp_sign option -> cpattern + + val glob_cpattern : Genintern.glob_sign -> cpattern -> cpattern + val subst_ssrterm : Mod_subst.substitution -> cpattern -> cpattern + val interp_ssrterm : Geninterp.interp_sign -> Goal.goal Evd.sigma -> cpattern -> Evd.evar_map * cpattern + val pr_ssrterm : cpattern -> Pp.t +end (* eof *) diff --git a/plugins/ssrmatching/ssrmatching.v b/plugins/ssrmatching/ssrmatching.v index 829ee05e11..9a53e1dd1a 100644 --- a/plugins/ssrmatching/ssrmatching.v +++ b/plugins/ssrmatching/ssrmatching.v @@ -11,9 +11,11 @@ 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). +Declare Scope ssrpatternscope. +Delimit Scope ssrpatternscope with pattern. + (* 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. diff --git a/plugins/ssrmatching/ssrmatching_plugin.mlpack b/plugins/ssrmatching/ssrmatching_plugin.mlpack index 5fb1f1567d..02c75f14ed 100644 --- a/plugins/ssrmatching/ssrmatching_plugin.mlpack +++ b/plugins/ssrmatching/ssrmatching_plugin.mlpack @@ -1 +1,2 @@ Ssrmatching +G_ssrmatching diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index acb297ddfa..94255bab6c 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -24,23 +24,23 @@ open Coqlib exception Non_closed_ascii let make_dir l = DirPath.make (List.rev_map Id.of_string l) -let make_kn dir id = Globnames.encode_mind (make_dir dir) (Id.of_string id) let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) let is_gr c gr = match DAst.get c with -| GRef (r, _) -> Globnames.eq_gr r gr +| GRef (r, _) -> GlobRef.equal r gr | _ -> false let ascii_module = ["Coq";"Strings";"Ascii"] +let ascii_modpath = MPfile (make_dir ascii_module) let ascii_path = make_path ascii_module "ascii" -let ascii_kn = make_kn ascii_module "ascii" +let ascii_label = Label.make "ascii" +let ascii_kn = MutInd.make2 ascii_modpath ascii_label let path_of_Ascii = ((ascii_kn,0),1) let static_glob_Ascii = ConstructRef path_of_Ascii -let make_reference id = find_reference "Ascii interpretation" ascii_module id -let glob_Ascii = lazy (make_reference "Ascii") +let glob_Ascii = lazy (lib_ref "plugins.syntax.Ascii") open Lazy @@ -48,7 +48,7 @@ let interp_ascii ?loc p = let rec aux n p = if Int.equal n 0 then [] else let mp = p mod 2 in - (DAst.make ?loc @@ GRef ((if Int.equal mp 0 then glob_false else glob_true),None)) + (DAst.make ?loc @@ GRef (lib_ref (if Int.equal mp 0 then "core.bool.false" else "core.bool.true"),None)) :: (aux (n-1) (p/2)) in DAst.make ?loc @@ GApp (DAst.make ?loc @@ GRef(force glob_Ascii,None), aux 8 p) @@ -66,8 +66,8 @@ let interp_ascii_string ?loc s = let uninterp_ascii r = let rec uninterp_bool_list n = function | [] when Int.equal n 0 -> 0 - | r::l when is_gr r glob_true -> 1+2*(uninterp_bool_list (n-1) l) - | r::l when is_gr r glob_false -> 2*(uninterp_bool_list (n-1) l) + | r::l when is_gr r (lib_ref "core.bool.true") -> 1+2*(uninterp_bool_list (n-1) l) + | r::l when is_gr r (lib_ref "core.bool.false") -> 2*(uninterp_bool_list (n-1) l) | _ -> raise Non_closed_ascii in try let aux c = match DAst.get c with @@ -83,8 +83,18 @@ let make_ascii_string n = let uninterp_ascii_string (AnyGlobConstr r) = Option.map make_ascii_string (uninterp_ascii r) +open Notation + +let at_declare_ml_module f x = + Mltop.declare_cache_obj (fun () -> f x) __coq_plugin_name + let _ = - Notation.declare_string_interpreter "char_scope" - (ascii_path,ascii_module) - interp_ascii_string - ([DAst.make @@ GRef (static_glob_Ascii,None)], uninterp_ascii_string, true) + let sc = "char_scope" in + register_string_interpretation sc (interp_ascii_string,uninterp_ascii_string); + at_declare_ml_module enable_prim_token_interpretation + { pt_local = false; + pt_scope = sc; + pt_interp_info = Uid sc; + pt_required = (ascii_path,ascii_module); + pt_refs = [static_glob_Ascii]; + pt_in_match = true } diff --git a/plugins/syntax/g_numeral.mlg b/plugins/syntax/g_numeral.mlg new file mode 100644 index 0000000000..13e0bcbd47 --- /dev/null +++ b/plugins/syntax/g_numeral.mlg @@ -0,0 +1,41 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +DECLARE PLUGIN "numeral_notation_plugin" + +{ + +open Notation +open Numeral +open Pp +open Names +open Ltac_plugin +open Stdarg +open Pcoq.Prim + +let pr_numnot_option _ _ _ = function + | Nop -> mt () + | Warning n -> str "(warning after " ++ str n ++ str ")" + | Abstract n -> str "(abstract after " ++ str n ++ str ")" + +} + +ARGUMENT EXTEND numnotoption + PRINTED BY { pr_numnot_option } +| [ ] -> { Nop } +| [ "(" "warning" "after" bigint(waft) ")" ] -> { Warning waft } +| [ "(" "abstract" "after" bigint(n) ")" ] -> { Abstract n } +END + +VERNAC COMMAND EXTEND NumeralNotation CLASSIFIED AS SIDEFF + | #[ locality = Attributes.locality; ] [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" + ident(sc) numnotoption(o) ] -> + { vernac_numeral_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } +END diff --git a/plugins/syntax/int31_syntax.ml b/plugins/syntax/int31_syntax.ml index 5529ea7006..e34a401c2c 100644 --- a/plugins/syntax/int31_syntax.ml +++ b/plugins/syntax/int31_syntax.ml @@ -26,7 +26,7 @@ let make_dir l = DirPath.make (List.rev_map Id.of_string l) let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) let is_gr c gr = match DAst.get c with -| GRef (r, _) -> Globnames.eq_gr r gr +| GRef (r, _) -> GlobRef.equal r gr | _ -> false let make_mind mp id = Names.MutInd.make2 mp (Label.make id) @@ -96,10 +96,19 @@ let uninterp_int31 (AnyGlobConstr i) = with Non_closed -> None +open Notation + +let at_declare_ml_module f x = + Mltop.declare_cache_obj (fun () -> f x) __coq_plugin_name + (* Actually declares the interpreter for int31 *) -let _ = Notation.declare_numeral_interpreter int31_scope - (int31_path, int31_module) - interp_int31 - ([DAst.make (GRef (int31_construct, None))], - uninterp_int31, - true) + +let _ = + register_bignumeral_interpretation int31_scope (interp_int31,uninterp_int31); + at_declare_ml_module enable_prim_token_interpretation + { pt_local = false; + pt_scope = int31_scope; + pt_interp_info = Uid int31_scope; + pt_required = (int31_path,int31_module); + pt_refs = [int31_construct]; + pt_in_match = true } diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml deleted file mode 100644 index ad8b54d4d7..0000000000 --- a/plugins/syntax/nat_syntax.ml +++ /dev/null @@ -1,84 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - - -(* 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*) -open Glob_term -open Bigint -open Coqlib -open Pp -open CErrors -(*i*) - -(**********************************************************************) -(* Parsing via scopes *) -(* For example, (nat_of_string "3") is <<(S (S (S O)))>> *) - -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 ?loc n = - if is_pos_or_zero n then begin - if less_than threshold n then warn_large_nat (); - let ref_O = DAst.make ?loc @@ GRef (glob_O, None) in - let ref_S = DAst.make ?loc @@ GRef (glob_S, None) in - let rec mk_nat acc n = - if n <> zero then - mk_nat (DAst.make ?loc @@ GApp (ref_S, [acc])) (sub_1 n) - else - acc - in - mk_nat ref_O n - end - else - user_err ?loc ~hdr:"nat_of_int" - (str "Cannot interpret a negative number as a number of type nat") - -(************************************************************************) -(* Printing via scopes *) - -exception Non_closed_number - -let rec int_of_nat x = DAst.with_val (function - | GApp (r, [a]) -> - begin match DAst.get r with - | GRef (s,_) when Globnames.eq_gr s glob_S -> add_1 (int_of_nat a) - | _ -> raise Non_closed_number - end - | GRef (z,_) when Globnames.eq_gr z glob_O -> zero - | _ -> raise Non_closed_number - ) x - -let uninterp_nat (AnyGlobConstr p) = - try - Some (int_of_nat p) - with - Non_closed_number -> None - -(************************************************************************) -(* Declare the primitive parsers and printers *) - -let _ = - Notation.declare_numeral_interpreter "nat_scope" - (nat_path,datatypes_module_name) - nat_of_int - ([DAst.make @@ GRef (glob_S,None); DAst.make @@ GRef (glob_O,None)], uninterp_nat, true) diff --git a/plugins/syntax/nat_syntax_plugin.mlpack b/plugins/syntax/nat_syntax_plugin.mlpack deleted file mode 100644 index 39bdd62f47..0000000000 --- a/plugins/syntax/nat_syntax_plugin.mlpack +++ /dev/null @@ -1 +0,0 @@ -Nat_syntax diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml new file mode 100644 index 0000000000..10a0af0b8f --- /dev/null +++ b/plugins/syntax/numeral.ml @@ -0,0 +1,142 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open Util +open Names +open Libnames +open Globnames +open Constrexpr +open Constrexpr_ops +open Notation + +(** * Numeral notation *) + +let warn_abstract_large_num_no_op = + CWarnings.create ~name:"abstract-large-number-no-op" ~category:"numbers" + (fun f -> + strbrk "The 'abstract after' directive has no effect when " ++ + strbrk "the parsing function (" ++ + Nametab.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ") targets an " ++ + strbrk "option type.") + +let get_constructors ind = + let mib,oib = Global.lookup_inductive ind in + let mc = oib.Declarations.mind_consnames in + Array.to_list + (Array.mapi (fun j c -> ConstructRef (ind, j + 1)) mc) + +let q_z = qualid_of_string "Coq.Numbers.BinNums.Z" +let q_positive = qualid_of_string "Coq.Numbers.BinNums.positive" +let q_int = qualid_of_string "Coq.Init.Decimal.int" +let q_uint = qualid_of_string "Coq.Init.Decimal.uint" +let q_option = qualid_of_string "Coq.Init.Datatypes.option" + +let unsafe_locate_ind q = + match Nametab.locate q with + | IndRef i -> i + | _ -> raise Not_found + +let locate_ind q = + try unsafe_locate_ind q + with Not_found -> Nametab.error_global_not_found q + +let locate_z () = + try + Some { z_ty = unsafe_locate_ind q_z; + pos_ty = unsafe_locate_ind q_positive } + with Not_found -> None + +let locate_int () = + { uint = locate_ind q_uint; + int = locate_ind q_int } + +let has_type f ty = + let (sigma, env) = Pfedit.get_current_context () in + let c = mkCastC (mkRefC f, Glob_term.CastConv ty) in + try let _ = Constrintern.interp_constr env sigma c in true + with Pretype_errors.PretypeError _ -> false + +let type_error_to f ty loadZ = + CErrors.user_err + (pr_qualid f ++ str " should go from Decimal.int to " ++ + pr_qualid ty ++ str " or (option " ++ pr_qualid ty ++ str ")." ++ + fnl () ++ str "Instead of Decimal.int, the types Decimal.uint or Z could be used" ++ + (if loadZ then str " (require BinNums first)." else str ".")) + +let type_error_of g ty loadZ = + CErrors.user_err + (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ + str " to Decimal.int or (option Decimal.int)." ++ fnl () ++ + str "Instead of Decimal.int, the types Decimal.uint or Z could be used" ++ + (if loadZ then str " (require BinNums first)." else str ".")) + +let vernac_numeral_notation local ty f g scope opts = + let int_ty = locate_int () in + let z_pos_ty = locate_z () in + let tyc = Smartlocate.global_inductive_with_alias ty in + let to_ty = Smartlocate.global_with_alias f in + let of_ty = Smartlocate.global_with_alias g in + let cty = mkRefC ty in + let app x y = mkAppC (x,[y]) in + let cref q = mkRefC q in + let arrow x y = + mkProdC ([CAst.make Anonymous],Default Decl_kinds.Explicit, x, y) + in + let cZ = cref q_z in + let cint = cref q_int in + let cuint = cref q_uint in + let coption = cref q_option in + let opt r = app coption r in + let constructors = get_constructors tyc in + (* Check the type of f *) + let to_kind = + if has_type f (arrow cint cty) then Int int_ty, Direct + else if has_type f (arrow cint (opt cty)) then Int int_ty, Option + else if has_type f (arrow cuint cty) then UInt int_ty.uint, Direct + else if has_type f (arrow cuint (opt cty)) then UInt int_ty.uint, Option + else + match z_pos_ty with + | Some z_pos_ty -> + if has_type f (arrow cZ cty) then Z z_pos_ty, Direct + else if has_type f (arrow cZ (opt cty)) then Z z_pos_ty, Option + else type_error_to f ty false + | None -> type_error_to f ty true + in + (* Check the type of g *) + let of_kind = + if has_type g (arrow cty cint) then Int int_ty, Direct + else if has_type g (arrow cty (opt cint)) then Int int_ty, Option + else if has_type g (arrow cty cuint) then UInt int_ty.uint, Direct + else if has_type g (arrow cty (opt cuint)) then UInt int_ty.uint, Option + else + match z_pos_ty with + | Some z_pos_ty -> + if has_type g (arrow cty cZ) then Z z_pos_ty, Direct + else if has_type g (arrow cty (opt cZ)) then Z z_pos_ty, Option + else type_error_of g ty false + | None -> type_error_of g ty true + in + let o = { to_kind; to_ty; of_kind; of_ty; + num_ty = ty; + warning = opts } + in + (match opts, to_kind with + | Abstract _, (_, Option) -> warn_abstract_large_num_no_op o.to_ty + | _ -> ()); + let i = + { pt_local = local; + pt_scope = scope; + pt_interp_info = NumeralNotation o; + pt_required = Nametab.path_of_global (IndRef tyc),[]; + pt_refs = constructors; + pt_in_match = true } + in + enable_prim_token_interpretation i diff --git a/plugins/syntax/numeral.mli b/plugins/syntax/numeral.mli new file mode 100644 index 0000000000..f96b8321f8 --- /dev/null +++ b/plugins/syntax/numeral.mli @@ -0,0 +1,17 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Libnames +open Vernacexpr +open Notation + +(** * Numeral notation *) + +val vernac_numeral_notation : locality_flag -> qualid -> qualid -> qualid -> Notation_term.scope_name -> numnot_option -> unit diff --git a/plugins/syntax/numeral_notation_plugin.mlpack b/plugins/syntax/numeral_notation_plugin.mlpack new file mode 100644 index 0000000000..f4d9cae3ff --- /dev/null +++ b/plugins/syntax/numeral_notation_plugin.mlpack @@ -0,0 +1,2 @@ +Numeral +G_numeral diff --git a/plugins/syntax/plugin_base.dune b/plugins/syntax/plugin_base.dune new file mode 100644 index 0000000000..bfdd480fe9 --- /dev/null +++ b/plugins/syntax/plugin_base.dune @@ -0,0 +1,35 @@ +(library + (name numeral_notation_plugin) + (public_name coq.plugins.numeral_notation) + (synopsis "Coq numeral notation plugin") + (modules g_numeral numeral) + (libraries coq.plugins.ltac)) + +(library + (name r_syntax_plugin) + (public_name coq.plugins.r_syntax) + (synopsis "Coq syntax plugin: reals") + (modules r_syntax) + (libraries coq.vernac)) + +(library + (name ascii_syntax_plugin) + (public_name coq.plugins.ascii_syntax) + (synopsis "Coq syntax plugin: ASCII") + (modules ascii_syntax) + (libraries coq.vernac)) + +(library + (name string_syntax_plugin) + (public_name coq.plugins.string_syntax) + (synopsis "Coq syntax plugin: strings") + (modules string_syntax) + (libraries coq.plugins.ascii_syntax)) + +(library + (name int31_syntax_plugin) + (public_name coq.plugins.int31_syntax) + (synopsis "Coq syntax plugin: int31") + (modules int31_syntax) + (libraries coq.vernac)) + diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 372e8ff306..d90b7d754c 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -30,16 +30,12 @@ let make_dir l = DirPath.make (List.rev_map Id.of_string l) let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) let is_gr c gr = match DAst.get c with -| GRef (r, _) -> Globnames.eq_gr r gr +| GRef (r, _) -> GlobRef.equal r gr | _ -> false -let positive_path = make_path binnums "positive" +let positive_modpath = MPfile (make_dir binnums) -(* TODO: temporary hack *) -let make_kn dir id = Globnames.encode_mind dir id - -let positive_kn = make_kn (make_dir binnums) (Id.of_string "positive") -let glob_positive = IndRef (positive_kn,0) +let positive_kn = MutInd.make2 positive_modpath (Label.make "positive") let path_of_xI = ((positive_kn,0),1) let path_of_xO = ((positive_kn,0),2) let path_of_xH = ((positive_kn,0),3) @@ -66,16 +62,14 @@ let pos_of_bignat ?loc x = let rec bignat_of_pos c = match DAst.get c with | GApp (r, [a]) when is_gr r glob_xO -> mult_2(bignat_of_pos a) | GApp (r, [a]) when is_gr r glob_xI -> add_1(mult_2(bignat_of_pos a)) - | GRef (a, _) when Globnames.eq_gr a glob_xH -> Bigint.one + | GRef (a, _) when GlobRef.equal a glob_xH -> Bigint.one | _ -> raise Non_closed_number (**********************************************************************) (* Parsing Z via scopes *) (**********************************************************************) -let z_path = make_path binnums "Z" -let z_kn = make_kn (make_dir binnums) (Id.of_string "Z") -let glob_z = IndRef (z_kn,0) +let z_kn = MutInd.make2 positive_modpath (Label.make "Z") let path_of_ZERO = ((z_kn,0),1) let path_of_POS = ((z_kn,0),2) let path_of_NEG = ((z_kn,0),3) @@ -98,7 +92,7 @@ let z_of_int ?loc n = let bigint_of_z c = match DAst.get c with | GApp (r,[a]) when is_gr r glob_POS -> bignat_of_pos a | GApp (r,[a]) when is_gr r glob_NEG -> Bigint.neg (bignat_of_pos a) - | GRef (a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero + | GRef (a, _) when GlobRef.equal a glob_ZERO -> Bigint.zero | _ -> raise Non_closed_number (**********************************************************************) @@ -106,12 +100,10 @@ let bigint_of_z c = match DAst.get c with (**********************************************************************) let rdefinitions = ["Coq";"Reals";"Rdefinitions"] +let r_modpath = MPfile (make_dir rdefinitions) let r_path = make_path rdefinitions "R" -(* TODO: temporary hack *) -let make_path dir id = Globnames.encode_con dir (Id.of_string id) - -let glob_IZR = ConstRef (make_path (make_dir rdefinitions) "IZR") +let glob_IZR = ConstRef (Constant.make2 r_modpath @@ Label.make "IZR") let r_of_int ?loc z = DAst.make @@ GApp (DAst.make @@ GRef(glob_IZR,None), [z_of_int ?loc z]) @@ -131,9 +123,19 @@ let uninterp_r (AnyGlobConstr p) = with Non_closed_number -> None -let _ = Notation.declare_numeral_interpreter "R_scope" - (r_path,["Coq";"Reals";"Rdefinitions"]) - r_of_int - ([DAst.make @@ GRef (glob_IZR, None)], - uninterp_r, - false) +open Notation + +let at_declare_ml_module f x = + Mltop.declare_cache_obj (fun () -> f x) __coq_plugin_name + +let r_scope = "R_scope" + +let _ = + register_bignumeral_interpretation r_scope (r_of_int,uninterp_r); + at_declare_ml_module enable_prim_token_interpretation + { pt_local = false; + pt_scope = r_scope; + pt_interp_info = Uid r_scope; + pt_required = (r_path,["Coq";"Reals";"Rdefinitions"]); + pt_refs = [glob_IZR]; + pt_in_match = false } diff --git a/plugins/syntax/r_syntax.mli b/plugins/syntax/r_syntax.mli new file mode 100644 index 0000000000..7c3ee60040 --- /dev/null +++ b/plugins/syntax/r_syntax.mli @@ -0,0 +1,9 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index 2421cc12fe..59e65a0672 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -8,6 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Names open Globnames open Ascii_syntax_plugin.Ascii_syntax open Glob_term @@ -23,18 +24,18 @@ exception Non_closed_string let string_module = ["Coq";"Strings";"String"] +let string_modpath = MPfile (make_dir string_module) let string_path = make_path string_module "string" -let string_kn = make_kn string_module "string" +let string_kn = MutInd.make2 string_modpath @@ Label.make "string" let static_glob_EmptyString = ConstructRef ((string_kn,0),1) let static_glob_String = ConstructRef ((string_kn,0),2) -let make_reference id = find_reference "String interpretation" string_module id -let glob_String = lazy (make_reference "String") -let glob_EmptyString = lazy (make_reference "EmptyString") +let glob_String = lazy (lib_ref "plugins.syntax.String") +let glob_EmptyString = lazy (lib_ref "plugins.syntax.EmptyString") let is_gr c gr = match DAst.get c with -| GRef (r, _) -> Globnames.eq_gr r gr +| GRef (r, _) -> GlobRef.equal r gr | _ -> false open Lazy @@ -55,7 +56,7 @@ let uninterp_string (AnyGlobConstr r) = (match uninterp_ascii a with | Some c -> Buffer.add_char b (Char.chr c); aux s | _ -> raise Non_closed_string) - | GRef (z,_) when eq_gr z (force glob_EmptyString) -> + | GRef (z,_) when GlobRef.equal z (force glob_EmptyString) -> Some (Buffer.contents b) | _ -> raise Non_closed_string @@ -63,10 +64,18 @@ let uninterp_string (AnyGlobConstr r) = with Non_closed_string -> None +open Notation + +let at_declare_ml_module f x = + Mltop.declare_cache_obj (fun () -> f x) __coq_plugin_name + let _ = - Notation.declare_string_interpreter "string_scope" - (string_path,["Coq";"Strings";"String"]) - interp_string - ([DAst.make @@ GRef (static_glob_String,None); - DAst.make @@ GRef (static_glob_EmptyString,None)], - uninterp_string, true) + let sc = "string_scope" in + register_string_interpretation sc (interp_string,uninterp_string); + at_declare_ml_module enable_prim_token_interpretation + { pt_local = false; + pt_scope = sc; + pt_interp_info = Uid sc; + pt_required = (string_path,["Coq";"Strings";"String"]); + pt_refs = [static_glob_String; static_glob_EmptyString]; + pt_in_match = true } diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml deleted file mode 100644 index d5300e474c..0000000000 --- a/plugins/syntax/z_syntax.ml +++ /dev/null @@ -1,202 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Pp -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 - -(**********************************************************************) -(* Parsing positive via scopes *) -(**********************************************************************) - -open Globnames -open Glob_term - -let binnums = ["Coq";"Numbers";"BinNums"] - -let make_dir l = DirPath.make (List.rev_map Id.of_string l) -let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) - -let positive_path = make_path binnums "positive" - -(* TODO: temporary hack *) -let make_kn dir id = Globnames.encode_mind dir id - -let positive_kn = make_kn (make_dir binnums) (Id.of_string "positive") -let glob_positive = IndRef (positive_kn,0) -let path_of_xI = ((positive_kn,0),1) -let path_of_xO = ((positive_kn,0),2) -let path_of_xH = ((positive_kn,0),3) -let glob_xI = ConstructRef path_of_xI -let glob_xO = ConstructRef path_of_xO -let glob_xH = ConstructRef path_of_xH - -let pos_of_bignat ?loc x = - let ref_xI = DAst.make ?loc @@ GRef (glob_xI, None) in - let ref_xH = DAst.make ?loc @@ GRef (glob_xH, None) in - let ref_xO = DAst.make ?loc @@ GRef (glob_xO, None) in - let rec pos_of x = - match div2_with_rest x with - | (q,false) -> DAst.make ?loc @@ GApp (ref_xO,[pos_of q]) - | (q,true) when not (Bigint.equal q zero) -> DAst.make ?loc @@ GApp (ref_xI,[pos_of q]) - | (q,true) -> ref_xH - in - pos_of x - -let error_non_positive ?loc = - user_err ?loc ~hdr:"interp_positive" - (str "Only strictly positive numbers in type \"positive\".") - -let interp_positive ?loc n = - if is_strictly_pos n then pos_of_bignat ?loc n - else error_non_positive ?loc - -(**********************************************************************) -(* Printing positive via scopes *) -(**********************************************************************) - -let is_gr c gr = match DAst.get c with -| GRef (r, _) -> Globnames.eq_gr r gr -| _ -> false - -let rec bignat_of_pos x = DAst.with_val (function - | GApp (r ,[a]) when is_gr r glob_xO -> mult_2(bignat_of_pos a) - | GApp (r ,[a]) when is_gr r glob_xI -> add_1(mult_2(bignat_of_pos a)) - | GRef (a, _) when Globnames.eq_gr a glob_xH -> Bigint.one - | _ -> raise Non_closed_number - ) x - -let uninterp_positive (AnyGlobConstr p) = - try - Some (bignat_of_pos p) - with Non_closed_number -> - None - -(************************************************************************) -(* Declaring interpreters and uninterpreters for positive *) -(************************************************************************) - -let _ = Notation.declare_numeral_interpreter "positive_scope" - (positive_path,binnums) - interp_positive - ([DAst.make @@ GRef (glob_xI, None); - DAst.make @@ GRef (glob_xO, None); - DAst.make @@ GRef (glob_xH, None)], - uninterp_positive, - true) - -(**********************************************************************) -(* Parsing N via scopes *) -(**********************************************************************) - -let n_kn = make_kn (make_dir binnums) (Id.of_string "N") -let glob_n = IndRef (n_kn,0) -let path_of_N0 = ((n_kn,0),1) -let path_of_Npos = ((n_kn,0),2) -let glob_N0 = ConstructRef path_of_N0 -let glob_Npos = ConstructRef path_of_Npos - -let n_path = make_path binnums "N" - -let n_of_binnat ?loc pos_or_neg n = DAst.make ?loc @@ - if not (Bigint.equal n zero) then - GApp(DAst.make @@ GRef (glob_Npos,None), [pos_of_bignat ?loc n]) - else - GRef(glob_N0, None) - -let error_negative ?loc = - user_err ?loc ~hdr:"interp_N" (str "No negative numbers in type \"N\".") - -let n_of_int ?loc n = - if is_pos_or_zero n then n_of_binnat ?loc true n - else error_negative ?loc - -(**********************************************************************) -(* Printing N via scopes *) -(**********************************************************************) - -let bignat_of_n n = DAst.with_val (function - | GApp (r, [a]) when is_gr r glob_Npos -> bignat_of_pos a - | GRef (a,_) when Globnames.eq_gr a glob_N0 -> Bigint.zero - | _ -> raise Non_closed_number - ) n - -let uninterp_n (AnyGlobConstr p) = - try Some (bignat_of_n p) - with Non_closed_number -> None - -(************************************************************************) -(* Declaring interpreters and uninterpreters for N *) - -let _ = Notation.declare_numeral_interpreter "N_scope" - (n_path,binnums) - n_of_int - ([DAst.make @@ GRef (glob_N0, None); - DAst.make @@ GRef (glob_Npos, None)], - uninterp_n, - true) - -(**********************************************************************) -(* Parsing Z via scopes *) -(**********************************************************************) - -let z_path = make_path binnums "Z" -let z_kn = make_kn (make_dir binnums) (Id.of_string "Z") -let glob_z = IndRef (z_kn,0) -let path_of_ZERO = ((z_kn,0),1) -let path_of_POS = ((z_kn,0),2) -let path_of_NEG = ((z_kn,0),3) -let glob_ZERO = ConstructRef path_of_ZERO -let glob_POS = ConstructRef path_of_POS -let glob_NEG = ConstructRef path_of_NEG - -let z_of_int ?loc n = - if not (Bigint.equal n zero) then - let sgn, n = - if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in - DAst.make ?loc @@ GApp(DAst.make ?loc @@ GRef(sgn,None), [pos_of_bignat ?loc n]) - else - DAst.make ?loc @@ GRef(glob_ZERO, None) - -(**********************************************************************) -(* Printing Z via scopes *) -(**********************************************************************) - -let bigint_of_z z = DAst.with_val (function - | GApp (r, [a]) when is_gr r glob_POS -> bignat_of_pos a - | GApp (r, [a]) when is_gr r glob_NEG -> Bigint.neg (bignat_of_pos a) - | GRef (a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero - | _ -> raise Non_closed_number - ) z - -let uninterp_z (AnyGlobConstr p) = - try - Some (bigint_of_z p) - with Non_closed_number -> None - -(************************************************************************) -(* Declaring interpreters and uninterpreters for Z *) - -let _ = Notation.declare_numeral_interpreter "Z_scope" - (z_path,binnums) - z_of_int - ([DAst.make @@ GRef (glob_ZERO, None); - DAst.make @@ GRef (glob_POS, None); - DAst.make @@ GRef (glob_NEG, None)], - uninterp_z, - true) diff --git a/plugins/syntax/z_syntax_plugin.mlpack b/plugins/syntax/z_syntax_plugin.mlpack deleted file mode 100644 index 411260c04c..0000000000 --- a/plugins/syntax/z_syntax_plugin.mlpack +++ /dev/null @@ -1 +0,0 @@ -Z_syntax diff --git a/plugins/xml/README b/plugins/xml/README deleted file mode 100644 index 3128189929..0000000000 --- a/plugins/xml/README +++ /dev/null @@ -1,4 +0,0 @@ -The xml export plugin for Coq has been removed from the sources. -A backward compatible plug-in will be provided as a third-party plugin. -For more informations, contact -Claudio Sacerdoti Coen <claudio.sacerdoticoen@unibo.it>. |