section {*L\_ATS\_SchedUF\_SB*}
theory
  L_ATS_SchedUF_SB

imports
  L_ATS_SchedUF_Basic

begin

locale ATS_SchedUF_SB =
  ATS_SchedUF_Basic
  "TSstructure :: 'TSstructure \<Rightarrow> bool"
  "configurations :: 'TSstructure \<Rightarrow> 'conf set"
  "initial_configurations :: 'TSstructure \<Rightarrow> 'conf set"
  "step_labels :: 'TSstructure \<Rightarrow> 'label set"
  "step_relation :: 'TSstructure \<Rightarrow> 'conf \<Rightarrow> 'label \<Rightarrow> 'conf \<Rightarrow> bool"
  "effects :: 'TSstructure \<Rightarrow> 'event set"
  "marking_condition :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> bool"
  "marked_effect :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> 'event set"
  "unmarked_effect :: 'TSstructure \<Rightarrow> ('label, 'conf) derivation \<Rightarrow> 'event set"
  "scheduler_fragments :: 'TSstructure \<Rightarrow> 'scheduler_fragment set"
  "empty_scheduler_fragment :: 'TSstructure \<Rightarrow> 'scheduler_fragment"
  "join_scheduler_fragments :: 'scheduler_fragment \<Rightarrow> 'scheduler_fragment \<Rightarrow> 'scheduler_fragment"
  "unfixed_schedulers :: 'TSstructure \<Rightarrow> 'unfixed_scheduler set"
  "empty_unfixed_scheduler :: 'TSstructure \<Rightarrow> 'unfixed_scheduler"
  "unfixed_scheduler_right_quotient :: 'unfixed_scheduler \<Rightarrow> 'unfixed_scheduler \<Rightarrow> 'scheduler_fragment option"
  "extend_unfixed_scheduler :: 'scheduler_fragment \<Rightarrow> 'unfixed_scheduler \<Rightarrow> 'unfixed_scheduler"
  "unfixed_scheduler_extendable :: 'TSstructure \<Rightarrow> 'unfixed_scheduler \<Rightarrow> bool"
  for
    TSstructure configurations initial_configurations step_labels step_relation effects marking_condition marked_effect unmarked_effect scheduler_fragments empty_scheduler_fragment join_scheduler_fragments unfixed_schedulers empty_unfixed_scheduler unfixed_scheduler_right_quotient extend_unfixed_scheduler unfixed_scheduler_extendable
    +
  fixes set_unfixed_scheduler :: "'conf \<Rightarrow> 'unfixed_scheduler \<Rightarrow> 'conf"
  fixes get_unfixed_scheduler :: "'conf \<Rightarrow> 'unfixed_scheduler"

assumes AX_unfixed_scheduler_extendable_quasi_preserved_by_set_unfixed_scheduler: "
  TSstructure G
  \<Longrightarrow> c1 \<in> configurations G
  \<Longrightarrow> c2 \<in> configurations G
  \<Longrightarrow> unfixed_scheduler_extendable G (get_unfixed_scheduler c1)
  \<Longrightarrow> set_unfixed_scheduler c1 (get_unfixed_scheduler c2) = c2
  \<Longrightarrow> unfixed_scheduler_extendable G (get_unfixed_scheduler c2)"

assumes AX_get_unfixed_scheduler_closed: "
  TSstructure G
  \<Longrightarrow> c \<in> configurations G
  \<Longrightarrow> get_unfixed_scheduler c \<in> unfixed_schedulers G"

assumes AX_set_unfixed_scheduler_set: "
  TSstructure G
  \<Longrightarrow> c \<in> configurations G
  \<Longrightarrow> sUF1 \<in> unfixed_schedulers G
  \<Longrightarrow> sUF2 \<in> unfixed_schedulers G
  \<Longrightarrow> set_unfixed_scheduler (set_unfixed_scheduler c sUF1) sUF2 = set_unfixed_scheduler c sUF2"

assumes AX_get_set_unfixed_scheduler: "
  TSstructure G
  \<Longrightarrow> c \<in> configurations G
  \<Longrightarrow> sUF \<in> unfixed_schedulers G
  \<Longrightarrow> get_unfixed_scheduler (set_unfixed_scheduler c sUF) = sUF"

assumes AX_set_unfixed_scheduler_get: "
  TSstructure G
  \<Longrightarrow> c1 \<in> configurations G
  \<Longrightarrow> c2 \<in> configurations G
  \<Longrightarrow> \<exists>sUF\<in> unfixed_schedulers G. set_unfixed_scheduler c1 sUF = set_unfixed_scheduler c2 sUF
  \<Longrightarrow> set_unfixed_scheduler c1 (get_unfixed_scheduler c2) = c2"

assumes AX_unfixed_scheduler_right_quotient_split: "
  TSstructure G
  \<Longrightarrow> derivation G d
  \<Longrightarrow> belongs G d
  \<Longrightarrow> d n = Some (pair e1 c1)
  \<Longrightarrow> d m = Some (pair e2 c2)
  \<Longrightarrow> d k = Some (pair e3 c3)
  \<Longrightarrow> n\<le>m
  \<Longrightarrow> m\<le>k
  \<Longrightarrow> (the (unfixed_scheduler_right_quotient (get_unfixed_scheduler c1) (get_unfixed_scheduler c3))) = join_scheduler_fragments (the (unfixed_scheduler_right_quotient (get_unfixed_scheduler c1) (get_unfixed_scheduler c2))) (the (unfixed_scheduler_right_quotient (get_unfixed_scheduler c2) (get_unfixed_scheduler c3)))"

context ATS_SchedUF_SB begin

definition map_unfixed_scheduler :: "
  ('label, 'conf) derivation
  \<Rightarrow> ('unfixed_scheduler \<Rightarrow> 'unfixed_scheduler)
  \<Rightarrow> ('label, 'conf) derivation"
  where
    "map_unfixed_scheduler d C \<equiv>
  (\<lambda>n. case d n of
  None \<Rightarrow> None
  | Some (pair e c) \<Rightarrow> Some (pair e (set_unfixed_scheduler c (C (get_unfixed_scheduler c)))))"

definition map_unfixed_scheduler_ALT :: "
  ('label, 'conf) derivation
  \<Rightarrow> ('unfixed_scheduler \<Rightarrow> 'unfixed_scheduler)
  \<Rightarrow> ('label, 'conf) derivation"
  where
    "map_unfixed_scheduler_ALT d C \<equiv>
  derivation_map d (\<lambda>c. set_unfixed_scheduler c (C (get_unfixed_scheduler c)))"

lemma map_unfixed_scheduler_ALT_vs_map_unfixed_scheduler: "
  map_unfixed_scheduler_ALT d C = map_unfixed_scheduler d C"
  apply(simp add: map_unfixed_scheduler_ALT_def map_unfixed_scheduler_def derivation_map_def)
  done

definition get_unfixed_scheduler_nth :: "
  ('label, 'conf) derivation
  \<Rightarrow> nat
  \<Rightarrow> 'unfixed_scheduler"
  where
    "get_unfixed_scheduler_nth d n \<equiv>
  get_unfixed_scheduler (the (get_configuration (d n)))"

definition replace_unfixed_scheduler :: "
  'TSstructure
  \<Rightarrow> ('label, 'conf) derivation
  \<Rightarrow> 'unfixed_scheduler
  \<Rightarrow> nat
  \<Rightarrow> ('label, 'conf) derivation"
  where
    "replace_unfixed_scheduler G d1 sUF n
  \<equiv> map_unfixed_scheduler
      d1
      (\<lambda>c. extend_unfixed_scheduler
       (the
         (unfixed_scheduler_right_quotient
           c
           (get_unfixed_scheduler_nth d1 n)))
       sUF)"

definition PB_Nonblockingness_RestSB :: "
  'TSstructure
  \<Rightarrow> ('label,'conf) derivation
  \<Rightarrow> nat
  \<Rightarrow> bool"
  where
    "PB_Nonblockingness_RestSB G dh n \<equiv>
  unfixed_scheduler_extendable G (get_unfixed_scheduler_nth dh n)"

definition PB_Nonblockingness_branching_SB_restricted :: "
  'TSstructure
  \<Rightarrow> bool"
  where
    "PB_Nonblockingness_branching_SB_restricted G \<equiv>
  Nonblockingness_pattern G
  PB_Nonblockingness_RestSB
  PB_Nonblockingness_NoAdapt"

definition PB_Nonblockingness_AdaptSB :: "
  'TSstructure
  \<Rightarrow> ('label,'conf) derivation
  \<Rightarrow> nat
  \<Rightarrow> ('label,'conf) derivation
  \<Rightarrow> nat
  \<Rightarrow> ('label,'conf) derivation
  \<Rightarrow> bool"
  where
    "PB_Nonblockingness_AdaptSB G dh nh dc nc dh' \<equiv>
  if (unfixed_scheduler_extendable G (get_unfixed_scheduler_nth dh nh))
  then
  dh' = replace_unfixed_scheduler G dh (get_unfixed_scheduler_nth dc 0) nh
  else dh' = dh"

end

end


theory prop_12
imports Main
        "../../TestTheories/Listi"
        "../../TestTheories/Naturals"
        "$HIPSTER_HOME/IsaHipster"

begin

theorem initDef: "init (app ts (Cons t Nil)) = ts"
by hipster_induct_schemes

end


(*:maxLineLen=78:*)

theory Tactic
imports Base
begin

chapter \<open>Tactical reasoning\<close>

text \<open>
  Tactical reasoning works by refining an initial claim in a backwards
  fashion, until a solved form is reached. A \<open>goal\<close> consists of several
  subgoals that need to be solved in order to achieve the main statement; zero
  subgoals means that the proof may be finished. A \<open>tactic\<close> is a refinement
  operation that maps a goal to a lazy sequence of potential successors. A
  \<open>tactical\<close> is a combinator for composing tactics.
\<close>

section \<open>Goals \label{sec:tactical-goals}\<close>

