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