src/Pure/Isar/rule_cases.ML
changeset 15531 08c8dad8e399
parent 14981 e73f8140af78
child 15570 8d8c70b41bab
equal deleted inserted replaced
15530:6f43714517ee 15531:08c8dad8e399
    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 
    74 fun get thm =
    74 fun get thm =
    75   let
    75   let
    76     val n = if_none (lookup_consumes thm) 0;
    76     val n = if_none (lookup_consumes thm) 0;
    77     val ss =
    77     val ss =
    78       (case lookup_case_names thm of
    78       (case lookup_case_names thm of
    79         None => map Library.string_of_int (1 upto (Thm.nprems_of thm - n))
    79         NONE => map Library.string_of_int (1 upto (Thm.nprems_of thm - n))
    80       | Some ss => ss);
    80       | SOME ss => ss);
    81   in (ss, n) end;
    81   in (ss, n) end;
    82 
    82 
    83 fun add thm = (thm, get thm);
    83 fun add thm = (thm, get thm);
    84 
    84 
    85 
    85 
   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))