(*<*)
theory Refine_Monadic_Userguide
imports "../Refine_Dflt_Only_ICF"
begin
(*>*)

text_raw \<open>\isasection{Old Monadic Refinement Framework Userguide}\<close>

section \<open>Introduction\<close>
text \<open>
  This is the old userguide from Refine-Monadic. It contains the
  manual approach of using the mondaic refinement framework with the
  Isabelle Collection Framework. An alternative, more simple approach is
  provided by the Automatic Refinement Framework and the
  Generic Collection Framework.

  The Isabelle/HOL refinement framework is a library that supports
  program and data refinement.

  Programs are specified using a nondeterminism monad:
  An element of the monad type is either a set of results, or
  the special element @{term "FAIL"}, that indicates a failed assertion.

  The bind-operation of the monad applies a function to all elements of the
  result-set, and joins all possible results.

  On the monad type, an ordering \<open>\<le>\<close> is defined, that is lifted subset
  ordering, where @{term "FAIL"} is the greatest element. Intuitively,
  @{term "S\<le>S'"} means that program \<open>S\<close> refines program \<open>S'\<close>,
  i.e., all results of \<open>S\<close> are also results of \<open>S'\<close>, and
  \<open>S\<close> may only fail if \<open>S'\<close> also fails.
\<close>

section \<open>Guided Tour\<close>
text \<open>
  In this section, we provide a small example program development in our
  framework. All steps of the development are heavily commented.
\<close>

subsection \<open>Defining Programs\<close>
text \<open>
  A program is defined using the Haskell-like do-notation, that is provided by
  the Isabelle/HOL library. We start with a simple example, that iterates
  over a set of numbers, and computes the maximum value and the sum of
  all elements.
\<close>

definition sum_max :: "nat set \<Rightarrow> (nat\<times>nat) nres" where
  "sum_max V \<equiv> do {
    (_,s,m) \<leftarrow> WHILE (\<lambda>(V,s,m). V\<noteq>{}) (\<lambda>(V,s,m). do {
      x\<leftarrow>SPEC (\<lambda>x. x\<in>V);
      let V=V-{x};
      let s=s+x;
      let m=max m x;
      RETURN (V,s,m)
    }) (V,0,0);
    RETURN (s,m)
  }"

text \<open>
  The type of the nondeterminism monad is @{typ "'a nres"}, where @{typ "'a"}
  is the type of the results. Note that this program has only one possible
  result, however, the order in which we iterate over the elements of the set
  is unspecified.

  This program uses the following statements provided by our framework:
  While-loops, bindings, return, and specification. We briefly explain the
  statements here. A complete reference can be found in
  Section~\ref{sec:stmt_ref}.

  A while-loop has the form @{term "WHILE b f \<sigma>\<^sub>0"}, where @{term "b"} is the
  continuation condition, @{term "f"} is the loop body, and @{term "\<sigma>\<^sub>0"} is
  the initial state. In our case, the state used for the loop is a triple
  @{term "(V,s,m)"}, where @{term "V"} is the set of remaining elements,
  @{term "s"} is the sum of the elements seen so far, and @{term "m"} is
  the maximum of the elements seen so far.
  The @{term "WHILE b f \<sigma>\<^sub>0"} construct describes a partially correct loop,
  i.e., it describes only those results that can be reached by finitely many
  iterations, and ignores infinite paths of the loop. In order to
  prove total correctness, the construct @{term "WHILE\<^sub>T b f \<sigma>\<^sub>0"} is used. It
  fails if there exists an infinite execution of the loop.

  A binding @{term [source] "do {x\<leftarrow>(S\<^sub>1::'a nres); S\<^sub>2}"} nondeterministically
  chooses a result of
  @{term "S\<^sub>1"}, binds it to variable @{term "x"}, and then continues with
  @{term "S\<^sub>2"}. If @{term "S\<^sub>1"} is @{const "FAIL"}, the
  bind statement also fails.

  The syntactic form @{term [source] "do { let x=V; (S::'a \<Rightarrow> 'b nres)}"}
  assigns the value \<open>V\<close> to variable \<open>x\<close>, and continues with
  \<open>S\<close>.

  The return statement @{term "RETURN x"} specifies precisely the result
  \<open>x\<close>.

  The specification statement @{term "SPEC \<Phi>"} describes all results that
  satisfy the predicate \<open>\<Phi>\<close>. This is the source of nondeterminism in
  programs, as there may be more than one such result. In our case, we describe
  any element of set \<open>V\<close>.

  Note that these statement are shallowly embedded into Isabelle/HOL, i.e.,
  they are ordinary Isabelle/HOL constants. The main advantage is, that any
  other construct and datatype from Isabelle/HOL may be used inside programs.
  In our case, we use Isabelle/HOL's predefined operations on sets and natural
  numbers. Another advantage is that extending the framework with new commands
  becomes fairly easy.
\<close>

subsection \<open>Proving Programs Correct\<close>
text \<open>
  The next step in the program development is to prove the program correct
  w.r.t.\ a specification. In refinement notion, we have to prove that the
  program \<open>S\<close> refines a specification \<open>\<Phi>\<close> if the precondition
  \<open>\<Psi>\<close> holds, i.e., @{term "\<Psi> \<Longrightarrow> S \<le> SPEC \<Phi>"}.

  For our purposes, we prove that @{const "sum_max"} really computes the sum
  and the maximum.
\<close>

text \<open>
  As usual, we have to think of a loop invariant first. In our case, this
  is rather straightforward. The main complication is introduced by the
  partially defined \<open>Max\<close>-operator of the Isabelle/HOL standard library.
\<close>
definition "sum_max_invar V\<^sub>0 \<equiv> \<lambda>(V,s::nat,m).
             V\<subseteq>V\<^sub>0
           \<and> s=\<Sum>(V\<^sub>0-V)
           \<and> m=(if (V\<^sub>0-V)={} then 0 else Max (V\<^sub>0-V))
           \<and> finite (V\<^sub>0-V)"

text \<open>
  We have extracted the most complex verification condition
  --- that the invariant is preserved by the loop body --- to
  an own lemma. For complex proofs, it is always a good idea to do that,
  as it makes the proof more readable.
\<close>
lemma sum_max_invar_step:
  assumes "x\<in>V" "sum_max_invar V\<^sub>0 (V,s,m)"
  shows "sum_max_invar V\<^sub>0 (V-{x},s+x,max m x)"
  txt \<open>In our case the proof is rather straightforward, it only
    requires the lemma @{thm [source] it_step_insert_iff}, that handles
    the @{term "(V\<^sub>0-(V-{x}))"} terms that occur in the invariant.\<close>
  using assms unfolding sum_max_invar_def by (auto simp: it_step_insert_iff)

text \<open>
  The correctness is now proved by first invoking the verification condition
  generator, and then discharging the verification conditions by
  \<open>auto\<close>. Note that we have to apply the
  @{thm [source] sum_max_invar_step} lemma, {\em before} we unfold the
  definition of the invariant to discharge the remaining verification
  conditions.
\<close>
theorem sum_max_correct:
  assumes PRE: "V\<noteq>{}"
  shows "sum_max V \<le> SPEC (\<lambda>(s,m). s=\<Sum>V \<and> m=Max V)"
  txt \<open>
    The precondition \<open>V\<noteq>{}\<close> is necessary, as the
    \<open>Max\<close>-operator from Isabelle/HOL's standard library is not defined
    for empty sets.
\<close>
  using PRE unfolding sum_max_def
  apply (intro WHILE_rule[where I="sum_max_invar V"] refine_vcg) \<comment> \<open>Invoke vcg\<close>
  txt \<open>Note that we have explicitely instantiated
    the rule for the while-loop with the invariant. If this is not done,
    the verification condition generator will stop at the WHILE-loop.
\<close>
  apply (auto intro: sum_max_invar_step) \<comment> \<open>Discharge step\<close>
  unfolding sum_max_invar_def \<comment> \<open>Unfold invariant definition\<close>
  apply (auto) \<comment> \<open>Discharge remaining goals\<close>
  done

text \<open>
  In this proof, we specified the invariant explicitely.
  Alternatively, we may annotate the invariant at the while loop,
  using the syntax @{term "WHILE\<^bsup>I\<^esup> b f \<sigma>\<^sub>0"}. Then, the verification condition
  generator will use the annotated invariant automatically.
\<close>

text_raw\<open>\paragraph{Total Correctness}\<close>
text \<open>
  Now, we reformulate our program to use a total correct while loop,
  and annotate the invariant at the loop. The invariant is strengthened by
  stating that the set of elements is finite.
\<close>

definition "sum_max'_invar V\<^sub>0 \<sigma> \<equiv>
  sum_max_invar V\<^sub>0 \<sigma>
  \<and> (let (V,_,_)=\<sigma> in finite (V\<^sub>0-V))"

definition sum_max' :: "nat set \<Rightarrow> (nat\<times>nat) nres" where
  "sum_max' V \<equiv> do {
    (_,s,m) \<leftarrow> WHILE\<^sub>T\<^bsup>sum_max'_invar V\<^esup> (\<lambda>(V,s,m). V\<noteq>{}) (\<lambda>(V,s,m). do {
      x\<leftarrow>SPEC (\<lambda>x. x\<in>V);
      let V=V-{x};
      let s=s+x;
      let m=max m x;
      RETURN (V,s,m)
    }) (V,0,0);
    RETURN (s,m)
  }"

theorem sum_max'_correct:
  assumes NE: "V\<noteq>{}" and FIN: "finite V"
  shows "sum_max' V \<le> SPEC (\<lambda>(s,m). s=\<Sum>V \<and> m=Max V)"
  using NE FIN unfolding sum_max'_def
  apply (intro refine_vcg) \<comment> \<open>Invoke vcg\<close>

  txt \<open>This time, the verification condition generator uses the annotated
    invariant. Moreover, it leaves us with a variant. We have to specify a
    well-founded relation, and show that the loop body respects this
    relation. In our case, the set \<open>V\<close> decreases in each step, and
    is initially finite. We use the relation @{const "finite_psubset"} and the
    @{const "inv_image"} combinator from the Isabelle/HOL standard library.\<close>
  apply (subgoal_tac "wf (inv_image finite_psubset fst)",
    assumption) \<comment> \<open>Instantiate variant\<close>
  apply simp \<comment> \<open>Show variant well-founded\<close>

  unfolding sum_max'_invar_def \<comment> \<open>Unfold definition of invariant\<close>
  apply (auto intro: sum_max_invar_step) \<comment> \<open>Discharge step\<close>

  unfolding sum_max_invar_def \<comment> \<open>Unfold definition of invariant completely\<close>
  apply (auto intro: finite_subset) \<comment> \<open>Discharge remaining goals\<close>
  done

