src/Pure/Isar/method.ML
changeset 17110 4c5622d7bdbe
parent 16876 f57b38cced32
child 17221 6cd180204582
equal deleted inserted replaced
17109:606c269d1e26 17110:4c5622d7bdbe
     1 (*  Title:      Pure/Isar/method.ML
     1 (*  Title:      Pure/Isar/method.ML
     2     ID:         $Id$
     2     ID:         $Id$
     3     Author:     Markus Wenzel, TU Muenchen
     3     Author:     Markus Wenzel, TU Muenchen
     4 
     4 
     5 Proof methods.
     5 Isar proof methods.
     6 *)
     6 *)
     7 
     7 
     8 signature BASIC_METHOD =
     8 signature BASIC_METHOD =
     9 sig
     9 sig
       
    10   val FINDGOAL: (int -> thm -> 'a Seq.seq) -> thm -> 'a Seq.seq
       
    11   val HEADGOAL: (int -> thm -> 'a Seq.seq) -> thm -> 'a Seq.seq
       
    12   type method
    10   val trace_rules: bool ref
    13   val trace_rules: bool ref
    11   val print_methods: theory -> unit
    14   val print_methods: theory -> unit
    12   val Method: bstring -> (Args.src -> Proof.context -> Proof.method) -> string -> unit
    15   val Method: bstring -> (Args.src -> ProofContext.context -> method) -> string -> unit
    13 end;
    16 end;
    14 
    17 
    15 signature METHOD =
    18 signature METHOD =
    16 sig
    19 sig
    17   include BASIC_METHOD
    20   include BASIC_METHOD
    18   type src
       
    19   val trace: Proof.context -> thm list -> unit
       
    20   val RAW_METHOD: (thm list -> tactic) -> Proof.method
       
    21   val RAW_METHOD_CASES: (thm list -> RuleCases.tactic) -> Proof.method
       
    22   val METHOD: (thm list -> tactic) -> Proof.method
       
    23   val METHOD_CASES: (thm list -> RuleCases.tactic) -> Proof.method
       
    24   val SIMPLE_METHOD: tactic -> Proof.method
       
    25   val SIMPLE_METHOD': ((int -> tactic) -> tactic) -> (int -> tactic) -> Proof.method
       
    26   val fail: Proof.method
       
    27   val succeed: Proof.method
       
    28   val defer: int option -> Proof.method
       
    29   val prefer: int -> Proof.method
       
    30   val insert_tac: thm list -> int -> tactic
       
    31   val insert: thm list -> Proof.method
       
    32   val insert_facts: Proof.method
       
    33   val unfold: thm list -> Proof.method
       
    34   val fold: thm list -> Proof.method
       
    35   val multi_resolve: thm list -> thm -> thm Seq.seq
    21   val multi_resolve: thm list -> thm -> thm Seq.seq
    36   val multi_resolves: thm list -> thm list -> thm Seq.seq
    22   val multi_resolves: thm list -> thm list -> thm Seq.seq
    37   val rules_tac: Proof.context -> int option -> int -> tactic
    23   val apply: method -> thm list -> RuleCases.tactic;
       
    24   val RAW_METHOD_CASES: (thm list -> RuleCases.tactic) -> method
       
    25   val RAW_METHOD: (thm list -> tactic) -> method
       
    26   val METHOD_CASES: (thm list -> RuleCases.tactic) -> method
       
    27   val METHOD: (thm list -> tactic) -> method
       
    28   val fail: method
       
    29   val succeed: method
       
    30   val insert_tac: thm list -> int -> tactic
       
    31   val insert: thm list -> method
       
    32   val insert_facts: method
       
    33   val SIMPLE_METHOD: tactic -> method
       
    34   val SIMPLE_METHOD': ((int -> tactic) -> tactic) -> (int -> tactic) -> method
       
    35   val defer: int option -> method
       
    36   val prefer: int -> method
       
    37   val intro: thm list -> method
       
    38   val elim: thm list -> method
       
    39   val unfold: thm list -> method
       
    40   val fold: thm list -> method
       
    41   val atomize: bool -> method
       
    42   val this: method
       
    43   val assumption: ProofContext.context -> method
       
    44   val close: bool -> ProofContext.context -> method
       
    45   val trace: ProofContext.context -> thm list -> unit
    38   val rule_tac: thm list -> thm list -> int -> tactic
    46   val rule_tac: thm list -> thm list -> int -> tactic
    39   val some_rule_tac: thm list -> Proof.context -> thm list -> int -> tactic
    47   val some_rule_tac: thm list -> ProofContext.context -> thm list -> int -> tactic
    40   val rule: thm list -> Proof.method
    48   val rule: thm list -> method
    41   val erule: int -> thm list -> Proof.method
    49   val erule: int -> thm list -> method
    42   val drule: int -> thm list -> Proof.method
    50   val drule: int -> thm list -> method
    43   val frule: int -> thm list -> Proof.method
    51   val frule: int -> thm list -> method
    44   val this: Proof.method
    52   val rules_tac: ProofContext.context -> int option -> int -> tactic
    45   val assumption: Proof.context -> Proof.method
    53   val bires_inst_tac: bool -> ProofContext.context -> (indexname * string) list ->
    46   val bires_inst_tac: bool -> Proof.context -> (indexname * string) list -> thm -> int -> tactic
    54     thm -> int -> tactic
    47   val set_tactic: (Proof.context -> thm list -> tactic) -> unit
    55   val set_tactic: (ProofContext.context -> thm list -> tactic) -> unit
    48   val tactic: string -> Proof.context -> Proof.method
    56   val tactic: string -> ProofContext.context -> method
    49   exception METHOD_FAIL of (string * Position.T) * exn
    57   type src
    50   val method: theory -> src -> Proof.context -> Proof.method
       
    51   val add_method: bstring * (src -> Proof.context -> Proof.method) * string
       
    52     -> theory -> theory
       
    53   val add_methods: (bstring * (src -> Proof.context -> Proof.method) * string) list
       
    54     -> theory -> theory
       
    55   val syntax: (Proof.context * Args.T list -> 'a * (Proof.context * Args.T list)) ->
       
    56     src -> Proof.context -> Proof.context * 'a
       
    57   val simple_args: (Args.T list -> 'a * Args.T list)
       
    58     -> ('a -> Proof.context -> Proof.method) -> src -> Proof.context -> Proof.method
       
    59   val ctxt_args: (Proof.context -> Proof.method) -> src -> Proof.context -> Proof.method
       
    60   val no_args: Proof.method -> src -> Proof.context -> Proof.method
       
    61   type modifier
       
    62   val sectioned_args: (Proof.context * Args.T list -> 'a * (Proof.context * Args.T list)) ->
       
    63     (Args.T list -> modifier * Args.T list) list ->
       
    64     ('a -> Proof.context -> 'b) -> src -> Proof.context -> 'b
       
    65   val bang_sectioned_args:
       
    66     (Args.T list -> modifier * Args.T list) list ->
       
    67     (thm list -> Proof.context -> 'a) -> src -> Proof.context -> 'a
       
    68   val bang_sectioned_args':
       
    69     (Args.T list -> modifier * Args.T list) list ->
       
    70     (Proof.context * Args.T list -> 'a * (Proof.context * Args.T list)) ->
       
    71     ('a -> thm list -> Proof.context -> 'b) -> src -> Proof.context -> 'b
       
    72   val only_sectioned_args:
       
    73     (Args.T list -> modifier * Args.T list) list ->
       
    74     (Proof.context -> 'a) -> src -> Proof.context -> 'a
       
    75   val thms_ctxt_args: (thm list -> Proof.context -> 'a) -> src -> Proof.context -> 'a
       
    76   val thms_args: (thm list -> 'a) -> src -> Proof.context -> 'a
       
    77   val thm_args: (thm -> 'a) -> src -> Proof.context -> 'a
       
    78   datatype text =
    58   datatype text =
    79     Basic of (Proof.context -> Proof.method) |
    59     Basic of (ProofContext.context -> method) |
    80     Source of src |
    60     Source of src |
    81     Then of text list |
    61     Then of text list |
    82     Orelse of text list |
    62     Orelse of text list |
    83     Try of text |
    63     Try of text |
    84     Repeat1 of text
    64     Repeat1 of text
    85   val refine: text -> Proof.state -> Proof.state Seq.seq
    65   val default_text: text
    86   val refine_end: text -> Proof.state -> Proof.state Seq.seq
    66   val this_text: text
    87   val proof: text option -> Proof.state -> Proof.state Seq.seq
    67   val done_text: text
    88   val local_qed: bool -> text option
    68   val finish_text: bool -> text option -> text
    89     -> (Proof.context -> string * (string * thm list) list -> unit) *
    69   exception METHOD_FAIL of (string * Position.T) * exn
    90       (Proof.context -> thm -> unit) -> Proof.state -> Proof.state Seq.seq
    70   val method: theory -> src -> ProofContext.context -> method
    91   val local_terminal_proof: text * text option
    71   val add_methods: (bstring * (src -> ProofContext.context -> method) * string) list
    92     -> (Proof.context -> string * (string * thm list) list -> unit) *
    72     -> theory -> theory
    93       (Proof.context -> thm -> unit) -> Proof.state -> Proof.state Seq.seq
    73   val add_method: bstring * (src -> ProofContext.context -> method) * string
    94   val local_default_proof: (Proof.context -> string * (string * thm list) list -> unit) *
    74     -> theory -> theory
    95     (Proof.context -> thm -> unit) -> Proof.state -> Proof.state Seq.seq
    75   val syntax: (ProofContext.context * Args.T list -> 'a * (ProofContext.context * Args.T list))
    96   val local_immediate_proof: (Proof.context -> string * (string * thm list) list -> unit) *
    76     -> src -> ProofContext.context -> ProofContext.context * 'a
    97     (Proof.context -> thm -> unit) -> Proof.state -> Proof.state Seq.seq
    77   val simple_args: (Args.T list -> 'a * Args.T list)
    98   val local_done_proof: (Proof.context -> string * (string * thm list) list -> unit) *
    78     -> ('a -> ProofContext.context -> method) -> src -> ProofContext.context -> method
    99     (Proof.context -> thm -> unit) -> Proof.state -> Proof.state Seq.seq
    79   val ctxt_args: (ProofContext.context -> method) -> src -> ProofContext.context -> method
   100   val global_qed: bool -> text option
    80   val no_args: method -> src -> ProofContext.context -> method
   101     -> Proof.state -> theory * ((string * string) * (string * thm list) list)
    81   type modifier
   102   val global_terminal_proof: text * text option
    82   val sectioned_args: (ProofContext.context * Args.T list ->
   103     -> Proof.state -> theory * ((string * string) * (string * thm list) list)
    83       'a * (ProofContext.context * Args.T list)) ->
   104   val global_default_proof: Proof.state -> theory * ((string * string) * (string * thm list) list)
    84     (Args.T list -> modifier * Args.T list) list ->
   105   val global_immediate_proof: Proof.state ->
    85     ('a -> ProofContext.context -> 'b) -> src -> ProofContext.context -> 'b
   106     theory * ((string * string) * (string * thm list) list)
    86   val bang_sectioned_args:
   107   val global_done_proof: Proof.state -> theory * ((string * string) * (string * thm list) list)
    87     (Args.T list -> modifier * Args.T list) list ->
       
    88     (thm list -> ProofContext.context -> 'a) -> src -> ProofContext.context -> 'a
       
    89   val bang_sectioned_args':
       
    90     (Args.T list -> modifier * Args.T list) list ->
       
    91     (ProofContext.context * Args.T list -> 'a * (ProofContext.context * Args.T list)) ->
       
    92     ('a -> thm list -> ProofContext.context -> 'b) -> src -> ProofContext.context -> 'b
       
    93   val only_sectioned_args:
       
    94     (Args.T list -> modifier * Args.T list) list ->
       
    95     (ProofContext.context -> 'a) -> src -> ProofContext.context -> 'a
       
    96   val thms_ctxt_args: (thm list -> ProofContext.context -> 'a) -> src ->
       
    97     ProofContext.context -> 'a
       
    98   val thms_args: (thm list -> 'a) -> src -> ProofContext.context -> 'a
       
    99   val thm_args: (thm -> 'a) -> src -> ProofContext.context -> 'a
   108   val goal_args: (Args.T list -> 'a * Args.T list) -> ('a -> int -> tactic)
   100   val goal_args: (Args.T list -> 'a * Args.T list) -> ('a -> int -> tactic)
   109     -> src -> Proof.context -> Proof.method
   101     -> src -> ProofContext.context -> method
   110   val goal_args': (Proof.context * Args.T list -> 'a * (Proof.context * Args.T list))
   102   val goal_args': (ProofContext.context * Args.T list ->
   111     -> ('a -> int -> tactic) -> src -> Proof.context -> Proof.method
   103       'a * (ProofContext.context * Args.T list))
   112   val goal_args_ctxt: (Args.T list -> 'a * Args.T list) -> (Proof.context -> 'a -> int -> tactic)
   104     -> ('a -> int -> tactic) -> src -> ProofContext.context -> method
   113     -> src -> Proof.context -> Proof.method
   105   val goal_args_ctxt: (Args.T list -> 'a * Args.T list) ->
   114   val goal_args_ctxt': (Proof.context * Args.T list -> 'a * (Proof.context * Args.T list))
   106     (ProofContext.context -> 'a -> int -> tactic) -> src -> ProofContext.context -> method
   115     -> (Proof.context -> 'a -> int -> tactic) -> src -> Proof.context -> Proof.method
   107   val goal_args_ctxt': (ProofContext.context * Args.T list ->
       
   108     'a * (ProofContext.context * Args.T list)) ->
       
   109     (ProofContext.context -> 'a -> int -> tactic) -> src -> ProofContext.context -> method
   116 end;
   110 end;
   117 
   111 
   118 structure Method: METHOD =
   112 structure Method: METHOD =
   119 struct
   113 struct
   120 
   114 
   121 type src = Args.src;
   115 (** generic tools **)
       
   116 
       
   117 (* goal addressing *)
       
   118 
       
   119 fun FINDGOAL tac st =
       
   120   let fun find i n = if i > n then Seq.fail else Seq.APPEND (tac i, find (i + 1) n)
       
   121   in find 1 (Thm.nprems_of st) st end;
       
   122 
       
   123 fun HEADGOAL tac = tac 1;
       
   124 
       
   125 
       
   126 (* multi_resolve *)
       
   127 
       
   128 local
       
   129 
       
   130 fun res th i rule =
       
   131   Thm.biresolution false [(false, th)] i rule handle THM _ => Seq.empty;
       
   132 
       
   133 fun multi_res _ [] rule = Seq.single rule
       
   134   | multi_res i (th :: ths) rule = Seq.flat (Seq.map (res th i) (multi_res (i + 1) ths rule));
       
   135 
       
   136 in
       
   137 
       
   138 val multi_resolve = multi_res 1;
       
   139 fun multi_resolves facts rules = Seq.flat (Seq.map (multi_resolve facts) (Seq.of_list rules));
       
   140 
       
   141 end;
       
   142 
   122 
   143 
   123 
   144 
   124 (** proof methods **)
   145 (** proof methods **)
   125 
   146 
   126 (* tracing *)
   147 (* datatype method *)
   127 
   148 
   128 val trace_rules = ref false;
   149 datatype method = Method of thm list -> RuleCases.tactic;
   129 
   150 
   130 fun trace ctxt rules =
   151 fun apply (Method m) = m;
   131   conditional (! trace_rules andalso not (null rules)) (fn () =>
   152 
   132     Pretty.big_list "rules:" (map (ProofContext.pretty_thm ctxt) rules)
   153 val RAW_METHOD_CASES = Method;
   133     |> Pretty.string_of |> tracing);
   154 
   134 
   155 fun RAW_METHOD tac = RAW_METHOD_CASES (NO_CASES o tac);
   135 
   156 
   136 (* make methods *)
   157 fun METHOD_CASES tac = RAW_METHOD_CASES (fn facts =>
   137 
   158   Seq.THEN (TRY Tactic.conjunction_tac, tac facts));
   138 val RAW_METHOD = Proof.method;
   159 
   139 val RAW_METHOD_CASES = Proof.method_cases;
   160 fun METHOD tac = RAW_METHOD (fn facts =>
   140 
   161   TRY Tactic.conjunction_tac THEN tac facts);
   141 fun METHOD m = Proof.method (fn facts => TRY Tactic.conjunction_tac THEN m facts);
       
   142 fun METHOD_CASES m =
       
   143   Proof.method_cases (fn facts => Seq.THEN (TRY Tactic.conjunction_tac, m facts));
       
   144 
       
   145 
       
   146 (* primitive *)
       
   147 
   162 
   148 val fail = METHOD (K no_tac);
   163 val fail = METHOD (K no_tac);
   149 val succeed = METHOD (K all_tac);
   164 val succeed = METHOD (K all_tac);
   150 
   165 
   151 
   166 
   152 (* shuffle *)
   167 (* insert facts *)
   153 
       
   154 fun prefer i = METHOD (K (Tactic.defer_tac i THEN PRIMITIVE (Thm.permute_prems 0 ~1)));
       
   155 fun defer opt_i = METHOD (K (Tactic.defer_tac (if_none opt_i 1)));
       
   156 
       
   157 
       
   158 (* insert *)
       
   159 
   168 
   160 local
   169 local
   161 
   170 
   162 fun cut_rule_tac raw_rule =
   171 fun cut_rule_tac raw_rule =
   163   let
   172   let
   177 fun SIMPLE_METHOD' quant tac = METHOD (fn facts => quant (insert_tac facts THEN' tac));
   186 fun SIMPLE_METHOD' quant tac = METHOD (fn facts => quant (insert_tac facts THEN' tac));
   178 
   187 
   179 end;
   188 end;
   180 
   189 
   181 
   190 
       
   191 (* shuffle subgoals *)
       
   192 
       
   193 fun prefer i = METHOD (K (Tactic.defer_tac i THEN PRIMITIVE (Thm.permute_prems 0 ~1)));
       
   194 fun defer opt_i = METHOD (K (Tactic.defer_tac (if_none opt_i 1)));
       
   195 
       
   196 
       
   197 (* unfold intro/elim rules *)
       
   198 
       
   199 fun intro ths = SIMPLE_METHOD' HEADGOAL (CHANGED_PROP o REPEAT_ALL_NEW (Tactic.match_tac ths));
       
   200 fun elim ths = SIMPLE_METHOD' HEADGOAL (CHANGED_PROP o REPEAT_ALL_NEW (Tactic.ematch_tac ths));
       
   201 
       
   202 
   182 (* unfold/fold definitions *)
   203 (* unfold/fold definitions *)
   183 
   204 
   184 fun unfold_meth ths = SIMPLE_METHOD (CHANGED_PROP (rewrite_goals_tac ths));
   205 fun unfold_meth ths = SIMPLE_METHOD (CHANGED_PROP (rewrite_goals_tac ths));
   185 fun fold_meth ths = SIMPLE_METHOD (CHANGED_PROP (fold_goals_tac ths));
   206 fun fold_meth ths = SIMPLE_METHOD (CHANGED_PROP (fold_goals_tac ths));
   186 
   207 
   189 
   210 
   190 fun atomize false = SIMPLE_METHOD' HEADGOAL (CHANGED_PROP o ObjectLogic.atomize_tac)
   211 fun atomize false = SIMPLE_METHOD' HEADGOAL (CHANGED_PROP o ObjectLogic.atomize_tac)
   191   | atomize true = RAW_METHOD (K (HEADGOAL (CHANGED_PROP o ObjectLogic.full_atomize_tac)));
   212   | atomize true = RAW_METHOD (K (HEADGOAL (CHANGED_PROP o ObjectLogic.full_atomize_tac)));
   192 
   213 
   193 
   214 
   194 (* unfold intro/elim rules *)
   215 (* this -- apply facts directly *)
   195 
   216 
   196 fun intro ths = SIMPLE_METHOD' HEADGOAL (CHANGED_PROP o REPEAT_ALL_NEW (Tactic.match_tac ths));
   217 val this = METHOD (EVERY o map (HEADGOAL o Tactic.rtac));
   197 fun elim ths = SIMPLE_METHOD' HEADGOAL (CHANGED_PROP o REPEAT_ALL_NEW (Tactic.ematch_tac ths));
   218 
   198 
   219 
   199 
   220 (* assumption *)
   200 (* multi_resolve *)
       
   201 
   221 
   202 local
   222 local
   203 
   223 
   204 fun res th i rule =
   224 fun asm_tac ths =
   205   Thm.biresolution false [(false, th)] i rule handle THM _ => Seq.empty;
   225   foldr (op APPEND') (K no_tac) (map (fn th => Tactic.rtac th THEN_ALL_NEW assume_tac) ths);
   206 
   226 
   207 fun multi_res _ [] rule = Seq.single rule
   227 val refl_tac = SUBGOAL (fn (prop, i) =>
   208   | multi_res i (th :: ths) rule = Seq.flat (Seq.map (res th i) (multi_res (i + 1) ths rule));
   228   if can Logic.dest_equals (Logic.strip_assums_concl prop)
       
   229   then Tactic.rtac Drule.reflexive_thm i else no_tac);
       
   230 
       
   231 fun assm_tac ctxt =
       
   232   assume_tac APPEND'
       
   233   asm_tac (ProofContext.prems_of ctxt) APPEND'
       
   234   refl_tac;
       
   235 
       
   236 fun assumption_tac ctxt [] = assm_tac ctxt
       
   237   | assumption_tac _ [fact] = asm_tac [fact]
       
   238   | assumption_tac _ _ = K no_tac;
   209 
   239 
   210 in
   240 in
   211 
   241 
   212 val multi_resolve = multi_res 1;
   242 fun assumption ctxt = METHOD (HEADGOAL o assumption_tac ctxt);
   213 fun multi_resolves facts rules = Seq.flat (Seq.map (multi_resolve facts) (Seq.of_list rules));
   243 fun close asm ctxt = METHOD (K
   214 
   244   (FILTER Thm.no_prems ((if asm then ALLGOALS (assm_tac ctxt) else all_tac) THEN flexflex_tac)));
   215 end;
   245 
   216 
   246 end;
   217 
   247 
   218 (* rules_tac *)
   248 
       
   249 (* rule etc. -- single-step refinements *)
       
   250 
       
   251 val trace_rules = ref false;
       
   252 
       
   253 fun trace ctxt rules =
       
   254   conditional (! trace_rules andalso not (null rules)) (fn () =>
       
   255     Pretty.big_list "rules:" (map (ProofContext.pretty_thm ctxt) rules)
       
   256     |> Pretty.string_of |> tracing);
       
   257 
       
   258 local
       
   259 
       
   260 fun gen_rule_tac tac rules [] i st = tac rules i st
       
   261   | gen_rule_tac tac rules facts i st =
       
   262       Seq.flat (Seq.map (fn rule => (tac o single) rule i st) (multi_resolves facts rules));
       
   263 
       
   264 fun gen_arule_tac tac j rules facts =
       
   265   EVERY' (gen_rule_tac tac rules facts :: replicate j Tactic.assume_tac);
       
   266 
       
   267 fun gen_some_rule_tac tac arg_rules ctxt facts = SUBGOAL (fn (goal, i) =>
       
   268   let
       
   269     val rules =
       
   270       if not (null arg_rules) then arg_rules
       
   271       else List.concat (ContextRules.find_rules false facts goal ctxt)
       
   272   in trace ctxt rules; tac rules facts i end);
       
   273 
       
   274 fun meth tac x = METHOD (HEADGOAL o tac x);
       
   275 fun meth' tac x y = METHOD (HEADGOAL o tac x y);
       
   276 
       
   277 in
       
   278 
       
   279 val rule_tac = gen_rule_tac Tactic.resolve_tac;
       
   280 val rule = meth rule_tac;
       
   281 val some_rule_tac = gen_some_rule_tac rule_tac;
       
   282 val some_rule = meth' some_rule_tac;
       
   283 
       
   284 val erule = meth' (gen_arule_tac Tactic.eresolve_tac);
       
   285 val drule = meth' (gen_arule_tac Tactic.dresolve_tac);
       
   286 val frule = meth' (gen_arule_tac Tactic.forward_tac);
       
   287 
       
   288 end;
       
   289 
       
   290 
       
   291 (* rules -- intuitionistic proof search *)
   219 
   292 
   220 local
   293 local
   221 
   294 
   222 val remdups_tac = SUBGOAL (fn (g, i) =>
   295 val remdups_tac = SUBGOAL (fn (g, i) =>
   223   let val prems = Logic.strip_assums_hyp g in
   296   let val prems = Logic.strip_assums_hyp g in
   246 
   319 
   247 fun step_tac ctxt i =
   320 fun step_tac ctxt i =
   248   REPEAT_DETERM1 (REMDUPS (safe_step_tac ctxt) i) ORELSE
   321   REPEAT_DETERM1 (REMDUPS (safe_step_tac ctxt) i) ORELSE
   249   REMDUPS (unsafe_step_tac ctxt) i;
   322   REMDUPS (unsafe_step_tac ctxt) i;
   250 
   323 
   251 fun intpr_tac ctxt gs d lim = SUBGOAL (fn (g, i) => if d > lim then no_tac else
   324 fun intprover_tac ctxt gs d lim = SUBGOAL (fn (g, i) => if d > lim then no_tac else
   252   let
   325   let
   253     val ps = Logic.strip_assums_hyp g;
   326     val ps = Logic.strip_assums_hyp g;
   254     val c = Logic.strip_assums_concl g;
   327     val c = Logic.strip_assums_concl g;
   255   in
   328   in
   256     if gen_mem (fn ((ps1, c1), (ps2, c2)) =>
   329     if gen_mem (fn ((ps1, c1), (ps2, c2)) =>
   257       c1 aconv c2 andalso gen_eq_set op aconv ps1 ps2) ((ps, c), gs) then no_tac
   330       c1 aconv c2 andalso gen_eq_set op aconv ps1 ps2) ((ps, c), gs) then no_tac
   258     else (step_tac ctxt THEN_ALL_NEW intpr_tac ctxt ((ps, c) :: gs) (d + 1) lim) i
   331     else (step_tac ctxt THEN_ALL_NEW intprover_tac ctxt ((ps, c) :: gs) (d + 1) lim) i
   259   end);
   332   end);
   260 
   333 
   261 in
   334 in
   262 
   335 
   263 fun rules_tac ctxt opt_lim =
   336 fun rules_tac ctxt opt_lim =
   264   SELECT_GOAL (DEEPEN (2, if_none opt_lim 20) (intpr_tac ctxt [] 0) 4 1);
   337   SELECT_GOAL (DEEPEN (2, if_none opt_lim 20) (intprover_tac ctxt [] 0) 4 1);
   265 
   338 
   266 end;
   339 end;
   267 
   340 
   268 
   341 
   269 (* rule_tac etc. *)
   342 (* rule_tac etc. -- refer to dynamic goal state!! *)
   270 
       
   271 local
       
   272 
       
   273 fun gen_rule_tac tac rules [] i st = tac rules i st
       
   274   | gen_rule_tac tac rules facts i st =
       
   275       Seq.flat (Seq.map (fn rule => (tac o single) rule i st) (multi_resolves facts rules));
       
   276 
       
   277 fun gen_arule_tac tac j rules facts =
       
   278   EVERY' (gen_rule_tac tac rules facts :: replicate j Tactic.assume_tac);
       
   279 
       
   280 fun gen_some_rule_tac tac arg_rules ctxt facts = SUBGOAL (fn (goal, i) =>
       
   281   let
       
   282     val rules =
       
   283       if not (null arg_rules) then arg_rules
       
   284       else List.concat (ContextRules.find_rules false facts goal ctxt)
       
   285   in trace ctxt rules; tac rules facts i end);
       
   286 
       
   287 fun meth tac x = METHOD (HEADGOAL o tac x);
       
   288 fun meth' tac x y = METHOD (HEADGOAL o tac x y);
       
   289 
       
   290 in
       
   291 
       
   292 val rule_tac = gen_rule_tac Tactic.resolve_tac;
       
   293 val rule = meth rule_tac;
       
   294 val some_rule_tac = gen_some_rule_tac rule_tac;
       
   295 val some_rule = meth' some_rule_tac;
       
   296 
       
   297 val erule = meth' (gen_arule_tac Tactic.eresolve_tac);
       
   298 val drule = meth' (gen_arule_tac Tactic.dresolve_tac);
       
   299 val frule = meth' (gen_arule_tac Tactic.forward_tac);
       
   300 
       
   301 end;
       
   302 
       
   303 
       
   304 (* this *)
       
   305 
       
   306 val this = METHOD (EVERY o map (HEADGOAL o Tactic.rtac));
       
   307 
       
   308 
       
   309 (* assumption *)
       
   310 
       
   311 fun asm_tac ths =
       
   312   foldr (op APPEND') (K no_tac) (map (fn th => Tactic.rtac th THEN_ALL_NEW assume_tac) ths);
       
   313 
       
   314 val refl_tac = SUBGOAL (fn (prop, i) =>
       
   315   if can Logic.dest_equals (Logic.strip_assums_concl prop)
       
   316   then Tactic.rtac Drule.reflexive_thm i else no_tac);
       
   317 
       
   318 fun assm_tac ctxt =
       
   319   assume_tac APPEND'
       
   320   asm_tac (ProofContext.prems_of ctxt) APPEND'
       
   321   refl_tac;
       
   322 
       
   323 fun assumption_tac ctxt [] = assm_tac ctxt
       
   324   | assumption_tac _ [fact] = asm_tac [fact]
       
   325   | assumption_tac _ _ = K no_tac;
       
   326 
       
   327 fun assumption ctxt = METHOD (HEADGOAL o assumption_tac ctxt);
       
   328 
       
   329 
       
   330 (* res_inst_tac etc. *)
       
   331 
       
   332 (*Reimplemented to support both static (Isar) and dynamic (proof state)
       
   333   context.  By Clemens Ballarin.*)
       
   334 
   343 
   335 fun bires_inst_tac bires_flag ctxt insts thm =
   344 fun bires_inst_tac bires_flag ctxt insts thm =
   336   let
   345   let
   337     val sign = ProofContext.sign_of ctxt;
   346     val thy = ProofContext.theory_of ctxt;
   338     (* Separate type and term insts *)
   347     (* Separate type and term insts *)
   339     fun has_type_var ((x, _), _) = (case Symbol.explode x of
   348     fun has_type_var ((x, _), _) = (case Symbol.explode x of
   340           "'"::cs => true | cs => false);
   349           "'"::cs => true | cs => false);
   341     val Tinsts = List.filter has_type_var insts;
   350     val Tinsts = List.filter has_type_var insts;
   342     val tinsts = filter_out has_type_var insts;
   351     val tinsts = filter_out has_type_var insts;
   352     fun absent xi = error
   361     fun absent xi = error
   353           ("No such variable in theorem: " ^ Syntax.string_of_vname xi);
   362           ("No such variable in theorem: " ^ Syntax.string_of_vname xi);
   354     val (rtypes, rsorts) = types_sorts thm;
   363     val (rtypes, rsorts) = types_sorts thm;
   355     fun readT (xi, s) =
   364     fun readT (xi, s) =
   356         let val S = case rsorts xi of SOME S => S | NONE => absent xi;
   365         let val S = case rsorts xi of SOME S => S | NONE => absent xi;
   357             val T = Sign.read_typ (sign, sorts) s;
   366             val T = Sign.read_typ (thy, sorts) s;
   358             val U = TVar (xi, S);
   367             val U = TVar (xi, S);
   359         in if Sign.typ_instance sign (T, U) then (U, T)
   368         in if Sign.typ_instance thy (T, U) then (U, T)
   360            else error
   369            else error
   361              ("Instantiation of " ^ Syntax.string_of_vname xi ^ " fails")
   370              ("Instantiation of " ^ Syntax.string_of_vname xi ^ " fails")
   362         end;
   371         end;
   363     val Tinsts_env = map readT Tinsts;
   372     val Tinsts_env = map readT Tinsts;
   364     (* Preprocess rule: extract vars and their types, apply Tinsts *)
   373     (* Preprocess rule: extract vars and their types, apply Tinsts *)
   385         val envT' = map (fn (ixn, T) =>
   394         val envT' = map (fn (ixn, T) =>
   386           (TVar (ixn, the (rsorts ixn)), T)) envT @ Tinsts_env;
   395           (TVar (ixn, the (rsorts ixn)), T)) envT @ Tinsts_env;
   387         val cenv =
   396         val cenv =
   388           map
   397           map
   389             (fn (xi, t) =>
   398             (fn (xi, t) =>
   390               pairself (Thm.cterm_of sign) (Var (xi, fastype_of t), t))
   399               pairself (Thm.cterm_of thy) (Var (xi, fastype_of t), t))
   391             (gen_distinct
   400             (gen_distinct
   392               (fn ((x1, t1), (x2, t2)) => x1 = x2 andalso t1 aconv t2)
   401               (fn ((x1, t1), (x2, t2)) => x1 = x2 andalso t1 aconv t2)
   393               (xis ~~ ts));
   402               (xis ~~ ts));
   394         (* Lift and instantiate rule *)
   403         (* Lift and instantiate rule *)
   395         val {maxidx, ...} = rep_thm st;
   404         val {maxidx, ...} = rep_thm st;
   400           | liftvar t = raise TERM("Variable expected", [t]);
   409           | liftvar t = raise TERM("Variable expected", [t]);
   401         fun liftterm t = list_abs_free
   410         fun liftterm t = list_abs_free
   402               (params, Logic.incr_indexes(paramTs,inc) t)
   411               (params, Logic.incr_indexes(paramTs,inc) t)
   403         fun liftpair (cv,ct) =
   412         fun liftpair (cv,ct) =
   404               (cterm_fun liftvar cv, cterm_fun liftterm ct)
   413               (cterm_fun liftvar cv, cterm_fun liftterm ct)
   405         val lifttvar = pairself (ctyp_of sign o Logic.incr_tvar inc);
   414         val lifttvar = pairself (ctyp_of thy o Logic.incr_tvar inc);
   406         val rule = Drule.instantiate
   415         val rule = Drule.instantiate
   407               (map lifttvar envT', map liftpair cenv)
   416               (map lifttvar envT', map liftpair cenv)
   408               (lift_rule (st, i) thm)
   417               (lift_rule (st, i) thm)
   409       in
   418       in
   410         if i > nprems_of st then no_tac st
   419         if i > nprems_of st then no_tac st
   415                 | THM  (msg,_,_) => (warning msg; no_tac st);
   424                 | THM  (msg,_,_) => (warning msg; no_tac st);
   416   in
   425   in
   417     tac
   426     tac
   418   end;
   427   end;
   419 
   428 
       
   429 local
       
   430 
   420 fun gen_inst _ tac _ (quant, ([], thms)) =
   431 fun gen_inst _ tac _ (quant, ([], thms)) =
   421       METHOD (fn facts => quant (insert_tac facts THEN' tac thms))
   432       METHOD (fn facts => quant (insert_tac facts THEN' tac thms))
   422   | gen_inst inst_tac _ ctxt (quant, (insts, [thm])) =
   433   | gen_inst inst_tac _ ctxt (quant, (insts, [thm])) =
   423       METHOD (fn facts =>
   434       METHOD (fn facts =>
   424         quant (insert_tac facts THEN' inst_tac ctxt insts thm))
   435         quant (insert_tac facts THEN' inst_tac ctxt insts thm))
   425   | gen_inst _ _ _ _ = error "Cannot have instantiations with multiple rules";
   436   | gen_inst _ _ _ _ = error "Cannot have instantiations with multiple rules";
   426 
   437 
   427 val res_inst_meth = gen_inst (bires_inst_tac false) Tactic.resolve_tac;
       
   428 
       
   429 val eres_inst_meth = gen_inst (bires_inst_tac true) Tactic.eresolve_tac;
       
   430 
       
   431 (* Preserve Var indexes of rl; increment revcut_rl instead.
   438 (* Preserve Var indexes of rl; increment revcut_rl instead.
   432    Copied from tactic.ML *)
   439    Copied from tactic.ML *)
   433 fun make_elim_preserve rl =
   440 fun make_elim_preserve rl =
   434   let val {maxidx,...} = rep_thm rl
   441   let val {maxidx,...} = rep_thm rl
   435       fun cvar xi = cterm_of (Theory.sign_of ProtoPure.thy) (Var(xi,propT));
   442       fun cvar xi = cterm_of ProtoPure.thy (Var(xi,propT));
   436       val revcut_rl' =
   443       val revcut_rl' =
   437           instantiate ([],  [(cvar("V",0), cvar("V",maxidx+1)),
   444           instantiate ([],  [(cvar("V",0), cvar("V",maxidx+1)),
   438                              (cvar("W",0), cvar("W",maxidx+1))]) revcut_rl
   445                              (cvar("W",0), cvar("W",maxidx+1))]) revcut_rl
   439       val arg = (false, rl, nprems_of rl)
   446       val arg = (false, rl, nprems_of rl)
   440       val [th] = Seq.list_of (bicompose false arg 1 revcut_rl')
   447       val [th] = Seq.list_of (bicompose false arg 1 revcut_rl')
   441   in  th  end
   448   in  th  end
   442   handle Bind => raise THM("make_elim_preserve", 1, [rl]);
   449   handle Bind => raise THM("make_elim_preserve", 1, [rl]);
   443 
   450 
       
   451 in
       
   452 
       
   453 val res_inst_meth = gen_inst (bires_inst_tac false) Tactic.resolve_tac;
       
   454 
       
   455 val eres_inst_meth = gen_inst (bires_inst_tac true) Tactic.eresolve_tac;
       
   456 
   444 val cut_inst_meth =
   457 val cut_inst_meth =
   445   gen_inst
   458   gen_inst
   446     (fn ctxt => fn insts => fn thm =>
   459     (fn ctxt => fn insts => bires_inst_tac false ctxt insts o make_elim_preserve)
   447        bires_inst_tac false ctxt insts (make_elim_preserve thm))
       
   448     Tactic.cut_rules_tac;
   460     Tactic.cut_rules_tac;
   449 
   461 
   450 val dres_inst_meth =
   462 val dres_inst_meth =
   451   gen_inst
   463   gen_inst
   452     (fn ctxt => fn insts => fn rule =>
   464     (fn ctxt => fn insts => bires_inst_tac true ctxt insts o make_elim_preserve)
   453        bires_inst_tac true ctxt insts (make_elim_preserve rule))
       
   454     Tactic.dresolve_tac;
   465     Tactic.dresolve_tac;
   455 
   466 
   456 val forw_inst_meth =
   467 val forw_inst_meth =
   457   gen_inst
   468   gen_inst
   458     (fn ctxt => fn insts => fn rule =>
   469     (fn ctxt => fn insts => fn rule =>
   459        bires_inst_tac false ctxt insts (make_elim_preserve rule) THEN'
   470        bires_inst_tac false ctxt insts (make_elim_preserve rule) THEN'
   460        assume_tac)
   471        assume_tac)
   461     Tactic.forward_tac;
   472     Tactic.forward_tac;
   462 
   473 
   463 fun subgoal_tac ctxt sprop =
   474 fun subgoal_tac ctxt sprop =
   464   DETERM o bires_inst_tac false ctxt [(("psi", 0), sprop)] cut_rl THEN'
   475   DETERM o bires_inst_tac false ctxt [(("psi", 0), sprop)] cut_rl;
   465   SUBGOAL (fn (prop, _) =>
       
   466     let val concl' = Logic.strip_assums_concl prop in
       
   467       if null (term_tvars concl') then ()
       
   468       else warning "Type variables in new subgoal: add a type constraint?";
       
   469       all_tac
       
   470   end);
       
   471 
   476 
   472 fun subgoals_tac ctxt sprops = EVERY' (map (subgoal_tac ctxt) sprops);
   477 fun subgoals_tac ctxt sprops = EVERY' (map (subgoal_tac ctxt) sprops);
   473 
   478 
   474 fun thin_tac ctxt s =
   479 fun thin_tac ctxt s =
   475   bires_inst_tac true ctxt [(("V", 0), s)] thin_rl;
   480   bires_inst_tac true ctxt [(("V", 0), s)] thin_rl;
   476 
   481 
   477 
   482 end;
   478 (* simple Prolog interpreter *)
       
   479 
       
   480 fun prolog_tac rules facts =
       
   481   DEPTH_SOLVE_1 (HEADGOAL (Tactic.assume_tac APPEND' Tactic.resolve_tac (facts @ rules)));
       
   482 
       
   483 val prolog = METHOD o prolog_tac;
       
   484 
   483 
   485 
   484 
   486 (* ML tactics *)
   485 (* ML tactics *)
   487 
   486 
   488 val tactic_ref = ref ((fn _ => raise Match): Proof.context -> thm list -> tactic);
   487 val tactic_ref = ref ((fn _ => raise Match): ProofContext.context -> thm list -> tactic);
   489 fun set_tactic f = tactic_ref := f;
   488 fun set_tactic f = tactic_ref := f;
   490 
   489 
   491 fun tactic txt ctxt = METHOD (fn facts =>
   490 fun tactic txt ctxt = METHOD (fn facts =>
   492   (Context.use_mltext
   491   (Context.use_mltext
   493     ("let fun tactic (ctxt: Proof.context) (facts: thm list) : tactic = \
   492     ("let fun tactic (ctxt: ProofContext.context) (facts: thm list) : tactic = \
   494        \let val thm = ProofContext.get_thm_closure ctxt o PureThy.Name\n\
   493        \let val thm = ProofContext.get_thm_closure ctxt o PureThy.Name\n\
   495        \  and thms = ProofContext.get_thms_closure ctxt o PureThy.Name in\n"
   494        \  and thms = ProofContext.get_thms_closure ctxt o PureThy.Name in\n"
   496        ^ txt ^
   495        ^ txt ^
   497        "\nend in Method.set_tactic tactic end")
   496        "\nend in Method.set_tactic tactic end")
   498     false NONE;
   497     false NONE;
   499     Context.setmp (SOME (ProofContext.theory_of ctxt)) (! tactic_ref ctxt) facts));
   498     Context.setmp (SOME (ProofContext.theory_of ctxt)) (! tactic_ref ctxt) facts));
   500 
   499 
   501 
   500 
   502 
   501 
   503 (** methods theory data **)
   502 (** method syntax **)
   504 
   503 
   505 (* data kind 'Isar/methods' *)
   504 (* method text *)
       
   505 
       
   506 type src = Args.src;
       
   507 
       
   508 datatype text =
       
   509   Basic of (ProofContext.context -> method) |
       
   510   Source of src |
       
   511   Then of text list |
       
   512   Orelse of text list |
       
   513   Try of text |
       
   514   Repeat1 of text;
       
   515 
       
   516 val default_text = Source (Args.src (("default", []), Position.none));
       
   517 val this_text = Basic (K this);
       
   518 val done_text = Basic (K (SIMPLE_METHOD all_tac));
       
   519 
       
   520 fun finish_text asm NONE = Basic (close asm)
       
   521   | finish_text asm (SOME txt) = Then [txt, Basic (close asm)];
       
   522 
       
   523 
       
   524 (* method definitions *)
   506 
   525 
   507 structure MethodsData = TheoryDataFun
   526 structure MethodsData = TheoryDataFun
   508 (struct
   527 (struct
   509   val name = "Isar/methods";
   528   val name = "Isar/methods";
   510   type T = (((src -> Proof.context -> Proof.method) * string) * stamp) NameSpace.table;
   529   type T = (((src -> ProofContext.context -> method) * string) * stamp) NameSpace.table;
   511 
   530 
   512   val empty = NameSpace.empty_table;
   531   val empty = NameSpace.empty_table;
   513   val copy = I;
   532   val copy = I;
   514   val extend = I;
   533   val extend = I;
   515   fun merge _ tables = NameSpace.merge_tables eq_snd tables handle Symtab.DUPS dups =>
   534   fun merge _ tables = NameSpace.merge_tables eq_snd tables handle Symtab.DUPS dups =>
   546         | SOME ((mth, _), _) => transform_failure (curry METHOD_FAIL (name, pos)) (mth src))
   565         | SOME ((mth, _), _) => transform_failure (curry METHOD_FAIL (name, pos)) (mth src))
   547       end;
   566       end;
   548   in meth end;
   567   in meth end;
   549 
   568 
   550 
   569 
   551 (* add_method(s) *)
   570 (* add method *)
   552 
   571 
   553 fun add_methods raw_meths thy =
   572 fun add_methods raw_meths thy =
   554   let
   573   let
   555     val sg = Theory.sign_of thy;
       
   556     val new_meths = raw_meths |> map (fn (name, f, comment) =>
   574     val new_meths = raw_meths |> map (fn (name, f, comment) =>
   557       (name, ((f, comment), stamp ())));
   575       (name, ((f, comment), stamp ())));
   558 
   576 
   559     fun add meths = NameSpace.extend_table (Sign.naming_of sg) (meths, new_meths)
   577     fun add meths = NameSpace.extend_table (Sign.naming_of thy) (meths, new_meths)
   560       handle Symtab.DUPS dups =>
   578       handle Symtab.DUPS dups =>
   561         error ("Duplicate declaration of method(s) " ^ commas_quote dups);
   579         error ("Duplicate declaration of method(s) " ^ commas_quote dups);
   562   in MethodsData.map add thy end;
   580   in MethodsData.map add thy end;
   563 
   581 
   564 val add_method = add_methods o Library.single;
   582 val add_method = add_methods o Library.single;
   565 
   583 
   566 (*implicit version*)
       
   567 fun Method name meth cmt = Context.>> (add_methods [(name, meth, cmt)]);
   584 fun Method name meth cmt = Context.>> (add_methods [(name, meth, cmt)]);
   568 
   585 
   569 
   586 
   570 
   587 
   571 (** method syntax **)
   588 (** concrete syntax **)
   572 
   589 
   573 (* basic *)
   590 (* basic *)
   574 
   591 
   575 fun syntax (scan: (Proof.context * Args.T list -> 'a * (Proof.context * Args.T list))) =
   592 fun syntax (scan:
       
   593     (ProofContext.context * Args.T list -> 'a * (ProofContext.context * Args.T list))) =
   576   Args.syntax "method" scan;
   594   Args.syntax "method" scan;
   577 
   595 
   578 fun simple_args scan f src ctxt : Proof.method =
   596 fun simple_args scan f src ctxt : method =
   579   #2 (syntax (Scan.lift (scan >> (fn x => f x ctxt))) src ctxt);
   597   #2 (syntax (Scan.lift (scan >> (fn x => f x ctxt))) src ctxt);
   580 
   598 
   581 fun ctxt_args (f: Proof.context -> Proof.method) src ctxt =
   599 fun ctxt_args (f: ProofContext.context -> method) src ctxt =
   582   #2 (syntax (Scan.succeed (f ctxt)) src ctxt);
   600   #2 (syntax (Scan.succeed (f ctxt)) src ctxt);
   583 
   601 
   584 fun no_args m = ctxt_args (K m);
   602 fun no_args m = ctxt_args (K m);
   585 
   603 
   586 
   604 
   587 (* sections *)
   605 (* sections *)
   588 
   606 
   589 type modifier = (Proof.context -> Proof.context) * Proof.context attribute;
   607 type modifier = (ProofContext.context -> ProofContext.context) * ProofContext.context attribute;
   590 
   608 
   591 local
   609 local
   592 
   610 
   593 fun sect ss = Scan.first (map Scan.lift ss);
   611 fun sect ss = Scan.first (map Scan.lift ss);
   594 fun thms ss = Scan.unless (sect ss) Attrib.local_thms;
   612 fun thms ss = Scan.unless (sect ss) Attrib.local_thms;
   628 val destN = "dest";
   646 val destN = "dest";
   629 val ruleN = "rule";
   647 val ruleN = "rule";
   630 
   648 
   631 fun modifier name kind kind' att =
   649 fun modifier name kind kind' att =
   632   Args.$$$ name |-- (kind >> K NONE || kind' |-- Args.nat --| Args.colon >> SOME)
   650   Args.$$$ name |-- (kind >> K NONE || kind' |-- Args.nat --| Args.colon >> SOME)
   633     >> (pair (I: Proof.context -> Proof.context) o att);
   651     >> (pair (I: ProofContext.context -> ProofContext.context) o att);
   634 
   652 
   635 val rules_modifiers =
   653 val rules_modifiers =
   636  [modifier destN Args.bang_colon Args.bang ContextRules.dest_bang_local,
   654  [modifier destN Args.bang_colon Args.bang ContextRules.dest_bang_local,
   637   modifier destN Args.colon (Scan.succeed ()) ContextRules.dest_local,
   655   modifier destN Args.colon (Scan.succeed ()) ContextRules.dest_local,
   638   modifier elimN Args.bang_colon Args.bang ContextRules.elim_bang_local,
   656   modifier elimN Args.bang_colon Args.bang ContextRules.elim_bang_local,
   666 val insts_var =
   684 val insts_var =
   667   Scan.optional
   685   Scan.optional
   668     (Args.enum1 "and" (Scan.lift (Args.var -- (Args.$$$ "=" |-- Args.!!! Args.name))) --|
   686     (Args.enum1 "and" (Scan.lift (Args.var -- (Args.$$$ "=" |-- Args.!!! Args.name))) --|
   669       Scan.lift (Args.$$$ "in")) [] -- Attrib.local_thmss;
   687       Scan.lift (Args.$$$ "in")) [] -- Attrib.local_thmss;
   670 
   688 
   671 fun inst_args_var f src ctxt = f ctxt (#2 (syntax (Args.goal_spec HEADGOAL -- insts_var) src ctxt));
   689 fun inst_args_var f src ctxt =
       
   690   f ctxt (#2 (syntax (Args.goal_spec HEADGOAL -- insts_var) src ctxt));
   672 
   691 
   673 fun goal_args' args tac src ctxt = #2 (syntax (Args.goal_spec HEADGOAL -- args >>
   692 fun goal_args' args tac src ctxt = #2 (syntax (Args.goal_spec HEADGOAL -- args >>
   674   (fn (quant, s) => SIMPLE_METHOD' quant (tac s))) src ctxt);
   693   (fn (quant, s) => SIMPLE_METHOD' quant (tac s))) src ctxt);
   675 
   694 
   676 fun goal_args args tac = goal_args' (Scan.lift args) tac;
   695 fun goal_args args tac = goal_args' (Scan.lift args) tac;
   678 fun goal_args_ctxt' args tac src ctxt =
   697 fun goal_args_ctxt' args tac src ctxt =
   679   #2 (syntax (Args.goal_spec HEADGOAL -- args >>
   698   #2 (syntax (Args.goal_spec HEADGOAL -- args >>
   680   (fn (quant, s) => SIMPLE_METHOD' quant (tac ctxt s))) src ctxt);
   699   (fn (quant, s) => SIMPLE_METHOD' quant (tac ctxt s))) src ctxt);
   681 
   700 
   682 fun goal_args_ctxt args tac = goal_args_ctxt' (Scan.lift args) tac;
   701 fun goal_args_ctxt args tac = goal_args_ctxt' (Scan.lift args) tac;
   683 
       
   684 
       
   685 (** method text **)
       
   686 
       
   687 (* datatype text *)
       
   688 
       
   689 datatype text =
       
   690   Basic of (Proof.context -> Proof.method) |
       
   691   Source of src |
       
   692   Then of text list |
       
   693   Orelse of text list |
       
   694   Try of text |
       
   695   Repeat1 of text;
       
   696 
       
   697 
       
   698 (* refine *)
       
   699 
       
   700 fun gen_refine f text state =
       
   701   let
       
   702     val thy = Proof.theory_of state;
       
   703 
       
   704     fun eval (Basic mth) = f mth
       
   705       | eval (Source src) = f (method thy src)
       
   706       | eval (Then txts) = Seq.EVERY (map eval txts)
       
   707       | eval (Orelse txts) = Seq.FIRST (map eval txts)
       
   708       | eval (Try txt) = Seq.TRY (eval txt)
       
   709       | eval (Repeat1 txt) = Seq.REPEAT1 (eval txt);
       
   710   in eval text state end;
       
   711 
       
   712 val refine = gen_refine Proof.refine;
       
   713 val refine_end = gen_refine Proof.refine_end;
       
   714 
       
   715 
       
   716 (* structured proof steps *)
       
   717 
       
   718 val default_text = Source (Args.src (("default", []), Position.none));
       
   719 val this_text = Basic (K this);
       
   720 val done_text = Basic (K (SIMPLE_METHOD all_tac));
       
   721 
       
   722 fun close_text asm = Basic (fn ctxt => METHOD (K
       
   723   (FILTER Thm.no_prems ((if asm then ALLGOALS (assm_tac ctxt) else all_tac) THEN flexflex_tac))));
       
   724 
       
   725 fun finish_text asm NONE = close_text asm
       
   726   | finish_text asm (SOME txt) = Then [txt, close_text asm];
       
   727 
       
   728 fun proof opt_text state =
       
   729   state
       
   730   |> Proof.assert_backward
       
   731   |> refine (if_none opt_text default_text)
       
   732   |> Seq.map (Proof.goal_facts (K []))
       
   733   |> Seq.map Proof.enter_forward;
       
   734 
       
   735 fun local_qed asm opt_text = Proof.local_qed (refine (finish_text asm opt_text));
       
   736 fun local_terminal_proof (text, opt_text) pr =
       
   737   Seq.THEN (proof (SOME text), local_qed true opt_text pr);
       
   738 val local_default_proof = local_terminal_proof (default_text, NONE);
       
   739 val local_immediate_proof = local_terminal_proof (this_text, NONE);
       
   740 fun local_done_proof pr = Seq.THEN (proof (SOME done_text), local_qed false NONE pr);
       
   741 
       
   742 
       
   743 fun global_qeds asm opt_text = Proof.global_qed (refine (finish_text asm opt_text));
       
   744 
       
   745 fun global_qed asm opt_text state =
       
   746   state
       
   747   |> global_qeds asm opt_text
       
   748   |> Proof.check_result "Failed to finish proof" state
       
   749   |> Seq.hd;
       
   750 
       
   751 fun global_term_proof asm (text, opt_text) state =
       
   752   state
       
   753   |> proof (SOME text)
       
   754   |> Proof.check_result "Terminal proof method failed" state
       
   755   |> (Seq.flat o Seq.map (global_qeds asm opt_text))
       
   756   |> Proof.check_result "Failed to finish proof (after successful terminal method)" state
       
   757   |> Seq.hd;
       
   758 
       
   759 val global_terminal_proof = global_term_proof true;
       
   760 val global_default_proof = global_terminal_proof (default_text, NONE);
       
   761 val global_immediate_proof = global_terminal_proof (this_text, NONE);
       
   762 val global_done_proof = global_term_proof false (done_text, NONE);
       
   763 
   702 
   764 
   703 
   765 (* misc tactic emulations *)
   704 (* misc tactic emulations *)
   766 
   705 
   767 val subgoal_meth = goal_args_ctxt (Scan.repeat1 Args.name) subgoals_tac;
   706 val subgoal_meth = goal_args_ctxt (Scan.repeat1 Args.name) subgoals_tac;
   797   ("cut_tac", inst_args_var cut_inst_meth, "cut rule (dynamic instantiation)"),
   736   ("cut_tac", inst_args_var cut_inst_meth, "cut rule (dynamic instantiation)"),
   798   ("subgoal_tac", subgoal_meth, "insert subgoal (dynamic instantiation)"),
   737   ("subgoal_tac", subgoal_meth, "insert subgoal (dynamic instantiation)"),
   799   ("thin_tac", thin_meth, "remove premise (dynamic instantiation)"),
   738   ("thin_tac", thin_meth, "remove premise (dynamic instantiation)"),
   800   ("rename_tac", rename_meth, "rename parameters of goal (dynamic instantiation)"),
   739   ("rename_tac", rename_meth, "rename parameters of goal (dynamic instantiation)"),
   801   ("rotate_tac", rotate_meth, "rotate assumptions of goal"),
   740   ("rotate_tac", rotate_meth, "rotate assumptions of goal"),
   802   ("prolog", thms_args prolog, "simple prolog interpreter"),
       
   803   ("tactic", simple_args Args.name tactic, "ML tactic as proof method")];
   741   ("tactic", simple_args Args.name tactic, "ML tactic as proof method")];
   804 
   742 
   805 val _ = Context.add_setup [add_methods pure_methods];
   743 val _ = Context.add_setup [add_methods pure_methods];
   806 
   744 
   807 
   745