2016-04-17 20:40:00 +00:00
|
|
|
(*
|
|
|
|
* Copyright 2014, NICTA
|
|
|
|
*
|
|
|
|
* This software may be distributed and modified according to the terms of
|
|
|
|
* the BSD 2-Clause license. Note that NO WARRANTY is provided.
|
|
|
|
* See "LICENSE_BSD2.txt" for details.
|
|
|
|
*
|
|
|
|
* @TAG(NICTA_BSD)
|
|
|
|
*)
|
|
|
|
|
2015-07-08 02:30:43 +00:00
|
|
|
theory Rule_By_Method
|
2016-04-17 20:40:00 +00:00
|
|
|
imports
|
|
|
|
Main
|
|
|
|
"~~/src/HOL/Eisbach/Eisbach_Tools"
|
2015-07-08 02:30:43 +00:00
|
|
|
begin
|
|
|
|
|
|
|
|
ML \<open>
|
|
|
|
signature RULE_BY_METHOD =
|
|
|
|
sig
|
|
|
|
val rule_by_tac: Proof.context -> {vars : bool, prop: bool} ->
|
|
|
|
(Proof.context -> tactic) -> (Proof.context -> tactic) list -> Position.T -> thm
|
|
|
|
end;
|
|
|
|
|
|
|
|
|
|
|
|
fun atomize ctxt = Conv.fconv_rule (Object_Logic.atomize ctxt);
|
|
|
|
|
|
|
|
fun fix_schematics ctxt raw_st =
|
|
|
|
let
|
|
|
|
val ((schematic_types, [st']), ctxt1) = Variable.importT [raw_st] ctxt;
|
2016-01-10 06:49:15 +00:00
|
|
|
fun certify_inst ctxt inst = map (apsnd (Thm.cterm_of ctxt)) (#2 inst)
|
|
|
|
val (schematic_terms, ctxt2) =
|
2015-07-08 02:30:43 +00:00
|
|
|
Variable.import_inst true [Thm.prop_of st'] ctxt1
|
2016-01-10 06:49:15 +00:00
|
|
|
|>> certify_inst ctxt1;
|
2015-07-08 02:30:43 +00:00
|
|
|
val schematics = (schematic_types, schematic_terms);
|
|
|
|
in (Thm.instantiate schematics st', ctxt2) end
|
|
|
|
|
|
|
|
fun curry_asm ctxt st = if Thm.nprems_of st = 0 then Seq.empty else
|
|
|
|
let
|
|
|
|
|
|
|
|
val prems = Thm.cprem_of st 1 |> Thm.term_of |> Logic.strip_imp_prems;
|
|
|
|
|
|
|
|
val (thesis :: xs,ctxt') = Variable.variant_fixes ("thesis" :: replicate (length prems) "P") ctxt;
|
|
|
|
|
|
|
|
val rl =
|
|
|
|
xs
|
|
|
|
|> map (fn x => Thm.cterm_of ctxt' (Free (x, propT)))
|
|
|
|
|> Conjunction.mk_conjunction_balanced
|
|
|
|
|> (fn xs => Thm.apply (Thm.apply @{cterm "Pure.imp"} xs) (Thm.cterm_of ctxt' (Free (thesis,propT))))
|
|
|
|
|> Thm.assume
|
|
|
|
|> Conjunction.curry_balanced (length prems)
|
|
|
|
|> Drule.implies_intr_hyps
|
|
|
|
|
|
|
|
val rl' = singleton (Variable.export ctxt' ctxt) rl;
|
|
|
|
|
|
|
|
in Thm.bicompose (SOME ctxt) {flatten = false, match = false, incremented = false}
|
|
|
|
(false, rl', 1) 1 st end;
|
|
|
|
|
2017-07-12 05:13:51 +00:00
|
|
|
val drop_trivial_imp =
|
2015-07-08 02:30:43 +00:00
|
|
|
let
|
2017-07-12 05:13:51 +00:00
|
|
|
val asm =
|
|
|
|
Thm.assume (Drule.protect @{cprop "(PROP A \<Longrightarrow> PROP A) \<Longrightarrow> PROP A"})
|
2015-07-08 02:30:43 +00:00
|
|
|
|> Goal.conclude;
|
|
|
|
|
|
|
|
in
|
|
|
|
Thm.implies_elim asm (Thm.trivial @{cprop "PROP A"})
|
|
|
|
|> Drule.implies_intr_hyps
|
|
|
|
|> Thm.generalize ([],["A"]) 1
|
|
|
|
|> Drule.zero_var_indexes
|
|
|
|
end
|
|
|
|
|
2017-07-12 05:13:51 +00:00
|
|
|
val drop_trivial_imp' =
|
2015-07-08 02:30:43 +00:00
|
|
|
let
|
2017-07-12 05:13:51 +00:00
|
|
|
val asm =
|
|
|
|
Thm.assume (Drule.protect @{cprop "(PROP P \<Longrightarrow> A) \<Longrightarrow> A"})
|
2015-07-08 02:30:43 +00:00
|
|
|
|> Goal.conclude;
|
|
|
|
|
|
|
|
val asm' = Thm.assume @{cprop "PROP P == Trueprop A"}
|
|
|
|
|
|
|
|
in
|
|
|
|
Thm.implies_elim asm (asm' COMP Drule.equal_elim_rule1)
|
|
|
|
|> Thm.implies_elim (asm' COMP Drule.equal_elim_rule2)
|
|
|
|
|> Drule.implies_intr_hyps
|
|
|
|
|> Thm.permute_prems 0 ~1
|
|
|
|
|> Thm.generalize ([],["A","P"]) 1
|
|
|
|
|> Drule.zero_var_indexes
|
|
|
|
end
|
2017-07-12 05:13:51 +00:00
|
|
|
|
|
|
|
fun atomize_equiv_tac ctxt i =
|
2015-07-08 02:30:43 +00:00
|
|
|
Object_Logic.full_atomize_tac ctxt i
|
2017-07-12 05:13:51 +00:00
|
|
|
THEN PRIMITIVE (fn st' =>
|
2015-07-08 02:30:43 +00:00
|
|
|
let val (_,[A,_]) = Drule.strip_comb (Thm.cprem_of st' i) in
|
|
|
|
if Object_Logic.is_judgment ctxt (Thm.term_of A) then st'
|
|
|
|
else error ("Failed to fully atomize result:\n" ^ (Syntax.string_of_term ctxt (Thm.term_of A))) end)
|
|
|
|
|
|
|
|
|
|
|
|
structure Data = Proof_Data
|
|
|
|
(
|
|
|
|
type T = thm list * bool;
|
|
|
|
fun init _ = ([],false);
|
|
|
|
);
|
|
|
|
|
|
|
|
val empty_rule_prems = Data.map (K ([],true));
|
|
|
|
|
|
|
|
fun add_rule_prem thm = Data.map (apfst (Thm.add_thm thm));
|
|
|
|
|
|
|
|
fun with_rule_prems enabled parse =
|
2017-03-28 10:37:51 +00:00
|
|
|
Scan.state :|-- (fn context =>
|
|
|
|
let
|
|
|
|
val context' = Context.proof_of context |> Data.map (K ([Drule.free_dummy_thm],enabled))
|
|
|
|
|> Context.Proof
|
|
|
|
in Scan.lift (Scan.pass context' parse) end)
|
|
|
|
|
2015-07-08 02:30:43 +00:00
|
|
|
|
2017-07-12 05:13:51 +00:00
|
|
|
fun get_rule_prems ctxt =
|
2015-07-08 02:30:43 +00:00
|
|
|
let
|
|
|
|
val (thms,b) = Data.get ctxt
|
2016-11-25 01:21:40 +00:00
|
|
|
in if (not b) then [] else thms end
|
2015-07-08 02:30:43 +00:00
|
|
|
|
|
|
|
|
|
|
|
fun zip_subgoal assume tac (ctxt,st : thm) = if Thm.nprems_of st = 0 then Seq.single (ctxt,st) else
|
|
|
|
let
|
|
|
|
fun bind_prems st' =
|
|
|
|
let
|
|
|
|
val prems = Drule.cprems_of st';
|
|
|
|
val (asms, ctxt') = Assumption.add_assumes prems ctxt;
|
|
|
|
val ctxt'' = fold add_rule_prem asms ctxt';
|
2015-09-18 07:44:00 +00:00
|
|
|
val st'' = Goal.conclude (Drule.implies_elim_list st' (map Thm.assume prems));
|
2015-07-08 02:30:43 +00:00
|
|
|
in (ctxt'',st'') end
|
|
|
|
|
|
|
|
fun defer_prems st' =
|
|
|
|
let
|
|
|
|
val nprems = Thm.nprems_of st';
|
|
|
|
val st'' = Thm.permute_prems 0 nprems (Goal.conclude st');
|
|
|
|
in (ctxt,st'') end;
|
|
|
|
|
2017-07-12 05:13:51 +00:00
|
|
|
|
|
|
|
in
|
2015-07-08 02:30:43 +00:00
|
|
|
tac ctxt (Goal.protect 1 st)
|
|
|
|
|> Seq.map (if assume then bind_prems else defer_prems) end
|
|
|
|
|
|
|
|
|
|
|
|
fun zip_subgoals assume tacs pos ctxt st =
|
|
|
|
let
|
|
|
|
val nprems = Thm.nprems_of st;
|
|
|
|
val _ = nprems < length tacs andalso error ("More tactics than rule assumptions" ^ Position.here pos);
|
|
|
|
val tacs' = map (zip_subgoal assume) (tacs @ (replicate (nprems - length tacs) (K all_tac)));
|
|
|
|
val ctxt' = empty_rule_prems ctxt;
|
|
|
|
in Seq.EVERY tacs' (ctxt',st) end;
|
|
|
|
|
2017-03-20 03:57:55 +00:00
|
|
|
fun rule_by_tac' ctxt {vars,prop} tac asm_tacs pos raw_st =
|
2015-07-08 02:30:43 +00:00
|
|
|
let
|
|
|
|
val (st,ctxt1) = if vars then (raw_st,ctxt) else fix_schematics ctxt raw_st;
|
|
|
|
|
|
|
|
val ([x],ctxt2) = Proof_Context.add_fixes [(Binding.name Auto_Bind.thesisN,NONE, NoSyn)] ctxt1;
|
|
|
|
|
|
|
|
val thesis = if prop then Free (x,propT) else Object_Logic.fixed_judgment ctxt2 x;
|
|
|
|
|
|
|
|
val cthesis = Thm.cterm_of ctxt thesis;
|
|
|
|
|
2016-01-10 06:49:15 +00:00
|
|
|
val revcut_rl' = Thm.instantiate' [] ([NONE,SOME cthesis]) @{thm revcut_rl};
|
2015-07-08 02:30:43 +00:00
|
|
|
|
|
|
|
fun is_thesis t = Logic.strip_assums_concl t aconv thesis;
|
|
|
|
|
2017-03-20 03:57:55 +00:00
|
|
|
fun err thm str = error (str ^ Position.here pos ^ "\n" ^
|
|
|
|
(Pretty.string_of (Goal_Display.pretty_goal ctxt thm)));
|
2015-07-08 02:30:43 +00:00
|
|
|
|
|
|
|
fun pop_thesis st =
|
|
|
|
let
|
|
|
|
val prems = Thm.prems_of st |> tag_list 0;
|
|
|
|
val (i,_) = (case filter (is_thesis o snd) prems of
|
2017-03-20 03:57:55 +00:00
|
|
|
[] => err st "Lost thesis"
|
2015-07-08 02:30:43 +00:00
|
|
|
| [x] => x
|
2017-03-20 03:57:55 +00:00
|
|
|
| _ => err st "More than one result obtained");
|
2015-07-08 02:30:43 +00:00
|
|
|
in st |> Thm.permute_prems 0 i end
|
2017-07-12 05:13:51 +00:00
|
|
|
|
|
|
|
val asm_st =
|
2015-07-08 02:30:43 +00:00
|
|
|
(revcut_rl' OF [st])
|
|
|
|
|> (fn st => Goal.protect (Thm.nprems_of st - 1) st)
|
|
|
|
|
|
|
|
|
|
|
|
val (ctxt3,concl_st) = case Seq.pull (zip_subgoals (not vars) asm_tacs pos ctxt2 asm_st) of
|
|
|
|
SOME (x,_) => x
|
2017-03-20 03:57:55 +00:00
|
|
|
| NONE => error ("Failed to apply tactics to rule assumptions. " ^ (Position.here pos));
|
2015-07-08 02:30:43 +00:00
|
|
|
|
2017-03-20 03:57:55 +00:00
|
|
|
val concl_st_prepped =
|
2015-07-08 02:30:43 +00:00
|
|
|
concl_st
|
|
|
|
|> Goal.conclude
|
|
|
|
|> (fn st => Goal.protect (Thm.nprems_of st) st |> Thm.permute_prems 0 ~1 |> Goal.protect 1)
|
2017-03-20 03:57:55 +00:00
|
|
|
|
|
|
|
val concl_st_result = concl_st_prepped
|
2015-07-08 02:30:43 +00:00
|
|
|
|> (tac ctxt3
|
|
|
|
THEN (PRIMITIVE pop_thesis)
|
|
|
|
THEN curry_asm ctxt
|
|
|
|
THEN PRIMITIVE (Goal.conclude #> Thm.permute_prems 0 1 #> Goal.conclude))
|
|
|
|
|
|
|
|
val result = (case Seq.pull concl_st_result of
|
|
|
|
SOME (result,_) => singleton (Proof_Context.export ctxt3 ctxt) result
|
2017-03-20 03:57:55 +00:00
|
|
|
| NONE => err concl_st_prepped "Failed to apply tactic to rule conclusion:")
|
2015-07-08 02:30:43 +00:00
|
|
|
|
|
|
|
val drop_rule = if prop then drop_trivial_imp else drop_trivial_imp'
|
|
|
|
|
2017-07-12 05:13:51 +00:00
|
|
|
val result' = ((Goal.protect (Thm.nprems_of result -1) result) RS drop_rule)
|
2015-07-08 02:30:43 +00:00
|
|
|
|> (if prop then all_tac else
|
|
|
|
(atomize_equiv_tac ctxt (Thm.nprems_of result)
|
|
|
|
THEN resolve_tac ctxt @{thms Pure.reflexive} (Thm.nprems_of result)))
|
|
|
|
|> Seq.hd
|
|
|
|
|> Raw_Simplifier.norm_hhf ctxt
|
|
|
|
|
|
|
|
in Drule.zero_var_indexes result' end;
|
|
|
|
|
2017-03-20 03:57:55 +00:00
|
|
|
fun rule_by_tac is_closed ctxt args tac asm_tacs pos raw_st =
|
|
|
|
let val f = rule_by_tac' ctxt args tac asm_tacs pos
|
|
|
|
in
|
2017-03-20 07:21:45 +00:00
|
|
|
if is_closed orelse Context_Position.is_really_visible ctxt then SOME (f raw_st)
|
|
|
|
else try f raw_st
|
2017-03-20 03:57:55 +00:00
|
|
|
end
|
2015-07-08 02:30:43 +00:00
|
|
|
|
2017-03-20 03:57:55 +00:00
|
|
|
fun pos_closure (scan : 'a context_parser) :
|
|
|
|
(('a * (Position.T * bool)) context_parser) = (fn (context,toks) =>
|
2015-07-08 02:30:43 +00:00
|
|
|
let
|
|
|
|
val (((context',x),tr_toks),toks') = Scan.trace (Scan.pass context (Scan.state -- scan)) toks;
|
|
|
|
val pos = Token.range_of tr_toks;
|
2017-03-20 03:57:55 +00:00
|
|
|
val is_closed = exists (fn t => is_some (Token.get_value t)) tr_toks
|
|
|
|
in ((x,(Position.range_position pos, is_closed)),(context',toks')) end)
|
2015-07-08 02:30:43 +00:00
|
|
|
|
|
|
|
val parse_flags = Args.mode "schematic" -- Args.mode "raw_prop" >> (fn (b,b') => {vars = b, prop = b'})
|
|
|
|
|
2016-01-12 03:58:16 +00:00
|
|
|
fun tac m ctxt =
|
|
|
|
Method.NO_CONTEXT_TACTIC ctxt
|
2016-11-10 21:45:41 +00:00
|
|
|
(Method.evaluate_runtime m ctxt []);
|
2015-07-08 02:30:43 +00:00
|
|
|
|
2017-03-20 03:57:55 +00:00
|
|
|
(* Declare as a mixed attribute to avoid any partial evaluation *)
|
|
|
|
|
2017-03-20 07:21:45 +00:00
|
|
|
fun handle_dummy f (context, thm) =
|
|
|
|
case (f context thm) of SOME thm' => (NONE, SOME thm')
|
|
|
|
| NONE => (SOME context, SOME Drule.free_dummy_thm)
|
|
|
|
|
|
|
|
val (rule_prems_by_method : attribute context_parser) = Scan.lift parse_flags :-- (fn flags =>
|
2017-03-20 03:57:55 +00:00
|
|
|
pos_closure (Scan.repeat1
|
|
|
|
(with_rule_prems (not (#vars flags)) Method.text_closure ||
|
2017-03-20 07:21:45 +00:00
|
|
|
Scan.lift (Args.$$$ "_" >> (K Method.succeed_text))))) >>
|
|
|
|
(fn (flags,(ms,(pos, is_closed))) => handle_dummy (fn context =>
|
|
|
|
rule_by_tac is_closed (Context.proof_of context) flags (K all_tac) (map tac ms) pos))
|
2015-07-08 02:30:43 +00:00
|
|
|
|
2017-03-20 07:21:45 +00:00
|
|
|
val (rule_concl_by_method : attribute context_parser) = Scan.lift parse_flags :-- (fn flags =>
|
2017-03-20 03:57:55 +00:00
|
|
|
pos_closure (with_rule_prems (not (#vars flags)) Method.text_closure)) >>
|
2017-03-20 07:21:45 +00:00
|
|
|
(fn (flags,(m,(pos, is_closed))) => handle_dummy (fn context =>
|
|
|
|
rule_by_tac is_closed (Context.proof_of context) flags (tac m) [] pos))
|
2015-07-08 02:30:43 +00:00
|
|
|
|
2017-03-20 07:21:45 +00:00
|
|
|
val _ = Theory.setup
|
|
|
|
(Global_Theory.add_thms_dynamic (@{binding "rule_prems"},
|
2015-07-08 02:30:43 +00:00
|
|
|
(fn context => get_rule_prems (Context.proof_of context))) #>
|
|
|
|
Attrib.setup @{binding "#"} rule_prems_by_method
|
|
|
|
"transform rule premises with method" #>
|
|
|
|
Attrib.setup @{binding "@"} rule_concl_by_method
|
2017-03-28 10:37:51 +00:00
|
|
|
"transform rule conclusion with method" #>
|
|
|
|
Attrib.setup @{binding atomized}
|
|
|
|
(Scan.succeed (Thm.rule_attribute []
|
|
|
|
(fn context => fn thm =>
|
|
|
|
Conv.fconv_rule (Object_Logic.atomize (Context.proof_of context)) thm
|
|
|
|
|> Drule.zero_var_indexes)))
|
|
|
|
"atomize rule")
|
2015-07-08 02:30:43 +00:00
|
|
|
\<close>
|
|
|
|
|
2017-03-20 03:57:55 +00:00
|
|
|
experiment begin
|
|
|
|
|
|
|
|
ML \<open>
|
2017-03-20 07:21:45 +00:00
|
|
|
val [att] = @{attributes [@\<open>erule thin_rl, cut_tac TrueI, fail\<close>]}
|
2017-03-20 03:57:55 +00:00
|
|
|
val k = Attrib.attribute @{context} att
|
|
|
|
val _ = case (try k (Context.Proof @{context}, Drule.dummy_thm)) of
|
|
|
|
SOME _ => error "Should fail"
|
|
|
|
| _ => ()
|
|
|
|
\<close>
|
|
|
|
|
|
|
|
lemmas baz = [[@\<open>erule thin_rl, rule revcut_rl[of "P \<longrightarrow> P \<and> P"], simp\<close>]] for P
|
|
|
|
|
2017-03-20 07:21:45 +00:00
|
|
|
lemmas bazz[THEN impE] = TrueI[@\<open>erule thin_rl, rule revcut_rl[of "P \<longrightarrow> P \<and> P"], simp\<close>] for P
|
|
|
|
|
2017-03-20 03:57:55 +00:00
|
|
|
lemma "Q \<longrightarrow> Q \<and> Q" by (rule baz)
|
|
|
|
|
|
|
|
method silly_rule for P :: bool uses rule =
|
|
|
|
(rule [[@\<open>erule thin_rl, cut_tac rule, drule asm_rl[of P]\<close>]])
|
|
|
|
|
|
|
|
lemma assumes A shows A by (silly_rule A rule: \<open>A\<close>)
|
|
|
|
|
|
|
|
lemma assumes A[simp]: "A" shows A
|
|
|
|
apply (match conclusion in P for P \<Rightarrow>
|
|
|
|
\<open>rule [[@\<open>erule thin_rl, rule revcut_rl[of "P"], simp\<close>]]\<close>)
|
|
|
|
done
|
|
|
|
|
|
|
|
end
|
|
|
|
|
2017-03-28 10:37:51 +00:00
|
|
|
end
|