theory Evaluation
imports Setup
begin

section {* Evaluation \label{sec:evaluation} *}

text {*
  Recalling \secref{sec:principle}, code generation turns a system of
  equations into a program with the \emph{same} equational semantics.
  As a consequence, this program can be used as a \emph{rewrite
  engine} for terms: rewriting a term @{term "t"} using a program to a
  term @{term "t'"} yields the theorems @{prop "t \<equiv> t'"}.  This
  application of code generation in the following is referred to as
  \emph{evaluation}.
*}

subsection {* Evaluation techniques *}

text {*
  The existing infrastructure provides a rich palette of evaluation
  techniques, each comprising different aspects:

  \begin{description}

    \item[Expressiveness.]  Depending on how good symbolic computation
      is supported, the class of terms which can be evaluated may be
      bigger or smaller.

    \item[Efficiency.]  The more machine-near the technique, the
      faster it is.

    \item[Trustability.]  Techniques which a huge (and also probably
      more configurable infrastructure) are more fragile and less
      trustable.

  \end{description}
*}

subsubsection {* The simplifier (@{text simp}) *}

text {*
  The simplest way for evaluation is just using the simplifier with
  the original code equations of the underlying program.  This gives
  fully symbolic evaluation and highest trustablity, with the usual
  performance of the simplifier.  Note that for operations on abstract
  datatypes (cf.~\secref{sec:invariant}), the original theorems as
  given by the users are used, not the modified ones.
*}

subsubsection {* Normalization by evaluation (@{text nbe}) *}

text {*
  Normalization by evaluation @{cite "Aehlig-Haftmann-Nipkow:2008:nbe"}
  provides a comparably fast partially symbolic evaluation which
  permits also normalization of functions and uninterpreted symbols;
  the stack of code to be trusted is considerable.
*}

subsubsection {* Evaluation in ML (@{text code}) *}

text {*
  Highest performance can be achieved by evaluation in ML, at the cost
  of being restricted to ground results and a layered stack of code to
  be trusted, including code generator configurations by the user.

  Evaluation is carried out in a target language \emph{Eval} which
  inherits from \emph{SML} but for convenience uses parts of the
  Isabelle runtime environment.  The soundness of computation carried
  out there depends crucially on the correctness of the code
  generator setup; this is one of the reasons why you should not use
  adaptation (see \secref{sec:adaptation}) frivolously.
*}

subsection {* Aspects of evaluation *}

text {*
  Each of the techniques can be combined with different aspects.  The
  most important distinction is between dynamic and static evaluation.
  Dynamic evaluation takes the code generator configuration \qt{as it
  is} at the point where evaluation is issued.  Best example is the
  @{command_def value} command which allows ad-hoc evaluation of
  terms:
*}

value %quote "42 / (12 :: rat)"

text {*
  \noindent @{command value} tries first to evaluate using ML, falling
  back to normalization by evaluation if this fails.

  A particular technique may be specified in square brackets, e.g.
*}

value %quote [nbe] "42 / (12 :: rat)"

text {*
  To employ dynamic evaluation in the document generation, there is also
  a @{text value} antiquotation with the same evaluation techniques
  as @{command value}.

  Static evaluation freezes the code generator configuration at a
  certain point and uses this context whenever evaluation is issued
  later on.  This is particularly appropriate for proof procedures
  which use evaluation, since then the behaviour of evaluation is not
  changed or even compromised later on by actions of the user.

  As a technical complication, terms after evaluation in ML must be
  turned into Isabelle's internal term representation again.  Since
  this is also configurable, it is never fully trusted.  For this
  reason, evaluation in ML comes with further aspects:

  \begin{description}

    \item[Plain evaluation.]  A term is normalized using the provided
      term reconstruction from ML to Isabelle; for applications which
      do not need to be fully trusted.

    \item[Property conversion.]  Evaluates propositions; since these
      are monomorphic, the term reconstruction is fixed once and for all
      and therefore trustable.

    \item[Conversion.]  Evaluates an arbitrary term @{term "t"} first
      by plain evaluation and certifies the result @{term "t'"} by
      checking the equation @{term "t \<equiv> t'"} using property
      conversion.

  \end{description}

  \noindent The picture is further complicated by the roles of
  exceptions.  Here three cases have to be distinguished:

  \begin{itemize}

    \item Evaluation of @{term t} terminates with a result @{term
      "t'"}.

    \item Evaluation of @{term t} terminates which en exception
      indicating a pattern match failure or a non-implemented
      function.  As sketched in \secref{sec:partiality}, this can be
      interpreted as partiality.

    \item Evaluation raises any other kind of exception.

  \end{itemize}

  \noindent For conversions, the first case yields the equation @{term
  "t = t'"}, the second defaults to reflexivity @{term "t = t"}.
  Exceptions of the third kind are propagated to the user.

  By default return values of plain evaluation are optional, yielding
  @{text "SOME t'"} in the first case, @{text "NONE"} in the
  second, and propagating the exception in the third case.  A strict
  variant of plain evaluation either yields @{text "t'"} or propagates
  any exception, a liberal variant captures any exception in a result
  of type @{text "Exn.result"}.

  For property conversion (which coincides with conversion except for
  evaluation in ML), methods are provided which solve a given goal by
  evaluation.
*}

subsection {* Schematic overview *}

text {*
  \newcommand{\ttsize}{\fontsize{5.8pt}{8pt}\selectfont}
  \fontsize{9pt}{12pt}\selectfont
  \begin{tabular}{ll||c|c|c}
    & & @{text simp} & @{text nbe} & @{text code} \tabularnewline \hline \hline
    \multirow{5}{1ex}{\rotatebox{90}{dynamic}}
      & interactive evaluation
      & @{command value} @{text "[simp]"} & @{command value} @{text "[nbe]"} & @{command value} @{text "[code]"}
      \tabularnewline
    & plain evaluation & & & \ttsize@{ML "Code_Evaluation.dynamic_value"} \tabularnewline \cline{2-5}
    & evaluation method & @{method code_simp} & @{method normalization} & @{method eval} \tabularnewline
    & property conversion & & & \ttsize@{ML "Code_Runtime.dynamic_holds_conv"} \tabularnewline \cline{2-5}
    & conversion & \ttsize@{ML "Code_Simp.dynamic_conv"} & \ttsize@{ML "Nbe.dynamic_conv"}
      & \ttsize@{ML "Code_Evaluation.dynamic_conv"} \tabularnewline \hline \hline
    \multirow{3}{1ex}{\rotatebox{90}{static}}
    & plain evaluation & & & \ttsize@{ML "Code_Evaluation.static_value"} \tabularnewline \cline{2-5}
    & property conversion & &
      & \ttsize@{ML "Code_Runtime.static_holds_conv"} \tabularnewline \cline{2-5}
    & conversion & \ttsize@{ML "Code_Simp.static_conv"}
      & \ttsize@{ML "Nbe.static_conv"}
      & \ttsize@{ML "Code_Evaluation.static_conv"}
  \end{tabular}
*}

subsection {* Preprocessing HOL terms into evaluable shape *}

text {*
  When integration decision procedures developed inside HOL into HOL itself,
  it is necessary to somehow get from the Isabelle/ML representation to
  the representation used by the decision procedure itself (``reification'').
  One option is to hardcode it using code antiquotations (see \secref{sec:code_antiq}).
  Another option is to use pre-existing infrastructure in HOL:
  @{ML "Reification.conv"} and @{ML "Reification.tac"}

  An simplistic example:
*}

datatype %quote form_ord = T | F | Less nat nat
  | And form_ord form_ord | Or form_ord form_ord | Neg form_ord

primrec %quote interp :: "form_ord \<Rightarrow> 'a::order list \<Rightarrow> bool"
where
  "interp T vs \<longleftrightarrow> True"
| "interp F vs \<longleftrightarrow> False"
| "interp (Less i j) vs \<longleftrightarrow> vs ! i < vs ! j"
| "interp (And f1 f2) vs \<longleftrightarrow> interp f1 vs \<and> interp f2 vs"
| "interp (Or f1 f2) vs \<longleftrightarrow> interp f1 vs \<or> interp f2 vs"
| "interp (Neg f) vs \<longleftrightarrow> \<not> interp f vs"

text {*
  The datatype @{type form_ord} represents formulae whose semantics is given by
  @{const interp}.  Note that values are represented by variable indices (@{typ nat})
  whose concrete values are given in list @{term vs}.
*}

ML (*<*) {* *}
schematic_lemma "thm": fixes x y z :: "'a::order" shows "x < y \<and> x < z \<equiv> ?P"
ML_prf
(*>*) {* val thm =
  Reification.conv @{context} @{thms interp.simps} @{cterm "x < y \<and> x < z"} *} (*<*)
by (tactic {* ALLGOALS (rtac thm) *})
(*>*)

text {*
  By virtue of @{fact interp.simps}, @{ML "Reification.conv"} provides a conversion
  which, for this concrete example, yields @{thm thm [no_vars]}.  Note that the argument
  to @{const interp} does not contain any free variables and can this be evaluated
  using evaluation.

  A less meager example can be found in the AFP, session @{text "Regular-Sets"},
  theory @{text Regexp_Method}.
*}

subsection {* Intimate connection between logic and system runtime *}

text {*
  The toolbox of static evaluation conversions forms a reasonable base
  to interweave generated code and system tools.  However in some
  situations more direct interaction is desirable.
*}

subsubsection {* Static embedding of generated code into system runtime -- the @{text code} antiquotation \label{sec:code_antiq} *}

text {*
  The @{text code} antiquotation allows to include constants from
  generated code directly into ML system code, as in the following toy
  example:
*}

datatype %quote form = T | F | And form form | Or form form (*<*)

(*>*) ML %quotett {*
  fun eval_form @{code T} = true
    | eval_form @{code F} = false
    | eval_form (@{code And} (p, q)) =
        eval_form p andalso eval_form q
    | eval_form (@{code Or} (p, q)) =
        eval_form p orelse eval_form q;
*}

text {*
  \noindent @{text code} takes as argument the name of a constant;
  after the whole ML is read, the necessary code is generated
  transparently and the corresponding constant names are inserted.
  This technique also allows to use pattern matching on constructors
  stemming from compiled datatypes.  Note that the @{text code}
  antiquotation may not refer to constants which carry adaptations;
  here you have to refer to the corresponding adapted code directly.

  For a less simplistic example, theory @{text Approximation} in
  the @{text Decision_Procs} session is a good reference.
*}

subsubsection {* Static embedding of generated code into system runtime -- @{text code_reflect} *}

text {*
  The @{text code} antiquoation is lightweight, but the generated code
  is only accessible while the ML section is processed.  Sometimes this
  is not appropriate, especially if the generated code contains datatype
  declarations which are shared with other parts of the system.  In these
  cases, @{command_def code_reflect} can be used:
*}

code_reflect %quote Sum_Type
  datatypes sum = Inl | Inr
  functions "Sum_Type.sum.projl" "Sum_Type.sum.projr"

text {*
  \noindent @{command_def code_reflect} takes a structure name and
  references to datatypes and functions; for these code is compiled
  into the named ML structure and the \emph{Eval} target is modified
  in a way that future code generation will reference these
  precompiled versions of the given datatypes and functions.  This
  also allows to refer to the referenced datatypes and functions from
  arbitrary ML code as well.

  A typical example for @{command code_reflect} can be found in the
  @{theory Predicate} theory.
*}

subsubsection {* Separate compilation -- @{text code_reflect} *}

text {*
  For technical reasons it is sometimes necessary to separate
  generation and compilation of code which is supposed to be used in
  the system runtime.  For this @{command code_reflect} with an
  optional @{text "file"} argument can be used:
*}

code_reflect %quote Rat
  datatypes rat = Frct
  functions Fract
    "(plus :: rat \<Rightarrow> rat \<Rightarrow> rat)" "(minus :: rat \<Rightarrow> rat \<Rightarrow> rat)"
    "(times :: rat \<Rightarrow> rat \<Rightarrow> rat)" "(divide :: rat \<Rightarrow> rat \<Rightarrow> rat)"
  file "examples/rat.ML"

text {*
  \noindent This merely generates the referenced code to the given
  file which can be included into the system runtime later on.
*}

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Strong_Late_Expansion_Law
  imports Strong_Late_Bisim_SC
begin

nominal_primrec summands :: "pi \<Rightarrow> pi set" where
  "summands \<zero> = {}"
| "summands (\<tau>.(P)) = {\<tau>.(P)}"
| "x \<sharp> a \<Longrightarrow> summands (a<x>.P) = {a<x>.P}"
| "summands (a{b}.P) = {a{b}.P}"
| "summands ([a\<frown>b]P) = {}"
| "summands ([a\<noteq>b]P) = {}"
| "summands (P \<oplus> Q) = (summands P) \<union> (summands Q)"
| "summands (P \<parallel> Q) = {}"
| "summands (<\<nu>x>P) = (if (\<exists>a P'. a \<noteq> x \<and> P = a{x}.P') then ({<\<nu>x>P}) else {})"
| "summands (!P) = {}"
apply(auto simp add: fresh_singleton name_fresh_abs fresh_set_empty fresh_singleton pi.fresh)
apply(finite_guess)+
by(fresh_guess)+

lemma summandsInput[simp]:
  fixes a :: name
  and   x :: name
  and   P :: pi

  shows "summands (a<x>.P) = {a<x>.P}"
proof -
  obtain y where yineqa: "y \<noteq> a" and yFreshP: "y \<sharp> P"
    by(force intro: name_exists_fresh[of "(a, P)"] simp add: fresh_prod)
  from yFreshP have "a<x>.P = a<y>.([(x, y)] \<bullet> P)" by(simp add: alphaInput)
  with yineqa show ?thesis by simp
qed

lemma finiteSummands:
  fixes P :: pi

  shows "finite(summands P)"
by(induct P rule: pi.induct) auto

lemma boundSummandDest[dest]:
  fixes x  :: name
  and   y  :: name
  and   P' :: pi
  and   P  :: pi

  assumes "<\<nu>x>x{y}.P' \<in> summands P"

  shows False
using assms
by(induct P rule: pi.induct, auto simp add: if_split pi.inject name_abs_eq name_calc)

lemma summandFresh:
  fixes P :: pi
  and   Q :: pi
  and   x :: name

  assumes "P \<in> summands Q"
  and     "x \<sharp> Q"

  shows "x \<sharp> P"
using assms
by(nominal_induct Q avoiding: P rule: pi.strong_induct, auto simp add: if_split)

nominal_primrec hnf :: "pi \<Rightarrow> bool" where
  "hnf \<zero> = True"
