(*<*)
theory Backward_Reasoning
  imports Main
begin
(*>*)

section \<open>Backward reasoning\<close>

subsection \<open>Isabelle/ML interfaces\<close>

text \<open>
  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>Goal.prove\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>ctxt\<close> : \<^ML_type>\<open>Proof.context\<close>)\\
  (\<open>vars\<close> : \<^ML_type>\<open>string list\<close>)\\
  (\<open>asms\<close> : \<^ML_type>\<open>term list\<close>)\\
  (\<open>prop\<close> : \<^ML_type>\<open>term\<close>)\\
  (\<open>tacf\<close> : \<^ML_type>\<open>{prems: thm list, context: Proof.context} -> tactic\<close>) :\\
  \<^ML_type>\<open>thm\<close>
  \end{tabular}\\
  A convenient shortcut to prove theorems of the form \<open>\<lbrakk>A\<^sub>1 \<^bold>x; \<dots>; A\<^sub>n \<^bold>x\<rbrakk> \<Longrightarrow> B \<^bold>x\<close>, where \<open>\<^bold>x\<close> (\<open>vars\<close>) are the outer
  (would-be schematic) variables of the theorem to be generalized, \<open>A\<^sub>1 \<^bold>x; \<dots>; A\<^sub>n \<^bold>x\<close> (\<open>asms\<close>) are auxiliary premises
  (\<open>prems\<close>) to be later lifted to assumptions, and \<open>B \<^bold>x\<close> (\<open>prop\<close>) is the conclusion. \<open>context\<close> is the inner context with
  the assumptions explicitly given as premises (\<open>prems\<close>) and the variables properly fixed and assumed. E.\,g.:
