diff --git a/.github/workflows/ci-libhyps.yml b/.github/workflows/ci-libhyps.yml index e17cf86..653a112 100644 --- a/.github/workflows/ci-libhyps.yml +++ b/.github/workflows/ci-libhyps.yml @@ -28,6 +28,7 @@ jobs: image: - 'rocq/rocq-prover:latest' - 'rocq/rocq-prover:dev' + - 'rocq/rocq-prover:9.2' - 'rocq/rocq-prover:9.1' - 'rocq/rocq-prover:9.0' # Steps represent a sequence of tasks that will be executed as part of the job diff --git a/CHANGES.md b/CHANGES.md index cc84073..f144bc4 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,26 +1,85 @@ +# Changes from 4 to 5.0 + +- Almost all tactics are implementd in Ltac2. + - consequently they are musch faster + - also no more "list" variant of the tactical `; { }`. Typically + `/g` now is a shotcut for `; { move_up_types }` (`group_up_list` + removed). + - for auto naming, the user defined naming schemes need to be + written as ltac2 tactics now, instead of ltac1. Tranlation is + straightforward. Typically + +``` coq +Require Import Ltac2.Ltac2. +From Stdlib Require Import List. +Import ListNotations. + + +Ltac2 rename_hyp_2 _ th := + match! th with + | true <> false => [ String "tNEQf" ] + | true = false => [ String "tEQf" ] + end. + +Ltac2 Set rename_hyp := rename_hyp_2. + +(* Suppose I want to add later another naming rule: *) +Ltac2 rename_hyp_3 n th := + match! th with + | Nat.eqb ?x ?y = true => [ String "Neqb"; Rename x ; Rename y ] + | true = Nat.eqb ?x ?y => [ String "Neqb" ; Rename x ; Rename y ] + | _ => rename_hyp_2 n th (* call the previously defined tactic *) + end. + +Ltac2 Set rename_hyp := rename_hyp_3. + +Local Set Default Proof Mode "Classic". (* This restores ltac1 proof mode. *) +``` + +- `especialize` now allows the generated subgoals to use the + quantified hypothesis. This is logically more sound. +- `especialize` now by default quanttifies hypothesis that are not + mentioned. To build evars instead, use the `with x,y` argument. See + README.md. +- `especialize` has a variant where the subgoal are transformed into a + new hypothesis instead of being directly applied to the initial + hypothesis. This variant can create only one subgoal. + +## Unpoolugged syntax + +- `tac1 ;; tac2` a,d `tac1 ;!; tac2` syntax definitely disabled. + Although you can re-enable it with: + +``` coq +Tactic Notation (at level 4) tactic4(tac) ";;" tactic4(tach) := then_eachnh tac tach. ` +Tactic Notation (at level 4) tactic4(tac) ";!;" tactic4(tach) := (then_eachnh_rev tac tach). +``` + # Changes from 1.x to 2.x ## New Syntax - + "tac1 ;; tac2" remains, but you can also use "tac1; { tac2 }". - + "tac1 ;!; tac2" remains, but you can also use "tac1; {< tac2 }". - - + "!tac", "!!tac" etc are now only loaded if you do: - `Import LibHyps.LegacyNotations.`, the new following - composable tacticals are preferred: - - + `tac /s` is an alias for `tac ;{ substHyp }` - + `tac /r` is an alias for `tac ;{ revertHyp }` - + `tac /n` is an alias for `tac ;{ autorename }` - + `tac /g` is an alias for `tac ;{ group_up_list}` which is itself - preferred to `tac ; { move_up_types }` or `tac ;; move_up_types.` - - + Combinations like `tac /s/n/g` are accepted. - + Some combination have shortcuts, e.g. `tac /sng` stands for `tac - /s/n/g`. Other shortcuts include `\sn`,`\ng`,`\sg`... - -## New Tactical for tactical dealing with all hyps at once ++ The tactical `then_eachnh tac1 tac2` has now syntax `tac1 ; { tac2 }`. ++ The tactical `then_eachnh_rev tac1 tac2` has now syntax `tac1 ; {< tac2 }`. ++ `tac /s` is an alias for `tac ;{ substHyp }` ++ `tac /r` is an alias for `tac ;{ revertHyp }` ++ `tac /n` is an alias for `tac ;{ autorename }` ++ `tac /g` is an alias for `tac ;{ group_up_list }` which is itself + preferred to `tac ; { move_up_types }` or `tac ;; move_up_types.` ++ Combinations like `tac /s/n/g` are accepted. ++ Some combination have shortcuts, e.g. `tac /sng` stands for `tac + /s/n/g`. Other shortcuts include `\sn`,`\ng`,`\sg`... + +## Old syntax + ++ "tac1 ;; tac2" remains, but you can also use "tac1; { tac2 }". ++ "tac1 ;!; tac2" remains, but you can also use "tac1; {< tac2 }". ++ "!tac", "!!tac" etc are now only loaded if you do: + `Import LibHyps.LegacyNotations.`, the new following + composable tacticals are preferred: + +## New Tactical for tactical dealing with all hyps at once (OBSOLETE IN > 5.0) + "tac1; {! tac2 }" applies tac2 once to *the list of* all new hypothesis. + "tac1; {!< tac2 }" applies tac2 once to *the list of* all new hypothesis (reverse order). diff --git a/LibHyps/.filestoinstall b/LibHyps/.filestoinstall deleted file mode 100644 index 29fe27d..0000000 --- a/LibHyps/.filestoinstall +++ /dev/null @@ -1 +0,0 @@ -./LibHypsNaming.vo ./Especialize.vo ./IdentParsing.vo ./LibHypsTactics.vo ./LibSpecialize.vo ./LibDecomp.vo ./TacNewHyps.vo ./LibHyps.vo ./LibHypsNaming.v ./Especialize.v ./IdentParsing.v ./LibHypsTactics.v ./LibSpecialize.v ./LibDecomp.v ./TacNewHyps.v ./LibHyps.v ./LibHypsNaming.glob ./Especialize.glob ./IdentParsing.glob ./LibHypsTactics.glob ./LibSpecialize.glob ./LibDecomp.glob ./TacNewHyps.glob ./LibHyps.glob diff --git a/LibHyps/AssertPremise.v b/LibHyps/AssertPremise.v new file mode 100644 index 0000000..926bcc8 --- /dev/null +++ b/LibHyps/AssertPremise.v @@ -0,0 +1,288 @@ +Require Import Ltac2.Ltac2. +Require Sorting.Mergesort Structures.OrdersEx. +From Ltac2 Require Import Option Constr Printf. +Import Constr.Unsafe. +Local Set Default Proof Mode "Classic". +(* Require Import LibHyps.LibHypsDebug. *) + +(* Utilities *) +Local Ltac2 invalid_arg (msg:string) := Control.throw (Invalid_argument (Some (Message.of_string msg))). + +Local Ltac2 mk_evar ename typ := + let tac := ltac1:(ename typ|- evar (ename:typ)) in + tac (Ltac1.of_ident ename) (Ltac1.of_constr typ). + + +Local Ltac2 Type premise := [ Int(int) | Ident(ident) ]. + +Local Ltac2 pr_premise () a := + match a with + | Int(i) => fprintf "Int(%i)" i + | Ident(id) => fprintf "Ident(%I)" id + end. + +Local Ltac2 minus_one (x:premise):premise := + match x with + | Int n => Int (Int.sub n 1) + | _ => x + end. + +Local Ltac2 map_minus_one (li:premise list) : premise list := List.map minus_one li. +Ltac2 Type when_cited := [ Evarize | Quantify]. +Ltac2 mutable on_cited_vars := Quantify. +Ltac2 mutable dont_quantif_unused := true. + +Local Ltac2 andb := Bool.and. +Local Ltac2 negb := Bool.neg. +Local Ltac2 orb := Bool.or. + +Local Ltac2 Type whatToDo := [ ForceQuantif (binder) | ForceEvar(ident) | OptQuantif (binder) | OptEvar(ident) ]. +(* +Local Ltac2 pr_whattodo () a := + match a with + ForceQuantif bnd => fprintf "ForceQuantif(%a)" pr_binder bnd + | OptQuantif bnd => fprintf "OptQuantif(%a)" pr_binder bnd + | ForceEvar id => fprintf "ForceEvar(%I)" id + | OptEvar id => fprintf "OptEvar(%I)" id + end. +*) + +(* build_premise_type (forall x,y, h1 -> h2 -> forall n,n, h3 -> h4) + [2;3] return the "forall ..., (h2 -> h3)" where ... are the + variables appearing in (h2 -> h3). *) +Local Ltac2 rec build_premise_type (t:constr) (li:int list) (lid:ident list) : constr := + match Unsafe.kind t with + | Prod bnd t' => + let h_premis:ident option := Constr.Binder.name bnd in + let typ_premis:constr := Constr.Binder.type bnd in + let is_dep := Bool.neg (noccurn 1 t') in + if is_dep (* dep product; forall x:T, U. *) + then + let (whattodo,lid'):(whatToDo*ident list) := + match lid, on_cited_vars with + | [], Evarize => (OptQuantif(bnd),lid) + | [], Quantify => (OptEvar(Option.get h_premis),lid) + | id :: lid'' , Quantify => + if Ident.equal id (Option.get h_premis) + then (ForceQuantif(bnd), lid'') + else (OptEvar(Option.get h_premis) , lid) + | id :: lid'' , Evarize => + if Ident.equal id (Option.get h_premis) + then (ForceEvar(Option.get h_premis) , lid'') + else (OptQuantif(bnd), lid) + end + in + let res := build_premise_type t' li lid' in + match whattodo with + | ForceQuantif bnd => make (Prod bnd res) + | ForceEvar id => + let ename:ident := Fresh.in_goal id in + mk_evar ename typ_premis; + let ev:constr := make (Var ename) in + let ressubst := substnl [ev] 0 res in (* this also performs a pop *) + (if (noccurn 1 res) (* andb (default_ignore_unused) the evar will disappear if we ignore it *) + then printf "Warning: an evar is created (?%I) but there is no reference to it in goals" ename + else ()); + ressubst + | OptQuantif bnd => + if andb (noccurn 1 res) dont_quantif_unused then liftn -1 1 res + else make (Prod bnd res) + | OptEvar id => + if (noccurn 1 res) (* andb (default_ignore_unused) the evar will disappear if we ignore it *) + then liftn -1 1 res + else + let ename:ident := Fresh.in_goal id in + mk_evar ename typ_premis; + let ev:constr := make (Var ename) in + let ressubst := substnl [ev] 0 res in (* this also performs a pop *) + ressubst + end + else (* non dep premise: T -> U *) + match li with + | [] => invalid_arg "Empty occurence list, please report." + | n :: li' => + if Int.le n 1 (* either the final premise, or we want to quantify it *) + then + if List.is_empty li' + then + if List.is_empty lid + then typ_premis (* We found the final premise *) + else invalid_arg "the list of variables is too long (or not in the right order?)" + else (* We found a dependent premise we want to keep, but not the final one *) + let popli' := List.map (fun x => Int.sub x 1) li' in + let res := build_premise_type t' popli' lid in + make (Prod bnd res) (* we keep the premise *) + else + (* We found a dependent premise we want to ignore *) + let popli := List.map (fun x => Int.sub x 1) li in + let res := build_premise_type t' popli lid in + if noccurn 1 res (* if premise does NOT occur in result *) + then + let r := liftn -1 1 res in (* forget premis, pop rels accordingly. *) + r + else (* this dependent premise is actually needed for typing the result *) + invalid_arg "Some other premise occurs in the built type." + end + | _ => invalid_arg "Not enough products" + end. +(* +Goal True. + ltac2:(let t := build_premise_type + constr:(forall n p m:nat, n<=m -> n n=p -> False) + [1] [ident:(n) ] in + printf "res = %t" t). + Undo. + ltac2:(let t := build_premise_type + constr:(forall n p m:nat, n<=m -> n n=p -> False) + [1;2] [ident:(n) ] in + printf "res = %t" t). + Undo. + ltac2:(let t := build_premise_type + constr:(forall n p m:nat, n<=m -> n n=p -> False) + [1;2] [ident:(n); ident:(m) ] in + printf "res = %t" t). + Undo. + ltac2:(let t := build_premise_type + constr:(forall n p m:nat, n<=m -> n n=p -> False) + [Ident ident:(n) ; Int 1; Int 3] in + printf "res = %t" t). + +Abort. +*) + +(* Local Ltac2 rec assert_premise (t:constr) (li:int list) : unit := *) + (* let typ := build_premise_type t li in *) + (* Std.assert (Std.AssertType None typ None). *) +(* Pure Ltac2 tactics *) +Module Ltac2. + Ltac2 all_hyps_ident() := List.map (fun (x,_,_) => x) (Control.hyps ()). + + Ltac2 iter_hyps (tac:ident -> unit) (lh:ident list) := + List.iter tac lh. + + Ltac2 map_all_hyps (tac:'a -> unit) := + let all_hyps := all_hyps_ident() in + iter_hyps tac all_hyps. + + Ltac2 map_all_hyps_rev (tac: 'a -> unit) := + let all_hyps := List.rev (all_hyps_ident()) in + iter_hyps tac all_hyps. + + Ltac2 then_eachnh_gen (tac1:'a -> unit) (tac2:ident -> unit) (rev:bool) := + let hyps_before := all_hyps_ident() in + let _ := tac1() in + Control.enter + (fun () => + let hyps_after := all_hyps_ident() in + let new_hyps: ident list := List.filter_out (fun id => List.mem Ident.equal id hyps_before) hyps_after in + iter_hyps tac2 (if rev then List.rev new_hyps else new_hyps)). + + Ltac2 then_eachnh (tac1:'a -> unit) (tac2:ident -> unit) := + then_eachnh_gen tac1 tac2 false. + + Ltac2 then_eachnh_rev (tac1:'a -> unit) (tac2:ident -> unit) := + then_eachnh_gen tac1 tac2 true. + +End Ltac2. + +Local Ltac2 rec assert_premise_type (t:constr) (li:int list) (lid:ident list) (name:ident option) : unit := + (* We call the tactic then subst any let ins (created along with evars). *) + Ltac2.then_eachnh_rev + (fun () => + let typ := build_premise_type t li lid in + let intro_ptn := + Option.map (fun x => (Std.IntroNaming (Std.IntroIdentifier x))) name in + Std.assert (Std.AssertType (intro_ptn) typ None)) + (fun (h:ident) => + match Control.hyp_value h with + | None => () + | Some _ => + Std.subst [h] + end). +(* +Goal forall x y:nat, True. + intros x y. + (ltac2:(assert_premise_type constr:(forall n p m:nat, n<=m -> n n=p -> False) [ 1;2;3] [] None)). + Undo. + + (ltac2:(assert_premise_type constr:(forall n p m:nat, n<=m -> n n=p -> False) [ 1;2;3] [ident:(n)] None)). + Undo. + + (ltac2:(assert_premise_type constr:(forall n p m:nat, n<=m -> n n=p -> False) + [ 1;2;3] + [ident:(n); ident:(m)] + None)). + Undo. + (ltac2:(assert_premise_type constr:(forall n p m:nat, n<=m -> n n=p -> False) + [ 1; 2; 3] + [ident:(n);ident:(p)] + None)). + Undo. + (ltac2:(assert_premise_type constr:(forall n p m:nat, n<=m -> n n=p -> False) + [ 1; 2; 3] + [ident:(n);ident:(p);ident:(m)] + None)). + Undo. + (* wrong order in variables: n remains in the list after depleting ints *) + Fail (ltac2:(assert_premise_type constr:(forall n p m:nat, n<=m -> n n=p -> False) + [ 1; 2; 3] + [ident:(p); ident:(n)] + None)). +Abort. + +*) +Local Ltac2 interp_ltac1_int_or_id_list (li:Ltac1.t list) : premise list := + List.map + (fun x => + match Ltac1.to_int x with + None => match (Ltac1.to_ident x) with + | None => invalid_arg "not an integer nor a ident" + | Some id => Ident id + end + | Some i => Int i + end) + li. + + +Local Ltac2 interp_ltac1_id_list (lid:Ltac1.t list) : ident list := + List.map (fun x => Option.get (Ltac1.to_ident x)) lid. + +Local Ltac2 interp_ltac1_int_list (li:Ltac1.t list) : int list := + List.map (fun x => Option.get (Ltac1.to_int x)) li. + + +Local Ltac2 rec assert_premise_from_ltac1 (h:Ltac1.t) (li:Ltac1.t) (lid:Ltac1.t) (name:Ltac1.t) : unit := + let h' := Option.get (Ltac1.to_constr h) in + (* if li is not a list, then it means no li has been given, thus []. *) + let li' := interp_ltac1_int_list (default [] (Ltac1.to_list li)) in + let lid' := interp_ltac1_id_list (default [] (Ltac1.to_list lid)) in + (* If name is not recognized it means that no name was given, thus None. *) + let name' := Ltac1.to_ident name in + let th' := type h' in + + assert_premise_type th' li' lid' name'. + +Local Ltac dummy_term := constr:(Prop). + + +Global Tactic Notation "assert" "premise" ne_integer_list_sep(li,"->") "of" constr(h) "with" ne_ident_list_sep(lid,",") "as" ident(newH) := + let tac := ltac2:(h li lid newH |- assert_premise_from_ltac1 h li lid newH) in + tac h li lid newH. + + +Global Tactic Notation "assert" "premise" ne_integer_list_sep(li,"->") "of" constr(h) "with" ne_ident_list_sep(lid,",") := + let tac := ltac2:(h li lid newH |- assert_premise_from_ltac1 h li lid newH) in + let newH := dummy_term in + tac h li lid newH. + +Global Tactic Notation "assert" "premise" ne_integer_list_sep(li,"->") "of" constr(h) "as" ident(newH) := + let tac := ltac2:(h li lid newH |- assert_premise_from_ltac1 h li lid newH) in + let lid := dummy_term in + tac h li lid newH. + +Global Tactic Notation "assert" "premise" ne_integer_list_sep(li,"->") "of" constr(h) := + let tac := ltac2:(h li lid newH |- assert_premise_from_ltac1 h li lid newH) in + let lid := dummy_term in + let newH := dummy_term in + tac h li lid newH. + diff --git a/LibHyps/Especialize.v b/LibHyps/Especialize.v index 499aa71..95799f8 100644 --- a/LibHyps/Especialize.v +++ b/LibHyps/Especialize.v @@ -1,109 +1,17 @@ -From Stdlib Require Import String. -(* Require ident_of_string. *) Require Import Ltac2.Ltac2. +Require Sorting.Mergesort Structures.OrdersEx. From Ltac2 Require Import Option Constr Printf. Import Constr.Unsafe. -(* Declare Scope specialize_scope. *) -(* Delimit Scope specialize_scope with spec. *) -(* Local Open Scope specialize_scope. *) -Require IdentParsing. - -From Stdlib Require Import String Ascii. -Open Scope string_scope. Local Set Default Proof Mode "Classic". +(* Require Import LibHyps.LibHypsDebug. *) -(* The type describing how to specialize the arguments of a hyp. Premises are either -- transformed into a sub goal -- transformed into an evar -- requantified (default). *) -Inductive spec_arg : Type := - (* This 4 are meant to be put in a exhaustive list of what to do - with args in order. The others are actually transformed into these - ones on the fly *) - Quantif | QuantifIgnore | SubGoal | Evar: string -> spec_arg -| SubGoalAtName: string -> spec_arg (* make a subgoal with named arg *) -| SubGoalAtNum: nat -> spec_arg (* make a subgoal with arg's number *) -| EvarAtName: string -> string -> spec_arg (* make an evar with the named arg. *) -| SubGoalUntilNum: nat -> spec_arg (* make subgoals with all non dep hyp until nth one. *) -| SubGoalAtAll: spec_arg. (* make subgoals with all non dep hyp. *) - -Definition spec_args := list spec_arg . - -(* List storing heterogenous terms, for storing telescopes. A simple - product could also be used. *) -(* -Inductive Depl := -| DNil: Depl -| DCons: forall (A:Type) (x:A), Depl -> Depl. -*) - -(* if H head product is dependent, call tac1, else call tac2 *) -Ltac if_is_dep_prod H tac1 tac2 := - (* tryif is_dep_prod H then ltac:(tac1) else ltac:(tac2). *) - let t := type of H in - match goal with - | |- _ => match goal with - | |- _ => assert t; - let h := fresh "__h__" in - intro h; - (tryif clear h then fail else fail 1) (* we fail in both cases to backtrack the assert*) - | |- _ => tac2 - | |- _ => fail 2 (* don't fall back to tac1 *) - end - | |- _ => tac1 - end. - -Ltac2 rec length_constr_string (xs : constr) : int := - match kind xs with - | App _ args => - match Int.equal (Array.length args) 2 with - | true => Int.add 1 (length_constr_string (Array.get args 1)) - | _ => if equal xs 'String.EmptyString then 0 else Control.throw No_value - end - | Constr.Unsafe.Constructor _ _ => 0 - | _ => Control.throw No_value +(* Utilities *) +Local Ltac2 is_dep_prod (t:constr): bool := + match kind t with + | Prod _ subt => Bool.neg (is_closed subt) + | _ => false end. -Ltac2 string_of_constr_string (s : constr) : string := - let s := eval vm_compute in ($s : String.string) in - let ret := String.make (length_constr_string s) (Char.of_int 0) in - let t := constr:(true) in - let rec fill i s := - (match kind s with - | App _ args => - (if Int.equal (Array.length args) 2 then - (String.set ret i (match kind (Array.get args 0) with App _ b => Char.of_int ( - Int.add (if equal (Array.get b 0) t then 1 else 0) ( - Int.add (if equal (Array.get b 1) t then 2 else 0) ( - Int.add (if equal (Array.get b 2) t then 4 else 0) ( - Int.add (if equal (Array.get b 3) t then 8 else 0) ( - Int.add (if equal (Array.get b 4) t then 16 else 0) ( - Int.add (if equal (Array.get b 5) t then 32 else 0) ( - Int.add (if equal (Array.get b 6) t then 64 else 0) ( - (if equal (Array.get b 7) t then 128 else 0))))))))) - | _ => Control.throw No_value end); - fill (Int.add i 1) (Array.get args 1)) - else ()) - | _ => () - end) in - fill 0 s; - ret. - -Ltac if_eqstr := - ltac2:(ident s tac1 tac2 |- - (if String.equal - (Ident.to_string (Option.get (Ltac1.to_ident ident))) - (string_of_constr_string (Option.get (Ltac1.to_constr s))) - then Ltac1.apply tac1 [] - else Ltac1.apply tac2 []) Ltac1.run). - -Ltac2 ident_of_constr_string (s : constr) := Option.get (Ident.of_string (string_of_constr_string s)). - -Ltac ident_of_constr_string_cps := ltac2:(s tac |- - Ltac1.apply tac [Ltac1.of_ident (ident_of_constr_string (Option.get (Ltac1.to_constr s)))] Ltac1.run). - -Ltac evar_as_string s t := ident_of_constr_string_cps s ltac:(fun s => let s' := fresh s in evar(s':t)). - (* ESPECIALIZE INTERNAL DOC *) (* We show here by hand what the especialize tactic does. We start @@ -154,405 +62,429 @@ Proof. (* we go on by specializing H with this new goal *) specialize (H h'). (* Now we have finished, we finish refining the unknown goal with H itself. *) - exact H. + exact H. (* Building the new hyp: the specialized version of H. *) (* Now we are left with 2 subgoals and the initial goal where H has been specialized. *) Abort. -(* debug *) -(*Require Import LibHyps.LibHypsTactics. -Module Prgoal_Notation. - Ltac pr_goal := - match goal with - |- ?g => - let allh := harvest_hyps revert_clearbody_all in - (* let allh := all_hyps in *) - idtac "GOAL: " allh " ⊢ " g - end. -End Prgoal_Notation. +Lemma foo: forall x y : nat, (forall n m:nat, n < m -> n <= m -> forall p:nat, p >= 0 -> p+1 = m+n) -> True. +Proof. + + intros x y H. + (* - We start from a goal evarEV with no typing constraint. *) + let ev1 := open_constr:(_) in + assert ev1 as newH. + (* then we refine this unknown goal by mimick H until we reach the + premise we want to remove: *) + (* ignore n, m n= 0) as h. + 2:{ exact h. } (* Building the new hyp: h itself, that is the premise of H *) + { unfold p. apply OrdersEx.Nat_as_OT.le_0_1. } + specialize H with (3:=newH). + + +Abort. -Local Ltac2 tag_info s := (String.concat "" [ ""; s; "" ]). -Local Ltac2 tag_msg m := Message.concat - (Message.concat (Message.of_string "") m) - (Message.of_string ""). -Local Ltac2 str_to_msg s := tag_msg (Message.of_string s). -Local Ltac2 int_to_msg i := tag_msg (Message.of_int i). -Local Ltac2 id_to_msg id := tag_msg (Message.of_ident id). -Local Ltac2 constr_to_msg c := tag_msg (Message.of_constr c). -Local Ltac2 msgs s := Message.print (str_to_msg s). -Local Ltac2 msgi i := Message.print (int_to_msg i). -Local Ltac2 msgc c := Message.print (constr_to_msg c). -Local Ltac2 msgid id := Message.print (id_to_msg id). -Ltac2 pr_binder () (b:binder) := - let nme:ident option := Binder.name b in - let typ:constr := Binder.type b in - fprintf "(%I:%t)" (Option.get nme) typ. -*) -(* This performs the refinement of the current goal by mimicking h and - making evars and subgoals according to args. n is the number of - dependent product we have already met. *) -Ltac refine_hd_OLD h largs n := - let newn := if_is_dep_prod h ltac:(constr:(n)) ltac:(constr:(S n)) in - (* let newn := tryif is_dep_prod h then constr:(n) else constr:(S n) in *) - lazymatch largs with - | nil => exact h - | _ => - lazymatch type of h with - | (forall (h_premis:?t) , _) => - let id := ident:(h_premis) in (* ltac hack, if the product was not named, - then "h_premis" is taken "as is" by fresh *) - let intronme := (*fresh*) id in - lazymatch largs with - | nil => exact h - | cons Quantif ?largs' => - refine (fun intronme: t => _); - specialize (h intronme); - refine_hd_OLD h largs' newn - | cons QuantifIgnore ?largs' => - (* let intronme := fresh x in *) - refine (fun intronme: t => _); - specialize (h intronme); - clear h_premis; - refine_hd_OLD h largs' newn - | cons (SubGoalAtName ?nme) ?largs' => - if_eqstr ident:(h_premis) nme - ltac:(idtac;refine_hd_OLD h (cons SubGoal largs') n) - ltac:(idtac;refine_hd_OLD h (cons Quantif largs) n) - | cons (EvarAtName ?nmearg ?nameevar) ?largs' => - if_eqstr ident:(h_premis) nmearg - ltac:(idtac;refine_hd_OLD h (cons (Evar nameevar) largs') n) - ltac:(idtac;refine_hd_OLD h (cons Quantif largs) n) - | cons (SubGoalAtNum ?num) ?largs' => - if_is_dep_prod h - ltac:((idtac;refine_hd_OLD h (cons Quantif largs) n)) - ltac:(idtac;tryif convert num newn - then refine_hd_OLD h (cons SubGoal largs') n - else refine_hd_OLD h (cons Quantif largs) n) - | cons (SubGoalUntilNum ?num) ?largs' => - if_is_dep_prod h - ltac:((idtac;refine_hd_OLD h (cons Quantif largs) n)) - ltac:(idtac;tryif convert num newn - then refine_hd_OLD h (cons SubGoal largs') n - else refine_hd_OLD h (cons SubGoal largs) n) - | cons (Evar ?ename) ?largs' => - evar_as_string ename t; - (* hackish: this should get the evar just created *) - let hename := match goal with H:t|-_ => H end in - specialize (h hename); - subst hename; - (* idtac "subst"; *) - refine_hd_OLD h largs' newn - | cons SubGoal ?largs' => - (unshelve evar_as_string "SubGoal" t); - (* hackish: this should get the evar just created *) - [ | let hename := match goal with - H:t|-_ => H - end in - specialize (h hename); - clearbody hename; - (* idtac "subst"; *) - refine_hd_OLD h largs' newn] - end - | _ => idtac "Not enough products." (*; fail*) - end + +Local Ltac2 Type directarg := [ Quantif | QuantifIgnore | SubGoal | Evar(ident) ]. +Local Ltac2 Type namearg := [ + SubGoalAtName(ident) (* make a subgoal with named arg *) + | EvarAtName(ident,ident) (* make an evar with the named arg. *) +]. +Local Ltac2 Type numarg := [ + | SubGoalAtNum(int) (* make a subgoal with arg's number *) + | SubGoalUntilNum(int) (* make subgoals with all non dep hyp until nth one. *) + | SubGoalAtAll (* make subgoals with all non dep hyp. *) + ]. + + +Local Ltac2 pr_numarg () a := + match a with + | SubGoalAtNum(i) => fprintf "SubGoalAtNum(%i)" i + | SubGoalUntilNum(i) => fprintf "SubGoalUntilNum(%i)" i + | SubGoalAtAll => fprintf "SubGoalAtAll" end. -Ltac refine_hd h ldirectarg lnameargs lnumargs n := - let th := type of h in - let newn := if_is_dep_prod h ltac:(constr:(n)) ltac:(constr:(S n)) in - (* idtac "REFINE_HD: " th; *) - (* idtac " " h "ldirect:" ldirectarg " , lnames:" lnameargs " , lnums" lnumargs; *) - (* let newn := tryif is_dep_prod h then constr:(n) else constr:(S n) in *) - match constr:((ldirectarg,lnameargs,lnumargs)) with - | (nil,nil,nil) => exact h - | (cons ?directarg ?ldirectarg',_,_) => - lazymatch type of h with - | (forall (h_premis:?t) , _) => - let intronme := ident:(h_premis) in (* ltac hack, if the product was not named, - then "h_premis" is taken "as is" by fresh *) - match directarg with - | Quantif => - refine (fun intronme: t => _); - specialize (h intronme); - refine_hd h ldirectarg' lnameargs lnumargs newn - | QuantifIgnore => - (* let intronme := fresh x in *) - refine (fun intronme: t => _); - specialize (h intronme); - clear h_premis; - refine_hd h ldirectarg' lnameargs lnumargs newn - | Evar ?ename => - evar_as_string ename t; - (* hackish: this should get the evar just created *) - let hename := match goal with H:t|-_ => H end in - specialize (h hename); - subst hename; - refine_hd h ldirectarg' lnameargs lnumargs newn - | SubGoal => - (unshelve evar_as_string "SubGoal" t); - (* hackish: this should get the evar just created *) - [ | let hename := match goal with - H:t|-_ => H - end in - specialize (h hename); - clearbody hename; - refine_hd h ldirectarg' lnameargs lnumargs newn ] - end - | _ => fail 1 - end - | (nil,cons ?namearg ?lnameargs',_) => - lazymatch type of h with - | (forall (h_premis:?t) , _) => - let intronme := ident:(h_premis) in (* ltac hack, if the product was not named, - then "h_premis" is taken "as is" by fresh *) - lazymatch namearg with - | (SubGoalAtName ?nme) => - if_eqstr ident:(h_premis) nme - ltac:(idtac;refine_hd h (cons SubGoal nil) lnameargs' lnumargs n) - ltac:(fail 0) - | (EvarAtName ?nme ?nameevar) => - if_eqstr ident:(h_premis) nme - ltac:(idtac;refine_hd h (cons (Evar nameevar) nil) lnameargs' lnumargs n) - ltac:(fail 0) +Local Ltac2 pr_directarg () a := + match a with + | Quantif => fprintf "Quantif" + | QuantifIgnore => fprintf "QuantifIgnore" + | SubGoal => fprintf "SubGoal" + | Evar(id) => fprintf "Evar(%I)" id + end. + +Local Ltac2 pr_namearg () a := + match a with + | SubGoalAtName id => fprintf "SubGoalAtName(%I)" id + | EvarAtName id1 id2 => fprintf "EvarAtName(%I,%I)" id1 id2 + end. +(* +Goal True. + ltac2:(printf "%a" pr_namearg (SubGoalAtName @toto)). + ltac2:(printf "%a" (pr_list pr_namearg) ([SubGoalAtName @toto; EvarAtName @titi1 @titi2])). +*) + + + +Local Ltac2 backtrack (msg:string) := Control.zero (Tactic_failure (Some (fprintf "Backtrack: %s" msg))). +Local Ltac2 invalid_arg (msg:string) := Control.throw (Invalid_argument (Some (Message.of_string msg))). + +Local Ltac2 mk_evar ename typ := + let tac := ltac1:(ename typ|- evar (ename:typ)) in + tac (Ltac1.of_ident ename) (Ltac1.of_constr typ). + +Local Ltac2 assert_evar nme := + let tac := ltac1:(nme |-let ev1 := open_constr:(_) in assert ev1 as nme) in + tac (Ltac1.of_ident nme). + + +Local Ltac2 intro_typed (name:ident) (typ:constr) := + let tac := ltac1:(name typ |- refine (fun (name:typ) => _)) in + tac (Ltac1.of_ident name) (Ltac1.of_constr typ). + +Local Ltac2 specialize_id_id (h:ident) (arg:ident) : unit := + let newhyp := Control.hyp arg in + let hc:constr := Control.hyp h in + let special := Unsafe.make (Unsafe.App hc [|newhyp|]) in + Std.specialize (special , Std.NoBindings) None. + +Local Ltac2 specialize_id_cstr (h:ident) (c:constr) : unit := + let hc:constr := Control.hyp h in + let special := Unsafe.make (Unsafe.App hc [|c|]) in + Std.specialize (special , Std.NoBindings) None. + + +(* Local Ltac2 pr_debug (h:ident) (ldirectarg:directarg list) (lnameargs:namearg list) *) +(* (lnumargs:numarg list) (n:int) := *) +(* let hc := Control.hyp h in *) +(* let th := Constr.type hc in *) +(* LibHyps.LibHypsDebug.msgs "--------------"; *) +(* (* LibHyps.dev.LibHypsDebug.pr_goal(); *) *) +(* printf "n = %i ; th = %t" n th; *) +(* printf "lnumargs = %a" (pr_list pr_numarg) lnumargs; *) +(* printf "lnameargs = %a" (pr_list pr_namearg) lnameargs; *) +(* printf "ldirectarg = %a" (pr_list pr_directarg) ldirectarg. *) + +(* The main function is refine_hd. It interprets all available directargs. The two other + functions refine_hd_name and refine_hd_num are applied when no directarg is available. + They compute the next directarg and call the main function. + + n is the last seen dephyp number. + *) + +Local Ltac2 rec refine_hd (only_premis:bool) (h:ident) + (ldirectarg:directarg list) (lnameargs:namearg list) (lnumargs:numarg list) (n:int) + : unit := + (* pr_debug h ldirectarg lnameargs lnumargs n; *) + let hc := Control.hyp h in + let th := Constr.type hc in + let newn := if is_dep_prod th then n else (Int.add n 1) in + (* msgc th; *) + match Unsafe.kind th with + | Prod _ _ => + match ldirectarg with + | directarg::ldirectarg' => + match Unsafe.kind th with + | Prod bnd _ => + let h_premis:ident option := Constr.Binder.name bnd in + let typ_premis := Constr.Binder.type bnd in + let intronme:ident := + match h_premis with + None => + let id := Option.map Fresh.in_goal (Ident.of_string "h_premis") in + Option.get id + | Some idh => idh + end in + match directarg with + | Quantif => + intro_typed intronme typ_premis; + specialize_id_id h intronme; + refine_hd only_premis h ldirectarg' lnameargs lnumargs newn + | QuantifIgnore => + intro_typed intronme typ_premis; + specialize_id_id h intronme; + clear $intronme; + refine_hd only_premis h ldirectarg' lnameargs lnumargs newn + | Evar ename => + let ename := Fresh.in_goal ename in + mk_evar ename typ_premis; + specialize_id_id h ename; + subst $ename; + refine_hd only_premis h ldirectarg' lnameargs lnumargs newn + | SubGoal => + let gl := Fresh.in_goal @h in (* this uses base name "h" *) + (unshelve (epose (_:$typ_premis) as $gl)) > + [ | + if only_premis then + match ldirectarg' with + | _ :: _ => invalid_arg "only one subgoal allowed." + | [] => let special := Control.hyp gl in + exact $special (* base case: we only create a premise *) + end + else + let special := Control.hyp gl in + specialize_id_cstr h special; + refine_hd only_premis h ldirectarg' lnameargs lnumargs newn ] + end + | _ => invalid_arg "Not a product (directarg)" end - | _ => fail 0 + | [] => + (* If this succeeds, never go back here from later backtrack. *) + Control.once + (fun () => Control.plus + (fun() => refine_hd_name only_premis h lnameargs lnumargs n) + (fun _ => + (* msgs "Backtracking from refine_hd_name "; *) + Control.plus + (fun () => refine_hd_num only_premis h lnameargs lnumargs n) + (* neither matching a namearg nor a numarg, let us generate a + Quantif and let refine_hd deal with it. *) + (fun _ => + (*msgs "Backtracking from refine_hd_num "; *) + refine_hd only_premis h [Quantif] lnameargs lnumargs n))) + end - | (nil,_,cons ?numarg ?lnumargs') => - lazymatch type of h with - | (forall (h_premis:?t) , _) => - let intronme := ident:(h_premis) in (* ltac hack, if the product was not named, - then "h_premis" is taken "as is" by fresh *) - match numarg with - | (SubGoalAtNum ?num) => - if_is_dep_prod h - ltac:(fail 0) - ltac:(idtac; - tryif convert constr:(PeanoNat.Nat.leb newn num) constr:(true) - then - tryif convert num newn - then refine_hd h (cons SubGoal nil) lnameargs lnumargs' n - else (fail 3) - else - (fail 10000 "Did you not order the evar numbers?")) - | (SubGoalUntilNum ?num) => - if_is_dep_prod h - ltac:(fail 0) - ltac:(idtac;tryif convert num newn - then refine_hd h (cons SubGoal nil) lnameargs lnumargs' n - else refine_hd h (cons SubGoal nil) lnameargs lnumargs n) - | SubGoalAtAll => - if_is_dep_prod h - ltac:(fail 0) - ltac:(idtac; refine_hd h (cons SubGoal nil) lnameargs lnumargs n) - end - | _ => fail 0 + | _ => (*base case *) + match ldirectarg,lnameargs,lnumargs with + | [],[],[] => exact $hc + | [],[],[SubGoalAtAll] => exact $hc + | _ => invalid_arg "Not a product (others)" end - | _ => lazymatch type of h with - | (forall (h_premis:?t) , _) => refine_hd h (cons Quantif nil) lnameargs lnumargs n - | _ => refine_hd h (@nil spec_arg)(@nil spec_arg)(@nil spec_arg) n - end - | _ => fail "refine_hd" - end. + end + (* Try to match the first namearg with the name of the head product. If yes, apply the + namearg (by inserting the corresponding directarg), otherwise backtrack. *) + with refine_hd_name (only_premis:bool) (h:ident) (lnameargs:namearg list) + (lnumargs:numarg list) (n:int) := + let hc:constr := Control.hyp h in + let th:constr := Constr.type hc in + match lnameargs with + | namearg :: lnameargs' => + match Unsafe.kind th with + | Prod bnd _ => + let h_premis := Constr.Binder.name bnd in + match namearg with + | SubGoalAtName nme => + if map_default (Ident.equal nme) false h_premis + then refine_hd only_premis h [SubGoal] lnameargs' lnumargs n + else backtrack "refine_hd_name: SubGoalAtName" + | EvarAtName nme nameevar => + if map_default (Ident.equal nme) false h_premis + then refine_hd only_premis h [Evar nameevar] lnameargs' lnumargs n + else backtrack "refine_hd_name: EvarAtName" + end + | _ => invalid_arg "Not a product (refine_hd_name)" + end + | _ => backtrack "refine_hd_name: no namearg" + end + (* compute the num corresponding to the current hyp (newn), then try to match the + first numarg with it. If yes, apply the numarg (by inserting the corresponding + directarg), otherwise backtrack. *) + with refine_hd_num (only_premis:bool) (h:ident) (lnameargs:namearg list) + (lnumargs:numarg list) (n:int) := + let hc:constr := Control.hyp h in (* h as a constr *) + let th:constr := Constr.type hc in (* type of h as a constr *) + let newn := if is_dep_prod th then n else (Int.add n 1) in + match lnumargs with + | numarg::lnumargs' => + match Unsafe.kind th with + | Prod _ _ => + match numarg with + | SubGoalAtNum num => + if is_dep_prod th + then backtrack "refine_hd_num: SubGoalAtNum, dep" + else if Int.le newn num + then if Int.equal newn num + then refine_hd only_premis h [SubGoal] lnameargs lnumargs' n + else backtrack "refine_hd_num: SubGoalAtNum,nodep" + else invalid_arg "Did you not order the evar numbers?" + | SubGoalUntilNum num => + if is_dep_prod th + then backtrack "refine_hd_num: SubGoalUntilNum, dep" + else + if Int.equal newn num + then refine_hd only_premis h [SubGoal] lnameargs lnumargs' n + else refine_hd only_premis h [SubGoal] lnameargs lnumargs n + + | SubGoalAtAll => + if is_dep_prod th + then backtrack "refine_hd_num: SubGoalAtAll, dep" + else refine_hd only_premis h [SubGoal] lnameargs lnumargs n + end + | _ => invalid_arg "Not a product (refine_hd_num)." + end + | _ => backtrack "refine_hd_num: no numarg" + end. + (* initialize n to zero. *) -Ltac refine_spec h lnameargs lnumargs := refine_hd h constr:(@nil spec_arg) lnameargs lnumargs 0. +Local Ltac2 refine_spec (only_premis:bool) h lnameargs lnumargs := refine_hd only_premis h [] lnameargs lnumargs 0. + +(* +(* tests *) +Definition eq_one (i:nat) := i = 1. +Definition hidden_product := forall i j :nat, i+1=j -> i+1=j -> i+1=j. +Axiom ex_hyp : (forall (b:bool), forall x: nat, eq_one 1 -> forall y:nat, eq_one 2 ->eq_one 3 ->eq_one 4 ->eq_one x ->eq_one 6 ->eq_one y -> eq_one 8 -> eq_one 9 -> False). + +Lemma test_esepec: True. +Proof. + specialize ex_hyp as H. + let ev1 := open_constr:(_) in + assert ev1 as hhh;[ + ltac2:(refine_spec + true + (Option.get (Ident.of_string "H")) + [EvarAtName @b @b; EvarAtName @x @x; EvarAtName @y @y] + [SubGoalAtNum 3;SubGoalAtNum 5]) + | ]. + +*) + +(* num args should be sorted. *) +Local Ltac2 cmp_numarg a b := + match a with + SubGoalAtNum na => + match b with + SubGoalAtNum nb => Int.compare na nb + | _ => -1 + end + | _ => -1 + end. + +Local Ltac2 sort_numargs (l: numarg list): numarg list:= List.sort cmp_numarg l. (* TODO:sort the names or work modulo order on names? Or simply avoid infinite loops. TODO: if there is only one "at" and no "with" - nor "until", then allow for the subgoal to be kept like an assert. *) + nor "until", then allow for the subgoal to be kept like an assert. *) (* builds the inital unknown goal, call the refining tactic, end up by replacing h or naming the new hyp. *) (* Precondition: name is already fresh *) -From Stdlib Require Sorting.Mergesort Structures.OrdersEx. -Module SpecargOrder <: Structures.Orders.TotalLeBool. - Definition t := spec_arg. - - Definition leb a b := - match a with - SubGoalAtNum na => - match b with - SubGoalAtNum nb => Nat.leb na nb - | _ => true - end - | _ => true - end. - -(* Nat.leb. *) - - Theorem leb_total : forall a1 a2, leb a1 a2 = true \/ leb a2 a1 = true. - Proof. - intros a1 a2. - destruct a1;destruct a2;auto. - setoid_rewrite PeanoNat.Nat.leb_le. - apply PeanoNat.Nat.le_ge_cases. - Qed. -End SpecargOrder. - - -Module NatSort := Sorting.Mergesort.Sort(SpecargOrder). - -Local Ltac espec_gen H lnames lnums name replaceb := - (* morally this evar is of type Type, don't know how to enforce this - without having an ugly cast in goals *) - (* idtac "espec_gen " H " " l " " name " " replaceb; *) - (* idtac "lnums = " lnums; *) - let lnums := eval compute in (NatSort.sort lnums) in - (* idtac "lnums = " lnums; *) - tryif is_var H - then (let ev1 := open_constr:(_) in - match replaceb with - true => - assert ev1 as name ; [ (refine_spec H lnames lnums) - | clear H;try rename name into H ] - | false => - assert ev1 as name; [ (refine_spec H lnames lnums) | ] - end) - else (* replaceb should be false in this case. *) - (let H' := fresh "H" in - specialize H as H'; - let ev1 := open_constr:(_) in - assert ev1 as name; [ (refine_spec H' lnames lnums) | clear H' ]). - -(* ltac2 int -> constr nat *) -Ltac2 rec int_to_coq_nat n := - match Int.equal n 0 with - | true => constr:(O) - | false => let n := int_to_coq_nat (Int.sub n 1) in - constr:(S $n) +Local Ltac2 dest_var (c:constr) : ident := + match Unsafe.kind c with + | Unsafe.Var x => x + | _ => Control.throw (Invalid_argument (Some (Message.of_string "dest_var"))) end. -Ltac2 int_to_constr_nat n := - let val := int_to_coq_nat n in - Std.eval_vm None val. - -Ltac2 rec li_to_speclist_SGAtNum (li: int list): constr := - match li with - [] => constr:(@nil spec_arg) - | i :: l' => - let cl := li_to_speclist_SGAtNum l' in - let ci := int_to_constr_nat i in - constr:(cons (SubGoalAtNum $ci) $cl) - end. +Local Ltac2 espec_gen (h:constr) lnames lnums name (replaceb:bool) := + let lnums := sort_numargs lnums in + if is_var h + then + let h := dest_var h in + match replaceb with + true => + assert_evar name > [ (refine_spec false h lnames lnums) + | Std.clear [h]; Std.rename [(name, h)] ] + | false => + assert_evar name > [ (refine_spec false h lnames lnums) | ] + end + else + (* replaceb should be false in this case. *) + (let h' := Fresh.in_goal @H in + Std.specialize (h , Std.NoBindings) (Some (Std.IntroNaming (Std.IntroIdentifier h'))); + assert_evar name > [ (refine_spec false h' lnames lnums) | Std.clear [h'] ]). + +(* One num (the hypothesis one wants to prove, some args to evarize. *) +Local Ltac2 epremis_gen (h:constr) lnames (num:numarg) name := + let lnums := sort_numargs [num] in + if is_var h + then + let h := dest_var h in + assert_evar name > [ (refine_spec true h lnames lnums) | ] + else + let h' := Fresh.in_goal @H_temp in + Std.specialize (h , Std.NoBindings) (Some (Std.IntroNaming (Std.IntroIdentifier h'))); + + assert_evar name > [ (refine_spec true h' lnames lnums) | Std.clear [h'] ]. -Ltac2 rec li_to_speclist_SGUntilNum (li: int list): constr := - match li with - [] => constr:(@nil spec_arg) - | i :: l' => - let cl := li_to_speclist_SGUntilNum l' in - let ci := int_to_constr_nat i in - constr:(cons (SubGoalUntilNum $ci) $cl) - end. -Ltac2 rec li_to_speclist_EVAtName (li: ident list): constr := - match li with - [] => constr:(@nil spec_arg) - | i :: l' => - let cl := li_to_speclist_EVAtName l' in - let istr := Ident.to_string i in - let icstr := IdentParsing.coq_string_of_string istr in - constr:(cons (EvarAtName $icstr $icstr) $cl) - end. -(* Ltac2 occurrences_to_evaratname (li:ident list): constr := li_to_speclist_EVAtName li. *) +Local Ltac2 sgatnum_from_lint (li:int list): numarg list := + List.map (fun i => SubGoalAtNum i) li. -Ltac2 espec_at_using_ltac1_gen (h:constr) (li:int list) (occsevar:ident list) (newH: ident) (replaceb:bool):unit := - (* FIXME: we should also refuse when a section variables is given. *) +Local Ltac2 evatname_from_lid (li:ident list): namearg list := + List.map (fun i => EvarAtName i i) li. + +(* FIXME li should really be a single int *) +Local Ltac2 sguntilnum_from_lid (li:int list): numarg list := + List.map (fun i => SubGoalUntilNum i) li. + +Local Ltac2 espec_at_using_ltac1_gen (h:constr) (li:int list) (occsevar:ident list) (newH: ident) (replaceb:bool):unit := if Bool.and (Bool.neg (is_var h)) replaceb - then - Control.zero (Tactic_failure (Some (fprintf "You must provide a name with 'as'."))) - else - let c1 := li_to_speclist_SGAtNum li in - let c2 := li_to_speclist_EVAtName occsevar in - (* let c := Std.eval_red constr:(List.app $c2 $c1) in *) - let replaceb := if replaceb then constr:(true) else constr:(false) in - ltac1:(h c2 c1 newH replaceb |- espec_gen h c2 c1 newH replaceb) - (Ltac1.of_constr h) - (Ltac1.of_constr c2) - (Ltac1.of_constr c1) - (Ltac1.of_ident newH) - (Ltac1.of_constr replaceb). - -Ltac2 espec_until_using_ltac1_gen (h:constr) (li:int list) (occsevar:ident list) (newH: ident) (replaceb:bool) (atAll:bool):unit := + then Control.zero (Tactic_failure (Some (fprintf "You must provide a name with 'as'."))) + else espec_gen h (evatname_from_lid occsevar) (sgatnum_from_lint li) newH replaceb. + +Local Ltac2 espec_until_using_ltac1_gen (h:constr) (li:int list) (occsevar:ident list) (newH: ident) (replaceb:bool) (atAll:bool):unit := (* FIXME: we should also refuse when a section variables is given. *) if Bool.and (Bool.neg (is_var h)) replaceb then Control.zero (Tactic_failure (Some (fprintf "You must provide a name with 'as'."))) else - let c1 := if atAll then constr:(cons SubGoalAtAll nil) else li_to_speclist_SGUntilNum li in - let c2 := li_to_speclist_EVAtName occsevar in - (* let c := Std.eval_red constr:(List.app $c2 $c1) in *) - let replaceb := if replaceb then constr:(true) else constr:(false) in - ltac1:(h c2 c1 newH replaceb |- espec_gen h c2 c1 newH replaceb) - (Ltac1.of_constr h) - (Ltac1.of_constr c2) - (Ltac1.of_constr c1) - (Ltac1.of_ident newH) - (Ltac1.of_constr replaceb). - -Ltac2 interp_ltac1_id_list (lid:Ltac1.t) : ident list := - List.map (fun x => Option.get (Ltac1.to_ident x)) (Option.get (Ltac1.to_list lid)). - -Ltac2 interp_ltac1_int_list (li:Ltac1.t) : int list := - List.map (fun x => Option.get (Ltac1.to_int x)) (Option.get (Ltac1.to_list li)). - -Ltac2 interp_ltac1_hyp (h:Ltac1.t) : constr := Option.get (Ltac1.to_constr h). - -(* let t:constr option := Ltac1.to_constr li in - match t with - Some x => if Constr.equal x constr:(SubGoalAtAll) - then constr:(cons SubGoalAtAll nil) - else Control.zero (Tactic_failure (Some (fprintf "bad at specification."))) - - | _ => [] - end - *) -(* call Ltac2'especialize on argscoming from Ltac1 notation *) -Ltac2 call_specialize_ltac2_gen (h:Ltac1.t) (li:Ltac1.t) levars newh (replaceb:bool) := - let li2 := match Ltac1.to_list li with - None => [] - | Some _ => interp_ltac1_int_list li - end in - let levar2 := match Ltac1.to_list levars with - None => [] - | Some _ => interp_ltac1_id_list levars - end in - espec_at_using_ltac1_gen - (interp_ltac1_hyp h) - li2 - levar2 - (Option.get (Ltac1.to_ident newh)) - replaceb. + let c1 := if atAll then [SubGoalAtAll] else sguntilnum_from_lid li in + espec_gen h (evatname_from_lid occsevar) c1 newH replaceb. + +(* Create a new subgoal, based ont the ith dependent premise of h. + named newH. Creating occsevar on the fly.*) +Local Ltac2 eprem_at_using_ltac1_gen (h:constr) (i:int) (occsevar:ident list) (newH: ident):unit := + let lid' := evatname_from_lid occsevar in + epremis_gen h lid' (SubGoalAtNum i) newH. + + +Local Ltac2 interp_ltac1_id_list (lid:Ltac1.t list) : ident list := + List.map (fun x => Option.get (Ltac1.to_ident x)) lid. + +Local Ltac2 interp_ltac1_int_list (li:Ltac1.t list) : int list := + List.map (fun x => Option.get (Ltac1.to_int x)) li. +Local Ltac2 interp_ltac1_hyp (h:Ltac1.t) : constr := Option.get (Ltac1.to_constr h). + +Local Ltac2 default := Option.default. (* call Ltac2'especialize on argscoming from Ltac1 notation *) +Local Ltac2 call_specialize_ltac2_gen (h:Ltac1.t) (li:Ltac1.t) levars newh (replaceb:bool) := + let li2 := interp_ltac1_int_list (default [] (Ltac1.to_list li)) in + let levar2 := interp_ltac1_id_list (default [] (Ltac1.to_list levars)) in + let nme := Option.get (Ltac1.to_ident newh) in + espec_at_using_ltac1_gen (interp_ltac1_hyp h) li2 levar2 nme replaceb. -Ltac2 call_specialize_until_ltac2_gen (h:Ltac1.t) li levars newh replaceb (atAll:bool) := - let li2 := match Ltac1.to_list li with - None => [] - | Some _ => interp_ltac1_int_list li - end in - let levar2 := match Ltac1.to_list levars with - None => [] - | Some _ => interp_ltac1_id_list levars - end in +(* call Ltac2'especialize on argscoming from Ltac1 notation *) + +Local Ltac2 call_specialize_until_ltac2_gen (h:Ltac1.t) li levars newh replaceb (atAll:bool) := + let li2 := interp_ltac1_int_list (default [] (Ltac1.to_list li)) in + let levar2 := interp_ltac1_id_list (default [] (Ltac1.to_list levars)) in if Int.gt (List.length li2) 1 then - (* msgi (List.length li'); *) - Control.zero (Tactic_failure (Some (fprintf "In 'specialize X until I', I must be a singleton."))) + Control.zero (Tactic_failure + (Some (fprintf "In 'specialize X until I', I must be a singleton."))) else - espec_until_using_ltac1_gen (interp_ltac1_hyp h) li2 levar2 - (Option.get (Ltac1.to_ident newh)) replaceb atAll. - + let nme := Option.get (Ltac1.to_ident newh) in + espec_until_using_ltac1_gen (interp_ltac1_hyp h) li2 levar2 nme replaceb atAll. +(* +Local Ltac2 call_premise_ltac2_gen (h:Ltac1.t) (i:Ltac1.t) levars (newh:Ltac1.t) := + let i2 := Option.get (Ltac1.to_int i) in + let levar2 := interp_ltac1_id_list (default [] (Ltac1.to_list levars)) in + match Ltac1.to_ident newh with + | None => Control.zero (Tactic_failure (Some (fprintf "You must provide a name with 'as'."))) + | Some newh2 => eprem_at_using_ltac1_gen (interp_ltac1_hyp h) i2 levar2 newh2 + end.*) + +(* Create a new subgoal, based ont the ith dependent premise of h, + named newh, creating levars on the fly.. *) +Local Ltac2 call_premise_ltac2_gen (h:Ltac1.t) (i:Ltac1.t) levars (newh:Ltac1.t) := + let i2 := Option.get (Ltac1.to_int i) in + let levar2 := interp_ltac1_id_list (default [] (Ltac1.to_list levars)) in + let newh2 := Option.default (Fresh.in_goal @H) (Ltac1.to_ident newh) in + eprem_at_using_ltac1_gen (interp_ltac1_hyp h) i2 levar2 newh2. Ltac gen_hyp_name h := match goal with | |- _ => let _ := is_var h in fresh h "_spec_" @@ -560,6 +492,83 @@ Ltac gen_hyp_name h := match goal with end. Ltac dummy_term := constr:(Prop). +(* TODO only one integer, + evars + as => create a subgoal that wioll + be added as hyp, h is not specialized. Since a new hyp is created, + the "as" field is mandatory. *) + +Tactic Notation "assert" "premise" int(n) "of" constr(h) "with" ne_ident_list_sep(levars,",") "as" ident(newH) := + let tac := ltac2:(h n levars newH |- call_premise_ltac2_gen h n levars newH) in + tac h n levars newH. + +Tactic Notation "assert" "premise" int(n) "of" constr(h) "as" ident(newH) := + let tac := ltac2:(h n levars newH |- call_premise_ltac2_gen h n levars newH) in + let levars := dummy_term in (* something that is not a list. *) + tac h n levars newH. + +(* Explicitely asking for a autogen name, this is discouraged unless + you use another naming mechanism e.g. LibHyps's "/n" tactical. *) +Tactic Notation "assert" "premise" int(n) "of" constr(h) "with" ne_ident_list_sep(levars,",") "as" "?" := + let tac := ltac2:(h n levars newH |- call_premise_ltac2_gen h n levars newH) in + let newH := fresh "HHH" in + tac h n levars newH. + +Tactic Notation "assert" "premise" int(n) "of" constr(h) "as" "?" := + let tac := ltac2:(h n levars newH |- call_premise_ltac2_gen h n levars newH) in + let levars := dummy_term in (* something that is not a list. *) + let newH := fresh "HHH" in + tac h n levars newH. + +(* VERSION WITHOUT "AS". Should it be forbidden? *) +(* TODO only one integer, + evars + as => create a subgoal that wioll be added as hyp, h is not specialized *) +Tactic Notation "assert" "premise" int(n) "of" constr(h) "with" ne_ident_list_sep(levars,",") := + let tac := ltac2:(h n levars newH |- call_premise_ltac2_gen h n levars newH) in + let newH := dummy_term in + tac h n levars newH. + +Tactic Notation "assert" "premise" int(n) "of" constr(h) := + let tac := ltac2:(h n levars newH |- call_premise_ltac2_gen h n levars newH) in + let levars := dummy_term in (* something that is not a list. *) + let newH := dummy_term in + tac h n levars newH. + + + +(* +Ltac2 foo () := + let h' := Fresh.in_goal @H in + printf "%I" h'. + +Definition eq_one (i:nat) := i = 1. +Definition hidden_product := forall i j :nat, i+1=j -> i+1=j -> i+1=j. + +Axiom ex_hyp : (forall (b:bool), forall x: nat, eq_one 1 -> forall y:nat, eq_one 2 ->eq_one 3 ->eq_one 4 ->eq_one x ->eq_one 6 ->eq_one y -> eq_one 8 -> eq_one 9 -> False). + +Require Import Arith ZArith List. + +Lemma test_espec_namings: forall n:nat, (forall m:nat, eq_one n -> eq_one 1 -> eq_one m -> False) -> True. +Proof. + intros n h_premis. + specialize Nat.quadmul_le_squareadd as hle. + + Check Nat.quadmul_le_squareadd. + assert premise 1 of Nat.quadmul_le_squareadd with a as h. + { apply OrdersEx.Nat_as_OT.le_0_1. } + + Undo 4. + assert premise 1 of Nat.quadmul_le_squareadd with a as ?. + { apply OrdersEx.Nat_as_OT.le_0_1. } + + Undo 4. + assert premise 1 of Nat.quadmul_le_squareadd as h. + { apply OrdersEx.Nat_as_OT.le_0_l. } + + Undo 4. + assert premise 1 of Nat.quadmul_le_squareadd as ?. + { apply OrdersEx.Nat_as_OT.le_0_l. } + + Undo 4. + +*) (* ESPECIALIZE AT *) (* ********************* *) @@ -751,6 +760,224 @@ Tactic Notation "especialize" constr(h) "until" ne_integer_list_sep(li,",") := + +(* +(* tests *) +Definition eq_one (i:nat) := i = 1. +Definition hidden_product := forall i j :nat, i+1=j -> i+1=j -> i+1=j. + +Axiom ex_hyp : (forall (b:bool), forall x: nat, eq_one 1 -> forall y:nat, eq_one 2 ->eq_one 3 ->eq_one 4 ->eq_one x ->eq_one 6 ->eq_one y -> eq_one 8 -> eq_one 9 -> False). + + +Lemma test_espec_namings: forall n:nat, (eq_one n -> eq_one 1 -> False) -> True. +Proof. + intros n h_eqone. + specialize min_l as hhh. + ltac2:(espec_at_using_ltac1_gen constr:(hhh) [1] [@n; @m] @hhh' false). + + let tac := ltac2:(hhh |- call_specialize_ltac2_gen hhh [1] [@n; @m] hhh' false) in + tac hhh. + let tac := ltac2:(h li levars newH |- call_specialize_ltac2_gen h li levars newH false) in + let newH := gen_hyp_name hhh in + tac hhh li levars ident:(newH). + + especialize hhh with n,m at 1 as ?. + especialize min_l with n,m at 1 as ?. + + +Lemma foo: forall x y : nat, + (forall (n m p :nat) (hhh:n < m) (iii:n <= m), + p > 0 + -> p > 2 + -> p > 1 + -> hidden_product) -> False. +Proof. + intros x y H. + + ltac2:(espec_at_using_ltac1_gen constr:(H) [2;4] [@m; @p] @toto false). + Undo 1. + ltac2:(espec_at_using_ltac1_gen constr:(H) [2;4] [@m; @p] @toto true). + Undo 1. + ltac2:(espec_until_using_ltac1_gen constr:(H) [] [@m] @toto false true). + Undo 1. + ltac2:(espec_until_using_ltac1_gen constr:(H) [] [@m] @toto true true). + Undo 1. + ltac2:(espec_until_using_ltac1_gen constr:(H) [3] [@m] @toto false false). + Undo 1. + ltac2:(espec_until_using_ltac1_gen constr:(H) [3] [@m] @toto true false). + Undo 1. + ltac2:(espec_until_using_ltac1_gen constr:(H) [4] [@n ; @m] @toto false false). + Undo 1. + ltac2:(espec_until_using_ltac1_gen constr:(H) [4] [@n ; @m] @toto true false). + Undo 1. +*) + + +(* TEST *) +(* +Definition eq_one (i:nat) := i = 1. +Definition hidden_product := forall i j :nat, i+1=j -> i+1=j -> i+1=j. + +Axiom ex_hyp : (forall (b:bool), forall x: nat, eq_one 1 -> forall y:nat, eq_one 2 ->eq_one 3 ->eq_one 4 ->eq_one x ->eq_one 6 ->eq_one y -> eq_one 8 -> eq_one 9 -> False). + + +Lemma test_espec_namings: forall n:nat, (forall m:nat, eq_one n -> eq_one 1 -> eq_one m -> False) -> True. +Proof. + intros n h_eqone. + ltac2: + prove_premise h_eqone with m at 3 as hhhh. + { admit. } + Undo 4. + prove_premise h_eqone at 3 with m as hhhh. + { admit. } + Undo 4. + prove_premise h_eqone at 3 as hhh. + { admit. } + Undo 4. + prove_premise h_eqone with m at 3. + { admit. } + Undo 4. + prove_premise h_eqone at 3 with m. + { admit. } + Undo 4. + prove_premise h_eqone at 3. + { admit. } + Undo 4. + + + + + +*) + + +(* TEST *) + +(* +(* tests *) +Definition eq_one (i:nat) := i = 1. +Definition hidden_product := forall i j :nat, i+1=j -> i+1=j -> i+1=j. + +Lemma foo: forall x y : nat, + (forall (n m p :nat) (hhh:n < m) (iii:n <= m), + p > 0 + -> p > 2 + -> p > 1 + -> hidden_product) -> False. +Proof. + intros x y H. + + ltac2:(espec_gen constr:(H) [EvarAtName @m @m] [SubGoalAtAll] @toto false). + Undo 1. + ltac2:(espec_gen constr:(H) [EvarAtName @m @m] [SubGoalAtAll] @toto true). + Undo 1. + ltac2:(espec_gen constr:(H) [EvarAtName @m @m] [SubGoalUntilNum 3] @toto false). + 4:let ttoto := type of toto in + match ttoto with + | nat -> forall p : nat, p > 2 -> p > 1 -> hidden_product => idtac + end. + Undo 2. + ltac2:(espec_gen constr:(H) [EvarAtName @m @m] [SubGoalUntilNum 3] @toto true). + Undo 1. + ltac2:(espec_gen constr:(H) [EvarAtName @m @m] [SubGoalAtAll] @toto false). + Undo 1. + ltac2:(espec_gen constr:(H) [EvarAtName @n @n; EvarAtName @m @m] [SubGoalAtNum 4] @toto false). + Undo 1. + ltac2:(espec_gen constr:(H) [EvarAtName @n @n; EvarAtName @m @m] [SubGoalAtNum 4] @toto true). + Undo 1. + + ltac2:(epremis_gen constr:(H) [EvarAtName @m @m] [SubGoalAtAll] @toto). + 2:let ttoto := type of toto in + match ttoto with + | (forall n : nat, nat -> n < _) => idtac + end. + Undo 2. + + ltac2:(epremis_gen constr:(H) [EvarAtName @m @m] [SubGoalUntilNum 3] @toto). + 2:{ + Undo 1. + ltac2:(epremis_gen constr:(H) [EvarAtName @m @m] [SubGoalUntilNum 3] @toto true). + Undo 1. + ltac2:(epremis_gen constr:(H) [EvarAtName @m @m] [SubGoalAtAll] @toto false). + Undo 1. + ltac2:(epremis_gen constr:(H) [EvarAtName @n @n; EvarAtName @m @m] [SubGoalAtNum 4] @toto false). + Undo 1. + ltac2:(epremis_gen constr:(H) [EvarAtName @n @n; EvarAtName @m @m] [SubGoalAtNum 4] @toto true). + Undo 1. + +*) + +(* +Definition eq_one (i:nat) := i = 1. +Definition hidden_product := forall i j :nat, i+1=j -> i+1=j -> i+1=j. + +Axiom ex_hyp : (forall (b:bool), forall x: nat, eq_one 1 -> forall y:nat, eq_one 2 ->eq_one 3 ->eq_one 4 ->eq_one x ->eq_one 6 ->eq_one y -> eq_one 8 -> eq_one 9 -> False). + + +Lemma test_espec_namings: forall n:nat, (forall m:nat, eq_one n -> eq_one 1 -> eq_one m -> False) -> True. +Proof. + intros n h_eqone. + prove_premise h_eqone with m at 3 as h. + { admit. } + Undo 4. + prove_premise h_eqone at 3 as h. + { admit. } + Undo 4. + especialize h_eqone with m at 3. + { admit. } + Undo 4. + + + specialize h_eqone with (1:=h). + prove_premise h_eqone with m at 1 as h. + { admit. } + specialize h_eqone with (1:=h). +*) + + + +(* +(* tests *) +Definition eq_one (i:nat) := i = 1. +Definition hidden_product := forall i j :nat, i+1=j -> i+1=j -> i+1=j. + + +Lemma foo: forall x y : nat, + (forall (n m p :nat) (hhh:n < m) (iii:n <= m), + p > 0 + -> p > 2 + -> p > 1 + -> hidden_product) -> False. +Proof. + intros x y H. + + especialize H with m,p at * as toto. + Undo 1. + especialize H with m,p until 3 as toto. + Undo. + (* evar names must be given in order. *) + Fail especialize H with p,m at 2,4 as toto. + + ltac2:(espec_at_using_ltac1_gen constr:(H) [2;4] [@m; @p] @toto false). + Undo 1. + ltac2:(espec_at_using_ltac1_gen constr:(H) [2;4] [@m; @p] @toto true). + Undo 1. + ltac2:(espec_until_using_ltac1_gen constr:(H) [] [@m] @toto false true). + Undo 1. + ltac2:(espec_until_using_ltac1_gen constr:(H) [] [@m] @toto true true). + Undo 1. + ltac2:(espec_until_using_ltac1_gen constr:(H) [3] [@m] @toto false false). + Undo 1. + ltac2:(espec_until_using_ltac1_gen constr:(H) [3] [@m] @toto true false). + Undo 1. + ltac2:(espec_until_using_ltac1_gen constr:(H) [4] [@n ; @m] @toto false false). + Undo 1. + ltac2:(espec_until_using_ltac1_gen constr:(H) [4] [@n ; @m] @toto true false). + Undo 1. + + +*) + (* Experimenting a small set of tactic to manipulate a hyp: *) (* Ltac quantify H := @@ -789,7 +1016,7 @@ Abort. *) - +(* (* tests *) Definition eq_one (i:nat) := i = 1. Definition hidden_product := forall i j :nat, i+1=j -> i+1=j -> i+1=j. @@ -820,3 +1047,39 @@ Lemma foo: forall x y : nat, Proof. intros x y H. Abort. + + +Axiom ex_hyp : (forall (b:bool), forall x: nat, eq_one 1 -> forall y:nat, eq_one 2 ->eq_one 3 ->eq_one 4 ->eq_one x ->eq_one 6 ->eq_one y -> eq_one 8 -> eq_one 9 -> False). + +Lemma test_esepec: True. +Proof. + (* specialize ex_hyp as h. *) + (* especialize ex_hyp at 2 as h. *) + + especialize ex_hyp at 3 with b,x,y as h;[ .. | match type of h with eq_one 1 -> eq_one 3 -> eq_one 4 -> eq_one _ -> eq_one 6 -> eq_one _ -> eq_one 8 -> eq_one 9 -> False => idtac end]. + Undo. +Abort. + +Lemma test_espec_namings: forall n:nat, (eq_one n -> eq_one 1 -> False) -> True. +Proof. + intros n h_eqone. + especialize min_l with n,m at 1 as ?. + (* especialize PeanOant.Nat.quadmul_le_squareadd with a at 1 as hh : h. *) + especialize PeanoNat.Nat.quadmul_le_squareadd with a at 1 as hh. + { apply le_n. } + specialize min_l as hhh. + especialize hhh with n,m at 1 as ?. + especialize min_l with n,m at 1 as ?. + { apply (le_n O). } + especialize h_eqone at 2 as h1. + { reflexivity. } + unfold eq_one in min_l_spec_. + (* match type of h2 with 1 = 1 => idtac | _ => fail end. *) + match type of h1 with eq_one n -> False => idtac | _ => fail end. + exact I. +Qed. + + + + +*) diff --git a/LibHyps/IdentParsing.v b/LibHyps/IdentParsing.v deleted file mode 100644 index 1e9ec5d..0000000 --- a/LibHyps/IdentParsing.v +++ /dev/null @@ -1,276 +0,0 @@ -(*! Frontend | Ltac2-based identifier parsing for prettier notations !*) -From Stdlib Require Import NArith.NArith Strings.String Init.Byte. -Require Import Ltac2.Ltac2. - -Import Ltac2.Init. -Import Ltac2.Notations. - -Import Lists.List.ListNotations. -Open Scope list. - -Ltac2 compute c := - Std.eval_vm None c. - -Ltac2 rec array_blit_list pos ls arr := - match ls with - | [] => () - | h :: ls => Array.set arr pos h; array_blit_list (Int.add pos 1) ls arr - end. - -Ltac2 array_of_list default len ls := - let arr := Array.make len default in - array_blit_list 0 ls arr; - arr. - -Module Safe. - Ltac2 string_to_coq_list type coq_of_char s := - let rec to_list acc pos := - match Int.equal pos 0 with - | true => acc - | false => - let pos := Int.sub pos 1 in - let b := coq_of_char (String.get s pos) in - to_list (constr:(List.cons $b $acc)) pos - end in - to_list (constr:(@List.nil $type)) (String.length s). - - Ltac2 coq_string_of_string' coq_string_of_coq_list type coq_of_char s := - let bs := string_to_coq_list type coq_of_char s in - compute constr:($coq_string_of_coq_list $bs). -End Safe. - -Module Unsafe. - Module U := Ltac2.Constr.Unsafe. - - Ltac2 string_to_coq_list type coq_of_char s := - let cons := constr:(@cons) in - let dummy_constr := constr:(tt) in - let rec to_list acc pos := - match Int.equal pos 0 with - | true => acc - | false => - let pos := Int.sub pos 1 in - let b := coq_of_char (String.get s pos) in - to_list (U.make (U.App cons (array_of_list dummy_constr 3 [type; b; acc]))) pos - end in - match U.check (to_list constr:(@List.nil $type) (String.length s)) with - | Val v => v - | Err exn => Control.throw exn - end. - - Ltac2 coq_string_of_string' coq_string_of_coq_list type coq_of_char s := - let bs := string_to_coq_list type coq_of_char s in - compute constr:($coq_string_of_coq_list $bs). -End Unsafe. - -Import Unsafe. -(* -Module Linear. - (* char → int →[O(n)] N → ascii *) - - Ltac2 rec int_to_coq_N' n := - match Int.equal n 0 with - | true => constr:(N.zero) - | false => let n := int_to_coq_N' (Int.sub n 1) in - constr:(N.succ $n) - end. - - Ltac2 int_to_coq_N n := - let val := int_to_coq_N' n in - compute val. - - Definition string_of_list_N list_N := - String.string_of_list_ascii (List.map Ascii.ascii_of_N list_N). - - Ltac2 coq_string_of_string s := - coq_string_of_string' constr:(string_of_list_N) constr:(N) (fun c => int_to_coq_N (Char.to_int c)) s. -End Linear. -*) -(* -Module TestBits. - (* char → int →[O(log2 n)] N → list bits → _ *) - - Ltac2 int_gt n n' := - Int.equal (Int.compare n n') 1. - - Ltac2 rec bits_of_int' pow2s n := - match pow2s with - | [] => [] - | pow2 :: pow2s => - match int_gt pow2 n with - | true => false :: bits_of_int' pow2s n - | false => true :: bits_of_int' pow2s (Int.sub n pow2) - end - end. - - Ltac2 rec bits_of_char c := - bits_of_int' [128; 64; 32; 16; 8; 4; 2; 1] (Char.to_int c). - - Ltac2 list_pop fn l := - match l with - | [] => Control.throw Match_failure - | h :: t => (fn h, t) - end. - - Ltac2 coq_bool_of_bool b := - match b with - | true => constr:(true) - | false => constr:(false) - end. - - Ltac2 map_char_bits c fn := - let bs := bits_of_char c in - let (b0, bs) := list_pop coq_bool_of_bool bs in - let (b1, bs) := list_pop coq_bool_of_bool bs in - let (b2, bs) := list_pop coq_bool_of_bool bs in - let (b3, bs) := list_pop coq_bool_of_bool bs in - let (b4, bs) := list_pop coq_bool_of_bool bs in - let (b5, bs) := list_pop coq_bool_of_bool bs in - let (b6, bs) := list_pop coq_bool_of_bool bs in - let (b7, bs) := list_pop coq_bool_of_bool bs in - fn b7 b6 b5 b4 b3 b2 b1 b0. -End TestBits. -*) -(* -Module TestBitsBytes. - (* char → int →[O(log2 n)] byte *) - - Ltac2 coq_byte_of_char chr := - TestBits.map_char_bits - chr - (fun b7 b6 b5 b4 b3 b2 b1 b0 => - compute constr:(Byte.of_bits ($b7, ($b6, ($b5, ($b4, ($b3, ($b2, ($b1, $b0))))))))). - - Ltac2 coq_string_of_string s := - coq_string_of_string' constr:(string_of_list_byte) constr:(Byte.byte) coq_byte_of_char s. -End TestBitsBytes. -*) -(* -Module TestBitsAscii. - (* char → int →[O(log2 n)] ascii *) - - Ltac2 coq_ascii_of_char chr := - TestBits.map_char_bits - chr - (fun b7 b6 b5 b4 b3 b2 b1 b0 => - constr:(Ascii.Ascii $b0 $b1 $b2 $b3 $b4 $b5 $b6 $b7)). - - Ltac2 coq_string_of_string s := - coq_string_of_string' constr:(string_of_list_ascii) constr:(Ascii.ascii) coq_ascii_of_char s. -End TestBitsAscii. -*) -Module LookupTable. - (* char → int →[O(1)] byte *) - - Ltac2 bytes_list () := - [constr:(x00); constr:(x01); constr:(x02); constr:(x03) - ; constr:(x04); constr:(x05); constr:(x06); constr:(x07) - ; constr:(x08); constr:(x09); constr:(x0a); constr:(x0b) - ; constr:(x0c); constr:(x0d); constr:(x0e); constr:(x0f) - ; constr:(x10); constr:(x11); constr:(x12); constr:(x13) - ; constr:(x14); constr:(x15); constr:(x16); constr:(x17) - ; constr:(x18); constr:(x19); constr:(x1a); constr:(x1b) - ; constr:(x1c); constr:(x1d); constr:(x1e); constr:(x1f) - ; constr:(x20); constr:(x21); constr:(x22); constr:(x23) - ; constr:(x24); constr:(x25); constr:(x26); constr:(x27) - ; constr:(x28); constr:(x29); constr:(x2a); constr:(x2b) - ; constr:(x2c); constr:(x2d); constr:(x2e); constr:(x2f) - ; constr:(x30); constr:(x31); constr:(x32); constr:(x33) - ; constr:(x34); constr:(x35); constr:(x36); constr:(x37) - ; constr:(x38); constr:(x39); constr:(x3a); constr:(x3b) - ; constr:(x3c); constr:(x3d); constr:(x3e); constr:(x3f) - ; constr:(x40); constr:(x41); constr:(x42); constr:(x43) - ; constr:(x44); constr:(x45); constr:(x46); constr:(x47) - ; constr:(x48); constr:(x49); constr:(x4a); constr:(x4b) - ; constr:(x4c); constr:(x4d); constr:(x4e); constr:(x4f) - ; constr:(x50); constr:(x51); constr:(x52); constr:(x53) - ; constr:(x54); constr:(x55); constr:(x56); constr:(x57) - ; constr:(x58); constr:(x59); constr:(x5a); constr:(x5b) - ; constr:(x5c); constr:(x5d); constr:(x5e); constr:(x5f) - ; constr:(x60); constr:(x61); constr:(x62); constr:(x63) - ; constr:(x64); constr:(x65); constr:(x66); constr:(x67) - ; constr:(x68); constr:(x69); constr:(x6a); constr:(x6b) - ; constr:(x6c); constr:(x6d); constr:(x6e); constr:(x6f) - ; constr:(x70); constr:(x71); constr:(x72); constr:(x73) - ; constr:(x74); constr:(x75); constr:(x76); constr:(x77) - ; constr:(x78); constr:(x79); constr:(x7a); constr:(x7b) - ; constr:(x7c); constr:(x7d); constr:(x7e); constr:(x7f) - ; constr:(x80); constr:(x81); constr:(x82); constr:(x83) - ; constr:(x84); constr:(x85); constr:(x86); constr:(x87) - ; constr:(x88); constr:(x89); constr:(x8a); constr:(x8b) - ; constr:(x8c); constr:(x8d); constr:(x8e); constr:(x8f) - ; constr:(x90); constr:(x91); constr:(x92); constr:(x93) - ; constr:(x94); constr:(x95); constr:(x96); constr:(x97) - ; constr:(x98); constr:(x99); constr:(x9a); constr:(x9b) - ; constr:(x9c); constr:(x9d); constr:(x9e); constr:(x9f) - ; constr:(xa0); constr:(xa1); constr:(xa2); constr:(xa3) - ; constr:(xa4); constr:(xa5); constr:(xa6); constr:(xa7) - ; constr:(xa8); constr:(xa9); constr:(xaa); constr:(xab) - ; constr:(xac); constr:(xad); constr:(xae); constr:(xaf) - ; constr:(xb0); constr:(xb1); constr:(xb2); constr:(xb3) - ; constr:(xb4); constr:(xb5); constr:(xb6); constr:(xb7) - ; constr:(xb8); constr:(xb9); constr:(xba); constr:(xbb) - ; constr:(xbc); constr:(xbd); constr:(xbe); constr:(xbf) - ; constr:(xc0); constr:(xc1); constr:(xc2); constr:(xc3) - ; constr:(xc4); constr:(xc5); constr:(xc6); constr:(xc7) - ; constr:(xc8); constr:(xc9); constr:(xca); constr:(xcb) - ; constr:(xcc); constr:(xcd); constr:(xce); constr:(xcf) - ; constr:(xd0); constr:(xd1); constr:(xd2); constr:(xd3) - ; constr:(xd4); constr:(xd5); constr:(xd6); constr:(xd7) - ; constr:(xd8); constr:(xd9); constr:(xda); constr:(xdb) - ; constr:(xdc); constr:(xdd); constr:(xde); constr:(xdf) - ; constr:(xe0); constr:(xe1); constr:(xe2); constr:(xe3) - ; constr:(xe4); constr:(xe5); constr:(xe6); constr:(xe7) - ; constr:(xe8); constr:(xe9); constr:(xea); constr:(xeb) - ; constr:(xec); constr:(xed); constr:(xee); constr:(xef) - ; constr:(xf0); constr:(xf1); constr:(xf2); constr:(xf3) - ; constr:(xf4); constr:(xf5); constr:(xf6); constr:(xf7) - ; constr:(xf8); constr:(xf9); constr:(xfa); constr:(xfb) - ; constr:(xfc); constr:(xfd); constr:(xfe); constr:(xff)]. - - Ltac2 bytes_table () := - array_of_list constr:(Byte.x00) 256 (bytes_list ()). - - Ltac2 byte_of_char bytes_table chr := - Array.get bytes_table (Char.to_int chr). - - Ltac2 coq_string_of_string s := - let table := bytes_table () in - coq_string_of_string' constr:(string_of_list_byte) constr:(Byte.byte) (byte_of_char table) s. -End LookupTable. - -Ltac2 coq_string_of_string := LookupTable.coq_string_of_string. -Ltac2 coq_string_of_ident x := LookupTable.coq_string_of_string (Ident.to_string x). - -Ltac2 Type exn ::= [ NoIdentInContext ]. - -Module TacInTerm. - (* This is the original implementation, as described in the CoqPL'21 paper. *) - Definition __Ltac2_MarkedIdent (A: Type) := A. - - Ltac serialize_ident_in_context := - ltac2:(match! goal with - | [ h: __Ltac2_MarkedIdent _ |- _ ] => - let coq_string := coq_string_of_ident h in - exact ($coq_string) - | [ |- _ ] => Control.throw NoIdentInContext - end). - - (* `binder_to_string` is useful when converting an identifier to a string but - also using it as an actual binder. *) - Notation binder_to_string body a := - (match (body: __Ltac2_MarkedIdent _) return string with - | a => ltac:(serialize_ident_in_context) - end) (only parsing). - - Notation ident_to_string a := - (binder_to_string true a) (only parsing). -End TacInTerm. - -Notation ident_to_string a := - (TacInTerm.ident_to_string a) (only parsing). - -Notation binder_to_string body a := - (TacInTerm.binder_to_string body a) (only parsing). - - diff --git a/LibHyps/LibDecomp.v b/LibHyps/LibDecomp.v deleted file mode 100644 index a3914f5..0000000 --- a/LibHyps/LibDecomp.v +++ /dev/null @@ -1,47 +0,0 @@ -(* Copyright 2021 Pierre Courtieu - This file is part of LibHyps. It is distributed under the MIT - "expat license". You should have recieved a LICENSE file with it. *) - -(** ** A specific variant of decompose. Which decomposes all logical connectives. *) - -Ltac decomp_logicals h := - idtac;match type of h with - | @ex _ (fun x => _) => let x' := fresh x in let h1 := fresh in destruct h as [x' h1]; decomp_logicals h1 - | @sig _ (fun x => _) => let x' := fresh x in let h1 := fresh in destruct h as [x' h1]; decomp_logicals h1 - | @sig2 _ (fun x => _) (fun _ => _) => let x' := fresh x in - let h1 := fresh in - let h2 := fresh in - destruct h as [x' h1 h2]; - decomp_logicals h1; - decomp_logicals h2 - | @sigT _ (fun x => _) => let x' := fresh x in let h1 := fresh in destruct h as [x' h1]; decomp_logicals h1 - | @sigT2 _ (fun x => _) (fun _ => _) => let x' := fresh x in - let h1 := fresh in - let h2 := fresh in - destruct h as [x' h1 h2]; decomp_logicals h1; decomp_logicals h2 - | and _ _ => let h1 := fresh in let h2 := fresh in destruct h as [h1 h2]; decomp_logicals h1; decomp_logicals h2 - | iff _ _ => let h1 := fresh in let h2 := fresh in destruct h as [h1 h2]; decomp_logicals h1; decomp_logicals h2 - | or _ _ => let h' := fresh in destruct h as [h' | h']; [decomp_logicals h' | decomp_logicals h' ] - | _ => idtac - end. - -(* -Lemma foo: (IF_then_else False True False) -> False. -Proof. - intros H. - decomp_logicals H. -Admitted. - -Lemma foo2 : { aa:False & True } -> False. -Proof. - intros H. - decomp_logicals H. -Admitted. - - -Lemma foo3 : { aa:False & True & False } -> False. -Proof. - intros H. - decomp_logicals H. -Abort. -*) diff --git a/LibHyps/LibEspecialize.v b/LibHyps/LibEspecialize.v deleted file mode 100644 index d4a1d9a..0000000 --- a/LibHyps/LibEspecialize.v +++ /dev/null @@ -1,664 +0,0 @@ - -Require Import LibHyps.LibHypsTactics. - -(* debug *) -Module Prgoal_Notation. - Ltac pr_goal := - match goal with - |- ?g => - let allh := harvest_hyps revert_clearbody_all in - (* let allh := all_hyps in *) - idtac allh " ⊢ " g - end. -End Prgoal_Notation. - -Require Import Arith. -(* The tactics in this file use the folowing pattern, that consists in - refining a new evar goal until being in the right scope to prove - the premise. *) -(* -Lemma foo: forall x y : nat, (forall n m p :nat, n < m -> n <= m -> p > 0 -> False) -> False. -Proof. - intros x y H. - (* On veut prouver le n <= m comme conséquence du n < m dans H. *) - (* On crée un but dont le type n'est pas connu, et on raffine pour - être dans le bon environnement. *) - - assert (forall n m p : nat, n < m -> n <= m). - { admit. } - pose proof (fun (n m p : nat) (h:n < m) => (H n m p h (H0 n m p h))). - - let ev := open_constr:(_) in - assert (ev) as h. - { refine (fun (n m p:nat) (h:n < m) => _). - assert(n <= m) as hhyp. - { now apply Nat.lt_le_incl. } - exact(H n m p h hhyp). } - (* Voilà! *) -Admitted. -*) - -(* Describing how each arg of a hypothesis must be treated: either - requantify it, or evarize it, or requantify but don't use it in - premise proofs (not sure this is needed) finally make it a subgoal. - We don't use list for cosmetic reasons: no need for nil (since the - list is non empty). *) -Inductive spec_args : Type := - ConsQuantif: spec_args -> spec_args (* re-quantify *) -| ConsEvar: spec_args -> spec_args (* make it an evar *) -| ConsIgnore: spec_args -> spec_args (* gnore it (useless?) *) -| ConsSubGoal: spec_args -> spec_args (* make it a subgoal *) -| SubGoalEnd: spec_args. (* make it a subgoal, end of list. *) - - -Inductive int_spec_args: Type := -| ConsEVAR: nat -> int_spec_args -> int_spec_args -| ConsGOAL: nat -> int_spec_args -> int_spec_args -| FinalGOAL: nat -> int_spec_args. - - -Declare Scope especialize_scope. -Delimit Scope especialize_scope with espec. -(* Local Open Scope especialize_scope. *) - -Declare Scope especialize_using_scope. -Delimit Scope especialize_using_scope with euspec. -(* Local Open Scope especialize_using_scope. *) - -Module SpecNotation. - - Infix "?::" := ConsEVAR (at level 60, right associativity) : especialize_scope. - Infix "#::" := ConsGOAL (at level 60, right associativity) : especialize_scope. - Notation "## X" := (FinalGOAL X) (at level 60) : especialize_scope. - - Notation "! X" := (ConsQuantif X) (at level 100) : especialize_using_scope. - Notation "? X" := (ConsEvar X) (at level 100) : especialize_using_scope. - Notation "# X" := (ConsSubGoal X) (at level 100) : especialize_using_scope. - Notation "##" := (SubGoalEnd) (at level 100) : especialize_using_scope. - - Ltac interp_num min l := - lazymatch l with - nil => fail - | FinalGOAL ?min' => - match min with - min' => constr:(SubGoalEnd) - | _ => - let lres := interp_num (S min) l in - constr:(ConsQuantif lres) - end - | ConsGOAL ?min' ?l' => - match min with - min' => - let lres := interp_num (S min) l' in - constr:(ConsSubGoal lres) - | _ => - let lres := interp_num (S min) l in - constr:(ConsQuantif lres) - end - | ConsEVAR ?min' ?l' => - match min with - min' => - let lres := interp_num (S min) l' in - constr:(ConsEvar lres) - | _ => - let lres := interp_num (S min) l in - constr:(ConsQuantif lres) - end - end. - -End SpecNotation. -Import SpecNotation. - - (* builds the application of c to each element of l (in reversed - order). apply t [t1;t2;t3] => (t t3 t2 t1) *) - Ltac list_apply c l := - match l with - DNil => c - | DCons _ ?x ?l' => - let inside := list_apply c l' in - let res := constr:(ltac:(exact (inside x))) in - res - end. - - Ltac refine_hd h largs := - match largs with - | SubGoalEnd => - match type of h with - | (forall x:?t, _) => - (* create the user subgoal *) - let x' := fresh x in - unshelve (evar(x':t); exact (h x')) - end - | ConsQuantif ?largs' => - match type of h with - | (forall x:?t, _) => - let x':= fresh x in - refine (fun x': t => _); - specialize (h x'); - refine_hd h largs' - end - (* Fallback to evar creation *) - (* | ConsQuantif ?largs' => refine_hd h (ConsEvar largs') *) - | ConsEvar ?largs' => - match type of h with - | (forall x:?t, _) => - let x' := fresh x in - evar(x':t); - specialize (h x'); - subst x'; - refine_hd h largs' - end - | ConsSubGoal ?largs' => - match type of h with - | (forall x:?t, _) => - let x' := fresh x in - unshelve (evar(x':t));[ - clear h - | specialize (h x'); - refine_hd h largs'] - end - end. - - - Ltac refine_premise_hd h largs := - match largs with - | SubGoalEnd => - match type of h with - | (forall x:?t, _) => - (* create the user subgoal *) - let x' := fresh x in - unshelve (evar(x':t); exact x') - end - | ConsQuantif ?largs' => - match type of h with - | (forall x:?t, _) => - let x':= fresh x in - refine (fun x': t => _); - specialize (h x'); - refine_premise_hd h largs' - end - (* Fallback to evar creation *) - (* | ConsQuantif ?largs' => refine_premise_hd h (ConsEvar largs') *) - | ConsEvar ?largs' => - match type of h with - | (forall x:?t, _) => - let x' := fresh x in - evar(x':t); - specialize (h x'); - subst x'; - refine_premise_hd h largs' - end - | ConsSubGoal ?largs' => - match type of h with - | (forall x:?t, _) => - let x' := fresh x in - unshelve (evar(x':t));[ - clear h - | specialize (h x'); - refine_premise_hd h largs'] - end - end. - - - (* Precondition: name is already fresh *) - Global Ltac espec_gen H l name := - (* morally this evar is of type Type, don't know how to enforce this - without having an ugly cast in goals *) - let ev1 := open_constr:(_) in - assert ev1 as name - ; [ - (refine_hd H l) - | ]. - - Global Ltac eprem_gen H l name := - (* morally this evar is of type Type, don't know how to enforce this - without having an ugly cast in goals *) - let ev1 := open_constr:(_) in - assert ev1 as name - ; [ - (refine_premise_hd H l) - | ]. - - - Ltac fresh_unfail H := - match constr:(True) with - | _ => fresh H - | _ => fresh "H_" - end. - Global Ltac especialize_clear H args := - (is_var H ; - let temp := fresh_unfail H in - espec_gen H args temp; [ .. | clear H; rename temp into H ]) - + ((assert_fails (is_var(H))) ; - let tempH := fresh_unfail H in - specialize H as tempH; - let temp := fresh_unfail H in - espec_gen tempH args temp). - - - Global Ltac especialize_named H args name := - (is_var H ; espec_gen H args name) - + ((assert_fails (is_var(H))) ; - let tempH := fresh_unfail H in - specialize H as tempH; - espec_gen tempH args name; - [ .. | clear tempH ]). - - Global Ltac epremise_named H args name := - (is_var H ; eprem_gen H args name) - + ((assert_fails (is_var(H))) ; - let tempH := fresh_unfail H in - specialize H as tempH; - eprem_gen tempH args name; - [ .. | clear tempH ]). - - - Global Ltac especialize_autoname H args := - let name := fresh_unfail H in - espec_gen H args name. - - Global Ltac especialize_clear_autoname H args := - let name := fresh_unfail H in - (* let name := fresh name "_inst" in *) - especialize_autoname H args name. - - - Tactic Notation "especialize" constr(H) "using" constr(specarg) "as" ident(idH) := - especialize_named H specarg idH. - - Tactic Notation "especialize" constr(H) "using" constr(specarg) := - especialize_clear H specarg. - - (* TODO *) - Tactic Notation "especialize" constr(H) "using" constr(specarg) ":" ident(hprem) := - especialize_clear H specarg. - - Tactic Notation "assert" "premises" constr(H) "at" constr(specarg) "as" ident(idH) := - let specarg' := SpecNotation.interp_num 1%nat specarg in - epremise_named H specarg' idH. - - - Tactic Notation "especialize" constr(H) "at" constr(specarg) "as" ident(idH) := - let specarg' := SpecNotation.interp_num 1%nat specarg in - especialize_named H specarg' idH. - - Tactic Notation "assert" "premises" constr(H) "at" constr(specarg) := - let specarg' := SpecNotation.interp_num 1%nat specarg in - let idH := fresh "Hprem" in - epremise_named H specarg' idH. - - Tactic Notation "especialize" constr(H) "at" constr(specarg) := - let specarg' := SpecNotation.interp_num 1%nat specarg in - especialize_clear H specarg'. - - (* TODO *) - Tactic Notation "especialize" constr(H) "at" constr(specarg) ":" ident(hprem) := - let specarg' := SpecNotation.interp_num 1%nat specarg in - especialize_clear H specarg'. - - - (* Tactic Notation "exploit" constr(H) "using" constr(specarg) "as" ident(idH) := *) - (* prove_premises H specarg idH. *) - - - - - Ltac check_var H := - (is_var(H)) - + (assert_fails(is_var(H)) - ; fail "the term " H "is not a hypothesis. To create a new hypothesis from it, please us 'as '. "). - - - - (* SPECIALIZE WITH EVAR(S) *) - (* Precondiion: H must already be a hyp at this point. *) - Ltac spec_evar H var_name := - check_var(H); - let idt := fresh var_name "T" in - let id := fresh var_name in - evar (idt : Type); - evar (id : idt); - specialize H with (var_name := id); subst id; subst idt. - - Tactic Notation "specevar" constr(H) "at" ident(i) "as" ident(newH) := - specialize H as newH; - spec_evar newH i. - - Tactic Notation "specevar" constr(H) "at" ident(i) "as" "?" := - let newH := fresh "H" in - specevar newH at i as newH. - - Ltac create_hyp_if_necessary H := - (assert_fails(is_var(H)); let newH := fresh_unfail H in specialize H as newH) - + idtac. - - - (* Without a name: duplicate only if c is not a hypothesis, otherwise - specialize directly on H *) - Tactic Notation "specevar" constr(c) "at" ident(i) := - create_hyp_if_necessary c; - spec_evar c i. - - - Definition eq_one (i:nat) := i = 1. -(* -Module Using. - -Local Open Scope especialize_using_scope. - -Lemma test_espec: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. -Proof. - intros x hx h_eqone. - (* specevar h_eqone at y. *) - especialize h_eqone using (? ? ! # ##). - + reflexivity. - + reflexivity. - + exfalso. - apply h_eqone with 0. - * reflexivity. - * symmetry. - assumption. -Qed. - -Lemma test_espec': forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. -Proof. - intros x hx h_eqone. - (* specevar h_eqone at y. *) - especialize h_eqone using (? ? ! # ##) as h_eqonetemp. - + reflexivity. - + reflexivity. - + exfalso. - apply h_eqonetemp with 0. - * reflexivity. - * symmetry. - assumption. -Qed. - - -Lemma test_espec2: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. -Proof. - intros x hx h_eqone. - (* specevar h_eqone at y. *) - especialize h_eqone using (! ? ! ! ##). - + reflexivity. - + exfalso. - apply h_eqone with 1 0. - * reflexivity. - * reflexivity. - * symmetry. - assumption. -Qed. - - -Lemma test_espec3: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. -Proof. - intros x hx h_eqone. - (* specevar h_eqone at y. *) - especialize h_eqone using (! ? ? ! ##). - + reflexivity. - + exfalso. - apply h_eqone with 1. - * reflexivity. - * instantiate (z:=0). reflexivity. - * symmetry. - assumption. -Qed. - - -Lemma test_espec4: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. -Proof. - intros x hx h_eqone. - (* specevar h_eqone at y. *) - especialize h_eqone using (? ? ? ! ##). - + reflexivity. - + exfalso. - apply h_eqone. - * reflexivity. - * instantiate (z:=0). reflexivity. - * symmetry. - assumption. -Qed. - -Lemma test_espec5: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. -Proof. - intros x hx h_eqone. - (* specevar h_eqone at y. *) - especialize h_eqone using (? ? ? ##). - + reflexivity. - + exfalso. - apply h_eqone. - * reflexivity. - * instantiate (z:=0). reflexivity. - * symmetry. - assumption. -Qed. - -Lemma test_espec6: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. -Proof. - intros x hx h_eqone. - (* specevar h_eqone at y. *) - especialize h_eqone using (? ! ! ##). - + reflexivity. - + exfalso. - apply h_eqone with 1 0. - * reflexivity. - * reflexivity. - * symmetry. - assumption. -Qed. - -Lemma test_espec7: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. -Proof. - intros x hx h_eqone. - (* specevar h_eqone at y. *) - especialize h_eqone using (? ! ? # ! ! ##). - + reflexivity. - + rewrite hx. - instantiate (z:=0). - reflexivity. - + exfalso. - apply h_eqone with 1. - * reflexivity. - * reflexivity. -Qed. - -Lemma test_espec8: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. -Proof. - intros x hx h_eqone. - (* specevar h_eqone at y. *) - especialize h_eqone using (? ! ! # ! ! ##). - + reflexivity. - + subst. - rewrite Nat.add_comm in x2. - cbn in x2. - injection x2;intro ;assumption. - + exfalso. - apply h_eqone with 1 0. - * reflexivity. - * reflexivity. -Qed. - -Lemma test_espec9: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. -Proof. - intros x hx h_eqone. - (* specevar h_eqone at y. *) - especialize h_eqone using (! ! ! # ! ! ##). - + subst. - Fail - (* this should fail if there are only nat hyps: *) - ltac:(match goal with - | H: ?t |- a = 1 => - match t with - nat => fail 1 - | _ => idtac "remaining hyp: " H ":" t - end - end). -Abort. - -End Using. *) - - -Import SpecNotation. - Module At. - Module Using. - Import List.ListNotations. - Open Scope list_scope. - - Close Scope autonaming_scope. - Open Scope especialize_scope. - Lemma test_espec: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. - Proof. - intros x hx h_eqone. - (* specevar h_eqone at y. *) - (* especialize h_eqone at (ConsEVAR 1 (ConsEVAR 2 (ConsGOAL 4 (FinalGOAL 5)))). *) - assert premises h_eqone at (2?::##5) as h. - + reflexivity. - + exfalso. - eapply h_eqone with (z:=0);eauto. - subst. - reflexivity. -Qed. - - - -Lemma foo: False. -Proof. - (* specialize (le_sind 0) as h. *) - (* Set Ltac Debug. *) - especialize (le_sind 0) at (1?:: ##2) as h'. - (* Set Ltac Debug. *) - especialize (le_sind 0) at (1?:: ##2) as h. ? P. as hh : h. - { admit. } - especialize min_l at 1 as ? : ?. - { apply (le_n O). } - - especialize H at 1 as hh : h. - { reflexivity. } - match type of h with False => idtac "OK" | _ => fail end. - assumption. -Qed. -*) - - -Lemma test_espec2: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. -Proof. - intros x hx h_eqone. - (* specevar h_eqone at y. *) - especialize h_eqone using (! ? ! ! ##). - + reflexivity. - + exfalso. - apply h_eqonetemp with 1 0. - * reflexivity. - * reflexivity. - * symmetry. - assumption. -Qed. - - -Lemma test_espec3: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. -Proof. - intros x hx h_eqone. - (* specevar h_eqone at y. *) - especialize h_eqone using (! ? ? ! ##). - + reflexivity. - + exfalso. - apply h_eqonetemp with 1. - * reflexivity. - * instantiate (z:=0). reflexivity. - * symmetry. - assumption. -Qed. - - -Lemma test_espec4: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. -Proof. - intros x hx h_eqone. - (* specevar h_eqone at y. *) - especialize h_eqone using (? ? ? ! ##). - + reflexivity. - + exfalso. - apply h_eqonetemp. - * reflexivity. - * instantiate (z:=0). reflexivity. - * symmetry. - assumption. -Qed. - -Lemma test_espec5: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. -Proof. - intros x hx h_eqone. - (* specevar h_eqone at y. *) - especialize h_eqone using (? ? ? ##). - + reflexivity. - + exfalso. - apply h_eqonetemp. - * reflexivity. - * instantiate (z:=0). reflexivity. - * symmetry. - assumption. -Qed. - -Lemma test_espec6: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. -Proof. - intros x hx h_eqone. - (* specevar h_eqone at y. *) - especialize h_eqone using (? ! ! ##). - + reflexivity. - + exfalso. - apply h_eqonetemp with 1 0. - * reflexivity. - * reflexivity. - * symmetry. - assumption. -Qed. - -Lemma test_espec7: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. -Proof. - intros x hx h_eqone. - (* specevar h_eqone at y. *) - especialize h_eqone using (? ! ? # ! ! ##). - + reflexivity. - + rewrite hx. - instantiate (z:=0). - reflexivity. - + exfalso. - apply h_eqonetemp with 1. - * reflexivity. - * reflexivity. -Qed. - -Lemma test_espec8: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. -Proof. - intros x hx h_eqone. - (* specevar h_eqone at y. *) - especialize h_eqone using (? ! ! # ! ! ##). - + reflexivity. - + subst. - rewrite Nat.add_comm in x2. - cbn in x2. - injection x2;intro ;assumption. - + exfalso. - apply h_eqonetemp with 1 0. - * reflexivity. - * reflexivity. -Qed. - -Lemma test_espec9: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. -Proof. - intros x hx h_eqone. - (* specevar h_eqone at y. *) - especialize h_eqone using (! ! ! # ! ! ##). - + subst. - Fail - (* this should fail if there are only nat hyps: *) - ltac:(match goal with - | H: ?t |- a = 1 => - match t with - nat => fail 1 - | _ => idtac "remaining hyp: " H ":" t - end - end). -Abort. - - -End At. diff --git a/LibHyps/LibHyps.v b/LibHyps/LibHyps.v index 25d96d6..f2a4176 100644 --- a/LibHyps/LibHyps.v +++ b/LibHyps/LibHyps.v @@ -5,10 +5,23 @@ Require Export LibHyps.TacNewHyps. Require Export LibHyps.LibHypsNaming. Require Export LibHyps.Especialize. +Require Export LibHyps.AssertPremise. Require Export LibHyps.LibHypsTactics. -(* We export ; { } etc. ";;" also. *) +(* Some usual tactics one may want to use on new hyps. *) +Ltac rename_or_revert H := autorename_strict H + generalize dependent H. +(* revert, fails if impossible, should not fail if hyps are ordered in the right order *) +Ltac revertHyp H := revert H. (* revert is a tactic notation, so we need to define this *) +(* revert if subst fails. Never fail, be careful not to use this tactic in the + left member of a "+" tactical: *) +Ltac subst_or_revert H := try first [progress substHyp H | generalize dependent H]. +(* try subst. Never fail, be careful to not use this tactic in the + left member of a "+" tactical: *) +Ltac subst_or_idtac H := substHyp H. + +(* TACTIC NOTATIONS *) +(* This exports the "tac ; { } ." syntax for then_eachnh. *) Export TacNewHyps.Notations. (* There are three variants of the autorename tatic, depending on what @@ -27,12 +40,9 @@ Tactic Notation (at level 4) "/" "n?" := (onAllHyps rename_or_revert). Tactic Notation (at level 4) tactic4(Tac) "/" "r" := Tac ; {< revertHyp }. Tactic Notation (at level 4) "/" "r" := (onAllHypsRev revertHyp). -(* WARNING group_up_list applies to the whole list of hyps directly. *) -(* Tactic Notation (at level 4) tactic4(Tac) "/" "g" := (then_allnh Tac group_up_list). *) -Tactic Notation (at level 4) tactic4(Tac) "/" "g" := Tac ; {! group_up_list }. -Tactic Notation (at level 4) "/" "g" := (group_up_list all_hyps). +Tactic Notation (at level 4) tactic4(Tac) "/" "g" := Tac ; { move_up_types }. +Tactic Notation (at level 4) "/" "g" := (onAllHyps move_up_types). -(* Tactic Notation (at level 4) tactic4(Tac) "/" "s" := (then_eachnh Tac subst_or_idtac). *) Tactic Notation (at level 4) tactic4(Tac) "/" "s" := Tac ; { subst_or_idtac }. Tactic Notation (at level 4) "/" "s" := (onAllHyps subst_or_idtac). @@ -46,11 +56,11 @@ Tactic Notation (at level 4) tactic4(Tac) "/" "sg" := (Tac /s/g). Tactic Notation (at level 4) tactic4(Tac) "/" "ng" := (Tac /n/g). Tactic Notation (at level 4) tactic4(Tac) "/" "gn" := (Tac /g/n). -Tactic Notation (at level 4) "/" "sng" := - (onAllHyps subst_or_idtac); (onAllHyps autorename); group_up_list all_hyps. +(* Tactic Notation (at level 4) "/" "sng" := *) + (* (onAllHyps subst_or_idtac); (onAllHyps autorename); group_up_list all_hyps. *) Tactic Notation (at level 4) "/" "sn" := (onAllHyps subst_or_idtac); (onAllHyps autorename). Tactic Notation (at level 4) "/" "sr" := (onAllHyps subst_or_idtac); (onAllHyps revertHyp). -Tactic Notation (at level 4) "/" "ng" := ((onAllHyps autorename) ; group_up_list all_hyps). +Tactic Notation (at level 4) "/" "ng" := ((onAllHyps autorename) ; (onAllHyps move_up_types) ). Module LegacyNotations. Import Notations. @@ -72,74 +82,3 @@ Module LegacyNotations. Tactic Notation (at level 4) "?!" tactic4(tac1) := tac1 /s/n!. End LegacyNotations. - - -(* -Goal forall x1 x3:bool, forall a z e : nat, - z+e = a - -> forall SEP:(True -> True), - a = z+z - -> ((fun f => z = e) true) - -> forall b1 b2 b3 b4: bool, - True -> True. -Proof. - (* Set Ltac Debug. *) - (* then_nh_rev ltac:(intros) ltac:(subst_or_idtac). *) - intros ; {! group_up_list }. - - (* intros ? ? ? ? ? ? ? ? ? ?. *) - (* group_up_list (DCons bool b1 DNil). *) - Undo. - intros ; { move_up_types }. - Undo. - intros /n. - Undo. - intros /s/n. - Undo. - intros /n. - match goal with - | h: bool => assert - end - Undo. - intros/n. - Undo. - intros ; { autorename }; {! group_up_list }. - Undo. - intros/ng. - Undo. - intros ; {subst_or_idtac} ; { autorename } ; {! group_up_list }. - Undo. - intros/sng. - Fail progress intros ; { revertHyp }. - - subst_or_idtac (DCons (z0 + r = a) H DNil). - - - let hyps := all_hyps in - idtac hyps. - subst_or_idtac hyps. - - intros ;!; ltac:(subst_or_idtac_l). - - then_nh_one_by_one ltac:(intros) ltac:(subst_or_idtac). -; {< subst_or_idtac }. ; { group_up_list } ; { autorename_l }. - subst_or_idtac h_eq_a_add_z0_t. - intros ; { fun h => autorename_strict h }. - intros ; { fun h => idtac h }. - intros ; { ltac:(fun h => idtac h) }. - intros ; [H: sng H]. -*) -(* -Goal forall x1 x3:bool, True -> forall a z e r t z e r t z e r t z e r t y: nat, False -> forall u i o p q s d f g:nat, forall x2:bool, True -> True. -Proof. - - time then_nh ltac:(intros) ltac:(group_up_list). - - intros. - Set Ltac Profiling. - let lh := all_hyps in - let cache := build_initial_cache lh in - group_up_list_ H (DCons bool x3 DNil) lh. - idtac cache. - - *) diff --git a/LibHyps/LibHypsDebug.v b/LibHyps/LibHypsDebug.v new file mode 100644 index 0000000..98b4e57 --- /dev/null +++ b/LibHyps/LibHypsDebug.v @@ -0,0 +1,60 @@ +Require Import Ltac2.Ltac2. +From Ltac2 Require Import Option Constr Printf. + +(* debug *) +(* +Require LibHyps.LibHypsTactics. +Module Prgoal_Notation. + Ltac pr_goal := + match goal with + |- ?g => + let allh := LibHyps.TacNewHyps.harvest_hyps LibHyps.TacNewHyps.revert_clearbody_all in + (* let allh := all_hyps in *) + idtac "GOAL: " allh " ⊢ " g + end. +End Prgoal_Notation. +*) + +Ltac2 tag_info s := (String.concat "" [ ""; s; "" ]). +Ltac2 tag_msg m := Message.concat + (Message.concat (Message.of_string "") m) + (Message.of_string ""). +Ltac2 str_to_msg s := tag_msg (Message.of_string s). +Ltac2 int_to_msg i := tag_msg (Message.of_int i). +Ltac2 id_to_msg id := tag_msg (Message.of_ident id). +Ltac2 constr_to_msg c := tag_msg (Message.of_constr c). + +Ltac2 msgm m := Message.print (tag_msg m). +Ltac2 msgs s := Message.print (str_to_msg s). +Ltac2 msgi i := Message.print (int_to_msg i). +Ltac2 msgc c := Message.print (constr_to_msg c). +Ltac2 msgid id := Message.print (id_to_msg id). + +Ltac2 pr_list (pr: unit -> 'a -> message) () (l: 'a list) : message := + let rec pr_list_ () (l: 'a list) := + match l with + | [] => fprintf "" + | [e] => fprintf "%a" pr e + | e::l' => fprintf "%a , %a" pr e pr_list_ l' + end in + fprintf "[ %a ]" pr_list_ l. + + +Ltac2 pr_binder () (b:binder):message := + let nme:ident option := Binder.name b in + let typ:constr := Binder.type b in + fprintf "(%I:%t)" (Option.get nme) typ. + +Ltac2 pr_string () (s:string): message := fprintf "%s" s. +Ltac2 pr_ident () (id:ident): message := fprintf "%I" id. +Ltac2 pr_bool () (b:bool): message := fprintf "%s" (if b then "true" else "false"). + +Ltac2 pr_goal() := + let l := Control.hyps() in + printf " Goal:"; + List.iter (fun (nme,_,typ) => printf "%I : %t" nme typ) l; + printf "⊢ %t" (Control.goal()); + printf "". + +Ltac2 pr_acc () (acc:string list) := + fprintf "[%a]" (pr_list pr_string) acc. diff --git a/LibHyps/LibHypsNaming.v b/LibHyps/LibHypsNaming.v index 94f15b2..9ba2f9e 100644 --- a/LibHyps/LibHypsNaming.v +++ b/LibHyps/LibHypsNaming.v @@ -1,619 +1,564 @@ (* Copyright 2021 Pierre Courtieu This file is part of LibHyps. It is distributed under the MIT "expat license". You should have recieved a LICENSE file with it. *) - -From Stdlib Require Import Arith ZArith List. -Require Import LibHyps.TacNewHyps. -Import ListNotations. -Local Open Scope list. +(* **************************************************************** *) (** This file defines a tactic "autorename h" (and "autorename_strict - h") that automatically rename hypothesis h followinh a systematic, + h") that automatically rename hypothesis h following a systematic, but customizable heuristic. Comments welcome. *) +Require Import Arith ZArith List. +Require LibHyps.TacNewHyps. + +(* Import ListNotations. *) +(* Local Open Scope list. *) +Require Import Ltac2.Ltac2. +From Ltac2 Require Import Option Constr Printf. +Import Constr.Unsafe. +Local Set Default Proof Mode "Classic". +(* Require Import LibHyps.LibHypsDebug. *) + +Local Ltac2 backtrack (msg:string) := Control.zero (Tactic_failure (Some (fprintf "Backtrack: %s" msg))). +Local Ltac2 control_try tac := Control.plus tac (fun _ => ()). + (* Comment this and the Z-dependent lines below if you don't want ZArith to be loaded *) -From Stdlib Require Import ZArith. +Require Import ZArith. -(** ** The custom renaming tactic +Ltac2 decr (n:int):int := + if Int.equal n 0 then 0 else Int.sub n 1. - The tactic "rename_hyp" should be redefined along a coq development, - it should return a fresh name build from a type th and a depth. It - should fail if no name is found, so that the fallback scheme is - called. +Ltac2 incr (n:int):int := Int.add n 1. - Typical use, in increasing order of complexity, approximatively - equivalent to the decreasing order of interest. +Ltac2 Type rename_directive := [ String(string) | Rename(constr) | RenameN(int,constr) ]. +Ltac2 Type rename_directives := rename_directive list. -<< -Ltac rename_hyp1 n th := - match th with - | List.In ?e ?l => name ( `_lst_in` ++ e#n ++ l#O) - | InA _ ?e ?l => name( `_inA` ++ e#n ++ l#0) - | @StronglySorted _ ?ord ?l => name ( `_strgSorted` ++ l#(S (S n))) - | @Forall _ ?P ?x => name (`_lst_forall` ++ P#n ++ x#n) - | @Forall2 _ _ ?P ?x ?y => name (`_lst_forall2` ++ P#n ++ x#n ++ y#n) - | NoDupA _ ?l => name (`_NoDupA` ++ l#n) - | NoDup _ ?l => name (`_NoDup` ++ l#n) - end. ->> -(* Overwrite the definition of rename_hyp using the ::= operator. :*) +(* For debugging *) +Module Debug. + Ltac2 pr_directive () (d:rename_directive) := + match d with + String s => fprintf "%s" s + | Rename c => fprintf "%t" c + | RenameN i c => fprintf "N(%i,%t)" i c + end. +End Debug. -<< -Ltac rename_hyp ::= my_rename_hyp. ->> *) +Ltac2 Type hypnames := string list. +(** This determines the depth of the recursive analysis of a type to + compute the corresponding hypothesis name. generally 2 or 3 is + enough. More gives too log names, less may give identical names + too often. *) +Ltac2 mutable rename_depth := 3. +(* The pretty printing of numerical values is by default 1, 2... Set this to + true (Ltac2 Set numerical_sufs := true) to have 1z, 1n or 1N depending of the type nat, Z or N. *) +Ltac2 mutable numerical_sufx := false. +(* Whether autorename should add a "_" at the end of every hypothesis name *) +Ltac2 mutable add_suffix := true. +(* Whether autornename should add "h_" at the beginniong of each hypothesis name *) +Ltac2 mutable add_prefix := true. -(** * Implementation principle: +(** Default prefix for hypothesis names. *) +Ltac2 default_prefix():string := "h". - The name of the hypothesis will be a sequence of chunks. A chunk is - a word generally starting with "_". +(** A few special default chunks, for special cases in the naming heuristic. *) +Ltac2 impl_prefix() := "impl". +Ltac2 forall_prefix() := "all". +Ltac2 exists_prefix() := "ex". - Internally (not seen by the user) this sequence is represented by a - list of small terms. One term of the form (∀ :Prop, DUMMY - ) per chunk. For instance the sequence "h_eq_foo" is - represented by the following coq term: +(** ** The custom renaming tactic + + This is the customizable naming tactic that the user should REDEFINE along + his development. See below for an example of such redefinition. It should + always fail when no name suggestion is found, to give a chance to the + default naming scheme to apply. *) +#[warnings="-ltac2-unused-variable"] +Ltac2 mutable rename_hyp (stop:int) (th:constr): rename_directives := backtrack "rename_hyp". + + +(* Typical use, in increasing order of complexity, approximatively + equivalent to the decreasing order of interest. *) +(** +<< +From Stdlib Require Import Sorting.SetoidList. +Ltac2 rename_hyp_2 n th := + match! th with + | true <> false => [String "tNEQf"] + | true = false => [String "tEQf"] +end. +Ltac2 rename_hyp_3 n th := + match! th with + | List.In ?e ?l => [String "lst_in" ; RecRename n e ; RecRename 0 l] + | InA _ ?e ?l => [String "inA" ; RecRename n e ; RecRename 0 l ] + | @StronglySorted _ ?ord ?l => [ String"strgSorted" ; RecRename (Int.add 2 n) l] + | @Forall _ ?p ?x => [String "lst_forall" ; RecRename n p ; RecRename n x] + | @Forall2 _ _ ?p ?x ?y => [String "_lst_forall2" ; RecRename n p ; RecRename n x; RecRename n y] + | NoDupA _ ?l => [String "_NoDupA" ; RecRename n l ] + | NoDup _ ?l => [String "_NoDup" ; RecRename n l ] + | _ => rename_hyp_2 n th + end. +Ltac2 Set rename_hyp := rename_hyp_3. +>> *) - [(∀ h,DUMMY h) ; (∀ _eq,DUMMY _eq) ; (∀ _foo, DUMMY _foo)] +(* This one is similar but for internal use *) +#[global,warnings="-ltac2-unused-variable"] +Ltac2 mutable rename_hyp_default (n:int) (th:constr): rename_directives := backtrack "rename_hyp_default". - where DUMMY is an opaque (identity) function but we don't care. *) +Module Ltac2. + (* from [ "foo" ; "bar" ; "oof" ] to "h_oof_bar_foo_". Note the reversing of the list *) + Ltac2 build_name_gen (sep:string) (prefx:bool) (suffx:bool) (l:string list) := + let l := if prefx then (default_prefix()::l) else l in + (String.app (String.concat sep l) (if suffx then "_" else "")). -(** We define DUMMY as an opaque symbol. *) -Definition DUMMY: Prop -> Prop. - exact (fun x:Prop => x). -Qed. + Ltac2 build_name (l:string list): string := build_name_gen "_" add_prefix add_suffix (List.rev l). -(* ********** CUSTOMIZATION ********** *) + Ltac2 string_of_int (i:int) := Message.to_string (Message.of_int i). -(** If this is true, then all hyps names will have a trailing "_". In - case of names ending with a digit (like in "le_1_2" or "le_x1_x2") - this additional suffix avoids Coq's fresh name generation to - *replace* the digit. Although this is esthetically bad, it makes - things more predictable. You may set this to true for backward - compatility. *) -Ltac add_suffix := constr:(true). -(* This sets the way numerical constants are displayed, default value - is set below to numerical_names_nosufx, which will give the same - name to (O<1)%nat and (O<1)%Z and (O<1)%N, i.e. h_lt_0_1_. - but you can use this in your development to change it - h_lt_0n_1n_/h_lt_0z_1z_/h_lt_0N_1N_: - Ltac numerical_names ::= numerical_names_sufx *) -Ltac numerical_names := fail. + Ltac2 string_forall (p:char -> bool) (s:string) : bool := + let rec check i := + if Int.ge i (String.length s) then true + else if p (String.get s i) then check (Int.add 1 i) else false + in + check 0. -(** This determines the depth of the recursive analysis of a type to - compute the corresponding hypothesis name. generally 2 or 3 is - enough. More gives too log names, less may give identical names - too often. *) -Ltac rename_depth := constr:(3). -(** Default prefix for hypothesis names. *) -Ltac default_prefix :=constr:(forall h, DUMMY h). + Ltac2 codepercent():int := (Char.to_int (String.get "%" 0)). + Ltac2 code0() := Char.to_int (String.get "0" 0). + Ltac2 code9() := Char.to_int (String.get "9" 0). -(** A few special default chunks, for special cases in the naming heuristic. *) -Ltac impl_prefix := constr:(forall _impl, DUMMY _impl). -Ltac forall_prefix := constr:(forall _all, DUMMY _all). -Ltac exists_prefix := constr:(forall _ex, DUMMY _ex). - -(** This is the customizable naming tactic that the user should - REDEFINE along his development. See above for an example of such - redefinition. It should always fail when no name suggestion is - found, to give a chance to the default naming scheme to apply. *) - - Ltac rename_hyp stop th := fail. - -(* ************************************** *) - - -(** Builds an id from a sequence of chunks. fresh is not supposed to - add suffixes anywhere because all the ids we use start with "_". - As long as no constant or hyp name start with "_" it is ok. *) -Ltac build_name_gen suffx l := - let l := eval lazy beta delta [List.app] iota in l in - match l with - | nil => fail - | (forall id1:Prop, DUMMY id1)::nil => - match suffx with - | true => fresh id1 "_" - | false => fresh id1 - end - | (forall id1:Prop, DUMMY id1)::?l' => - let recres := build_name_gen suffx l' in - (* id1 starts with "_", so fresh do not add any suffix *) - let res := fresh id1 recres in - res - end. + Ltac2 is_digit (c:char): bool := + let code := Char.to_int c in + Bool.and (Int.le (code0()) code) (Int.le code (code9())). -Ltac build_name l := build_name_gen add_suffix l. -Ltac build_name_no_suffix l := build_name_gen constr:(false) l. + Ltac2 string_first (p:char -> bool) (s:string) : int := + let lgth := String.length s in + let rec count i := + if Int.ge i lgth then i + else if p (String.get s i) then i + else count (Int.add 1 i) + in + count 0. + Ltac2 Eval (string_first (fun c => Int.equal (Char.to_int c) (codepercent())) "xxxcc"). -(** Check if t is an eligible argument for fresh function. For instance - if t is (forall foo, ...), it is not eligible. *) -Ltac freshable t := - let x := fresh t "_dummy_sufx" in - idtac. + Ltac2 string_shorten_percent (s:string) : string := + let i := string_first (fun c => Int.equal (Char.to_int c) (codepercent())) s in + String.sub s 0 i. -(** Generate fresh name for numerical constants. + + (** Generate fresh name for numerical constants. Warning: problem here: hyps names may end with a digit: Coq may *replace* the digit in case of name clash. If you are bitten by this, you should switch to "Ltac add_suffix ::= constr:(true)." so that every hyp name ends with "_", so that coq never mangle with the digits *) -Ltac numerical_names_nosufx t := - match t with - | 0%Z => fresh "_0" - | 1%Z => fresh "_1" - | 2%Z => fresh "_2" - | 3%Z => fresh "_3" - | 4%Z => fresh "_4" - | 5%Z => fresh "_5" - | 6%Z => fresh "_6" - | 7%Z => fresh "_7" - | 8%Z => fresh "_8" - | 9%Z => fresh "_9" - | 10%Z => fresh "_10" - (* | Z0 => fresh "_0" *) - | O%nat => fresh "_0" - | 1%nat => fresh "_1" - | 2%nat => fresh "_2" - | 3%nat => fresh "_3" - | 4%nat => fresh "_4" - | 5%nat => fresh "_5" - | 6%nat => fresh "_6" - | 7%nat => fresh "_7" - | 8%nat => fresh "_8" - | 9%nat => fresh "_9" - | 10%nat => fresh "_10" - | O%N => fresh "_0" - | 1%N => fresh "_1" - | 2%N => fresh "_2" - | 3%N => fresh "_3" - | 4%N => fresh "_4" - | 5%N => fresh "_5" - | 6%N => fresh "_6" - | 7%N => fresh "_7" - | 8%N => fresh "_8" - | 9%N => fresh "_9" - | 10%N => fresh "_10" - end. - -Ltac numerical_names_sufx t := - match t with - | 0%Z => fresh "_0z" - | 1%Z => fresh "_1z" - | 2%Z => fresh "_2z" - | 3%Z => fresh "_3z" - | 4%Z => fresh "_4z" - | 5%Z => fresh "_5z" - | 6%Z => fresh "_6z" - | 7%Z => fresh "_7z" - | 8%Z => fresh "_8z" - | 9%Z => fresh "_9z" - | 10%Z => fresh "_10z" - (* | Z0 => fresh "_0" *) - | O%nat => fresh "_0n" - | 1%nat => fresh "_1n" - | 2%nat => fresh "_2n" - | 3%nat => fresh "_3n" - | 4%nat => fresh "_4n" - | 5%nat => fresh "_5n" - | 6%nat => fresh "_6n" - | 7%nat => fresh "_7n" - | 8%nat => fresh "_8n" - | 9%nat => fresh "_9n" - | 10%nat => fresh "_10n" - | O%N => fresh "_0N" - | 1%N => fresh "_1N" - | 2%N => fresh "_2N" - | 3%N => fresh "_3N" - | 4%N => fresh "_4N" - | 5%N => fresh "_5N" - | 6%N => fresh "_6N" - | 7%N => fresh "_7N" - | 8%N => fresh "_8N" - | 9%N => fresh "_9N" - | 10%N => fresh "_10N" - end. -(* Default value, see above for another possible one. -Ltac numerical_names ::= numerical_names_sufx *) -Ltac numerical_names ::= numerical_names_nosufx. - + (* FIXME: this relies on printf to build a string from a constr in + nat, Z and N. It feels wrong. *) + Ltac2 build_numerical_name (t:constr):string := + let s := Message.to_string (fprintf "%t" t) in + let s := string_shorten_percent s in (* remove trailing "%scope" *) + if string_forall is_digit s + then if Bool.neg numerical_sufx then s + else + let typ := Constr.type t in + match! typ with + | Z => String.app s "z" + | nat => String.app s "n" + | N => String.app s "N" + end + else backtrack "numerical_names_nosufx". -Ltac raw_name X := (constr:((forall X, DUMMY X) :: [])). -(** Build a chunk from a simple term: either a number or a freshable - term. *) -Ltac box_name t := - let id_ := - match t with - | _ => numerical_names t - | _ => - let _ := freshable t in - fresh "_" t - end - in constr:(forall id_:Prop, DUMMY id_). + (* FIXME: find something better to detect implicits!! *) + (* Determines the number of non "head" implicit arguments, i.e. implicit + arguments that are before any explicit one. This shall be ignored + when naming an application. This is done in very ugly way. Any + better solution welcome. *) + Ltac2 count_impl th := + (* match Unsafe.kind th with | App _ args => Array.length args | _ => 0 end. *) + match Unsafe.kind th with + | App _ _ => + lazy_match! th with + | (?z _ _ _ _ _ _ _ _ _ _ _) => + match! th with + | _ => let _ := constr:(fun a b c d e f g h i j k => ($z a b c d e f g h i j k , $z _ _ _ _ _ _ _ _ _ _ k)) in 1 + | _ => let _ := constr:(fun a b c d e f g h i j k => ($z a b c d e f g h i j k , $z _ _ _ _ _ _ _ _ _ j k)) in 2 + | _ => let _ := constr:(fun a b c d e f g h i j k => ($z a b c d e f g h i j k , $z _ _ _ _ _ _ _ _ i j k)) in 3 + | _ => let _ := constr:(fun a b c d e f g h i j k => ($z a b c d e f g h i j k , $z _ _ _ _ _ _ _ h i j k)) in 4 + | _ => let _ := constr:(fun a b c d e f g h i j k => ($z a b c d e f g h i j k , $z _ _ _ _ _ _ g h i j k)) in 5 + | _ => let _ := constr:(fun a b c d e f g h i j k => ($z a b c d e f g h i j k , $z _ _ _ _ _ f g h i j k)) in 6 + | _ => let _ := constr:(fun a b c d e f g h i j k => ($z a b c d e f g h i j k , $z _ _ _ _ e f g h i j k)) in 7 + | _ => let _ := constr:(fun a b c d e f g h i j k => ($z a b c d e f g h i j k , $z _ _ _ d e f g h i j k)) in 8 + | _ => let _ := constr:(fun a b c d e f g h i j k => ($z a b c d e f g h i j k , $z _ _ c d e f g h i j k)) in 9 + | _ => let _ := constr:(fun a b c d e f g h i j k => ($z a b c d e f g h i j k , $z _ b c d e f g h i j k)) in 10 + | _ => let _ := constr:(fun a b c d e f g h i j k => ($z a b c d e f g h i j k , $z a b c d e f g h i j k)) in 11 + end + | (?z _ _ _ _ _ _ _ _ _ _) => + match! th with + | _ => let _ := constr:(fun b c d e f g h i j k => ($z b c d e f g h i j k , $z _ _ _ _ _ _ _ _ _ k)) in 1 + | _ => let _ := constr:(fun b c d e f g h i j k => ($z b c d e f g h i j k , $z _ _ _ _ _ _ _ _ j k)) in 2 + | _ => let _ := constr:(fun b c d e f g h i j k => ($z b c d e f g h i j k , $z _ _ _ _ _ _ _ i j k)) in 3 + | _ => let _ := constr:(fun b c d e f g h i j k => ($z b c d e f g h i j k , $z _ _ _ _ _ _ h i j k)) in 4 + | _ => let _ := constr:(fun b c d e f g h i j k => ($z b c d e f g h i j k , $z _ _ _ _ _ g h i j k)) in 5 + | _ => let _ := constr:(fun b c d e f g h i j k => ($z b c d e f g h i j k , $z _ _ _ _ f g h i j k)) in 6 + | _ => let _ := constr:(fun b c d e f g h i j k => ($z b c d e f g h i j k , $z _ _ _ e f g h i j k)) in 7 + | _ => let _ := constr:(fun b c d e f g h i j k => ($z b c d e f g h i j k , $z _ _ d e f g h i j k)) in 8 + | _ => let _ := constr:(fun b c d e f g h i j k => ($z b c d e f g h i j k , $z _ c d e f g h i j k)) in 9 + | _ => let _ := constr:(fun b c d e f g h i j k => ($z b c d e f g h i j k , $z b c d e f g h i j k)) in 10 + end + | (?z _ _ _ _ _ _ _ _ _) => + match! th with + | _ => let _ := constr:(fun c d e f g h i j k => ($z c d e f g h i j k , $z _ _ _ _ _ _ _ _ k)) in 1 + | _ => let _ := constr:(fun c d e f g h i j k => ($z c d e f g h i j k , $z _ _ _ _ _ _ _ j k)) in 2 + | _ => let _ := constr:(fun c d e f g h i j k => ($z c d e f g h i j k , $z _ _ _ _ _ _ i j k)) in 3 + | _ => let _ := constr:(fun c d e f g h i j k => ($z c d e f g h i j k , $z _ _ _ _ _ h i j k)) in 4 + | _ => let _ := constr:(fun c d e f g h i j k => ($z c d e f g h i j k , $z _ _ _ _ g h i j k)) in 5 + | _ => let _ := constr:(fun c d e f g h i j k => ($z c d e f g h i j k , $z _ _ _ f g h i j k)) in 6 + | _ => let _ := constr:(fun c d e f g h i j k => ($z c d e f g h i j k , $z _ _ e f g h i j k)) in 7 + | _ => let _ := constr:(fun c d e f g h i j k => ($z c d e f g h i j k , $z _ d e f g h i j k)) in 8 + | _ => let _ := constr:(fun c d e f g h i j k => ($z c d e f g h i j k , $z c d e f g h i j k)) in 9 + end + | (?z _ _ _ _ _ _ _ _) => + match! th with + | _ => let _ := constr:(fun d e f g h i j k => ($z d e f g h i j k , $z _ _ _ _ _ _ _ k)) in 1 + | _ => let _ := constr:(fun d e f g h i j k => ($z d e f g h i j k , $z _ _ _ _ _ _ j k)) in 2 + | _ => let _ := constr:(fun d e f g h i j k => ($z d e f g h i j k , $z _ _ _ _ _ i j k)) in 3 + | _ => let _ := constr:(fun d e f g h i j k => ($z d e f g h i j k , $z _ _ _ _ h i j k)) in 4 + | _ => let _ := constr:(fun d e f g h i j k => ($z d e f g h i j k , $z _ _ _ g h i j k)) in 5 + | _ => let _ := constr:(fun d e f g h i j k => ($z d e f g h i j k , $z _ _ f g h i j k)) in 6 + | _ => let _ := constr:(fun d e f g h i j k => ($z d e f g h i j k , $z _ e f g h i j k)) in 7 + | _ => let _ := constr:(fun d e f g h i j k => ($z d e f g h i j k , $z d e f g h i j k)) in 8 + end + | (?z _ _ _ _ _ _ _) => + match! th with + | _ => let _ := constr:(fun e f g h i j k => ($z e f g h i j k , $z _ _ _ _ _ _ k)) in 1 + | _ => let _ := constr:(fun e f g h i j k => ($z e f g h i j k , $z _ _ _ _ _ j k)) in 2 + | _ => let _ := constr:(fun e f g h i j k => ($z e f g h i j k , $z _ _ _ _ i j k)) in 3 + | _ => let _ := constr:(fun e f g h i j k => ($z e f g h i j k , $z _ _ _ h i j k)) in 4 + | _ => let _ := constr:(fun e f g h i j k => ($z e f g h i j k , $z _ _ g h i j k)) in 5 + | _ => let _ := constr:(fun e f g h i j k => ($z e f g h i j k , $z _ f g h i j k)) in 6 + | _ => let _ := constr:(fun e f g h i j k => ($z e f g h i j k , $z e f g h i j k)) in 7 + end + | (?z _ _ _ _ _ _) => + match! th with + | _ => let _ := constr:(fun f g h i j k => ($z f g h i j k , $z _ _ _ _ _ k)) in 1 + | _ => let _ := constr:(fun f g h i j k => ($z f g h i j k , $z _ _ _ _ j k)) in 2 + | _ => let _ := constr:(fun f g h i j k => ($z f g h i j k , $z _ _ _ i j k)) in 3 + | _ => let _ := constr:(fun f g h i j k => ($z f g h i j k , $z _ _ h i j k)) in 4 + | _ => let _ := constr:(fun f g h i j k => ($z f g h i j k , $z _ g h i j k)) in 5 + | _ => let _ := constr:(fun f g h i j k => ($z f g h i j k , $z f g h i j k)) in 6 + end + | (?z _ _ _ _ _) => + match! th with + | _ => let _ := constr:(fun g h i j k => ($z g h i j k , $z _ _ _ _ k)) in 1 + | _ => let _ := constr:(fun g h i j k => ($z g h i j k , $z _ _ _ j k)) in 2 + | _ => let _ := constr:(fun g h i j k => ($z g h i j k , $z _ _ i j k)) in 3 + | _ => let _ := constr:(fun g h i j k => ($z g h i j k , $z _ h i j k)) in 4 + | _ => let _ := constr:(fun g h i j k => ($z g h i j k , $z g h i j k)) in 5 + end + | (?z _ _ _ _) => + match! th with + | _ => let _ := constr:(fun h i j k => ($z h i j k , $z _ _ _ k)) in 1 + | _ => let _ := constr:(fun h i j k => ($z h i j k , $z _ _ j k)) in 2 + | _ => let _ := constr:(fun h i j k => ($z h i j k , $z _ i j k)) in 3 + | _ => let _ := constr:(fun h i j k => ($z h i j k , $z h i j k)) in 4 + end + | (?z _ _ _) => + match! th with + | _ => let _ := constr:(fun a b c => ($z a b c, $z _ _ c)) in 1 + | _ => let _ := constr:(fun a b c => ($z a b c, $z _ b c)) in 2 + | _ => let _ := constr:(fun a b c => ($z a b c, $z a b c)) in 3 + end + | (?z _ _) => + match! th with + | _ => let _ := constr:(fun a b => ($z a b, $z _ b)) in 1 + | _ => let _ := constr:(fun a b => ($z a b, $z a b)) in 2 + end + | (?z _) => + match! th with + | _ => let _ := constr:(fun b => ($z b, $z _)) in 0 + | _ => let _ := constr:(fun b => ($z b, $z b)) in 1 + end + end + | _ => 0 + end. -(** This will later contain a few default fallback naming strategy. *) -Ltac rename_hyp_default stop th := - fail. -Ltac decr n := - match n with - | S ?n' => n' - | 0 => 0 - end. + Ltac2 arobase():char := (Char.of_int 64). -(* This computes the way we decrement our depth counter when we go - inside of t. For now we forget the idea of traversing Prop sorted - terms indefinitely. It gives too long names. *) -Ltac nextlevel n t := - let tt := type of t in - match tt with - (* | Prop => n *) - | _ => decr n - end. + (** Build a chunk from a simple term: either a number or a freshable + term. *) + Ltac2 box_name t : string := + (* Hackish? *) + let s:string := Message.to_string (fprintf "%t" t) in + let s := if Char.equal (String.get s 0) (arobase()) + then String.sub s 1 (Int.sub (String.length s) 1) + else s in + match Ident.of_string s with + | Some _ => s + | None => + match Unsafe.kind t with + | Unsafe.Constant cstt _ => + let id:ident := List.last (Env.path (Std.ConstRef cstt)) in + Ident.to_string id + | Unsafe.Var id => Ident.to_string id + | Unsafe.Ind _ _ => + (* printf "IND: %t" t; *) + let s:string := Message.to_string (fprintf "%t" t) in + let s := if Char.equal (String.get s 0) (arobase()) + then String.sub s 1 (Int.sub (String.length s) 1) + else s in + s + | _ => build_numerical_name t + end + end. -(* Determines the number of "head" implicit arguments, i.e. implicit - arguments that are before any explicit one. This shall be ignored - when naming an application. This is done in very ugly way. Any - better solution welcome. *) -Ltac count_impl th := - lazymatch th with - | (?z ?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k) => - match th with - | _ => let foo := constr:(z _ _ _ _ _ _ _ _ _ _ k) in constr:(1%nat) - | _ => let foo := constr:(z _ _ _ _ _ _ _ _ _ j k) in constr:(2%nat) - | _ => let foo := constr:(z _ _ _ _ _ _ _ _ i j k) in constr:(3%nat) - | _ => let foo := constr:(z _ _ _ _ _ _ _ h i j k) in constr:(4%nat) - | _ => let foo := constr:(z _ _ _ _ _ _ g h i j k) in constr:(5%nat) - | _ => let foo := constr:(z _ _ _ _ _ f g h i j k) in constr:(6%nat) - | _ => let foo := constr:(z _ _ _ _ e f g h i j k) in constr:(7%nat) - | _ => let foo := constr:(z _ _ _ d e f g h i j k) in constr:(8%nat) - | _ => let foo := constr:(z _ _ c d e f g h i j k) in constr:(9%nat) - | _ => let foo := constr:(z _ b c d e f g h i j k) in constr:(10%nat) - | _ => let foo := constr:(z a b c d e f g h i j k) in constr:(10%nat) - end - | (?z ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k) => - match th with - | _ => let foo := constr:(z _ _ _ _ _ _ _ _ _ k) in constr:(1%nat) - | _ => let foo := constr:(z _ _ _ _ _ _ _ _ j k) in constr:(2%nat) - | _ => let foo := constr:(z _ _ _ _ _ _ _ i j k) in constr:(3%nat) - | _ => let foo := constr:(z _ _ _ _ _ _ h i j k) in constr:(4%nat) - | _ => let foo := constr:(z _ _ _ _ _ g h i j k) in constr:(5%nat) - | _ => let foo := constr:(z _ _ _ _ f g h i j k) in constr:(6%nat) - | _ => let foo := constr:(z _ _ _ e f g h i j k) in constr:(7%nat) - | _ => let foo := constr:(z _ _ d e f g h i j k) in constr:(8%nat) - | _ => let foo := constr:(z _ c d e f g h i j k) in constr:(9%nat) - | _ => let foo := constr:(z b c d e f g h i j k) in constr:(10%nat) - end - | (?z ?c ?d ?e ?f ?g ?h ?i ?j ?k) => - match th with - | _ => let foo := constr:(z _ _ _ _ _ _ _ _ k) in constr:(1%nat) - | _ => let foo := constr:(z _ _ _ _ _ _ _ j k) in constr:(2%nat) - | _ => let foo := constr:(z _ _ _ _ _ _ i j k) in constr:(3%nat) - | _ => let foo := constr:(z _ _ _ _ _ h i j k) in constr:(4%nat) - | _ => let foo := constr:(z _ _ _ _ g h i j k) in constr:(5%nat) - | _ => let foo := constr:(z _ _ _ f g h i j k) in constr:(6%nat) - | _ => let foo := constr:(z _ _ e f g h i j k) in constr:(7%nat) - | _ => let foo := constr:(z _ d e f g h i j k) in constr:(8%nat) - | _ => let foo := constr:(z c d e f g h i j k) in constr:(9%nat) - end - | (?z ?d ?e ?f ?g ?h ?i ?j ?k) => - match th with - | _ => let foo := constr:(z _ _ _ _ _ _ _ k) in constr:(1%nat) - | _ => let foo := constr:(z _ _ _ _ _ _ j k) in constr:(2%nat) - | _ => let foo := constr:(z _ _ _ _ _ i j k) in constr:(3%nat) - | _ => let foo := constr:(z _ _ _ _ h i j k) in constr:(4%nat) - | _ => let foo := constr:(z _ _ _ g h i j k) in constr:(5%nat) - | _ => let foo := constr:(z _ _ f g h i j k) in constr:(6%nat) - | _ => let foo := constr:(z _ e f g h i j k) in constr:(7%nat) - | _ => let foo := constr:(z d e f g h i j k) in constr:(8%nat) - end - | (?z ?e ?f ?g ?h ?i ?j ?k) => - match th with - | _ => let foo := constr:(z _ _ _ _ _ _ k) in constr:(1%nat) - | _ => let foo := constr:(z _ _ _ _ _ j k) in constr:(2%nat) - | _ => let foo := constr:(z _ _ _ _ i j k) in constr:(3%nat) - | _ => let foo := constr:(z _ _ _ h i j k) in constr:(4%nat) - | _ => let foo := constr:(z _ _ g h i j k) in constr:(5%nat) - | _ => let foo := constr:(z _ f g h i j k) in constr:(6%nat) - | _ => let foo := constr:(z e f g h i j k) in constr:(7%nat) - end - | (?z ?f ?g ?h ?i ?j ?k) => - match th with - | _ => let foo := constr:(z _ _ _ _ _ k) in constr:(1%nat) - | _ => let foo := constr:(z _ _ _ _ j k) in constr:(2%nat) - | _ => let foo := constr:(z _ _ _ i j k) in constr:(3%nat) - | _ => let foo := constr:(z _ _ h i j k) in constr:(4%nat) - | _ => let foo := constr:(z _ g h i j k) in constr:(5%nat) - | _ => let foo := constr:(z f g h i j k) in constr:(6%nat) - end - | (?z ?g ?h ?i ?j ?k) => - match th with - | _ => let foo := constr:(z _ _ _ _ k) in constr:(1%nat) - | _ => let foo := constr:(z _ _ _ j k) in constr:(2%nat) - | _ => let foo := constr:(z _ _ i j k) in constr:(3%nat) - | _ => let foo := constr:(z _ h i j k) in constr:(4%nat) - | _ => let foo := constr:(z g h i j k) in constr:(5%nat) - end - | (?z ?h ?i ?j ?k) => - match th with - | _ => let foo := constr:(z _ _ _ k) in constr:(1%nat) - | _ => let foo := constr:(z _ _ j k) in constr:(2%nat) - | _ => let foo := constr:(z _ i j k) in constr:(3%nat) - | _ => let foo := constr:(z h i j k) in constr:(4%nat) - end - | (?z ?i ?j ?k) => - match th with - | _ => let foo := constr:(z _ _ k) in constr:(1%nat) - | _ => let foo := constr:(z _ j k) in constr:(2%nat) - | _ => let foo := constr:(z i j k) in constr:(3%nat) - end - | (?z ?j ?k) => - match th with - | _ => let foo := constr:(z _ k) in constr:(1%nat) - | _ => let foo := constr:(z j k) in constr:(2%nat) - end - | (?z ?j) => constr:(1%nat) - | _ => constr:(0%nat) - end. + Local Ltac2 is_dep_prod (t:constr): bool := + match kind t with + | Prod _ subt => Bool.neg (is_closed subt) + | _ => false + end. + Ltac2 is_hyp (id:ident) := + let hyps := Control.hyps () in + List.exist (fun (x,_,_) => Ident.equal id x) hyps. -(** Default naming of an application: we name the function if possible + (** Default naming of an application: we name the function if possible or fail, then we name all parameters that can be named either recursively or simply. Parameters at positions below nonimpl are - considered implicit and not considered. *) -Ltac rename_app nonimpl stop acc th := - match th with - | ?f => let f'' := box_name f in - constr:(f''::acc) - | (?f ?x) => - match nonimpl with - | (S ?nonimpl') => - let newstop := nextlevel stop x in - let namex := match true with - | _ => fallback_rename_hyp newstop x - | _ => constr:(@nil Prop) - end in - let newacc := constr:(namex ++ acc) in - rename_app nonimpl' stop newacc f - | 0%nat => (* don't consider this (implicit) argument *) - rename_app nonimpl stop acc f - end - | _ => constr:(@nil Prop) - end - -(* Go under binder and rebuild a term with a good name inside, - catchable by a match context. *) -with build_dummy_quantified stop th := - lazymatch th with - | forall __z:?A , ?B => - constr:( - fun __z:A => - ltac:( - let th' := constr:((fun __z => B) __z) in - let th' := eval lazy beta in th' in - let res := build_dummy_quantified stop th' in - exact res)) - | ex ?f => - match f with - | (fun __z:?A => ?B) => - constr:( - fun __z:A => - ltac:( - let th' := constr:((fun __z => B) __z) in - let th' := eval lazy beta in th' in - let res := build_dummy_quantified stop th' in - exact res)) - end - | _ => fallback_rename_hyp stop th + ignored as implicits. *) + Ltac2 rec rename_app (nonimpl:int) (stop:int) (acc:string list ref) th: unit := + Control.once_plus (fun () => let s := box_name th in + Ref.set acc (s:: Ref.get acc)) + (fun _ => + match Unsafe.kind th with + | App f args => + (* control_try? *) + (let fun_name:string := box_name f in + Ref.set acc (fun_name:: Ref.get acc)); + let newstop:int := Int.sub stop 1 in + let nonimplicitsargs := Array.sub args (Int.sub (Array.length args) nonimpl) nonimpl in + Array.iter (fun arg => (fallback_rename_hyp newstop acc arg)) nonimplicitsargs + | _ => control_try (fun() => Ref.set acc (box_name th :: Ref.get acc)) + end) + + (** ** Calls the (user-defined) rename_hyp + and fallbacks to some default + namings if needed. [h] is the hypothesis (ident) to rename, [th] is its + type. *) + with rename_hyp_chained_quantifs stop (acc:string list ref) (th:constr) : unit := + let _newstop := Int.sub stop 1 in + match Unsafe.kind th with + | Prod bnd subth => + if is_dep_prod th + then + let nme:ident := Option.get(Binder.name bnd) in + let typ := Binder.type bnd in + (* If there is already a hyp named nme, we rename it so that the + 'in_context nme ...' below does not fail. We could rename the + other way around but we prefer keeping the name found in the + binder. *) + (if is_hyp nme then Std.rename [(nme , Fresh.in_goal nme)] else ()) ; + (* Ref.set acc (Ident.to_string nme :: Ref.get acc); *) + let tac_under_binder := + fun () => + let nme_c:constr := Unsafe.make (Var(nme)) in + let subth' := Constr.Unsafe.substnl [nme_c] 0 subth in + rename_hyp_chained_quantifs stop acc subth' in + let _ := in_context nme typ tac_under_binder in + () + else + rename_hyp_chained_quantifs stop acc subth + | _ => fallback_rename_hyp stop acc th end -(** ** Calls the (user-defined) rename_hyp + and fallbacks to some - default namings if needed. [h] is the hypothesis (ident) to - rename, [th] is its type. *) - -with fallback_rename_hyp_quantif stop th := - let prefx := - match th with - | ?A -> ?B => impl_prefix - | forall _ , _ => forall_prefix - | ex (fun _ => _) => exists_prefix - | _ => fail - end in - let newstop := decr stop in - (* sufx_buried contains a list of dummies *) - let sufx_buried := build_dummy_quantified newstop th in - (* FIXME: a bit fragile *) - let sufx_buried' := eval lazy beta delta [List.app] iota in sufx_buried in - let sufx := - match sufx_buried' with - | context [ (@cons Prop ?x ?y)] => constr:(x::y) - end - in - constr:(prefx::sufx) - -with fallback_rename_hyp_specials stop th := - let newstop := decr stop in - match th with - (* First see if user has something that applies *) - | _ => rename_hyp newstop th - (* if it fails try default specials *) - | _ => rename_hyp_default newstop th - end - -with fallback_rename_hyp stop th := - match stop with - (*| 0 => constr:(cons ltac:(box_name th) nil)*) - | 0 => constr:(@nil Prop) - | S ?n => - match th with - | _ => fallback_rename_hyp_specials stop th - | _ => fallback_rename_hyp_quantif stop th - | _ => - (*let newstop := nextlevel stop th in*) - let numnonimpl := count_impl th in - rename_app numnonimpl stop (@nil Prop) th - end - end. - -(** * Notation to define specific naming strategy *) -Declare Scope autonaming_scope. -(** Notation to build a singleton chunk list *) - -(* from coq-8.13 we should use name instead of ident. But let us wait - a few versions before this change. *) -Notation "'`' idx '`'" := (@cons Prop (forall idx:Prop, DUMMY idx) (@nil Prop)) - (at level 1,idx name,only parsing): autonaming_scope. - - -(** Notation to call naming on a term X, with a given depth n. *) -Notation " X '#' n " := ltac:( - let c := fallback_rename_hyp n X in exact c) - (at level 1,X constr, only parsing): autonaming_scope. - -Notation " X '##' " := - ltac:(let c := raw_name X in exact c) - (at level 1,X constr, only parsing): autonaming_scope. - - -(** It is nicer to write name t than constr:t, see below. *) -Ltac name c := (constr:(c)). - - -(** * Default fallback renaming strategy - - (Re)defining it now that we have everything we need. *) - -Local Open Scope autonaming_scope. -Ltac rename_hyp_default n th ::= - let res := - match th with - (* | (@eq _ ?x ?y) => name (`_eq` ++ x#n ++ y#n) *) - (* | Z.le ?A ?B => name (`_Zle` ++ A#n ++ B#n) *) - | ?x <> ?y => name ( `_neq` ++ x#(decr n) ++ y#(decr n)) - | @cons _ ?x (cons ?y ?l) => - match n with - | S ?n' => name (`_cons` ++ x#n ++ y#n ++ l#n') - | 0 => name (`_cons` ++ x#n) + with fallback_rename_hyp_quantif stop (acc:string list ref) (th:constr) : unit := + let newstop := Int.sub stop 1 in + match Unsafe.kind th with + | Prod bnd subth => + if is_dep_prod th + then + let nme:ident := Option.get(Binder.name bnd) in + let typ := Binder.type bnd in + (* If there is already a hyp named nme, we rename it so that the + 'in_context nme ...' below does not fail. We could rename the + other way around but we prefer keeping the name found in the + binder. *) + (if is_hyp nme then Std.rename [(nme , Fresh.in_goal nme)] else ()) ; + Ref.set acc ((*Ident.to_string nme ::*) forall_prefix() :: Ref.get acc); + let tac_under_binder := + fun () => + let nme_c:constr := Unsafe.make (Var(nme)) in + let subth' := Constr.Unsafe.substnl [nme_c] 0 subth in + rename_hyp_chained_quantifs newstop acc subth' in + let _ := in_context nme typ tac_under_binder in + () + + else + (Ref.set acc (impl_prefix() :: Ref.get acc); + rename_hyp_chained_quantifs newstop acc subth) + | App f args => + match Unsafe.kind f, Unsafe.kind constr:(@Init.Logic.ex) with + | Ind ind _, Ind ind' _ => + if Ind.equal ind ind' + then ( + Ref.set acc ((*Ident.to_string a ::*) exists_prefix() :: Ref.get acc); + match Unsafe.kind (Array.get args 1) with + | Lambda _bnd subth => rename_hyp_chained_quantifs newstop acc subth + | _ => backtrack "not exist" + end) + else backtrack "not exist" + | _ => backtrack "not exist" + end + | _ => backtrack "no quantif" end - | @cons _ ?x ?l => - match n with - | S ?n' => name (`_cons` ++ x#n ++ l#n') - | 0 => name (`_cons` ++ x#n) - end - | (@Some _ ?x) => name (x#(S n)) - | (@None _) => name (`_None`) - | _ => fail - end in - res. - -(* Call this in your own renaming scheme if you want the "hneg" prefix - on negated properties *) -Ltac rename_hyp_neg n th := - match th with - | ~ (_ = _) => fail 1(* h_neq already dealt by fallback *) - | ~ ?th' => name (`not` ++ th'#(S n)) - | _ => fail - end. -Local Close Scope autonaming_scope. - -(* Entry point of the renaming code. *) -Ltac fallback_rename_hyp_name th := - let depth := rename_depth in - let h := constr:(ltac:(let x := default_prefix in exact x)) in - let l := fallback_rename_hyp depth th in - match l with - nil => fail 1 - | _ => let nme := build_name (h::l) in - fresh nme - end. + with fallback_rename_hyp_specials stop (acc:string list ref) th :unit := + let newstop := Int.sub stop 1 in + let freeze := Ref.get acc in + Control.once_plus + (* First see if user has something that applies *) + (fun() => let dirs := rename_hyp newstop th in + interp_directives newstop acc (List.rev dirs) ) + (* if it fails try default specials *) + (fun _ => let dirs := rename_hyp_default newstop th in + Ref.set acc freeze; (* backtracking acc by hand here *) + interp_directives newstop acc (List.rev dirs)) + + with fallback_rename_hyp stop (acc:string list ref) th:unit := + if Int.le stop 0 then () + else + Control.once_plus (fun () => fallback_rename_hyp_specials stop acc th) + (fun _ => + lazy_match! th with + | forall _, _ => fallback_rename_hyp_quantif stop acc th + | exists _, _ => fallback_rename_hyp_quantif stop acc th + | _ => let numnonimpl := count_impl th in + let _ := rename_app numnonimpl stop acc th in + () + end) + + with interp_directives stop acc ld:unit := + List.fold_right (fun d _ => interp_directive stop acc d) ld () + + with interp_directive stop acc d := + (* printf "interp_directive %a %a" pr_acc (Ref.get acc) pr_directive d; *) + match d with + | String s => Ref.set acc (s :: (Ref.get acc)) + | Rename t => fallback_rename_hyp stop acc t + | RenameN n t => fallback_rename_hyp n acc t + end. + + (* Like in_context but then forget about the new goal. Only side effects are + kept *) + Ltac2 in_context_then_forget nme typ f := + Control.once_plus + (fun () => let _ := in_context nme typ f in backtrack "forget in_context subgoal") + (fun _ => ()). + + Ltac2 rename_acc n th := + let acc := Ref.ref [] in + (* We intentionally create a separate goal and backtrack it at the end. We + only keep the name stored in acc. *) + let dummy_nme := Option.get (Ident.of_string "DUMMY_SUBGOAL") in + in_context_then_forget dummy_nme constr:(Prop) (fun () => fallback_rename_hyp n acc th); + Ref.get acc. + + Ltac2 fallback_rename_hyp_name th: ident := + let depth := rename_depth in + let l := rename_acc depth th in + (* printf "ICI10 : %a" pr_acc l; *) + match l with + [] => backtrack "No name built" + | _ => let nme := build_name l in + let id := Option.get (Ident.of_string nme) in + Fresh.in_goal id + end. + + (* This entry point is for really adhoc user renaming that need to inspect the +goal in depth. For instance itf the name of a variable depends on the presence +of some hypothesis. Currently unplugged.*) + #[warnings="-ltac2-unused-variable"] + Local Ltac2 rename_hyp_with_name h th := fail. + + (* Tactic renaming hypothesis H. Ignore Type-sorted hyps, fails if no +renaming can be computed. Example of failing type: H:((fun x => True) true). *) + Local Ltac2 autorename_strict (h:ident) := + let th := Constr.type (Control.hyp h) in + let tth := Constr.type th in + (* printf "th = %t" tth ; *) + lazy_match! tth with + (* TODO: the deep entry point *) + (* | _ => *) + (* let l := rename_hyp_with_name $h th in *) + (* let dummy_name := fresh "dummy" in *) + (* rename $h into dummy_name; (* frees current name of H, in case of idempotency *) *) + (* let newname := build_name_no_suffix l in *) + (* rename dummy_name into newname *) + | Prop => + let dummy_name := Fresh.in_goal (Option.get (Ident.of_string "dummy")) in + Std.rename [(h , dummy_name)]; (* frees current name of H, in case of idempotency *) + let newname := fallback_rename_hyp_name th in + Std.rename [(dummy_name,newname)] + | Prop => + let msg := fprintf "no renaming pattern for %I : %t" h th in + backtrack (Message.to_string msg) + | _ => + if Constr.equal constr:(Prop) tth + then let msg := fprintf "no renaming pattern for %I : %t" h th in + backtrack (Message.to_string msg) + else () (* not in Prop or "no renaming pattern for " $h *) + end. -(* Formating Error message *) -Inductive LHMsg t (h:t) := LHMsgC: LHMsg t h. + (* Tactic renaming hypothesis H. *) -Notation "h : t" := (LHMsgC t h) (at level 1,only printing, format -"'[ ' h ':' '/' '[' t ']' ']'"). + Local Ltac2 ltac2_autorename (h:ident) := + control_try (fun () => autorename_strict h). -Ltac rename_hyp_with_name h th := fail. + Ltac2 ltac1_autorename (h:Ltac1.t) := + let h: ident := Option.get (Ltac1.to_ident h) in + ltac2_autorename h. + Ltac2 ltac1_autorename_strict (h:Ltac1.t) := + let h: ident := Option.get (Ltac1.to_ident h) in + autorename_strict h. -(* Tactic renaming hypothesis H. Ignore Type-sorted hyps, fails if no -renaming can be computed. Example of failing type: H:((fun x => True) true). *) -Ltac autorename_strict H := - match type of H with - | ?th => - match type of th with - | _ => - let l := rename_hyp_with_name H th in - let dummy_name := fresh "dummy" in - rename H into dummy_name; (* frees current name of H, in case of idempotency *) - let newname := build_name_no_suffix l in - rename dummy_name into newname - | Prop => - let dummy_name := fresh "dummy" in - rename H into dummy_name; (* frees current name of H, in case of idempotency *) - let newname := fallback_rename_hyp_name th in - rename dummy_name into newname - | Prop => - let c := constr:(LHMsgC th H) in - fail 1 "no renaming pattern for " c (* "no renaming pattern for " H *) - | _ => idtac (* not in Prop or "no renaming pattern for " H *) - end - end. + Ltac2 rename_list l acc s := + List.iter (fun (n,t) => fallback_rename_hyp n acc t) l; + Ref.set acc (s :: (Ref.get acc)). -(* Tactic renaming hypothesis H. *) +End Ltac2. -Ltac autorename H := try autorename_strict H. +(* This is the default renaming hard-coded in LibHYps *) +Ltac2 Set rename_hyp_default := + fun n th => + if Int.lt n 0 then [] + else + lazy_match! th with + | ?x <> ?y => [ String "neq" ; Rename x ; Rename y ] + | (@Some _ ?x) => [RenameN (incr n) x] + | (@None _) => [String "None"] + end. -(* -(* Tests *) -Print Visibility. -Local Open Scope autonaming_scope. -Ltac rename_hyp1 n th := - match th with - (* | (?min <= ?x) /\ (?x < ?max) => name (x#n ++ `_bounded_` ++ min#n ++ `_` ++ max#n) *) - | ((?min <= ?x) /\ (?x <= ?max))%nat => name (x#n ++ `_bounded` ++ min#n ++ max#n) - end. -(* example of adhoc naming from hyp name: *) -Ltac rename_hyp_with_name h th ::= - match reverse goal with - | H: ?A = h |- _ => - name ( A## ++ `_same`) - (* let _ := freshable A in *) - (* name (`same_as` ++ A#1) *) - end. -Local Close Scope autonaming_scope. +Local Tactic Notation "Lautorename" hyp(h) := + let tac := ltac2:(h |- Ltac2.ltac1_autorename h) in + tac h. -Ltac rename_hyp n th ::= - match th with - | _ => rename_hyp1 n th - end. +Local Tactic Notation "Lautorename_strict" hyp(h) := + let tac := ltac2:(h |- Ltac2.ltac1_autorename_strict h) in + tac h. + +(* GLOBAL TACTICS *) + +Global Ltac autorename h := Lautorename h. + +Global Ltac autorename_strict h := Lautorename_strict h. -Goal forall x1 x3:bool, forall a z e : nat, - z+e = a - -> z = a - -> forall SEP:(True -> True), - a = z+z - -> z+z <= a <= e + e - -> ((fun f => z = e) true) - -> forall b1 b2 b3 b4: bool, - True -> True. -Proof. - intros. - autorename a. - autorename H2. - autorename H1. - Fail autorename_strict H2. - -*) diff --git a/LibHyps/LibHypsTactics.v b/LibHyps/LibHypsTactics.v index 3943acd..dda25c9 100644 --- a/LibHyps/LibHypsTactics.v +++ b/LibHyps/LibHypsTactics.v @@ -2,68 +2,67 @@ This file is part of LibHyps. It is distributed under the MIT "expat license". You should have recieved a LICENSE file with it. *) -Require Export LibHyps.TacNewHyps. -Require Export LibHyps.LibHypsNaming. -(* Require Export LibHyps.LibSpecialize. *) +Require Import Ltac2.Ltac2. + +(* HYPS GROUPING *) + +Ltac2 rec find_above_which (foundone:bool) (t:constr) + (lH:(ident * constr option * constr) list): ident option := + match lH with + | (id,_,tid)::lH' => + if Constr.equal (Constr.type tid) constr:(Prop) then Some id + else + if Constr.equal tid t + then + match find_above_which true t lH' with + | Some x => Some x + | None => Some id + end + else if foundone then Some id + else find_above_which false t lH' + | [] => None + end. -(* debug -Module Prgoal_Notation. - Ltac pr_goal := - match goal with - |- ?g => - let allh := all_hyps in - idtac "[" allh " ⊢ " g "]" +Ltac2 rec cut_at (h:ident) (lH:(ident * constr option * constr) list) := + match lH with + | ((id,_,_) as elt)::lH' => if Ident.equal id h then [elt] else elt :: (cut_at h lH') + | [] => Control.throw (Invalid_argument None) (* Should we fail here? h should always be in lH *) + end. + +Ltac2 move_up_types (h:ident) := + let t := Constr.type (Control.hyp h) in + let tt := Constr.type t in + if Constr.equal constr:(Prop) tt then () + else + let l := (Control.hyps()) in + let l := cut_at h l in + let aboveh := find_above_which false t l in + match aboveh with + | None => () + | Some aboveh => + if Ident.equal aboveh h then () + else Std.move h (Std.MoveAfter aboveh) end. - Notation "X : Y ; Z" := (DCons Y X Z) (at level 1, Z at level 1, right associativity,only printing,format "'[v' X : Y ; '/' Z ']' ") . -End Prgoal_Notation. - - (* example: *) -Import Prgoal_Notation. -Lemma test_espec2: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. -Proof. - intros x hx h_eqone. - (* specevar h_eqone at y. *) - pr_goal. -pr_goal. -Abort. *) +Ltac2 ltac1_move_up_types (h:Ltac1.t) := + let h: ident := Option.get (Ltac1.to_ident h) in + move_up_types h. -(* Default behaviour: generalize hypothesis that we failed to rename, - so that no automatic names are introduced by mistake. Of course one - can do "intros" to reintroduce them. +Local Tactic Notation "Lmove_up_type" hyp(h) := + let tac := ltac2:(h |- ltac1_move_up_types h) in + tac h. - Revert needs to be done in the other direction (so better do ";; - autorename ;!; revertHyp"), and may fail if something depends on - the reverted hyp. So we should revert everything depending on the - unrenamed hyp. *) -Ltac revert_if_norename H := - let t := type of H in - match type of t with - | Prop => match goal with - | _ => let x := fallback_rename_hyp_name t in idtac - (* since we are only in prop it is almost never the case - that something depends on H but if this happens we revert - everything that does. This needs testing. *) - | _ => try generalize dependent H - end - | _ => idtac - end. +(* GLOBAL TACTICS *) -Ltac rename_or_revert H := autorename_strict H + revert H. +Global Ltac move_up_types h := Lmove_up_type h. -(* Some usual tactics one may want to use with onNewHypsOf: *) -(* apply subst using H if possible. *) -(*Ltac substHyp H := - match type of H with - | ?x = ?y => move H at top; (* to ensure subst will take this hyp *) - once (subst x + subst y) - end. *) +(* SUBST WITH ONLY ONE HYP *) (* This is similar to subst x, but ensures that H and only H is used. Even if there is another hyp with the same variable *) -Ltac substHyp H := +Global Ltac substHyp H := match type of H with - | Depl => fail 1 (* fail immediately, we are applying on a list of hyps. *) + (* | Depl => fail 1 (* fail immediately, we are applying on a list of hyps. *) *) | ?x = ?y => (* subst would maybe subst using another hyp, so use replace to be sure *) once ((is_var(x); replace x with y in *; [try clear x ; try clear H] ) @@ -71,280 +70,27 @@ Ltac substHyp H := | _ => idtac end. -(* revert, fails if impossible, should not fail if hyps are ordered in the right order *) -Ltac revertHyp H := revert H. (* revert is a tactic notation, so we need to define this *) - -(* revert if subst fails. Never fail, be careful not to use this tactic in the - left member of a "+" tactical: *) -Ltac subst_or_revert H := try first [progress substHyp H | revert H]. - -(* try subst. Never fail, be careful to not use this tactic in the - left member of a "+" tactical: *) -Ltac subst_or_idtac H := substHyp H. - -Ltac map_tac tac lH := - lazymatch lH with - (DCons _ ?Hyp ?lH') => (try tac Hyp); map_tac tac lH' - | DNil => idtac - end. - -(* Naive variants for lists of hyps. We might want to optimize if - possible like group_up_list. *) -Ltac subst_or_revert_l := map_tac subst_or_revert. -Ltac subst_or_idtac_l := map_tac subst_or_idtac. -Ltac revertHyp_l := map_tac revertHyp. -Ltac substHyp_l := map_tac ltac:(fun x => try substHyp x) substHyp. -Ltac revert_if_norename_l := map_tac revert_if_norename. -Ltac autorename_l := map_tac autorename. - -(* Auto rename all hypothesis *) -Ltac rename_all_hyps := autorename_l all_hyps. - - - -(* return the lowest hyp with type T in segment lH. We suppose lH is -given lower-first. I.e. we return the first hyp of type T. *) -Ltac find_lowest_T T candidate lH := - lazymatch lH with - | (DCons T ?Hyp _) => Hyp - | (DCons _ ?Hyp ?lH') => find_lowest_T T candidate lH' - | _ => candidate - end. - -(* Look into the cache for a hyp of type T. If found, returns the hyp - + the cache where hyp is deleted. *) -Ltac find_in_cache_T cache T := - lazymatch cache with - | DCons ?th ?h ?cache' => - match th with - | T => constr:((cache' , h)) - | _ => - let recres := find_in_cache_T cache' T in - match recres with - | (_,@None T) => constr:((cache,@None T)) - | (?newcache1,?res1) => constr:((DCons th h newcache1 , res1)) - end - end - | _ => constr:((cache,@None T)) - end. - -(* if T is not already present in cache, return the (cache + (h:T)), - otherwise return cache unchanged. *) -Ltac find_in_cache_update cache T h := - match find_in_cache_T cache T with - (?c , None) => constr:((DCons T h c , None)) - | (?c , ?res) => constr:((DCons T h c , res)) - end. - -(* Precondition: x must be "below" y at start *) -(* equivalent to move x before belowme but fails if x=bleowme. This - forces the pre-8.14 behaviour of move below. *) -Ltac move_above x y := - match constr:((x , y)) with - | (?c,?c) => idtac - | _ => move x after y - end. - -(* Precondition: x must be "below" y at start *) -(* equivalent to move x after belowme but fails if x=bleowme *) -Ltac move_below x y := - match constr:((x , y)) with - | (?c,?c) => idtac - | _ => move x before y - end. - - -(* move each hyp in lhyps either after the pivot hyp for its type -found in cache, or just above fstProp if there is no pivot. In this -second case we return a new cache with h as a new pivot. *) -(* Example -There is a number of "segments". A segment for type T is the first set -of consecutive variables of type T, located before the first -Prop-sorted hyp. For sintance there are 2 segments in the goal below, -one is x1-x3 and the other is b1-b2. - - x1 : nat - x2 : nat - x3 : nat <-- pivot for nat - b1 : bool - b2 : bool <-- pivot for bool - H : ... : Prop <-- fstProp - H2: ... : Prop not in lhyps - x : nat <-- in lhyps - b : bool <-- in lhyps - c : Z <-- in lhyps - ======= - ... - -This is described by the three arguments: - -- cache is (DCons bool b2 (DCons nat x3 DNil)) i.e. last variable of - each segment -- lhyps is (DCons nat x (DCons bool b (DCons Z c DNil))) list of - variable to move (may not contain all the badly place variables) -- fstProp is H. - -The goal of group_up_list_ is to move all vars of lhyps to there -segment or above fstProp if there segment does not exist yet. - -invariant: the things in lhyps always need to be moved upward, -otherwise move before and move after work the wrong way. *) -Ltac group_up_list_ fstProp cache lhyps := - lazymatch lhyps with - | DCons ?th ?h ?lhyps' => - match type of th with - | Prop => (* lhyps is supposed to be filtered out of Prop already. *) - idtac "LibHyps: This shoud not happen. Please report."; - group_up_list_ fstProp cache lhyps' - | _ => - let upd := find_in_cache_update cache th h in - lazymatch upd with - | (?newcache , None) => (* there was no pivot for th *) - match fstProp with - | @None => idtac (* No Prop Hyp, don't move *) - | ?hfstprop => move_above h hfstprop - end; - group_up_list_ fstProp constr:(DCons th h cache) lhyps' - | (?newcache , ?theplace) => - (* we append h to its segment, and it becomes the new pivot. *) - (try move_below h theplace); - group_up_list_ fstProp newcache lhyps' - end - end - | DNil => idtac (* no more hyps to move *) - end -. - -Ltac find_in t lh := - match lh with - | DNil => None - | (DCons t ?h ?lh') => h - | (DCons _ ?h ?lh') => find_in t lh' - end. - -(* return a triple for hyps groupinf initiation: -- H: topmost Prop-sorted hyp (where a hyp goes if there is no segment for it). -- list of pivots for each type seen above H (pivot = lowest of the first segment of a type) -- the hypothesis that may need to be moved (not belonging to there first segment). -See group_up_list_ above. - *) -Ltac build_initial_cache_ acc lh := - match acc with - (?fstProp, ?pivots, ?tomove) => - lazymatch lh with - | DNil => constr:((fstProp, pivots , tomove)) - | (DCons ?th ?h ?lh') => - lazymatch type of th with - | Prop => - lazymatch fstProp with (* is this the first Prop? *) - | @None => build_initial_cache_ (h, pivots, tomove) lh' - | _ => build_initial_cache_ (fstProp, pivots, tomove) lh' - end - | _ => (* Type-sorted hyp *) - lazymatch fstProp with (* we haven't reached the fstprop *) - | @None => - (* does this type already have a pivot? if yes don't replace *) - let found := find_in th pivots in - lazymatch found with - | @None => (* no pivot yet, see the next hyp *) - lazymatch lh' with - | (DCons th _ _) => (* h is correctly placed, not the pivot *) - build_initial_cache_ (fstProp, pivots, tomove) lh' - | (DCons _ _ _) => (* h is the pivot for th *) - build_initial_cache_ (fstProp, DCons th h pivots , tomove) lh' - | DNil => (* h is the pivot for th *) - constr:((fstProp, DCons th h pivots , tomove)) - end - | _ => (* there already is a pivot for th, and it needs to move *) - build_initial_cache_ (fstProp, pivots , DCons th h tomove) lh' - end - | _ => (*fstprop already reached, this is not a pivot and needs to move*) - build_initial_cache_ (fstProp, pivots , DCons th h tomove) lh' - end - end - end - end. - -Ltac build_initial_cache lh := build_initial_cache_ constr:((@None, DNil, DNil)) lh. - -Ltac mem x l := - lazymatch l with - | DNil => false - | DCons _ x ?l' => true - | DCons _ _ ?l' => mem x l' - end. - -(* return the intersection of l1 l2 in reverse order of l1 *) -Ltac intersec_ acc l1 l2 := - match l1 with - DNil => acc - | DCons ?th ?h ?l1' => - match (mem h l2) with - | true => intersec_ (DCons th h acc) l1' l2 - | false => intersec_ acc l1' l2 - end - end. - -Ltac intersec l1 l2 := intersec_ DNil l1 l2. - - -(* Move up non-Prop hypothesis of lhyps up in the goal, to make Prop - hyptohesis closer to the conclusion. Also group non-Prop hyps by - same type to win some place in goal printing. - -Note: This tactic takes a list of hyps, you should use the tactical -then_allnh (syntax: ";{! group_up_list }") or then_allnh_rev (syntax: -";{!< group_up_list}"). *) -Ltac group_up_list lhyps := - match build_initial_cache all_hyps with - | (?fstProp, ?cache, ?tomove) => - (* tomove is reversed, but intersec re-reverse *) - let tomove2 := intersec tomove lhyps in - group_up_list_ fstProp cache tomove2 - end. - -(* Stays for compatibility, but for efficiency reason prefer - rename_all_hyps, which applies on the list of hyptohesis to move. - Use the corresponding tactical. *) -Ltac move_up_types H := - let t := type of H in - match t with - Depl => fail "Try to use { } instead of {! }" - | _ => group_up_list constr:(DCons t H DNil) +(* DECOMPOSE LOGICAL CONNECTORS *) + +Global Ltac decomp_logicals h := + idtac;match type of h with + | @ex _ (fun x => _) => let x' := fresh x in let h1 := fresh in destruct h as [x' h1]; decomp_logicals h1 + | @sig _ (fun x => _) => let x' := fresh x in let h1 := fresh in destruct h as [x' h1]; decomp_logicals h1 + | @sig2 _ (fun x => _) (fun _ => _) => let x' := fresh x in + let h1 := fresh in + let h2 := fresh in + destruct h as [x' h1 h2]; + decomp_logicals h1; + decomp_logicals h2 + | @sigT _ (fun x => _) => let x' := fresh x in let h1 := fresh in destruct h as [x' h1]; decomp_logicals h1 + | @sigT2 _ (fun x => _) (fun _ => _) => let x' := fresh x in + let h1 := fresh in + let h2 := fresh in + destruct h as [x' h1 h2]; decomp_logicals h1; decomp_logicals h2 + | and _ _ => let h1 := fresh in let h2 := fresh in destruct h as [h1 h2]; decomp_logicals h1; decomp_logicals h2 + | iff _ _ => let h1 := fresh in let h2 := fresh in destruct h as [h1 h2]; decomp_logicals h1; decomp_logicals h2 + | or _ _ => let h' := fresh in destruct h as [h' | h']; [decomp_logicals h' | decomp_logicals h' ] + | _ => idtac end. -(* -(* Tests *) -Export TacNewHyps.Notations. -Goal forall x1 x3:bool, forall a z e : nat, - z+e = a - -> forall SEP:(True -> True), - a = z+z - -> ((fun f => z = e) true) - -> forall b1 b2 b3 b4: bool, - True -> True. -Proof. - (* Set Ltac Debug. *) - (* then_nh_rev ltac:(intros) ltac:(subst_or_idtac). *) - intros ; {! group_up_list }. - (* intros ? ? ? ? ? ? ? ? ? ?. *) - (* group_up_list (DCons bool b1 DNil). *) - Undo. - intros ; { move_up_types }. - Undo. - intros ; { autorename }; {! group_up_list }. - Undo. - intros ; {subst_or_idtac} ; { autorename } ; {! group_up_list }. - Undo. - Fail progress intros ; { revertHyp }. - intros. - let hyps := all_hyps in - idtac hyps. - Undo 2. - then_eachnh ltac:(intros) ltac:(subst_or_idtac). - Undo. - Fail intros ; { fun h => autorename_strict h }. - intros ; { fun h => idtac h }. - intros ; { ltac:(fun h => idtac h) }. -*) diff --git a/LibHyps/LibSpecialize.v b/LibHyps/LibSpecialize.v deleted file mode 100644 index 1ff133a..0000000 --- a/LibHyps/LibSpecialize.v +++ /dev/null @@ -1,1043 +0,0 @@ -(* Copyright 2021 Pierre Courtieu - This file is part of LibHyps. It is distributed under the MIT - "expat license". You should have recieved a LICENSE file with it. *) - -(* The especialize tactic allows to create subgoals from premises of a - hypothesis. - -From a hypothesis of the form: - -H: forall a b c, A -> B -> C -> X - -one can start a goal for either A and/or B and/or C, while making -evars for a and/pr b and/or c. Duplicating H or not. - -especialize H with a at 2. - -will start a goal GB of type B[a<-?a] and specialize H with ?a and GB. -Changing H into: - -H: forall b c, A[a<-?a] -> C[a<-?a} -> X[a<-?a] - -Note that B must be proved without without supposing A. This tactic -does not implement the exact logical rule (this is work in progress). -This limitation is however not a problem in practice: if B needs A -then the user almost always wants to prove A first. - -The tactic supports sevral evars and/or several sibgoals at once: - -especialize H with a,b at 1,2. -etc. - -Special "at *" form (inspired by exploit from Compcert=:: - -especialize H with a,b,c at *. - -will start goals for all premises (A, B and C in the example above). - -Special "until" form e.g. : - -especialize with a,c A until 2. - -will start goals for all the 2 first premises with evars ?a, and ?c. *) - - -(* proveprem H at i as h. Create an assert for the ith dependent -premiss of hypothesis H and specialize H with the resulting proof. h -is the (optional) name of the asserted premiss. *) - -Ltac freshable t := - let x := fresh t "_dummy_sufx" in - idtac. - -Ltac fresh_unfail H := - match constr:(True) with - | _ => fresh H "_" - | _ => fresh "H_" - end. - -Ltac fail_if_not_hyp c := - tryif is_var(c) then idtac else fail "especialize: please provide a name for the new hyp (with 'as')". - - -Ltac proveprem_as_prem H i idpremis idnewH := - (* prefer this to evar, which is not well "typed" by Ltac (does not - know that it creates an evar (coq bug?). *) - let ev := open_constr:((_:Prop)) in - assert (idpremis:ev); - [|specialize H with (i:=idpremis) as idnewH]. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i) "as" ident(idH) ":" ident(idprem) := proveprem_as_prem H i idprem idH. - -Ltac proveprem_asg_newH H i idpremis := - let prefx := fresh_unfail H in - let idnewH := fresh prefx "spec" in (* FIXME: if H is not freshable? *) - proveprem_as_prem H i idpremis idnewH. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i) "as" "?" ":" ident(idprem) := proveprem_asg_newH H i idprem. - -Ltac proveprem_as_premg H i idnewH := - let prefx := fresh_unfail H in - let idpremis := fresh prefx "prem" in - proveprem_as_prem H i idpremis idnewH. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i) "as" ident(idH) ":" "?" := proveprem_as_premg H i idH. - - -Ltac proveprem_asg_premg H i := - let prefx := fresh_unfail H in - let idnewH := fresh prefx "spec" in - let idpremis := fresh prefx "prem" in - proveprem_as_prem H i idpremis idnewH. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i) "as" "?" ":" "?" := proveprem_asg_premg H i. - -Ltac proveprem_as H i idnewH := - let prefx := fresh_unfail H in - let idpremis := fresh prefx "prem" in - proveprem_as_prem H i idpremis idnewH;[ | clear idpremis]. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i) "as" ident(idH) := proveprem_as H i idH. - - -Ltac proveprem_asg H i := - let prefx := fresh_unfail H in - let idnewH := fresh prefx "spec" in - let idpremis := fresh prefx "prem" in - proveprem_as_prem H i idpremis idnewH;[ | clear idpremis]. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i) "as" "?" := proveprem_asg H i. - - -(* Version where specialize is not given a name (soeither H is a - hypand it is modified, or the new hyp is generalized). *) - -Ltac proveprem_prem H i idpremis := - let ev := open_constr:((_:Prop)) in - assert (idpremis:ev); - [|specialize H with (i:=idpremis)]. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i) ":" ident(idprem) := - fail_if_not_hyp H; - proveprem_prem H i idprem. - -Ltac proveprem_premg H i := - let prefx := fresh_unfail H in - let idpremis := fresh prefx "prem" in - proveprem_prem H i idpremis. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i) ":" "?" := proveprem_premg H i. - -(* same as proveprem_prem but discard the created hypothesis once used in specialization *) -Ltac proveprem H i := - let prefx := fresh_unfail H in - let idpremis := fresh prefx "prem" in - proveprem_prem H i idpremis ; [ | clear idpremis]. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i) := fail_if_not_hyp H;proveprem H i. - -(* Create a subgoal for each dependent premiss of H *) -Ltac proveprem_all H := (especialize H at 1; [| proveprem_all H]) + idtac. - -(* TODO: make the "as" mandatory if G not a hyp. *) -Tactic Notation "especialize" constr(H) "at" "*" := - tryif is_var(H) then proveprem_all H - else - let prefx := fresh_unfail H in - let h := fresh prefx "spec" in - specialize H as h; (* create the hyp *) - proveprem_all h. - -Tactic Notation "especialize" constr(H) "at" "*" "as" ident(idH) := - (let h := fresh idH in - specialize H as h; (* create the hyp *) - proveprem_all h). - -(* Create a subgoal for each dependent premiss of H *) -Ltac proveprem_until H i := - match i with - 0 => idtac - | (S ?i') => (especialize H at 1; [| proveprem_until H i']) - end. - -(* TODO idem: make as mandatory *) -Tactic Notation "especialize" constr(H) "until" constr(i) := - tryif is_var(H) then proveprem_until H i - else - let prefx := fresh_unfail H in - let h := fresh prefx "spec" in - specialize H as h; (* create the hyp *) - proveprem_until h i. - -Tactic Notation "especialize" constr(H) "until" constr(i) "as" ident(idH) := - (let h := fresh idH in - specialize H as h; (* create the hyp *) - proveprem_until h i). - -(* Same but discard the created hypothesis once used in specialization *) -Ltac proveprem_as_2 H idnewH i1 i2 := - let prefx := fresh_unfail H in - let idprem1 := fresh prefx "_prem" in (* FIXME when H is not freshable, and in all others. *) - let idprem2 := fresh prefx "_prem'" in - let ev1 := open_constr:((_:Prop)) in - let ev2 := open_constr:((_:Prop)) in - assert (idprem1:ev1); - [ | - assert (idprem2:ev2); - [|specialize H with (i1:=idprem1) (i2:=idprem2) as idnewH ; clear idprem2 idprem1]]. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i1) "," int_or_var(i2) "as" ident(idH) := proveprem_as_2 H idH i1 i2. - -(* Same but discard the created hypothesis once used in specialization *) -Ltac proveprem_2 H i1 i2 := - let prefx := fresh_unfail H in - let idprem1 := fresh prefx "_prem" in - let idprem2 := fresh prefx "_prem'" in - let ev1 := open_constr:((_:Prop)) in - let ev2 := open_constr:((_:Prop)) in - assert (idprem1:ev1); - [ | - assert (idprem2:ev2); - [|specialize H with (i1:=idprem1) (i2:=idprem2) ; clear idprem2 idprem1]]. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i1) "," int_or_var(i2) := proveprem_2 H i1 i2. - -Ltac proveprem_as_3 H idnewH i1 i2 i3 := - let prefx := fresh_unfail H in - let idprem1 := fresh prefx "_prem" in - let idprem2 := fresh prefx "_prem" in - let idprem3 := fresh prefx "_prem" in - let ev1 := open_constr:((_:Prop)) in - let ev2 := open_constr:((_:Prop)) in - let ev3 := open_constr:((_:Prop)) in - assert (idprem1:ev1); - [ | assert (idprem2:ev2); - [ | assert (idprem3:ev3); - [ | specialize H with (i1:=idprem1) (i2:=idprem2) (i3:=idprem3) as idnewH ; clear idprem3 idprem2 idprem1 ]]]. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i1) "," int_or_var(i2)"," int_or_var(i3) "as" ident(idH) := proveprem_as_3 H idH i1 i2 i3. - -Ltac proveprem_3 H i1 i2 i3 := - let prefx := fresh_unfail H in - let idprem1 := fresh prefx "_prem" in - let idprem2 := fresh prefx "_prem" in - let idprem3 := fresh prefx "_prem" in - let ev1 := open_constr:((_:Prop)) in - let ev2 := open_constr:((_:Prop)) in - let ev3 := open_constr:((_:Prop)) in - assert (idprem1:ev1); - [ | assert (idprem2:ev2); - [ | assert (idprem3:ev3); - [ | specialize H with (i1:=idprem1) (i2:=idprem2) (i3:=idprem3) ; clear idprem3 idprem2 idprem1 ]]]. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i1) "," int_or_var(i2)"," int_or_var(i3) := proveprem_3 H i1 i2 i3. - -Ltac proveprem_as_4 H idnewH i1 i2 i3 i4 := - let prefx := fresh_unfail H in - let idprem1 := fresh prefx "_prem" in - let idprem2 := fresh prefx "_prem" in - let idprem3 := fresh prefx "_prem" in - let idprem4 := fresh prefx "_prem" in - let ev1 := open_constr:((_:Prop)) in - let ev2 := open_constr:((_:Prop)) in - let ev3 := open_constr:((_:Prop)) in - let ev4 := open_constr:((_:Prop)) in - assert (idprem1:ev1); [ - | assert (idprem2:ev2); [ - | assert (idprem3:ev3); [ - | assert (idprem4:ev4); - [ | specialize H with (i1:=idprem1) (i2:=idprem2) (i3:=idprem3) (i4:=idprem4) as idnewH ; - clear idprem4 idprem3 idprem2 idprem1 ]]]]. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i1) "," int_or_var(i2)"," int_or_var(i3) "," int_or_var(i4) "as" ident(idH) := proveprem_as_4 H idH i1 i2 i3 i4. - -Ltac proveprem_4 H i1 i2 i3 i4 := - let prefx := fresh_unfail H in - let idprem1 := fresh prefx "_prem" in - let idprem2 := fresh prefx "_prem" in - let idprem3 := fresh prefx "_prem" in - let idprem4 := fresh prefx "_prem" in - let ev1 := open_constr:((_:Prop)) in - let ev2 := open_constr:((_:Prop)) in - let ev3 := open_constr:((_:Prop)) in - let ev4 := open_constr:((_:Prop)) in - assert (idprem1:ev1); [ - | assert (idprem2:ev2); [ - | assert (idprem3:ev3); [ - | assert (idprem4:ev4); - [ | specialize H with (i1:=idprem1) (i2:=idprem2) (i3:=idprem3) (i4:=idprem4) ; - clear idprem4 idprem3 idprem2 idprem1 ]]]]. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i1) "," int_or_var(i2)"," int_or_var(i3) "," int_or_var(i4) := proveprem_4 H i1 i2 i3 i4. - - -Ltac proveprem_as_5 H idnewH i1 i2 i3 i4 i5 := - let prefx := fresh_unfail H in - let idprem1 := fresh prefx "_prem" in - let idprem2 := fresh prefx "_prem" in - let idprem3 := fresh prefx "_prem" in - let idprem4 := fresh prefx "_prem" in - let idprem5 := fresh prefx "_prem" in - let ev1 := open_constr:((_:Prop)) in - let ev2 := open_constr:((_:Prop)) in - let ev3 := open_constr:((_:Prop)) in - let ev4 := open_constr:((_:Prop)) in - let ev5 := open_constr:((_:Prop)) in - assert (idprem1:ev1); [ - | assert (idprem2:ev2); [ - | assert (idprem3:ev3); [ - | assert (idprem4:ev4); [ - | assert (idprem5:ev5); [ - | specialize H with (i1:=idprem1) (i2:=idprem2) (i3:=idprem3) (i4:=idprem4) (i5:=idprem5) as idnewH ; - clear idprem5 idprem4 idprem3 idprem2 idprem1 ]]]]]. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i1) "," int_or_var(i2)"," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "as" ident(idH) := proveprem_as_5 H idH i1 i2 i3 i4 i5. - -Ltac proveprem_5 H i1 i2 i3 i4 i5 := - let prefx := fresh_unfail H in - let idprem1 := fresh prefx "_prem" in - let idprem2 := fresh prefx "_prem" in - let idprem3 := fresh prefx "_prem" in - let idprem4 := fresh prefx "_prem" in - let idprem5 := fresh prefx "_prem" in - let ev1 := open_constr:((_:Prop)) in - let ev2 := open_constr:((_:Prop)) in - let ev3 := open_constr:((_:Prop)) in - let ev4 := open_constr:((_:Prop)) in - let ev5 := open_constr:((_:Prop)) in - assert (idprem1:ev1); [ - | assert (idprem2:ev2); [ - | assert (idprem3:ev3); [ - | assert (idprem4:ev4); [ - | assert (idprem5:ev5); [ - | specialize H with (i1:=idprem1) (i2:=idprem2) (i3:=idprem3) (i4:=idprem4) (i5:=idprem5); - clear idprem5 idprem4 idprem3 idprem2 idprem1 ]]]]]. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i1) "," int_or_var(i2)"," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) := proveprem_5 H i1 i2 i3 i4 i5. - -Ltac proveprem_as_6 H idnewH i1 i2 i3 i4 i5 i6 := - let prefx := fresh_unfail H in - let idprem1 := fresh prefx "_prem" in - let idprem2 := fresh prefx "_prem" in - let idprem3 := fresh prefx "_prem" in - let idprem4 := fresh prefx "_prem" in - let idprem5 := fresh prefx "_prem" in - let idprem6 := fresh prefx "_prem" in - let ev1 := open_constr:((_:Prop)) in - let ev2 := open_constr:((_:Prop)) in - let ev3 := open_constr:((_:Prop)) in - let ev4 := open_constr:((_:Prop)) in - let ev5 := open_constr:((_:Prop)) in - let ev6 := open_constr:((_:Prop)) in - assert (idprem1:ev1); [ - | assert (idprem2:ev2); [ - | assert (idprem3:ev3); [ - | assert (idprem4:ev4); [ - | assert (idprem5:ev5); [ - | assert (idprem6:ev6); [ - | specialize H with (i1:=idprem1) (i2:=idprem2) (i3:=idprem3) (i4:=idprem4) (i5:=idprem5) (i6:=idprem6) as idnewH ; - clear idprem6 idprem5 idprem4 idprem3 idprem2 idprem1 ]]]]]]. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i1) "," int_or_var(i2)"," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "as" ident(idH) := proveprem_as_6 H idH i1 i2 i3 i4 i5 i6. - -Ltac proveprem_6 H i1 i2 i3 i4 i5 i6 := - let prefx := fresh_unfail H in - let idprem1 := fresh prefx "_prem" in - let idprem2 := fresh prefx "_prem" in - let idprem3 := fresh prefx "_prem" in - let idprem4 := fresh prefx "_prem" in - let idprem5 := fresh prefx "_prem" in - let idprem6 := fresh prefx "_prem" in - let ev1 := open_constr:((_:Prop)) in - let ev2 := open_constr:((_:Prop)) in - let ev3 := open_constr:((_:Prop)) in - let ev4 := open_constr:((_:Prop)) in - let ev5 := open_constr:((_:Prop)) in - let ev6 := open_constr:((_:Prop)) in - assert (idprem1:ev1); [ - | assert (idprem2:ev2); [ - | assert (idprem3:ev3); [ - | assert (idprem4:ev4); [ - | assert (idprem5:ev5); [ - | assert (idprem6:ev6); [ - | specialize H with (i1:=idprem1) (i2:=idprem2) (i3:=idprem3) (i4:=idprem4) (i5:=idprem5) (i6:=idprem6); - clear idprem6 idprem5 idprem4 idprem3 idprem2 idprem1 ]]]]]]. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i1) "," int_or_var(i2)"," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) := proveprem_6 H i1 i2 i3 i4 i5 i6. - -Ltac proveprem_as_7 H idnewH i1 i2 i3 i4 i5 i6 i7 := - let prefx := fresh_unfail H in - let idprem1 := fresh prefx "_prem" in - let idprem2 := fresh prefx "_prem" in - let idprem3 := fresh prefx "_prem" in - let idprem4 := fresh prefx "_prem" in - let idprem5 := fresh prefx "_prem" in - let idprem6 := fresh prefx "_prem" in - let idprem7 := fresh prefx "_prem" in - let ev1 := open_constr:((_:Prop)) in - let ev2 := open_constr:((_:Prop)) in - let ev3 := open_constr:((_:Prop)) in - let ev4 := open_constr:((_:Prop)) in - let ev5 := open_constr:((_:Prop)) in - let ev6 := open_constr:((_:Prop)) in - let ev7 := open_constr:((_:Prop)) in - assert (idprem1:ev1); [ - | assert (idprem2:ev2); [ - | assert (idprem3:ev3); [ - | assert (idprem4:ev4); [ - | assert (idprem5:ev5); [ - | assert (idprem6:ev6); [ - | assert (idprem7:ev7); [ - | specialize H with (i1:=idprem1) (i2:=idprem2) (i3:=idprem3) (i4:=idprem4) (i5:=idprem5) (i6:=idprem6) (i7:=idprem7) as idnewH ; - clear idprem7 idprem6 idprem5 idprem4 idprem3 idprem2 idprem1 ]]]]]]]. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i1) "," int_or_var(i2)"," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "," int_or_var(i7) "as" ident(idH) := proveprem_as_7 H idH i1 i2 i3 i4 i5 i6 i7. - -Ltac proveprem_7 H i1 i2 i3 i4 i5 i6 i7:= - let prefx := fresh_unfail H in - let idprem1 := fresh prefx "_prem" in - let idprem2 := fresh prefx "_prem" in - let idprem3 := fresh prefx "_prem" in - let idprem4 := fresh prefx "_prem" in - let idprem5 := fresh prefx "_prem" in - let idprem6 := fresh prefx "_prem" in - let idprem7 := fresh prefx "_prem" in - let ev1 := open_constr:((_:Prop)) in - let ev2 := open_constr:((_:Prop)) in - let ev3 := open_constr:((_:Prop)) in - let ev4 := open_constr:((_:Prop)) in - let ev5 := open_constr:((_:Prop)) in - let ev6 := open_constr:((_:Prop)) in - let ev7 := open_constr:((_:Prop)) in - assert (idprem1:ev1); [ - | assert (idprem2:ev2); [ - | assert (idprem3:ev3); [ - | assert (idprem4:ev4); [ - | assert (idprem5:ev5); [ - | assert (idprem6:ev6); [ - | assert (idprem7:ev7); [ - | specialize H with (i1:=idprem1) (i2:=idprem2) (i3:=idprem3) (i4:=idprem4) (i5:=idprem5) (i6:=idprem6) (i7:=idprem7); - clear idprem7 idprem6 idprem5 idprem4 idprem3 idprem2 idprem1 ]]]]]]]. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i1) "," int_or_var(i2)"," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "," int_or_var(i7) := proveprem_7 H i1 i2 i3 i4 i5 i6 i7. - - -Tactic Notation "especialize" constr(H) "at" int_or_var(i) "as" "?" := - let nme := fresh in - especialize H at i as nme. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i1) "," int_or_var(i2) "as" "?" := - let nme := fresh in - especialize H at i1,i2 as nme. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "as" "?" := - let nme := fresh in - especialize H at i1,i2,i3 as nme. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "as" "?" := - let nme := fresh in - especialize H at i1,i2,i3,i4 as nme. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "as" "?" := - let nme := fresh in - especialize H at i1,i2,i3,i4,i5 as nme. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "as" "?" := - let nme := fresh in - especialize H at i1,i2,i3,i4,i5,i6 as nme. - -Tactic Notation "especialize" constr(H) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "," int_or_var(i7) "as" "?" := - let nme := fresh in - especialize H at i1,i2,i3,i4,i5,i6,i7 as nme. - - - - -(* Adding a phase of evar creation for premises that should be solved - by side effect of proving others. NOTE that there is no mechanism - to ensure that these evar are actually solved when subgoals are - proved. You may want to try "unshelve especialize ..." to have a - look at created evars. - -NOTE: All these tactic notations would be greatly simplified if there -were a way of iterating on a list_int_sep and/or on list_ident_sep and -on the list of "with bindindgs". Probablt Ltac2 would be much better -at this. *) - -Ltac spec_evar H id_name := - let idt := fresh id_name "T" in - let id := fresh id_name in - evar (idt : Type); - evar (id : idt); - specialize H with (id_name := id); subst id; subst idt. - - -Tactic Notation "especialize" constr(H) "with" ident(id) "at" "*" := - fail_if_not_hyp H; - spec_evar H id; - especialize H at * . -Tactic Notation "especialize" constr(oldH) "with" ident(id) "at" "*" "as" ident(H) := - specialize oldH as H; - especialize H with id at *. -Tactic Notation "especialize" constr(H) "with" ident(id) "at" "*" "as" "?" := - let nme := fresh in - especialize H with id at * as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id) "until" constr(i) := - fail_if_not_hyp H; - spec_evar H id; - especialize H until i . -Tactic Notation "especialize" constr(oldH) "with" ident(id) "until" constr(i) "as" ident(H) := - specialize oldH as H; - especialize H with id until i. -Tactic Notation "especialize" constr(H) "with" ident(id) "until" constr(i) "as" "?" := - let nme := fresh in - especialize H with id until i as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id) "at" int_or_var(i) := - fail_if_not_hyp H; - spec_evar H id; - especialize H at i . -Tactic Notation "especialize" constr(oldH) "with" ident(id) "at" int_or_var(i) "as" ident(H) := - specialize oldH as H; - especialize H with id at i. -Tactic Notation "especialize" constr(H) "with" ident(id) "at" int_or_var(i) "as" "?" := - let nme := fresh in - especialize H with id at i as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id) "at" int_or_var(i) ":" ident(hprem) := - fail_if_not_hyp H; - spec_evar H id; - especialize H at i : hprem. -Tactic Notation "especialize" constr(oldH) "with" ident(id) "at" int_or_var(i) "as" ident(H) ":" ident(hprem) := - specialize oldH as H; - especialize H with id at i : hprem. -Tactic Notation "especialize" constr(H) "with" ident(id) "at" int_or_var(i) "as" "?" ":" ident(hprem) := - let nme := fresh in - especialize H with id at i as nme : hprem. - -Tactic Notation "especialize" constr(H) "with" ident(id) "at" int_or_var(i1) "," int_or_var(i2) := - fail_if_not_hyp H; - spec_evar H id; - especialize H at i1,i2 . -Tactic Notation "especialize" constr(oldH) "with" ident(id) "at" int_or_var(i1) "," int_or_var(i2) "as" ident(H) := - specialize oldH as H; - especialize H with id at i1,i2. -Tactic Notation "especialize" constr(H) "with" ident(id) "at" int_or_var(i1) "," int_or_var(i2) "as" "?" := - let nme := fresh in - especialize H with id at i1,i2 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) := - fail_if_not_hyp H; - spec_evar H id; - especialize H at i1,i2,i3. -Tactic Notation "especialize" constr(oldH) "with" ident(id) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "as" ident(H) := - specialize oldH as H; - especialize H with id at i1,i2,i3. -Tactic Notation "especialize" constr(H) "with" ident(id) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "as" "?" := - let nme := fresh in - especialize H with id at i1,i2,i3 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) := - fail_if_not_hyp H; - spec_evar H id; - especialize H at i1,i2,i3,i4 . -Tactic Notation "especialize" constr(oldH) "with" ident(id) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "as" ident(H) := - specialize oldH as H; - especialize H with id at i1,i2,i3,i4. -Tactic Notation "especialize" constr(H) "with" ident(id) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "as" "?" := - let nme := fresh in - especialize H with id at i1,i2,i3,i4 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) := - fail_if_not_hyp H; - spec_evar H id; - especialize H at i1,i2,i3,i4,i5 . -Tactic Notation "especialize" constr(oldH) "with" ident(id) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "as" ident(H) := - specialize oldH as H; - especialize H with id at i1,i2,i3,i4,i5 . -Tactic Notation "especialize" constr(H) "with" ident(id) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "as" "?" := - let nme := fresh in - especialize H with id at i1,i2,i3,i4,i5 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) := - fail_if_not_hyp H; - spec_evar H id; - especialize H at i1,i2,i3,i4,i5,i6. -Tactic Notation "especialize" constr(oldH) "with" ident(id) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "as" ident(H) := - specialize oldH as H; - especialize H with id at i1,i2,i3,i4,i5,i6. -Tactic Notation "especialize" constr(H) "with" ident(id) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "as" "?" := - let nme := fresh in - especialize H with id at i1,i2,i3,i4,i5,i6 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "," int_or_var(i7) := - fail_if_not_hyp H; - spec_evar H id; - especialize H at i1,i2,i3,i4,i5,i6,i7. -Tactic Notation "especialize" constr(oldH) "with" ident(id) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "," int_or_var(i7) "as" ident(H) := - specialize oldH as H; - especialize H with id at i1,i2,i3,i4,i5,i6,i7. -Tactic Notation "especialize" constr(H) "with" ident(id) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "," int_or_var(i7) "as" "?" := - let nme := fresh in - especialize H with id at i1,i2,i3,i4,i5,i6,i7 as nme. - - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "at" "*" := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2 at *. -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "at" "*" "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2 at *. -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "at" "*" "as" "?" := - let nme := fresh in - especialize H with id1,id2 at * as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "until" constr(i) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2 until i . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "until" constr(i) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2 until i . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "until" constr(i) "as" "?" := - let nme := fresh in - especialize H with id1,id2 until i as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "at" int_or_var(i) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2 at i . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "at" int_or_var(i) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2 at i . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "at" int_or_var(i) "as" "?" := - let nme := fresh in - especialize H with id1,id2 at i as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "at" int_or_var(i) ":" ident(hprem) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2 at i : hprem. -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "at" int_or_var(i) "as" ident(H) ":" ident(hprem) := - specialize oldH as H; - especialize H with id1,id2 at i : hprem. -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "at" int_or_var(i) "as" "?" ":" ident(hprem) := - let nme := fresh in - especialize H with id1,id2 at i as nme : hprem. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "at" int_or_var(i1) "," int_or_var(i2) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2 at i1,i2 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "at" int_or_var(i1) "," int_or_var(i2) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2 at i1,i2 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "at" int_or_var(i1) "," int_or_var(i2) "as" "?" := - let nme := fresh in - especialize H with id1,id2 at i1,i2 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2 at i1,i2,i3 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2 at i1,i2,i3 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "as" "?" := - let nme := fresh in - especialize H with id1,id2 at i1,i2,i3 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2 at i1,i2,i3,i4 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2 at i1,i2,i3,i4 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "as" "?" := - let nme := fresh in - especialize H with id1,id2 at i1,i2,i3,i4 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2 at i1,i2,i3,i4,i5 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2 at i1,i2,i3,i4,i5 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "as" "?" := - let nme := fresh in - especialize H with id1,id2 at i1,i2,i3,i4,i5 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2 at i1,i2,i3,i4,i5,i6 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2 at i1,i2,i3,i4,i5,i6 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "as" "?" := - let nme := fresh in - especialize H with id1,id2 at i1,i2,i3,i4,i5,i6 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "," int_or_var(i7) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2 at i1,i2,i3,i4,i5,i6,i7 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "," int_or_var(i7) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2 at i1,i2,i3,i4,i5,i6,i7 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "," int_or_var(i7) "as" "?" := - let nme := fresh in - especialize H with id1,id2 at i1,i2,i3,i4,i5,i6,i7 as nme. - - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "at" "*" := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3 at *. -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "at" "*" "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3 at *. -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "at" "*" "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3 at * as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "until" constr(i) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3 until i . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "until" constr(i) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3 until i . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "until" constr(i) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3 until i as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3 at i . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3 at i . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3 at i as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i) ":" ident(hprem) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3 at i : hprem. -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i) "as" ident(H) ":" ident(hprem) := - specialize oldH as H; - especialize H with id1,id2,id3 at i : hprem. -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i) "as" "?" ":" ident(hprem) := - let nme := fresh in - especialize H with id1,id2,id3 at i as nme : hprem. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i1) "," int_or_var(i2) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3 at i1,i2. -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i1) "," int_or_var(i2) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3 at i1,i2 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i1) "," int_or_var(i2) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3 at i1,i2 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3 at i1,i2,i3 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3 at i1,i2,i3 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3 at i1,i2,i3 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3 at i1,i2,i3,i4 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3 at i1,i2,i3,i4 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3 at i1,i2,i3,i4 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3 at i1,i2,i3,i4,i5 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3 at i1,i2,i3,i4,i5 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3 at i1,i2,i3,i4,i5 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3 at i1,i2,i3,i4,i5,i6 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3 at i1,i2,i3,i4,i5,i6 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3 at i1,i2,i3,i4,i5,i6 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "," int_or_var(i7) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3 at i1,i2,i3,i4,i5,i6,i7 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "," int_or_var(i7) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3 at i1,i2,i3,i4,i5,i6,i7 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "," int_or_var(i7) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3 at i1,i2,i3,i4,i5,i6,i7 as nme. - - - - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" "*" := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4 at *. -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" "*" "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3,id4 at *. -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" "*" "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3,id4 at * as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "until" constr(i) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4 until i . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "until" constr(i) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3,id4 until i . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "until" constr(i) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3,id4 until i as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4 at i . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3,id4 at i . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3,id4 at i as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i) ":" ident(hprem) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4 at i : hprem. -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i) "as" ident(H) ":" ident(hprem) := - specialize oldH as H; - especialize H with id1,id2,id3,id4 at i : hprem. -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i) "as" "?" ":" ident(hprem) := - let nme := fresh in - especialize H with id1,id2,id3,id4 at i as nme : hprem. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i1) "," int_or_var(i2) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4 at i1,i2 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i1) "," int_or_var(i2) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3,id4 at i1,i2 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i1) "," int_or_var(i2) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3,id4 at i1,i2 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4 at i1,i2,i3 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3,id4 at i1,i2,i3 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3,id4 at i1,i2,i3 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4 at i1,i2,i3,i4 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3,id4 at i1,i2,i3,i4 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3,id4 at i1,i2,i3,i4 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4 at i1,i2,i3,i4,i5 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3,id4 at i1,i2,i3,i4,i5 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3,id4 at i1,i2,i3,i4,i5 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4 at i1,i2,i3,i4,i5,i6 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3,id4 at i1,i2,i3,i4,i5,i6 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3,id4 at i1,i2,i3,i4,i5,i6 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "," int_or_var(i7) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4 at i1,i2,i3,i4,i5,i6,i7 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "," int_or_var(i7) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3,id4 at i1,i2,i3,i4,i5,i6,i7 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "," int_or_var(i7) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3,id4 at i1,i2,i3,i4,i5,i6,i7 as nme. - - - - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" "*" := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4,id5 at *. -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" "*" "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3,id4,id5 at *. -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" "*" "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3,id4,id5 at * as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "until" constr(i) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4,id5 until i. -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "until" constr(i) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3,id4,id5 until i . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "until" constr(i) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3,id4,id5 until i as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4,id5 at i . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3,id4,id5 at i . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3,id4,id5 at i as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i) ":" ident(hprem) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4,id5 at i : hprem. -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i) "as" ident(H) ":" ident(hprem) := - specialize oldH as H; - especialize H with id1,id2,id3,id4,id5 at i : hprem. -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i) "as" "?" ":" ident(hprem) := - let nme := fresh in - especialize H with id1,id2,id3,id4,id5 at i as nme : hprem. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4,id5 at i1,i2 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3,id4,id5 at i1,i2 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3,id4,id5 at i1,i2 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4,id5 at i1,i2 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3,id4,id5 at i1,i2 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3,id4,id5 at i1,i2 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4,id5 at i1,i2,i3 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3,id4,id5 at i1,i2,i3 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3,id4,id5 at i1,i2,i3 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4,id5 at i1,i2,i3,i4 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3,id4,id5 at i1,i2,i3,i4 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3,id4,id5 at i1,i2,i3,i4 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4,id5 at i1,i2,i3,i4,i5 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3,id4,id5 at i1,i2,i3,i4,i5 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3,id4,id5 at i1,i2,i3,i4,i5 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4,id5 at i1,i2,i3,i4,i5,i6 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3,id4,id5 at i1,i2,i3,i4,i5,i6 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3,id4,id5 at i1,i2,i3,i4,i5,i6 as nme. - -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "," int_or_var(i7) := - fail_if_not_hyp H; - spec_evar H id1; - especialize H with id2,id3,id4,id5 at i1,i2,i3,i4,i5,i6,i7 . -Tactic Notation "especialize" constr(oldH) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "," int_or_var(i7) "as" ident(H) := - specialize oldH as H; - especialize H with id1,id2,id3,id4,id5 at i1,i2,i3,i4,i5,i6,i7 . -Tactic Notation "especialize" constr(H) "with" ident(id1) "," ident(id2) "," ident(id3) "," ident(id4) "," ident(id5) "at" int_or_var(i1) "," int_or_var(i2) "," int_or_var(i3) "," int_or_var(i4) "," int_or_var(i5) "," int_or_var(i6) "," int_or_var(i7) "as" "?" := - let nme := fresh in - especialize H with id1,id2,id3,id4,id5 at i1,i2,i3,i4,i5,i6,i7 as nme. - diff --git a/LibHyps/TacNewHyps.v b/LibHyps/TacNewHyps.v index 7322d61..90567b9 100644 --- a/LibHyps/TacNewHyps.v +++ b/LibHyps/TacNewHyps.v @@ -29,268 +29,154 @@ *) -(* Credit for the harvesting of hypothesis: Jonathan Leivant *) -Ltac harvest_hyps harvester := constr:(ltac:(harvester; constructor) : True). -Ltac harvest_hyps_h harvester h := constr:(ltac:(harvester h; constructor) : True). - -(* This will be stuck on section variables if some hypothesis really - depends on it. We can use "revert dependent" but the hypothesis - remains in the goal and make this tactic loop. The trick consisting - of marking hyms with (id) fails on types. Needs more thinking. - Meanwhile harvest_hyps will fail on some section variables. *) -Ltac revert_clearbody_all := - repeat lazymatch goal with - H : _ |- _ => try clearbody H; revert H - end. - -Ltac revert_clearbody_above Hyp := - lazymatch goal with - | _H : ?T |- _ => - match constr:((_H , Hyp)) with - | (?h,?h) => let dummy := constr:(ltac:(apply eq_refl): _H=Hyp) in - (* we have foud Hyp, clear it and register everything up *) - clear _H; revert_clearbody_all - | _ => clear _H; revert_clearbody_above Hyp - end - end. -(* THE GENERIC MECHANISM is to have a tactic that applies directly to - the *list* of hypothesis. Most of the time it will be a simpl - iteration on each hypothesis independently, but sometimes for - efficiency we will need to be smarter (e.g. group_up_list). We - don't use directly the product build by harvest_hyps for efficiency - reasons. Instead we use the dependent list Depl defined below. *) -Inductive Depl := - | DNil: Depl - | DCons: forall (A:Type) (x:A), Depl -> Depl. - -(* Transforming the product from harvest_hyps into a Depl. *) -Ltac prod_to_list_ acc prod := - match prod with - | (?prod' ?h) => - let t := type of h in - let acc := constr:(DCons t h acc) in - prod_to_list_ acc prod' - | _ => acc - end. +Require Import Ltac2.Ltac2. -Ltac prod_to_list prod := prod_to_list_ DNil prod. +From Ltac2 Require Import Option Constr Printf. +Import Constr.Unsafe. +Local Set Default Proof Mode "Classic". +(* Require Import LibHyps.LibHypsDebug. *) -(* Same but reversing the list. *) -Ltac prod_to_list_rev prod := - match prod with - | (?prod' ?h) => - let t := type of h in - let recres := prod_to_list_rev prod' in - constr:(DCons t h recres) - | _ => DNil +(* Utilities *) +Local Ltac2 is_dep_prod (t:constr): bool := + match kind t with + | Prod _ subt => Bool.neg (is_closed subt) + | _ => false end. -(* { BUILDING THE LIST OF ALL HYPS } *) - -(* Builds the DList of all hyps *) -Ltac all_hyps := let prod := harvest_hyps revert_clearbody_all in prod_to_list prod. -Ltac all_hyps_rev := let prod := harvest_hyps revert_clearbody_all in prod_to_list_rev prod. - -(* { BUILDING THE LIST OF ALL HYPS ABOVE H }. (useful?). *) -Ltac up_segment H := - let prod := harvest_hyps_h revert_clearbody_above H in prod_to_list prod. -Ltac up_segment_rev H := - let prod := harvest_hyps_h revert_clearbody_above H in prod_to_list_rev prod. - -(* { GENERATING THE LIST OF "NEW" HYPOTHESIS } *) - -(* Remark: this version has several potential efficiency problems: - -1) it is quadratic, but this may be unavoidable unless we replace list -by trees. - -2) it looks for hyp (context) names inside types, instead of only hyp -names. Since context is quite fast it does not seem much visible, -but on big types (class types for instance) it may become problematic. - -I have tried to optimize more the filtering. Mainly trying to avoid to -look at types by iterating by hand in ltac on the list. No real -speedup was observed. - -The filter_new_hyps_optim tactic does speed up significantly in most -cases. *) - -(* Builds the list (DCons/DNil) of hypothesis appearing in lh2 that - are not present in lh1. This version may be slow on big types - because of the "context" will dive into them uselessly. However on - standard goals it is quite efficient. See below for - optimizations. *) -Ltac filter_new_hyps lh2 lh1 := - match lh2 with - (DCons _ ?h ?lh2') => - match lh1 with - (* This context is fast but it may have bad complexity on big hyps - types (e.g. type classes). *) - | context [h] => filter_new_hyps lh2' lh1 - | _ => let th := type of h in - let recres := filter_new_hyps lh2' lh1 in - constr:(DCons th h recres) - end - | _ => DNil - end. +Local Ltac2 pr_list (pr: unit -> 'a -> message) () (l: 'a list) := + let rec pr_list_ () (l: 'a list) := + match l with + | [] => fprintf "" + | [e] => fprintf "%a" pr e + | e::l' => fprintf "%a , %a" pr e pr_list_ l' + end in + fprintf "[ %a ]" pr_list_ l. -(* This naive optimization works pretty well since most of the time - lh1 and lh2 share a significant prefix. *) -Ltac filter_new_hyps_optim lh2 lh1 := - lazymatch lh2 with - | (DCons _ ?h ?lh2') => - lazymatch lh1 with - | (DCons _ h ?lh1') => - filter_new_hyps_optim lh2' lh1' - | _ => filter_new_hyps lh2 lh1 - end - | _ => filter_new_hyps lh2 lh1 - end. -(* { TACTICALS ITERATING ON A GIVEN LIST OF HYPOTHESIS } *) +(* Pure Ltac2 tactics *) +Module Ltac2. + Ltac2 all_hyps_ident() := List.map (fun (x,_,_) => x) (Control.hyps ()). -(* Default way of iterating a tactic on all elements of a Decl. *) -Ltac map_hyps tac l := - match l with - | DNil => idtac - | DCons _ ?h ?l' => tac h; map_hyps tac l' - end. + Ltac2 iter_hyps (tac:ident -> unit) (lh:ident list) := + List.iter tac lh. -(* Same thing in reverse order. Prefer map_hyps on reversed list? *) -Ltac map_hyps_rev tac l := - match l with - | DNil => idtac - | DCons _ ?h ?l' => map_hyps_rev tac l'; tac h - end. + Ltac2 map_all_hyps (tac:'a -> unit) := + let all_hyps := all_hyps_ident() in + iter_hyps tac all_hyps. + + Ltac2 map_all_hyps_rev (tac: 'a -> unit) := + let all_hyps := List.rev (all_hyps_ident()) in + iter_hyps tac all_hyps. + + Ltac2 then_eachnh_gen (tac1:'a -> unit) (tac2:ident -> unit) (rev:bool) := + let hyps_before := all_hyps_ident() in + let _ := tac1() in + Control.enter + (fun () => + let hyps_after := all_hyps_ident() in + let new_hyps: ident list := List.filter_out (fun id => List.mem Ident.equal id hyps_before) hyps_after in + iter_hyps tac2 (if rev then List.rev new_hyps else new_hyps)). + + Ltac2 then_eachnh (tac1:'a -> unit) (tac2:ident -> unit) := + then_eachnh_gen tac1 tac2 false. + + Ltac2 then_eachnh_rev (tac1:'a -> unit) (tac2:ident -> unit) := + then_eachnh_gen tac1 tac2 true. + +End Ltac2. + +(* Ltac2 tacticals on Ltac1 tactics and values. Mainly work + translating them to ltac2 values and call tactical from Ltac2 + above.*) +Module Ltac1. + Ltac2 apply_run (tac:Ltac1.t) lid := + let larg := List.map Ltac1.of_ident lid in + Ltac1.apply tac larg (fun t => Ltac1.run t). + + Ltac2 iter_hyps (tac:Ltac1.t) (lh:ident list): unit := + let tac2:ident -> unit := (fun (id:ident) => apply_run tac [id]) in + Ltac2.iter_hyps tac2 lh. + + (* Iterate tac on all hyps of a goal, top to bottom or reverse. *) + + Ltac2 map_all_hyps (tac:Ltac1.t) := + let tac2:ident -> unit := (fun (id:ident) => apply_run tac [id]) in + Ltac2.map_all_hyps tac2. + + Ltac2 map_all_hyps_rev (tac:Ltac1.t) := + let tac2:ident -> unit := (fun (id:ident) => apply_run tac [id]) in + Ltac2.map_all_hyps_rev tac2. + + Ltac2 then_eachnh (tac1:Ltac1.t) (tac2:Ltac1.t) := + let tac1':unit -> unit := (fun () => Ltac1.run tac1) in + let tac2':ident -> unit := (fun id => apply_run tac2 [id]) in + Ltac2.then_eachnh tac1' tac2'. + + Ltac2 then_eachnh_rev (tac1:Ltac1.t) (tac2:Ltac1.t) := + let tac1':unit -> unit := (fun () => Ltac1.run tac1) in + let tac2':ident -> unit := (fun id => apply_run tac2 [id]) in + Ltac2.then_eachnh_rev tac1' tac2'. +End Ltac1. + +Ltac map_all_hyps tac := + let t := ltac2:(tac |- Ltac1.map_all_hyps tac) in + t tac. + +Ltac map_all_hyps_rev tac := + let t := ltac2:(tac |- Ltac1.map_all_hyps_rev tac) in + t tac. + +(* Ltac tacticals *) +Ltac then_eachnh tac1 tac2 := + let t := ltac2:(tac1 tac2 |- Ltac1.then_eachnh tac1 tac2) in + t tac1 tac2. + +Ltac then_eachnh_rev tac1 tac2 := + let t := ltac2:(tac1 tac2 |- Ltac1.then_eachnh_rev tac1 tac2) in + t tac1 tac2. + + (* then_allnh_rev tac1 ltac:(map_hyps tac2). *) +(* Ltac then_eachnh tac1 tac2 := then_allnh tac1 ltac:(map_hyps tac2). *) -(* { TACTICALS ITERATING ON ALL HYPOTHESIS OF A GOAL } *) -(* Iterate tac on all hyps of a goal, top to bottom or reverse. *) -Ltac map_all_hyps tac := map_hyps tac all_hyps. -Ltac map_all_hyps_rev tac := map_hyps tac all_hyps_rev. (* For less parenthesis: OnAllHyp tacA;tac2. *) -Tactic Notation (at level 4) "onAllHyps" tactic(Tac) := (map_all_hyps Tac). -Tactic Notation (at level 4) "onAllHypsRev" tactic(Tac) := (map_all_hyps_rev Tac). - -(* { TACTICALS ITERATING ON *NEW* HYPOTHESIS AFTER APPLYING A TACTIC } - -The most common tacticals are then_eachnh and then_eachnh_rev, use -then_allnh and then_allnh_rev for efficiency reason (see e.g. -LibHyps.group_up_list). *) - -Ltac then_allnh_gen gathertac tac1 tac2 := - let hyps_before_tac := gathertac idtac in - tac1; - let hyps_after_tac := gathertac idtac in - let l_new_hyps := filter_new_hyps_optim hyps_after_tac hyps_before_tac in - tac2 l_new_hyps. - -(* [then_allnh tac1 tac2] and [then_allnh_rev tac1 tac2] applies tac1 and - then applies tac2 on the list of *new* hypothesis of the resulting - goals. The list is of type [Decl]. - NOTE: tac2 must operates directly on the whole list. For - single-goal minded tac2, use then_eachnh(_rev), below. *) -Ltac then_allnh tac1 tac2 := then_allnh_gen ltac:(fun x => all_hyps) tac1 tac2. -Ltac then_allnh_rev tac1 tac2 := then_allnh_gen ltac:(fun x => all_hyps_rev) tac1 tac2. -(* For a single-goal-minded tac2 (most common use case). *) -Ltac then_eachnh_rev tac1 tac2 := then_allnh_rev tac1 ltac:(map_hyps tac2). -Ltac then_eachnh tac1 tac2 := then_allnh tac1 ltac:(map_hyps tac2). +Tactic Notation (at level 4) "onAllHyps" tactic(tac) := map_all_hyps tac. +Tactic Notation (at level 4) "onAllHypsRev" tactic(tac) := map_all_hyps_rev tac. Module Notations. (* Default syntax: *) - Tactic Notation (at level 4) tactic4(tac)";" "{!" tactic(tach) "}" := then_allnh tac tach. - Tactic Notation (at level 4) tactic4(tac)";" "{!<" tactic(tach)"}":= then_allnh_rev tac tach. + (* Tactic Notation (at level 4) tactic4(tac)";" "{!" tactic(tach) "}" := then_allnh tac tach. *) + (* Tactic Notation (at level 4) tactic4(tac)";" "{!<" tactic(tach)"}":= then_allnh_rev tac tach. *) (* single-goal-minded tach (most common use case). *) Tactic Notation (at level 4) tactic4(tac)";" "{" tactic(tach)"}":= then_eachnh tac tach. Tactic Notation (at level 4) tactic4(tac)";" "{<" tactic(tach)"}":= then_eachnh_rev tac tach. (* Legacy tacticals. Warning: not applicable for tactic operating directly on a list of hyps *) - Tactic Notation (at level 4) tactic4(tac) ";;" tactic4(tach) := then_eachnh tac tach. - Tactic Notation (at level 4) tactic4(tac) ";!;" tactic4(tach) := (then_eachnh_rev tac tach). + (* Tactic Notation (at level 4) tactic4(tac) ";;" tactic4(tach) := then_eachnh tac tach. *) + (* Tactic Notation (at level 4) tactic4(tac) ";!;" tactic4(tach) := (then_eachnh_rev tac tach). *) End Notations. -(* -(* Tests. *) -Ltac r h := revert h. -Ltac rl lh := - match lh with - DCons ?t ?h ?lh' => revert h; rl lh' - | DNil => idtac - end. - - -Ltac p h := idtac h. -Ltac pl lh := - match lh with - DCons ?t ?h ?lh' => idtac h; pl lh' - | DNil => idtac - end. - -(* dummy rename *) -Ltac n h := let nm := fresh "h" in rename h into nm. -Ltac nl lh := - match lh with - DCons ?t ?h ?lh' => (let nm := fresh "h" in rename h into nm) ; nl lh' - | DNil => idtac - end. - -Import TacNewHyps.Notations. -Goal forall x1:bool, forall a z e r t z e r t z e r t z e r t y: nat, True -> forall u i o p q s d f g:nat, forall x2:bool, True -> True. -Proof. - (* intros. let l := all_hyps in idtac l. (* pb dans l'ordre entre map_hyp et all_hyp *) *) - (* intros ;; n. *) - - intros ; { p }; { n }; { r }. - Undo. - intros ; {! pl } ; { n }; { r }. - Undo. - intros ; { n }; { p }; { r }. - Undo. - intros ; {! nl }; { p }; { r }. - Undo. -Import TacNewHyps.SimpleNotations. - - intros ;!; ltac:(fun h => idtac h) ;; ltac:(fun h => revert h). - - ;!; ltac:(fun h => idtac h) - then_nh ltac:(intros) ltac:(revert_l). *) - -(* Testing speedup for filter_new_hyps_optim, when there is a common -prefix in the two lists. *) +Import Notations. (* -Lemma foo: - forall (_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - : (forall (_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - :nat), True)) - (a b:bool), True -> forall y z:nat, True. - intros. - Ltac prefx n l := - lazymatch n with - 0%nat => DNil - | S ?n' => - lazymatch l with - DCons ?a ?b ?l' => let p := prefx n' l' in constr:(DCons a b p) - | DNil => DNil - | _ => fail - end - end. - - time let all := all_hyps in - let few := prefx 20 all in - let diff := filter_new_hyps_optim all few in - idtac. +Goal forall n m p q : nat, n m