subsection \<open>Refinement\<close>
text \<open>
  The next step in the program development is to refine the initial program
  towards an executable program. This usually involves both, program refinement
  and data refinement. Program refinement means changing the structure of the
  program. Usually, some specification statements are replaced by more concrete
  implementations. Data refinement means changing the used data types towards
  implementable data types.

  In our example, we implement the set \<open>V\<close> with a distinct list,
  and replace the specification statement @{term "SPEC (\<lambda>x. x\<in>V)"} by
  the head operation on distinct lists. For the lists, we use
  the list-set data structure provided by the Isabelle Collection Framework
  \cite{L09_collections,LL10}.

  For this example, we write the refined program ourselves.
  An automation of this task can be achieved with the automatic refinement tool,
  which is available as a prototype in Refine-Autoref. Usage examples are in
  ex/Automatic-Refinement.
\<close>

definition sum_max_impl :: "nat ls \<Rightarrow> (nat\<times>nat) nres" where
  "sum_max_impl V \<equiv> do {
    (_,s,m) \<leftarrow> WHILE (\<lambda>(V,s,m). \<not>ls.isEmpty V) (\<lambda>(V,s,m). do {
      x\<leftarrow>RETURN (the (ls.sel V (\<lambda>x. True)));
      let V=ls.delete x V;
      let s=s+x;
      let m=max m x;
      RETURN (V,s,m)
    }) (V,0,0);
    RETURN (s,m)
  }"

text \<open>
  Note that we replaced the operations on sets by the respective operations
  on lists (with the naming scheme \<open>ls.xxx\<close>). The specification
  statement was replaced by @{term "the (ls.sel V (\<lambda>x. True))"}, i.e.,
  selection of an element that satisfies the predicate @{term "(\<lambda>x. True)"}.
  As @{const "ls.sel"} returns an option datatype, we extract the value with
  @{const "the"}. Moreover, we omitted the loop invariant, as we don't need it
  any more.
\<close>

text \<open>
  Next, we have to show that our concrete pogram actually refines
  the abstract one.
\<close>
theorem sum_max_impl_refine:
  assumes "(V,V')\<in>build_rel ls.\<alpha> ls.invar"
  shows "sum_max_impl V \<le> \<Down>Id (sum_max V')"
  txt \<open>
    Let \<open>R\<close> be a
    {\em refinement relation\footnote{Also called coupling invariant.}},
    that relates concrete and abstract values.

    Then, the function @{term "\<Down>R"} maps a result-set over abstract values to
    the greatest result-set over concrete values that is compatible
    w.r.t.\ \<open>R\<close>. The value @{const "FAIL"} is mapped to itself.

    Thus, the proposition @{term "S \<le> \<Down>R S'"} means, that \<open>S\<close> refines
    \<open>S'\<close> w.r.t.\ \<open>R\<close>, i.e., every value in the result of
    \<open>S\<close> can be abstracted to a value in the result of \<open>S'\<close>.

    Usually, the refinement relation consists of an invariant \<open>I\<close> and
    an abstraction function \<open>\<alpha>\<close>. In this case, we may use the
    @{term "build_rel I \<alpha>"}-function to define the refinement relation.

    In our example, we assume that the input is in the refinement relation
    specified by list-sets, and show that the output is in the identity
    relation. We use the identity here, as we do not change the datatypes of
    the output.
\<close>

  txt \<open>The proof is done automatically by the refinement verification
    condition generator.
    Note that the theory \<open>Collection_Bindings\<close> sets up all the
    necessary lemmas to discharge refinement conditions for the collection
    framework.\<close>
  using assms unfolding sum_max_impl_def sum_max_def
  apply (refine_rcg) \<comment> \<open>Decompose combinators, generate data refinement goals\<close>

  apply (refine_dref_type) \<comment> \<open>Type-based heuristics to instantiate data
    refinement goals\<close>
  apply (auto simp add:
    ls.correct refine_hsimp refine_rel_defs) \<comment> \<open>Discharge proof obligations\<close>
  done

text \<open>
  Refinement is transitive, so it is easy to show that the concrete
  program meets the specification.
\<close>
theorem sum_max_impl_correct:
  assumes "(V,V')\<in>build_rel ls.\<alpha> ls.invar" and "V'\<noteq>{}"
  shows "sum_max_impl V \<le> SPEC (\<lambda>(s,m). s=\<Sum>V' \<and> m=Max V')"
proof -
  note sum_max_impl_refine
  also note sum_max_correct
  finally show ?thesis using assms .
qed

text \<open>
  Just for completeness, we also refine the total correct program in the
  same way.
\<close>
definition sum_max'_impl :: "nat ls \<Rightarrow> (nat\<times>nat) nres" where
  "sum_max'_impl V \<equiv> do {
    (_,s,m) \<leftarrow> WHILE\<^sub>T (\<lambda>(V,s,m). \<not>ls.isEmpty V) (\<lambda>(V,s,m). do {
      x\<leftarrow>RETURN (the (ls.sel V (\<lambda>x. True)));
      let V=ls.delete x V;
      let s=s+x;
      let m=max m x;
      RETURN (V,s,m)
    }) (V,0,0);
    RETURN (s,m)
  }"

theorem sum_max'_impl_refine:
  "(V,V')\<in>build_rel ls.\<alpha> ls.invar \<Longrightarrow> sum_max'_impl V \<le> \<Down>Id (sum_max' V')"
  unfolding sum_max'_impl_def sum_max'_def
  apply refine_rcg
  apply refine_dref_type
  apply (auto simp: refine_hsimp ls.correct refine_rel_defs)
  done

theorem sum_max'_impl_correct:
  assumes "(V,V')\<in>build_rel ls.\<alpha> ls.invar" and "V'\<noteq>{}"
  shows "sum_max'_impl V \<le> SPEC (\<lambda>(s,m). s=\<Sum>V' \<and> m=Max V')"
  using ref_two_step[OF sum_max'_impl_refine sum_max'_correct] assms
  txt \<open>Note that we do not need the finiteness precondition, as list-sets are
    always finite. However, in order to exploit this, we have to
    unfold the \<open>build_rel\<close> construct, that relates the list-set on
    the concrete side to the set on the abstract side.
\<close>
  apply (auto simp: build_rel_def)
  done

subsection \<open>Code Generation\<close>
text \<open>
  In order to generate code from the above definitions,
  we convert the function defined in our monad to an ordinary, deterministic
  function, for that the Isabelle/HOL code generator can generate code.

  For partial correct algorithms, we can generate code inside a deterministic
  result monad. The domain of this monad is a flat complete lattice, where
  top means a failed assertion and bottom means nontermination. (Note that
  executing a function in this monad will never return bottom,
  but just diverge).
  The construct @{term "nres_of x"} embeds the deterministic into the
  nondeterministic monad.

  Thus, we have to construct a function \<open>?sum_max_code\<close> such that:
\<close>
schematic_goal sum_max_code_aux: "nres_of ?sum_max_code \<le> sum_max_impl V"
  txt \<open>This is done automatically by the transfer procedure of
    our framework.\<close>
  unfolding sum_max_impl_def
  apply (refine_transfer)
  done

text \<open>
  In order to define the function from the above lemma, we can use the
  command \<open>concrete_definition\<close>, that is provided by our framework:
\<close>
concrete_definition sum_max_code for V uses sum_max_code_aux

text \<open>This defines a new constant \<open>sum_max_code\<close>:\<close>
thm sum_max_code_def
text \<open>And proves the appropriate refinement lemma:\<close>
thm sum_max_code.refine

text \<open>Note that the \<open>concrete_definition\<close> command is sensitive to
  patterns of the form \<open>RETURN _\<close> and \<open>nres_of\<close>, in which case
  the defined constant will not contain the \<open>RETURN\<close>
  or \<open>nres_of\<close>. In any other case, the defined constant will just be
  the left hand side of the refinement statement.
\<close>

text \<open>Finally, we can prove a correctness statement that is independent
  from our refinement framework:\<close>
theorem sum_max_code_correct:
  assumes "ls.\<alpha> V \<noteq> {}"
  shows "sum_max_code V = dRETURN (s,m) \<Longrightarrow> s=\<Sum>(ls.\<alpha> V) \<and> m=Max (ls.\<alpha> V)"
    and "sum_max_code V \<noteq> dFAIL"
  txt \<open>The proof is done by transitivity, and unfolding some
    definitions:\<close>
  using nres_correctD[OF order_trans[OF sum_max_code.refine sum_max_impl_correct,
    of V "ls.\<alpha> V"]] assms
  by (auto simp: refine_rel_defs)

text \<open>For total correctness, the approach is the same. The
  only difference is, that we use @{const "RETURN"} instead
  of @{const "nres_of"}:\<close>
schematic_goal sum_max'_code_aux:
  "RETURN ?sum_max'_code \<le> sum_max'_impl V"
  unfolding sum_max'_impl_def
  apply (refine_transfer)
  done

concrete_definition sum_max'_code for V uses sum_max'_code_aux

theorem sum_max'_code_correct:
  "\<lbrakk>ls.\<alpha> V \<noteq> {}\<rbrakk> \<Longrightarrow> sum_max'_code V = (\<Sum>(ls.\<alpha> V), Max (ls.\<alpha> V))"
  using order_trans[OF sum_max'_code.refine sum_max'_impl_correct,
    of V "ls.\<alpha> V"]
  by (auto simp: refine_rel_defs)

text \<open>
  If we use recursion combinators, a plain function can only be generated,
  if the recursion combinators can be defined. Alternatively, for total correct
  programs, we may generate a (plain) function that internally uses the
  deterministic monad, and then extracts the result.
\<close>