\<close>
ML \<open>
  Goal.prove \<^context> ["A", "B"] [\<^prop>\<open>A\<close>] \<^prop>\<open>B \<Longrightarrow> A \<and> B\<close>
    (fn {context=ctxt, prems=[A]} =>
          HEADGOAL (REPEAT_ALL_NEW (resolve_tac ctxt [@{thm conjI}, A]) THEN' assume_tac ctxt)
       | _ => raise Match)
\<close>
text \<open>
  The resulting theorem is \<open>?A \<Longrightarrow> ?B \<Longrightarrow> ?A \<and> ?B\<close>.
  This can be illustrated as follows:\\
  context:\\
  \tab{}A\\
  state:\\
  \tab{}\begin{tabular}{l}
  \<open>B \<Longrightarrow> A \<and> B\<close>\\
  \hline
  \<open>B \<Longrightarrow> A \<and> B\<close>
  \end{tabular}\\
  Or, for simplicity: \<open>A \<turnstile> B \<Longrightarrow> A \<and> B\<close>. What's below the line (the outermost implication) is always the original
  conjecture, so it's omitted for brevity. Meanwhile, the above part is gradually transformed by the tactics. When the
  above part becomes empty (which is equivalent to identical truth), the conjecture below the line becomes a theorem.
  The proof proceeds as follows:\\
  \tab\begin{tabular}{ll}
  \<open>A \<turnstile> B \<Longrightarrow> A \<and> B\<close>&           \<open>\<Midarrow>resolve with \<open>conjI\<close>\<Rightarrow>\<close>\\
  \<open>A \<turnstile> B \<Longrightarrow> A &&& B \<Longrightarrow> B\<close>&   \<open>\<Midarrow>resolve head goal with \<open>A\<close>\<Rightarrow>\<close>\\
  \<open>A \<turnstile> B \<Longrightarrow> B\<close>&               \<open>\<Midarrow>assume\<Rightarrow>\<close>\\
  \<open>A \<turnstile> \<top>\<close>& \<open>\<top>\<close> designates an empty outermost premise
  \end{tabular}\\
  After the proof, the premise \<^term>\<open>A\<close> is lifted to an assumption \<open>A \<Longrightarrow> _\<close> and the variables \<open>A\<close> and \<open>B\<close> are
  generalized and become schematic.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>type\<close> \<^ML_type>\<open>tactic\<close> = \<^ML_type>\<open>thm -> thm Seq.seq\<close> \\
  The Isabelle/ML type for \<^emph>\<open>tactics\<close> i.\,e. functions non-deterministically transforming the goal state e.\,g.\\
  \<open>B \<Longrightarrow> B\<close> is transformed to \<open>\<top>\<close> by the \<^ML>\<open>assume_tac\<close> or \<open>x \<in> {u} \<Longrightarrow> y \<in> {v} \<Longrightarrow> T\<close> is transformed to either
  \<open>y \<in> {v} \<Longrightarrow> x = u \<Longrightarrow> T\<close> or \<open>x \<in> {u} \<Longrightarrow> y = v \<Longrightarrow> T\<close> by \<open>eresolve_tac \<^context> [@{thm singletonE}]\<close>. The
  resulting \<^emph>\<open>lazily computed\<close> sequence contains all possible resulting states emerging from applying the tactic and
  can be potentially infinite.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>Local_Defs.unfold_tac\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>ctxt\<close> : \<^ML_type>\<open>Proof.context\<close>)\\
  (\<open>thms\<close> : \<^ML_type>\<open>thm list\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  Unfolds definitions represented by the specified theorems (\<open>thms\<close>) as equalities (\<open>LHS = RHS\<close> or\\ \<open>LHS \<equiv> RHS\<close>)
  \<^emph>\<open>everywhere\<close> in \<^emph>\<open>all\<close> subgoals of the proof state.
\<close>
text\<open>
  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>assume_tac\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>ctxt\<close> : \<^ML_type>\<open>Proof.context\<close>)\\
  (\<open>goal\<close> : \<^ML_type>\<open>int\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  Solves the subgoal with number \<open>goal\<close> (counted starting from 1) by unifying its conclusion with one of the premises
  e.\,g. \<open>A \<Longrightarrow> \<dots> \<Longrightarrow> D \<Longrightarrow> \<dots> \<Longrightarrow> Z \<Longrightarrow> D\<close>, i.\,e. corresponds to the use of a trivial implication of the
  form \<open>A \<Longrightarrow> A\<close>. It's considered a better practice to specify the subgoal index implicitly using some tactical,
  such as \<^ML>\<open>HEADGOAL\<close>.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>HEADGOAL\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>tac\<close> : \<^ML_type>\<open>int -> tactic\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  Applies the tactic \<open>tac\<close> to the first subgoal of the proof state.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>resolve_tac\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>ctxt\<close> : \<^ML_type>\<open>Proof.context\<close>)\\
  (\<open>thms\<close> : \<^ML_type>\<open>thm list\<close>)\\
  (\<open>goal\<close> : \<^ML_type>\<open>int\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  Transforms subgoal with index \<open>goal\<close> by resolving its conclusion with the conclusion of one of the theorems
  in the list \<open>thms\<close>. Tries all possible unifiers, then all possible theorems in the list in order. The premises
  of the theorems in \<open>thms\<close> become new subgoals \<^emph>\<open>replacing\<close> the target subgoal. E.\,g.
  \<open>resolve_tac \<^context> [@{thm UnI1}, @{thm UnI2}]\<close> will transform \<open>x \<in> A \<Longrightarrow> y \<in> B \<Longrightarrow> A \<union> B \<close> to either
  \<open>x \<in> A \<Longrightarrow> x \<in> B \<Longrightarrow> x \<in> A\<close> or \<open>x \<in> A \<Longrightarrow> x \<in> B \<Longrightarrow> x \<in> B\<close> (in that order).
  \<open>resolve_tac \<^context> [@{thm IntI}]\<close>, on
  the other hand, will transform \<open>x \<in> A \<Longrightarrow> x \<in> B \<Longrightarrow> x \<in> A \<inter> B\<close> to
  \<open>x \<in> A \<Longrightarrow> x \<in> B \<Longrightarrow> x \<in> A &&& x \<in> A \<Longrightarrow> x \<in> B \<Longrightarrow> x \<in> B\<close> (two emerging subgoals). The tactic is often used
  in combination with \<^ML>\<open>assume_tac\<close> and the \<^ML>\<open>THEN\<close> combinator.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>infix 1 THEN\<close>\\
  \<^ML_text>\<open>val\<close> \<^ML>\<open>THEN\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>tacs\<close> : \<^ML_type>\<open>tactic * tactic\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  Sequential combination of tactics. Applies two tactics in order, but returns the sequence of all
  possible \<^emph>\<open>successful\<close> applications of the second tactic to one of the resulting states returned by the first one.
  Thus it automatically filters out unsuccessful attempts and provides a mechanism for proof search with backtracking.
  E.\,g. \<open>HEADGOAL (resolve_tac \<^context> [@{thm UnI1}, @{thm UnI2}]) THEN HEADGOAL (assume_tac \<^context>)\<close> will
  succeed on the subgoal \<open>x \<in> B \<Longrightarrow> x \<in> A \<union> B\<close>, even though the first attempt will result in an intermediate state
  \<open>x \<in> B \<Longrightarrow> x \<in> A\<close>, which cannot be solved by assumption.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>infix 1 THEN'\<close>\\
  \<^ML_text>\<open>val\<close> \<^ML>\<open>THEN'\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>tacs\<close> : \<^ML_type>\<open>(int -> tactic) * (int -> tactic)\<close>)\\
  (\<open>goal\<close> : \<^ML_type>\<open>int\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  A version of \<^ML>\<open>THEN\<close> for goal-specific tactics (with a \<open>goal\<close> parameter), equivalent to
  \<open>fn x => tac\<^sub>1 x THEN tac\<^sub>2 x\<close> i.\,e. the goal index is always the same.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>infix 1 THEN_ALL_NEW\<close>\\
  \<^ML_text>\<open>val\<close> \<^ML>\<open>THEN_ALL_NEW\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>tacs\<close> : \<^ML_type>\<open>(int -> tactic) * (int -> tactic)\<close>)\\
  (\<open>goal\<close> : \<^ML_type>\<open>int\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  Structural combination of tactics: apply the second tactic to all subgoals emerging from application of the first
  one. Supports backtracking and enumerates all possible outcomes.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>REPEAT_ALL_NEW\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>tac\<close> : \<^ML_type>\<open>(int -> tactic)\<close>)\\
  (\<open>goal\<close> : \<^ML_type>\<open>int\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  Repeats application of \<open>tac\<close> as in \<open>tac THEN_ALL_NEW tac \<dots> THEN_ALL_NEW tac\<close> until an empty sequence is returned,
  then returns the last resulting state. Also supports backtrackingm thus returning all possible terminal states (where
  no further application of the tactic is possible anymore).

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>solve_tac\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>ctxt\<close> : \<^ML_type>\<open>Proof.context\<close>)\\
  (\<open>thms\<close> : \<^ML_type>\<open>thm list\<close>)\\
  (\<open>goal\<close> : \<^ML_type>\<open>int\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  A shorthand for \<open>resolve_tac ctxt thms THEN_ALL_NEW assume_tac ctxt\<close>. Convenient for applying
  theorems with several premises that can be solved by assumption.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>hyp_subst_tac\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>ctxt\<close> : \<^ML_type>\<open>Proof.context\<close>)\\
  (\<open>goal\<close> : \<^ML_type>\<open>int\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  Rewrite all assumptions and the conclusion of the subgoal \<open>goal\<close> using the first encountered
  assumption of the form \<open>x = t\<close>, where \<open>x\<close> is a variable and \<open>t\<close> is a term. Also \<^emph>\<open>delete\<close> the assumption
  \<open>x = t\<close> afterwards. E.\,g. \<open>x = y \<Longrightarrow> P (f x) \<Longrightarrow> C\<close> becomes \<open>P (f y) \<Longrightarrow> C\<close>. For a more sophisticated substitutions
  using assumed equalities, a full higher-order unification should be employed using the simplifier or the
  following \<^ML>\<open>eresolve_tac\<close> tactic.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>eresolve_tac\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>ctxt\<close> : \<^ML_type>\<open>Proof.context\<close>)\\
  (\<open>thms\<close> : \<^ML_type>\<open>thm list\<close>)\\
  (\<open>goal\<close> : \<^ML_type>\<open>int\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  Applies an \<^emph>\<open>elimination rule\<close> of the form \<open>A \<Longrightarrow> (\<And> \<^bold>x. B \<^bold>x \<Longrightarrow> ?T \<^bold>z) \<Longrightarrow> ?T \<^bold>y\<close> by replacing the subgoal
  \<open>A \<Longrightarrow> C \<Longrightarrow> D \<^bold>y\<close>
  with the subgoal \<open>\<And> \<^bold>x. C \<Longrightarrow> B \<^bold>x \<Longrightarrow> D \<^bold>z\<close>, i.~e. the meta-quantified variables \<open>\<^bold>x\<close> are introduced into the resulting
  subgoal, the context \<open>B \<^bold>x\<close> is assumed, the goal is substituted with the variables \<open>\<^bold>z\<close> and the assumption \<open>A\<close> is
  \<^emph>\<open>deleted\<close>. E.\,g. resolving with
  the theorem \<^prop>\<open>\<lbrakk>s = t; P s\<rbrakk> \<Longrightarrow> P t\<close> will substitute \<open>t\<close> for \<open>s\<close> in the conclusion of the subgoal \<open>goal\<close>
  given the assumption \<open>s = t\<close>, whereas resolving with the theorem \<^prop>\<open>\<lbrakk>s = t; P s; P t \<Longrightarrow> T\<rbrakk> \<Longrightarrow> T\<close> will
  substitute \<open>t\<close> for \<open>s\<close> in \<^emph>\<open>some\<close> of the assumptions given the same assumption \<open>s = t\<close>. Again, the tactic returns
  a lazy sequence of all possible resulting proof states (arising due to non-deterministic unification, choice of
  assumptions for resolution or choice of the theorem from the list \<open>thms\<close>). The tactic is often combined with the
  following theorem transformer function \<^ML>\<open>make_elim\<close>.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>make_elim\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>thm\<close> : \<^ML_type>\<open>thm\<close>) :\\
  \<^ML_type>\<open>thm\<close>
  \end{tabular}\\
  Transforms a theorem of the form \<open>A \<Longrightarrow> B\<close> into an elimination rule \<open>A \<Longrightarrow> (B \<Longrightarrow> T) \<Longrightarrow> T\<close>. Combining this
  with \<^ML>\<open>resolve_tac\<close> and \<^ML>\<open>assume_tac\<close> is essentially equivalent to the following \<^emph>\<open>forward resolution\<close> tactic.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>forward_tac\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>ctxt\<close> : \<^ML_type>\<open>Proof.context\<close>)\\
  (\<open>thms\<close> : \<^ML_type>\<open>thm list\<close>)\\
  (\<open>goal\<close> : \<^ML_type>\<open>int\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  Forward resolution. Try to solve the \<^emph>\<open>major\<close> (first) premise of a theorem in \<open>thms\<close> by assumption,
  then return the subgoals
  for solving other (\<^emph>\<open>minor\<close>) premises and the subgoal with the conclusion of the theorem added as an assumption.
  E.\,g. given the state \<open>x = y \<Longrightarrow> y = z \<Longrightarrow> C\<close>, forward resolution \<open>forward_tac \<^context> [@{thm trans}]\<close>
  (@{thm trans[no_vars]}) will result in
  two subgoals: \<open>x = y \<Longrightarrow> y = z \<Longrightarrow> y = ?t &&& x = y \<Longrightarrow> y = z \<Longrightarrow> x = ?t \<Longrightarrow> C\<close>. Here \<open>?t\<close> is a schematic variable
  and it can be further instantiated to any term e.\,g. by some resolution tactic such as \<^ML>\<open>assume_tac\<close>. Note that
  the schematic variable occurring in the proof state (the goal) are \<^emph>\<open>existentially\<close> quantified i.\,e. it's sufficient
  to provide a proof with \<^emph>\<open>some\<close> instantiation of such a variable.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>Method.insert_tac\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>ctxt\<close> : \<^ML_type>\<open>Proof.context\<close>)\\
  (\<open>thms\<close> : \<^ML_type>\<open>thm list\<close>)\\
  (\<open>goal\<close> : \<^ML_type>\<open>int\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  Simply insert the theorems \<open>thms\<close> as assumptions into the specified subgoal \<open>goal\<close>.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>EqSubst.eqsubst_tac\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>ctxt\<close> : \<^ML_type>\<open>Proof.context\<close>)\\
  (\<open>occs\<close> : \<^ML_type>\<open>int list\<close>)\\
  (\<open>thms\<close> : \<^ML_type>\<open>thm list\<close>)\\
  (\<open>goal\<close> : \<^ML_type>\<open>int\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  Given a selection of possible conditional equalities of the form \<open>C \<Longrightarrow> LHS = RHS\<close>,
  rewrite the specified occurrences \<open>occs\<close> of the
  \<open>LHS\<close> in the \<^emph>\<open>conclusion\<close> of the subgoal \<open>goal\<close> to \<open>RHS\<close>, leaving the pre-condition \<open>C\<close> as a new subgoal. Only the
  first applicable theorem in \<open>thms\<close> is used. The
  occurrences are counted starting from \<open>1\<close>, \<open>0\<close> designated \<^emph>\<open>any\<close> occurrence. The subgoal for the pre-condition \<open>C\<close>
  is posed \<^emph>\<open>before\<close> the substituted initial subgoal \<open>goal\<close>. E.\,g. applying
  \<open>EqSubst.eqsubst_tac \<^context> [0] [@{thm arg_cong[where f=F]}]\<close> (@{thm arg_cong})
  to the subgoal \<open>x = t \<Longrightarrow> P (F x) = P (F t)\<close> will result
  in a state \<open>x = t \<Longrightarrow> ?x = ?y &&& x = t \<Longrightarrow> P (F ?y) = P (F t)\<close>. The instantiation \<open>[where f=F]\<close> can be preformed
  using the function \<^ML>\<open>infer_instantiate'\<close>.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>infer_instantiate'\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>ctxt\<close> : \<^ML_type>\<open>Proof.context\<close>)\\
  (\<open>subs\<close> : \<^ML_type>\<open>cterm option list\<close>)\\
  (\<open>thms\<close> : \<^ML_type>\<open>thm\<close>) :\\
  \<^ML_type>\<open>thm\<close>
  \end{tabular}\\
  Instantiate the theorem \<open>thm\<close> with the terms \<open>subs\<close>, substituting the schematic variables from left to right
  and leaving the unspecified variables (designated as \<open>NONE\<close>s) as is.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>EqSubst.eqsubst_asm_tac\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>ctxt\<close> : \<^ML_type>\<open>Proof.context\<close>)\\
  (\<open>occs\<close> : \<^ML_type>\<open>int list\<close>)\\
  (\<open>thms\<close> : \<^ML_type>\<open>thm list\<close>)\\
  (\<open>goal\<close> : \<^ML_type>\<open>int\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  Same as \<^ML>\<open>EqSubst.eqsubst_tac\<close>, but performs substitutions in the assumptions of the subgoal \<open>goal\<close>.
\<close>
text\<open>
  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>Induct_Tacs.case_tac\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>ctxt\<close> : \<^ML_type>\<open>Proof.context\<close>)\\
  (\<open>term\<close> : \<^ML_type>\<open>string\<close>)\\
  (\<open>fixes\<close> : \<^ML_type>\<open>(binding * string option * mixfix) list\<close>)\\
  (\<open>rule\<close> : \<^ML_type>\<open>thm option\<close>)\\
  (\<open>goal\<close> : \<^ML_type>\<open>int\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  Applies case-splitting/induction rule instantiated \<^emph>\<open>within local subgoal context\<close>. Normally, an induction or
  case-splitting rule is just an elimination rule of the form \<open>A \<Longrightarrow> (B \<Longrightarrow> T) \<Longrightarrow> (C \<Longrightarrow> T) \<Longrightarrow> T\<close>. E.\,g.
  @{thm finite_induct[no_vars]} (\<open>@{thm finite_induct\<close>). However, there are two problems regarding
  instantiation of such elimination rules:
  \<^item> First, the substituted terms e.\,g. the term for the finite set \<open>F\<close>, may depend on the local variables bound in the
    current subgoal, such as in \<open>\<And> u v. finite u \<Longrightarrow> finite v \<Longrightarrow> P (F u v)\<close>, where the desired term \<open>F u v\<close> depends on
    bound variables \<open>u\<close> and \<open>v\<close> that \<^emph>\<open>do not exist\<close> in the outer context \<open>ctxt\<close> or \<open>\<^context>\<close> and therefore cannot be
    specified by usual means.
  \<^item> Second, the substituted terms may contain nested schematic variables e.\,g. \<open>P (F ?u ?v)\<close> that are to be
    instantiated later, possibly implicitly by applying some resolution tactics such as \<^ML>\<open>assume_tac\<close>. This is useful
    for specifying big complex terms by only outlining their external skeleton.

  To address those issues, the term \<open>term\<close> for case analysis is passed as a \<^emph>\<open>string\<close>, which is interpreted in the
  special local subgoal context extended with declaration of subgoal-specific quantified variables and
  fixed constants provided in \<open>fixes\<close> that are later turned into schematic variables.
  The case-splitting/induction rule can be omitted
  if the default rule for the type of the term \<open>term\<close> is used (e.\,g. the rule \<open>@{thm case_split}\<close>
  (@{thm case_split[no_vars]}) for type \<^typ>\<open>bool\<close>).
  The default rules are specified using the attribute @{attribute cases}.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>Lin_Arith.tac\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>ctxt\<close> : \<^ML_type>\<open>Proof.context\<close>)\\
  (\<open>goal\<close> : \<^ML_type>\<open>int\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  Prove the subgoal \<open>goal\<close> by solving a system of linear arithmetic inequalities. The conjunction of the
  assumptions with the negation of the conclusion must be unsatisfiable. Supports all types of class
  \<^class>\<open>linordered_idom\<close>, including \<open>int\<close>.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>type\<close> \<^ML_type>\<open>attribute\<close> = \<^ML_type>\<open>Context.generic * thm -> Context.generic option * thm option\<close> \\
  A type of \<^emph>\<open>attributes\<close>, i.~e. functions that simultaneously transform a theorem and the corresponding context.
  Attributes can both modify the theorem (e.\,g. they can transform it into an elimination rule, atomize, rulify etc.)
  and change some components of the shared state in the context e.\,g. by registring a case-splitting rule or
  symmetry rule.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>Thm.proof_attributes\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>atts\<close> : \<^ML_type>\<open>attribute list\<close>) \\
  (\<open>thm\<close> : \<^ML_type>\<open>thm\<close>) \\
  (\<open>ctxt\<close> : \<^ML_type>\<open>Proof.context\<close>) :\\
  \<^ML_type>\<open>thm * Proof.context\<close>
  \end{tabular}\\
  A function to apply a list of attributes \<open>atts\<close> (in order) in the proof context \<open>ctxt\<close> and obtain the transformed
  theorem (the same theorem, if the attribute returns \<open>NONE\<close>) and the context.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>Calculation.symmetric\<close> : \<^ML_type>\<open>attribute\<close>\\
  This attribute transforms theorems with an equality in the conclusion by swapping the sides of the equality.
  \<open>A \<Longrightarrow> x = y\<close> will become \<open>A \<Longrightarrow> y = x\<close>. Useful in combination with substitution tactics such as
  \<^ML>\<open>EqSubst.eqsubst_tac\<close> and \<^ML>\<open>EqSubst.eqsubst_asm_tac\<close>. The particular equality is specified using an attribute
  @{attribute sym} for a theorem of the form \<open>a = b \<Longrightarrow> b = a\<close>, so the attribute is slightly more general and,
  in particular, also supports disequalities (\<open>a \<noteq> b \<Longrightarrow> b \<noteq> a\<close>).
\<close>
text \<open>

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>ALLGOALS\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>tac\<close> : \<^ML_type>\<open>int -> tactic\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  A tactic combinator (\<^emph>\<open>tactical\<close>) to apply a subgoal-specific tactic (with a \<open>goal\<close> parameter) to all subgoals
  of the current proof state.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>RANGE\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>tacs\<close> : \<^ML_type>\<open>(int -> tactic) list\<close>)\\
  (\<open>goal\<close> : \<^ML_type>\<open>int\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  A tactical that applies subgoal-specific tactics to the \<^emph>\<open>corresponding\<close> subgoals, starting from the subgoal
  at index \<open>goal\<close>. This is quite convenient to convey proof trees with several sub-branches to clearly delimit
  the proof branches from each other. The \<open>i\<close>-th element of the list \<open>tacs\<close> (counting from \<open>0\<close>) is applied to
  the subgoal with index \<open>goal + i\<close>, where subgoals are counted from \<open>1\<close>.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>EVERY\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>tacs\<close> : \<^ML_type>\<open>tactic list\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  A shortcut for \<open>tac\<^sub>1 THEN tac\<^sub>2 ... THEN tac\<^sub>n\<close>.

  \<^bigskip>

  \marginsymbol
  \<^ML_text>\<open>val\<close> \<^ML>\<open>EVERY'\<close>\\
  \tab\begin{tabular}{ll}
  (\<open>tac\<close> : \<^ML_type>\<open>('a -> tactic) list\<close>)\\
  (\<open>x\<close> : \<^ML_type>\<open>'a\<close>) :\\
  \<^ML_type>\<open>tactic\<close>
  \end{tabular}\\
  A shortcut for \<open>fn i \<Rightarrow> tac\<^sub>1 i THEN tac\<^sub>2 i ... THEN tac\<^sub>n i\<close> (consequtive application of tactics to the same subgoal).

  \<^bigskip>
  More tactics can be found in the module \<open>Tactic\<close> (implemented in file \<^file>\<open>~~/src/Pure/tactic.ML\<close>) and throughout
  the Isabelle sources, usually with the suffix \<open>_tac\<close>. More
  tacticals can be found in module \<open>Tactical\<close> (implemented in \<^file>\<open>~~/src/Pure/tactical.ML\<close>).
\<close>

subsection \<open>Theorems\<close>

text \<open>
\begin{tabular}{rl}
  \<open>set_eq_iff\<close>:& @{thm set_eq_iff[no_vars]}\\
  \<open>not_all\<close>:& @{thm not_all[no_vars]}\\
  \<open>HOL.nnf_simps(5)\<close>:& @{thm HOL.nnf_simps(5)[no_vars]}\\
  \<open>subst\<close>:& @{thm subst[no_vars]}\\
  \<open>Diff_iff\<close>:& @{thm Diff_iff[no_vars]}\\
  \<open>DiffI\<close>:& @{thm DiffI[no_vars]}\\
  \<open>someI\<close>:& @{thm someI[no_vars]}\\
  \<open>exE\<close>:& @{thm exE[no_vars]}\\
  \<open>notE\<close>:& @{thm notE[no_vars]}\\
  \<open>emptyE\<close>:& @{thm emptyE[no_vars]}\\
  \<open>UnE\<close>:& @{thm UnE[no_vars]}\\
  \<open>disjE\<close>:& @{thm disjE[no_vars]}\\
  \<open>conjE\<close>:& @{thm conjE[no_vars]}\\
  \<open>IntE\<close>:& @{thm IntE[no_vars]}\\
  \<open>IntI\<close>:& @{thm IntI[no_vars]}\\
  \<open>conj_commute\<close>:& @{thm conj_commute[no_vars]}\\
  \<open>singletonE\<close>:& @{thm singletonE[no_vars]}\\
  \<open>singletonI\<close>:& @{thm singletonI[no_vars]}\\
\end{tabular}
\<close>

subsection \<open>Problems\<close>

text \<open>
  \<^enum> Define (using \<^ML>\<open>Sign.declare_const_global\<close> and \<^ML>\<open>Global_Theory.add_defs\<close>)
    an auxiliary skolem function \<open>w\<close> arising from skolemization of the theorem
    \<^prop>\<open>s \<noteq> t \<Longrightarrow> \<exists> x. x \<in> s - t \<or> x \<in> t - s\<close>. Use the Hilbert epsilon operator \<^const>\<open>Eps\<close> that has a designated
    syntax \<^term>\<open>SOME x. P x\<close>.
  \<^enum> Prove the following theorem: \<open>set_neqD\<close>: \<^prop>\<open>s \<noteq> t \<Longrightarrow> w s t \<in> s \<and> w s t \<notin> t \<or> w s t \<notin> s \<and> w s t \<in> t\<close> for the
    skolem function \<open>w\<close> above. Use backward (tactical) reasoning in pure Isabelle/ML and the function \<^ML>\<open>Goal.prove\<close>.
  \<^enum> Prove the following theorem: \<open>sample1\<close>: \<^prop>\<open>x \<in> {1} \<union> {2} \<Longrightarrow> x \<le> (2 :: int)\<close> using tactical reasoning.
  \<^enum> Prove an auxiliary property \<open>member_neqI\<close>: \<^prop>\<open>x \<in> A \<Longrightarrow> y \<notin> A \<Longrightarrow> x \<noteq> y\<close> using tactical reasoning.
  \<^enum> Using the auxiliary properties \<open>set_neqD\<close> and \<open>member_neqI\<close>, prove the following theorem:
    \<^prop>\<open>\<lbrakk>4 < u; u < 6; u \<in> x \<union> y; x \<inter> {5 :: int} \<noteq> {5}; z = {}\<rbrakk> \<Longrightarrow> y - z \<noteq> {}\<close>. The proof is non-trivial and
    the corresponding proof tree can be found in the paper \<open>Calogero G. Zarba. Combining Sets with Elements\<close> on page
    \<open>13\<close>. Use tactical reasoning and structure the proof tree using the \<^ML>\<open>RANGE\<close> and \<^ML>\<open>EVERY'\<close> tacticals.

You can help yourself by using tactical reasoning in Isabelle GUI with commands @{command apply} and @{command by}.
Also, a special tactic @{method tactic} can be used to apply a tactic implemented in pure ML e.\,g.:
\<close>
lemma "A \<Longrightarrow> A" apply (tactic \<open>HEADGOAL (assume_tac \<^context>)\<close>) done

subsection \<open>Solutions\<close>

subsubsection \<open>Problem 1\<close>

setup \<open>Sign.declare_const_global ((\<^binding>\<open>w\<close>, \<^typ>\<open>'a set \<Rightarrow> 'a set \<Rightarrow> 'a\<close>), NoSyn) #> snd\<close>

setup \<open>
   pair (\<^binding>\<open>w_def\<close>, \<^term>\<open>w s t \<equiv> SOME x. x \<in> s - t \<or> x \<in> t - s\<close>)
   #>> Thm.simple_fact #-> Global_Theory.add_defs false #> snd
\<close>

thm w_def

subsubsection \<open>Problem 2\<close>

experiment begin
lemma set_neqD:
  "s \<noteq> t \<Longrightarrow> w s t \<in> s \<and> w s t \<notin> t \<or> w s t \<notin> s \<and> w s t \<in> t"
  apply (unfold set_eq_iff not_all HOL.nnf_simps(5))
  apply (elim exE)
  apply (subst (asm) (2) conj_commute)
  apply (subst (2) conj_commute)
  apply (unfold w_def Diff_iff[symmetric])
  by (intro someI)
end

ML \<open>
  val prove_set_neqD =
    Goal.prove \<^context> ["s", "t"] []
      \<^prop>\<open>s \<noteq> t \<Longrightarrow> w s t \<in> s \<and> w s t \<notin> t \<or> w s t \<notin> s \<and> w s t \<in> t\<close>
      (fn { context=ctxt, ... } =>
        Local_Defs.unfold_tac ctxt [@{thm set_eq_iff}, @{thm not_all}, @{thm HOL.nnf_simps(5)}]
        THEN HEADGOAL (eresolve_tac ctxt [@{thm exE}])
        THEN HEADGOAL (EqSubst.eqsubst_asm_tac ctxt [2] [@{thm conj_commute}])
        THEN HEADGOAL (EqSubst.eqsubst_tac ctxt [2] [@{thm conj_commute}])
        THEN Local_Defs.unfold_tac
          ctxt
          [@{thm w_def}, Thm.proof_attributes [Calculation.symmetric] @{thm Diff_iff} ctxt |> fst]
        THEN HEADGOAL (solve_tac ctxt [@{thm someI}])) |>
    pair \<^binding>\<open>set_neqD\<close> |> Global_Theory.store_thm #> snd
\<close>

setup \<open>prove_set_neqD\<close>
thm set_neqD

subsubsection \<open>Problem 3\<close>

experiment begin
lemma sample1: "x \<in> {1} \<union> {2} \<Longrightarrow> x \<le> (2 :: int)"
  apply (elim UnE singletonE)
  by (linarith)+
end

ML \<open>
  val prove_sample1 =
    Goal.prove \<^context> ["x"] []
      \<^prop>\<open>x \<in> {1} \<union> {2} \<Longrightarrow> x \<le> (2 :: int)\<close>
      (fn { context=ctxt, ... } =>
        HEADGOAL (REPEAT_ALL_NEW (eresolve_tac ctxt [@{thm UnE}, @{thm singletonE}])) THEN
        ALLGOALS (Lin_Arith.tac ctxt))
    |> pair \<^binding>\<open>sample1\<close> |> Global_Theory.store_thm #> snd
\<close>

setup \<open>prove_sample1\<close>
thm sample1

subsubsection \<open>Problem 4\<close>

experiment begin
lemma member_neqI: "x \<in> A \<Longrightarrow> y \<notin> A \<Longrightarrow> x \<noteq> y"
  apply (cases "x = y")
   apply hypsubst
  by (erule (1) notE)
end

ML \<open>
  val prove_member_neqI =
    Goal.prove \<^context> ["x", "y", "A", "B"] []
      \<^prop>\<open>x \<in> A \<Longrightarrow> y \<notin> A \<Longrightarrow> x \<noteq> y\<close>
      (fn { context=ctxt, ... } =>
        HEADGOAL (Induct_Tacs.case_tac ctxt "x = y" [] NONE)
        THEN HEADGOAL (hyp_subst_tac ctxt)
        THEN HEADGOAL (eresolve_tac ctxt [@{thm notE}])
        THEN ALLGOALS (assume_tac ctxt)) |>
    pair \<^binding>\<open>member_neqI\<close> |> Global_Theory.store_thm #> snd
\<close>

setup \<open>prove_member_neqI\<close>
thm member_neqI

subsubsection \<open>Problem 5\<close>

experiment begin
lemma sample2: "\<lbrakk>4 < u; u < 6; u \<in> x \<union> y; x \<inter> {5 :: int} \<noteq> {5}; z = {}\<rbrakk> \<Longrightarrow> y - z \<noteq> {}"
  apply (elim UnE set_neqD[elim_format])
   apply (elim disjE conjE IntE)
    apply (erule (1) notE)
   apply (elim singletonE)
   apply (insert singletonI[of 5])
   apply (cases "5 \<in> x")
    apply (frule (1) IntI[where A=x and B="{5}"])
    apply (frule (1) member_neqI)
    apply linarith
   apply (cases "u = 5")
    apply hypsubst
    apply (erule (1) notE)
   apply linarith
  apply (cases "u \<in> z")
   apply hypsubst
   apply (erule emptyE)
  apply (frule (1) DiffI)
  apply (intro notI)
  apply (erule (1) subst[where P="\<lambda> x. _ \<in> x", elim_format])
  apply (erule emptyE)
  done
end

ML \<open>
  val prove_sample2 =
    Goal.prove \<^context> ["u", "x", "y", "z"] []
      \<^prop>\<open>\<lbrakk>4 < u; u < 6; u \<in> x \<union> y; x \<inter> {5 :: int} \<noteq> {5}; z = {}\<rbrakk> \<Longrightarrow> y - z \<noteq> {}\<close>
      (fn { context=ctxt, ... } =>
        HEADGOAL (REPEAT_ALL_NEW (eresolve_tac ctxt [@{thm UnE}, make_elim @{thm set_neqD}]))
        THEN HEADGOAL (REPEAT_ALL_NEW (eresolve_tac ctxt [@{thm disjE}, @{thm conjE}, @{thm IntE}]))
        THEN HEADGOAL
          (RANGE
            [solve_tac ctxt [@{thm notE}],
             EVERY'
               [eresolve_tac ctxt [@{thm singletonE}],
                Method.insert_tac ctxt [@{thm singletonI} |> infer_instantiate' ctxt [SOME \<^cterm>\<open>5 :: int\<close>]],
                Induct_Tacs.case_tac ctxt "5 \<in> x" [] NONE,
                RANGE
                  [EVERY'
                    [forward_tac ctxt [@{thm IntI}],
                     assume_tac ctxt,
                     forward_tac ctxt [@{thm member_neqI}],
                     assume_tac ctxt,
                     Lin_Arith.tac ctxt],
                   EVERY'
                    [forward_tac ctxt [@{thm member_neqI}],
                     assume_tac ctxt,
                     Lin_Arith.tac ctxt]]],

             EVERY'
               [Induct_Tacs.case_tac ctxt "u \<in> z" [] NONE,
                RANGE
                  [EVERY'
                    [hyp_subst_tac ctxt,
                     eresolve_tac ctxt [@{thm emptyE}]],
                   EVERY'
                    [forward_tac ctxt [@{thm DiffI}],
                     assume_tac ctxt,
                     resolve_tac ctxt [@{thm notI}],
                     eresolve_tac ctxt [@{thm subst} |> make_elim],
                     assume_tac ctxt,
                     eresolve_tac ctxt [@{thm emptyE}]]]]])) |>
    pair \<^binding>\<open>sample2\<close> |> Global_Theory.store_thm #> snd
\<close>

setup \<open>prove_sample2\<close>
thm sample2

(*<*)
end
(*>*)


theory Numbers_Nat
imports "$HETS_LIB/Isabelle/MainHC"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"sub_dom_Nat\", \"divide_dom_Nat\", \"div_dom_Nat\",
     \"mod_dom_Nat\", \"distr1_Nat\", \"distr2_Nat\", \"ga_select_pre\",
     \"X1_def_Nat\", \"X2_def_Nat\", \"X3_def_Nat\", \"X4_def_Nat\",
     \"X5_def_Nat\", \"X6_def_Nat\", \"X7_def_Nat\", \"X8_def_Nat\",
     \"X9_def_Nat\", \"decimal_def\", \"leq_def1_Nat\",
     \"leq_def2_Nat\", \"leq_def3_Nat\", \"geq_def_Nat\",
     \"less_def_Nat\", \"greater_def_Nat\", \"even_0_Nat\",
     \"even_suc_Nat\", \"odd_def_Nat\", \"factorial_0\",
     \"factorial_suc\", \"add_0_Nat\", \"add_suc_Nat\", \"mult_0_Nat\",
     \"mult_suc_Nat\", \"power_0_Nat\", \"power_suc_Nat\",
     \"min_def_Nat\", \"max_def_Nat\", \"subTotal_def1_Nat\",
     \"subTotal_def2_Nat\", \"sub_def_Nat\", \"divide_0_Nat\",
     \"divide_Pos_Nat\", \"div_Nat\", \"mod_Nat\"]"

datatype Nat = X0 ("0''") | X_suc "Nat" ("suc/'(_')" [3] 999)

consts
X1 :: "Nat" ("1''")
X2 :: "Nat" ("2")
X3 :: "Nat" ("3")
X4 :: "Nat" ("4")
X5 :: "Nat" ("5")
X6 :: "Nat" ("6")
X7 :: "Nat" ("7")
X8 :: "Nat" ("8")
X9 :: "Nat" ("9")
X__XAtXAt__X :: "Nat => Nat => Nat" ("(_/ @@/ _)" [54,54] 52)
X__XCaret__X :: "Nat => Nat => Nat" ("(_/ ^''/ _)" [54,54] 52)
X__XExclam :: "Nat => Nat" ("(_/ !'')" [58] 58)
X__XGtXEq__X :: "Nat => Nat => bool" ("(_/ >=''/ _)" [44,44] 42)
X__XGt__X :: "Nat => Nat => bool" ("(_/ >''/ _)" [44,44] 42)
X__XLtXEq__X :: "Nat => Nat => bool" ("(_/ <=''/ _)" [44,44] 42)
X__XLt__X :: "Nat => Nat => bool" ("(_/ <''/ _)" [44,44] 42)
X__XMinusXExclam__X :: "Nat => Nat => Nat" ("(_/ -!/ _)" [54,54] 52)
X__XMinusXQuest__X :: "Nat => Nat => Nat option" ("(_/ -?/ _)" [54,54] 52)
X__XPlus__X :: "Nat => Nat => Nat" ("(_/ +''/ _)" [54,54] 52)
X__XSlashXQuest__X :: "Nat => Nat => Nat option" ("(_/ '/?/ _)" [54,54] 52)
X__Xx__X :: "Nat => Nat => Nat" ("(_/ *''/ _)" [54,54] 52)
X__div__X :: "Nat => Nat => Nat option" ("(_/ div''/ _)" [54,54] 52)
X__mod__X :: "Nat => Nat => Nat option" ("(_/ mod''/ _)" [54,54] 52)
X_even :: "Nat => bool" ("even''/'(_')" [3] 999)
X_max :: "Nat => Nat => Nat" ("max''/'(_,/ _')" [3,3] 999)
X_min :: "Nat => Nat => Nat" ("min''/'(_,/ _')" [3,3] 999)
X_odd :: "Nat => bool" ("odd''/'(_')" [3] 999)
X_pre :: "Nat => Nat option" ("pre/'(_')" [3] 999)

instance Nat:: type ..

axioms
ga_select_pre [rule_format] :
"ALL x_1_1. pre(suc(x_1_1)) = Some x_1_1"

X1_def_Nat [rule_format] : "1' = suc(0')"

X2_def_Nat [rule_format] : "2 = suc(1')"

X3_def_Nat [rule_format] : "3 = suc(2)"

X4_def_Nat [rule_format] : "4 = suc(3)"

X5_def_Nat [rule_format] : "5 = suc(4)"

X6_def_Nat [rule_format] : "6 = suc(5)"

X7_def_Nat [rule_format] : "7 = suc(6)"

X8_def_Nat [rule_format] : "8 = suc(7)"

X9_def_Nat [rule_format] : "9 = suc(8)"

decimal_def [rule_format] :
"ALL m. ALL X_n. m @@ X_n = (m *' suc(9)) +' X_n"

leq_def1_Nat [rule_format] : "ALL X_n. 0' <=' X_n"

leq_def2_Nat [rule_format] : "ALL X_n. ~ suc(X_n) <=' 0'"

leq_def3_Nat [rule_format] :
"ALL m. ALL X_n. (suc(m) <=' suc(X_n)) = (m <=' X_n)"

geq_def_Nat [rule_format] :
"ALL m. ALL X_n. (m >=' X_n) = (X_n <=' m)"

less_def_Nat [rule_format] :
"ALL m. ALL X_n. (m <' X_n) = (m <=' X_n & ~ m = X_n)"

greater_def_Nat [rule_format] :
"ALL m. ALL X_n. (m >' X_n) = (X_n <' m)"

even_0_Nat [rule_format] : "even'(0')"

even_suc_Nat [rule_format] : "ALL m. even'(suc(m)) = odd'(m)"

odd_def_Nat [rule_format] : "ALL m. odd'(m) = (~ even'(m))"

factorial_0 [rule_format] : "0' !' = 1'"

factorial_suc [rule_format] :
"ALL X_n. suc(X_n) !' = suc(X_n) *' X_n !'"

add_0_Nat [rule_format] : "ALL m. 0' +' m = m"

add_suc_Nat [rule_format] :
"ALL m. ALL X_n. suc(X_n) +' m = suc(X_n +' m)"

mult_0_Nat [rule_format] : "ALL m. 0' *' m = 0'"

mult_suc_Nat [rule_format] :
"ALL m. ALL X_n. suc(X_n) *' m = (X_n *' m) +' m"

power_0_Nat [rule_format] : "ALL m. m ^' 0' = 1'"

power_suc_Nat [rule_format] :
"ALL m. ALL X_n. m ^' suc(X_n) = m *' (m ^' X_n)"

min_def_Nat [rule_format] :
"ALL m. ALL X_n. min'(m, X_n) = (if m <=' X_n then m else X_n)"

max_def_Nat [rule_format] :
"ALL m. ALL X_n. max'(m, X_n) = (if m <=' X_n then X_n else m)"

subTotal_def1_Nat [rule_format] :
"ALL m. ALL X_n. m >' X_n --> X_n -! m = 0'"

subTotal_def2_Nat [rule_format] :
"ALL m. ALL X_n. m <=' X_n --> Some (X_n -! m) = X_n -? m"

sub_def_Nat [rule_format] :
"ALL m. ALL X_n. ALL r. m -? X_n = Some r = (m = r +' X_n)"

divide_0_Nat [rule_format] : "ALL m. ~ defOp (m /? 0')"

divide_Pos_Nat [rule_format] :
"ALL m.
 ALL X_n. ALL r. X_n >' 0' --> m /? X_n = Some r = (m = r *' X_n)"

div_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ALL r.
 m div' X_n = Some r = (EX s. m = (X_n *' r) +' s & s <' X_n)"

mod_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ALL s.
 m mod' X_n = Some s = (EX r. m = (X_n *' r) +' s & s <' X_n)"

declare ga_select_pre [simp]
declare leq_def1_Nat [simp]
declare leq_def2_Nat [simp]
declare leq_def3_Nat [simp]
declare even_0_Nat [simp]
declare even_suc_Nat [simp]
declare factorial_0 [simp]
declare add_0_Nat [simp]
declare mult_0_Nat [simp]
declare power_0_Nat [simp]
declare subTotal_def1_Nat [simp]
declare subTotal_def2_Nat [simp]
declare divide_0_Nat [simp]

theorem sub_dom_Nat :
"ALL m. ALL X_n. defOp (m -? X_n) = (m >=' X_n)"
using X1_def_Nat X2_def_Nat X3_def_Nat X4_def_Nat X5_def_Nat X6_def_Nat X7_def_Nat X8_def_Nat X9_def_Nat decimal_def by auto

ML "Header.record \"sub_dom_Nat\""

theorem divide_dom_Nat :
"ALL m.
 ALL X_n. defOp (m /? X_n) = (~ X_n = 0' & m mod' X_n = Some 0')"
using X1_def_Nat X2_def_Nat X3_def_Nat X4_def_Nat X5_def_Nat X6_def_Nat X7_def_Nat X8_def_Nat X9_def_Nat decimal_def by auto

ML "Header.record \"divide_dom_Nat\""

theorem div_dom_Nat :
"ALL m. ALL X_n. defOp (m div' X_n) = (~ X_n = 0')"
using X1_def_Nat X2_def_Nat X3_def_Nat X4_def_Nat X5_def_Nat X6_def_Nat X7_def_Nat X8_def_Nat X9_def_Nat decimal_def by auto

ML "Header.record \"div_dom_Nat\""

theorem mod_dom_Nat :
"ALL m. ALL X_n. defOp (m mod' X_n) = (~ X_n = 0')"
using X1_def_Nat X2_def_Nat X3_def_Nat X4_def_Nat X5_def_Nat X6_def_Nat X7_def_Nat X8_def_Nat X9_def_Nat decimal_def by auto

ML "Header.record \"mod_dom_Nat\""

theorem distr1_Nat :
"ALL r. ALL s. ALL t. (r +' s) *' t = (r *' t) +' (s *' t)"
using X1_def_Nat X2_def_Nat X3_def_Nat X4_def_Nat X5_def_Nat X6_def_Nat X7_def_Nat X8_def_Nat X9_def_Nat decimal_def by auto

ML "Header.record \"distr1_Nat\""

theorem distr2_Nat :
"ALL r. ALL s. ALL t. t *' (r +' s) = (t *' r) +' (t *' s)"
using X1_def_Nat X2_def_Nat X3_def_Nat X4_def_Nat X5_def_Nat X6_def_Nat X7_def_Nat X8_def_Nat X9_def_Nat decimal_def by auto

ML "Header.record \"distr2_Nat\""

end


(*  Title:       Conservation of CSP Noninterference Security under Sequential Composition
    Author:      Pasquale Noce
                 Security Certification Specialist at Arjo Systems, Italy
                 pasquale dot noce dot lavoro at gmail dot com
                 pasquale dot noce at arjosystems dot com
*)

section "Necessity of nontrivial assumptions"

theory Counterexamples
imports SequentialComposition
begin

text \<open>
\null

The security conservation theorem proven in this paper contains two nontrivial assumptions; namely,
the security policy must satisfy predicate @{term secure_termination}, and the first input process
must satisfy predicate @{term sequential} instead of @{term weakly_sequential} alone. This section
shows, by means of counterexamples, that both of these assumptions are necessary for the theorem to
hold.

In more detail, two counterexamples will be constructed: the former drops the termination security
assumption, whereas the latter drops the process sequentiality assumption, replacing it with weak
sequentiality alone. In both cases, all the other assumptions of the theorem keep being satisfied.

Both counterexamples make use of reflexive security policies, which is the case for any policy of
practical significance, and are based on trace set processes as defined in \<^cite>\<open>"R3"\<close>. The security
of the processes input to sequential composition, as well as the insecurity of the resulting
process, are demonstrated by means of the Ipurge Unwinding Theorem proven in \<^cite>\<open>"R3"\<close>.
\<close>

subsection "Preliminary definitions and lemmas"

text \<open>
Both counterexamples will use the same type @{term event} as native type of ordinary events, as well
as the same process @{term Q} as second input to sequential composition. Here below are the
definitions of these constants, followed by few useful lemmas on process @{term Q}.

\null
\<close>

datatype event = a | b

definition Q :: "event option process" where
"Q \<equiv> ts_process {[], [Some b]}"

lemma trace_set_snd:
 "trace_set {[], [Some b]}"
by (simp add: trace_set_def)

lemmas failures_snd = ts_process_failures [OF trace_set_snd]

lemmas traces_snd = ts_process_traces [OF trace_set_snd]

lemmas next_events_snd = ts_process_next_events [OF trace_set_snd]

lemmas unwinding_snd = ts_ipurge_unwinding [OF trace_set_snd]

subsection "Necessity of termination security"

text \<open>
The reason why the conservation of noninterference security under sequential composition requires
the security policy to satisfy predicate @{term secure_termination} is that the second input process
cannot engage in its events unless the first process has terminated successfully. Thus, the ordinary
events of the first process can indirectly affect the events of the second process by affecting the
successful termination of the first process. Therefore, if an ordinary event is allowed to affect
successful termination, then the policy must allow it to affect any other event as well, which is
exactly what predicate @{term secure_termination} states.

A counterexample showing the necessity of this assumption can then be constructed by defining a
reflexive policy @{term I\<^sub>1} that allows event @{term "Some a"} to affect @{term None}, but not
@{term "Some b"}, and a deterministic process @{term P\<^sub>1} that can engage in @{term None} only after
engaging in @{term "Some a"}. The resulting process @{term "P\<^sub>1 ; Q"} will number
@{term "[Some a, Some b]"}, but not @{term "[Some b]"}, among its traces, so that event
@{term "Some a"} affects the occurrence of event @{term "Some b"} in contrast with policy
@{term I\<^sub>1}, viz. @{term "P\<^sub>1 ; Q"} is not secure with respect to @{term I\<^sub>1}.

Here below are the definitions of constants @{term I\<^sub>1} and @{term P\<^sub>1}, followed by few useful lemmas
on process @{term P\<^sub>1}.

\null
\<close>

definition I\<^sub>1 :: "(event option \<times> event option) set" where
"I\<^sub>1 \<equiv> {(Some a, None)}\<^sup>="

definition P\<^sub>1 :: "event option process" where
"P\<^sub>1 \<equiv> ts_process {[], [Some a], [Some a, None]}"

lemma trace_set_fst_1:
 "trace_set {[], [Some a], [Some a, None]}"
by (simp add: trace_set_def)

lemmas failures_fst_1 = ts_process_failures [OF trace_set_fst_1]

lemmas traces_fst_1 = ts_process_traces [OF trace_set_fst_1]

lemmas next_events_fst_1 = ts_process_next_events [OF trace_set_fst_1]

lemmas unwinding_fst_1 = ts_ipurge_unwinding [OF trace_set_fst_1]

text \<open>
\null

Here below is the proof that policy @{term I\<^sub>1} does not satisfy predicate
@{term secure_termination}, whereas the remaining assumptions of the security conservation theorem
keep being satisfied. For the sake of simplicity, the identity function is used as event-domain map.

\null
\<close>

lemma not_secure_termination_1:
 "\<not> secure_termination I\<^sub>1 id"
proof (simp add: secure_termination_def I\<^sub>1_def, rule exI [where x = "Some a"],
 simp)
qed (rule exI [where x = "Some b"], simp)

lemma ref_union_closed_fst_1:
 "ref_union_closed P\<^sub>1"
by (rule d_implies_ruc, subst P\<^sub>1_def, rule ts_process_d, rule trace_set_fst_1)

lemma sequential_fst_1:
 "sequential P\<^sub>1"
proof (simp add: sequential_def sentences_def P\<^sub>1_def traces_fst_1)
qed (simp add: set_eq_iff next_events_fst_1)

lemma secure_fst_1:
 "secure P\<^sub>1 I\<^sub>1 id"
proof (simp add: P\<^sub>1_def unwinding_fst_1 dfc_equals_dwfc_rel_ipurge [symmetric]
 d_future_consistent_def rel_ipurge_def traces_fst_1, (rule allI)+)
  fix u xs ys
  show
   "(xs = [] \<or> xs = [Some a] \<or> xs = [Some a, None]) \<and>
    (ys = [] \<or> ys = [Some a] \<or> ys = [Some a, None]) \<and>
    ipurge_tr_rev I\<^sub>1 id u xs = ipurge_tr_rev I\<^sub>1 id u ys \<longrightarrow>
      next_dom_events (ts_process {[], [Some a], [Some a, None]}) id u xs =
      next_dom_events (ts_process {[], [Some a], [Some a, None]}) id u ys"
  proof (simp add: next_dom_events_def next_events_fst_1, cases u)
    case None
    show
     "(xs = [] \<or> xs = [Some a] \<or> xs = [Some a, None]) \<and>
      (ys = [] \<or> ys = [Some a] \<or> ys = [Some a, None]) \<and>
      ipurge_tr_rev I\<^sub>1 id u xs = ipurge_tr_rev I\<^sub>1 id u ys \<longrightarrow>
        {x. u = x \<and> (xs = [] \<and> x = Some a \<or> xs = [Some a] \<and> x = None)} =
        {x. u = x \<and> (ys = [] \<and> x = Some a \<or> ys = [Some a] \<and> x = None)}"
     by (simp add: I\<^sub>1_def None, rule impI, (erule conjE)+,
      (((erule disjE)+)?, simp)+)
  next
    case (Some v)
    show
     "(xs = [] \<or> xs = [Some a] \<or> xs = [Some a, None]) \<and>
      (ys = [] \<or> ys = [Some a] \<or> ys = [Some a, None]) \<and>
      ipurge_tr_rev I\<^sub>1 id u xs = ipurge_tr_rev I\<^sub>1 id u ys \<longrightarrow>
        {x. u = x \<and> (xs = [] \<and> x = Some a \<or> xs = [Some a] \<and> x = None)} =
        {x. u = x \<and> (ys = [] \<and> x = Some a \<or> ys = [Some a] \<and> x = None)}"
     by (simp add: I\<^sub>1_def Some, rule impI, (erule conjE)+, cases v,
      (((erule disjE)+)?, simp, blast?)+)
  qed
qed

lemma secure_snd_1:
 "secure Q I\<^sub>1 id"
proof (simp add: Q_def unwinding_snd dfc_equals_dwfc_rel_ipurge [symmetric]
 d_future_consistent_def rel_ipurge_def traces_snd, (rule allI)+)
  fix u xs ys
  show
   "(xs = [] \<or> xs = [Some b]) \<and>
    (ys = [] \<or> ys = [Some b]) \<and>
    ipurge_tr_rev I\<^sub>1 id u xs = ipurge_tr_rev I\<^sub>1 id u ys \<longrightarrow>
      next_dom_events (ts_process {[], [Some b]}) id u xs =
      next_dom_events (ts_process {[], [Some b]}) id u ys"
  proof (simp add: next_dom_events_def next_events_snd, cases u)
    case None
    show
     "(xs = [] \<or> xs = [Some b]) \<and>
      (ys = [] \<or> ys = [Some b]) \<and>
      ipurge_tr_rev I\<^sub>1 id u xs = ipurge_tr_rev I\<^sub>1 id u ys \<longrightarrow>
        {x. u = x \<and> xs = [] \<and> x = Some b} = {x. u = x \<and> ys = [] \<and> x = Some b}"
     by (simp add: None, rule impI, (erule conjE)+,
      (((erule disjE)+)?, simp)+)
  next
    case (Some v)
    show
     "(xs = [] \<or> xs = [Some b]) \<and>
      (ys = [] \<or> ys = [Some b]) \<and>
      ipurge_tr_rev I\<^sub>1 id u xs = ipurge_tr_rev I\<^sub>1 id u ys \<longrightarrow>
        {x. u = x \<and> xs = [] \<and> x = Some b} = {x. u = x \<and> ys = [] \<and> x = Some b}"
     by (simp add: I\<^sub>1_def Some, rule impI, (erule conjE)+, cases v,
      (((erule disjE)+)?, simp)+)
  qed
qed

text \<open>
\null

In what follows, the insecurity of process @{term "P\<^sub>1 ; Q"} is demonstrated by proving that event
list @{term "[Some a, Some b]"} is a trace of the process, whereas @{term "[Some b]"} is not.

\null
\<close>

lemma traces_comp_1:
 "traces (P\<^sub>1 ; Q) = Domain (seq_comp_failures P\<^sub>1 Q)"
by (subst seq_comp_traces, rule seq_implies_weakly_seq, rule sequential_fst_1, simp)

lemma ref_union_closed_comp_1:
 "ref_union_closed (P\<^sub>1 ; Q)"
proof (rule seq_comp_ref_union_closed, rule seq_implies_weakly_seq,
 rule sequential_fst_1, rule ref_union_closed_fst_1)
qed (rule d_implies_ruc, subst Q_def, rule ts_process_d, rule trace_set_snd)

lemma not_secure_comp_1_aux_aux_1:
 "(xs, X) \<in> seq_comp_failures P\<^sub>1 Q \<Longrightarrow> xs \<noteq> [Some b]"
proof (rule notI, erule rev_mp, erule seq_comp_failures.induct, (rule_tac [!] impI)+,
 simp_all add: P\<^sub>1_def Q_def sentences_def)
qed (simp_all add: failures_fst_1 traces_fst_1)

lemma not_secure_comp_1_aux_1:
 "[Some b] \<notin> traces (P\<^sub>1 ; Q)"
proof (simp add: traces_comp_1 Domain_iff, rule allI, rule notI)
qed (drule not_secure_comp_1_aux_aux_1, simp)

lemma not_secure_comp_1_aux_2:
 "[Some a, Some b] \<in> traces (P\<^sub>1 ; Q)"
proof (simp add: traces_comp_1 Domain_iff, rule exI [where x = "{}"])
  have "[Some a] \<in> sentences P\<^sub>1"
   by (simp add: P\<^sub>1_def sentences_def traces_fst_1)
  moreover have "([Some b], {}) \<in> failures Q"
   by (simp add: Q_def failures_snd)
  moreover have "[Some b] \<noteq> []"
   by simp
  ultimately have "([Some a] @ [Some b], {}) \<in> seq_comp_failures P\<^sub>1 Q"
   by (rule SCF_R3)
  thus "([Some a, Some b], {}) \<in> seq_comp_failures P\<^sub>1 Q"
   by simp
qed

lemma not_secure_comp_1:
 "\<not> secure (P\<^sub>1 ; Q) I\<^sub>1 id"
proof (subst ipurge_unwinding, rule ref_union_closed_comp_1, simp
 add: fc_equals_wfc_rel_ipurge [symmetric] future_consistent_def rel_ipurge_def
 del: disj_not1, rule exI [where x = "Some b"], rule exI [where x = "[]"], rule conjI)
  show "[] \<in> traces (P\<^sub>1 ; Q)"
   by (rule failures_traces [where X = "{}"], rule process_rule_1)
next
  show "\<exists>ys. ys \<in> traces (P\<^sub>1 ; Q) \<and>
    ipurge_tr_rev I\<^sub>1 id (Some b) [] = ipurge_tr_rev I\<^sub>1 id (Some b) ys \<and>
    (next_dom_events (P\<^sub>1 ; Q) id (Some b) [] \<noteq>
       next_dom_events (P\<^sub>1 ; Q) id (Some b) ys \<or>
     ref_dom_events (P\<^sub>1 ; Q) id (Some b) [] \<noteq>
       ref_dom_events (P\<^sub>1 ; Q) id (Some b) ys)"
  proof (rule exI [where x = "[Some a]"], rule conjI, rule_tac [2] conjI,
   rule_tac [3] disjI1)
    have "[Some a] @ [Some b] \<in> traces (P\<^sub>1 ; Q)"
     by (simp add: not_secure_comp_1_aux_2)
    thus "[Some a] \<in> traces (P\<^sub>1 ; Q)"
     by (rule process_rule_2_traces)
  next
    show "ipurge_tr_rev I\<^sub>1 id (Some b) [] = ipurge_tr_rev I\<^sub>1 id (Some b) [Some a]"
     by (simp add: I\<^sub>1_def)
  next
    show
     "next_dom_events (P\<^sub>1 ; Q) id (Some b) [] \<noteq>
      next_dom_events (P\<^sub>1 ; Q) id (Some b) [Some a]"
    proof (simp add: next_dom_events_def next_events_def set_eq_iff,
     rule exI [where x = "Some b"], simp)
    qed (simp add: not_secure_comp_1_aux_1 not_secure_comp_1_aux_2)
  qed
qed

text \<open>
\null

Here below, the previous results are used to show that constants @{term I\<^sub>1}, @{term P\<^sub>1}, @{term Q},
and @{term id} indeed constitute a counterexample to the statement obtained by removing termination
security from the assumptions of the security conservation theorem.

\null
\<close>

lemma counterexample_1:
 "\<not> (ref_union_closed P\<^sub>1 \<and>
     sequential P\<^sub>1 \<and>
     secure P\<^sub>1 I\<^sub>1 id \<and>
     secure Q I\<^sub>1 id \<longrightarrow>
   secure (P\<^sub>1 ; Q) I\<^sub>1 id)"
proof (simp, simp only: conj_assoc [symmetric], (rule conjI)+)
  show "ref_union_closed P\<^sub>1"
   by (rule ref_union_closed_fst_1)
next
  show "sequential P\<^sub>1"
   by (rule sequential_fst_1)
next
  show "secure P\<^sub>1 I\<^sub>1 id"
   by (rule secure_fst_1)
next
  show "secure Q I\<^sub>1 id"
   by (rule secure_snd_1)
next
  show "\<not> secure (P\<^sub>1 ; Q) I\<^sub>1 id"
   by (rule not_secure_comp_1)
qed

subsection "Necessity of process sequentiality"

text \<open>
The reason why the conservation of noninterference security under sequential composition requires
the first input process to satisfy predicate @{term sequential}, instead of the more permissive
predicate @{term weakly_sequential}, is that the possibility for the first process to engage in
events alternative to successful termination entails the possibility for the resulting process to
engage in events alternative to the initial ones of the second process. Namely, the resulting
process would admit some state in which events of the first process can occur in alternative to
events of the second process. But neither process, though being secure on its own, will in general
be prepared to handle securely the alternative events added by the other process. Therefore, the
first process must not admit alternatives to successful termination, which is exactly what predicate
@{term sequential} states in addition to @{term weakly_sequential}.

A counterexample showing the necessity of this assumption can then be constructed by defining a
reflexive policy @{term I\<^sub>2} that does not allow event @{term "Some b"} to affect @{term "Some a"},
and a deterministic process @{term P\<^sub>2} that can engage in @{term "Some a"} in alternative to
@{term None}. The resulting process @{term "P\<^sub>2 ; Q"} will number both @{term "[Some b]"} and
@{term "[Some a]"}, but not @{term "[Some b, Some a]"}, among its traces, so that event
@{term "Some b"} affects the occurrence of event @{term "Some a"} in contrast with policy
@{term I\<^sub>2}, viz. @{term "P\<^sub>2 ; Q"} is not secure with respect to @{term I\<^sub>2}.

Here below are the definitions of constants @{term I\<^sub>2} and @{term P\<^sub>2}, followed by few useful lemmas
on process @{term P\<^sub>2}.

\null
\<close>

definition I\<^sub>2 :: "(event option \<times> event option) set" where
"I\<^sub>2 \<equiv> {(None, Some a)}\<^sup>="

definition P\<^sub>2 :: "event option process" where
"P\<^sub>2 \<equiv> ts_process {[], [None], [Some a], [Some a, None]}"

lemma trace_set_fst_2:
 "trace_set {[], [None], [Some a], [Some a, None]}"
by (simp add: trace_set_def)

lemmas failures_fst_2 = ts_process_failures [OF trace_set_fst_2]

lemmas traces_fst_2 = ts_process_traces [OF trace_set_fst_2]

lemmas next_events_fst_2 = ts_process_next_events [OF trace_set_fst_2]

lemmas unwinding_fst_2 = ts_ipurge_unwinding [OF trace_set_fst_2]

text \<open>
\null

Here below is the proof that process @{term P\<^sub>2} does not satisfy predicate @{term sequential}, but
rather predicate @{term weakly_sequential} only, whereas the remaining assumptions of the security
conservation theorem keep being satisfied. For the sake of simplicity, the identity function is used
as event-domain map.

\null
\<close>

lemma secure_termination_2:
 "secure_termination I\<^sub>2 id"
by (simp add: secure_termination_def I\<^sub>2_def)

lemma ref_union_closed_fst_2:
 "ref_union_closed P\<^sub>2"
by (rule d_implies_ruc, subst P\<^sub>2_def, rule ts_process_d, rule trace_set_fst_2)

lemma weakly_sequential_fst_2:
 "weakly_sequential P\<^sub>2"
by (simp add: weakly_sequential_def P\<^sub>2_def traces_fst_2)

lemma not_sequential_fst_2:
 "\<not> sequential P\<^sub>2"
proof (simp add: sequential_def, rule disjI2, rule bexI [where x = "[]"])
  show "next_events P\<^sub>2 [] \<noteq> {None}"
  proof (rule notI, drule eqset_imp_iff [where x = "Some a"], simp)
  qed (simp add: P\<^sub>2_def next_events_fst_2)
next
  show "[] \<in> sentences P\<^sub>2"
   by (simp add: sentences_def P\<^sub>2_def traces_fst_2)
qed

lemma secure_fst_2:
 "secure P\<^sub>2 I\<^sub>2 id"
proof (simp add: P\<^sub>2_def unwinding_fst_2 dfc_equals_dwfc_rel_ipurge [symmetric]
 d_future_consistent_def rel_ipurge_def traces_fst_2, (rule allI)+)
  fix u xs ys
  show
   "(xs = [] \<or> xs = [None] \<or> xs = [Some a] \<or> xs = [Some a, None]) \<and>
    (ys = [] \<or> ys = [None] \<or> ys = [Some a] \<or> ys = [Some a, None]) \<and>
    ipurge_tr_rev I\<^sub>2 id u xs = ipurge_tr_rev I\<^sub>2 id u ys \<longrightarrow>
      next_dom_events (ts_process {[], [None], [Some a], [Some a, None]}) id u xs =
      next_dom_events (ts_process {[], [None], [Some a], [Some a, None]}) id u ys"
  proof (simp add: next_dom_events_def next_events_fst_2, cases u)
    case None
    show
     "(xs = [] \<or> xs = [None] \<or> xs = [Some a] \<or> xs = [Some a, None]) \<and>
      (ys = [] \<or> ys = [None] \<or> ys = [Some a] \<or> ys = [Some a, None]) \<and>
      ipurge_tr_rev I\<^sub>2 id u xs = ipurge_tr_rev I\<^sub>2 id u ys \<longrightarrow>
        {x. u = x \<and> (xs = [] \<and> x = None \<or> xs = [] \<and> x = Some a \<or>
          xs = [Some a] \<and> x = None)} =
        {x. u = x \<and> (ys = [] \<and> x = None \<or> ys = [] \<and> x = Some a \<or>
          ys = [Some a] \<and> x = None)}"
     by (simp add: I\<^sub>2_def None, rule impI, (erule conjE)+,
      (((erule disjE)+)?, simp, blast?)+)
  next
    case (Some v)
    show
     "(xs = [] \<or> xs = [None] \<or> xs = [Some a] \<or> xs = [Some a, None]) \<and>
      (ys = [] \<or> ys = [None] \<or> ys = [Some a] \<or> ys = [Some a, None]) \<and>
      ipurge_tr_rev I\<^sub>2 id u xs = ipurge_tr_rev I\<^sub>2 id u ys \<longrightarrow>
        {x. u = x \<and> (xs = [] \<and> x = None \<or> xs = [] \<and> x = Some a \<or>
          xs = [Some a] \<and> x = None)} =
        {x. u = x \<and> (ys = [] \<and> x = None \<or> ys = [] \<and> x = Some a \<or>
          ys = [Some a] \<and> x = None)}"
     by (simp add: I\<^sub>2_def Some, rule impI, (erule conjE)+, cases v,
      (((erule disjE)+)?, simp, blast?)+)
  qed
qed

lemma secure_snd_2:
 "secure Q I\<^sub>2 id"
proof (simp add: Q_def unwinding_snd dfc_equals_dwfc_rel_ipurge [symmetric]
 d_future_consistent_def rel_ipurge_def traces_snd, (rule allI)+)
  fix u xs ys
  show
   "(xs = [] \<or> xs = [Some b]) \<and>
    (ys = [] \<or> ys = [Some b]) \<and>
    ipurge_tr_rev I\<^sub>2 id u xs = ipurge_tr_rev I\<^sub>2 id u ys \<longrightarrow>
      next_dom_events (ts_process {[], [Some b]}) id u xs =
      next_dom_events (ts_process {[], [Some b]}) id u ys"
  proof (simp add: next_dom_events_def next_events_snd, cases u)
    case None
    show
     "(xs = [] \<or> xs = [Some b]) \<and>
      (ys = [] \<or> ys = [Some b]) \<and>
      ipurge_tr_rev I\<^sub>2 id u xs = ipurge_tr_rev I\<^sub>2 id u ys \<longrightarrow>
        {x. u = x \<and> xs = [] \<and> x = Some b} = {x. u = x \<and> ys = [] \<and> x = Some b}"
     by (simp add: None, rule impI, (erule conjE)+,
      (((erule disjE)+)?, simp)+)
  next
    case (Some v)
    show
     "(xs = [] \<or> xs = [Some b]) \<and>
      (ys = [] \<or> ys = [Some b]) \<and>
      ipurge_tr_rev I\<^sub>2 id u xs = ipurge_tr_rev I\<^sub>2 id u ys \<longrightarrow>
        {x. u = x \<and> xs = [] \<and> x = Some b} = {x. u = x \<and> ys = [] \<and> x = Some b}"
     by (simp add: I\<^sub>2_def Some, rule impI, (erule conjE)+, cases v,
      (((erule disjE)+)?, simp)+)
  qed
qed

text \<open>
\null

In what follows, the insecurity of process @{term "P\<^sub>2 ; Q"} is demonstrated by proving that event
lists @{term "[Some b]"} and @{term "[Some a]"} are traces of the process, whereas
@{term "[Some b, Some a]"} is not.

\null
\<close>

lemma traces_comp_2:
 "traces (P\<^sub>2 ; Q) = Domain (seq_comp_failures P\<^sub>2 Q)"
by (subst seq_comp_traces, rule weakly_sequential_fst_2, simp)

lemma ref_union_closed_comp_2:
 "ref_union_closed (P\<^sub>2 ; Q)"
proof (rule seq_comp_ref_union_closed, rule weakly_sequential_fst_2,
 rule ref_union_closed_fst_2)
qed (rule d_implies_ruc, subst Q_def, rule ts_process_d, rule trace_set_snd)

lemma not_secure_comp_2_aux_aux_1:
 "(xs, X) \<in> seq_comp_failures P\<^sub>2 Q \<Longrightarrow> xs \<noteq> [Some b, Some a]"
proof (rule notI, erule rev_mp, erule seq_comp_failures.induct, (rule_tac [!] impI)+,
 simp_all add: P\<^sub>2_def Q_def sentences_def)
qed (simp_all add: failures_fst_2 traces_fst_2 failures_snd)

lemma not_secure_comp_2_aux_1:
 "[Some b, Some a] \<notin> traces (P\<^sub>2 ; Q)"
proof (simp add: traces_comp_2 Domain_iff, rule allI, rule notI)
qed (drule not_secure_comp_2_aux_aux_1, simp)

lemma not_secure_comp_2_aux_2:
 "[Some a] \<in> traces (P\<^sub>2 ; Q)"
proof (simp add: traces_comp_2 Domain_iff, rule exI [where x = "{}"])
  have "[Some a] \<in> sentences P\<^sub>2"
   by (simp add: P\<^sub>2_def sentences_def traces_fst_2)
  moreover have "([Some a], {}) \<in> failures P\<^sub>2"
   by (simp add: P\<^sub>2_def failures_fst_2)
  moreover have "([], {}) \<in> failures Q"
   by (simp add: Q_def failures_snd)
  ultimately have "([Some a], insert None {} \<inter> {}) \<in> seq_comp_failures P\<^sub>2 Q"
   by (rule SCF_R2)
  thus "([Some a], {}) \<in> seq_comp_failures P\<^sub>2 Q"
   by simp
qed

lemma not_secure_comp_2_aux_3:
 "[Some b] \<in> traces (P\<^sub>2 ; Q)"
proof (simp add: traces_comp_2 Domain_iff, rule exI [where x = "{}"])
  have "[] \<in> sentences P\<^sub>2"
   by (simp add: P\<^sub>2_def sentences_def traces_fst_2)
  moreover have "([Some b], {}) \<in> failures Q"
   by (simp add: Q_def failures_snd)
  moreover have "[Some b] \<noteq> []"
   by simp
  ultimately have "([] @ [Some b], {}) \<in> seq_comp_failures P\<^sub>2 Q"
   by (rule SCF_R3)
  thus "([Some b], {}) \<in> seq_comp_failures P\<^sub>2 Q"
   by simp
qed

lemma not_secure_comp_2:
 "\<not> secure (P\<^sub>2 ; Q) I\<^sub>2 id"
proof (subst ipurge_unwinding, rule ref_union_closed_comp_2, simp
 add: fc_equals_wfc_rel_ipurge [symmetric] future_consistent_def rel_ipurge_def
 del: disj_not1, rule exI [where x = "Some a"], rule exI [where x = "[]"], rule conjI)
  show "[] \<in> traces (P\<^sub>2 ; Q)"
   by (rule failures_traces [where X = "{}"], rule process_rule_1)
next
  show "\<exists>ys. ys \<in> traces (P\<^sub>2 ; Q) \<and>
    ipurge_tr_rev I\<^sub>2 id (Some a) [] = ipurge_tr_rev I\<^sub>2 id (Some a) ys \<and>
    (next_dom_events (P\<^sub>2 ; Q) id (Some a) [] \<noteq>
       next_dom_events (P\<^sub>2 ; Q) id (Some a) ys \<or>
     ref_dom_events (P\<^sub>2 ; Q) id (Some a) [] \<noteq>
       ref_dom_events (P\<^sub>2 ; Q) id (Some a) ys)"
  proof (rule exI [where x = "[Some b]"], rule conjI, rule_tac [2] conjI,
   rule_tac [3] disjI1)
    show "[Some b] \<in> traces (P\<^sub>2 ; Q)"
     by (rule not_secure_comp_2_aux_3)
  next
    show "ipurge_tr_rev I\<^sub>2 id (Some a) [] = ipurge_tr_rev I\<^sub>2 id (Some a) [Some b]"
     by (simp add: I\<^sub>2_def)
  next
    show
     "next_dom_events (P\<^sub>2 ; Q) id (Some a) [] \<noteq>
      next_dom_events (P\<^sub>2 ; Q) id (Some a) [Some b]"
    proof (simp add: next_dom_events_def next_events_def set_eq_iff,
     rule exI [where x = "Some a"], simp)
    qed (simp add: not_secure_comp_2_aux_1 not_secure_comp_2_aux_2)
  qed
qed

text \<open>
\null

Here below, the previous results are used to show that constants @{term I\<^sub>2}, @{term P\<^sub>2}, @{term Q},
and @{term id} indeed constitute a counterexample to the statement obtained by replacing process
sequentiality with weak sequentiality in the assumptions of the security conservation theorem.

\null
\<close>

lemma counterexample_2:
 "\<not> (secure_termination I\<^sub>2 id \<and>
     ref_union_closed P\<^sub>2 \<and>
     weakly_sequential P\<^sub>2 \<and>
     secure P\<^sub>2 I\<^sub>2 id \<and>
     secure Q I\<^sub>2 id \<longrightarrow>
   secure (P\<^sub>2 ; Q) I\<^sub>2 id)"
proof (simp, simp only: conj_assoc [symmetric], (rule conjI)+)
  show "secure_termination I\<^sub>2 id"
   by (rule secure_termination_2)
next
  show "ref_union_closed P\<^sub>2"
   by (rule ref_union_closed_fst_2)
next
  show "weakly_sequential P\<^sub>2"
   by (rule weakly_sequential_fst_2)
next
  show "secure P\<^sub>2 I\<^sub>2 id"
   by (rule secure_fst_2)
next
  show "secure Q I\<^sub>2 id"
   by (rule secure_snd_2)
next
  show "\<not> secure (P\<^sub>2 ; Q) I\<^sub>2 id"
   by (rule not_secure_comp_2)
qed

end


section\<open>Relativization of Finite Functions\<close>
theory FiniteFun_Relative
  imports
    Lambda_Replacement
begin

lemma FiniteFunI :
  assumes  "f\<in>Fin(A\<times>B)" "function(f)"
  shows "f \<in> A -||> B"
  using assms
proof(induct)
  case 0
  then show ?case using emptyI by simp
next
  case (cons p f)
  moreover
  from assms this
  have "fst(p)\<in>A" "snd(p)\<in>B" "function(f)"
    using snd_type[OF \<open>p\<in>_\<close>] function_subset
    by auto
  moreover
  from \<open>function(cons(p,f))\<close> \<open>p\<notin>f\<close> \<open>p\<in>_\<close>
  have "fst(p)\<notin>domain(f)"
    unfolding function_def
    by force
  ultimately
  show ?case
    using consI[of "fst(p)" _ "snd(p)"]
    by auto
qed

subsection\<open>The set of finite binary sequences\<close>

text\<open>We implement the poset for adding one Cohen real, the set
$2^{<\omega}$ of finite binary sequences.\<close>

definition
  seqspace :: "[i,i] \<Rightarrow> i" (\<open>_\<^bsup><_\<^esup>\<close> [100,1]100) where
  "B\<^bsup><\<alpha>\<^esup> \<equiv> \<Union>n\<in>\<alpha>. (n\<rightarrow>B)"

lemma seqspaceI[intro]: "n\<in>\<alpha> \<Longrightarrow> f:n\<rightarrow>B \<Longrightarrow> f\<in>B\<^bsup><\<alpha>\<^esup>"
  unfolding seqspace_def by blast

lemma seqspaceD[dest]: "f\<in>B\<^bsup><\<alpha>\<^esup> \<Longrightarrow> \<exists>n\<in>\<alpha>. f:n\<rightarrow>B"
  unfolding seqspace_def by blast

locale M_pre_seqspace =  M_trancl + M_replacement + M_Pi
begin

lemma function_space_subset_Pow_rel:
  assumes "n\<in>\<omega>" "M(B)"
  shows "n\<rightarrow>B \<subseteq> Pow\<^bsup>M\<^esup>(\<Union>(\<omega>\<rightarrow>\<^bsup>M\<^esup>B))"
proof -
  {
    fix f p
    assume "f \<subseteq> n \<times> B" "p \<in> f"
    with assms
    obtain x y where "p =\<langle>x,y\<rangle>" "x\<in>n" "y\<in>B" by auto
    with assms
    have "p \<in> (\<lambda>_\<in>\<omega>. y)"
      using Ord_trans[of _ _ \<omega>] lam_constant_eq_cartprod by simp
    moreover
    note assms and \<open>y\<in>B\<close>
    moreover from this
    have "M(\<lambda>_\<in>\<omega>. y)" using lam_constant_eq_cartprod by (auto dest:transM)
    moreover from calculation
    have "(\<lambda>_\<in>\<omega>. y) : \<omega> \<rightarrow>\<^bsup>M\<^esup> B"
      using mem_function_space_rel_abs[of \<omega> B, THEN iffD2]
      by simp
    ultimately
    have "\<exists>B\<in>\<omega> \<rightarrow>\<^bsup>M\<^esup> B. p \<in> B"
      by (rule_tac x="\<lambda>_\<in>\<omega>. y" in bexI)
  }
  with assms
  show ?thesis
    by (auto dest:transM intro!:mem_Pow_rel_abs[THEN iffD2])
      (unfold Pi_def, auto)
qed

lemma seqspace_subset_Pow_rel:
  assumes "M(B)"
  shows "B\<^bsup><\<omega>\<^esup> \<subseteq> Pow\<^bsup>M\<^esup>(\<Union>(\<omega>\<rightarrow>\<^bsup>M\<^esup>B))"
  using assms function_space_subset_Pow_rel unfolding seqspace_def
  by auto

lemma seqspace_imp_M:
  assumes "x \<in> B\<^bsup><\<omega>\<^esup>" "M(B)"
  shows "M(x)"
  using assms seqspace_subset_Pow_rel
  by (auto dest:transM)

lemma seqspace_eq_Collect:
  assumes "M(B)"
  shows "B\<^bsup><\<omega>\<^esup> = {z \<in> Pow\<^bsup>M\<^esup>(\<Union>(\<omega>\<rightarrow>\<^bsup>M\<^esup>B)). \<exists>x[M]. \<exists>n[M]. n \<in> \<omega> \<and> z \<in> x \<and> x = n \<rightarrow>\<^bsup>M\<^esup> B}"
  using assms seqspace_subset_Pow_rel nat_into_M seqspace_imp_M
    transM[OF _ finite_funspace_closed, of _ _ B] function_space_rel_char
  by (intro equalityI) (auto dest:transM dest!:seqspaceD)

end \<comment> \<open>\<^locale>\<open>M_pre_seqspace\<close>\<close>

locale M_seqspace =  M_pre_seqspace +
  assumes
    seqspace_separation: "M(B) \<Longrightarrow> separation(M,\<lambda>z. \<exists>x[M]. \<exists>n[M]. n \<in> \<omega> \<and> z \<in> x \<and> x = n \<rightarrow>\<^bsup>M\<^esup> B)"
begin

lemma seqspace_closed:
  "M(B) \<Longrightarrow> M(B\<^bsup><\<omega>\<^esup>)"
  using seqspace_eq_Collect using seqspace_separation
  by simp

end \<comment> \<open>\<^locale>\<open>M_seqspace\<close>\<close>

subsection\<open>Representation of finite functions\<close>

text\<open>A function $f\in A\to_{\mathit{fin}}B$ can be represented by a function
$g\in |f| \to A\times B$. It is clear that $f$ can be represented by
any $g' = g \cdot \pi$, where $\pi$ is a permutation $\pi\in dom(g)\to dom(g)$.
We use this representation of $A\to_{\mathit{fin}}B$ to prove that our model is
closed under $\_\to_{\mathit{fin}}\_$.\<close>

text\<open>A function $g\in n\to A\times B$ that is functional in the first components.\<close>
definition cons_like :: "i \<Rightarrow> o" where
  "cons_like(f) \<equiv> \<forall> i\<in>domain(f) . \<forall>j\<in>i . fst(f`i) \<noteq> fst(f`j)"

definition FiniteFun_iso :: "[i,i,i,i,i] \<Rightarrow> o" where
  "FiniteFun_iso(A,B,n,g,f) \<equiv>  (\<forall> i\<in>n . g`i \<in> f) \<and> (\<forall> ab\<in>f. (\<exists> i\<in>n. g`i=ab))"

text\<open>From a function $g\in n \to A\times B$ we obtain a finite function in \<^term>\<open>A-||>B\<close>.\<close>

definition to_FiniteFun :: "i \<Rightarrow> i" where
  "to_FiniteFun(f) \<equiv> {f`i. i\<in>domain(f)}"

definition FiniteFun_Repr :: "[i,i] \<Rightarrow> i" where
  "FiniteFun_Repr(A,B) \<equiv> {f \<in> (A\<times>B)\<^bsup><\<omega>\<^esup> . cons_like(f) }"

locale M_FiniteFun =  M_seqspace +
  assumes
    separation_is_function : "separation(M, is_function(M))"
begin

lemma cons_like_separation : "separation(M,\<lambda>f. cons_like(f))"
  unfolding cons_like_def
  using lam_replacement_identity lam_replacement_domain lam_replacement_snd
    lam_replacement_hcomp[OF _ lam_replacement_snd ]
    lam_replacement_hcomp[OF _ lam_replacement_fst]
    separation_eq lam_replacement_apply2[THEN [5] lam_replacement_hcomp2] separation_neg
  by(rule_tac separation_all,auto,rule_tac separation_all,auto)

lemma supset_separation: "separation(M, \<lambda> x. \<exists>a. \<exists>b. x = \<langle>a,b\<rangle> \<and> b \<subseteq> a)"
  using separation_Pair separation_subset lam_replacement_fst lam_replacement_snd
  by simp

lemma to_finiteFun_replacement: "strong_replacement(M, \<lambda>x y. y = range(x))"
  using lam_replacement_range lam_replacement_imp_strong_replacement
  by simp

lemma fun_range_eq: "f\<in>A\<rightarrow>B \<Longrightarrow> {f`i . i\<in>domain(f) } = range(f)"
  using ZF_Library.range_eq_image[of f] domain_of_fun image_fun func.apply_rangeI
  by simp

lemma FiniteFun_fst_type:
  assumes "h\<in>A-||>B" "p\<in>h"
  shows  "fst(p)\<in>domain(h)"
  using assms
  by(induct h, auto)

lemma FinFun_closed:
  "M(A) \<Longrightarrow> M(B) \<Longrightarrow> M(\<Union>{n\<rightarrow>A\<times>B . n\<in>\<omega>})"
  using cartprod_closed seqspace_closed
  unfolding seqspace_def by simp

lemma cons_like_lt :
  assumes "n\<in>\<omega>" "f\<in>succ(n)\<rightarrow>A\<times>B" "cons_like(f)"
  shows "restrict(f,n)\<in>n\<rightarrow>A\<times>B" "cons_like(restrict(f,n))"
  using assms
proof (auto simp add: le_imp_subset restrict_type2)
  from \<open>f\<in>_\<close>
  have D:"domain(restrict(f,n)) = n" "domain(f) = succ(n)"
    using domain_of_fun domain_restrict by auto
  {
    fix i j
    assume "i\<in>domain(restrict(f,n))" (is "i\<in>?D") "j\<in>i"
    with \<open>n\<in>_\<close> D
    have "j\<in>?D" "i\<in>n" "j\<in>n" using Ord_trans[of j] by simp_all
    with D \<open>cons_like(f)\<close>  \<open>j\<in>n\<close> \<open>i\<in>n\<close> \<open>j\<in>i\<close>
    have "fst(restrict(f,n)`i) \<noteq> fst(restrict(f,n)`j)"
      using restrict_if unfolding cons_like_def by auto
  }
  then show "cons_like(restrict(f,n))"
    unfolding cons_like_def by auto
qed

text\<open>A finite function \<^term>\<open>f \<in> A -||> B\<close> can be represented by a
function $g \in n \to A \times B$, with $n=|f|$.\<close>
lemma FiniteFun_iso_intro1:
  assumes "f \<in> (A -||> B)"
  shows "\<exists>n\<in>\<omega> . \<exists>g\<in>n\<rightarrow>A\<times>B. FiniteFun_iso(A,B,n,g,f) \<and> cons_like(g)"
  using assms
proof(induct f,force simp add:emptyI FiniteFun_iso_def cons_like_def)
  case (consI a b h)
  then obtain n g where
    HI: "n\<in>\<omega>" "g\<in>n\<rightarrow>A\<times>B" "FiniteFun_iso(A,B,n,g,h)" "cons_like(g)" by auto
  let ?G="\<lambda> i \<in> succ(n) . if i=n then <a,b> else g`i"
  from HI \<open>a\<in>_\<close> \<open>b\<in>_\<close>
  have G: "?G \<in> succ(n)\<rightarrow>A\<times>B"
    by (auto intro:lam_type)
  have "FiniteFun_iso(A,B,succ(n),?G,cons(<a,b>,h))"
    unfolding FiniteFun_iso_def
  proof(intro conjI)
    {
      fix i
      assume "i\<in>succ(n)"
      then consider "i=n" | "i\<in>n\<and>i\<noteq>n" by auto
      then have "?G ` i \<in> cons(<a,b>,h)"
        using HI
        by(cases,simp;auto simp add:HI FiniteFun_iso_def)
    }
    then show "\<forall>i\<in>succ(n). ?G ` i \<in> cons(\<langle>a, b\<rangle>, h)" ..
  next
    { fix ab'
      assume "ab' \<in> cons(<a,b>,h)"
      then
      consider  "ab' = <a,b>" | "ab' \<in> h" using cons_iff by auto
      then
      have "\<exists>i \<in> succ(n) . ?G`i = ab'" unfolding FiniteFun_iso_def
      proof(cases,simp)
        case 2
        with HI obtain i
          where "i\<in>n" "g`i=ab'" unfolding FiniteFun_iso_def by auto
        with HI show ?thesis using  ltI[OF \<open>i\<in>_\<close>] by auto
      qed
    }
    then
    show "\<forall>ab\<in>cons(\<langle>a, b\<rangle>, h). \<exists>i\<in>succ(n). ?G`i = ab"  ..
  qed
  with HI G
  have 1: "?G\<in>succ(n)\<rightarrow>A\<times>B" "FiniteFun_iso(A,B,succ(n),?G,cons(<a,b>,h))" "succ(n)\<in>\<omega>" by simp_all
  have "cons_like(?G)"
  proof -
    from \<open>?G\<in>_\<close> \<open>g\<in>_\<close>
    have "domain(g) = n" using domain_of_fun by simp
    {
      fix i j
      assume "i\<in>domain(?G)" "j\<in>i"
      with \<open>n\<in>_\<close>
      have "j\<in>n" using Ord_trans[of j _ n] by auto
      from \<open>i\<in>_\<close> consider (a) "i=n \<and> i\<notin>n" | (b) "i\<in>n" by auto
      then
      have " fst(?G`i) \<noteq> fst(?G`j)"
      proof(cases)
        case a
        with \<open>j\<in>n\<close> HI
        have "?G`i=<a,b>" "?G`j=g`j" "g`j\<in>h"
          unfolding FiniteFun_iso_def by auto
        with \<open>a\<notin>_\<close> \<open>h\<in>_\<close>
        show ?thesis using  FiniteFun_fst_type by auto
      next
        case b
        with \<open>i\<in>n\<close> \<open>j\<in>i\<close> \<open>j\<in>n\<close> HI \<open>domain(g) = n\<close>
        show ?thesis unfolding cons_like_def
          using mem_not_refl by auto
      qed
    }
    then show ?thesis unfolding cons_like_def by auto
  qed
  with 1 show ?case by auto
qed

text\<open>All the representations of \<^term>\<open>f\<in>A-||>B\<close> are equal.\<close>
lemma FiniteFun_isoD :
  assumes "n\<in>\<omega>" "g\<in>n\<rightarrow>A\<times>B" "f\<in>A-||>B" "FiniteFun_iso(A,B,n,g,f)"
  shows "to_FiniteFun(g) = f"
proof
  show "to_FiniteFun(g) \<subseteq> f"
  proof
    fix ab
    assume "ab\<in>to_FiniteFun(g)"
    moreover
    note assms
    moreover from calculation
    obtain i where "i\<in>n" "g`i=ab" "ab\<in>A\<times>B"
      unfolding to_FiniteFun_def using domain_of_fun by auto
    ultimately
    show "ab\<in>f" unfolding FiniteFun_iso_def by auto
  qed
next
  show "f \<subseteq> to_FiniteFun(g)"
  proof
    fix ab
    assume "ab\<in>f"
    with assms
    obtain i where "i\<in>n" "g`i=ab" "ab\<in>A\<times>B"
      unfolding FiniteFun_iso_def by auto
    with assms
    show "ab \<in> to_FiniteFun(g)"
      unfolding to_FiniteFun_def
      using domain_of_fun by auto
  qed
qed

lemma to_FiniteFun_succ_eq :
  assumes "n\<in>\<omega>" "f\<in>succ(n) \<rightarrow> A"
  shows "to_FiniteFun(f) = cons(f`n,to_FiniteFun(restrict(f,n)))"
  using assms domain_restrict domain_of_fun
  unfolding to_FiniteFun_def by auto

text\<open>If $g \in n\to A\times B$ is \<^term>\<open>cons_like\<close>, then it is a representation of
\<^term>\<open>to_FiniteFun(g)\<close>.\<close>
lemma FiniteFun_iso_intro_to:
  assumes "n\<in>\<omega>" "g\<in>n\<rightarrow>A\<times>B" "cons_like(g)"
  shows "to_FiniteFun(g) \<in> (A -||> B) \<and> FiniteFun_iso(A,B,n,g,to_FiniteFun(g))"
  using assms
proof(induct n  arbitrary:g rule:nat_induct)
  case 0
  fix g
  assume "g\<in>0\<rightarrow>A\<times>B"
  then
  have "g=0" by simp
  then have "to_FiniteFun(g)=0" unfolding to_FiniteFun_def by simp
  then show "to_FiniteFun(g) \<in> (A -||> B) \<and> FiniteFun_iso(A,B,0,g,to_FiniteFun(g))"
    using emptyI unfolding FiniteFun_iso_def by simp
next
  case (succ x)
  fix g
  let ?g'="restrict(g,x)"
  assume "g\<in>succ(x)\<rightarrow>A\<times>B" "cons_like(g)"
  with succ.hyps \<open>g\<in>_\<close>
  have "cons_like(?g')" "?g' \<in> x\<rightarrow>A\<times>B" "g`x\<in>A\<times>B" "domain(g) = succ(x)"
    using cons_like_lt succI1 apply_funtype domain_of_fun by simp_all
  with succ.hyps  \<open>?g'\<in>_\<close> \<open>x\<in>\<omega>\<close>
  have HI:
    "to_FiniteFun(?g') \<in> A -||> B" (is "(?h) \<in> _")
    "FiniteFun_iso(A,B,x,?g',to_FiniteFun(?g'))"
    by simp_all
  then
  have "fst(g`x) \<notin> domain(?h)"
  proof -
    {
      assume "fst(g`x) \<in> domain(?h)"
      with HI \<open>x\<in>_\<close>
      obtain i b
        where "i\<in>x" "<fst(?g'`i),b>\<in>?h" "i<x" "fst(g`x) = fst(?g'`i)"
        unfolding FiniteFun_iso_def using ltI by auto
      with \<open>cons_like(g)\<close> \<open>domain(g) = _\<close>
      have False
        unfolding cons_like_def by auto
    }
    then show ?thesis ..
  qed
  with HI assms \<open>g`x\<in>_\<close>
  have "cons(g`x,?h) \<in> A-||>B" (is "?h' \<in>_") using consI by auto
  have "FiniteFun_iso(A,B,succ(x),g,?h')"
    unfolding FiniteFun_iso_def
  proof
    { fix i
      assume "i\<in>succ(x)"
      with \<open>x\<in>_\<close> consider (a) "i=x"| (b) "i\<in>x\<and>i\<noteq>x" by auto
      then have "g`i\<in> ?h'"
      proof(cases,simp)
        case b
        with \<open>FiniteFun_iso(_,_,_,?g',?h)\<close>
        show ?thesis unfolding FiniteFun_iso_def by simp
      qed
    }
    then show "\<forall>i\<in>succ(x). g ` i \<in> cons(g ` x, ?h)" ..
  next
    {
      fix ab
      assume "ab\<in>?h'"
      then consider "ab=g`x" | "ab \<in> ?h" using cons_iff by auto
      then
      have "\<exists>i \<in> succ(x) . g`i = ab" unfolding FiniteFun_iso_def
      proof(cases,simp)
        case 2
        with HI obtain i
          where 2:"i\<in>x" "?g'`i=ab"  unfolding FiniteFun_iso_def by auto
        with \<open>x\<in>_\<close>
        have "i\<noteq>x" "i\<in>succ(x)" using  ltI[OF \<open>i\<in>_\<close>] by auto
        with 2 HI show ?thesis by auto
      qed
    } then show "\<forall>ab\<in>cons(g ` x, ?h). \<exists>i\<in>succ(x). g ` i = ab" ..
  qed
  with \<open>?h'\<in>_\<close>
  show "to_FiniteFun(g) \<in> A -||>B \<and> FiniteFun_iso(A,B,succ(x),g,to_FiniteFun(g))"
    using to_FiniteFun_succ_eq[OF \<open>x\<in>_\<close> \<open>g\<in>_\<close>,symmetric] by auto
qed

lemma FiniteFun_iso_intro2:
  assumes "n\<in>\<omega>" "f\<in>n\<rightarrow>A\<times>B" "cons_like(f)"
  shows "\<exists> g \<in> (A -||> B) . FiniteFun_iso(A,B,n,f,g)"
  using assms FiniteFun_iso_intro_to by blast

lemma FiniteFun_eq_range_Repr :
  shows "{range(h) . h \<in> FiniteFun_Repr(A,B) } = {to_FiniteFun(h) . h \<in> FiniteFun_Repr(A,B) }"
  unfolding FiniteFun_Repr_def to_FiniteFun_def seqspace_def
  using fun_range_eq
  by(intro equalityI subsetI,auto)

lemma FiniteFun_eq_to_FiniteFun_Repr :
  shows "A-||>B = {to_FiniteFun(h) . h \<in> FiniteFun_Repr(A,B) } "
    (is "?Y=?X")
proof
  {
    fix f
    assume "f\<in>A-||>B"
    then obtain n g where
      1: "n\<in>\<omega>" "g\<in>n\<rightarrow>A\<times>B" "FiniteFun_iso(A,B,n,g,f)" "cons_like(g)"
      using FiniteFun_iso_intro1 by blast
    with \<open>f\<in>_\<close>
    have "cons_like(g)" "f=to_FiniteFun(g)" "domain(g) = n" "g\<in>FiniteFun_Repr(A,B)"
      using FiniteFun_isoD domain_of_fun
      unfolding FiniteFun_Repr_def
      by auto
    with 1 have "f\<in>?X"
      by auto
  } then show "?Y\<subseteq>?X" ..
next
  {
    fix f
    assume "f\<in>?X"
    then obtain g where
      A:"g\<in>FiniteFun_Repr(A,B)" "f=to_FiniteFun(g)" "cons_like(g)"
      using RepFun_iff unfolding FiniteFun_Repr_def by auto
    then obtain n where "n\<in>\<omega>" "g\<in>n\<rightarrow>A\<times>B" "domain(g) = n"
      unfolding FiniteFun_Repr_def using domain_of_fun by force
    with A
    have "f\<in>?Y"
      using FiniteFun_iso_intro_to by simp
  } then show "?X\<subseteq>?Y" ..
qed

lemma FiniteFun_Repr_closed :
  assumes "M(A)" "M(B)"
  shows "M(FiniteFun_Repr(A,B))"
  unfolding FiniteFun_Repr_def
  using assms cartprod_closed
    seqspace_closed separation_closed cons_like_separation
  by simp

lemma to_FiniteFun_closed:
  assumes "M(A)" "f\<in>A"
  shows "M(range(f))"
  using assms transM[of _ A] by simp

lemma To_FiniteFun_Repr_closed :
  assumes "M(A)" "M(B)"
  shows "M({range(h) . h \<in> FiniteFun_Repr(A,B) })"
  using assms FiniteFun_Repr_closed
    RepFun_closed  to_finiteFun_replacement
    to_FiniteFun_closed[OF FiniteFun_Repr_closed]
  by simp

lemma FiniteFun_closed[intro,simp] :
  assumes "M(A)" "M(B)"
  shows "M(A -||> B)"
  using assms To_FiniteFun_Repr_closed FiniteFun_eq_to_FiniteFun_Repr
    FiniteFun_eq_range_Repr
  by simp

end \<comment> \<open>\<^locale>\<open>M_FiniteFun\<close>\<close>

end


(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * (C)opyright 2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory Last
imports
  HOLCF
  LList
  WorkerWrapper
begin

(*>*)
section{* Optimise ``last''. *}

text{* Andy Gill's solution, mechanised. No fusion, works fine using their rule. *}

subsection{* The @{term "last"} function. *}

fixrec llast :: "'a llist \<rightarrow> 'a"
where
  "llast\<cdot>(x :@ yys) = (case yys of lnil \<Rightarrow> x | y :@ ys \<Rightarrow> llast\<cdot>yys)"

lemma llast_strict[simp]: "llast\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

fixrec llast_body :: "('a llist \<rightarrow> 'a) \<rightarrow> 'a llist \<rightarrow> 'a"
where
  "llast_body\<cdot>f\<cdot>(x :@ yys) = (case yys of lnil \<Rightarrow> x | y :@ ys \<Rightarrow> f\<cdot>yys)"

lemma llast_llast_body: "llast = fix\<cdot>llast_body"
  by (rule cfun_eqI, subst llast_def, subst llast_body.unfold, simp)

definition wrap :: "('a \<rightarrow> 'a llist \<rightarrow> 'a) \<rightarrow> ('a llist \<rightarrow> 'a)" where
  "wrap \<equiv> \<Lambda> f (x :@ xs). f\<cdot>x\<cdot>xs"

definition unwrap :: "('a llist \<rightarrow> 'a) \<rightarrow> ('a \<rightarrow> 'a llist \<rightarrow> 'a)" where
  "unwrap \<equiv> \<Lambda> f x xs. f\<cdot>(x :@ xs)"

lemma unwrap_strict[simp]: "unwrap\<cdot>\<bottom> = \<bottom>"
  unfolding unwrap_def by ((rule cfun_eqI)+, simp)

lemma wrap_unwrap_ID: "wrap oo unwrap oo llast_body = llast_body"
  unfolding llast_body_def wrap_def unwrap_def
  apply (rule cfun_eqI)+
  apply (case_tac xa)
  apply (simp_all add: fix_const)
  done

definition llast_worker :: "('a \<rightarrow> 'a llist \<rightarrow> 'a) \<rightarrow> 'a \<rightarrow> 'a llist \<rightarrow> 'a" where
  "llast_worker \<equiv> \<Lambda> r x yys. case yys of lnil \<Rightarrow> x | y :@ ys \<Rightarrow> r\<cdot>y\<cdot>ys"

definition llast' :: "'a llist \<rightarrow> 'a" where
  "llast' \<equiv> wrap\<cdot>(fix\<cdot>llast_worker)"

lemma llast_worker_llast_body: "llast_worker = unwrap oo llast_body oo wrap"
  unfolding llast_worker_def llast_body_def wrap_def unwrap_def
  apply (rule cfun_eqI)+
  apply (case_tac xb)
  apply (simp_all add: fix_const)
  done

lemma llast'_llast: "llast' = llast" (is "?lhs = ?rhs")
proof -
  have "?rhs = fix\<cdot>llast_body" by (simp only: llast_llast_body)
  also have "\<dots> = wrap\<cdot>(fix\<cdot>(unwrap oo llast_body oo wrap))"
    by (simp only: worker_wrapper_body[OF wrap_unwrap_ID])
  also have "\<dots> = wrap\<cdot>(fix\<cdot>(llast_worker))"
    by (simp only: llast_worker_llast_body)
  also have "... = ?lhs" unfolding llast'_def by simp
  finally show ?thesis by simp
qed

end


(*  Title:      LCF/LCF.thy
    Author:     Tobias Nipkow
    Copyright   1992  University of Cambridge
*)

section {* LCF on top of First-Order Logic *}

theory LCF
imports "~~/src/FOL/FOL"
begin

text {* This theory is based on Lawrence Paulson's book Logic and Computation. *}

subsection {* Natural Deduction Rules for LCF *}

class cpo = "term"
default_sort cpo

typedecl tr
typedecl void
typedecl ('a,'b) prod  (infixl "*" 6)
typedecl ('a,'b) sum  (infixl "+" 5)

instance "fun" :: (cpo, cpo) cpo ..
instance prod :: (cpo, cpo) cpo ..
instance sum :: (cpo, cpo) cpo ..
instance tr :: cpo ..
instance void :: cpo ..

consts
 UU     :: "'a"
 TT     :: "tr"
 FF     :: "tr"
 FIX    :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a"
 FST    :: "'a*'b \<Rightarrow> 'a"
 SND    :: "'a*'b \<Rightarrow> 'b"
 INL    :: "'a \<Rightarrow> 'a+'b"
 INR    :: "'b \<Rightarrow> 'a+'b"
 WHEN   :: "['a\<Rightarrow>'c, 'b\<Rightarrow>'c, 'a+'b] \<Rightarrow> 'c"
 adm    :: "('a \<Rightarrow> o) \<Rightarrow> o"
 VOID   :: "void"               ("'(')")
 PAIR   :: "['a,'b] \<Rightarrow> 'a*'b"   ("(1<_,/_>)" [0,0] 100)
 COND   :: "[tr,'a,'a] \<Rightarrow> 'a"   ("(_ \<Rightarrow>/ (_ |/ _))" [60,60,60] 60)
 less   :: "['a,'a] \<Rightarrow> o"       (infixl "<<" 50)

axiomatization where
  (** DOMAIN THEORY **)

  eq_def:        "x=y == x << y \<and> y << x" and

  less_trans:    "\<lbrakk>x << y; y << z\<rbrakk> \<Longrightarrow> x << z" and

  less_ext:      "(\<forall>x. f(x) << g(x)) \<Longrightarrow> f << g" and

  mono:          "\<lbrakk>f << g; x << y\<rbrakk> \<Longrightarrow> f(x) << g(y)" and

  minimal:       "UU << x" and

  FIX_eq:        "\<And>f. f(FIX(f)) = FIX(f)"

axiomatization where
  (** TR **)

  tr_cases:      "p=UU \<or> p=TT \<or> p=FF" and

  not_TT_less_FF: "\<not> TT << FF" and
  not_FF_less_TT: "\<not> FF << TT" and
  not_TT_less_UU: "\<not> TT << UU" and
  not_FF_less_UU: "\<not> FF << UU" and

  COND_UU:       "UU \<Rightarrow> x | y  =  UU" and
  COND_TT:       "TT \<Rightarrow> x | y  =  x" and
  COND_FF:       "FF \<Rightarrow> x | y  =  y"

axiomatization where
  (** PAIRS **)

  surj_pairing:  "<FST(z),SND(z)> = z" and

  FST:   "FST(<x,y>) = x" and
  SND:   "SND(<x,y>) = y"

axiomatization where
  (*** STRICT SUM ***)

  INL_DEF: "\<not>x=UU \<Longrightarrow> \<not>INL(x)=UU" and
  INR_DEF: "\<not>x=UU \<Longrightarrow> \<not>INR(x)=UU" and

  INL_STRICT: "INL(UU) = UU" and
  INR_STRICT: "INR(UU) = UU" and

  WHEN_UU:  "WHEN(f,g,UU) = UU" and
  WHEN_INL: "\<not>x=UU \<Longrightarrow> WHEN(f,g,INL(x)) = f(x)" and
  WHEN_INR: "\<not>x=UU \<Longrightarrow> WHEN(f,g,INR(x)) = g(x)" and

  SUM_EXHAUSTION:
    "z = UU \<or> (\<exists>x. \<not>x=UU \<and> z = INL(x)) \<or> (\<exists>y. \<not>y=UU \<and> z = INR(y))"

axiomatization where
  (** VOID **)

  void_cases:    "(x::void) = UU"

  (** INDUCTION **)

axiomatization where
  induct: "\<lbrakk>adm(P); P(UU); \<forall>x. P(x) \<longrightarrow> P(f(x))\<rbrakk> \<Longrightarrow> P(FIX(f))"

axiomatization where
  (** Admissibility / Chain Completeness **)
  (* All rules can be found on pages 199--200 of Larry's LCF book.
     Note that "easiness" of types is not taken into account
     because it cannot be expressed schematically; flatness could be. *)

  adm_less:      "\<And>t u. adm(\<lambda>x. t(x) << u(x))" and
  adm_not_less:  "\<And>t u. adm(\<lambda>x.\<not> t(x) << u)" and
  adm_not_free:  "\<And>A. adm(\<lambda>x. A)" and
  adm_subst:     "\<And>P t. adm(P) \<Longrightarrow> adm(\<lambda>x. P(t(x)))" and
  adm_conj:      "\<And>P Q. \<lbrakk>adm(P); adm(Q)\<rbrakk> \<Longrightarrow> adm(\<lambda>x. P(x)\<and>Q(x))" and
  adm_disj:      "\<And>P Q. \<lbrakk>adm(P); adm(Q)\<rbrakk> \<Longrightarrow> adm(\<lambda>x. P(x)\<or>Q(x))" and
  adm_imp:       "\<And>P Q. \<lbrakk>adm(\<lambda>x.\<not>P(x)); adm(Q)\<rbrakk> \<Longrightarrow> adm(\<lambda>x. P(x)\<longrightarrow>Q(x))" and
  adm_all:       "\<And>P. (\<And>y. adm(P(y))) \<Longrightarrow> adm(\<lambda>x. \<forall>y. P(y,x))"

lemma eq_imp_less1: "x = y \<Longrightarrow> x << y"
  by (simp add: eq_def)

lemma eq_imp_less2: "x = y \<Longrightarrow> y << x"
  by (simp add: eq_def)

lemma less_refl [simp]: "x << x"
  apply (rule eq_imp_less1)
  apply (rule refl)
  done

lemma less_anti_sym: "\<lbrakk>x << y; y << x\<rbrakk> \<Longrightarrow> x=y"
  by (simp add: eq_def)

lemma ext: "(\<And>x::'a::cpo. f(x)=(g(x)::'b::cpo)) \<Longrightarrow> (\<lambda>x. f(x))=(\<lambda>x. g(x))"
  apply (rule less_anti_sym)
  apply (rule less_ext)
  apply simp
  apply simp
  done

lemma cong: "\<lbrakk>f = g; x = y\<rbrakk> \<Longrightarrow> f(x)=g(y)"
  by simp

lemma less_ap_term: "x << y \<Longrightarrow> f(x) << f(y)"
  by (rule less_refl [THEN mono])

lemma less_ap_thm: "f << g \<Longrightarrow> f(x) << g(x)"
  by (rule less_refl [THEN [2] mono])

lemma ap_term: "(x::'a::cpo) = y \<Longrightarrow> (f(x)::'b::cpo) = f(y)"
  apply (rule cong [OF refl])
  apply simp
  done

lemma ap_thm: "f = g \<Longrightarrow> f(x) = g(x)"
  apply (erule cong)
  apply (rule refl)
  done

lemma UU_abs: "(\<lambda>x::'a::cpo. UU) = UU"
  apply (rule less_anti_sym)
  prefer 2
  apply (rule minimal)
  apply (rule less_ext)
  apply (rule allI)
  apply (rule minimal)
  done

lemma UU_app: "UU(x) = UU"
  by (rule UU_abs [symmetric, THEN ap_thm])

lemma less_UU: "x << UU \<Longrightarrow> x=UU"
  apply (rule less_anti_sym)
  apply assumption
  apply (rule minimal)
  done

lemma tr_induct: "\<lbrakk>P(UU); P(TT); P(FF)\<rbrakk> \<Longrightarrow> \<forall>b. P(b)"
  apply (rule allI)
  apply (rule mp)
  apply (rule_tac [2] p = b in tr_cases)
  apply blast
  done

lemma Contrapos: "\<not> B \<Longrightarrow> (A \<Longrightarrow> B) \<Longrightarrow> \<not>A"
  by blast

lemma not_less_imp_not_eq1: "\<not> x << y \<Longrightarrow> x \<noteq> y"
  apply (erule Contrapos)
  apply simp
  done

lemma not_less_imp_not_eq2: "\<not> y << x \<Longrightarrow> x \<noteq> y"
  apply (erule Contrapos)
  apply simp
  done

lemma not_UU_eq_TT: "UU \<noteq> TT"
  by (rule not_less_imp_not_eq2) (rule not_TT_less_UU)
lemma not_UU_eq_FF: "UU \<noteq> FF"
  by (rule not_less_imp_not_eq2) (rule not_FF_less_UU)
lemma not_TT_eq_UU: "TT \<noteq> UU"
  by (rule not_less_imp_not_eq1) (rule not_TT_less_UU)
lemma not_TT_eq_FF: "TT \<noteq> FF"
  by (rule not_less_imp_not_eq1) (rule not_TT_less_FF)
lemma not_FF_eq_UU: "FF \<noteq> UU"
  by (rule not_less_imp_not_eq1) (rule not_FF_less_UU)
lemma not_FF_eq_TT: "FF \<noteq> TT"
  by (rule not_less_imp_not_eq1) (rule not_FF_less_TT)

lemma COND_cases_iff [rule_format]:
    "\<forall>b. P(b\<Rightarrow>x|y) \<longleftrightarrow> (b=UU\<longrightarrow>P(UU)) \<and> (b=TT\<longrightarrow>P(x)) \<and> (b=FF\<longrightarrow>P(y))"
  apply (insert not_UU_eq_TT not_UU_eq_FF not_TT_eq_UU
    not_TT_eq_FF not_FF_eq_UU not_FF_eq_TT)
  apply (rule tr_induct)
  apply (simplesubst COND_UU)
  apply blast
  apply (simplesubst COND_TT)
  apply blast
  apply (simplesubst COND_FF)
  apply blast
  done

lemma COND_cases:
  "\<lbrakk>x = UU \<longrightarrow> P(UU); x = TT \<longrightarrow> P(xa); x = FF \<longrightarrow> P(y)\<rbrakk> \<Longrightarrow> P(x \<Rightarrow> xa | y)"
  apply (rule COND_cases_iff [THEN iffD2])
  apply blast
  done

lemmas [simp] =
  minimal
  UU_app
  UU_app [THEN ap_thm]
  UU_app [THEN ap_thm, THEN ap_thm]
  not_TT_less_FF not_FF_less_TT not_TT_less_UU not_FF_less_UU not_UU_eq_TT
  not_UU_eq_FF not_TT_eq_UU not_TT_eq_FF not_FF_eq_UU not_FF_eq_TT
  COND_UU COND_TT COND_FF
  surj_pairing FST SND

subsection {* Ordered pairs and products *}

lemma expand_all_PROD: "(\<forall>p. P(p)) \<longleftrightarrow> (\<forall>x y. P(<x,y>))"
  apply (rule iffI)
  apply blast
  apply (rule allI)
  apply (rule surj_pairing [THEN subst])
  apply blast
  done

lemma PROD_less: "(p::'a*'b) << q \<longleftrightarrow> FST(p) << FST(q) \<and> SND(p) << SND(q)"
  apply (rule iffI)
  apply (rule conjI)
  apply (erule less_ap_term)
  apply (erule less_ap_term)
  apply (erule conjE)
  apply (rule surj_pairing [of p, THEN subst])
  apply (rule surj_pairing [of q, THEN subst])
  apply (rule mono, erule less_ap_term, assumption)
  done

lemma PROD_eq: "p=q \<longleftrightarrow> FST(p)=FST(q) \<and> SND(p)=SND(q)"
  apply (rule iffI)
  apply simp
  apply (unfold eq_def)
  apply (simp add: PROD_less)
  done

lemma PAIR_less [simp]: "<a,b> << <c,d> \<longleftrightarrow> a<<c \<and> b<<d"
  by (simp add: PROD_less)

lemma PAIR_eq [simp]: "<a,b> = <c,d> \<longleftrightarrow> a=c \<and> b=d"
  by (simp add: PROD_eq)

lemma UU_is_UU_UU [simp]: "<UU,UU> = UU"
  by (rule less_UU) (simp add: PROD_less)

lemma FST_STRICT [simp]: "FST(UU) = UU"
  apply (rule subst [OF UU_is_UU_UU])
  apply (simp del: UU_is_UU_UU)
  done

lemma SND_STRICT [simp]: "SND(UU) = UU"
  apply (rule subst [OF UU_is_UU_UU])
  apply (simp del: UU_is_UU_UU)
  done

subsection {* Fixedpoint theory *}

lemma adm_eq: "adm(\<lambda>x. t(x)=(u(x)::'a::cpo))"
  apply (unfold eq_def)
  apply (rule adm_conj adm_less)+
  done

lemma adm_not_not: "adm(P) \<Longrightarrow> adm(\<lambda>x. \<not> \<not> P(x))"
  by simp

lemma not_eq_TT: "\<forall>p. \<not>p=TT \<longleftrightarrow> (p=FF \<or> p=UU)"
  and not_eq_FF: "\<forall>p. \<not>p=FF \<longleftrightarrow> (p=TT \<or> p=UU)"
  and not_eq_UU: "\<forall>p. \<not>p=UU \<longleftrightarrow> (p=TT \<or> p=FF)"
  by (rule tr_induct, simp_all)+

lemma adm_not_eq_tr: "\<forall>p::tr. adm(\<lambda>x. \<not>t(x)=p)"
  apply (rule tr_induct)
  apply (simp_all add: not_eq_TT not_eq_FF not_eq_UU)
  apply (rule adm_disj adm_eq)+
  done

lemmas adm_lemmas =
  adm_not_free adm_eq adm_less adm_not_less
  adm_not_eq_tr adm_conj adm_disj adm_imp adm_all

method_setup induct = {*
  Scan.lift Args.name_inner_syntax >> (fn v => fn ctxt =>
    SIMPLE_METHOD' (fn i =>
      res_inst_tac ctxt [(("f", 0), v)] @{thm induct} i THEN
      REPEAT (resolve_tac @{thms adm_lemmas} i)))
*}

lemma least_FIX: "f(p) = p \<Longrightarrow> FIX(f) << p"
  apply (induct f)
  apply (rule minimal)
  apply (intro strip)
  apply (erule subst)
  apply (erule less_ap_term)
  done

lemma lfp_is_FIX:
  assumes 1: "f(p) = p"
    and 2: "\<forall>q. f(q)=q \<longrightarrow> p << q"
  shows "p = FIX(f)"
  apply (rule less_anti_sym)
  apply (rule 2 [THEN spec, THEN mp])
  apply (rule FIX_eq)
  apply (rule least_FIX)
  apply (rule 1)
  done

lemma FIX_pair: "<FIX(f),FIX(g)> = FIX(\<lambda>p.<f(FST(p)),g(SND(p))>)"
  apply (rule lfp_is_FIX)
  apply (simp add: FIX_eq [of f] FIX_eq [of g])
  apply (intro strip)
  apply (simp add: PROD_less)
  apply (rule conjI)
  apply (rule least_FIX)
  apply (erule subst, rule FST [symmetric])
  apply (rule least_FIX)
  apply (erule subst, rule SND [symmetric])
  done

lemma FIX1: "FIX(f) = FST(FIX(\<lambda>p. <f(FST(p)),g(SND(p))>))"
  by (rule FIX_pair [unfolded PROD_eq FST SND, THEN conjunct1])

lemma FIX2: "FIX(g) = SND(FIX(\<lambda>p. <f(FST(p)),g(SND(p))>))"
  by (rule FIX_pair [unfolded PROD_eq FST SND, THEN conjunct2])

lemma induct2:
  assumes 1: "adm(\<lambda>p. P(FST(p),SND(p)))"
    and 2: "P(UU::'a,UU::'b)"
    and 3: "\<forall>x y. P(x,y) \<longrightarrow> P(f(x),g(y))"
  shows "P(FIX(f),FIX(g))"
  apply (rule FIX1 [THEN ssubst, of _ f g])
  apply (rule FIX2 [THEN ssubst, of _ f g])
  apply (rule induct [where ?f = "\<lambda>x. <f(FST(x)),g(SND(x))>"])
  apply (rule 1)
  apply simp
  apply (rule 2)
  apply (simp add: expand_all_PROD)
  apply (rule 3)
  done

ML {*
fun induct2_tac ctxt (f, g) i =
  res_inst_tac ctxt [(("f", 0), f), (("g", 0), g)] @{thm induct2} i THEN
  REPEAT(resolve_tac @{thms adm_lemmas} i)
*}

end