865 lines
35 KiB
Standard ML
865 lines
35 KiB
Standard ML
(*
|
|
* Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
|
|
*
|
|
* SPDX-License-Identifier: BSD-2-Clause
|
|
*)
|
|
|
|
(*
|
|
What is crunch? Crunch is for proving easily proved properties over various
|
|
functions within a (shallow monadic) specification. Suppose we have a toplevel
|
|
specification function f and some simple notion of correctness, P \<turnstile> f, which
|
|
we want to prove. However f is defined in terms of subfunctions g etc.
|
|
To prove P \<turnstile> f, we will first show many lemmas P \<turnstile> g, which crunch lets us
|
|
do easily.
|
|
|
|
As a first step, crunch must discover "crunch rules" which structure the proof.
|
|
For instance, if f is a constant with a definition, crunch may discover the
|
|
definition "f == f_body" and derive the crunch rule "P \<turnstile> f_body \<Longrightarrow> P \<turnstile> f".
|
|
A crunch rule will be used if all its premises are either proofs of the
|
|
same notion of correctness (P \<turnstile> ?f) or can be solved trivially by wp/simp.
|
|
|
|
The user can supply crunch rules with the rule: section or crunch_rule
|
|
attribute, which will be tried both as rewrites and
|
|
as introduction rules. Crunch also has a number of builtin strategies
|
|
for finding definitional rules in the context.
|
|
|
|
Once a crunch rule for P \<turnstile> f is found, crunch will recursively apply to
|
|
almost all monadic constants in all of the premises. (The exploration
|
|
terminates where crunch rules can be found without premises.) Crunch
|
|
will obtain proofs e.g. P \<turnstile> g for all f's dependencies, then finally
|
|
try to prove P \<turnstile> f using the crunch rule, wp (with the given dependencies)
|
|
and simp. Additional wp and simp rules can also be given with the wp: and
|
|
simp: sections.
|
|
|
|
When obtaining proofs for f's dependencies, crunch will first determine
|
|
whether a rule already exists for that goal (P \<turnstile> g). It does this by
|
|
checking whether a) crunch has already proven a rule for that constant,
|
|
b) a rule in the wp set can be used to solve the goal, or c) a rule
|
|
already exists with the name that crunch would use. In the case of c),
|
|
crunch will fail if the found rule cannot be applied to the goal.
|
|
|
|
There are some monadic constants that it does not make sense to apply
|
|
crunch to. These are added to a crunch_ignore set, and are removed from
|
|
f's dependencies if they are ever found. The command crunch_ignore (add: )
|
|
can be used to add new constants, along with the ignore: section of a
|
|
specific crunch invocation.
|
|
|
|
*)
|
|
|
|
(* Tracing debug. *)
|
|
val crunch_debug = Unsynchronized.ref false
|
|
fun debug_trace_pf pref f =
|
|
if (!crunch_debug) then
|
|
tracing (pref ^ f ())
|
|
else
|
|
()
|
|
fun debug_trace s =
|
|
if (!crunch_debug) then
|
|
tracing s
|
|
else
|
|
()
|
|
fun debug_trace_bl bl =
|
|
if (!crunch_debug) then
|
|
tracing (Pretty.string_of (Pretty.block
|
|
(map (fn f => f ()) bl)))
|
|
else
|
|
()
|
|
|
|
fun funkysplit [_,b,c] = [b,c]
|
|
| funkysplit [_,c] = [c]
|
|
| funkysplit l = l
|
|
|
|
fun real_base_name name = name |> Long_Name.explode |> funkysplit |> Long_Name.implode (*Handles locales properly-ish*)
|
|
|
|
fun handle_int exn func = if Exn.is_interrupt exn then Exn.reraise exn else func
|
|
|
|
val Thm : (Facts.ref * Token.src list) -> ((Facts.ref * Token.src list), xstring) sum = Inl
|
|
val Constant : xstring -> ((Facts.ref * Token.src list), xstring) sum = Inr
|
|
val thms = lefts
|
|
val constants = rights
|
|
|
|
val wp_sect = ("wp", Parse.thm >> Thm);
|
|
val wp_del_sect = ("wp_del", Parse.thm >> Thm);
|
|
val wps_sect = ("wps", Parse.thm >> Thm);
|
|
val ignore_sect = ("ignore", Parse.const >> Constant);
|
|
val ignore_del_sect = ("ignore_del", Parse.const >> Constant);
|
|
val simp_sect = ("simp", Parse.thm >> Thm);
|
|
val simp_del_sect = ("simp_del", Parse.thm >> Thm);
|
|
val rule_sect = ("rule", Parse.thm >> Thm);
|
|
val rule_del_sect = ("rule_del", Parse.thm >> Thm);
|
|
|
|
fun read_const ctxt = Proof_Context.read_const {proper = true, strict = false} ctxt;
|
|
|
|
fun gen_term_eq (f $ x, f' $ x') = gen_term_eq (f, f') andalso gen_term_eq (x, x')
|
|
| gen_term_eq (Abs (_, _, t), Abs (_, _, t')) = gen_term_eq (t, t')
|
|
| gen_term_eq (Const (nm, _), Const (nm', _)) = (nm = nm')
|
|
| gen_term_eq (Free (nm, _), Free (nm', _)) = (nm = nm')
|
|
| gen_term_eq (Var (nm, _), Var (nm', _)) = (nm = nm')
|
|
| gen_term_eq (Bound i, Bound j) = (i = j)
|
|
| gen_term_eq _ = false
|
|
fun ae_conv (t, t') = gen_term_eq
|
|
(Envir.beta_eta_contract t, Envir.beta_eta_contract t')
|
|
|
|
(*
|
|
Crunch can be instantiated to prove different properties about monadic
|
|
specifications. For several examples of this instantiation see
|
|
Crunch_Instances_NonDet.
|
|
*)
|
|
signature CrunchInstance =
|
|
sig
|
|
(* The name of the property. *)
|
|
val name : string;
|
|
(* The type of any parameters of the property beyond a (optional) precondition
|
|
and the function being crunched. *)
|
|
type extra;
|
|
(* Equality of the extra parameter, often uses ae_conv. *)
|
|
val eq_extra : extra * extra -> bool;
|
|
(* How to parse anything after the list of specifications to be crunched,
|
|
returns a precondition and extra field. *)
|
|
val parse_extra : Proof.context -> string -> term * extra;
|
|
(* Whether the property has preconditions. *)
|
|
val has_preconds : bool;
|
|
(* Construct the property out of a precondition, function and extra. *)
|
|
val mk_term : term -> term -> extra -> term;
|
|
(* Deconstruct the property. *)
|
|
val dest_term : term -> (term * term * extra) option;
|
|
(* Put a new precondition into an instance of the property. *)
|
|
val put_precond : term -> term -> term;
|
|
(* Theorems used to modify the precondition of the property. An empty list
|
|
if the property has no preconditions. *)
|
|
val pre_thms : thm list;
|
|
(* The wpc_tactic used, normally wp_cases_tactic_weak. See BCorres_UL for
|
|
an alternative. *)
|
|
val wpc_tactic : Proof.context -> int -> tactic;
|
|
(* The wps_tactic used, normally wps_tac when applicable and no_tac when not. *)
|
|
val wps_tactic : Proof.context -> thm list -> int -> tactic;
|
|
val magic : term;
|
|
(* Get the type of the state a monadic specification is operating on. Returns
|
|
NONE when given the wrong type. See get_nondet_monad_state_type in
|
|
Crunch_Instances_NonDet for an example. *)
|
|
val get_monad_state_type : typ -> typ option
|
|
end
|
|
|
|
signature CRUNCH =
|
|
sig
|
|
type extra;
|
|
(* Crunch configuration: theory, naming scheme, name space, wp rules, wps_rules,
|
|
constants to ignore, simp rules, constants to not ignore, unfold rules*)
|
|
type crunch_cfg = {ctxt: local_theory, prp_name: string, nmspce: string option,
|
|
wp_rules: (string * thm) list, wps_rules: thm list, igs: string list, simps: thm list,
|
|
ig_dels: string list, rules: thm list};
|
|
|
|
(* Crunch takes a configuration, a precondition, any extra information needed, a debug stack,
|
|
a constant name, and a list of previously proven theorems, and returns a theorem for
|
|
this constant and a list of new theorems (which may be empty if the result
|
|
had already been proven). *)
|
|
val crunch :
|
|
crunch_cfg -> term -> extra -> string list -> string
|
|
-> (string * thm) list -> (thm option * (string * thm) list);
|
|
|
|
val crunch_x : Token.src list -> string -> string
|
|
-> (string * ((Facts.ref * Token.src list), xstring) sum) list
|
|
-> string list -> local_theory -> local_theory;
|
|
|
|
val crunch_ignore_add_del : string list -> string list -> theory -> theory
|
|
|
|
val mism_term_trace : (term * extra) list Unsynchronized.ref
|
|
end
|
|
|
|
functor Crunch (Instance : CrunchInstance) =
|
|
struct
|
|
|
|
type extra = Instance.extra;
|
|
|
|
type crunch_cfg = {ctxt: local_theory, prp_name: string, nmspce: string option,
|
|
wp_rules: (string * thm) list, wps_rules: thm list, igs: string list, simps: thm list,
|
|
ig_dels: string list, rules: thm list};
|
|
|
|
structure CrunchIgnore = Theory_Data
|
|
(struct
|
|
type T = string list
|
|
val empty = []
|
|
val extend = I
|
|
val merge = Library.merge (op =);
|
|
end);
|
|
|
|
fun crunch_ignore_add thms thy =
|
|
CrunchIgnore.map (curry (Library.merge (op =)) thms) thy
|
|
|
|
fun crunch_ignore_del thms thy =
|
|
CrunchIgnore.map (Library.subtract (op =) thms) thy
|
|
|
|
fun crunch_ignore_add_del adds dels =
|
|
crunch_ignore_add adds #> crunch_ignore_del dels
|
|
|
|
fun crunch_ignores cfg ctxt =
|
|
subtract (op =) (#ig_dels cfg) (#igs cfg @ CrunchIgnore.get (Proof_Context.theory_of ctxt))
|
|
|
|
val def_sfx = "_def";
|
|
val induct_sfx = ".induct";
|
|
val simps_sfx = ".simps";
|
|
val param_name = "param_a";
|
|
val dummy_monad_name = "__dummy__";
|
|
|
|
fun def_of n = n ^ def_sfx;
|
|
fun induct_of n = n ^ induct_sfx;
|
|
fun simps_of n = n ^ simps_sfx;
|
|
|
|
fun num_args t = length (binder_types t) - 1;
|
|
|
|
fun real_const_from_name const nmspce ctxt =
|
|
let
|
|
val qual::locale::nm::nil = Long_Name.explode const;
|
|
val SOME some_nmspce = nmspce;
|
|
val nm = Long_Name.implode (some_nmspce :: nm :: nil);
|
|
val _ = read_const ctxt nm;
|
|
in
|
|
nm
|
|
end
|
|
handle exn => handle_int exn const;
|
|
|
|
|
|
fun get_monad ctxt f xs = if is_Const f then
|
|
(* we need the type of the underlying constant to avoid polymorphic
|
|
constants like If, case_option, K_bind being considered monadic *)
|
|
let val T = dest_Const f |> fst |> read_const ctxt |> type_of;
|
|
|
|
fun is_product v p =
|
|
Option.getOpt (Option.map (fn v' => v = v') (Instance.get_monad_state_type p),
|
|
false)
|
|
|
|
fun num_args (Type ("fun", [v,p])) n =
|
|
if is_product v p then SOME n else num_args p (n + 1)
|
|
| num_args _ _ = NONE
|
|
|
|
in case num_args T 0 of NONE => []
|
|
| SOME n => [list_comb (f, Library.take n (xs @ map Bound (1 upto n)))]
|
|
end
|
|
else [];
|
|
|
|
fun monads_of ctxt t = case strip_comb t of
|
|
(Const f, xs) => get_monad ctxt (Const f) xs @ maps (monads_of ctxt) xs
|
|
| (Abs (_, _, t), []) => monads_of ctxt t
|
|
| (Abs a, xs) => monads_of ctxt (betapplys (Abs a, xs))
|
|
| (_, xs) => maps (monads_of ctxt) xs;
|
|
|
|
|
|
val get_thm = Proof_Context.get_thm
|
|
|
|
val get_thms = Proof_Context.get_thms
|
|
|
|
val get_thms_from_facts = Attrib.eval_thms
|
|
|
|
fun maybe_thms thy name = get_thms thy name handle ERROR _ => []
|
|
fun thy_maybe_thms thy name = Global_Theory.get_thms thy name handle ERROR _ => []
|
|
|
|
fun add_thm thm atts name ctxt =
|
|
Local_Theory.notes [((Binding.name name, atts), [([thm], atts)])] ctxt |> #2
|
|
|
|
fun get_thm_name (cfg : crunch_cfg) const_name
|
|
= if read_const (#ctxt cfg) (Long_Name.base_name const_name)
|
|
= read_const (#ctxt cfg) const_name
|
|
then Long_Name.base_name const_name ^ "_" ^ (#prp_name cfg)
|
|
else space_implode "_" (space_explode "." const_name @ [#prp_name cfg])
|
|
|
|
fun get_stored cfg n = get_thm (#ctxt cfg) (get_thm_name cfg n)
|
|
|
|
fun mapM _ [] y = y
|
|
| mapM f (x::xs) y = mapM f xs (f x y)
|
|
|
|
fun dest_equals t = t |> Logic.dest_equals
|
|
handle TERM _ => t |> HOLogic.dest_Trueprop |> HOLogic.dest_eq;
|
|
|
|
fun const_is_lhs const nmspce ctxt def =
|
|
let
|
|
val (lhs, _) = def |> Thm.prop_of |> dest_equals;
|
|
val (nm, _) = dest_Const const;
|
|
val (nm', _) = dest_Const (head_of lhs);
|
|
in
|
|
(real_const_from_name nm nmspce ctxt) = (real_const_from_name nm' nmspce ctxt)
|
|
end handle TERM _ => false
|
|
|
|
fun deep_search_thms ctxt defn const nmspce =
|
|
let
|
|
val thy = Proof_Context.theory_of ctxt
|
|
val thys = thy :: Theory.ancestors_of thy;
|
|
val filt = filter (const_is_lhs const nmspce ctxt);
|
|
|
|
fun search [] = error("not found: const: " ^ @{make_string} const ^ " defn: " ^ @{make_string} defn)
|
|
| search (t::ts) = (case (filt (thy_maybe_thms t defn)) of
|
|
[] => search ts
|
|
| thms => thms);
|
|
in
|
|
case filt (maybe_thms ctxt defn) of
|
|
[] => search thys
|
|
| defs => defs
|
|
end;
|
|
|
|
(*
|
|
When making recursive crunch calls we want to identify and collect preconditions
|
|
about parameters of the functions we are crunching. To assist with this we
|
|
attempt to turn bound variables into free variables by simplifying with rules
|
|
like Let_def, return_bind and bind_assoc. One example of this named_theorem
|
|
being populated can be found in Crunch_Instances_NonDet.
|
|
*)
|
|
fun unfold_get_params ctxt =
|
|
Named_Theorems.get ctxt @{named_theorems crunch_param_rules}
|
|
|
|
fun def_from_ctxt ctxt const =
|
|
let
|
|
val crunch_defs = Named_Theorems.get ctxt @{named_theorems crunch_def}
|
|
val abs_def = Local_Defs.meta_rewrite_rule ctxt #> Drule.abs_def;
|
|
fun do_filter thm =
|
|
try (abs_def #> Thm.prop_of #> Logic.dest_equals #> fst #> dest_Const #> fst) thm
|
|
= SOME const
|
|
in
|
|
case crunch_defs |> filter do_filter of
|
|
[x] => SOME x
|
|
| [] => NONE
|
|
| _ => raise Fail ("Multiple definitions declared for:" ^ const)
|
|
end
|
|
|
|
fun unfold ctxt const triple nmspce =
|
|
let
|
|
val _ = debug_trace "unfold"
|
|
val const_term = read_const ctxt const;
|
|
val const_defn = const |> Long_Name.base_name |> def_of;
|
|
val const_def = deep_search_thms ctxt const_defn const_term nmspce
|
|
|> hd |> Simpdata.safe_mk_meta_eq;
|
|
val _ = debug_trace_bl [K (Pretty.str "const_def:"),
|
|
fn () => Pretty.str (@{make_string} const_defn), fn () => Thm.pretty_thm ctxt const_def]
|
|
val trivial_rule = Thm.trivial triple
|
|
val _ = debug_trace_bl [K (Pretty.str "trivial_rule :"),
|
|
fn () => Thm.pretty_thm ctxt trivial_rule]
|
|
val unfold_rule = trivial_rule
|
|
|> Simplifier.rewrite_goals_rule ctxt [const_def];
|
|
val _ = debug_trace_bl [K (Pretty.str "unfold_rule :"),
|
|
fn () => Thm.pretty_thm ctxt unfold_rule]
|
|
val ms = unfold_rule
|
|
|> Simplifier.rewrite_goals_rule ctxt (unfold_get_params ctxt)
|
|
|> Thm.prems_of |> maps (monads_of ctxt);
|
|
in if Thm.eq_thm_prop (trivial_rule, unfold_rule)
|
|
then error ("Unfold rule generated for " ^ const ^ " does not apply")
|
|
else (ms, unfold_rule) end
|
|
|
|
fun mk_apps t n m =
|
|
if n = 0
|
|
then t
|
|
else mk_apps t (n-1) (m+1) $ Bound m
|
|
|
|
fun mk_abs t n =
|
|
if n = 0
|
|
then t
|
|
else Abs ("_", dummyT, mk_abs t (n-1))
|
|
|
|
fun eq_cname (Const (s, _)) (Const (t, _)) = (s = t)
|
|
| eq_cname _ _ = false
|
|
|
|
fun resolve_abbreviated ctxt abbrev =
|
|
let
|
|
val (abbrevn,_) = dest_Const abbrev
|
|
val origin = (head_of (snd ((Consts.the_abbreviation o Proof_Context.consts_of) ctxt abbrevn)));
|
|
val (originn,_) = dest_Const origin;
|
|
val (_::_::_::nil) = Long_Name.explode originn;
|
|
in origin end handle exn => handle_int exn abbrev
|
|
|
|
fun map_consts f =
|
|
let
|
|
fun map_aux (Const a) = f (Const a)
|
|
| map_aux (t $ u) = map_aux t $ map_aux u
|
|
| map_aux x = x
|
|
in map_aux end;
|
|
|
|
fun map_unvarifyT t = map_types Logic.unvarifyT_global t
|
|
|
|
fun dummy_fix ctxt vars = let
|
|
val nns = Name.invent Name.context "dummy_var_a" (length vars)
|
|
val frees = map Free (nns ~~ map fastype_of vars)
|
|
|> map (Thm.cterm_of ctxt)
|
|
in Drule.infer_instantiate ctxt (map (fst o dest_Var) vars ~~ frees) end
|
|
|
|
fun induct_inst ctxt const goal nmspce =
|
|
let
|
|
val _ = debug_trace "induct_inst"
|
|
val base_const = Long_Name.base_name const;
|
|
val _ = debug_trace_pf "base_const: " (fn () => @{make_string} base_const)
|
|
val induct_thm = base_const |> induct_of |> get_thm ctxt;
|
|
val _ = debug_trace_pf "induct_thm: " (fn () => @{make_string} induct_thm)
|
|
val act_goal = HOLogic.dest_Trueprop (Thm.term_of goal)
|
|
val goal_f = case Instance.dest_term act_goal of
|
|
NONE => (warning "induct_inst: dest_term failed"; error "induct_inst: dest_term failed")
|
|
| SOME (_, goal_f, _) => goal_f
|
|
val params = map_filter (fn Free (s, _) =>
|
|
(if String.isPrefix "param" s then SOME s else NONE) | _ => NONE)
|
|
(snd (strip_comb goal_f))
|
|
val _ = debug_trace ("induct_inst params: " ^ commas params)
|
|
val induct_thm_params = induct_thm |> Thm.concl_of
|
|
|> HOLogic.dest_Trueprop |> strip_comb |> snd
|
|
val induct_thm_inst = dummy_fix ctxt (drop (length params) induct_thm_params) induct_thm
|
|
val trivial_rule = Thm.trivial goal;
|
|
val tac = Induct_Tacs.induct_tac ctxt [map SOME params] (SOME [induct_thm_inst]) 1
|
|
val induct_inst = tac trivial_rule |> Seq.hd
|
|
val _ = debug_trace_pf "induct_inst: " (fn () => Syntax.string_of_term ctxt (Thm.prop_of induct_inst))
|
|
val simp_thms = deep_search_thms ctxt (base_const |> simps_of) (head_of goal_f) nmspce;
|
|
val induct_inst_simplified = induct_inst
|
|
|> Simplifier.rewrite_goals_rule ctxt (map Simpdata.safe_mk_meta_eq simp_thms);
|
|
val ms = maps (monads_of ctxt) (Thm.prems_of induct_inst_simplified);
|
|
val ms' = filter_out (eq_cname (resolve_abbreviated ctxt (head_of goal_f)) o head_of) ms;
|
|
in if Thm.eq_thm_prop (trivial_rule, induct_inst)
|
|
then error ("Unfold rule generated for " ^ const ^ " does not apply")
|
|
else (ms', induct_inst_simplified) end
|
|
|
|
fun unfold_data ctxt constn goal nmspce NONE = (
|
|
induct_inst ctxt constn goal nmspce handle exn => handle_int exn
|
|
unfold ctxt constn goal nmspce handle exn => handle_int exn
|
|
error ("unfold_data: couldn't find defn or induct rule for " ^ constn))
|
|
| unfold_data ctxt constn goal _ (SOME thm) =
|
|
let
|
|
val trivial_rule = Thm.trivial goal
|
|
val unfold_rule = Simplifier.rewrite_goals_rule ctxt [safe_mk_meta_eq thm] trivial_rule;
|
|
val ms = unfold_rule
|
|
|> Simplifier.rewrite_goals_rule ctxt (unfold_get_params ctxt)
|
|
|> Thm.prems_of |> maps (monads_of ctxt);
|
|
in if Thm.eq_thm_prop (trivial_rule, unfold_rule)
|
|
then error ("Unfold rule given for " ^ constn ^ " does not apply")
|
|
else (ms, unfold_rule) end
|
|
|
|
fun get_unfold_rule ctxt const cgoal namespace =
|
|
unfold_data ctxt const cgoal namespace (def_from_ctxt ctxt const)
|
|
|
|
val split_if = @{thm "if_split"}
|
|
|
|
fun maybe_cheat_tac ctxt thm =
|
|
if (Goal.skip_proofs_enabled ())
|
|
then ALLGOALS (Skip_Proof.cheat_tac ctxt) thm
|
|
else all_tac thm;
|
|
|
|
fun get_precond t =
|
|
if Instance.has_preconds
|
|
then case Instance.dest_term t of
|
|
SOME (pre, _, _) => pre
|
|
| _ => error ("get_precond: not a " ^ Instance.name ^ " term")
|
|
else error ("crunch (" ^ Instance.name ^ ") should not be calling get_precond")
|
|
|
|
fun var_precond v =
|
|
if Instance.has_preconds
|
|
then Instance.put_precond (Var (("Precond", 0), get_precond v |> fastype_of)) v
|
|
else v;
|
|
|
|
fun is_proof_of cfg const (name, _) =
|
|
get_thm_name cfg const = name
|
|
|
|
fun get_inst_precond ctxt pre extra (mapply, goal) = let
|
|
val (c, xs) = strip_comb mapply;
|
|
fun replace_vars (t, n) =
|
|
if exists_subterm (fn t => is_Bound t orelse is_Var t) t
|
|
then Free ("ignore_me" ^ string_of_int n, dummyT)
|
|
else t
|
|
val ys = map replace_vars (xs ~~ (1 upto (length xs)));
|
|
val goal2 = Instance.mk_term pre (list_comb (c, ys)) extra
|
|
|> Syntax.check_term ctxt |> var_precond
|
|
|> HOLogic.mk_Trueprop |> Thm.cterm_of ctxt;
|
|
val spec = goal RS Thm.trivial goal2;
|
|
val precond = Thm.concl_of spec |> HOLogic.dest_Trueprop |> get_precond;
|
|
in SOME precond end
|
|
(* in rare cases the tuple extracted from the naming scheme doesn't
|
|
match what we were trying to prove, thus a THM exception from RS *)
|
|
handle THM _ => NONE;
|
|
|
|
fun split_precond (Const (@{const_name pred_conj}, _) $ P $ Q)
|
|
= split_precond P @ split_precond Q
|
|
| split_precond (Abs (n, T, @{const "HOL.conj"} $ P $ Q))
|
|
= maps (split_precond o Envir.eta_contract) [Abs (n, T, P), Abs (n, T, Q)]
|
|
| split_precond t = [t];
|
|
|
|
val precond_implication_term
|
|
= Syntax.parse_term @{context}
|
|
"%P Q. (!! s. (P s ==> Q s))";
|
|
|
|
fun precond_needed ctxt pre css pre' = let
|
|
val imp = Syntax.check_term ctxt (precond_implication_term $ pre $ pre');
|
|
in not (can (Goal.prove ctxt [] [] imp)
|
|
(fn _ => clarsimp_tac css 1)) end
|
|
|
|
fun combine_preconds ctxt pre pres = let
|
|
val pres' = maps (split_precond o Envir.beta_eta_contract) pres
|
|
|> filter_out (exists_subterm (fn t => is_Var t orelse
|
|
(is_Free t andalso
|
|
is_prefix (op =) (String.explode "ignore_me")
|
|
(String.explode (fst (dest_Free t))))))
|
|
|> remove (op aconv) pre |> distinct (op aconv)
|
|
|> filter (precond_needed ctxt pre ctxt);
|
|
val T = fastype_of pre;
|
|
val conj = Const (@{const_name pred_conj}, T --> T --> T)
|
|
in case pres' of
|
|
[] => pre
|
|
| _ => let val precond = foldl1 (fn (a, b) => conj $ a $ b) pres'
|
|
in if precond_needed ctxt precond ctxt pre then conj $ pre $ precond else precond end
|
|
end;
|
|
|
|
(* the crunch function is designed to be foldable with this custom fold
|
|
to crunch over a list of constants *)
|
|
fun funkyfold _ [] _ = ([], [])
|
|
| funkyfold f (x :: xs) thms = let
|
|
val (z, thms') = f x thms
|
|
val (zs, thms'') = funkyfold f xs (thms' @ thms)
|
|
in (z :: zs, thms' @ thms'') end
|
|
|
|
exception WrongType
|
|
|
|
fun make_goal const_term const pre extra ctxt =
|
|
let val nns = const_term |> fastype_of |> num_args |>
|
|
Name.invent Name.context param_name;
|
|
val parse = Syntax.parse_term ctxt;
|
|
val check = Syntax.check_term ctxt;
|
|
val body = parse (String.concat (separate " " (const :: nns)));
|
|
in check (Instance.mk_term pre body extra) end;
|
|
|
|
fun unify_helper rs n t =
|
|
case
|
|
Thm.cprem_of t n |> Thm.term_of |> snd (#trips rs) (Thm.theory_of_thm t)
|
|
|> Envir.beta_eta_contract |> Logic.strip_assums_concl
|
|
handle THM _ => @{const True}
|
|
of
|
|
Const (@{const_name Trueprop}, _) $
|
|
(Const (@{const_name triple_judgement}, _) $ _ $ f $ _) => SOME f
|
|
| _ => NONE
|
|
|
|
fun get_wp_rules ctxt n goal =
|
|
let
|
|
val wp_data = WeakestPre.debug_get ctxt
|
|
val f = unify_helper wp_data n goal
|
|
in case f of
|
|
SOME f => Net.unify_term (#1 (#rules wp_data)) f |> order_list |> rev
|
|
| NONE => map snd (#3 (#rules wp_data)) end
|
|
|
|
(*rule can either solve thm or can be applied and refers to the same const*)
|
|
fun can_solve_or_apply ctxt goal thm rule =
|
|
let
|
|
fun body term = term |> Instance.dest_term
|
|
|> Option.map (Term.term_name o Term.head_of o #2)
|
|
val const' = rule |> Thm.concl_of |> HOLogic.dest_Trueprop |> body
|
|
handle TERM _ => NONE
|
|
val thm' = SINGLE (resolve_tac ctxt [rule] 1) thm
|
|
fun changed st' = not (Thm.eq_thm (thm, st'));
|
|
fun solved st' = Thm.nprems_of st' < Thm.nprems_of thm
|
|
in if is_some thm'
|
|
then solved (the thm') orelse
|
|
(body goal = const' andalso changed (the thm'))
|
|
else false end
|
|
|
|
fun test_thm_applies ctxt goal thm = SINGLE (CHANGED (resolve_tac ctxt [thm] 1)) goal
|
|
|
|
fun crunch_known_rule cfg const thms goal =
|
|
let
|
|
val ctxt = #ctxt cfg
|
|
val vgoal_prop = goal |> var_precond |> HOLogic.mk_Trueprop
|
|
val cgoal_in = Goal.init (Thm.cterm_of ctxt vgoal_prop)
|
|
|
|
(*first option: previously crunched thm*)
|
|
val thms_proof = Seq.filter (is_proof_of cfg const) (Seq.of_list thms)
|
|
|
|
fun used_rule thm =
|
|
(Pretty.writeln (Pretty.big_list "found a rule for this constant:"
|
|
[ThmExtras.pretty_thm false ctxt thm]); thm)
|
|
|
|
(*second option: thm with same name*)
|
|
val stored_rule = try (get_stored cfg) const
|
|
val stored_rule_applies =
|
|
Option.mapPartial (test_thm_applies ctxt cgoal_in) stored_rule |> is_some
|
|
val stored_rule_error =
|
|
if is_some stored_rule andalso not stored_rule_applies
|
|
then Pretty.big_list "the generated goal does not match the existing rule:"
|
|
[ThmExtras.pretty_thm false ctxt (the stored_rule)]
|
|
|> Pretty.string_of |> SOME
|
|
else NONE
|
|
val stored =
|
|
if stored_rule_applies
|
|
then Seq.single (the stored_rule) |> Seq.map used_rule
|
|
else Seq.empty
|
|
|
|
(*third option: thm in wp set*)
|
|
val wp_rules = get_wp_rules ctxt 1 cgoal_in
|
|
val rules = map snd (thms @ #wp_rules cfg) @ wp_rules
|
|
val wps = filter (can_solve_or_apply ctxt goal cgoal_in) rules
|
|
val wps' = Seq.map used_rule (Seq.of_list wps)
|
|
|
|
(*error if no thm found and thm with same name does not apply*)
|
|
fun error'' (SOME opt) = SOME opt
|
|
| error'' NONE = Option.mapPartial error stored_rule_error
|
|
|
|
val seq = Seq.append (Seq.map snd thms_proof) (Seq.append stored wps')
|
|
in Seq.pull seq |> Option.map fst |> error'' end
|
|
|
|
val mism_term_trace = Unsynchronized.ref []
|
|
|
|
fun seq_try_apply f x = Seq.map_filter (try f) (Seq.single x)
|
|
|
|
fun wp ctxt rules = WeakestPre.apply_rules_tac_n false ctxt rules
|
|
|
|
fun wpsimp ctxt wp_rules simp_rules =
|
|
let val ctxt' = Config.put Method.old_section_parser true ctxt
|
|
in Method.NO_CONTEXT_TACTIC ctxt'
|
|
(Method_Closure.apply_method ctxt' @{method wpsimp} [] [wp_rules, [], simp_rules] [] ctxt' [])
|
|
end
|
|
|
|
fun crunch_rule cfg const goal extra thms =
|
|
let
|
|
(* first option: produce a trivial rule as constant is being ignored *)
|
|
val ctxt = #ctxt cfg
|
|
val goal_prop = goal |> HOLogic.mk_Trueprop
|
|
val ignore_seq =
|
|
if member (op =) (crunch_ignores cfg ctxt) const
|
|
then goal_prop |> Thm.cterm_of ctxt |> Thm.trivial |> Seq.single |> Seq.map (pair NONE)
|
|
else Seq.empty
|
|
|
|
(* second option: produce a terminal rule via wpsimp *)
|
|
fun wpsimp' rules = wpsimp ctxt (map snd (thms @ #wp_rules cfg) @ rules) (#simps cfg)
|
|
val vgoal_prop = goal |> var_precond |> HOLogic.mk_Trueprop
|
|
val ctxt' = Variable.auto_fixes goal_prop (Variable.auto_fixes vgoal_prop ctxt)
|
|
val wp_seq = seq_try_apply (Goal.prove ctxt' [] [] goal_prop)
|
|
(fn _ => TRY (wpsimp' []))
|
|
|> Seq.map (singleton (Proof_Context.export ctxt' ctxt))
|
|
|> Seq.map (pair NONE)
|
|
|
|
(* third option: apply a supplied rule *)
|
|
val cgoal = vgoal_prop |> Thm.cterm_of ctxt
|
|
val base_rule = Thm.trivial cgoal
|
|
fun app_rew r t = Seq.single (Simplifier.rewrite_goals_rule ctxt [r] t)
|
|
|> Seq.filter (fn t' => not (Thm.eq_thm_prop (t, t')))
|
|
val supplied_apps = Seq.of_list (#rules cfg)
|
|
|> Seq.maps (fn r => resolve_tac ctxt [r] 1 base_rule)
|
|
val supplied_app_rews = Seq.of_list (#rules cfg)
|
|
|> Seq.maps (fn r => app_rew r base_rule)
|
|
val supplied_seq = Seq.append supplied_apps supplied_app_rews
|
|
|> Seq.map (pair NONE)
|
|
|
|
(* fourth option: builtins *)
|
|
val builtin_seq = seq_try_apply (get_unfold_rule ctxt' const cgoal) (#nmspce cfg)
|
|
|> Seq.map (apfst SOME)
|
|
|
|
val seq = foldr1 (uncurry Seq.append) [ignore_seq, wp_seq, supplied_seq, builtin_seq]
|
|
|
|
fun fail_tac t _ _ = (writeln "discarding crunch rule, unsolved premise:";
|
|
Syntax.pretty_term ctxt t |> Pretty.writeln;
|
|
mism_term_trace := (t, extra) :: (! mism_term_trace);
|
|
Seq.empty)
|
|
val goal_extra = goal |> Instance.dest_term |> the |> #3
|
|
val finalise = ALLGOALS (SUBGOAL (fn (t, i)
|
|
=> if try (Logic.strip_assums_concl #> HOLogic.dest_Trueprop
|
|
#> Instance.dest_term #> the #> #3 #> curry Instance.eq_extra goal_extra)
|
|
t = SOME true
|
|
then all_tac
|
|
else DETERM (((fn i => wpsimp' [])
|
|
THEN_ALL_NEW fail_tac t) i)))
|
|
|
|
val seq = Seq.maps (fn (ms, t) => Seq.map (pair ms) (finalise t)) seq
|
|
|
|
val (ms, thm) = case Seq.pull seq of SOME ((ms, thm), _) => (ms, thm)
|
|
| NONE => error ("could not find crunch rule for " ^ const)
|
|
|
|
val _ = debug_trace_bl [K (Pretty.str "crunch rule: "), fn () => Thm.pretty_thm ctxt thm]
|
|
|
|
val ms = case ms of SOME ms => ms
|
|
| NONE => Thm.prems_of thm |> maps (monads_of ctxt)
|
|
in (ms, thm) end
|
|
|
|
fun warn_helper_thms wp ctxt t =
|
|
let val simp_thms = maybe_thms ctxt "crunch_simps"
|
|
val ctxt' = ctxt addsimps simp_thms
|
|
val wp_thms = maybe_thms ctxt "crunch_wps"
|
|
fun can_tac tac = (is_some o SINGLE (HEADGOAL (CHANGED_GOAL tac))) t
|
|
in if can_tac (clarsimp_tac ctxt')
|
|
then warning "Using crunch_simps makes more progress"
|
|
else ();
|
|
if can_tac (wp wp_thms)
|
|
then warning "Using crunch_wps makes more progress"
|
|
else ()
|
|
end;
|
|
|
|
fun warn_const_ignored const cfg ctxt =
|
|
if member (op =) (crunch_ignores cfg ctxt) const
|
|
then warning ("constant " ^ const ^ " is being ignored")
|
|
else ();
|
|
|
|
fun warn_stack const stack ctxt =
|
|
Pretty.big_list "Crunch call stack:"
|
|
(map (Proof_Context.pretty_const ctxt) (const::stack))
|
|
|> Pretty.string_of |> warning;
|
|
|
|
fun proof_failed_warnings const stack cfg wp ctxt t =
|
|
if Thm.no_prems t
|
|
then all_tac t
|
|
else (warn_const_ignored const cfg ctxt; warn_helper_thms wp ctxt t;
|
|
warn_stack const stack ctxt; all_tac t)
|
|
|
|
fun crunch cfg pre extra stack const' thms =
|
|
let
|
|
val ctxt = #ctxt cfg |> Context_Position.set_visible false;
|
|
val const = real_const_from_name const' (#nmspce cfg) ctxt;
|
|
in
|
|
let
|
|
val _ = "crunching constant: " ^ const |> writeln;
|
|
val const_term = read_const ctxt const;
|
|
val goal = make_goal const_term const pre extra ctxt
|
|
handle exn => handle_int exn (raise WrongType);
|
|
val goal_prop = HOLogic.mk_Trueprop goal;
|
|
in (* first check: has this constant already been done or supplied? *)
|
|
case crunch_known_rule cfg const thms goal
|
|
of SOME thm => (SOME thm, [])
|
|
| NONE => let (* not already known, find a crunch rule. *)
|
|
val (ms, rule) = crunch_rule cfg const goal extra thms
|
|
(* and now crunch *)
|
|
val ctxt' = Variable.auto_fixes goal ctxt;
|
|
val ms = ms
|
|
|> map (fn t => (real_const_from_name (fst (dest_Const (head_of t))) (#nmspce cfg) ctxt', t))
|
|
|> subtract (fn (a, b) => a = (fst b)) (crunch_ignores cfg ctxt)
|
|
|> filter_out (fn (s, _) => s = const');
|
|
val stack' = const :: stack;
|
|
val _ = if (length stack' > 20) then
|
|
(writeln "Crunch call stack:";
|
|
map writeln (const::stack);
|
|
error("probably infinite loop")) else ();
|
|
val (goals, thms') = funkyfold (crunch cfg pre extra stack') (map fst ms) thms;
|
|
val goals' = map_filter I goals
|
|
val ctxt'' = ctxt' addsimps ((#simps cfg) @ goals')
|
|
|> Splitter.del_split split_if
|
|
|
|
fun collect_preconds pre =
|
|
let val preconds = map_filter (fn (x, SOME y) => SOME (x, y) | (_, NONE) => NONE) (map snd ms ~~ goals)
|
|
|> map_filter (get_inst_precond ctxt'' pre extra);
|
|
val precond = combine_preconds ctxt'' (get_precond goal) preconds;
|
|
in Instance.put_precond precond goal |> HOLogic.mk_Trueprop end;
|
|
val goal_prop2 = if Instance.has_preconds then collect_preconds pre else goal_prop;
|
|
|
|
val ctxt''' = ctxt'' |> Variable.auto_fixes goal_prop2
|
|
val _ = writeln ("attempting: " ^ Syntax.string_of_term ctxt''' goal_prop2);
|
|
|
|
fun wp' wp_rules = wp ctxt (map snd (thms @ #wp_rules cfg) @ goals' @ wp_rules)
|
|
|
|
val thm = Goal.prove_future ctxt''' [] [] goal_prop2
|
|
( (*DupSkip.goal_prove_wrapper *) (fn _ =>
|
|
resolve_tac ctxt''' [rule] 1
|
|
THEN maybe_cheat_tac ctxt'''
|
|
THEN ALLGOALS (simp_tac ctxt''')
|
|
THEN ALLGOALS (fn n =>
|
|
TRY (resolve_tac ctxt''' Instance.pre_thms n)
|
|
THEN
|
|
REPEAT_DETERM ((
|
|
WPFix.tac ctxt
|
|
ORELSE'
|
|
wp' []
|
|
ORELSE'
|
|
CHANGED_GOAL (clarsimp_tac ctxt''')
|
|
ORELSE'
|
|
assume_tac ctxt'''
|
|
ORELSE'
|
|
Instance.wpc_tactic ctxt'''
|
|
ORELSE'
|
|
Instance.wps_tactic ctxt''' (#wps_rules cfg)
|
|
ORELSE'
|
|
SELECT_GOAL (safe_tac ctxt''')
|
|
ORELSE'
|
|
CHANGED_GOAL (simp_tac ctxt''')
|
|
) n))
|
|
THEN proof_failed_warnings const stack cfg wp' ctxt'''
|
|
)) |> singleton (Proof_Context.export ctxt''' ctxt)
|
|
in (SOME thm, (get_thm_name cfg const, thm) :: thms') end
|
|
end
|
|
handle WrongType =>
|
|
let val _ = writeln ("The constant " ^ const ^ " has the wrong type and is being ignored")
|
|
in (NONE, []) end
|
|
end
|
|
|
|
(*Todo: Remember mapping from locales to theories*)
|
|
fun get_locale_origins full_const_names ctxt =
|
|
let
|
|
fun get_locale_origin abbrev =
|
|
let
|
|
(*Check if the given const is an abbreviation*)
|
|
val (origin,_) = dest_Const (head_of (snd ((Consts.the_abbreviation o Proof_Context.consts_of) ctxt abbrev)));
|
|
(*Check that the origin can be broken into 3 parts (i.e. it is from a locale) *)
|
|
val [_,_,_] = Long_Name.explode origin;
|
|
(*Remember the theory for the abbreviation*)
|
|
|
|
val [qual,nm] = Long_Name.explode abbrev
|
|
in SOME qual end handle exn => handle_int exn NONE
|
|
in fold (curry (fn (abbrev,qual) => case (get_locale_origin abbrev) of
|
|
SOME q => SOME q
|
|
| NONE => NONE)) full_const_names NONE
|
|
end
|
|
|
|
fun crunch_x atts extra prp_name wpigs consts ctxt =
|
|
let
|
|
fun const_name const = dest_Const (read_const ctxt const) |> #1
|
|
|
|
val wp_rules' = wpigs |> filter (fn (s,_) => s = #1 wp_sect) |> map #2 |> thms
|
|
|
|
val wp_dels' = wpigs |> filter (fn (s,_) => s = #1 wp_del_sect) |> map #2 |> thms
|
|
|
|
val wps_rules = wpigs |> filter (fn (s,_) => s = #1 wps_sect) |> map #2 |> thms
|
|
|> get_thms_from_facts ctxt
|
|
|
|
val simps = wpigs |> filter (fn (s,_) => s = #1 simp_sect) |> map #2 |> thms
|
|
|> get_thms_from_facts ctxt
|
|
|
|
val simp_dels = wpigs |> filter (fn (s,_) => s = #1 simp_del_sect) |> map #2 |> thms
|
|
|> get_thms_from_facts ctxt
|
|
|
|
val igs = wpigs |> filter (fn (s,_) => s = #1 ignore_sect) |> map #2 |> constants
|
|
|> map const_name
|
|
|
|
val ig_dels = wpigs |> filter (fn (s,_) => s = #1 ignore_del_sect) |> map #2 |> constants
|
|
|> map const_name
|
|
|
|
val rules = wpigs |> filter (fn (s,_) => s = #1 rule_sect) |> map #2 |> thms
|
|
|> get_thms_from_facts ctxt
|
|
val rules = rules @ Named_Theorems.get ctxt @{named_theorems crunch_rules}
|
|
|
|
fun mk_wp thm =
|
|
let val ms = Thm.prop_of thm |> monads_of ctxt;
|
|
val m = if length ms = 1
|
|
then hd ms |> head_of |> dest_Const |> fst
|
|
else dummy_monad_name;
|
|
in (m, thm) end;
|
|
|
|
val wp_rules = get_thms_from_facts ctxt wp_rules' |> map mk_wp;
|
|
val full_const_names = map const_name consts;
|
|
|
|
val nmspce = get_locale_origins full_const_names ctxt;
|
|
val (pre', extra') = Instance.parse_extra ctxt extra
|
|
handle ERROR s => error ("parsing parameters for " ^ prp_name ^ ": " ^ s)
|
|
|
|
(* check that the given constants match the type of the given property*)
|
|
val const_terms = map (read_const ctxt) full_const_names;
|
|
val _ = map (fn (const_term, const) => make_goal const_term const pre' extra' ctxt)
|
|
(const_terms ~~ full_const_names)
|
|
|
|
val wp_dels = get_thms_from_facts ctxt wp_dels';
|
|
val ctxt' = fold (fn thm => fn ctxt => Thm.proof_attributes [WeakestPre.wp_del] thm ctxt |> snd)
|
|
wp_dels ctxt;
|
|
|
|
val ctxt'' = ctxt' delsimps simp_dels;
|
|
|
|
val (_, thms) = funkyfold (crunch {ctxt = ctxt'', prp_name = prp_name, nmspce = nmspce,
|
|
wp_rules = wp_rules, wps_rules = wps_rules, igs = igs, simps = simps,
|
|
ig_dels = ig_dels, rules = rules} pre' extra' [])
|
|
full_const_names [];
|
|
val _ = if null thms then warning "crunch: no theorems proven" else ();
|
|
|
|
val atts' = map (Attrib.check_src ctxt) atts;
|
|
|
|
val ctxt''' = fold (fn (name, thm) => add_thm thm atts' name) thms ctxt;
|
|
in
|
|
Pretty.writeln
|
|
(Pretty.big_list "proved:"
|
|
(map (fn (n,t) =>
|
|
Pretty.block
|
|
[Pretty.str (n ^ ": "),
|
|
Syntax.pretty_term ctxt (Thm.prop_of t)])
|
|
thms));
|
|
ctxt'''
|
|
end
|
|
|
|
end
|