schematic_goal sum_max''_code_aux:
  "RETURN ?sum_max''_code \<le> sum_max'_impl V"
  unfolding sum_max'_impl_def
  apply (refine_transfer the_resI) \<comment> \<open>Using @{text "the_resI"} for internal monad and result extraction\<close>
  done

concrete_definition sum_max''_code for V uses sum_max''_code_aux

theorem sum_max''_code_correct:
  "\<lbrakk>ls.\<alpha> V \<noteq> {}\<rbrakk> \<Longrightarrow> sum_max''_code V = (\<Sum>(ls.\<alpha> V), Max (ls.\<alpha> V))"
  using order_trans[OF sum_max''_code.refine sum_max'_impl_correct,
    of V "ls.\<alpha> V"]
  by (auto simp: refine_rel_defs)

text \<open>Now, we can generate verified code with the Isabelle/HOL code
  generator:\<close>
export_code sum_max_code sum_max'_code sum_max''_code checking SML
export_code sum_max_code sum_max'_code sum_max''_code checking OCaml?
export_code sum_max_code sum_max'_code sum_max''_code checking Haskell?
export_code sum_max_code sum_max'_code sum_max''_code checking Scala

subsection \<open>Foreach-Loops\<close>
text \<open>
  In the \<open>sum_max\<close> example above, we used a while-loop to iterate over
  the elements of a set. As this pattern is used commonly, there is
  an abbreviation for it in the refinement framework. The construct
  @{term "FOREACH S f \<sigma>\<^sub>0"} iterates \<open>f::'x\<Rightarrow>'s\<Rightarrow>'s\<close> for each element
  in \<open>S::'x set\<close>, starting with state \<open>\<sigma>\<^sub>0::'s\<close>.

  With foreach-loops, we could have written our example as follows:
\<close>

definition sum_max_it :: "nat set \<Rightarrow> (nat\<times>nat) nres" where
  "sum_max_it V \<equiv> FOREACH V (\<lambda>x (s,m). RETURN (s+x,max m x)) (0,0)"

theorem sum_max_it_correct:
  assumes PRE: "V\<noteq>{}" and FIN: "finite V"
  shows "sum_max_it V \<le> SPEC (\<lambda>(s,m). s=\<Sum>V \<and> m=Max V)"
  using PRE unfolding sum_max_it_def
  apply (intro FOREACH_rule[where I="\<lambda>it \<sigma>. sum_max_invar V (it,\<sigma>)"] refine_vcg)
  apply (rule FIN) \<comment> \<open>Discharge finiteness of iterated set\<close>
  apply (auto intro: sum_max_invar_step) \<comment> \<open>Discharge step\<close>
  unfolding sum_max_invar_def \<comment> \<open>Unfold invariant definition\<close>
  apply (auto) \<comment> \<open>Discharge remaining goals\<close>
  done

definition sum_max_it_impl :: "nat ls \<Rightarrow> (nat\<times>nat) nres" where
  "sum_max_it_impl V \<equiv> FOREACH (ls.\<alpha> V) (\<lambda>x (s,m). RETURN (s+x,max m x)) (0,0)"
text \<open>Note: The nondeterminism for iterators is currently resolved at
  transfer phase, where they are replaced by iterators from the ICF.\<close>

lemma sum_max_it_impl_refine:
  notes [refine] = inj_on_id
  assumes "(V,V')\<in>build_rel ls.\<alpha> ls.invar"
  shows "sum_max_it_impl V \<le> \<Down>Id (sum_max_it V')"
  unfolding sum_max_it_impl_def sum_max_it_def
  txt \<open>Note that we specified \<open>inj_on_id\<close> as additional introduction
    rule. This is due to the very general iterator refinement rule, that may
    also change the set over that is iterated.\<close>
  using assms
  apply refine_rcg \<comment> \<open>This time, we don't need the
    @{text "refine_dref_type"} heuristics, as no schematic refinement
    relations are generated.\<close>
  apply (auto simp: refine_hsimp refine_rel_defs)
  done

schematic_goal sum_max_it_code_aux:
  "RETURN ?sum_max_it_code \<le> sum_max_it_impl V"
  unfolding sum_max_it_impl_def
  apply (refine_transfer)
  done

text \<open>Note that the transfer method has replaced the iterator by an iterator
  from the Isabelle Collection Framework.\<close>

thm sum_max_it_code_aux
concrete_definition sum_max_it_code for V uses sum_max_it_code_aux

theorem sum_max_it_code_correct:
  assumes "ls.\<alpha> V \<noteq> {}"
  shows "sum_max_it_code V = (\<Sum>(ls.\<alpha> V), Max (ls.\<alpha> V))"
proof -
  note sum_max_it_code.refine[of V]
  also note sum_max_it_impl_refine[of V "ls.\<alpha> V"]
  also note sum_max_it_correct
  finally show ?thesis using assms by (auto simp: refine_rel_defs)
qed

export_code sum_max_it_code checking SML
export_code sum_max_it_code checking OCaml?
export_code sum_max_it_code checking Haskell?
export_code sum_max_it_code checking Scala

definition "sum_max_it_list \<equiv> sum_max_it_code o ls.from_list"
ML_val \<open>
  @{code sum_max_it_list} (map @{code nat_of_integer} [1,2,3,4,5])
\<close>

section \<open>Pointwise Reasoning\<close>

text \<open>
  In this section, we describe how to use pointwise reasoning to prove
  refinement statements and other relations between element of the
  nondeterminism monad.

  Pointwise reasoning is often a powerful tool to show refinement between
  structurally different program fragments.
\<close>

text \<open>
  The refinement framework defines the predicates
  @{const "nofail"} and @{const "inres"}.
  @{term "nofail S"} states that \<open>S\<close> does not fail,
  and @{term "inres S x"} states that one possible result of \<open>S\<close> is
  \<open>x\<close> (Note that this includes the case that \<open>S\<close> fails).

  Equality and refinement can be stated using @{const "nofail"} and
  @{const "inres"}:
  @{thm [display] pw_eq_iff}
  @{thm [display] pw_le_iff}

  Useful corollaries of this lemma are
  @{thm [source] pw_leI}, @{thm [source] pw_eqI}, and @{thm [source] pwD}.

  Once a refinement has been expressed via nofail/inres, the simplifier can be
  used to propagate the nofail and inres predicates inwards over the structure
  of the program. The relevant lemmas are contained in the named theorem
  collection \<open>refine_pw_simps\<close>.

  As an example, we show refinement of two structurally different programs here,
  both returning some value in a certain range:
\<close>
lemma "do { ASSERT (fst p > 2); SPEC (\<lambda>x. x\<le>(2::nat)*(fst p + snd p)) }
  \<le> do { let (x,y)=p; z\<leftarrow>SPEC (\<lambda>z. z\<le>x+y);
          a\<leftarrow>SPEC (\<lambda>a. a\<le>x+y); ASSERT (x>2); RETURN (a+z)}"
  apply (rule pw_leI)
  apply (auto simp add: refine_pw_simps split: prod.split)

  apply (rename_tac a b x)
  apply (case_tac "x\<le>a+b")
  apply (rule_tac x=0 in exI)
  apply simp
  apply (rule_tac x="a+b" in exI)
  apply (simp)
  apply (rule_tac x="x-(a+b)" in exI)
  apply simp
  done

section "Arbitrary Recursion (TBD)"
text \<open>
  While-loops are suited to express tail-recursion.
  In order to express arbitrary recursion, the refinement framework provides
  the nrec-mode for the \<open>partial_function\<close> command, as well as the fixed
  point combinators @{const "REC"} (partial correctness) and
  @{const "RECT"} (total correctness).

  Examples for \<open>partial_function\<close> can be found in
  \<open>ex/Refine_Fold\<close>. Examples for the recursion combinators can be found
  in \<open>ex/Recursion\<close> and \<open>ex/Nested_DFS\<close>.
\<close>

section \<open>Reference\<close>
  subsection \<open>Statements\<close> text_raw \<open>\label{sec:stmt_ref}\<close>
  text \<open>
    \begin{description}
      \item[@{const "SUCCEED"}] The empty set of results. Least element of
        the refinement ordering.
      \item[@{const "FAIL"}] Result that indicates a failing assertion.
        Greatest element of the refinement ordering.
      \item{@{term "RES X"}} All results from set \<open>X\<close>.
      \item[@{term "RETURN x"}] Return single result \<open>x\<close>. Defined in
        terms of \<open>RES\<close>: @{lemma "RETURN x = RES {x}" by simp}.
      \item[@{term "EMBED r"}] Embed partial-correctness option type, i.e.,
        succeed if \<open>r=None\<close>, otherwise return value of \<open>r\<close>.
      \item[@{term "SPEC \<Phi>"}] Specification.
        All results that satisfy predicate \<open>\<Phi>\<close>. Defined in terms of
        @{term "RES"}: @{lemma "SPEC \<Phi> = RES (Collect \<Phi>)" by simp}
      \item[@{term [source] "bind M f"}] Binding.
        Nondeterministically choose a result from
        \<open>M\<close> and apply \<open>f\<close> to it. Note that usually the
        \<open>do\<close>-notation is used, i.e., \<open>do {x\<leftarrow>M; f x}\<close> or
        \<open>do {M;f}\<close> if the result of \<open>M\<close> is not important.
        If \<open>M\<close> fails, @{term [source] "bind M f"} also fails.
      \item[@{term "ASSERT \<Phi>"}] Assertion. Fails
        if \<open>\<Phi>\<close> does not hold, otherwise returns \<open>()\<close>.
        Note that the default usage with the do-notation is:
        @{term [source] "do {ASSERT \<Phi>; f}"}.

      \item[@{term "ASSUME \<Phi>"}] Assumption. Succeeds
        if \<open>\<Phi>\<close> does not hold, otherwise returns \<open>()\<close>. Note that
        the default usage with the do-notation is:
        @{term [source] "do {ASSUME \<Phi>; f}"}.

      \item[@{term "REC body"}] Recursion for partial correctness.
        May be used to express arbitrary recursion. Returns \<open>SUCCEED\<close> on
        nontermination.
      \item[@{term "RECT body"}] Recursion for total correctness.
        Returns \<open>FAIL\<close> on nontermination.
      \item[@{term "WHILE b f \<sigma>\<^sub>0"}] Partial correct while-loop.
        Start with state \<open>\<sigma>\<^sub>0\<close>,
        and repeatedly apply \<open>f\<close> as long as \<open>b\<close> holds for the
        current state. Non-terminating paths are ignored, i.e., they do not
        contribute a result.
      \item[@{term "WHILE\<^sub>T b f \<sigma>\<^sub>0"}] Total correct while-loop. If there is a
        non-terminating path, the result is @{term "FAIL"}.
      \item[@{term "WHILE\<^bsup>I\<^esup> b f \<sigma>\<^sub>0"}, @{term "WHILE\<^sub>T\<^bsup>I\<^esup> b f \<sigma>\<^sub>0"}] While-loop with
        annotated invariant. It is asserted that the invariant holds.
      \item[@{term "FOREACH S f \<sigma>\<^sub>0"}] Foreach loop.
        Start with state \<open>\<sigma>\<^sub>0\<close>, and transform
        the state with \<open>f x\<close> for each element \<open>x\<in>S\<close>. Asserts that
        \<open>S\<close> is finite.
      \item[@{term "FOREACH\<^bsup>I\<^esup> S f \<sigma>\<^sub>0"}] Foreach-loop with
        annotated invariant.

        Alternative syntax: @{term "FOREACHi I S f \<sigma>\<^sub>0"}.

        The invariant is a predicate of type
        \<open>I::'a set \<Rightarrow> 'b \<Rightarrow> bool\<close>, where \<open>I it \<sigma>\<close> means, that
        the invariant holds for the remaining set of elements \<open>it\<close> and
        current state \<open>\<sigma>\<close>.
      \item[@{term "FOREACH\<^sub>C S c f \<sigma>\<^sub>0"}] Foreach-loop with explicit continuation
        condition.

        Alternative syntax: @{term "FOREACHc S c f \<sigma>\<^sub>0"}.

        If \<open>c::'\<sigma>\<Rightarrow>bool\<close> becomes false for the current state,
        the iteration immediately terminates.
      \item[@{term "FOREACH\<^sub>C\<^bsup>I\<^esup> S c f \<sigma>\<^sub>0"}] Foreach-loop with explicit continuation
        condition and annotated invariant.

        Alternative syntax: @{term "FOREACHci I S c f \<sigma>\<^sub>0"}.
      \item[\<open>partial_function (nrec)\<close>] Mode of the partial function
        package for the nondeterminism monad.
    \end{description}
