34 (* number of consumed facts *) |
34 (* number of consumed facts *) |
35 |
35 |
36 fun lookup_consumes thm = |
36 fun lookup_consumes thm = |
37 let fun err () = raise THM ("Malformed 'consumes' tag of theorem", 0, [thm]) in |
37 let fun err () = raise THM ("Malformed 'consumes' tag of theorem", 0, [thm]) in |
38 (case Library.assoc (Thm.tags_of_thm thm, consumes_tagN) of |
38 (case Library.assoc (Thm.tags_of_thm thm, consumes_tagN) of |
39 None => None |
39 NONE => NONE |
40 | Some [s] => (case Syntax.read_nat s of Some n => Some n | _ => err ()) |
40 | SOME [s] => (case Syntax.read_nat s of SOME n => SOME n | _ => err ()) |
41 | _ => err ()) |
41 | _ => err ()) |
42 end; |
42 end; |
43 |
43 |
44 fun put_consumes None th = th |
44 fun put_consumes NONE th = th |
45 | put_consumes (Some n) th = th |
45 | put_consumes (SOME n) th = th |
46 |> Drule.untag_rule consumes_tagN |
46 |> Drule.untag_rule consumes_tagN |
47 |> Drule.tag_rule (consumes_tagN, [Library.string_of_int n]); |
47 |> Drule.tag_rule (consumes_tagN, [Library.string_of_int n]); |
48 |
48 |
49 val save_consumes = put_consumes o lookup_consumes; |
49 val save_consumes = put_consumes o lookup_consumes; |
50 |
50 |
51 fun consumes n x = Drule.rule_attribute (K (put_consumes (Some n))) x; |
51 fun consumes n x = Drule.rule_attribute (K (put_consumes (SOME n))) x; |
52 fun consumes_default n x = if Library.is_some (lookup_consumes (#2 x)) then x else consumes n x; |
52 fun consumes_default n x = if Library.is_some (lookup_consumes (#2 x)) then x else consumes n x; |
53 |
53 |
54 |
54 |
55 (* case names *) |
55 (* case names *) |
56 |
56 |
57 fun put_case_names None thm = thm |
57 fun put_case_names NONE thm = thm |
58 | put_case_names (Some names) thm = |
58 | put_case_names (SOME names) thm = |
59 thm |
59 thm |
60 |> Drule.untag_rule cases_tagN |
60 |> Drule.untag_rule cases_tagN |
61 |> Drule.tag_rule (cases_tagN, names); |
61 |> Drule.tag_rule (cases_tagN, names); |
62 |
62 |
63 fun lookup_case_names thm = Library.assoc (Thm.tags_of_thm thm, cases_tagN); |
63 fun lookup_case_names thm = Library.assoc (Thm.tags_of_thm thm, cases_tagN); |
64 |
64 |
65 val save_case_names = put_case_names o lookup_case_names; |
65 val save_case_names = put_case_names o lookup_case_names; |
66 val name = put_case_names o Some; |
66 val name = put_case_names o SOME; |
67 fun case_names ss = Drule.rule_attribute (K (name ss)); |
67 fun case_names ss = Drule.rule_attribute (K (name ss)); |
68 |
68 |
69 |
69 |
70 (* access hints *) |
70 (* access hints *) |
71 |
71 |
100 |
100 |
101 fun prep_case is_open split sg prop name i = |
101 fun prep_case is_open split sg prop name i = |
102 let |
102 let |
103 val Bi = Drule.norm_hhf sg (nth_subgoal(i,prop)); |
103 val Bi = Drule.norm_hhf sg (nth_subgoal(i,prop)); |
104 val all_xs = Logic.strip_params Bi |
104 val all_xs = Logic.strip_params Bi |
105 val n = (case split of None => length all_xs |
105 val n = (case split of NONE => length all_xs |
106 | Some t => length (Logic.strip_params(nth_subgoal(i,t)))) |
106 | SOME t => length (Logic.strip_params(nth_subgoal(i,t)))) |
107 val (ind_xs, goal_xs) = splitAt(n,all_xs) |
107 val (ind_xs, goal_xs) = splitAt(n,all_xs) |
108 val rename = if is_open then I else apfst Syntax.internal |
108 val rename = if is_open then I else apfst Syntax.internal |
109 val xs = map rename ind_xs @ goal_xs |
109 val xs = map rename ind_xs @ goal_xs |
110 val asms = map (curry Term.list_abs xs) (Logic.strip_assums_hyp Bi); |
110 val asms = map (curry Term.list_abs xs) (Logic.strip_assums_hyp Bi); |
111 val named_asms = |
111 val named_asms = |
112 (case split of None => [("", asms)] |
112 (case split of NONE => [("", asms)] |
113 | Some t => |
113 | SOME t => |
114 let val h = length (Logic.strip_assums_hyp(nth_subgoal(i,t))) |
114 let val h = length (Logic.strip_assums_hyp(nth_subgoal(i,t))) |
115 val (ps,qs) = splitAt(h, asms) |
115 val (ps,qs) = splitAt(h, asms) |
116 in [(hypsN, ps), (premsN, qs)] end); |
116 in [(hypsN, ps), (premsN, qs)] end); |
117 val concl = Term.list_abs (xs, Logic.strip_assums_concl Bi); |
117 val concl = Term.list_abs (xs, Logic.strip_assums_concl Bi); |
118 val bind = ((case_conclN, 0), Some (ObjectLogic.drop_judgment sg concl)); |
118 val bind = ((case_conclN, 0), SOME (ObjectLogic.drop_judgment sg concl)); |
119 in (name, {fixes = xs, assumes = named_asms, binds = [bind]}) end; |
119 in (name, {fixes = xs, assumes = named_asms, binds = [bind]}) end; |
120 |
120 |
121 fun make is_open split (sg, prop) names = |
121 fun make is_open split (sg, prop) names = |
122 let val nprems = Logic.count_prems (prop, 0) in |
122 let val nprems = Logic.count_prems (prop, 0) in |
123 foldr (fn (name, (cases, i)) => (prep_case is_open split sg prop name i :: cases, i - 1)) |
123 foldr (fn (name, (cases, i)) => (prep_case is_open split sg prop name i :: cases, i - 1)) |