section \<open>Preliminary Results\<close>

text \<open>This section contains various short preliminary results used in the sections below.\<close>

theory Distributed_Distinct_Elements_Preliminary
  imports
    Frequency_Moments.Frequency_Moments_Preliminary_Results
    Frequency_Moments.Product_PMF_Ext
    Median_Method.Median
    Expander_Graphs.Extra_Congruence_Method
    Expander_Graphs.Constructive_Chernoff_Bound
    Frequency_Moments.Landau_Ext
    Stirling_Formula.Stirling_Formula
begin

unbundle intro_cong_syntax

text \<open>Simplified versions of measure theoretic results for pmfs:\<close>

lemma measure_pmf_cong:
  assumes "\<And>x. x \<in> set_pmf p \<Longrightarrow> x \<in> P \<longleftrightarrow> x \<in> Q"
  shows "measure (measure_pmf p) P = measure (measure_pmf p)  Q"
  using assms
  by (intro finite_measure.finite_measure_eq_AE AE_pmfI) auto

lemma pmf_mono:
  assumes "\<And>x. x \<in> set_pmf p \<Longrightarrow> x \<in> P \<Longrightarrow> x \<in> Q"
  shows "measure (measure_pmf p) P \<le> measure (measure_pmf p) Q"
proof -
  have "measure (measure_pmf p) P = measure (measure_pmf p) (P \<inter> (set_pmf p))"
    by (intro measure_pmf_cong) auto
  also have "... \<le> measure (measure_pmf p) Q"
    using assms by (intro finite_measure.finite_measure_mono) auto
  finally show ?thesis by simp
qed

lemma pmf_rev_mono:
  assumes "\<And>x. x \<in> set_pmf p \<Longrightarrow> x \<notin> Q \<Longrightarrow> x \<notin> P"
  shows "measure p P \<le> measure p Q"
  using assms by (intro pmf_mono) blast

lemma pmf_exp_mono:
  fixes f g :: "'a \<Rightarrow> real"
  assumes "integrable (measure_pmf p) f" "integrable (measure_pmf p) g"
  assumes "\<And>x. x \<in> set_pmf p \<Longrightarrow> f x \<le> g x"
  shows "integral\<^sup>L (measure_pmf p) f \<le> integral\<^sup>L (measure_pmf p) g"
  using assms  by (intro integral_mono_AE AE_pmfI) auto

lemma pmf_markov:
  assumes "integrable (measure_pmf p) f" "c > 0"
  assumes "\<And>x. x \<in> set_pmf p \<Longrightarrow> f x \<ge> 0"
  shows "measure p {\<omega>. f \<omega> \<ge> c} \<le> (\<integral>\<omega>. f \<omega> \<partial>p)/ c" (is "?L \<le> ?R")
proof -
  have a:"AE \<omega> in (measure_pmf p). 0 \<le> f \<omega>"
    by (intro AE_pmfI assms(3))
  have b:"{} \<in> measure_pmf.events p"
    unfolding assms(1) by simp

  have "?L = \<P>(\<omega> in (measure_pmf p). f \<omega> \<ge> c)"
    using assms(1) by simp
  also have "... \<le>  ?R"
    by (intro  integral_Markov_inequality_measure[OF _ b] assms a)
  finally show ?thesis by simp
qed

lemma pmf_add:
  assumes  "\<And>x. x \<in> P \<Longrightarrow> x \<in> set_pmf p \<Longrightarrow> x \<in> Q \<or> x \<in> R"
  shows "measure p P \<le> measure p Q + measure p R"
proof -
  have "measure p P \<le> measure p (Q \<union> R)"
    using assms by (intro pmf_mono) blast
  also have "... \<le> measure p Q + measure p R"
    by (rule measure_subadditive, auto)
  finally show ?thesis by simp
qed

lemma pair_pmf_prob_left:
  "measure_pmf.prob (pair_pmf A B) {\<omega>. P (fst \<omega>)} = measure_pmf.prob A {\<omega>. P \<omega>}" (is "?L = ?R")
proof -
  have "?L = measure_pmf.prob (map_pmf fst (pair_pmf A B)) {\<omega>. P \<omega>}"
    by (subst measure_map_pmf) simp
  also have "... = ?R"
    by (subst map_fst_pair_pmf) simp
  finally show ?thesis by simp
qed

lemma pmf_exp_of_fin_function:
  assumes "finite A" "g ` set_pmf p \<subseteq> A"
  shows "(\<integral>\<omega>. f (g \<omega>) \<partial>p) = (\<Sum>y \<in> A. f y * measure p {\<omega>. g \<omega> = y})"
    (is "?L = ?R")
proof -
  have "?L = integral\<^sup>L (map_pmf g p) f"
    using integral_map_pmf assms by simp
  also have "... = (\<Sum>a\<in>A. f a * pmf (map_pmf g p) a)"
    using assms
    by (intro integral_measure_pmf_real) auto
  also have " ... = (\<Sum>y \<in> A. f y * measure p (g -` {y}))"
    unfolding assms(1) by (intro_cong "[\<sigma>\<^sub>2 (*)]" more:sum.cong pmf_map)
  also have "... = ?R"
    by (intro sum.cong) (auto simp add: vimage_def)
  finally show ?thesis by simp
qed

text \<open>Cardinality rules for distinct/ordered pairs of a set without the finiteness constraint - to
use in simplification:\<close>

lemma card_distinct_pairs:
  "card {x \<in> B \<times> B. fst x \<noteq> snd x} = card B^2 - card B" (is "card ?L = ?R")
proof (cases "finite B")
  case True
  include intro_cong_syntax
  have "card ?L = card (B \<times> B - (\<lambda>x. (x,x)) ` B)"
    by (intro arg_cong[where f="card"]) auto
  also have "... = card (B \<times> B) - card ((\<lambda>x. (x,x)) ` B)"
    by (intro card_Diff_subset finite_imageI True image_subsetI) auto
  also have "... = ?R"
    using True by (intro_cong "[\<sigma>\<^sub>2 (-)]" more: card_image)
      (auto simp add:power2_eq_square inj_on_def)
  finally show ?thesis by simp
next
  case False
  then obtain p where p_in: "p \<in> B" by fastforce
  have "False" if "finite ?L"
  proof -
    have "(\<lambda>x. (p,x)) ` (B - {p}) \<subseteq> ?L"
      using p_in by (intro image_subsetI) auto
    hence "finite ((\<lambda>x. (p,x)) ` (B - {p}))"
      using finite_subset that by auto
    hence "finite (B - {p})"
      by (rule finite_imageD) (simp add:inj_on_def)
    hence "finite B"
      by simp
    thus "False" using False by simp
  qed
  hence "infinite ?L" by auto
  hence "card ?L = 0" by simp
  also have "... = ?R"
    using False by simp
  finally show ?thesis by simp
qed

lemma card_ordered_pairs':
  fixes M :: "('a ::linorder) set"
  shows "card {(x,y) \<in> M \<times> M. x < y} = card M * (card M - 1) / 2"
proof (cases "finite M")
  case True
  show ?thesis using card_ordered_pairs[OF True] by linarith
next
  case False
  then obtain p where p_in: "p \<in> M" by fastforce
  let ?f= "(\<lambda>x. if x < p then (x,p) else (p,x))"
  have "False" if "finite {(x,y) \<in> M \<times> M. x < y}" (is "finite ?X")
  proof -
    have "?f ` (M-{p}) \<subseteq> ?X"
      using p_in by (intro image_subsetI) auto
    hence "finite (?f ` (M-{p}))" using that finite_subset by auto
    moreover have "inj_on ?f (M-{p})"
      by (intro inj_onI) (metis Pair_inject)
    ultimately have "finite (M - {p})"
      using finite_imageD by blast
    hence "finite M"
      using finite_insert[where a="p" and A="M-{p}"] by simp
    thus "False" using False by simp
  qed
  hence "infinite ?X" by auto
  then show ?thesis using False by simp
qed

text \<open>The following are versions of the mean value theorem, where the interval endpoints may be
reversed.\<close>

lemma MVT_symmetric:
  assumes "\<And>x. \<lbrakk>min a b \<le> x; x \<le> max a b\<rbrakk> \<Longrightarrow> DERIV f x :> f' x"
  shows "\<exists>z::real. min a b \<le> z \<and> z \<le> max a b \<and> (f b - f a = (b - a) * f' z)"
