author | traytel |
Sun, 30 Sep 2012 12:08:16 +0200 | |
changeset 49667 | 44d85dc8ca08 |
parent 49641 | 9b831f93d4e8 |
child 51686 | 532e0ac5a66d |
permissions | -rw-r--r-- |
49509
163914705f8d
renamed top-level theory from "Codatatype" to "BNF"
blanchet
parents:
49504
diff
changeset
|
1 |
(* Title: HOL/BNF/Tools/bnf_wrap_tactics.ML |
49020
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
diff
changeset
|
2 |
Author: Jasmin Blanchette, TU Muenchen |
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
diff
changeset
|
3 |
Copyright 2012 |
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
diff
changeset
|
4 |
|
49074 | 5 |
Tactics for wrapping datatypes. |
49020
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
diff
changeset
|
6 |
*) |
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
diff
changeset
|
7 |
|
49074 | 8 |
signature BNF_WRAP_TACTICS = |
49020
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
diff
changeset
|
9 |
sig |
49148
93f281430e77
fixed "mk_alternate_disc_def_tac" in the case where the constructors are swapped compared with the common Nil/Cons case
blanchet
parents:
49137
diff
changeset
|
10 |
val mk_alternate_disc_def_tac: Proof.context -> int -> thm -> thm -> thm -> tactic |
49049 | 11 |
val mk_case_cong_tac: thm -> thm list -> tactic |
49594
55e798614c45
tweaked theorem names (in particular, dropped s's)
blanchet
parents:
49586
diff
changeset
|
12 |
val mk_case_conv_tac: Proof.context -> int -> thm -> thm list -> thm list list -> thm list list -> |
49153
c15a7123605c
made "mk_case_eq_tac" work in the case where the first constructor is an "alternate" constructor (in which case its discriminator paradoxically starts with a negation)
blanchet
parents:
49151
diff
changeset
|
13 |
tactic |
49118 | 14 |
val mk_collapse_tac: Proof.context -> int -> thm -> thm list -> tactic |
49029 | 15 |
val mk_disc_exhaust_tac: int -> thm -> thm list -> tactic |
49667
44d85dc8ca08
use Thm.close_derivation in theorems proved using Skip_Proof.prove; tuned signature;
traytel
parents:
49641
diff
changeset
|
16 |
val mk_expand_tac: int -> int list -> thm -> thm -> thm list -> thm list list list -> |
44d85dc8ca08
use Thm.close_derivation in theorems proved using Skip_Proof.prove; tuned signature;
traytel
parents:
49641
diff
changeset
|
17 |
thm list list list -> tactic |
49122 | 18 |
val mk_half_disc_exclude_tac: int -> thm -> thm -> tactic |
49020
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
diff
changeset
|
19 |
val mk_nchotomy_tac: int -> thm -> tactic |
49122 | 20 |
val mk_other_half_disc_exclude_tac: thm -> tactic |
49052 | 21 |
val mk_split_tac: thm -> thm list -> thm list list -> thm list list list -> tactic |
49044 | 22 |
val mk_split_asm_tac: Proof.context -> thm -> tactic |
49137 | 23 |
val mk_unique_disc_def_tac: int -> thm -> tactic |
49020
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
diff
changeset
|
24 |
end; |
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
diff
changeset
|
25 |
|
49074 | 26 |
structure BNF_Wrap_Tactics : BNF_WRAP_TACTICS = |
49020
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
diff
changeset
|
27 |
struct |
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
diff
changeset
|
28 |
|
49050 | 29 |
open BNF_Util |
49029 | 30 |
open BNF_Tactics |
49020
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
diff
changeset
|
31 |
|
49486 | 32 |
val meta_mp = @{thm meta_mp}; |
33 |
||
49212 | 34 |
fun if_P_or_not_P_OF pos thm = thm RS (if pos then @{thm if_P} else @{thm if_not_P}); |
49031 | 35 |
|
49020
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
diff
changeset
|
36 |
fun mk_nchotomy_tac n exhaust = |
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
diff
changeset
|
37 |
(rtac allI THEN' rtac exhaust THEN' |
49022 | 38 |
EVERY' (maps (fn k => [rtac (mk_disjIN n k), REPEAT_DETERM o rtac exI, atac]) (1 upto n))) 1; |
49020
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
diff
changeset
|
39 |
|
49486 | 40 |
fun mk_unique_disc_def_tac m uexhaust = |
41 |
EVERY' [rtac iffI, rtac uexhaust, REPEAT_DETERM_N m o rtac exI, atac, rtac refl] 1; |
|
49137 | 42 |
|
49486 | 43 |
fun mk_alternate_disc_def_tac ctxt k other_disc_def distinct uexhaust = |
49630 | 44 |
EVERY' ([rtac (other_disc_def RS @{thm arg_cong[of _ _ Not]} RS trans), |
45 |
rtac @{thm iffI_np}, REPEAT_DETERM o etac exE, |
|
49504
df9b897fb254
renamed "iter"/"coiter" to "fold"/"unfold" (cf. Wadler)
blanchet
parents:
49486
diff
changeset
|
46 |
hyp_subst_tac, SELECT_GOAL (unfold_thms_tac ctxt [not_ex]), REPEAT_DETERM o rtac allI, |
49486 | 47 |
rtac distinct, rtac uexhaust] @ |
49174
41790d616f63
by default, only generate one discriminator for a two-value datatype
blanchet
parents:
49168
diff
changeset
|
48 |
(([etac notE, REPEAT_DETERM o rtac exI, atac], [REPEAT_DETERM o rtac exI, atac]) |
41790d616f63
by default, only generate one discriminator for a two-value datatype
blanchet
parents:
49168
diff
changeset
|
49 |
|> k = 1 ? swap |> op @)) 1; |
49116
3d520eec2746
allow pseudo-definition of is_Cons in terms of is_Nil (and similarly for other two-constructor datatypes)
blanchet
parents:
49075
diff
changeset
|
50 |
|
49484 | 51 |
fun mk_half_disc_exclude_tac m discD disc' = |
52 |
(dtac discD THEN' REPEAT_DETERM_N m o etac exE THEN' hyp_subst_tac THEN' rtac disc') 1; |
|
49028 | 53 |
|
49484 | 54 |
fun mk_other_half_disc_exclude_tac half = (etac @{thm contrapos_pn} THEN' etac half) 1; |
49028 | 55 |
|
49029 | 56 |
fun mk_disc_exhaust_tac n exhaust discIs = |
57 |
(rtac exhaust THEN' |
|
58 |
EVERY' (map2 (fn k => fn discI => |
|
49486 | 59 |
dtac discI THEN' select_prem_tac n (etac meta_mp) k THEN' atac) (1 upto n) discIs)) 1; |
49029 | 60 |
|
49484 | 61 |
fun mk_collapse_tac ctxt m discD sels = |
49030 | 62 |
(dtac discD THEN' |
63 |
(if m = 0 then |
|
64 |
atac |
|
65 |
else |
|
49484 | 66 |
REPEAT_DETERM_N m o etac exE THEN' hyp_subst_tac THEN' |
49504
df9b897fb254
renamed "iter"/"coiter" to "fold"/"unfold" (cf. Wadler)
blanchet
parents:
49486
diff
changeset
|
67 |
SELECT_GOAL (unfold_thms_tac ctxt sels) THEN' rtac refl)) 1; |
49030 | 68 |
|
49667
44d85dc8ca08
use Thm.close_derivation in theorems proved using Skip_Proof.prove; tuned signature;
traytel
parents:
49641
diff
changeset
|
69 |
fun mk_expand_tac n ms udisc_exhaust vdisc_exhaust uncollapses disc_excludesss disc_excludesss' = |
49486 | 70 |
if ms = [0] then |
71 |
rtac (@{thm trans_sym} OF (replicate 2 (the_single uncollapses RS sym))) 1 |
|
72 |
else |
|
73 |
let |
|
74 |
val ks = 1 upto n; |
|
75 |
val maybe_atac = if n = 1 then K all_tac else atac; |
|
76 |
in |
|
77 |
(rtac udisc_exhaust THEN' |
|
78 |
EVERY' (map5 (fn k => fn m => fn disc_excludess => fn disc_excludess' => fn uuncollapse => |
|
49641 | 79 |
EVERY' [if m = 0 then K all_tac else rtac (uuncollapse RS trans) THEN' maybe_atac, |
49486 | 80 |
rtac sym, rtac vdisc_exhaust, |
81 |
EVERY' (map4 (fn k' => fn disc_excludes => fn disc_excludes' => fn vuncollapse => |
|
82 |
EVERY' |
|
83 |
(if k' = k then |
|
84 |
if m = 0 then |
|
85 |
[hyp_subst_tac, rtac refl] |
|
86 |
else |
|
49641 | 87 |
[rtac (vuncollapse RS trans), maybe_atac, |
49486 | 88 |
if n = 1 then K all_tac else EVERY' [dtac meta_mp, atac, dtac meta_mp, atac], |
89 |
REPEAT_DETERM_N (Int.max (0, m - 1)) o etac conjE, asm_simp_tac (ss_only [])] |
|
90 |
else |
|
91 |
[dtac (the_single (if k = n then disc_excludes else disc_excludes')), |
|
92 |
etac (if k = n then @{thm iff_contradict(1)} else @{thm iff_contradict(2)}), |
|
93 |
atac, atac])) |
|
94 |
ks disc_excludess disc_excludess' uncollapses)]) |
|
95 |
ks ms disc_excludesss disc_excludesss' uncollapses)) 1 |
|
96 |
end; |
|
97 |
||
49594
55e798614c45
tweaked theorem names (in particular, dropped s's)
blanchet
parents:
49586
diff
changeset
|
98 |
fun mk_case_conv_tac ctxt n uexhaust cases discss' selss = |
49486 | 99 |
(rtac uexhaust THEN' |
49484 | 100 |
EVERY' (map3 (fn casex => fn if_discs => fn sels => |
49504
df9b897fb254
renamed "iter"/"coiter" to "fold"/"unfold" (cf. Wadler)
blanchet
parents:
49486
diff
changeset
|
101 |
EVERY' [hyp_subst_tac, SELECT_GOAL (unfold_thms_tac ctxt (if_discs @ sels)), rtac casex]) |
49484 | 102 |
cases (map2 (seq_conds if_P_or_not_P_OF n) (1 upto n) discss') selss)) 1; |
49031 | 103 |
|
49486 | 104 |
fun mk_case_cong_tac uexhaust cases = |
105 |
(rtac uexhaust THEN' |
|
49484 | 106 |
EVERY' (maps (fn casex => [dtac sym, asm_simp_tac (ss_only [casex])]) cases)) 1; |
49043 | 107 |
|
108 |
val naked_ctxt = Proof_Context.init_global @{theory HOL}; |
|
109 |
||
49586 | 110 |
(* TODO: More precise "simp_thms"; get rid of "blast_tac" *) |
49486 | 111 |
fun mk_split_tac uexhaust cases injectss distinctsss = |
112 |
rtac uexhaust 1 THEN |
|
49157 | 113 |
ALLGOALS (fn k => (hyp_subst_tac THEN' |
49484 | 114 |
simp_tac (ss_only (@{thms simp_thms} @ cases @ nth injectss (k - 1) @ |
49052 | 115 |
flat (nth distinctsss (k - 1))))) k) THEN |
49045
7d9631754bba
minor fixes (for compatibility with existing datatype package)
blanchet
parents:
49044
diff
changeset
|
116 |
ALLGOALS (blast_tac naked_ctxt); |
49032 | 117 |
|
49044 | 118 |
val split_asm_thms = @{thms imp_conv_disj de_Morgan_conj de_Morgan_disj not_not not_ex}; |
119 |
||
120 |
fun mk_split_asm_tac ctxt split = |
|
49504
df9b897fb254
renamed "iter"/"coiter" to "fold"/"unfold" (cf. Wadler)
blanchet
parents:
49486
diff
changeset
|
121 |
rtac (split RS trans) 1 THEN unfold_thms_tac ctxt split_asm_thms THEN rtac refl 1; |
49044 | 122 |
|
49020
f379cf5d71bd
more work on BNF sugar -- up to derivation of nchotomy
blanchet
parents:
diff
changeset
|
123 |
end; |