| "hnf (\<tau>.(P)) = True"
| "x \<sharp> a \<Longrightarrow> hnf (a<x>.P) = True"
| "hnf (a{b}.P) = True"
| "hnf ([a\<frown>b]P) = False"
| "hnf ([a\<noteq>b]P) = False"
| "hnf (P \<oplus> Q) = ((hnf P) \<and> (hnf Q) \<and> P \<noteq> \<zero> \<and> Q \<noteq> \<zero>)"
| "hnf (P \<parallel> Q) = False"
| "hnf (<\<nu>x>P) = (\<exists>a P'. a \<noteq> x \<and> P = a{x}.P')"
| "hnf (!P) = False"
apply(auto simp add: fresh_bool)
apply(finite_guess)+
by(fresh_guess)+

lemma hnfInput[simp]:
  fixes a :: name
  and   x :: name
  and   P :: pi

  shows "hnf (a<x>.P)"
proof -
  obtain y where yineqa: "y \<noteq> a" and yFreshP: "y \<sharp> P"
    by(force intro: name_exists_fresh[of "(a, P)"] simp add: fresh_prod)
  from yFreshP have "a<x>.P = a<y>.([(x, y)] \<bullet> P)" by(simp add: alphaInput)
  with yineqa show ?thesis by simp
qed

lemma summandTransition:
  fixes P  :: pi
  and   a  :: name
  and   x  :: name
  and   b  :: name
  and   P' :: pi

  assumes "hnf P"

  shows "P \<longmapsto>\<tau> \<prec> P' = (\<tau>.(P') \<in> summands P)"
  and   "P \<longmapsto>a<x> \<prec> P' = (a<x>.P' \<in> summands P)"
  and   "P \<longmapsto>a[b] \<prec> P' = (a{b}.P' \<in> summands P)"
  and   "a \<noteq> x \<Longrightarrow> P \<longmapsto>a<\<nu>x> \<prec> P' = (<\<nu>x>a{x}.P' \<in> summands P)"
proof -
  from assms show "P \<longmapsto>\<tau> \<prec> P' = (\<tau>.(P') \<in> summands P)"
  proof(induct P rule: pi.induct)
    case PiNil
    show ?case by auto
  next
    case(Output a b P)
    show ?case by auto
  next
    case(Tau P)
    have "\<tau>.(P) \<longmapsto>\<tau> \<prec> P' \<Longrightarrow> \<tau>.(P') \<in> summands (\<tau>.(P))"
      by(auto elim: tauCases simp add: pi.inject residual.inject)
    moreover have "\<tau>.(P') \<in> summands (\<tau>.(P)) \<Longrightarrow> \<tau>.(P) \<longmapsto>\<tau> \<prec> P'"
      by(auto simp add: pi.inject intro: transitions.Tau)
    ultimately show ?case by blast
  next
    case(Input a x P)
    show ?case by auto
  next
    case(Match a b P)
    have "hnf ([a\<frown>b]P)" by fact
    hence False by simp
    thus ?case by simp
  next
    case(Mismatch a b P)
    have "hnf ([a\<noteq>b]P)" by fact
    hence False by simp
    thus ?case by simp
  next
    case(Sum P Q)
    have "hnf (P \<oplus> Q)" by fact
    hence Phnf: "hnf P" and Qhnf: "hnf Q" by simp+

    have IHP: "P \<longmapsto>\<tau> \<prec> P' = (\<tau>.(P') \<in> summands P)"
    proof -
      have "hnf P \<Longrightarrow> P \<longmapsto>\<tau> \<prec> P' = (\<tau>.(P') \<in> summands P)" by fact
      with Phnf show ?thesis by simp
    qed

    have IHQ: "Q \<longmapsto>\<tau> \<prec> P' = (\<tau>.(P') \<in> summands Q)"
    proof -
      have "hnf Q \<Longrightarrow> Q \<longmapsto>\<tau> \<prec> P' = (\<tau>.(P') \<in> summands Q)" by fact
      with Qhnf show ?thesis by simp
    qed

    from IHP IHQ have "P \<oplus> Q \<longmapsto>\<tau> \<prec> P' \<Longrightarrow> \<tau>.(P') \<in> summands (P \<oplus> Q)"
      by(erule_tac sumCases, auto)
    moreover from IHP IHQ have "\<tau>.(P') \<in> summands (P \<oplus> Q) \<Longrightarrow> P \<oplus> Q \<longmapsto>\<tau> \<prec> P'"
      by(auto dest: Sum1 Sum2)
    ultimately show ?case by blast
  next
    case(Par P Q)
    have "hnf (P \<parallel> Q)" by fact
    hence False by simp
    thus ?case by simp
  next
    case(Res x P)
    thus ?case by(auto elim: resCasesF)
  next
    case(Bang P)
    have "hnf (!P)" by fact
    hence False by simp
    thus ?case by simp
  qed