text \<open>
  Isabelle/Pure represents a goal as a theorem stating that the subgoals imply
  the main goal: \<open>A\<^sub>1 \<Longrightarrow> \<dots> \<Longrightarrow> A\<^sub>n \<Longrightarrow> C\<close>. The outermost goal structure is that of
  a Horn Clause: i.e.\ an iterated implication without any quantifiers\<^footnote>\<open>Recall
  that outermost \<open>\<And>x. \<phi>[x]\<close> is always represented via schematic variables in
  the body: \<open>\<phi>[?x]\<close>. These variables may get instantiated during the course of
  reasoning.\<close>. For \<open>n = 0\<close> a goal is called ``solved''.

  The structure of each subgoal \<open>A\<^sub>i\<close> is that of a general Hereditary Harrop
  Formula \<open>\<And>x\<^sub>1 \<dots> \<And>x\<^sub>k. H\<^sub>1 \<Longrightarrow> \<dots> \<Longrightarrow> H\<^sub>m \<Longrightarrow> B\<close>. Here \<open>x\<^sub>1, \<dots>, x\<^sub>k\<close> are goal
  parameters, i.e.\ arbitrary-but-fixed entities of certain types, and \<open>H\<^sub>1,
  \<dots>, H\<^sub>m\<close> are goal hypotheses, i.e.\ facts that may be assumed locally.
  Together, this forms the goal context of the conclusion \<open>B\<close> to be
  established. The goal hypotheses may be again arbitrary Hereditary Harrop
  Formulas, although the level of nesting rarely exceeds 1--2 in practice.

  The main conclusion \<open>C\<close> is internally marked as a protected proposition,
  which is represented explicitly by the notation \<open>#C\<close> here. This ensures that
  the decomposition into subgoals and main conclusion is well-defined for
  arbitrarily structured claims.

  \<^medskip>
  Basic goal management is performed via the following Isabelle/Pure rules:

  \[
  \infer[\<open>(init)\<close>]{\<open>C \<Longrightarrow> #C\<close>}{} \qquad
  \infer[\<open>(finish)\<close>]{\<open>C\<close>}{\<open>#C\<close>}
  \]

  \<^medskip>
  The following low-level variants admit general reasoning with protected
  propositions:

  \[
  \infer[\<open>(protect n)\<close>]{\<open>A\<^sub>1 \<Longrightarrow> \<dots> \<Longrightarrow> A\<^sub>n \<Longrightarrow> #C\<close>}{\<open>A\<^sub>1 \<Longrightarrow> \<dots> \<Longrightarrow> A\<^sub>n \<Longrightarrow> C\<close>}
  \]
  \[
  \infer[\<open>(conclude)\<close>]{\<open>A \<Longrightarrow> \<dots> \<Longrightarrow> C\<close>}{\<open>A \<Longrightarrow> \<dots> \<Longrightarrow> #C\<close>}
  \]
\<close>

text %mlref \<open>
  \begin{mldecls}
  @{define_ML Goal.init: "cterm -> thm"} \\
  @{define_ML Goal.finish: "Proof.context -> thm -> thm"} \\
  @{define_ML Goal.protect: "int -> thm -> thm"} \\
  @{define_ML Goal.conclude: "thm -> thm"} \\
  \end{mldecls}

  \<^descr> \<^ML>\<open>Goal.init\<close>~\<open>C\<close> initializes a tactical goal from the well-formed
  proposition \<open>C\<close>.

  \<^descr> \<^ML>\<open>Goal.finish\<close>~\<open>ctxt thm\<close> checks whether theorem \<open>thm\<close> is a solved
  goal (no subgoals), and concludes the result by removing the goal
  protection. The context is only required for printing error messages.

  \<^descr> \<^ML>\<open>Goal.protect\<close>~\<open>n thm\<close> protects the statement of theorem \<open>thm\<close>. The
  parameter \<open>n\<close> indicates the number of premises to be retained.

  \<^descr> \<^ML>\<open>Goal.conclude\<close>~\<open>thm\<close> removes the goal protection, even if there are
  pending subgoals.
\<close>

section \<open>Tactics\label{sec:tactics}\<close>

text \<open>
  A \<open>tactic\<close> is a function \<open>goal \<rightarrow> goal\<^sup>*\<^sup>*\<close> that maps a given goal state
  (represented as a theorem, cf.\ \secref{sec:tactical-goals}) to a lazy
  sequence of potential successor states. The underlying sequence
  implementation is lazy both in head and tail, and is purely functional in
  \<^emph>\<open>not\<close> supporting memoing.\<^footnote>\<open>The lack of memoing and the strict nature of ML
  requires some care when working with low-level sequence operations, to avoid
  duplicate or premature evaluation of results. It also means that modified
  runtime behavior, such as timeout, is very hard to achieve for general
  tactics.\<close>

  An \<^emph>\<open>empty result sequence\<close> means that the tactic has failed: in a compound
  tactic expression other tactics might be tried instead, or the whole
  refinement step might fail outright, producing a toplevel error message in
  the end. When implementing tactics from scratch, one should take care to
  observe the basic protocol of mapping regular error conditions to an empty
  result; only serious faults should emerge as exceptions.

  By enumerating \<^emph>\<open>multiple results\<close>, a tactic can easily express the
  potential outcome of an internal search process. There are also combinators
  for building proof tools that involve search systematically, see also
  \secref{sec:tacticals}.

  \<^medskip>
  As explained before, a goal state essentially consists of a list of subgoals
  that imply the main goal (conclusion). Tactics may operate on all subgoals
  or on a particularly specified subgoal, but must not change the main
  conclusion (apart from instantiating schematic goal variables).

  Tactics with explicit \<^emph>\<open>subgoal addressing\<close> are of the form \<open>int \<rightarrow> tactic\<close>
  and may be applied to a particular subgoal (counting from 1). If the subgoal
  number is out of range, the tactic should fail with an empty result
  sequence, but must not raise an exception!

  Operating on a particular subgoal means to replace it by an interval of zero
  or more subgoals in the same place; other subgoals must not be affected,
  apart from instantiating schematic variables ranging over the whole goal
  state.

  A common pattern of composing tactics with subgoal addressing is to try the
  first one, and then the second one only if the subgoal has not been solved
  yet. Special care is required here to avoid bumping into unrelated subgoals
  that happen to come after the original subgoal. Assuming that there is only
  a single initial subgoal is a very common error when implementing tactics!

  Tactics with internal subgoal addressing should expose the subgoal index as
  \<open>int\<close> argument in full generality; a hardwired subgoal 1 is not acceptable.

  \<^medskip>
  The main well-formedness conditions for proper tactics are summarized as
  follows.

    \<^item> General tactic failure is indicated by an empty result, only serious
    faults may produce an exception.

    \<^item> The main conclusion must not be changed, apart from instantiating
    schematic variables.

    \<^item> A tactic operates either uniformly on all subgoals, or specifically on a
    selected subgoal (without bumping into unrelated subgoals).

    \<^item> Range errors in subgoal addressing produce an empty result.

  Some of these conditions are checked by higher-level goal infrastructure
  (\secref{sec:struct-goals}); others are not checked explicitly, and
  violating them merely results in ill-behaved tactics experienced by the user
  (e.g.\ tactics that insist in being applicable only to singleton goals, or
  prevent composition via standard tacticals such as \<^ML>\<open>REPEAT\<close>).
\<close>

text %mlref \<open>
  \begin{mldecls}
  @{define_ML_type tactic = "thm -> thm Seq.seq"} \\
  @{define_ML no_tac: tactic} \\
  @{define_ML all_tac: tactic} \\
  @{define_ML print_tac: "Proof.context -> string -> tactic"} \\[1ex]
  @{define_ML PRIMITIVE: "(thm -> thm) -> tactic"} \\[1ex]
  @{define_ML SUBGOAL: "(term * int -> tactic) -> int -> tactic"} \\
  @{define_ML CSUBGOAL: "(cterm * int -> tactic) -> int -> tactic"} \\
  @{define_ML SELECT_GOAL: "tactic -> int -> tactic"} \\
  @{define_ML PREFER_GOAL: "tactic -> int -> tactic"} \\
  \end{mldecls}

  \<^descr> Type \<^ML_type>\<open>tactic\<close> represents tactics. The well-formedness conditions
  described above need to be observed. See also \<^file>\<open>~~/src/Pure/General/seq.ML\<close>
  for the underlying implementation of lazy sequences.

  \<^descr> Type \<^ML_type>\<open>int -> tactic\<close> represents tactics with explicit subgoal
  addressing, with well-formedness conditions as described above.

  \<^descr> \<^ML>\<open>no_tac\<close> is a tactic that always fails, returning the empty sequence.

  \<^descr> \<^ML>\<open>all_tac\<close> is a tactic that always succeeds, returning a singleton
  sequence with unchanged goal state.

  \<^descr> \<^ML>\<open>print_tac\<close>~\<open>ctxt message\<close> is like \<^ML>\<open>all_tac\<close>, but prints a message
  together with the goal state on the tracing channel.

  \<^descr> \<^ML>\<open>PRIMITIVE\<close>~\<open>rule\<close> turns a primitive inference rule into a tactic with
  unique result. Exception \<^ML>\<open>THM\<close> is considered a regular tactic failure
  and produces an empty result; other exceptions are passed through.

  \<^descr> \<^ML>\<open>SUBGOAL\<close>~\<open>(fn (subgoal, i) => tactic)\<close> is the most basic form to
  produce a tactic with subgoal addressing. The given abstraction over the
  subgoal term and subgoal number allows to peek at the relevant information
  of the full goal state. The subgoal range is checked as required above.

  \<^descr> \<^ML>\<open>CSUBGOAL\<close> is similar to \<^ML>\<open>SUBGOAL\<close>, but passes the subgoal as
  \<^ML_type>\<open>cterm\<close> instead of raw \<^ML_type>\<open>term\<close>. This avoids expensive
  re-certification in situations where the subgoal is used directly for
  primitive inferences.

  \<^descr> \<^ML>\<open>SELECT_GOAL\<close>~\<open>tac i\<close> confines a tactic to the specified subgoal \<open>i\<close>.
  This rearranges subgoals and the main goal protection
  (\secref{sec:tactical-goals}), while retaining the syntactic context of the
  overall goal state (concerning schematic variables etc.).

  \<^descr> \<^ML>\<open>PREFER_GOAL\<close>~\<open>tac i\<close> rearranges subgoals to put \<open>i\<close> in front. This is
  similar to \<^ML>\<open>SELECT_GOAL\<close>, but without changing the main goal protection.
\<close>

subsection \<open>Resolution and assumption tactics \label{sec:resolve-assume-tac}\<close>

text \<open>
  \<^emph>\<open>Resolution\<close> is the most basic mechanism for refining a subgoal using a
  theorem as object-level rule. \<^emph>\<open>Elim-resolution\<close> is particularly suited for
  elimination rules: it resolves with a rule, proves its first premise by
  assumption, and finally deletes that assumption from any new subgoals.
  \<^emph>\<open>Destruct-resolution\<close> is like elim-resolution, but the given destruction
  rules are first turned into canonical elimination format.
  \<^emph>\<open>Forward-resolution\<close> is like destruct-resolution, but without deleting the
  selected assumption. The \<open>r/e/d/f\<close> naming convention is maintained for
  several different kinds of resolution rules and tactics.

  Assumption tactics close a subgoal by unifying some of its premises against
  its conclusion.

  \<^medskip>
  All the tactics in this section operate on a subgoal designated by a
  positive integer. Other subgoals might be affected indirectly, due to
  instantiation of schematic variables.

  There are various sources of non-determinism, the tactic result sequence
  enumerates all possibilities of the following choices (if applicable):

    \<^enum> selecting one of the rules given as argument to the tactic;

    \<^enum> selecting a subgoal premise to eliminate, unifying it against the first
    premise of the rule;

    \<^enum> unifying the conclusion of the subgoal to the conclusion of the rule.

  Recall that higher-order unification may produce multiple results that are
  enumerated here.
\<close>

text %mlref \<open>
  \begin{mldecls}
  @{define_ML resolve_tac: "Proof.context -> thm list -> int -> tactic"} \\
  @{define_ML eresolve_tac: "Proof.context -> thm list -> int -> tactic"} \\
  @{define_ML dresolve_tac: "Proof.context -> thm list -> int -> tactic"} \\
  @{define_ML forward_tac: "Proof.context -> thm list -> int -> tactic"} \\
  @{define_ML biresolve_tac: "Proof.context -> (bool * thm) list -> int -> tactic"} \\[1ex]
  @{define_ML assume_tac: "Proof.context -> int -> tactic"} \\
  @{define_ML eq_assume_tac: "int -> tactic"} \\[1ex]
  @{define_ML match_tac: "Proof.context -> thm list -> int -> tactic"} \\
  @{define_ML ematch_tac: "Proof.context -> thm list -> int -> tactic"} \\
  @{define_ML dmatch_tac: "Proof.context -> thm list -> int -> tactic"} \\
  @{define_ML bimatch_tac: "Proof.context -> (bool * thm) list -> int -> tactic"} \\
  \end{mldecls}

  \<^descr> \<^ML>\<open>resolve_tac\<close>~\<open>ctxt thms i\<close> refines the goal state using the given
  theorems, which should normally be introduction rules. The tactic resolves a
  rule's conclusion with subgoal \<open>i\<close>, replacing it by the corresponding
  versions of the rule's premises.

  \<^descr> \<^ML>\<open>eresolve_tac\<close>~\<open>ctxt thms i\<close> performs elim-resolution with the given
  theorems, which are normally be elimination rules.

  Note that \<^ML_text>\<open>eresolve_tac ctxt [asm_rl]\<close> is equivalent to \<^ML_text>\<open>assume_tac ctxt\<close>, which facilitates mixing of assumption steps with
  genuine eliminations.

  \<^descr> \<^ML>\<open>dresolve_tac\<close>~\<open>ctxt thms i\<close> performs destruct-resolution with the
  given theorems, which should normally be destruction rules. This replaces an
  assumption by the result of applying one of the rules.

  \<^descr> \<^ML>\<open>forward_tac\<close> is like \<^ML>\<open>dresolve_tac\<close> except that the selected
  assumption is not deleted. It applies a rule to an assumption, adding the
  result as a new assumption.

  \<^descr> \<^ML>\<open>biresolve_tac\<close>~\<open>ctxt brls i\<close> refines the proof state by resolution or
  elim-resolution on each rule, as indicated by its flag. It affects subgoal
  \<open>i\<close> of the proof state.

  For each pair \<open>(flag, rule)\<close>, it applies resolution if the flag is \<open>false\<close>
  and elim-resolution if the flag is \<open>true\<close>. A single tactic call handles a
  mixture of introduction and elimination rules, which is useful to organize
  the search process systematically in proof tools.

  \<^descr> \<^ML>\<open>assume_tac\<close>~\<open>ctxt i\<close> attempts to solve subgoal \<open>i\<close> by assumption
  (modulo higher-order unification).

  \<^descr> \<^ML>\<open>eq_assume_tac\<close> is similar to \<^ML>\<open>assume_tac\<close>, but checks only for
  immediate \<open>\<alpha>\<close>-convertibility instead of using unification. It succeeds (with
  a unique next state) if one of the assumptions is equal to the subgoal's
  conclusion. Since it does not instantiate variables, it cannot make other
  subgoals unprovable.

  \<^descr> \<^ML>\<open>match_tac\<close>, \<^ML>\<open>ematch_tac\<close>, \<^ML>\<open>dmatch_tac\<close>, and \<^ML>\<open>bimatch_tac\<close>
  are similar to \<^ML>\<open>resolve_tac\<close>, \<^ML>\<open>eresolve_tac\<close>, \<^ML>\<open>dresolve_tac\<close>,
  and \<^ML>\<open>biresolve_tac\<close>, respectively, but do not instantiate schematic
  variables in the goal state.\<^footnote>\<open>Strictly speaking, matching means to treat the
  unknowns in the goal state as constants, but these tactics merely discard
  unifiers that would update the goal state. In rare situations (where the
  conclusion and goal state have flexible terms at the same position), the
  tactic will fail even though an acceptable unifier exists.\<close> These tactics
  were written for a specific application within the classical reasoner.

  Flexible subgoals are not updated at will, but are left alone.
\<close>

subsection \<open>Explicit instantiation within a subgoal context\<close>

text \<open>
  The main resolution tactics (\secref{sec:resolve-assume-tac}) use
  higher-order unification, which works well in many practical situations
  despite its daunting theoretical properties. Nonetheless, there are
  important problem classes where unguided higher-order unification is not so
  useful. This typically involves rules like universal elimination,
  existential introduction, or equational substitution. Here the unification
  problem involves fully flexible \<open>?P ?x\<close> schemes, which are hard to manage
  without further hints.

  By providing a (small) rigid term for \<open>?x\<close> explicitly, the remaining
  unification problem is to assign a (large) term to \<open>?P\<close>, according to the
  shape of the given subgoal. This is sufficiently well-behaved in most
  practical situations.

  \<^medskip>
  Isabelle provides separate versions of the standard \<open>r/e/d/f\<close> resolution
  tactics that allow to provide explicit instantiations of unknowns of the
  given rule, wrt.\ terms that refer to the implicit context of the selected
  subgoal.

  An instantiation consists of a list of pairs of the form \<open>(?x, t)\<close>, where
  \<open>?x\<close> is a schematic variable occurring in the given rule, and \<open>t\<close> is a term
  from the current proof context, augmented by the local goal parameters of
  the selected subgoal; cf.\ the \<open>focus\<close> operation described in
  \secref{sec:variables}.

  Entering the syntactic context of a subgoal is a brittle operation, because
  its exact form is somewhat accidental, and the choice of bound variable
  names depends on the presence of other local and global names. Explicit
  renaming of subgoal parameters prior to explicit instantiation might help to
  achieve a bit more robustness.

  Type instantiations may be given as well, via pairs like \<open>(?'a, \<tau>)\<close>. Type
  instantiations are distinguished from term instantiations by the syntactic
  form of the schematic variable. Types are instantiated before terms are.
  Since term instantiation already performs simple type-inference, so explicit
  type instantiations are seldom necessary.
\<close>

text %mlref \<open>
  \begin{mldecls}
  @{define_ML Rule_Insts.res_inst_tac: "Proof.context ->
    ((indexname * Position.T) * string) list -> (binding * string option * mixfix) list ->
    thm -> int -> tactic"} \\
  @{define_ML Rule_Insts.eres_inst_tac: "Proof.context ->
    ((indexname * Position.T) * string) list -> (binding * string option * mixfix) list ->
    thm -> int -> tactic"} \\
  @{define_ML Rule_Insts.dres_inst_tac: "Proof.context ->
    ((indexname * Position.T) * string) list -> (binding * string option * mixfix) list ->
    thm -> int -> tactic"} \\
  @{define_ML Rule_Insts.forw_inst_tac: "Proof.context ->
    ((indexname * Position.T) * string) list -> (binding * string option * mixfix) list ->
    thm -> int -> tactic"} \\
  @{define_ML Rule_Insts.subgoal_tac: "Proof.context -> string ->
    (binding * string option * mixfix) list -> int -> tactic"} \\
  @{define_ML Rule_Insts.thin_tac: "Proof.context -> string ->
    (binding * string option * mixfix) list -> int -> tactic"} \\
  @{define_ML rename_tac: "string list -> int -> tactic"} \\
  \end{mldecls}

  \<^descr> \<^ML>\<open>Rule_Insts.res_inst_tac\<close>~\<open>ctxt insts thm i\<close> instantiates the rule
  \<open>thm\<close> with the instantiations \<open>insts\<close>, as described above, and then performs
  resolution on subgoal \<open>i\<close>.

  \<^descr> \<^ML>\<open>Rule_Insts.eres_inst_tac\<close> is like \<^ML>\<open>Rule_Insts.res_inst_tac\<close>, but
  performs elim-resolution.

  \<^descr> \<^ML>\<open>Rule_Insts.dres_inst_tac\<close> is like \<^ML>\<open>Rule_Insts.res_inst_tac\<close>, but
  performs destruct-resolution.

  \<^descr> \<^ML>\<open>Rule_Insts.forw_inst_tac\<close> is like \<^ML>\<open>Rule_Insts.dres_inst_tac\<close>
  except that the selected assumption is not deleted.

  \<^descr> \<^ML>\<open>Rule_Insts.subgoal_tac\<close>~\<open>ctxt \<phi> i\<close> adds the proposition \<open>\<phi>\<close> as local
  premise to subgoal \<open>i\<close>, and poses the same as a new subgoal \<open>i + 1\<close> (in the
  original context).

  \<^descr> \<^ML>\<open>Rule_Insts.thin_tac\<close>~\<open>ctxt \<phi> i\<close> deletes the specified premise from
  subgoal \<open>i\<close>. Note that \<open>\<phi>\<close> may contain schematic variables, to abbreviate
  the intended proposition; the first matching subgoal premise will be
  deleted. Removing useless premises from a subgoal increases its readability
  and can make search tactics run faster.

  \<^descr> \<^ML>\<open>rename_tac\<close>~\<open>names i\<close> renames the innermost parameters of subgoal \<open>i\<close>
  according to the provided \<open>names\<close> (which need to be distinct identifiers).

  For historical reasons, the above instantiation tactics take unparsed string
  arguments, which makes them hard to use in general ML code. The slightly
  more advanced \<^ML>\<open>Subgoal.FOCUS\<close> combinator of \secref{sec:struct-goals}
  allows to refer to internal goal structure with explicit context management.
\<close>

subsection \<open>Rearranging goal states\<close>

text \<open>
  In rare situations there is a need to rearrange goal states: either the
  overall collection of subgoals, or the local structure of a subgoal. Various
  administrative tactics allow to operate on the concrete presentation these
  conceptual sets of formulae.
\<close>

text %mlref \<open>
  \begin{mldecls}
  @{define_ML rotate_tac: "int -> int -> tactic"} \\
  @{define_ML distinct_subgoals_tac: tactic} \\
  @{define_ML flexflex_tac: "Proof.context -> tactic"} \\
  \end{mldecls}

  \<^descr> \<^ML>\<open>rotate_tac\<close>~\<open>n i\<close> rotates the premises of subgoal \<open>i\<close> by \<open>n\<close>
  positions: from right to left if \<open>n\<close> is positive, and from left to right if
  \<open>n\<close> is negative.

  \<^descr> \<^ML>\<open>distinct_subgoals_tac\<close> removes duplicate subgoals from a proof state.
  This is potentially inefficient.

  \<^descr> \<^ML>\<open>flexflex_tac\<close> removes all flex-flex pairs from the proof state by
  applying the trivial unifier. This drastic step loses information. It is
  already part of the Isar infrastructure for facts resulting from goals, and
  rarely needs to be invoked manually.

  Flex-flex constraints arise from difficult cases of higher-order
  unification. To prevent this, use \<^ML>\<open>Rule_Insts.res_inst_tac\<close> to
  instantiate some variables in a rule. Normally flex-flex constraints can be
  ignored; they often disappear as unknowns get instantiated.
\<close>

subsection \<open>Raw composition: resolution without lifting\<close>

text \<open>
  Raw composition of two rules means resolving them without prior lifting or
  renaming of unknowns. This low-level operation, which underlies the
  resolution tactics, may occasionally be useful for special effects.
  Schematic variables are not renamed by default, so beware of clashes!
\<close>

text %mlref \<open>
  \begin{mldecls}
  @{define_ML compose_tac: "Proof.context -> (bool * thm * int) -> int -> tactic"} \\
  @{define_ML Drule.compose: "thm * int * thm -> thm"} \\
  @{define_ML_infix COMP: "thm * thm -> thm"} \\
  \end{mldecls}

  \<^descr> \<^ML>\<open>compose_tac\<close>~\<open>ctxt (flag, rule, m) i\<close> refines subgoal \<open>i\<close> using
  \<open>rule\<close>, without lifting. The \<open>rule\<close> is taken to have the form \<open>\<psi>\<^sub>1 \<Longrightarrow> \<dots> \<psi>\<^sub>m \<Longrightarrow>
  \<psi>\<close>, where \<open>\<psi>\<close> need not be atomic; thus \<open>m\<close> determines the number of new
  subgoals. If \<open>flag\<close> is \<open>true\<close> then it performs elim-resolution --- it solves
  the first premise of \<open>rule\<close> by assumption and deletes that assumption.

  \<^descr> \<^ML>\<open>Drule.compose\<close>~\<open>(thm\<^sub>1, i, thm\<^sub>2)\<close> uses \<open>thm\<^sub>1\<close>, regarded as an
  atomic formula, to solve premise \<open>i\<close> of \<open>thm\<^sub>2\<close>. Let \<open>thm\<^sub>1\<close> and \<open>thm\<^sub>2\<close> be
  \<open>\<psi>\<close> and \<open>\<phi>\<^sub>1 \<Longrightarrow> \<dots> \<phi>\<^sub>n \<Longrightarrow> \<phi>\<close>. The unique \<open>s\<close> that unifies \<open>\<psi>\<close> and \<open>\<phi>\<^sub>i\<close> yields
  the theorem \<open>(\<phi>\<^sub>1 \<Longrightarrow> \<dots> \<phi>\<^sub>i\<^sub>-\<^sub>1 \<Longrightarrow> \<phi>\<^sub>i\<^sub>+\<^sub>1 \<Longrightarrow> \<dots> \<phi>\<^sub>n \<Longrightarrow> \<phi>)s\<close>. Multiple results are
  considered as error (exception \<^ML>\<open>THM\<close>).

  \<^descr> \<open>thm\<^sub>1 COMP thm\<^sub>2\<close> is the same as \<open>Drule.compose (thm\<^sub>1, 1, thm\<^sub>2)\<close>.

  \begin{warn}
  These low-level operations are stepping outside the structure imposed by
  regular rule resolution. Used without understanding of the consequences,
  they may produce results that cause problems with standard rules and tactics
  later on.
  \end{warn}
\<close>

section \<open>Tacticals \label{sec:tacticals}\<close>

text \<open>
  A \<^emph>\<open>tactical\<close> is a functional combinator for building up complex tactics
  from simpler ones. Common tacticals perform sequential composition,
  disjunctive choice, iteration, or goal addressing. Various search strategies
  may be expressed via tacticals.
\<close>

subsection \<open>Combining tactics\<close>

text \<open>
  Sequential composition and alternative choices are the most basic ways to
  combine tactics, similarly to ``\<^verbatim>\<open>,\<close>'' and ``\<^verbatim>\<open>|\<close>'' in Isar method notation.
  This corresponds to \<^ML_infix>\<open>THEN\<close> and \<^ML_infix>\<open>ORELSE\<close> in ML, but there
  are further possibilities for fine-tuning alternation of tactics such as
  \<^ML_infix>\<open>APPEND\<close>. Further details become visible in ML due to explicit
  subgoal addressing.
\<close>

text %mlref \<open>
  \begin{mldecls}
  @{define_ML_infix "THEN": "tactic * tactic -> tactic"} \\
  @{define_ML_infix "ORELSE": "tactic * tactic -> tactic"} \\
  @{define_ML_infix "APPEND": "tactic * tactic -> tactic"} \\
  @{define_ML "EVERY": "tactic list -> tactic"} \\
  @{define_ML "FIRST": "tactic list -> tactic"} \\[0.5ex]

  @{define_ML_infix "THEN'": "('a -> tactic) * ('a -> tactic) -> 'a -> tactic"} \\
  @{define_ML_infix "ORELSE'": "('a -> tactic) * ('a -> tactic) -> 'a -> tactic"} \\
  @{define_ML_infix "APPEND'": "('a -> tactic) * ('a -> tactic) -> 'a -> tactic"} \\
  @{define_ML "EVERY'": "('a -> tactic) list -> 'a -> tactic"} \\
  @{define_ML "FIRST'": "('a -> tactic) list -> 'a -> tactic"} \\
  \end{mldecls}

  \<^descr> \<open>tac\<^sub>1\<close>~\<^ML_infix>\<open>THEN\<close>~\<open>tac\<^sub>2\<close> is the sequential composition of \<open>tac\<^sub>1\<close> and
  \<open>tac\<^sub>2\<close>. Applied to a goal state, it returns all states reachable in two
  steps by applying \<open>tac\<^sub>1\<close> followed by \<open>tac\<^sub>2\<close>. First, it applies \<open>tac\<^sub>1\<close> to
  the goal state, getting a sequence of possible next states; then, it applies
  \<open>tac\<^sub>2\<close> to each of these and concatenates the results to produce again one
  flat sequence of states.

  \<^descr> \<open>tac\<^sub>1\<close>~\<^ML_infix>\<open>ORELSE\<close>~\<open>tac\<^sub>2\<close> makes a choice between \<open>tac\<^sub>1\<close> and
  \<open>tac\<^sub>2\<close>. Applied to a state, it tries \<open>tac\<^sub>1\<close> and returns the result if
  non-empty; if \<open>tac\<^sub>1\<close> fails then it uses \<open>tac\<^sub>2\<close>. This is a deterministic
  choice: if \<open>tac\<^sub>1\<close> succeeds then \<open>tac\<^sub>2\<close> is excluded from the result.

  \<^descr> \<open>tac\<^sub>1\<close>~\<^ML_infix>\<open>APPEND\<close>~\<open>tac\<^sub>2\<close> concatenates the possible results of
  \<open>tac\<^sub>1\<close> and \<open>tac\<^sub>2\<close>. Unlike \<^ML_infix>\<open>ORELSE\<close> there is \<^emph>\<open>no commitment\<close> to
  either tactic, so \<^ML_infix>\<open>APPEND\<close> helps to avoid incompleteness during
  search, at the cost of potential inefficiencies.

  \<^descr> \<^ML>\<open>EVERY\<close>~\<open>[tac\<^sub>1, \<dots>, tac\<^sub>n]\<close> abbreviates \<open>tac\<^sub>1\<close>~\<^ML_infix>\<open>THEN\<close>~\<open>\<dots>\<close>~\<^ML_infix>\<open>THEN\<close>~\<open>tac\<^sub>n\<close>. Note that \<^ML>\<open>EVERY []\<close> is the same as
  \<^ML>\<open>all_tac\<close>: it always succeeds.

  \<^descr> \<^ML>\<open>FIRST\<close>~\<open>[tac\<^sub>1, \<dots>, tac\<^sub>n]\<close> abbreviates \<open>tac\<^sub>1\<close>~\<^ML_infix>\<open>ORELSE\<close>~\<open>\<dots>\<close>~\<^ML_infix>\<open>ORELSE\<close>~\<open>tac\<^sub>n\<close>. Note that \<^ML>\<open>FIRST []\<close> is the
  same as \<^ML>\<open>no_tac\<close>: it always fails.

  \<^descr> \<^ML_infix>\<open>THEN'\<close> is the lifted version of \<^ML_infix>\<open>THEN\<close>, for tactics
  with explicit subgoal addressing. So \<open>(tac\<^sub>1\<close>~\<^ML_infix>\<open>THEN'\<close>~\<open>tac\<^sub>2) i\<close> is
  the same as \<open>(tac\<^sub>1 i\<close>~\<^ML_infix>\<open>THEN\<close>~\<open>tac\<^sub>2 i)\<close>.

  The other primed tacticals work analogously.
\<close>

subsection \<open>Repetition tacticals\<close>

text \<open>
  These tacticals provide further control over repetition of tactics, beyond
  the stylized forms of ``\<^verbatim>\<open>?\<close>'' and ``\<^verbatim>\<open>+\<close>'' in Isar method expressions.
\<close>

text %mlref \<open>
  \begin{mldecls}
  @{define_ML "TRY": "tactic -> tactic"} \\
  @{define_ML "REPEAT": "tactic -> tactic"} \\
  @{define_ML "REPEAT1": "tactic -> tactic"} \\
  @{define_ML "REPEAT_DETERM": "tactic -> tactic"} \\
  @{define_ML "REPEAT_DETERM_N": "int -> tactic -> tactic"} \\
  \end{mldecls}

  \<^descr> \<^ML>\<open>TRY\<close>~\<open>tac\<close> applies \<open>tac\<close> to the goal state and returns the resulting
  sequence, if non-empty; otherwise it returns the original state. Thus, it
  applies \<open>tac\<close> at most once.

  Note that for tactics with subgoal addressing, the combinator can be applied
  via functional composition: \<^ML>\<open>TRY\<close>~\<^ML_infix>\<open>o\<close>~\<open>tac\<close>. There is no need
  for \<^verbatim>\<open>TRY'\<close>.

  \<^descr> \<^ML>\<open>REPEAT\<close>~\<open>tac\<close> applies \<open>tac\<close> to the goal state and, recursively, to
  each element of the resulting sequence. The resulting sequence consists of
  those states that make \<open>tac\<close> fail. Thus, it applies \<open>tac\<close> as many times as
  possible (including zero times), and allows backtracking over each
  invocation of \<open>tac\<close>. \<^ML>\<open>REPEAT\<close> is more general than \<^ML>\<open>REPEAT_DETERM\<close>,
  but requires more space.

  \<^descr> \<^ML>\<open>REPEAT1\<close>~\<open>tac\<close> is like \<^ML>\<open>REPEAT\<close>~\<open>tac\<close> but it always applies \<open>tac\<close>
  at least once, failing if this is impossible.

  \<^descr> \<^ML>\<open>REPEAT_DETERM\<close>~\<open>tac\<close> applies \<open>tac\<close> to the goal state and,
  recursively, to the head of the resulting sequence. It returns the first
  state to make \<open>tac\<close> fail. It is deterministic, discarding alternative
  outcomes.

  \<^descr> \<^ML>\<open>REPEAT_DETERM_N\<close>~\<open>n tac\<close> is like \<^ML>\<open>REPEAT_DETERM\<close>~\<open>tac\<close> but the
  number of repetitions is bound by \<open>n\<close> (where \<^ML>\<open>~1\<close> means \<open>\<infinity>\<close>).
\<close>

text %mlex \<open>
  The basic tactics and tacticals considered above follow some algebraic laws:

  \<^item> \<^ML>\<open>all_tac\<close> is the identity element of the tactical \<^ML_infix>\<open>THEN\<close>.

  \<^item> \<^ML>\<open>no_tac\<close> is the identity element of \<^ML_infix>\<open>ORELSE\<close> and \<^ML_infix>\<open>APPEND\<close>. Also, it is a zero element for \<^ML_infix>\<open>THEN\<close>, which means that
  \<open>tac\<close>~\<^ML_infix>\<open>THEN\<close>~\<^ML>\<open>no_tac\<close> is equivalent to \<^ML>\<open>no_tac\<close>.

  \<^item> \<^ML>\<open>TRY\<close> and \<^ML>\<open>REPEAT\<close> can be expressed as (recursive) functions over
  more basic combinators (ignoring some internal implementation tricks):
\<close>

ML \<open>
  fun TRY tac = tac ORELSE all_tac;
  fun REPEAT tac st = ((tac THEN REPEAT tac) ORELSE all_tac) st;
\<close>

text \<open>
  If \<open>tac\<close> can return multiple outcomes then so can \<^ML>\<open>REPEAT\<close>~\<open>tac\<close>. \<^ML>\<open>REPEAT\<close> uses \<^ML_infix>\<open>ORELSE\<close> and not \<^ML_infix>\<open>APPEND\<close>, it applies \<open>tac\<close>
  as many times as possible in each outcome.

  \begin{warn}
  Note the explicit abstraction over the goal state in the ML definition of
  \<^ML>\<open>REPEAT\<close>. Recursive tacticals must be coded in this awkward fashion to
  avoid infinite recursion of eager functional evaluation in Standard ML. The
  following attempt would make \<^ML>\<open>REPEAT\<close>~\<open>tac\<close> loop:
  \end{warn}
\<close>

ML_val \<open>
  (*BAD -- does not terminate!*)
  fun REPEAT tac = (tac THEN REPEAT tac) ORELSE all_tac;
\<close>

subsection \<open>Applying tactics to subgoal ranges\<close>

text \<open>
  Tactics with explicit subgoal addressing \<^ML_type>\<open>int -> tactic\<close> can be
  used together with tacticals that act like ``subgoal quantifiers'': guided
  by success of the body tactic a certain range of subgoals is covered. Thus
  the body tactic is applied to \<^emph>\<open>all\<close> subgoals, \<^emph>\<open>some\<close> subgoal etc.

  Suppose that the goal state has \<open>n \<ge> 0\<close> subgoals. Many of these tacticals
  address subgoal ranges counting downwards from \<open>n\<close> towards \<open>1\<close>. This has the
  fortunate effect that newly emerging subgoals are concatenated in the
  result, without interfering each other. Nonetheless, there might be
  situations where a different order is desired.
\<close>

text %mlref \<open>
  \begin{mldecls}
  @{define_ML ALLGOALS: "(int -> tactic) -> tactic"} \\
  @{define_ML SOMEGOAL: "(int -> tactic) -> tactic"} \\
  @{define_ML FIRSTGOAL: "(int -> tactic) -> tactic"} \\
  @{define_ML HEADGOAL: "(int -> tactic) -> tactic"} \\
  @{define_ML REPEAT_SOME: "(int -> tactic) -> tactic"} \\
  @{define_ML REPEAT_FIRST: "(int -> tactic) -> tactic"} \\
  @{define_ML RANGE: "(int -> tactic) list -> int -> tactic"} \\
  \end{mldecls}

  \<^descr> \<^ML>\<open>ALLGOALS\<close>~\<open>tac\<close> is equivalent to \<open>tac n\<close>~\<^ML_infix>\<open>THEN\<close>~\<open>\<dots>\<close>~\<^ML_infix>\<open>THEN\<close>~\<open>tac 1\<close>. It applies the \<open>tac\<close> to all the subgoals, counting downwards.

  \<^descr> \<^ML>\<open>SOMEGOAL\<close>~\<open>tac\<close> is equivalent to \<open>tac n\<close>~\<^ML_infix>\<open>ORELSE\<close>~\<open>\<dots>\<close>~\<^ML_infix>\<open>ORELSE\<close>~\<open>tac 1\<close>. It applies \<open>tac\<close> to one subgoal, counting downwards.

  \<^descr> \<^ML>\<open>FIRSTGOAL\<close>~\<open>tac\<close> is equivalent to \<open>tac 1\<close>~\<^ML_infix>\<open>ORELSE\<close>~\<open>\<dots>\<close>~\<^ML_infix>\<open>ORELSE\<close>~\<open>tac n\<close>. It applies \<open>tac\<close> to one subgoal, counting upwards.

  \<^descr> \<^ML>\<open>HEADGOAL\<close>~\<open>tac\<close> is equivalent to \<open>tac 1\<close>. It applies \<open>tac\<close>
  unconditionally to the first subgoal.

  \<^descr> \<^ML>\<open>REPEAT_SOME\<close>~\<open>tac\<close> applies \<open>tac\<close> once or more to a subgoal, counting
  downwards.

  \<^descr> \<^ML>\<open>REPEAT_FIRST\<close>~\<open>tac\<close> applies \<open>tac\<close> once or more to a subgoal, counting
  upwards.

  \<^descr> \<^ML>\<open>RANGE\<close>~\<open>[tac\<^sub>1, \<dots>, tac\<^sub>k] i\<close> is equivalent to \<open>tac\<^sub>k (i + k -
  1)\<close>~\<^ML_infix>\<open>THEN\<close>~\<open>\<dots>\<close>~\<^ML_infix>\<open>THEN\<close>~\<open>tac\<^sub>1 i\<close>. It applies the given list of
  tactics to the corresponding range of subgoals, counting downwards.
\<close>

subsection \<open>Control and search tacticals\<close>

text \<open>
  A predicate on theorems \<^ML_type>\<open>thm -> bool\<close> can test whether a goal
  state enjoys some desirable property --- such as having no subgoals. Tactics
  that search for satisfactory goal states are easy to express. The main
  search procedures, depth-first, breadth-first and best-first, are provided
  as tacticals. They generate the search tree by repeatedly applying a given
  tactic.
\<close>

text %mlref ""

subsubsection \<open>Filtering a tactic's results\<close>

text \<open>
  \begin{mldecls}
  @{define_ML FILTER: "(thm -> bool) -> tactic -> tactic"} \\
  @{define_ML CHANGED: "tactic -> tactic"} \\
  \end{mldecls}

  \<^descr> \<^ML>\<open>FILTER\<close>~\<open>sat tac\<close> applies \<open>tac\<close> to the goal state and returns a
  sequence consisting of those result goal states that are satisfactory in the
  sense of \<open>sat\<close>.

  \<^descr> \<^ML>\<open>CHANGED\<close>~\<open>tac\<close> applies \<open>tac\<close> to the goal state and returns precisely
  those states that differ from the original state (according to \<^ML>\<open>Thm.eq_thm\<close>). Thus \<^ML>\<open>CHANGED\<close>~\<open>tac\<close> always has some effect on the state.
\<close>

subsubsection \<open>Depth-first search\<close>

text \<open>
  \begin{mldecls}
  @{define_ML DEPTH_FIRST: "(thm -> bool) -> tactic -> tactic"} \\
  @{define_ML DEPTH_SOLVE: "tactic -> tactic"} \\
  @{define_ML DEPTH_SOLVE_1: "tactic -> tactic"} \\
  \end{mldecls}

  \<^descr> \<^ML>\<open>DEPTH_FIRST\<close>~\<open>sat tac\<close> returns the goal state if \<open>sat\<close> returns true.
  Otherwise it applies \<open>tac\<close>, then recursively searches from each element of
  the resulting sequence. The code uses a stack for efficiency, in effect
  applying \<open>tac\<close>~\<^ML_infix>\<open>THEN\<close>~\<^ML>\<open>DEPTH_FIRST\<close>~\<open>sat tac\<close> to the state.

  \<^descr> \<^ML>\<open>DEPTH_SOLVE\<close>\<open>tac\<close> uses \<^ML>\<open>DEPTH_FIRST\<close> to search for states having
  no subgoals.

  \<^descr> \<^ML>\<open>DEPTH_SOLVE_1\<close>~\<open>tac\<close> uses \<^ML>\<open>DEPTH_FIRST\<close> to search for states
  having fewer subgoals than the given state. Thus, it insists upon solving at
  least one subgoal.
\<close>

subsubsection \<open>Other search strategies\<close>

text \<open>
  \begin{mldecls}
  @{define_ML BREADTH_FIRST: "(thm -> bool) -> tactic -> tactic"} \\
  @{define_ML BEST_FIRST: "(thm -> bool) * (thm -> int) -> tactic -> tactic"} \\
  @{define_ML THEN_BEST_FIRST: "tactic -> (thm -> bool) * (thm -> int) -> tactic -> tactic"} \\
  \end{mldecls}

  These search strategies will find a solution if one exists. However, they do
  not enumerate all solutions; they terminate after the first satisfactory
  result from \<open>tac\<close>.

  \<^descr> \<^ML>\<open>BREADTH_FIRST\<close>~\<open>sat tac\<close> uses breadth-first search to find states for
  which \<open>sat\<close> is true. For most applications, it is too slow.

  \<^descr> \<^ML>\<open>BEST_FIRST\<close>~\<open>(sat, dist) tac\<close> does a heuristic search, using \<open>dist\<close>
  to estimate the distance from a satisfactory state (in the sense of \<open>sat\<close>).
  It maintains a list of states ordered by distance. It applies \<open>tac\<close> to the
  head of this list; if the result contains any satisfactory states, then it
  returns them. Otherwise, \<^ML>\<open>BEST_FIRST\<close> adds the new states to the list,
  and continues.

  The distance function is typically \<^ML>\<open>size_of_thm\<close>, which computes the
  size of the state. The smaller the state, the fewer and simpler subgoals it
  has.

  \<^descr> \<^ML>\<open>THEN_BEST_FIRST\<close>~\<open>tac\<^sub>0 (sat, dist) tac\<close> is like \<^ML>\<open>BEST_FIRST\<close>,
  except that the priority queue initially contains the result of applying
  \<open>tac\<^sub>0\<close> to the goal state. This tactical permits separate tactics for
  starting the search and continuing the search.
\<close>

subsubsection \<open>Auxiliary tacticals for searching\<close>

text \<open>
  \begin{mldecls}
  @{define_ML COND: "(thm -> bool) -> tactic -> tactic -> tactic"} \\
  @{define_ML IF_UNSOLVED: "tactic -> tactic"} \\
  @{define_ML SOLVE: "tactic -> tactic"} \\
  @{define_ML DETERM: "tactic -> tactic"} \\
  \end{mldecls}

  \<^descr> \<^ML>\<open>COND\<close>~\<open>sat tac\<^sub>1 tac\<^sub>2\<close> applies \<open>tac\<^sub>1\<close> to the goal state if it
  satisfies predicate \<open>sat\<close>, and applies \<open>tac\<^sub>2\<close>. It is a conditional tactical
  in that only one of \<open>tac\<^sub>1\<close> and \<open>tac\<^sub>2\<close> is applied to a goal state. However,
  both \<open>tac\<^sub>1\<close> and \<open>tac\<^sub>2\<close> are evaluated because ML uses eager evaluation.

  \<^descr> \<^ML>\<open>IF_UNSOLVED\<close>~\<open>tac\<close> applies \<open>tac\<close> to the goal state if it has any
  subgoals, and simply returns the goal state otherwise. Many common tactics,
  such as \<^ML>\<open>resolve_tac\<close>, fail if applied to a goal state that has no
  subgoals.

  \<^descr> \<^ML>\<open>SOLVE\<close>~\<open>tac\<close> applies \<open>tac\<close> to the goal state and then fails iff there
  are subgoals left.

  \<^descr> \<^ML>\<open>DETERM\<close>~\<open>tac\<close> applies \<open>tac\<close> to the goal state and returns the head of
  the resulting sequence. \<^ML>\<open>DETERM\<close> limits the search space by making its
  argument deterministic.
\<close>

subsubsection \<open>Predicates and functions useful for searching\<close>

text \<open>
  \begin{mldecls}
  @{define_ML has_fewer_prems: "int -> thm -> bool"} \\
  @{define_ML Thm.eq_thm: "thm * thm -> bool"} \\
  @{define_ML Thm.eq_thm_prop: "thm * thm -> bool"} \\
  @{define_ML size_of_thm: "thm -> int"} \\
  \end{mldecls}

  \<^descr> \<^ML>\<open>has_fewer_prems\<close>~\<open>n thm\<close> reports whether \<open>thm\<close> has fewer than \<open>n\<close>
  premises.

  \<^descr> \<^ML>\<open>Thm.eq_thm\<close>~\<open>(thm\<^sub>1, thm\<^sub>2)\<close> reports whether \<open>thm\<^sub>1\<close> and \<open>thm\<^sub>2\<close> are
  equal. Both theorems must have the same conclusions, the same set of
  hypotheses, and the same set of sort hypotheses. Names of bound variables
  are ignored as usual.

  \<^descr> \<^ML>\<open>Thm.eq_thm_prop\<close>~\<open>(thm\<^sub>1, thm\<^sub>2)\<close> reports whether the propositions of
  \<open>thm\<^sub>1\<close> and \<open>thm\<^sub>2\<close> are equal. Names of bound variables are ignored.

  \<^descr> \<^ML>\<open>size_of_thm\<close>~\<open>thm\<close> computes the size of \<open>thm\<close>, namely the number of
  variables, constants and abstractions in its conclusion. It may serve as a
  distance function for \<^ML>\<open>BEST_FIRST\<close>.
\<close>

end


theory Bound_UntilM

imports
  "Sail.Sail2_prompt"

begin

text \<open>
Adjustment of untilM to add a metric function which guarantees
termination.
\<close>

function
  bound_untilM :: "('a \<Rightarrow> nat) \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> ('b, bool, 'c) monad) \<Rightarrow> ('a \<Rightarrow> ('b, 'a, 'c) monad) \<Rightarrow> ('b, 'a, 'c) monad"
  where
  "bound_untilM bound orig_vars cond body = (
  body orig_vars \<bind> (\<lambda> vars.
  cond vars \<bind> (\<lambda> cond_val.
  if cond_val then return vars
  else if bound vars < bound orig_vars
  then bound_untilM bound vars cond body
    else Fail ''untilM'')))"
  by pat_completeness auto

termination bound_untilM
  apply (relation "measure (\<lambda>(bound, vs, _, _). bound vs)")
   apply simp
  apply simp
  done

declare bound_untilM.simps[simp del]

lemma coerce_inv_bound_untilM_induct:
  assumes I: "I vs"
  and step: "\<forall>vs vs' t t'. I vs \<and> Run (body vs) t vs' \<and> Run (cond vs') t' False \<longrightarrow>
        I vs' \<and> bound vs' < bound vs"
  shows "untilM_dom (vs, cond, body) \<and> untilM vs cond body = bound_untilM bound vs cond body"
  (is "?dom vs \<and> ?eq vs")
  using I
proof (induct vs rule: measure_induct[where f=bound])
case (1 vs)

  note step2 = step[simplified imp_conjL, rule_format, OF "1.prems"]

  from 1 have dom: "?dom vs"
    by (fastforce intro: accpI elim!: untilM_rel.cases dest!: step2)

  from 1 have eq: "?eq vs"
    apply (subst bound_untilM.simps)
    apply (simp add: untilM.psimps[OF dom])
    apply (intro bind_cong refl if_cong)
    apply (auto dest!: step2)
    done

  from dom eq show ?case by simp
qed

lemmas coerce_inv_bound_untilM =
    coerce_inv_bound_untilM_induct[THEN conjunct2]

end


section \<open>Automation\<close>
theory Automation
imports Hoare_Triple Refine_Imp_Hol (*"../Lib/Refine_Util"*)
begin

text \<open>
  In this theory, we provide a set of tactics and a simplifier setup for easy
  reasoning with our separation logic.\<close>

subsection \<open>Normalization of Assertions\<close>
text \<open>
  In this section, we provide a set of lemmas and a simplifier
  setup to bring assertions to a normal form. We provide a simproc that
  detects pure parts of assertions and duplicate pointers. Moreover,
  we provide ac-rules for assertions. See Section~\ref{sec:auto:overview}
  for a short overview of the available proof methods.
\<close>

lemmas assn_aci =
  inf_aci[where 'a=assn]
  sup_aci[where 'a=assn]
  mult.left_ac[where 'a=assn]

lemmas star_assoc = mult.assoc[where 'a=assn]
lemmas assn_assoc =
  mult.left_assoc inf_assoc[where 'a=assn] sup_assoc[where 'a=assn]

lemma merge_true_star_ctx: "true * (true * P) = true * P"
  by (simp add: mult.left_ac)

lemmas star_aci =
  mult.assoc[where 'a=assn] mult.commute[where 'a=assn] mult.left_commute[where 'a=assn]
  assn_one_left mult_1_right[where 'a=assn]
  merge_true_star merge_true_star_ctx

text \<open>Move existential quantifiers to the front of assertions\<close>
lemma ex_assn_move_out[simp]:
  "\<And>Q R. (\<exists>\<^sub>Ax. Q x) * R = (\<exists>\<^sub>Ax. (Q x * R))"
  "\<And>Q R. R * (\<exists>\<^sub>Ax. Q x) = (\<exists>\<^sub>Ax. (R * Q x))"

  "\<And>P Q. (\<exists>\<^sub>Ax. Q x) \<and>\<^sub>A P = (\<exists>\<^sub>Ax. (Q x \<and>\<^sub>A P)) "
  "\<And>P Q. Q \<and>\<^sub>A (\<exists>\<^sub>Ax. P x) = (\<exists>\<^sub>Ax. (Q \<and>\<^sub>A P x))"

  "\<And>P Q. (\<exists>\<^sub>Ax. Q x) \<or>\<^sub>A P = (\<exists>\<^sub>Ax. (Q x \<or>\<^sub>A P))"
  "\<And>P Q. Q \<or>\<^sub>A (\<exists>\<^sub>Ax. P x) = (\<exists>\<^sub>Ax. (Q \<or>\<^sub>A P x))"
  apply -
  apply (simp add: ex_distrib_star)
  apply (subst mult.commute)
  apply (subst (2) mult.commute)
  apply (simp add: ex_distrib_star)

  apply (simp add: ex_distrib_and)
  apply (subst inf_commute)
  apply (subst (2) inf_commute)
  apply (simp add: ex_distrib_and)

  apply (simp add: ex_distrib_or)
  apply (subst sup_commute)
  apply (subst (2) sup_commute)
  apply (simp add: ex_distrib_or)
  done

text \<open>Extract pure assertions from and-clauses\<close>
lemma and_extract_pure_left_iff[simp]: "\<up>b \<and>\<^sub>A Q = (emp\<and>\<^sub>AQ)*\<up>b"
  by (cases b) auto

lemma and_extract_pure_left_ctx_iff[simp]: "P*\<up>b \<and>\<^sub>A Q = (P\<and>\<^sub>AQ)*\<up>b"
  by (cases b) auto

lemma and_extract_pure_right_iff[simp]: "P \<and>\<^sub>A \<up>b = (emp\<and>\<^sub>AP)*\<up>b"
  by (cases b) (auto simp: assn_aci)

lemma and_extract_pure_right_ctx_iff[simp]: "P \<and>\<^sub>A Q*\<up>b = (P\<and>\<^sub>AQ)*\<up>b"
  by (cases b) auto

lemmas and_extract_pure_iff =
  and_extract_pure_left_iff and_extract_pure_left_ctx_iff
  and_extract_pure_right_iff and_extract_pure_right_ctx_iff

lemmas norm_assertion_simps =
  (* Neutral elements *)
  mult_1[where 'a=assn] mult_1_right[where 'a=assn]
  inf_top_left[where 'a=assn] inf_top_right[where 'a=assn]
  sup_bot_left[where 'a=assn] sup_bot_right[where 'a=assn]

  (* Zero elements *)
  star_false_left star_false_right
  inf_bot_left[where 'a=assn] inf_bot_right[where 'a=assn]
  sup_top_left[where 'a=assn] sup_top_right[where 'a=assn]

  (* Associativity *)
  mult.left_assoc[where 'a=assn]
  inf_assoc[where 'a=assn]
  sup_assoc[where 'a=assn]

  (* Existential Quantifiers *)
  ex_assn_move_out ex_assn_const

  (* Extract pure assertions from conjunctions *)
  and_extract_pure_iff

  (* Merging *)
  merge_pure_star merge_pure_and merge_pure_or
  merge_true_star
  inf_idem[where 'a=assn] sup_idem[where 'a=assn]

  (* Duplicated References *)
  sngr_same_false snga_same_false

subsubsection \<open>Simplifier Setup Fine-Tuning\<close>
(*text \<open>Imperative HOL likes to simplify pointer inequations to this strange
  operator. We do some additional simplifier setup here\<close>
lemma not_same_noteqr[simp]: "\<not> a=!=a"
  by (metis Ref.unequal)
declare Ref.noteq_irrefl[dest!]

lemma not_same_noteqa[simp]: "\<not> a=!!=a"
  by (metis Array.unequal)
declare Array.noteq_irrefl[dest!]
*)

text \<open>However, it is safest to disable this rewriting, as there is
  a working standard simplifier setup for \<open>(\<noteq>)\<close>
\<close>
(*declare Ref.unequal[simp del]
declare Array.unequal[simp del]
*)

subsection \<open>Normalization of Entailments\<close>

text \<open>Used by existential quantifier extraction tactic\<close>
lemma enorm_exI': (* Incomplete, as chosen x may depend on heap! *)
  "(\<And>x. Z x \<longrightarrow> (P \<Longrightarrow>\<^sub>A Q x)) \<Longrightarrow> (\<exists>x. Z x) \<longrightarrow> (P \<Longrightarrow>\<^sub>A (\<exists>\<^sub>Ax. Q x))"
  by (metis ent_ex_postI)

text \<open>Example of how to build an extraction lemma.\<close>
thm enorm_exI'[OF enorm_exI'[OF imp_refl]]

lemmas ent_triv = ent_true ent_false

text \<open>Dummy rule to detect Hoare triple goal\<close>
lemma is_hoare_triple: "<P> c <Q> \<Longrightarrow> <P> c <Q>" .
text \<open>Dummy rule to detect entailment goal\<close>
lemma is_entails: "P\<Longrightarrow>\<^sub>AQ \<Longrightarrow> P \<Longrightarrow>\<^sub>AQ" .

subsection \<open>Frame Matcher\<close>
text \<open>Given star-lists P,Q and a frame F, this method tries to match
  all elements of Q with corresponding elements of P. The result is a
  partial match, that contains matching pairs and the unmatched content.\<close>

text \<open>The frame-matcher internally uses syntactic lists separated by
  star, and delimited by the special symbol \<open>SLN\<close>, which is defined
  to be \<open>emp\<close>.\<close>
definition [simp]: "SLN \<equiv> emp"
lemma SLN_left: "SLN * P = P" by simp
lemma SLN_right: "P * SLN = P" by simp

lemmas SLN_normalize = SLN_right mult.left_assoc[where 'a=assn]
lemmas SLN_strip = SLN_right SLN_left mult.left_assoc[where 'a=assn]

text \<open>A query to the frame matcher. Contains the assertions
  P and Q that shall be matched, as well as a frame F, that is not
  touched.\<close>

definition [simp]: "FI_QUERY P Q F \<equiv> P \<Longrightarrow>\<^sub>A Q*F"

abbreviation "fi_m_fst M \<equiv> foldr (*) (map fst M) emp"
abbreviation "fi_m_snd M \<equiv> foldr (*) (map snd M) emp"
abbreviation "fi_m_match M \<equiv> (\<forall>(p,q)\<in>set M. p \<Longrightarrow>\<^sub>A q)"

text \<open>A result of the frame matcher. Contains a list of matching pairs,
  as well as the unmatched parts of P and Q, and the frame F.
\<close>
definition [simp]: "FI_RESULT M UP UQ F \<equiv>
  fi_m_match M \<longrightarrow> (fi_m_fst M * UP \<Longrightarrow>\<^sub>A fi_m_snd M * UQ * F)"

text \<open>Internal structure used by the frame matcher:
  m contains the matched pairs; p,q the assertions that still needs to be
  matched; up,uq the assertions that could not be matched; and f the frame.
  p and q are SLN-delimited syntactic lists.
\<close>

definition [simp]: "FI m p q up uq f \<equiv>
  fi_m_match m \<longrightarrow> (fi_m_fst m * p * up \<Longrightarrow>\<^sub>A fi_m_snd m * q * uq * f)"

text \<open>Initialize processing of query\<close>
lemma FI_init:
  assumes "FI [] (SLN*P) (SLN*Q) SLN SLN F"
  shows "FI_QUERY P Q F"
  using assms by simp

text \<open>Construct result from internal representation\<close>
lemma FI_finalize:
  assumes "FI_RESULT m (p*up) (q*uq) f"
  shows "FI m p q up uq f"
  using assms by (simp add: assn_aci)

text \<open>Auxiliary lemma to show that all matching pairs together form
  an entailment. This is required for most applications.\<close>
lemma fi_match_entails:
  assumes "fi_m_match m"
  shows "fi_m_fst m \<Longrightarrow>\<^sub>A fi_m_snd m"
  using assms apply (induct m)
  apply (simp_all split: prod.split_asm add: ent_star_mono)
  done

text \<open>Internally, the frame matcher tries to match the first assertion
  of q with the first assertion of p. If no match is found, the first
  assertion of p is discarded. If no match for any assertion in p can be
  found, the first assertion of q is discarded.\<close>

text \<open>Match\<close>
lemma FI_match:
  assumes "p \<Longrightarrow>\<^sub>A q"
  assumes "FI ((p,q)#m) (ps*up) (qs*uq) SLN SLN f"
  shows "FI m (ps*p) (qs*q) up uq f"
  using assms unfolding FI_def
  by (simp add: assn_aci)

text \<open>No match\<close>
lemma FI_p_nomatch:
  assumes "FI m ps (qs*q) (p*up) uq f"
  shows "FI m (ps*p) (qs*q) up uq f"
  using assms unfolding FI_def
  by (simp add: assn_aci)

text \<open>Head of q could not be matched\<close>
lemma FI_q_nomatch:
  assumes "FI m (SLN*up) qs SLN (q*uq) f"
  shows "FI m SLN (qs*q) up uq f"
  using assms unfolding FI_def
  by (simp add: assn_aci)

subsection \<open>Frame Inference\<close>
lemma frame_inference_init:
  assumes "FI_QUERY P Q F"
  shows "P \<Longrightarrow>\<^sub>A Q * F"
  using assms by simp

lemma frame_inference_finalize:
  shows "FI_RESULT M F emp F"
  apply simp
  apply rule
  apply (drule fi_match_entails)
  apply (rule ent_star_mono[OF _ ent_refl])
  apply assumption
  done

subsection \<open>Entailment Solver\<close>
lemma entails_solve_init:
  "FI_QUERY P Q true \<Longrightarrow> P \<Longrightarrow>\<^sub>A Q * true"
  "FI_QUERY P Q emp \<Longrightarrow> P \<Longrightarrow>\<^sub>A Q"
  by (simp_all add: assn_aci)

lemma entails_solve_finalize:
  "FI_RESULT M P emp true"
  "FI_RESULT M emp emp emp"
  by (auto simp add: fi_match_entails intro: ent_star_mono)

lemmas solve_ent_preprocess_simps =
  ent_pure_post_iff ent_pure_post_iff_sng ent_pure_pre_iff ent_pure_pre_iff_sng

subsection \<open>Verification Condition Generator\<close>

lemmas normalize_rules = norm_pre_ex_rule norm_pre_pure_rule

(* Originally we introduced backwards-reasoning here, via
  cons_pre_rule[OF _ return_wp_rule] (old name: complete_return_cons).
  This only works, if the postcondition is not schematic! However, for
  forward reasoning, one usually assumes a schematic postcondition!
  *)
text \<open>May be useful in simple, manual proofs, where the postcondition
  is no schematic variable.\<close>
lemmas return_cons_rule = cons_pre_rule[OF _ return_wp_rule]

text \<open>Useful frame-rule variant for manual proof:\<close>
lemma frame_rule_left:
  "<P> c <Q> \<Longrightarrow> <R * P> c <\<lambda>x. R * Q x>"
  using frame_rule by (simp add: assn_aci)

lemmas deconstruct_rules =
  wait_bind_decon assert'_bind_rule
  bind_rule if_rule false_rule return_sp_rule let_rule
  case_prod_rule case_list_rule case_option_rule case_sum_rule

lemmas heap_rules =
  ref_rule
  lookup_rule
  update_rule
  new_rule
  make_rule
  of_list_rule
  length_rule
  nth_rule
  upd_rule
  freeze_rule
  wait_rule
  assert'_rule

lemma fi_rule:
  assumes CMD: "<P> c <Q>"
  assumes FRAME: "Ps \<Longrightarrow>\<^sub>A P * F"
  shows "<Ps> c <\<lambda>x. Q x * F>"
  apply (rule cons_pre_rule[rotated])
  apply (rule frame_rule)
  apply (rule CMD)
  apply (rule FRAME)
  done

subsection \<open>ML-setup\<close>

named_theorems sep_dflt_simps "Seplogic: Default simplification rules for automated solvers"
named_theorems sep_eintros "Seplogic: Intro rules for entailment solver"
named_theorems sep_heap_rules "Seplogic: VCG heap rules"
named_theorems sep_decon_rules "Seplogic: VCG deconstruct rules"

ML \<open>
infix 1 THEN_IGNORE_NEWGOALS

structure Seplogic_Auto =
struct

  (***********************************)
  (*             Tools               *)
  (***********************************)

  (* Repeat tac on subgoal. Determinize each step.
     Stop if tac fails or subgoal is solved. *)
  fun REPEAT_DETERM' tac i st = let
    val n = Thm.nprems_of st
  in
    REPEAT_DETERM (COND (has_fewer_prems n) no_tac (tac i)) st
  end

  (***********************************)
  (*             Debugging           *)
  (***********************************)
  fun tr_term t = Pretty.string_of (Syntax.pretty_term @{context} t);

  (***********************************)
  (*        Custom Tacticals         *)
  (***********************************)

  (* Apply tac1, and then tac2 with an offset such that anything left
     over by tac1 is skipped.

     The typical usage of this tactic is, if a theorem is instantiated
     with another theorem that produces additional goals that should
     be ignored first. Here, it is used in the vcg to ensure that
     frame inference is done before additional premises (that may
     depend on the frame) are discharged.
  *)
  fun (tac1 THEN_IGNORE_NEWGOALS tac2) i st = let
    val np = Thm.nprems_of st
  in
    (tac1 i THEN (fn st' => let val np' = Thm.nprems_of st' in
      if np'<np then tac2 i st'
      else tac2 (i+(np'-np)+1) st'
    end)) st
  end;

  (***********************************)
  (*     Assertion Normalization     *)
  (***********************************)
  (* Find two terms in a list whose key is equal *)
  fun find_similar (key_of:term -> term) (ts:term list) = let
    fun frec _ [] = NONE
    | frec tab (t::ts) = let val k=key_of t in
      if Termtab.defined tab k then
        SOME (the (Termtab.lookup tab k),t)
      else frec (Termtab.update (k,t) tab) ts
    end
  in
    frec Termtab.empty ts
  end;

  (* Perform DFS over term with binary operator opN, threading through
    a state. Atomic terms are transformed by tr. Supports omission of
    terms from the result structure by transforming them to NONE. *)
  fun dfs_opr opN (tr:'state -> term -> ('state*term option))
    d (t as ((op_t as Const (fN,_))$t1$t2)) =
    if fN = opN then let
        val (d1,t1') = dfs_opr opN tr d t1;
        val (d2,t2') = dfs_opr opN tr d1 t2;
      in
        case (t1',t2') of
          (NONE,NONE) => (d2,NONE)
        | (SOME t1',NONE) => (d2,SOME t1')
        | (NONE,SOME t2') => (d2,SOME t2')
        | (SOME t1',SOME t2') => (d2,SOME (op_t$t1'$t2'))
      end
    else tr d t
  | dfs_opr _ tr d t = tr d t;

  (* Replace single occurrence of (atomic) ot in t by nt.
    Returns new term or NONE if nothing was removed. *)
  fun dfs_replace_atomic opN ot nt t = let
    fun tr d t = if not d andalso t=ot then (true,SOME nt) else (d,SOME t);
    val (success,SOME t') = dfs_opr opN tr false t;
  in
    if success then SOME t' else NONE
  end;

  fun assn_simproc_fun ctxt credex = let
    val ([redex],ctxt') = Variable.import_terms true [Thm.term_of credex] ctxt;
    (*val _ = tracing (tr_term redex);*)
    val export = singleton (Variable.export ctxt' ctxt)

    fun mk_star t1 t2 = @{term "(*)::assn \<Rightarrow> _ \<Rightarrow> _"}$t2$t1;

    fun mk_star' NONE NONE = NONE
    | mk_star' (SOME t1) NONE  = SOME t1
    | mk_star' NONE (SOME t2) = SOME t2
    | mk_star' (SOME t1) (SOME t2) = SOME (mk_star t1 t2);

    fun ptrs_key (_$k$_) = k;

    fun remove_term pt t = case
      dfs_replace_atomic @{const_name "Groups.times_class.times"} pt
        @{term emp} t
    of
      SOME t' => t';

    fun normalize t = let

      fun ep_tr (has_true,ps,ptrs) t = case t of
        Const (@{const_name "Assertions.pure_assn"},_)$_
        => ((has_true,t::ps,ptrs),NONE)
      | Const (@{const_name "Assertions.sngr_assn"},_)$_$_
        => ((has_true,ps,t::ptrs),SOME t)
      | Const (@{const_name "Assertions.snga_assn"},_)$_$_
        => ((has_true,ps,t::ptrs),SOME t)
      | Const (@{const_name "Orderings.top_class.top"},_)
        => ((true,ps,ptrs),NONE)
      | (inf_op as Const (@{const_name "Lattices.inf_class.inf"},_))$t1$t2
        => ((has_true,ps,ptrs),SOME (inf_op$normalize t1$normalize t2))
      | _ => ((has_true,ps,ptrs),SOME t);

      fun normalizer t = case dfs_opr @{const_name "Groups.times_class.times"}
        ep_tr (false,[],[]) t
      of
        ((has_true,ps,ptrs),rt) => ((has_true,rev ps,ptrs),rt);

      fun normalize_core t = let
        val ((has_true,pures,ptrs),rt) = normalizer t;
        val similar = find_similar ptrs_key ptrs;
        val true_t = if has_true then SOME @{term "Assertions.top_assn"}
          else NONE;
        val pures' = case pures of
            [] => NONE
          | p::ps => SOME (fold mk_star ps p);
      in
        case similar of NONE => the (mk_star' pures' (mk_star' true_t rt))
        | SOME (t1,t2) => let
            val t_stripped = remove_term t1 (remove_term t2 t);
          in mk_star t_stripped (mk_star t1 t2) end
      end;

      fun skip_ex ((exq as Const (@{const_name "ex_assn"},_))$(Abs (n,ty,t))) =
        exq$Abs (n,ty,skip_ex t)
      | skip_ex t = normalize_core t;

      val (bs,t') = strip_abs t;
      val ty = fastype_of1 (map #2 bs,t');
    in
      if ty = @{typ assn} then
        Logic.rlist_abs (bs,skip_ex t')
      else t
    end;

    (*val _ = tracing (tr_term redex);*)
    val (f,terms) = strip_comb redex;
    val nterms = map (fn t => let
        (*val _ = tracing (tr_term t); *)
        val t'=normalize t;
        (*val _ = tracing (tr_term t');*)
      in t' end) terms;
    val new_form = list_comb (f,nterms);

    val res_ss = (put_simpset HOL_basic_ss ctxt addsimps @{thms star_aci});
    val result = Option.map (export o mk_meta_eq) (Arith_Data.prove_conv_nohyps
      [simp_tac res_ss 1] ctxt' (redex,new_form)
    );

  in
    result
  end handle exc =>
    if Exn.is_interrupt exc then Exn.reraise exc
    else
      (tracing ("assn_simproc failed with exception\n:" ^ Runtime.exn_message exc);
        NONE) (* Fail silently *);

  val assn_simproc =
    Simplifier.make_simproc @{context} "assn_simproc"
     {lhss =
      [@{term "h \<Turnstile> P"},
       @{term "P \<Longrightarrow>\<^sub>A Q"},
       @{term "P \<Longrightarrow>\<^sub>t Q"},
       @{term "Hoare_Triple.hoare_triple P c Q"},
       @{term "(P::assn) = Q"}],
      proc = K assn_simproc_fun};

  (***********************************)
  (*     Default Simplifications     *)
  (***********************************)

  (* Default simplification. MUST contain assertion normalization!
    Tactic must not fail! *)
  fun dflt_tac ctxt = asm_full_simp_tac
    (put_simpset HOL_ss ctxt
      addsimprocs [assn_simproc]
      addsimps @{thms norm_assertion_simps}
      addsimps (Named_Theorems.get ctxt @{named_theorems sep_dflt_simps})
      |> fold Splitter.del_split @{thms if_split}
    );

  (***********************************)
  (*         Frame Matcher           *)
  (***********************************)

  (* Do frame matching
    imp_solve_tac - tactic used to discharge first assumption of match-rule
      cf. lemma FI_match.
  *)
  fun match_frame_tac imp_solve_tac ctxt = let
    (* Normalize star-lists *)
    val norm_tac = simp_tac (
      put_simpset HOL_basic_ss ctxt addsimps @{thms SLN_normalize});

    (* Strip star-lists *)
    val strip_tac =
      simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms SLN_strip}) THEN'
      simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms SLN_def});

    (* Do a match step *)
    val match_tac = resolve_tac ctxt @{thms FI_match} (* Separate p,q*)
      THEN' SOLVED' imp_solve_tac (* Solve implication *)
      THEN' norm_tac;

    (* Do a no-match step *)
    val nomatch_tac = resolve_tac ctxt @{thms FI_p_nomatch} ORELSE'
      (resolve_tac ctxt @{thms FI_q_nomatch} THEN' norm_tac);
  in
    resolve_tac ctxt @{thms FI_init} THEN' norm_tac
    THEN' REPEAT_DETERM' (FIRST' [
      CHANGED o dflt_tac ctxt,
      (match_tac ORELSE' nomatch_tac)])
    THEN' resolve_tac ctxt @{thms FI_finalize} THEN' strip_tac
  end;

  (***********************************)
  (*         Frame Inference         *)
  (***********************************)

  fun frame_inference_tac ctxt =
    resolve_tac ctxt @{thms frame_inference_init}
    THEN' match_frame_tac (resolve_tac ctxt @{thms ent_refl}) ctxt
    THEN' resolve_tac ctxt @{thms frame_inference_finalize};

  (***********************************)
  (*       Entailment Solver         *)
  (***********************************)

  (* Extract existential quantifiers from entailment goal *)
  fun extract_ex_tac ctxt i st = let
    fun count_ex (Const (@{const_name Assertions.entails},_)$_$c) =
      count_ex c RS @{thm HOL.mp}
    | count_ex (Const (@{const_name Assertions.ex_assn},_)$Abs (_,_,t))
      = count_ex t RS @{thm enorm_exI'}
    | count_ex _ = @{thm imp_refl};

    val concl = Logic.concl_of_goal (Thm.prop_of st) i |> HOLogic.dest_Trueprop;
    val thm = count_ex concl;
  in
    (TRY o REPEAT_ALL_NEW (match_tac ctxt @{thms ent_ex_preI}) THEN'
     resolve_tac ctxt [thm]) i st
  end;

  (* Solve Entailment *)
  fun solve_entails_tac ctxt = let
    val preprocess_entails_tac =
      dflt_tac ctxt
      THEN' extract_ex_tac ctxt
      THEN' simp_tac
        (put_simpset HOL_ss ctxt addsimps @{thms solve_ent_preprocess_simps});

    val match_entails_tac =
      resolve_tac ctxt @{thms entails_solve_init}
      THEN' match_frame_tac (resolve_tac ctxt @{thms ent_refl}) ctxt
      THEN' resolve_tac ctxt @{thms entails_solve_finalize};
  in
    preprocess_entails_tac
    THEN' (TRY o
      REPEAT_ALL_NEW (match_tac ctxt (rev (Named_Theorems.get ctxt @{named_theorems sep_eintros}))))
    THEN_ALL_NEW (dflt_tac ctxt THEN'
      TRY o (match_tac ctxt @{thms ent_triv}
        ORELSE' resolve_tac ctxt @{thms ent_refl}
        ORELSE' match_entails_tac))
  end;

  (***********************************)
  (* Verification Condition Generator*)
  (***********************************)

  fun heap_rule_tac ctxt h_thms =
    resolve_tac ctxt h_thms ORELSE' (
    resolve_tac ctxt @{thms fi_rule} THEN' (resolve_tac ctxt h_thms THEN_IGNORE_NEWGOALS
    frame_inference_tac ctxt));

  fun vcg_step_tac ctxt = let
    val h_thms = rev (Named_Theorems.get ctxt @{named_theorems sep_heap_rules});
    val d_thms = rev (Named_Theorems.get ctxt @{named_theorems sep_decon_rules});
    val heap_rule_tac = heap_rule_tac ctxt h_thms

    (* Apply consequence rule if postcondition is not a schematic var *)
    fun app_post_cons_tac i st =
      case Logic.concl_of_goal (Thm.prop_of st) i |> HOLogic.dest_Trueprop of
        Const (@{const_name Hoare_Triple.hoare_triple},_)$_$_$qt =>
          if is_Var (head_of qt) then no_tac st
          else resolve_tac ctxt @{thms cons_post_rule} i st
      | _ => no_tac st;

  in
    CSUBGOAL (snd #> (FIRST' [
      CHANGED o dflt_tac ctxt,
      REPEAT_ALL_NEW (resolve_tac ctxt @{thms normalize_rules}),
      CHANGED o (FIRST' [resolve_tac ctxt d_thms, heap_rule_tac]
        ORELSE' (app_post_cons_tac THEN'
          FIRST' [resolve_tac ctxt d_thms, heap_rule_tac]))
    ]))
  end;

  fun vcg_tac ctxt = REPEAT_DETERM' (vcg_step_tac ctxt)

  (***********************************)
  (*        Automatic Solver         *)
  (***********************************)

  fun sep_autosolve_tac do_pre do_post ctxt = let
    val pre_tacs = [
      CHANGED o clarsimp_tac ctxt,
      CHANGED o REPEAT_ALL_NEW (match_tac ctxt @{thms ballI allI impI conjI})
    ];
    val main_tacs = [
      match_tac ctxt @{thms is_hoare_triple} THEN' CHANGED o vcg_tac ctxt,
      match_tac ctxt @{thms is_entails} THEN' CHANGED o solve_entails_tac ctxt
    ];
    val post_tacs = [SELECT_GOAL (auto_tac ctxt)];
    val tacs = (if do_pre then pre_tacs else [])
      @ main_tacs
      @ (if do_post then post_tacs else []);
  in
    REPEAT_DETERM' (CHANGED o FIRST' tacs)
  end;

  (***********************************)
  (*          Method Setup           *)
  (***********************************)

  val dflt_simps_modifiers = [
    Args.$$$ "dflt_simps" -- Scan.option Args.add -- Args.colon
      >> K (Method.modifier (Named_Theorems.add @{named_theorems sep_dflt_simps}) \<^here>),
    Args.$$$ "dflt_simps" -- Scan.option Args.del -- Args.colon
      >> K (Method.modifier (Named_Theorems.del @{named_theorems sep_dflt_simps}) \<^here>)
  ];
  val heap_modifiers = [
    Args.$$$ "heap" -- Scan.option Args.add -- Args.colon
      >> K (Method.modifier (Named_Theorems.add @{named_theorems sep_heap_rules}) \<^here>),
    Args.$$$ "heap" -- Scan.option Args.del -- Args.colon
      >> K (Method.modifier (Named_Theorems.del @{named_theorems sep_heap_rules}) \<^here>)
  ];
  val decon_modifiers = [
    Args.$$$ "decon" -- Scan.option Args.add -- Args.colon
      >> K (Method.modifier (Named_Theorems.add @{named_theorems sep_decon_rules}) \<^here>),
    Args.$$$ "decon" -- Scan.option Args.del -- Args.colon
      >> K (Method.modifier (Named_Theorems.del @{named_theorems sep_decon_rules}) \<^here>)
  ];

  val eintros_modifiers = [
    Args.$$$ "eintros" -- Scan.option Args.add -- Args.colon
      >> K (Method.modifier (Named_Theorems.add @{named_theorems sep_eintros}) \<^here>),
    Args.$$$ "eintros" -- Scan.option Args.del -- Args.colon
      >> K (Method.modifier (Named_Theorems.del @{named_theorems sep_eintros}) \<^here>)
  ];

  val solve_entails_modifiers = dflt_simps_modifiers @ eintros_modifiers;

  val vcg_modifiers =
    heap_modifiers @ decon_modifiers @ dflt_simps_modifiers;

  val sep_auto_modifiers =
    clasimp_modifiers @ vcg_modifiers @ eintros_modifiers;

end;
\<close>

simproc_setup assn_simproc
  ("h\<Turnstile>P" | "P\<Longrightarrow>\<^sub>AQ" | "P\<Longrightarrow>\<^sub>tQ" | "<P> c <R>" | "(P::assn) = Q")
  = \<open>K Seplogic_Auto.assn_simproc_fun\<close>

method_setup assn_simp =\<open>Scan.succeed (fn ctxt => (SIMPLE_METHOD' (
  CHANGED o Seplogic_Auto.dflt_tac ctxt
)))\<close> "Seplogic: Simplification of assertions"

method_setup frame_inference = \<open>Scan.succeed (fn ctxt => (SIMPLE_METHOD' (
  CHANGED o Seplogic_Auto.frame_inference_tac ctxt
)))\<close> "Seplogic: Frame inference"

method_setup solve_entails = \<open>
  Method.sections Seplogic_Auto.solve_entails_modifiers >>
  (fn _ => fn ctxt => SIMPLE_METHOD' (
  CHANGED o Seplogic_Auto.solve_entails_tac ctxt
))\<close> "Seplogic: Entailment Solver"

method_setup heap_rule = \<open>
  Attrib.thms >>
  (fn thms => fn ctxt => SIMPLE_METHOD' (
    let
      val thms = case thms of [] => rev (Named_Theorems.get ctxt @{named_theorems sep_heap_rules})
        | _ => thms
    in
      CHANGED o Seplogic_Auto.heap_rule_tac ctxt thms
    end
))\<close> "Seplogic: Apply rule with frame inference"

method_setup vcg = \<open>
  Scan.lift (Args.mode "ss") --
  Method.sections Seplogic_Auto.vcg_modifiers >>
  (fn (ss,_) => fn ctxt => SIMPLE_METHOD' (
  CHANGED o (
    if ss then Seplogic_Auto.vcg_step_tac ctxt
    else Seplogic_Auto.vcg_tac ctxt
  )
))\<close> "Seplogic: Verification Condition Generator"

method_setup sep_auto =
  \<open>Scan.lift (Args.mode "nopre" -- Args.mode "nopost" -- Args.mode "plain")
      --| Method.sections Seplogic_Auto.sep_auto_modifiers >>
  (fn ((nopre,nopost),plain) => fn ctxt => SIMPLE_METHOD' (
    CHANGED o Seplogic_Auto.sep_autosolve_tac
      ((not nopre) andalso (not plain))
      ((not nopost) andalso (not plain)) ctxt
  ))\<close> "Seplogic: Automatic solver"

lemmas [sep_dflt_simps] = split

declare deconstruct_rules[sep_decon_rules]
declare heap_rules[sep_heap_rules]

lemmas [sep_eintros] = impI conjI exI

subsection \<open>Semi-Automatic Reasoning\<close>
text \<open>In this section, we provide some lemmas for semi-automatic reasoning\<close>

text \<open>Forward reasoning with frame. Use \<open>frame_inference\<close>-method
  to discharge second assumption.\<close>
lemma ent_frame_fwd:
  assumes R: "P \<Longrightarrow>\<^sub>A R"
  assumes F: "Ps \<Longrightarrow>\<^sub>A P*F"
  assumes I: "R*F \<Longrightarrow>\<^sub>A Q"
  shows "Ps \<Longrightarrow>\<^sub>A Q"
  using assms
  by (metis ent_refl ent_star_mono ent_trans)

lemma mod_frame_fwd:
  assumes M: "h\<Turnstile>Ps"
  assumes R: "P\<Longrightarrow>\<^sub>AR"
  assumes F: "Ps \<Longrightarrow>\<^sub>A P*F"
  shows "h\<Turnstile>R*F"
  using assms
  by (metis ent_star_mono entails_def)

text \<open>Apply precision rule with frame inference.\<close>
lemma prec_frame:
  assumes PREC: "precise P"
  assumes M1: "h\<Turnstile>(R1 \<and>\<^sub>A R2)"
  assumes F1: "R1 \<Longrightarrow>\<^sub>A P x p * F1"
  assumes F2: "R2 \<Longrightarrow>\<^sub>A P y p * F2"
  shows "x=y"
  using preciseD[OF PREC] M1 F1 F2
  by (metis entailsD mod_and_dist)

lemma prec_frame_expl:
  assumes PREC: "\<forall>x y. (h\<Turnstile>(P x * F1) \<and>\<^sub>A (P y * F2)) \<longrightarrow> x=y"
  assumes M1: "h\<Turnstile>(R1 \<and>\<^sub>A R2)"
  assumes F1: "R1 \<Longrightarrow>\<^sub>A P x * F1"
  assumes F2: "R2 \<Longrightarrow>\<^sub>A P y * F2"
  shows "x=y"
  using assms
  by (metis entailsD mod_and_dist)

text \<open>Variant that is useful within induction proofs, where induction
  goes over \<open>x\<close> or \<open>y\<close>\<close>
lemma prec_frame':
  assumes PREC: "(h\<Turnstile>(P x * F1) \<and>\<^sub>A (P y * F2)) \<longrightarrow> x=y"
  assumes M1: "h\<Turnstile>(R1 \<and>\<^sub>A R2)"
  assumes F1: "R1 \<Longrightarrow>\<^sub>A P x * F1"
  assumes F2: "R2 \<Longrightarrow>\<^sub>A P y * F2"
  shows "x=y"
  using assms
  by (metis entailsD mod_and_dist)

lemma ent_wand_frameI:
  assumes "(Q -* R) * F \<Longrightarrow>\<^sub>A S"
  assumes "P \<Longrightarrow>\<^sub>A F * X"
  assumes "Q*X \<Longrightarrow>\<^sub>A R"
  shows "P \<Longrightarrow>\<^sub>A S"
  using assms
  by (metis ent_frame_fwd ent_wandI mult.commute)

subsubsection \<open>Manual Frame Inference\<close>

lemma ent_true_drop:
  "P\<Longrightarrow>\<^sub>AQ*true \<Longrightarrow> P*R\<Longrightarrow>\<^sub>AQ*true"
  "P\<Longrightarrow>\<^sub>AQ \<Longrightarrow> P\<Longrightarrow>\<^sub>AQ*true"
  apply (metis assn_times_comm ent_star_mono ent_true merge_true_star_ctx)
  apply (metis assn_one_left ent_star_mono ent_true star_aci(2))
  done

lemma fr_refl: "A\<Longrightarrow>\<^sub>AB \<Longrightarrow> A*C \<Longrightarrow>\<^sub>AB*C"
  by (blast intro: ent_star_mono ent_refl)

lemma fr_rot: "(A*B \<Longrightarrow>\<^sub>A C) \<Longrightarrow> (B*A \<Longrightarrow>\<^sub>A C)"
  by (simp add: assn_aci)

lemma fr_rot_rhs: "(A \<Longrightarrow>\<^sub>A B*C) \<Longrightarrow> (A \<Longrightarrow>\<^sub>A C*B)"
  by (simp add: assn_aci)

lemma ent_star_mono_true:
  assumes "A \<Longrightarrow>\<^sub>A A' * true"
  assumes "B \<Longrightarrow>\<^sub>A B' * true"
  shows "A*B*true \<Longrightarrow>\<^sub>A A'*B'*true"
  using ent_star_mono[OF assms] apply simp
  using ent_true_drop(1) by blast

lemma ent_refl_true: "A \<Longrightarrow>\<^sub>A A * true"
  by (simp add: ent_true_drop(2))

lemma entt_fr_refl: "F\<Longrightarrow>\<^sub>tF' \<Longrightarrow> F*A \<Longrightarrow>\<^sub>t F'*A" by (rule entt_star_mono) auto
lemma entt_fr_drop: "F\<Longrightarrow>\<^sub>tF' \<Longrightarrow> F*A \<Longrightarrow>\<^sub>t F'"
  using ent_true_drop(1) enttD enttI by blast

method_setup fr_rot = \<open>
  let
    fun rot_tac ctxt =
      resolve_tac ctxt @{thms fr_rot} THEN'
      simp_tac (put_simpset HOL_basic_ss ctxt
        addsimps @{thms star_assoc[symmetric]})

  in
    Scan.lift Parse.nat >>
      (fn n => fn ctxt => SIMPLE_METHOD' (
        fn i => REPEAT_DETERM_N n (rot_tac ctxt i)))

  end
\<close>

method_setup fr_rot_rhs = \<open>
  let
    fun rot_tac ctxt =
      resolve_tac ctxt @{thms fr_rot_rhs} THEN'
      simp_tac (put_simpset HOL_basic_ss ctxt
        addsimps @{thms star_assoc[symmetric]})

  in
    Scan.lift Parse.nat >>
      (fn n => fn ctxt => SIMPLE_METHOD' (
        fn i => REPEAT_DETERM_N n (rot_tac ctxt i)))

  end
\<close>

(*<*)
subsection \<open>Test Cases\<close>

lemma "\<And>x. A x * true * Q x \<Longrightarrow>\<^sub>A true * A x * Q x"
  apply simp
  done

lemma "A * (true * B) \<Longrightarrow>\<^sub>A true * A * B"
  apply (simp)
  done

lemma "h\<Turnstile>true*P*true \<longleftrightarrow> h\<Turnstile>P*true"
  by simp

lemma "A * true * \<up>(b \<and> c) * true * B \<Longrightarrow>\<^sub>A \<up>b * \<up>c * true *A * B"
  by simp

lemma "\<exists>y c. \<exists>\<^sub>Ax. P x * (R x * Q y) * \<up> (b \<and> c) \<Longrightarrow>\<^sub>A (\<exists>\<^sub>Ax. \<up>b * (P x * (R x * Q y) * \<up>c))"
  apply simp
  done

lemma "A * B * (\<up>c * B * C * D * \<up>a * true * \<up>d) * (\<exists>\<^sub>Ax. E x * F * \<up>b) * true \<Longrightarrow>\<^sub>A (\<exists>\<^sub>Ax. \<up> (c \<and> a \<and> d \<and> b) *
          true * A * B * (true * B * C * D) * (E x * F))"
  apply simp
  done

lemma "<P> c <\<lambda>r. Q r * true * \<up>(b r) * true * \<up>a>
  \<longleftrightarrow> <P> c <\<lambda>r. Q r * true * \<up>(b r \<and> a)>"
  apply simp
  done

lemma "(h\<Turnstile>((A*B*\<up>b*true*\<up>c*true) \<and>\<^sub>A (\<up>(p=q)*P*Q)))
  \<longleftrightarrow> h \<Turnstile> A * B * true \<and>\<^sub>A P * Q \<and> b \<and> c \<and> p = q"
  apply simp
  done

lemma assumes "FI_RESULT [(B, B), (A, A)] C D F"
  shows "FI_QUERY (A*B*C) (D*B*A) F"
  apply (tactic \<open>Seplogic_Auto.match_frame_tac
    (resolve_tac @{context} @{thms ent_refl}) @{context} 1\<close>)
  by (rule assms)

lemma
  assumes "FI_RESULT [(B,B), (A,A)] C emp F"
  shows "FI_QUERY (A*B*C) (B*A) F"
  apply (tactic \<open>Seplogic_Auto.match_frame_tac
    (resolve_tac @{context} @{thms ent_refl}) @{context} 1\<close>)
  by (rule assms)

lemma
  assumes "FI_RESULT [(B, B), (A, A)] emp emp F"
  shows "FI_QUERY (A*B) (B*A) F"
  apply (tactic \<open>Seplogic_Auto.match_frame_tac
    (resolve_tac @{context} @{thms ent_refl}) @{context} 1\<close>)
  by (rule assms)

lemma
  assumes "FI_RESULT [(A, A)] emp emp F"
  shows "FI_QUERY (A) (A) F"
  apply (tactic \<open>Seplogic_Auto.match_frame_tac
    (resolve_tac @{context} @{thms ent_refl}) @{context} 1\<close>)
  by (rule assms)

lemma
  assumes "FI_RESULT [(A, A)] (B * C * D) emp F"
  shows "FI_QUERY (B*C*D*A) (A) F"
  apply (tactic \<open>Seplogic_Auto.match_frame_tac
    (resolve_tac @{context} @{thms ent_refl}) @{context} 1\<close>)
  by (rule assms)

schematic_goal
  "P1 * P2 * P3 * P4 \<Longrightarrow>\<^sub>A P3 * ?R1"
  "P1 * (P2 * (P3 * P4)) \<Longrightarrow>\<^sub>A P1 * ?R2"
  "P4 * (P2 * (P1 * P3)) \<Longrightarrow>\<^sub>A P1 * ?R2'"
  "P1 * P2 * P3 * P4 \<Longrightarrow>\<^sub>A P4 * ?R3"
  "P1 * P2 \<Longrightarrow>\<^sub>A P1 * ?R4"
  "P1 * P2 \<Longrightarrow>\<^sub>A P2 * ?R5"
  "P1 \<Longrightarrow>\<^sub>A P1 * ?R6"
  "P1 * P2 \<Longrightarrow>\<^sub>A emp * ?R7"
  by frame_inference+

lemma "\<lbrakk>A; B; C; b 17\<rbrakk> \<Longrightarrow>
  Q 1 5 3 \<Longrightarrow>\<^sub>A (\<exists>\<^sub>Ax y z. \<exists>\<^sub>Aa. Q x y z * \<up>(b a) * \<up>(y=5))"
  by solve_entails

thm nth_rule
lemma "<P * x\<mapsto>\<^sub>a[1,2,3]>
  do { v\<leftarrow>Array_Time.nth x 1; return v }
  <\<lambda>r. P * x\<mapsto>\<^sub>a[1,2,3] * \<up>(r=2)>"
  apply sep_auto
  done

(*>*)

subsection \<open>Quick Overview of Proof Methods\<close>
  text_raw \<open>\label{sec:auto:overview}\<close>
text \<open>
  In this section, we give a quick overview of the available proof methods
  and options. The most versatile proof method that we provide is
  \<open>sep_auto\<close>. It tries to solve the first subgoal, invoking appropriate
  proof methods as required. If it cannot solve the subgoal completely, it
  stops at the intermediate state that it could not handle any more.

  \<open>sep_auto\<close> can be configured by
  section-arguments for the simplifier, the classical reasoner, and all
  section-arguments for the verification condition generator and
  entailment solver. Moreover, it takes an optional mode argument (mode), where
  valid modes are:
  \begin{description}
    \item[(nopre)] No preprocessing of goal. The preprocessor tries to clarify
      and simplify the goal before the main method is invoked.
    \item[(nopost)] No postprocessing of goal. The postprocessor tries to
      solve or simplify goals left over by verification condition generation or
      entailment solving.
    \item[(plain)] Neither pre- nor postprocessing. Just applies vcg and
      entailment solver.
  \end{description}

  \paragraph{Entailment Solver.} The entailment solver processes goals of the
  form \<open>P \<Longrightarrow>\<^sub>A Q\<close>. It is invoked by the method \<open>solve_entails\<close>.
  It first tries to pull out pure parts of
  \<open>P\<close> and \<open>Q\<close>. This may introduce quantifiers, conjunction,
  and implication into the goal, that are eliminated by resolving with rules
  declared as \<open>sep_eintros\<close> (method argument: eintros[add/del]:).
  Moreover, it simplifies with rules declared as \<open>sep_dflt_simps\<close>
  (section argument: \<open>dflt_simps[add/del]:\<close>).

  Now, \<open>P\<close> and \<open>Q\<close> should have the form \<open>X\<^sub>1*\<dots>*X\<^sub>n\<close>.
  Then, the frame-matcher is used to match all items of \<open>P\<close> with items
  of \<open>Q\<close>, and thus solve the implication. Matching is currently done
  syntactically, but can instantiate schematic variables.

  Note that, by default, existential introduction is declared as
  \<open>sep_eintros\<close>-rule. This introduces schematic variables, that can
  later be matched against. However, in some cases, the matching may instantiate
  the schematic variables in an undesired way. In this case, the argument
  \<open>eintros del: exI\<close> should be passed to the entailment solver, and
  the existential quantifier should be instantiated manually.

  \paragraph{Frame Inference}
  The method \<open>frame_inference\<close> tries to solve a goal of the
  form \<open>P\<Longrightarrow>Q*?F\<close>, by matching \<open>Q\<close> against the parts of
  \<open>P\<close>, and instantiating \<open>?F\<close> accordingly.
  Matching is done syntactically, possibly
  instantiating schematic variables. \<open>P\<close> and \<open>Q\<close> should be
  assertions separated by \<open>*\<close>. Note that frame inference does no
  simplification or other kinds of normalization.

  The method \<open>heap_rule\<close> applies the specified heap rules, using
  frame inference if necessary. If no rules are specified, the default
  heap rules are used.

  \paragraph{Verification Condition Generator}
  The verification condition generator processes goals of the form
  \<open><P>c<Q>\<close>. It is invoked by the method \<open>vcg\<close>.
  First, it tries to pull out pure parts and simplifies with
  the default simplification rules. Then, it tries to resolve the goal with
  deconstruct rules (attribute: \<open>sep_decon_rules\<close>,
  section argument: \<open>decon[add/del]:\<close>), and if this does not succeed,
  it tries
  to resolve the goal with heap rules (attribute: \<open>sep_heap_rules\<close>,
  section argument: \<open>heap[add/del]:\<close>), using the frame rule and
  frame inference.
  If resolving is not possible, it also tries to apply the consequence rule to
  make the postcondition a schematic variable.
\<close>

(*<*)
subsection \<open>Hiding of internal stuff\<close>
hide_const (open) FI SLN
(*>*)

end


(*<*)
(*
 * Copyright 2015, 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)
 *)

theory CIMP_one_place_buffer_ex
imports
  CIMP
begin

(*>*)
section\<open>One-place buffer example\<close>

text\<open>

\label{sec:one_place_buffer}

To demonstrate the CIMP reasoning infrastructure, we treat the trivial
one-place buffer example of @{cite [cite_macro=citet]
\<open>\S3.3\<close> "DBLP:journals/toplas/LamportS84"}. Note that the
semantics for our language is different to @{cite
[cite_macro=citeauthor] "DBLP:journals/toplas/LamportS84"}'s, who
treated a historical variant of CSP (i.e., not the one in @{cite
"Hoare:1985"}).

We introduce some syntax for fixed-topology (static channel-based)
scenarios.

\<close>

abbreviation
  Receive :: "'location \<Rightarrow> 'channel \<Rightarrow> ('val \<Rightarrow> 'state \<Rightarrow> 'state)
             \<Rightarrow> (unit, 'location, 'channel \<times> 'val, 'state) com" ("\<lbrace>_\<rbrace>/ _\<triangleright>_")
where
  "\<lbrace>l\<rbrace> ch\<triangleright>f \<equiv> \<lbrace>l\<rbrace> Response (\<lambda>quest s. if fst quest = ch then {(f (snd quest) s, ())} else {})"

abbreviation
  Send :: "'location \<Rightarrow> 'channel \<Rightarrow> ('state \<Rightarrow> 'val)
          \<Rightarrow> (unit, 'location, 'channel \<times> 'val, 'state) com" ("\<lbrace>_\<rbrace>/ _\<triangleleft>_")
where
  "\<lbrace>l\<rbrace> ch\<triangleleft>f \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (ch, f s)) (\<lambda>ans s. {s})"

text\<open>

We further specialise these for our particular example.

\<close>

abbreviation
  Receive' :: "'location \<Rightarrow> 'channel \<Rightarrow> (unit, 'location, 'channel \<times> 'state, 'state) com" ("\<lbrace>_\<rbrace>/ _\<triangleright>")
where
  "\<lbrace>l\<rbrace> ch\<triangleright> \<equiv> \<lbrace>l\<rbrace> ch\<triangleright>(\<lambda>v _. v)"

abbreviation
  Send' :: "'location \<Rightarrow> 'channel \<Rightarrow> (unit, 'location, 'channel \<times> 'state, 'state) com" ("\<lbrace>_\<rbrace>/ _\<triangleleft>")
where
 "\<lbrace>l\<rbrace> ch\<triangleleft> \<equiv> \<lbrace>l\<rbrace> ch\<triangleleft>id"

text\<open>

These definitions largely follow @{cite [cite_macro=citet]
"DBLP:journals/toplas/LamportS84"}. We have three processes
communicating over two channels. We enumerate program locations.

\<close>

datatype ex_chname = \<xi>12 | \<xi>23
type_synonym ex_val = nat
type_synonym ex_ch = "ex_chname \<times> ex_val"
datatype ex_loc = r12 | r23 | s23 | s12
datatype ex_proc = p1 | p2 | p3

type_synonym ex_pgm = "(unit, ex_loc, ex_ch, ex_val) com"
type_synonym ex_pred = "(unit, ex_loc, ex_proc, ex_ch, ex_val) pred"
type_synonym ex_state = "(unit, ex_loc, ex_proc, ex_ch, ex_val) global_state"
type_synonym ex_system = "(unit, ex_loc, ex_proc, ex_ch, ex_val) system"
type_synonym ex_history = "(ex_ch \<times> unit) list"

primrec
  ex_pgms :: "ex_proc \<Rightarrow> ex_pgm"
where
  "ex_pgms p1 = \<lbrace>s12\<rbrace> \<xi>12\<triangleleft>"
| "ex_pgms p2 = LOOP DO \<lbrace>r12\<rbrace> \<xi>12\<triangleright>;; \<lbrace>s23\<rbrace> \<xi>23\<triangleleft> OD"
| "ex_pgms p3 = \<lbrace>r23\<rbrace> \<xi>23\<triangleright>"

text\<open>

Each process starts with an arbitrary initial local state.

\<close>

abbreviation ex_init :: "(ex_proc \<Rightarrow> ex_val) \<Rightarrow> bool" where
  "ex_init \<equiv> \<langle>True\<rangle>"

abbreviation ex_system :: "ex_system" where
  "ex_system \<equiv> (ex_pgms, ex_init)"

text\<open>

The following adapts Kai Engelhardt's, from his notes titled
\emph{Proving an Asynchronous Message Passing Program Correct},
2011. The history variable tracks the causality of the system, which I
feel is missing in Lamport's treatment. We tack on Lamport's invariant
so we can establish \<open>Etern_pred\<close>.

\<close>

abbreviation
  filter_on_channel :: "ex_chname \<Rightarrow> ex_history \<Rightarrow> ex_val list"
where
  "filter_on_channel ch \<equiv> map (snd \<circ> fst) \<circ> filter ((=) ch \<circ> fst \<circ> fst)"

definition Ip1_0 :: ex_pred where
  "Ip1_0 \<equiv> at p1 s12 \<^bold>\<longrightarrow> (\<lambda>s. filter_on_channel \<xi>12 (hist s) = [])"
definition Ip1_1 :: ex_pred where
  "Ip1_1 \<equiv> terminated p1 \<^bold>\<longrightarrow> (\<lambda>s. filter_on_channel \<xi>12 (hist s) = [LST s p1])"

definition Ip2_0 :: ex_pred where
  "Ip2_0 \<equiv> at p2 r12 \<^bold>\<longrightarrow> (\<lambda>s. filter_on_channel \<xi>12 (hist s) = filter_on_channel \<xi>23 (hist s))"
definition Ip2_1 :: ex_pred where
  "Ip2_1 \<equiv> at p2 s23 \<^bold>\<longrightarrow> (\<lambda>s. filter_on_channel \<xi>12 (hist s) = filter_on_channel \<xi>23 (hist s) @ [LST s p2]
                           \<and> LST s p1 = LST s p2)"

definition Ip3_0 :: ex_pred where
  "Ip3_0 \<equiv> at p3 r23 \<^bold>\<longrightarrow> (\<lambda>s. filter_on_channel \<xi>23 (hist s) = [])"
definition Ip3_1 :: ex_pred where
  "Ip3_1 \<equiv> terminated p3 \<^bold>\<longrightarrow> (\<lambda>s. filter_on_channel \<xi>23 (hist s) = [LST s p2]
                                \<and> LST s p1 = LST s p3)"

definition I_pred :: ex_pred where
  "I_pred \<equiv> pred_conjoin [ Ip1_0, Ip1_1, Ip2_0, Ip2_1, Ip3_0, Ip3_1 ]"

lemmas I_defs = Ip1_0_def Ip1_1_def Ip2_0_def Ip2_1_def Ip3_0_def Ip3_1_def

text\<open>

If process three terminates, then it has process one's value. This is
stronger than @{cite [cite_macro=citeauthor]
"DBLP:journals/toplas/LamportS84"}'s as we don't ask that the first
process has also terminated.

\<close>

definition Etern_pred :: ex_pred where
  "Etern_pred \<equiv> terminated p3 \<^bold>\<longrightarrow> (\<lambda>s. LST s p1 = LST s p3)"

text\<open>

Proofs from here down.

\<close>

lemma correct_system:
  "I_pred sh \<Longrightarrow> Etern_pred sh"
apply (clarsimp simp: Etern_pred_def I_pred_def I_defs)
done

lemma p1: "ex_pgms, p1, lconst \<langle>False\<rangle> \<Turnstile> \<lbrace>I_pred\<rbrace> \<lbrace>s12\<rbrace> \<xi>12\<triangleleft>\<lambda>s. s"
apply (rule vcg.intros)
apply (rename_tac p')
apply (case_tac p')
  apply (auto simp: I_pred_def I_defs atS_def)
done

lemma p2_1: "ex_pgms, p2, lconst (\<lambda>l. l = r12) \<Turnstile> \<lbrace>I_pred\<rbrace> \<lbrace>s23\<rbrace> \<xi>23\<triangleleft>\<lambda>s. s"
apply (rule vcg.intros)
apply (rename_tac p')
apply (case_tac p')
  apply (auto simp: I_pred_def I_defs atS_def)
done

lemma "(s, h) \<in> reachable_states ex_system \<Longrightarrow> I_pred (mkP (s, h))"
apply (erule VCG)
 apply (clarsimp simp: I_pred_def I_defs atS_def)
apply simp
apply (rename_tac p)
apply (case_tac p)
  apply auto (* vcg_clarsimp_tac *)
  apply (auto simp: p1 p2_1)
done

text\<open>\<close>
(*<*)

end
(*>*)