\<close>

    subsection \<open>Refinement\<close>
    text \<open>
      \begin{description}
        \item{@{term_type "(\<le>) :: 'a nres \<Rightarrow> 'a nres \<Rightarrow> bool"}}
          Refinement ordering.
          \<open>S \<le> S'\<close> means, that every result in
          \<open>S\<close> is also a result in \<open>S'\<close>.
          Moreover, \<open>S\<close> may only fail if \<open>S'\<close> fails.
          \<open>\<le>\<close> forms a complete lattice, with least element
          \<open>SUCCEED\<close> and greatest element \<open>FAIL\<close>.
        \item{@{term "\<Down>R"}} Concretization. Takes a refinement relation
          \<open>R::('c\<times>'a) set\<close> that relates concrete to abstract values,
          and returns a concretization function
          @{term "\<Down>R :: 'a nres \<Rightarrow> 'c nres"}.
        \item{@{term "\<Up>R"}} Abstraction. Takes a refinement relation and
          returns an abstraction function.
          The functions \<open>\<Down>R\<close> and \<open>\<Up>R\<close> form a Galois-connection,
          i.e., we have: \<open>S \<le> \<Down>R S' \<longleftrightarrow> \<Up>R S \<le> S'\<close>.
        \item{@{term "build_rel \<alpha> I"}} Builds a refinement relation from
          an abstraction function and an invariant. Those refinement relations
          are always single-valued.
        \item{@{term "nofail S"}} Predicate that states that \<open>S\<close> does
          not fail.
        \item{@{term "inres S x"}} Predicate that states that \<open>S\<close>
          includes result \<open>x\<close>. Note that a failing program includes all
          results.
      \end{description}
\<close>

    subsection\<open>Proof Tools\<close>
      text \<open>
        \begin{description}
          \item{Verification Condition Generator:}
            \begin{description}
              \item[Method:] \<open>intro refine_vcg\<close>
              \item[Attributes:] \<open>refine_vcg\<close>
            \end{description}

            Transforms a subgoal of the
            form \<open>S \<le> SPEC \<Phi>\<close> into verification conditions by
            decomposing the structure of \<open>S\<close>. Invariants for loops
            without annotation must be specified explicitely by instantiating
            the respective proof-rule for the loop construct, e.g.,
            \<open>intro WHILE_rule[where I=\<dots>] refine_vcg\<close>.

            \<open>refine_vcg\<close> is a named theorems collection that contains
            the rules that are used by default.

          \item{Refinement Condition Generator:}
            \begin{description}
              \item[Method:] \<open>refine_rcg\<close> [thms].
              \item[Attributes:] \<open>refine0\<close>, \<open>refine\<close>,
                \<open>refine2\<close>.
              \item[Flags:] \<open>refine_no_prod_split\<close>.
            \end{description}
            Tries to prove a subgoal of the form \<open>S \<le> \<Down>R S'\<close> by
            decomposing the structure of \<open>S\<close> and \<open>S'\<close>.
            The rules to be used are contained in the theorem collection
            \<open>refine\<close>. More rules may be passed as argument to the method.
            Rules contained in \<open>refine0\<close> are always
            tried first, and rules in \<open>refine2\<close> are tried last.
            Usually, rules that decompose both programs equally
            should be put into \<open>refine\<close>. Rules that may make big steps,
            without decomposing the program further, should be put into
            \<open>refine0\<close> (e.g., @{thm [source] Id_refine}). Rules that
            decompose the programs differently and shall be used as last resort
            before giving up should be put into \<open>refine2\<close>, e.g.,
            @{thm [source] remove_Let_refine}.

            By default, this procedure will invoke the splitter to split
            product types in the goals. This behaviour can be disabled by
            setting the flag \<open>refine_no_prod_split\<close>.
          \item{Refinement Relation Heuristics:}
            \begin{description}
              \item[Method:] \<open>refine_dref_type\<close> [(trace)].
              \item[Attributes:] \<open>refine_dref_RELATES\<close>,
                \<open>refine_dref_pattern\<close>.
              \item[Flags:] \<open>refine_dref_tracing\<close>.
            \end{description}
            Tries to instantiate schematic refinement relations based on their
            type. By default, this rule is applied to all subgoals.
            Internally, it uses the rules declared as
            \<open>refine_dref_pattern\<close> to introduce a goal of the form
            \<open>RELATES ?R\<close>, that is then solved by exhaustively
            applying rules declared as \<open>refine_dref_RELATES\<close>.

            The flag \<open>refine_dref_tracing\<close> controls tracing of
            resolving \<open>RELATES\<close>-goals. Tracing may also be enabled by
            passing (trace) as argument.

          \item{Pointwise Reasoning Simplification Rules:}
            \begin{description}
              \item[Attributes:] \<open>refine_pw_simps\<close>
            \end{description}
            A theorem collection that contains
            simplification lemmas to push inwards @{term "nofail"} and
            @{term "inres"} predicates into program constructs.

          \item{Refinement Simp Rules:}
            \begin{description}
              \item[Attributes:] \<open>refine_hsimp\<close>
            \end{description}
            A theorem collection that contains some
            simplification lemmas that are useful to prove membership in
            refinement relations.

          \item{Transfer:}
            \begin{description}
              \item[Method:] \<open>refine_transfer\<close> [thms]
              \item[Attribute:] \<open>refine_transfer\<close>
            \end{description}
            Tries to prove a subgoal of the form \<open>\<alpha> f \<le> S\<close> by
            decomposing the structure of \<open>f\<close> and \<open>S\<close>.
            This is usually used in connection
            with a schematic lemma, to generate \<open>f\<close> from the structure
            of \<open>S\<close>.

            The theorems declared as \<open>refine_transfer\<close> are used to do
            the transfer. More theorems may be passed as arguments to the method.
            Moreover, some simplification for nested abstraction
            over product types (\<open>\<lambda>(a,b) (c,d). \<dots>\<close>) is done, and the
            monotonicity prover is used on monotonicity goals.

            There is a standard setup for \<open>\<alpha>=RETURN\<close>
            (transfer to plain function for total correct code generation), and
            \<open>\<alpha>=nres_of\<close> (transfer to deterministic result monad, for
            partial correct code generation).

          \item{Automatic Refinement:}
            \begin{description}
              \item[Method:] \<open>refine_autoref\<close>
              \item[Attributes:] ...
            \end{description}
            See automatic refinement package for documentation (TBD)

          \item{Concrete Definition:}
            \begin{description}
              \item[Command:]
               \<open>concrete_definition name [attribs] for params uses thm\<close>
               where \<open>attribs\<close> and the \<open>for\<close>-part are optional.

               Declares a new constant from the left-hand side of a refinement
               lemma. Has special handling for left-hand sides of the forms
               \<open>RETURN _\<close> and \<open>nres_of\<close>, in which cases those
               topmost functions are not included in the defined constant.

               The refinement lemma is folded with the new constant and
               registered as \<open>name.refine\<close>.
              \item[Command:]
              \<open>prepare_code_thms thms\<close> takes a list of definitional
                theorems and sets up lemmas for the code generator for those
                definitions. This includes handling of recursion combinators.
            \end{description}
        \end{description}
\<close>

    subsection\<open>Packages\<close>
      text \<open>
        The following parts of the refinement framework are not included
        by default, but can be imported if necessary:
        \begin{description}
          \item{Collection-Bindings:} Sets up refinement rules for the
            Isabelle Collection Framework. With this theory loaded, the
            refinement condition generator will discharge most data refinements
            using the ICF automatically. Moreover, the transfer procedure
            will replace \<open>FOREACH\<close>-statements by the corresponding
            ICF-iterators.
        \end{description}
\<close>

end


(*
  File: LinkedList.thy
  Author: Bohua Zhan
*)

section \<open>Implementation of linked list\<close>

theory LinkedList
  imports SepAuto
begin

text \<open>
  Examples in linked lists. Definitions and some of the examples are
  based on List\_Seg and Open\_List theories in \cite{Separation_Logic_Imperative_HOL-AFP}
  by Lammich and Meis.
