theory Select_Solve
imports Main Refine_Util
begin
lemma retrofit_with_prems:
fixes P Q R TAG :: "prop"
assumes 1: "PROP P ==> PROP Q"
assumes 2: "PROP R ==> PROP TAG &&& PROP P"
shows "PROP R ==> PROP Q"
proof -
assume "PROP R"
from this[THEN 2, THEN conjunctionD2] have "PROP P" .
with 1 show "PROP Q" .
qed
lemma retrofit_no_prems:
fixes P Q TAG :: "prop"
assumes 1: "PROP P ==> PROP Q"
assumes 2: "PROP TAG &&& PROP P"
shows "PROP Q"
proof -
from 2 have "PROP P" by (rule conjunctionD2)
thus "PROP Q" by (rule 1)
qed
consts NO_TAG :: "prop"
ML {*
signature SELECT_SOLVE = sig
val PREFER_SOLVED: tactic -> tactic
val IF_SUBGOAL_SOLVED: tactic -> tactic -> tactic -> tactic
val TRY_SOLVE_FWD: int -> tactic -> tactic
val SELECT_FIRST: Proof.context -> tactic -> tactic
val AS_FIRSTGOAL: tactic -> tactic'
val REPEAT_SOLVE_FWD_SELECT: Proof.context -> int -> tactic' -> tactic'
end
structure Select_Solve :SELECT_SOLVE = struct
fun PREFER_SOLVED tac st = let
val n = Thm.nprems_of st
val res = tac st
(*val res' = Seq.append
(Seq.filter (has_fewer_prems n) res)
(Seq.filter (not o has_fewer_prems n) res)*)
val res' = Seq.filter (has_fewer_prems n) res
in
res'
end
fun IF_SUBGOAL_SOLVED tac1 then_tac else_tac st = let
val n = Thm.nprems_of st
in
(tac1 THEN COND (has_fewer_prems n) then_tac else_tac) st
end
fun TRY_SOLVE_FWD i tac st =
if i <= 0 then
Seq.single st
else
IF_UNSOLVED (
IF_SUBGOAL_SOLVED tac (TRY_SOLVE_FWD (i-1) tac) all_tac
) st
fun TRY_SOLVE_ALL_NEW_FWD tac1 tac2 tac3 st = let
val n = Thm.nprems_of st
in
(
tac1 THEN_ELSE
( fn st' => let val n' = Thm.nprems_of st' in TRY_SOLVE_FWD (n' - n + 1) tac2 st' end,
tac3)
) st
end
fun SELECT_FIRST ctxt tac st = if Thm.nprems_of st < 2 then tac st
else let
(*val _ = print_tac "Focusing" st*)
(* Extract first subgoal *)
val (P,Q) = Thm.dest_implies (Thm.cprop_of st)
(*val _ = "Extracted: " ^ @{make_string} P |> tracing*)
(* Prepare tag *)
local
fun intr_bal [] = @{thm ‹TERM NO_TAG›}
| intr_bal l = Conjunction.intr_balanced l
val t = Thm.term_of P
val vars = Term.add_vars t []
val tvars = Term.add_tvars t []
val vtvars = fold (Term.add_tvarsT o #2) vars []
val tvars = subtract (op =) vtvars tvars
val tvars_tag = tvars
|> map (Drule.mk_term o Thm.cterm_of ctxt o Logic.mk_type o TVar)
|> intr_bal
val vars_tag = vars
|> map (Drule.mk_term o Thm.cterm_of ctxt o Var)
|> intr_bal
in
val tag_thm = Conjunction.intr tvars_tag vars_tag
end
val TAG = Thm.cprop_of tag_thm
(* Prepare new proof state *)
val st' = Conjunction.mk_conjunction (TAG, P)
|> Goal.init
|> Conjunction.curry_balanced 2
|> Thm.elim_implies tag_thm
(*val _ = "New proof state: " ^ @{make_string} st' |> tracing*)
(*val _ = print_tac "New state" st'*)
(* Apply proof *)
val seq = tac st'
fun elim_implies thA thAB =
case try Thm.dest_implies (Thm.cprop_of thAB) of
SOME (A,_) => (
A aconvc Thm.cprop_of thA
orelse (
(*tracing (@{make_string} (term_of A));
tracing (@{make_string} (prop_of thA));*)
raise CTERM ("implies_elim: No aconv",[A,Thm.cprop_of thA])
);
Thm.elim_implies thA thAB
)
| _ => raise THM ("implies_elim: No impl",0,[thAB,thA])
fun retrofit st' = let
val st' = Drule.incr_indexes st st'
val n = Thm.nprems_of st'
val thm = Conjunction.uncurry_balanced n st'
|> Goal.conclude
|> Conv.fconv_rule (Thm.beta_conversion true)
(*val _ = "Proved: " ^ @{make_string} thm |> tracing*)
in
if n=0 then
let
val (TAG',_) = Conjunction.dest_conjunction (Thm.cprop_of thm)
val inst = Thm.match (TAG, TAG')
val st = Thm.instantiate inst st
|> Conv.fconv_rule (Thm.beta_conversion true)
val P = Thm.instantiate_cterm inst P
val Q = Thm.instantiate_cterm inst Q
in
@{thm retrofit_no_prems}
|> Thm.instantiate' [] [SOME P, SOME Q, SOME TAG']
|> Conv.fconv_rule (Thm.beta_conversion true)
|> elim_implies st
|> elim_implies thm
end
else
let
val (R,TP') = Thm.dest_implies (Thm.cprop_of thm)
val (TAG',_) = Conjunction.dest_conjunction TP'
val inst = Thm.match (TAG, TAG')
val st = Thm.instantiate inst st
|> Conv.fconv_rule (Thm.beta_conversion true)
val P = Thm.instantiate_cterm inst P
val Q = Thm.instantiate_cterm inst Q
in
@{thm retrofit_with_prems}
|> Thm.instantiate' [] [SOME P, SOME Q, SOME R, SOME TAG']
|> Conv.fconv_rule (Thm.beta_conversion true)
|> elim_implies st
|> elim_implies thm
|> Conjunction.curry_balanced n
end
end
in
Seq.map retrofit seq
end
fun AS_FIRSTGOAL tac i st =
if i <= Thm.nprems_of st then
(PRIMITIVE (Thm.permute_prems 0 (i-1))
THEN tac
THEN PRIMITIVE (Thm.permute_prems 0 (1-i))) st
else Seq.empty
fun REPEAT_SOLVE_FWD_SELECT ctxt bias tac = let
fun BIASED_SELECT tac st =
if Thm.nprems_of st < 2 then tac st
else let
val s = Drule.size_of_thm st
(*val _ = if s>100 then string_of_int s |> tracing else ()*)
in
if s < bias then
tac st
else let
val s1 = Logic.dest_implies (Thm.prop_of st) |> #1 |> size_of_term
in
if 5 * s1 < 2 * s then
SELECT_FIRST ctxt tac st
else tac st
end
end
fun sg_rec st = IF_UNSOLVED (BIASED_SELECT (
PREFER_SOLVED (
TRY_SOLVE_ALL_NEW_FWD (tac 1) sg_rec all_tac
)
)) st
in
AS_FIRSTGOAL sg_rec
end
end
*}
end