src/Pure/goal.ML
author wenzelm
Sat Nov 08 21:31:51 2014 +0100 (2014-11-08)
changeset 58950 d07464875dd4
parent 58837 e84d900cd287
child 58963 26bf09b95dda
permissions -rw-r--r--
optional proof context for unify operations, for the sake of proper local options;
     1 (*  Title:      Pure/goal.ML
     2     Author:     Makarius
     3 
     4 Goals in tactical theorem proving, with support for forked proofs.
     5 *)
     6 
     7 signature BASIC_GOAL =
     8 sig
     9   val parallel_proofs: int Unsynchronized.ref
    10   val SELECT_GOAL: tactic -> int -> tactic
    11   val PREFER_GOAL: tactic -> int -> tactic
    12   val CONJUNCTS: tactic -> int -> tactic
    13   val PRECISE_CONJUNCTS: int -> tactic -> int -> tactic
    14 end;
    15 
    16 signature GOAL =
    17 sig
    18   include BASIC_GOAL
    19   val init: cterm -> thm
    20   val protect: int -> thm -> thm
    21   val conclude: thm -> thm
    22   val check_finished: Proof.context -> thm -> thm
    23   val finish: Proof.context -> thm -> thm
    24   val norm_result: Proof.context -> thm -> thm
    25   val skip_proofs_enabled: unit -> bool
    26   val future_enabled: int -> bool
    27   val future_enabled_timing: Time.time -> bool
    28   val future_result: Proof.context -> thm future -> term -> thm
    29   val prove_internal: Proof.context -> cterm list -> cterm -> (thm list -> tactic) -> thm
    30   val is_schematic: term -> bool
    31   val prove_multi: Proof.context -> string list -> term list -> term list ->
    32     ({prems: thm list, context: Proof.context} -> tactic) -> thm list
    33   val prove_future: Proof.context -> string list -> term list -> term ->
    34     ({prems: thm list, context: Proof.context} -> tactic) -> thm
    35   val prove: Proof.context -> string list -> term list -> term ->
    36     ({prems: thm list, context: Proof.context} -> tactic) -> thm
    37   val prove_global_future: theory -> string list -> term list -> term ->
    38     ({prems: thm list, context: Proof.context} -> tactic) -> thm
    39   val prove_global: theory -> string list -> term list -> term ->
    40     ({prems: thm list, context: Proof.context} -> tactic) -> thm
    41   val prove_sorry: Proof.context -> string list -> term list -> term ->
    42     ({prems: thm list, context: Proof.context} -> tactic) -> thm
    43   val prove_sorry_global: theory -> string list -> term list -> term ->
    44     ({prems: thm list, context: Proof.context} -> tactic) -> thm
    45   val restrict: int -> int -> thm -> thm
    46   val unrestrict: int -> thm -> thm
    47   val conjunction_tac: int -> tactic
    48   val precise_conjunction_tac: int -> int -> tactic
    49   val recover_conjunction_tac: tactic
    50   val norm_hhf_tac: Proof.context -> int -> tactic
    51   val assume_rule_tac: Proof.context -> int -> tactic
    52 end;
    53 
    54 structure Goal: GOAL =
    55 struct
    56 
    57 (** goals **)
    58 
    59 (*
    60   -------- (init)
    61   C ==> #C
    62 *)
    63 val init =
    64   let val A = #1 (Thm.dest_implies (Thm.cprop_of Drule.protectI))
    65   in fn C => Thm.instantiate ([], [(A, C)]) Drule.protectI end;
    66 
    67 (*
    68   A1 ==> ... ==> An ==> C
    69   ------------------------ (protect n)
    70   A1 ==> ... ==> An ==> #C
    71 *)
    72 fun protect n th = Drule.comp_no_flatten (th, n) 1 Drule.protectI;
    73 
    74 (*
    75   A ==> ... ==> #C
    76   ---------------- (conclude)
    77   A ==> ... ==> C
    78 *)
    79 fun conclude th = Drule.comp_no_flatten (th, Thm.nprems_of th) 1 Drule.protectD;
    80 
    81 (*
    82   #C
    83   --- (finish)
    84    C
    85 *)
    86 fun check_finished ctxt th =
    87   if Thm.no_prems th then th
    88   else
    89     raise THM ("Proof failed.\n" ^ Pretty.string_of (Goal_Display.pretty_goal ctxt th), 0, [th]);
    90 
    91 fun finish ctxt = check_finished ctxt #> conclude;
    92 
    93 
    94 
    95 (** results **)
    96 
    97 (* normal form *)
    98 
    99 fun norm_result ctxt =
   100   Drule.flexflex_unique (SOME ctxt)
   101   #> Raw_Simplifier.norm_hhf_protect ctxt
   102   #> Thm.strip_shyps
   103   #> Drule.zero_var_indexes;
   104 
   105 
   106 (* scheduling parameters *)
   107 
   108 fun skip_proofs_enabled () =
   109   let val skip = Options.default_bool "skip_proofs" in
   110     if Proofterm.proofs_enabled () andalso skip then
   111       (warning "Proof terms enabled -- cannot skip proofs"; false)
   112     else skip
   113   end;
   114 
   115 val parallel_proofs = Unsynchronized.ref 1;
   116 
   117 fun future_enabled n =
   118   Multithreading.enabled () andalso ! parallel_proofs >= n andalso
   119   is_some (Future.worker_task ());
   120 
   121 fun future_enabled_timing t =
   122   future_enabled 1 andalso
   123     Time.toReal t >= Options.default_real "parallel_subproofs_threshold";
   124 
   125 
   126 (* future_result *)
   127 
   128 fun future_result ctxt result prop =
   129   let
   130     val thy = Proof_Context.theory_of ctxt;
   131     val cert = Thm.cterm_of thy;
   132     val certT = Thm.ctyp_of thy;
   133 
   134     val assms = Assumption.all_assms_of ctxt;
   135     val As = map Thm.term_of assms;
   136 
   137     val xs = map Free (fold Term.add_frees (prop :: As) []);
   138     val fixes = map cert xs;
   139 
   140     val tfrees = fold Term.add_tfrees (prop :: As) [];
   141     val instT = map (fn (a, S) => (certT (TVar ((a, 0), S)), certT (TFree (a, S)))) tfrees;
   142 
   143     val global_prop =
   144       cert (Logic.varify_types_global (fold_rev Logic.all xs (Logic.list_implies (As, prop))))
   145       |> Thm.weaken_sorts (Variable.sorts_of ctxt);
   146     val global_result = result |> Future.map
   147       (Drule.flexflex_unique (SOME ctxt) #>
   148         Thm.adjust_maxidx_thm ~1 #>
   149         Drule.implies_intr_list assms #>
   150         Drule.forall_intr_list fixes #>
   151         Thm.generalize (map #1 tfrees, []) 0 #>
   152         Thm.strip_shyps);
   153     val local_result =
   154       Thm.future global_result global_prop
   155       |> Thm.close_derivation
   156       |> Thm.instantiate (instT, [])
   157       |> Drule.forall_elim_list fixes
   158       |> fold (Thm.elim_implies o Thm.assume) assms;
   159   in local_result end;
   160 
   161 
   162 
   163 (** tactical theorem proving **)
   164 
   165 (* prove_internal -- minimal checks, no normalization of result! *)
   166 
   167 fun prove_internal ctxt casms cprop tac =
   168   (case SINGLE (tac (map (Assumption.assume ctxt) casms)) (init cprop) of
   169     SOME th => Drule.implies_intr_list casms (finish ctxt th)
   170   | NONE => error "Tactic failed");
   171 
   172 
   173 (* prove variations *)
   174 
   175 fun is_schematic t =
   176   Term.exists_subterm Term.is_Var t orelse
   177   Term.exists_type (Term.exists_subtype Term.is_TVar) t;
   178 
   179 fun prove_common immediate pri ctxt xs asms props tac =
   180   let
   181     val thy = Proof_Context.theory_of ctxt;
   182 
   183     val schematic = exists is_schematic props;
   184     val future = future_enabled 1;
   185     val skip = not immediate andalso not schematic andalso future andalso skip_proofs_enabled ();
   186 
   187     val pos = Position.thread_data ();
   188     fun err msg =
   189       cat_error msg
   190         ("The error(s) above occurred for the goal statement" ^ Position.here pos ^ ":\n" ^
   191           Syntax.string_of_term ctxt (Logic.list_implies (asms, Logic.mk_conjunction_list props)));
   192 
   193     fun cert_safe t = Thm.cterm_of thy (Envir.beta_norm (Term.no_dummy_patterns t))
   194       handle TERM (msg, _) => err msg | TYPE (msg, _, _) => err msg;
   195     val casms = map cert_safe asms;
   196     val cprops = map cert_safe props;
   197 
   198     val (prems, ctxt') = ctxt
   199       |> Variable.add_fixes_direct xs
   200       |> fold Variable.declare_term (asms @ props)
   201       |> Assumption.add_assumes casms
   202       ||> Variable.set_body true;
   203     val sorts = Variable.sorts_of ctxt';
   204 
   205     val stmt = Thm.weaken_sorts sorts (Conjunction.mk_conjunction_balanced cprops);
   206 
   207     fun tac' args st =
   208       if skip then ALLGOALS Skip_Proof.cheat_tac st before Skip_Proof.report ctxt
   209       else tac args st;
   210     fun result () =
   211       (case SINGLE (tac' {prems = prems, context = ctxt'}) (init stmt) of
   212         NONE => err "Tactic failed"
   213       | SOME st =>
   214           let
   215             val _ =
   216               Theory.subthy (theory_of_thm st, thy) orelse err "Bad background theory of goal state";
   217             val res =
   218               (finish ctxt' st
   219                 |> Drule.flexflex_unique (SOME ctxt')
   220                 |> Thm.check_shyps sorts
   221                 |> Thm.check_hyps (Context.Proof ctxt'))
   222               handle THM (msg, _, _) => err msg | ERROR msg => err msg;
   223           in
   224             if Unify.matches_list (Context.Proof ctxt') [Thm.term_of stmt] [Thm.prop_of res]
   225             then res
   226             else err ("Proved a different theorem: " ^ Syntax.string_of_term ctxt' (Thm.prop_of res))
   227           end);
   228     val res =
   229       if immediate orelse schematic orelse not future orelse skip then result ()
   230       else
   231         future_result ctxt'
   232           (Execution.fork {name = "Goal.prove", pos = Position.thread_data (), pri = pri} result)
   233           (Thm.term_of stmt);
   234   in
   235     Conjunction.elim_balanced (length props) res
   236     |> map (Assumption.export false ctxt' ctxt)
   237     |> Variable.export ctxt' ctxt
   238     |> map Drule.zero_var_indexes
   239   end;
   240 
   241 val prove_multi = prove_common true 0;
   242 
   243 fun prove_future_pri pri ctxt xs asms prop tac =
   244   hd (prove_common false pri ctxt xs asms [prop] tac);
   245 
   246 val prove_future = prove_future_pri ~1;
   247 
   248 fun prove ctxt xs asms prop tac = hd (prove_multi ctxt xs asms [prop] tac);
   249 
   250 fun prove_global_future thy xs asms prop tac =
   251   Drule.export_without_context (prove_future (Proof_Context.init_global thy) xs asms prop tac);
   252 
   253 fun prove_global thy xs asms prop tac =
   254   Drule.export_without_context (prove (Proof_Context.init_global thy) xs asms prop tac);
   255 
   256 fun prove_sorry ctxt xs asms prop tac =
   257   if Config.get ctxt quick_and_dirty then
   258     prove ctxt xs asms prop (fn _ => ALLGOALS Skip_Proof.cheat_tac)
   259   else (if future_enabled 1 then prove_future_pri ~2 else prove) ctxt xs asms prop tac;
   260 
   261 fun prove_sorry_global thy xs asms prop tac =
   262   Drule.export_without_context
   263     (prove_sorry (Proof_Context.init_global thy) xs asms prop tac);
   264 
   265 
   266 
   267 (** goal structure **)
   268 
   269 (* rearrange subgoals *)
   270 
   271 fun restrict i n st =
   272   if i < 1 orelse n < 1 orelse i + n - 1 > Thm.nprems_of st
   273   then raise THM ("Goal.restrict", i, [st])
   274   else rotate_prems (i - 1) st |> protect n;
   275 
   276 fun unrestrict i = conclude #> rotate_prems (1 - i);
   277 
   278 (*with structural marker*)
   279 fun SELECT_GOAL tac i st =
   280   if Thm.nprems_of st = 1 andalso i = 1 then tac st
   281   else (PRIMITIVE (restrict i 1) THEN tac THEN PRIMITIVE (unrestrict i)) st;
   282 
   283 (*without structural marker*)
   284 fun PREFER_GOAL tac i st =
   285   if i < 1 orelse i > Thm.nprems_of st then Seq.empty
   286   else (PRIMITIVE (rotate_prems (i - 1)) THEN tac THEN PRIMITIVE (rotate_prems (1 - i))) st;
   287 
   288 
   289 (* multiple goals *)
   290 
   291 fun precise_conjunction_tac 0 i = eq_assume_tac i
   292   | precise_conjunction_tac 1 i = SUBGOAL (K all_tac) i
   293   | precise_conjunction_tac n i = PRIMITIVE (Drule.with_subgoal i (Conjunction.curry_balanced n));
   294 
   295 val adhoc_conjunction_tac = REPEAT_ALL_NEW
   296   (SUBGOAL (fn (goal, i) =>
   297     if can Logic.dest_conjunction goal then resolve_tac [Conjunction.conjunctionI] i
   298     else no_tac));
   299 
   300 val conjunction_tac = SUBGOAL (fn (goal, i) =>
   301   precise_conjunction_tac (length (Logic.dest_conjunctions goal)) i ORELSE
   302   TRY (adhoc_conjunction_tac i));
   303 
   304 val recover_conjunction_tac = PRIMITIVE (fn th =>
   305   Conjunction.uncurry_balanced (Thm.nprems_of th) th);
   306 
   307 fun PRECISE_CONJUNCTS n tac =
   308   SELECT_GOAL (precise_conjunction_tac n 1
   309     THEN tac
   310     THEN recover_conjunction_tac);
   311 
   312 fun CONJUNCTS tac =
   313   SELECT_GOAL (conjunction_tac 1
   314     THEN tac
   315     THEN recover_conjunction_tac);
   316 
   317 
   318 (* hhf normal form *)
   319 
   320 fun norm_hhf_tac ctxt =
   321   resolve_tac [Drule.asm_rl]  (*cheap approximation -- thanks to builtin Logic.flatten_params*)
   322   THEN' SUBGOAL (fn (t, i) =>
   323     if Drule.is_norm_hhf t then all_tac
   324     else rewrite_goal_tac ctxt Drule.norm_hhf_eqs i);
   325 
   326 
   327 (* non-atomic goal assumptions *)
   328 
   329 fun non_atomic (Const ("Pure.imp", _) $ _ $ _) = true
   330   | non_atomic (Const ("Pure.all", _) $ _) = true
   331   | non_atomic _ = false;
   332 
   333 fun assume_rule_tac ctxt = norm_hhf_tac ctxt THEN' CSUBGOAL (fn (goal, i) =>
   334   let
   335     val ((_, goal'), ctxt') = Variable.focus_cterm goal ctxt;
   336     val goal'' = Drule.cterm_rule (singleton (Variable.export ctxt' ctxt)) goal';
   337     val Rs = filter (non_atomic o Thm.term_of) (Drule.strip_imp_prems goal'');
   338     val tacs = Rs |> map (fn R =>
   339       eresolve_tac [Raw_Simplifier.norm_hhf ctxt (Thm.trivial R)] THEN_ALL_NEW assume_tac);
   340   in fold_rev (curry op APPEND') tacs (K no_tac) i end);
   341 
   342 end;
   343 
   344 structure Basic_Goal: BASIC_GOAL = Goal;
   345 open Basic_Goal;