\<close>

subsection \<open>List Assertion\<close>

datatype 'a node = Node (val: "'a") (nxt: "'a node ref option")
setup \<open>fold add_rewrite_rule @{thms node.sel}\<close>

fun node_encode :: "'a::heap node \<Rightarrow> nat" where
  "node_encode (Node x r) = to_nat (x, r)"

instance node :: (heap) heap
  apply (rule heap_class.intro)
  apply (rule countable_classI [of "node_encode"])
  apply (case_tac x, simp_all, case_tac y, simp_all)
  ..

fun os_list :: "'a::heap list \<Rightarrow> 'a node ref option \<Rightarrow> assn" where
  "os_list [] p = \<up>(p = None)"
| "os_list (x # l) (Some p) = (\<exists>\<^sub>Aq. p \<mapsto>\<^sub>r Node x q * os_list l q)"
| "os_list (x # l) None = false"
setup \<open>fold add_rewrite_ent_rule @{thms os_list.simps}\<close>

lemma os_list_empty [forward_ent]:
  "os_list [] p \<Longrightarrow>\<^sub>A \<up>(p = None)" by auto2

lemma os_list_Cons [forward_ent]:
  "os_list (x # l) p \<Longrightarrow>\<^sub>A (\<exists>\<^sub>Aq. the p \<mapsto>\<^sub>r Node x q * os_list l q * \<up>(p \<noteq> None))"
@proof @case "p = None" @qed

lemma os_list_none: "emp \<Longrightarrow>\<^sub>A os_list [] None" by auto2

lemma os_list_constr_ent:
  "p \<mapsto>\<^sub>r Node x q * os_list l q \<Longrightarrow>\<^sub>A os_list (x # l) (Some p)" by auto2

setup \<open>fold add_entail_matcher [@{thm os_list_none}, @{thm os_list_constr_ent}]\<close>
setup \<open>fold del_prfstep_thm @{thms os_list.simps}\<close>

ML_file "list_matcher_test.ML"

type_synonym 'a os_list = "'a node ref option"

subsection \<open>Basic operations\<close>

definition os_empty :: "'a::heap os_list Heap" where
  "os_empty = return None"

lemma os_empty_rule [hoare_triple]:
  "<emp> os_empty <os_list []>" by auto2

definition os_is_empty :: "'a::heap os_list \<Rightarrow> bool Heap" where
  "os_is_empty b = return (b = None)"

lemma os_is_empty_rule [hoare_triple]:
  "<os_list xs b> os_is_empty b <\<lambda>r. os_list xs b * \<up>(r \<longleftrightarrow> xs = [])>"
@proof @case "xs = []" @have "xs = hd xs # tl xs" @qed

definition os_prepend :: "'a \<Rightarrow> 'a::heap os_list \<Rightarrow> 'a os_list Heap" where
  "os_prepend a n = do { p \<leftarrow> ref (Node a n); return (Some p) }"

lemma os_prepend_rule [hoare_triple]:
  "<os_list xs n> os_prepend x n <os_list (x # xs)>" by auto2

definition os_pop :: "'a::heap os_list \<Rightarrow> ('a \<times> 'a os_list) Heap" where
  "os_pop r = (case r of
    None \<Rightarrow> raise STR ''Empty Os_list'' |
    Some p \<Rightarrow> do {m \<leftarrow> !p; return (val m, nxt m)})"

lemma os_pop_rule [hoare_triple]:
  "<os_list xs (Some p)>
   os_pop (Some p)
   <\<lambda>(x,r'). os_list (tl xs) r' * p \<mapsto>\<^sub>r (Node x r') * \<up>(x = hd xs)>"
@proof @case "xs = []" @have "xs = hd xs # tl xs" @qed

subsection \<open>Reverse\<close>

partial_function (heap) os_reverse_aux :: "'a::heap os_list \<Rightarrow> 'a os_list \<Rightarrow> 'a os_list Heap" where
  "os_reverse_aux q p = (case p of
    None \<Rightarrow> return q |
    Some r \<Rightarrow> do {
      v \<leftarrow> !r;
      r := Node (val v) q;
      os_reverse_aux p (nxt v) })"

lemma os_reverse_aux_rule [hoare_triple]:
  "<os_list xs p * os_list ys q>
    os_reverse_aux q p
   <os_list ((rev xs) @ ys)>"
@proof @induct xs arbitrary p q ys @qed

definition os_reverse :: "'a::heap os_list \<Rightarrow> 'a os_list Heap" where
  "os_reverse p = os_reverse_aux None p"

lemma os_reverse_rule:
  "<os_list xs p> os_reverse p <os_list (rev xs)>" by auto2

subsection \<open>Remove\<close>

setup \<open>fold add_rewrite_rule @{thms removeAll.simps}\<close>

partial_function (heap) os_rem :: "'a::heap \<Rightarrow> 'a node ref option \<Rightarrow> 'a node ref option Heap" where
  "os_rem x b = (case b of
     None \<Rightarrow> return None |
     Some p \<Rightarrow> do {
       n \<leftarrow> !p;
       q \<leftarrow> os_rem x (nxt n);
       (if (val n = x)
         then return q
         else do {
           p := Node (val n) q;
           return (Some p) }) })"

lemma os_rem_rule [hoare_triple]:
  "<os_list xs b> os_rem x b <\<lambda>r. os_list (removeAll x xs) r>\<^sub>t"
@proof @induct xs arbitrary b @qed

subsection \<open>Extract list\<close>

partial_function (heap) extract_list :: "'a::heap os_list \<Rightarrow> 'a list Heap" where
  "extract_list p = (case p of
    None \<Rightarrow> return []
  | Some pp \<Rightarrow> do {
      v \<leftarrow> !pp;
      ls \<leftarrow> extract_list (nxt v);
      return (val v # ls)
    })"

lemma extract_list_rule [hoare_triple]:
  "<os_list l p> extract_list p <\<lambda>r. os_list l p * \<up>(r = l)>"
@proof @induct l arbitrary p @qed

subsection \<open>Ordered insert\<close>

fun list_insert :: "'a::ord \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "list_insert x [] = [x]"
| "list_insert x (y # ys) = (
    if x \<le> y then x # (y # ys) else y # list_insert x ys)"
setup \<open>fold add_rewrite_rule @{thms list_insert.simps}\<close>

lemma list_insert_length:
  "length (list_insert x xs) = length xs + 1"
@proof @induct xs @qed
setup \<open>add_forward_prfstep_cond @{thm list_insert_length} [with_term "list_insert ?x ?xs"]\<close>

lemma list_insert_mset [rewrite]:
  "mset (list_insert x xs) = {#x#} + mset xs"
@proof @induct xs @qed

lemma list_insert_set [rewrite]:
  "set (list_insert x xs) = {x} \<union> set xs"
@proof @induct xs @qed

lemma list_insert_sorted [forward]:
  "sorted xs \<Longrightarrow> sorted (list_insert x xs)"
@proof @induct xs @qed

partial_function (heap) os_insert :: "'a::{ord,heap} \<Rightarrow> 'a os_list \<Rightarrow> 'a os_list Heap" where
  "os_insert x b = (case b of
      None \<Rightarrow> os_prepend x None
    | Some p \<Rightarrow> do {
        v \<leftarrow> !p;
        (if x \<le> val v then os_prepend x b
         else do {
           q \<leftarrow> os_insert x (nxt v);
           p := Node (val v) q;
           return (Some p) }) })"

lemma os_insert_to_fun [hoare_triple]:
  "<os_list xs b> os_insert x b <os_list (list_insert x xs)>"
@proof @induct xs arbitrary b @qed

subsection \<open>Insertion sort\<close>

fun insert_sort :: "'a::ord list \<Rightarrow> 'a list" where
  "insert_sort [] = []"
| "insert_sort (x # xs) = list_insert x (insert_sort xs)"
setup \<open>fold add_rewrite_rule @{thms insert_sort.simps}\<close>

lemma insert_sort_mset [rewrite]:
  "mset (insert_sort xs) = mset xs"
@proof @induct xs @qed

lemma insert_sort_sorted [forward]:
  "sorted (insert_sort xs)"
@proof @induct xs @qed

lemma insert_sort_is_sort [rewrite]:
  "insert_sort xs = sort xs" by auto2

fun os_insert_sort_aux :: "'a::{ord,heap} list \<Rightarrow> 'a os_list Heap" where
  "os_insert_sort_aux [] = (return None)"
| "os_insert_sort_aux (x # xs) = do {
     b \<leftarrow> os_insert_sort_aux xs;
     b' \<leftarrow> os_insert x b;
     return b'
   }"

lemma os_insert_sort_aux_correct [hoare_triple]:
  "<emp> os_insert_sort_aux xs <os_list (insert_sort xs)>"
@proof @induct xs @qed

definition os_insert_sort :: "'a::{ord,heap} list \<Rightarrow> 'a list Heap" where
  "os_insert_sort xs = do {
    p \<leftarrow> os_insert_sort_aux xs;
    l \<leftarrow> extract_list p;
    return l
  }"

lemma insertion_sort_rule [hoare_triple]:
  "<emp> os_insert_sort xs <\<lambda>ys. \<up>(ys = sort xs)>\<^sub>t" by auto2

subsection \<open>Merging two lists\<close>

fun merge_list :: "('a::ord) list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "merge_list xs [] = xs"
| "merge_list [] ys = ys"
| "merge_list (x # xs) (y # ys) = (
    if x \<le> y then x # (merge_list xs (y # ys))
    else y # (merge_list (x # xs) ys))"
setup \<open>fold add_rewrite_rule @{thms merge_list.simps}\<close>

lemma merge_list_correct [rewrite]:
  "set (merge_list xs ys) = set xs \<union> set ys"
@proof @fun_induct "merge_list xs ys" @qed

lemma merge_list_sorted [forward]:
  "sorted xs \<Longrightarrow> sorted ys \<Longrightarrow> sorted (merge_list xs ys)"
@proof @fun_induct "merge_list xs ys" @qed

