From f41122ed8a2a2b06035be4ebba700aeb04634b54 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Fri, 10 Oct 2025 19:25:37 +0200 Subject: [PATCH 01/15] WIP: refine_hd in ltac2. First working version. --- LibHyps/Especialize.v | 360 +++++++++++++++++++++++++++++++++--------- 1 file changed, 288 insertions(+), 72 deletions(-) diff --git a/LibHyps/Especialize.v b/LibHyps/Especialize.v index 499aa71..a707283 100644 --- a/LibHyps/Especialize.v +++ b/LibHyps/Especialize.v @@ -160,7 +160,7 @@ Proof. Abort. (* debug *) -(*Require Import LibHyps.LibHypsTactics. +Require Import LibHyps.LibHypsTactics. Module Prgoal_Notation. Ltac pr_goal := match goal with @@ -191,82 +191,298 @@ 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. + + +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 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). + +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. + +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. + + +(* +Goal False. + let ev1 := open_constr:(_) in + assert ev1. + ltac2:(intro_typed (Option.get (Ident.of_string "toto")) constr:(nat)). *) -(* 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] + +Ltac2 Type directarg := [ Quantif | QuantifIgnore | SubGoal | Evar(ident) ]. +Ltac2 Type namearg := [ + SubGoalAtName(ident) (* make a subgoal with named arg *) + | EvarAtName(ident,ident) (* make an evar with the named arg. *) +]. +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. *) + ]. + +(* FIXME *) +Ltac2 is_dep_prod (t:constr): bool := + match kind t with + | Prod _ subt => Bool.neg (is_closed subt) + | _ => false + end. + +Ltac2 pr_numarg () a := + match a with + | SubGoalAtNum(i) => fprintf "SubGoalAtNum(%i)" i + | SubGoalUntilNum(i) => fprintf "SubGoalUntilNum(%i)" i + | SubGoalAtAll => fprintf "SubGoalAtAll" + end. + +Ltac2 backtrack (msg:string) := Control.zero (Tactic_failure (Some (fprintf "Backtrack: %s" msg))). +Ltac2 invalid_arg (msg:string) := Control.throw (Invalid_argument (Some (Message.of_string msg))). + +Ltac2 rec refine_hd (h:ident) (ldirectarg:directarg list) (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 *) + (* pr_goal(); *) + printf "th = %t" th; + printf "%a" pr_numarg (List.hd lnumargs); + (* msgc th; *) + let newn := if is_dep_prod th then n else (Int.add n 1) in + match ldirectarg,lnameargs,lnumargs with + | [],[],[] => exact $hc (* let tc := ltac1:(h |- exact h) in tc (Ltac1.of_constr hc) *) + | (directarg::ldirectarg'),_,_ => + match Unsafe.kind th with + | Prod bnd _ => + msgs "ICI"; + let h_premis := Constr.Binder.name bnd in + let typ_premis := Constr.Binder.type bnd in + let intronme:ident := + match h_premis with + None => Option.get (Ident.of_string "h_premis") + | Some idh => idh + end in + match directarg with + | Quantif => + intro_typed intronme typ_premis; + specialize_id_id h intronme; + refine_hd h ldirectarg' lnameargs lnumargs newn + | QuantifIgnore => + intro_typed intronme typ_premis; + specialize_id_id h intronme; + clear $intronme; + refine_hd h ldirectarg' lnameargs lnumargs newn + | Evar ename => + let tac := ltac1:(ename typ_premis|- evar (ename:typ_premis)) in + tac (Ltac1.of_ident ename) (Ltac1.of_constr typ_premis) ; + specialize_id_id h ename; + subst $ename; + refine_hd h ldirectarg' lnameargs lnumargs newn + | SubGoal => + let gl := Fresh.in_goal @h in (* this uses base name "h" *) + (unshelve (epose (_:$typ_premis) as $gl)) > + [ | + let special := Control.hyp gl in + specialize_id_cstr h special; + refine_hd h ldirectarg' lnameargs lnumargs newn ] + end + | _ => + match lnumargs with + | [SubGoalAtAll] => exact $hc + | _ => let _ := printf "th: %t" th in + invalid_arg "Not a product (directarg)" end - | _ => idtac "Not enough products." (*; fail*) end - end. + | _ => + msgs "ICI 2"; + Control.plus + (fun() => refine_hd_name h ldirectarg lnameargs lnumargs n) + (fun _ => Control.plus + (fun () => refine_hd_num h ldirectarg lnameargs lnumargs n) + (fun _ => refine_hd h [Quantif] lnameargs lnumargs n)) + + (* (refine_hd_num (h:ident) (ldirectarg:directarg list) (lnameargs:namearg list) *) + (* (lnumargs:numarg list) (n:int)) *) + end + with refine_hd_name (h:ident) (ldirectarg:directarg list) (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 *) + match ldirectarg,lnameargs,lnumargs with + | [],[],[] => invalid_arg "refine_hd_name: assert false" + | [], (namearg :: lnameargs') , _ => + match Unsafe.kind th with + | Prod bnd _ => + let h_premis := Constr.Binder.name bnd in + let typ_premis := Constr.Binder.type bnd in + let intronme:ident := + match h_premis with + None => Option.get (Ident.of_string "h_premis") + | Some idh => idh + end in + match namearg with + | SubGoalAtName nme => + if map_default (Ident.equal nme) false h_premis + then refine_hd 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 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 + with refine_hd_num (h:ident) (ldirectarg:directarg list) (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 ldirectarg,lnameargs,lnumargs with + | [],[],[] => invalid_arg "refine_hd_num: assert false" + | [],_,numarg::lnumargs' => + match Unsafe.kind th with + | Prod bnd _ => + 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 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 + let _ := msgc th in + let _ := msgs "not dep" in + if Int.equal newn num + then refine_hd h [SubGoal] lnameargs lnumargs' n + else refine_hd h [SubGoal] lnameargs lnumargs n + + | SubGoalAtAll => + let _ := msgs "SubGoalAtAll:" in + let _ := msgc th in + if is_dep_prod th + then backtrack "refine_hd_num: SubGoalAtAll, dep" + else refine_hd h [SubGoal] lnameargs lnumargs n + end + | _ => backtrack "Not a product (refine_hd_num)." + end + | _ => backtrack "refine_hd_num: no numarg" + end +. + +(* 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. + + let ev1 := open_constr:(_) in + assert ev1. + + + (ltac2:(refine_hd + (Option.get (Ident.of_string "H")) + [] + [EvarAtName @m @m] + [SubGoalAtAll] + 0)). + + (ltac2:(refine_hd + (Option.get (Ident.of_string "H")) + [] + [EvarAtName @m @m] + [SubGoalUntilNum 3] + 0)). + + + + + (ltac2:(refine_hd + (Option.get (Ident.of_string "H")) + [Evar @ev] + [EvarAtName @p @p ;SubGoalAtName @iii] + [SubGoalAtNum 3] + 0)). + + + + + let ev1 := open_constr:(_) in + assert ev1; + [ (ltac2:(refine_hd (Option.get (Ident.of_string "H")) + [Quantif; Quantif; Evar @p] [] [] 0)) |]. + + + match goal with | |- False => idtac end; match type of X with forall (n:_) (m:_), n < m -> _ => idtac end . + Undo 1. + especialize H with n, p; + [ match goal with | |- False => idtac end; match type of H with forall (m:_), _ < m -> _ => idtac end ]. + Undo 1. + especialize H with p as h; + [ match goal with | |- False => idtac end; match type of h with forall (n:_) (m:_), n < m -> _ => idtac end ]. + Undo 1. + especialize H with n, p as h; + [ match goal with | |- False => idtac end; match type of h with forall (m:_), _ < m -> _ => idtac end ]. + Undo 1. + especialize H with p as ?; + [ match goal with | |- False => idtac end; match type of H_spec_ with forall (n:_) (m:_), n < m -> _ => idtac end ]. + Undo 1. + especialize H with n, p as ?; + [ match goal with | |- False => idtac end; match type of H_spec_ with forall (m:_), _ < m -> _ => idtac end ]. + Undo 1. + + +Goal forall (h:forall t z x y:nat, x = y -> x = x -> z = y -> x <= y), False. +Proof. + intros h. + let ev1 := open_constr:(_) in + assert ev1. + + (* epose _. *) + (* unshelve (ltac2:(epose (_) as hhh)). *) + (* unshelve (ltac2:(specialize_id_cstr @h constr:(hhh))). *) + + + + (ltac2:(refine_hd (Option.get (Ident.of_string "h")) + [Quantif;Quantif;Evar @myx; Quantif; SubGoal; SubGoal] [] [] 0)). + + + + + + + ltac2:(intro_typed (Option.get (Ident.of_string "toto")) constr:(nat)). + + -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',_,_) => From 5af46451a306a58b8c4ca4b9cffdfdd54c25a2d7 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Sat, 11 Oct 2025 19:12:18 +0200 Subject: [PATCH 02/15] Ltac2 version of especialize. --- LibHyps/Especialize.v | 914 ++++++++++++++++---------------------- LibHyps/LibHypsDebug.v | 45 ++ Makefile | 11 +- configure.sh | 31 +- testDebug.sh | 22 + tests/Especialize_tests.v | 2 +- 6 files changed, 493 insertions(+), 532 deletions(-) create mode 100644 LibHyps/LibHypsDebug.v create mode 100755 testDebug.sh diff --git a/LibHyps/Especialize.v b/LibHyps/Especialize.v index a707283..eba8bef 100644 --- a/LibHyps/Especialize.v +++ b/LibHyps/Especialize.v @@ -1,108 +1,24 @@ -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. *) -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)). +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. (* ESPECIALIZE INTERNAL DOC *) @@ -159,179 +75,167 @@ Proof. 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. +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 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). +Local Ltac2 pr_numarg () a := + match a with + | SubGoalAtNum(i) => fprintf "SubGoalAtNum(%i)" i + | SubGoalUntilNum(i) => fprintf "SubGoalUntilNum(%i)" i + | SubGoalAtAll => fprintf "SubGoalAtAll" + end. + +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])). +*) -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. -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 "". +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). + -Ltac2 intro_typed (name:ident) (typ:constr) := +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). -Ltac2 specialize_id_id (h:ident) (arg:ident) : unit := +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. -Ltac2 specialize_id_cstr (h:ident) (c:constr) : unit := +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. -(* -Goal False. - let ev1 := open_constr:(_) in - assert ev1. - ltac2:(intro_typed (Option.get (Ident.of_string "toto")) constr:(nat)). -*) +(* 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. *) -Ltac2 Type directarg := [ Quantif | QuantifIgnore | SubGoal | Evar(ident) ]. -Ltac2 Type namearg := [ - SubGoalAtName(ident) (* make a subgoal with named arg *) - | EvarAtName(ident,ident) (* make an evar with the named arg. *) -]. -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. *) - ]. -(* FIXME *) -Ltac2 is_dep_prod (t:constr): bool := - match kind t with - | Prod _ subt => Bool.neg (is_closed subt) - | _ => false - end. - -Ltac2 pr_numarg () a := - match a with - | SubGoalAtNum(i) => fprintf "SubGoalAtNum(%i)" i - | SubGoalUntilNum(i) => fprintf "SubGoalUntilNum(%i)" i - | SubGoalAtAll => fprintf "SubGoalAtAll" - end. - -Ltac2 backtrack (msg:string) := Control.zero (Tactic_failure (Some (fprintf "Backtrack: %s" msg))). -Ltac2 invalid_arg (msg:string) := Control.throw (Invalid_argument (Some (Message.of_string msg))). - -Ltac2 rec refine_hd (h:ident) (ldirectarg:directarg list) (lnameargs:namearg list) +Local Ltac2 rec refine_hd (h:ident) (ldirectarg:directarg list) (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 *) - (* pr_goal(); *) - printf "th = %t" th; - printf "%a" pr_numarg (List.hd lnumargs); - (* msgc th; *) + (* 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 - match ldirectarg,lnameargs,lnumargs with - | [],[],[] => exact $hc (* let tc := ltac1:(h |- exact h) in tc (Ltac1.of_constr hc) *) - | (directarg::ldirectarg'),_,_ => - match Unsafe.kind th with - | Prod bnd _ => - msgs "ICI"; - let h_premis := Constr.Binder.name bnd in - let typ_premis := Constr.Binder.type bnd in - let intronme:ident := - match h_premis with - None => Option.get (Ident.of_string "h_premis") - | Some idh => idh - end in - match directarg with - | Quantif => - intro_typed intronme typ_premis; - specialize_id_id h intronme; - refine_hd h ldirectarg' lnameargs lnumargs newn - | QuantifIgnore => - intro_typed intronme typ_premis; - specialize_id_id h intronme; - clear $intronme; - refine_hd h ldirectarg' lnameargs lnumargs newn - | Evar ename => - let tac := ltac1:(ename typ_premis|- evar (ename:typ_premis)) in - tac (Ltac1.of_ident ename) (Ltac1.of_constr typ_premis) ; - specialize_id_id h ename; - subst $ename; - refine_hd h ldirectarg' lnameargs lnumargs newn - | SubGoal => - let gl := Fresh.in_goal @h in (* this uses base name "h" *) - (unshelve (epose (_:$typ_premis) as $gl)) > - [ | - let special := Control.hyp gl in - specialize_id_cstr h special; - refine_hd h ldirectarg' lnameargs lnumargs newn ] - end - | _ => - match lnumargs with - | [SubGoalAtAll] => exact $hc - | _ => let _ := printf "th: %t" th in - invalid_arg "Not a product (directarg)" + (* msgc th; *) + match Unsafe.kind th with + | Prod _ _ => + match ldirectarg with + | directarg::ldirectarg' => + match Unsafe.kind th with + | Prod bnd _ => + let h_premis := Constr.Binder.name bnd in + let typ_premis := Constr.Binder.type bnd in + let intronme:ident := + match h_premis with + None => Option.get (Ident.of_string "h_premis") + | Some idh => idh + end in + match directarg with + | Quantif => + intro_typed intronme typ_premis; + specialize_id_id h intronme; + refine_hd h ldirectarg' lnameargs lnumargs newn + | QuantifIgnore => + intro_typed intronme typ_premis; + specialize_id_id h intronme; + clear $intronme; + refine_hd h ldirectarg' lnameargs lnumargs newn + | Evar ename => + let ename := Fresh.in_goal ename in + mk_evar ename typ_premis; + (* let tac := ltac1:(ename typ_premis|- evar (ename:typ_premis)) in *) + (* tac (Ltac1.of_ident ename) (Ltac1.of_constr typ_premis) ; *) + specialize_id_id h ename; + subst $ename; + refine_hd h ldirectarg' lnameargs lnumargs newn + | SubGoal => + let gl := Fresh.in_goal @h in (* this uses base name "h" *) + (unshelve (epose (_:$typ_premis) as $gl)) > + [ | + let special := Control.hyp gl in + specialize_id_cstr h special; + refine_hd h ldirectarg' lnameargs lnumargs newn ] + end + | _ => invalid_arg "Not a product (directarg)" + end + | _ => + (* If this succeeds, never go back here from later backtrack. *) + Control.once + (fun () => Control.plus + (fun() => refine_hd_name h lnameargs lnumargs n) + (fun _ => + (* msgs "Backtracking from refine_hd_name "; *) + Control.plus + (fun () => refine_hd_num h lnameargs lnumargs n) + (fun _ => + (*msgs "Backtracking from refine_hd_num "; *) + refine_hd h [Quantif] lnameargs lnumargs n))) + end + | _ => (*base case *) + match ldirectarg,lnameargs,lnumargs with + | [],[],[] => exact $hc + | [],[],[SubGoalAtAll] => exact $hc + | _ => invalid_arg "Not a product (others)" end - | _ => - msgs "ICI 2"; - Control.plus - (fun() => refine_hd_name h ldirectarg lnameargs lnumargs n) - (fun _ => Control.plus - (fun () => refine_hd_num h ldirectarg lnameargs lnumargs n) - (fun _ => refine_hd h [Quantif] lnameargs lnumargs n)) - (* (refine_hd_num (h:ident) (ldirectarg:directarg list) (lnameargs:namearg list) *) (* (lnumargs:numarg list) (n:int)) *) end - with refine_hd_name (h:ident) (ldirectarg:directarg list) (lnameargs:namearg list) + with refine_hd_name (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 *) - match ldirectarg,lnameargs,lnumargs with - | [],[],[] => invalid_arg "refine_hd_name: assert false" - | [], (namearg :: lnameargs') , _ => + match lnameargs with + | namearg :: lnameargs' => match Unsafe.kind th with | Prod bnd _ => let h_premis := Constr.Binder.name bnd in - let typ_premis := Constr.Binder.type bnd in - let intronme:ident := - match h_premis with - None => Option.get (Ident.of_string "h_premis") - | Some idh => idh - end in match namearg with | SubGoalAtName nme => if map_default (Ident.equal nme) false h_premis @@ -346,16 +250,15 @@ Ltac2 rec refine_hd (h:ident) (ldirectarg:directarg list) (lnameargs:namearg lis end | _ => backtrack "refine_hd_name: no namearg" end - with refine_hd_num (h:ident) (ldirectarg:directarg list) (lnameargs:namearg list) + with refine_hd_num (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 ldirectarg,lnameargs,lnumargs with - | [],[],[] => invalid_arg "refine_hd_num: assert false" - | [],_,numarg::lnumargs' => + match lnumargs with + | numarg::lnumargs' => match Unsafe.kind th with - | Prod bnd _ => + | Prod _ _ => match numarg with | SubGoalAtNum num => if is_dep_prod th @@ -369,29 +272,52 @@ Ltac2 rec refine_hd (h:ident) (ldirectarg:directarg list) (lnameargs:namearg lis if is_dep_prod th then backtrack "refine_hd_num: SubGoalUntilNum, dep" else - let _ := msgc th in - let _ := msgs "not dep" in if Int.equal newn num then refine_hd h [SubGoal] lnameargs lnumargs' n else refine_hd h [SubGoal] lnameargs lnumargs n | SubGoalAtAll => - let _ := msgs "SubGoalAtAll:" in - let _ := msgc th in if is_dep_prod th then backtrack "refine_hd_num: SubGoalAtAll, dep" else refine_hd h [SubGoal] lnameargs lnumargs n end - | _ => backtrack "Not a product (refine_hd_num)." + | _ => invalid_arg "Not a product (refine_hd_num)." end | _ => backtrack "refine_hd_num: no numarg" - end -. + end. + +(* initialize n to zero. *) +Local Ltac2 refine_spec h lnameargs lnumargs := refine_hd 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. *) + (* especialize ex_hyp at 2 as h. *) + specialize ex_hyp as H. + + ltac2:(assert_evar @hhh). + + let ev1 := open_constr:(_) in + assert ev1 as hhh;[ + ltac2:(refine_spec + (Option.get (Ident.of_string "H")) + [EvarAtName @b @b; EvarAtName @x @x; EvarAtName @y @y] + [SubGoalAtNum 3]) + | ]; + [ | match type of hhh 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]. + [ .. | match type of hhh 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]. + + +especialize ex_hyp at 3 with b,x,y as h; + Undo. + Lemma foo: forall x y : nat, (forall (n m p :nat) (hhh:n < m) (iii:n <= m), @@ -406,12 +332,11 @@ Proof. assert ev1. - (ltac2:(refine_hd - (Option.get (Ident.of_string "H")) - [] - [EvarAtName @m @m] - [SubGoalAtAll] - 0)). + ltac2:(refine_spec + (Option.get (Ident.of_string "H")) + [EvarAtName @m @m] + [SubGoalAtAll]). + Undo 1. (ltac2:(refine_hd (Option.get (Ident.of_string "H")) @@ -419,164 +344,28 @@ Proof. [EvarAtName @m @m] [SubGoalUntilNum 3] 0)). - - - + Undo 1. (ltac2:(refine_hd (Option.get (Ident.of_string "H")) [Evar @ev] [EvarAtName @p @p ;SubGoalAtName @iii] - [SubGoalAtNum 3] + [SubGoalAtNum 4] 0)). +*) - - - let ev1 := open_constr:(_) in - assert ev1; - [ (ltac2:(refine_hd (Option.get (Ident.of_string "H")) - [Quantif; Quantif; Evar @p] [] [] 0)) |]. - - - match goal with | |- False => idtac end; match type of X with forall (n:_) (m:_), n < m -> _ => idtac end . - Undo 1. - especialize H with n, p; - [ match goal with | |- False => idtac end; match type of H with forall (m:_), _ < m -> _ => idtac end ]. - Undo 1. - especialize H with p as h; - [ match goal with | |- False => idtac end; match type of h with forall (n:_) (m:_), n < m -> _ => idtac end ]. - Undo 1. - especialize H with n, p as h; - [ match goal with | |- False => idtac end; match type of h with forall (m:_), _ < m -> _ => idtac end ]. - Undo 1. - especialize H with p as ?; - [ match goal with | |- False => idtac end; match type of H_spec_ with forall (n:_) (m:_), n < m -> _ => idtac end ]. - Undo 1. - especialize H with n, p as ?; - [ match goal with | |- False => idtac end; match type of H_spec_ with forall (m:_), _ < m -> _ => idtac end ]. - Undo 1. - - -Goal forall (h:forall t z x y:nat, x = y -> x = x -> z = y -> x <= y), False. -Proof. - intros h. - let ev1 := open_constr:(_) in - assert ev1. - - (* epose _. *) - (* unshelve (ltac2:(epose (_) as hhh)). *) - (* unshelve (ltac2:(specialize_id_cstr @h constr:(hhh))). *) - - - - (ltac2:(refine_hd (Option.get (Ident.of_string "h")) - [Quantif;Quantif;Evar @myx; Quantif; SubGoal; SubGoal] [] [] 0)). - - - - - - - ltac2:(intro_typed (Option.get (Ident.of_string "toto")) constr:(nat)). - - - - let newn := if_is_dep_prod h ltac:(constr:(n)) ltac:(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) - end - | _ => fail 0 - 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 +Local Ltac2 cmp_numarg a b := + match a with + SubGoalAtNum na => + match b with + SubGoalAtNum nb => Int.compare na nb + | _ => -1 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" + | _ => -1 end. -(* initialize n to zero. *) -Ltac refine_spec h lnameargs lnumargs := refine_hd h constr:(@nil spec_arg) lnameargs lnumargs 0. - +Local Ltac2 sort_numargs (l: numarg list): numarg list:= List.sort cmp_numarg l. @@ -590,150 +379,148 @@ Ltac refine_spec h lnameargs lnumargs := refine_hd h constr:(@nil spec_arg) lnam 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 h lnames lnums) + | Std.clear [h]; Std.rename [(name, h)] ] + | false => + assert_evar name > [ (refine_spec 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 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. *) +(* +(* tests *) +Definition eq_one (i:nat) := i = 1. +Definition hidden_product := forall i j :nat, i+1=j -> i+1=j -> i+1=j. -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. *) +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). + Undo 1. + 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. +*) + +Local Ltac2 sgatnum_from_lint (li:int list): numarg list := + List.map (fun i => SubGoalAtNum i) li. + +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 := + let c1 := if atAll then [SubGoalAtAll] else sguntilnum_from_lid li in + espec_gen h (evatname_from_lid occsevar) c1 newH replaceb. + + +(* +(* 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. +*) + +Local 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 := +Local 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."))) +Local Ltac2 interp_ltac1_hyp (h:Ltac1.t) : constr := Option.get (Ltac1.to_constr h). - | _ => [] - end - *) (* call Ltac2'especialize on argscoming from Ltac1 notation *) -Ltac2 call_specialize_ltac2_gen (h:Ltac1.t) (li:Ltac1.t) levars newh (replaceb:bool) := +Local 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 @@ -749,10 +536,9 @@ Ltac2 call_specialize_ltac2_gen (h:Ltac1.t) (li:Ltac1.t) levars newh (replaceb:b (Option.get (Ltac1.to_ident newh)) replaceb. - (* call Ltac2'especialize on argscoming from Ltac1 notation *) -Ltac2 call_specialize_until_ltac2_gen (h:Ltac1.t) li levars newh replaceb (atAll:bool) := +Local 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 @@ -776,7 +562,6 @@ Ltac gen_hyp_name h := match goal with end. Ltac dummy_term := constr:(Prop). - (* ESPECIALIZE AT *) (* ********************* *) @@ -965,7 +750,42 @@ Tactic Notation "especialize" constr(h) "until" ne_integer_list_sep(li,",") := let levars := dummy_term in tac h li levars ident:(nme). +(* +(* 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 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: *) (* @@ -1005,7 +825,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. @@ -1036,3 +856,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/LibHypsDebug.v b/LibHyps/LibHypsDebug.v new file mode 100644 index 0000000..1b16a4a --- /dev/null +++ b/LibHyps/LibHypsDebug.v @@ -0,0 +1,45 @@ +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 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_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. + + +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 "". + 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/configure.sh b/configure.sh index beabc6c..6569323 100755 --- a/configure.sh +++ b/configure.sh @@ -1,5 +1,27 @@ #!/bin/bash +DEVOPT=no + +POSITIONAL=() +while [[ $# -gt 0 ]] +do +key="$1" + +case $key in + --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.) @@ -27,11 +49,18 @@ function gen_projet_file () { } -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 "ident_of_string\|especialize_ltac2\|LibEspecialize\|LibHypsDebug" ) +else + FILESLH=$(cd LibHyps && find . -name "*.v" | grep -v "ident_of_string\|especialize_ltac2\|LibEspecialize" ) +fi + PROJECTDIRLH="LibHyps" gen_projet_file "$FILESLH" "$PROJECTDIRLH" "resources/coq_project.libhyps" + FILESTEST=$(cd tests && find . -name "*.v" | grep -v "incremental" ) PROJECTDIRTESTS="tests" gen_projet_file "$FILESTEST" "$PROJECTDIRTESTS" "resources/coq_project.tests" diff --git a/testDebug.sh b/testDebug.sh new file mode 100755 index 0000000..b7cc63c --- /dev/null +++ b/testDebug.sh @@ -0,0 +1,22 @@ +#!/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 "Use ./configure.sh to remove rerferences to debug code." + echo "then make clean; make lib tests" + exit 1 +else + exit 0 +fi diff --git a/tests/Especialize_tests.v b/tests/Especialize_tests.v index 10eef6a..4a3fa03 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 *) From 2d71c73cc6f5c64c25c20fb74ee4f45ff0e9acf4 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Tue, 21 Oct 2025 19:59:45 +0200 Subject: [PATCH 03/15] WIP Ltac2 libHypsNaming. --- LibHyps/Especialize.v | 9 - LibHyps/LibHypsDebug.v | 13 +- LibHyps/LibHypsNaming.v | 572 ++++++++++++++++++++++++++++++++++++++-- LibHyps/TacNewHyps.v | 362 +++++++++---------------- 4 files changed, 692 insertions(+), 264 deletions(-) diff --git a/LibHyps/Especialize.v b/LibHyps/Especialize.v index eba8bef..8c15c92 100644 --- a/LibHyps/Especialize.v +++ b/LibHyps/Especialize.v @@ -11,15 +11,6 @@ Local Ltac2 is_dep_prod (t:constr): bool := | _ => false 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. - (* ESPECIALIZE INTERNAL DOC *) (* We show here by hand what the especialize tactic does. We start diff --git a/LibHyps/LibHypsDebug.v b/LibHyps/LibHypsDebug.v index 1b16a4a..c7b2a7c 100644 --- a/LibHyps/LibHypsDebug.v +++ b/LibHyps/LibHypsDebug.v @@ -24,17 +24,28 @@ 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) := + +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_goal() := let l := Control.hyps() in diff --git a/LibHyps/LibHypsNaming.v b/LibHyps/LibHypsNaming.v index 94f15b2..cd77426 100644 --- a/LibHyps/LibHypsNaming.v +++ b/LibHyps/LibHypsNaming.v @@ -4,9 +4,16 @@ From Stdlib Require Import Arith ZArith List. Require Import LibHyps.TacNewHyps. -Import ListNotations. -Local Open Scope list. - +(* 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))). + (** This file defines a tactic "autorename h" (and "autorename_strict h") that automatically rename hypothesis h followinh a systematic, but customizable heuristic. @@ -45,6 +52,539 @@ Ltac rename_hyp1 n th := Ltac rename_hyp ::= my_rename_hyp. >> *) +Ltac2 Type hypnames := string list. +Ltac2 add_suffix := true. + +(* Elements of l are supposed to already start with "_" *) +Ltac2 build_name_gen (sep:string) (suffx:bool) (l:string list) := + String.app (String.concat sep l) (if suffx then "_" else ""). + +Ltac2 build_name l := build_name_gen "_" add_suffix l. +Ltac2 build_name_no_suffix l := build_name_gen "_" false l. + +(* 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 *) + +Ltac2 Type numerical_names_style := bool. + +Ltac2 string_of_int (i:int) := Message.to_string (Message.of_int i). + +(** 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 *) +Ltac2 num_nosufx (i:int) := + msgs ". num_nosufx"; + printf ". i = %s" (string_of_int i); + let res := String.app "_" (string_of_int i) in + printf ". res = %s" res; + msgs ". num_nosufx: end"; + res. +Ltac2 num_sufx (i:int) (sfx:string) := String.app "_" (String.app (string_of_int i) sfx). + +(* TODO: find a way to make a string from nat, Z and N *) +Ltac2 numerical_names_nosufx (t:constr):string := + printf "...NUM: %t" t; + if is_closed t then + match! t with + | 0%Z => num_nosufx 0 + | 1%Z => num_nosufx 1 + | 2%Z => num_nosufx 2 + | 3%Z => num_nosufx 3 + | 4%Z => num_nosufx 4 + | 5%Z => num_nosufx 5 + | 6%Z => num_nosufx 6 + | 7%Z => num_nosufx 7 + | 8%Z => num_nosufx 8 + | 9%Z => num_nosufx 9 + | 10%Z => num_nosufx 10 + (* | Z0 => num_nosufx 0 *) + | O%nat => num_nosufx 0 + | 1%nat => num_nosufx 1 + | 2%nat => num_nosufx 2 + | 3%nat => num_nosufx 3 + | 4%nat => num_nosufx 4 + | 5%nat => num_nosufx 5 + | 6%nat => num_nosufx 6 + | 7%nat => num_nosufx 7 + | 8%nat => num_nosufx 8 + | 9%nat => num_nosufx 9 + | 10%nat => num_nosufx 10 + | O%N => num_nosufx 0 + | 1%N => num_nosufx 1 + | 2%N => num_nosufx 2 + | 3%N => num_nosufx 3 + | 4%N => num_nosufx 4 + | 5%N => num_nosufx 5 + | 6%N => num_nosufx 6 + | 7%N => num_nosufx 7 + | 8%N => num_nosufx 8 + | 9%N => num_nosufx 9 + | 10%N => num_nosufx 10 + | _ => backtrack "not recognized as a number " + end + else + backtrack "not a nameable number". + +Ltac2 numerical_names_sufx t := + match! t with + | 0%Z => num_sufx 0 "z" + | 1%Z => num_sufx 1 "z" + | 2%Z => num_sufx 2 "z" + | 3%Z => num_sufx 3 "z" + | 4%Z => num_sufx 4 "z" + | 5%Z => num_sufx 5 "z" + | 6%Z => num_sufx 6 "z" + | 7%Z => num_sufx 7 "z" + | 8%Z => num_sufx 8 "z" + | 9%Z => num_sufx 9 "z" + | 10%Z => num_sufx 10 "z" + (* | Z0 => num_sufx 0 *) + | O%nat => num_sufx 0 "n" + | 1%nat => num_sufx 1 "n" + | 2%nat => num_sufx 2 "n" + | 3%nat => num_sufx 3 "n" + | 4%nat => num_sufx 4 "n" + | 5%nat => num_sufx 5 "n" + | 6%nat => num_sufx 6 "n" + | 7%nat => num_sufx 7 "n" + | 8%nat => num_sufx 8 "n" + | 9%nat => num_sufx 9 "n" + | 10%nat => num_sufx 10 "n" + | O%N => num_sufx 0 "N" + | 1%N => num_sufx 1 "N" + | 2%N => num_sufx 2 "N" + | 3%N => num_sufx 3 "N" + | 4%N => num_sufx 4 "N" + | 5%N => num_sufx 5 "N" + | 6%N => num_sufx 6 "N" + | 7%N => num_sufx 7 "N" + | 8%N => num_sufx 8 "N" + | 9%N => num_sufx 9 "N" + | 10%N => num_sufx 10 "N" + end. + +(* Redefine at will *) +Ltac2 numerical_names: constr -> string:= numerical_names_nosufx. + +(** 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 rename_depth := 3. + +(** Default prefix for hypothesis names. *) +Ltac2 default_prefix():string := "h". + +(** A few special default chunks, for special cases in the naming heuristic. *) +Ltac2 impl_prefix() := "_impl". +Ltac2 forall_prefix() := "_all". +Ltac2 exists_prefix() := "_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. *) +Ltac2 rename_hyp stop th := backtrack "rename_hyp". +Ltac2 rename_hyp_default n th := backtrack "rename_hyp_default". + +(* TODO: 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 1 + | _ => let _ := constr:(fun b => ($z b, $z b)) in 2 + end + end + | _ => 0 + end. + + + +Ltac2 percent():char := (Char.of_int 37). +Ltac2 arobase():char := (Char.of_int 64). +Ltac2 space():char := (Char.of_int 32). +Ltac2 parg():char := (Char.of_int 40). +Ltac2 pard():char := (Char.of_int 41). + +(* Ltac2 Eval (Char.to_int (String.get ")" 0)). *) + +Ltac2 set_forbidden_chars (): char list := [space();pard();parg()]. +Ltac2 set_removable_chars (): char list := [percent();arobase()]. +Ltac2 set_suspect_chars (): char list := List.append (set_forbidden_chars()) (set_removable_chars()). +Ltac2 set_forbidden_charints (): int list := List.map Char.to_int (set_forbidden_chars()). +Ltac2 set_removable_charints (): int list := List.map Char.to_int (set_removable_chars()). +Ltac2 set_suspect_charints (): int list := List.map Char.to_int (set_suspect_chars()). + +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. + +Ltac2 string_count_if (p:char -> bool) (s:string) : int := + let lgth := String.length s in + let rec count acc i := + if Int.ge i lgth then acc + else if p (String.get s i) then count (Int.add 1 acc) (Int.add 1 i) + else count acc (Int.add 1 i) + in + count 0 0. + +Ltac2 string_remove (p:char -> bool) (s:string) : string := + let lgth := String.length s in + let nbgood := string_count_if (fun c => Bool.neg (p c)) s in + let res := String.make nbgood (arobase()) in + let rec fill k i: unit := + if Int.ge i lgth then () + else + let c := String.get s i in + if p c then fill k (Int.add 1 i) + else (String.set res k c; fill (Int.add 1 k) (Int.add 1 i)) in + fill 0 0; + res. + +Ltac2 forbidden_charint (c:char):bool := (List.mem Int.equal (Char.to_int c) (set_forbidden_charints())). +Ltac2 removeable_charint (c:char):bool := (List.mem Int.equal (Char.to_int c) (set_removable_charints())). +Ltac2 suspect_charint (c:char):bool := (List.mem Int.equal (Char.to_int c) (set_suspect_charints())). + +Ltac2 Eval (string_remove (fun c => (Char.equal c (arobase()))) "az@er% % @o"). +Ltac2 Eval (string_remove forbidden_charint "az@er% % @o"). +Ltac2 Eval (string_remove suspect_charint "az@er% % @o"). + +Ltac2 id_of_constr (t:constr) : string option := + let s:string := Message.to_string (fprintf "%t" t) in + if string_forall (fun c => Bool.neg (forbidden_charint c)) s + then + let s := string_remove removeable_charint s in + if string_forall (fun c => Bool.neg (Char.equal (space()) c)) s then Some s else None + else None. + + + +(* Ltac2 print_id (t:constr) : string option := *) +(* let (idopt,_) := Fresh.next (Fresh.Free.empty) t in *) +(* Some (Ident.to_string idopt). *) + +(** Build a chunk from a simple term: either a number or a freshable + term. *) +Ltac2 box_name t : ident := + 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 => s + | None => + match Unsafe.kind t with + | Unsafe.Constant cstt _ => + let id:ident := List.last (Env.path (Std.ConstRef cstt)) in + id + | Unsafe.Var id => 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 + Option.get (Ident.of_string s) + | _ => + if is_closed t then + printf ". BEFORE NUM %t" t; + let s := numerical_names t in + printf ". AFTER NUM %t -> %s" t s; + Option.get (Ident.of_string s) + else backtrack "cannot be a number" + end + end. + +Local Ltac2 is_dep_prod (t:constr): bool := + match kind t with + | Prod _ subt => Bool.neg (is_closed subt) + | _ => false + end. + + +(** 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. *) +Ltac2 rec rename_app (nonimpl:int) (stop:int) (acc:string list) th: string list := + match id_of_constr th with + | Some s => s::acc + | None => + printf "## rename_app (nonimpl=%i) (stop=%i) %t " nonimpl stop th; + match Unsafe.kind th with + | App f args => + let newstop:int := Int.sub stop 1 in + printf "...Arrays.sub args %i %i: " (Int.sub (Array.length args) nonimpl) nonimpl; + Array.iter (fun e => printf "....%t" e) args; + let nonimplicitsargs := Array.sub args (Int.sub (Array.length args) nonimpl) nonimpl in + let nme_array := + Array.map (fun arg => (*Control.plus*) ((*fun () => *) fallback_rename_hyp newstop arg) (* (fun _ => [])*)) + nonimplicitsargs in + let l: string list := List.flatten (Array.to_list nme_array) in + let f' := Control.plus (fun() => Ident.to_string(box_name f)) (fun _ => "?1") in + f' :: (List.append l acc) + | _ => (let f':string := Control.plus (fun() => Ident.to_string(box_name th)) (fun _ => "?2") in + printf ". NO APP %s" f'; f' :: acc) +end +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:constr) : string list := + printf "## fallback_rename_hyp_quantif (stop=%i) %t " stop th; + let newstop := Int.sub stop 1 in + match Unsafe.kind th with + | Prod bnd subth => + if is_dep_prod th + then + let sufx:ident := Option.default (Option.get (Ident.of_string "_h")) (Constr.Binder.name bnd) in + let remain := fallback_rename_hyp newstop subth in + forall_prefix() :: Ident.to_string sufx :: remain + else + let sufx := fallback_rename_hyp 1 (Constr.Binder.type bnd) in + let remain := fallback_rename_hyp newstop subth in + impl_prefix() :: (List.append sufx remain) + | _ => backtrack "no product" + end + +with fallback_rename_hyp_specials stop th :string list := + printf "## fallback_rename_hyp_specials (stop=%i) %t " stop th; + let newstop := Int.sub stop 1 in + Control.plus + (* First see if user has something that applies *) + (fun() => rename_hyp newstop th) + (* if it fails try default specials *) + (fun _ => rename_hyp_default newstop th) + +with fallback_rename_hyp stop th:string list := + printf "## fallback_rename_hyp (stop=%i) %t " stop th; + if Int.le stop 0 then [] + else + Control.plus (fun () => fallback_rename_hyp_specials stop th) + (fun _ => match Unsafe.kind th with + | Prod _ _ => fallback_rename_hyp_quantif stop th + | _ => + printf "...before count_impl: %t" th; + let numnonimpl := count_impl th in + printf "..after count_impl: %i" numnonimpl; + printf "## FALLBACK 1 rename_app %i %i %t " numnonimpl stop th; + let res := rename_app numnonimpl stop [] th in + msgs "..FALLBACK 2"; + res + end). + + + Unset Printing Notations. + +(* Ltac2 Eval (count_impl constr:(3 + 4)). *) + +Parameters X Y: nat -> Prop. +Parameters PX: X 3. +Parameters PY: Y 3. + +Goal forall [A : Type] (P Q : A -> Prop) (x : A), P x -> Q x -> (exists2 x : A, P x & Q x) -> False. + + intros A P Q x H H0 H1. + ltac2:(let l := fallback_rename_hyp 9 constr:(exists2 x0 : A, P x0 & Q x0) in + printf "BEFORE BUILDNAME %a " (pr_list pr_string) l; + let nme := build_name l in + printf "%s" nme). +Abort. + +Goal forall n m p : nat, n m<= p -> True. +Proof. + intros n m p H H0. + + Unset Printing Notations. + + ltac2:(let l := fallback_rename_hyp 9 constr:(Nat.clearbit n m = p) in + printf "BEFORE BUILDNAME %a " (pr_list pr_string) l; + let nme := build_name l in + printf "%s" nme). + + ltac2:(let l := fallback_rename_hyp 3 constr:(Nat.clearbit 3 4%nat = 0) in + printf "BEFORE BUILDNAME"; + let nme := build_name l in + printf "%s" nme). + + ltac2:(let l := fallback_rename_hyp 4 constr:(Nat.clearbit 3 4%nat = 0 -> Nat.clearbit 3 4%nat = 7) in + printf "BEFORE BUILDNAME"; + let nme := build_name l in + printf "%s" nme). + + ltac2:(let l := fallback_rename_hyp 4 constr:(forall x:nat, Nat.clearbit x 4%nat = 0) in + printf "BEFORE BUILDNAME"; + let nme := build_name l in + printf "%s" nme). + + ltac2:(let l := fallback_rename_hyp 4 constr:(forall x:Z, BinIntDef.Z.quot x x = 1%Z) in + printf "BEFORE BUILDNAME"; + let nme := build_name l in + printf "%s" nme). + + + ltac2:(let l := fallback_rename_hyp 4 constr:(Nat.clearbit 3%nat 4%nat) in + let nme := build_name l in + printf "%s" nme). + + ltac2:(let l := fallback_rename_hyp 4 constr:(Nat.clearbit 3%nat 4%nat) in + printf "%a" (pr_list (fun () s => fprintf "%s" s)) l). + + ltac2:(let nme := rename_app 1 2 [] constr:(Nat.clearbit 3%nat 4%nat) in + printf "%s" (List.hd nme)). + . + + + +(** 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. +(** This will later contain a few default fallback naming strategy. *) +Ltac rename_hyp_default 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. + + +Ltac build_name l := build_name_gen add_suffix l. +Ltac build_name_no_suffix l := build_name_gen constr:(false) l. + + (** * Implementation principle: @@ -531,7 +1071,7 @@ 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 $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 @@ -543,38 +1083,38 @@ Ltac fallback_rename_hyp_name th := Inductive LHMsg t (h:t) := LHMsgC: LHMsg t h. Notation "h : t" := (LHMsgC t h) (at level 1,only printing, format -"'[ ' h ':' '/' '[' t ']' ']'"). +"'[ ' $h ':' '/' '[' t ']' ']'"). -Ltac rename_hyp_with_name h th := fail. +Ltac 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). *) -Ltac autorename_strict H := - match type of H with +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 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 *) + 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 *) + 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 *) + fail 1 "no renaming pattern for " c (* "no renaming pattern for " $h *) + | _ => idtac (* not in Prop or "no renaming pattern for " $h *) end end. (* Tactic renaming hypothesis H. *) -Ltac autorename H := try autorename_strict H. +Ltac autorename $h := try autorename_strict H. (* (* Tests *) @@ -586,9 +1126,9 @@ Ltac rename_hyp1 n th := | ((?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 ::= +Ltac rename_hyp_with_name $h th ::= match reverse goal with - | H: ?A = h |- _ => + | H: ?A = $h |- _ => name ( A## ++ `_same`) (* let _ := freshable A in *) (* name (`same_as` ++ A#1) *) diff --git a/LibHyps/TacNewHyps.v b/LibHyps/TacNewHyps.v index 7322d61..416d204 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 }. *) From 177157ab5d9ce051f82b614cc3a7adc86b36f3b9 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Fri, 24 Oct 2025 19:50:44 +0200 Subject: [PATCH 04/15] First version of Ltac2 autorename. --- LibHyps/LibHypsNaming.v | 650 ++++++++++++++++++++++++++++++---------- 1 file changed, 485 insertions(+), 165 deletions(-) diff --git a/LibHyps/LibHypsNaming.v b/LibHyps/LibHypsNaming.v index cd77426..543bd73 100644 --- a/LibHyps/LibHypsNaming.v +++ b/LibHyps/LibHypsNaming.v @@ -3,7 +3,8 @@ "expat license". You should have recieved a LICENSE file with it. *) From Stdlib Require Import Arith ZArith List. -Require Import LibHyps.TacNewHyps. +Require LibHyps.TacNewHyps. +Import TacNewHyps.Notations. (* Import ListNotations. *) (* Local Open Scope list. *) Require Import Ltac2.Ltac2. @@ -13,7 +14,7 @@ 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 _ => ()). (** This file defines a tactic "autorename h" (and "autorename_strict h") that automatically rename hypothesis h followinh a systematic, but customizable heuristic. @@ -52,15 +53,18 @@ Ltac rename_hyp1 n th := Ltac rename_hyp ::= my_rename_hyp. >> *) +Ltac2 Type rename_directive := [ String(string) | RecRename(int,constr) ]. +Ltac2 Type rename_directives := rename_directive list. + Ltac2 Type hypnames := string list. -Ltac2 add_suffix := true. +Ltac2 mutable add_suffix := true. (* Elements of l are supposed to already start with "_" *) Ltac2 build_name_gen (sep:string) (suffx:bool) (l:string list) := String.app (String.concat sep l) (if suffx then "_" else ""). -Ltac2 build_name l := build_name_gen "_" add_suffix l. -Ltac2 build_name_no_suffix l := build_name_gen "_" false l. +Ltac2 build_name l := build_name_gen "_" add_suffix (List.rev l). +Ltac2 build_name_no_suffix l := build_name_gen "_" false (List.rev l). (* This sets the way numerical constants are displayed, default value is set below to numerical_names_nosufx, which will give the same @@ -71,6 +75,7 @@ Ltac2 build_name_no_suffix l := build_name_gen "_" false l. Ltac numerical_names ::= numerical_names_sufx *) Ltac2 Type numerical_names_style := bool. +Ltac2 mutable numerical_names := false. Ltac2 string_of_int (i:int) := Message.to_string (Message.of_int i). @@ -88,47 +93,47 @@ Ltac2 num_nosufx (i:int) := printf ". res = %s" res; msgs ". num_nosufx: end"; res. -Ltac2 num_sufx (i:int) (sfx:string) := String.app "_" (String.app (string_of_int i) sfx). +(* Ltac2 num_sufx (i:int) (sfx:string) := (String.app (string_of_int i) sfx). *) + (* TODO: find a way to make a string from nat, Z and N *) Ltac2 numerical_names_nosufx (t:constr):string := printf "...NUM: %t" t; if is_closed t then match! t with - | 0%Z => num_nosufx 0 - | 1%Z => num_nosufx 1 - | 2%Z => num_nosufx 2 - | 3%Z => num_nosufx 3 - | 4%Z => num_nosufx 4 - | 5%Z => num_nosufx 5 - | 6%Z => num_nosufx 6 - | 7%Z => num_nosufx 7 - | 8%Z => num_nosufx 8 - | 9%Z => num_nosufx 9 - | 10%Z => num_nosufx 10 - (* | Z0 => num_nosufx 0 *) - | O%nat => num_nosufx 0 - | 1%nat => num_nosufx 1 - | 2%nat => num_nosufx 2 - | 3%nat => num_nosufx 3 - | 4%nat => num_nosufx 4 - | 5%nat => num_nosufx 5 - | 6%nat => num_nosufx 6 - | 7%nat => num_nosufx 7 - | 8%nat => num_nosufx 8 - | 9%nat => num_nosufx 9 - | 10%nat => num_nosufx 10 - | O%N => num_nosufx 0 - | 1%N => num_nosufx 1 - | 2%N => num_nosufx 2 - | 3%N => num_nosufx 3 - | 4%N => num_nosufx 4 - | 5%N => num_nosufx 5 - | 6%N => num_nosufx 6 - | 7%N => num_nosufx 7 - | 8%N => num_nosufx 8 - | 9%N => num_nosufx 9 - | 10%N => num_nosufx 10 + | 0%Z => "0" + | 1%Z => "1" + | 2%Z => "2" + | 3%Z => "3" + | 4%Z => "4" + | 5%Z => "5" + | 6%Z => "6" + | 7%Z => "7" + | 8%Z => "8" + | 9%Z => "9" + | 10%Z => "10" + | O%nat => "0" + | 1%nat => "1" + | 2%nat => "2" + | 3%nat => "3" + | 4%nat => "4" + | 5%nat => "5" + | 6%nat => "6" + | 7%nat => "7" + | 8%nat => "8" + | 9%nat => "9" + | 10%nat => "10" + | O%N => "0" + | 1%N => "1" + | 2%N => "2" + | 3%N => "3" + | 4%N => "4" + | 5%N => "5" + | 6%N => "6" + | 7%N => "7" + | 8%N => "8" + | 9%N => "9" + | 10%N => "10" | _ => backtrack "not recognized as a number " end else @@ -136,66 +141,68 @@ Ltac2 numerical_names_nosufx (t:constr):string := Ltac2 numerical_names_sufx t := match! t with - | 0%Z => num_sufx 0 "z" - | 1%Z => num_sufx 1 "z" - | 2%Z => num_sufx 2 "z" - | 3%Z => num_sufx 3 "z" - | 4%Z => num_sufx 4 "z" - | 5%Z => num_sufx 5 "z" - | 6%Z => num_sufx 6 "z" - | 7%Z => num_sufx 7 "z" - | 8%Z => num_sufx 8 "z" - | 9%Z => num_sufx 9 "z" - | 10%Z => num_sufx 10 "z" + | 0%Z => "0z" + | 1%Z => "1z" + | 2%Z => "2z" + | 3%Z => "3z" + | 4%Z => "4z" + | 5%Z => "5z" + | 6%Z => "6z" + | 7%Z => "7z" + | 8%Z => "8z" + | 9%Z => "9z" + | 10%Z => "10z" (* | Z0 => num_sufx 0 *) - | O%nat => num_sufx 0 "n" - | 1%nat => num_sufx 1 "n" - | 2%nat => num_sufx 2 "n" - | 3%nat => num_sufx 3 "n" - | 4%nat => num_sufx 4 "n" - | 5%nat => num_sufx 5 "n" - | 6%nat => num_sufx 6 "n" - | 7%nat => num_sufx 7 "n" - | 8%nat => num_sufx 8 "n" - | 9%nat => num_sufx 9 "n" - | 10%nat => num_sufx 10 "n" - | O%N => num_sufx 0 "N" - | 1%N => num_sufx 1 "N" - | 2%N => num_sufx 2 "N" - | 3%N => num_sufx 3 "N" - | 4%N => num_sufx 4 "N" - | 5%N => num_sufx 5 "N" - | 6%N => num_sufx 6 "N" - | 7%N => num_sufx 7 "N" - | 8%N => num_sufx 8 "N" - | 9%N => num_sufx 9 "N" - | 10%N => num_sufx 10 "N" + | O%nat => "0n" + | 1%nat => "1n" + | 2%nat => "2n" + | 3%nat => "3n" + | 4%nat => "4n" + | 5%nat => "5n" + | 6%nat => "6n" + | 7%nat => "7n" + | 8%nat => "8n" + | 9%nat => "9n" + | 10%nat => "10n" + | O%N => "0N" + | 1%N => "1N" + | 2%N => "2N" + | 3%N => "3N" + | 4%N => "4N" + | 5%N => "5N" + | 6%N => "6N" + | 7%N => "7N" + | 8%N => "8N" + | 9%N => "9N" + | 10%N => "10N" end. (* Redefine at will *) -Ltac2 numerical_names: constr -> string:= numerical_names_nosufx. +Ltac2 add_numerical_names (): constr -> string:= + if numerical_names then numerical_names_sufx else numerical_names_nosufx. + (** 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 rename_depth := 3. +Ltac2 mutable rename_depth := 3. (** Default prefix for hypothesis names. *) Ltac2 default_prefix():string := "h". (** A few special default chunks, for special cases in the naming heuristic. *) -Ltac2 impl_prefix() := "_impl". -Ltac2 forall_prefix() := "_all". -Ltac2 exists_prefix() := "_ex". +Ltac2 impl_prefix() := "impl". +Ltac2 forall_prefix() := "all". +Ltac2 exists_prefix() := "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. *) -Ltac2 rename_hyp stop th := backtrack "rename_hyp". -Ltac2 rename_hyp_default n th := backtrack "rename_hyp_default". +Ltac2 mutable rename_hyp (stop:int) (th:constr): rename_directives := backtrack "rename_hyp". +Ltac2 mutable rename_hyp_default (n:int) (th:constr): rename_directives := backtrack "rename_hyp_default". (* TODO: find something better to detect implicits!! *) (* Determines the number of non "head" implicit arguments, i.e. implicit @@ -304,8 +311,8 @@ Ltac2 count_impl th := end | (?z _) => match! th with - | _ => let _ := constr:(fun b => ($z b, $z _)) in 1 - | _ => let _ := constr:(fun b => ($z b, $z b)) in 2 + | _ => let _ := constr:(fun b => ($z b, $z _)) in 0 + | _ => let _ := constr:(fun b => ($z b, $z b)) in 1 end end | _ => 0 @@ -365,13 +372,6 @@ Ltac2 Eval (string_remove (fun c => (Char.equal c (arobase()))) "az@er% % @o"). Ltac2 Eval (string_remove forbidden_charint "az@er% % @o"). Ltac2 Eval (string_remove suspect_charint "az@er% % @o"). -Ltac2 id_of_constr (t:constr) : string option := - let s:string := Message.to_string (fprintf "%t" t) in - if string_forall (fun c => Bool.neg (forbidden_charint c)) s - then - let s := string_remove removeable_charint s in - if string_forall (fun c => Bool.neg (Char.equal (space()) c)) s then Some s else None - else None. @@ -381,36 +381,45 @@ Ltac2 id_of_constr (t:constr) : string option := (** Build a chunk from a simple term: either a number or a freshable term. *) -Ltac2 box_name t : ident := +Ltac2 box_name t : string := 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 => s - | None => + | Some _ => s + | None => match Unsafe.kind t with | Unsafe.Constant cstt _ => let id:ident := List.last (Env.path (Std.ConstRef cstt)) in - id - | Unsafe.Var id => id + 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 - Option.get (Ident.of_string s) + s | _ => if is_closed t then printf ". BEFORE NUM %t" t; - let s := numerical_names t in + let s := add_numerical_names () t in printf ". AFTER NUM %t -> %s" t s; - Option.get (Ident.of_string s) + s else backtrack "cannot be a number" end end. +(* Ltac2 id_of_constr (t:constr) : string option := *) +(* let s:string := Message.to_string (fprintf "%t" t) in *) +(* if string_forall (fun c => Bool.neg (forbidden_charint c)) s *) +(* then *) +(* let s := string_remove removeable_charint s in *) +(* if string_forall (fun c => Bool.neg (Char.equal (space()) c)) s then Some s else None *) +(* else None. *) + + Local Ltac2 is_dep_prod (t:constr): bool := match kind t with | Prod _ subt => Bool.neg (is_closed subt) @@ -418,79 +427,349 @@ Local Ltac2 is_dep_prod (t:constr): bool := 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 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. *) -Ltac2 rec rename_app (nonimpl:int) (stop:int) (acc:string list) th: string list := - match id_of_constr th with - | Some s => s::acc - | None => - printf "## rename_app (nonimpl=%i) (stop=%i) %t " nonimpl stop th; - match Unsafe.kind th with - | App f args => - let newstop:int := Int.sub stop 1 in - printf "...Arrays.sub args %i %i: " (Int.sub (Array.length args) nonimpl) nonimpl; - Array.iter (fun e => printf "....%t" e) args; - let nonimplicitsargs := Array.sub args (Int.sub (Array.length args) nonimpl) nonimpl in - let nme_array := - Array.map (fun arg => (*Control.plus*) ((*fun () => *) fallback_rename_hyp newstop arg) (* (fun _ => [])*)) - nonimplicitsargs in - let l: string list := List.flatten (Array.to_list nme_array) in - let f' := Control.plus (fun() => Ident.to_string(box_name f)) (fun _ => "?1") in - f' :: (List.append l acc) - | _ => (let f':string := Control.plus (fun() => Ident.to_string(box_name th)) (fun _ => "?2") in - printf ". NO APP %s" f'; f' :: acc) -end -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:constr) : string list := - printf "## fallback_rename_hyp_quantif (stop=%i) %t " stop th; +Ltac2 rec rename_app (nonimpl:int) (stop:int) (acc:string list ref) th: unit := + Control.plus (fun () => let s := box_name th in + Ref.set acc (s:: Ref.get acc)) + (fun _ => + printf "## rename_app (nonimpl=%i) (stop=%i) %t " nonimpl stop th; + 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 _ := msgs "ICI DEP 20" in + 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 newstop acc subth' in + (in_context nme typ tac_under_binder); + () + else + let _ := msgs "ICI DEP 20" in + rename_hyp_chained_quantifs stop acc subth + | _ => fallback_rename_hyp stop acc th + end + +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 => + msgs "ICI 12"; if is_dep_prod th then - let sufx:ident := Option.default (Option.get (Ident.of_string "_h")) (Constr.Binder.name bnd) in - let remain := fallback_rename_hyp newstop subth in - forall_prefix() :: Ident.to_string sufx :: remain + let _ := msgs "ICI 13" in + 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 + (in_context nme typ tac_under_binder); + () + else - let sufx := fallback_rename_hyp 1 (Constr.Binder.type bnd) in - let remain := fallback_rename_hyp newstop subth in - impl_prefix() :: (List.append sufx remain) + (Ref.set acc (impl_prefix() :: Ref.get acc); + (* fallback_rename_hyp 1 acc (Constr.Binder.type bnd); *) + rename_hyp_chained_quantifs newstop acc subth) | _ => backtrack "no product" end -with fallback_rename_hyp_specials stop th :string list := + +with fallback_rename_hyp_specials stop (acc:string list ref) th :unit := printf "## fallback_rename_hyp_specials (stop=%i) %t " stop th; let newstop := Int.sub stop 1 in Control.plus (* First see if user has something that applies *) - (fun() => rename_hyp newstop th) + (fun() => let dirs := rename_hyp newstop th in + interp_directives acc (List.rev dirs) ) (* if it fails try default specials *) - (fun _ => rename_hyp_default newstop th) + (fun _ => let dirs := rename_hyp_default newstop th in + interp_directives acc (List.rev dirs)) -with fallback_rename_hyp stop th:string list := - printf "## fallback_rename_hyp (stop=%i) %t " stop th; - if Int.le stop 0 then [] +with fallback_rename_hyp stop (acc:string list ref) th:unit := + printf "## fallback_rename_hyp (stop=%i) %t (acc = %a) " stop th (pr_list pr_string) (Ref.get acc); + if Int.le stop 0 then () else - Control.plus (fun () => fallback_rename_hyp_specials stop th) + Control.plus (fun () => fallback_rename_hyp_specials stop acc th) (fun _ => match Unsafe.kind th with - | Prod _ _ => fallback_rename_hyp_quantif stop th - | _ => - printf "...before count_impl: %t" th; - let numnonimpl := count_impl th in - printf "..after count_impl: %i" numnonimpl; - printf "## FALLBACK 1 rename_app %i %i %t " numnonimpl stop th; - let res := rename_app numnonimpl stop [] th in - msgs "..FALLBACK 2"; - res - end). + | Prod _ _ => 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 acc ld:unit := + List.fold_right (fun d _ => interp_directive acc d) ld () + +with interp_directive acc d := + match d with + | String s => Ref.set acc (s :: (Ref.get acc)) + | RecRename n t => fallback_rename_hyp n acc t + end. +Ltac2 rename_acc n th := + let acc := Ref.ref [] in + (* Here we intentionally create a separate goal to discard all side + effect (renames) ont he current goal. The constr actually returned by in_context does not matter. *) + let _ := in_context (Option.get (Ident.of_string "DUMMY_SUBGOAL")) constr:(Prop) (fun () => fallback_rename_hyp n acc th) in + Ref.get acc. - Unset Printing Notations. +Ltac2 fallback_rename_hyp_name th: ident := + let depth := rename_depth in + msgs "ICI 1"; + let l := rename_acc depth th in + msgs "ICI10"; + match l with + [] => backtrack "No name built" + | _ => (printf "FINAL acc = %a" (pr_list pr_string) l; + let nme := String.app "h_" (build_name l) in + let id := Option.get (Ident.of_string nme) in + Fresh.in_goal id) + end. + +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). *) +Ltac2 autorename_strict (h:ident) := + let th := Constr.type (Control.hyp h) in + printf "th = %t" th ; + let tth := Constr.type th in + printf "th = %t" tth ; + match! tth 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.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) + (* | _ => () (* not in Prop or "no renaming pattern for " $h *) *) + end. + +(* Tactic renaming hypothesis H. *) + +Ltac2 ltac2_autorename (h:ident) := + control_try (fun () => autorename_strict h). + +Ltac2 ltac1_autorename (h:Ltac1.t) := + let h: ident := Option.get (Ltac1.to_ident h) in + ltac2_autorename h. + + +Tactic Notation "autorename" hyp(h) := + let tac := ltac2:(h |- ltac1_autorename h) in + tac h. + +Ltac2 decr (n:int):int := + if Int.equal n 0 then 0 else Int.sub n 1. + +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)). + + + +(* Ltac2 Notation x(constr) "#" y(tactic(1)) := (RecRename x y). *) + + +Ltac2 Set rename_hyp_default := + fun n th: rename_directives => + if Int.lt n 0 then [] + else + match! th with + | ?x <> ?y => [String "neq"; RecRename (decr n) x; RecRename (decr n) y] + | @cons _ ?x (cons ?y ?l) => [String "cons"; RecRename n x; RecRename n y; RecRename (decr (decr n)) l] + | @cons _ ?x ?l => if Int.ge n 1 then [String "cons"; RecRename n x; RecRename (decr n) l] else [String "cons"] + | (@Some _ ?x) => [RecRename (Int.add 1 n) x] + | (@None _) => [String "None"] + end. + +Definition DUMMY: Prop -> Prop. + exact (fun x:Prop => x). +Qed. + +Ltac2 recRename n x := + RecRename (Option.get (Ltac1.to_int n)) (Option.get (Ltac1.to_constr x)). + + +(* ********** CUSTOMIZATION ********** *) + +(** 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. *) + + + +(* TESTS *) + +(* This settings should reproduce the naming scheme of libhypps-1.0.0 + and libhypps-1.0.1. *) +Ltac2 Set add_suffix := false. +Ltac2 Set numerical_names := true. + +(* From there this is LibHypTest from 1f7a1ed2289e439c291fcbd06c51705547feef1e *) +Ltac2 rename_hyp_2 n 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" ; RecRename n x ; RecRename n y] + | true = Nat.eqb ?x ?y => [String "Neqb" ; RecRename n x ; RecRename n y] + | _ => rename_hyp_2 n th (* call the previously defined tactic *) + end. + +Ltac2 Set rename_hyp := rename_hyp_3. + +Ltac2 Set rename_depth := 3. + +Close Scope Z_scope. +Open Scope nat_scope. +Lemma dummy: forall x y, + 0 <= 1 -> + (0%Z <= 1%Z)%Z -> + x <= y -> + x = y -> + Some x = Some y -> + 0 = 1 -> + (0 = 1)%Z -> + ~x = y -> + true = Nat.eqb 3 4 -> + Nat.eqb 3 4 = true -> + true = Nat.leb 3 4 -> + 1 = 0 -> + ~x = y -> + ~1 < 0 -> + (forall w w':nat , w = w' -> ~true=false) -> + (forall w w':nat , w = w' -> true=false /\ True) -> + (forall w w':nat , w = w' -> False /\ True) -> + (exists w:nat , w = w -> ~(true=(andb false true)) /\ False) -> + (exists w:nat , w = w -> True /\ False) -> + (forall w w':nat , w = w' -> true=false) -> + (forall w w':nat , w = w' -> Nat.eqb 3 4=Nat.eqb 4 3) -> + List.length (cons 3 nil) = (fun x => 0)1 -> + List.length (cons 3 nil) = 0 -> + plus 0 y = y -> + (true=false) -> + (False -> (true=false)) -> + forall (x : nat) (env : list nat), + ~ List.In x nil -> + cons x (cons 3 env) = cons 2 env -> + forall z t:nat, IDProp -> + (0 < 1 -> 0 < 0 -> true = false -> ~(true=false)) -> + (~(true=false)) -> + (forall w w',w < w' -> ~(true=false)) -> + (0 < 1 -> ~(1<0)) -> + (0 < 1 -> 1<0) -> 0 < z -> True. + + intros;{(fun h => autorename h)}. + + match type of x with nat => idtac | _ => fail "test failed!" end. + match type of y with nat => idtac | _ => fail "test failed!" end. + match type of h_le_0n_1n with 0 <= 1 => idtac | _ => fail "test failed!" end. + match type of h_le_0z_1z with (0 <= 1)%Z => idtac | _ => fail "test failed!" end. + match type of h_le_x_y with x <= y => idtac | _ => fail "test failed!" end. + match type of h_eq_x_y with x = y => idtac | _ => fail "test failed!" end. + match type of h_eq_0n_1n with 0 = 1 => idtac | _ => fail "test failed!" end. + match type of h_eq_0z_1z with 0%Z = 1%Z => idtac | _ => fail "test failed!" end. + 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_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_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. *) + match type of h_eq_cons_x0_3n_cons_2n with x0 :: 3 :: env = 2 :: env => idtac | _ => fail "test failed!" end. + + (* match type of h_all_and_False_True with forall w w' : nat, w = w' -> False /\ True => idtac | _ => fail "test failed!" end. *) + (* match type of h_ex_and_neq_False with exists w : nat, w = w -> true <> (false && true)%bool /\ False => idtac | _ => fail "test failed!" end. *) + (* 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_1n with length (3::nil) = (fun _ : nat => 0) 1 => idtac | _ => fail "test failed!" end. + match type of h_eq_length_cons_0n with length (3::nil) = 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. + match type of h_impl_tEQf with False -> true = false => idtac | _ => fail "test failed!" end. + match type of x0 with nat => idtac | _ => fail "test failed!" end. + match type of env with list nat => idtac | _ => fail "test failed!" end. + match type of h_not_In_x0_nil with ~ In x0 [] => idtac | _ => fail "test failed!" end. + match type of h_eq_cons_x0_3n_cons_2n with x0 :: 3 :: env = 2 :: env => idtac | _ => fail "test failed!" end. + match type of h_IDProp with IDProp => idtac | _ => fail "test failed!" end. + match type of h_impl_tNEQf with 0 < 1 -> 0 < 0 -> true = false -> true <> false => idtac | _ => fail "test failed!" end. + match type of h_tNEQf with true <> false => idtac | _ => fail "test failed!" end. + match type of h_all_tNEQf0 with forall w w' : nat, w < w' -> true <> false => idtac | _ => fail "test failed!" end. + 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. + exact I. +Qed. + + +(* +(* Ltac autorename h := *) + (* let tac := ltac2:(h |- ltac2_autorename h) in *) + (* tac h. *) + + (* Unset Printing Notations. *) (* Ltac2 Eval (count_impl constr:(3 + 4)). *) @@ -498,58 +777,99 @@ Parameters X Y: nat -> Prop. Parameters PX: X 3. Parameters PY: Y 3. -Goal forall [A : Type] (P Q : A -> Prop) (x : A), P x -> Q x -> (exists2 x : A, P x & Q x) -> False. - intros A P Q x H H0 H1. - ltac2:(let l := fallback_rename_hyp 9 constr:(exists2 x0 : A, P x0 & Q x0) in +Goal forall [A : Type] (P Q : A -> Prop) (x : A), P x -> Q x -> (exists2 x : A, P x & Q x) -> ex2 P Q -> False. + + intros A P Q x H H0 H1 H2. + + autorename H1. + autorename H2. + autorename H. + autorename H0. + assert (HH: (fun x => x = x) 1). + 2:{ autorename HH. + + + ltac2:(let l := rename_acc 3 constr:(exists2 x0 : A, P x0 & Q x0) in + printf "BEFORE BUILDNAME %a " (pr_list pr_string) l; + let nme := build_name l in + printf "%s" nme). + + ltac2:(let l := rename_acc 9 constr:(ex2 P Q) in printf "BEFORE BUILDNAME %a " (pr_list pr_string) l; let nme := build_name l in printf "%s" nme). Abort. -Goal forall n m p : nat, n m<= p -> True. +Definition foo := (fun a b:bool => a = b). + +Goal forall n m p : nat, forall b:bool, n m<= p -> True . Proof. - intros n m p H H0. + intros n m p b H H0. + + assert (forall z, foo b z). + 2:{ + + ltac2:(let l := rename_acc 4 constr:(forall b:nat, Nat.clearbit b 4%nat = 0) in + printf "BEFORE BUILDNAME"; + let nme := build_name l in + printf "%s" nme). Unset Printing Notations. - ltac2:(let l := fallback_rename_hyp 9 constr:(Nat.clearbit n m = p) in + + + + ltac2:(let l := rename_acc 9 constr:(Nat.clearbit n m = p) in printf "BEFORE BUILDNAME %a " (pr_list pr_string) l; let nme := build_name l in printf "%s" nme). - ltac2:(let l := fallback_rename_hyp 3 constr:(Nat.clearbit 3 4%nat = 0) in + ltac2:(let l := rename_acc 3 constr:(Nat.clearbit 3 4%nat = 0) in printf "BEFORE BUILDNAME"; let nme := build_name l in printf "%s" nme). - ltac2:(let l := fallback_rename_hyp 4 constr:(Nat.clearbit 3 4%nat = 0 -> Nat.clearbit 3 4%nat = 7) in + ltac2:(let l := rename_acc 4 constr:(Nat.clearbit 3 4%nat = 0 -> Nat.clearbit 3 4%nat = 7) in printf "BEFORE BUILDNAME"; let nme := build_name l in printf "%s" nme). - ltac2:(let l := fallback_rename_hyp 4 constr:(forall x:nat, Nat.clearbit x 4%nat = 0) in + ltac2:(let l := rename_acc 3 constr:(forall x:nat, Nat.clearbit x 4%nat = 0) in printf "BEFORE BUILDNAME"; let nme := build_name l in printf "%s" nme). - ltac2:(let l := fallback_rename_hyp 4 constr:(forall x:Z, BinIntDef.Z.quot x x = 1%Z) in + ltac2:(let l := rename_acc 3 constr:(forall b:nat, Nat.clearbit b 4%nat = 0) in printf "BEFORE BUILDNAME"; let nme := build_name l in printf "%s" nme). - ltac2:(let l := fallback_rename_hyp 4 constr:(Nat.clearbit 3%nat 4%nat) in + ltac2:(let l := rename_acc 4 constr:(forall b:nat, Nat.clearbit b 4%nat = 0) in + printf "BEFORE BUILDNAME"; let nme := build_name l in printf "%s" nme). - - ltac2:(let l := fallback_rename_hyp 4 constr:(Nat.clearbit 3%nat 4%nat) in - printf "%a" (pr_list (fun () s => fprintf "%s" s)) l). - ltac2:(let nme := rename_app 1 2 [] constr:(Nat.clearbit 3%nat 4%nat) in - printf "%s" (List.hd nme)). - . - + ltac2:(let l := rename_acc 4 constr:(forall x:nat, Nat.clearbit x 4%nat = 0) in + printf "BEFORE BUILDNAME"; + let nme := build_name l in + printf "%s" nme). + + ltac2:(let l := rename_acc 4 constr:(forall x:Z, BinIntDef.Z.quot x x = 1%Z) in + printf "BEFORE BUILDNAME"; + let nme := build_name l in + printf "%s" nme). + + + ltac2:(let l := rename_acc 4 constr:(Nat.clearbit 3%nat 4%nat) in + let nme := build_name l in + printf "%s" nme). +Abort. + + +*) + (** This is the customizable naming tactic that the user should From b52cc00cff3b7c90e3643b2933c20441373bec09 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Sat, 25 Oct 2025 23:04:38 +0200 Subject: [PATCH 05/15] Forward compatibility of autorename. WIP. --- LibHyps/LibHypsNaming.v | 63 ++++++++++++++++++++++------------------- 1 file changed, 34 insertions(+), 29 deletions(-) diff --git a/LibHyps/LibHypsNaming.v b/LibHyps/LibHypsNaming.v index 543bd73..d734410 100644 --- a/LibHyps/LibHypsNaming.v +++ b/LibHyps/LibHypsNaming.v @@ -440,7 +440,6 @@ Ltac2 rec rename_app (nonimpl:int) (stop:int) (acc:string list ref) th: unit := Control.plus (fun () => let s := box_name th in Ref.set acc (s:: Ref.get acc)) (fun _ => - printf "## rename_app (nonimpl=%i) (stop=%i) %t " nonimpl stop th; match Unsafe.kind th with | App f args => (* control_try? *) @@ -461,7 +460,6 @@ with rename_hyp_chained_quantifs stop (acc:string list ref) (th:constr) : unit : | Prod bnd subth => if is_dep_prod th then - let _ := msgs "ICI DEP 20" in 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 @@ -469,16 +467,15 @@ with rename_hyp_chained_quantifs stop (acc:string list ref) (th:constr) : unit : 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); + (* 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 newstop acc subth' in + rename_hyp_chained_quantifs stop acc subth' in (in_context nme typ tac_under_binder); () else - let _ := msgs "ICI DEP 20" in rename_hyp_chained_quantifs stop acc subth | _ => fallback_rename_hyp stop acc th end @@ -487,10 +484,8 @@ 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 => - msgs "ICI 12"; if is_dep_prod th then - let _ := msgs "ICI 13" in 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 @@ -498,7 +493,7 @@ with fallback_rename_hyp_quantif stop (acc:string list ref) (th:constr) : unit : 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); + 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 @@ -509,14 +504,26 @@ with fallback_rename_hyp_quantif stop (acc:string list ref) (th:constr) : unit : else (Ref.set acc (impl_prefix() :: Ref.get acc); - (* fallback_rename_hyp 1 acc (Constr.Binder.type bnd); *) rename_hyp_chained_quantifs newstop acc subth) - | _ => backtrack "no product" + | App f args => + match Unsafe.kind f, Unsafe.kind constr:(@Init.Logic.ex) with + | Ind ind _, Ind ind' _ => + if Ind.equal ind ind' + then ( + msgs "EXXXX"; + 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 with fallback_rename_hyp_specials stop (acc:string list ref) th :unit := - printf "## fallback_rename_hyp_specials (stop=%i) %t " stop th; let newstop := Int.sub stop 1 in Control.plus (* First see if user has something that applies *) @@ -527,16 +534,16 @@ with fallback_rename_hyp_specials stop (acc:string list ref) th :unit := interp_directives acc (List.rev dirs)) with fallback_rename_hyp stop (acc:string list ref) th:unit := - printf "## fallback_rename_hyp (stop=%i) %t (acc = %a) " stop th (pr_list pr_string) (Ref.get acc); if Int.le stop 0 then () else Control.plus (fun () => fallback_rename_hyp_specials stop acc th) - (fun _ => match Unsafe.kind th with - | Prod _ _ => fallback_rename_hyp_quantif stop acc th - | _ => let numnonimpl := count_impl th in - let _ := rename_app numnonimpl stop acc th in - () - end) + (fun _ => 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 acc ld:unit := List.fold_right (fun d _ => interp_directive acc d) ld () @@ -573,7 +580,6 @@ Ltac2 rename_hyp_with_name h th := fail. renaming can be computed. Example of failing type: H:((fun x => True) true). *) Ltac2 autorename_strict (h:ident) := let th := Constr.type (Control.hyp h) in - printf "th = %t" th ; let tth := Constr.type th in printf "th = %t" tth ; match! tth with @@ -717,7 +723,6 @@ Lemma dummy: forall x y, (forall w w',w < w' -> ~(true=false)) -> (0 < 1 -> ~(1<0)) -> (0 < 1 -> 1<0) -> 0 < z -> True. - intros;{(fun h => autorename h)}. match type of x with nat => idtac | _ => fail "test failed!" end. @@ -735,23 +740,23 @@ Lemma dummy: forall x y, 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_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. *) + 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. match type of h_eq_cons_x0_3n_cons_2n with x0 :: 3 :: env = 2 :: env => idtac | _ => fail "test failed!" end. - (* match type of h_all_and_False_True with forall w w' : nat, w = w' -> False /\ True => idtac | _ => fail "test failed!" end. *) - (* match type of h_ex_and_neq_False with exists w : nat, w = w -> true <> (false && true)%bool /\ False => idtac | _ => fail "test failed!" end. *) - (* 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_1n with length (3::nil) = (fun _ : nat => 0) 1 => idtac | _ => fail "test failed!" end. + match type of h_all_and_False_True with forall w w' : nat, w = w' -> False /\ True => idtac | _ => fail "test failed!" end. + match type of h_ex_and_neq_False with exists w : nat, w = w -> true <> (false && true)%bool /\ False => idtac | _ => fail "test failed!" end. + 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_1n with length (3::nil) = (fun _ : nat => 0) 1 => idtac | _ => fail "test failed!" end. *) match type of h_eq_length_cons_0n with length (3::nil) = 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. match type of h_impl_tEQf with False -> true = false => idtac | _ => fail "test failed!" end. match type of x0 with nat => idtac | _ => fail "test failed!" end. match type of env with list nat => idtac | _ => fail "test failed!" end. - match type of h_not_In_x0_nil with ~ In x0 [] => idtac | _ => fail "test failed!" end. + match type of h_not_In_x0_nil with ~ In x0 nil => idtac | _ => fail "test failed!" end. match type of h_eq_cons_x0_3n_cons_2n with x0 :: 3 :: env = 2 :: env => idtac | _ => fail "test failed!" end. match type of h_IDProp with IDProp => idtac | _ => fail "test failed!" end. match type of h_impl_tNEQf with 0 < 1 -> 0 < 0 -> true = false -> true <> false => idtac | _ => fail "test failed!" end. From 01e56486555fe19e8523589d2a96fbd956d08e1a Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Sun, 26 Oct 2025 12:24:30 +0100 Subject: [PATCH 06/15] Cleaning backtracking in libhypsnaming. --- LibHyps/LibHypsDebug.v | 2 ++ LibHyps/LibHypsNaming.v | 77 +++++++++++++++++++++++++++-------------- 2 files changed, 53 insertions(+), 26 deletions(-) diff --git a/LibHyps/LibHypsDebug.v b/LibHyps/LibHypsDebug.v index c7b2a7c..490c2d5 100644 --- a/LibHyps/LibHypsDebug.v +++ b/LibHyps/LibHypsDebug.v @@ -54,3 +54,5 @@ Ltac2 pr_goal() := 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 d734410..7234ed9 100644 --- a/LibHyps/LibHypsNaming.v +++ b/LibHyps/LibHypsNaming.v @@ -66,6 +66,13 @@ Ltac2 build_name_gen (sep:string) (suffx:bool) (l:string list) := Ltac2 build_name l := build_name_gen "_" add_suffix (List.rev l). Ltac2 build_name_no_suffix l := build_name_gen "_" false (List.rev l). + +Ltac2 pr_directive () (d:rename_directive) := + match d with + String s => fprintf "%s" s + | RecRename i c => fprintf "(%i,%t)" i c + end. + (* 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_. @@ -395,7 +402,7 @@ Ltac2 box_name t : string := Ident.to_string id | Unsafe.Var id => Ident.to_string id | Unsafe.Ind _ _ => - printf "IND: %t" t; + (* 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) @@ -403,9 +410,9 @@ Ltac2 box_name t : string := s | _ => if is_closed t then - printf ". BEFORE NUM %t" t; + (* printf ". BEFORE NUM %t" t; *) let s := add_numerical_names () t in - printf ". AFTER NUM %t -> %s" t s; + (* printf ". AFTER NUM %t -> %s" t s; *) s else backtrack "cannot be a number" end @@ -426,8 +433,6 @@ Local Ltac2 is_dep_prod (t:constr): bool := | _ => false end. - - Ltac2 is_hyp (id:ident) := let hyps := Control.hyps () in List.exist (fun (x,_,_) => Ident.equal id x) hyps. @@ -437,7 +442,7 @@ Ltac2 is_hyp (id:ident) := recursively or simply. Parameters at positions below nonimpl are considered implicit and not considered. *) Ltac2 rec rename_app (nonimpl:int) (stop:int) (acc:string list ref) th: unit := - Control.plus (fun () => let s := box_name th in + Control.once_plus (fun () => let s := box_name th in Ref.set acc (s:: Ref.get acc)) (fun _ => match Unsafe.kind th with @@ -510,7 +515,6 @@ with fallback_rename_hyp_quantif stop (acc:string list ref) (th:constr) : unit : | Ind ind _, Ind ind' _ => if Ind.equal ind ind' then ( - msgs "EXXXX"; 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 @@ -524,31 +528,47 @@ with fallback_rename_hyp_quantif stop (acc:string list ref) (th:constr) : unit : with fallback_rename_hyp_specials stop (acc:string list ref) th :unit := + (* printf "hyp_specials = %a ; th : %t" pr_acc (Ref.get acc) th; *) let newstop := Int.sub stop 1 in - Control.plus + 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 acc (List.rev dirs) ) (* if it fails try default specials *) (fun _ => let dirs := rename_hyp_default newstop th in - interp_directives acc (List.rev dirs)) + (* msgs "C'est LA"; *) + (* printf "acc = %a" pr_acc (Ref.get acc); *) + (* printf "dirs = %a" (pr_list pr_directive) dirs; *) + Ref.set acc freeze; (* backtracking acc by hand here *) + interp_directives acc (List.rev dirs) + (* printf "acc AFTER = %a" pr_acc (Ref.get acc) *) + + ) with fallback_rename_hyp stop (acc:string list ref) th:unit := + (* printf "rename hyp %a ; th : %t" pr_acc (Ref.get acc) th; *) if Int.le stop 0 then () else - Control.plus (fun () => fallback_rename_hyp_specials stop acc th) - (fun _ => 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) + Control.once_plus (fun () => + fallback_rename_hyp_specials stop acc th + (* printf "rename_hyp 1 %a : %t" pr_acc (Ref.get acc) th *) + ) + (fun _ => + (* printf "special failed %a : %t" pr_acc (Ref.get acc) th; *) + 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 acc ld:unit := List.fold_right (fun d _ => interp_directive acc d) ld () with interp_directive 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)) | RecRename n t => fallback_rename_hyp n acc t @@ -556,19 +576,22 @@ with interp_directive acc d := Ltac2 rename_acc n th := let acc := Ref.ref [] in - (* Here we intentionally create a separate goal to discard all side - effect (renames) ont he current goal. The constr actually returned by in_context does not matter. *) - let _ := in_context (Option.get (Ident.of_string "DUMMY_SUBGOAL")) constr:(Prop) (fun () => fallback_rename_hyp n acc th) in - Ref.get acc. + (* Here we intentionally create a separate goal to discard all side effect + (renames) ont he current goal. The constr actually returned by in_context + does not matter. We also backtrack at the end to forget about this + separate goal. *) + let dummy_nme := Option.get (Ident.of_string "DUMMY_SUBGOAL") in + Control.once_plus (fun () => in_context dummy_nme constr:(Prop) (fun () => fallback_rename_hyp n acc th) ; + backtrack "Forgetting about the dummy subgoal") + (fun _ => Ref.get acc). Ltac2 fallback_rename_hyp_name th: ident := let depth := rename_depth in - msgs "ICI 1"; let l := rename_acc depth th in - msgs "ICI10"; + (* printf "ICI10 : %a" pr_acc l; *) match l with [] => backtrack "No name built" - | _ => (printf "FINAL acc = %a" (pr_list pr_string) l; + | _ => ( (*printf "FINAL acc = %a" (pr_list pr_string) l;*) let nme := String.app "h_" (build_name l) in let id := Option.get (Ident.of_string nme) in Fresh.in_goal id) @@ -581,7 +604,7 @@ renaming can be computed. Example of failing type: H:((fun x => True) true). *) Ltac2 autorename_strict (h:ident) := let th := Constr.type (Control.hyp h) in let tth := Constr.type th in - printf "th = %t" tth ; + (* printf "th = %t" tth ; *) match! tth with (* | _ => *) (* let l := rename_hyp_with_name $h th in *) @@ -630,7 +653,7 @@ Ltac2 Set rename_hyp_default := fun n th: rename_directives => if Int.lt n 0 then [] else - match! th with + lazy_match! th with | ?x <> ?y => [String "neq"; RecRename (decr n) x; RecRename (decr n) y] | @cons _ ?x (cons ?y ?l) => [String "cons"; RecRename n x; RecRename n y; RecRename (decr (decr n)) l] | @cons _ ?x ?l => if Int.ge n 1 then [String "cons"; RecRename n x; RecRename (decr n) l] else [String "cons"] @@ -723,6 +746,8 @@ Lemma dummy: forall x y, (forall w w',w < w' -> ~(true=false)) -> (0 < 1 -> ~(1<0)) -> (0 < 1 -> 1<0) -> 0 < z -> True. + + intros;{(fun h => autorename h)}. match type of x with nat => idtac | _ => fail "test failed!" end. From ad12e212117e6d86ec4d9ae919b81ab101762344 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Sun, 26 Oct 2025 20:23:22 +0100 Subject: [PATCH 07/15] Cleaning LibHypsNaming. --- LibHyps/LibHypsNaming.v | 832 +++++----------------------------------- 1 file changed, 91 insertions(+), 741 deletions(-) diff --git a/LibHyps/LibHypsNaming.v b/LibHyps/LibHypsNaming.v index 7234ed9..331fe52 100644 --- a/LibHyps/LibHypsNaming.v +++ b/LibHyps/LibHypsNaming.v @@ -1,10 +1,17 @@ (* 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. *) +(* **************************************************************** *) + +(** This file defines a tactic "autorename h" (and "autorename_strict + h") that automatically rename hypothesis h following a systematic, + but customizable heuristic. + + Comments welcome. *) From Stdlib Require Import Arith ZArith List. Require LibHyps.TacNewHyps. -Import TacNewHyps.Notations. + (* Import ListNotations. *) (* Local Open Scope list. *) Require Import Ltac2.Ltac2. @@ -15,74 +22,81 @@ 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 _ => ()). -(** This file defines a tactic "autorename h" (and "autorename_strict - h") that automatically rename hypothesis h followinh a systematic, - but customizable heuristic. - - Comments welcome. *) (* Comment this and the Z-dependent lines below if you don't want ZArith to be loaded *) From Stdlib Require Import ZArith. -(** ** The custom renaming tactic - - 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. - - Typical use, in increasing order of complexity, approximatively - equivalent to the decreasing order of interest. - -<< -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. :*) - -<< -Ltac rename_hyp ::= my_rename_hyp. ->> *) - Ltac2 Type rename_directive := [ String(string) | RecRename(int,constr) ]. Ltac2 Type rename_directives := rename_directive list. +(* For debugging *) +Ltac2 pr_directive () (d:rename_directive) := + match d with + String s => fprintf "%s" s + | RecRename i c => fprintf "(%i,%t)" i c + end. + Ltac2 Type hypnames := string list. + +(* The pretty printing of numerical values is by default 1, 2... Set this to + true (Ltac2 Set numerical_names := 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. -(* Elements of l are supposed to already start with "_" *) -Ltac2 build_name_gen (sep:string) (suffx:bool) (l:string list) := - String.app (String.concat sep l) (if suffx then "_" else ""). +(** Default prefix for hypothesis names. *) +Ltac2 default_prefix():string := "h". -Ltac2 build_name l := build_name_gen "_" add_suffix (List.rev l). -Ltac2 build_name_no_suffix l := build_name_gen "_" false (List.rev l). +(** A few special default chunks, for special cases in the naming heuristic. *) +Ltac2 impl_prefix() := "impl". +Ltac2 forall_prefix() := "all". +Ltac2 exists_prefix() := "ex". +(** ** 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. *) +Ltac2 mutable rename_hyp (stop:int) (th:constr): rename_directives := backtrack "rename_hyp". -Ltac2 pr_directive () (d:rename_directive) := - match d with - String s => fprintf "%s" s - | RecRename i c => fprintf "(%i,%t)" i c +(* 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. +>> *) + +(* This one is similar but for internal use *) +Ltac2 mutable rename_hyp_default (n:int) (th:constr): rename_directives := backtrack "rename_hyp_default". -(* 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 *) +(* 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 "")). -Ltac2 Type numerical_names_style := bool. -Ltac2 mutable numerical_names := false. +Ltac2 build_name (l:string list): string := build_name_gen "_" add_prefix add_suffix (List.rev l). Ltac2 string_of_int (i:int) := Message.to_string (Message.of_int i). @@ -93,19 +107,9 @@ Ltac2 string_of_int (i:int) := Message.to_string (Message.of_int i). 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 *) -Ltac2 num_nosufx (i:int) := - msgs ". num_nosufx"; - printf ". i = %s" (string_of_int i); - let res := String.app "_" (string_of_int i) in - printf ". res = %s" res; - msgs ". num_nosufx: end"; - res. -(* Ltac2 num_sufx (i:int) (sfx:string) := (String.app (string_of_int i) sfx). *) - (* TODO: find a way to make a string from nat, Z and N *) Ltac2 numerical_names_nosufx (t:constr):string := - printf "...NUM: %t" t; if is_closed t then match! t with | 0%Z => "0" @@ -186,7 +190,7 @@ Ltac2 numerical_names_sufx t := (* Redefine at will *) Ltac2 add_numerical_names (): constr -> string:= - if numerical_names then numerical_names_sufx else numerical_names_nosufx. + if numerical_sufx then numerical_names_sufx else numerical_names_nosufx. (** This determines the depth of the recursive analysis of a type to @@ -195,22 +199,9 @@ Ltac2 add_numerical_names (): constr -> string:= too often. *) Ltac2 mutable rename_depth := 3. -(** Default prefix for hypothesis names. *) -Ltac2 default_prefix():string := "h". -(** A few special default chunks, for special cases in the naming heuristic. *) -Ltac2 impl_prefix() := "impl". -Ltac2 forall_prefix() := "all". -Ltac2 exists_prefix() := "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. *) -Ltac2 mutable rename_hyp (stop:int) (th:constr): rename_directives := backtrack "rename_hyp". -Ltac2 mutable rename_hyp_default (n:int) (th:constr): rename_directives := backtrack "rename_hyp_default". - (* TODO: 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 @@ -327,68 +318,13 @@ Ltac2 count_impl th := -Ltac2 percent():char := (Char.of_int 37). Ltac2 arobase():char := (Char.of_int 64). -Ltac2 space():char := (Char.of_int 32). -Ltac2 parg():char := (Char.of_int 40). -Ltac2 pard():char := (Char.of_int 41). - -(* Ltac2 Eval (Char.to_int (String.get ")" 0)). *) - -Ltac2 set_forbidden_chars (): char list := [space();pard();parg()]. -Ltac2 set_removable_chars (): char list := [percent();arobase()]. -Ltac2 set_suspect_chars (): char list := List.append (set_forbidden_chars()) (set_removable_chars()). -Ltac2 set_forbidden_charints (): int list := List.map Char.to_int (set_forbidden_chars()). -Ltac2 set_removable_charints (): int list := List.map Char.to_int (set_removable_chars()). -Ltac2 set_suspect_charints (): int list := List.map Char.to_int (set_suspect_chars()). - -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. - -Ltac2 string_count_if (p:char -> bool) (s:string) : int := - let lgth := String.length s in - let rec count acc i := - if Int.ge i lgth then acc - else if p (String.get s i) then count (Int.add 1 acc) (Int.add 1 i) - else count acc (Int.add 1 i) - in - count 0 0. - -Ltac2 string_remove (p:char -> bool) (s:string) : string := - let lgth := String.length s in - let nbgood := string_count_if (fun c => Bool.neg (p c)) s in - let res := String.make nbgood (arobase()) in - let rec fill k i: unit := - if Int.ge i lgth then () - else - let c := String.get s i in - if p c then fill k (Int.add 1 i) - else (String.set res k c; fill (Int.add 1 k) (Int.add 1 i)) in - fill 0 0; - res. - -Ltac2 forbidden_charint (c:char):bool := (List.mem Int.equal (Char.to_int c) (set_forbidden_charints())). -Ltac2 removeable_charint (c:char):bool := (List.mem Int.equal (Char.to_int c) (set_removable_charints())). -Ltac2 suspect_charint (c:char):bool := (List.mem Int.equal (Char.to_int c) (set_suspect_charints())). - -Ltac2 Eval (string_remove (fun c => (Char.equal c (arobase()))) "az@er% % @o"). -Ltac2 Eval (string_remove forbidden_charint "az@er% % @o"). -Ltac2 Eval (string_remove suspect_charint "az@er% % @o"). - - -(* Ltac2 print_id (t:constr) : string option := *) -(* let (idopt,_) := Fresh.next (Fresh.Free.empty) t in *) -(* Some (Ident.to_string idopt). *) - (** 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) @@ -408,25 +344,10 @@ Ltac2 box_name t : string := then String.sub s 1 (Int.sub (String.length s) 1) else s in s - | _ => - if is_closed t then - (* printf ". BEFORE NUM %t" t; *) - let s := add_numerical_names () t in - (* printf ". AFTER NUM %t -> %s" t s; *) - s - else backtrack "cannot be a number" + | _ => add_numerical_names () t end end. -(* Ltac2 id_of_constr (t:constr) : string option := *) -(* let s:string := Message.to_string (fprintf "%t" t) in *) -(* if string_forall (fun c => Bool.neg (forbidden_charint c)) s *) -(* then *) -(* let s := string_remove removeable_charint s in *) -(* if string_forall (fun c => Bool.neg (Char.equal (space()) c)) s then Some s else None *) -(* else None. *) - - Local Ltac2 is_dep_prod (t:constr): bool := match kind t with | Prod _ subt => Bool.neg (is_closed subt) @@ -528,7 +449,6 @@ with fallback_rename_hyp_quantif stop (acc:string list ref) (th:constr) : unit : with fallback_rename_hyp_specials stop (acc:string list ref) th :unit := - (* printf "hyp_specials = %a ; th : %t" pr_acc (Ref.get acc) th; *) let newstop := Int.sub stop 1 in let freeze := Ref.get acc in Control.once_plus @@ -537,25 +457,14 @@ with fallback_rename_hyp_specials stop (acc:string list ref) th :unit := interp_directives acc (List.rev dirs) ) (* if it fails try default specials *) (fun _ => let dirs := rename_hyp_default newstop th in - (* msgs "C'est LA"; *) - (* printf "acc = %a" pr_acc (Ref.get acc); *) - (* printf "dirs = %a" (pr_list pr_directive) dirs; *) Ref.set acc freeze; (* backtracking acc by hand here *) - interp_directives acc (List.rev dirs) - (* printf "acc AFTER = %a" pr_acc (Ref.get acc) *) - - ) + interp_directives acc (List.rev dirs)) with fallback_rename_hyp stop (acc:string list ref) th:unit := - (* printf "rename hyp %a ; th : %t" pr_acc (Ref.get acc) th; *) if Int.le stop 0 then () else - Control.once_plus (fun () => - fallback_rename_hyp_specials stop acc th - (* printf "rename_hyp 1 %a : %t" pr_acc (Ref.get acc) th *) - ) + Control.once_plus (fun () => fallback_rename_hyp_specials stop acc th) (fun _ => - (* printf "special failed %a : %t" pr_acc (Ref.get acc) th; *) lazy_match! th with | forall _, _ => fallback_rename_hyp_quantif stop acc th | exists _, _ => fallback_rename_hyp_quantif stop acc th @@ -574,16 +483,20 @@ with interp_directive acc d := | RecRename 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 () => in_context nme typ f; backtrack "forget in_context subgoal") + (fun _ => ()). + Ltac2 rename_acc n th := let acc := Ref.ref [] in - (* Here we intentionally create a separate goal to discard all side effect - (renames) ont he current goal. The constr actually returned by in_context - does not matter. We also backtrack at the end to forget about this - separate goal. *) + (* 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 - Control.once_plus (fun () => in_context dummy_nme constr:(Prop) (fun () => fallback_rename_hyp n acc th) ; - backtrack "Forgetting about the dummy subgoal") - (fun _ => Ref.get acc). + 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 @@ -591,12 +504,14 @@ Ltac2 fallback_rename_hyp_name th: ident := (* printf "ICI10 : %a" pr_acc l; *) match l with [] => backtrack "No name built" - | _ => ( (*printf "FINAL acc = %a" (pr_list pr_string) l;*) - let nme := String.app "h_" (build_name l) in + | _ => let nme := build_name l in let id := Option.get (Ident.of_string nme) in - Fresh.in_goal id) + 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.*) Ltac2 rename_hyp_with_name h th := fail. (* Tactic renaming hypothesis H. Ignore Type-sorted hyps, fails if no @@ -606,6 +521,7 @@ Ltac2 autorename_strict (h:ident) := let tth := Constr.type th in (* printf "th = %t" tth ; *) match! tth with + (* TODO: the deep entry point *) (* | _ => *) (* let l := rename_hyp_with_name $h th in *) (* let dummy_name := fresh "dummy" in *) @@ -685,7 +601,7 @@ Ltac2 recRename n x := (* This settings should reproduce the naming scheme of libhypps-1.0.0 and libhypps-1.0.1. *) Ltac2 Set add_suffix := false. -Ltac2 Set numerical_names := true. +Ltac2 Set numerical_sufx := true. (* From there this is LibHypTest from 1f7a1ed2289e439c291fcbd06c51705547feef1e *) Ltac2 rename_hyp_2 n th := @@ -707,7 +623,7 @@ Ltac2 rename_hyp_3 n th := Ltac2 Set rename_hyp := rename_hyp_3. Ltac2 Set rename_depth := 3. - +Import TacNewHyps.Notations. Close Scope Z_scope. Open Scope nat_scope. Lemma dummy: forall x y, @@ -817,7 +733,7 @@ Goal forall [A : Type] (P Q : A -> Prop) (x : A), P x -> Q x -> (exists2 x : A, autorename H. autorename H0. assert (HH: (fun x => x = x) 1). - 2:{ autorename HH. + 2:{ autorename HH. } ltac2:(let l := rename_acc 3 constr:(exists2 x0 : A, P x0 & Q x0) in @@ -838,7 +754,7 @@ Proof. intros n m p b H H0. assert (forall z, foo b z). - 2:{ + 2:{ } ltac2:(let l := rename_acc 4 constr:(forall b:nat, Nat.clearbit b 4%nat = 0) in printf "BEFORE BUILDNAME"; @@ -900,572 +816,6 @@ Abort. *) - - -(** 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. -(** This will later contain a few default fallback naming strategy. *) -Ltac rename_hyp_default 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. - - -Ltac build_name l := build_name_gen add_suffix l. -Ltac build_name_no_suffix l := build_name_gen constr:(false) l. - - - -(** * Implementation principle: - - The name of the hypothesis will be a sequence of chunks. A chunk is - a word generally starting with "_". - - 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: - - [(∀ h,DUMMY h) ; (∀ _eq,DUMMY _eq) ; (∀ _foo, DUMMY _foo)] - - where DUMMY is an opaque (identity) function but we don't care. *) - - -(** We define DUMMY as an opaque symbol. *) -Definition DUMMY: Prop -> Prop. - exact (fun x:Prop => x). -Qed. - -(* ********** CUSTOMIZATION ********** *) - -(** 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. - -(** 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). - -(** 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. - -Ltac build_name l := build_name_gen add_suffix l. -Ltac build_name_no_suffix l := build_name_gen constr:(false) l. - - -(** 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. - -(** 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. - - -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_). - - -(** 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. - -(* 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. - - -(* 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. - - -(** 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 - 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) - 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. - -(* Formating Error message *) -Inductive LHMsg t (h:t) := LHMsgC: LHMsg t h. - -Notation "h : t" := (LHMsgC t h) (at level 1,only printing, format -"'[ ' $h ':' '/' '[' t ']' ']'"). - -Ltac 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). *) -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. - -(* Tactic renaming hypothesis H. *) - -Ltac autorename $h := try autorename_strict H. - (* (* Tests *) Print Visibility. From 15286724c60d6db1f569a14641373a2a2b9195dd Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Sun, 26 Oct 2025 22:30:03 +0100 Subject: [PATCH 08/15] Re-implementing renaming tacticals. --- LibHyps/LibHypsNaming.v | 185 +++++++++++++++++----------------------- 1 file changed, 76 insertions(+), 109 deletions(-) diff --git a/LibHyps/LibHypsNaming.v b/LibHyps/LibHypsNaming.v index 331fe52..1edcf81 100644 --- a/LibHyps/LibHypsNaming.v +++ b/LibHyps/LibHypsNaming.v @@ -39,8 +39,13 @@ Ltac2 pr_directive () (d:rename_directive) := 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_names := true) to have 1z, 1n or 1N depending of the type nat, Z or N. *) + 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. @@ -100,109 +105,67 @@ Ltac2 build_name (l:string list): string := build_name_gen "_" add_prefix add_su Ltac2 string_of_int (i:int) := Message.to_string (Message.of_int i). -(** 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 *) -(* TODO: find a way to make a string from nat, Z and N *) -Ltac2 numerical_names_nosufx (t:constr):string := - if is_closed t then - match! t with - | 0%Z => "0" - | 1%Z => "1" - | 2%Z => "2" - | 3%Z => "3" - | 4%Z => "4" - | 5%Z => "5" - | 6%Z => "6" - | 7%Z => "7" - | 8%Z => "8" - | 9%Z => "9" - | 10%Z => "10" - | O%nat => "0" - | 1%nat => "1" - | 2%nat => "2" - | 3%nat => "3" - | 4%nat => "4" - | 5%nat => "5" - | 6%nat => "6" - | 7%nat => "7" - | 8%nat => "8" - | 9%nat => "9" - | 10%nat => "10" - | O%N => "0" - | 1%N => "1" - | 2%N => "2" - | 3%N => "3" - | 4%N => "4" - | 5%N => "5" - | 6%N => "6" - | 7%N => "7" - | 8%N => "8" - | 9%N => "9" - | 10%N => "10" - | _ => backtrack "not recognized as a number " - end - else - backtrack "not a nameable number". - -Ltac2 numerical_names_sufx t := - match! t with - | 0%Z => "0z" - | 1%Z => "1z" - | 2%Z => "2z" - | 3%Z => "3z" - | 4%Z => "4z" - | 5%Z => "5z" - | 6%Z => "6z" - | 7%Z => "7z" - | 8%Z => "8z" - | 9%Z => "9z" - | 10%Z => "10z" - (* | Z0 => num_sufx 0 *) - | O%nat => "0n" - | 1%nat => "1n" - | 2%nat => "2n" - | 3%nat => "3n" - | 4%nat => "4n" - | 5%nat => "5n" - | 6%nat => "6n" - | 7%nat => "7n" - | 8%nat => "8n" - | 9%nat => "9n" - | 10%nat => "10n" - | O%N => "0N" - | 1%N => "1N" - | 2%N => "2N" - | 3%N => "3N" - | 4%N => "4N" - | 5%N => "5N" - | 6%N => "6N" - | 7%N => "7N" - | 8%N => "8N" - | 9%N => "9N" - | 10%N => "10N" - end. +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. -(* Redefine at will *) -Ltac2 add_numerical_names (): constr -> string:= - if numerical_sufx then numerical_names_sufx else numerical_names_nosufx. +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). -(** 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. +Ltac2 is_digit (c:char): bool := + let code := Char.to_int c in + Bool.and (Int.le (code0()) code) (Int.le code (code9())). +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"). +Ltac2 string_shorten_percent (s:string) : string := + let lgth := String.length s in + let i := string_first (fun c => Int.equal (Char.to_int c) (codepercent())) s in + String.sub s 0 i. -(* TODO: find something better to detect implicits!! *) + +(** 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 *) + +(* 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". + + +(* 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 @@ -344,7 +307,7 @@ Ltac2 box_name t : string := then String.sub s 1 (Int.sub (String.length s) 1) else s in s - | _ => add_numerical_names () t + | _ => build_numerical_name t end end. @@ -516,11 +479,12 @@ 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). *) +#[global] Ltac2 autorename_strict (h:ident) := let th := Constr.type (Control.hyp h) in let tth := Constr.type th in (* printf "th = %t" tth ; *) - match! tth with + lazy_match! tth with (* TODO: the deep entry point *) (* | _ => *) (* let l := rename_hyp_with_name $h th in *) @@ -536,7 +500,11 @@ Ltac2 autorename_strict (h:ident) := | Prop => let msg := fprintf "no renaming pattern for %I : %t" h th in backtrack (Message.to_string msg) - (* | _ => () (* not in Prop or "no renaming pattern for " $h *) *) + | _ => + 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. (* Tactic renaming hypothesis H. *) @@ -548,11 +516,18 @@ Ltac2 ltac1_autorename (h:Ltac1.t) := let h: ident := Option.get (Ltac1.to_ident h) in ltac2_autorename h. +#[global]Ltac2 ltac1_autorename_strict (h:Ltac1.t) := + let h: ident := Option.get (Ltac1.to_ident h) in + autorename_strict h. Tactic Notation "autorename" hyp(h) := let tac := ltac2:(h |- ltac1_autorename h) in tac h. +Tactic Notation "autorename_strict" hyp(h) := + let tac := ltac2:(h |- ltac1_autorename_strict h) in + tac h. + Ltac2 decr (n:int):int := if Int.equal n 0 then 0 else Int.sub n 1. @@ -587,15 +562,6 @@ Ltac2 recRename n x := (* ********** CUSTOMIZATION ********** *) -(** 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. *) - - - (* TESTS *) (* This settings should reproduce the naming scheme of libhypps-1.0.0 @@ -633,6 +599,7 @@ Lemma dummy: forall x y, x = y -> Some x = Some y -> 0 = 1 -> + 223 = 426 -> (0 = 1)%Z -> ~x = y -> true = Nat.eqb 3 4 -> @@ -662,8 +629,7 @@ Lemma dummy: forall x y, (forall w w',w < w' -> ~(true=false)) -> (0 < 1 -> ~(1<0)) -> (0 < 1 -> 1<0) -> 0 < z -> True. - - +Proof. intros;{(fun h => autorename h)}. match type of x with nat => idtac | _ => fail "test failed!" end. @@ -672,6 +638,7 @@ Lemma dummy: forall x y, match type of h_le_0z_1z with (0 <= 1)%Z => idtac | _ => fail "test failed!" end. match type of h_le_x_y with x <= y => idtac | _ => fail "test failed!" end. match type of h_eq_x_y with x = y => idtac | _ => fail "test failed!" end. + match type of h_eq_223n_426n with 223 = 426 => idtac | _ => fail "test failed!" end. match type of h_eq_0n_1n with 0 = 1 => idtac | _ => fail "test failed!" end. match type of h_eq_0z_1z with 0%Z = 1%Z => idtac | _ => fail "test failed!" end. match type of h_neq_x_y with x <> y => idtac | _ => fail "test failed!" end. From cfd87a77073a5a47a521ddc3f272730cdf756e34 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Tue, 24 Mar 2026 10:15:58 +0100 Subject: [PATCH 09/15] Auto naming works ok. Needs cleaning. Now working on (ltac2) hyps grouping. --- LibHyps/LibHyps.v | 104 +++++++++++++-------- LibHyps/LibHypsNaming.v | 189 +++++++++++++++++++++++++++----------- LibHyps/LibHypsTactics.v | 81 ++-------------- configure.sh | 20 +++- tests/LibHypsRegression.v | 59 +++++++++++- tests/demo.v | 2 +- 6 files changed, 281 insertions(+), 174 deletions(-) diff --git a/LibHyps/LibHyps.v b/LibHyps/LibHyps.v index 25d96d6..3ba4768 100644 --- a/LibHyps/LibHyps.v +++ b/LibHyps/LibHyps.v @@ -5,10 +5,38 @@ Require Export LibHyps.TacNewHyps. Require Export LibHyps.LibHypsNaming. Require Export LibHyps.Especialize. -Require Export LibHyps.LibHypsTactics. +(* Require Export LibHyps.LibHypsTactics. *) (* We export ; { } etc. ";;" also. *) +Ltac rename_or_revert H := autorename_strict H + generalize dependent H. + +(* Some usual tactics one may want to use on new hyps. *) + +(* 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 := + 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 y; try clear 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 | 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. + + Export TacNewHyps.Notations. (* There are three variants of the autorename tatic, depending on what @@ -27,30 +55,33 @@ 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 ; {! group_up_list }. *) +(* Not yet reimplemented in ltac2 *) +Tactic Notation (at level 4) "/" "g" := (group_up_list all_hyps). +*) (* 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). (* usual combinations *) -Tactic Notation (at level 4) tactic4(Tac) "//" := (Tac /s/n/g). +(*Tactic Notation (at level 4) tactic4(Tac) "//" := (Tac /s/n/g). Tactic Notation (at level 4) tactic4(Tac) "/" "sng" := (Tac /s/n/g). -Tactic Notation (at level 4) tactic4(Tac) "/" "sgn" := (Tac /s/g/n). +Tactic Notation (at level 4) tactic4(Tac) "/" "sgn" := (Tac /s/g/n). *) Tactic Notation (at level 4) tactic4(Tac) "/" "sn" := (Tac /s/n). Tactic Notation (at level 4) tactic4(Tac) "/" "sr" := (Tac /s/r). -Tactic Notation (at level 4) tactic4(Tac) "/" "sg" := (Tac /s/g). +(*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) 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) ; group_up_list all_hyps). *) Module LegacyNotations. Import Notations. @@ -61,7 +92,7 @@ Module LegacyNotations. (* like !!tac + tries to subst with each new hypothesis. *) Tactic Notation "!!!" tactic3(Tac) := Tac/s/n?. (* Like !!! + regroup new Type-sorted hyps at top. *) - Tactic Notation (at level 4) "!!!!" tactic4(Tac) := Tac /s/n?/g. + (* Tactic Notation (at level 4) "!!!!" tactic4(Tac) := Tac /s/n?/g. *) (* Other Experimental combinations *) @@ -85,49 +116,50 @@ Goal forall x1 x3:bool, forall a z e : nat, Proof. (* Set Ltac Debug. *) (* then_nh_rev ltac:(intros) ltac:(subst_or_idtac). *) - intros ; {! group_up_list }. + (* intros ; {! group_up_list }. *) (* intros ? ? ? ? ? ? ? ? ? ?. *) (* group_up_list (DCons bool b1 DNil). *) - Undo. - intros ; { move_up_types }. - Undo. + (* 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 }. + intros ; { autorename }. (*; {! group_up_list }.*) Undo. - intros/ng. + (* intros/ng. *) + (* Undo. *) + intros ; {subst_or_idtac} ; { autorename }. (* ; {! group_up_list }.*) Undo. - intros ; {subst_or_idtac} ; { autorename } ; {! group_up_list }. - Undo. - intros/sng. - Fail progress intros ; { revertHyp }. + (* intros/sng. *) + (* Fail progress intros ; { revertHyp }. *) - subst_or_idtac (DCons (z0 + r = a) H DNil). + (* subst_or_idtac (DCons (z0 + r = a) H DNil). *) - let hyps := all_hyps in - idtac hyps. - subst_or_idtac hyps. + (* let hyps := all_hyps in *) + (* idtac hyps. *) + (* subst_or_idtac hyps. *) - intros ;!; ltac:(subst_or_idtac_l). + (* 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 }. + (* 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. *) + Fail (intros ; { fun h => autorename_strict h }). + intros ; { fun h => autorename_orelse_revert h }. + match goal with + | |- (fun _ : bool => z = e) true -> True => idtac + end. + Undo 2. intros ; { fun h => idtac h }. + Undo. 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. diff --git a/LibHyps/LibHypsNaming.v b/LibHyps/LibHypsNaming.v index 1edcf81..f64ebff 100644 --- a/LibHyps/LibHypsNaming.v +++ b/LibHyps/LibHypsNaming.v @@ -27,16 +27,23 @@ Local Ltac2 control_try tac := Control.plus tac (fun _ => ()). ZArith to be loaded *) From Stdlib Require Import ZArith. -Ltac2 Type rename_directive := [ String(string) | RecRename(int,constr) ]. +Ltac2 decr (n:int):int := + if Int.equal n 0 then 0 else Int.sub n 1. + +Ltac2 incr (n:int):int := Int.add n 1. + +Ltac2 Type rename_directive := [ String(string) | Rename(constr) | RenameN(int,constr) ]. Ltac2 Type rename_directives := rename_directive list. (* For debugging *) +Module Debug. Ltac2 pr_directive () (d:rename_directive) := match d with String s => fprintf "%s" s - | RecRename i c => fprintf "(%i,%t)" i c + | Rename c => fprintf "%t" c + | RenameN i c => fprintf "N(%i,%t)" i c end. - +End Debug. Ltac2 Type hypnames := string list. (** This determines the depth of the recursive analysis of a type to @@ -68,6 +75,7 @@ Ltac2 exists_prefix() := "ex". default naming scheme to apply. *) 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. *) (** @@ -95,6 +103,7 @@ Ltac2 Set rename_hyp := rename_hyp_3. (* This one is similar but for internal use *) Ltac2 mutable rename_hyp_default (n:int) (th:constr): rename_directives := backtrack "rename_hyp_default". +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) := @@ -324,7 +333,7 @@ Ltac2 is_hyp (id:ident) := (** 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. *) + 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)) @@ -344,7 +353,7 @@ Ltac2 rec rename_app (nonimpl:int) (stop:int) (acc:string list ref) th: unit := 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 + let _newstop := Int.sub stop 1 in match Unsafe.kind th with | Prod bnd subth => if is_dep_prod th @@ -401,7 +410,7 @@ with fallback_rename_hyp_quantif stop (acc:string list ref) (th:constr) : unit : 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 + | Lambda _bnd subth => rename_hyp_chained_quantifs newstop acc subth | _ => backtrack "not exist" end) else backtrack "not exist" @@ -417,11 +426,11 @@ with fallback_rename_hyp_specials stop (acc:string list ref) th :unit := Control.once_plus (* First see if user has something that applies *) (fun() => let dirs := rename_hyp newstop th in - interp_directives acc (List.rev dirs) ) + 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 acc (List.rev dirs)) + interp_directives newstop acc (List.rev dirs)) with fallback_rename_hyp stop (acc:string list ref) th:unit := if Int.le stop 0 then () @@ -436,14 +445,15 @@ with fallback_rename_hyp stop (acc:string list ref) th:unit := () end) -with interp_directives acc ld:unit := - List.fold_right (fun d _ => interp_directive acc d) ld () +with interp_directives stop acc ld:unit := + List.fold_right (fun d _ => interp_directive stop acc d) ld () -with interp_directive acc d := +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)) - | RecRename n t => fallback_rename_hyp n acc t + | 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 @@ -509,58 +519,103 @@ Ltac2 autorename_strict (h:ident) := (* Tactic renaming hypothesis H. *) -Ltac2 ltac2_autorename (h:ident) := +Local Ltac2 ltac2_autorename (h:ident) := control_try (fun () => autorename_strict h). Ltac2 ltac1_autorename (h:Ltac1.t) := let h: ident := Option.get (Ltac1.to_ident h) in ltac2_autorename h. -#[global]Ltac2 ltac1_autorename_strict (h:Ltac1.t) := +Ltac2 ltac1_autorename_strict (h:Ltac1.t) := let h: ident := Option.get (Ltac1.to_ident h) in autorename_strict h. -Tactic Notation "autorename" hyp(h) := - let tac := ltac2:(h |- ltac1_autorename h) in - tac h. - -Tactic Notation "autorename_strict" hyp(h) := - let tac := ltac2:(h |- ltac1_autorename_strict h) in - tac h. - -Ltac2 decr (n:int):int := - if Int.equal n 0 then 0 else Int.sub n 1. - 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)). +End Ltac2. - -(* Ltac2 Notation x(constr) "#" y(tactic(1)) := (RecRename x y). *) - - +(* This is the default renaming hard-coded in LibHYps *) Ltac2 Set rename_hyp_default := - fun n th: rename_directives => + fun n th => if Int.lt n 0 then [] else lazy_match! th with - | ?x <> ?y => [String "neq"; RecRename (decr n) x; RecRename (decr n) y] - | @cons _ ?x (cons ?y ?l) => [String "cons"; RecRename n x; RecRename n y; RecRename (decr (decr n)) l] - | @cons _ ?x ?l => if Int.ge n 1 then [String "cons"; RecRename n x; RecRename (decr n) l] else [String "cons"] - | (@Some _ ?x) => [RecRename (Int.add 1 n) x] + | ?x <> ?y => [ String "neq" ; Rename x ; Rename y ] + | (@Some _ ?x) => [RenameN (incr n) x] | (@None _) => [String "None"] end. -Definition DUMMY: Prop -> Prop. - exact (fun x:Prop => x). -Qed. +(* This may be due to the definition of ltac1_autorename which uses + Ltac1.to_ident, but this is the only way I found to have + "autorename h" be callable from ltac1: make it a notation expecting + an ident, and then define a tactic using this notation. If I define + directly the tatic autorename instead of a notation, then it does + not accept "autorename id". *) +(* to reproduce: +Ltac2 ltac1_autorename (h:Ltac1.t) := + let h: ident := Option.get (Ltac1.to_ident h) in + ltac2_autorename h. + +Global Ltac autorename h := + let tac := ltac2:(h |- Ltac2.ltac1_autorename h) in + tac h. + +Goal 1 = 2 -> False. +Proof. + intros H. + autorename H. (* Ltac1.to_ident fails with Ltac2 exception: No_value *) + +More generally to reproduce: + +Ltac2 ltac2_mytac (id:ident) := printf "%I" id. + +Ltac2 ltac1_mytac (h:Ltac1.t) := + let h: ident := Option.get (Ltac1.to_ident h) in + ltac2_mytac h. -Ltac2 recRename n x := - RecRename (Option.get (Ltac1.to_int n)) (Option.get (Ltac1.to_constr x)). +Global Ltac mytac h := + let tac := ltac2:(h |- ltac1_mytac h) in + tac h. +Local Set Default Proof Mode "Classic". -(* ********** CUSTOMIZATION ********** *) +Goal 1 = 2 -> False. +Proof. + intros H. + Fail mytac H. (* Ltac1.to_ident fails with Ltac2 exception: No_value *) +Abort. + +(* Solution *) +Tactic Notation "XXXmytac" hyp(h) := + let tac := ltac2:(h |- ltac1_mytac h) in + tac h. + +Ltac mytac' h := XXXmytac h. + + +Goal 1 = 2 -> False. +Proof. + intros H. + mytac' H. + +*) + + +Local Tactic Notation "Lautorename" hyp(h) := + let tac := ltac2:(h |- Ltac2.ltac1_autorename h) in + tac h. + +Global Ltac autorename h := Lautorename h. + +Local Tactic Notation "Lautorename_strict" hyp(h) := + let tac := ltac2:(h |- Ltac2.ltac1_autorename_strict h) in + tac h. +Global Ltac autorename_strict h := Lautorename_strict h. + +(* +(* ********** EXAMPLE CUSTOMIZATION ********** *) (* TESTS *) @@ -569,11 +624,21 @@ Ltac2 recRename n x := Ltac2 Set add_suffix := false. Ltac2 Set numerical_sufx := true. +(* This should maybe be by default *) +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. + (* From there this is LibHypTest from 1f7a1ed2289e439c291fcbd06c51705547feef1e *) 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. Ltac2 Set rename_hyp := rename_hyp_2. @@ -581,8 +646,8 @@ 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" ; RecRename n x ; RecRename n y] - | true = Nat.eqb ?x ?y => [String "Neqb" ; RecRename n x ; RecRename n y] + | 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. @@ -592,6 +657,7 @@ Ltac2 Set rename_depth := 3. Import TacNewHyps.Notations. Close Scope Z_scope. Open Scope nat_scope. + Lemma dummy: forall x y, 0 <= 1 -> (0%Z <= 1%Z)%Z -> @@ -601,9 +667,11 @@ Lemma dummy: forall x y, 0 = 1 -> 223 = 426 -> (0 = 1)%Z -> - ~x = y -> + x <> y -> + Nat.eqb (x + 1) 0 <> Nat.eqb 1 y -> true = Nat.eqb 3 4 -> - Nat.eqb 3 4 = true -> + Nat.eqb (x + 3) 4 = true -> + Nat.eqb (2 * (x + 3)) 4 = true -> true = Nat.leb 3 4 -> 1 = 0 -> ~x = y -> @@ -630,7 +698,10 @@ Lemma dummy: forall x y, (0 < 1 -> ~(1<0)) -> (0 < 1 -> 1<0) -> 0 < z -> True. Proof. - intros;{(fun h => autorename h)}. + intros x y H. + autorename H. + Undo 2. + intros;{ autorename }. match type of x with nat => idtac | _ => fail "test failed!" end. match type of y with nat => idtac | _ => fail "test failed!" end. @@ -643,10 +714,12 @@ Proof. match type of h_eq_0z_1z with 0%Z = 1%Z => idtac | _ => fail "test failed!" end. 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_add_x_3n_4n with (x + 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. @@ -677,7 +750,9 @@ Proof. Qed. -(* + + + (* Ltac autorename h := *) (* let tac := ltac2:(h |- ltac2_autorename h) in *) (* tac h. *) @@ -686,31 +761,35 @@ Qed. (* Ltac2 Eval (count_impl constr:(3 + 4)). *) +Import TacNewHyps.Notations. Parameters X Y: nat -> Prop. Parameters PX: X 3. Parameters PY: Y 3. +Local Ltac rename_or_revert H := autorename_strict H + (try revert H). -Goal forall [A : Type] (P Q : A -> Prop) (x : A), P x -> Q x -> (exists2 x : A, P x & Q x) -> ex2 P Q -> False. +Goal forall [A : Type] (P Q : A -> Prop) (x : A), P x -> Q x -> (exists2 x : A, P x & Q x) -> ((fun x => x = x) 1) -> ex2 P Q -> False. - intros A P Q x H H0 H1 H2. + intros A P Q x H H0 H1 HH H2. autorename H1. autorename H2. autorename H. autorename H0. - assert (HH: (fun x => x = x) 1). - 2:{ autorename HH. } + Fail autorename_strict HH. + rename_or_revert HH. + intros ; { rename_or_revert }. + Fail intros ; { autorename_strict }. - ltac2:(let l := rename_acc 3 constr:(exists2 x0 : A, P x0 & Q x0) in + ltac2:(let l := Ltac2.rename_acc 3 constr:(exists2 x0 : A, P x0 & Q x0) in printf "BEFORE BUILDNAME %a " (pr_list pr_string) l; - let nme := build_name l in + let nme := Ltac2.build_name l in printf "%s" nme). - ltac2:(let l := rename_acc 9 constr:(ex2 P Q) in + ltac2:(let l := Ltac2.rename_acc 9 constr:(ex2 P Q) in printf "BEFORE BUILDNAME %a " (pr_list pr_string) l; - let nme := build_name l in + let nme := Ltac2.build_name l in printf "%s" nme). Abort. diff --git a/LibHyps/LibHypsTactics.v b/LibHyps/LibHypsTactics.v index 3943acd..313cdcb 100644 --- a/LibHyps/LibHypsTactics.v +++ b/LibHyps/LibHypsTactics.v @@ -6,7 +6,8 @@ Require Export LibHyps.TacNewHyps. Require Export LibHyps.LibHypsNaming. (* Require Export LibHyps.LibSpecialize. *) -(* debug +(* START DEBUG *) +(* Module Prgoal_Notation. Ltac pr_goal := match goal with @@ -26,81 +27,12 @@ Proof. (* specevar h_eqone at y. *) pr_goal. pr_goal. -Abort. *) - -(* 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. - - 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. - -Ltac rename_or_revert H := autorename_strict H + revert 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. *) - -(* 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 := - 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 y; try clear 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. +Abort. +(* END DEBUG *) + *) +(* TODO (* 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. *) @@ -348,3 +280,4 @@ Proof. intros ; { fun h => idtac h }. intros ; { ltac:(fun h => idtac h) }. *) +*) diff --git a/configure.sh b/configure.sh index 6569323..4904fe4 100755 --- a/configure.sh +++ b/configure.sh @@ -1,6 +1,7 @@ #!/bin/bash DEVOPT=no +STDLIB= POSITIONAL=() while [[ $# -gt 0 ]] @@ -8,6 +9,11 @@ do key="$1" case $key in + --stdlib|-stdlib) + shift + STDLIB=$1 + shift + ;; --dev) DEVOPT=yes shift @@ -28,10 +34,18 @@ set -- "${POSITIONAL[@]}" # restore positional parameters (i.e. 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" @@ -57,10 +71,10 @@ else 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/tests/LibHypsRegression.v b/tests/LibHypsRegression.v index 284b385..b357c7b 100644 --- a/tests/LibHypsRegression.v +++ b/tests/LibHypsRegression.v @@ -8,11 +8,45 @@ Require Export LibHyps.LibHypsNaming. Require Export LibHyps.LibHyps. Export TacNewHyps.Notations. From Stdlib 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. *) +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. + +Ltac2 Set rename_hyp := rename_hyp_2. + +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. + +(* Ltac add_suffix ::= constr:(false). Ltac numerical_names ::= numerical_names_sufx. @@ -38,7 +72,7 @@ Ltac rename_hyp_3 n th := Ltac rename_hyp ::= rename_hyp_3. Ltac rename_depth ::= constr:(3). - +*) Close Scope Z_scope. Open Scope nat_scope. Lemma dummy: forall x y, @@ -49,7 +83,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 +127,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 +140,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. @@ -124,6 +163,7 @@ 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. @@ -140,19 +180,28 @@ Proof. Qed. *) +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. + Require Import LibHyps.LibDecomp. +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/demo.v b/tests/demo.v index 7c24db4..93caba1 100644 --- a/tests/demo.v +++ b/tests/demo.v @@ -20,7 +20,7 @@ From Stdlib 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 *) From acd120b08a7194eb2fd20fa25c98ba01a391d18f Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Tue, 24 Mar 2026 14:25:51 +0100 Subject: [PATCH 10/15] grouping hyps now works with ltac2. --- LibHyps/LibHyps.v | 18 ++- LibHyps/LibHypsTactics.v | 312 +++++++++++--------------------------- tests/LibHypsRegression.v | 39 +---- tests/LibHypsTest.v | 168 ++++---------------- tests/demo.v | 52 ++----- 5 files changed, 150 insertions(+), 439 deletions(-) diff --git a/LibHyps/LibHyps.v b/LibHyps/LibHyps.v index 3ba4768..f600dda 100644 --- a/LibHyps/LibHyps.v +++ b/LibHyps/LibHyps.v @@ -5,11 +5,11 @@ Require Export LibHyps.TacNewHyps. Require Export LibHyps.LibHypsNaming. Require Export LibHyps.Especialize. -(* Require Export LibHyps.LibHypsTactics. *) +Require Export LibHyps.LibHypsTactics. (* We export ; { } etc. ";;" also. *) -Ltac rename_or_revert H := autorename_strict H + generalize dependent H. +Ltac rename_or_revert H := autorename_strict H + revert dependent H. (* Some usual tactics one may want to use on new hyps. *) @@ -55,6 +55,8 @@ 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). +Tactic Notation (at level 4) tactic4(Tac) "/" "g" := Tac ; { move_up_types }. +(* Tactic Notation (at level 4) tactic4(Tac) "/" "g" := Tac ; {! group_up_list }. *) (* (* 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). *) @@ -68,20 +70,20 @@ Tactic Notation (at level 4) tactic4(Tac) "/" "s" := Tac ; { subst_or_idtac }. Tactic Notation (at level 4) "/" "s" := (onAllHyps subst_or_idtac). (* usual combinations *) -(*Tactic Notation (at level 4) tactic4(Tac) "//" := (Tac /s/n/g). +Tactic Notation (at level 4) tactic4(Tac) "//" := (Tac /s/n/g). Tactic Notation (at level 4) tactic4(Tac) "/" "sng" := (Tac /s/n/g). -Tactic Notation (at level 4) tactic4(Tac) "/" "sgn" := (Tac /s/g/n). *) +Tactic Notation (at level 4) tactic4(Tac) "/" "sgn" := (Tac /s/g/n). Tactic Notation (at level 4) tactic4(Tac) "/" "sn" := (Tac /s/n). Tactic Notation (at level 4) tactic4(Tac) "/" "sr" := (Tac /s/r). -(*Tactic Notation (at level 4) tactic4(Tac) "/" "sg" := (Tac /s/g). +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) 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) "/" "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. @@ -92,7 +94,7 @@ Module LegacyNotations. (* like !!tac + tries to subst with each new hypothesis. *) Tactic Notation "!!!" tactic3(Tac) := Tac/s/n?. (* Like !!! + regroup new Type-sorted hyps at top. *) - (* Tactic Notation (at level 4) "!!!!" tactic4(Tac) := Tac /s/n?/g. *) + Tactic Notation (at level 4) "!!!!" tactic4(Tac) := Tac /s/n?/g. (* Other Experimental combinations *) diff --git a/LibHyps/LibHypsTactics.v b/LibHyps/LibHypsTactics.v index 313cdcb..ca3c68e 100644 --- a/LibHyps/LibHypsTactics.v +++ b/LibHyps/LibHypsTactics.v @@ -5,249 +5,87 @@ Require Export LibHyps.TacNewHyps. Require Export LibHyps.LibHypsNaming. (* Require Export LibHyps.LibSpecialize. *) +Require Import Ltac2.Ltac2. +From Ltac2 Require Import Option Constr Printf. (* START DEBUG *) -(* -Module Prgoal_Notation. - Ltac pr_goal := - match goal with - |- ?g => - let allh := all_hyps in - idtac "[" allh " ⊢ " g "]" - 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. +(* +Require Import LibHypsDebug. + (* 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. + (pr_goal()). Abort. (* END DEBUG *) - *) - -(* TODO - -(* 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 +(* TODO *) + +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 - 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' + else if foundone then Some id + else find_above_which false t lH' + | [] => None 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. +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. +(* Ltac2 move_up (h:constr) := *) +(* match Constr.Unsafe.kind h with *) +(* | Constr.Unsafe.Var id => move_up_hyp id *) +(* | _ => Control.throw (Invalid_argument None) *) +(* end. *) -(* 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. +Ltac2 ltac1_move_up_types (h:Ltac1.t) := + let h: ident := Option.get (Ltac1.to_ident h) in + move_up_types h. -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. +Local Tactic Notation "Lmove_up_type" hyp(h) := + let tac := ltac2:(h |- ltac1_move_up_types h) in + tac h. -(* 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) - end. +Global Ltac move_up_types h := Lmove_up_type h. +Local Set Default Proof Mode "Classic". (* (* Tests *) +Require Import LibHyps.LibHyps. Export TacNewHyps.Notations. Goal forall x1 x3:bool, forall a z e : nat, z+e = a @@ -259,25 +97,47 @@ Goal forall x1 x3:bool, forall a z e : nat, Proof. (* Set Ltac Debug. *) (* then_nh_rev ltac:(intros) ltac:(subst_or_idtac). *) - intros ; {! group_up_list }. + intros ; {< move_up_types }. (* intros ? ? ? ? ? ? ? ? ? ?. *) (* group_up_list (DCons bool b1 DNil). *) Undo. intros ; { move_up_types }. Undo. - intros ; { autorename }; {! group_up_list }. + intros ; { autorename }; {< move_up_types }. Undo. - intros ; {subst_or_idtac} ; { autorename } ; {! group_up_list }. + intros ; {subst_or_idtac} ; { autorename } ; {< move_up_types }. 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 => autorename_strict h }. intros ; { fun h => idtac h }. intros ; { ltac:(fun h => idtac h) }. *) + +(* + +Goal forall x y:nat, x x+1 forall z:nat, forall a b : bool, forall n m p : nat, True. +Proof. + intros. + + progress (move_up_types z). + Fail progress (move_up_types z). + Fail progress (move_up_types H). + Fail progress (move_up_types H0). + + + let l:(ident * constr option * constr) list := (Control.hyps()) in + let idopt := find_above_which false constr:(nat) l in + match idopt with + | None => printf "None" + | Some id => printf "res = %I" id + end. + + Std.move ident:(z) (Std.MoveAfter ident:(H)). + + let l:(ident * constr option * constr) list := (Control.hyps()) in + let (h,_,_) := find_lowest constr:(nat) l in + printf "h = %I" h. *) diff --git a/tests/LibHypsRegression.v b/tests/LibHypsRegression.v index b357c7b..c2520d6 100644 --- a/tests/LibHypsRegression.v +++ b/tests/LibHypsRegression.v @@ -46,33 +46,6 @@ Ltac2 rename_hyp_3 n th := Ltac2 Set rename_hyp := rename_hyp_3. -(* -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`) - end. - -Ltac 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) - | _ => rename_hyp_2 n th (* call the previously defined tactic *) - end. - -Ltac rename_hyp ::= rename_hyp_3. -Ltac rename_depth ::= constr:(3). -*) Close Scope Z_scope. Open Scope nat_scope. Lemma dummy: forall x y, @@ -162,23 +135,23 @@ 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. -*) + Ltac2 rename_hyp_4 n th := match! th with diff --git a/tests/LibHypsTest.v b/tests/LibHypsTest.v index 78c2e60..38e9d0e 100644 --- a/tests/LibHypsTest.v +++ b/tests/LibHypsTest.v @@ -4,33 +4,43 @@ From Stdlib Require Import Arith ZArith List. Require Import LibHyps.LibHyps (*LibHyps.LibSpecialize*). +Require Import Ltac2.Ltac2. From Stdlib 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 n 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 93caba1..67b20da 100644 --- a/tests/demo.v +++ b/tests/demo.v @@ -203,10 +203,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 +267,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. - -Goal forall x y:nat, True. - intros. - (* computing a few names *) - (* Customize the starting depth *) +Ltac2 Set rename_hyp := rename_hyp_2. - 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 +316,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. From 1db5410f96a918cccdc20963a918e2f919b9b174 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Tue, 7 Apr 2026 14:12:39 +0200 Subject: [PATCH 11/15] Ltac2 tactics working. --- CHANGES.md | 87 ++- LibHyps/.filestoinstall | 1 - LibHyps/Especialize.v | 484 ++++++++++------ LibHyps/IdentParsing.v | 276 --------- LibHyps/LibEspecialize.v | 664 ---------------------- LibHyps/LibHyps.v | 2 +- LibHyps/LibHypsNaming.v | 12 +- LibHyps/LibSpecialize.v | 1043 ----------------------------------- LibHyps/TacNewHyps.v | 2 +- LibHyps/especialize_ltac2.v | 901 ------------------------------ LibHyps/ident_of_string.v | 353 ------------ README.md | 86 ++- TODO.md | 17 +- configure.sh | 6 +- testDebug.sh | 2 + tests/Especialize_tests.v | 42 +- tests/LibHypsTest.v | 2 +- tests/demo.v | 32 +- 18 files changed, 543 insertions(+), 3469 deletions(-) delete mode 100644 LibHyps/.filestoinstall delete mode 100644 LibHyps/IdentParsing.v delete mode 100644 LibHyps/LibEspecialize.v delete mode 100644 LibHyps/LibSpecialize.v delete mode 100644 LibHyps/especialize_ltac2.v delete mode 100644 LibHyps/ident_of_string.v diff --git a/CHANGES.md b/CHANGES.md index cc84073..aef0d04 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,26 +1,79 @@ +# 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. -# 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: +# Changes from 2.x to 4.x - + `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.` +# Changes from 1.x to 2.x - + 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 Syntax -## 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/Especialize.v b/LibHyps/Especialize.v index 8c15c92..0261af8 100644 --- a/LibHyps/Especialize.v +++ b/LibHyps/Especialize.v @@ -66,6 +66,61 @@ Proof. been specialized. *) Abort. +Lemma foo: forall x y : nat, (forall n m:nat, n < m -> n <= m -> forall p:nat, p > 0 -> p+1 = m+n) -> False. +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: *) + intro n. (*or refine (fun (n:nat) => _) *) + specialize (H n). + intro m. + specialize (H m). + + (* 1 more times, but more automatic *) + match type of H with + (forall nme:?t, _) => (intro nme) (*refine (fun nme:t => _)*); specialize (H nme) + end. + + (* We want to prove (n<=m) as a consequence of (n _) *) + specialize (H n). + specialize (newH n). (* we specialize both the initial hypothesis and the previously created one. *) + intro m. + specialize (H m). + specialize (newH m). + + (* 1 more times, but more automatic *) + match type of H with + (forall nme:?t, _) => (intro nme) (*refine (fun nme:t => _)*); specialize (H nme); specialize (newH nme) + end. + specialize (H newH). + exact H. + + +Abort. + + + + Local Ltac2 Type directarg := [ Quantif | QuantifIgnore | SubGoal | Evar(ident) ]. Local Ltac2 Type namearg := [ @@ -146,9 +201,16 @@ Local Ltac2 specialize_id_cstr (h:ident) (c:constr) : unit := (* 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 (h:ident) (ldirectarg:directarg list) (lnameargs:namearg list) - (lnumargs:numarg list) (n:int) := +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 @@ -156,72 +218,81 @@ Local Ltac2 rec refine_hd (h:ident) (ldirectarg:directarg list) (lnameargs:namea (* msgc th; *) match Unsafe.kind th with | Prod _ _ => - match ldirectarg with - | directarg::ldirectarg' => - match Unsafe.kind th with - | Prod bnd _ => - let h_premis := Constr.Binder.name bnd in - let typ_premis := Constr.Binder.type bnd in - let intronme:ident := - match h_premis with - None => Option.get (Ident.of_string "h_premis") - | Some idh => idh - end in - match directarg with - | Quantif => - intro_typed intronme typ_premis; - specialize_id_id h intronme; - refine_hd h ldirectarg' lnameargs lnumargs newn - | QuantifIgnore => - intro_typed intronme typ_premis; - specialize_id_id h intronme; - clear $intronme; - refine_hd h ldirectarg' lnameargs lnumargs newn - | Evar ename => - let ename := Fresh.in_goal ename in - mk_evar ename typ_premis; - (* let tac := ltac1:(ename typ_premis|- evar (ename:typ_premis)) in *) - (* tac (Ltac1.of_ident ename) (Ltac1.of_constr typ_premis) ; *) - specialize_id_id h ename; - subst $ename; - refine_hd h ldirectarg' lnameargs lnumargs newn - | SubGoal => - let gl := Fresh.in_goal @h in (* this uses base name "h" *) - (unshelve (epose (_:$typ_premis) as $gl)) > - [ | - let special := Control.hyp gl in - specialize_id_cstr h special; - refine_hd h ldirectarg' lnameargs lnumargs newn ] - end - | _ => invalid_arg "Not a product (directarg)" + 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 - | _ => - (* If this succeeds, never go back here from later backtrack. *) - Control.once - (fun () => Control.plus - (fun() => refine_hd_name h lnameargs lnumargs n) - (fun _ => - (* msgs "Backtracking from refine_hd_name "; *) - Control.plus - (fun () => refine_hd_num h lnameargs lnumargs n) - (fun _ => - (*msgs "Backtracking from refine_hd_num "; *) - refine_hd h [Quantif] lnameargs lnumargs n))) - + | _ => invalid_arg "Not a product (directarg)" end + | [] => + (* 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 | _ => (*base case *) match ldirectarg,lnameargs,lnumargs with | [],[],[] => exact $hc | [],[],[SubGoalAtAll] => exact $hc | _ => invalid_arg "Not a product (others)" end - (* (refine_hd_num (h:ident) (ldirectarg:directarg list) (lnameargs:namearg list) *) - (* (lnumargs:numarg list) (n:int)) *) end - with refine_hd_name (h:ident) (lnameargs:namearg list) + (* 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 (* h as a constr *) - let th:constr := Constr.type hc in (* type of h as a constr *) + let hc:constr := Control.hyp h in + let th:constr := Constr.type hc in match lnameargs with | namearg :: lnameargs' => match Unsafe.kind th with @@ -230,24 +301,27 @@ Local Ltac2 rec refine_hd (h:ident) (ldirectarg:directarg list) (lnameargs:namea match namearg with | SubGoalAtName nme => if map_default (Ident.equal nme) false h_premis - then refine_hd h [SubGoal] lnameargs' lnumargs n + 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 h [Evar nameevar] lnameargs' lnumargs n + 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 - with refine_hd_num (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' => + (* 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 @@ -256,7 +330,7 @@ Local Ltac2 rec refine_hd (h:ident) (ldirectarg:directarg list) (lnameargs:namea then backtrack "refine_hd_num: SubGoalAtNum, dep" else if Int.le newn num then if Int.equal newn num - then refine_hd h [SubGoal] lnameargs lnumargs' n + 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 => @@ -264,21 +338,22 @@ Local Ltac2 rec refine_hd (h:ident) (ldirectarg:directarg list) (lnameargs:namea then backtrack "refine_hd_num: SubGoalUntilNum, dep" else if Int.equal newn num - then refine_hd h [SubGoal] lnameargs lnumargs' n - else refine_hd h [SubGoal] lnameargs lnumargs n + 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 h [SubGoal] lnameargs lnumargs n + 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. *) -Local Ltac2 refine_spec h lnameargs lnumargs := refine_hd h [] lnameargs lnumargs 0. +Local Ltac2 refine_spec (only_premis:bool) h lnameargs lnumargs := refine_hd only_premis h [] lnameargs lnumargs 0. (* (* tests *) @@ -289,63 +364,19 @@ Axiom ex_hyp : (forall (b:bool), forall x: nat, eq_one 1 -> forall y:nat, eq_one Lemma test_esepec: True. Proof. - (* specialize ex_hyp as h. *) - (* especialize ex_hyp at 2 as h. *) specialize ex_hyp as H. - - ltac2:(assert_evar @hhh). - 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]) - | ]; - [ | match type of hhh 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]. - [ .. | match type of hhh 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]. - - -especialize ex_hyp at 3 with b,x,y as h; - Undo. - - -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. - - let ev1 := open_constr:(_) in - assert ev1. - - - ltac2:(refine_spec - (Option.get (Ident.of_string "H")) - [EvarAtName @m @m] - [SubGoalAtAll]). - Undo 1. - - (ltac2:(refine_hd - (Option.get (Ident.of_string "H")) - [] - [EvarAtName @m @m] - [SubGoalUntilNum 3] - 0)). - Undo 1. - - (ltac2:(refine_hd - (Option.get (Ident.of_string "H")) - [Evar @ev] - [EvarAtName @p @p ;SubGoalAtName @iii] - [SubGoalAtNum 4] - 0)). + [SubGoalAtNum 3;SubGoalAtNum 5]) + | ]. *) +(* num args should be sorted. *) Local Ltac2 cmp_numarg a b := match a with SubGoalAtNum na => @@ -362,7 +393,7 @@ 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 *) @@ -383,17 +414,28 @@ Local Ltac2 espec_gen (h:constr) lnames lnums name (replaceb:bool) := let h := dest_var h in match replaceb with true => - assert_evar name > [ (refine_spec h lnames lnums) + assert_evar name > [ (refine_spec false h lnames lnums) | Std.clear [h]; Std.rename [(name, h)] ] | false => - assert_evar name > [ (refine_spec h lnames lnums) | ] + 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 h' lnames lnums) | Std.clear [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 in + Std.specialize (h , Std.NoBindings) (Some (Std.IntroNaming (Std.IntroIdentifier h'))); + assert_evar name > [ (refine_spec true h' lnames lnums) | Std.clear [h'] ]). (* @@ -415,7 +457,11 @@ Proof. 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). - Undo 1. + 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). @@ -424,6 +470,28 @@ Proof. 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. + + + *) Local Ltac2 sgatnum_from_lint (li:int list): numarg list := @@ -450,6 +518,10 @@ Local Ltac2 espec_until_using_ltac1_gen (h:constr) (li:int list) (occsevar:ident let c1 := if atAll then [SubGoalAtAll] else sguntilnum_from_lid li in espec_gen h (evatname_from_lid occsevar) c1 newH replaceb. +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. + (* (* tests *) @@ -502,49 +574,44 @@ Proof. Undo 1. *) -Local 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)). +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) : int list := - List.map (fun x => Option.get (Ltac1.to_int x)) (Option.get (Ltac1.to_list li)). +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 := 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 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. (* 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 := 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 + 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. + + +(* call Ltac2'especialize on argscoming from Ltac1 notation *) +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 @@ -553,6 +620,76 @@ 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 *) +Tactic Notation "prove_premise" constr(h) "with" ne_ident_list_sep(levars,",") "at" int(n) "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 "prove_premise" constr(h) "at" int(n) "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 "prove_premise" constr(h) "at" int(n) "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. + +(* TODO only one integer, + evars + as => create a subgoal that wioll be added as hyp, h is not specialized *) +Tactic Notation "prove_premise" constr(h) "with" ne_ident_list_sep(levars,",") "at" int(n) := + 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. + +(* TODO only one integer, + evars + as => create a subgoal that wioll be added as hyp, h is not specialized *) +Tactic Notation "prove_premise" constr(h) "at" int(n) "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 "prove_premise" constr(h) "at" int(n) := + 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. + +(* 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. + 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. + + + + + +*) + + + (* ESPECIALIZE AT *) (* ********************* *) @@ -740,6 +877,36 @@ Tactic Notation "especialize" constr(h) "until" ne_integer_list_sep(li,",") := let nme := gen_hyp_name h in let levars := dummy_term in tac h li levars ident:(nme). +(* 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. + 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 *) @@ -756,7 +923,12 @@ Lemma foo: forall x y : nat, Proof. intros x y H. - especialize H with m,p at 2,4 as toto. + 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. 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/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 f600dda..8d22cbf 100644 --- a/LibHyps/LibHyps.v +++ b/LibHyps/LibHyps.v @@ -9,7 +9,7 @@ Require Export LibHyps.LibHypsTactics. (* We export ; { } etc. ";;" also. *) -Ltac rename_or_revert H := autorename_strict H + revert dependent H. +Ltac rename_or_revert H := autorename_strict H + generalize dependent H. (* Some usual tactics one may want to use on new hyps. *) diff --git a/LibHyps/LibHypsNaming.v b/LibHyps/LibHypsNaming.v index f64ebff..7a77788 100644 --- a/LibHyps/LibHypsNaming.v +++ b/LibHyps/LibHypsNaming.v @@ -18,7 +18,7 @@ Require Import Ltac2.Ltac2. From Ltac2 Require Import Option Constr Printf. Import Constr.Unsafe. Local Set Default Proof Mode "Classic". -Require Import LibHyps.LibHypsDebug. +(* 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 _ => ()). @@ -73,6 +73,7 @@ Ltac2 exists_prefix() := "ex". 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". @@ -101,6 +102,7 @@ Ltac2 Set rename_hyp := rename_hyp_3. >> *) (* This one is similar but for internal use *) +#[warnings="-ltac2-unused-variable"] Ltac2 mutable rename_hyp_default (n:int) (th:constr): rename_directives := backtrack "rename_hyp_default". Module Ltac2. @@ -144,7 +146,6 @@ Ltac2 string_first (p:char -> bool) (s:string) : int := Ltac2 Eval (string_first (fun c => Int.equal (Char.to_int c) (codepercent())) "xxxcc"). Ltac2 string_shorten_percent (s:string) : string := - let lgth := String.length s in let i := string_first (fun c => Int.equal (Char.to_int c) (codepercent())) s in String.sub s 0 i. @@ -371,7 +372,7 @@ with rename_hyp_chained_quantifs stop (acc:string list ref) (th:constr) : unit : 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 - (in_context nme typ tac_under_binder); + let _ := in_context nme typ tac_under_binder in () else rename_hyp_chained_quantifs stop acc subth @@ -397,7 +398,7 @@ with fallback_rename_hyp_quantif stop (acc:string list ref) (th:constr) : unit : 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 - (in_context nme typ tac_under_binder); + let _ := in_context nme typ tac_under_binder in () else @@ -460,7 +461,7 @@ with interp_directive stop acc d := kept *) Ltac2 in_context_then_forget nme typ f := Control.once_plus - (fun () => in_context nme typ f; backtrack "forget in_context subgoal") + (fun () => let _ := in_context nme typ f in backtrack "forget in_context subgoal") (fun _ => ()). Ltac2 rename_acc n th := @@ -485,6 +486,7 @@ Ltac2 fallback_rename_hyp_name th: ident := (* 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"] Ltac2 rename_hyp_with_name h th := fail. (* Tactic renaming hypothesis H. Ignore Type-sorted hyps, fails if no 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 416d204..90567b9 100644 --- a/LibHyps/TacNewHyps.v +++ b/LibHyps/TacNewHyps.v @@ -35,7 +35,7 @@ Require Import Ltac2.Ltac2. From Ltac2 Require Import Option Constr Printf. Import Constr.Unsafe. Local Set Default Proof Mode "Classic". -Require Import LibHyps.LibHypsDebug. +(* Require Import LibHyps.LibHypsDebug. *) (* Utilities *) Local Ltac2 is_dep_prod (t:constr): bool := 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/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 4904fe4..cdd2eac 100755 --- a/configure.sh +++ b/configure.sh @@ -14,7 +14,7 @@ case $key in STDLIB=$1 shift ;; - --dev) + -dev|--dev) DEVOPT=yes shift ;; @@ -65,9 +65,9 @@ function gen_projet_file () { if [ "$DEVOPT" = "no" ] then - FILESLH=$(cd LibHyps && find . -name "*.v" | grep -v "ident_of_string\|especialize_ltac2\|LibEspecialize\|LibHypsDebug" ) + FILESLH=$(cd LibHyps && find . -name "*.v" | grep -v "LibHypsDebug" ) else - FILESLH=$(cd LibHyps && find . -name "*.v" | grep -v "ident_of_string\|especialize_ltac2\|LibEspecialize" ) + FILESLH=$(cd LibHyps && find . -name "*.v" ) fi PROJECTDIRLH="LibHyps" diff --git a/testDebug.sh b/testDebug.sh index b7cc63c..49a521e 100755 --- a/testDebug.sh +++ b/testDebug.sh @@ -14,8 +14,10 @@ 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 diff --git a/tests/Especialize_tests.v b/tests/Especialize_tests.v index 4a3fa03..e50eee0 100644 --- a/tests/Especialize_tests.v +++ b/tests/Especialize_tests.v @@ -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/LibHypsTest.v b/tests/LibHypsTest.v index 38e9d0e..634690f 100644 --- a/tests/LibHypsTest.v +++ b/tests/LibHypsTest.v @@ -9,7 +9,7 @@ From Stdlib Require Import List. Import ListNotations. -Ltac2 rename_hyp_2 n th := +Ltac2 rename_hyp_2 _ th := match! th with | true <> false => [ String "tNEQf" ] | true = false => [ String "tEQf" ] diff --git a/tests/demo.v b/tests/demo.v index 67b20da..b1fd18b 100644 --- a/tests/demo.v +++ b/tests/demo.v @@ -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). *) From a78546b63d9d0470aa07d787411b0ab8774c8b9d Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Tue, 7 Apr 2026 14:49:49 +0200 Subject: [PATCH 12/15] coq 8.20 compatibility. Although coq 8.20 is not officially supported, this is almost costless. 8.18 fails to compile though. --- .github/workflows/ci-libhyps.yml | 1 + LibHyps/Especialize.v | 2 +- LibHyps/LibHypsNaming.v | 4 ++-- configure.sh | 18 ++++++++++++++++-- resources/coq_project.libhyps | 3 +++ resources/coq_project.tests | 2 ++ tests/LibHypsRegression.v | 2 +- tests/LibHypsTest.v | 4 ++-- tests/demo.v | 2 +- 9 files changed, 29 insertions(+), 9 deletions(-) diff --git a/.github/workflows/ci-libhyps.yml b/.github/workflows/ci-libhyps.yml index e17cf86..6bf1bde 100644 --- a/.github/workflows/ci-libhyps.yml +++ b/.github/workflows/ci-libhyps.yml @@ -29,6 +29,7 @@ jobs: - 'rocq/rocq-prover:latest' - 'rocq/rocq-prover:dev' - 'rocq/rocq-prover:9.1' + - 'rocq/rocq-prover:9.2' - 'rocq/rocq-prover:9.0' # Steps represent a sequence of tasks that will be executed as part of the job steps: diff --git a/LibHyps/Especialize.v b/LibHyps/Especialize.v index 0261af8..6b6fda5 100644 --- a/LibHyps/Especialize.v +++ b/LibHyps/Especialize.v @@ -1,4 +1,5 @@ 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". @@ -398,7 +399,6 @@ Local Ltac2 sort_numargs (l: numarg list): numarg list:= List.sort cmp_numarg l. replacing h or naming the new hyp. *) (* Precondition: name is already fresh *) -From Stdlib Require Sorting.Mergesort Structures.OrdersEx. Local Ltac2 dest_var (c:constr) : ident := diff --git a/LibHyps/LibHypsNaming.v b/LibHyps/LibHypsNaming.v index 7a77788..136ac21 100644 --- a/LibHyps/LibHypsNaming.v +++ b/LibHyps/LibHypsNaming.v @@ -9,7 +9,7 @@ Comments welcome. *) -From Stdlib Require Import Arith ZArith List. +Require Import Arith ZArith List. Require LibHyps.TacNewHyps. (* Import ListNotations. *) @@ -25,7 +25,7 @@ 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. Ltac2 decr (n:int):int := if Int.equal n 0 then 0 else Int.sub n 1. diff --git a/configure.sh b/configure.sh index cdd2eac..8d87ac6 100755 --- a/configure.sh +++ b/configure.sh @@ -58,8 +58,22 @@ function gen_projet_file () { cat < $PROJECTFILE - echo "Calling rocq makefile in $DIR" - (cd $DIR && rocq makefile -f _CoqProject -o Makefile ) + which -s rocq ; rocqexists=$? + if [ $rocqexists -eq 0 ] + then + echo "Calling rocq makefile in $DIR" + (cd $DIR && rocq makefile -f _CoqProject -o Makefile ) + else + which -s 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 } 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/tests/LibHypsRegression.v b/tests/LibHypsRegression.v index c2520d6..f3b43fc 100644 --- a/tests/LibHypsRegression.v +++ b/tests/LibHypsRegression.v @@ -7,7 +7,7 @@ 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". diff --git a/tests/LibHypsTest.v b/tests/LibHypsTest.v index 634690f..70827ef 100644 --- a/tests/LibHypsTest.v +++ b/tests/LibHypsTest.v @@ -2,10 +2,10 @@ 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*). Require Import Ltac2.Ltac2. -From Stdlib Require Import List. +Require Import List. Import ListNotations. diff --git a/tests/demo.v b/tests/demo.v index b1fd18b..ed22e97 100644 --- a/tests/demo.v +++ b/tests/demo.v @@ -16,7 +16,7 @@ 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, From 4d3dcc9c847fed405ecb04040487b742094ae772 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Wed, 8 Apr 2026 17:58:38 +0200 Subject: [PATCH 13/15] Syntax "assert premise 3 of h." instead of "prove_premise H at 3". This hypothesis needs to allow to ignore some hypothesis. Work in progress. --- .github/workflows/ci-libhyps.yml | 1 - CHANGES.md | 10 +- LibHyps/Especialize.v | 396 ++++++----- LibHyps/LibDecomp.v | 47 -- LibHyps/LibHyps.v | 104 +-- LibHyps/LibHypsNaming.v | 1091 ++++++++++-------------------- LibHyps/LibHypsTactics.v | 121 +--- tests/LibHypsRegression.v | 54 +- 8 files changed, 686 insertions(+), 1138 deletions(-) delete mode 100644 LibHyps/LibDecomp.v diff --git a/.github/workflows/ci-libhyps.yml b/.github/workflows/ci-libhyps.yml index 6bf1bde..e17cf86 100644 --- a/.github/workflows/ci-libhyps.yml +++ b/.github/workflows/ci-libhyps.yml @@ -29,7 +29,6 @@ jobs: - 'rocq/rocq-prover:latest' - 'rocq/rocq-prover:dev' - 'rocq/rocq-prover:9.1' - - 'rocq/rocq-prover:9.2' - 'rocq/rocq-prover:9.0' # Steps represent a sequence of tasks that will be executed as part of the job steps: diff --git a/CHANGES.md b/CHANGES.md index aef0d04..f144bc4 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,5 @@ # 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 @@ -46,9 +45,16 @@ Local Set Default Proof Mode "Classic". (* This restores ltac1 proof mode. *) 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 2.x to 4.x # Changes from 1.x to 2.x diff --git a/LibHyps/Especialize.v b/LibHyps/Especialize.v index 6b6fda5..95799f8 100644 --- a/LibHyps/Especialize.v +++ b/LibHyps/Especialize.v @@ -62,12 +62,12 @@ 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. -Lemma foo: forall x y : nat, (forall n m:nat, n < m -> n <= m -> forall p:nat, p > 0 -> p+1 = m+n) -> False. +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. @@ -76,46 +76,15 @@ Proof. assert ev1 as newH. (* then we refine this unknown goal by mimick H until we reach the premise we want to remove: *) - intro n. (*or refine (fun (n:nat) => _) *) - specialize (H n). - intro m. - specialize (H m). - - (* 1 more times, but more automatic *) - match type of H with - (forall nme:?t, _) => (intro nme) (*refine (fun nme:t => _)*); specialize (H nme) - end. + (* ignore n, m n _) *) - specialize (H n). - specialize (newH n). (* we specialize both the initial hypothesis and the previously created one. *) - intro m. - specialize (H m). - specialize (newH m). - - (* 1 more times, but more automatic *) - match type of H with - (forall nme:?t, _) => (intro nme) (*refine (fun nme:t => _)*); specialize (H nme); specialize (newH nme) - end. - specialize (H newH). - exact H. + evar (p:nat). + assert (p >= 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. @@ -433,67 +402,13 @@ Local Ltac2 epremis_gen (h:constr) lnames (num:numarg) name := let h := dest_var h in assert_evar name > [ (refine_spec true h lnames lnums) | ] else - (let h' := Fresh.in_goal @H in + 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'] ]). - + + assert_evar name > [ (refine_spec true h' lnames lnums) | Std.clear [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. - - 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. - -*) - Local Ltac2 sgatnum_from_lint (li:int list): numarg list := List.map (fun i => SubGoalAtNum i) li. @@ -518,62 +433,13 @@ Local Ltac2 espec_until_using_ltac1_gen (h:constr) (li:int list) (occsevar:ident 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. -(* -(* 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. -*) - Local Ltac2 interp_ltac1_id_list (lid:Ltac1.t list) : ident list := List.map (fun x => Option.get (Ltac1.to_ident x)) lid. @@ -603,93 +469,107 @@ Local Ltac2 call_specialize_until_ltac2_gen (h:Ltac1.t) li levars newh replaceb else 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.*) - -(* call Ltac2'especialize on argscoming from Ltac1 notation *) +(* 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_" | |- _ => fresh "H_spec_" 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 *) -Tactic Notation "prove_premise" constr(h) "with" ne_ident_list_sep(levars,",") "at" int(n) "as" ident(newH) := +(* 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 "prove_premise" constr(h) "at" int(n) "with" ne_ident_list_sep(levars,",") "as" ident(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. -Tactic Notation "prove_premise" constr(h) "at" int(n) "as" ident(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 levars := dummy_term in (* something that is not a list. *) + let newH := fresh "HHH" in tac h n levars newH. -(* TODO only one integer, + evars + as => create a subgoal that wioll be added as hyp, h is not specialized *) -Tactic Notation "prove_premise" constr(h) "with" ne_ident_list_sep(levars,",") "at" int(n) := +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 newH := dummy_term 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 "prove_premise" constr(h) "at" int(n) "with" ne_ident_list_sep(levars,",") := +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 "prove_premise" constr(h) "at" int(n) := +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. -(* TEST *) + + (* +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_eqone. - 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. } + 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. - prove_premise h_eqone at 3. - { admit. } + 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 *) (* ********************* *) @@ -877,8 +757,156 @@ Tactic Notation "especialize" constr(h) "until" ne_integer_list_sep(li,",") := let nme := gen_hyp_name h in let levars := dummy_term in tac h li levars ident:(nme). + + + + +(* +(* 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. 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/LibHyps.v b/LibHyps/LibHyps.v index 8d22cbf..d6f4bcd 100644 --- a/LibHyps/LibHyps.v +++ b/LibHyps/LibHyps.v @@ -6,37 +6,21 @@ Require Export LibHyps.TacNewHyps. Require Export LibHyps.LibHypsNaming. Require Export LibHyps.Especialize. Require Export LibHyps.LibHypsTactics. -(* We export ; { } etc. ";;" also. *) - - -Ltac rename_or_revert H := autorename_strict H + generalize dependent H. (* Some usual tactics one may want to use on new hyps. *) -(* 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 := - 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 y; try clear H])) - | _ => idtac - end. - +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 @@ -56,16 +40,8 @@ Tactic Notation (at level 4) tactic4(Tac) "/" "r" := Tac ; {< revertHyp }. Tactic Notation (at level 4) "/" "r" := (onAllHypsRev revertHyp). Tactic Notation (at level 4) tactic4(Tac) "/" "g" := Tac ; { move_up_types }. -(* Tactic Notation (at level 4) tactic4(Tac) "/" "g" := Tac ; {! group_up_list }. *) -(* -(* 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" := (onAllHyps move_up_types). -(* Not yet reimplemented in ltac2 *) -Tactic Notation (at level 4) "/" "g" := (group_up_list all_hyps). -*) -(* 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). @@ -105,75 +81,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. - 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. *) - Fail (intros ; { fun h => autorename_strict h }). - intros ; { fun h => autorename_orelse_revert h }. - match goal with - | |- (fun _ : bool => z = e) true -> True => idtac - end. - Undo 2. - intros ; { fun h => idtac h }. - Undo. - intros ; { ltac:(fun h => idtac 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/LibHypsNaming.v b/LibHyps/LibHypsNaming.v index 136ac21..9ba2f9e 100644 --- a/LibHyps/LibHypsNaming.v +++ b/LibHyps/LibHypsNaming.v @@ -37,13 +37,14 @@ Ltac2 Type rename_directives := rename_directive list. (* 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. + 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. + Ltac2 Type hypnames := string list. (** This determines the depth of the recursive analysis of a type to @@ -102,55 +103,55 @@ Ltac2 Set rename_hyp := rename_hyp_3. >> *) (* This one is similar but for internal use *) -#[warnings="-ltac2-unused-variable"] +#[global,warnings="-ltac2-unused-variable"] Ltac2 mutable rename_hyp_default (n:int) (th:constr): rename_directives := backtrack "rename_hyp_default". 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 "")). + (* 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 "")). -Ltac2 build_name (l:string list): string := build_name_gen "_" add_prefix add_suffix (List.rev l). + Ltac2 build_name (l:string list): string := build_name_gen "_" add_prefix add_suffix (List.rev l). -Ltac2 string_of_int (i:int) := Message.to_string (Message.of_int i). + Ltac2 string_of_int (i:int) := Message.to_string (Message.of_int i). -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 + 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. + check 0. -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). + 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). -Ltac2 is_digit (c:char): bool := - let code := Char.to_int c in - Bool.and (Int.le (code0()) code) (Int.le code (code9())). + Ltac2 is_digit (c:char): bool := + let code := Char.to_int c in + Bool.and (Int.le (code0()) code) (Int.le code (code9())). -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 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"). + Ltac2 Eval (string_first (fun c => Int.equal (Char.to_int c) (codepercent())) "xxxcc"). -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. + 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 @@ -158,383 +159,381 @@ Ltac2 string_shorten_percent (s:string) : string := that every hyp name ends with "_", so that coq never mangle with the digits *) -(* FIXME: this relies on printf to build a string from a constr in + (* 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". - - -(* FIXME: find something better to detect implicits!! *) -(* Determines the number of non "head" implicit arguments, i.e. implicit + 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". + + + (* 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. + 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. -Ltac2 arobase():char := (Char.of_int 64). + Ltac2 arobase():char := (Char.of_int 64). -(** Build a chunk from a simple term: either a number or a freshable + (** 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. + 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. -Local Ltac2 is_dep_prod (t:constr): bool := - match kind t with - | Prod _ subt => Bool.neg (is_closed subt) - | _ => false - 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. + 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 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 + 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 + 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 := + (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 - -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 + let _ := in_context nme typ tac_under_binder in + () + else + rename_hyp_chained_quantifs stop acc subth + | _ => fallback_rename_hyp stop acc th + end + + 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" + (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 - | _ => backtrack "no quantif" - 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 + 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 + 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 + 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"] -Ltac2 rename_hyp_with_name h th := fail. + #[warnings="-ltac2-unused-variable"] + Local Ltac2 rename_hyp_with_name h th := fail. -(* Tactic renaming hypothesis H. Ignore Type-sorted hyps, fails if no + (* Tactic renaming hypothesis H. Ignore Type-sorted hyps, fails if no renaming can be computed. Example of failing type: H:((fun x => True) true). *) -#[global] -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 *) + 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. - -(* Tactic renaming hypothesis H. *) - -Local Ltac2 ltac2_autorename (h:ident) := - control_try (fun () => autorename_strict h). - -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. - -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)). + | 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. + + (* Tactic renaming hypothesis H. *) + + Local Ltac2 ltac2_autorename (h:ident) := + control_try (fun () => autorename_strict h). + + 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. + + 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)). End Ltac2. @@ -549,359 +548,17 @@ Ltac2 Set rename_hyp_default := | (@None _) => [String "None"] end. -(* This may be due to the definition of ltac1_autorename which uses - Ltac1.to_ident, but this is the only way I found to have - "autorename h" be callable from ltac1: make it a notation expecting - an ident, and then define a tactic using this notation. If I define - directly the tatic autorename instead of a notation, then it does - not accept "autorename id". *) -(* to reproduce: -Ltac2 ltac1_autorename (h:Ltac1.t) := - let h: ident := Option.get (Ltac1.to_ident h) in - ltac2_autorename h. - -Global Ltac autorename h := - let tac := ltac2:(h |- Ltac2.ltac1_autorename h) in - tac h. - -Goal 1 = 2 -> False. -Proof. - intros H. - autorename H. (* Ltac1.to_ident fails with Ltac2 exception: No_value *) - -More generally to reproduce: - -Ltac2 ltac2_mytac (id:ident) := printf "%I" id. - -Ltac2 ltac1_mytac (h:Ltac1.t) := - let h: ident := Option.get (Ltac1.to_ident h) in - ltac2_mytac h. - -Global Ltac mytac h := - let tac := ltac2:(h |- ltac1_mytac h) in - tac h. - -Local Set Default Proof Mode "Classic". - -Goal 1 = 2 -> False. -Proof. - intros H. - Fail mytac H. (* Ltac1.to_ident fails with Ltac2 exception: No_value *) -Abort. - -(* Solution *) -Tactic Notation "XXXmytac" hyp(h) := - let tac := ltac2:(h |- ltac1_mytac h) in - tac h. - -Ltac mytac' h := XXXmytac h. - - -Goal 1 = 2 -> False. -Proof. - intros H. - mytac' H. - -*) - - Local Tactic Notation "Lautorename" hyp(h) := let tac := ltac2:(h |- Ltac2.ltac1_autorename h) in tac h. -Global Ltac autorename h := Lautorename h. - Local Tactic Notation "Lautorename_strict" hyp(h) := let tac := ltac2:(h |- Ltac2.ltac1_autorename_strict h) in tac h. -Global Ltac autorename_strict h := Lautorename_strict h. - -(* -(* ********** EXAMPLE CUSTOMIZATION ********** *) - -(* TESTS *) - -(* This settings should reproduce the naming scheme of libhypps-1.0.0 - and libhypps-1.0.1. *) -Ltac2 Set add_suffix := false. -Ltac2 Set numerical_sufx := true. - -(* This should maybe be by default *) -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. - -(* From there this is LibHypTest from 1f7a1ed2289e439c291fcbd06c51705547feef1e *) -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. - -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. - -Ltac2 Set rename_depth := 3. -Import TacNewHyps.Notations. -Close Scope Z_scope. -Open Scope nat_scope. - -Lemma dummy: forall x y, - 0 <= 1 -> - (0%Z <= 1%Z)%Z -> - x <= y -> - x = y -> - Some x = Some y -> - 0 = 1 -> - 223 = 426 -> - (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 -> - true = Nat.leb 3 4 -> - 1 = 0 -> - ~x = y -> - ~1 < 0 -> - (forall w w':nat , w = w' -> ~true=false) -> - (forall w w':nat , w = w' -> true=false /\ True) -> - (forall w w':nat , w = w' -> False /\ True) -> - (exists w:nat , w = w -> ~(true=(andb false true)) /\ False) -> - (exists w:nat , w = w -> True /\ False) -> - (forall w w':nat , w = w' -> true=false) -> - (forall w w':nat , w = w' -> Nat.eqb 3 4=Nat.eqb 4 3) -> - List.length (cons 3 nil) = (fun x => 0)1 -> - List.length (cons 3 nil) = 0 -> - plus 0 y = y -> - (true=false) -> - (False -> (true=false)) -> - forall (x : nat) (env : list nat), - ~ List.In x nil -> - cons x (cons 3 env) = cons 2 env -> - forall z t:nat, IDProp -> - (0 < 1 -> 0 < 0 -> true = false -> ~(true=false)) -> - (~(true=false)) -> - (forall w w',w < w' -> ~(true=false)) -> - (0 < 1 -> ~(1<0)) -> - (0 < 1 -> 1<0) -> 0 < z -> True. -Proof. - intros x y H. - autorename H. - Undo 2. - intros;{ autorename }. - - match type of x with nat => idtac | _ => fail "test failed!" end. - match type of y with nat => idtac | _ => fail "test failed!" end. - match type of h_le_0n_1n with 0 <= 1 => idtac | _ => fail "test failed!" end. - match type of h_le_0z_1z with (0 <= 1)%Z => idtac | _ => fail "test failed!" end. - match type of h_le_x_y with x <= y => idtac | _ => fail "test failed!" end. - match type of h_eq_x_y with x = y => idtac | _ => fail "test failed!" end. - match type of h_eq_223n_426n with 223 = 426 => idtac | _ => fail "test failed!" end. - match type of h_eq_0n_1n with 0 = 1 => idtac | _ => fail "test failed!" end. - match type of h_eq_0z_1z with 0%Z = 1%Z => idtac | _ => fail "test failed!" end. - 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_add_x_3n_4n with (x + 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. - match type of h_eq_cons_x0_3n_cons_2n with x0 :: 3 :: env = 2 :: env => idtac | _ => fail "test failed!" end. - - match type of h_all_and_False_True with forall w w' : nat, w = w' -> False /\ True => idtac | _ => fail "test failed!" end. - match type of h_ex_and_neq_False with exists w : nat, w = w -> true <> (false && true)%bool /\ False => idtac | _ => fail "test failed!" end. - 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_1n with length (3::nil) = (fun _ : nat => 0) 1 => idtac | _ => fail "test failed!" end. *) - match type of h_eq_length_cons_0n with length (3::nil) = 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. - match type of h_impl_tEQf with False -> true = false => idtac | _ => fail "test failed!" end. - match type of x0 with nat => idtac | _ => fail "test failed!" end. - match type of env with list nat => idtac | _ => fail "test failed!" end. - match type of h_not_In_x0_nil with ~ In x0 nil => idtac | _ => fail "test failed!" end. - match type of h_eq_cons_x0_3n_cons_2n with x0 :: 3 :: env = 2 :: env => idtac | _ => fail "test failed!" end. - match type of h_IDProp with IDProp => idtac | _ => fail "test failed!" end. - match type of h_impl_tNEQf with 0 < 1 -> 0 < 0 -> true = false -> true <> false => idtac | _ => fail "test failed!" end. - match type of h_tNEQf with true <> false => idtac | _ => fail "test failed!" end. - match type of h_all_tNEQf0 with forall w w' : nat, w < w' -> true <> false => idtac | _ => fail "test failed!" end. - 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. - exact I. -Qed. - - - - - -(* Ltac autorename h := *) - (* let tac := ltac2:(h |- ltac2_autorename h) in *) - (* tac h. *) - - (* Unset Printing Notations. *) - -(* Ltac2 Eval (count_impl constr:(3 + 4)). *) - -Import TacNewHyps.Notations. -Parameters X Y: nat -> Prop. -Parameters PX: X 3. -Parameters PY: Y 3. - -Local Ltac rename_or_revert H := autorename_strict H + (try revert H). - -Goal forall [A : Type] (P Q : A -> Prop) (x : A), P x -> Q x -> (exists2 x : A, P x & Q x) -> ((fun x => x = x) 1) -> ex2 P Q -> False. - - intros A P Q x H H0 H1 HH H2. - - autorename H1. - autorename H2. - autorename H. - autorename H0. - Fail autorename_strict HH. - rename_or_revert HH. - intros ; { rename_or_revert }. - Fail intros ; { autorename_strict }. - - - ltac2:(let l := Ltac2.rename_acc 3 constr:(exists2 x0 : A, P x0 & Q x0) in - printf "BEFORE BUILDNAME %a " (pr_list pr_string) l; - let nme := Ltac2.build_name l in - printf "%s" nme). - ltac2:(let l := Ltac2.rename_acc 9 constr:(ex2 P Q) in - printf "BEFORE BUILDNAME %a " (pr_list pr_string) l; - let nme := Ltac2.build_name l in - printf "%s" nme). -Abort. +(* GLOBAL TACTICS *) -Definition foo := (fun a b:bool => a = b). - -Goal forall n m p : nat, forall b:bool, n m<= p -> True . -Proof. - intros n m p b H H0. - - assert (forall z, foo b z). - 2:{ } - - ltac2:(let l := rename_acc 4 constr:(forall b:nat, Nat.clearbit b 4%nat = 0) in - printf "BEFORE BUILDNAME"; - let nme := build_name l in - printf "%s" nme). - - Unset Printing Notations. - - - - - ltac2:(let l := rename_acc 9 constr:(Nat.clearbit n m = p) in - printf "BEFORE BUILDNAME %a " (pr_list pr_string) l; - let nme := build_name l in - printf "%s" nme). - - ltac2:(let l := rename_acc 3 constr:(Nat.clearbit 3 4%nat = 0) in - printf "BEFORE BUILDNAME"; - let nme := build_name l in - printf "%s" nme). - - ltac2:(let l := rename_acc 4 constr:(Nat.clearbit 3 4%nat = 0 -> Nat.clearbit 3 4%nat = 7) in - printf "BEFORE BUILDNAME"; - let nme := build_name l in - printf "%s" nme). - - ltac2:(let l := rename_acc 3 constr:(forall x:nat, Nat.clearbit x 4%nat = 0) in - printf "BEFORE BUILDNAME"; - let nme := build_name l in - printf "%s" nme). - - ltac2:(let l := rename_acc 3 constr:(forall b:nat, Nat.clearbit b 4%nat = 0) in - printf "BEFORE BUILDNAME"; - let nme := build_name l in - printf "%s" nme). - - - ltac2:(let l := rename_acc 4 constr:(forall b:nat, Nat.clearbit b 4%nat = 0) in - printf "BEFORE BUILDNAME"; - let nme := build_name l in - printf "%s" nme). - - ltac2:(let l := rename_acc 4 constr:(forall x:nat, Nat.clearbit x 4%nat = 0) in - printf "BEFORE BUILDNAME"; - let nme := build_name l in - printf "%s" nme). - - ltac2:(let l := rename_acc 4 constr:(forall x:Z, BinIntDef.Z.quot x x = 1%Z) in - printf "BEFORE BUILDNAME"; - let nme := build_name l in - printf "%s" nme). - - - ltac2:(let l := rename_acc 4 constr:(Nat.clearbit 3%nat 4%nat) in - let nme := build_name l in - printf "%s" nme). -Abort. - - -*) - -(* -(* 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. +Global Ltac autorename h := Lautorename h. -Ltac rename_hyp n th ::= - match th with - | _ => rename_hyp1 n th - end. +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 ca3c68e..dda25c9 100644 --- a/LibHyps/LibHypsTactics.v +++ b/LibHyps/LibHypsTactics.v @@ -2,30 +2,9 @@ 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. -From Ltac2 Require Import Option Constr Printf. -(* START DEBUG *) -(* -Require Import LibHypsDebug. - - - - (* example: *) -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()). -Abort. - -(* END DEBUG *) -*) - -(* TODO *) +(* HYPS GROUPING *) Ltac2 rec find_above_which (foundone:bool) (t:constr) (lH:(ident * constr option * constr) list): ident option := @@ -65,12 +44,6 @@ Ltac2 move_up_types (h:ident) := else Std.move h (Std.MoveAfter aboveh) end. -(* Ltac2 move_up (h:constr) := *) -(* match Constr.Unsafe.kind h with *) -(* | Constr.Unsafe.Var id => move_up_hyp id *) -(* | _ => Control.throw (Invalid_argument None) *) -(* end. *) - Ltac2 ltac1_move_up_types (h:Ltac1.t) := let h: ident := Option.get (Ltac1.to_ident h) in move_up_types h. @@ -79,65 +52,45 @@ Local Tactic Notation "Lmove_up_type" hyp(h) := let tac := ltac2:(h |- ltac1_move_up_types h) in tac h. -Global Ltac move_up_types h := Lmove_up_type h. - - -Local Set Default Proof Mode "Classic". -(* -(* Tests *) -Require Import LibHyps.LibHyps. -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 ; {< move_up_types }. - (* intros ? ? ? ? ? ? ? ? ? ?. *) - (* group_up_list (DCons bool b1 DNil). *) - Undo. - intros ; { move_up_types }. - Undo. - intros ; { autorename }; {< move_up_types }. - Undo. - intros ; {subst_or_idtac} ; { autorename } ; {< move_up_types }. - Undo. - Fail progress intros ; { revertHyp }. - intros. - then_eachnh ltac:(intros) ltac:(subst_or_idtac). - Undo. - intros ; { fun h => autorename_strict h }. - intros ; { fun h => idtac h }. - intros ; { ltac:(fun h => idtac h) }. -*) +(* GLOBAL TACTICS *) -(* +Global Ltac move_up_types h := Lmove_up_type h. -Goal forall x y:nat, x x+1 forall z:nat, forall a b : bool, forall n m p : nat, True. -Proof. - intros. - - progress (move_up_types z). - Fail progress (move_up_types z). - Fail progress (move_up_types H). - Fail progress (move_up_types H0). - +(* 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 *) +Global 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 y; try clear H])) + | _ => idtac + end. - let l:(ident * constr option * constr) list := (Control.hyps()) in - let idopt := find_above_which false constr:(nat) l in - match idopt with - | None => printf "None" - | Some id => printf "res = %I" id +(* 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. - Std.move ident:(z) (Std.MoveAfter ident:(H)). - let l:(ident * constr option * constr) list := (Control.hyps()) in - let (h,_,_) := find_lowest constr:(nat) l in - printf "h = %I" h. -*) diff --git a/tests/LibHypsRegression.v b/tests/LibHypsRegression.v index f3b43fc..2b1019f 100644 --- a/tests/LibHypsRegression.v +++ b/tests/LibHypsRegression.v @@ -129,10 +129,32 @@ 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. - exact I. -Qed. + 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. @@ -152,6 +174,33 @@ Proof. exact I. Qed. +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. + assert premise 1 of min_l with a,b . + { 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. + Ltac2 rename_hyp_4 n th := match! th with @@ -161,7 +210,6 @@ Ltac2 rename_hyp_4 n th := Ltac2 Set rename_hyp := rename_hyp_4. -Require Import LibHyps.LibDecomp. 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. From a67e22d067b84365ad5430d54a17c1861970b67b Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Wed, 8 Apr 2026 18:43:24 +0200 Subject: [PATCH 14/15] Fix CI. configure.sh was using an non-standard "which" option. --- .github/workflows/ci-libhyps.yml | 1 + configure.sh | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) 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/configure.sh b/configure.sh index 8d87ac6..ebfbac4 100755 --- a/configure.sh +++ b/configure.sh @@ -58,13 +58,13 @@ function gen_projet_file () { cat < $PROJECTFILE - which -s rocq ; rocqexists=$? + command -v rocq ; rocqexists=$? if [ $rocqexists -eq 0 ] then echo "Calling rocq makefile in $DIR" (cd $DIR && rocq makefile -f _CoqProject -o Makefile ) else - which -s coqc ; coqexists=$? + command -v coqc ; coqexists=$? if [ $coqexists -eq 0 ] then echo "Calling coq_makefile in $DIR" From 9c7f1cbc052da6fcf43da18961ecc6d2b46c2e2d Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Fri, 10 Apr 2026 17:29:57 +0200 Subject: [PATCH 15/15] tactic "assert premise 2 of h with ....". --- LibHyps/AssertPremise.v | 288 ++++++++++++++++++++++++++++++++++++ LibHyps/LibHyps.v | 1 + LibHyps/LibHypsDebug.v | 2 + tests/LibHypsRegression.v | 27 ---- tests/test_assert_premise.v | 225 ++++++++++++++++++++++++++++ 5 files changed, 516 insertions(+), 27 deletions(-) create mode 100644 LibHyps/AssertPremise.v create mode 100644 tests/test_assert_premise.v 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/LibHyps.v b/LibHyps/LibHyps.v index d6f4bcd..f2a4176 100644 --- a/LibHyps/LibHyps.v +++ b/LibHyps/LibHyps.v @@ -5,6 +5,7 @@ Require Export LibHyps.TacNewHyps. Require Export LibHyps.LibHypsNaming. Require Export LibHyps.Especialize. +Require Export LibHyps.AssertPremise. Require Export LibHyps.LibHypsTactics. (* Some usual tactics one may want to use on new hyps. *) diff --git a/LibHyps/LibHypsDebug.v b/LibHyps/LibHypsDebug.v index 490c2d5..98b4e57 100644 --- a/LibHyps/LibHypsDebug.v +++ b/LibHyps/LibHypsDebug.v @@ -46,6 +46,8 @@ Ltac2 pr_binder () (b:binder):message := 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 diff --git a/tests/LibHypsRegression.v b/tests/LibHypsRegression.v index 2b1019f..122edfb 100644 --- a/tests/LibHypsRegression.v +++ b/tests/LibHypsRegression.v @@ -174,33 +174,6 @@ Proof. exact I. Qed. -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. - assert premise 1 of min_l with a,b . - { 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. - Ltac2 rename_hyp_4 n th := match! th with 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.