(*  Author:      Andreas Lochbihler
    Maintainer:  Andreas Lochbihler
*)
section \<open>Manual construction of a resumption codatatype\<close>

theory Resumption imports
  "HOL-Library.Old_Datatype"
begin

text \<open>
  This theory defines the following codatatype:

\begin{verbatim}
codatatype ('a,'b,'c,'d) resumption =
    Terminal 'a
  | Linear 'b "('a,'b,'c,'d) resumption"
  | Branch 'c "'d => ('a,'b,'c,'d) resumption"
\end{verbatim}

\<close>

subsection \<open>Auxiliary definitions and lemmata similar to @{theory "HOL-Library.Old_Datatype"}\<close>

lemma Lim_mono: "(\<And>d. rs d \<subseteq> rs' d) \<Longrightarrow> Old_Datatype.Lim rs \<subseteq> Old_Datatype.Lim rs'"
by(simp add: Lim_def) blast

lemma Lim_UN1:  "Old_Datatype.Lim (\<lambda>x. \<Union>y. f x y) = (\<Union>y. Old_Datatype.Lim (\<lambda>x. f x y))"
by(simp add: Old_Datatype.Lim_def) blast

text \<open>
  Inverse for @{term "Old_Datatype.Lim"} like @{term "Old_Datatype.Split"} and @{term "Old_Datatype.Case"}
  for @{term "Old_Datatype.Scons"} and @{term "In0"}/@{term "In1"}
\<close>

definition DTBranch :: "(('b \<Rightarrow> ('a, 'b) Old_Datatype.dtree) \<Rightarrow> 'c) \<Rightarrow> ('a, 'b) Old_Datatype.dtree \<Rightarrow> 'c"
where "DTBranch f M = (THE u. \<exists>x. M = Old_Datatype.Lim x \<and> u = f x)"

lemma DTBranch_Lim [simp]: "DTBranch f (Old_Datatype.Lim M) = f M"
by(auto simp add: DTBranch_def dest: Lim_inject)

text \<open>Lemmas for @{term Old_Datatype.ntrunc} and @{term "Old_Datatype.Lim"}\<close>

lemma ndepth_Push_Node_Inl_aux:
     "case_nat (Inl n) f k = Inr 0 \<Longrightarrow> Suc (LEAST x. f x = Inr 0) <= k"
apply (induct "k", auto)
apply (erule Least_le)
done

lemma ndepth_Push_Node_Inl:
  "ndepth (Push_Node (Inl a) n) = Suc (ndepth n)"
using Rep_Node[of n, unfolded Node_def]
apply(simp add: ndepth_def Push_Node_def Abs_Node_inverse[OF Node_Push_I[OF Rep_Node]])
apply(simp add: Push_def split_beta)
apply(rule Least_equality)
apply(auto elim: LeastI intro: ndepth_Push_Node_Inl_aux)
done

lemma ntrunc_Lim [simp]: "ntrunc (Suc k) (Old_Datatype.Lim rs) = Old_Datatype.Lim (\<lambda>x. ntrunc k (rs x))"
unfolding Lim_def ntrunc_def
apply(rule equalityI)
apply clarify
apply(auto simp add: ndepth_Push_Node_Inl)
done

subsection \<open>Definition for the codatatype universe\<close>

text \<open>Constructors\<close>

definition TERMINAL :: "'a \<Rightarrow> ('c + 'b + 'a, 'd) Old_Datatype.dtree"
where "TERMINAL a = In0 (Old_Datatype.Leaf (Inr (Inr a)))"

definition LINEAR :: "'b \<Rightarrow> ('c + 'b + 'a, 'd) Old_Datatype.dtree \<Rightarrow> ('c + 'b + 'a, 'd) Old_Datatype.dtree"
  where "LINEAR b r = In1 (In0 (Scons (Old_Datatype.Leaf (Inr (Inl b))) r))"

definition BRANCH :: "'c \<Rightarrow> ('d \<Rightarrow> ('c + 'b + 'a, 'd) Old_Datatype.dtree) \<Rightarrow> ('c + 'b + 'a, 'd) Old_Datatype.dtree"
 where "BRANCH c rs = In1 (In1 (Scons (Old_Datatype.Leaf (Inl c)) (Old_Datatype.Lim rs)))"

text \<open>case operator\<close>

definition case_RESUMPTION :: "('a \<Rightarrow> 'e) \<Rightarrow> ('b \<Rightarrow> (('c + 'b + 'a, 'd) Old_Datatype.dtree) \<Rightarrow> 'e) \<Rightarrow> ('c \<Rightarrow> ('d \<Rightarrow> ('c + 'b + 'a, 'd) Old_Datatype.dtree) \<Rightarrow> 'e) \<Rightarrow> ('c + 'b + 'a, 'd) Old_Datatype.dtree \<Rightarrow> 'e"
where
  "case_RESUMPTION t l br =
   Old_Datatype.Case (t o inv (Old_Datatype.Leaf o Inr o Inr))
                 (Old_Datatype.Case (Old_Datatype.Split (\<lambda>x. l (inv (Old_Datatype.Leaf o Inr o Inl) x)))
                                (Old_Datatype.Split (\<lambda>x. DTBranch (br (inv (Old_Datatype.Leaf o Inl) x)))))"

lemma case_RESUMPTION_simps [simp]:
  shows case_RESUMPTION_TERMINAL: "case_RESUMPTION t l br (TERMINAL a) = t a"
  and case_RESUMPTION_LINEAR: "case_RESUMPTION t l br (LINEAR b r) = l b r"
  and case_RESUMPTION_BRANCH: "case_RESUMPTION t l br (BRANCH c rs) = br c rs"
apply(simp_all add: case_RESUMPTION_def TERMINAL_def LINEAR_def BRANCH_def o_def)
apply(rule arg_cong) back
apply(blast intro: injI inv_f_f)
apply(rule arg_cong) back
apply(blast intro: injI inv_f_f)
apply(rule arg_cong) back
apply(blast intro: injI inv_f_f)
done

lemma LINEAR_mono: "r \<subseteq> r' \<Longrightarrow> LINEAR b r \<subseteq> LINEAR b r'"
by(simp add: LINEAR_def In1_mono In0_mono Scons_mono)

lemma BRANCH_mono: "(\<And>d. rs d \<subseteq> rs' d) \<Longrightarrow> BRANCH c rs \<subseteq> BRANCH c rs'"
by(simp add: BRANCH_def In1_mono Scons_mono Lim_mono)

lemma LINEAR_UN: "LINEAR b (\<Union>x. f x) = (\<Union>x. LINEAR b (f x))"
by (simp add: LINEAR_def In1_UN1 In0_UN1 Scons_UN1_y)

lemma BRANCH_UN: "BRANCH b (\<lambda>d. \<Union>x. f d x) = (\<Union>x. BRANCH b (\<lambda>d. f d x))"
by (simp add: BRANCH_def Lim_UN1 In1_UN1 In0_UN1 Scons_UN1_y)

text \<open>The codatatype universe\<close>

coinductive_set resumption :: "('c + 'b + 'a, 'd) Old_Datatype.dtree set"
where
resumption_TERMINAL:
  "TERMINAL a \<in> resumption"
| resumption_LINEAR:
  "r \<in> resumption \<Longrightarrow> LINEAR b r \<in> resumption"
| resumption_BRANCH:
  "(\<And>d. rs d \<in> resumption) \<Longrightarrow> BRANCH c rs \<in> resumption"

subsection \<open>Definition of the codatatype as a type\<close>

typedef ('a,'b,'c,'d) resumption = "resumption :: ('c + 'b + 'a, 'd) Old_Datatype.dtree set"
proof
  show "TERMINAL undefined \<in> ?resumption" by(blast intro: resumption.intros)
qed

text \<open>Constructors\<close>

definition Terminal :: "'a \<Rightarrow> ('a,'b,'c,'d) resumption"
where "Terminal a = Abs_resumption (TERMINAL a)"

definition Linear :: "'b \<Rightarrow> ('a,'b,'c,'d) resumption \<Rightarrow> ('a,'b,'c,'d) resumption"
where "Linear b r = Abs_resumption (LINEAR b (Rep_resumption r))"

definition Branch :: "'c \<Rightarrow> ('d \<Rightarrow> ('a,'b,'c,'d) resumption) \<Rightarrow> ('a,'b,'c,'d) resumption"
where "Branch c rs = Abs_resumption (BRANCH c (\<lambda>d. Rep_resumption (rs d)))"

lemma [iff]:
  shows Terminal_not_Linear: "Terminal a \<noteq> Linear b r"
  and Linear_not_Terminal: "Linear b R \<noteq> Terminal a"
  and Termina_not_Branch: "Terminal a \<noteq> Branch c rs"
  and Branch_not_Terminal: "Branch c rs \<noteq> Terminal a"
  and Linear_not_Branch: "Linear b r \<noteq> Branch c rs"
  and Branch_not_Linear: "Branch c rs \<noteq> Linear b r"
  and Terminal_inject: "Terminal a = Terminal a' \<longleftrightarrow> a = a'"
  and Linear_inject: "Linear b r = Linear b' r' \<longleftrightarrow> b = b' \<and> r = r'"
  and Branch_inject: "Branch c rs = Branch c' rs' \<longleftrightarrow> c = c' \<and> rs = rs'"
apply(auto simp add: Terminal_def Linear_def Branch_def simp add: Rep_resumption resumption.intros Abs_resumption_inject Rep_resumption_inject)
apply(subst (asm) fun_eq_iff, auto simp add: Rep_resumption_inject)
done

lemma Rep_resumption_constructors:
  shows Rep_resumption_Terminal: "Rep_resumption (Terminal a) = TERMINAL a"
  and Rep_resumption_Linear: "Rep_resumption (Linear b r) = LINEAR b (Rep_resumption r)"
  and Rep_resumption_Branch: "Rep_resumption (Branch c rs) = BRANCH c (\<lambda>d. Rep_resumption (rs d))"
by(simp_all add: Terminal_def Linear_def Branch_def Abs_resumption_inverse resumption.intros Rep_resumption)

text \<open>Case operator\<close>

definition case_resumption :: "('a \<Rightarrow> 'e) \<Rightarrow> ('b \<Rightarrow> ('a,'b,'c,'d) resumption \<Rightarrow> 'e) \<Rightarrow>
                            ('c \<Rightarrow> ('d \<Rightarrow> ('a,'b,'c,'d) resumption) \<Rightarrow> 'e) \<Rightarrow> ('a,'b,'c,'d) resumption \<Rightarrow> 'e"