partial_function (heap) merge_os_list :: "('a::{heap, ord}) os_list \<Rightarrow> 'a os_list \<Rightarrow> 'a os_list Heap" where
  "merge_os_list p q = (
    if p = None then return q
    else if q = None then return p
    else do {
      np \<leftarrow> !(the p); nq \<leftarrow> !(the q);
      if val np \<le> val nq then
        do { npq \<leftarrow> merge_os_list (nxt np) q;
             (the p) := Node (val np) npq;
             return p }
      else
        do { pnq \<leftarrow> merge_os_list p (nxt nq);
             (the q) := Node (val nq) pnq;
             return q } })"

lemma merge_os_list_to_fun [hoare_triple]:
  "<os_list xs p * os_list ys q>
  merge_os_list p q
  <\<lambda>r. os_list (merge_list xs ys) r>"
@proof @fun_induct "merge_list xs ys" arbitrary p q @qed

subsection \<open>List copy\<close>

partial_function (heap) copy_os_list :: "'a::heap os_list \<Rightarrow> 'a os_list Heap" where
  "copy_os_list b = (case b of
      None \<Rightarrow> return None
    | Some p \<Rightarrow> do {
        v \<leftarrow> !p;
        q \<leftarrow> copy_os_list (nxt v);
        os_prepend (val v) q })"

lemma copy_os_list_rule [hoare_triple]:
  "<os_list xs b> copy_os_list b <\<lambda>r. os_list xs b * os_list xs r>"
@proof @induct xs arbitrary b @qed

subsection \<open>Higher-order functions\<close>

partial_function (heap) map_os_list :: "('a::heap \<Rightarrow> 'a) \<Rightarrow> 'a os_list \<Rightarrow> 'a os_list Heap" where
  "map_os_list f b = (case b of
      None \<Rightarrow> return None
    | Some p \<Rightarrow> do {
        v \<leftarrow> !p;
        q \<leftarrow> map_os_list f (nxt v);
        p := Node (f (val v)) q;
        return (Some p) })"

lemma map_os_list_rule [hoare_triple]:
  "<os_list xs b> map_os_list f b <os_list (map f xs)>"
@proof @induct xs arbitrary b @qed

partial_function (heap) filter_os_list :: "('a::heap \<Rightarrow> bool) \<Rightarrow> 'a os_list \<Rightarrow> 'a os_list Heap" where
  "filter_os_list f b = (case b of
      None \<Rightarrow> return None
    | Some p \<Rightarrow> do {
        v \<leftarrow> !p;
        q \<leftarrow> filter_os_list f (nxt v);
        (if (f (val v)) then do {
           p := Node (val v) q;
           return (Some p) }
         else return q) })"

lemma filter_os_list_rule [hoare_triple]:
  "<os_list xs b> filter_os_list f b <\<lambda>r. os_list (filter f xs) r * true>"
@proof @induct xs arbitrary b @qed

partial_function (heap) filter_os_list2 :: "('a::heap \<Rightarrow> bool) \<Rightarrow> 'a os_list \<Rightarrow> 'a os_list Heap" where
  "filter_os_list2 f b = (case b of
      None \<Rightarrow> return None
    | Some p \<Rightarrow> do {
        v \<leftarrow> !p;
        q \<leftarrow> filter_os_list2 f (nxt v);
        (if (f (val v)) then os_prepend (val v) q
         else return q) })"

lemma filter_os_list2_rule [hoare_triple]:
  "<os_list xs b> filter_os_list2 f b <\<lambda>r. os_list xs b * os_list (filter f xs) r>"
@proof @induct xs arbitrary b @qed

setup \<open>fold add_rewrite_rule @{thms List.fold_simps}\<close>

partial_function (heap) fold_os_list :: "('a::heap \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a os_list \<Rightarrow> 'b \<Rightarrow> 'b Heap" where
  "fold_os_list f b x = (case b of
      None \<Rightarrow> return x
    | Some p \<Rightarrow> do {
       v \<leftarrow> !p;
       r \<leftarrow> fold_os_list f (nxt v) (f (val v) x);
       return r})"

lemma fold_os_list_rule [hoare_triple]:
  "<os_list xs b> fold_os_list f b x <\<lambda>r. os_list xs b * \<up>(r = fold f xs x)>"
@proof @induct xs arbitrary b x @qed

end


theory Typing
  imports Set_Calculus
begin

section \<open>Typing and Branch Expansion\<close>
text \<open>
  In this theory, we prove that the branch expansion rules
  preserve well-typedness.
\<close>

no_notation Set.member  ("(_/ : _)" [51, 51] 50)

lemma types_term_unique: "v \<turnstile> t : l1 \<Longrightarrow> v \<turnstile> t : l2 \<Longrightarrow> l2 = l1"
  apply(induction arbitrary: l2 rule: types_pset_term.induct)
  apply (metis types_pset_term_cases)+
  done

lemma type_of_term_if_types_term:
  "v \<turnstile> t : l \<Longrightarrow> type_of_term v t = l"
  using types_term_unique unfolding type_of_term_def by blast

lemma types_term_if_mem_subterms_term:
  assumes "s \<in> subterms t"
  assumes "v \<turnstile> t : lt"
  shows "\<exists>ls. v \<turnstile> s : ls"
  using assms
  by (induction t arbitrary: s lt) (auto elim: types_pset_term_cases)

lemma is_Var_if_types_term_0: "v \<turnstile> t : 0 \<Longrightarrow> is_Var t"
  by (induction t) (auto elim: types_pset_term_cases)

lemma is_Var_if_urelem': "urelem' v \<phi> t \<Longrightarrow> is_Var t"
  using is_Var_if_types_term_0 by blast

lemma is_Var_if_urelem: "urelem \<phi> t \<Longrightarrow> is_Var t"
  unfolding urelem_def using is_Var_if_urelem' by blast

lemma types_fmD:
  "v \<turnstile> And p q \<Longrightarrow> v \<turnstile> p"
  "v \<turnstile> And p q \<Longrightarrow> v \<turnstile> q"
  "v \<turnstile> Or p q \<Longrightarrow> v \<turnstile> p"
  "v \<turnstile> Or p q \<Longrightarrow> v \<turnstile> q"
  "v \<turnstile> Neg p \<Longrightarrow> v \<turnstile> p"
  "v \<turnstile> Atom a \<Longrightarrow> v \<turnstile> a"
  unfolding types_pset_fm_def using fm.set_intros by auto

lemma types_fmI:
  "v \<turnstile> p \<Longrightarrow> v \<turnstile> q \<Longrightarrow> v \<turnstile> And p q"
  "v \<turnstile> p \<Longrightarrow> v \<turnstile> q \<Longrightarrow> v \<turnstile> Or p q"
  "v \<turnstile> p \<Longrightarrow> v \<turnstile> Neg p"
  "v \<turnstile> a \<Longrightarrow> v \<turnstile> Atom a"
  unfolding types_pset_fm_def using fm.set_intros by auto

lemma types_pset_atom_Member_D:
  assumes "v \<turnstile> s \<in>\<^sub>s f t1 t2" "f \<in> {(\<squnion>\<^sub>s), (\<sqinter>\<^sub>s), (-\<^sub>s)}"
  shows "v \<turnstile> s \<in>\<^sub>s t1" "v \<turnstile> s \<in>\<^sub>s t2"
proof -
  from assms obtain ls where
    "v \<turnstile> s : ls" "v \<turnstile> f t1 t2 : Suc ls"
    using types_pset_atom.simps by fastforce
  with assms have "v \<turnstile> s \<in>\<^sub>s t1 \<and> v \<turnstile> s \<in>\<^sub>s t2"
    by (auto simp: types_pset_atom.simps elim: types_pset_term_cases)
  then show "v \<turnstile> s \<in>\<^sub>s t1" "v \<turnstile> s \<in>\<^sub>s t2"
    by blast+
qed

lemmas types_pset_atom_Member_Union_D = types_pset_atom_Member_D[where ?f="(\<squnion>\<^sub>s)", simplified]
   and types_pset_atom_Member_Inter_D = types_pset_atom_Member_D[where ?f="(\<sqinter>\<^sub>s)", simplified]
   and types_pset_atom_Member_Diff_D = types_pset_atom_Member_D[where ?f="(-\<^sub>s)", simplified]

lemma types_term_if_mem_subterms:
  fixes \<phi> :: "'a pset_fm"
  assumes "v \<turnstile> \<phi>"
  assumes "f t1 t2 \<in> subterms \<phi>" "f \<in> {(\<squnion>\<^sub>s), (\<sqinter>\<^sub>s), (-\<^sub>s)}"
  obtains lt where "v \<turnstile> t1 : lt" "v \<turnstile> t2 : lt"