proof -
  consider (a) "a < b" | (b) "a = b" | (c) "a > b"
    by argo
  then show ?thesis
  proof (cases)
    case a
    then obtain z :: real where r: "a < z" "z < b" "f b - f a = (b - a) * f' z"
      using assms MVT2[where a="a" and b="b" and f="f" and f'="f'"] by auto
    have "a \<le> z" "z \<le> b" using r(1,2) by auto
    thus ?thesis using a r(3) by auto
  next
    case b
    then show ?thesis by auto
  next
    case c
    then obtain z :: real where r: "b < z" "z < a" "f a - f b = (a - b) * f' z"
      using assms MVT2[where a="b" and b="a" and f="f" and f'="f'"] by auto
    have "f b - f a = (b-a) * f' z" using r by argo
    moreover have "b \<le> z" "z \<le> a" using r(1,2) by auto
    ultimately show ?thesis using c by auto
  qed
qed

lemma MVT_interval:
  fixes I :: "real set"
  assumes "interval I" "a \<in> I" "b \<in> I"
  assumes "\<And>x. x \<in> I \<Longrightarrow> DERIV f x :> f' x"
  shows "\<exists>z. z \<in> I \<and> (f b - f a = (b - a) * f' z)"
proof -
  have a:"min a b \<in> I"
    using assms(2,3) by (cases "a < b") auto
  have b:"max a b \<in> I"
    using assms(2,3) by (cases "a < b") auto
  have c:"x \<in> {min a b..max a b} \<Longrightarrow> x \<in> I" for x
    using interval_def assms(1) a b by auto
  have "\<lbrakk>min a b \<le> x; x \<le> max a b\<rbrakk> \<Longrightarrow> DERIV f x :> f' x" for x
    using c assms(4) by auto
  then obtain z where z:"z \<ge> min a b" "z \<le> max a b" "f b - f a = (b-a) * f' z"
    using MVT_symmetric by blast
  have "z \<in> I"
    using c z(1,2) by auto
  thus ?thesis using z(3) by auto
qed

text \<open>Ln is monotone on the positive numbers and thus commutes with min and max:\<close>
lemma ln_min_swap:
  "x > (0::real) \<Longrightarrow> (y > 0) \<Longrightarrow> ln (min x y) = min (ln x) (ln y)"
  using ln_less_cancel_iff by fastforce

lemma ln_max_swap:
  "x > (0::real) \<Longrightarrow> (y > 0) \<Longrightarrow> ln (max x y) = max (ln x) (ln y)"
  using ln_le_cancel_iff by fastforce

text \<open>Loose lower bounds for the factorial fuction:.\<close>

lemma fact_lower_bound:
  "sqrt(2*pi*n)*(n/exp(1))^n \<le> fact n" (is "?L \<le> ?R")
proof (cases "n > 0")
  case True
  have "ln ?L = ln (2*pi*n)/2 + n * ln n - n"
    using True by (simp add: ln_mult ln_sqrt ln_realpow ln_div algebra_simps)
  also have "... \<le> ln ?R"
    by (intro Stirling_Formula.ln_fact_bounds True)
  finally show ?thesis
    using iffD1[OF ln_le_cancel_iff] True by simp
next
  case False
  then show ?thesis by simp
qed

lemma fact_lower_bound_1:
  assumes "n > 0"
  shows "(n/exp 1)^n \<le> fact n" (is "?L \<le> ?R")
proof -
  have "2 * pi \<ge> 1" using pi_ge_two by auto
  moreover have "n \<ge> 1" using assms by simp
  ultimately have "2 * pi * n \<ge> 1*1"
    by (intro mult_mono) auto
  hence a:"2 * pi * n \<ge> 1" by simp

  have "?L = 1 * ?L" by simp
  also have "... \<le> sqrt(2 * pi * n) * ?L"
    using a by (intro mult_right_mono) auto
  also have "... \<le> ?R"
    using fact_lower_bound by simp
  finally show ?thesis by simp
qed

text \<open>Rules to handle O-notation with multiple variables, where some filters may be towards zero:\<close>

lemma real_inv_at_right_0_inf:
  "\<forall>\<^sub>F x in at_right (0::real). c \<le> 1 / x"
proof -
  have "c \<le> 1 /  x" if b:" x \<in> {0<..<1 / (max c 1)}" for x
  proof -
    have "c * x \<le> (max c 1) * x"
      using b by (intro mult_right_mono, linarith, auto)
    also have "... \<le> (max c 1)  * (1 / (max c 1))"
      using b by (intro mult_left_mono) auto
    also have "... \<le> 1"
      by (simp add:of_rat_divide)
    finally have "c * x \<le> 1" by simp
    moreover have "0 < x"
      using b by simp
    ultimately show ?thesis by (subst pos_le_divide_eq, auto)
  qed
  thus ?thesis
    by (intro eventually_at_rightI[where b="1/(max c 1)"], simp_all)
qed

lemma bigo_prod_1:
  assumes "(\<lambda>x. f x) \<in> O[F](\<lambda>x. g x)" "G \<noteq> bot"
  shows "(\<lambda>x. f (fst x)) \<in> O[F \<times>\<^sub>F G](\<lambda>x. g (fst x))"
proof -
  obtain c where a: "\<forall>\<^sub>F x in F. norm (f x) \<le> c * norm (g x)" and c_gt_0: "c > 0"
    using assms unfolding bigo_def by auto

  have "\<exists>c>0. \<forall>\<^sub>F x in F \<times>\<^sub>F G. norm (f (fst x)) \<le> c * norm (g (fst x))"
    by (intro exI[where x="c"] conjI c_gt_0  eventually_prod1' a assms(2))
  thus ?thesis
    unfolding bigo_def by simp
qed

lemma bigo_prod_2:
  assumes "(\<lambda>x. f x) \<in> O[G](\<lambda>x. g x)" "F \<noteq> bot"
  shows "(\<lambda>x. f (snd x)) \<in> O[F \<times>\<^sub>F G](\<lambda>x. g (snd x))"
proof -
  obtain c where a: "\<forall>\<^sub>F x in G. norm (f x) \<le> c * norm (g x)" and c_gt_0: "c > 0"
    using assms unfolding bigo_def by auto

  have "\<exists>c>0. \<forall>\<^sub>F x in F \<times>\<^sub>F G. norm (f (snd x)) \<le> c * norm (g (snd x))"
    by (intro exI[where x="c"] conjI c_gt_0  eventually_prod2' a assms(2))
  thus ?thesis
    unfolding bigo_def by simp
qed

lemma eventually_inv:
  fixes P :: "real \<Rightarrow> bool"
  assumes "eventually (\<lambda>x. P (1/x)) at_top "
  shows "eventually (\<lambda>x. P x) (at_right 0)"
proof -
  obtain N where c:"n \<ge> N \<Longrightarrow> P (1/n)" for n
    using assms unfolding eventually_at_top_linorder by auto

  define q where "q = max 1 N"
  have d: "0 < 1 / q" "q > 0"
    unfolding q_def by auto

  have "P x" if "x \<in> {0<..<1 / q}" for x
  proof -
    define n where "n = 1/x"
    have x_eq: "x = 1 / n"
      unfolding n_def using that by simp

    have "N \<le> q" unfolding q_def by simp
    also have "... \<le> n"
      unfolding n_def using that d by (simp add:divide_simps ac_simps)
    finally have "N \<le> n" by simp
    thus ?thesis
      unfolding x_eq by (intro c)
  qed

  thus ?thesis
    by (intro eventually_at_rightI[where b="1/q"] d)
qed

lemma bigo_inv:
  fixes f g :: "real \<Rightarrow> real"
  assumes "(\<lambda>x. f (1/x)) \<in> O(\<lambda>x. g (1/x))"
  shows "f \<in> O[at_right 0](g)"
  using assms eventually_inv unfolding bigo_def by auto

unbundle no_intro_cong_syntax

end


section \<open> Centimetre-Gram-Second System \<close>

theory CGS
  imports SI_Units
begin

subsection \<open> Preliminaries \<close>

typedef CGS = "UNIV :: unit set" ..
instance CGS :: unit_system
  by (rule unit_system_intro[of "Abs_CGS ()"], metis (full_types)
           Abs_CGS_cases UNIV_eq_I insert_iff old.unit.exhaust)
instance CGS :: time_second ..
abbreviation "CGS \<equiv> unit :: CGS"

subsection \<open> Base Units \<close>

abbreviation "centimetre  \<equiv> BUNIT(L, CGS)"
abbreviation "gram        \<equiv> BUNIT(M, CGS)"

subsection \<open> Conversion to SI \<close>

instantiation CGS :: metrifiable
begin

lift_definition convschema_CGS :: "CGS itself \<Rightarrow> (CGS, SI) Conversion" is
"\<lambda> x. \<lparr> cLengthF = 0.01, cMassF = 0.001, cTimeF = 1
      , cCurrentF = 1, cTemperatureF = 1, cAmountF = 1, cIntensityF = 1 \<rparr>" by simp

instance ..
end

lemma CGS_SI_simps [simp]: "LengthF (convschema (a::CGS itself)) = 0.01" "MassF (convschema a) = 0.001"
  "TimeF (convschema a) = 1" "CurrentF (convschema a) = 1" "TemperatureF (convschema a) = 1"
  by (transfer, simp)+

subsection \<open> Conversion Examples \<close>

lemma "metrify ((100::rat) *\<^sub>Q centimetre) = 1 *\<^sub>Q metre"
  by (si_simp)

end


theory Scratch_Fib
  imports Refine_Imperative_HOL.IICF
begin

fun fib :: "nat \<Rightarrow> int" where
  "fib 0 = 1"
| "fib (Suc 0) = 1"
| "fib (Suc (Suc n)) = fib (Suc n) + fib n"

definition fib_spec :: "nat \<Rightarrow> int nres" where
  "fib_spec n \<equiv> RETURN (fib n)"

term RECT
term REC
term trimono

definition fib_rec_body :: "(nat \<Rightarrow> int nres) \<Rightarrow> nat \<Rightarrow> int nres" where
  "fib_rec_body \<equiv> \<lambda>f n.
    if n < 2
      then RETURN 1
      else do {
        f0 \<leftarrow> f (n-2);
        f1 \<leftarrow> f (n-1);
        RETURN (f0+f1)
      }"

(* case_nat seems to be unfriendly with sepref_definition *)
definition fib_rec_body' :: "(nat \<Rightarrow> int nres) \<Rightarrow> nat \<Rightarrow> int nres" where
  "fib_rec_body' \<equiv> \<lambda>f n.
    case n of
      0 \<Rightarrow> RETURN 1
    | Suc 0 \<Rightarrow> RETURN 1
    | Suc (Suc n') \<Rightarrow> do {
        f0 \<leftarrow> f n';
        f1 \<leftarrow> f (Suc n');
        RETURN (f0+f1)
      }"

definition fib_rec :: "nat \<Rightarrow> int nres" where
  "fib_rec n \<equiv> RECT fib_rec_body n"

lemma fib_rec_refine: "(fib_rec, fib_spec) \<in> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
  unfolding fib_rec_def fib_spec_def fib_rec_body_def
  apply (clarsimp intro!: nres_relI)
  apply (refine_vcg RECT_rule[where V=less_than and pre="\<lambda>_. True"])
  subgoal ..
  subgoal ..
  subgoal for _ f n by (cases n rule: fib.cases; simp)
  subgoal premises prems for _ f n
    thm prems(1)[simplified] prems(3)[symmetric] prems(4)
    apply (refine_vcg order_trans[OF prems(1)]; cases n rule: fib.cases)
    using prems(4) apply auto
    done
  done

sepref_definition fib_rec1 is fib_rec :: "nat_assn\<^sup>k \<rightarrow>\<^sub>a int_assn"
  unfolding fib_rec_def fib_rec_body_def
  by sepref
term 0 (**)

end


section \<open>Proof Infrastructure\<close>
subsection \<open>Bisimulation\<close>

theory Bisimulation
imports
  Stuttering
begin

(* WIP strong bisimilar
fun strongly_bisimilar :: "
(IRGraph \<times> ID \<times> MapState \<times> FieldRefHeap) rel
\<Rightarrow> (IRGraph \<times> ID \<times> MapState \<times> FieldRefHeap)
\<Rightarrow> (IRGraph \<times> ID \<times> MapState \<times> FieldRefHeap)
\<Rightarrow> bool"
  where
  "strongly_bisimilar \<R> (g1, nid1, m1, h1) (g2, nid2, m2, h2) =
    ((((g1, nid1, m1, h1), (g2, nid2, m2, h2)) \<in> \<R>) \<longrightarrow>
    ((\<forall>P'. (g1 \<turnstile> (nid1, m1, h1) \<rightarrow> P') \<longrightarrow> (\<exists>Q' . (g2 \<turnstile> (nid2, m2, h2) \<rightarrow> Q') \<and> ((g1,P'), (g2,Q')) \<in> \<R>)) \<and>
    (\<forall>Q'. (g2 \<turnstile> (nid2, m2, h2) \<rightarrow> Q') \<longrightarrow> (\<exists>P' . (g1 \<turnstile> (nid1, m1, h1) \<rightarrow> P') \<and> ((g1,P'), (g2,Q')) \<in> \<R>))))"
*)

inductive weak_bisimilar :: "ID \<Rightarrow> IRGraph \<Rightarrow> IRGraph \<Rightarrow> bool"
  ("_ . _ \<sim> _") for nid where
  "\<lbrakk>\<forall>P'. (g m p h \<turnstile> nid \<leadsto> P') \<longrightarrow> (\<exists>Q' . (g' m p h \<turnstile> nid \<leadsto> Q') \<and> P' = Q');
    \<forall>Q'. (g' m p h \<turnstile> nid \<leadsto> Q') \<longrightarrow> (\<exists>P' . (g m p h \<turnstile> nid \<leadsto> P') \<and> P' = Q')\<rbrakk>
  \<Longrightarrow> nid . g \<sim> g'"

text \<open>A strong bisimilution between no-op transitions\<close>
inductive strong_noop_bisimilar :: "ID \<Rightarrow> IRGraph \<Rightarrow> IRGraph \<Rightarrow> bool"
  ("_ | _ \<sim> _") for nid where
  "\<lbrakk>\<forall>P'. (g, p \<turnstile> (nid, m, h) \<rightarrow> P') \<longrightarrow> (\<exists>Q' . (g', p \<turnstile> (nid, m, h) \<rightarrow> Q') \<and> P' = Q');
    \<forall>Q'. (g', p \<turnstile> (nid, m, h) \<rightarrow> Q') \<longrightarrow> (\<exists>P' . (g, p \<turnstile> (nid, m, h) \<rightarrow> P') \<and> P' = Q')\<rbrakk>
  \<Longrightarrow> nid | g \<sim> g'"

lemma lockstep_strong_bisimilulation:
  assumes "g' = replace_node nid node g"
  assumes "g, p \<turnstile> (nid, m, h) \<rightarrow> (nid', m, h)"
  assumes "g', p \<turnstile> (nid, m, h) \<rightarrow> (nid', m, h)"
  shows "nid | g \<sim> g'"
  using assms(2) assms(3) stepDet strong_noop_bisimilar.simps by metis

lemma no_step_bisimulation:
  assumes "\<forall>m p h nid' m' h'. \<not>(g, p \<turnstile> (nid, m, h) \<rightarrow> (nid', m', h'))"
  assumes "\<forall>m p h nid' m' h'. \<not>(g', p \<turnstile> (nid, m, h) \<rightarrow> (nid', m', h'))"
  shows "nid | g \<sim> g'"
  using assms
  by (simp add: assms(1) assms(2) strong_noop_bisimilar.intros)

end


section \<open>Lemmas about the prover\<close>

theory ProverLemmas imports Prover begin

text \<open>This theory contains a number of lemmas about the prover.
  We will need these when proving soundness and completeness.\<close>

subsection \<open>SeCaV lemmas\<close>
text \<open>We need a few lemmas about the SeCaV system.\<close>

text \<open>Incrementing variable indices does not change the function names in term or a list of terms.\<close>
lemma paramst_liftt [simp]:
  \<open>paramst (liftt t) = paramst t\<close> \<open>paramsts (liftts ts) = paramsts ts\<close>
  by (induct t and ts rule: liftt.induct liftts.induct) auto

text \<open>Subterms do not contain any functions except those in the original term\<close>
lemma paramst_sub_term:
  \<open>paramst (sub_term m s t) \<subseteq> paramst s \<union> paramst t\<close>
  \<open>paramsts (sub_list m s l) \<subseteq> paramst s \<union> paramsts l\<close>
  by (induct t and l rule: sub_term.induct sub_list.induct) auto

text \<open>Substituting a variable for a term does not introduce function names not in that term\<close>
lemma params_sub: \<open>params (sub m t p) \<subseteq> paramst t \<union> params p\<close>
proof (induct p arbitrary: m t)
  case (Pre x1 x2)
  then show ?case
    using paramst_sub_term(2) by simp
qed fastforce+

abbreviation \<open>paramss z \<equiv> \<Union>p \<in> set z. params p\<close>

text \<open>If a function name is fresh, it is not in the list of function names in the sequent\<close>
lemma news_paramss: \<open>news i z \<longleftrightarrow> i \<notin> paramss z\<close>
  by (induct z) auto

text \<open>If a list of terms is a subset of another, the set of function names in it is too\<close>
lemma paramsts_subset: \<open>set A \<subseteq> set B \<Longrightarrow> paramsts A \<subseteq> paramsts B\<close>
  by (induct A) auto

text \<open>Substituting a variable by a term does not change the depth of a formula
  (only the term size changes)\<close>
lemma size_sub [simp]: \<open>size (sub i t p) = size p\<close>
  by (induct p arbitrary: i t) auto

subsection \<open>Fairness\<close>
text \<open>While fairness of the rule stream should be pretty trivial (since we are simply repeating a
  static list of rules forever), the proof is a bit involved.\<close>

text \<open>This function tells us what rule comes next in the stream.\<close>
primrec next_rule :: \<open>rule \<Rightarrow> rule\<close> where
  \<open>next_rule NegNeg = AlphaImp\<close>
| \<open>next_rule AlphaImp = AlphaDis\<close>
| \<open>next_rule AlphaDis = AlphaCon\<close>
| \<open>next_rule AlphaCon = DeltaExi\<close>
| \<open>next_rule DeltaExi = DeltaUni\<close>
| \<open>next_rule DeltaUni = BetaImp\<close>
| \<open>next_rule BetaImp = BetaDis\<close>
| \<open>next_rule BetaDis = BetaCon\<close>
| \<open>next_rule BetaCon = GammaExi\<close>
| \<open>next_rule GammaExi = GammaUni\<close>
| \<open>next_rule GammaUni = NegNeg\<close>

text \<open>This function tells us the index of a rule in the list of rules to repeat.\<close>
primrec rule_index :: \<open>rule \<Rightarrow> nat\<close> where
  \<open>rule_index NegNeg = 0\<close>
| \<open>rule_index AlphaImp = 1\<close>
| \<open>rule_index AlphaDis = 2\<close>
| \<open>rule_index AlphaCon = 3\<close>
| \<open>rule_index DeltaExi = 4\<close>
| \<open>rule_index DeltaUni = 5\<close>
| \<open>rule_index BetaImp = 6\<close>
| \<open>rule_index BetaDis = 7\<close>
| \<open>rule_index BetaCon = 8\<close>
| \<open>rule_index GammaExi = 9\<close>
| \<open>rule_index GammaUni = 10\<close>

text \<open>The list of rules does not have any duplicates.
  This is important because we can then look up rules by their index.\<close>
lemma distinct_rulesList: \<open>distinct rulesList\<close>
  unfolding rulesList_def by simp

text \<open>If you cycle a list, it repeats every \<open>length\<close> elements.\<close>
lemma cycle_nth: \<open>xs \<noteq> [] \<Longrightarrow> cycle xs !! n = xs ! (n mod length xs)\<close>
  by (metis cycle.sel(1) hd_rotate_conv_nth rotate_conv_mod sdrop_cycle sdrop_simps(1))

text \<open>The rule index function can actually be used to look up rules in the list.\<close>
lemma nth_rule_index: \<open>rulesList ! (rule_index r) = r\<close>
  unfolding rulesList_def by (cases r) simp_all

lemma rule_index_bnd: \<open>rule_index r < length rulesList\<close>
  unfolding rulesList_def by (cases r) simp_all

lemma unique_rule_index:
  assumes \<open>n < length rulesList\<close> \<open>rulesList ! n = r\<close>
  shows \<open>n = rule_index r\<close>
  using assms nth_rule_index distinct_rulesList rule_index_bnd nth_eq_iff_index_eq by metis

text \<open>The rule indices repeat in the stream each cycle.\<close>
lemma rule_index_mod:
  assumes \<open>rules !! n = r\<close>
  shows \<open>n mod length rulesList = rule_index r\<close>
proof -
  have *: \<open>rulesList ! (n mod length rulesList) = r\<close>
    using assms cycle_nth unfolding rules_def rulesList_def by (metis list.distinct(1))
  then show ?thesis
    using distinct_rulesList * unique_rule_index
    by (cases r) (metis length_greater_0_conv list.discI rulesList_def
        unique_euclidean_semiring_numeral_class.pos_mod_bound)+
qed

text \<open>We need some lemmas about the modulo function to show that the rules repeat at the right rate.\<close>
lemma mod_hit:
  fixes k :: nat
  assumes \<open>0 < k\<close>
  shows \<open>\<forall>i < k. \<exists>n > m. n mod k = i\<close>
proof safe
  fix i
  let ?n = \<open>(1 + m) * k + i\<close>
  assume \<open>i < k\<close>
  then have \<open>?n mod k = i\<close>
    by (metis mod_less mod_mult_self3)
  moreover have \<open>?n > m\<close>
    using assms
    by (metis One_nat_def Suc_eq_plus1_left Suc_leI add.commute add_lessD1 less_add_one
        mult.right_neutral nat_mult_less_cancel1 order_le_less trans_less_add1 zero_less_one)
  ultimately show \<open>\<exists>n > m. n mod k = i\<close>
    by fast
qed

lemma mod_suff:
  assumes \<open>\<forall>(n :: nat) > m. P (n mod k)\<close> \<open>0 < k\<close>
  shows \<open>\<forall>i < k. P i\<close>
  using assms mod_hit by blast

text \<open>It is always possible to find an index after some point that results in any given rule.\<close>
lemma rules_repeat: \<open>\<exists>n > m. rules !! n = r\<close>
proof (rule ccontr)
  assume \<open>\<not> (\<exists>n > m. rules !! n = r)\<close>
  then have \<open>\<not> (\<exists>n > m. n mod length rulesList = rule_index r)\<close>
    using rule_index_mod nth_rule_index by metis
  then have \<open>\<forall>n > m. n mod length rulesList \<noteq> rule_index r\<close>
    by blast
  moreover have \<open>length rulesList > 0\<close>
    unfolding rulesList_def by simp
  ultimately have \<open>\<forall>k < length rulesList. k \<noteq> rule_index r\<close>
    using mod_suff[where P=\<open>\<lambda>a. a \<noteq> rule_index r\<close>] by blast
  then show False
    using rule_index_bnd by blast
qed

text \<open>It is possible to find such an index no matter where in the stream we start.\<close>
lemma rules_repeat_sdrop: \<open>\<exists>n. (sdrop k rules) !! n = r\<close>
  using rules_repeat by (metis less_imp_add_positive sdrop_snth)

text \<open>Using the lemma above, we prove that the stream of rules is fair by coinduction.\<close>
lemma fair_rules: \<open>fair rules\<close>
proof -
  { fix r assume \<open>r \<in> R\<close>
    then obtain m where r: \<open>r = rules !! m\<close> unfolding sset_range by blast
    { fix n :: nat and rs let ?rules = \<open>\<lambda>n. sdrop n rules\<close>
      assume \<open>n > 0\<close>
      then have \<open>alw (ev (holds ((=) r))) (rs @- ?rules n)\<close>
      proof (coinduction arbitrary: n rs)
        case alw
        show ?case
        proof (rule exI[of _ \<open>rs @- ?rules n\<close>], safe)
          show \<open>\<exists>n' rs'. stl (rs @- ?rules n) = rs' @- ?rules n' \<and> n' > 0\<close>
          proof (cases rs)
            case Nil then show ?thesis unfolding alw
              by (metis sdrop_simps(2) shift.simps(1) zero_less_Suc)
          qed (auto simp: alw intro: exI[of _ n])
        next
          have \<open>ev (holds ((=) r)) (sdrop n rules)\<close>
            unfolding ev_holds_sset using rules_repeat_sdrop by (metis snth_sset)
          then show \<open>ev (holds ((=) r)) (rs @- sdrop n rules)\<close>
            unfolding ev_holds_sset by simp
        qed
      qed
    }
  }
  then show \<open>fair rules\<close> unfolding fair_def
    by (metis (full_types) alw_iff_sdrop ev_holds_sset neq0_conv order_refl sdrop.simps(1)
        stake_sdrop)
qed

subsection \<open>Substitution\<close>
text \<open>We need some lemmas about substitution of variables for terms for the Delta and Gamma rules.\<close>

text \<open>If a term is a subterm of another, so are all of its subterms.\<close>
lemma subtermTm_le: \<open>t \<in> set (subtermTm s) \<Longrightarrow> set (subtermTm t) \<subseteq> set (subtermTm s)\<close>
  by (induct s) auto

text \<open>Trying to substitute a variable that is not in the term does nothing (contrapositively).\<close>
lemma sub_term_const_transfer:
  \<open>sub_term m (Fun a []) t \<noteq> sub_term m s t \<Longrightarrow>
    Fun a [] \<in> set (subtermTm (sub_term m (Fun a []) t))\<close>
  \<open>sub_list m (Fun a []) ts \<noteq> sub_list m s ts \<Longrightarrow>
    Fun a [] \<in> (\<Union>t \<in> set (sub_list m (Fun a []) ts). set (subtermTm t))\<close>
proof (induct t and ts rule: sub_term.induct sub_list.induct)
  case (Var x)
  then show ?case
    by (metis list.set_intros(1) sub_term.simps(1) subtermTm.simps(1))
qed auto

text \<open>If substituting different terms makes a difference, then the substitution has an effect.\<close>
lemma sub_const_transfer:
  assumes \<open>sub m (Fun a []) p \<noteq> sub m t p\<close>
  shows \<open>Fun a [] \<in> set (subtermFm (sub m (Fun a []) p))\<close>
  using assms
proof (induct p arbitrary: m t)
  case (Pre i l)
  then show ?case
    using sub_term_const_transfer(2) by simp
qed auto

text \<open>If the list of subterms is empty for all formulas in a sequent, constant 0 is used instead.\<close>
lemma set_subterms:
  fixes z
  defines \<open>ts \<equiv> \<Union>p \<in> set z. set (subtermFm p)\<close>
  shows \<open>set (subterms z) = (if ts = {} then {Fun 0 []} else ts)\<close>
proof -
  have *: \<open>set (remdups (concat (map subtermFm z))) = (\<Union>p \<in> set z. set (subtermFm p))\<close>
    by (induct z) auto
  then show ?thesis
  proof (cases \<open>ts = {}\<close>)
    case True
    then show ?thesis
      unfolding subterms_def ts_def using *
      by (metis list.simps(15) list.simps(4) set_empty)
  next
    case False
    then show ?thesis
      unfolding subterms_def ts_def using *
      by (metis empty_set list.exhaust list.simps(5))
  qed
qed

text \<open>The parameters and the subterm functions respect each other.\<close>
lemma paramst_subtermTm:
  \<open>\<forall>i \<in> paramst t. \<exists>l. Fun i l \<in> set (subtermTm t)\<close>
  \<open>\<forall>i \<in> paramsts ts. \<exists>l. Fun i l \<in> (\<Union>t \<in> set ts. set (subtermTm t))\<close>
  by (induct t and ts rule: paramst.induct paramsts.induct) fastforce+

lemma params_subtermFm: \<open>\<forall>i \<in> params p. \<exists>l. Fun i l \<in> set (subtermFm p)\<close>
proof (induct p)
  case (Pre x1 x2)
  then show ?case
    using paramst_subtermTm by simp
qed auto

lemma subtermFm_subset_params: \<open>set (subtermFm p) \<subseteq> set A \<Longrightarrow> params p \<subseteq> paramsts A\<close>
  using params_subtermFm by force

subsection \<open>Custom cases\<close>
text \<open>Some proofs are more efficient with some custom case lemmas.\<close>

lemma Neg_exhaust
  [case_names Pre Imp Dis Con Exi Uni NegPre NegImp NegDis NegCon NegExi NegUni NegNeg]:
  assumes
    \<open>\<And>i ts. x = Pre i ts \<Longrightarrow> P\<close>
    \<open>\<And>p q. x = Imp p q \<Longrightarrow> P\<close>
    \<open>\<And>p q. x = Dis p q \<Longrightarrow> P\<close>
    \<open>\<And>p q. x = Con p q \<Longrightarrow> P\<close>
    \<open>\<And>p. x = Exi p \<Longrightarrow> P\<close>
    \<open>\<And>p. x = Uni p \<Longrightarrow> P\<close>
    \<open>\<And>i ts. x = Neg (Pre i ts) \<Longrightarrow> P\<close>
    \<open>\<And>p q. x = Neg (Imp p q) \<Longrightarrow> P\<close>
    \<open>\<And>p q. x = Neg (Dis p q) \<Longrightarrow> P\<close>
    \<open>\<And>p q. x = Neg (Con p q) \<Longrightarrow> P\<close>
    \<open>\<And>p. x = Neg (Exi p) \<Longrightarrow> P\<close>
    \<open>\<And>p. x = Neg (Uni p) \<Longrightarrow> P\<close>
    \<open>\<And>p. x = Neg (Neg p) \<Longrightarrow> P\<close>
  shows P
  using assms
proof (induct x)
  case (Neg p)
  then show ?case
    by (cases p) simp_all
qed simp_all

lemma parts_exhaust
  [case_names AlphaDis AlphaImp AlphaCon BetaDis BetaImp BetaCon
    DeltaUni DeltaExi NegNeg GammaExi GammaUni Other]:
  assumes
    \<open>\<And>p q. r = AlphaDis \<Longrightarrow> x = Dis p q \<Longrightarrow> P\<close>
    \<open>\<And>p q. r = AlphaImp \<Longrightarrow> x = Imp p q \<Longrightarrow> P\<close>
    \<open>\<And>p q. r = AlphaCon \<Longrightarrow> x = Neg (Con p q) \<Longrightarrow> P\<close>
    \<open>\<And>p q. r = BetaDis \<Longrightarrow> x = Neg (Dis p q) \<Longrightarrow> P\<close>
    \<open>\<And>p q. r = BetaImp \<Longrightarrow> x = Neg (Imp p q) \<Longrightarrow> P\<close>
    \<open>\<And>p q. r = BetaCon \<Longrightarrow> x = Con p q \<Longrightarrow> P\<close>
    \<open>\<And>p. r = DeltaUni \<Longrightarrow> x = Uni p \<Longrightarrow> P\<close>
    \<open>\<And>p. r = DeltaExi \<Longrightarrow> x = Neg (Exi p) \<Longrightarrow> P\<close>
    \<open>\<And>p. r = NegNeg \<Longrightarrow> x = Neg (Neg p) \<Longrightarrow> P\<close>
    \<open>\<And>p. r = GammaExi \<Longrightarrow> x = Exi p \<Longrightarrow> P\<close>
    \<open>\<And>p. r = GammaUni \<Longrightarrow> x = Neg (Uni p) \<Longrightarrow> P\<close>
    \<open>\<forall>A. parts A r x = [[x]] \<Longrightarrow> P\<close>
  shows P
  using assms
proof (cases r)
  case BetaCon
  then show ?thesis
    using assms
  proof (cases x rule: Neg_exhaust)
    case (Con p q)
    then show ?thesis
      using BetaCon assms by blast
  qed (simp_all add: parts_def)
next
  case BetaImp
  then show ?thesis
    using assms
  proof (cases x rule: Neg_exhaust)
    case (NegImp p q)
    then show ?thesis
      using BetaImp assms by blast
  qed (simp_all add: parts_def)
next
  case DeltaUni
  then show ?thesis
    using assms
  proof (cases x rule: Neg_exhaust)
    case (Uni p)
    then show ?thesis
      using DeltaUni assms by fast
  qed (simp_all add: parts_def)
next
  case DeltaExi
  then show ?thesis
    using assms
  proof (cases x rule: Neg_exhaust)
    case (NegExi p)
    then show ?thesis
      using DeltaExi assms by fast
  qed (simp_all add: parts_def)
next
  case n: NegNeg
  then show ?thesis
    using assms
  proof (cases x rule: Neg_exhaust)
    case (NegNeg p)
    then show ?thesis
      using n assms by fast
  qed (simp_all add: parts_def)
next
  case GammaExi
  then show ?thesis
    using assms
  proof (cases x rule: Neg_exhaust)
    case (Exi p)
    then show ?thesis
      using GammaExi assms by fast
  qed (simp_all add: parts_def)
next
  case GammaUni
  then show ?thesis
    using assms
  proof (cases x rule: Neg_exhaust)
    case (NegUni p)
    then show ?thesis
      using GammaUni assms by fast
  qed (simp_all add: parts_def)
qed (cases x rule: Neg_exhaust, simp_all add: parts_def)+

subsection \<open>Unaffected formulas\<close>
text \<open>We need some lemmas to show that formulas to which rules do not apply are not lost.\<close>

text \<open>This function returns True if the rule applies to the formula, and False otherwise.\<close>
definition affects :: \<open>rule \<Rightarrow> fm \<Rightarrow> bool\<close> where
  \<open>affects r p \<equiv> case (r, p) of
    (AlphaDis, Dis _ _) \<Rightarrow> True
  | (AlphaImp, Imp _ _) \<Rightarrow> True
  | (AlphaCon, Neg (Con _ _)) \<Rightarrow> True
  | (BetaCon, Con _ _) \<Rightarrow> True
  | (BetaImp, Neg (Imp _ _)) \<Rightarrow> True
  | (BetaDis, Neg (Dis _ _)) \<Rightarrow> True
  | (DeltaUni, Uni _) \<Rightarrow> True
  | (DeltaExi, Neg (Exi _)) \<Rightarrow> True
  | (NegNeg, Neg (Neg _)) \<Rightarrow> True
  | (GammaExi, Exi _) \<Rightarrow> False
  | (GammaUni, Neg (Uni _)) \<Rightarrow> False
  | (_,  _) \<Rightarrow> False\<close>

text \<open>If a rule does not affect a formula, that formula will be in the sequent obtained after
  applying the rule.\<close>
lemma parts_preserves_unaffected:
  assumes \<open>\<not> affects r p\<close> \<open>z' \<in> set (parts A r p)\<close>
  shows \<open>p \<in> set z'\<close>
  using assms unfolding affects_def
  by (cases r p rule: parts_exhaust) (simp_all add: parts_def)

text \<open>The \<open>list_prod\<close> function computes the Cartesian product.\<close>
lemma list_prod_is_cartesian:
  \<open>set (list_prod hs ts) = {h @ t |h t. h \<in> set hs \<and> t \<in> set ts}\<close>
  by (induct ts) auto

text \<open>The \<open>children\<close> function produces the Cartesian product of the branches from the first formula
and the branches from the rest of the sequent.\<close>
lemma set_children_Cons:
  \<open>set (children A r (p # z)) =
    {hs @ ts |hs ts. hs \<in> set (parts A r p) \<and>
      ts \<in> set (children (remdups (A @ subtermFms (concat (parts A r p)))) r z)}\<close>
  using list_prod_is_cartesian by (metis children.simps(2))

text \<open>The \<open>children\<close> function does not change unaffected formulas.\<close>
lemma children_preserves_unaffected:
  assumes \<open>p \<in> set z\<close> \<open>\<not> affects r p\<close> \<open>z' \<in> set (children A r z)\<close>
  shows \<open>p \<in> set z'\<close>
  using assms parts_preserves_unaffected set_children_Cons
  by (induct z arbitrary: A z') auto

text \<open>The \<open>effect\<close> function does not change unaffected formulas.\<close>
lemma effect_preserves_unaffected:
  assumes \<open>p \<in> set z\<close> and \<open>\<not> affects r p\<close> and \<open>(B, z') |\<in>| effect r (A, z)\<close>
  shows \<open>p \<in> set z'\<close>
  using assms children_preserves_unaffected
  unfolding effect_def
  by (smt (verit, best) Pair_inject femptyE fimageE fset_of_list_elem old.prod.case)

subsection \<open>Affected formulas\<close>
text \<open>We need some lemmas to show that formulas to which rules do apply are decomposed into their
  constituent parts correctly.\<close>

text \<open>If a formula occurs in a sequent on a child branch generated by \<open>children\<close>, it was part of
  the current sequent.\<close>
lemma parts_in_children:
  assumes \<open>p \<in> set z\<close> \<open>z' \<in> set (children A r z)\<close>
  shows \<open>\<exists>B xs. set A \<subseteq> set B \<and> xs \<in> set (parts B r p) \<and> set xs \<subseteq> set z'\<close>
  using assms
proof (induct z arbitrary: A z')
  case (Cons a _)
  then show ?case
  proof (cases \<open>a = p\<close>)
    case True
    then show ?thesis
      using Cons(3) set_children_Cons by fastforce
  next
    case False
    then show ?thesis
      using Cons set_children_Cons
      by (smt (verit, del_insts) le_sup_iff mem_Collect_eq set_ConsD set_append set_remdups subset_trans sup_ge2)
  qed
qed simp

text \<open>If \<open>effect\<close> contains something, then the input sequent is not an axiom.\<close>
lemma ne_effect_not_branchDone: \<open>(B, z') |\<in>| effect r (A, z) \<Longrightarrow> \<not> branchDone z\<close>
  by (cases \<open>branchDone z\<close>) simp_all

text \<open>The \<open>effect\<close> function decomposes formulas in the sequent using the \<open>parts\<close> function.
  (Unless the sequent is an axiom, in which case no child branches are generated.)\<close>
lemma parts_in_effect:
  assumes \<open>p \<in> set z\<close> and \<open>(B, z') |\<in>| effect r (A, z)\<close>
  shows \<open>\<exists>C xs. set A \<subseteq> set C \<and> xs \<in> set (parts C r p) \<and> set xs \<subseteq> set z'\<close>
  using assms parts_in_children ne_effect_not_branchDone
  by (smt (verit, ccfv_threshold) Pair_inject effect.simps fimageE fset_of_list_elem le_sup_iff
      set_append set_remdups)

text \<open>Specifically, this applied to the double negation elimination rule and the GammaUni rule.\<close>
corollary \<open>Neg (Neg p) \<in> set z \<Longrightarrow> (B, z') |\<in>| effect NegNeg (A, z) \<Longrightarrow> p \<in> set z'\<close>
  using parts_in_effect unfolding parts_def by fastforce

corollary \<open>Neg (Uni p) \<in> set z \<Longrightarrow> (B, z') |\<in>| effect GammaUni (A, z) \<Longrightarrow>
    set (map (\<lambda>t. Neg (sub 0 t p)) A) \<subseteq> set z'\<close>
  using parts_in_effect unfolding parts_def by fastforce

text \<open>If the sequent is not an axiom, and the rule and sequent match, all of the child branches
  generated by \<open>children\<close> will be included in the proof tree.\<close>
lemma eff_children:
  assumes \<open>\<not> branchDone z\<close> \<open>eff r (A, z) ss\<close>
  shows \<open>\<forall>z' \<in> set (children (remdups (A @ subtermFms z)) r z). \<exists>B. (B, z') |\<in>| ss\<close>
  using assms unfolding eff_def using fset_of_list_elem by fastforce

subsection \<open>Generating new function names\<close>
text \<open>We need to show that the \<open>generateNew\<close> function actually generates new function names.
  This requires a few lemmas about the interplay between \<open>max\<close> and \<open>foldr\<close>.\<close>

lemma foldr_max:
  fixes xs :: \<open>nat list\<close>
  shows \<open>foldr max xs 0 = (if xs = [] then 0 else Max (set xs))\<close>
  by (induct xs) simp_all

lemma Suc_max_new:
  fixes xs :: \<open>nat list\<close>
  shows \<open>Suc (foldr max xs 0) \<notin> set xs\<close>
proof (cases xs)
  case (Cons x xs)
  then have \<open>foldr max (x # xs) 0 = Max (set (x # xs))\<close>
    using foldr_max by simp
  then show ?thesis
    using Cons by (metis List.finite_set Max.insert add_0 empty_iff list.set(2) max_0_1(2)
        n_not_Suc_n nat_add_max_left plus_1_eq_Suc remdups.simps(2) set_remdups)
qed simp

lemma listFunTm_paramst: \<open>set (listFunTm t) = paramst t\<close> \<open>set (listFunTms ts) = paramsts ts\<close>
  by (induct t and ts rule: paramst.induct paramsts.induct) auto

subsection \<open>Finding axioms\<close>

text \<open>The \<open>branchDone\<close> function correctly determines whether a sequent is an axiom.\<close>
lemma branchDone_contradiction: \<open>branchDone z \<longleftrightarrow> (\<exists>p. p \<in> set z \<and> Neg p \<in> set z)\<close>
  by (induct z rule: branchDone.induct) auto

subsection \<open>Subterms\<close>
text \<open>We need a few lemmas about the behaviour of our subterm functions.\<close>

text \<open>Any term is a subterm of itself.\<close>
lemma subtermTm_refl [simp]: \<open>t \<in> set (subtermTm t)\<close>
  by (induct t) simp_all

text \<open>The arguments of a predicate are subterms of it.\<close>
lemma subterm_Pre_refl: \<open>set ts \<subseteq> set (subtermFm (Pre n ts))\<close>
  by (induct ts) auto

text \<open>The arguments of function are subterms of it.\<close>
lemma subterm_Fun_refl: \<open>set ts \<subseteq> set (subtermTm (Fun n ts))\<close>
  by (induct ts) auto

text \<open>This function computes the predicates in a formula.
  We will use this function to help prove the final lemma in this section.\<close>
primrec preds :: \<open>fm \<Rightarrow> fm set\<close> where
  \<open>preds (Pre n ts) = {Pre n ts}\<close>
| \<open>preds (Imp p q) = preds p \<union> preds q\<close>
| \<open>preds (Dis p q) = preds p \<union> preds q\<close>
| \<open>preds (Con p q) = preds p \<union> preds q\<close>
| \<open>preds (Exi p) = preds p\<close>
| \<open>preds (Uni p) = preds p\<close>
| \<open>preds (Neg p) = preds p\<close>

text \<open>If a term is a subterm of a formula, it is a subterm of some predicate in the formula.\<close>
lemma subtermFm_preds: \<open>t \<in> set (subtermFm p) \<longleftrightarrow> (\<exists>pre \<in> preds p. t \<in> set (subtermFm pre))\<close>
  by (induct p) auto

lemma preds_shape: \<open>pre \<in> preds p \<Longrightarrow> \<exists>n ts. pre = Pre n ts\<close>
  by (induct p) auto

text \<open>If a function is a subterm of a formula, so are the arguments of that function.\<close>
lemma fun_arguments_subterm:
  assumes \<open>Fun n ts \<in> set (subtermFm p)\<close>
  shows \<open>set ts \<subseteq> set (subtermFm p)\<close>
proof -
  obtain pre where pre: \<open>pre \<in> preds p\<close> \<open>Fun n ts \<in> set (subtermFm pre)\<close>
    using assms subtermFm_preds by blast
  then obtain n' ts' where \<open>pre = Pre n' ts'\<close>
    using preds_shape by blast
  then have \<open>set ts \<subseteq> set (subtermFm pre)\<close>
    using subtermTm_le pre by force
  then have \<open>set ts \<subseteq> set (subtermFm p)\<close>
    using pre subtermFm_preds by blast
  then show ?thesis
    by blast
qed

end


theory "AList-Utils"
imports Main "HOL-Library.AList"
begin
declare implies_True_equals [simp] False_implies_equals[simp]
text \<open>We want to have \<open>delete\<close> and \<open>update\<close> back in the namespace.\<close>

abbreviation delete where "delete \<equiv> AList.delete"
abbreviation update where "update \<equiv> AList.update"
abbreviation restrictA where "restrictA \<equiv> AList.restrict"
abbreviation clearjunk where "clearjunk \<equiv> AList.clearjunk"

lemmas restrict_eq = AList.restrict_eq
  and delete_eq = AList.delete_eq

lemma restrictA_append: "restrictA S (a@b) = restrictA S a @ restrictA S b"
  unfolding restrict_eq by (rule filter_append)

lemma length_restrictA_le: "length (restrictA S a) \<le> length a"
  by (metis length_filter_le restrict_eq)

subsubsection \<open>The domain of an associative list\<close>

definition domA
  where "domA h = fst ` set h"

lemma domA_append[simp]:"domA (a @ b) = domA a \<union> domA b"
  and [simp]:"domA ((v,e) # h) = insert v (domA h)"
  and [simp]:"domA (p # h) = insert (fst p) (domA h)"
  and [simp]:"domA [] = {}"
  by (auto simp add: domA_def)

lemma domA_from_set:
  "(x, e) \<in> set h \<Longrightarrow> x \<in> domA h"
by (induct h, auto)

lemma finite_domA[simp]:
  "finite (domA \<Gamma>)"
  by (auto simp add: domA_def)

lemma domA_delete[simp]:
  "domA (delete x \<Gamma>) = domA \<Gamma> - {x}"
  by (induct \<Gamma>) auto

lemma domA_restrictA[simp]:
  "domA (restrictA S \<Gamma>) = domA \<Gamma> \<inter> S"
  by (induct \<Gamma>) auto

lemma delete_not_domA[simp]:
  "x \<notin> domA \<Gamma> \<Longrightarrow>  delete x \<Gamma> = \<Gamma>"
  by (induct \<Gamma>) auto

lemma deleted_not_domA: "x \<notin> domA (delete x \<Gamma>)"
  by (induct \<Gamma>) auto

lemma dom_map_of_conv_domA:
  "dom (map_of \<Gamma>) = domA \<Gamma>"
  by (induct \<Gamma>) (auto simp add: dom_if)

lemma domA_map_of_Some_the:
  "x \<in> domA \<Gamma> \<Longrightarrow> map_of \<Gamma> x = Some (the (map_of \<Gamma> x))"
  by (induct \<Gamma>) (auto simp add: dom_if)

lemma domA_clearjunk[simp]: "domA (clearjunk \<Gamma>) = domA \<Gamma>"
  unfolding domA_def using dom_clearjunk.

lemma the_map_option_domA[simp]: "x \<in> domA \<Gamma> \<Longrightarrow> the (map_option f (map_of \<Gamma> x)) = f (the (map_of \<Gamma> x))"
  by (induction \<Gamma>) auto

lemma map_of_domAD: "map_of \<Gamma> x = Some e \<Longrightarrow> x \<in> domA \<Gamma>"
  using dom_map_of_conv_domA by fastforce

lemma restrictA_noop: "domA \<Gamma> \<subseteq> S \<Longrightarrow> restrictA S \<Gamma> = \<Gamma>"
  unfolding restrict_eq by (induction \<Gamma>) auto

lemma restrictA_cong:
  "(\<And>x. x \<in> domA m1 \<Longrightarrow> x \<in> V \<longleftrightarrow> x \<in> V') \<Longrightarrow> m1 = m2 \<Longrightarrow> restrictA V m1 = restrictA V' m2"
  unfolding restrict_eq by (induction m1 arbitrary: m2) auto

subsubsection \<open>Other lemmas about associative lists\<close>

lemma delete_set_none: "(map_of l)(x := None) = map_of (delete x l)"
proof (induct l)
  case Nil thus ?case by simp
  case (Cons l ls)
  from this[symmetric]
  show ?case
  by (cases "fst l = x") auto
qed

lemma list_size_delete[simp]: "size_list size (delete x l) < Suc (size_list size l)"
  by (induct l) auto

lemma delete_append[simp]: "delete x (l1 @ l2) = delete x l1 @ delete x l2"
  unfolding AList.delete_eq by simp

lemma map_of_delete_insert:
  assumes "map_of \<Gamma> x = Some e"
  shows "map_of ((x,e) # delete x \<Gamma>) = map_of \<Gamma>"
  using assms by (induct \<Gamma>) (auto split:prod.split)

lemma map_of_delete_iff[simp]: "map_of (delete x \<Gamma>) xa = Some e \<longleftrightarrow> (map_of \<Gamma> xa = Some e) \<and> xa \<noteq> x"
  by (metis delete_conv fun_upd_same map_of_delete option.distinct(1))

lemma map_add_domA[simp]:
  "x \<in> domA \<Gamma> \<Longrightarrow> (map_of \<Delta> ++ map_of \<Gamma>) x = map_of \<Gamma> x"
  "x \<notin> domA \<Gamma> \<Longrightarrow> (map_of \<Delta> ++ map_of \<Gamma>) x = map_of \<Delta> x"
    apply (metis dom_map_of_conv_domA map_add_dom_app_simps(1))
    apply (metis dom_map_of_conv_domA map_add_dom_app_simps(3))
    done

lemma set_delete_subset: "set (delete k al) \<subseteq> set al"
  by (auto simp add: delete_eq)

lemma dom_delete_subset: "snd ` set (delete k al) \<subseteq> snd ` set al"
  by (auto simp add: delete_eq)

(*
lemma ran_map_cong[fundef_cong]:
  "\<lbrakk> list_all2 (\<lambda> x y. fst x = fst y \<and> f1 (fst x) (snd x) = f2 (fst y) (snd y)) m1 m2 \<rbrakk>
      \<Longrightarrow> map_ran f1 m1 = map_ran f2 m2"
  by (induction rule: list_all2_induct) auto
*)
lemma map_ran_cong[fundef_cong]:
  "\<lbrakk> \<And> x . x \<in> set m1 \<Longrightarrow> f1 (fst x) (snd x) = f2 (fst x) (snd x) ; m1 = m2 \<rbrakk>
      \<Longrightarrow> map_ran f1 m1 = map_ran f2 m2"
  by (induction m1 arbitrary: m2) auto

lemma domA_map_ran[simp]: "domA (map_ran f m) = domA m"
  unfolding domA_def by (rule dom_map_ran)

lemma map_ran_delete:
  "map_ran f (delete x \<Gamma>) = delete x (map_ran f \<Gamma>)"
  by (induction \<Gamma>)  auto

lemma map_ran_restrictA:
  "map_ran f (restrictA V \<Gamma>) = restrictA V (map_ran f \<Gamma>)"
  by (induction \<Gamma>)  auto

lemma map_ran_append:
  "map_ran f (\<Gamma>@\<Delta>) = map_ran f \<Gamma> @ map_ran f \<Delta>"
  by (induction \<Gamma>)  auto

subsubsection \<open>Syntax for map comprehensions\<close>

definition mapCollect :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> 'c set"
  where "mapCollect f m = {f k v | k v . m k = Some v}"

syntax
 "_MapCollect" :: "'c \<Rightarrow> pttrn => pttrn \<Rightarrow> 'a \<rightharpoonup> 'b => 'c set"    ("(1{_ |/_/\<mapsto>/_/\<in>/_/})")
translations
  "{e | k\<mapsto>v \<in> m}" == "CONST mapCollect (\<lambda>k v. e) m"

lemma mapCollect_empty[simp]: "{f k v | k \<mapsto> v \<in> Map.empty} = {}"
  unfolding mapCollect_def by simp

lemma mapCollect_const[simp]:
  "m \<noteq> Map.empty \<Longrightarrow> {e | k\<mapsto>v\<in>m} = {e}"
  unfolding mapCollect_def by auto

lemma mapCollect_cong[fundef_cong]:
  "(\<And> k v. m1 k = Some v \<Longrightarrow> f1 k v = f2 k v) \<Longrightarrow> m1 = m2 \<Longrightarrow> mapCollect f1 m1 = mapCollect f2 m2"
  unfolding mapCollect_def by force

lemma mapCollectE[elim!]:
  assumes "x \<in> {f k v | k \<mapsto> v \<in> m}"
  obtains k v where "m k = Some v" and "x = f k v"
  using assms by (auto simp add: mapCollect_def)

lemma mapCollectI[intro]:
  assumes  "m k = Some v"
  shows "f k v \<in> {f k v | k \<mapsto> v \<in> m}"
  using assms by (auto simp add: mapCollect_def)

lemma ball_mapCollect[simp]:
  "(\<forall> x \<in> {f k v | k \<mapsto> v \<in> m}. P x) \<longleftrightarrow> (\<forall> k v. m k = Some v \<longrightarrow> P (f k v))"
  by (auto simp add: mapCollect_def)

lemma mapCollect_map_upd[simp]:
  "mapCollect f (m(k\<mapsto>v)) = insert (f k v) (mapCollect f (m(k := None)))"
unfolding mapCollect_def by auto

definition mapCollectFilter :: "('a \<Rightarrow> 'b \<Rightarrow> (bool \<times> 'c)) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> 'c set"
  where "mapCollectFilter f m = {snd (f k v) | k v . m k = Some v \<and> fst (f k v)}"

syntax
 "_MapCollectFilter" :: "'c \<Rightarrow> pttrn \<Rightarrow> pttrn \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> bool \<Rightarrow> 'c set"    ("(1{_ |/_/\<mapsto>/_/\<in>/_/./ _})")
translations
  "{e | k\<mapsto>v \<in> m . P }" == "CONST mapCollectFilter (\<lambda>k v. (P,e)) m"

lemma mapCollectFilter_const_False[simp]:
  "{e | k\<mapsto>v \<in> m . False } = {}"
  unfolding mapCollect_def mapCollectFilter_def by simp

lemma mapCollectFilter_const_True[simp]:
  "{e | k\<mapsto>v \<in> m . True } = {e | k\<mapsto>v \<in> m}"
  unfolding mapCollect_def mapCollectFilter_def by simp

end


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

definition weakSimAct :: "pi \<Rightarrow> residual \<Rightarrow> ('a::fs_name) \<Rightarrow> (pi \<times> pi) set \<Rightarrow> bool" where
  "weakSimAct P Rs C Rel \<equiv> (\<forall>Q' a x. Rs = a<\<nu>x> \<prec> Q' \<longrightarrow> x \<sharp> C \<longrightarrow> (\<exists>P' . P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel)) \<and>
                         (\<forall>Q' a x. Rs = a<x> \<prec> Q' \<longrightarrow> x \<sharp> C \<longrightarrow> (\<exists>P''. \<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel)) \<and>
                         (\<forall>Q' \<alpha>. Rs = \<alpha> \<prec> Q' \<longrightarrow> (\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel))"

definition weakSimAux :: "pi \<Rightarrow> (pi \<times> pi) set \<Rightarrow> pi \<Rightarrow> bool" where
  "weakSimAux P Rel Q \<equiv> (\<forall>Q' a x. (Q \<longmapsto> a<\<nu>x> \<prec> Q' \<and> x \<sharp> P) \<longrightarrow> (\<exists>P' . P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel)) \<and>
                         (\<forall>Q' a x. (Q \<longmapsto> a<x> \<prec> Q' \<and> x \<sharp> P) \<longrightarrow> (\<exists>P''. \<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel)) \<and>
                         (\<forall>Q' \<alpha>. Q \<longmapsto> \<alpha> \<prec> Q' \<longrightarrow> (\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel))"

definition weakSimulation :: "pi \<Rightarrow> (pi \<times> pi) set \<Rightarrow> pi \<Rightarrow> bool" ("_ \<leadsto>\<^sup>^<_> _" [80, 80, 80] 80) where
  "P \<leadsto>\<^sup>^<Rel> Q \<equiv> (\<forall>Rs. Q \<longmapsto> Rs \<longrightarrow> weakSimAct P Rs P Rel)"

lemmas simDef = weakSimAct_def weakSimulation_def

lemma "weakSimAux P Rel Q = weakSimulation P Rel Q"
by(auto simp add: weakSimAux_def simDef)

  assumes "P \<leadsto>\<^sup>^<A> P'"
  and     "A \<subseteq> B"

  shows "P \<leadsto>\<^sup>^<B> P'"
using assms
apply(auto simp add: simDef)
apply blast
apply(erule_tac x="a<x> \<prec> Q'" in allE)
apply(clarsimp)
apply(rotate_tac 4)
apply(erule_tac x=Q' in allE)
apply(erule_tac x=a in allE)
apply(erule_tac x=x in allE)
by blast+

  assumes Eqvt:  "eqvt Rel"
  and     Bound: "\<And>Q' a x. \<lbrakk>x \<sharp> C; Q \<longmapsto>a<\<nu>x> \<prec> Q'\<rbrakk> \<Longrightarrow> \<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel"
  and     Input: "\<And>Q' a x. \<lbrakk>x \<sharp> C; Q \<longmapsto>a<x> \<prec> Q'\<rbrakk> \<Longrightarrow> \<exists>P''. \<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"
  and     Free:  "\<And>Q' \<alpha>. Q \<longmapsto> \<alpha> \<prec> Q' \<Longrightarrow> (\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^ \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel)"

  shows "P \<leadsto>\<^sup>^<Rel> Q"
using Free
proof(auto simp add: simDef)
  fix Q' a x
  assume xFreshP: "(x::name) \<sharp> P"
  assume Trans: "Q \<longmapsto> a<\<nu>x> \<prec> Q'"
  have "\<exists>c::name. c \<sharp> (P, Q', x, C)" by(blast intro: name_exists_fresh)
  then obtain c::name where cFreshP: "c \<sharp> P" and cFreshQ': "c \<sharp> Q'" and cFreshC: "c \<sharp> C"
                        and cineqx: "c \<noteq> x"
    by(force simp add: fresh_prod)

  from Trans cFreshQ' have "Q \<longmapsto> a<\<nu>c> \<prec> ([(x, c)] \<bullet> Q')" by(simp add: alphaBoundResidual)
  with cFreshC have "\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^ a<\<nu>c> \<prec> P' \<and> (P', [(x, c)] \<bullet> Q') \<in> Rel"
    by(rule Bound)
  then obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>c> \<prec> P'" and P'RelQ': "(P', [(x, c)] \<bullet> Q') \<in> Rel"
    by blast

  from PTrans xFreshP cineqx have xFreshP': "x \<sharp> P'" by(force dest: freshTransition)
  with PTrans have "P \<Longrightarrow>\<^sub>l\<^sup>^ a<\<nu>x> \<prec> ([(x, c)] \<bullet> P')" by(simp add: alphaBoundResidual name_swap)
  moreover have "([(x, c)] \<bullet> P', Q') \<in> Rel" (is "?goal")
  proof -
    from Eqvt P'RelQ' have "([(x, c)] \<bullet> P', [(x, c)] \<bullet> [(x, c)] \<bullet> Q') \<in> Rel"
      by(rule eqvtRelI)
    with cineqx show ?goal by(simp add: name_calc)
  qed
  ultimately show "\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel" by blast
next
  fix Q' a x u
  assume QTrans: "Q \<longmapsto>a<x> \<prec> (Q'::pi)"and xFreshP: "x \<sharp> P"

  have "\<exists>c::name. c \<sharp> (P, Q', C, x)" by(blast intro: name_exists_fresh)
  then obtain c::name where cFreshP: "c \<sharp> P" and cFreshQ': "c \<sharp> Q'" and cFreshC: "c \<sharp> C"
                        and cineqx: "c \<noteq> x"
    by(force simp add: fresh_prod)

  from QTrans cFreshQ' have "Q \<longmapsto>a<c> \<prec> ([(x, c)] \<bullet> Q')" by(simp add: alphaBoundResidual)
  with cFreshC have "\<exists>P''. \<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<c> \<prec> P' \<and> (P', ([(x, c)] \<bullet> Q')[c::=u]) \<in> Rel"
    by(rule Input)

  then obtain P'' where L1: "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<c> \<prec> P' \<and> (P', ([(x, c)] \<bullet> Q')[c::=u]) \<in> Rel" by blast

  have "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in ([(c, x)] \<bullet> P'')\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"
  proof(auto)
    fix u
    from L1 obtain P' where PTrans: "P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<c> \<prec> P'" and P'RelQ': "(P', ([(x, c)] \<bullet> Q')[c::=u]) \<in> Rel"
      by blast

    from PTrans xFreshP have "P \<Longrightarrow>\<^sub>lu in ([(c, x)] \<bullet> P'')\<rightarrow>a<x> \<prec> P'" by(rule alphaInput)
    moreover from P'RelQ' cFreshQ' have "(P', Q'[x::=u]) \<in> Rel" by(simp add: renaming[THEN sym] name_swap)

    ultimately show "\<exists>P'. P \<Longrightarrow>\<^sub>lu in ([(c, x)] \<bullet> P'')\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel" by blast
  qed

  thus "\<exists>P''. \<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel" by blast
qed

lemma simCases[case_names Bound Input Free]:
  fixes P   :: pi
  and   Q   :: pi
  and   Rel :: "(pi \<times> pi) set"
  and   C   :: "'a::fs_name"

  assumes Bound: "\<And>Q' a x. \<lbrakk>Q \<longmapsto>a<\<nu>x> \<prec> Q'; x \<sharp> P\<rbrakk> \<Longrightarrow> \<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel"
  and     Input: "\<And>Q' a x. \<lbrakk>Q \<longmapsto>a<x> \<prec> Q'; x \<sharp> P\<rbrakk> \<Longrightarrow> \<exists>P''. \<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"
  and     Free:  "\<And>Q' \<alpha>. Q \<longmapsto> \<alpha> \<prec> Q' \<Longrightarrow> (\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^ \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel)"

  shows "P \<leadsto>\<^sup>^<Rel> Q"
using assms
by(auto simp add: simDef)

lemma simActBoundCases[consumes 1, case_names Input BoundOutput]:
  fixes P   :: pi
  and   a   :: subject
  and   x   :: name
  and   Q'  :: pi
  and   C   :: "'a::fs_name"
  and   Rel :: "(pi \<times> pi) set"

  assumes EqvtRel: "eqvt Rel"
  and     DerInput: "\<And>b. a = InputS b \<Longrightarrow> (\<exists>P''. \<forall>u. \<exists>P'. (P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>b<x> \<prec> P') \<and> (P', Q'[x::=u]) \<in> Rel)"
  and     DerBoundOutput: "\<And>b. a = BoundOutputS b \<Longrightarrow> (\<exists>P'. (P \<Longrightarrow>\<^sub>l\<^sup>^b<\<nu>x> \<prec> P') \<and> (P', Q') \<in> Rel)"

  shows "weakSimAct P (a\<guillemotleft>x\<guillemotright> \<prec> Q') P Rel"
proof(simp add: weakSimAct_def fresh_prod, auto)
  fix Q'' b y
  assume Eq: "a\<guillemotleft>x\<guillemotright> \<prec> Q' = b<\<nu>y> \<prec> Q''"
  assume yFreshP: "y \<sharp> P"

  from Eq have "a = BoundOutputS b" by(simp add: residual.inject)

  from yFreshP DerBoundOutput[OF this] Eq show "\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^b<\<nu>y> \<prec> P' \<and> (P', Q'') \<in> Rel"
  proof(cases "x=y", auto simp add: residual.inject name_abs_eq)
    fix P'
    assume PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^b<\<nu>x> \<prec> P'"
    assume P'RelQ': "(P', ([(x, y)] \<bullet> Q'')) \<in> Rel"
    assume xineqy: "x \<noteq> y"

    with PTrans yFreshP have yFreshP': "y \<sharp> P'"
      by(force intro: freshTransition)

    hence "b<\<nu>x> \<prec> P' = b<\<nu>y> \<prec> [(x, y)] \<bullet> P'" by(rule alphaBoundResidual)
    moreover have "([(x, y)] \<bullet> P', Q'') \<in> Rel"
    proof -
      from EqvtRel P'RelQ' have "([(x, y)] \<bullet> P', [(x, y)] \<bullet> ([(x, y)] \<bullet> Q''))\<in> Rel"
        by(rule eqvtRelI)
      thus ?thesis by(simp add: name_calc)
    qed

    ultimately show "\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^b<\<nu>y> \<prec> P' \<and> (P', Q'') \<in> Rel" using PTrans by auto
  qed
next
  fix Q'' b y u
  assume Eq: "a\<guillemotleft>x\<guillemotright> \<prec> Q' = b<y> \<prec> Q''"
  assume yFreshP: "y \<sharp> P"

  from Eq have "a = InputS b" by(simp add: residual.inject)
  from DerInput[OF this] obtain P'' where L1: "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>b<x> \<prec> P' \<and>
                                                        (P', Q'[x::=u]) \<in> Rel"
    by blast
  have "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in ([(x, y)] \<bullet> P'')\<rightarrow>b<y> \<prec> P' \<and> (P', Q''[y::=u]) \<in> Rel"
  proof(rule allI)
    fix u
    from L1 Eq show "\<exists>P'. P \<Longrightarrow>\<^sub>lu in ([(x, y)] \<bullet> P'')\<rightarrow>b<y> \<prec> P' \<and> (P', Q''[y::=u]) \<in> Rel"
    proof(cases "x=y", auto simp add: residual.inject name_abs_eq)
      assume Der: "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>b<x> \<prec> P' \<and> (P', ([(x, y)] \<bullet> Q'')[x::=u]) \<in> Rel"
      assume xFreshQ'': "x \<sharp> Q''"

      from Der obtain P' where PTrans: "P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>b<x> \<prec> P'"
                          and P'RelQ': "(P', ([(x, y)] \<bullet> Q'')[x::=u]) \<in> Rel"
        by force

      from PTrans yFreshP have "P \<Longrightarrow>\<^sub>lu in ([(x, y)] \<bullet> P'')\<rightarrow>b<y> \<prec> P'" by(rule alphaInput)
      moreover from xFreshQ'' P'RelQ' have "(P', Q''[y::=u]) \<in> Rel"
        by(simp add: renaming)
      ultimately show ?thesis by force
    qed
  qed
  thus  "\<exists>P''. \<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>b<y> \<prec> P' \<and> (P', Q''[y::=u]) \<in> Rel"
    by blast
qed

lemma simActFreeCases[consumes 0, case_names Der]:
  fixes P   :: pi
  and   \<alpha>   :: freeRes
  and   Q'  :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes "\<exists>P'. (P \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P') \<and> (P', Q') \<in> Rel"

  shows "weakSimAct P (\<alpha> \<prec> Q') P Rel"
using assms
by(simp add: residual.inject weakSimAct_def fresh_prod)

lemma simE:
  fixes P   :: pi
  and   Rel :: "(pi \<times> pi) set"
  and   Q   :: pi
  and   a   :: name
  and   x   :: name
  and   u   :: name
  and   Q'  :: pi

  assumes "P \<leadsto>\<^sup>^<Rel> Q"

  shows "Q \<longmapsto>a<\<nu>x> \<prec> Q' \<Longrightarrow> x \<sharp> P \<Longrightarrow> \<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel"
  and   "Q \<longmapsto>a<x> \<prec> Q' \<Longrightarrow> x \<sharp> P \<Longrightarrow> \<exists>P''. \<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"
  and   "Q \<longmapsto>\<alpha> \<prec> Q' \<Longrightarrow> (\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel)"
using assms by(simp add: simDef)+

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

  assumes QChain: "Q \<Longrightarrow>\<^sub>\<tau> Q'"
  and     PRelQ: "(P, Q) \<in> Rel"
  and     Sim: "\<And>P Q. (P, Q) \<in> Rel \<Longrightarrow> P \<leadsto>\<^sup>^<Rel> Q"

  shows "\<exists>P'. P \<Longrightarrow>\<^sub>\<tau> P' \<and> (P', Q') \<in> Rel"
proof -
  from QChain show ?thesis
  proof(induct rule: tauChainInduct)
    case id
    have "P \<Longrightarrow>\<^sub>\<tau> P" by simp
    with PRelQ show ?case by blast
  next
    case(ih Q' Q'')
    have IH: "\<exists>P'. P \<Longrightarrow>\<^sub>\<tau> P' \<and> (P', Q') \<in> Rel" by fact
    then obtain P' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'" and P'RelQ': "(P', Q') \<in> Rel" by blast
    from P'RelQ' have "P' \<leadsto>\<^sup>^<Rel> Q'" by(rule Sim)
    moreover have Q'Trans: "Q' \<longmapsto>\<tau> \<prec> Q''" by fact
    ultimately have "\<exists>P''. P' \<Longrightarrow>\<^sub>l\<^sup>^\<tau> \<prec> P'' \<and> (P'', Q'') \<in> Rel" by(rule simE)
    then obtain P'' where P'Trans: "P' \<Longrightarrow>\<^sub>l\<^sup>^\<tau> \<prec> P''" and P''RelQ'': "(P'', Q'') \<in> Rel" by blast
    from P'Trans have "P' \<Longrightarrow>\<^sub>\<tau> P''" by(rule tauTransitionChain)
    with PChain have "P \<Longrightarrow>\<^sub>\<tau> P''" by auto
    with P''RelQ'' show ?case by blast
  qed
qed

lemma simE2:
  fixes P   :: pi
  and   Rel :: "(pi \<times> pi) set"
  and   Q   :: pi
  and   a   :: name
  and   x   :: name
  and   Q'  :: pi

  assumes PSimQ: "P \<leadsto>\<^sup>^<Rel> Q"
  and     Sim: "\<And>P Q. (P, Q) \<in> Rel \<Longrightarrow> P \<leadsto>\<^sup>^<Rel> Q"
  and     Eqvt: "eqvt Rel"
  and     PRelQ: "(P, Q) \<in> Rel"

  shows "Q \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> Q' \<Longrightarrow> x \<sharp> P \<Longrightarrow> \<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel"
  and   "Q \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> Q' \<Longrightarrow> \<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"
proof -
  assume QTrans: "Q \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> Q'"
  assume xFreshP: "x \<sharp> P"
  have Goal: "\<And>P Q a x Q'. \<lbrakk>P \<leadsto>\<^sup>^<Rel> Q; Q \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> Q'; x \<sharp> P; x \<sharp> Q; (P, Q) \<in> Rel\<rbrakk> \<Longrightarrow>
                            \<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel"
  proof -
    fix P Q a x Q'
    assume PSimQ: "P \<leadsto>\<^sup>^<Rel> Q"
    assume QTrans: "Q \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> Q'"
    assume xFreshP: "x \<sharp> P"
    assume xFreshQ: "x \<sharp> Q"
    assume PRelQ: "(P, Q) \<in> Rel"

    from QTrans xFreshQ obtain Q'' Q''' where QChain: "Q \<Longrightarrow>\<^sub>\<tau> Q''"
                                          and Q''Trans: "Q'' \<longmapsto>a<\<nu>x> \<prec> Q'''"
                                          and Q'''Chain: "Q''' \<Longrightarrow>\<^sub>\<tau> Q'"
      by(force dest: Weak_Late_Step_Semantics.transitionE simp add: weakTransition_def)

    from QChain PRelQ Sim have "\<exists>P''. P \<Longrightarrow>\<^sub>\<tau> P'' \<and> (P'', Q'') \<in> Rel"
      by(rule weakSimTauChain)
    then obtain P'' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P''" and P''RelQ'': "(P'', Q'') \<in> Rel" by blast
    from PChain xFreshP have xFreshP'': "x \<sharp> P''" by(rule freshChain)

    from P''RelQ'' have "P'' \<leadsto>\<^sup>^<Rel> Q''" by(rule Sim)
    hence "\<exists>P'''. P'' \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P''' \<and> (P''', Q''') \<in> Rel" using Q''Trans xFreshP''
      by(rule simE)
    then obtain P''' where P''Trans: "P'' \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P'''" and P'''RelQ''': "(P''', Q''') \<in> Rel"
      by blast

    from P'''RelQ''' have "P''' \<leadsto>\<^sup>^<Rel> Q'''" by(rule Sim)
    have "\<exists>P'. P''' \<Longrightarrow>\<^sub>\<tau> P' \<and> (P', Q') \<in> Rel" using Q'''Chain P'''RelQ''' Sim
      by(rule weakSimTauChain)
    then obtain P' where P'''Chain: "P''' \<Longrightarrow>\<^sub>\<tau> P'" and P'RelQ': "(P', Q') \<in> Rel" by blast

    from PChain P''Trans P'''Chain xFreshP'' have "P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P'"
      by(blast dest: chainTransitionAppend)
    with P'RelQ' show "\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^ a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel" by blast
  qed

  have "\<exists>c::name. c \<sharp> (Q, Q', P, x)" by(blast intro: name_exists_fresh)
  then obtain c::name where cFreshQ: "c \<sharp> Q" and cFreshQ': "c \<sharp> Q'" and cFreshP: "c \<sharp> P"
                        and xineqc: "x \<noteq> c"
    by(force simp add: fresh_prod)

  from QTrans cFreshQ' have "Q \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>c> \<prec> ([(x, c)] \<bullet> Q')" by(simp add: alphaBoundResidual)
  with PSimQ have "\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>c> \<prec> P' \<and> (P', [(x, c)] \<bullet> Q') \<in> Rel" using cFreshP cFreshQ \<open>(P, Q) \<in> Rel\<close>
    by(rule Goal)
  then obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>c> \<prec> P'" and P'RelQ': "(P', [(x, c)] \<bullet> Q') \<in> Rel"
    by force
  have "P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> ([(x, c)] \<bullet> P')"
  proof -
    from PTrans xFreshP xineqc have "x \<sharp> P'" by(rule freshTransition)
    with PTrans show ?thesis by(simp add: alphaBoundResidual name_swap)
  qed
  moreover have "([(x, c)] \<bullet> P', Q') \<in> Rel"
  proof -
    from Eqvt P'RelQ' have "([(x, c)] \<bullet> P', [(x, c)] \<bullet> [(x, c)] \<bullet> Q') \<in> Rel"
      by(rule eqvtRelI)
    thus ?thesis by simp
  qed

  ultimately show "\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^ a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel" by blast
next
  assume QTrans: "Q \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> Q'"
  thus "\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"
  proof(induct rule: transitionCases)
    case Step
    have "Q \<Longrightarrow>\<^sub>l\<alpha> \<prec> Q'" by fact
    then obtain Q'' Q''' where QChain: "Q \<Longrightarrow>\<^sub>\<tau> Q''"
                           and Q''Trans: "Q'' \<longmapsto>\<alpha> \<prec> Q'''"
                           and Q'''Chain: "Q''' \<Longrightarrow>\<^sub>\<tau> Q'"
      by(blast dest: Weak_Late_Step_Semantics.transitionE)

    from QChain PRelQ Sim have "\<exists>P''. P \<Longrightarrow>\<^sub>\<tau> P'' \<and> (P'', Q'') \<in> Rel"
      by(rule weakSimTauChain)
    then obtain P'' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P''" and P''RelQ'': "(P'', Q'') \<in> Rel" by blast
    from P''RelQ'' have "P'' \<leadsto>\<^sup>^<Rel> Q''" by(rule Sim)
    hence "\<exists>P'''. P'' \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P''' \<and> (P''', Q''') \<in> Rel" using Q''Trans
      by(rule simE)
    then obtain P''' where P''Trans: "P'' \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P'''" and P'''RelQ''': "(P''', Q''') \<in> Rel"
      by blast

    from P'''RelQ''' have "P''' \<leadsto>\<^sup>^<Rel> Q'''" by(rule Sim)
    have "\<exists>P'. P''' \<Longrightarrow>\<^sub>\<tau> P' \<and> (P', Q') \<in> Rel" using Q'''Chain P'''RelQ''' Sim
      by(rule weakSimTauChain)
    then obtain P' where P'''Chain: "P''' \<Longrightarrow>\<^sub>\<tau> P'" and P'RelQ': "(P', Q') \<in> Rel" by blast

    from PChain P''Trans P'''Chain have "P \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P'"
      by(blast dest: chainTransitionAppend)
    with P'RelQ' show ?case by blast
  next
    case Stay
    have "\<alpha> \<prec> Q' = \<tau> \<prec> Q" by fact
    hence "Q = Q'" and "\<alpha> = \<tau>" by(simp add: residual.inject)+
    moreover have "P \<Longrightarrow>\<^sub>l\<^sup>^\<tau> \<prec> P" by(simp add: weakTransition_def)
    ultimately show ?case using PRelQ by blast
  qed
qed
(*
lemma tauChainStep:
  fixes P  :: pi
  and   P' :: pi

  assumes PChain: "P \<Longrightarrow>\<^sub>\<tau> P'"
  and     PineqP': "P \<noteq> P'"

  shows "\<exists>P''. P \<longmapsto>\<tau> \<prec> P'' \<and> P'' \<Longrightarrow>\<^sub>\<tau> P'"
proof -
  from PChain have "(P, P') \<in> Id \<union> (tauActs O tauActs\<^sup>* )"
    by(insert rtrancl_unfold, blast)
  with PineqP' have "(P, P') \<in> tauActs O tauActs\<^sup>*" by simp
  hence "(P, P') \<in> tauActs\<^sup>* O tauActs" by(simp add: r_comp_rtrancl_eq)
  thus ?thesis
    by(auto simp add: tauActs_def tauChain_def)
qed
*)
lemma eqvtI:
  fixes P    :: pi
  and   Q    :: pi
  and   Rel  :: "(pi \<times> pi) set"
  and   perm :: "name prm"

  assumes Sim: "P \<leadsto>\<^sup>^<Rel> Q"
  and     RelRel': "Rel \<subseteq> Rel'"
  and     EqvtRel': "eqvt Rel'"

  shows "(perm \<bullet> P) \<leadsto>\<^sup>^<Rel'> (perm \<bullet> Q)"
proof -
  from EqvtRel' show ?thesis
  proof(induct rule: simCasesCont[of _ "(perm \<bullet> P)"])
    case(Bound Q' a x)
    have Trans: "(perm \<bullet> Q) \<longmapsto> a<\<nu>x> \<prec> Q'" and xFreshP: "x \<sharp> perm \<bullet> P" by fact+

    from Trans have "(rev perm \<bullet> (perm \<bullet> Q)) \<longmapsto> rev perm \<bullet> (a<\<nu>x> \<prec> Q')"
      by(rule eqvts)
    hence "Q \<longmapsto> (rev perm \<bullet> a)<\<nu>(rev perm \<bullet> x)> \<prec> (rev perm \<bullet> Q')"
      by(simp add: name_rev_per)
    moreover from xFreshP have "(rev perm \<bullet> x) \<sharp> P" by(simp add: name_fresh_left)
    ultimately have "\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^ (rev perm \<bullet> a)<\<nu>(rev perm \<bullet> x)> \<prec> P' \<and> (P', rev perm \<bullet> Q') \<in> Rel" using Sim
      by(force intro: simE)
    then obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^ (rev perm \<bullet> a)<\<nu>(rev perm \<bullet> x)> \<prec> P'" and P'RelQ': "(P', rev perm \<bullet> Q') \<in> Rel" by blast

    from PTrans have "(perm \<bullet> P) \<Longrightarrow>\<^sub>l\<^sup>^ perm \<bullet> ((rev perm \<bullet> a)<\<nu>(rev perm \<bullet> x)> \<prec> P')"
      by(rule Weak_Late_Semantics.eqvtI)
    hence L1: "(perm \<bullet> P) \<Longrightarrow>\<^sub>l\<^sup>^ a<\<nu>x> \<prec> (perm \<bullet> P')" by(simp add: name_per_rev)
    from P'RelQ' RelRel' have "(P', rev perm \<bullet> Q') \<in> Rel'" by blast
    with EqvtRel' have "(perm \<bullet> P', perm \<bullet> (rev perm \<bullet> Q')) \<in> Rel'"
      by(rule eqvtRelI)
    hence "(perm \<bullet> P', Q') \<in> Rel'" by(simp add: name_per_rev)
    with L1 show ?case by blast
  next
    case(Input Q' a x)
    have Trans: "(perm \<bullet> Q) \<longmapsto>a<x> \<prec> Q'" and xFreshP: "x \<sharp> perm \<bullet> P" by fact+

    from Trans have "(rev perm \<bullet> (perm \<bullet> Q)) \<longmapsto> rev perm \<bullet> (a<x> \<prec> Q')"
      by(rule eqvts)
    hence "Q \<longmapsto> (rev perm \<bullet> a)<(rev perm \<bullet> x)> \<prec> (rev perm \<bullet> Q')"
      by(simp add: name_rev_per)
    moreover from xFreshP have xFreshP: "(rev perm \<bullet> x) \<sharp> P" by(simp add: name_fresh_left)
    ultimately have "\<exists>P''. \<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>(rev perm \<bullet> a)<(rev perm \<bullet> x)> \<prec> P' \<and> (P', (rev perm \<bullet> Q')[(rev perm \<bullet> x)::=u]) \<in> Rel" using Sim
      by(force intro: simE)
    then obtain P'' where L1:  "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>(rev perm \<bullet> a)<(rev perm \<bullet> x)> \<prec> P' \<and> (P', (rev perm \<bullet> Q')[(rev perm \<bullet> x)::=u]) \<in> Rel"
      by blast
    have "\<forall>u. \<exists>P'. (perm \<bullet> P) \<Longrightarrow>\<^sub>lu in (perm \<bullet> P'')\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'"
    proof(rule allI)
      fix u
      from L1 obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l(rev perm \<bullet> u) in P''\<rightarrow>(rev perm \<bullet> a)<(rev perm \<bullet> x)> \<prec> P'"
                          and P'RelQ': "(P', (rev perm \<bullet> Q')[(rev perm \<bullet> x)::=(rev perm \<bullet> u)]) \<in> Rel" by blast
      from PTrans have "(perm \<bullet> P) \<Longrightarrow>\<^sub>l(perm \<bullet> (rev perm \<bullet> u)) in (perm \<bullet> P'')\<rightarrow>(perm \<bullet> rev perm \<bullet> a)<(perm \<bullet> rev perm \<bullet> x)> \<prec> (perm \<bullet> P')"
        by(rule_tac Weak_Late_Step_Semantics.eqvtI, auto)
      hence L2: "(perm \<bullet> P) \<Longrightarrow>\<^sub>lu in (perm \<bullet> P'')\<rightarrow>a<x> \<prec> (perm \<bullet> P')" by(simp add: name_per_rev)
      from P'RelQ' RelRel' have "(P', (rev perm \<bullet> Q')[(rev perm \<bullet> x)::=(rev perm \<bullet> u)]) \<in> Rel'" by blast
      with EqvtRel' have "(perm \<bullet> P', perm \<bullet> ((rev perm \<bullet> Q')[(rev perm \<bullet> x)::=(rev perm \<bullet> u)])) \<in> Rel'"
        by(rule eqvtRelI)
      hence "(perm \<bullet> P', Q'[x::=u]) \<in> Rel'" by(simp add: name_per_rev eqvt_subs[THEN sym] name_calc)
      with L2 show "\<exists>P'. (perm \<bullet> P) \<Longrightarrow>\<^sub>lu in (perm \<bullet> P'')\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel'" by blast
    qed

    thus ?case by blast
  next
    case(Free Q' \<alpha>)
    have Trans: "(perm \<bullet> Q) \<longmapsto> \<alpha> \<prec> Q'" by fact

    from Trans have "(rev perm \<bullet> (perm \<bullet> Q)) \<longmapsto> rev perm \<bullet> (\<alpha> \<prec> Q')"
      by(rule eqvts)
    hence "Q \<longmapsto> (rev perm \<bullet> \<alpha>) \<prec> (rev perm \<bullet> Q')"
      by(simp add: name_rev_per)
    with Sim have "(\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^ (rev perm \<bullet> \<alpha>) \<prec> P' \<and> (P', (rev perm \<bullet> Q')) \<in> Rel)"
      by(rule simE)
    then obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^ (rev perm \<bullet> \<alpha>) \<prec> P'" and PRel: "(P', (rev perm \<bullet> Q')) \<in> Rel" by blast
    from PTrans have "(perm \<bullet> P) \<Longrightarrow>\<^sub>l\<^sup>^ perm \<bullet> ((rev perm \<bullet> \<alpha>)\<prec> P')"
      by(rule Weak_Late_Semantics.eqvtI)
    hence L1: "(perm \<bullet> P) \<Longrightarrow>\<^sub>l\<^sup>^ \<alpha> \<prec> (perm \<bullet> P')" by(simp add: name_per_rev)
    from PRel EqvtRel' RelRel'  have "((perm \<bullet> P'), (perm \<bullet> (rev perm \<bullet> Q'))) \<in> Rel'"
      by(force intro: eqvtRelI)
    hence "((perm \<bullet> P'), Q') \<in> Rel'" by(simp add: name_per_rev)
    with L1 show ?case by blast
  qed
qed

(*****************Reflexivity and transitivity*********************)

lemma reflexive:
  fixes P   :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes "Id \<subseteq> Rel"

  shows "P \<leadsto>\<^sup>^<Rel> P"
using assms
by(auto intro: Weak_Late_Step_Semantics.singleActionChain
  simp add: simDef weakTransition_def)

  assumes QSimR: "Q \<leadsto>\<^sup>^<Rel'> R"
  and     Eqvt:  "eqvt Rel"
  and     Eqvt': "eqvt Rel''"
  and     Trans: "Rel O Rel' \<subseteq> Rel''"
  and     Sim:   "\<And>P Q. (P, Q) \<in> Rel \<Longrightarrow> P \<leadsto>\<^sup>^<Rel> Q"
  and     PRelQ: "(P, Q) \<in> Rel"

  shows "P \<leadsto>\<^sup>^<Rel''> R"
proof -
  from PRelQ have PSimQ: "P \<leadsto>\<^sup>^<Rel> Q" by(rule Sim)
  from Eqvt' show ?thesis
  proof(induct rule: simCasesCont[of _ "(P, Q)"])
    case(Bound R' a x)
    have RTrans: "R \<longmapsto> a<\<nu>x> \<prec> R'" by fact
    have "x \<sharp> (P, Q)" by fact
    hence xFreshP: "x \<sharp> P" and xFreshQ: "x \<sharp> Q" by(simp add: fresh_prod)+

    from QSimR RTrans xFreshQ have "\<exists>Q'. Q \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> Q' \<and> (Q', R') \<in> Rel'"
      by(rule simE)
    then obtain Q' where QTrans: "Q \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> Q'" and Q'RelR': "(Q', R') \<in> Rel'" by blast
    from PSimQ Sim Eqvt PRelQ QTrans xFreshP have "\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel"
      by(rule simE2)
    then obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel" by blast
    moreover from P'RelQ' Q'RelR' Trans have "(P', R') \<in> Rel''" by blast
    ultimately show ?case by blast
  next
    case(Input R' a x)
    have RTrans: "R \<longmapsto> a<x> \<prec> R'" by fact
    have "x \<sharp> (P, Q)" by fact
    hence xFreshP: "x \<sharp> P" and xFreshQ: "x \<sharp> Q" by(simp add: fresh_prod)+

    from QSimR RTrans xFreshQ  obtain Q'' where "\<forall>u. \<exists>Q'. Q \<Longrightarrow>\<^sub>lu in Q''\<rightarrow>a<x> \<prec> Q' \<and> (Q', R'[x::=u]) \<in> Rel'"
      by(blast dest: simE)
    hence "\<exists>Q'''. Q \<Longrightarrow>\<^sub>\<tau> Q''' \<and> Q'''\<longmapsto>a<x> \<prec> Q'' \<and> (\<forall>u. \<exists>Q'. Q''[x::=u]\<Longrightarrow>\<^sub>\<tau> Q' \<and> (Q', R'[x::=u]) \<in> Rel')"
      by(simp add: inputTransition_def, blast)
    then obtain Q''' where QChain: "Q \<Longrightarrow>\<^sub>\<tau> Q'''"
                       and Q'''Trans: "Q''' \<longmapsto>a<x> \<prec> Q''"
                       and L1: "\<forall>u. \<exists>Q'. Q''[x::=u]\<Longrightarrow>\<^sub>\<tau> Q' \<and> (Q', R'[x::=u]) \<in> Rel'"
      by blast
    from QChain PRelQ Sim have "\<exists>P'''. P \<Longrightarrow>\<^sub>\<tau> P''' \<and> (P''', Q''') \<in> Rel"
      by(rule weakSimTauChain)
    then obtain P''' where PChain: "P \<Longrightarrow>\<^sub>\<tau> P'''" and P'''RelQ''': "(P''', Q''') \<in> Rel" by blast
    from PChain xFreshP have xFreshP''': "x \<sharp> P'''" by(rule freshChain)
    from P'''RelQ''' have "P''' \<leadsto>\<^sup>^<Rel> Q'''" by(rule Sim)
    hence "\<exists>P''''. \<forall>u. \<exists>P''. P''' \<Longrightarrow>\<^sub>lu in P''''\<rightarrow>a<x> \<prec> P'' \<and> (P'', Q''[x::=u]) \<in> Rel" using Q'''Trans xFreshP'''
      by(rule simE)
    then obtain P'''' where L2: "\<forall>u. \<exists>P''. P''' \<Longrightarrow>\<^sub>lu in P''''\<rightarrow>a<x> \<prec> P'' \<and> (P'', Q''[x::=u]) \<in> Rel"
      by blast
    have "\<forall>u. \<exists>P' Q'. P \<Longrightarrow>\<^sub>lu in P''''\<rightarrow>a<x> \<prec> P' \<and> (P', R'[x::=u]) \<in> Rel''"
    proof(rule allI)
      fix u
      from L1 obtain Q' where Q''Chain: "Q''[x::=u] \<Longrightarrow>\<^sub>\<tau> Q'" and Q'RelR': "(Q', R'[x::=u]) \<in> Rel'"
        by blast
      from L2 obtain P'' where P'''Trans: "P''' \<Longrightarrow>\<^sub>lu in P''''\<rightarrow>a<x> \<prec> P''"
                           and P''RelQ'': "(P'', Q''[x::=u]) \<in> Rel"
        by blast
      from P''RelQ'' have "P'' \<leadsto>\<^sup>^<Rel> Q''[x::=u]" by(rule Sim)
      have "\<exists>P'. P'' \<Longrightarrow>\<^sub>\<tau> P' \<and> (P', Q') \<in> Rel" using Q''Chain P''RelQ'' Sim
        by(rule weakSimTauChain)
      then obtain P' where P''Chain: "P'' \<Longrightarrow>\<^sub>\<tau> P'" and P'RelQ': "(P', Q') \<in> Rel" by blast
      from PChain P'''Trans P''Chain  have "P \<Longrightarrow>\<^sub>lu in P''''\<rightarrow>a<x> \<prec> P'"
        by(blast dest: Weak_Late_Step_Semantics.chainTransitionAppend)
      moreover from P'RelQ' Q'RelR' have "(P', R'[x::=u]) \<in> Rel''" by(insert Trans, auto)
      ultimately show "\<exists>P' Q'. P \<Longrightarrow>\<^sub>lu in P''''\<rightarrow>a<x> \<prec> P' \<and> (P', R'[x::=u]) \<in> Rel''" by blast
    qed
    thus ?case by force
  next
    case(Free R' \<alpha>)
    have RTrans: "R \<longmapsto> \<alpha> \<prec> R'" by fact
    with QSimR have "\<exists>Q'. Q \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> Q' \<and> (Q', R') \<in> Rel'" by(rule simE)
    then obtain Q' where QTrans: "Q \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> Q'" and Q'RelR': "(Q', R') \<in> Rel'" by blast
    from PSimQ Sim Eqvt PRelQ QTrans have "\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P' \<and> (P', Q') \<in> Rel" by(rule simE2)
    then obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel" by blast
    from P'RelQ' Q'RelR' Trans have "(P', R') \<in> Rel''" by blast
    with PTrans show "\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P' \<and> (P', R') \<in> Rel''" by blast
  qed
qed

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

  assumes PSimQ: "P \<leadsto>[Rel] Q"

  shows "P \<leadsto>\<^sup>^<Rel> Q"
proof(induct rule: simCases)
  case(Bound Q' a x)
  have "Q \<longmapsto>a<\<nu>x> \<prec> Q'" and "x \<sharp> P" by fact+
  with PSimQ obtain P' where PTrans: "P \<longmapsto>a<\<nu>x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
    by(force dest: Strong_Late_Sim.simE simp add: derivative_def)

  from PTrans have "P \<Longrightarrow>\<^sub>l\<^sup>^a<\<nu>x> \<prec> P'"
    by(force intro: Weak_Late_Step_Semantics.singleActionChain simp add: weakTransition_def)
  with P'RelQ' show ?case by blast
next
  case(Input Q' a x)
  assume "Q \<longmapsto>a<x> \<prec> Q'" and "x \<sharp> P"
  with PSimQ obtain P' where PTrans: "P \<longmapsto>a<x> \<prec> P'" and PDer: "derivative P' Q' (InputS a) x Rel"
    by(blast dest: Strong_Late_Sim.simE)

  have "\<forall>u. \<exists>P''. P \<Longrightarrow>\<^sub>lu in P'\<rightarrow>a<x> \<prec> P'' \<and> (P'', Q'[x::=u]) \<in> Rel"
  proof(rule allI)
    fix u
    from PTrans have "P \<Longrightarrow>\<^sub>lu in P'\<rightarrow>a<x> \<prec> P'[x::=u]" by(blast intro: Weak_Late_Step_Semantics.singleActionChain)
    moreover from PDer have "(P'[x::=u], Q'[x::=u]) \<in> Rel" by(force simp add: derivative_def)
    ultimately show "\<exists>P''. P \<Longrightarrow>\<^sub>lu in P'\<rightarrow>a<x> \<prec> P'' \<and> (P'', Q'[x::=u]) \<in> Rel" by auto
  qed
  thus ?case by blast
next
  case(Free Q' \<alpha>)
  have "Q \<longmapsto>\<alpha> \<prec> Q'" by fact
  with PSimQ obtain P' where PTrans: "P \<longmapsto>\<alpha> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel"
    by(blast dest: Strong_Late_Sim.simE)
  from PTrans have "P \<Longrightarrow>\<^sub>l\<^sup>^\<alpha> \<prec> P'" by(rule Weak_Late_Semantics.singleActionChain)
  with P'RelQ' show ?case by blast
qed

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

  assumes PSimQ: "P \<leadsto>\<^sup>^<Rel> Q"
  and     QSimR: "Q \<leadsto>[Rel'] R"
  and     Eqvt'': "eqvt Rel''"
  and     Trans: "Rel O Rel' \<subseteq> Rel''"

  shows "P \<leadsto>\<^sup>^<Rel''> R"
proof -
  from Eqvt'' show ?thesis
  proof(induct rule: simCasesCont[of _ "(P, Q)"])
    case(Bound R' a x)
    have "x \<sharp> (P, Q)" by fact
    hence xFreshP: "x \<sharp> P" and xFreshQ: "x \<sharp> Q" by(simp add: fresh_prod)+
    have RTrans: "R \<longmapsto>a<\<nu>x> \<prec> R'" by fact
    from xFreshQ QSimR RTrans obtain Q' where QTrans: "Q \<longmapsto>a<\<nu>x> \<prec> Q'"
                                          and Q'Rel'R': "(Q', R') \<in> Rel'"
      by(force dest: Strong_Late_Sim.simE simp add: derivative_def)

    with PSimQ QTrans xFreshP have "\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^ a<\<nu>x> \<prec> P' \<and> (P', Q') \<in> Rel"
      by(blast intro: simE)
    then obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^ a<\<nu>x> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel" by blast
    moreover from P'RelQ' Q'Rel'R' Trans have "(P', R') \<in> Rel''" by blast
    ultimately show ?case by blast
  next
    case(Input R' a x)
    have RTrans: "R \<longmapsto> a<x> \<prec> R'" by fact
    have "x \<sharp> (P, Q)" by fact
    hence xFreshP: "x \<sharp> P" and xFreshQ: "x \<sharp> Q" by(simp add: fresh_prod)+

    from QSimR RTrans xFreshQ  obtain Q' where QTrans: "Q \<longmapsto>a<x> \<prec> Q'" and Q'Der: "derivative Q' R' (InputS a) x Rel'"
      by(blast dest: Strong_Late_Sim.simE)
    from QTrans PSimQ xFreshP obtain P'' where L2: "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', Q'[x::=u]) \<in> Rel"
      by(blast dest: simE)
    have "\<forall>u. \<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', R'[x::=u]) \<in> Rel''"
    proof(rule allI)
      fix u
      from L2 obtain P' where PTrans: "P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P'"
                          and P'RelQ': "(P', Q'[x::=u]) \<in> Rel"
        by blast
      moreover from Q'Der have "(Q'[x::=u], R'[x::=u]) \<in> Rel'" by(simp add: derivative_def)
      ultimately show "\<exists>P'. P \<Longrightarrow>\<^sub>lu in P''\<rightarrow>a<x> \<prec> P' \<and> (P', R'[x::=u]) \<in> Rel''" using Trans by blast
    qed
    thus ?case by force
  next
    case(Free R' \<alpha>)
    have RTrans: "R \<longmapsto> \<alpha> \<prec> R'" by fact
    with QSimR obtain Q' where QTrans: "Q \<longmapsto>\<alpha> \<prec> Q'" and Q'RelR': "(Q', R') \<in> Rel'"
      by(blast dest: Strong_Late_Sim.simE)
    from PSimQ QTrans have "\<exists>P'. P \<Longrightarrow>\<^sub>l\<^sup>^ \<alpha> \<prec> P' \<and> (P', Q') \<in> Rel"
      by(blast intro: simE)
    then obtain P' where PTrans: "P \<Longrightarrow>\<^sub>l\<^sup>^ \<alpha> \<prec> P'" and P'RelQ': "(P', Q') \<in> Rel" by blast
    from P'RelQ' Q'RelR' Trans have "(P', R') \<in> Rel''" by blast
    with PTrans show ?case by blast
  qed
qed

end