p<=q -> True. +Proof. + intros n m p q H H0 H1. + Unset Silent. + map_all_hyps ltac:(fun h => idtac h). + map_all_hyps_rev ltac:(fun h => idtac h). + onAllHyps (fun h => idtac h). + onAllHypsRev (fun h => idtac h). + ltac2:(Ltac2.then_eachnh (fun () => induction H) (fun id => printf "%I" id)). + Undo 1. + then_eachnh ltac:(induction H) ltac:(fun h => idtac h). + Undo 1. + then_eachnh_rev ltac:(induction H) ltac:(fun h => idtac h). + Undo 1. + induction H ;{ fun h => idtac h }. + Undo 1. + induction H ;{< fun h => idtac h }. *) diff --git a/LibHyps/especialize_ltac2.v b/LibHyps/especialize_ltac2.v deleted file mode 100644 index 6c294ee..0000000 --- a/LibHyps/especialize_ltac2.v +++ /dev/null @@ -1,901 +0,0 @@ -From Stdlib Require Import String. -Require ident_of_string. -Require Import Ltac2.Ltac2. -From Ltac2 Require Import Option Constr Printf. -Import Constr.Unsafe. -Declare Scope specialize_scope. -Delimit Scope specialize_scope with spec. -Local Open Scope specialize_scope. - -From Stdlib Require Import String Ascii. -Open Scope string_scope. -Local Set Default Proof Mode "Classic". - -(* -Require Import LibHyps.LibHypsTactics. - -(* debug *) -Module Prgoal_Notation. - Ltac pr_goal := - match goal with - |- ?g => - let allh := harvest_hyps revert_clearbody_all in - (* let allh := all_hyps in *) - idtac allh " ⊢ " g - end. -End Prgoal_Notation. - - -Local Ltac2 tag_info s := (String.concat "" [ ""; s; "" ]). -Local Ltac2 tag_msg m := Message.concat - (Message.concat (Message.of_string "") m) - (Message.of_string ""). -Local Ltac2 str_to_msg s := tag_msg (Message.of_string s). -Local Ltac2 int_to_msg i := tag_msg (Message.of_int i). -Local Ltac2 id_to_msg id := tag_msg (Message.of_ident id). -Local Ltac2 constr_to_msg c := tag_msg (Message.of_constr c). - -Local Ltac2 msgs s := Message.print (str_to_msg s). -Local Ltac2 msgi i := Message.print (int_to_msg i). -Local Ltac2 msgc c := Message.print (constr_to_msg c). -Local Ltac2 msgid id := Message.print (id_to_msg id). - - -Ltac2 pr_binder () (b:binder) := - let nme:ident option := Binder.name b in - let typ:constr := Binder.type b in - fprintf "(%I:%t)" (Option.get nme) typ. -*) - -(* the type describing how to specialize the arguments of a hyp *) -Inductive spec_arg : Type := - (* This 4 are meant to be put in a exhaustive list of what to do - with arg in order. *) - Quantif | QuantifIgnore | SubGoal | Evar: string -> spec_arg - -(* quantify everything until the hyp named after the string, which is - made a subgoal *) -| QuantifAtName: string -> spec_arg - -(* thisquantify everything until the non dep num is reached, which is -made a subgoal *) -| QuantifAtNum: nat -> spec_arg - -(* (* quantify everything until the hyp named after the string, which is - made an evar *) *) -| EvarAtName: string -> string -> spec_arg - -(* make subgoals with all non dep hyp. *) -| SubGoalUntilNum: nat -> spec_arg -. - -Definition spec_args := list spec_arg . - -(* List storing heterogenous terms, for storing (tele(scopes). A - simple product could also be used. *) -Inductive Depl := -| DNil: Depl -| DCons: forall (A:Type) (x:A), Depl -> Depl. - - -(* - We start from a goal evarEV with no typing constraint. - - h: forall x y z, P x -> ... - ======================== - ?EV - - subgoal 2 - h: forall x y z, P x -> ... - ======================== - old goal - - - - We refine it to have the same products at head than h, until we - reach the aimed hypothesis - - h: P x -> ... - x: ... y: ... z: ... - ======================== - ?EV - - - then we do 2 things - - create a goal USERGOAL for this hyp - - conclude EV (and fix its type) by applying h to USERGOAL - - subgoal 1 - x: ... y: ... z: ... - ========================== - P x - - subgoal 2: - h: forall x y z, P x -> ... - hEV: forall x y z, ... - ========================== - old goal - - Refines a non specified goal (an evar) to prove the specialized - version of h. The idea is to use (fun x y z => (?ev x y z)) as the - argument being instnaciated, where ?ev will be the new goal - - larg is the specidication of what to do with each arg, larg2 is the - accumulator *) - - -(* Illustrating the idea on an example: *) -(* -Ltac2 create_evar_goal (nme:ident) := - let ev:ident := Fresh.in_goal @__h__ in (* this uses base name "h" *) - (* Std.pose (Some(@h)) constr:(Type). *) - epose _ as $ev; - let cev := Control.hyp ev in - let h' := Fresh.in_goal nme in - assert($h': $cev);subst $ev. - -(* in ltac1 this amounts to refine (fun (id:typ), _ ) where (id:typ) - is the head produt's bider of h. FIXME: simplifiy this code? *) -Ltac2 quantify h := - let hcstr := Control.hyp h in - let th := Constr.type hcstr in - printf "inter hyp: %I (%t) : %t" h hcstr th ; - let bnder := match kind th with - | Prod bnder _ => bnder - | _ => Control.zero (Tactic_failure (Some (fprintf "goal is not a product."))) - end in - msgs "post bnder" ; - printf "binder = %a" pr_binder bnder; - let nme:ident := Option.get (Binder.name bnder) in - printf "name = %I" nme; - let typ:constr := Binder.type bnder in - printf "type = %t" typ; - (unshelve ( - msgs "in unshelve" ; - let t:constr := Constr.in_context nme typ (fun () => ()) in - let tt := (Constr.type t) in - (printf "t := = %t : %t" t tt); - msgs "post in_context" ; - (* let t:constr := open_constr:(_) in *) - (Control.refine (fun () => t)); - (Control.enter (fun () => msgs "post refine"))) - (* > [ Control.shelve()| ] *) - ) - (* let cnme := Control.hyp nme in *) - (* specialize ($hcstr $cnme) *) -. -*) -(* -Lemma foo: forall x y : nat, (forall n m p :nat, n < m -> n <= m -> p > 0 -> p+1 = m+n) -> False. -Proof. - - intros x y H. - - - (* On veut prouver le n <= m comme conséquence du n < m dans H. *) - (* On crée un but dont le typ#e n'est pas connu, et on raffine pour - être dans le bon environnement. *) - - (* assert (forall n m p : nat, n < m -> n <= m). *) - (* { admit. } *) - (* pose proof (fun (n m p : nat) (h:n < m) => (H n m p h (H0 n m p h))). *) - - (* let arg_i := Fresh.in_goal @h in (* this uses base name "h" *) *) - (create_evar_goal @h). - quantify @H. - 2:specialize (H n). - 2:specialize (H n). - 2:quantify @H. - - specialize (H m). - quantify @H. - specialize (H p). - - assert (n [ | exact (H ccl) ]. - { admit. } - exact (H ccl). - - - Control.shelve(). - Unshelve. -shelve_unifiable. - - 2:{ - specialize (H n). - quantify @H. - - quantify ident:(H). - quantify @H. - - let t:constr := Constr.in_context ident:(foo) typ (fun () => ()) in - (). - - - - > [ () | specialize (H n) | ]. - - - epose _ as hole_name; - let hcstr := Control.hyp @H in - let th := Constr.type hcstr in - (* let cev := Control.hyp @hole_name in *) - let bnder := - match Unsafe.kind th with - | Unsafe.Prod bnder _ => bnder - | _ => Control.zero (Tactic_failure (Some (fprintf "hypothesis is not a product."))) - end in - printf "bnder = %a" pr_binder bnder; - let thole := Option.get (Control.hyp_value @hole_name) in - match kind thole with - | Unsafe.Evar evar _ => - let open_cstr:constr := make (Unsafe.Lambda bnder thole) in - printf "open_cstr = %t" open_cstr; - printf "thole = %t" thole; - (* unfold @hole_name; *) - ltac1:(refine $open_cstr) - (* Ltac1.apply (tac ()) [open_cstr] Ltac1.run *) - (* Control.new_goal evar *) - | _ => Control.zero (Tactic_failure (Some (fprintf "???"))) - end. - -(* -; - Control.enter (fun () => - (* Control.new_goal thole; *) - printf "%t" thole)*) - - (* Control.refine (fun () => constr:(fun (n:nat) =>_)). *) - (* quantify ident:(H). *) - - - - - (* ltac1:(refine (fun (n m p:nat) => _)). *) - Control.refine (fun _ => open_constr:(fun (n m p:nat) => _));Control.shelve_unifiable(). - specialize (H n m p). - - - let h' := Fresh.in_goal @hh in - assert($h':__h__);subst __h__. - - - let ev:ident := Fresh.in_goal @h in (* this uses base name "h" *) - (* Std.pose (Some(@h)) constr:(Type). *) - epose _ as $ev; (* _ gives a new evar, use '_ or open_constr:(_) in other contexts *) - let h' := Fresh.in_goal @hh in - assert($h':h);subst h. - - let ev := Fresh.in_goal @h in (* this uses base name "h" *) - epose _ as $ev; (* _ gives a new evar, use '_ or open_constr:(_) in other contexts *) - Control.new_goal ev. - evar xxx. - - ltac1:(let ev := open_constr:(_) in - assert (ev) as h). - ltac1:(refine (fun (n m p:nat) => _)). - specialize (H n m p). - - assert (n < m) as h1. - all:Control.focus 2 2 (fun () => specialize (H h1)). - all:swap 1 2. - specialize (H h1). - assert (n <= m) as h2. - all:swap 1 2. - specialize (H h2). - assert (p > 0) as h3. - all:swap 1 2. - specialize (H h3). -*) - -(* -Ltac is_dep_prodOLD H := - let t := type of H in - match goal with - | |- _ => assert t; - let h := fresh "__h__" in - intro h; (tryif clear h then fail 1 else fail) - | |- _ => idtac - end. -(* This uses the ltac 2 counterpart *) -Ltac2 call_is_dep_prod_ltac2 (h:Ltac1.t) := - let h':ident := Option.get (Ltac1.to_ident h) in - if ident_of_string.is_dep_prod h' then () - else Control.zero (Tactic_failure (Some (fprintf "not dependent"))). - -Tactic Notation "is_dep_prod" hyp(h) := - let tac := ltac2:(h |- call_is_dep_prod_ltac2 h) in - tac h. - -Goal (forall n m p , n < m -> p =0) -> (1 < 2 -> 3<4 -> False) -> False. - intros H H'. -(* Why does this only work for these: *) - tryif is_dep_prod H then idtac "YES" else idtac "NO". - tryif is_dep_prod H' then idtac "YES" else idtac "NO". - (* but not for these *) - let c1 := constr:(1) in - let c2 := constr:(2) in - - let x := tryif is_dep_prod H then c1 else c2 in - assert (forall n, n = x). - - -Abort. -*) -Ltac if_is_dep_prod H tac1 tac2 := - (* tryif is_dep_prod H then ltac:(tac1) else ltac:(tac2). *) - let t := type of H in - match goal with - | |- _ => match goal with - | |- _ => assert t; - let h := fresh "__h__" in - intro h; - (tryif clear h then fail else fail 1) (* we fail in both cases to backtrack the assert*) - | |- _ => tac2 - | |- _ => fail 2 (* don't fall back to tac1 *) - end - | |- _ => tac1 - end. - -Ltac refine_hd h largs n := - let newn := if_is_dep_prod h ltac:(constr:(n)) ltac:(constr:(S n)) in - (* let newn := tryif is_dep_prod h then constr:(n) else constr:(S n) in *) - lazymatch largs with - | nil => exact h - | _ => - lazymatch type of h with - | (forall (x:?t) , _) => - lazymatch largs with - | nil => exact h - | cons Quantif ?largs' => - refine (fun x: t => _); - specialize (h x); - refine_hd h largs' newn - | cons QuantifIgnore ?largs' => - refine (fun x: t => _); - specialize (h x); - clear x; - refine_hd h largs' newn - | cons (QuantifAtName ?nme) ?largs' => - ident_of_string.if_eqstr ident:(x) nme - ltac:(idtac;refine_hd h (cons SubGoal largs') n) - ltac:(idtac;refine_hd h (cons Quantif largs) n) - | cons (EvarAtName ?nmearg ?nameevar) ?largs' => - ident_of_string.if_eqstr ident:(x) nmearg - ltac:(idtac;refine_hd h (cons (Evar nameevar) largs') n) - ltac:(idtac;refine_hd h (cons Quantif largs) n) - | cons (QuantifAtNum ?num) ?largs' => - if_is_dep_prod h - ltac:((idtac;refine_hd h (cons Quantif largs) n)) - ltac:(idtac;tryif convert num newn - then refine_hd h (cons SubGoal largs') n - else refine_hd h (cons Quantif largs) n) - | cons (SubGoalUntilNum ?num) ?largs' => - if_is_dep_prod h - ltac:((idtac;refine_hd h (cons Quantif largs) n)) - ltac:(idtac;tryif convert num newn - then refine_hd h (cons SubGoal largs') n - else refine_hd h (cons SubGoal largs) n) - | cons (Evar ?ename) ?largs' => - ident_of_string.evar_as_string ename t; - (* hackish: this should get the evar just created *) - let hename := match goal with H:t|-_ => H end in - specialize (h hename); - subst hename; - (* idtac "subst"; *) - refine_hd h largs' newn - | cons SubGoal ?largs' => - (unshelve ident_of_string.evar_as_string "SubGoal" t); - (* hackish: this should get the evar just created *) - [ | let hename := match goal with - H:t|-_ => H - end in - specialize (h hename); - subst hename; - (* idtac "subst"; *) - refine_hd h largs' newn] - end - | _ => idtac "Not enough products." ; fail - end - end. - - - -Ltac refine_spec h larg := refine_hd h larg 0. - -(* Precondition: name is already fresh *) -Local Ltac espec_gen H l name clearb := - (* morally this evar is of type Type, don't know how to enforce this - without having an ugly cast in goals *) - (* idtac "espec_gen " H " " l " " name " " clearb; *) - let ev1 := open_constr:(_) in - match clearb with - true => - assert ev1 as name ; [ (refine_spec H l) | clear H;try rename name into H ] - | false => - assert ev1 as name; [ (refine_spec H l) | ] - end. -(* - (* idtac "espec_gen name :=" name; *) - assert ev1 as name - ; [ - (refine_spec H l) - | - match clearb with - true => - clear H;try rename name into H - | false _ => - idtac "ICI false"; - idtac - end - ]. *) - -Local Ltac especialize_clear H args := - let dummy_name := fresh "__" in - espec_gen H args dummy_name true. - -(* -(* Interpretation of strings "fffg?x" *) -Definition nat_of_nth_char (s:string) (i:nat): option nat := - let c := String.get i s in - match c with - Some ("0"%char) => Some 0%nat - | Some ("1"%char) => Some 1 - | Some ("2"%char) => Some 2 - | Some ("3"%char) => Some 3 - | Some ("4"%char) => Some 4 - | Some ("5"%char) => Some 5 - | Some ("6"%char) => Some 6 - | Some ("7"%char) => Some 7 - | Some ("8"%char) => Some 8 - | Some ("9"%char) => Some 9 - | _ => None - end. - -Fixpoint nat_of_string_rec (s:string) (i:nat) {struct i}: option nat := - match i with - 0 => Some 0 - | S i' => - match nat_of_nth_char s i' with - None => None - | Some n => - match nat_of_string_rec s i' with - | Some res => Some (10 * res + n) - | None => None - end - end - end -. - -Definition nat_of_string (s:string) := - nat_of_string_rec s (String.length s). - - -Eval compute in (nat_of_string "12"). - - -(* bulds a spec arg list from the string s. *) -Fixpoint interp_specialize (s:string): spec_args := - match s with - | "" => nil - | String " "%char s' => interp_specialize s' - | String "f"%char s' => cons Quantif (interp_specialize s') - | String "i"%char s' => cons QuantifIgnore (interp_specialize s') - | String "g"%char s' => cons SubGoal (interp_specialize s') - | String "?"%char s' => - let (nme,s'') := extract_word s' in - cons (Evar (string_of_list_ascii nme)) s'' - | String "-"%char ( String ">"%char s') => - let (nme,s'') := extract_word s' in - match nat_of_string (string_of_list_ascii nme) with - None => cons (QuantifAtName (string_of_list_ascii nme)) s'' - | Some n => cons (QuantifAtNum n) s'' - end - | _ => nil (* fixme *) - end -(* extract the first word of s and the name of the evar and the remaining string. *) -with extract_word (s:string): (list Ascii.ascii * spec_args) := - match s with - | "" => (nil,nil) - | String " "%char s' => (nil, interp_specialize s') - | String c s' => - let '(nme,s'') := extract_word s' in - (cons c nme, s'') - end. - - -Eval compute in (interp_specialize "->a ->2"). -*) -(* -Ltac espec_string H s idH := - let specarg := constr:(interp_specialize s) in - let specarg := eval compute in specarg in - espec_gen H specarg idH. - -Ltac espec_clear_string H s := - let specarg := constr:(interp_specialize s) in - let specarg := (eval compute in specarg) in - especialize_clear H specarg. - - -Require Import List. -Import ListNotations. - -#[global]Tactic Notation "especialize" constr(H) constr(specarg) "as" ident(idH) := - espec_string H specarg idH. - -(* permut args *) -(* #[global]Tactic Notation "especialize" constr(H) "as" ident(idH) "at" constr(specarg) := *) - (* especialize H specarg as idH. *) - -#[global]Tactic Notation "especialize" constr(H) constr(specarg) := - espec_clear_string H specarg. - -#[global]Tactic Notation "especialize" constr(H) "at" constr(n1) := - especialize_clear H [QuantifAtNum n1]. -*) - -(* ltac2 int -> constr nat *) -Ltac2 rec int_to_coq_nat n := - match Int.equal n 0 with - | true => constr:(O) - | false => let n := int_to_coq_nat (Int.sub n 1) in - constr:(S $n) - end. - -Ltac2 int_to_constr_nat' n := - let val := int_to_coq_nat n in - Std.eval_vm None val. - -Ltac2 rec li_to_speclist_QAU (li: int list): constr := - match li with - [] => constr:(@nil spec_arg) - | i :: l' => - let cl := li_to_speclist_QAU l' in - let ci := int_to_constr_nat i in - constr:(cons (QuantifAtNum $ci) $cl) - end. - -Ltac2 rec li_to_speclist_SAU (li: int list): constr := - match li with - [] => constr:(@nil spec_arg) - | i :: l' => - let cl := li_to_speclist_SAU l' in - let ci := int_to_constr_nat i in - constr:(cons (SubGoalUntilNum $ci) $cl) - end. - -Require Import IdentParsing. - -Ltac2 rec li_to_speclist_EAU (li: ident list): constr := - match li with - [] => constr:(@nil spec_arg) - | i :: l' => - let cl := li_to_speclist_EAU l' in - let istr := Ident.to_string i in - let icstr := IdentParsing.coq_string_of_string istr in - constr:(cons (EvarAtName $icstr $icstr) $cl) - end. - -Ltac2 occurrences_to_quantifatnum (occs:Std.occurrences): constr := - match occs with - | Std.AllOccurrences => Control.zero (Tactic_failure (Some (fprintf "Not implemented yet 1"))) - | Std.AllOccurrencesBut (_) => Control.zero (Tactic_failure (Some (fprintf "Not implemented yet 2"))) - | Std.NoOccurrences => Control.zero (Tactic_failure (Some (fprintf "Not implemented yet 3"))) - | Std.OnlyOccurrences (li) => li_to_speclist_QAU li - end. - -Ltac2 occurrences_to_evaratname (li:ident list): constr := li_to_speclist_EAU li. - -Ltac2 espec_at (h:constr) (occs:Std.occurrences) := - let c := occurrences_to_quantifatnum occs in - ltac1:(h c |- especialize_clear h c) (Ltac1.of_constr h) (Ltac1.of_constr c). - -Ltac2 espec_at_using (h:constr) (occs:Std.occurrences) (occsevar:ident list) := - let c1 := occurrences_to_quantifatnum occs in - let c2 := occurrences_to_evaratname occsevar in - let c := Std.eval_red constr:(List.app $c2 $c1) in - ltac1:(h c |- especialize_clear h c) (Ltac1.of_constr h) (Ltac1.of_constr c). - - -(* Ltac2 Notation "especialize" h(constr) occs(occurrences) := *) -(* espec_at_using h occs []. *) - -(* Ltac2 Notation "especialize" h(constr) occs(occurrences) "evar" levars(list1(ident)):= *) -(* espec_at_using h occs levars. *) - -(* Ltac2 Notation "especialize" h(constr) "using" levars(list1(ident)) occs(occurrences) := *) -(* espec_at_using h occs levars. *) - - -(* -Ltac2 espec_until_using_ltac1_gen (h:constr) (li:int list) (occsevar:ident list) (newH: ident opt) (clearb:bool):unit := - match identopt,clearb with - | false => - end - - let c1 := li_to_speclist_SAU li in - let c2 := occurrences_to_evaratname occsevar in - let c := Std.eval_red constr:(List.app $c2 $c1) in - let clearb := if clearb then constr:(true) else constr:(false) in - ltac1:(h c newH clearb |- espec_gen h c newH clearb) - (Ltac1.of_constr h) - (Ltac1.of_constr c) - (Ltac1.of_ident newH) - (Ltac1.of_constr clearb) -. -*) -(* Ltac2 tac1 (li:Ltac1.t list option) := (). *) -Ltac2 espec_at_ltac1 (h:constr) (li:int list) := - let cl := li_to_speclist_QAU li in - ltac1:(h c |- especialize_clear h c) (Ltac1.of_constr h) (Ltac1.of_constr cl). - -Ltac2 espec_at_using_ltac1 (h:constr) (li:int list) (occsevar:ident list):unit := - let c1 := li_to_speclist_QAU li in - let c2 := occurrences_to_evaratname occsevar in - let c := Std.eval_red constr:(List.app $c2 $c1) in - - ltac1:(h c |- especialize_clear h c) - (Ltac1.of_constr h) - (Ltac1.of_constr c) -. - - -Ltac2 espec_at_using_ltac1_gen (h:constr) (li:int list) (occsevar:ident list) (newH: ident) (clearb:bool):unit := - let c1 := li_to_speclist_QAU li in - let c2 := occurrences_to_evaratname occsevar in - let c := Std.eval_red constr:(List.app $c2 $c1) in - let clearb := constr:(false) in - ltac1:(h c newH clearb |- espec_gen h c newH clearb) - (Ltac1.of_constr h) - (Ltac1.of_constr c) - (Ltac1.of_ident newH) - (Ltac1.of_constr clearb) -. - -Ltac2 espec_until_using_ltac1_gen (h:constr) (li:int list) (occsevar:ident list) (newH: ident) (clearb:bool):unit := - let c1 := li_to_speclist_SAU li in - let c2 := occurrences_to_evaratname occsevar in - let c := Std.eval_red constr:(List.app $c2 $c1) in - let clearb := if clearb then constr:(true) else constr:(false) in - ltac1:(h c newH clearb |- espec_gen h c newH clearb) - (Ltac1.of_constr h) - (Ltac1.of_constr c) - (Ltac1.of_ident newH) - (Ltac1.of_constr clearb) -. - -Ltac2 interp_ltac1_id_list (lid:Ltac1.t) : ident list := - List.map (fun x => Option.get (Ltac1.to_ident x)) (Option.get (Ltac1.to_list lid)). - -Ltac2 interp_ltac1_int_list (li:Ltac1.t) : int list := - List.map (fun x => Option.get (Ltac1.to_int x)) (Option.get (Ltac1.to_list li)). - -Ltac2 interp_ltac1_hyp (h:Ltac1.t) : constr := Option.get (Ltac1.to_constr h). - -(* call Ltac2'especialize on argscoming from Ltac1 notation *) -Ltac2 call_specialize_ltac2_nousing h li := - espec_at_using_ltac1 (interp_ltac1_hyp h) (interp_ltac1_int_list li) []. - -(* call Ltac2'especialize on argscoming from Ltac1 notation *) -Ltac2 call_specialize_ltac2 h li levars := - espec_at_using_ltac1 - (interp_ltac1_hyp h) - (interp_ltac1_int_list li) - (interp_ltac1_id_list levars). - -(* call Ltac2'especialize on argscoming from Ltac1 notation *) -Ltac2 call_specialize_ltac2_gen h li levars newh clearb := - espec_at_using_ltac1_gen - (interp_ltac1_hyp h) - (interp_ltac1_int_list li) - (interp_ltac1_id_list levars) - (Option.get (Ltac1.to_ident newh)) - clearb. - -(* call Ltac2'especialize on argscoming from Ltac1 notation *) - -Ltac2 call_specialize_until_ltac2_gen h li levars newh clearb := - let li' := interp_ltac1_int_list li in - if Int.gt (List.length li') 1 - then - (* msgi (List.length li'); *) - Control.zero (Tactic_failure (Some (fprintf "In 'specialize X until I', I must be a singleton."))) - else - espec_until_using_ltac1_gen (interp_ltac1_hyp h) li' (interp_ltac1_id_list levars) - (Option.get (Ltac1.to_ident newh)) clearb. - - -Tactic Notation "especialize" constr(h) "using" ne_ident_list(levars) "at" ne_integer_list(li) - "as" ident(newH) := - let tac := ltac2:(h li levars newH |- call_specialize_ltac2_gen h li levars newH false) in - tac h li levars newH. - -Tactic Notation "especialize" constr(h) "at" ne_integer_list(li) "using" ne_ident_list(levars) "as" ident(newH) := - let tac := ltac2:(h li levars newH |- call_specialize_ltac2_gen h li levars newH false) in - tac h li levars newH. - -Tactic Notation "especialize" constr(h) "at" ne_integer_list(li) "using" ne_ident_list(levars) := - let tac := ltac2:(h li levars |- call_specialize_ltac2 h li levars) in - tac h li levars. - - -Tactic Notation "especialize" constr(h) "using" ne_ident_list(levars) "at" ne_integer_list(li) := - let tac := ltac2:(h li levars |- call_specialize_ltac2 h li levars) in - tac h li levars. - - (* - Tactic Notation "especialize" constr(h) "at" ne_integer_list(li) := - (* let tac := ltac2:(h li |- call_specialize_ltac2_nousing h li) in *) - (* tac h li. *) - let dummynewH := fresh "__h__" in - let levars := ltac2:(Ltac - let tac := ltac2:(h li levars newH |- call_specialize_ltac2_gen h li levars newH false) in - tac h li constr:(@nil) dummynewH. -*) - - -(* "using" must be first, probably because it is not a keyword: *) -Tactic Notation "especialize" constr(h) "until" ne_integer_list(li) "using" ne_ident_list(levars) "as" ident(newH) := - let tac := ltac2:(h li levars newH |- call_specialize_until_ltac2_gen h li levars newH false) in - tac h li levars newH. - -(* "using" must be first, probably because it is not a keyword: *) -Tactic Notation "especialize" constr(h) "until" ne_integer_list(li) "using" ne_ident_list(levars) "as" ident(newH) := - let tac := ltac2:(h li levars newH |- call_specialize_until_ltac2_gen h li levars newH false) in - tac h li newH. - -(* "using" must be first, probably because it is not a keyword: *) -Tactic Notation "especialize" constr(h) "until" ne_integer_list(li) "using" ne_ident_list(levars) "as" "?" := - let tac := ltac2:(h li levars newH |- call_specialize_until_ltac2_gen h li levars newH false) in - let nme := fresh "__h_" in - tac h li levars ident:(nme). - - -(* "using" must be first, probably because it is not a keyword: *) -Tactic Notation "especialize" constr(h) "until" ne_integer_list(li) "using" ne_ident_list(levars) := - let tac := ltac2:(h li levars newH |- call_specialize_until_ltac2_gen h li levars newH true) in - let nme := fresh "__h_" in - tac h li levars ident:(nme). - - -Definition hidden_product := forall i j :nat, i+1=j -> i+1=j -> i+1=j. - -Lemma foo: forall x y : nat, - (forall (n m p :nat) (hhh:n < m) (iii:n <= m), - p > 0 - -> p > 0 - -> p > 0 - -> p > 0 - -> p > 0 - -> p > 0 - -> p > 0 - -> p > 0 - -> p > 0 - -> p > 0 - -> p > 0 - -> p > 0 - -> p > 0 - -> p > 0 - -> p > 0 - -> p > 0 - -> p > 2 - -> p > 1 - -> hidden_product) -> False. -Proof. - intros x y H. - - - (* especialize H with (n:=0) at 2. *) - - especialize H at 19 20 using p. - - especialize H until 3 using n p. - - - - - especialize H at 2 3 using n m. - 1: match goal with - |- ?lft <= ?rght => is_evar lft; is_evar rght - end. - 2: match goal with - H: ?lft < ?rght |- p > 0 => is_evar lft; is_evar rght - end. - 3: match goal with - H: nat -> ?lft < ?rght -> hidden_product |- False => is_evar lft; is_evar rght - end. - Undo 4. - - especialize H using n m at 2 3. - 1: match goal with - |- ?lft <= ?rght => is_evar lft; is_evar rght - end. - 2: match goal with - H: ?lft < ?rght |- p > 0 => is_evar lft; is_evar rght - end. - 3: match goal with - H: nat -> ?lft < ?rght -> hidden_product |- False => is_evar lft; is_evar rght - end. - Undo 4. - - especialize H at 2 3. - 1: match goal with - H: n < m |- n <= m => idtac - end. - 2: match goal with - H: n < m |- p > 0 => idtac - end. - 3: match goal with - H: forall n m : nat, nat -> n < m -> hidden_product |- False => idtac - end. - Undo 4. - - especialize H at 2 3 using n p as hfoo. - 1: match goal with - |- ?lft <= m => is_evar lft - end. - 2: match goal with - H: ?lft < m |- ?rght > 0 => is_evar lft; is_evar rght - end. - 3: match goal with - H : (forall n m p : nat, n < m -> n <= m -> p > 0 -> hidden_product), - H': forall m : nat, ?lft < m -> hidden_product |- False => is_evar lft - end. - 3: match type of hfoo with - forall m : nat, ?lft < m -> hidden_product => idtac - end. - Undo 5. - - especialize H using n p at 2 3 as hfoo. - 1: match goal with - |- ?lft <= m => is_evar lft - end. - 2: match goal with - H: ?lft < m |- ?rght > 0 => is_evar lft; is_evar rght - end. - 3: match goal with - H : (forall n m p : nat, n < m -> n <= m -> p > 0 -> hidden_product), - H': forall m : nat, ?lft < m -> hidden_product |- False => is_evar lft - end. - 3: match type of hfoo with - forall m : nat, ?lft < m -> hidden_product => idtac - end. - Undo 5. - -Abort. - -(* -(* Experimenting a small set of tactic to manipulate a hyp: *) - -Ltac quantify H := - match type of H with - (forall x:?t, _) => refine (fun (x:t) => _); specialize (H x) - end. - -Ltac evary H := - match type of H with - (forall x:?t, _) => evar (x:t); specialize (H x);subst x - end. - -Ltac goaly H := - match type of H with - (forall x:?t, _) => [> assert (x:t); [ | specialize (H x)]] - end. - -Ltac stopy H := exact H. -Ltac start name := - let ev1 := open_constr:(_) in - assert ev1 as name. - -Lemma foo: forall x y : nat, - (forall (n m p :nat) (hhh:n < m) (iii:n <= m), p > 0 -> p+m=n) -> False. -Proof. - intros x y H. - start newH. - quantify H. - quantify H. - quantify H. - quantify H. - goaly H. - { now apply PeanoNat.Nat.lt_le_incl. } - stopy H. -Abort. -*) - diff --git a/LibHyps/ident_of_string.v b/LibHyps/ident_of_string.v deleted file mode 100644 index bb470b4..0000000 --- a/LibHyps/ident_of_string.v +++ /dev/null @@ -1,353 +0,0 @@ -Require Coq.Strings.String. -Require Import Ltac2.Ltac2. -From Ltac2 Require Import Option Constr Printf. -Import Constr.Unsafe. - - -Ltac2 rec length_constr_string (xs : constr) : int := - match kind xs with - | App _ args => - match Int.equal (Array.length args) 2 with - | true => Int.add 1 (length_constr_string (Array.get args 1)) - | _ => if equal xs 'String.EmptyString then 0 else Control.throw No_value - end - | Constr.Unsafe.Constructor _ _ => 0 - | _ => Control.throw No_value - end. - - -Ltac2 string_of_constr_string (s : constr) : string := - let s := eval vm_compute in ($s : String.string) in - let ret := String.make (length_constr_string s) (Char.of_int 0) in - let t := constr:(true) in - let rec fill i s := - match kind s with - | App _ args => - if Int.equal (Array.length args) 2 then - String.set ret i (match kind (Array.get args 0) with App _ b => Char.of_int ( - Int.add (if equal (Array.get b 0) t then 1 else 0) ( - Int.add (if equal (Array.get b 1) t then 2 else 0) ( - Int.add (if equal (Array.get b 2) t then 4 else 0) ( - Int.add (if equal (Array.get b 3) t then 8 else 0) ( - Int.add (if equal (Array.get b 4) t then 16 else 0) ( - Int.add (if equal (Array.get b 5) t then 32 else 0) ( - Int.add (if equal (Array.get b 6) t then 64 else 0) ( - (if equal (Array.get b 7) t then 128 else 0))))))))) - | _ => Control.throw No_value end); - fill (Int.add i 1) (Array.get args 1) - else () - | _ => () - end in - fill 0 s; ret. - -Ltac2 ident_of_constr_string (s : constr) := Option.get (Ident.of_string (string_of_constr_string s)). - -Ltac2 eq_string s1 s2 := if String.equal s1 s2 then constr:(true) else constr:(false). - -Ltac ident_of_constr_string_cps := ltac2:(s tac |- - Ltac1.apply tac [Ltac1.of_ident (ident_of_constr_string (Option.get (Ltac1.to_constr s)))] Ltac1.run). - -Ltac2 eq_id_string (id:ident) (s : string) := - if String.equal (Ident.to_string id) s then constr:(true) else constr:(false). - -Ltac intro_as_string s := ident_of_constr_string_cps s ltac:(fun i => intro i). - -Ltac evar_as_string s t := ident_of_constr_string_cps s ltac:(fun s => let s' := fresh s in evar(s':t)). - -Ltac if_eqstr := - ltac2:(ident s tac1 tac2 |- - (if String.equal - (Ident.to_string (Option.get (Ltac1.to_ident ident))) - (string_of_constr_string (Option.get (Ltac1.to_constr s))) - then Ltac1.apply tac1 [] - else Ltac1.apply tac2 []) Ltac1.run). - -Ltac2 is_dep_prod (h:ident) := - let h := Control.hyp h in - let th := Constr.type h in - match Constr.Unsafe.kind th with - | Prod _ c => Bool.neg (Constr.Unsafe.is_closed c) - | _ => Control.zero (Tactic_failure (Some (fprintf "Not a product"))) - end. - -Ltac2 rec chop_prod_until (th:constr) (id:ident): constr := - match Constr.Unsafe.kind th with - | Prod bind th' => - (* Message.print (Message.of_constr th); *) - match Binder.name bind with - | None => - let res : constr := chop_prod_until th' id in - Constr.Unsafe.make (Constr.Unsafe.Prod bind res) - - | Some nme => - if Ident.equal nme id - then Binder.type bind - else - let res : constr := chop_prod_until th' id in - Constr.Unsafe.make (Constr.Unsafe.Prod bind res) - end - | _ => Control.zero (Tactic_failure (Some (fprintf "Not a product"))) - end -. - -Ltac2 Notation "chop" hyp(ident) "until" id(ident) := - let h := Control.hyp hyp in - let th := Constr.type h in - let res := chop_prod_until th id in - Message.print (Message.of_constr res). - - - -(* -Ltac2 analyze_deps (th:constr) (id:ident) := - match Constr.Unsafe.kind th with - | Prod bind th' => - Message.print (Message.of_constr th); - match Binder.name bind with - | None => Message.print (Message.of_string "NO NAME") - | Some nme => - if Ident.equal nme id - then Message.print (Message.of_string "EQ") - else - if - Message.print (Message.of_string "NEQ") - end - | _ => Control.zero (Tactic_failure (Some (fprintf "Not a product"))) - end -. - -Ltac2 Notation "deps" hyp(ident) "until" id(ident) := - let h := Control.hyp hyp in - let th := Constr.type h in - analyze_deps th id. -*) - - -(* -Set Default Proof Mode "Ltac2". -Goal (forall (n m p:nat) (hhh:n=p), m=1) -> (4=0 -> 1=1)-> 2=2 -> (forall m:nat, False). - intros . - chop H until hhh. - - refinehd H. -*) - - -(* - - -Ltac2 Type specialize_arg := - [ QuantifArg | QuantifIgnoreArg | SubGoalArg | EvarArg(string) - | QuantifUntilArg(string) | QuantifUntilNum(int) ]. - -Ltac2 Notation "is_depH" h(ident) := is_dep_prod h. - -Ltac2 Notation "QuantifArg" := QuantifArg. - -Ltac2 refine_hd (hyp:ident) (largs: specialize_arg list) (n:int) := - let h := Control.hyp hyp in - let th := Constr.type h in - match Constr.Unsafe.kind th with - | Prod bind th' => - let newn:int := if Constr.Unsafe.is_closed th' then n else (Int.add n 1) in - let x := Binder.name bind in - let t := Binder.type bind in - match largs with - | QuantifArg :: largs' => - let hole := '_ in - let open_cstr := Constr.Unsafe.make (Constr.Unsafe.Prod bind hole) in - ltac1:(x |- refine x) (Ltac1.of_constr open_cstr) - - - | _ => Control.zero (Tactic_failure (Some (fprintf "Not implemented yet!"))) - end - | _ => - match largs with - [] => ltac1:(x |- exact x) (Ltac1.of_ident hyp) - | _ => Control.zero (Tactic_failure (Some (fprintf "Not a product"))) - end - end. - - - -(* Ltac2 Notation refinehd := refine_hd. *) -Ltac2 Notation "refinehd" h(ident) := refine_hd h [QuantifArg] 0. -*) - -(* -Set Default Proof Mode "Ltac2". - - -Goal (forall n, n=0 -> 1=1) -> (4=0 -> 1=1)-> 2=2 -> (forall m:nat, False). - intros . - - if (is_dep_prod ident:(H0)) then Message.print (Message.of_string "DEP") - else Message.print (Message.of_string "NO DEP"). - - refinehd H. - - - let newn := if is_dep_prod h then constr:(n) else (constr:(S n)) in - - - lazymatch largs with - | nil => exact h - | _ => - lazymatch type of h with - | (forall (x:?t) , _) => - lazymatch largs with - | nil => exact h - | cons QuantifArg ?largs' => - refine (fun x: t => _); - specialize (h x); - refine_hd h largs' newn - | cons QuantifIgnoreArg ?largs' => - refine (fun x: t => _); - specialize (h x); - clear x; - refine_hd h largs' newn - | cons (QuantifUntilArg ?nme) ?largs' => - if_eqstr ident:(x) nme - ltac:(idtac;refine_hd h (cons SubGoalArg largs') n) - ltac:(idtac;refine_hd h (cons QuantifArg largs) n) - | cons (QuantifUntilNum ?num) ?largs' => - if_is_dep_prod h - ltac:((idtac;refine_hd h (cons QuantifArg largs) n)) - ltac:(idtac;tryif convert num newn - then refine_hd h (cons SubGoalArg largs') n - else refine_hd h (cons QuantifArg largs) n) - | cons (EvarArg ?ename) ?largs' => - evar_as_string ename t; - (* hackish: this should get the evar just created *) - let hename := match goal with H:t|-_ => H end in - specialize (h hename); - subst hename; - (* idtac "subst"; *) - refine_hd h largs' newn - | cons SubGoalArg ?largs' => - (unshelve evar_as_string "SubGoal" t); - (* hackish: this should get the evar just created *) - [ | let hename := match goal with - H:t|-_ => H - end in - specialize (h hename); - subst hename; - (* idtac "subst"; *) - refine_hd h largs' newn] - end - | _ => idtac "Not enough products." ; fail - end - end. -*) - -(* -(* Set Default Proof Mode "Classic". *) - Set Default Proof Mode "Ltac2". -Goal (0=0 -> 1=1) -> 2=2 -> False. - intros . - - is_depH H. - is_depH H0. - - let h := Control.hyp (Ident.of_string "H") in - (is_dep_prod H). - - - let t := type of H in - lazy_match! t with - (forall n:tn, reste) => Message.print (Message.of_string "Youhou") - | _ => Message.print (Message.of_string "Buh") - end. - - match! goal with - | [ |- _ ] => - - Control.plus (fun () => - assert t; - Control.focus 1 1 (fun () => - let h := fresh "__h__" in - intro h)) - false - true - - match Control. with - - end - (tryif clear h then fail 1 else fail) - | [ |- _ ] => idtac - end. - -Ltac2 if_is_dep_prod H tac1 tac2 := - let t := type of H in - match goal with - | |- _ => match goal with - | |- _ => assert t; - let h := fresh "__h__" in - intro h; - (tryif clear h then fail else fail 1) (* we fail in both cases to backtrack the assert*) - | |- _ => tac2 - | |- _ => fail 2 (* don't fall back to tac1 *) - end - | |- _ => tac1 - end. -*) - - -(* -Goal forall toto:nat,True. - intros toto. - if_eqstr ident:(toto) - - - let x := (Ident.to_string ident:(toto)) in - if String.equal x "toti" then Message.print (Message.of_string "true") - else Message.print (Message.of_string "false"). - - Message.print (Message.of_string x); - Message.print (Message.of_string "toto") - . - if String.equal x "toti" then Message.print (Message.of_string "true") - else Message.print (Message.of_string "true"). - - let x := eq_id_string (Option.get (Ident.of_string "toto")) "toto" in - Ltac1:(pose proof res). -*) - -(* -Goal forall toto:nat,True. - intros toto. - let x := eq_id_string (Option.get (Ident.of_string "toto")) "toto" in - Ltac1:(pose proof res).*) - -(* -Local Open Scope string_scope. -Local Set Default Proof Mode "Classic". -Import Coq.Strings.String Coq.Strings.Ascii. Local Open Scope string_scope. -Goal forall x:nat, True. -Proof. - let s := constr:("ab_cdef_gh") in - (* time *) do 1000 (intro_as_string s; revert ab_cdef_gh). (*0.5s*) - let s := constr:("ab_cdef_gh") in - intro_as_string s. -Abort. - -Local Set Warnings "-abstract-large-number". -Goal forall x:nat, True. -Proof. - let s := eval vm_compute in (string_of_list_ascii (List.repeat "a"%char 10000)) in - (* time *) intro_as_string s (*0.4s*). -Abort. - -Goal forall x:nat, True. -Proof. - let s := constr:("ab_cdef_gh") in - evar_as_string s nat. - ident_of_constr_string_cps s ltac:(fun x => let ev := open_constr:(x:nat) in - assert (let x := ev in _)). - let e := open_constr:(s:nat) in - assert (e). - -Abort. - - -*) diff --git a/Makefile b/Makefile index 8b80794..a6af6cf 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,13 @@ -lib: +.PHONY: tests LibHyps + +lib: sanity + make -C LibHyps + +# Use this instead of make lib when the debug code is present +make debug: make -C LibHyps + make -C tests tests: lib make -C tests @@ -18,3 +25,5 @@ clean: install: lib make -C LibHyps install +sanity: + @./testDebug.sh diff --git a/README.md b/README.md index dc4955f..1eaf06f 100644 --- a/README.md +++ b/README.md @@ -31,30 +31,84 @@ modification: see the remark about evars below of `H` (or of a new created hypothesis if the `as` option is given). -+ `especialize H until n [as h].` Creates one subgoal for each n first - dependent premises of `H`, creating necessary evars for non ++ `especialize H until 3 [as h].` Creates one subgoal for each 3 first + dependent premises of `H`. Creating necessary evars for non unifiable variables. Once proved the subgoal is used to remove the premises of `H` (or of a new created hypothesis if the `as` option is given). -+ all this variant accept (and may *need*) a supplementary argument - `with x,y,z` to declare the variables of the hypothesis which must - be transformed into existential variables. Examples: ++ By default all non-dependent hypothesis of `H` are left quantified. + But you can specify the ones that should rather be transformed into + existential variables. Examples: - `especialize H with x,z at n [as h].`, - `especialize H with a,b at * [as h].`, etc. + - `especialize H with x,z at n [as h].` makes xn and `z` evars. + - `especialize H with a at * [as h].`, etc. - These declarations are mandatory (from version 3 of libHyps) due to - restriction in coq >= 8.18. If you forget to mention such a variable - you will get an error message like this: - - ```coq - Unable to unify "?n0" with "u" (cannot instantiate "?n0"` - `because "u" is not in its scope: available arguments are "y" "a" "b" "t"). +Note that the variables declared in `with` must be **in the order of +quantification**, otherwise you will get an error +(`Invalid_argument`)". + +Note that (contrary to previous versions of this library), if you +forget to list a variable, the tactic won't fail. Instead it will +simply leave the variable quantified in the original hypothesis +**and in suqsequentlky created subgoals**. + +For example, after this: + + ``` coq + Lemma test_espec8: forall x:nat, (forall a :nat, a = 1 -> x = 1 -> False) -> x > 1. + Proof. + intros x h. ``` - I am considering the possibility to have a mode where some of these - variables may be declared implicitly. +the goal looks like this + +``` coq + x : nat + h : forall a : nat, a = 1 -> x = 1 -> False + ============================ + x > 1 +``` + +the following tactic: + +``` coq +especialize h with a at 1. +``` + +gives two subgoals: + +``` coq + x : nat + ============================ + ?a = 1 + + x : nat + h : x = 1 -> False + ============================ + x > 1 + +``` + +Whereas + +``` coq +especialize h at 1. +``` + +gives (note how `a` is quantified in both subgoals, which makes the +first one unprovable): + +``` coq + x, a : nat + ============================ + a = 1 + + x : nat + h : nat -> x = 1 -> False + ============================ + x > 1 +``` ## QUICK REF: Pre-defined tacticals /s /n... diff --git a/TODO.md b/TODO.md index 70ae66d..e5c1a03 100644 --- a/TODO.md +++ b/TODO.md @@ -1,15 +1,5 @@ # Suggestion by Sylvain Boulme: -## Looks like "exploit" developped in compcert. - -exploit creates evars for all premisses of a hyp. -especialize creates evars for ONE premiss. -Maybe we could have the best of both? -like: -``` -especialize h at 1,4,6. (* fine grained exploit *) -especialize h at *. (* equivalent to exploit *) -``` # have a true replacement for "as" Syntax suggestion: @@ -39,8 +29,10 @@ tac1 ; [[ tac2 ]]. ## or go back to double semi-colon? tac1 ;; tac2. +tac1 ;<; tac2. -but we need 4 variants. ;<; ;!; ;!<; which are quite ugly. +We don't need the 4 variants anymore (ltac2 is fast enough to avoid +the list variants). # Are shortcuts reasonable wrt to ssreflect? @@ -59,6 +51,9 @@ make possible the fact to decide to use an arg name only if it is an id. typically: "h_eq_add_add" is not so interesting +idea yet to be refined: at last level if seeing a hyp name then use it +else don't generate the last level. + # Naming : distinguish sub terms in the name Typically "h_add_x_y_z" would maybe be better as "h_add_x_y__z" diff --git a/configure.sh b/configure.sh index beabc6c..ebfbac4 100755 --- a/configure.sh +++ b/configure.sh @@ -1,15 +1,51 @@ #!/bin/bash +DEVOPT=no +STDLIB= + +POSITIONAL=() +while [[ $# -gt 0 ]] +do +key="$1" + +case $key in + --stdlib|-stdlib) + shift + STDLIB=$1 + shift + ;; + -dev|--dev) + DEVOPT=yes + shift + ;; + *) # unknown option + POSITIONAL+=("$1") # save it in an array for later + shift # past argument + ;; +esac +done + +set -- "${POSITIONAL[@]}" # restore positional parameters (i.e. + # parameters that were not recognized by the + # previous code.) function gen_projet_file () { FILES="$1" DIR=$2 + STDLIB=$4 PROJECTFILE=$DIR/_CoqProject RESOURCEFILE=$3 - cat < $RESOURCEFILE > "$PROJECTFILE" + if [ "$STDLIB" != "" ] + then + echo "stdlib detected" + echo "-Q $STDLIB Stdlib" > "$PROJECTFILE" + else echo "" > "$PROJECTFILE" + fi + + cat < $RESOURCEFILE >> "$PROJECTFILE" echo "" >> "$PROJECTFILE" @@ -22,16 +58,37 @@ function gen_projet_file () { cat < $PROJECTFILE - echo "Calling rocq makefile in $DIR" - (cd $DIR && rocq makefile -f _CoqProject -o Makefile ) + command -v rocq ; rocqexists=$? + if [ $rocqexists -eq 0 ] + then + echo "Calling rocq makefile in $DIR" + (cd $DIR && rocq makefile -f _CoqProject -o Makefile ) + else + command -v coqc ; coqexists=$? + if [ $coqexists -eq 0 ] + then + echo "Calling coq_makefile in $DIR" + (cd $DIR && coq_makefile -f _CoqProject -o Makefile ) + else + echo "Neither rocq nor coq executable found" + exit 1 + fi + fi } -FILESLH=$(cd LibHyps && find . -name "*.v" | grep -v "ident_of_string\|especialize_ltac2\|LibEspecialize" ) +if [ "$DEVOPT" = "no" ] +then + FILESLH=$(cd LibHyps && find . -name "*.v" | grep -v "LibHypsDebug" ) +else + FILESLH=$(cd LibHyps && find . -name "*.v" ) +fi + PROJECTDIRLH="LibHyps" -gen_projet_file "$FILESLH" "$PROJECTDIRLH" "resources/coq_project.libhyps" +gen_projet_file "$FILESLH" "$PROJECTDIRLH" "resources/coq_project.libhyps" "$STDLIB" + FILESTEST=$(cd tests && find . -name "*.v" | grep -v "incremental" ) PROJECTDIRTESTS="tests" -gen_projet_file "$FILESTEST" "$PROJECTDIRTESTS" "resources/coq_project.tests" +gen_projet_file "$FILESTEST" "$PROJECTDIRTESTS" "resources/coq_project.tests" "$STDLIB" diff --git a/resources/coq_project.libhyps b/resources/coq_project.libhyps index 52f81d5..997cfc0 100644 --- a/resources/coq_project.libhyps +++ b/resources/coq_project.libhyps @@ -1 +1,4 @@ -R . LibHyps.LibHyps +-arg -w +-arg -deprecated-since-9.0 + diff --git a/resources/coq_project.tests b/resources/coq_project.tests index 000812b..4b66821 100644 --- a/resources/coq_project.tests +++ b/resources/coq_project.tests @@ -4,4 +4,6 @@ -arg force -arg -w -arg -undo-batch-mode +-arg -w +-arg -deprecated-since-9.0 diff --git a/testDebug.sh b/testDebug.sh new file mode 100755 index 0000000..49a521e --- /dev/null +++ b/testDebug.sh @@ -0,0 +1,24 @@ +#!/bin/bash + + +## Explanation +# - Debug code is in LibHyps/LibHypsDebug.v +# +# - by default ./configure.sh does ignores this file +# - unless we use ./configure.sh --dev +# +# - the present test checks that we have not forgotten to remove +# - refrences to the debug file (by doing ./configure.sh). +# +echo "Sanity check (debug files)" +if grep -q "LibHypsDebug.v" LibHyps/_CoqProject +then + echo "REMAINING DEBUG CODE: ABORTING." + echo "LibHypsDebug.v shoiuld not be compiled in a released code." + echo "Use ./configure.sh to remove rerferences to debug code." + echo "then make clean; make lib tests" + echo "If this fails, remove the calls to LibHypsDebug.v in the code" + exit 1 +else + exit 0 +fi diff --git a/tests/Especialize_tests.v b/tests/Especialize_tests.v index 10eef6a..e50eee0 100644 --- a/tests/Especialize_tests.v +++ b/tests/Especialize_tests.v @@ -1,4 +1,4 @@ -Require Import LibHyps.LibHypsTactics. +(* Require Import LibHyps.LibHypsTactics. *) Require Import LibHyps.Especialize. (* tests *) @@ -30,20 +30,24 @@ Lemma foo: forall x y : nat, -> hidden_product) -> False. Proof. intros x y H. - + (* evar names must be given in order. *) + Fail especialize H at * with n,p,m. (* Fail especialize (let x:=not_eq_S in x) with n,m at *. *) - especialize H at * with n,m,p;[admit|admit|admit|admit| |admit]; - match goal with - H1 : ?n < ?m - , H2 : ?n <= ?m - , H3 : ?p > 0 - , H4 : ?p > 2 |- _ => idtac - end. - Undo 1. - especialize H at 2; - [ now apply PeanoNat.Nat.lt_le_incl | match goal with | |- False => idtac end; - match type of H with forall (n:_) (m:_) (p:_), n < m -> _ => idtac end ]. - Undo 1. + especialize H at * with n,m,p. + 5:{ + match goal with + H1 : ?n < ?m + , H2 : ?n <= ?m + , H3 : ?p > 0 + , H4 : ?p > 2 |- _ => idtac + end. admit. } + Undo 5. + + especialize H at 2. + 2:{ match goal with | |- False => idtac end. + match type of H with forall (n:_) (m:_) (p:_), n < m -> _ => idtac end. + admit. } + Undo 6. especialize H at 2 as h; [ now apply PeanoNat.Nat.lt_le_incl | match goal with | |- False => idtac end; match type of h with forall (n:_) (m:_) (p:_), n < m -> _ => idtac end ]. @@ -588,11 +592,21 @@ Module Using. Qed. (* This tests only hold for coq >= 8.18 *) + + Lemma test_espec8: forall x:nat, (forall a :nat, a = 1 -> x = 1 -> False) -> x > 1. + Proof. + intros x h. + especialize h at 1. + Undo 1. + especialize h with a at 1. + Abort. + + (* Lemma test_espec8: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. Proof. intros x hx h_eqone. - Fail especialize h_eqone with a at 1,4 . + especialize h_eqone with a at 1,4 . Abort. Lemma test_espec8_h: forall x:nat, x = 1 -> (forall a y z:nat, a = 1 -> y = 1 -> z+y+a = 2 -> z+1 = x -> False) -> x > 1. diff --git a/tests/LibHypsRegression.v b/tests/LibHypsRegression.v index 284b385..122edfb 100644 --- a/tests/LibHypsRegression.v +++ b/tests/LibHypsRegression.v @@ -7,37 +7,44 @@ Require Export LibHyps.TacNewHyps. Require Export LibHyps.LibHypsNaming. Require Export LibHyps.LibHyps. Export TacNewHyps.Notations. -From Stdlib Require Import Arith ZArith List. +Require Import Arith ZArith List. +Require Import Ltac2.Ltac2. +From Ltac2 Require Import Option Constr Printf. +Local Set Default Proof Mode "Classic". +Import ListNotations. Import LibHyps.LegacyNotations. (* This settings should reproduce the naming scheme of libhypps-1.0.0 and libhypps-1.0.1. *) -Ltac add_suffix ::= constr:(false). -Ltac numerical_names ::= numerical_names_sufx. - -Local Open Scope autonaming_scope. -Import ListNotations. - -(* From there this is LibHypTest from 1f7a1ed2289e439c291fcbd06c51705547feef1e *) -Ltac rename_hyp_2 n th := - match th with - | true <> false => name(`_tNEQf`) - | true = false => name(`_tEQf`) +Ltac2 Set numerical_sufx := true. +Ltac2 Set add_suffix := false. + +Ltac2 rename_hyp_1 n th := + if Int.lt n 0 then [] + else + lazy_match! th with + | @cons _ ?x (cons ?y ?l) => [String "cons"; Rename x; Rename y; RenameN (decr (decr n)) l] + | @cons _ ?x ?l => if Int.ge n 1 then [String "cons"; Rename x; RenameN (decr n) l] else [String "cons"] + end. + +Ltac2 rename_hyp_2 n th := + match! th with + | true <> false => [ String "tNEQf" ] + | true = false => [ String "tEQf"] + | _ => rename_hyp_1 n th (* call the previously defined tactic *) end. -Ltac rename_hyp ::= rename_hyp_2. +Ltac2 Set rename_hyp := rename_hyp_2. -(* Suppose I want to add later another naming rule: *) -Ltac rename_hyp_3 n th := - match th with - | Nat.eqb ?x ?y = true => name(`_Neqb` ++ x#n ++ y#n) - | true = Nat.eqb ?x ?y => name(`_Neqb` ++ x#n ++ y#n) +Ltac2 rename_hyp_3 n th := + match! th with + | Nat.eqb ?x ?y = true => [ String "Neqb" ; Rename x ; Rename y ] + | true = Nat.eqb ?x ?y => [ String "Neqb" ; Rename x ; Rename y ] | _ => rename_hyp_2 n th (* call the previously defined tactic *) end. -Ltac rename_hyp ::= rename_hyp_3. -Ltac rename_depth ::= constr:(3). +Ltac2 Set rename_hyp := rename_hyp_3. Close Scope Z_scope. Open Scope nat_scope. @@ -49,7 +56,10 @@ Lemma dummy: forall x y, 0 = 1 -> (0 = 1)%Z -> ~x = y -> + Nat.eqb (x + 1) 0 <> Nat.eqb 1 y -> true = Nat.eqb 3 4 -> + Nat.eqb (x + 3) 4 = true -> + Nat.eqb (2 * (x + 3)) 4 = true -> Nat.eqb 3 4 = true -> true = Nat.leb 3 4 -> 1 = 0 -> @@ -90,9 +100,11 @@ Lemma dummy: forall x y, match type of h_neq_x_y with x <> y => idtac | _ => fail "test failed!" end. match type of h_Neqb_3n_4n with true = (3 =? 4) => idtac | _ => fail "test failed!" end. match type of h_Neqb_3n_4n0 with (3 =? 4) = true => idtac | _ => fail "test failed!" end. + match type of h_Neqb_mul_2n_add_4n with (2 * (x + 3) =? 4) = true => idtac | _ => fail "test failed!" end. match type of h_eq_true_leb_3n_4n with true = (3 <=? 4) => idtac | _ => fail "test failed!" end. match type of h_eq_1n_0n with 1 = 0 => idtac | _ => fail "test failed!" end. match type of h_neq_x_y0 with x <> y => idtac | _ => fail "test failed!" end. + match type of h_neq_eqb_add_0n_eqb_1n_y with (x + 1 =? 0) <> (1 =? y) => idtac | _ => fail "test failed!" end. match type of h_not_lt_1n_0n with ~ 1 < 0 => idtac | _ => fail "test failed!" end. match type of h_all_tNEQf with forall w w' : nat, w = w' -> true <> false => idtac | _ => fail "test failed!" end. match type of h_all_and_tEQf_True with forall w w' : nat, w = w' -> true = false /\ True => idtac | _ => fail "test failed!" end. @@ -101,7 +113,7 @@ Lemma dummy: forall x y, match type of h_ex_and_True_False with exists w : nat, w = w -> True /\ False => idtac | _ => fail "test failed!" end. match type of h_all_tEQf with forall w w' : nat, w = w' -> true = false => idtac | _ => fail "test failed!" end. match type of h_all_eq_eqb_eqb with forall w w' : nat, w = w' -> (3 =? 4) = (4 =? 3) => idtac | _ => fail "test failed!" end. - match type of h_eq_length_cons with length [3] = (fun _ : nat => 0) 1 => idtac | _ => fail "test failed!" end. + match type of h_eq_length_cons with (length [3] = (fun _ : nat => 0) 1) => idtac | _ => fail "test failed!" end. match type of h_eq_length_cons_0n with length [3] = 0 => idtac | _ => fail "test failed!" end. match type of h_eq_add_0n_y_y with 0 + y = y => idtac | _ => fail "test failed!" end. match type of h_tEQf with true = false => idtac | _ => fail "test failed!" end. @@ -117,42 +129,73 @@ Lemma dummy: forall x y, match type of h_impl_not_lt with 0 < 1 -> ~ 1 < 0 => idtac | _ => fail "test failed!" end. match type of h_impl_lt_1n_0n with 0 < 1 -> 1 < 0 => idtac | _ => fail "test failed!" end. match type of h_lt_0n_z with 0 < z => idtac | _ => fail "test failed!" end. + + Restart. + intros /ng. + lazymatch reverse goal with + | Ht:_,Hz:_, Hx0:_,Hy:_ , Hx:_ |- True => + let _ := constr:((ltac:(reflexivity)): Hx=x) in + let _ := constr:((ltac:(reflexivity)): Hy=y) in + let _ := constr:((ltac:(reflexivity)): Hx0=x0) in + let _ := constr:((ltac:(reflexivity)): Ht=t) in + idtac + | _ => fail "test failed (wrong order of hypothesis)!" + end. + + Restart. + intros /sng. + lazymatch reverse goal with + | Ht:_,Hz:_, Hx0:_,Hy:_ |- True => + let _ := constr:((ltac:(reflexivity)): Hy=y) in + let _ := constr:((ltac:(reflexivity)): Hx0=x0) in + let _ := constr:((ltac:(reflexivity)): Ht=t) in + idtac + | _ => fail "test failed (wrong order of hypothesis)!" + end. + exact I. Qed. - -(* +Definition eq_one (i:nat) := i = 1. Lemma test_espec_namings: forall n:nat, (eq_one n -> eq_one 1 -> False) -> True. Proof. intros n h_eqone. - especialize Nat.quadmul_le_squareadd with a at 1 as hh : h. + especialize Nat.quadmul_le_squareadd with a at 1 as hh (*: h*). { apply le_n. } especialize min_l with n,m at 1 as ?. { apply (le_n O). } - especialize h_eqone at 2 as h1 : h2. + especialize h_eqone at 2 as h1 (*: h2 *). { reflexivity. } - unfold eq_one in h2. - match type of h2 with 1 = 1 => idtac | _ => fail end. + (* unfold eq_one in h2. *) + (* match type of h2 with 1 = 1 => idtac | _ => fail end. *) match type of h1 with eq_one n -> False => idtac | _ => fail end. exact I. Qed. -*) -Require Import LibHyps.LibDecomp. + +Ltac2 rename_hyp_4 n th := + match! th with + | length ?l => [ String "lgth" ; Rename l ] + | _ => rename_hyp_3 n th (* call the previously defined tactic *) + end. + +Ltac2 Set rename_hyp := rename_hyp_4. + +Ltac2 Set rename_depth := 3. Goal forall l1 l2 l3:list nat, List.length l1 = List.length l2 /\ List.length l1 = List.length l3 -> True. Proof. - intros l1 l2 l3 h. + intros l1 l2 l3 ?/n. (* then_allnh_gen ltac:(fun x => all_hyps) ltac:(fun _ => decomp_logicals h) ltac:(fun lh => idtac lh) . *) (* Set Ltac Debug. *) - decomp_logicals h /sng. + decomp_logicals h_and_eq_lgth_lgth_eq_lgth_lgth /sn. match goal with |- _ => - match type of h_eq_length_l1_length_l2 with + match type of h_eq_lgth_l1_lgth_l2 with length l1 = length l2 => idtac | _ => fail "Test failed (wrong type)!" end diff --git a/tests/LibHypsTest.v b/tests/LibHypsTest.v index 78c2e60..70827ef 100644 --- a/tests/LibHypsTest.v +++ b/tests/LibHypsTest.v @@ -2,35 +2,45 @@ This file is part of LibHyps. It is distributed under the MIT "expat license". You should have recieved a LICENSE file with it. *) -From Stdlib Require Import Arith ZArith List. +Require Import Arith ZArith List. Require Import LibHyps.LibHyps (*LibHyps.LibSpecialize*). -From Stdlib Require Import List. +Require Import Ltac2.Ltac2. +Require Import List. -Local Open Scope autonaming_scope. Import ListNotations. -Ltac rename_hyp_2 n th := - match th with - | true <> false => name(`_tNEQf`) - | true = false => name(`_tEQf`) +Ltac2 rename_hyp_2 _ th := + match! th with + | true <> false => [ String "tNEQf" ] + | true = false => [ String "tEQf" ] end. -Ltac rename_hyp ::= rename_hyp_2. +Ltac2 Set rename_hyp := rename_hyp_2. (* Suppose I want to add later another naming rule: *) -Ltac rename_hyp_3 n th := - match th with - | Nat.eqb ?x ?y = true => name(`_Neqb` ++ x#n ++ y#n) - | true = Nat.eqb ?x ?y => name(`_Neqb` ++ x#n ++ y#n) +Ltac2 rename_hyp_3 n th := + match! th with + | Nat.eqb ?x ?y = true => [ String "Neqb"; Rename x ; Rename y ] + | true = Nat.eqb ?x ?y => [ String "Neqb" ; Rename x ; Rename y ] | _ => rename_hyp_2 n th (* call the previously defined tactic *) end. -Ltac rename_hyp ::= rename_hyp_3. -Ltac rename_depth ::= constr:(3). +Ltac2 Set rename_hyp := rename_hyp_3. + +Ltac2 rename_hyp_4 n th := + lazy_match! th with + | @cons _ ?x (cons ?y ?l) => [String "cons"; Rename x; Rename y; RenameN (decr (decr n)) l] + | @cons _ ?x ?l => if Int.ge n 1 then [String "cons"; Rename x; RenameN (decr n) l] else [String "cons"] + | _ => rename_hyp_3 n th (* call the previously defined tactic *) + end. + +Ltac2 Set rename_hyp := rename_hyp_4. + +Ltac2 rename_depth := 3. -Close Scope autonaming_scope. Close Scope Z_scope. Open Scope nat_scope. +Local Set Default Proof Mode "Classic". Ltac test h th := match type of h with @@ -172,7 +182,9 @@ Lemma test_rename_or_revert: forall x y:nat, (0 < 1 -> 1<0) -> 0 < z -> True. Proof. intros ; { rename_or_revert }. - testg ((fun _ : bool => x = y) true -> True). + match goal with + | |- _ -> True => idtac + end. auto. Qed. @@ -186,7 +198,9 @@ Lemma test_rename_or_revert2: forall x y:nat, (0 < 1 -> 1<0) -> 0 < z -> True. Proof. intros /n?. - testg ((fun _ : bool => x = y) true -> True). + match goal with + | |- _ -> True => idtac + end. test x (nat). test y (nat). (* Checking that hyps after the failed rename are introduced. *) @@ -233,7 +247,7 @@ Lemma test_group_up_list2: forall x y:nat, x = y -> (0 < 1 -> 1<0) -> 0 < z -> True. Proof. - intros ; {! group_up_list }. + intros ; { move_up_types }. lazymatch reverse goal with | Hb:_, Ha:_,Hz : _ , Hy:_ , Hx:_ |- True => let t := constr:((ltac:(reflexivity)): Hb=b) in @@ -291,43 +305,6 @@ Proof. exact I. Qed. -(* group_up_list is insensitive to order of hypothesis. It respects - the respective order of variables in each segment. This has changed - in version 2.0.5 together with a bug fix. - Note that the deprecated move_up_types is sensitive to order. *) -Lemma test_group_up_list1_rev: forall x y:nat, - ((fun f => x = y) true) - -> forall a b: bool, forall z:nat, - 0 <= 1 -> - (0%Z <= 1%Z)%Z -> - x <= y -> - x = y -> - (0 < 1 -> 1<0) -> 0 < z -> True. -Proof. - intros ; {!< group_up_list }. - lazymatch reverse goal with - | Hb:_, Ha:_,Hz : _ , Hy:_ , Hx:_ |- True => - let t := constr:((ltac:(reflexivity)): Hb=b) in - let t := constr:((ltac:(reflexivity)): Ha=a) in - let t := constr:((ltac:(reflexivity)): Hz=z) in - let t := constr:((ltac:(reflexivity)): Hy=y) in - let t := constr:((ltac:(reflexivity)): Hx=x) in - idtac - | _ => fail "test failed (wrong order of hypothesis)!" - end. - lazymatch goal with - | hH1:_, hH2:_,hH3 : _ , hH4:_ , hH5:_ |- True => - let t := constr:((ltac:(reflexivity)):H1=hH1) in - let t := constr:((ltac:(reflexivity)): H2=hH2) in - let t := constr:((ltac:(reflexivity)): H3=hH3) in - let t := constr:((ltac:(reflexivity)): H4=hH4) in - let t := constr:((ltac:(reflexivity)): H5=hH5) in - idtac - | _ => fail "test failed (wrong order of hypothesis)!" - end. - exact I. - Qed. - (* Two more tests for the case where the top hyp is Prop-sorted. *) Lemma test_group_up_list3: @@ -435,7 +412,7 @@ Lemma test_group_up_after_subst: forall x y:nat, x = y -> (0 < 1 -> 1<0) -> 0 < z -> True. Proof. - intros ; { subst_or_idtac } ; {! group_up_list }. + intros ; { subst_or_idtac } ; { move_up_types }. lazymatch reverse goal with | Hb:_, Ha:_,Hz:_ , Hy:_ |- True => let t := constr:((ltac:(reflexivity)): Hb=b) in @@ -459,87 +436,6 @@ Proof. Qed. -Ltac substHyp H ::= - match type of H with - | Depl => fail 1 (* fail immediately, we are applying on a list of hyps. *) - | ?x = ?y => - (* subst would maybe subst using another hyp, so use replace to be sure *) - once ((is_var(x); replace x with y in *; [try clear x ; try clear H] ) - + (is_var(y);replace y with x in * ; [ try clear H])) - | _ => idtac - end. - - -(* Legacy Notations tac ;!; tac2. *) -Lemma test_tactical_semi: forall x y:nat, - ((fun f => x = y) true) - -> forall a b: bool, forall z:nat, - 0 <= 1 -> - (0%Z <= 1%Z)%Z -> - x <= y -> - x = y -> - (0 < 1 -> 1<0) -> 0 < z -> True. -Proof. - (* move_up_types is there for backward compatibility. It moves Type-Sorted hyps up. *) - intros ;; move_up_types. - lazymatch reverse goal with - | Hb:_, Ha:_,Hz : _ , Hy:_ , Hx:_ |- True => - let t := constr:((ltac:(reflexivity)): Hb=b) in - let t := constr:((ltac:(reflexivity)): Ha=a) in - let t := constr:((ltac:(reflexivity)): Hz=z) in - let t := constr:((ltac:(reflexivity)): Hy=y) in - let t := constr:((ltac:(reflexivity)): Hx=x) in - idtac - | _ => fail "test failed (wrong order of hypothesis)!" - end. - lazymatch goal with - | hH1:_, hH2:_,hH3 : _ , hH4:_ , hH5:_ |- True => - let t := constr:((ltac:(reflexivity)): H1=hH1) in - let t := constr:((ltac:(reflexivity)): H2=hH2) in - let t := constr:((ltac:(reflexivity)): H3=hH3) in - let t := constr:((ltac:(reflexivity)): H4=hH4) in - let t := constr:((ltac:(reflexivity)): H5=hH5) in - idtac - | _ => fail "test failed (wrong order of hypothesis)!" - end. - auto. -Qed. - -(* Legacy Notations tac ;; tac2. *) -Lemma test_tactical_semi_rev: forall x y:nat, - ((fun f => x = y) true) - -> forall a b: bool, forall z u:nat, - 0 <= 1 -> - (0%Z <= 1%Z)%Z -> - x <= y -> - x = y -> - (0 < 1 -> 1<0) -> 0 < z -> True. -Proof. - (* move_up_types is there for backward compatibility. It moves Type-Sorted hyps up. *) - intros ;!; move_up_types. - lazymatch reverse goal with - | Ha:_, Hb:_, Hz: _ , Hu : _ , Hy:_ , Hx:_ |- True => - let t := constr:((ltac:(reflexivity)): Hb=b) in - let t := constr:((ltac:(reflexivity)): Ha=a) in - let t := constr:((ltac:(reflexivity)): Hu=u) in - let t := constr:((ltac:(reflexivity)): Hz=z) in - let t := constr:((ltac:(reflexivity)): Hy=y) in - let t := constr:((ltac:(reflexivity)): Hx=x) in - idtac - | _ => fail "test failed (wrong order of hypothesis)!" - end. - lazymatch goal with - | hH1:_, hH2:_,hH3 : _ , hH4:_ , hH5:_ |- True => - let t := constr:((ltac:(reflexivity)): H1=hH1) in - let t := constr:((ltac:(reflexivity)): H2=hH2) in - let t := constr:((ltac:(reflexivity)): H3=hH3) in - let t := constr:((ltac:(reflexivity)): H4=hH4) in - let t := constr:((ltac:(reflexivity)): H5=hH5) in - idtac - | _ => fail "test failed (wrong order of hypothesis)!" - end. - auto. -Qed. (* Legacy Notations !!!!tac. *) @@ -641,7 +537,7 @@ Lemma foo': (a b:bool), True -> forall y z:nat, True. (* Time intros. (* .07s *) *) (* Time intros; { fun x => idtac x}. (* 1,6s *) *) - Time intros /g. (* 3s *) + Time intros /g. (* Ltac with cache: 3s, Ltac2: 0,04s *) (* Time intros ; { move_up_types }. (* ~7mn *) *) (* Time intros /n. (* 19s *) *) exact I. diff --git a/tests/demo.v b/tests/demo.v index 7c24db4..ed22e97 100644 --- a/tests/demo.v +++ b/tests/demo.v @@ -16,11 +16,11 @@ playing the Undos. *) opam install coq_libhyps *) (*** Proof maintenance ***) -From Stdlib Require Import Arith ZArith List. +Require Import Arith ZArith List. Require Import LibHyps.LibHyps. Lemma demo: forall x y z:nat, - x = y -> forall a b t : nat, a+1 = t+2 -> b + 5 = t - 7 -> (forall u v, v+1 = 1 -> u+1 = 1 -> a+1 = z+2) -> z = b + x-> True. + x = y -> x+y = y+ z -> forall a b t : nat, a+1 = t+2 -> b + 5 = t - 7 -> (forall u v, v+1 = 1 -> u+1 = 1 -> a+1 = z+2) -> z = b + x-> True. Proof. intros. (* ugly names *) @@ -42,16 +42,32 @@ Proof. Undo. (* Even shorter: *) intros /sng. - (* Let us instantiate the 2nd premis of h_all_eq_add_add without copying its type: *) - (* BROKEN IN COQ 8.18*) + (* Let us instantiate the 2nd premis of h_all_eq_add_add without + copying its type. Having variable u evarized (and then instantitated): *) especialize h_all_eq_add_add_ with u at 2. { apply Nat.add_0_l. } - (* now h_all_eq_add_add is specialized *) - Undo 6. + (* See how both u and (u + 1) have been removed from the hypothesis. *) + Undo 4. + (* We can do it for several hyps at a time: *) + especialize h_all_eq_add_add_ with u,v until 2. + { apply Nat.add_0_l. } + { apply Nat.add_0_l. } + Undo 7. + (* We can do it for several hyps at a time: *) + especialize h_all_eq_add_add_ with u,v at *. + { apply Nat.add_0_l. } + { apply Nat.add_0_l. } + Undo 7. + (* We can do it for several hyps at a time: *) + especialize h_all_eq_add_add_ with u,v at 1,2. + { apply Nat.add_0_l. } + { apply Nat.add_0_l. } + Undo 7. + Restart. intros until 1. (** The taticals apply after any tactic. Notice how H:x=y is not new - and hence not substituted, whereas z = b + x is. *) + and hence not substituted (and becomes 0=y), whereas z = b + x is. *) destruct x eqn:heq;intros /sng. - apply I. - apply I. @@ -172,7 +188,7 @@ Proof. Undo 5. (* IDEs don't like Undo, replay the next ocommand twice will resync proofgeneral. *) - (* It accepts several (up to 7) premisses numers. *) + (* It accepts several (up to 7) premisses numbers. *) (* THIS HAS CHANGED in libHyps 3 *) especialize H3 with n,m,p at 2,3. Undo. @@ -189,6 +205,10 @@ Proof. (* Show 4. *) Undo. + (* Note that non dependent variables must be given in order: *) + Fail especialize H3 with n,p,m until 3. + + (* VARIABLES MIXED WITH HYPOTHESIS. *) (* move_up_types X. moves X at top near something of the same type, but only if X is Type-sorted (not Prop). *) @@ -203,10 +223,7 @@ Proof. (* Better do that on new hyps only. *) intros ; { move_up_types }. Undo. - (* Faster version dealing with the whole list of new hyps at once: *) - intros; {! group_up_list }. - Undo. - (* Shortcut for this faster version: *) + (* Shortcut: *) intros /g. Undo. (* combined with subst: *) @@ -270,59 +287,42 @@ Abort. (* customization of autorename *) -Local Open Scope autonaming_scope. +(* Local Open Scope autonaming_scope. *) Import ListNotations. - +Require Import Ltac2.Ltac2. (* Define the naming scheme as new tactic pattern matching on a type th, and the depth n of the recursive naming analysis. Here we state that a type starting with Nat.eqb should start with _Neqb, followed by the name of both arguments. #n here means normal decrement of depth. (S n) would increase depth by 1 (n-1) would decrease depth. *) -Ltac rename_hyp_2 n th := - match th with - | Nat.eqb ?x ?y => name(`_Neqb` ++ x#n ++ y#n) + +Ltac2 rename_hyp_2 _n th := + match! th with + | Nat.eqb ?x ?y => [ String "Neqb" ; Rename x ; Rename y] end. (* Then overwrite the customization hook of the naming tactic *) -Ltac rename_hyp ::= rename_hyp_2. +Ltac2 Set rename_hyp := rename_hyp_2. -Goal forall x y:nat, True. - intros. - (* computing a few names *) - (* Customize the starting depth *) - - let res := fallback_rename_hyp_name (Nat.eqb 1 2) in idtac res. - let res := fallback_rename_hyp_name (Nat.eqb x 4) in idtac res. - let res := fallback_rename_hyp_name (Nat.eqb 1 2 = false) in idtac res. - Ltac rename_depth ::= constr:(2). - let res := fallback_rename_hyp_name (Nat.eqb 1 2 = false) in idtac res. - Ltac rename_depth ::= constr:(3). -Abort. (** Suppose I want to add another naming rule: I need to cumulate the previous scheme with the new one. First define a new tactic that will replace the old one. it should call previous naming schemes in case of failure of the new scheme. It is thus important that rename_hyp_2 was defined by itself and directly as rename_hyp. *) -Ltac rename_hyp_3 n th := - match th with - | ?x = false => name(x#n ++ `_isf`) - | ?x = true => name( x#n ++ `_ist`) +Ltac2 rename_hyp_3 n th := + match! th with + | ?x = false => [ Rename x ; String "isf" ] + | ?x = true => [ Rename x ; String "ist" ] | _ => rename_hyp_2 n th (* previous naming scheme *) end. (* Then update the customization hook *) -Ltac rename_hyp ::= rename_hyp_3. +Ltac2 Set rename_hyp := rename_hyp_3. (* Close the naming scope *) -Local Close Scope autonaming_scope. - -Goal forall x y:nat, True. - intros. - let res := fallback_rename_hyp_name (Nat.eqb 1 2 = false) in - idtac res. -Abort. +Local Set Default Proof Mode "Classic". Lemma foo: forall (x:nat) (b1:bool) (y:nat) (b2:bool), x = y @@ -336,12 +336,12 @@ Lemma foo: forall (x:nat) (b1:bool) (y:nat) (b2:bool), -> z = b + 5-> z' + 1 = b + x-> x < y + b. Proof. (* Customize the starting depth *) - Ltac rename_depth ::= constr:(3). + Ltac2 Set rename_depth := 3. intros/n/g. Undo. (* Have shorter names: *) - Ltac rename_depth ::= constr:(2). + Ltac2 Set rename_depth := 2. intros/n/g. diff --git a/tests/test_assert_premise.v b/tests/test_assert_premise.v new file mode 100644 index 0000000..46f1fb7 --- /dev/null +++ b/tests/test_assert_premise.v @@ -0,0 +1,225 @@ +Require Import Arith. +Require Import LibHyps.LibHyps. +Require Import Ltac2.Ltac2. +Local Set Default Proof Mode "Classic". + +Definition eq_one (i:nat) := i = 1. + +(* Default configuration: variables are quantified unless not + appearing in the type of the created hypothesis *) +Ltac2 Set on_cited_vars := Evarize. +Ltac2 Set dont_quantif_unused := true. + +Lemma test_espec_namings_premis: forall n:nat, (eq_one n -> eq_one 1 -> False) -> True. +Proof. + intros n h_eqone. + assert premise 1 of Nat.quadmul_le_squareadd with a as h. + { apply le_n. } + Undo 4. + assert premise 1 of Nat.quadmul_le_squareadd with a as hh (*: h*). + { apply le_n. } + Undo 4. + assert premise 1 of min_l with n,m as hhh. + { apply (le_n O). } + Undo 4. + assert premise 1 of min_l as hhh. + { admit. } + Undo 4. + + especialize h_eqone at 2 as h1 (*: h2 *). + { reflexivity. } + (* unfold eq_one in h2. *) + (* match type of h2 with 1 = 1 => idtac | _ => fail end. *) + match type of h1 with eq_one n -> False => idtac | _ => fail end. + exact I. +Qed. + +(* Testing the four variants of these config. *) + +Ltac2 Set on_cited_vars := Evarize. +Ltac2 Set dont_quantif_unused := false. + +Goal (forall n p m:nat, n<=m -> n n=p -> False) -> True. + intros h. + assert premise 1 -> 2 of h with n,m as hh. + match goal with + | |- (nat -> ?n <= ?m -> ?n < ?m) => idtac + end. + 2:match type of hh with (nat -> ?n <= ?m -> ?n < ?m) => idtac end. + Undo 3. + assert premise 2 of h with n as hh. + match goal with + | |- nat -> forall m : nat, ?n < m => idtac + end. + Undo 2. + assert premise 2 of h as hh. + match goal with + | |- forall n : nat, nat -> forall m : nat, n < m => idtac + end. + Undo 2. + assert premise 1 -> 2 -> 3 of h as hh. + match goal with + | |- forall n p m : nat, n <= m -> n < m -> n = p => idtac + end. + Undo 2. + assert premise 1 -> 2 of h with n,m. + match goal with + | |- (nat -> ?n <= ?m -> ?n < ?m) => idtac + end. + 2:match type of H with (nat -> ?n <= ?m -> ?n < ?m) => idtac end. + Undo 3. + assert premise 2 of h with n. + match goal with + | |- nat -> forall m : nat, ?n < m => idtac + end. + Undo 2. + assert premise 2 of h. + match goal with + | |- forall n : nat, nat -> forall m : nat, n < m => idtac + end. + Undo 2. + assert premise 1 -> 2 -> 3 of h. + match goal with + | |- forall n p m : nat, n <= m -> n < m -> n = p => idtac + end. + Undo 2. + +Ltac2 Set on_cited_vars := Evarize. +Ltac2 Set dont_quantif_unused := true. + + assert premise 1 -> 2 of h with n,m as hh. + match goal with + | |- (?n <= ?m -> ?n < ?m) => idtac + end. + 2:match type of hh with (?n <= ?m -> ?n < ?m) => idtac end. + Undo 3. + assert premise 2 of h with n as hh. + match goal with + | |- forall m : nat, ?n < m => idtac + end. + Undo 2. + assert premise 2 of h as hh. + match goal with + | |- forall n : nat, forall m : nat, n < m => idtac + end. + Undo 2. + assert premise 1 -> 2 -> 3 of h as hh. + match goal with + | |- forall n p m : nat, n <= m -> n < m -> n = p => idtac + end. + Undo 2. + assert premise 1 -> 2 of h with n,m. + match goal with + | |- (?n <= ?m -> ?n < ?m) => idtac + end. + 2:match type of H with (?n <= ?m -> ?n < ?m) => idtac end. + Undo 3. + assert premise 2 of h with n. + match goal with + | |- forall m : nat, ?n < m => idtac + end. + Undo 2. + assert premise 2 of h. + match goal with + | |- forall n : nat, forall m : nat, n < m => idtac + end. + Undo 2. + assert premise 1 -> 2 -> 3 of h. + match goal with + | |- forall n p m : nat, n <= m -> n < m -> n = p => idtac + end. + Undo 2. + + +Ltac2 Set on_cited_vars := Quantify. +Ltac2 Set dont_quantif_unused := false. + + assert premise 1 -> 2 of h with n,m as hh. + match goal with + | |- forall n m : nat, n <= m -> n < m => idtac + end. + 2:match type of hh with (forall n m : nat, n <= m -> n < m) => idtac end. + Undo 3. + assert premise 2 of h with n as hh. + match goal with + | |- forall n : nat, n < ?m => idtac + end. + Undo 2. + assert premise 2 of h as hh. + match goal with + | |- ?n < ?m => idtac + end. + Undo 2. + assert premise 1 -> 2 -> 3 of h as hh. + match goal with + | |- ?n <= ?m -> ?n < ?m -> ?n = ?p => idtac + end. + Undo 2. + assert premise 1 -> 2 of h with n,m. + match goal with + | |- forall n m : nat, n <= m -> n < m => idtac + end. + 2:match type of H with (forall n m : nat, n <= m -> n < m) => idtac end. + Undo 3. + assert premise 2 of h with n. + match goal with + | |- forall n : nat, n < ?m => idtac + end. + Undo 2. + assert premise 2 of h. + match goal with + | |- ?n < ?m => idtac + end. + Undo 2. + assert premise 1 -> 2 -> 3 of h. + match goal with + | |- ?n <= ?m -> ?n < ?m -> ?n = ?p => idtac + end. + Undo 2. + +Ltac2 Set on_cited_vars := Quantify. +Ltac2 Set dont_quantif_unused := true. (* should not change anything, since we (don't) evar unused vars anyways. *) + + assert premise 1 -> 2 of h with n,m as hh. + match goal with + | |- forall n m : nat, n <= m -> n < m => idtac + end. + 2:match type of hh with (forall n m : nat, n <= m -> n < m) => idtac end. + Undo 3. + assert premise 2 of h with n as hh. + match goal with + | |- forall n : nat, n < ?m => idtac + end. + Undo 2. + assert premise 2 of h as hh. + match goal with + | |- ?n < ?m => idtac + end. + Undo 2. + assert premise 1 -> 2 -> 3 of h as hh. + match goal with + | |- ?n <= ?m -> ?n < ?m -> ?n = ?p => idtac + end. + Undo 2. + assert premise 1 -> 2 of h with n,m. + match goal with + | |- forall n m : nat, n <= m -> n < m => idtac + end. + 2:match type of H with (forall n m : nat, n <= m -> n < m) => idtac end. + Undo 3. + assert premise 2 of h with n. + match goal with + | |- forall n : nat, n < ?m => idtac + end. + Undo 2. + assert premise 2 of h. + match goal with + | |- ?n < ?m => idtac + end. + Undo 2. + assert premise 1 -> 2 -> 3 of h. + match goal with + | |- ?n <= ?m -> ?n < ?m -> ?n = ?p => idtac + end. + Undo 2. +Abort.