19 |
19 |
20 signature RULE_CASES = |
20 signature RULE_CASES = |
21 sig |
21 sig |
22 include BASIC_RULE_CASES |
22 include BASIC_RULE_CASES |
23 type T |
23 type T |
24 val consume: thm list -> ('a * int) * thm -> (('a * (int * thm list)) * thm) Seq.seq |
24 val consume: thm list -> thm list -> ('a * int) * thm -> |
|
25 (('a * (int * thm list)) * thm) Seq.seq |
25 val consumes: int -> 'a attribute |
26 val consumes: int -> 'a attribute |
26 val consumes_default: int -> 'a attribute |
27 val consumes_default: int -> 'a attribute |
27 val name: string list -> thm -> thm |
28 val name: string list -> thm -> thm |
28 val case_names: string list -> 'a attribute |
29 val case_names: string list -> 'a attribute |
29 val case_conclusion: string -> (string * string) list -> 'a attribute |
30 val case_conclusion: string * string list -> 'a attribute |
30 val case_conclusion_binops: string -> string list -> 'a attribute |
|
31 val save: thm -> thm -> thm |
31 val save: thm -> thm -> thm |
32 val get: thm -> (string * (string * string) list) list * int |
32 val get: thm -> (string * string list) list * int |
33 val strip_params: term -> (string * typ) list |
33 val strip_params: term -> (string * typ) list |
34 val make: bool -> term option -> theory * term -> |
34 val make: bool -> term option -> theory * term -> (string * string list) list -> cases |
35 (string * (string * string) list) list -> cases |
|
36 val simple: bool -> theory * term -> string -> string * T option |
35 val simple: bool -> theory * term -> string -> string * T option |
37 val rename_params: string list list -> thm -> thm |
36 val rename_params: string list list -> thm -> thm |
38 val params: string list list -> 'a attribute |
37 val params: string list list -> 'a attribute |
39 end; |
38 end; |
40 |
39 |
59 SOME goal => tac (goal, i) st |
58 SOME goal => tac (goal, i) st |
60 | NONE => Seq.empty); |
59 | NONE => Seq.empty); |
61 |
60 |
62 fun (tac1 THEN_ALL_NEW_CASES tac2) i st = |
61 fun (tac1 THEN_ALL_NEW_CASES tac2) i st = |
63 st |> tac1 i |> Seq.maps (fn (cases, st') => |
62 st |> tac1 i |> Seq.maps (fn (cases, st') => |
64 Seq.map (pair cases) (Seq.INTERVAL tac2 i (i + nprems_of st' - nprems_of st) st')); |
63 CASES cases (Seq.INTERVAL tac2 i (i + nprems_of st' - nprems_of st)) st'); |
65 |
64 |
66 |
65 |
67 |
66 |
68 (** consume facts **) |
67 (** consume facts **) |
69 |
68 |
70 fun consume facts ((x, n), th) = |
69 fun consume defs facts ((x, n), th) = |
71 Drule.multi_resolves (Library.take (n, facts)) [th] |
70 let val m = Int.min (length facts, n) in |
72 |> Seq.map (pair (x, (n - length facts, Library.drop (n, facts)))); |
71 th |> K (not (null defs)) ? |
|
72 Drule.fconv_rule (Drule.goals_conv (fn i => i <= m) (Tactic.rewrite true defs)) |
|
73 |> Drule.multi_resolve (Library.take (m, facts)) |
|
74 |> Seq.map (pair (x, (n - m, Library.drop (m, facts)))) |
|
75 end; |
73 |
76 |
74 val consumes_tagN = "consumes"; |
77 val consumes_tagN = "consumes"; |
75 |
78 |
76 fun lookup_consumes th = |
79 fun lookup_consumes th = |
77 let fun err () = raise THM ("Malformed 'consumes' tag of theorem", 0, [th]) in |
80 let fun err () = raise THM ("Malformed 'consumes' tag of theorem", 0, [th]) in |
94 |
97 |
95 |
98 |
96 |
99 |
97 (** case names **) |
100 (** case names **) |
98 |
101 |
99 val cases_tagN = "cases"; |
102 val case_names_tagN = "case_names"; |
100 |
103 |
101 fun add_case_names NONE = I |
104 fun add_case_names NONE = I |
102 | add_case_names (SOME names) = |
105 | add_case_names (SOME names) = |
103 Drule.untag_rule cases_tagN |
106 Drule.untag_rule case_names_tagN |
104 #> Drule.tag_rule (cases_tagN, names); |
107 #> Drule.tag_rule (case_names_tagN, names); |
105 |
108 |
106 fun lookup_case_names th = AList.lookup (op =) (Thm.tags_of_thm th) cases_tagN; |
109 fun lookup_case_names th = AList.lookup (op =) (Thm.tags_of_thm th) case_names_tagN; |
107 |
110 |
108 val save_case_names = add_case_names o lookup_case_names; |
111 val save_case_names = add_case_names o lookup_case_names; |
109 val name = add_case_names o SOME; |
112 val name = add_case_names o SOME; |
110 fun case_names ss = Drule.rule_attribute (K (name ss)); |
113 fun case_names ss = Drule.rule_attribute (K (name ss)); |
111 |
114 |
112 |
115 |
113 |
116 |
114 (** case conclusions **) |
117 (** case conclusions **) |
115 |
118 |
116 (* term positions *) |
|
117 |
|
118 fun term_at pos tm = |
|
119 let |
|
120 fun at [] t = t |
|
121 | at ("0" :: ps) (t $ _) = at ps t |
|
122 | at ("1" :: ps) (_ $ u) = at ps u |
|
123 | at _ _ = raise TERM ("Bad term position: " ^ pos, [tm]); |
|
124 in at (explode pos) tm end; |
|
125 |
|
126 fun binop_positions [] = [] |
|
127 | binop_positions [x] = [(x, "")] |
|
128 | binop_positions xs = |
|
129 let |
|
130 fun pos i = replicate_string i "1"; |
|
131 val k = length xs - 1; |
|
132 in xs ~~ (map (suffix "01" o pos) (0 upto k - 1) @ [pos k]) end; |
|
133 |
|
134 |
|
135 (* conclusion tags *) |
|
136 |
|
137 val case_concl_tagN = "case_conclusion"; |
119 val case_concl_tagN = "case_conclusion"; |
138 |
120 |
139 fun is_case_concl name ((a, b :: _): tag) = (a = case_concl_tagN andalso b = name) |
121 fun is_case_concl name ((a, b :: _): tag) = (a = case_concl_tagN andalso b = name) |
140 | is_case_concl _ _ = false; |
122 | is_case_concl _ _ = false; |
141 |
123 |
142 fun add_case_concl (name, cs) = Drule.map_tags (fn tags => |
124 fun add_case_concl (name, cs) = Drule.map_tags (fn tags => |
143 filter_out (is_case_concl name) tags @ [(case_concl_tagN, name :: cs)]); |
125 filter_out (is_case_concl name) tags @ [(case_concl_tagN, name :: cs)]); |
144 |
126 |
145 fun lookup_case_concl th name = |
|
146 find_first (is_case_concl name) (Thm.tags_of_thm th) |> Option.map (tl o snd); |
|
147 |
|
148 fun get_case_concls th name = |
127 fun get_case_concls th name = |
149 let |
128 (case find_first (is_case_concl name) (Thm.tags_of_thm th) of |
150 fun concls (x :: pos :: cs) = (x, pos) :: concls cs |
129 SOME (_, _ :: cs) => cs |
151 | concls [] = [] |
130 | _ => []); |
152 | concls [x] = error ("No position for conclusion " ^ quote x ^ " of case " ^ quote name); |
|
153 in concls (these (lookup_case_concl th name)) end; |
|
154 |
131 |
155 fun save_case_concls th = |
132 fun save_case_concls th = |
156 let val concls = Thm.tags_of_thm th |> List.mapPartial |
133 let val concls = Thm.tags_of_thm th |> List.mapPartial |
157 (fn (a, b :: bs) => |
134 (fn (a, b :: cs) => |
158 if a = case_concl_tagN then SOME (b, bs) else NONE |
135 if a = case_concl_tagN then SOME (b, cs) else NONE |
159 | _ => NONE) |
136 | _ => NONE) |
160 in fold add_case_concl concls end; |
137 in fold add_case_concl concls end; |
161 |
138 |
162 fun case_conclusion name concls = Drule.rule_attribute (fn _ => |
139 fun case_conclusion concl = Drule.rule_attribute (fn _ => add_case_concl concl); |
163 add_case_concl (name, List.concat (map (fn (a, b) => [a, b]) concls))); |
|
164 |
|
165 fun case_conclusion_binops name xs = case_conclusion name (binop_positions xs); |
|
166 |
140 |
167 |
141 |
168 |
142 |
169 (** case declarations **) |
143 (** case declarations **) |
170 |
144 |
187 val case_conclN = "case"; |
161 val case_conclN = "case"; |
188 val case_hypsN = "hyps"; |
162 val case_hypsN = "hyps"; |
189 val case_premsN = "prems"; |
163 val case_premsN = "prems"; |
190 |
164 |
191 val strip_params = map (apfst Syntax.deskolem) o Logic.strip_params; |
165 val strip_params = map (apfst Syntax.deskolem) o Logic.strip_params; |
|
166 |
|
167 fun dest_binops cs tm = |
|
168 let |
|
169 val n = length cs; |
|
170 fun dest 0 _ = [] |
|
171 | dest 1 t = [t] |
|
172 | dest k (_ $ t $ u) = t :: dest (k - 1) u |
|
173 | dest _ _ = raise TERM ("Expected " ^ string_of_int n ^ " binop arguments", [tm]); |
|
174 in cs ~~ dest n tm end; |
192 |
175 |
193 fun extract_case is_open thy (split, raw_prop) name concls = |
176 fun extract_case is_open thy (split, raw_prop) name concls = |
194 let |
177 let |
195 val prop = Drule.norm_hhf thy raw_prop; |
178 val prop = Drule.norm_hhf thy raw_prop; |
196 |
179 |
211 | SOME t => |
194 | SOME t => |
212 let val (hyps, prems) = splitAt (length (Logic.strip_assums_hyp t), asms) |
195 let val (hyps, prems) = splitAt (length (Logic.strip_assums_hyp t), asms) |
213 in [(case_hypsN, hyps), (case_premsN, prems)] end); |
196 in [(case_hypsN, hyps), (case_premsN, prems)] end); |
214 |
197 |
215 val concl = ObjectLogic.drop_judgment thy (Logic.strip_assums_concl prop); |
198 val concl = ObjectLogic.drop_judgment thy (Logic.strip_assums_concl prop); |
216 fun bind (x, pos) = ((x, 0), SOME (abs_fixes (term_at pos concl))); |
199 val binds = (case_conclN, concl) :: dest_binops concls concl |
217 val binds = bind (case_conclN, "") :: map bind concls; |
200 |> map (fn (x, t) => ((x, 0), SOME (abs_fixes t))); |
218 in {fixes = fixes, assumes = assumes, binds = binds} end; |
201 in {fixes = fixes, assumes = assumes, binds = binds} end; |
219 |
202 |
220 fun make is_open split (thy, prop) cases = |
203 fun make is_open split (thy, prop) cases = |
221 let |
204 let |
222 val n = length cases; |
205 val n = length cases; |