where [code del]:
  "case_resumption t l br r =
   case_RESUMPTION t (\<lambda>b r. l b (Abs_resumption r)) (\<lambda>c rs. br c (\<lambda>d. Abs_resumption (rs d))) (Rep_resumption r)"

lemma case_resumption_simps [simp, code]:
  shows case_resumption_Terminal: "case_resumption t l br (Terminal a) = t a"
  and case_resumption_Linear: "case_resumption t l br (Linear b r) = l b r"
  and case_resumption_Branch: "case_resumption t l br (Branch c rs) = br c rs"
by(simp_all add: Terminal_def Linear_def Branch_def case_resumption_def Abs_resumption_inverse resumption.intros Rep_resumption Rep_resumption_inverse)

declare [[case_translation case_resumption Terminal Linear Branch]]

lemma case_resumption_cert:
  assumes "CASE \<equiv> case_resumption t l br"
  shows "(CASE (Terminal a) \<equiv> t a) &&& (CASE (Linear b r) \<equiv> l b r) &&& (CASE (Branch c rs) \<equiv> br c rs)"
using assms by simp_all

code_datatype Terminal Linear Branch

setup \<open>Code.declare_case_global @{thm case_resumption_cert}\<close>

setup \<open>
  Nitpick.register_codatatype @{typ "('a,'b,'c,'d) resumption"} @{const_name case_resumption}
                              (map dest_Const [@{term Terminal}, @{term Linear}, @{term Branch}])
\<close>

lemma resumption_exhaust [cases type: resumption]:
  obtains (Terminal) a where "x = Terminal a"
  | (Linear) b r where "x = Linear b r"
  | (Branch) c rs where "x = Branch c rs"
proof(cases x)
  case (Abs_resumption y)
  note [simp] = \<open>x = Abs_resumption y\<close>
  from \<open>y \<in> resumption\<close> show thesis
  proof(cases rule: resumption.cases)
    case resumption_TERMINAL thus ?thesis
      by -(rule Terminal, simp add: Terminal_def)
  next
    case (resumption_LINEAR r b)
    from \<open>r \<in> resumption\<close> have "Rep_resumption (Abs_resumption r) = r"
      by(simp add: Abs_resumption_inverse)
    hence "y = LINEAR b (Rep_resumption (Abs_resumption r))"
      using \<open>y = LINEAR b r\<close> by simp
    thus ?thesis by -(rule Linear, simp add: Linear_def)
  next
    case (resumption_BRANCH rs c)
    from \<open>\<And>d. rs d \<in> resumption\<close>
    have eq: "rs = (\<lambda>d. Rep_resumption (Abs_resumption (rs d)))"
      by(subst Abs_resumption_inverse) blast+
    show ?thesis using \<open>y = BRANCH c rs\<close>
      by -(rule Branch, simp add: Branch_def, subst eq, simp)
  qed
qed