proof -
  from assms obtain a :: "'a pset_atom" where atom: "v \<turnstile> a" "f t1 t2 \<in> subterms a"
    unfolding types_pset_fm_def by (induction \<phi>) auto
  obtain t' l where "v \<turnstile> t' : l" "f t1 t2 \<in> subterms t'"
    apply(rule types_pset_atom.cases[OF \<open>v \<turnstile> a\<close>])
    using atom(2) by auto
  then obtain lt where "v \<turnstile> t1 : lt \<and> v \<turnstile> t2 : lt"
    by (induction t' arbitrary: l)
       (use assms(3) in \<open>auto elim: types_pset_term_cases\<close>)
  with that show ?thesis
    by blast
qed

lemma types_if_types_Member_and_subterms:
  fixes \<phi> :: "'a pset_fm"
  assumes "v \<turnstile> s \<in>\<^sub>s t1 \<or> v \<turnstile> s \<in>\<^sub>s t2" "v \<turnstile> \<phi>"
  assumes "f t1 t2 \<in> subterms \<phi>" "f \<in> {(\<squnion>\<^sub>s), (\<sqinter>\<^sub>s), (-\<^sub>s)}"
  shows "v \<turnstile> s \<in>\<^sub>s f t1 t2"
proof -
  from types_term_if_mem_subterms[OF assms(2-)] obtain lt where lt:
    "v \<turnstile> t1 : lt" "v \<turnstile> t2 : lt"
    by blast
  moreover from assms(1) lt(1,2) obtain ls where "v \<turnstile> s : ls" "lt = Suc ls"
    by (auto simp: types_pset_atom.simps dest: types_term_unique)
  ultimately show ?thesis
    using assms
    by (auto simp: types_pset_term.intros types_pset_atom.simps)
qed

lemma types_subst_tlvl:
  fixes l :: "'a pset_atom"
  assumes "v \<turnstile> AT (t1 =\<^sub>s t2)" "v \<turnstile> l"
  shows "v \<turnstile> subst_tlvl t1 t2 l"
proof -
  from assms obtain lt where "v \<turnstile> t1 : lt" "v \<turnstile> t2 : lt"
    by (auto simp: types_pset_atom.simps dest!: types_fmD(6))
  with assms(2) show ?thesis
    by (cases "(t1, t2, l)" rule: subst_tlvl.cases)
       (auto simp: types_pset_atom.simps dest: types_term_unique)
qed

lemma types_sym_Equal:
  assumes "v \<turnstile> t1 =\<^sub>s t2"
  shows "v \<turnstile> t2 =\<^sub>s t1"
  using assms by (auto simp: types_pset_atom.simps)

lemma types_lexpands:
  fixes \<phi> :: "'a pset_fm"
  assumes "lexpands b' b" "b \<noteq> []" "\<phi> \<in> set b'"
  assumes "\<And>(\<phi> :: 'a pset_fm). \<phi> \<in> set b \<Longrightarrow> v \<turnstile> \<phi>"
  shows "v \<turnstile> \<phi>"
  using assms
proof(induction rule: lexpands.induct)
  case (1 b' b)
  then show ?case
    apply(induction rule: lexpands_fm.induct)
          apply(force dest: types_fmD intro: types_fmI(3))+
    done
next
  case (2 b' b)
  then show ?case
  proof(induction rule: lexpands_un.induct)
    case (1 s t1 t2 b)
    then show ?thesis
      by (auto dest!: types_fmD(5,6) "1"(4) intro!: types_fmI(2,3,4)
               intro: types_pset_atom_Member_Union_D)
  next
    case (2 s t1 b t2)
    then have "v \<turnstile> last b"
      by auto
    from types_if_types_Member_and_subterms[OF _ this] 2 show ?case
      by (auto dest!: "2"(5) types_fmD(6) intro: types_fmI(4))
  next
    case (3 s t2 b t1)
    then have "v \<turnstile> last b"
      by auto
    from types_if_types_Member_and_subterms[OF _ this] 3 show ?case
      by (auto dest!: "3"(5) types_fmD(6) intro: types_fmI(4))
  next
    case (4 s t1 t2 b)
    then show ?case
      by (auto dest!: types_fmD(5,6) "4"(5) intro!: types_fmI(2,3,4)
               intro: types_pset_atom_Member_Union_D)
  next
    case (5 s t1 t2 b)
    then show ?case
      by (auto dest!: types_fmD(5,6) "5"(5) intro!: types_fmI(2,3,4)
               intro: types_pset_atom_Member_Union_D)
  next
    case (6 s t1 b t2)
    then have "v \<turnstile> last b"
      by auto
    note types_if_types_Member_and_subterms[where ?f="(\<squnion>\<^sub>s)", OF _ this "6"(3), simplified]
    with 6 show ?case
      by (auto dest!: types_fmD(5,6) "6"(6) intro!: types_fmI(2,3,4))
  qed
next
  case (3 b' b)
  then show ?case
  proof(induction rule: lexpands_int.induct)
    case (1 s t1 t2 b)
    then show ?thesis
      by (auto dest!: types_fmD(5,6) "1"(4) intro!: types_fmI(2,3,4)
               intro: types_pset_atom_Member_Inter_D)
  next
    case (2 s t1 b t2)
    then have "v \<turnstile> last b"
      by auto
    from types_if_types_Member_and_subterms[OF _ this] 2 show ?case
      by (auto dest!: "2"(5) types_fmD(5,6) intro!: types_fmI(3,4))
  next
    case (3 s t2 b t1)
    then have "v \<turnstile> last b"
      by auto
    from types_if_types_Member_and_subterms[OF _ this] 3 show ?case
      by (auto dest!: "3"(5) types_fmD(5,6) intro!: types_fmI(3,4))
  next
    case (4 s t1 t2 b)
    then show ?case
      by (auto dest!: types_fmD(5,6) "4"(5) intro!: types_fmI(2,3,4)
               intro: types_pset_atom_Member_Inter_D)
  next
    case (5 s t1 t2 b)
    then show ?case
      by (auto dest!: types_fmD(5,6) "5"(5) intro!: types_fmI(2,3,4)
               intro: types_pset_atom_Member_Inter_D)
  next
    case (6 s t1 b t2)
    then have "v \<turnstile> last b"
      by auto
    note types_if_types_Member_and_subterms[where ?f="(\<sqinter>\<^sub>s)", OF _ this "6"(3), simplified]
    with 6 show ?case
      by (auto dest!: types_fmD(5,6) "6"(6) intro!: types_fmI(2,3,4))
  qed
next
  case (4 b' b)
  then show ?case
    proof(induction rule: lexpands_diff.induct)
    case (1 s t1 t2 b)
    then show ?thesis
      by (auto dest!: types_fmD(5,6) "1"(4) intro!: types_fmI(2,3,4)
               intro: types_pset_atom_Member_Diff_D)
  next
    case (2 s t1 b t2)
    then have "v \<turnstile> last b"
      by auto
    from types_if_types_Member_and_subterms[OF _ this] 2 show ?case
      by (auto dest!: "2"(5) types_fmD(5,6) intro!: types_fmI(3,4))
  next
    case (3 s t2 b t1)
    then have "v \<turnstile> last b"
      by auto
    from types_if_types_Member_and_subterms[OF _ this] 3 show ?case
      by (auto dest!: "3"(5) types_fmD(5,6) intro!: types_fmI(3,4))
  next
    case (4 s t1 t2 b)
    then show ?case
      by (auto dest!: types_fmD(5,6) "4"(5) intro!: types_fmI(2,3,4)
               intro: types_pset_atom_Member_Diff_D)
  next
    case (5 s t1 t2 b)
    then show ?case
      by (auto dest!: types_fmD(5,6) "5"(5) intro!: types_fmI(2,3,4)
               intro: types_pset_atom_Member_Diff_D)
  next
    case (6 s t1 b t2)
    then have "v \<turnstile> last b"
      by auto
    note types_if_types_Member_and_subterms[where ?f="(-\<^sub>s)", OF _ this "6"(3), simplified]
    with 6 show ?case
      by (auto dest!: types_fmD(5,6) "6"(6) intro!: types_fmI(2,3,4))
  qed
next
  case (5 b' b)
  then show ?case
  proof(cases rule: lexpands_single.cases)
    case (1 t1)
    with 5 have "v \<turnstile> last b"
      by auto
    with \<open>Single t1 \<in> subterms (last b)\<close> obtain a :: "'a pset_atom"
      where atom: "a \<in> atoms (last b)" "Single t1 \<in> subterms a" "v \<turnstile> a"
      unfolding types_pset_fm_def by (metis UN_E subterms_fm_def)
    obtain t' l where "Single t1 \<in> subterms t'" "v \<turnstile> t' : l"
      apply(rule types_pset_atom.cases[OF \<open>v \<turnstile> a\<close>])
      using atom(2) by auto
    note types_term_if_mem_subterms_term[OF this]
    then obtain lt1 where "v \<turnstile> t1 : lt1" "v \<turnstile> Single t1 : Suc lt1"
      by (metis types_pset_term_cases(3))
    with 5 1 show ?thesis
      using types_pset_atom.intros(2) types_pset_fm_def by fastforce
  qed (auto simp: types_pset_atom.simps elim!: types_pset_term_cases
            dest!: types_fmD(5,6) "5"(4) intro!: types_fmI(3,4))
next
  case (6 b' b)
  then show ?case
  proof(cases rule: lexpands_eq.cases)
    case (5 s t s')
    with 6 show ?thesis
      by (auto 0 3 dest!: "6"(4) types_fmD(5,6) dest: types_term_unique
                   simp: types_pset_atom.simps types_term_unique intro!: types_fmI(3,4))
  qed (auto simp: types_sym_Equal dest!: "6"(4) types_fmD(5,6)
            intro!: types_fmI(3,4) types_subst_tlvl)
qed

lemma types_bexpands_nowit:
  fixes \<phi> :: "'a pset_fm"
  assumes "bexpands_nowit bs' b" "b' \<in> bs'" "\<phi> \<in> set b'"
  assumes "\<And>(\<phi> :: 'a pset_fm). \<phi> \<in> set b \<Longrightarrow> v \<turnstile> \<phi>"
  shows "v \<turnstile> \<phi>"
  using assms(1)
proof(cases rule: bexpands_nowit.cases)
  case (1 p q)
  from assms "1"(2) show ?thesis
    unfolding "1"(1)
    by (auto dest!: assms(4) types_fmD(3) intro!: types_fmI(3))
next
  case (2 p q)
  from assms "2"(2) show ?thesis
    unfolding "2"(1)
    by (auto dest!: assms(4) types_fmD(5) dest: types_fmD(1,2) intro!: types_fmI(3))
next
  case (3 s t1 t2)
  from assms "3"(2,3) show ?thesis
    unfolding "3"(1) using types_pset_atom_Member_Union_D(1)[of v s t1 t2]
    by (auto dest!: types_fmD(6) assms(4) intro!: types_fmI(3,4))
next
  case (4 s t1 t2)
  with assms have "v \<turnstile> last b"
    by (metis empty_iff empty_set last_in_set)
  from assms "4"(2,3) show ?thesis
    unfolding "4"(1)
    using types_if_types_Member_and_subterms[where ?f="(\<sqinter>\<^sub>s)", OF _ \<open>v \<turnstile> last b\<close> "4"(3),
                                             THEN types_pset_atom_Member_Inter_D(2)]
    by (force dest!: types_fmD(6) assms(4) intro!: types_fmI(3,4))
next
  case (5 s t1 t2)
  with assms have "v \<turnstile> last b"
    by (metis empty_iff empty_set last_in_set)
  from assms "5"(2,3) show ?thesis
    unfolding "5"(1)
    using types_if_types_Member_and_subterms[where ?f="(-\<^sub>s)", OF _ \<open>v \<turnstile> last b\<close> "5"(3),
                                             THEN types_pset_atom_Member_Diff_D(2)]
    by (force dest!: types_fmD(6) assms(4) intro!: types_fmI(3,4))
qed

lemma types_term_if_on_vars_eq:
  assumes "\<forall>x \<in> vars t. v' x = v x"
  shows "v' \<turnstile> t : l \<longleftrightarrow> v \<turnstile> t : l"
  using assms
  apply(induction t arbitrary: l)
       apply(auto intro!: types_pset_term_intros' types_pset_term.intros(4-)
                  elim!: types_pset_term_cases)
  done

lemma types_pset_atom_if_on_vars_eq:
  fixes a :: "'a pset_atom"
  assumes "\<forall>x \<in> vars a. v' x = v x"
  shows "v' \<turnstile> a \<longleftrightarrow> v \<turnstile> a"
  using assms
  by (auto simp: ball_Un types_pset_atom.simps dest!: types_term_if_on_vars_eq)

lemma types_pset_fm_if_on_vars_eq:
  fixes \<phi> :: "'a pset_fm"
  assumes "\<forall>x \<in> vars \<phi>. v' x = v x"
  shows "v' \<turnstile> \<phi> \<longleftrightarrow> v \<turnstile> \<phi>"
  using assms types_pset_atom_if_on_vars_eq
  unfolding types_pset_fm_def vars_fm_def by fastforce

lemma types_term_fun_upd:
  assumes "x \<notin> vars t"
  shows "v(x := l) \<turnstile> t : l \<longleftrightarrow> v \<turnstile> t : l"
  using assms types_term_if_on_vars_eq by (metis fun_upd_other)

lemma types_pset_atom_fun_upd:
  fixes a :: "'a pset_atom"
  assumes "x \<notin> vars a"
  shows "v(x := l) \<turnstile> a \<longleftrightarrow> v \<turnstile> a"
  using assms types_pset_atom_if_on_vars_eq by (metis fun_upd_other)

lemma types_pset_fm_fun_upd:
  fixes \<phi> :: "'a pset_fm"
  assumes "x \<notin> vars \<phi>"
  shows "v(x := l) \<turnstile> \<phi> \<longleftrightarrow> v \<turnstile> \<phi>"
  using assms types_pset_fm_if_on_vars_eq by (metis fun_upd_other)

lemma types_bexpands_wit:
  fixes b :: "'a branch" and bs' :: "'a branch set"
  assumes "bexpands_wit t1 t2 x bs' b" "b \<noteq> []"
  assumes "\<And>(\<phi> :: 'a pset_fm). \<phi> \<in> set b \<Longrightarrow> v \<turnstile> \<phi>"
  obtains l where "\<forall>\<phi> \<in> set b. v(x := l) \<turnstile> \<phi>"
                  "\<forall>b' \<in> bs'. \<forall>\<phi> \<in> set b'. v(x := l) \<turnstile> \<phi>"
  using assms(1)
proof(cases rule: bexpands_wit.cases)
  case 1
  from assms(3)[OF "1"(2)] obtain lt where lt: "v \<turnstile> t1 : lt" "v \<turnstile> t2 : lt"
    by (auto dest!: types_fmD simp: types_pset_atom.simps)
  with 1 assms(2,3) have "lt \<noteq> 0"
    unfolding urelem_def using last_in_set by metis
  with lt obtain ltp where ltp: "v \<turnstile> t1 : Suc ltp" "v \<turnstile> t2 : Suc ltp"
    using not0_implies_Suc by blast
  with assms(3) have "\<forall>\<phi> \<in> set b. v(x := ltp) \<turnstile> \<phi>"
    using types_pset_fm_fun_upd \<open>x \<notin> vars b\<close> by (metis vars_fm_vars_branchI)
  moreover from \<open>x \<notin> vars b\<close> \<open>AF (t1 =\<^sub>s t2) \<in> set b\<close> have not_in_vars: "x \<notin> vars t1" "x \<notin> vars t2"
    using assms(2) by (auto simp: vars_fm_vars_branchI)
  from this[THEN types_term_fun_upd] have "\<forall>b' \<in> bs'. \<forall>\<phi> \<in> set b'. v(x := ltp) \<turnstile> \<phi>"
    using ltp unfolding "1"(1)
    apply(auto intro!: types_fmI types_pset_term_intros'(2) simp: types_pset_atom.simps)
    apply (metis fun_upd_same fun_upd_upd types_pset_term.intros(2))+
    done
  ultimately show ?thesis
    using that by blast
qed

lemma types_expandss:
  fixes b b' :: "'a branch"
  assumes "expandss b' b" "b \<noteq> []"
  assumes "\<And>\<phi>. \<phi> \<in> set b \<Longrightarrow> v \<turnstile> \<phi>"
  obtains v' where "\<forall>x \<in> vars b. v' x = v x" "\<forall>\<phi> \<in> set b'. v' \<turnstile> \<phi>"
  using assms
proof(induction b' b arbitrary: thesis rule: expandss.induct)
  case (1 b)
  then show ?case by blast
next
  case (2 b3 b2 b1)
  then obtain v' where v': "\<forall>x \<in> vars b1. v' x = v x" "\<forall>\<phi> \<in> set b2. v' \<turnstile> \<phi>"
    by blast
  with types_lexpands[OF \<open>lexpands b3 b2\<close>] have "\<forall>\<phi> \<in> set b3. v' \<turnstile> \<phi>"
    using expandss_not_Nil[OF \<open>expandss b2 b1\<close> \<open>b1 \<noteq> []\<close>] by blast
  with v' "2.prems" show ?case
    by force
next
  case (3 bs b2 b3 b1)
  then obtain v' where v': "\<forall>x \<in> vars b1. v' x = v x" "\<forall>\<phi> \<in> set b2. v' \<turnstile> \<phi>"
    by blast
  from \<open>bexpands bs b2\<close> show ?case
  proof(cases rule: bexpands.cases)
    case 1
    from types_bexpands_nowit[OF this] v' \<open>b3 \<in> bs\<close> have "\<forall>\<phi> \<in> set b3. v' \<turnstile> \<phi>"
      by blast
    with v' "3.prems" show ?thesis
      by force
  next
    case (2 t1 t2 x)
    from types_bexpands_wit[OF this] v' \<open>b3 \<in> bs\<close> obtain l
      where "\<forall>\<phi> \<in> set b3. v'(x := l) \<turnstile> \<phi>"
      using expandss_not_Nil[OF \<open>expandss b2 b1\<close> \<open>b1 \<noteq> []\<close>] by metis
    moreover from bexpands_witD(9)[OF 2] have "x \<notin> vars b1"
      using expandss_mono[OF \<open>expandss b2 b1\<close>] unfolding vars_branch_def by blast
    then have "\<forall>y \<in> vars b1. (v'(x := l)) y = v y"
      using v'(1) by simp
    moreover from \<open>x \<notin> vars b2\<close> v'(2) have "\<forall>\<phi> \<in> set b2. v'(x := l) \<turnstile> \<phi>"
      by (meson types_pset_fm_fun_upd vars_fm_vars_branchI)
    ultimately show ?thesis
      using v' "3.prems"(1)[where ?v'="v'(x := l)"] by fastforce
  qed
qed

lemma urelem_invar_if_wf_branch:
  assumes "wf_branch b"
  assumes "urelem (last b) x" "x \<in> subterms (last b)"
  shows "\<exists>v. \<forall>\<phi> \<in> set b. urelem' v \<phi> x"
proof -
  from assms obtain v where v: "v \<turnstile> last b" "v \<turnstile> x : 0"
    unfolding urelem_def by blast
  moreover from assms have "expandss b [last b]"
    by (metis expandss_last_eq last.simps list.distinct(1) wf_branch_def)
  from types_expandss[OF this, simplified] v obtain v' where
    "\<forall>x \<in> vars (last b). v' x = v x" "\<forall>\<phi> \<in> set b. v' \<turnstile> \<phi>"
    by (metis list.set_intros(1) vars_fm_vars_branchI)
  ultimately show ?thesis
    unfolding urelem_def using assms
    by (metis mem_vars_fm_if_mem_subterms_fm types_term_if_on_vars_eq)
qed

lemma not_types_term_0_if_types_term:
  fixes s :: "'a pset_term"
  assumes "f t1 t2 \<in> subterms s" "f \<in> {(\<sqinter>\<^sub>s), (\<squnion>\<^sub>s), (-\<^sub>s)}"
  assumes "v \<turnstile> f t1 t2 : l"
  shows "\<not> v \<turnstile> t1 : 0" "\<not> v \<turnstile> t2 : 0"
  using assms
  by (induction s arbitrary: l)
     (auto elim: types_pset_term_cases dest: types_term_unique)

lemma types_term_subterms:
  assumes "t \<in> subterms s"
  assumes "v \<turnstile> s : ls"
  obtains lt where "v \<turnstile> t : lt"
  using assms
  by (induction s arbitrary: ls) (auto elim: types_pset_term_cases dest: types_term_unique)

lemma types_atom_subterms:
  fixes a :: "'a pset_atom"
  assumes "t \<in> subterms a"
  assumes "v \<turnstile> a"
  obtains lt where "v \<turnstile> t : lt"
  using assms
  by (cases a) (fastforce elim: types_term_subterms simp: types_pset_atom.simps)+

lemma subterms_type_pset_fm_not_None:
  fixes \<phi> :: "'a pset_fm"
  assumes "t \<in> subterms \<phi>"
  assumes "v \<turnstile> \<phi>"
  obtains lt where "v \<turnstile> t : lt"
  using assms
  by (induction \<phi>) (auto elim: types_atom_subterms dest: types_fmD(1-5) dest!: types_fmD(6))

lemma not_urelem_comps_if_compound:
  assumes "f t1 t2 \<in> subterms \<phi>" "f \<in> {(\<sqinter>\<^sub>s), (\<squnion>\<^sub>s), (-\<^sub>s)}"
  shows "\<not> urelem \<phi> t1" "\<not> urelem \<phi> t2"
proof -
  from assms have "\<not> v \<turnstile> t1 : 0" "\<not> v \<turnstile> t2 : 0" if "v \<turnstile> \<phi>" for v
    using that not_types_term_0_if_types_term[OF _ _ subterms_type_pset_fm_not_None]
    using subterms_refl by metis+
  then show "\<not> urelem \<phi> t1" "\<not> urelem \<phi> t2"
    unfolding urelem_def by blast+
qed

end