next
  from assms show "P \<longmapsto>a<x> \<prec> P' = (a<x>.P' \<in> summands P)"
  proof(induct P rule: pi.induct)
    case PiNil
    show ?case by auto
  next
    case(Output c b P)
    show ?case by auto
  next
    case(Tau P)
    show ?case by auto
  next
    case(Input b y P)
    have "b<y>.P \<longmapsto>a<x> \<prec> P' \<Longrightarrow> a<x>.P' \<in> summands (b<y>.P)"
      by(auto elim: inputCases' simp add: pi.inject residual.inject)
    moreover have "a<x>.P' \<in> summands (b<y>.P) \<Longrightarrow> b<y>.P \<longmapsto>a<x> \<prec> P'"
      apply(auto simp add: pi.inject name_abs_eq intro: Late_Semantics.Input)
      apply(subgoal_tac "b<x> \<prec> [(x, y)] \<bullet> P = (b<y> \<prec> [(x, y)] \<bullet> [(x, y)] \<bullet> P)")
      apply(auto intro: Late_Semantics.Input)
      by(simp add: alphaBoundResidual name_swap)
    ultimately show ?case by blast
  next
    case(Match a b P)
    have "hnf ([a\<frown>b]P)" by fact
    hence False by simp
    thus ?case by simp
  next
    case(Mismatch a b P)
    have "hnf ([a\<noteq>b]P)" by fact
    hence False by simp
    thus ?case by simp
  next
    case(Sum P Q)
    have "hnf (P \<oplus> Q)" by fact
    hence Phnf: "hnf P" and Qhnf: "hnf Q" by simp+

    have IHP: "P \<longmapsto>a<x> \<prec> P' = (a<x>.P' \<in> summands P)"
    proof -
      have "hnf P \<Longrightarrow> P \<longmapsto>a<x> \<prec> P' = (a<x>.P' \<in> summands P)" by fact
      with Phnf show ?thesis by simp
    qed

    have IHQ: "Q \<longmapsto>a<x> \<prec> P' = (a<x>.P' \<in> summands Q)"
    proof -
      have "hnf Q \<Longrightarrow> Q \<longmapsto>a<x> \<prec> P' = (a<x>.P' \<in> summands Q)" by fact
      with Qhnf show ?thesis by simp
    qed

    from IHP IHQ have "P \<oplus> Q \<longmapsto>a<x> \<prec> P' \<Longrightarrow> a<x>.P' \<in> summands (P \<oplus> Q)"
      by(erule_tac sumCases, auto)
    moreover from IHP IHQ have "a<x>.P' \<in> summands (P \<oplus> Q) \<Longrightarrow> P \<oplus> Q \<longmapsto>a<x> \<prec> P'"
      by(auto dest: Sum1 Sum2)
    ultimately show ?case by blast
  next
    case(Par P Q)
    have "hnf (P \<parallel> Q)" by fact
    hence False by simp
    thus ?case by simp
  next
    case(Res y P)
    have "hnf(<\<nu>y>P)" by fact
    thus ?case by(auto simp add: if_split)
  next
    case(Bang P)
    have "hnf (!P)" by fact
    hence False by simp
    thus ?case by simp
  qed
next
  from assms show "P \<longmapsto>a[b] \<prec> P' = (a{b}.P' \<in> summands P)"
  proof(induct P rule: pi.induct)
    case PiNil
    show ?case by auto
  next
    case(Output c d P)
    have "c{d}.P \<longmapsto>a[b] \<prec> P' \<Longrightarrow> a{b}.P' \<in> summands (c{d}.P)"
      by(auto elim: outputCases simp add: residual.inject pi.inject)
    moreover have "a{b}.P' \<in> summands (c{d}.P) \<Longrightarrow> c{d}.P \<longmapsto>a[b] \<prec> P'"
      by(auto simp add: pi.inject intro: transitions.Output)
    ultimately show ?case by blast
  next
    case(Tau P)
    show ?case by auto
  next
    case(Input c x P)
    show ?case by auto
  next
    case(Match a b P)
    have "hnf ([a\<frown>b]P)" by fact
    hence False by simp
    thus ?case by simp
  next
    case(Mismatch a b P)
    have "hnf ([a\<noteq>b]P)" by fact
    hence False by simp
    thus ?case by simp
  next
    case(Sum P Q)
    have "hnf (P \<oplus> Q)" by fact
    hence Phnf: "hnf P" and Qhnf: "hnf Q" by simp+

    have IHP: "P \<longmapsto>a[b] \<prec> P' = (a{b}.P' \<in> summands P)"
    proof -
      have "hnf P \<Longrightarrow> P \<longmapsto>a[b] \<prec> P' = (a{b}.P' \<in> summands P)" by fact
      with Phnf show ?thesis by simp
    qed

    have IHQ: "Q \<longmapsto>a[b] \<prec> P' = (a{b}.P' \<in> summands Q)"
    proof -
      have "hnf Q \<Longrightarrow> Q \<longmapsto>a[b] \<prec> P' = (a{b}.P' \<in> summands Q)" by fact
      with Qhnf show ?thesis by simp
    qed

    from IHP IHQ have "P \<oplus> Q \<longmapsto>a[b] \<prec> P' \<Longrightarrow> a{b}.P' \<in> summands (P \<oplus> Q)"
      by(erule_tac sumCases, auto)
    moreover from IHP IHQ have "a{b}.P' \<in> summands (P \<oplus> Q) \<Longrightarrow> P \<oplus> Q \<longmapsto>a[b] \<prec> P'"
      by(auto dest: Sum1 Sum2)
    ultimately show ?case by blast
  next
    case(Par P Q)
    have "hnf (P \<parallel> Q)" by fact
    hence False by simp
    thus ?case by simp
  next
    case(Res x P)
    have "hnf (<\<nu>x>P)" by fact
    thus ?case by(force elim: resCasesF outputCases simp add: if_split residual.inject)
  next
    case(Bang P)
    have "hnf (!P)" by fact
    hence False by simp
    thus ?case by simp
  qed
next
  assume "a\<noteq>x"
  with assms show "P \<longmapsto>a<\<nu>x> \<prec> P' = (<\<nu>x>a{x}.P' \<in> summands P)"
  proof(nominal_induct P avoiding: x P' rule: pi.strong_induct)
    case PiNil
    show ?case by auto
  next
    case(Output a b P)
    show ?case by auto
  next
    case(Tau P)
    show ?case by auto
  next
    case(Input a x P)
    show ?case by auto
  next
    case(Match a b P)
    have "hnf ([a\<frown>b]P)" by fact
    hence False by simp
    thus ?case by simp
  next
    case(Mismatch a b P)
    have "hnf ([a\<noteq>b]P)" by fact
    hence False by simp
    thus ?case by simp
  next
    case(Sum P Q)
    have "hnf (P \<oplus> Q)" by fact
    hence Phnf: "hnf P" and Qhnf: "hnf Q" by simp+
    have aineqx: "a \<noteq> x" by fact

    have IHP: "P \<longmapsto>a<\<nu>x> \<prec> P' = (<\<nu>x>a{x}.P' \<in> summands P)"
    proof -
      have "\<And>x P'. \<lbrakk>hnf P; a \<noteq> x\<rbrakk> \<Longrightarrow> P \<longmapsto>a<\<nu>x> \<prec> P' = (<\<nu>x>a{x}.P' \<in> summands P)" by fact
      with Phnf aineqx show ?thesis by simp
    qed

    have IHQ: "Q \<longmapsto>a<\<nu>x> \<prec> P' = (<\<nu>x>a{x}.P' \<in> summands Q)"
    proof -
      have "\<And>x Q'. \<lbrakk>hnf Q; a \<noteq> x\<rbrakk> \<Longrightarrow> Q \<longmapsto>a<\<nu>x> \<prec> P' = (<\<nu>x>a{x}.P' \<in> summands Q)" by fact
      with Qhnf aineqx show ?thesis by simp
    qed

    from IHP IHQ have "P \<oplus> Q \<longmapsto>a<\<nu>x> \<prec> P' \<Longrightarrow> <\<nu>x>a{x}.P' \<in> summands (P \<oplus> Q)"
      by(erule_tac sumCases, auto)
    moreover from IHP IHQ have "<\<nu>x>a{x}.P' \<in> summands (P \<oplus> Q) \<Longrightarrow> P \<oplus> Q \<longmapsto>a<\<nu>x> \<prec> P'"
      by(auto dest: Sum1 Sum2)
    ultimately show ?case by blast
  next
    case(Par P Q)
    have "hnf (P \<parallel> Q)" by fact
    hence False by simp
    thus ?case by simp
  next
    case(Res y P)
    have Phnf: "hnf (<\<nu>y>P)" by fact
    then obtain b P'' where bineqy: "b \<noteq> y" and PeqP'': "P = b{y}.P''"
      by auto
    have "y \<sharp> x" by fact hence xineqy:  "x \<noteq> y" by simp
    have yFreshP': "y \<sharp> P'" by fact
    have aineqx: "a\<noteq>x" by fact
    have "<\<nu>y>P \<longmapsto>a<\<nu>x> \<prec> P' \<Longrightarrow> (<\<nu>x>a{x}.P' \<in> summands (<\<nu>y>P))"
    proof -
      assume Trans: "<\<nu>y>P \<longmapsto>a<\<nu>x> \<prec> P'"
      hence  aeqb: "a = b" using xineqy bineqy PeqP''
        by(induct rule: resCasesB', auto elim: outputCases simp add: residual.inject alpha' abs_fresh pi.inject)

      have Goal: "\<And>x P'. \<lbrakk><\<nu>y>b{y}.P'' \<longmapsto>b<\<nu>x> \<prec> P'; x \<noteq> y; x \<noteq> b; x \<sharp> P''\<rbrakk> \<Longrightarrow>
                           <\<nu>x>b{x}.P' \<in> summands(<\<nu>y>b{y}.P'')"
      proof -
        fix x P'
        assume xFreshP'': "(x::name) \<sharp> P''" and xineqb: "x \<noteq> b"
        assume "<\<nu>y>b{y}.P'' \<longmapsto>b<\<nu>x> \<prec> P'" and xineqy: "x \<noteq> y"
        moreover from \<open>x \<noteq> b\<close> \<open>x \<sharp> P''\<close> \<open>x \<noteq> y\<close> have "x \<sharp> b{y}.P''" by simp
        ultimately show "<\<nu>x>b{x}.P' \<in> summands (<\<nu>y>b{y}.P'')"
        proof(induct rule: resCasesB)
          case(cOpen a P''')
          have "BoundOutputS b = BoundOutputS a" by fact hence beqa: "b = a" by simp
          have Trans: "b{y}.P'' \<longmapsto>a[y] \<prec> P'''" by fact
          with PeqP'' have P''eqP''': "P'' = P'''"
            by(force elim: outputCases simp add: residual.inject)
          with bineqy xineqy xFreshP'' have "y \<sharp> b{x}.([(x, y)] \<bullet> P''')"
            by(simp add: name_fresh_abs name_calc name_fresh_left)
          with bineqy Phnf PeqP'' P''eqP''' xineqb show ?case
            by(simp only: alphaRes, simp add: name_calc)
        next
          case(cRes P''')
          have "b{y}.P'' \<longmapsto>b<\<nu>x> \<prec> P'''" by fact
          hence False by auto
          thus ?case by simp
        qed
      qed
      obtain z where zineqx: "z \<noteq> x" and zineqy: "z \<noteq> y" and zFreshP'': "z \<sharp> P''"
                 and zineqb: "z \<noteq> b" and zFreshP': "z \<sharp> P'"
        by(force intro: name_exists_fresh[of "(x, y, b, P'', P')"] simp add: fresh_prod)

      from zFreshP' aeqb PeqP'' Trans have Trans': "<\<nu>y>b{y}.P'' \<longmapsto>b<\<nu>z> \<prec> [(z, x)] \<bullet> P'"
        by(simp add: alphaBoundResidual name_swap)
      hence "<\<nu>z>b{z}.([(z, x)] \<bullet> P') \<in> summands (<\<nu>y>b{y}.P'')" using zineqy zineqb zFreshP''
        by(rule Goal)
      moreover from bineqy zineqx zFreshP' aineqx aeqb have "x \<sharp> b{z}.([(z, x)] \<bullet> P')"
        by(simp add: name_fresh_left name_calc)
      ultimately have "<\<nu>x>b{x}.P' \<in> summands (<\<nu>y>b{y}.P'')" using zineqb
        by(simp add: alphaRes name_calc)
      with aeqb PeqP'' show ?thesis by blast
    qed
    moreover have "<\<nu>x>a{x}.P' \<in> summands(<\<nu>y>P) \<Longrightarrow> <\<nu>y>P \<longmapsto>a<\<nu>x> \<prec> P'"
    proof -
      assume "<\<nu>x>a{x}.P' \<in> summands(<\<nu>y>P)"
      with PeqP'' have Summ: "<\<nu>x>a{x}.P' \<in> summands(<\<nu>y>b{y}.P'')" by simp
      moreover with bineqy xineqy have aeqb: "a = b"
        by(auto simp add: if_split pi.inject name_abs_eq name_fresh_fresh)
      from bineqy xineqy yFreshP' have "y \<sharp> b{x}.P'" by(simp add: name_calc)
      with Summ aeqb bineqy aineqx have "<\<nu>y>b{y}.([(x, y)] \<bullet> P') \<in> summands(<\<nu>y>b{y}.P'')"
        by(simp only: alphaRes, simp add: name_calc)
      with aeqb PeqP'' have "<\<nu>y>P \<longmapsto>a<\<nu>y> \<prec> [(x, y)] \<bullet> P'"
        by(auto intro: Open Output simp add: if_split pi.inject name_abs_eq)
      moreover from yFreshP' have "x \<sharp> [(x, y)] \<bullet> P'" by(simp add: name_fresh_left name_calc)
      ultimately show ?thesis by(simp add: alphaBoundResidual name_swap)
    qed
    ultimately show ?case by blast
  next
    case(Bang P)
    have "hnf (!P)" by fact
    hence False by simp
    thus ?case by simp
  qed
qed

definition "expandSet" :: "pi \<Rightarrow> pi \<Rightarrow> pi set" where
          "expandSet P Q \<equiv> {\<tau>.(P' \<parallel> Q) | P'. \<tau>.(P') \<in> summands P} \<union>
                           {\<tau>.(P \<parallel> Q') | Q'. \<tau>.(Q') \<in> summands Q} \<union>
                           {a{b}.(P' \<parallel> Q) | a b P'. a{b}.P' \<in> summands P} \<union>
                           {a{b}.(P \<parallel> Q') | a b Q'. a{b}.Q' \<in> summands Q} \<union>
                           {a<x>.(P' \<parallel> Q) | a x P'. a<x>.P' \<in> summands P \<and> x \<sharp> Q} \<union>
                           {a<x>.(P \<parallel> Q') | a x Q'. a<x>.Q' \<in> summands Q \<and> x \<sharp> P} \<union>
                           {<\<nu>x>a{x}.(P' \<parallel> Q) | a x P'. <\<nu>x>a{x}.P' \<in> summands P \<and> x \<sharp> Q} \<union>
                           {<\<nu>x>a{x}.(P \<parallel> Q') | a x Q'. <\<nu>x>a{x}.Q' \<in> summands Q \<and> x \<sharp> P} \<union>
                           {\<tau>.(P'[x::=b] \<parallel> Q') | x P' b Q'. \<exists>a. a<x>.P' \<in> summands P \<and> a{b}.Q' \<in> summands Q} \<union>
                           {\<tau>.(P' \<parallel> (Q'[x::=b])) | b P' x Q'. \<exists>a. a{b}.P' \<in> summands P \<and> a<x>.Q' \<in> summands Q} \<union>
                           {\<tau>.(<\<nu>y>(P'[x::=y] \<parallel> Q')) | x P' y Q'. \<exists>a. a<x>.P' \<in> summands P \<and> <\<nu>y>a{y}.Q' \<in> summands Q \<and> y \<sharp> P} \<union>
                           {\<tau>.(<\<nu>y>(P' \<parallel> (Q'[x::=y]))) | y P' x Q'. \<exists>a. <\<nu>y>a{y}.P' \<in> summands P \<and> a<x>.Q' \<in> summands Q \<and> y \<sharp> Q}"

lemma finiteExpand:
  fixes P :: pi
  and   Q :: pi

  shows "finite(expandSet P Q)"
proof -
  have "finite {\<tau>.(P' \<parallel> Q) | P'. \<tau>.(P') \<in> summands P}"
    by(induct P rule: pi.induct, auto simp add: pi.inject Collect_ex_eq conj_disj_distribL
                                                           Collect_disj_eq UN_Un_distrib)
  moreover have "finite {\<tau>.(P \<parallel> Q') | Q'. \<tau>.(Q') \<in> summands Q}"
    by(induct Q rule: pi.induct, auto simp add: pi.inject Collect_ex_eq conj_disj_distribL
                                                           Collect_disj_eq UN_Un_distrib)
  moreover have "finite {a{b}.(P' \<parallel> Q) | a b P'. a{b}.P' \<in> summands P}"
    by(induct P rule: pi.induct, auto simp add: pi.inject Collect_ex_eq conj_disj_distribL
                                                           Collect_disj_eq UN_Un_distrib)
  moreover have "finite {a{b}.(P \<parallel> Q') | a b Q'. a{b}.Q' \<in> summands Q}"
    by(induct Q rule: pi.induct, auto simp add: pi.inject Collect_ex_eq conj_disj_distribL
                                                           Collect_disj_eq UN_Un_distrib)
  moreover have "finite {a<x>.(P' \<parallel> Q) | a x P'. a<x>.P' \<in> summands P \<and> x \<sharp> Q}"
  proof -
    have Aux: "\<And>a x P Q. (x::name) \<sharp> Q \<Longrightarrow> {a'<x'>.(P' \<parallel> Q) |a' x' P'. a'<x'>.P' = a<x>.P \<and> x' \<sharp> Q} = {a<x>.(P \<parallel> Q)}"
      by(auto simp add: pi.inject name_abs_eq name_fresh_fresh)
    thus ?thesis
      by(nominal_induct P avoiding: Q rule: pi.strong_induct,
         auto simp add: Collect_ex_eq conj_disj_distribL conj_disj_distribR
                        Collect_disj_eq UN_Un_distrib)
  qed
  moreover have "finite {a<x>.(P \<parallel> Q') | a x Q'. a<x>.Q' \<in> summands Q \<and> x \<sharp> P}"
  proof -
    have Aux: "\<And>a x P Q. (x::name) \<sharp> P \<Longrightarrow> {a'<x'>.(P \<parallel> Q') |a' x' Q'. a'<x'>.Q' = a<x>.Q \<and> x' \<sharp> P} = {a<x>.(P \<parallel> Q)}"
      by(auto simp add: pi.inject name_abs_eq name_fresh_fresh)
    thus ?thesis
      by(nominal_induct Q avoiding: P rule: pi.strong_induct,
         auto simp add: Collect_ex_eq conj_disj_distribL conj_disj_distribR
                        Collect_disj_eq UN_Un_distrib)
  qed
  moreover have "finite {<\<nu>x>a{x}.(P' \<parallel> Q) | a x P'. <\<nu>x>a{x}.P' \<in> summands P \<and> x \<sharp> Q}"
  proof -
    have Aux: "\<And>a x P Q. \<lbrakk>x \<sharp> Q; a \<noteq> x\<rbrakk> \<Longrightarrow> {<\<nu>x'>a'{x'}.(P' \<parallel> Q) |a' x' P'. <\<nu>x'>a'{x'}.P' = <\<nu>x>a{x}.P \<and> x' \<sharp> Q} =
                                             {<\<nu>x>a{x}.(P \<parallel> Q)}"
      by(auto simp add: pi.inject name_abs_eq name_fresh_fresh)
    thus ?thesis
      by(nominal_induct P avoiding: Q rule: pi.strong_induct,
         auto simp add: Collect_ex_eq conj_disj_distribL conj_disj_distribR
                        Collect_disj_eq UN_Un_distrib)
  qed
  moreover have "finite {<\<nu>x>a{x}.(P \<parallel> Q') | a x Q'. <\<nu>x>a{x}.Q' \<in> summands Q \<and> x \<sharp> P}"
  proof -
    have Aux: "\<And>a x P Q. \<lbrakk>x \<sharp> P; a \<noteq> x\<rbrakk> \<Longrightarrow> {<\<nu>x'>a'{x'}.(P \<parallel> Q') |a' x' Q'. <\<nu>x'>a'{x'}.Q' = <\<nu>x>a{x}.Q \<and> x' \<sharp> P} =
                                             {<\<nu>x>a{x}.(P \<parallel> Q)}"
      by(auto simp add: pi.inject name_abs_eq name_fresh_fresh)
    thus ?thesis
      by(nominal_induct Q avoiding: P rule: pi.strong_induct,
         auto simp add: Collect_ex_eq conj_disj_distribL conj_disj_distribR
                        Collect_disj_eq UN_Un_distrib)
  qed
  moreover have "finite {\<tau>.(P'[x::=b] \<parallel> Q') | x P' b Q'. \<exists>a. a<x>.P' \<in> summands P \<and> a{b}.Q' \<in> summands Q}"
  proof -
    have Aux: "\<And>a x P b Q. {\<tau>.(P'[x'::=b'] \<parallel> Q') | a' x' P' b' Q'. a'<x'>.P' = a<x>.P \<and> a'{b'}.Q' = a{b}.Q} = {\<tau>.(P[x::=b] \<parallel> Q)}"
      by(auto simp add: name_abs_eq pi.inject renaming)
    have "\<And>a x P Q b::'a::{}. finite {\<tau>.(P'[x'::=b] \<parallel> Q') | a' x' P' b Q'. a'<x'>.P' = a<x>.P \<and> a'{b}.Q' \<in> summands Q}"
      apply(induct rule: pi.induct, simp_all)
      apply(case_tac "a=name1")
      apply(simp add: Aux)
      apply(simp add: pi.inject)
      by(simp add: Collect_ex_eq conj_disj_distribL conj_disj_distribR
                   Collect_disj_eq UN_Un_distrib)
    hence "finite {\<tau>.(P'[x::=b] \<parallel> Q') | a x P' b Q'. a<x>.P' \<in> summands P \<and> a{b}.Q' \<in> summands Q}"
      by(nominal_induct P avoiding: Q rule: pi.strong_induct,
         auto simp add: Collect_ex_eq conj_disj_distribL conj_disj_distribR
                        Collect_disj_eq UN_Un_distrib name_abs_eq)
    thus ?thesis
      apply(rule_tac finite_subset)
      defer
      by blast+
  qed
  moreover have "finite {\<tau>.(P' \<parallel> (Q'[x::=b])) | b P' x Q'. \<exists>a. a{b}.P' \<in> summands P \<and> a<x>.Q' \<in> summands Q}"
  proof -
      have Aux: "\<And>a x P b Q. {\<tau>.(P' \<parallel> (Q'[x'::=b'])) | a' b' P' x' Q'. a'{b'}.P' = a{b}.P \<and> a'<x'>.Q' = a<x>.Q} = {\<tau>.(P \<parallel> (Q[x::=b]))}"
        by(auto simp add: name_abs_eq pi.inject renaming)
      have "\<And>a b P Q x::'a::{}. finite {\<tau>.(P' \<parallel> (Q'[x::=b'])) | a' b' P' x Q'. a'{b'}.P' = a{b}.P \<and> a'<x>.Q' \<in> summands Q}"
      apply(induct rule: pi.induct, simp_all)
      apply(case_tac "a=name1")
      apply(simp add: Aux)
      apply(simp add: pi.inject)
      by(simp add: Collect_ex_eq conj_disj_distribL conj_disj_distribR
                     Collect_disj_eq UN_Un_distrib)
    hence "finite {\<tau>.(P' \<parallel> (Q'[x::=b])) | a b P' x Q'. a{b}.P' \<in> summands P \<and> a<x>.Q' \<in> summands Q}"
      by(nominal_induct P avoiding: Q rule: pi.strong_induct,
         auto simp add: Collect_ex_eq conj_disj_distribL conj_disj_distribR
                        Collect_disj_eq UN_Un_distrib name_abs_eq)
    thus ?thesis
      apply(rule_tac finite_subset) defer by blast+
  qed
  moreover have "finite {\<tau>.(<\<nu>y>(P'[x::=y] \<parallel> Q')) | x P' y Q'. \<exists>a. a<x>.P' \<in> summands P \<and> <\<nu>y>a{y}.Q' \<in> summands Q \<and> y \<sharp> P}"
  proof -
    have Aux: "\<And>a x P y Q. y \<sharp> P \<and> y \<noteq> a \<Longrightarrow> {\<tau>.(<\<nu>y'>(P'[x'::=y'] \<parallel> Q')) | a' x' P' y' Q'. a'<x'>.P' = a<x>.P \<and> <\<nu>y'>a'{y'}.Q' = <\<nu>y>a{y}.Q \<and> y' \<sharp> a<x>.P} = {\<tau>.(<\<nu>y>(P[x::=y] \<parallel> Q))}"
      apply(auto simp add: pi.inject name_abs_eq name_fresh_abs name_calc fresh_fact2 fresh_fact1 eqvts forget)
      apply(subst name_swap, simp add: injPermSubst fresh_fact1 fresh_fact2)+
      by(simp add: name_swap injPermSubst)+

    have BC: "\<And>a x P Q. finite {\<tau>.(<\<nu>y>(P'[x'::=y] \<parallel> Q')) | a' x' P' y Q'. a'<x'>.P' = a<x>.P \<and> <\<nu>y>a'{y}.Q' \<in> summands Q \<and> y \<sharp> a<x>.P}"
    proof -
      fix a x P Q
      show "finite {\<tau>.(<\<nu>y>(P'[x'::=y] \<parallel> Q')) | a' x' P' y Q'. a'<x'>.P' = a<x>.P \<and> <\<nu>y>a'{y}.Q' \<in> summands Q \<and> y \<sharp> a<x>.P}"
        apply(nominal_induct Q avoiding: a P rule: pi.strong_induct, simp_all)
        apply(simp add: Collect_ex_eq conj_disj_distribL conj_disj_distribR
                        Collect_disj_eq UN_Un_distrib)
        apply(clarsimp)
        apply(case_tac "a=aa")
        apply(insert Aux, auto)
        by(simp add: pi.inject name_abs_eq name_calc)
    qed

    have IH: "\<And>P P' Q. {\<tau>.(<\<nu>y>(P''[x::=y] \<parallel> Q')) | a x P'' y Q'. (a<x>.P'' \<in> summands P \<or> a<x>.P'' \<in> summands P') \<and> <\<nu>y>a{y}.Q' \<in> summands Q \<and> y \<sharp> P \<and> y \<sharp> P'} = {\<tau>.(<\<nu>y>(P''[x::=y] \<parallel> Q')) | a x P'' y Q'. a<x>.P'' \<in> summands P \<and> <\<nu>y>a{y}.Q' \<in> summands Q \<and> y \<sharp> P \<and> y \<sharp> P'} \<union> {\<tau>.(<\<nu>y>(P''[x::=y] \<parallel> Q')) | a x P'' y Q'. a<x>.P'' \<in> summands P' \<and> <\<nu>y>a{y}.Q' \<in> summands Q \<and> y \<sharp> P \<and> y \<sharp> P'}"
      by blast
    have IH': "\<And>P Q P'. {\<tau>.(<\<nu>y>(P''[x::=y] \<parallel> Q')) | a x P'' y Q'. a<x>.P'' \<in> summands P \<and> <\<nu>y>a{y}.Q' \<in> summands Q \<and> y \<sharp> P \<and> y \<sharp> P'} \<subseteq> {\<tau>.(<\<nu>y>(P''[x::=y] \<parallel> Q')) | a x P'' y Q'. a<x>.P'' \<in> summands P \<and> <\<nu>y>a{y}.Q' \<in> summands Q \<and> y \<sharp> P}"
      by blast
    have IH'': "\<And>P Q P'. {\<tau>.(<\<nu>y>(P''[x::=y] \<parallel> Q')) | a x P'' y Q'. a<x>.P'' \<in> summands P' \<and> <\<nu>y>a{y}.Q' \<in> summands Q \<and> y \<sharp> P \<and> y \<sharp> P'} \<subseteq> {\<tau>.(<\<nu>y>(P''[x::=y] \<parallel> Q')) | a x P'' y Q'. a<x>.P'' \<in> summands P' \<and> <\<nu>y>a{y}.Q' \<in> summands Q \<and> y \<sharp> P'}"
      by blast
    have "finite {\<tau>.(<\<nu>y>(P'[x::=y] \<parallel> Q')) | a x P' y Q'. a<x>.P' \<in> summands P \<and> <\<nu>y>a{y}.Q' \<in> summands Q \<and> y \<sharp> P}"
      apply(nominal_induct P avoiding: Q rule: pi.strong_induct, simp_all)
      apply(insert BC, force)
      apply(insert IH, auto)
      apply(blast intro: finite_subset[OF IH'])
      by(blast intro: finite_subset[OF IH''])
    thus ?thesis
      apply(rule_tac finite_subset) defer by(blast)+
  qed
  moreover have "finite {\<tau>.(<\<nu>y>(P' \<parallel> (Q'[x::=y]))) | y P' x Q'. \<exists>a. <\<nu>y>a{y}.P' \<in> summands P \<and> a<x>.Q' \<in> summands Q \<and> y \<sharp> Q}"
  proof -
    have Aux: "\<And>a y P x Q. \<lbrakk>y \<sharp> Q; y \<noteq> a\<rbrakk> \<Longrightarrow> {\<tau>.(<\<nu>y'>(P' \<parallel> (Q'[x'::=y']))) | a' y' P' x' Q'. <\<nu>y'>a'{y'}.P' = <\<nu>y>a{y}.P \<and> a'<x'>.Q' = a<x>.Q \<and> y' \<sharp> a<x>.Q} = {\<tau>.(<\<nu>y>(P \<parallel> (Q[x::=y])))}"
      apply(auto simp add: pi.inject name_abs_eq name_fresh_abs name_calc fresh_fact2 fresh_fact1 forget eqvts fresh_left renaming[symmetric])
      apply(subst name_swap, simp add: injPermSubst fresh_fact1 fresh_fact2)+
      by(simp add: name_swap injPermSubst)+

    have IH: "\<And>P y a Q Q'. {\<tau>.(<\<nu>y'>(P' \<parallel> (Q''[x::=y']))) | a' y' P' x Q''. <\<nu>y'>a'{y'}.P' = <\<nu>y>a{y}.P \<and> (a'<x>.Q'' \<in> summands Q \<or> a'<x>.Q'' \<in> summands Q') \<and> y' \<sharp> Q \<and> y' \<sharp> Q'} = {\<tau>.(<\<nu>y'>(P' \<parallel> (Q''[x::=y']))) | a' y' P' x Q''. <\<nu>y'>a'{y'}.P' = <\<nu>y>a{y}.P \<and> a'<x>.Q'' \<in> summands Q \<and> y' \<sharp> Q \<and> y' \<sharp> Q'} \<union> {\<tau>.(<\<nu>y'>(P' \<parallel> (Q''[x::=y']))) | a' y' P' x Q''. <\<nu>y'>a'{y'}.P' = <\<nu>y>a{y}.P \<and> a'<x>.Q'' \<in> summands Q' \<and> y' \<sharp> Q \<and> y' \<sharp> Q'}"
      by blast
    have IH': "\<And>a y P Q Q'. {\<tau>.(<\<nu>y'>(P' \<parallel> (Q''[x::=y']))) | a' y' P' x Q''. <\<nu>y'>a'{y'}.P' = <\<nu>y>a{y}.P \<and> a'<x>.Q'' \<in> summands Q \<and> y' \<sharp> Q \<and> y' \<sharp> Q'} \<subseteq> {\<tau>.(<\<nu>y'>(P' \<parallel> (Q''[x::=y']))) | a' y' P' x Q''. <\<nu>y'>a'{y'}.P' = <\<nu>y>a{y}.P \<and> a'<x>.Q'' \<in> summands Q \<and> y' \<sharp> Q}"
      by blast
    have IH'': "\<And>a y P Q Q'. {\<tau>.(<\<nu>y'>(P' \<parallel> (Q''[x::=y']))) | a' y' P' x Q''. <\<nu>y'>a'{y'}.P' = <\<nu>y>a{y}.P \<and> a'<x>.Q'' \<in> summands Q' \<and> y' \<sharp> Q \<and> y' \<sharp> Q'} \<subseteq> {\<tau>.(<\<nu>y'>(P' \<parallel> (Q''[x::=y']))) | a' y' P' x Q''. <\<nu>y'>a'{y'}.P' = <\<nu>y>a{y}.P \<and> a'<x>.Q'' \<in> summands Q' \<and> y' \<sharp> Q'}"
      by blast

    have BC: "\<And>a y P Q. \<lbrakk>y \<sharp> Q; y \<noteq> a\<rbrakk> \<Longrightarrow> finite {\<tau>.(<\<nu>y'>(P' \<parallel> (Q'[x::=y']))) | a' y' P' x Q'. <\<nu>y'>a'{y'}.P' = <\<nu>y>a{y}.P \<and> a'<x>.Q' \<in> summands Q \<and> y' \<sharp> Q}"
    proof -
      fix a y P Q
      assume "(y::name) \<sharp> (Q::pi)" and "y \<noteq> a"
      thus "finite {\<tau>.(<\<nu>y'>(P' \<parallel> (Q'[x::=y']))) | a' y' P' x Q'. <\<nu>y'>a'{y'}.P' = <\<nu>y>a{y}.P \<and> a'<x>.Q' \<in> summands Q \<and> y' \<sharp> Q}"
        apply(nominal_induct Q avoiding: y rule: pi.strong_induct, simp_all)
        apply(case_tac "a=name1")
        apply auto
        apply(subgoal_tac "ya \<sharp> (pi::pi)")
        apply(insert Aux)
        apply auto
        apply(simp add: name_fresh_abs)
        apply(simp add: pi.inject name_abs_eq name_calc)
        apply(insert IH)
        apply auto
        apply(blast intro: finite_subset[OF IH'])
        by(blast intro: finite_subset[OF IH''])
    qed
    have "finite {\<tau>.(<\<nu>y>(P' \<parallel> (Q'[x::=y]))) | a y P' x Q'. <\<nu>y>a{y}.P' \<in> summands P \<and> a<x>.Q' \<in> summands Q \<and> y \<sharp> Q}"

      apply(nominal_induct P avoiding: Q rule: pi.strong_induct, simp_all)
      apply(simp add: Collect_ex_eq conj_disj_distribL conj_disj_distribR name_fresh_abs
                      Collect_disj_eq UN_Un_distrib)
      by(auto intro: BC)
    thus ?thesis
      apply(rule_tac finite_subset) defer by blast+
  qed

  ultimately show ?thesis
    by(simp add: expandSet_def)
qed

lemma expandHnf:
  fixes P :: pi
  and   Q :: pi

  shows "\<forall>R \<in> (expandSet P Q). hnf R"
by(force simp add: expandSet_def)

inductive_set sumComposeSet :: "(pi \<times> pi set) set"
where
  empty:  "(\<zero>, {}) \<in> sumComposeSet"
| insert: "\<lbrakk>Q \<in> S; (P, S - {Q}) \<in> sumComposeSet\<rbrakk> \<Longrightarrow> (P \<oplus> Q, S) \<in> sumComposeSet"

lemma expandAction:
  fixes P :: pi
  and   Q :: pi
  and   S :: "pi set"

  assumes "(P, S) \<in> sumComposeSet"
  and     "Q \<in> S"
  and     "Q \<longmapsto> Rs"

  shows "P \<longmapsto> Rs"
using assms
proof(induct arbitrary: Q rule: sumComposeSet.induct)
  case empty
  have "Q \<in> {}" by fact
  hence False by simp
  thus ?case by simp
next
  case(insert Q' S P Q)
  have QTrans: "Q \<longmapsto> Rs" by fact
  show ?case
  proof(case_tac "Q = Q'")
    assume "Q = Q'"
    with QTrans show "P \<oplus> Q' \<longmapsto> Rs" by(blast intro: Sum2)
  next
    assume QineqQ': "Q \<noteq> Q'"
    have IH: "\<And>Q. \<lbrakk>Q \<in> S - {Q'}; Q \<longmapsto> Rs\<rbrakk> \<Longrightarrow> P \<longmapsto> Rs" by fact
    have QinS: "Q \<in> S" by fact
    with QineqQ' have "Q \<in> S - {Q'}" by simp
    hence "P \<longmapsto> Rs" using QTrans by(rule IH)
    thus ?case by(rule Sum1)
  qed
qed

lemma expandAction':
  fixes P :: pi
  and   Q :: pi
  and   R :: pi

  assumes "(R, S) \<in> sumComposeSet"
  and     "R \<longmapsto> Rs"

  shows "\<exists>P \<in> S. P \<longmapsto> Rs"
using assms
proof(induct rule: sumComposeSet.induct)
  case empty
  have "\<zero> \<longmapsto> Rs" by fact
  hence False by blast
  thus ?case by simp
next
  case(insert Q S P)
  have QinS: "Q \<in> S" by fact
  have "P \<oplus> Q \<longmapsto> Rs" by fact
  thus ?case
  proof(induct rule: sumCases)
    case cSum1
    have "P \<longmapsto> Rs" by fact
    moreover have "P \<longmapsto> Rs \<Longrightarrow> \<exists>P \<in> (S - {Q}). P \<longmapsto> Rs" by fact
    ultimately obtain P where PinS: "P \<in> (S - {Q})" and PTrans: "P \<longmapsto> Rs" by blast
    show ?case
    proof(case_tac "P = Q")
      assume "P = Q"
      with PTrans QinS show ?case by blast
    next
      assume PineqQ: "P \<noteq> Q"
      from PinS have "P \<in> S" by simp
      with PTrans show ?thesis by blast
    qed
  next
    case cSum2
    have "Q \<longmapsto> Rs" by fact
    with QinS show ?case by blast
  qed
qed

lemma expandTrans:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi
  and   a :: name
  and   b :: name
  and   x :: name

  assumes Exp: "(R, expandSet P Q) \<in> sumComposeSet"
  and     Phnf: "hnf P"
  and     Qhnf: "hnf Q"

  shows "(P \<parallel> Q \<longmapsto>\<tau> \<prec> P') = (R \<longmapsto>\<tau> \<prec> P')"
  and   "(P \<parallel> Q \<longmapsto>a[b] \<prec> P') = (R \<longmapsto>a[b] \<prec> P')"
  and   "(P \<parallel> Q \<longmapsto>a<x> \<prec> P') = (R \<longmapsto>a<x> \<prec> P')"
  and   "(P \<parallel> Q \<longmapsto>a<\<nu>x> \<prec> P') = (R \<longmapsto>a<\<nu>x> \<prec> P')"
proof -
  show "P \<parallel> Q \<longmapsto> \<tau> \<prec> P' = R \<longmapsto> \<tau> \<prec> P'"
  proof(rule iffI)
    assume "P \<parallel> Q \<longmapsto>\<tau> \<prec> P'"
    thus "R \<longmapsto>\<tau> \<prec> P'"
    proof(induct rule: parCasesF[of _ _ _ _ _ "(P, Q)"])
      case(cPar1 P')
      have "P \<longmapsto>\<tau> \<prec> P'" by fact
      with Phnf have "\<tau>.(P') \<in> summands P" by(simp add: summandTransition)
      hence "\<tau>.(P' \<parallel> Q) \<in> expandSet P Q" by(auto simp add: expandSet_def)
      moreover have "\<tau>.(P' \<parallel> Q) \<longmapsto>\<tau> \<prec> (P' \<parallel> Q)" by(rule Tau)
      ultimately show ?case using Exp by(blast intro: expandAction)
    next
      case(cPar2 Q')
      have "Q \<longmapsto>\<tau> \<prec> Q'" by fact
      with Qhnf have "\<tau>.(Q') \<in> summands Q" by(simp add: summandTransition)
      hence "\<tau>.(P \<parallel> Q') \<in> expandSet P Q" by(auto simp add: expandSet_def)
      moreover have "\<tau>.(P \<parallel> Q') \<longmapsto>\<tau> \<prec> (P \<parallel> Q')" by(rule Tau)
      ultimately show ?case using Exp by(blast intro: expandAction)
    next
      case(cComm1 P' Q' a b x)
      have "P \<longmapsto>a<x> \<prec> P'" and "Q \<longmapsto>a[b] \<prec> Q'" by fact+
      with Phnf Qhnf have "a<x>.P' \<in> summands P" and "a{b}.Q' \<in> summands Q" by(simp add: summandTransition)+
      hence "\<tau>.(P'[x::=b] \<parallel> Q') \<in> expandSet P Q" by(simp add: expandSet_def, blast)
      moreover have "\<tau>.(P'[x::=b] \<parallel> Q') \<longmapsto>\<tau> \<prec> (P'[x::=b] \<parallel> Q')" by(rule Tau)
      ultimately show ?case using Exp by(blast intro: expandAction)
    next
      case(cComm2 P' Q' a b x)
      have "P \<longmapsto>a[b] \<prec> P'" and "Q \<longmapsto>a<x> \<prec> Q'" by fact+
      with Phnf Qhnf have "a{b}.P' \<in> summands P" and "a<x>.Q' \<in> summands Q" by(simp add: summandTransition)+
      hence "\<tau>.(P' \<parallel> (Q'[x::=b])) \<in> expandSet P Q" by(simp add: expandSet_def, blast)
      moreover have "\<tau>.(P' \<parallel> (Q'[x::=b])) \<longmapsto>\<tau> \<prec> (P' \<parallel> (Q'[x::=b]))" by(rule Tau)
      ultimately show ?case using Exp by(blast intro: expandAction)
    next
      case(cClose1 P' Q' a x y)
      have "y \<sharp> (P, Q)" by fact
      hence yFreshP: "y \<sharp> P" by(simp add: fresh_prod)
      have PTrans: "P \<longmapsto>a<x> \<prec> P'" by fact
      with Phnf have PSumm: "a<x>.P' \<in> summands P" by(simp add: summandTransition)
      have "Q \<longmapsto>a<\<nu>y> \<prec> Q'" by fact
      moreover from PTrans yFreshP have "y \<noteq> a" by(force dest: freshBoundDerivative)
      ultimately have "<\<nu>y>a{y}.Q' \<in> summands Q" using Qhnf by(simp add: summandTransition)
      with PSumm yFreshP have "\<tau>.(<\<nu>y>(P'[x::=y] \<parallel> Q')) \<in> expandSet P Q"
        by(auto simp add: expandSet_def)
      moreover have "\<tau>.(<\<nu>y>(P'[x::=y] \<parallel> Q')) \<longmapsto>\<tau> \<prec> <\<nu>y>(P'[x::=y] \<parallel> Q')" by(rule Tau)
      ultimately show ?case using Exp by(blast intro: expandAction)
    next
      case(cClose2 P' Q' a x y)
      have "y \<sharp> (P, Q)" by fact
      hence yFreshQ: "y \<sharp> Q" by(simp add: fresh_prod)
      have QTrans: "Q \<longmapsto>a<x> \<prec> Q'" by fact
      with Qhnf have QSumm: "a<x>.Q' \<in> summands Q" by(simp add: summandTransition)
      have "P \<longmapsto>a<\<nu>y> \<prec> P'" by fact
      moreover from QTrans yFreshQ have "y \<noteq> a" by(force dest: freshBoundDerivative)
      ultimately have "<\<nu>y>a{y}.P' \<in> summands P" using Phnf by(simp add: summandTransition)
      with QSumm yFreshQ have "\<tau>.(<\<nu>y>(P' \<parallel> (Q'[x::=y]))) \<in> expandSet P Q"
        by(simp add: expandSet_def, blast)
      moreover have "\<tau>.(<\<nu>y>(P' \<parallel> (Q'[x::=y]))) \<longmapsto>\<tau> \<prec> <\<nu>y>(P' \<parallel> (Q'[x::=y]))" by(rule Tau)
      ultimately show ?case using Exp by(blast intro: expandAction)
    qed
  next
    assume "R \<longmapsto>\<tau> \<prec> P'"
    with Exp obtain R where "R \<in> expandSet P Q" and "R \<longmapsto>\<tau> \<prec> P'" by(blast dest: expandAction')
    thus "P \<parallel> Q \<longmapsto>\<tau> \<prec> P'"
    proof(auto simp add: expandSet_def)
      fix P''
      assume "\<tau>.(P'') \<in> summands P"
      with Phnf have "P \<longmapsto>\<tau> \<prec> P''" by(simp add: summandTransition)
      hence PQTrans: "P \<parallel> Q \<longmapsto>\<tau> \<prec> P'' \<parallel> Q" by(rule Par1F)
      assume "\<tau>.(P'' \<parallel> Q) \<longmapsto>\<tau> \<prec> P'"
      hence "P' = P'' \<parallel> Q" by(erule_tac tauCases, auto simp add: pi.inject residual.inject)
      with PQTrans show ?thesis by simp
    next
      fix Q'
      assume "\<tau>.(Q') \<in> summands Q"
      with Qhnf have "Q \<longmapsto>\<tau> \<prec> Q'" by(simp add: summandTransition)
      hence PQTrans: "P \<parallel> Q \<longmapsto>\<tau> \<prec> P \<parallel> Q'" by(rule Par2F)
      assume "\<tau>.(P \<parallel> Q') \<longmapsto>\<tau> \<prec> P'"
      hence "P' = P \<parallel> Q'" by(erule_tac tauCases, auto simp add: pi.inject residual.inject)
      with PQTrans show ?thesis by simp
    next
      fix a x P'' b Q'
      assume "a<x>.P'' \<in> summands P" and "a{b}.Q' \<in> summands Q"
      with Phnf Qhnf have "P \<longmapsto>a<x> \<prec> P''" and "Q \<longmapsto>a[b] \<prec> Q'" by(simp add: summandTransition)+
      hence PQTrans: "P \<parallel> Q \<longmapsto>\<tau> \<prec> P''[x::=b] \<parallel> Q'" by(rule Comm1)
      assume "\<tau>.(P''[x::=b] \<parallel> Q') \<longmapsto>\<tau> \<prec> P'"
      hence "P' = P''[x::=b] \<parallel> Q'" by(erule_tac tauCases, auto simp add: pi.inject residual.inject)
      with PQTrans show ?thesis by simp
    next
      fix a b P'' x Q'
      assume "a{b}.P'' \<in> summands P" and "a<x>.Q' \<in> summands Q"
      with Phnf Qhnf have "P \<longmapsto>a[b] \<prec> P''" and "Q \<longmapsto>a<x> \<prec> Q'" by(simp add: summandTransition)+
      hence PQTrans: "P \<parallel> Q \<longmapsto>\<tau> \<prec> P'' \<parallel> (Q'[x::=b])" by(rule Comm2)
      assume "\<tau>.(P'' \<parallel> (Q'[x::=b])) \<longmapsto>\<tau> \<prec> P'"
      hence "P' = P'' \<parallel> (Q'[x::=b])" by(erule_tac tauCases, auto simp add: pi.inject residual.inject)
      with PQTrans show ?thesis by simp
    next
      fix a x P'' y Q'
      assume yFreshP: "(y::name) \<sharp> P"
      assume "a<x>.P'' \<in> summands P"
      with Phnf have PTrans: "P \<longmapsto>a<x> \<prec> P''" by(simp add: summandTransition)
      assume "<\<nu>y>a{y}.Q' \<in> summands Q"
      moreover from yFreshP PTrans have "y \<noteq> a" by(force dest: freshBoundDerivative)
      ultimately have "Q \<longmapsto>a<\<nu>y> \<prec> Q'" using Qhnf by(simp add: summandTransition)
      with PTrans have PQTrans: "P \<parallel> Q \<longmapsto>\<tau> \<prec> <\<nu>y>(P''[x::=y] \<parallel> Q')" using yFreshP by(rule Close1)
      assume "\<tau>.(<\<nu>y>(P''[x::=y] \<parallel> Q')) \<longmapsto>\<tau> \<prec> P'"
      hence "P' = <\<nu>y>(P''[x::=y] \<parallel> Q')" by(erule_tac tauCases, auto simp add: pi.inject residual.inject)
      with PQTrans show ?thesis by simp
    next
      fix a y P'' x Q'
      assume yFreshQ: "(y::name) \<sharp> Q"
      assume "a<x>.Q' \<in> summands Q"
      with Qhnf have QTrans: "Q \<longmapsto>a<x> \<prec> Q'" by(simp add: summandTransition)
      assume "<\<nu>y>a{y}.P'' \<in> summands P"
      moreover from yFreshQ QTrans have "y \<noteq> a" by(force dest: freshBoundDerivative)
      ultimately have "P \<longmapsto>a<\<nu>y> \<prec> P''" using Phnf by(simp add: summandTransition)
      hence PQTrans: "P \<parallel> Q \<longmapsto>\<tau> \<prec> <\<nu>y>(P'' \<parallel> Q'[x::=y])" using QTrans yFreshQ by(rule Close2)
      assume "\<tau>.(<\<nu>y>(P'' \<parallel> Q'[x::=y])) \<longmapsto>\<tau> \<prec> P'"
      hence "P' = <\<nu>y>(P'' \<parallel> Q'[x::=y])" by(erule_tac tauCases, auto simp add: pi.inject residual.inject)
      with PQTrans show ?thesis by simp
    qed
  qed
next
  show "P \<parallel> Q \<longmapsto> a[b] \<prec> P' = R \<longmapsto> a[b] \<prec> P'"
  proof(rule iffI)
    assume "P \<parallel> Q \<longmapsto>a[b] \<prec> P'"
    thus "R \<longmapsto>a[b] \<prec> P'"
    proof(induct rule: parCasesF[where C="()"])
      case(cPar1 P')
      have "P \<longmapsto>a[b] \<prec> P'" by fact
      with Phnf have "a{b}.P' \<in> summands P" by(simp add: summandTransition)
      hence "a{b}.(P' \<parallel> Q) \<in> expandSet P Q" by(auto simp add: expandSet_def)
      moreover have "a{b}.(P' \<parallel> Q) \<longmapsto>a[b] \<prec> (P' \<parallel> Q)" by(rule Output)
      ultimately show ?case using Exp by(blast intro: expandAction)
    next
      case(cPar2 Q')
      have "Q \<longmapsto>a[b] \<prec> Q'" by fact
      with Qhnf have "a{b}.Q' \<in> summands Q" by(simp add: summandTransition)
      hence "a{b}.(P \<parallel> Q') \<in> expandSet P Q" by(simp add: expandSet_def, blast)
      moreover have "a{b}.(P \<parallel> Q') \<longmapsto>a[b] \<prec> (P \<parallel> Q')" by(rule Output)
      ultimately show ?case using Exp by(blast intro: expandAction)
    next
      case cComm1
      thus ?case by auto
    next
      case cComm2
      thus ?case by auto
    next
      case cClose1
      thus ?case by auto
    next
      case cClose2
      thus ?case by auto
    qed
  next
    assume "R \<longmapsto>a[b] \<prec> P'"
    with Exp obtain R where "R \<in> expandSet P Q" and "R \<longmapsto>a[b] \<prec> P'" by(blast dest: expandAction')
    thus "P \<parallel> Q \<longmapsto>a[b] \<prec> P'"
    proof(auto simp add: expandSet_def)
      fix a' b' P''
      assume "a'{b'}.P'' \<in> summands P"
      with Phnf have "P \<longmapsto>a'[b'] \<prec> P''" by(simp add: summandTransition)
      hence PQTrans: "P \<parallel> Q \<longmapsto>a'[b'] \<prec> P'' \<parallel> Q" by(rule Par1F)
      assume "a'{b'}.(P'' \<parallel> Q) \<longmapsto>a[b] \<prec> P'"
      hence "P' = P'' \<parallel> Q" and "a = a'" and "b = b'"
        by(erule_tac outputCases, auto simp add: pi.inject residual.inject)+
      with PQTrans show ?thesis by simp
    next
      fix a' b' Q'
      assume "a'{b'}.Q' \<in> summands Q"
      with Qhnf have "Q \<longmapsto>a'[b'] \<prec> Q'" by(simp add: summandTransition)
      hence PQTrans: "P \<parallel> Q \<longmapsto>a'[b'] \<prec> P \<parallel> Q'" by(rule Par2F)
      assume "a'{b'}.(P \<parallel> Q') \<longmapsto>a[b] \<prec> P'"
      hence "P' = P \<parallel> Q'" and "a = a'" and "b = b'"
        by(erule_tac outputCases, auto simp add: pi.inject residual.inject)+
      with PQTrans show ?thesis by simp
    qed
  qed
next
  show "P \<parallel> Q \<longmapsto> a<x> \<prec> P' = R \<longmapsto> a<x> \<prec> P'"
  proof(rule iffI)
    {
      fix x P'
      assume "P \<parallel> Q \<longmapsto>a<x> \<prec> P'" and "x \<sharp> P" and "x \<sharp> Q"
      hence "R \<longmapsto>a<x> \<prec> P'"
      proof(induct rule: parCasesB)
        case(cPar1 P')
        have "P \<longmapsto>a<x> \<prec> P'" by fact
        with Phnf have "a<x>.P' \<in> summands P" by(simp add: summandTransition)
        moreover have "x \<sharp> Q" by fact
        ultimately have "a<x>.(P' \<parallel> Q) \<in> expandSet P Q" by(auto simp add: expandSet_def)
        moreover have "a<x>.(P' \<parallel> Q) \<longmapsto>a<x> \<prec> (P' \<parallel> Q)" by(rule Input)
        ultimately show ?case using Exp by(blast intro: expandAction)
      next
        case(cPar2 Q')
        have "Q \<longmapsto>a<x> \<prec> Q'" by fact
        with Qhnf have "a<x>.Q' \<in> summands Q" by(simp add: summandTransition)
        moreover have "x \<sharp> P" by fact
        ultimately have "a<x>.(P \<parallel> Q') \<in> expandSet P Q" by(simp add: expandSet_def, blast)
        moreover have "a<x>.(P \<parallel> Q') \<longmapsto>a<x> \<prec> (P \<parallel> Q')" by(rule Input)
        ultimately show ?case using Exp by(blast intro: expandAction)
      qed
    }
    moreover obtain y::name where "y \<sharp> P" and "y \<sharp> Q" and "y \<sharp> P'"
      by(generate_fresh "name") auto
    assume "P \<parallel> Q \<longmapsto>a<x> \<prec> P'"
    with \<open>y \<sharp> P'\<close> have "P \<parallel> Q \<longmapsto>a<y> \<prec> ([(x, y)] \<bullet> P')"
      by(simp add: alphaBoundResidual)
    ultimately have "R \<longmapsto>a<y> \<prec> ([(x, y)] \<bullet> P')" using \<open>y \<sharp> P\<close> \<open>y \<sharp> Q\<close>
      by auto
    thus "R \<longmapsto>a<x> \<prec> P'" using \<open>y \<sharp> P'\<close> by(simp add: alphaBoundResidual)
  next
    assume "R \<longmapsto>a<x> \<prec> P'"
    with Exp obtain R where "R \<in> expandSet P Q" and "R \<longmapsto>a<x> \<prec> P'" by(blast dest: expandAction')
    thus "P \<parallel> Q \<longmapsto>a<x> \<prec> P'"
    proof(auto simp add: expandSet_def)
      fix a' y P''
      assume "a'<y>.P'' \<in> summands P"
      with Phnf have "P \<longmapsto>a'<y> \<prec> P''" by(simp add: summandTransition)
      moreover assume "y \<sharp> Q"
      ultimately have PQTrans: "P \<parallel> Q \<longmapsto>a'<y> \<prec> P'' \<parallel> Q" by(rule Par1B)
      assume "a'<y>.(P'' \<parallel> Q) \<longmapsto>a<x> \<prec> P'"
      hence "a<x> \<prec> P' = a'<y> \<prec> P'' \<parallel> Q" and "a = a'"
        by(erule_tac inputCases', auto simp add: pi.inject residual.inject)+
      with PQTrans show ?thesis by simp
    next
      fix a' y Q'
      assume "a'<y>.Q' \<in> summands Q"
      with Qhnf have "Q \<longmapsto>(a'::name)<y> \<prec> Q'" by(simp add: summandTransition)
      moreover assume "y \<sharp> P"
      ultimately have PQTrans: "P \<parallel> Q \<longmapsto>a'<y> \<prec> P \<parallel> Q'" by(rule Par2B)
      assume "a'<y>.(P \<parallel> Q') \<longmapsto>a<x> \<prec> P'"
      hence "a<x> \<prec> P' = a'<y> \<prec> P \<parallel> Q'" and "a = a'"
        by(erule_tac inputCases', auto simp add: pi.inject residual.inject)+
      with PQTrans show ?thesis by simp
    qed
  qed
next
  have Goal: "\<And>P Q a x P' R. \<lbrakk>(R, expandSet P Q) \<in> sumComposeSet; hnf P; hnf Q; a \<noteq> x\<rbrakk> \<Longrightarrow> P \<parallel> Q \<longmapsto>a<\<nu>x> \<prec> P' = R \<longmapsto>a<\<nu>x> \<prec> P'"
  proof -
    fix P Q a x P' R
    assume aineqx: "(a::name) \<noteq> x"
    assume Exp: "(R, expandSet P Q) \<in> sumComposeSet"
    assume Phnf: "hnf P"
    assume Qhnf: "hnf Q"
    show "P \<parallel> Q \<longmapsto>a<\<nu>x> \<prec> P' = R \<longmapsto> a<\<nu>x> \<prec> P'"
    proof(rule iffI)
      {
        fix x P'
        assume "P \<parallel> Q \<longmapsto>a<\<nu>x> \<prec> P'" and "x \<sharp> P" and "x \<sharp> Q" and "a \<noteq> x"
        hence "R \<longmapsto>a<\<nu>x> \<prec> P'"
        proof(induct rule: parCasesB)
          case(cPar1 P')
          have "P \<longmapsto>a<\<nu>x> \<prec> P'" by fact
          with Phnf \<open>a \<noteq> x\<close> have "<\<nu>x>a{x}.P' \<in> summands P" by(simp add: summandTransition)
          moreover have "x \<sharp> Q" by fact
          ultimately have "<\<nu>x>a{x}.(P' \<parallel> Q) \<in> expandSet P Q" by(auto simp add: expandSet_def)
          moreover have "<\<nu>x>a{x}.(P' \<parallel> Q) \<longmapsto>a<\<nu>x> \<prec> (P' \<parallel> Q)" using \<open>a \<noteq> x\<close>
            by(blast intro: Open Output)
          ultimately show ?case using Exp by(blast intro: expandAction)
        next
          case(cPar2 Q')
          have "Q \<longmapsto>a<\<nu>x> \<prec> Q'" by fact
          with Qhnf \<open>a \<noteq> x\<close> have "<\<nu>x>a{x}.Q' \<in> summands Q" by(simp add: summandTransition)
          moreover have "x \<sharp> P" by fact
          ultimately have "<\<nu>x>a{x}.(P \<parallel> Q') \<in> expandSet P Q" by(simp add: expandSet_def, blast)
          moreover have "<\<nu>x>a{x}.(P \<parallel> Q') \<longmapsto>a<\<nu>x> \<prec> (P \<parallel> Q')" using \<open>a \<noteq> x\<close>
            by(blast intro: Open Output)
          ultimately show ?case using Exp by(blast intro: expandAction)
        qed
      }
      moreover obtain y::name where "y \<sharp> P" and "y \<sharp> Q" and "y \<sharp> P'" and "y \<noteq> a"
        by(generate_fresh "name") auto
      assume "P \<parallel> Q \<longmapsto>a<\<nu>x> \<prec> P'"
      with \<open>y \<sharp> P'\<close> have "P \<parallel> Q \<longmapsto>a<\<nu>y> \<prec> ([(x, y)] \<bullet> P')"
        by(simp add: alphaBoundResidual)
      ultimately have "R \<longmapsto>a<\<nu>y> \<prec> ([(x, y)] \<bullet> P')" using \<open>y \<sharp> P\<close> \<open>y \<sharp> Q\<close> \<open>y \<noteq> a\<close>
        by auto
      thus "R \<longmapsto>a<\<nu>x> \<prec> P'" using \<open>y \<sharp> P'\<close> by(simp add: alphaBoundResidual)
    next
      {
        fix R x P'
        assume "R \<longmapsto>a<\<nu>x> \<prec> P'" and "R \<in> expandSet P Q" and "x \<sharp> R" and "x \<sharp> P" and "x \<sharp> Q"
        hence "P \<parallel> Q \<longmapsto>a<\<nu>x> \<prec> P'"
        proof(auto simp add: expandSet_def)
          fix a' y P''
          assume "<\<nu>y>a'{y}.P'' \<in> summands P"
          moreover hence "a' \<noteq> y" by auto
          ultimately have "P \<longmapsto>a'<\<nu>y> \<prec> P''" using Phnf by(simp add: summandTransition)
          moreover assume "y \<sharp> Q"
          ultimately have PQTrans: "P \<parallel> Q \<longmapsto>a'<\<nu>y> \<prec> P'' \<parallel> Q" by(rule Par1B)
          assume ResTrans: "<\<nu>y>a'{y}.(P'' \<parallel> Q) \<longmapsto>a<\<nu>x> \<prec> P'" and "x \<sharp> [y].a'{y}.(P'' \<parallel> Q)"
          with ResTrans \<open>a' \<noteq> y\<close> \<open>x \<sharp> P\<close> \<open>x \<sharp> Q\<close> have "a<\<nu>x> \<prec> P' = a'<\<nu>y> \<prec> P'' \<parallel> Q"
            apply(case_tac "x=y")
            defer
            apply(erule_tac resCasesB)
            apply simp
            apply(simp add: abs_fresh)
            apply(auto simp add: residual.inject alpha' calc_atm fresh_left abs_fresh elim: outputCases)
            apply(ind_cases "<\<nu>y>a'{y}.(P'' \<parallel> Q) \<longmapsto> a<\<nu>y> \<prec> P'")
            apply(simp add: pi.inject alpha' residual.inject abs_fresh eqvts calc_atm)
            apply(auto elim: outputCases)
            apply(simp add: pi.inject residual.inject alpha' calc_atm)
            apply auto
            apply(ind_cases "<\<nu>y>a'{y}.(P'' \<parallel> Q) \<longmapsto> a<\<nu>y> \<prec> P'")
            apply(auto simp add: pi.inject alpha' residual.inject abs_fresh eqvts calc_atm)
            apply(auto elim: outputCases)
            apply(erule_tac outputCases)
            apply(auto simp add: freeRes.inject)
            apply hypsubst_thin
            apply(drule_tac pi="[(b, y)]" in pt_bij3)
            by simp
        with PQTrans show ?thesis by simp
      next
        fix a' y Q'
        assume "<\<nu>y>a'{y}.Q' \<in> summands Q"
        moreover hence "a' \<noteq> y" by auto
        ultimately have "Q \<longmapsto>a'<\<nu>y> \<prec> Q'" using Qhnf by(simp add: summandTransition)
        moreover assume "y \<sharp> P"
        ultimately have PQTrans: "P \<parallel> Q \<longmapsto>a'<\<nu>y> \<prec> P \<parallel> Q'" by(rule Par2B)
        assume ResTrans: "<\<nu>y>a'{y}.(P \<parallel> Q') \<longmapsto>a<\<nu>x> \<prec> P'" and "x \<sharp> [y].a'{y}.(P \<parallel> Q')"
        with ResTrans \<open>a' \<noteq> y\<close> have "a<\<nu>x> \<prec> P' = a'<\<nu>y> \<prec> P \<parallel> Q'"
          apply(case_tac "x=y")
          defer
          apply(erule_tac resCasesB)
            apply simp
            apply(simp add: abs_fresh)
            apply(auto simp add: residual.inject alpha' calc_atm fresh_left abs_fresh elim: outputCases)
            apply(ind_cases "<\<nu>y>a'{y}.(P \<parallel> Q') \<longmapsto> a<\<nu>y> \<prec> P'")
            apply(simp add: pi.inject alpha' residual.inject abs_fresh eqvts calc_atm)
            apply(auto elim: outputCases)
            apply(simp add: pi.inject residual.inject alpha' calc_atm)
            apply auto
            apply(ind_cases "<\<nu>y>a'{y}.(P \<parallel> Q') \<longmapsto> a<\<nu>y> \<prec> P'")
            apply(auto simp add: pi.inject alpha' residual.inject abs_fresh eqvts calc_atm)
            apply(auto elim: outputCases)
            apply(erule_tac outputCases)
            apply(auto simp add: freeRes.inject)
            apply hypsubst_thin
            apply(drule_tac pi="[(b, y)]" in pt_bij3)
            by simp
        with PQTrans show ?thesis by simp
      qed
    }
    moreover assume "R \<longmapsto>a<\<nu>x> \<prec> P'"
    with Exp obtain R where "R \<in> expandSet P Q" and "R \<longmapsto>a<\<nu>x> \<prec> P'"
      apply(drule_tac expandAction') by auto
    moreover obtain y::name where "y \<sharp> P" and "y \<sharp> Q" and "y \<sharp> R" and "y \<sharp> P'"
      by(generate_fresh "name") auto
    moreover with \<open>y \<sharp> P'\<close> \<open>R \<longmapsto>a<\<nu>x> \<prec> P'\<close> have "R \<longmapsto>a<\<nu>y> \<prec> ([(x, y)] \<bullet> P')" by(simp add: alphaBoundResidual)
    ultimately have "P \<parallel> Q \<longmapsto>a<\<nu>y> \<prec> ([(x, y)] \<bullet> P')" by auto
    thus "P \<parallel> Q \<longmapsto>a<\<nu>x> \<prec> P'" using \<open>y \<sharp> P'\<close> by(simp add: alphaBoundResidual)
    qed
  qed

  obtain y where yineqx: "a \<noteq> y" and yFreshP': "y \<sharp> P'"
    by(force intro: name_exists_fresh[of "(a, P')"] simp add: fresh_prod)
  from Exp Phnf Qhnf yineqx have "(P \<parallel> Q \<longmapsto>a<\<nu>y> \<prec> [(x, y)] \<bullet> P') = (R \<longmapsto>a<\<nu>y> \<prec> [(x, y)] \<bullet> P')"
    by(rule Goal)
  moreover with yFreshP' have "x \<sharp> [(x, y)] \<bullet> P'" by(simp add: name_fresh_left name_calc)
  ultimately show "(P \<parallel> Q \<longmapsto>a<\<nu>x> \<prec> P') = (R \<longmapsto>a<\<nu>x> \<prec> P')"
    by(simp add: alphaBoundResidual name_swap)
qed

lemma expandLeft:
  fixes P   :: pi
  and   Q   :: pi
  and   R   :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes Exp: "(R, expandSet P Q) \<in> sumComposeSet"
  and     Phnf: "hnf P"
  and     Qhnf: "hnf Q"
  and     Id: "Id \<subseteq> Rel"

  shows "P \<parallel> Q \<leadsto>[Rel] R"
proof(induct rule: simCases)
  case(Bound a x R')
  have "R \<longmapsto>a\<guillemotleft>x\<guillemotright> \<prec> R'" by fact
  with Exp Phnf Qhnf have "P \<parallel> Q \<longmapsto>a\<guillemotleft>x\<guillemotright> \<prec> R'" by(cases a, auto simp add: expandTrans)
  moreover from Id have "derivative R' R' a x Rel" by(cases a, auto simp add: derivative_def)
  ultimately show ?case by blast
next
  case(Free \<alpha> R')
  have "R \<longmapsto>\<alpha> \<prec> R'" by fact
  with Exp Phnf Qhnf have "P \<parallel> Q \<longmapsto>\<alpha> \<prec> R'" by(cases \<alpha>, auto simp add: expandTrans)
  moreover from Id have "(R', R') \<in> Rel" by blast
  ultimately show ?case by blast
qed

lemma expandRight:
  fixes P   :: pi
  and   Q   :: pi
  and   R   :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes Exp: "(R, expandSet P Q) \<in> sumComposeSet"
  and     Phnf: "hnf P"
  and     Qhnf: "hnf Q"
  and     Id: "Id \<subseteq> Rel"

  shows "R \<leadsto>[Rel] P \<parallel> Q"
proof(induct rule: simCases)
  case(Bound a x R')
  have "P \<parallel> Q \<longmapsto>a\<guillemotleft>x\<guillemotright> \<prec> R'" by fact
  with Exp Phnf Qhnf have "R \<longmapsto>a\<guillemotleft>x\<guillemotright> \<prec> R'" by(cases a, auto simp add: expandTrans)
  moreover from Id have "derivative R' R' a x Rel" by(cases a, auto simp add: derivative_def)
  ultimately show ?case by blast
next
  case(Free \<alpha> R')
  have "P \<parallel> Q \<longmapsto>\<alpha> \<prec> R'" by fact
  with Exp Phnf Qhnf have "R \<longmapsto>\<alpha> \<prec> R'" by(cases \<alpha>, auto simp add: expandTrans)
  moreover from Id have "(R', R') \<in> Rel" by blast
  ultimately show ?case by blast
qed

lemma expandSC:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi

  assumes "(R, expandSet P Q) \<in> sumComposeSet"
  and     "hnf P"
  and     "hnf Q"

  shows "P \<parallel> Q \<sim> R"
proof -
  let ?X = "{(P \<parallel> Q, R) | P Q R. (R, expandSet P Q) \<in> sumComposeSet \<and> hnf P \<and> hnf Q} \<union> {(R, P \<parallel> Q) | P Q R. (R, expandSet P Q) \<in> sumComposeSet \<and> hnf P \<and> hnf Q}"
  from assms have "(P \<parallel> Q, R) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: bisimCoinduct)
    case(cSim P Q)
    thus ?case
      by(blast intro: reflexive expandLeft expandRight)
  next
    case(cSym P Q)
     thus ?case by auto
   qed
 qed

end


(*  Title:      ZF/Coind/ECR.thy
    Author:     Jacob Frost, Cambridge University Computer Laboratory
    Copyright   1995  University of Cambridge
*)

theory ECR imports Static Dynamic begin

(* The extended correspondence relation *)

consts
  HasTyRel :: i
coinductive
  domains "HasTyRel" \<subseteq> "Val * Ty"
  intros
    htr_constI [intro!]:
      "[| c \<in> Const; t \<in> Ty; isof(c,t) |] ==> <v_const(c),t> \<in> HasTyRel"
    htr_closI [intro]:
      "[| x \<in> ExVar; e \<in> Exp; t \<in> Ty; ve \<in> ValEnv; te \<in> TyEnv;
          <te,e_fn(x,e),t> \<in> ElabRel;
          ve_dom(ve) = te_dom(te);
          {<ve_app(ve,y),te_app(te,y)>.y \<in> ve_dom(ve)} \<in> Pow(HasTyRel) |]
       ==> <v_clos(x,e,ve),t> \<in> HasTyRel"
  monos  Pow_mono
  type_intros Val_ValEnv.intros

(* Pointwise extension to environments *)

definition
  hastyenv :: "[i,i] => o"  where
    "hastyenv(ve,te) ==
         ve_dom(ve) = te_dom(te) &
         (\<forall>x \<in> ve_dom(ve). <ve_app(ve,x),te_app(te,x)> \<in> HasTyRel)"

(* Specialised co-induction rule *)

lemma htr_closCI [intro]:
     "[| x \<in> ExVar; e \<in> Exp; t \<in> Ty; ve \<in> ValEnv; te \<in> TyEnv;
         <te, e_fn(x, e), t> \<in> ElabRel; ve_dom(ve) = te_dom(te);
         {<ve_app(ve,y),te_app(te,y)>.y \<in> ve_dom(ve)} \<in>
           Pow({<v_clos(x,e,ve),t>} \<union> HasTyRel) |]
      ==> <v_clos(x, e, ve),t> \<in> HasTyRel"
apply (rule singletonI [THEN HasTyRel.coinduct], auto)
done

(* Specialised elimination rules *)

inductive_cases
    htr_constE [elim!]: "<v_const(c),t> \<in> HasTyRel"
  and htr_closE [elim]: "<v_clos(x,e,ve),t> \<in> HasTyRel"

(* Properties of the pointwise extension to environments *)

lemmas HasTyRel_non_zero =
       HasTyRel.dom_subset [THEN subsetD, THEN SigmaD1, THEN ValNEE]

lemma hastyenv_owr:
  "[| ve \<in> ValEnv; te \<in> TyEnv; hastyenv(ve,te); <v,t> \<in> HasTyRel |]
   ==> hastyenv(ve_owr(ve,x,v),te_owr(te,x,t))"
by (auto simp add: hastyenv_def ve_app_owr HasTyRel_non_zero)

lemma basic_consistency_lem:
  "[| ve \<in> ValEnv; te \<in> TyEnv; isofenv(ve,te) |] ==> hastyenv(ve,te)"
apply (unfold isofenv_def hastyenv_def)
apply (force intro: te_appI ve_domI)
done

(* ############################################################ *)
(* The Consistency theorem                                      *)
(* ############################################################ *)

lemma consistency_const:
     "[| c \<in> Const; hastyenv(ve,te);<te,e_const(c),t> \<in> ElabRel |]
      ==> <v_const(c), t> \<in> HasTyRel"
by blast

lemma consistency_var:
  "[| x \<in> ve_dom(ve); hastyenv(ve,te); <te,e_var(x),t> \<in> ElabRel |] ==>
   <ve_app(ve,x),t> \<in> HasTyRel"
by (unfold hastyenv_def, blast)

lemma consistency_fn:
  "[| ve \<in> ValEnv; x \<in> ExVar; e \<in> Exp; hastyenv(ve,te);
           <te,e_fn(x,e),t> \<in> ElabRel
        |] ==> <v_clos(x, e, ve), t> \<in> HasTyRel"
by (unfold hastyenv_def, blast)

declare ElabRel.dom_subset [THEN subsetD, dest]

declare Ty.intros [simp, intro!]
declare TyEnv.intros [simp, intro!]
declare Val_ValEnv.intros [simp, intro!]

lemma consistency_fix:
  "[| ve \<in> ValEnv; x \<in> ExVar; e \<in> Exp; f \<in> ExVar; cl \<in> Val;
      v_clos(x,e,ve_owr(ve,f,cl)) = cl;
      hastyenv(ve,te); <te,e_fix(f,x,e),t> \<in> ElabRel |] ==>
   <cl,t> \<in> HasTyRel"
apply (unfold hastyenv_def)
apply (erule elab_fixE, safe)
apply hypsubst_thin
apply (rule subst, assumption)
apply (rule_tac te="te_owr(te, f, t_fun(t1, t2))" in htr_closCI)
apply simp_all
apply (blast intro: ve_owrI)
apply (rule ElabRel.fnI)
apply (simp_all add: ValNEE, force)
done

lemma consistency_app1:
 "[| ve \<in> ValEnv; e1 \<in> Exp; e2 \<in> Exp; c1 \<in> Const; c2 \<in> Const;
     <ve,e1,v_const(c1)> \<in> EvalRel;
     \<forall>t te.
       hastyenv(ve,te) \<longrightarrow> <te,e1,t> \<in> ElabRel \<longrightarrow> <v_const(c1),t> \<in> HasTyRel;
     <ve, e2, v_const(c2)> \<in> EvalRel;
     \<forall>t te.
       hastyenv(ve,te) \<longrightarrow> <te,e2,t> \<in> ElabRel \<longrightarrow> <v_const(c2),t> \<in> HasTyRel;
     hastyenv(ve, te);
     <te,e_app(e1,e2),t> \<in> ElabRel |]
  ==> <v_const(c_app(c1, c2)),t> \<in> HasTyRel"
by (blast intro!: c_appI intro: isof_app)

lemma consistency_app2:
 "[| ve \<in> ValEnv; vem \<in> ValEnv; e1 \<in> Exp; e2 \<in> Exp; em \<in> Exp; xm \<in> ExVar;
     v \<in> Val;
     <ve,e1,v_clos(xm,em,vem)> \<in> EvalRel;
     \<forall>t te. hastyenv(ve,te) \<longrightarrow>
            <te,e1,t> \<in> ElabRel \<longrightarrow> <v_clos(xm,em,vem),t> \<in> HasTyRel;
     <ve,e2,v2> \<in> EvalRel;
     \<forall>t te. hastyenv(ve,te) \<longrightarrow> <te,e2,t> \<in> ElabRel \<longrightarrow> <v2,t> \<in> HasTyRel;
     <ve_owr(vem,xm,v2),em,v> \<in> EvalRel;
     \<forall>t te. hastyenv(ve_owr(vem,xm,v2),te) \<longrightarrow>
            <te,em,t> \<in> ElabRel \<longrightarrow> <v,t> \<in> HasTyRel;
     hastyenv(ve,te); <te,e_app(e1,e2),t> \<in> ElabRel |]
   ==> <v,t> \<in> HasTyRel"
apply (erule elab_appE)
apply (drule spec [THEN spec, THEN mp, THEN mp], assumption+)
apply (drule spec [THEN spec, THEN mp, THEN mp], assumption+)
apply (erule htr_closE)
apply (erule elab_fnE, simp)
apply clarify
apply (drule spec [THEN spec, THEN mp, THEN mp])
prefer 2 apply assumption+
apply (rule hastyenv_owr, assumption)
apply assumption
apply (simp add: hastyenv_def, blast+)
done

lemma consistency [rule_format]:
   "<ve,e,v> \<in> EvalRel
    ==> (\<forall>t te. hastyenv(ve,te) \<longrightarrow> <te,e,t> \<in> ElabRel \<longrightarrow> <v,t> \<in> HasTyRel)"
apply (erule EvalRel.induct)
apply (simp_all add: consistency_const consistency_var consistency_fn
                     consistency_fix consistency_app1)
apply (blast intro: consistency_app2)
done

lemma basic_consistency:
     "[| ve \<in> ValEnv; te \<in> TyEnv; isofenv(ve,te);
         <ve,e,v_const(c)> \<in> EvalRel; <te,e,t> \<in> ElabRel |]
      ==> isof(c,t)"
by (blast dest: consistency intro!: basic_consistency_lem)

end


theory SumList
  imports Main
begin

(* This is probably in the standard libraries... *)

primrec sum_elim :: "('a \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow> 'a + 'b \<Rightarrow> 'c" ("\<langle>_,_\<rangle>" [0,0] 1000) where
  "sum_elim f g (Inl x) = f x"
| "sum_elim f g (Inr x) = g x"

fun lefts :: "('a + 'b) list \<Rightarrow> 'a list" ("\<ll>") where
  "lefts [] = []"
| "lefts (Inl x # zs) = x # lefts zs"
| "lefts (Inr y # zs) = lefts zs"

fun rights :: "('a + 'b) list \<Rightarrow> 'b list" ("\<rr>") where
  "rights [] = []"
| "rights (Inl x # zs) = rights zs"
| "rights (Inr y # zs) = y # rights zs"

lemma rights_mapR [simp]: "\<rr> (map Inr xs) = xs"
  by (induct xs) auto

lemma lefts_mapL [simp]: "\<ll> (map Inl xs) = xs"
  by (induct xs) auto

lemma rights_mapL [simp]: "\<rr> (map Inl xs) = []"
  by (induct xs) auto

lemma lefts_mapR [simp]: "\<ll> (map Inr xs) = []"
  by (induct xs) auto

fun swap :: "('a + 'b) \<Rightarrow> ('b, 'a) sum" where
  "swap (Inl x) = Inr x"
| "swap (Inr x) = Inl x"

lemma sum_list_induct: "\<lbrakk>P []; \<And>x xs. P xs \<Longrightarrow> P (Inl x # xs); \<And>x xs. P xs \<Longrightarrow> P (Inr x # xs)\<rbrakk> \<Longrightarrow> P xs"
  by (induct xs, auto, metis swap.cases)

lemma sum_list_cases: "\<lbrakk>P []; \<And>x xs. P (Inl x # xs); \<And>x xs. P (Inr x # xs)\<rbrakk> \<Longrightarrow> P xs"
  by (induct xs rule: sum_list_induct) auto

lemma [simp]: "\<ll> (map swap xs) = \<rr> xs"
  by (induct xs rule: sum_list_induct) auto

lemma [simp]: "\<langle>id,id\<rangle> (swap x) = \<langle>id,id\<rangle> x"
  by (cases x) auto

lemma no_lefts: "\<ll> xs = [] \<Longrightarrow> map Inr (\<rr> xs) = xs"
  by (induct xs rule: sum_list_induct) auto

lemma no_rights: "rights xs = [] \<Longrightarrow> map Inl (\<ll> xs) = xs"
  by (induct xs rule: sum_list_induct) auto

fun rbr1 :: "'a + ('b + 'c) \<Rightarrow> ('a + 'b) + 'c" where
  "rbr1 (Inl x) = Inl (Inl x)"
| "rbr1 (Inr (Inl x)) = Inl (Inr x)"
| "rbr1 (Inr (Inr x)) = Inr x"

lemma sum3_list_induct1: "\<lbrakk>P []; \<And>x xs. P xs \<Longrightarrow> P (Inl x # xs); \<And>x xs. P xs \<Longrightarrow> P (Inr (Inl x) # xs); \<And>x xs. P xs \<Longrightarrow> P (Inr (Inr x) # xs)\<rbrakk> \<Longrightarrow> P xs"
  by (induct xs, auto, metis swap.cases)

lemma sum3_list_induct2: "\<lbrakk>P []; \<And>x xs. P xs \<Longrightarrow> P (Inr x # xs); \<And>x xs. P xs \<Longrightarrow> P (Inl (Inr x) # xs); \<And>x xs. P xs \<Longrightarrow> P (Inl (Inl x) # xs)\<rbrakk> \<Longrightarrow> P xs"
  by (induct xs, auto, metis swap.cases)

fun rbr2 :: "('a + 'b) + 'c \<Rightarrow> 'a + ('b + 'c)" where
  "rbr2 (Inr x) = Inr (Inr x)"
| "rbr2 (Inl (Inr x)) = Inr (Inl x)"
| "rbr2 (Inl (Inl x)) = Inl x"

lemma [simp]: "lefts (lefts (map rbr1 xs)) = lefts xs"
  by (induct xs rule: sum3_list_induct1) auto

lemma [simp]: "rights (lefts (map rbr1 xs)) = lefts (rights xs)"
  by (induct xs rule: sum3_list_induct1) auto

lemma [simp]: "rights (map rbr1 xs) = rights (rights xs)"
  by (induct xs rule: sum3_list_induct1) auto

lemma [simp]: "sum_elim (sum_elim id id) id (rbr1 x) = sum_elim id (sum_elim id id) x"
  apply (cases x)
  apply auto
  by (metis rbr1.simps(2) rbr1.simps(3) sum_elim.simps(1) sum_elim.simps(2) swap.cases)

lemma [simp]: "rights (rights (map rbr2 xs)) = rights xs"
  by (induct xs rule: sum3_list_induct2) auto

lemma [simp]: "lefts (rights (map rbr2 xs)) = rights (lefts xs)"
  by (induct xs rule: sum3_list_induct2) auto

lemma [simp]: "lefts (map rbr2 xs) = lefts (lefts xs)"
  by (induct xs rule: sum3_list_induct2) auto

lemma [simp]: "sum_elim id (sum_elim id id) (rbr2 x) = sum_elim (sum_elim id id) id x"
  apply (cases x)
  apply auto
  by (metis id_def rbr2.simps(2) rbr2.simps(3) sum_elim.simps(1) sum_elim.simps(2) swap.cases)

lemma left_append [simp]: "\<ll> (xs @ ys) = \<ll> xs @ \<ll> ys"
  by (induct xs rule: sum_list_induct) auto

lemma right_append [simp]: "\<rr> (xs @ ys) = \<rr> xs @ \<rr> ys"
  by (induct xs rule: sum_list_induct) auto

lemma sum_ext:
  assumes "\<And>x. f (Inl x) = g (Inl x)"
  and "\<And>x. f (Inr x) = g (Inr x)"
  shows "f = g"
proof -
  {
    fix x
    have "f x = g x"
      by (cases x, auto intro: assms)
  }
  thus ?thesis by auto
qed

lemma sum_elim_split: "\<langle>Inl \<circ> f, Inr \<circ> g\<rangle> = \<langle>Inl \<circ> f, Inr\<rangle> \<circ> \<langle>Inl, Inr \<circ> g\<rangle>"
  by (rule sum_ext, auto)

lemma sum_elim_id: "sum_elim Inl Inr = id"
proof -
  {
    fix x :: "('a + 'b)"
    have "sum_elim Inl Inr x = id x"
      by (cases x) auto
  }
  thus ?thesis by auto
qed

fun rfl :: "('a + 'b) list \<Rightarrow> ('a + 'b) list" where
  "rfl [] = []"
| "rfl ((Inl x)#xs) = xs"
| "rfl ((Inr x)#xs) = rfl xs"

fun rfr :: "('a + 'b) list \<Rightarrow> ('a + 'b) list" where
  "rfr [] = []"
| "rfr ((Inr x)#xs) = xs"
| "rfr ((Inl x)#xs) = rfr xs"

lemma rfl1 [intro]: "lefts z = x # xs \<Longrightarrow> lefts (rfl z) = xs"
  by (induct z rule: sum_list_induct, auto)

lemma rfr1 [intro]: "rights z = x # xs \<Longrightarrow> rights (rfr z) = xs"
  by (induct z rule: sum_list_induct, auto)

lemma map_sum_elim_simp1: "map \<langle>id,id\<rangle> \<circ> map \<langle>Inl \<circ> \<langle>id,id\<rangle>, Inr\<rangle> = map \<langle>\<langle>id,id\<rangle>,id\<rangle>"
proof -
  {
    fix xs :: "(('a, 'a) sum, 'a) sum list"
    have "(map \<langle>id,id\<rangle> \<circ> map \<langle>Inl \<circ> \<langle>id,id\<rangle>, Inr\<rangle>) xs = map \<langle>\<langle>id,id\<rangle>,id\<rangle> xs"
      by (induct xs rule: sum3_list_induct2) auto
  }
  thus ?thesis by auto
qed

lemma map_sum_elim_simp2: "map \<langle>id,id\<rangle> \<circ> map \<langle>Inl, Inr \<circ> \<langle>id,id\<rangle>\<rangle> = map \<langle>id,\<langle>id,id\<rangle>\<rangle>"
proof -
  {
    fix xs :: "('a, ('a, 'a) sum) sum list"
    have "(map \<langle>id,id\<rangle> \<circ> map \<langle>Inl, Inr \<circ> \<langle>id,id\<rangle>\<rangle>) xs = map \<langle>id,\<langle>id,id\<rangle>\<rangle> xs"
      by (induct xs rule: sum3_list_induct1) auto
  }
  thus ?thesis by auto
qed

fun take_left :: "nat \<Rightarrow> ('a + 'b) list \<Rightarrow> ('a + 'b) list" where
  "take_left n [] = []"
| "take_left 0 ((Inl x) # xs) = []"
| "take_left n ((Inr x) # xs) = Inr x # take_left n xs"
| "take_left (Suc n) ((Inl x) # xs) = Inl x # take_left n xs"

value "take_left 2 [Inl a, Inr b, Inl c, Inr d, Inl e]"

fun drop_left :: "nat \<Rightarrow> ('a + 'b) list \<Rightarrow> ('a + 'b) list" where
  "drop_left n [] = []"
| "drop_left n ((Inr x) # xs) = drop_left n xs"
| "drop_left 0 ((Inl x) # xs) = Inl x # xs"
| "drop_left (Suc n) ((Inl x) # xs) = drop_left n xs"

definition delete_left :: "nat \<Rightarrow> ('a + 'b) list \<Rightarrow> ('a + 'b) list" where
  "delete_left n xs = take_left n xs @ tl (drop_left n xs)"

lemma sum_list_induct_with_n:
  "\<lbrakk> P 0 []; \<And>n. P (Suc n) []
   ; \<And>x xs. (\<And>n. P n xs) \<Longrightarrow> P 0 (Inl x # xs); \<And>x xs. (\<And>n. P n xs) \<Longrightarrow> P 0 (Inr x # xs)
   ; \<And>n x xs. (\<And>n. P n xs) \<Longrightarrow> P (Suc n) (Inl x # xs); \<And>n x xs. (\<And>n. P n xs) \<Longrightarrow> P (Suc n) (Inr x # xs)
   \<rbrakk> \<Longrightarrow> P n xs"
  by (induct xs arbitrary: n rule: sum_list_induct) (metis nat.exhaust)+

lemma left_take_flip: "\<ll> (take_left n xs) = take n (\<ll> xs)"
  by (induct xs rule: sum_list_induct_with_n, auto)

lemma left_drop_flip: "\<ll> (drop_left n xs) = drop n (\<ll> xs)"
  by (induct xs rule: sum_list_induct_with_n, auto)

lemma take_drop_left: "take_left n xs @ drop_left n xs = xs"
  by (induct xs rule: sum_list_induct_with_n, auto)

lemma take_left_idem: "take_left n (take_left n xs) = take_left n xs"
  by (induct xs rule: sum_list_induct_with_n, auto)

lemma take_all_left: "(take_left (length (\<ll> xs)) xs) = xs"
  by (induct xs rule: sum_list_induct, auto)

lemma take_take_append: "n \<le> length (\<ll> xs) \<Longrightarrow> take_left n (take_left n xs @ (Inl y) # ys) = take_left n xs"
  by (induct xs rule: sum_list_induct_with_n, auto)

lemma lefts_non_empty: "\<ll> xs \<noteq> [] \<Longrightarrow> xs \<noteq> []"
  by (induct xs) auto

lemma rights_non_empty: "\<rr> xs \<noteq> [] \<Longrightarrow> xs \<noteq> []"
  by (induct xs) auto

lemma cons_non_empty: "xs = y#ys \<Longrightarrow> xs \<noteq> []"
  by (metis list.distinct(1))

lemma delete_left_rights [simp]: "\<rr> (delete_left n xs) = \<rr> xs"
  by (induct xs rule: sum_list_induct_with_n) (auto simp add: delete_left_def)

lemma drop_left_append_non_empty: "\<ll> ws = xs @ y # ys \<Longrightarrow> drop_left (length xs) ws \<noteq> []"
  apply (induct xs)
  apply simp
  apply (induct ws rule: sum_list_induct)
  apply simp
  apply simp
  apply simp
  by (metis append_eq_conv_conj left_drop_flip lefts.simps(1) list.distinct(1))

lemma [simp]: "map (\<langle>id,id\<rangle> \<circ> Inr) xs = xs"
  by (metis (lifting, mono_tags) id_apply map_eq_conv map_ident o_eq_dest_lhs sum_elim.simps(2))

lemma [simp]: "map (\<langle>id,id\<rangle> \<circ> Inl) xs = xs"
  by (induct xs, auto)

lemma empty_left: "\<ll> xs = [] \<Longrightarrow> \<rr> xs = map \<langle>id,id\<rangle> xs"
  by (induct xs rule: sum_list_induct) auto

lemma drop_head: "\<ll> ws = xs @ (y # ys) \<Longrightarrow> hd (drop_left (length xs) ws) = Inl y"
proof (induct ws arbitrary: xs rule: sum_list_induct, simp_all)
  fix w :: "'a" and ws :: "('a + 'b) list" and xs :: "'a list"
  assume ih: "\<And>xs. \<ll> ws = xs @ y # ys \<Longrightarrow> hd (drop_left (length xs) ws) = Inl y"
  and ws_lefts: "w # (\<ll> ws) = xs @ y # ys"
  thus "hd (drop_left (length xs) (Inl w # ws)) = Inl y"
  proof (cases "length xs = 0", simp)
    assume "length xs \<noteq> 0"
    then obtain x and xs' where xs_def: "xs = x # xs'"
      by (metis gen_length_code(1) length_code neq_Nil_conv)
    thus "hd (drop_left (length xs) (Inl w # ws)) = Inl y"
      by simp (metis Cons_eq_appendI ws_lefts ih list.inject)
  qed
qed

lemma left_singleton [simp]: "map \<langle>id,id\<rangle> [Inl x] = [x]"
  by simp

lemma delete_left_lefts: "\<ll> ws = xs @ y # ys \<Longrightarrow> \<ll> (delete_left (length xs) ws) = xs @ ys"
proof (induct ws arbitrary: xs rule: sum_list_induct, simp_all add: delete_left_def)
  fix w :: "'a" and ws :: "('a + 'b) list" and xs :: "'a list"
  assume ih: "\<And>xs. \<ll> ws = xs @ y # ys \<Longrightarrow> \<ll> (take_left (length xs) ws) @ \<ll> (tl (drop_left (length xs) ws)) = xs @ ys"
  and ws_lefts: "w # \<ll> ws = xs @ y # ys"
  thus "\<ll> (take_left (length xs) (Inl w # ws)) @ \<ll> (tl (drop_left (length xs) (Inl w # ws))) = xs @ ys"
  proof (cases "length xs = 0", simp)
    assume "length xs \<noteq> 0"
    then obtain x and xs' where xs_def: "xs = x # xs'"
      by (metis list.size(3) neq_Nil_conv)
    thus "\<ll> (take_left (length xs) (Inl w # ws)) @ \<ll> (tl (drop_left (length xs) (Inl w # ws))) = xs @ ys"
      by simp (metis append_Cons ih list.inject ws_lefts)
  qed
qed

lemma lefts_insert:
  assumes "\<ll> ws = xs @ [y] @ ys"
  and "\<rr> ws = zs"
  and "n = length xs"
  shows "ws = take_left n ws @ [Inl y] @ tl (drop_left n ws)"
proof -
  have "ws = take_left n ws @ drop_left n ws"
    by (metis take_drop_left)
  also have "... = take_left n ws @ hd (drop_left n ws) # tl (drop_left n ws)"
    apply (subst hd_Cons_tl)
    apply (insert assms)
    apply simp
    apply (rule drop_left_append_non_empty)
    apply auto
    done
  also have "... = take_left n ws @ Inl y # tl (drop_left n ws)"
    by (metis append_Cons assms(1) assms(3) drop_head)
  also have "... = take_left n ws @ [Inl y] @ tl (drop_left n ws)"
    by auto
  finally show ?thesis .
qed

lemma take_lefts_is_append: "\<ll> xs = ys @ zs \<Longrightarrow> \<ll> (take_left (length ys) xs) = ys"
  apply (induct xs rule: sum_list_induct)
  apply auto
  apply (cases "length ys = 0")
  apply simp
  by (metis append_eq_conv_conj left_take_flip lefts.simps(2))

lemma drop_lefts_is_append: "\<ll> zs' = as @ d # ds \<Longrightarrow> \<ll> (tl (drop_left (length as) zs')) = ds"
  apply (induct zs' arbitrary: as rule: sum_list_induct)
  apply auto
proof -
  fix x :: "'a" and xs :: "('a + 'b) list" and as :: "'a list"
  assume ih: "\<And>as. \<ll> xs = as @ d # ds \<Longrightarrow> \<ll> (tl (drop_left (length as) xs)) = ds"
  and xs_lefts: "x # \<ll> xs = as @ d # ds"
  thus "\<ll> (tl (drop_left (length as) (Inl x # xs))) = ds"
  proof (cases "length as = 0", simp)
    assume "length as \<noteq> 0"
    then obtain a and as' where as_def: "as = a # as'"
      by (metis length_0_conv neq_Nil_conv)
    thus "\<ll> (tl (drop_left (length as) (Inl x # xs))) = ds"
      apply simp
      by (metis `length as \<noteq> 0` ih length_0_conv tl.simps(2) tl_append2 xs_lefts)
  qed
qed

lemma single_left [simp]: "\<ll> xs = [l] \<Longrightarrow> map \<langle>id,id\<rangle> xs = \<rr> (take_left 0 xs) @ l # \<rr> (drop_left 0 xs)"
  apply (induct xs rule: sum_list_induct)
  apply simp
  apply simp
  apply (metis empty_left)
  by simp

lemma sum_list_empty [simp]: "xs = [] \<longleftrightarrow> \<ll> xs = [] \<and> \<rr> xs = []"
  by (induct xs rule: sum_list_induct) auto

lemma [intro]: "\<ll> xs = y # ys \<Longrightarrow> \<ll> (delete_left 0 xs) = ys"
  by (induct xs rule: sum_list_induct) (auto simp add: delete_left_def)

primrec is_left :: "('a, 'b) sum \<Rightarrow> bool" where
  "is_left (Inl x) = True"
| "is_left (Inr x) = False"

primrec is_right :: "('a, 'b) sum \<Rightarrow> bool" where
  "is_right (Inr x) = True"
| "is_right (Inl x) = False"

lemma not_is_left [simp]: "\<not> is_left x \<longleftrightarrow> is_right x"
  by (cases x) auto

lemma not_is_right [simp]: "\<not> is_right x \<longleftrightarrow> is_left x"
  by (cases x) auto

lemma is_left_swap [simp]: "is_left (swap x) \<longleftrightarrow> is_right x"
  by (cases x) auto

lemma is_right_swap [simp]: "is_right (swap x) \<longleftrightarrow> is_left x"
  by (cases x) auto

lemma lefts_singleton_emp [elim]: "is_right x \<Longrightarrow> \<ll> [x] = []"
  by (cases x) auto

lemma rights_singleton_emp [elim]: "is_left x \<Longrightarrow> \<rr> [x] = []"
  by (cases x) auto

primrec unl :: "('a, 'b) sum \<Rightarrow> 'a" where
  "unl (Inl x) = x"
| "unl (Inr x) = undefined"

primrec unr :: "('a, 'b) sum \<Rightarrow> 'b" where
  "unr (Inr x) = x"
| "unr (Inl x) = undefined"

end