lemma resumption_split:
  "P (case_resumption t l br r) \<longleftrightarrow>
  (\<forall>a. r = Terminal a \<longrightarrow> P (t a)) \<and>
  (\<forall>b r'. r = Linear b r' \<longrightarrow> P (l b r')) \<and>
  (\<forall>c rs. r = Branch c rs \<longrightarrow> P (br c rs))"
by(cases r) simp_all

lemma resumption_split_asm:
  "P (case_resumption t l br r) \<longleftrightarrow>
  \<not> ((\<exists>a. r = Terminal a \<and> \<not> P (t a)) \<or>
     (\<exists>b r'. r = Linear b r' \<and> \<not> P (l b r')) \<or>
     (\<exists>c rs. r = Branch c rs \<and> \<not> P (br c rs)))"
by(cases r) simp_all

lemmas resumption_splits = resumption_split resumption_split_asm

text \<open>corecursion operator\<close>

datatype (dead 'a, dead 'b, dead 'c, dead 'd, dead 'e) resumption_corec =
    Terminal_corec 'a
  | Linear_corec 'b 'e
  | Branch_corec 'c "'d \<Rightarrow> 'e"
  | Resumption_corec "('a, 'b, 'c, 'd) resumption"

primrec RESUMPTION_corec_aux :: "nat \<Rightarrow> ('e \<Rightarrow> ('a,'b,'c,'d,'e) resumption_corec) \<Rightarrow> 'e \<Rightarrow> ('c + 'b + 'a,'d) Old_Datatype.dtree"
where
  "RESUMPTION_corec_aux 0 f e = {}"
| "RESUMPTION_corec_aux (Suc n) f e =
  (case f e of Terminal_corec a \<Rightarrow> TERMINAL a
            | Linear_corec b e' \<Rightarrow> LINEAR b (RESUMPTION_corec_aux n f e')
            | Branch_corec c es \<Rightarrow> BRANCH c (\<lambda>d. RESUMPTION_corec_aux n f (es d))
            | Resumption_corec r \<Rightarrow> Rep_resumption r)"

definition RESUMPTION_corec :: "('e \<Rightarrow> ('a,'b,'c,'d,'e) resumption_corec) \<Rightarrow> 'e \<Rightarrow> ('c + 'b + 'a,'d) Old_Datatype.dtree"
where
  "RESUMPTION_corec f e = (\<Union>n. RESUMPTION_corec_aux n f e)"

lemma RESUMPTION_corec [nitpick_simp]:
  "RESUMPTION_corec f e =
  (case f e of Terminal_corec a \<Rightarrow> TERMINAL a
            | Linear_corec b e' \<Rightarrow> LINEAR b (RESUMPTION_corec f e')
            | Branch_corec c es \<Rightarrow> BRANCH c (\<lambda>d. RESUMPTION_corec f (es d))
            | Resumption_corec r \<Rightarrow> Rep_resumption r)"
  (is "?lhs = ?rhs")
proof
  show "?lhs \<subseteq> ?rhs" unfolding RESUMPTION_corec_def
  proof(rule UN_least)
    fix n
    show "RESUMPTION_corec_aux n f e
        \<subseteq> (case f e of Terminal_corec a \<Rightarrow> TERMINAL a
           | Linear_corec b e' \<Rightarrow> LINEAR b (\<Union>n. RESUMPTION_corec_aux n f e')
           | Branch_corec c es \<Rightarrow> BRANCH c (\<lambda>d. \<Union>n. RESUMPTION_corec_aux n f (es d))
           | Resumption_corec r \<Rightarrow> Rep_resumption r)"
      apply(cases n, simp_all split: resumption_corec.split)
      by(rule conjI strip LINEAR_mono[OF UN_upper] BRANCH_mono[OF UN_upper] UNIV_I)+
  qed
next
  show "?rhs \<subseteq> ?lhs" unfolding RESUMPTION_corec_def
    apply(simp split: resumption_corec.split add: LINEAR_UN BRANCH_UN)
    by safe(rule_tac a="Suc n" for n in UN_I, rule UNIV_I, simp)+
qed

lemma RESUMPTION_corec_type: "RESUMPTION_corec f e \<in> resumption"
proof -
  have "\<exists>x. RESUMPTION_corec f e = RESUMPTION_corec f x" by blast
  thus ?thesis
  proof coinduct
    case (resumption x)
    then obtain e where x: "x = RESUMPTION_corec f e" by blast
    thus ?case
    proof(cases "f e")
      case (Resumption_corec r)
      thus ?thesis using x
        by(cases r)(simp_all add: RESUMPTION_corec Rep_resumption_constructors Rep_resumption)
    qed(auto simp add: RESUMPTION_corec)
  qed
qed

text \<open>corecursion operator for the resumption type\<close>

definition resumption_corec :: "('e \<Rightarrow> ('a,'b,'c,'d,'e) resumption_corec) \<Rightarrow> 'e \<Rightarrow> ('a,'b,'c,'d) resumption"
where
  "resumption_corec f e = Abs_resumption (RESUMPTION_corec f e)"

lemma resumption_corec:
  "resumption_corec f e =
  (case f e of Terminal_corec a \<Rightarrow> Terminal a
            | Linear_corec b e' \<Rightarrow> Linear b (resumption_corec f e')
            | Branch_corec c es \<Rightarrow> Branch c (\<lambda>d. resumption_corec f (es d))
            | Resumption_corec r \<Rightarrow> r)"
unfolding resumption_corec_def
apply(subst RESUMPTION_corec)
apply(auto split: resumption_corec.splits simp add: Terminal_def Linear_def Branch_def RESUMPTION_corec_type Abs_resumption_inverse Rep_resumption_inverse)
done

text \<open>Equality as greatest fixpoint\<close>

coinductive Eq_RESUMPTION :: "('c+'b+'a, 'd) Old_Datatype.dtree \<Rightarrow> ('c+'b+'a, 'd) Old_Datatype.dtree \<Rightarrow> bool"
where
  EqTERMINAL: "Eq_RESUMPTION (TERMINAL a) (TERMINAL a)"
| EqLINEAR: "Eq_RESUMPTION r r' \<Longrightarrow> Eq_RESUMPTION (LINEAR b r) (LINEAR b r')"
| EqBRANCH: "(\<And>d. Eq_RESUMPTION (rs d) (rs' d)) \<Longrightarrow> Eq_RESUMPTION (BRANCH c rs) (BRANCH c rs')"

lemma Eq_RESUMPTION_refl:
  assumes "r \<in> resumption"
  shows "Eq_RESUMPTION r r"
proof -
  define r' where "r' = r"
  with assms have "r = r' \<and> r \<in> resumption" by auto
  thus "Eq_RESUMPTION r r'"
  proof(coinduct)
    case (Eq_RESUMPTION r r')
    hence [simp]: "r = r'" and "r \<in> resumption" by auto
    from \<open>r \<in> resumption\<close> show ?case
      by(cases rule: resumption.cases) auto
  qed
qed

lemma Eq_RESUMPTION_into_resumption:
  assumes "Eq_RESUMPTION r r"
  shows "r \<in> resumption"
using assms
proof(coinduct)
  case resumption thus ?case by cases auto
qed

lemma Eq_RESUMPTION_eq:
  "Eq_RESUMPTION r r' \<longleftrightarrow> r = r' \<and> r \<in> resumption"
proof(rule iffI)
  assume "Eq_RESUMPTION r r'"
  hence "\<And>k. ntrunc k r = ntrunc k r'" by(rule Eq_RESUMPTION_implies_ntrunc_equality)
  hence "r = r'" by(rule ntrunc_equality)
  moreover with \<open>Eq_RESUMPTION r r'\<close> have "r \<in> resumption"
    by(auto intro: Eq_RESUMPTION_into_resumption)
  ultimately show "r = r' \<and> r \<in> resumption" ..
next
  assume "r = r' \<and> r \<in> resumption"
  thus "Eq_RESUMPTION r r'" by(blast intro: Eq_RESUMPTION_refl)
qed

lemma Eq_RESUMPTION_I [consumes 1, case_names Eq_RESUMPTION, case_conclusion Eq_RESUMPTION EqTerminal EqLinear EqBranch]:
  assumes "X r r'"
  and step: "\<And>r r'. X r r' \<Longrightarrow>
             (\<exists>a. r = TERMINAL a \<and> r' = TERMINAL a) \<or>
             (\<exists>R R' b. r = LINEAR b R \<and> r' = LINEAR b R' \<and> (X R R' \<or> Eq_RESUMPTION R R')) \<or>
             (\<exists>rs rs' c. r = BRANCH c rs \<and> r' = BRANCH c rs' \<and> (\<forall>d. X (rs d) (rs' d) \<or> Eq_RESUMPTION (rs d) (rs' d)))"
  shows "r = r'"
proof -
  from \<open>X r r'\<close> have "Eq_RESUMPTION r r'"
    by(coinduct)(rule step)
  thus ?thesis by(simp add: Eq_RESUMPTION_eq)
qed

lemma resumption_equalityI [consumes 1, case_names Eq_resumption, case_conclusion Eq_resumption EqTerminal EqLinear EqBranch]:
  assumes "X r r'"
  and step: "\<And>r r'. X r r' \<Longrightarrow>
             (\<exists>a. r = Terminal a \<and> r' = Terminal a) \<or>
             (\<exists>R R' b. r = Linear b R \<and> r' = Linear b R' \<and> (X R R' \<or> R = R')) \<or>
             (\<exists>rs rs' c. r = Branch c rs \<and> r' = Branch c rs' \<and> (\<forall>d. X (rs d) (rs' d) \<or> rs d = rs' d))"
  shows "r = r'"
proof -
  define M N where "M = Rep_resumption r" and "N = Rep_resumption r'"
  with \<open>X r r'\<close> have "\<exists>r r'. M = Rep_resumption r \<and> N = Rep_resumption r' \<and> X r r'" by blast
  hence "M = N"
  proof(coinduct rule: Eq_RESUMPTION_I)
    case (Eq_RESUMPTION M N)
    then obtain r r' where [simp]: "M = Rep_resumption r" "N = Rep_resumption r'"
      and "X r r'" by blast
    { assume "\<exists>a. r = Terminal a \<and> r' = Terminal a"
      hence ?EqTerminal by(auto simp add: Rep_resumption_constructors)
      hence ?case .. }
    moreover
    { assume "\<exists>R R' b. r = Linear b R \<and> r' = Linear b R' \<and> (X R R' \<or> R = R')"
      hence ?EqLinear
        by(clarsimp simp add: Rep_resumption_constructors Eq_RESUMPTION_eq Rep_resumption_inject Rep_resumption)
      hence ?case by blast }
    moreover
    { assume "\<exists>rs rs' c. r = Branch c rs \<and> r' = Branch c rs' \<and> (\<forall>d. X (rs d) (rs' d) \<or> rs d = rs' d)"
      hence ?EqBranch
        by(clarsimp simp add: Rep_resumption_constructors Eq_RESUMPTION_eq Rep_resumption_inject Rep_resumption)
      hence ?case by blast }
    ultimately show ?case using step[OF \<open>X r r'\<close>] by blast
  qed
  thus ?thesis unfolding M_def N_def by(simp add: Rep_resumption_inject)
qed

text \<open>
  Finality of \<open>resumption\<close>: Uniqueness of functions defined by corecursion.
\<close>

lemma equals_RESUMPTION_corec:
  assumes h: "\<And>x. h x = (case f x of Terminal_corec a \<Rightarrow> TERMINAL a
                                   | Linear_corec b x' \<Rightarrow> LINEAR b (h x')
                                   | Branch_corec c xs \<Rightarrow> BRANCH c (\<lambda>d. h (xs d))
                                   | Resumption_corec r \<Rightarrow> Rep_resumption r)"
  shows "h = RESUMPTION_corec f"
proof
  fix x
  define h' where "h' = RESUMPTION_corec f"
  have h': "\<And>x. h' x = (case f x of Terminal_corec a \<Rightarrow> TERMINAL a
                                   | Linear_corec b x' \<Rightarrow> LINEAR b (h' x')
                                   | Branch_corec c xs \<Rightarrow> BRANCH c (\<lambda>d. h' (xs d))
                                   | Resumption_corec r \<Rightarrow> Rep_resumption r)"
    unfolding h'_def by(simp add: RESUMPTION_corec)
  define M N where "M = h x" and "N = h' x"
  hence "\<exists>x. M = h x \<and> N = h' x" by blast
  thus "M = N"
  proof(coinduct rule: Eq_RESUMPTION_I)
    case (Eq_RESUMPTION M N)
    then obtain x where [simp]: "M = h x" "N = h' x" by blast
    show ?case
    proof(cases "f x")
      case (Terminal_corec a)
      with h h' have ?EqTerminal by simp
      thus ?thesis ..
    next
      case (Linear_corec b x')
      with h h' have ?EqLinear by auto
      thus ?thesis by blast
    next
      case (Branch_corec c xs)
      with h h' have ?EqBranch by auto
      thus ?thesis by blast
    next
      case (Resumption_corec r)
      thus ?thesis
        by(cases r)(simp_all add: h h' Rep_resumption_constructors Eq_RESUMPTION_refl Rep_resumption)
    qed
  qed
qed

lemma equals_resumption_corec:
  assumes h: "\<And>x. h x = (case f x of Terminal_corec a \<Rightarrow> Terminal a
                                   | Linear_corec b x' \<Rightarrow> Linear b (h x')
                                   | Branch_corec c xs \<Rightarrow> Branch c (\<lambda>d. h (xs d))
                                   | Resumption_corec r \<Rightarrow> r)"
  shows "h = resumption_corec f"
proof(rule ext)
  fix x
  { fix x
    from h[of x]
    have "Rep_resumption (h x) =
      (case f x of Terminal_corec a \<Rightarrow> TERMINAL a
                | Linear_corec b x' \<Rightarrow> LINEAR b (Rep_resumption (h x'))
                | Branch_corec c xs \<Rightarrow> BRANCH c (\<lambda>d. Rep_resumption (h (xs d)))
                | Resumption_corec r \<Rightarrow> Rep_resumption r)"
      by(auto split: resumption_corec.split simp add: Rep_resumption_constructors) }
  hence eq: "(\<lambda>x. Rep_resumption (h x)) = RESUMPTION_corec f" by(rule equals_RESUMPTION_corec)
  hence "Abs_resumption (Rep_resumption (h x)) = Abs_resumption (RESUMPTION_corec f x)"
    by(subst (asm) fun_eq_iff)(auto)
  from this[symmetric] show "h x = resumption_corec f x"
    unfolding resumption_corec_def by(simp add: Rep_resumption_inverse)
qed

end


(*
Copyright 2009-2014 Christian Sternagel, René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)

section {* Converting Values to Readable Strings *}

theory Old_Show
imports Main
keywords "standard_shows_list" :: thy_decl
begin

text {*
  A type class similar to Haskell's \texttt{Show} class, allowing for constant-time concatenation of
  @{type string}s using function composition.
*}

type_synonym
  "shows" = "string \<Rightarrow> string"

text {*
  Convert a string to a show-function that simply prepends the string unchanged.
*}
definition shows_string :: "string \<Rightarrow> shows"
where
  "shows_string = op @"

class "show" =
  fixes shows_prec :: "nat \<Rightarrow> 'a \<Rightarrow> shows"
    and shows_list :: "'a list \<Rightarrow> shows"
  assumes assoc [simp]:
    "shows_prec d x r @ s = shows_prec d x (r @ s)"
    "shows_list xs r @ s = shows_list xs (r @ s)"
begin

abbreviation "shows" :: "'a \<Rightarrow> shows"
where
  "shows x \<equiv> shows_prec 0 x"

abbreviation "show" :: "'a \<Rightarrow> string"
where
  "show x \<equiv> shows x ''''"

end

abbreviation shows_cons :: "string \<Rightarrow> shows \<Rightarrow> shows" (infixr "+#+" 10)
where
  "s +#+ p \<equiv> shows_string s \<circ> p"

abbreviation (input) shows_append :: "shows \<Rightarrow> shows \<Rightarrow> shows" (infixr "+@+" 10)
where
  "s +@+ p \<equiv> s \<circ> p"

definition shows_between :: "shows \<Rightarrow> shows \<Rightarrow> shows \<Rightarrow> shows"
where
  "shows_between l p r = (l +@+ p +@+ r)"

fun shows_sep :: "('a \<Rightarrow> shows) \<Rightarrow> shows \<Rightarrow> 'a list \<Rightarrow> shows"
where
  "shows_sep s sep [] = shows_string ''''" |
  "shows_sep s sep [x] = s x" |
  "shows_sep s sep (x#xs) = (s x +@+ sep +@+ shows_sep s sep xs)"

lemma shows_sep_assoc [simp]:
  assumes "\<And>r s. \<forall>x\<in>set xs. elt x r @ s = elt x (r @ s)"
    and "\<And>r s. sep r @ s = sep (r @ s)"
  shows "shows_sep elt sep xs r @ s = shows_sep elt sep xs (r @ s)"
using assms
proof (induct xs)
  case (Cons x xs) then show ?case by (cases xs) (simp_all)
qed (simp add: shows_string_def)

lemma shows_string_assoc [simp]:
  "shows_string x r @ s = shows_string x (r @ s)"
  by (simp add: shows_string_def)

lemma shows_between_assoc [simp]:
  assumes "\<And>s t. l s @ t = l (s @ t)"
    and "\<And>s t. m s @ t = m (s @ t)"
    and "\<And>s t. r s @ t = r (s @ t)"
  shows "shows_between l m r s @ t = shows_between l m r (s @ t)"
  using assms by (simp add: shows_between_def)

definition
  shows_list_gen :: "('a \<Rightarrow> shows) \<Rightarrow> string \<Rightarrow> string \<Rightarrow> string \<Rightarrow> string \<Rightarrow> 'a list \<Rightarrow> shows"
where
  "shows_list_gen elt e l s r xs = (
    if xs = [] then shows_string e
    else shows_between (shows_string l) (shows_sep elt (shows_string s) xs) (shows_string r))"

lemma shows_list_gen_assoc [simp]:
  assumes "\<And>r s. \<forall>x\<in>set xs. elt x r @ s = elt x (r @ s)"
  shows "shows_list_gen elt e l sep r xs s @ t = shows_list_gen elt e l sep r xs (s @ t)"
  using assms by (cases xs) (simp_all add: shows_list_gen_def)

definition shows_list_aux :: "('a \<Rightarrow> shows) \<Rightarrow> 'a list \<Rightarrow> shows"
where
  "shows_list_aux s xs = shows_list_gen s ''[]'' ''['' '', '' '']'' xs"

lemma assoc_elt:
  "\<forall>x\<in>set xs. shows (x::'a::show) r @ s = shows x (r @ s)"
  by simp

lemma shows_list_aux_assoc:
  assumes "\<And>r s. \<forall>x\<in>set xs. elt x r @ s = elt x (r @ s)"
  shows "shows_list_aux elt xs r @ s = shows_list_aux elt xs (r @ s)"
  using assms by (simp add: shows_list_aux_def)

ML {*
(* FIXME export proper ML interfaces: define_shows_list, define_shows_list_cmd *)
let
  fun define_shows_list assoc_thm_ref lthy =
    let
      val assoc_thm = singleton (Attrib.eval_thms lthy) assoc_thm_ref
      fun get_base_type thm =
        let
           val lhs = thm |> Thm.prop_of |> HOLogic.dest_Trueprop |> HOLogic.dest_eq |> fst
           fun get_ty (Const (@{const_name append}, _) $
             (Const (@{const_name shows_prec}, _) $ _ $ x $ _) $ _) = dest_Var x |> snd
             | get_ty t = raise TERM ("Expecting associativity lemma for 'shows_prec'", [t])
        in get_ty lhs end
      val base_ty = get_base_type assoc_thm

      val list_ty = Type (@{type_name "list"}, [base_ty])
      val shows_ty = @{typ "shows"}
      val shows = Abs ("x", base_ty, Const (@{const_name "shows_prec"},
        @{typ nat} --> base_ty --> shows_ty) $ @{term "0 :: nat"} $ Bound 0)
      val shows_list_aux = Const (@{const_name shows_list_aux},
        (base_ty --> shows_ty) --> list_ty --> shows_ty)
      val shows_list = Const (@{const_name shows_list}, list_ty --> shows_ty)
      val rhs = shows_list_aux $ shows
      val shows_list_eq = Logic.mk_equals (shows_list, rhs)

      val ((c, _), rhs) = Syntax.check_term lthy shows_list_eq |> Logic.dest_equals |>> dest_Free;
      val ((_, (_, def_thm')), lthy') =
        Local_Theory.define
          ((Binding.name c, NoSyn), ((Binding.name (c ^ "_def"), @{attributes [code]}), rhs))
          lthy
      val def_thm =
        Proof_Context.theory_of lthy'
        |> Proof_Context.init_global
        |> Proof_Context.export lthy'
        |> (fn x => singleton x def_thm')

      val lthy'' = Class.prove_instantiation_instance (fn ctxt =>
        Class.intro_classes_tac ctxt []
        THEN resolve_tac ctxt [assoc_thm] 1
        THEN unfold_tac ctxt [def_thm]
        THEN resolve_tac ctxt @{thms shows_list_aux_assoc} 1
        THEN resolve_tac ctxt @{thms ballI} 1
        THEN resolve_tac ctxt [assoc_thm] 1
        ) lthy'
    in lthy'' end
in
  Outer_Syntax.local_theory @{command_keyword standard_shows_list}
    "use standard way to extend shows to shows_list, requires associativity lemma as parameter"
    (*standard way: "shows_list = shows_list_aux shows"*)
    (Parse.xthm >> define_shows_list)
end
*}

instantiation char :: "show"
begin

definition "shows_prec d (c::char) = op # c"

definition "shows_list (cs::string) = shows_string cs"

instance
  by (intro_classes,unfold shows_prec_char_def shows_list_char_def shows_string_def, simp) auto

end

instantiation list :: ("show") "show"
begin

definition "shows_prec d (l::'a::show list) = shows_list l"

lemma assoc_list:
  "shows_prec d (x::'a::show list) r @ s = shows_prec d x (r @ s)"
  by (simp add: shows_prec_list_def)

standard_shows_list assoc_list

end

definition "shows_nl = shows ''\<newline>''"

definition "shows_space = shows (CHR '' '')"

definition shows_paren :: "shows \<Rightarrow> shows"
where
  "shows_paren p = (shows (CHR ''('') +@+ p +@+ shows (CHR '')''))"

lemmas show_defs =
  shows_prec_char_def shows_nl_def shows_space_def
  shows_string_def shows_between_def shows_paren_def

definition shows_lines :: "'a::show list \<Rightarrow> shows"
where
  "shows_lines = shows_sep shows shows_nl"

definition shows_many :: "'a::show list \<Rightarrow> shows"
where
  "shows_many = shows_sep shows id"

definition shows_words :: "'a::show list \<Rightarrow> shows"
where
  "shows_words = shows_sep shows shows_space"

fun shows_map :: "('a \<Rightarrow> shows) \<Rightarrow> 'a list \<Rightarrow> shows"
where
  "shows_map s [] = id" |
  "shows_map s (x # xs) = (s x +@+ shows_map s xs)"

lemma shows_nl_assoc [simp]:
  "shows_nl r @ s = shows_nl (r @ s)"
  by (simp add: show_defs)

lemma shows_id_assoc [simp]:
  "id r @ s = id (r @ s)" by simp

lemma shows_space_assoc [simp]:
  "shows_space r @ s = shows_space (r @ s)"
  by (simp add: show_defs)

lemma shows_lines_assoc [simp]:
  "shows_lines xs r @ s = shows_lines xs (r @ s)"
  by (simp add: shows_lines_def)

lemma shows_many_assoc [simp]:
  "shows_many xs r @ s = shows_many xs (r @ s)"
  by (simp add: shows_many_def)

lemma shows_words_assoc [simp]:
  "shows_words xs r @ s = shows_words xs (r @ s)"
  by (simp add: shows_words_def)

lemma shows_map_assoc [simp]:
  assumes "\<And>r s.\<forall>x\<in>set xs. elt x r @ s = elt x (r @ s)"
  shows "shows_map elt xs r @ s = shows_map elt xs (r @ s)"
  using assms by (induct xs) auto

fun shows_concat :: "shows list \<Rightarrow> shows"
where
  "shows_concat [] = id" |
  "shows_concat (s # ss) = (s +@+ shows_concat ss)"

lemma shows_map_cong [fundef_cong]:
  assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> f x = g x"
  shows "shows_map f xs = shows_map g ys"
  using assms by (induct xs arbitrary: ys) auto

lemma shows_sep_cong [fundef_cong]:
  assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> f x = g x"
  shows "shows_sep f sep xs = shows_sep g sep ys"
  unfolding assms(1) using assms(2)
proof (induct ys)
  case (Cons y ys)
  thus ?case by (cases ys) auto
qed auto

lemma shows_list_gen_cong [fundef_cong]:
  assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> f x = g x"
  shows "shows_list_gen f e l sep r xs = shows_list_gen g e l sep r ys"
  using shows_sep_cong [of xs ys f g] assms by (cases xs) (auto simp: shows_list_gen_def)

definition shows_quote :: "shows \<Rightarrow> shows"
where
  "shows_quote s = shows_between (shows (Char Nibble2 Nibble7)) s (shows (Char Nibble2 Nibble7))"

text {*
  Don't use Haskell's existing "Show" class for code-generation, since it is not compatible to the
  formalized class.
*}
code_reserved Haskell "Show"

end


theory Bisim_Pres
  imports Bisimulation Sim_Pres
begin

context env begin

lemma bisim_input_pres:
  fixes \<Psi>    :: 'b
  and   P    :: "('a, 'b, 'c) psi"
  and   Q    :: "('a, 'b, 'c) psi"
  and   M    :: 'a
  and   xvec :: "name list"
  and   N    :: 'a

  assumes "\<And>Tvec. length xvec = length Tvec \<Longrightarrow> \<Psi> \<rhd> P[xvec::=Tvec] \<sim> Q[xvec::=Tvec]"

  shows "\<Psi> \<rhd> M\<lparr>\<lambda>*xvec N\<rparr>.P \<sim> M\<lparr>\<lambda>*xvec N\<rparr>.Q"
proof -
  let ?X = "{(\<Psi>, M\<lparr>\<lambda>*xvec N\<rparr>.P, M\<lparr>\<lambda>*xvec N\<rparr>.Q) | \<Psi> M xvec N P Q. \<forall>Tvec. length xvec = length Tvec \<longrightarrow> \<Psi> \<rhd> P[xvec::=Tvec] \<sim> Q[xvec::=Tvec]}"

  from assms have "(\<Psi>, M\<lparr>\<lambda>*xvec N\<rparr>.P, M\<lparr>\<lambda>*xvec N\<rparr>.Q) \<in> ?X" by blast
  thus ?thesis
  proof(coinduct rule: bisim_coinduct)
    case(c_stat_eq \<Psi> P Q)
    thus ?case by auto
  next
    case(c_sim \<Psi> P Q)
    thus ?case by(blast intro: input_pres)
  next
    case(c_ext \<Psi> P Q \<Psi>')
    thus ?case by(blast dest: bisimE)
  next
    case(c_sym \<Psi> P Q)
    thus ?case by(blast dest: bisimE)
  qed
qed

lemma bisim_output_pres:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   M :: 'a
  and   N :: 'a

  assumes "\<Psi> \<rhd> P \<sim> Q"

  shows "\<Psi> \<rhd> M\<langle>N\<rangle>.P \<sim> M\<langle>N\<rangle>.Q"
proof -
  let ?X = "{(\<Psi>, M\<langle>N\<rangle>.P, M\<langle>N\<rangle>.Q) | \<Psi> M N P Q. \<Psi> \<rhd> P \<sim> Q}"
  from `\<Psi> \<rhd> P \<sim> Q` have "(\<Psi>, M\<langle>N\<rangle>.P, M\<langle>N\<rangle>.Q) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: bisim_coinduct, auto) (blast intro: output_pres dest: bisimE)+
qed

lemma bisim_case_pres:
  fixes \<Psi>   :: 'b
  and   CsP :: "('c \<times> ('a, 'b, 'c) psi) list"
  and   CsQ :: "('c \<times> ('a, 'b, 'c) psi) list"

  assumes "\<And>\<phi> P. (\<phi>, P) mem CsP \<Longrightarrow> \<exists>Q. (\<phi>, Q) mem CsQ \<and> guarded Q \<and> \<Psi> \<rhd> P \<sim> Q"
  and     "\<And>\<phi> Q. (\<phi>, Q) mem CsQ \<Longrightarrow> \<exists>P. (\<phi>, P) mem CsP \<and> guarded P \<and> \<Psi> \<rhd> P \<sim> Q"

  shows "\<Psi> \<rhd> Cases CsP \<sim> Cases CsQ"
proof -
  let ?X = "{(\<Psi>, Cases CsP, Cases CsQ) | \<Psi> CsP CsQ. (\<forall>\<phi> P. (\<phi>, P) mem CsP \<longrightarrow> (\<exists>Q. (\<phi>, Q) mem CsQ \<and> guarded Q \<and> \<Psi> \<rhd> P \<sim> Q)) \<and>
                                                     (\<forall>\<phi> Q. (\<phi>, Q) mem CsQ \<longrightarrow> (\<exists>P. (\<phi>, P) mem CsP \<and> guarded P \<and> \<Psi> \<rhd> P \<sim> Q))}"
  from assms have "(\<Psi>, Cases CsP, Cases CsQ) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: bisim_coinduct)
    case(c_stat_eq \<Psi> P Q)
    thus ?case by auto
  next
    case(c_sim \<Psi> CasesP CasesQ)
    then obtain CsP CsQ where C1: "\<And>\<phi> Q. (\<phi>, Q) mem CsQ \<Longrightarrow> \<exists>P. (\<phi>, P) mem CsP \<and> guarded P \<and> \<Psi> \<rhd> P \<sim> Q"
                          and A: "CasesP = Cases CsP" and B: "CasesQ = Cases CsQ"
      by auto
    note C1
    moreover have "\<And>\<Psi> P Q. \<Psi> \<rhd> P \<sim> Q \<Longrightarrow> \<Psi> \<rhd> P \<leadsto>[bisim] Q" by(rule bisimE)
    moreover have "bisim \<subseteq> ?X \<union> bisim" by blast
    ultimately have "\<Psi> \<rhd> Cases CsP \<leadsto>[(?X \<union> bisim)] Cases CsQ"
      by(rule case_pres)
    thus ?case using A B by blast
  next
    case(c_ext \<Psi> P Q)
    thus ?case by(blast dest: bisimE)
  next
    case(c_sym \<Psi> P Q)
    thus ?case by(blast dest: bisimE)
  qed
qed

lemma bisim_res_pres:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   x :: name

  assumes "\<Psi> \<rhd> P \<sim> Q"
  and     "x \<sharp> \<Psi>"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>P \<sim> \<lparr>\<nu>x\<rparr>Q"
proof -
  let ?X = "{(\<Psi>, \<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) | \<Psi> x P Q. \<Psi> \<rhd> P \<sim> Q \<and> x \<sharp> \<Psi>}"

  from assms have "(\<Psi>, \<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: bisim_coinduct)
    case(c_stat_eq \<Psi> xP xQ)
    from `(\<Psi>, xP, xQ) \<in> ?X` obtain x P Q where "\<Psi> \<rhd> P \<sim> Q" and "x \<sharp> \<Psi>" and "xP = \<lparr>\<nu>x\<rparr>P" and "xQ = \<lparr>\<nu>x\<rparr>Q"
      by auto
    moreover from `\<Psi> \<rhd> P \<sim> Q` have PeqQ: "insert_assertion(extract_frame P) \<Psi> \<simeq>\<^sub>F insert_assertion(extract_frame Q) \<Psi>"
      by(rule bisimE)
    ultimately show ?case by(auto intro: frame_res_pres)
  next
    case(c_sim \<Psi> xP xQ)
    from `(\<Psi>, xP, xQ) \<in> ?X` obtain x P Q where "\<Psi> \<rhd> P \<sim> Q" and "x \<sharp> \<Psi>" and "xP = \<lparr>\<nu>x\<rparr>P" and "xQ = \<lparr>\<nu>x\<rparr>Q"
      by auto
    from `\<Psi> \<rhd> P \<sim> Q` have "\<Psi> \<rhd> P \<leadsto>[bisim] Q" by(rule bisimE)
    moreover have "eqvt ?X"
      by(force simp add: eqvt_def bisim_closed pt_fresh_bij[OF pt_name_inst, OF at_name_inst])
    hence "eqvt(?X \<union> bisim)" by auto
    moreover note `x \<sharp> \<Psi>`
    moreover have "bisim \<subseteq> ?X \<union> bisim" by auto
    moreover have "\<And>\<Psi> P Q x. \<lbrakk>(\<Psi>, P, Q) \<in> bisim; x \<sharp> \<Psi>\<rbrakk> \<Longrightarrow> (\<Psi>, \<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X \<union> bisim"
      by auto
    ultimately have "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>P \<leadsto>[(?X \<union> bisim)] \<lparr>\<nu>x\<rparr>Q"
      by(rule res_pres)
    with `xP = \<lparr>\<nu>x\<rparr>P` `xQ = \<lparr>\<nu>x\<rparr>Q` show ?case
      by simp
  next
    case(c_ext \<Psi> xP xQ \<Psi>')
    from `(\<Psi>, xP, xQ) \<in> ?X` obtain x P Q where "\<Psi> \<rhd> P \<sim> Q" and "x \<sharp> \<Psi>" and "xP = \<lparr>\<nu>x\<rparr>P" and "xQ = \<lparr>\<nu>x\<rparr>Q"
      by auto
    obtain y::name where "y \<sharp> P" and "y \<sharp> Q" and "y \<sharp> \<Psi>" and "y \<sharp> \<Psi>'"
     by(generate_fresh "name", auto simp add: fresh_prod)
   from `\<Psi> \<rhd> P \<sim> Q` have "\<Psi> \<otimes> ([(x, y)] \<bullet> \<Psi>') \<rhd> P \<sim> Q"
     by(rule bisimE)
   hence "([(x, y)] \<bullet> (\<Psi> \<otimes> ([(x, y)] \<bullet> \<Psi>'))) \<rhd> ([(x, y)] \<bullet> P) \<sim> ([(x, y)] \<bullet> Q)"
     by(rule bisim_closed)
   with `x \<sharp> \<Psi>` `y \<sharp> \<Psi>` have "\<Psi> \<otimes> \<Psi>' \<rhd> ([(x, y)] \<bullet> P) \<sim> ([(x, y)] \<bullet> Q)"
     by(simp add: eqvts)
   with `y \<sharp> \<Psi>` `y \<sharp> \<Psi>'` have "(\<Psi> \<otimes> \<Psi>', \<lparr>\<nu>y\<rparr>([(x, y)] \<bullet> P), \<lparr>\<nu>y\<rparr>([(x, y)] \<bullet> Q)) \<in> ?X"
     by auto
   moreover from `y \<sharp> P` `y \<sharp> Q` have "\<lparr>\<nu>x\<rparr>P = \<lparr>\<nu>y\<rparr>([(x, y)] \<bullet> P)" and "\<lparr>\<nu>x\<rparr>Q = \<lparr>\<nu>y\<rparr>([(x, y)] \<bullet> Q)"
     by(simp add: alpha_res)+
   ultimately show ?case using `xP = \<lparr>\<nu>x\<rparr>P` `xQ = \<lparr>\<nu>x\<rparr>Q` by simp
 next
    case(c_sym \<Psi> P Q)
    thus ?case
      by(blast dest: bisimE)
  qed
qed

lemma bisim_res_chain_pres:
  fixes \<Psi>   :: 'b
  and   P    :: "('a, 'b, 'c) psi"
  and   Q    :: "('a, 'b, 'c) psi"
  and   xvec :: "name list"

  assumes "\<Psi> \<rhd> P \<sim> Q"
  and     "xvec \<sharp>* \<Psi>"

  shows "\<Psi> \<rhd> \<lparr>\<nu>*xvec\<rparr>P \<sim> \<lparr>\<nu>*xvec\<rparr>Q"
using assms
by(induct xvec) (auto intro: bisim_res_pres)

lemma bisim_par_pres_aux:
  fixes \<Psi>  :: 'b
  and   \<Psi>\<^sub>R :: 'b
  and   P  :: "('a, 'b, 'c) psi"
  and   Q  :: "('a, 'b, 'c) psi"
  and   R  :: "('a, 'b, 'c) psi"
  and   A\<^sub>R :: "name list"

  assumes "\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<sim> Q"
  and     FrR: "extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>"
  and     "A\<^sub>R \<sharp>* \<Psi>"
  and     "A\<^sub>R \<sharp>* P"
  and     "A\<^sub>R \<sharp>* Q"

  shows "\<Psi> \<rhd> P \<parallel> R \<sim> Q \<parallel> R"
proof -
  let ?X = "{(\<Psi>, \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R), \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)) | xvec \<Psi> P Q R. xvec \<sharp>* \<Psi> \<and> (\<forall>A\<^sub>R \<Psi>\<^sub>R. (extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle> \<and> A\<^sub>R \<sharp>* \<Psi> \<and> A\<^sub>R \<sharp>* P \<and> A\<^sub>R \<sharp>* Q) \<longrightarrow>
                                                                                \<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<sim> Q)}"
  {
    fix xvec :: "name list"
    and \<Psi>    :: 'b
    and P    :: "('a, 'b, 'c) psi"
    and Q    :: "('a, 'b, 'c) psi"
    and R    :: "('a, 'b, 'c) psi"

    assume "xvec \<sharp>* \<Psi>"
    and    "\<And>A\<^sub>R \<Psi>\<^sub>R. \<lbrakk>extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>; A\<^sub>R \<sharp>* \<Psi>; A\<^sub>R \<sharp>* P; A\<^sub>R \<sharp>* Q\<rbrakk> \<Longrightarrow> \<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<sim> Q"

    hence "(\<Psi>, \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R), \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)) \<in> ?X"
      apply auto
      by blast
  }

  note XI = this
  {
    fix xvec :: "name list"
    and \<Psi>    :: 'b
    and P    :: "('a, 'b, 'c) psi"
    and Q    :: "('a, 'b, 'c) psi"
    and R    :: "('a, 'b, 'c) psi"
    and C    :: "'d::fs_name"

    assume "xvec \<sharp>* \<Psi>"
    and    A: "\<And>A\<^sub>R \<Psi>\<^sub>R. \<lbrakk>extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>; A\<^sub>R \<sharp>* \<Psi>; A\<^sub>R \<sharp>* P; A\<^sub>R \<sharp>* Q; A\<^sub>R \<sharp>* C\<rbrakk> \<Longrightarrow> \<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<sim> Q"

    from `xvec \<sharp>* \<Psi>` have "(\<Psi>, \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R), \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)) \<in> ?X"
    proof(rule XI)
      fix A\<^sub>R \<Psi>\<^sub>R
      assume FrR: "extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>"
      obtain p::"name prm" where "(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>" and "(p \<bullet> A\<^sub>R) \<sharp>* P" and "(p \<bullet> A\<^sub>R) \<sharp>* Q" and "(p \<bullet> A\<^sub>R) \<sharp>* R" and "(p \<bullet> A\<^sub>R) \<sharp>* C"
                             and "(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>\<^sub>R" and S: "(set p) \<subseteq> (set A\<^sub>R) \<times> (set(p \<bullet> A\<^sub>R))" and "distinct_perm p"
	by(rule_tac c="(\<Psi>, P, Q, R, \<Psi>\<^sub>R, C)" in name_list_avoiding) auto
      from FrR `(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>\<^sub>R` S have "extract_frame R = \<langle>(p \<bullet> A\<^sub>R), p \<bullet> \<Psi>\<^sub>R\<rangle>" by(simp add: frame_chain_alpha')

      moreover assume "A\<^sub>R \<sharp>* \<Psi>"
      hence "(p \<bullet> A\<^sub>R) \<sharp>* (p \<bullet> \<Psi>)" by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
      with `A\<^sub>R \<sharp>* \<Psi>` `(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>` S have "(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>" by simp
      moreover assume "A\<^sub>R \<sharp>* P"
      hence "(p \<bullet> A\<^sub>R) \<sharp>* (p \<bullet> P)" by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
      with `A\<^sub>R \<sharp>* P` `(p \<bullet> A\<^sub>R) \<sharp>* P` S have "(p \<bullet> A\<^sub>R) \<sharp>* P" by simp
      moreover assume "A\<^sub>R \<sharp>* Q"
      hence "(p \<bullet> A\<^sub>R) \<sharp>* (p \<bullet> Q)" by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
      with `A\<^sub>R \<sharp>* Q` `(p \<bullet> A\<^sub>R) \<sharp>* Q` S have "(p \<bullet> A\<^sub>R) \<sharp>* Q" by simp
      ultimately have "\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R) \<rhd> P \<sim> Q" using `(p \<bullet> A\<^sub>R) \<sharp>* C` A by blast
      hence "(p \<bullet> (\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R))) \<rhd> (p \<bullet> P) \<sim> (p \<bullet> Q)" by(rule bisim_closed)
      with `A\<^sub>R \<sharp>* \<Psi>` `(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>` `A\<^sub>R \<sharp>* P` `(p \<bullet> A\<^sub>R) \<sharp>* P` `A\<^sub>R \<sharp>* Q` `(p \<bullet> A\<^sub>R) \<sharp>* Q` S `distinct_perm p`
      show "\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<sim> Q" by(simp add: eqvts)
    qed
  }
  note XI' = this

  have "eqvt ?X"
    apply(auto simp add: eqvt_def)
    apply(rule_tac x="p \<bullet> xvec" in exI)
    apply(rule_tac x="p \<bullet> P" in exI)
    apply(rule_tac x="p \<bullet> Q" in exI)
    apply(rule_tac x="p \<bullet> R" in exI)
    apply(simp add: eqvts)
    apply(simp add: fresh_star_bij)
    apply(clarify)
    apply(erule_tac x="(rev p) \<bullet> A\<^sub>R" in allE)
    apply(erule_tac x="(rev p) \<bullet> \<Psi>\<^sub>R" in allE)
    apply(drule mp)
    apply(rule conjI)
    apply(rule_tac pi=p in pt_bij4[OF pt_name_inst, OF at_name_inst])
    apply(simp add: eqvts)
    defer
    apply(drule_tac p=p in bisim_closed)
    apply(simp add: eqvts)
    apply(subst pt_fresh_star_bij[OF pt_name_inst,OF at_name_inst, of p, THEN sym])
    apply simp
    apply(subst pt_fresh_star_bij[OF pt_name_inst,OF at_name_inst, of p, THEN sym])
    apply simp
    apply(subst pt_fresh_star_bij[OF pt_name_inst,OF at_name_inst, of p, THEN sym])
    by simp

  moreover have Res: "\<And>\<Psi> P Q x. \<lbrakk>(\<Psi>, P, Q) \<in> ?X \<union> bisim; x \<sharp> \<Psi>\<rbrakk> \<Longrightarrow> (\<Psi>, \<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X \<union> bisim"
  proof -
    fix \<Psi> P Q x
    assume "(\<Psi>, P, Q) \<in> ?X \<union> bisim" and "(x::name) \<sharp> \<Psi>"
    show "(\<Psi>, \<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X \<union> bisim"
    proof(case_tac "(\<Psi>, P, Q) \<in> ?X")
      assume "(\<Psi>, P, Q) \<in> ?X"
      with `x \<sharp> \<Psi>` have "(\<Psi>, \<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X"
	apply auto
	by(rule_tac x="x#xvec" in exI) auto
      thus ?thesis by simp
    next
      assume "\<not>(\<Psi>, P, Q) \<in> ?X"
      with `(\<Psi>, P, Q) \<in> ?X \<union> bisim` have "\<Psi> \<rhd> P \<sim> Q"
	by blast
      hence "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>P \<sim> \<lparr>\<nu>x\<rparr>Q" using `x \<sharp> \<Psi>`
	by(rule bisim_res_pres)
      thus ?thesis
	by simp
    qed
  qed

  have "(\<Psi>, P \<parallel> R, Q \<parallel> R) \<in> ?X"
  proof -
    {
      fix A\<^sub>R' :: "name list"
      and \<Psi>\<^sub>R' :: 'b

      assume Fr_r': "extract_frame R = \<langle>A\<^sub>R', \<Psi>\<^sub>R'\<rangle>"
      and    "A\<^sub>R' \<sharp>* \<Psi>"
      and    "A\<^sub>R' \<sharp>* P"
      and    "A\<^sub>R' \<sharp>* Q"

      obtain p where "(p \<bullet> A\<^sub>R') \<sharp>* A\<^sub>R" and "(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>\<^sub>R'" and "(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>" and "(p \<bullet> A\<^sub>R') \<sharp>* P" and "(p \<bullet> A\<^sub>R') \<sharp>* Q"
                 and Sp: "(set p) \<subseteq> (set A\<^sub>R') \<times> (set(p \<bullet> A\<^sub>R'))" and "distinct_perm p"
	by(rule_tac c="(A\<^sub>R, \<Psi>, \<Psi>\<^sub>R', P, Q)" in name_list_avoiding) auto

      from Fr_r' `(p \<bullet> A\<^sub>R') \<sharp>*  \<Psi>\<^sub>R'` Sp have "extract_frame R = \<langle>(p \<bullet> A\<^sub>R'), p \<bullet> \<Psi>\<^sub>R'\<rangle>"
	by(simp add: frame_chain_alpha eqvts)
      with FrR `(p \<bullet> A\<^sub>R') \<sharp>* A\<^sub>R` obtain q::"name prm"
	where Sq: "set q \<subseteq> set(p \<bullet> A\<^sub>R') \<times> set A\<^sub>R" and "distinct_perm q" and "\<Psi>\<^sub>R = q \<bullet> p \<bullet> \<Psi>\<^sub>R'"
	by(force elim: frame_chain_eq)

      from `\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<sim> Q` `\<Psi>\<^sub>R = q \<bullet> p \<bullet> \<Psi>\<^sub>R'` have "\<Psi> \<otimes> (q \<bullet> p \<bullet> \<Psi>\<^sub>R') \<rhd> P \<sim> Q" by simp
      hence "(q \<bullet> (\<Psi> \<otimes> (q \<bullet> p \<bullet> \<Psi>\<^sub>R'))) \<rhd> (q \<bullet> P) \<sim> (q \<bullet> Q)" by(rule bisim_closed)
      with Sq `A\<^sub>R \<sharp>* \<Psi>` `(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>` `A\<^sub>R \<sharp>* P` `(p \<bullet> A\<^sub>R') \<sharp>* P` `A\<^sub>R \<sharp>* Q` `(p \<bullet> A\<^sub>R') \<sharp>* Q` `distinct_perm q`
      have "\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R') \<rhd> P \<sim> Q" by(simp add: eqvts)
      hence "(p \<bullet> (\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R'))) \<rhd> (p \<bullet> P) \<sim> (p \<bullet> Q)" by(rule bisim_closed)
      with Sp `A\<^sub>R' \<sharp>* \<Psi>` `(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>` `A\<^sub>R' \<sharp>* P` `(p \<bullet> A\<^sub>R') \<sharp>* P` `A\<^sub>R' \<sharp>* Q` `(p \<bullet> A\<^sub>R') \<sharp>* Q` `distinct_perm p`
      have "\<Psi> \<otimes> \<Psi>\<^sub>R' \<rhd> P \<sim> Q" by(simp add: eqvts)
    }
    thus ?thesis
      apply auto
      apply(rule_tac x="[]" in exI)
      by auto blast
  qed
  thus ?thesis
  proof(coinduct rule: bisim_coinduct)
    case(c_stat_eq \<Psi> PR QR)
    from `(\<Psi>, PR, QR) \<in> ?X`
    obtain xvec P Q R A\<^sub>R \<Psi>\<^sub>R where P_frR: "PR = \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R)" and Q_frR: "QR = \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)"
                              and "xvec \<sharp>* \<Psi>" and FrR: "extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>" and P_simQ: "\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<sim> Q"
                              and "A\<^sub>R \<sharp>* xvec" and "A\<^sub>R \<sharp>* \<Psi>" and "A\<^sub>R \<sharp>* P" and "A\<^sub>R \<sharp>* Q" and "A\<^sub>R \<sharp>* R"
      apply auto
      apply(subgoal_tac "\<exists>A\<^sub>R \<Psi>\<^sub>R. extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle> \<and> A\<^sub>R \<sharp>* (xvec, \<Psi>, P, Q, R)")
      apply auto
      apply(rule_tac F="extract_frame R" and C="(xvec, \<Psi>, P, Q, R)" in fresh_frame)
      by auto

    obtain A\<^sub>P \<Psi>\<^sub>P where FrP: "extract_frame P = \<langle>A\<^sub>P, \<Psi>\<^sub>P\<rangle>" and "A\<^sub>P \<sharp>* \<Psi>" and "A\<^sub>P \<sharp>* A\<^sub>R" and "A\<^sub>P \<sharp>* \<Psi>\<^sub>R"
      by(rule_tac C="(\<Psi>, A\<^sub>R, \<Psi>\<^sub>R)" in fresh_frame) auto
    obtain A\<^sub>Q \<Psi>\<^sub>Q where FrQ: "extract_frame Q = \<langle>A\<^sub>Q, \<Psi>\<^sub>Q\<rangle>" and "A\<^sub>Q \<sharp>* \<Psi>" and "A\<^sub>Q \<sharp>* A\<^sub>R" and "A\<^sub>Q \<sharp>* \<Psi>\<^sub>R"
      by(rule_tac C="(\<Psi>, A\<^sub>R, \<Psi>\<^sub>R)" in fresh_frame) auto
    from `A\<^sub>R \<sharp>* P` `A\<^sub>R \<sharp>* Q` `A\<^sub>P \<sharp>* A\<^sub>R` `A\<^sub>Q \<sharp>* A\<^sub>R` FrP FrQ have "A\<^sub>R \<sharp>* \<Psi>\<^sub>P" and  "A\<^sub>R \<sharp>* \<Psi>\<^sub>Q"
      by(force dest: extract_frame_fresh_chain)+

    have "\<langle>(A\<^sub>P@A\<^sub>R), \<Psi> \<otimes> \<Psi>\<^sub>P \<otimes> \<Psi>\<^sub>R\<rangle> \<simeq>\<^sub>F \<langle>(A\<^sub>Q@A\<^sub>R), \<Psi> \<otimes> \<Psi>\<^sub>Q \<otimes> \<Psi>\<^sub>R\<rangle>"
    proof -
      have "\<langle>A\<^sub>P, \<Psi> \<otimes> \<Psi>\<^sub>P \<otimes> \<Psi>\<^sub>R\<rangle> \<simeq>\<^sub>F \<langle>A\<^sub>P, (\<Psi> \<otimes> \<Psi>\<^sub>R) \<otimes> \<Psi>\<^sub>P\<rangle>"
	by(metis frame_res_chain_pres frame_nil_stat_eq Associativity Commutativity Assertion_stat_eq_trans Composition)
      moreover from P_simQ have "insert_assertion(extract_frame P) (\<Psi> \<otimes> \<Psi>\<^sub>R) \<simeq>\<^sub>F insert_assertion(extract_frame Q) (\<Psi> \<otimes> \<Psi>\<^sub>R)"
	by(rule bisimE)
      with FrP FrQ fresh_comp_chain `A\<^sub>P \<sharp>* \<Psi>` `A\<^sub>P \<sharp>* \<Psi>\<^sub>R` `A\<^sub>Q \<sharp>* \<Psi>` `A\<^sub>Q \<sharp>* \<Psi>\<^sub>R` have "\<langle>A\<^sub>P, (\<Psi> \<otimes> \<Psi>\<^sub>R) \<otimes> \<Psi>\<^sub>P\<rangle> \<simeq>\<^sub>F \<langle>A\<^sub>Q, (\<Psi> \<otimes> \<Psi>\<^sub>R) \<otimes> \<Psi>\<^sub>Q\<rangle>"
	by auto
      moreover have "\<langle>A\<^sub>Q, (\<Psi> \<otimes> \<Psi>\<^sub>R) \<otimes> \<Psi>\<^sub>Q\<rangle> \<simeq>\<^sub>F \<langle>A\<^sub>Q, \<Psi> \<otimes> \<Psi>\<^sub>Q \<otimes> \<Psi>\<^sub>R\<rangle>"
	by(metis frame_res_chain_pres frame_nil_stat_eq Associativity Commutativity Assertion_stat_eq_trans Composition)
      ultimately have "\<langle>A\<^sub>P, \<Psi> \<otimes> \<Psi>\<^sub>P \<otimes> \<Psi>\<^sub>R\<rangle> \<simeq>\<^sub>F \<langle>A\<^sub>Q, \<Psi> \<otimes> \<Psi>\<^sub>Q \<otimes> \<Psi>\<^sub>R\<rangle>"
	by(blast intro: Frame_stat_eq_trans)
      hence "\<langle>(A\<^sub>R@A\<^sub>P), \<Psi> \<otimes> \<Psi>\<^sub>P \<otimes> \<Psi>\<^sub>R\<rangle> \<simeq>\<^sub>F \<langle>(A\<^sub>R@A\<^sub>Q), \<Psi> \<otimes> \<Psi>\<^sub>Q \<otimes> \<Psi>\<^sub>R\<rangle>"
	by(drule_tac frame_res_chain_pres) (simp add: frame_chain_append)
      thus ?thesis
	apply(simp add: frame_chain_append)
	by(metis frame_res_chain_comm Frame_stat_eq_trans)
    qed
    moreover from `A\<^sub>P \<sharp>* \<Psi>` `A\<^sub>R \<sharp>* \<Psi>` have "(A\<^sub>P@A\<^sub>R) \<sharp>* \<Psi>" by simp
    moreover from `A\<^sub>Q \<sharp>* \<Psi>` `A\<^sub>R \<sharp>* \<Psi>` have "(A\<^sub>Q@A\<^sub>R) \<sharp>* \<Psi>" by simp
    ultimately have P_frRQR: "insert_assertion(extract_frame(P \<parallel> R)) \<Psi> \<simeq>\<^sub>F insert_assertion(extract_frame(Q \<parallel> R)) \<Psi>"
      using FrP FrQ FrR `A\<^sub>P \<sharp>* A\<^sub>R` `A\<^sub>P \<sharp>* \<Psi>\<^sub>R` `A\<^sub>Q \<sharp>* A\<^sub>R` `A\<^sub>Q \<sharp>* \<Psi>\<^sub>R` `A\<^sub>R \<sharp>* \<Psi>\<^sub>P` `A\<^sub>R \<sharp>* \<Psi>\<^sub>Q`
      by simp

    from `xvec \<sharp>* \<Psi>` have "insert_assertion (extract_frame(\<lparr>\<nu>*xvec\<rparr>P \<parallel> R)) \<Psi> \<simeq>\<^sub>F \<lparr>\<nu>*xvec\<rparr>(insert_assertion (extract_frame(P \<parallel> R)) \<Psi>)"
      by(rule insert_assertion_extract_frame_fresh)
    moreover from P_frRQR have "\<lparr>\<nu>*xvec\<rparr>(insert_assertion (extract_frame(P \<parallel> R)) \<Psi>) \<simeq>\<^sub>F \<lparr>\<nu>*xvec\<rparr>(insert_assertion (extract_frame(Q \<parallel> R)) \<Psi>)"
      by(induct xvec) (auto intro: frame_res_pres)
    moreover from `xvec \<sharp>* \<Psi>` have "\<lparr>\<nu>*xvec\<rparr>(insert_assertion (extract_frame(Q \<parallel> R)) \<Psi>) \<simeq>\<^sub>F insert_assertion (extract_frame(\<lparr>\<nu>*xvec\<rparr>Q \<parallel> R)) \<Psi>"
      by(rule Frame_stat_eq_sym[OF insert_assertion_extract_frame_fresh])
    ultimately show ?case using P_frR Q_frR
      by(blast intro: Frame_stat_eq_trans)
  next
    case(c_sim \<Psi> PR QR)
    {
      fix \<Psi> P Q R xvec
      assume "\<And>A\<^sub>R \<Psi>\<^sub>R. \<lbrakk>extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>; A\<^sub>R \<sharp>* \<Psi>; A\<^sub>R \<sharp>* P; A\<^sub>R \<sharp>* Q\<rbrakk> \<Longrightarrow> \<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<sim> Q"
      moreover have "eqvt bisim" by simp
      moreover from `eqvt ?X` have "eqvt(?X \<union> bisim)" by auto
      moreover from bisimE(1) have "\<And>\<Psi> P Q. \<Psi> \<rhd> P \<sim> Q \<Longrightarrow> insert_assertion (extract_frame Q) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame P) \<Psi>" by(simp add: Frame_stat_eq_def)
      moreover note bisimE(2) bisimE(3)
      moreover
      {
	fix \<Psi> P Q A\<^sub>R \<Psi>\<^sub>R R
	assume P_simQ: "\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<sim> Q"
           and FrR: "extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>"
           and "A\<^sub>R \<sharp>* \<Psi>"
	   and "A\<^sub>R \<sharp>* P"
	   and "A\<^sub>R \<sharp>* Q"
	hence "(\<Psi>, P \<parallel> R, Q \<parallel> R) \<in> ?X"
	proof -
	  have "P \<parallel> R = \<lparr>\<nu>*[]\<rparr>(P \<parallel> R)" by simp
	  moreover have "Q \<parallel> R = \<lparr>\<nu>*[]\<rparr>(Q \<parallel> R)" by simp
	  moreover have "([]::name list) \<sharp>* \<Psi>" by simp
	  moreover
	  {
	    fix A\<^sub>R' \<Psi>\<^sub>R'

	    assume Fr_r': "extract_frame R = \<langle>A\<^sub>R', \<Psi>\<^sub>R'\<rangle>"
	       and "A\<^sub>R' \<sharp>* \<Psi>"
	       and "A\<^sub>R' \<sharp>* P"
	       and "A\<^sub>R' \<sharp>* Q"
	    obtain p where "(p \<bullet> A\<^sub>R') \<sharp>* A\<^sub>R"
                       and "(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>\<^sub>R'"
                       and "(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>"
                       and "(p \<bullet> A\<^sub>R') \<sharp>* P"
                       and "(p \<bullet> A\<^sub>R') \<sharp>* Q"
                       and S: "(set p) \<subseteq> (set A\<^sub>R') \<times> (set(p \<bullet> A\<^sub>R'))" and "distinct_perm p"
	      by(rule_tac c="(A\<^sub>R, \<Psi>, \<Psi>\<^sub>R', P, Q)" in name_list_avoiding) auto

	    from `(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>\<^sub>R'` S have "\<langle>A\<^sub>R', \<Psi>\<^sub>R'\<rangle> = \<langle>p \<bullet> A\<^sub>R', p \<bullet> \<Psi>\<^sub>R'\<rangle>"
	      by(simp add: frame_chain_alpha)

	    with Fr_r' have Fr_r'': "extract_frame R = \<langle>p \<bullet> A\<^sub>R', p \<bullet> \<Psi>\<^sub>R'\<rangle>" by simp
	    with FrR `(p \<bullet> A\<^sub>R') \<sharp>* A\<^sub>R`
	    obtain q where "p \<bullet> \<Psi>\<^sub>R' = (q::name prm) \<bullet> \<Psi>\<^sub>R" and S': "set q \<subseteq> (set A\<^sub>R) \<times> set(p \<bullet> A\<^sub>R')" and "distinct_perm q"
	      apply auto
	      apply(drule_tac sym) apply simp
	      by(drule_tac frame_chain_eq) auto
	    from P_simQ have "(q \<bullet> (\<Psi> \<otimes> \<Psi>\<^sub>R)) \<rhd> (q \<bullet> P) \<sim> (q \<bullet> Q)"
	      by(rule bisim_closed)
	    with `A\<^sub>R \<sharp>* \<Psi>` `A\<^sub>R \<sharp>* P` `A\<^sub>R \<sharp>* Q` `(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>` `(p \<bullet> A\<^sub>R') \<sharp>* P` `(p \<bullet> A\<^sub>R') \<sharp>* Q` S'
	    have "\<Psi> \<otimes> (q \<bullet> \<Psi>\<^sub>R) \<rhd> P \<sim> Q" by(simp add: eqvts)
	    hence "(p \<bullet> (\<Psi> \<otimes> (q \<bullet> \<Psi>\<^sub>R))) \<rhd> (p \<bullet> P) \<sim> (p \<bullet> Q)" by(rule bisim_closed)
	    with `A\<^sub>R' \<sharp>* \<Psi>` `A\<^sub>R' \<sharp>* P` `A\<^sub>R' \<sharp>* Q` `(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>` `(p \<bullet> A\<^sub>R') \<sharp>* P` `(p \<bullet> A\<^sub>R') \<sharp>* Q` S `distinct_perm p` `(p \<bullet> \<Psi>\<^sub>R') = q \<bullet> \<Psi>\<^sub>R`
	    have "\<Psi> \<otimes> \<Psi>\<^sub>R' \<rhd> P \<sim> Q"
	      by(drule_tac sym) (simp add: eqvts)
	  }
	  ultimately show ?thesis
	    by blast
	qed
	hence "(\<Psi>, P \<parallel> R, Q \<parallel> R) \<in> ?X \<union> bisim"
	  by simp
      }
      moreover have "\<And>\<Psi> P Q xvec. \<lbrakk>(\<Psi>, P, Q) \<in> ?X \<union> bisim; (xvec::name list) \<sharp>* \<Psi>\<rbrakk> \<Longrightarrow> (\<Psi>, \<lparr>\<nu>*xvec\<rparr>P, \<lparr>\<nu>*xvec\<rparr>Q) \<in> ?X \<union> bisim"
      proof -
	fix \<Psi> P Q xvec
	assume "(\<Psi>, P, Q) \<in> ?X \<union> bisim"
	assume "(xvec::name list) \<sharp>* \<Psi>"
	thus "(\<Psi>, \<lparr>\<nu>*xvec\<rparr>P, \<lparr>\<nu>*xvec\<rparr>Q) \<in> ?X \<union> bisim"
	proof(induct xvec)
	  case Nil
	  thus ?case using `(\<Psi>, P, Q) \<in> ?X \<union> bisim` by simp
	next
	  case(Cons x xvec)
	  thus ?case by(simp only: res_chain.simps) (rule_tac Res, auto)
	qed
      qed
      ultimately have "\<Psi> \<rhd> P \<parallel> R \<leadsto>[(?X \<union> bisim)] Q \<parallel> R" using stat_eq_bisim
	by(rule par_pres)
      moreover assume "(xvec::name list) \<sharp>* \<Psi>"
      moreover from `eqvt ?X` have "eqvt(?X \<union> bisim)" by auto
      ultimately have "\<Psi> \<rhd> \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R) \<leadsto>[(?X \<union> bisim)] \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)" using Res
	by(rule_tac res_chain_pres)
    }
    with `(\<Psi>, PR, QR) \<in> ?X` show ?case by blast
  next
    case(c_ext \<Psi> PR QR \<Psi>')

    from `(\<Psi>, PR, QR) \<in> ?X`
    obtain xvec P Q R A\<^sub>R \<Psi>\<^sub>R where P_frR: "PR = \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R)" and Q_frR: "QR = \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)"
                               and "xvec \<sharp>* \<Psi>" and A: "\<forall>A\<^sub>R \<Psi>\<^sub>R. (extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle> \<and> A\<^sub>R \<sharp>* \<Psi> \<and> A\<^sub>R \<sharp>* P \<and> A\<^sub>R \<sharp>* Q) \<longrightarrow> \<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<sim> Q"
      by auto

    obtain p where "(p \<bullet> xvec) \<sharp>* \<Psi>"
               and "(p \<bullet> xvec) \<sharp>* P"
               and "(p \<bullet> xvec) \<sharp>* Q"
               and "(p \<bullet> xvec) \<sharp>* R"
               and "(p \<bullet> xvec) \<sharp>* \<Psi>'"
               and S: "(set p) \<subseteq> (set xvec) \<times> (set(p \<bullet> xvec))" and "distinct_perm p"
      by(rule_tac c="(\<Psi>, P, Q, R, \<Psi>')" in name_list_avoiding) auto

    from `(p \<bullet> xvec) \<sharp>* P` `(p \<bullet> xvec) \<sharp>* R` S have "\<lparr>\<nu>*xvec\<rparr>(P \<parallel> R) = \<lparr>\<nu>*(p \<bullet> xvec)\<rparr>(p \<bullet> (P \<parallel> R))"
      by(subst res_chain_alpha) auto
    hence P_r_alpha: "\<lparr>\<nu>*xvec\<rparr>(P \<parallel> R) = \<lparr>\<nu>*(p \<bullet> xvec)\<rparr>((p \<bullet> P) \<parallel> (p \<bullet> R))"
      by(simp add: eqvts)

    from `(p \<bullet> xvec) \<sharp>* Q` `(p \<bullet> xvec) \<sharp>* R` S have "\<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R) = \<lparr>\<nu>*(p \<bullet> xvec)\<rparr>(p \<bullet> (Q \<parallel> R))"
      by(subst res_chain_alpha) auto
    hence Q_r_alpha: "\<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R) = \<lparr>\<nu>*(p \<bullet> xvec)\<rparr>((p \<bullet> Q) \<parallel> (p \<bullet> R))"
      by(simp add: eqvts)

    from `(p \<bullet> xvec) \<sharp>* \<Psi>` `(p \<bullet> xvec) \<sharp>* \<Psi>'` have "(\<Psi> \<otimes> \<Psi>', \<lparr>\<nu>*(p \<bullet> xvec)\<rparr>((p \<bullet> P) \<parallel> (p \<bullet> R)), \<lparr>\<nu>*(p \<bullet> xvec)\<rparr>((p \<bullet> Q) \<parallel> (p \<bullet> R))) \<in> ?X"
    proof(rule_tac C2="(\<Psi>, (p \<bullet> P), (p \<bullet> Q), R, \<Psi>', xvec, p \<bullet> xvec)" in XI', auto)
      fix A\<^sub>R \<Psi>\<^sub>R
      assume FrR: "extract_frame (p \<bullet> R) = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>" and "A\<^sub>R \<sharp>* \<Psi>" and "A\<^sub>R \<sharp>* \<Psi>'" and "A\<^sub>R \<sharp>* (p \<bullet> P)" and "A\<^sub>R \<sharp>* (p \<bullet> Q)"
      from FrR have "(p \<bullet> (extract_frame (p \<bullet> R))) = (p \<bullet> \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>)" by simp
      with `distinct_perm p` have "extract_frame R = \<langle>p \<bullet> A\<^sub>R, p \<bullet> \<Psi>\<^sub>R\<rangle>" by(simp add: eqvts)
      moreover from `A\<^sub>R \<sharp>* \<Psi>` have "(p \<bullet> A\<^sub>R) \<sharp>* (p \<bullet> \<Psi>)" by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
      with `xvec \<sharp>* \<Psi>` `(p \<bullet> xvec) \<sharp>* \<Psi>` S have "(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>" by simp
      moreover from `A\<^sub>R \<sharp>* (p \<bullet> P)` have "(p \<bullet> A\<^sub>R) \<sharp>* (p \<bullet> p \<bullet> P)" by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
      with `distinct_perm p` have "(p \<bullet> A\<^sub>R) \<sharp>* P" by simp
      moreover from `A\<^sub>R \<sharp>* (p \<bullet> Q)` have "(p \<bullet> A\<^sub>R) \<sharp>* (p \<bullet> p \<bullet> Q)" by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
      with `distinct_perm p` have "(p \<bullet> A\<^sub>R) \<sharp>* Q" by simp
      ultimately have "\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R) \<rhd> P \<sim> Q" using A by blast
      hence "(\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R)) \<otimes> (p \<bullet> \<Psi>') \<rhd> P \<sim> Q" by(rule bisimE)
      moreover have "(\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R)) \<otimes> (p \<bullet> \<Psi>') \<simeq> (\<Psi> \<otimes> (p \<bullet> \<Psi>')) \<otimes> (p \<bullet> \<Psi>\<^sub>R)"
	by(metis Associativity Commutativity Composition Assertion_stat_eq_trans Assertion_stat_eq_sym)
      ultimately have "(\<Psi> \<otimes> (p \<bullet> \<Psi>')) \<otimes> (p \<bullet> \<Psi>\<^sub>R) \<rhd> P \<sim> Q"
	by(rule stat_eq_bisim)
      hence "(p \<bullet> ((\<Psi> \<otimes> (p \<bullet> \<Psi>')) \<otimes> (p \<bullet> \<Psi>\<^sub>R))) \<rhd> (p \<bullet> P) \<sim> (p \<bullet> Q)"
	by(rule bisim_closed)
      with `distinct_perm p` `xvec \<sharp>* \<Psi>` `(p \<bullet> xvec) \<sharp>* \<Psi>` S show "(\<Psi> \<otimes> \<Psi>') \<otimes> \<Psi>\<^sub>R \<rhd> (p \<bullet> P) \<sim> (p \<bullet> Q)"
	by(simp add: eqvts)
    qed
    with P_frR Q_frR P_r_alpha Q_r_alpha show ?case by simp
  next
    case(c_sym \<Psi> PR QR)
    thus ?case by(blast dest: bisimE)
  qed
qed

lemma bisim_par_pres:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   R :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<sim> Q"

  shows "\<Psi> \<rhd> P \<parallel> R \<sim> Q \<parallel> R"
proof -
  obtain A\<^sub>R \<Psi>\<^sub>R where "extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>" and "A\<^sub>R \<sharp>* \<Psi>" and "A\<^sub>R \<sharp>* P" and "A\<^sub>R \<sharp>* Q"
    by(rule_tac C="(\<Psi>, P, Q)" in fresh_frame) auto
  moreover from `\<Psi> \<rhd> P \<sim> Q` have "\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<sim> Q" by(rule bisimE)
  ultimately show ?thesis by(rule_tac bisim_par_pres_aux)
qed

end

end