(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Permutations as abstract type\<close>

theory Perm
imports Main
begin

text \<open>
  This theory introduces basics about permutations, i.e. almost
  everywhere fix bijections.  But it is by no means complete.
  Grieviously missing are cycles since these would require more
  elaboration, e.g. the concept of distinct lists equivalent
  under rotation, which maybe would also deserve its own theory.
  But see theory @{text "src/HOL/ex/Perm_Fragments.thy"} for
  fragments on that.
\<close>

subsection \<open>Abstract type of permutations\<close>

typedef 'a perm = "{f :: 'a \<Rightarrow> 'a. bij f \<and> finite {a. f a \<noteq> a}}"
  morphisms "apply" Perm
proof
  show "id \<in> ?perm" by simp
qed

setup_lifting type_definition_perm

notation "apply" (infixl "\<langle>$\<rangle>" 999)
no_notation "apply" ("op \<langle>$\<rangle>")

lemma bij_apply [simp]:
  "bij (apply f)"
  using "apply" [of f] by simp

lemma perm_eqI:
  assumes "\<And>a. f \<langle>$\<rangle> a = g \<langle>$\<rangle> a"
  shows "f = g"
  using assms by transfer (simp add: fun_eq_iff)

lemma perm_eq_iff:
  "f = g \<longleftrightarrow> (\<forall>a. f \<langle>$\<rangle> a = g \<langle>$\<rangle> a)"
  by (auto intro: perm_eqI)

lemma apply_inj:
  "f \<langle>$\<rangle> a = f \<langle>$\<rangle> b \<longleftrightarrow> a = b"
  by (rule inj_eq) (rule bij_is_inj, simp)

lift_definition affected :: "'a perm \<Rightarrow> 'a set"
  is "\<lambda>f. {a. f a \<noteq> a}" .

lemma in_affected:
  "a \<in> affected f \<longleftrightarrow> f \<langle>$\<rangle> a \<noteq> a"
  by transfer simp

lemma finite_affected [simp]:
  "finite (affected f)"
  by transfer simp

lemma apply_affected [simp]:
  "f \<langle>$\<rangle> a \<in> affected f \<longleftrightarrow> a \<in> affected f"
proof transfer
  fix f :: "'a \<Rightarrow> 'a" and a :: 'a
  assume "bij f \<and> finite {b. f b \<noteq> b}"
  then have "bij f" by simp
  interpret bijection f by standard (rule \<open>bij f\<close>)
  have "f a \<in> {a. f a = a} \<longleftrightarrow> a \<in> {a. f a = a}" (is "?P \<longleftrightarrow> ?Q")
    by auto
  then show "f a \<in> {a. f a \<noteq> a} \<longleftrightarrow> a \<in> {a. f a \<noteq> a}"
    by simp
qed

lemma card_affected_not_one:
  "card (affected f) \<noteq> 1"
proof
  interpret bijection "apply f"
    by standard (rule bij_apply)
  assume "card (affected f) = 1"
  then obtain a where *: "affected f = {a}"
    by (rule card_1_singletonE)
  then have **: "f \<langle>$\<rangle> a \<noteq> a"
    by (simp add: in_affected [symmetric])
  with * have "f \<langle>$\<rangle> a \<notin> affected f"
    by simp
  then have "f \<langle>$\<rangle> (f \<langle>$\<rangle> a) = f \<langle>$\<rangle> a"
    by (simp add: in_affected)
  then have "inv (apply f) (f \<langle>$\<rangle> (f \<langle>$\<rangle> a)) = inv (apply f) (f \<langle>$\<rangle> a)"
    by simp
  with ** show False by simp
qed

subsection \<open>Identity, composition and inversion\<close>

instantiation Perm.perm :: (type) "{monoid_mult, inverse}"
begin

lift_definition one_perm :: "'a perm"
  is id
  by simp

lemma apply_one [simp]:
  "apply 1 = id"
  by (fact one_perm.rep_eq)

lemma affected_one [simp]:
  "affected 1 = {}"
  by transfer simp

lemma affected_empty_iff [simp]:
  "affected f = {} \<longleftrightarrow> f = 1"
  by transfer auto

lift_definition times_perm :: "'a perm \<Rightarrow> 'a perm \<Rightarrow> 'a perm"
  is comp
proof
  fix f g :: "'a \<Rightarrow> 'a"
  assume "bij f \<and> finite {a. f a \<noteq> a}"
    "bij g \<and>finite {a. g a \<noteq> a}"
  then have "finite ({a. f a \<noteq> a} \<union> {a. g a \<noteq> a})"
    by simp
  moreover have "{a. (f \<circ> g) a \<noteq> a} \<subseteq> {a. f a \<noteq> a} \<union> {a. g a \<noteq> a}"
    by auto
  ultimately show "finite {a. (f \<circ> g) a \<noteq> a}"
    by (auto intro: finite_subset)
qed (auto intro: bij_comp)

lemma apply_times:
  "apply (f * g) = apply f \<circ> apply g"
  by (fact times_perm.rep_eq)

lemma apply_sequence:
  "f \<langle>$\<rangle> (g \<langle>$\<rangle> a) = apply (f * g) a"
  by (simp add: apply_times)

lemma affected_times [simp]:
  "affected (f * g) \<subseteq> affected f \<union> affected g"
  by transfer auto

lift_definition inverse_perm :: "'a perm \<Rightarrow> 'a perm"
  is inv
proof transfer
  fix f :: "'a \<Rightarrow> 'a" and a
  assume "bij f \<and> finite {b. f b \<noteq> b}"
  then have "bij f" and fin: "finite {b. f b \<noteq> b}"
    by auto
  interpret bijection f by standard (rule \<open>bij f\<close>)
  from fin show "bij (inv f) \<and> finite {a. inv f a \<noteq> a}"
    by (simp add: bij_inv)
qed

instance
  by standard (transfer; simp add: comp_assoc)+

end

lemma apply_inverse:
  "apply (inverse f) = inv (apply f)"
  by (fact inverse_perm.rep_eq)

lemma affected_inverse [simp]:
  "affected (inverse f) = affected f"
proof transfer
  fix f :: "'a \<Rightarrow> 'a" and a
  assume "bij f \<and> finite {b. f b \<noteq> b}"
  then have "bij f" by simp
  interpret bijection f by standard (rule \<open>bij f\<close>)
  show "{a. inv f a \<noteq> a} = {a. f a \<noteq> a}"
    by simp
qed

global_interpretation perm: group times "1::'a perm" inverse
proof
  fix f :: "'a perm"
  show "1 * f = f"
    by transfer simp
  show "inverse f * f = 1"
  proof transfer
    fix f :: "'a \<Rightarrow> 'a" and a
    assume "bij f \<and> finite {b. f b \<noteq> b}"
    then have "bij f" by simp
    interpret bijection f by standard (rule \<open>bij f\<close>)
    show "inv f \<circ> f = id"
      by simp
  qed
qed

declare perm.inverse_distrib_swap [simp]

lemma perm_mult_commute:
  assumes "affected f \<inter> affected g = {}"
  shows "g * f = f * g"
proof (rule perm_eqI)
  fix a
  from assms have *: "a \<in> affected f \<Longrightarrow> a \<notin> affected g"
    "a \<in> affected g \<Longrightarrow> a \<notin> affected f" for a
    by auto
  consider "a \<in> affected f \<and> a \<notin> affected g
        \<and> f \<langle>$\<rangle> a \<in> affected f"
    | "a \<notin> affected f \<and> a \<in> affected g
        \<and> f \<langle>$\<rangle> a \<notin> affected f"
    | "a \<notin> affected f \<and> a \<notin> affected g"
    using assms by auto
  then show "(g * f) \<langle>$\<rangle> a = (f * g) \<langle>$\<rangle> a"
  proof cases
    case 1
    with * have "f \<langle>$\<rangle> a \<notin> affected g"
      by auto
    with 1 show ?thesis by (simp add: in_affected apply_times)
  next
    case 2
    with * have "g \<langle>$\<rangle> a \<notin> affected f"
      by auto
    with 2 show ?thesis by (simp add: in_affected apply_times)
  next
    case 3
    then show ?thesis by (simp add: in_affected apply_times)
  qed
qed

lemma apply_power:
  "apply (f ^ n) = apply f ^^ n"
  by (induct n) (simp_all add: apply_times)

lemma perm_power_inverse:
  "inverse f ^ n = inverse ((f :: 'a perm) ^ n)"
proof (induct n)
  case 0 then show ?case by simp
next
  case (Suc n)
  then show ?case
    unfolding power_Suc2 [of f] by simp
qed

subsection \<open>Orbit and order of elements\<close>

definition orbit :: "'a perm \<Rightarrow> 'a \<Rightarrow> 'a set"
where
  "orbit f a = range (\<lambda>n. (f ^ n) \<langle>$\<rangle> a)"

lemma in_orbitI:
  assumes "(f ^ n) \<langle>$\<rangle> a = b"
  shows "b \<in> orbit f a"
  using assms by (auto simp add: orbit_def)

lemma apply_power_self_in_orbit [simp]:
  "(f ^ n) \<langle>$\<rangle> a \<in> orbit f a"
  by (rule in_orbitI) rule

lemma in_orbit_self [simp]:
  "a \<in> orbit f a"
  using apply_power_self_in_orbit [of _ 0] by simp

lemma apply_self_in_orbit [simp]:
  "f \<langle>$\<rangle> a \<in> orbit f a"
  using apply_power_self_in_orbit [of _ 1] by simp

lemma orbit_not_empty [simp]:
  "orbit f a \<noteq> {}"
  using in_orbit_self [of a f] by blast

lemma not_in_affected_iff_orbit_eq_singleton:
  "a \<notin> affected f \<longleftrightarrow> orbit f a = {a}" (is "?P \<longleftrightarrow> ?Q")
proof
  assume ?P
  then have "f \<langle>$\<rangle> a = a"
    by (simp add: in_affected)
  then have "(f ^ n) \<langle>$\<rangle> a = a" for n
    by (induct n) (simp_all add: apply_times)
  then show ?Q
    by (auto simp add: orbit_def)
next
  assume ?Q
  then show ?P
    by (auto simp add: orbit_def in_affected dest: range_eq_singletonD [of _ _ 1])
qed

definition order :: "'a perm \<Rightarrow> 'a \<Rightarrow> nat"
where
  "order f = card \<circ> orbit f"

lemma orbit_subset_eq_affected:
  assumes "a \<in> affected f"
  shows "orbit f a \<subseteq> affected f"
proof (rule ccontr)
  assume "\<not> orbit f a \<subseteq> affected f"
  then obtain b where "b \<in> orbit f a" and "b \<notin> affected f"
    by auto
  then have "b \<in> range (\<lambda>n. (f ^ n) \<langle>$\<rangle> a)"
    by (simp add: orbit_def)
  then obtain n where "b = (f ^ n) \<langle>$\<rangle> a"
    by blast
  with \<open>b \<notin> affected f\<close>
  have "(f ^ n) \<langle>$\<rangle> a \<notin> affected f"
    by simp
  then have "f \<langle>$\<rangle> a \<notin> affected f"
    by (induct n) (simp_all add: apply_times)
  with assms show False
    by simp
qed

lemma finite_orbit [simp]:
  "finite (orbit f a)"
proof (cases "a \<in> affected f")
  case False then show ?thesis
    by (simp add: not_in_affected_iff_orbit_eq_singleton)
next
  case True then have "orbit f a \<subseteq> affected f"
    by (rule orbit_subset_eq_affected)
  then show ?thesis using finite_affected
    by (rule finite_subset)
qed

lemma orbit_1 [simp]:
  "orbit 1 a = {a}"
  by (auto simp add: orbit_def)

lemma order_1 [simp]:
  "order 1 a = 1"
  unfolding order_def by simp

lemma card_orbit_eq [simp]:
  "card (orbit f a) = order f a"
  by (simp add: order_def)

lemma order_greater_zero [simp]:
  "order f a > 0"
  by (simp only: card_gt_0_iff order_def comp_def) simp

lemma order_eq_one_iff:
  "order f a = Suc 0 \<longleftrightarrow> a \<notin> affected f" (is "?P \<longleftrightarrow> ?Q")
proof
  assume ?P then have "card (orbit f a) = 1"
    by simp
  then obtain b where "orbit f a = {b}"
    by (rule card_1_singletonE)
  with in_orbit_self [of a f]
    have "b = a" by simp
  with \<open>orbit f a = {b}\<close> show ?Q
    by (simp add: not_in_affected_iff_orbit_eq_singleton)
next
  assume ?Q
  then have "orbit f a = {a}"
    by (simp add: not_in_affected_iff_orbit_eq_singleton)
  then have "card (orbit f a) = 1"
    by simp
  then show ?P
    by simp
qed

lemma order_greater_eq_two_iff:
  "order f a \<ge> 2 \<longleftrightarrow> a \<in> affected f"
  using order_eq_one_iff [of f a]
  apply (auto simp add: neq_iff)
  using order_greater_zero [of f a]
  apply simp
  done

lemma order_less_eq_affected:
  assumes "f \<noteq> 1"
  shows "order f a \<le> card (affected f)"
proof (cases "a \<in> affected f")
  from assms have "affected f \<noteq> {}"
    by simp
  then obtain B b where "affected f = insert b B"
    by blast
  with finite_affected [of f] have "card (affected f) \<ge> 1"
    by (simp add: card_insert)
  case False then have "order f a = 1"
    by (simp add: order_eq_one_iff)
  with \<open>card (affected f) \<ge> 1\<close> show ?thesis
    by simp
next
  case True
  have "card (orbit f a) \<le> card (affected f)"
    by (rule card_mono) (simp_all add: True orbit_subset_eq_affected card_mono)
  then show ?thesis
    by simp
qed

lemma affected_order_greater_eq_two:
  assumes "a \<in> affected f"
  shows "order f a \<ge> 2"
proof (rule ccontr)
  assume "\<not> 2 \<le> order f a"
  then have "order f a < 2"
    by (simp add: not_le)
  with order_greater_zero [of f a] have "order f a = 1"
    by arith
  with assms show False
    by (simp add: order_eq_one_iff)
qed

lemma order_witness_unfold:
  assumes "n > 0" and "(f ^ n) \<langle>$\<rangle> a = a"
  shows "order f a = card ((\<lambda>m. (f ^ m) \<langle>$\<rangle> a) ` {0..<n})"
proof  -
  have "orbit f a = (\<lambda>m. (f ^ m) \<langle>$\<rangle> a) ` {0..<n}" (is "_ = ?B")
  proof (rule set_eqI, rule)
    fix b
    assume "b \<in> orbit f a"
    then obtain m where "(f ^ m) \<langle>$\<rangle> a = b"
      by (auto simp add: orbit_def)
    then have "b = (f ^ (m mod n + n * (m div n))) \<langle>$\<rangle> a"
      by simp
    also have "\<dots> = (f ^ (m mod n)) \<langle>$\<rangle> ((f ^ (n * (m div n))) \<langle>$\<rangle> a)"
      by (simp only: power_add apply_times) simp
    also have "(f ^ (n * q)) \<langle>$\<rangle> a = a" for q
      by (induct q)
        (simp_all add: power_add apply_times assms)
    finally have "b = (f ^ (m mod n)) \<langle>$\<rangle> a" .
    moreover from \<open>n > 0\<close>
    have "m mod n < n"
      by simp
    ultimately show "b \<in> ?B"
      by auto
  next
    fix b
    assume "b \<in> ?B"
    then obtain m where "(f ^ m) \<langle>$\<rangle> a = b"
      by blast
    then show "b \<in> orbit f a"
      by (rule in_orbitI)
  qed
  then have "card (orbit f a) = card ?B"
    by (simp only:)
  then show ?thesis
    by simp
qed

lemma inj_on_apply_range:
  "inj_on (\<lambda>m. (f ^ m) \<langle>$\<rangle> a) {..<order f a}"
proof -
  have "inj_on (\<lambda>m. (f ^ m) \<langle>$\<rangle> a) {..<n}"
    if "n \<le> order f a" for n
  using that proof (induct n)
    case 0 then show ?case by simp
  next
    case (Suc n)
    then have prem: "n < order f a"
      by simp
    with Suc.hyps have hyp: "inj_on (\<lambda>m. (f ^ m) \<langle>$\<rangle> a) {..<n}"
      by simp
    have "(f ^ n) \<langle>$\<rangle> a \<notin> (\<lambda>m. (f ^ m) \<langle>$\<rangle> a) ` {..<n}"
    proof
      assume "(f ^ n) \<langle>$\<rangle> a \<in> (\<lambda>m. (f ^ m) \<langle>$\<rangle> a) ` {..<n}"
      then obtain m where *: "(f ^ m) \<langle>$\<rangle> a = (f ^ n) \<langle>$\<rangle> a" and "m < n"
        by auto
      interpret bijection "apply (f ^ m)"
        by standard simp
      from \<open>m < n\<close> have "n = m + (n - m)"
        and nm: "0 < n - m" "n - m \<le> n"
        by arith+
      with * have "(f ^ m) \<langle>$\<rangle> a = (f ^ (m + (n - m))) \<langle>$\<rangle> a"
        by simp
      then have "(f ^ m) \<langle>$\<rangle> a = (f ^ m) \<langle>$\<rangle> ((f ^ (n - m)) \<langle>$\<rangle> a)"
        by (simp add: power_add apply_times)
      then have "(f ^ (n - m)) \<langle>$\<rangle> a = a"
        by simp
      with \<open>n - m > 0\<close>
      have "order f a = card ((\<lambda>m. (f ^ m) \<langle>$\<rangle> a) ` {0..<n - m})"
         by (rule order_witness_unfold)
      also have "card ((\<lambda>m. (f ^ m) \<langle>$\<rangle> a) ` {0..<n - m}) \<le> card {0..<n - m}"
        by (rule card_image_le) simp
      finally have "order f a \<le> n - m"
        by simp
      with prem show False by simp
    qed
    with hyp show ?case
      by (simp add: lessThan_Suc)
  qed
  then show ?thesis by simp
qed

lemma orbit_unfold_image:
  "orbit f a = (\<lambda>n. (f ^ n) \<langle>$\<rangle> a) ` {..<order f a}" (is "_ = ?A")
proof (rule sym, rule card_subset_eq)
  show "finite (orbit f a)"
    by simp
  show "?A \<subseteq> orbit f a"
    by (auto simp add: orbit_def)
  from inj_on_apply_range [of f a]
  have "card ?A = order f a"
    by (auto simp add: card_image)
  then show "card ?A = card (orbit f a)"
    by simp
qed

lemma in_orbitE:
  assumes "b \<in> orbit f a"
  obtains n where "b = (f ^ n) \<langle>$\<rangle> a" and "n < order f a"
  using assms unfolding orbit_unfold_image by blast

lemma apply_power_order [simp]:
  "(f ^ order f a) \<langle>$\<rangle> a = a"
proof -
  have "(f ^ order f a) \<langle>$\<rangle> a \<in> orbit f a"
    by simp
  then obtain n where
    *: "(f ^ order f a) \<langle>$\<rangle> a = (f ^ n) \<langle>$\<rangle> a"
    and "n < order f a"
    by (rule in_orbitE)
  show ?thesis
  proof (cases n)
    case 0 with * show ?thesis by simp
  next
    case (Suc m)
    from order_greater_zero [of f a]
      have "Suc (order f a - 1) = order f a"
      by arith
    from Suc \<open>n < order f a\<close>
      have "m < order f a"
      by simp
    with Suc *
    have "(inverse f) \<langle>$\<rangle> ((f ^ Suc (order f a - 1)) \<langle>$\<rangle> a) =
      (inverse f) \<langle>$\<rangle> ((f ^ Suc m) \<langle>$\<rangle> a)"
      by simp
    then have "(f ^ (order f a - 1)) \<langle>$\<rangle> a =
      (f ^ m) \<langle>$\<rangle> a"
      by (simp only: power_Suc apply_times)
        (simp add: apply_sequence mult.assoc [symmetric])
    with inj_on_apply_range
    have "order f a - 1 = m"
      by (rule inj_onD)
        (simp_all add: \<open>m < order f a\<close>)
    with Suc have "n = order f a"
      by auto
    with \<open>n < order f a\<close>
    show ?thesis by simp
  qed
qed

lemma apply_power_left_mult_order [simp]:
  "(f ^ (n * order f a)) \<langle>$\<rangle> a = a"
  by (induct n) (simp_all add: power_add apply_times)

lemma apply_power_right_mult_order [simp]:
  "(f ^ (order f a * n)) \<langle>$\<rangle> a = a"
  by (simp add: ac_simps)

lemma apply_power_mod_order_eq [simp]:
  "(f ^ (n mod order f a)) \<langle>$\<rangle> a = (f ^ n) \<langle>$\<rangle> a"
proof -
  have "(f ^ n) \<langle>$\<rangle> a = (f ^ (n mod order f a + order f a * (n div order f a))) \<langle>$\<rangle> a"
    by simp
  also have "\<dots> = (f ^ (n mod order f a) * f ^ (order f a * (n div order f a))) \<langle>$\<rangle> a"
    by (simp add: power_add [symmetric])
  finally show ?thesis
    by (simp add: apply_times)
qed

lemma apply_power_eq_iff:
  "(f ^ m) \<langle>$\<rangle> a = (f ^ n) \<langle>$\<rangle> a \<longleftrightarrow> m mod order f a = n mod order f a" (is "?P \<longleftrightarrow> ?Q")
proof
  assume ?Q
  then have "(f ^ (m mod order f a)) \<langle>$\<rangle> a = (f ^ (n mod order f a)) \<langle>$\<rangle> a"
    by simp
  then show ?P
    by simp
next
  assume ?P
  then have "(f ^ (m mod order f a)) \<langle>$\<rangle> a = (f ^ (n mod order f a)) \<langle>$\<rangle> a"
    by simp
  with inj_on_apply_range
  show ?Q
    by (rule inj_onD) simp_all
qed

lemma apply_inverse_eq_apply_power_order_minus_one:
  "(inverse f) \<langle>$\<rangle> a = (f ^ (order f a - 1)) \<langle>$\<rangle> a"
proof (cases "order f a")
  case 0 with order_greater_zero [of f a] show ?thesis
    by simp
next
  case (Suc n)
  moreover have "(f ^ order f a) \<langle>$\<rangle> a = a"
    by simp
  then have *: "(inverse f) \<langle>$\<rangle> ((f ^ order f a) \<langle>$\<rangle> a) = (inverse f) \<langle>$\<rangle> a"
    by simp
  ultimately show ?thesis
    by (simp add: apply_sequence mult.assoc [symmetric])
qed

lemma apply_inverse_self_in_orbit [simp]:
  "(inverse f) \<langle>$\<rangle> a \<in> orbit f a"
  using apply_inverse_eq_apply_power_order_minus_one [symmetric]
  by (rule in_orbitI)

lemma apply_inverse_power_eq:
  "(inverse (f ^ n)) \<langle>$\<rangle> a = (f ^ (order f a - n mod order f a)) \<langle>$\<rangle> a"
proof (induct n)
  case 0 then show ?case by simp
next
  case (Suc n)
  define m where "m = order f a - n mod order f a - 1"
  moreover have "order f a - n mod order f a > 0"
    by simp
  ultimately have *: "order f a - n mod order f a = Suc m"
    by arith
  moreover from * have m2: "order f a - Suc n mod order f a = (if m = 0 then order f a else m)"
    by (auto simp add: mod_Suc)
  ultimately show ?case
    using Suc
      by (simp_all add: apply_times power_Suc2 [of _ n] power_Suc [of _ m] del: power_Suc)
        (simp add: apply_sequence mult.assoc [symmetric])
qed

lemma apply_power_eq_self_iff:
  "(f ^ n) \<langle>$\<rangle> a = a \<longleftrightarrow> order f a dvd n"
  using apply_power_eq_iff [of f n a 0]
    by (simp add: mod_eq_0_iff_dvd)

lemma orbit_equiv:
  assumes "b \<in> orbit f a"
  shows "orbit f b = orbit f a" (is "?B = ?A")
proof
  from assms obtain n where "n < order f a" and b: "b = (f ^ n) \<langle>$\<rangle> a"
    by (rule in_orbitE)
  then show "?B \<subseteq> ?A"
    by (auto simp add: apply_sequence power_add [symmetric] intro: in_orbitI elim!: in_orbitE)
  from b have "(inverse (f ^ n)) \<langle>$\<rangle> b = (inverse (f ^ n)) \<langle>$\<rangle> ((f ^ n) \<langle>$\<rangle> a)"
    by simp
  then have a: "a = (inverse (f ^ n)) \<langle>$\<rangle> b"
    by (simp add: apply_sequence)
  then show "?A \<subseteq> ?B"
    apply (auto simp add: apply_sequence power_add [symmetric] intro: in_orbitI elim!: in_orbitE)
    unfolding apply_times comp_def apply_inverse_power_eq
    unfolding apply_sequence power_add [symmetric]
    apply (rule in_orbitI) apply rule
    done
qed

lemma orbit_apply [simp]:
  "orbit f (f \<langle>$\<rangle> a) = orbit f a"
  by (rule orbit_equiv) simp

lemma order_apply [simp]:
  "order f (f \<langle>$\<rangle> a) = order f a"
  by (simp only: order_def comp_def orbit_apply)

lemma orbit_apply_inverse [simp]:
  "orbit f (inverse f \<langle>$\<rangle> a) = orbit f a"
  by (rule orbit_equiv) simp

lemma order_apply_inverse [simp]:
  "order f (inverse f \<langle>$\<rangle> a) = order f a"
  by (simp only: order_def comp_def orbit_apply_inverse)

lemma orbit_apply_power [simp]:
  "orbit f ((f ^ n) \<langle>$\<rangle> a) = orbit f a"
  by (rule orbit_equiv) simp

lemma order_apply_power [simp]:
  "order f ((f ^ n) \<langle>$\<rangle> a) = order f a"
  by (simp only: order_def comp_def orbit_apply_power)

lemma orbit_inverse [simp]:
  "orbit (inverse f) = orbit f"
proof (rule ext, rule set_eqI, rule)
  fix b a
  assume "b \<in> orbit f a"
  then obtain n where b: "b = (f ^ n) \<langle>$\<rangle> a" "n < order f a"
    by (rule in_orbitE)
  then have "b = apply (inverse (inverse f) ^ n) a"
    by simp
  then have "b = apply (inverse (inverse f ^ n)) a"
    by (simp add: perm_power_inverse)
  then have "b = apply (inverse f ^ (n * (order (inverse f ^ n) a - 1))) a"
    by (simp add: apply_inverse_eq_apply_power_order_minus_one power_mult)
  then show "b \<in> orbit (inverse f) a"
    by simp
next
  fix b a
  assume "b \<in> orbit (inverse f) a"
  then show "b \<in> orbit f a"
    by (rule in_orbitE)
      (simp add: apply_inverse_eq_apply_power_order_minus_one
      perm_power_inverse power_mult [symmetric])
qed

lemma order_inverse [simp]:
  "order (inverse f) = order f"
  by (simp add: order_def)

lemma orbit_disjoint:
  assumes "orbit f a \<noteq> orbit f b"
  shows "orbit f a \<inter> orbit f b = {}"
proof (rule ccontr)
  assume "orbit f a \<inter> orbit f b \<noteq> {}"
  then obtain c where "c \<in> orbit f a \<inter> orbit f b"
    by blast
  then have "c \<in> orbit f a" and "c \<in> orbit f b"
    by auto
  then obtain m n where "c = (f ^ m) \<langle>$\<rangle> a"
    and "c = apply (f ^ n) b" by (blast elim!: in_orbitE)
  then have "(f ^ m) \<langle>$\<rangle> a = apply (f ^ n) b"
    by simp
  then have "apply (inverse f ^ m) ((f ^ m) \<langle>$\<rangle> a) =
    apply (inverse f ^ m) (apply (f ^ n) b)"
    by simp
  then have *: "apply (inverse f ^ m * f ^ n) b = a"
    by (simp add: apply_sequence perm_power_inverse)
  have "a \<in> orbit f b"
  proof (cases n m rule: linorder_cases)
    case equal with * show ?thesis
      by (simp add: perm_power_inverse)
  next
    case less
    moreover define q where "q = m - n"
    ultimately have "m = q + n" by arith
    with * have "apply (inverse f ^ q) b = a"
      by (simp add: power_add mult.assoc perm_power_inverse)
    then have "a \<in> orbit (inverse f) b"
      by (rule in_orbitI)
    then show ?thesis
      by simp
  next
    case greater
    moreover define q where "q = n - m"
    ultimately have "n = m + q" by arith
    with * have "apply (f ^ q) b = a"
      by (simp add: power_add mult.assoc [symmetric] perm_power_inverse)
    then show ?thesis
      by (rule in_orbitI)
  qed
  with assms show False
    by (auto dest: orbit_equiv)
qed

subsection \<open>Swaps\<close>

lift_definition swap :: "'a \<Rightarrow> 'a \<Rightarrow> 'a perm"  ("\<langle>_\<leftrightarrow>_\<rangle>")
  is "\<lambda>a b. Fun.swap a b id"
proof
  fix a b :: 'a
  have "{c. Fun.swap a b id c \<noteq> c} \<subseteq> {a, b}"
    by (auto simp add: Fun.swap_def)
  then show "finite {c. Fun.swap a b id c \<noteq> c}"
    by (rule finite_subset) simp
qed simp

lemma apply_swap_simp [simp]:
  "\<langle>a\<leftrightarrow>b\<rangle> \<langle>$\<rangle> a = b"
  "\<langle>a\<leftrightarrow>b\<rangle> \<langle>$\<rangle> b = a"
  by (transfer; simp)+

lemma apply_swap_same [simp]:
  "c \<noteq> a \<Longrightarrow> c \<noteq> b \<Longrightarrow> \<langle>a\<leftrightarrow>b\<rangle> \<langle>$\<rangle> c = c"
  by transfer simp

lemma apply_swap_eq_iff [simp]:
  "\<langle>a\<leftrightarrow>b\<rangle> \<langle>$\<rangle> c = a \<longleftrightarrow> c = b"
  "\<langle>a\<leftrightarrow>b\<rangle> \<langle>$\<rangle> c = b \<longleftrightarrow> c = a"
  by (transfer; auto simp add: Fun.swap_def)+

lemma swap_1 [simp]:
  "\<langle>a\<leftrightarrow>a\<rangle> = 1"
  by transfer simp

lemma swap_sym:
  "\<langle>b\<leftrightarrow>a\<rangle> = \<langle>a\<leftrightarrow>b\<rangle>"
  by (transfer; auto simp add: Fun.swap_def)+

lemma swap_self [simp]:
  "\<langle>a\<leftrightarrow>b\<rangle> * \<langle>a\<leftrightarrow>b\<rangle> = 1"
  by transfer (simp add: Fun.swap_def fun_eq_iff)

lemma affected_swap:
  "a \<noteq> b \<Longrightarrow> affected \<langle>a\<leftrightarrow>b\<rangle> = {a, b}"
  by transfer (auto simp add: Fun.swap_def)

lemma inverse_swap [simp]:
  "inverse \<langle>a\<leftrightarrow>b\<rangle> = \<langle>a\<leftrightarrow>b\<rangle>"
  by transfer (auto intro: inv_equality simp: Fun.swap_def)

subsection \<open>Permutations specified by cycles\<close>

fun cycle :: "'a list \<Rightarrow> 'a perm"  ("\<langle>_\<rangle>")
where
  "\<langle>[]\<rangle> = 1"
| "\<langle>[a]\<rangle> = 1"
| "\<langle>a # b # as\<rangle> = \<langle>a # as\<rangle> * \<langle>a\<leftrightarrow>b\<rangle>"

text \<open>
  We do not continue and restrict ourselves to syntax from here.
  See also introductory note.
\<close>

subsection \<open>Syntax\<close>

bundle no_permutation_syntax
begin
  no_notation swap    ("\<langle>_\<leftrightarrow>_\<rangle>")
  no_notation cycle   ("\<langle>_\<rangle>")
  no_notation "apply" (infixl "\<langle>$\<rangle>" 999)
end

bundle permutation_syntax
begin
  notation swap       ("\<langle>_\<leftrightarrow>_\<rangle>")
  notation cycle      ("\<langle>_\<rangle>")
  notation "apply"    (infixl "\<langle>$\<rangle>" 999)
  no_notation "apply" ("op \<langle>$\<rangle>")
end

unbundle no_permutation_syntax

end


(*  Title:      ZF/Constructible/Normal.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>Closed Unbounded Classes and Normal Functions\<close>

theory Normal imports ZF begin

text\<open>
One source is the book

Frank R. Drake.
\emph{Set Theory: An Introduction to Large Cardinals}.
North-Holland, 1974.
\<close>

subsection \<open>Closed and Unbounded (c.u.) Classes of Ordinals\<close>

definition
  Closed :: "(i\<Rightarrow>o) \<Rightarrow> o" where
    "Closed(P) \<equiv> \<forall>I. I \<noteq> 0 \<longrightarrow> (\<forall>i\<in>I. Ord(i) \<and> P(i)) \<longrightarrow> P(\<Union>(I))"

definition
  Unbounded :: "(i\<Rightarrow>o) \<Rightarrow> o" where
    "Unbounded(P) \<equiv> \<forall>i. Ord(i) \<longrightarrow> (\<exists>j. i<j \<and> P(j))"

definition
  Closed_Unbounded :: "(i\<Rightarrow>o) \<Rightarrow> o" where
    "Closed_Unbounded(P) \<equiv> Closed(P) \<and> Unbounded(P)"

subsubsection\<open>Simple facts about c.u. classes\<close>

lemma ClosedI:
  "\<lbrakk>\<And>I. \<lbrakk>I \<noteq> 0; \<forall>i\<in>I. Ord(i) \<and> P(i)\<rbrakk> \<Longrightarrow> P(\<Union>(I))\<rbrakk>
      \<Longrightarrow> Closed(P)"
  by (simp add: Closed_def)

lemma ClosedD:
  "\<lbrakk>Closed(P); I \<noteq> 0; \<And>i. i\<in>I \<Longrightarrow> Ord(i); \<And>i. i\<in>I \<Longrightarrow> P(i)\<rbrakk>
      \<Longrightarrow> P(\<Union>(I))"
  by (simp add: Closed_def)

lemma UnboundedD:
  "\<lbrakk>Unbounded(P);  Ord(i)\<rbrakk> \<Longrightarrow> \<exists>j. i<j \<and> P(j)"
  by (simp add: Unbounded_def)

lemma Closed_Unbounded_imp_Unbounded: "Closed_Unbounded(C) \<Longrightarrow> Unbounded(C)"
  by (simp add: Closed_Unbounded_def)

text\<open>The universal class, V, is closed and unbounded.
      A bit odd, since C. U. concerns only ordinals, but it's used below!\<close>
theorem Closed_Unbounded_V [simp]: "Closed_Unbounded(\<lambda>x. True)"
  by (unfold Closed_Unbounded_def Closed_def Unbounded_def, blast)

text\<open>The class of ordinals, \<^term>\<open>Ord\<close>, is closed and unbounded.\<close>
theorem Closed_Unbounded_Ord   [simp]: "Closed_Unbounded(Ord)"
  by (unfold Closed_Unbounded_def Closed_def Unbounded_def, blast)

text\<open>The class of limit ordinals, \<^term>\<open>Limit\<close>, is closed and unbounded.\<close>
theorem Closed_Unbounded_Limit [simp]: "Closed_Unbounded(Limit)"
proof -
  have "\<exists>j. i < j \<and> Limit(j)" if "Ord(i)" for i
    apply (rule_tac x="i++nat" in exI)
    apply (blast intro: oadd_lt_self oadd_LimitI Limit_has_0 that)
    done
  then show ?thesis
    by (auto simp: Closed_Unbounded_def Closed_def Unbounded_def Limit_Union)
qed

text\<open>The class of cardinals, \<^term>\<open>Card\<close>, is closed and unbounded.\<close>
theorem Closed_Unbounded_Card  [simp]: "Closed_Unbounded(Card)"
proof -
  have "\<forall>i. Ord(i) \<longrightarrow> (\<exists>j. i < j \<and> Card(j))"
    by (blast intro: lt_csucc Card_csucc)
  then show ?thesis
    by (simp add: Closed_Unbounded_def Closed_def Unbounded_def)
qed

subsubsection\<open>The intersection of any set-indexed family of c.u. classes is
      c.u.\<close>

text\<open>The constructions below come from Kunen, \emph{Set Theory}, page 78.\<close>
locale cub_family =
  fixes P and A
  fixes next_greater \<comment> \<open>the next ordinal satisfying class \<^term>\<open>A\<close>\<close>
  fixes sup_greater  \<comment> \<open>sup of those ordinals over all \<^term>\<open>A\<close>\<close>
  assumes closed:    "a\<in>A \<Longrightarrow> Closed(P(a))"
      and unbounded: "a\<in>A \<Longrightarrow> Unbounded(P(a))"
      and A_non0: "A\<noteq>0"
  defines "next_greater(a,x) \<equiv> \<mu> y. x<y \<and> P(a,y)"
      and "sup_greater(x) \<equiv> \<Union>a\<in>A. next_greater(a,x)"

begin

text\<open>Trivial that the intersection is closed.\<close>
lemma Closed_INT: "Closed(\<lambda>x. \<forall>i\<in>A. P(i,x))"
  by (blast intro: ClosedI ClosedD [OF closed])

text\<open>All remaining effort goes to show that the intersection is unbounded.\<close>

lemma Ord_sup_greater:
  "Ord(sup_greater(x))"
  by (simp add: sup_greater_def next_greater_def)

lemma Ord_next_greater:
  "Ord(next_greater(a,x))"
  by (simp add: next_greater_def)

text\<open>\<^term>\<open>next_greater\<close> works as expected: it returns a larger value
and one that belongs to class \<^term>\<open>P(a)\<close>.\<close>
lemma
  assumes "Ord(x)" "a\<in>A"
  shows next_greater_in_P: "P(a, next_greater(a,x))"
    and next_greater_gt:   "x < next_greater(a,x)"
proof -
  obtain y where "x < y" "P(a,y)"
    using assms UnboundedD [OF unbounded] by blast
  then have "P(a, next_greater(a,x)) \<and> x < next_greater(a,x)"
    unfolding next_greater_def
    by (blast intro: LeastI2 lt_Ord2)
  then show "P(a, next_greater(a,x))" "x < next_greater(a,x)"
    by auto
qed

lemma sup_greater_gt:
  "Ord(x) \<Longrightarrow> x < sup_greater(x)"
  using A_non0 unfolding sup_greater_def
  by (blast intro: UN_upper_lt next_greater_gt Ord_next_greater)

lemma next_greater_le_sup_greater:
  "a\<in>A \<Longrightarrow> next_greater(a,x) \<le> sup_greater(x)"
  unfolding sup_greater_def
  by (force intro: UN_upper_le Ord_next_greater)

lemma omega_sup_greater_eq_UN:
  assumes "Ord(x)" "a\<in>A"
  shows "sup_greater^\<omega> (x) =
          (\<Union>n\<in>nat. next_greater(a, sup_greater^n (x)))"
proof (rule le_anti_sym)
  show "sup_greater^\<omega> (x) \<le> (\<Union>n\<in>nat. next_greater(a, sup_greater^n (x)))"
    using assms
    unfolding iterates_omega_def
    by (blast intro: leI le_implies_UN_le_UN next_greater_gt Ord_iterates Ord_sup_greater)
next
  have "Ord(\<Union>n\<in>nat. sup_greater^n (x))"
    by (blast intro: Ord_iterates Ord_sup_greater assms)
  moreover have "next_greater(a, sup_greater^n (x)) \<le>
             (\<Union>n\<in>nat. sup_greater^n (x))" if "n \<in> nat" for n
  proof (rule UN_upper_le)
    show "next_greater(a, sup_greater^n (x)) \<le> sup_greater^succ(n) (x)"
      using assms by (simp add: next_greater_le_sup_greater)
    show "Ord(\<Union>xa\<in>nat. sup_greater^xa (x))"
      using assms by (blast intro: Ord_iterates Ord_sup_greater)
  qed (use that in auto)
  ultimately
  show "(\<Union>n\<in>nat. next_greater(a, sup_greater^n (x))) \<le> sup_greater^\<omega> (x)"
    using assms unfolding iterates_omega_def by (blast intro: UN_least_le)
qed

lemma P_omega_sup_greater:
  "\<lbrakk>Ord(x); a\<in>A\<rbrakk> \<Longrightarrow> P(a, sup_greater^\<omega> (x))"
  apply (simp add: omega_sup_greater_eq_UN)
  apply (rule ClosedD [OF closed])
     apply (blast intro: ltD, auto)
   apply (blast intro: Ord_iterates Ord_next_greater Ord_sup_greater)
  apply (blast intro: next_greater_in_P Ord_iterates Ord_sup_greater)
  done

lemma omega_sup_greater_gt:
  "Ord(x) \<Longrightarrow> x < sup_greater^\<omega> (x)"
  apply (simp add: iterates_omega_def)
  apply (rule UN_upper_lt [of 1], simp_all)
   apply (blast intro: sup_greater_gt)
  apply (blast intro: Ord_iterates Ord_sup_greater)
  done

lemma Unbounded_INT: "Unbounded(\<lambda>x. \<forall>a\<in>A. P(a,x))"
    unfolding Unbounded_def
    by (blast intro!: omega_sup_greater_gt P_omega_sup_greater)

lemma Closed_Unbounded_INT:
  "Closed_Unbounded(\<lambda>x. \<forall>a\<in>A. P(a,x))"
  by (simp add: Closed_Unbounded_def Closed_INT Unbounded_INT)

end

theorem Closed_Unbounded_INT:
  assumes "\<And>a. a\<in>A \<Longrightarrow> Closed_Unbounded(P(a))"
  shows "Closed_Unbounded(\<lambda>x. \<forall>a\<in>A. P(a, x))"
proof (cases "A=0")
  case False
  with assms [unfolded Closed_Unbounded_def] show ?thesis
    by (intro cub_family.Closed_Unbounded_INT [OF cub_family.intro]) auto
qed auto

lemma Int_iff_INT2:
  "P(x) \<and> Q(x)  \<longleftrightarrow>  (\<forall>i\<in>2. (i=0 \<longrightarrow> P(x)) \<and> (i=1 \<longrightarrow> Q(x)))"
  by auto

theorem Closed_Unbounded_Int:
  "\<lbrakk>Closed_Unbounded(P); Closed_Unbounded(Q)\<rbrakk>
      \<Longrightarrow> Closed_Unbounded(\<lambda>x. P(x) \<and> Q(x))"
  unfolding Int_iff_INT2
  by (rule Closed_Unbounded_INT, auto)

subsection \<open>Normal Functions\<close>

definition
  mono_le_subset :: "(i\<Rightarrow>i) \<Rightarrow> o" where
    "mono_le_subset(M) \<equiv> \<forall>i j. i\<le>j \<longrightarrow> M(i) \<subseteq> M(j)"

definition
  mono_Ord :: "(i\<Rightarrow>i) \<Rightarrow> o" where
    "mono_Ord(F) \<equiv> \<forall>i j. i<j \<longrightarrow> F(i) < F(j)"

definition
  cont_Ord :: "(i\<Rightarrow>i) \<Rightarrow> o" where
    "cont_Ord(F) \<equiv> \<forall>l. Limit(l) \<longrightarrow> F(l) = (\<Union>i<l. F(i))"

definition
  Normal :: "(i\<Rightarrow>i) \<Rightarrow> o" where
    "Normal(F) \<equiv> mono_Ord(F) \<and> cont_Ord(F)"

subsubsection\<open>Immediate properties of the definitions\<close>

lemma NormalI:
  "\<lbrakk>\<And>i j. i<j \<Longrightarrow> F(i) < F(j);  \<And>l. Limit(l) \<Longrightarrow> F(l) = (\<Union>i<l. F(i))\<rbrakk>
      \<Longrightarrow> Normal(F)"
  by (simp add: Normal_def mono_Ord_def cont_Ord_def)

lemma mono_Ord_imp_Ord: "\<lbrakk>Ord(i); mono_Ord(F)\<rbrakk> \<Longrightarrow> Ord(F(i))"
  apply (auto simp add: mono_Ord_def)
  apply (blast intro: lt_Ord)
  done

lemma mono_Ord_imp_mono: "\<lbrakk>i<j; mono_Ord(F)\<rbrakk> \<Longrightarrow> F(i) < F(j)"
  by (simp add: mono_Ord_def)

lemma Normal_imp_Ord [simp]: "\<lbrakk>Normal(F); Ord(i)\<rbrakk> \<Longrightarrow> Ord(F(i))"
  by (simp add: Normal_def mono_Ord_imp_Ord)

lemma Normal_imp_cont: "\<lbrakk>Normal(F); Limit(l)\<rbrakk> \<Longrightarrow> F(l) = (\<Union>i<l. F(i))"
  by (simp add: Normal_def cont_Ord_def)

lemma Normal_imp_mono: "\<lbrakk>i<j; Normal(F)\<rbrakk> \<Longrightarrow> F(i) < F(j)"
  by (simp add: Normal_def mono_Ord_def)

lemma Normal_increasing:
  assumes i: "Ord(i)" and F: "Normal(F)" shows"i \<le> F(i)"
using i
proof (induct i rule: trans_induct3)
  case 0 thus ?case by (simp add: subset_imp_le F)
next
  case (succ i)
  hence "F(i) < F(succ(i))" using F
    by (simp add: Normal_def mono_Ord_def)
  thus ?case using succ.hyps
    by (blast intro: lt_trans1)
next
  case (limit l)
  hence "l = (\<Union>y<l. y)"
    by (simp add: Limit_OUN_eq)
  also have "... \<le> (\<Union>y<l. F(y))" using limit
    by (blast intro: ltD le_implies_OUN_le_OUN)
  finally have "l \<le> (\<Union>y<l. F(y))" .
  moreover have "(\<Union>y<l. F(y)) \<le> F(l)" using limit F
    by (simp add: Normal_imp_cont lt_Ord)
  ultimately show ?case
    by (blast intro: le_trans)
qed

subsubsection\<open>The class of fixedpoints is closed and unbounded\<close>

text\<open>The proof is from Drake, pages 113--114.\<close>

lemma mono_Ord_imp_le_subset: "mono_Ord(F) \<Longrightarrow> mono_le_subset(F)"
  apply (simp add: mono_le_subset_def, clarify)
  apply (subgoal_tac "F(i)\<le>F(j)", blast dest: le_imp_subset)
  apply (simp add: le_iff)
  apply (blast intro: lt_Ord2 mono_Ord_imp_Ord mono_Ord_imp_mono)
  done

text\<open>The following equation is taken for granted in any set theory text.\<close>
lemma cont_Ord_Union:
  "\<lbrakk>cont_Ord(F); mono_le_subset(F); X=0 \<longrightarrow> F(0)=0; \<forall>x\<in>X. Ord(x)\<rbrakk>
      \<Longrightarrow> F(\<Union>(X)) = (\<Union>y\<in>X. F(y))"
  apply (frule Ord_set_cases)
  apply (erule disjE, force)
  apply (thin_tac "X=0 \<longrightarrow> Q" for Q, auto)
  txt\<open>The trival case of \<^term>\<open>\<Union>X \<in> X\<close>\<close>
   apply (rule equalityI, blast intro: Ord_Union_eq_succD)
   apply (simp add: mono_le_subset_def UN_subset_iff le_subset_iff)
   apply (blast elim: equalityE)
  txt\<open>The limit case, \<^term>\<open>Limit(\<Union>X)\<close>:
@{subgoals[display,indent=0,margin=65]}
\<close>
  apply (simp add: OUN_Union_eq cont_Ord_def)
  apply (rule equalityI)
  txt\<open>First inclusion:\<close>
   apply (rule UN_least [OF OUN_least])
   apply (simp add: mono_le_subset_def, blast intro: leI)
  txt\<open>Second inclusion:\<close>
  apply (rule UN_least)
  apply (frule Union_upper_le, blast, blast)
  apply (erule leE, drule ltD, elim UnionE)
   apply (simp add: OUnion_def)
   apply blast+
  done

lemma Normal_Union:
  "\<lbrakk>X\<noteq>0; \<forall>x\<in>X. Ord(x); Normal(F)\<rbrakk> \<Longrightarrow> F(\<Union>(X)) = (\<Union>y\<in>X. F(y))"
  unfolding Normal_def
  by (blast intro: mono_Ord_imp_le_subset cont_Ord_Union)

lemma Normal_imp_fp_Closed: "Normal(F) \<Longrightarrow> Closed(\<lambda>i. F(i) = i)"
  apply (simp add: Closed_def ball_conj_distrib, clarify)
  apply (frule Ord_set_cases)
  apply (auto simp add: Normal_Union)
  done

lemma iterates_Normal_increasing:
  "\<lbrakk>n\<in>nat;  x < F(x);  Normal(F)\<rbrakk>
      \<Longrightarrow> F^n (x) < F^(succ(n)) (x)"
  by (induct n rule: nat_induct) (simp_all add: Normal_imp_mono)

lemma Ord_iterates_Normal:
     "\<lbrakk>n\<in>nat;  Normal(F);  Ord(x)\<rbrakk> \<Longrightarrow> Ord(F^n (x))"
by (simp)

text\<open>THIS RESULT IS UNUSED\<close>
lemma iterates_omega_Limit:
  "\<lbrakk>Normal(F);  x < F(x)\<rbrakk> \<Longrightarrow> Limit(F^\<omega> (x))"
  apply (frule lt_Ord)
  apply (simp add: iterates_omega_def)
  apply (rule increasing_LimitI)
    \<comment> \<open>this lemma is @{thm increasing_LimitI [no_vars]}\<close>
   apply (blast intro: UN_upper_lt [of "1"]   Normal_imp_Ord
      Ord_iterates lt_imp_0_lt
      iterates_Normal_increasing, clarify)
  apply (rule bexI)
   apply (blast intro: Ord_in_Ord [OF Ord_iterates_Normal])
  apply (rule UN_I, erule nat_succI)
  apply (blast intro:  iterates_Normal_increasing Ord_iterates_Normal
      ltD [OF lt_trans1, OF succ_leI, OF ltI])
  done

lemma iterates_omega_fixedpoint:
     "\<lbrakk>Normal(F); Ord(a)\<rbrakk> \<Longrightarrow> F(F^\<omega> (a)) = F^\<omega> (a)"
apply (frule Normal_increasing, assumption)
apply (erule leE)
 apply (simp_all add: iterates_omega_triv [OF sym])  (*for subgoal 2*)
apply (simp add:  iterates_omega_def Normal_Union)
apply (rule equalityI, force simp add: nat_succI)
txt\<open>Opposite inclusion:
@{subgoals[display,indent=0,margin=65]}
\<close>
apply clarify
apply (rule UN_I, assumption)
apply (frule iterates_Normal_increasing, assumption, assumption, simp)
apply (blast intro: Ord_trans ltD Ord_iterates_Normal Normal_imp_Ord [of F])
done

lemma iterates_omega_increasing:
     "\<lbrakk>Normal(F); Ord(a)\<rbrakk> \<Longrightarrow> a \<le> F^\<omega> (a)"
  by (simp add: iterates_omega_def UN_upper_le [of 0])

lemma Normal_imp_fp_Unbounded: "Normal(F) \<Longrightarrow> Unbounded(\<lambda>i. F(i) = i)"
apply (unfold Unbounded_def, clarify)
apply (rule_tac x="F^\<omega> (succ(i))" in exI)
apply (simp add: iterates_omega_fixedpoint)
apply (blast intro: lt_trans2 [OF _ iterates_omega_increasing])
done

theorem Normal_imp_fp_Closed_Unbounded:
     "Normal(F) \<Longrightarrow> Closed_Unbounded(\<lambda>i. F(i) = i)"
  by (simp add: Closed_Unbounded_def Normal_imp_fp_Closed Normal_imp_fp_Unbounded)

subsubsection\<open>Function \<open>normalize\<close>\<close>

text\<open>Function \<open>normalize\<close> maps a function \<open>F\<close> to a
      normal function that bounds it above.  The result is normal if and
      only if \<open>F\<close> is continuous: succ is not bounded above by any
      normal function, by @{thm [source] Normal_imp_fp_Unbounded}.
\<close>
definition
  normalize :: "[i\<Rightarrow>i, i] \<Rightarrow> i" where
    "normalize(F,a) \<equiv> transrec2(a, F(0), \<lambda>x r. F(succ(x)) \<union> succ(r))"

lemma Ord_normalize [simp, intro]:
     "\<lbrakk>Ord(a); \<And>x. Ord(x) \<Longrightarrow> Ord(F(x))\<rbrakk> \<Longrightarrow> Ord(normalize(F, a))"
proof (induct a rule: trans_induct3)
qed (simp_all add: ltD def_transrec2 [OF normalize_def])

lemma normalize_increasing:
  assumes ab: "a < b" and F: "\<And>x. Ord(x) \<Longrightarrow> Ord(F(x))"
  shows "normalize(F,a) < normalize(F,b)"
proof -
  { fix x
    have "Ord(b)" using ab by (blast intro: lt_Ord2)
    hence "x < b \<Longrightarrow> normalize(F,x) < normalize(F,b)"
    proof (induct b arbitrary: x rule: trans_induct3)
      case 0 thus ?case by simp
    next
      case (succ b)
      thus ?case
        by (auto simp add: le_iff def_transrec2 [OF normalize_def] intro: Un_upper2_lt F)
    next
      case (limit l)
      hence sc: "succ(x) < l"
        by (blast intro: Limit_has_succ)
      hence "normalize(F,x) < normalize(F,succ(x))"
        by (blast intro: limit elim: ltE)
      hence "normalize(F,x) < (\<Union>j<l. normalize(F,j))"
        by (blast intro: OUN_upper_lt lt_Ord F sc)
      thus ?case using limit
        by (simp add: def_transrec2 [OF normalize_def])
    qed
  } thus ?thesis using ab .
qed

theorem Normal_normalize:
  assumes "\<And>x. Ord(x) \<Longrightarrow> Ord(F(x))" shows "Normal(normalize(F))"
proof (rule NormalI)
  show "\<And>i j. i < j \<Longrightarrow> normalize(F,i) < normalize(F,j)"
    using assms by (blast intro!: normalize_increasing)
  show "\<And>l. Limit(l) \<Longrightarrow> normalize(F, l) = (\<Union>i<l. normalize(F,i))"
    by (simp add: def_transrec2 [OF normalize_def])
qed

theorem le_normalize:
  assumes a: "Ord(a)" and coF: "cont_Ord(F)" and F: "\<And>x. Ord(x) \<Longrightarrow> Ord(F(x))"
  shows "F(a) \<le> normalize(F,a)"
using a
proof (induct a rule: trans_induct3)
  case 0 thus ?case by (simp add: F def_transrec2 [OF normalize_def])
next
  case (succ a)
  thus ?case
    by (simp add: def_transrec2 [OF normalize_def] Un_upper1_le F )
next
  case (limit l)
  thus ?case using F coF [unfolded cont_Ord_def]
    by (simp add: def_transrec2 [OF normalize_def] le_implies_OUN_le_OUN ltD)
qed

subsection \<open>The Alephs\<close>
text \<open>This is the well-known transfinite enumeration of the cardinal
numbers.\<close>

definition
  Aleph :: "i \<Rightarrow> i"  (\<open>\<aleph>_\<close> [90] 90) where
    "Aleph(a) \<equiv> transrec2(a, nat, \<lambda>x r. csucc(r))"

lemma Card_Aleph [simp, intro]:
  "Ord(a) \<Longrightarrow> Card(Aleph(a))"
  apply (erule trans_induct3)
    apply (simp_all add: Card_csucc Card_nat Card_is_Ord
      def_transrec2 [OF Aleph_def])
  done

lemma Aleph_increasing:
  assumes ab: "a < b" shows "Aleph(a) < Aleph(b)"
proof -
  { fix x
    have "Ord(b)" using ab by (blast intro: lt_Ord2)
    hence "x < b \<Longrightarrow> Aleph(x) < Aleph(b)"
    proof (induct b arbitrary: x rule: trans_induct3)
      case 0 thus ?case by simp
    next
      case (succ b)
      thus ?case
        by (force simp add: le_iff def_transrec2 [OF Aleph_def]
                  intro: lt_trans lt_csucc Card_is_Ord)
    next
      case (limit l)
      hence sc: "succ(x) < l"
        by (blast intro: Limit_has_succ)
      hence "\<aleph> x < (\<Union>j<l. \<aleph>j)" using limit
        by (blast intro: OUN_upper_lt Card_is_Ord ltD lt_Ord)
      thus ?case using limit
        by (simp add: def_transrec2 [OF Aleph_def])
    qed
  } thus ?thesis using ab .
qed

theorem Normal_Aleph: "Normal(Aleph)"
proof (rule NormalI)
  show "\<And>i j. i < j \<Longrightarrow> \<aleph>i < \<aleph>j"
    by (blast intro!: Aleph_increasing)
  show "\<And>l. Limit(l) \<Longrightarrow> \<aleph>l = (\<Union>i<l. \<aleph>i)"
    by (simp add: def_transrec2 [OF Aleph_def])
qed

end


(*
  File:        Periodic_Bernpoly.thy
  Author:      Manuel Eberl <manuel@pruvisto.org>

  Definition of the periodic Bernoulli polynomials as required for the Euler-Maclaurin
  summation formula and Stirling's formula for the lnGamma function.
*)
section \<open>Periodic Bernoulli polynomials\<close>

theory Periodic_Bernpoly
imports
  Bernoulli
  "HOL-Library.Periodic_Fun"
begin

text \<open>
  Given the $n$-th Bernoulli polynomial $B_n(x)$, one can define the periodic function
  $P_n(x) = B_n(x - \lfloor x\rfloor)$, which shares many of the interesting properties of
  the Bernoulli polynomials. In particular, all $P_n(x)$ with $n\neq 1$ are continuous and
  if $n \geq 3$, they are continuously differentiable with $P_n'(x) = n P_{n-1}(x)$ just
  like the Bernoully polynomials themselves.

  These functions occur e.\,g.\ in the Euler--MacLaurin summation formula and Stirling's
  approximation for the logarithmic Gamma function.
\<close>

(* TODO Move to distribution *)
lemma frac_0 [simp]: "frac 0 = 0" by (simp add: frac_def)

lemma frac_eq_id: "x \<in> {0..<1} \<Longrightarrow> frac x = x"
  by (simp add: frac_eq)

lemma periodic_continuous_onI:
  fixes f :: "real \<Rightarrow> real"
  assumes periodic: "\<And>x. f (x + p) = f x" "p > 0"
  assumes cont: "continuous_on {a..a+p} f"
  shows   "continuous_on UNIV f"
unfolding continuous_on_def
proof safe
  fix x :: real
  interpret f: periodic_fun_simple f p by unfold_locales (rule periodic)

  have "continuous_on {a-p..a} (f \<circ> (\<lambda>x. x + p))"
    by (intro continuous_on_compose) (auto intro!: continuous_intros cont)
  also have "f \<circ> (\<lambda>x. x + p) = f" by (rule ext) (simp add: f.periodic_simps)
  finally have "continuous_on ({a-p..a} \<union> {a..a+p}) f" using cont
    by (intro continuous_on_closed_Un) simp_all
  also have "{a-p..a} \<union> {a..a+p} = {a-p..a+p}" by auto
  finally have "continuous_on {a-p..a+p} f" .
  hence cont: "continuous_on {a-p<..<a+p} f" by (rule continuous_on_subset) auto

  define n :: int where "n = \<lceil>(a - x) / p\<rceil>"
  have "(a - x) / p \<le> n" "n < (a - x) / p + 1" unfolding n_def by linarith+
  with \<open>p > 0\<close> have "x + n * p \<in> {a-p<..<a + p}" by (simp add: field_simps)
  with cont have "isCont f (x + n * p)"
    by (subst (asm) continuous_on_eq_continuous_at) auto
  hence *: "f \<midarrow>x+n*p\<rightarrow> f (x+n*p)" by (simp add: isCont_def f.periodic_simps)
  have "(\<lambda>x. f (x + n*p)) \<midarrow>x\<rightarrow> f (x+n*p)"
    by (intro tendsto_compose[OF *] tendsto_intros)
  thus "f \<midarrow>x\<rightarrow> f x" by (simp add: f.periodic_simps)
qed

lemma has_field_derivative_at_within_union:
  assumes "(f has_field_derivative D) (at x within A)"
          "(f has_field_derivative D) (at x within B)"
  shows   "(f has_field_derivative D) (at x within (A \<union> B))"
proof -
  from assms have "((\<lambda>y. (f y - f x) / (y - x)) \<longlongrightarrow> D) (sup (at x within A) (at x within B))"
    unfolding has_field_derivative_iff by (rule filterlim_sup)
  also have "sup (at x within A) (at x within B) = at x within (A \<union> B)"
    using at_within_union ..
  finally show ?thesis unfolding has_field_derivative_iff .
qed

lemma has_field_derivative_cong_ev':
  assumes "x = y"
    and *: "eventually (\<lambda>x. x \<in> s \<longrightarrow> f x = g x) (nhds x)"
    and "u = v" "s = t" "f x = g y"
  shows "(f has_field_derivative u) (at x within s) = (g has_field_derivative v) (at y within t)"
proof -
  have "(f has_field_derivative u) (at x within (s \<union> {x})) =
            (g has_field_derivative v) (at y within (s \<union> {x}))" using assms
    by (intro has_field_derivative_cong_ev) (auto elim!: eventually_mono)
  also from assms have "at x within (s \<union> {x}) = at x within s" by (simp add: at_within_def)
  also from assms have "at y within (s \<union> {x}) = at y within t" by (simp add: at_within_def)
  finally show ?thesis .
qed

interpretation frac: periodic_fun_simple' frac
  by unfold_locales (simp add: frac_def)

lemma tendsto_frac_at_right_0:
  "(frac \<longlongrightarrow> 0) (at_right (0 :: 'a :: {floor_ceiling,order_topology}))"
proof -
  have *: "eventually (\<lambda>x. x = frac x) (at_right (0::'a))"
    by (intro eventually_at_rightI[of 0 1]) (simp_all add: frac_eq eq_commute[of _ "frac x" for x])
  moreover have **: "((\<lambda>x::'a. x) \<longlongrightarrow> 0) (at_right 0)"
    by (rule tendsto_ident_at)
  ultimately show ?thesis by (blast intro: Lim_transform_eventually)
qed

lemma tendsto_frac_at_left_1:
  "(frac \<longlongrightarrow> 1) (at_left (1 :: 'a :: {floor_ceiling,order_topology}))"
proof -
  have *: "eventually (\<lambda>x. x = frac x) (at_left (1::'a))"
    by (intro eventually_at_leftI[of 0]) (simp_all add: frac_eq eq_commute[of _ "frac x" for x])
  moreover have **: "((\<lambda>x::'a. x) \<longlongrightarrow> 1) (at_left 1)"
    by (rule tendsto_ident_at)
  ultimately show ?thesis by (blast intro: Lim_transform_eventually)
qed

lemma continuous_on_frac [THEN continuous_on_subset, continuous_intros]:
  "continuous_on {0::'a::{floor_ceiling,order_topology}..<1} frac"
proof (subst continuous_on_cong[OF refl])
  fix x :: 'a assume "x \<in> {0..<1}"
  thus "frac x = x" by (simp add: frac_eq)
qed (auto intro: continuous_intros)

lemma isCont_frac [continuous_intros]:
  assumes "(x :: 'a :: {floor_ceiling,order_topology,t2_space}) \<in> {0<..<1}"
  shows   "isCont frac x"
proof -
  have "continuous_on {0<..<(1::'a)} frac" by (rule continuous_on_frac) auto
  with assms show ?thesis
    by (subst (asm) continuous_on_eq_continuous_at) auto
qed

lemma has_field_derivative_frac:
  assumes "(x::real) \<notin> \<int>"
  shows   "(frac has_field_derivative 1) (at x)"
proof -
  have "((\<lambda>t. t - of_int \<lfloor>x\<rfloor>) has_field_derivative 1) (at x)"
    by (auto intro!: derivative_eq_intros)
  also have "?this \<longleftrightarrow> ?thesis"
    using eventually_floor_eq[OF filterlim_ident assms]
    by (intro DERIV_cong_ev refl) (auto elim!: eventually_mono simp: frac_def)
  finally show ?thesis .
qed

lemmas has_field_derivative_frac' [derivative_intros] =
  DERIV_chain'[OF _ has_field_derivative_frac]

lemma continuous_on_compose_fracI:
  fixes f :: "real \<Rightarrow> real"
  assumes cont1: "continuous_on {0..1} f"
  assumes cont2: "f 0 = f 1"
  shows   "continuous_on UNIV (\<lambda>x. f (frac x))"
proof (rule periodic_continuous_onI)
  have cont: "continuous_on {0..1} (\<lambda>x. f (frac x))"
    unfolding continuous_on_def
  proof safe
    fix x :: real assume x: "x \<in> {0..1}"
    show "((\<lambda>x. f (frac x)) \<longlongrightarrow> f (frac x)) (at x within {0..1})"
    proof (cases "x = 1")
      case False
      with x have [simp]: "frac x = x" by (simp add: frac_eq)
      from x False have "eventually (\<lambda>x. x \<in> {..<1}) (nhds x)"
        by (intro eventually_nhds_in_open) auto
      hence "eventually (\<lambda>x. frac x = x) (at x within {0..1})"
        by (auto simp: eventually_at_filter frac_eq elim!: eventually_mono)
      hence "eventually (\<lambda>x. f x = f (frac x)) (at x within {0..1})"
        by eventually_elim simp
      moreover from cont1 x have "(f \<longlongrightarrow> f (frac x)) (at x within {0..1})"
        by (simp add: continuous_on_def)
      ultimately show "((\<lambda>x. f (frac x)) \<longlongrightarrow> f (frac x)) (at x within {0..1})"
        by (blast intro: Lim_transform_eventually)
    next
      case True
      from cont1 have **: "(f \<longlongrightarrow> f 1) (at 1 within {0..1})" by (simp add: continuous_on_def)
      moreover have *: "filterlim frac (at 1 within {0..1}) (at 1 within {0..1})"
      proof (subst filterlim_cong[OF refl refl])
        show "eventually (\<lambda>x. frac x = x) (at 1 within {0..1})"
          by (auto simp: eventually_at_filter frac_eq)
      qed (simp add: filterlim_ident)
      ultimately have "((\<lambda>x. f (frac x)) \<longlongrightarrow> f 1) (at 1 within {0..1})"
        by (rule filterlim_compose)
      thus ?thesis by (simp add: True cont2 frac_def)
    qed
  qed
  thus "continuous_on {0..0+1} (\<lambda>x. f (frac x))" by simp
qed (simp_all add: frac.periodic_simps)
(* END TODO *)

definition pbernpoly :: "nat \<Rightarrow> real \<Rightarrow> real" where
  "pbernpoly n x = bernpoly n (frac x)"

lemma pbernpoly_0 [simp]: "pbernpoly n 0 = bernoulli n"
  by (simp add: pbernpoly_def)

lemma pbernpoly_eq_bernpoly: "x \<in> {0..<1} \<Longrightarrow> pbernpoly n x = bernpoly n x"
  by (simp add: pbernpoly_def frac_eq_id)

interpretation pbernpoly: periodic_fun_simple' "pbernpoly n"
  by unfold_locales (simp add: pbernpoly_def frac.periodic_simps)

lemma continuous_on_pbernpoly [continuous_intros]:
  assumes "n \<noteq> 1"
  shows   "continuous_on A (pbernpoly n)"
proof (cases "n = 0")
  case True
  thus ?thesis by (auto intro: continuous_intros simp: pbernpoly_def bernpoly_def)
next
  case False
  with assms have n: "n \<ge> 2" by auto
  have "continuous_on UNIV (pbernpoly n)" unfolding pbernpoly_def [abs_def]
    by (rule continuous_on_compose_fracI)
       (insert n, auto intro!: continuous_intros simp: bernpoly_0 bernpoly_1)
  thus ?thesis by (rule continuous_on_subset) simp_all
qed

lemma continuous_on_pbernpoly' [continuous_intros]:
  assumes "n \<noteq> 1" "continuous_on A f"
  shows   "continuous_on A (\<lambda>x. pbernpoly n (f x))"
  using continuous_on_compose[OF assms(2) continuous_on_pbernpoly[OF assms(1)]]
  by (simp add: o_def)

lemma isCont_pbernpoly [continuous_intros]: "n \<noteq> 1 \<Longrightarrow> isCont (pbernpoly n) x"
  using continuous_on_pbernpoly[of n UNIV] by (simp add: continuous_on_eq_continuous_at)

lemma has_field_derivative_pbernpoly_Suc:
  assumes "n \<ge> 2 \<or> x \<notin> \<int>"
  shows   "(pbernpoly (Suc n) has_field_derivative real (Suc n) * pbernpoly n x) (at x)"
using assms
proof (cases "x \<in> \<int>")
  assume "x \<notin> \<int>"
  with assms show ?thesis unfolding pbernpoly_def
    by (auto intro!: derivative_eq_intros simp del: of_nat_Suc)
next
  case True
  from True obtain k where k: "x = of_int k" by (auto elim: Ints_cases)
  have "(pbernpoly (Suc n) has_field_derivative real (Suc n) * pbernpoly n x)
          (at x within ({..<x} \<union> {x<..}))"
  proof (rule has_field_derivative_at_within_union)
    have "((\<lambda>x. bernpoly (Suc n) (x - of_int (k-1))) has_field_derivative
                  real (Suc n) * bernpoly n (x - of_int (k-1))) (at_left x)"
      by (auto intro!: derivative_eq_intros)
    also have "?this \<longleftrightarrow> (pbernpoly (Suc n) has_field_derivative
                            real (Suc n) * pbernpoly n x) (at_left x)" using assms
    proof (intro has_field_derivative_cong_ev' refl)
      have "\<forall>\<^sub>F y in nhds x. y \<in> {x - 1<..<x + 1}" by (intro eventually_nhds_in_open) simp_all
      thus "\<forall>\<^sub>F t in nhds x. t \<in> {..<x} \<longrightarrow> bernpoly (Suc n) (t - real_of_int (k - 1)) =
                pbernpoly (Suc n) t"
      proof (elim eventually_mono, safe)
        fix t assume "t < x" "t \<in> {x-1<..<x+1}"
        hence "frac t = t - real_of_int (k - 1)" using k
          by (subst frac_unique_iff) auto
        thus "bernpoly (Suc n) (t - real_of_int (k - 1)) = pbernpoly (Suc n) t"
          by (simp add: pbernpoly_def)
      qed
    qed (insert k, auto simp: pbernpoly_def bernpoly_1)
    finally show "(pbernpoly (Suc n) has_real_derivative
                      real (Suc n) * pbernpoly n x) (at_left x)" .
  next
    have "((\<lambda>x. bernpoly (Suc n) (x - of_int k)) has_field_derivative
                  real (Suc n) * bernpoly n (x - of_int k)) (at_right x)"
      by (auto intro!: derivative_eq_intros)
    also have "?this \<longleftrightarrow> (pbernpoly (Suc n) has_field_derivative
                            real (Suc n) * pbernpoly n x) (at_right x)" using assms
    proof (intro has_field_derivative_cong_ev' refl)
      have "\<forall>\<^sub>F y in nhds x. y \<in> {x - 1<..<x + 1}" by (intro eventually_nhds_in_open) simp_all
      thus "\<forall>\<^sub>F t in nhds x. t \<in> {x<..} \<longrightarrow> bernpoly (Suc n) (t - real_of_int k) =
                pbernpoly (Suc n) t"
      proof (elim eventually_mono, safe)
        fix t assume "t > x" "t \<in> {x-1<..<x+1}"
        hence "frac t = t - real_of_int k" using k
          by (subst frac_unique_iff) auto
        thus "bernpoly (Suc n) (t - real_of_int k) = pbernpoly (Suc n) t"
          by (simp add: pbernpoly_def)
      qed
    qed (insert k, auto simp: pbernpoly_def bernpoly_1)
    finally show "(pbernpoly (Suc n) has_real_derivative
                      real (Suc n) * pbernpoly n x) (at_right x)" .
  qed
  also have "{..<x} \<union> {x<..} = UNIV - {x}" by auto
  also have "at x within \<dots> = at x" by (simp add: at_within_def)
  finally show ?thesis .
qed

lemmas has_field_derivative_pbernpoly_Suc' =
  DERIV_chain'[OF _ has_field_derivative_pbernpoly_Suc]

lemma bounded_pbernpoly: obtains c where "\<And>x. norm (pbernpoly n x) \<le> c"
proof -
  have "\<exists>x\<in>{0..1}. \<forall>y\<in>{0..1}. norm (bernpoly n y :: real) \<le> norm (bernpoly n x :: real)"
    by (intro continuous_attains_sup) (auto intro!: continuous_intros)
  then obtain x where x:
    "\<And>y. y \<in> {0..1} \<Longrightarrow> norm (bernpoly n y :: real) \<le> norm (bernpoly n x :: real)"
    by blast
  have "norm (pbernpoly n y) \<le> norm (bernpoly n x :: real)" for y
    unfolding pbernpoly_def using frac_lt_1[of y] by (intro x) simp_all
  thus ?thesis by (rule that)
qed

end


(*:maxLineLen=78:*)

theory DeBruijn
  imports
    Main
    "HOL-Library.Lattice_Syntax"
begin

sledgehammer_params [smt_proofs = false]

declare [[syntax_ambiguity_warning = false]]

section \<open>The Untyped \<lambda>-Calculus With de Bruijn Indices\<close>
subsection \<open>Grammar\<close>

datatype dB =
    Variable    nat   ("\<langle>_\<rangle>" [100] 100)
  | Application dB dB (infixl "\<cdot>" 200)
  | Abstraction dB    ("\<^bold>\<lambda>")

subsection \<open>Substitution\<close>

primrec
  lift :: "dB \<Rightarrow> nat \<Rightarrow> dB"
where
    "lift (\<langle>i\<rangle>) k = (if i < k then \<langle>i\<rangle> else \<langle>(i + 1)\<rangle>)"
  | "lift (s \<cdot> t) k = lift s k \<cdot> lift t k"
  | "lift (\<^bold>\<lambda> s) k = \<^bold>\<lambda> (lift s (k + 1))"

primrec
  subst :: "dB \<Rightarrow> nat \<Rightarrow> dB \<Rightarrow> dB"  ("_[_ '\<^bold>\<mapsto> _]" [300, 0, 0] 300)
  where
    subst_Var: "(\<langle>i\<rangle>)[k \<^bold>\<mapsto> s] =
      (if k < i then \<langle>(i - 1)\<rangle> else if i = k then s else \<langle>i\<rangle>)"
  | subst_App: "(t \<cdot> u)[k \<^bold>\<mapsto> s] = t[k \<^bold>\<mapsto> s] \<cdot> u[k \<^bold>\<mapsto> s]"
  | subst_Abs: "(\<^bold>\<lambda> t)[k \<^bold>\<mapsto> s] = \<^bold>\<lambda> (t [k + 1 \<^bold>\<mapsto> lift s 0])"

declare subst_Var [simp del]
declare if_not_P [simp] not_less_eq [simp]

subsection \<open>Derived Substitution Rules\<close>

lemma subst_eq [simp]: "(\<langle>k\<rangle>)[k \<^bold>\<mapsto> u] = u"
  by (simp add: subst_Var)

lemma subst_gt [simp]: "i < j \<Longrightarrow> (\<langle>j\<rangle>)[i \<^bold>\<mapsto> u] = \<langle>(j - 1)\<rangle>"
  by (simp add: subst_Var)

lemma subst_lt [simp]: "j < i \<Longrightarrow> (\<langle>j\<rangle>)[i \<^bold>\<mapsto> u] = \<langle>j\<rangle>"
  by (simp add: subst_Var)

lemma lift_lift:
    "i < k + 1 \<Longrightarrow> lift (lift t i) (Suc k) = lift (lift t k) i"
  by (induct t arbitrary: i k) auto

lemma lift_subst [simp]:
    "j < i + 1 \<Longrightarrow> lift (t[j \<^bold>\<mapsto> s]) i = (lift t (i + 1))[j \<^bold>\<mapsto> lift s i]"
  by (induct t arbitrary: i j s)
    (simp_all add: diff_Suc subst_Var lift_lift split: nat.split)

lemma lift_subst_lt:
    "i < j + 1 \<Longrightarrow> lift (t[j \<^bold>\<mapsto> s]) i = (lift t i)[j+1 \<^bold>\<mapsto> lift s i]"
  by (induct t arbitrary: i j s) (simp_all add: subst_Var lift_lift)

lemma subst_lift [simp]:
    "(lift t k)[k \<^bold>\<mapsto> s] = t"
  by (induct t arbitrary: k s) simp_all

lemma subst_subst:
    "i < j + 1 \<Longrightarrow> t[j+1 \<^bold>\<mapsto> lift v i][i \<^bold>\<mapsto> u[j \<^bold>\<mapsto> v]] = t[i \<^bold>\<mapsto> u][j \<^bold>\<mapsto> v]"
  by (induct t arbitrary: i j u v)
    (simp_all
      add: diff_Suc subst_Var lift_lift [symmetric] lift_subst_lt
      split: nat.split)

subsection \<open>Small-Step \<beta>-Reduction\<close>

inductive beta :: "dB \<Rightarrow> dB \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>\<beta>" 50)
  where
    beta [simp, intro!]: "\<^bold>\<lambda> s \<cdot> t \<rightarrow>\<^sub>\<beta> s[0 \<^bold>\<mapsto> t]"
  | appL [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> s \<cdot> u \<rightarrow>\<^sub>\<beta> t \<cdot> u"
  | appR [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> u \<cdot> s \<rightarrow>\<^sub>\<beta> u \<cdot> t"
  | abs [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> \<^bold>\<lambda> s \<rightarrow>\<^sub>\<beta> \<^bold>\<lambda> t"

inductive_cases beta_cases [elim!]:
  "Var i \<rightarrow>\<^sub>\<beta> t"
  "\<^bold>\<lambda> r \<rightarrow>\<^sub>\<beta> s"
  "s \<cdot> t \<rightarrow>\<^sub>\<beta> u"

subsection \<open>Derived Small-Step \<beta>-Reduction Rules\<close>

theorem lift_preserves_beta [simp]:
    "r \<rightarrow>\<^sub>\<beta> s \<Longrightarrow> lift r i \<rightarrow>\<^sub>\<beta> lift s i"
  by (induct arbitrary: i set: beta) auto

theorem subst_preserves_beta [simp, intro!]:
    "r \<rightarrow>\<^sub>\<beta> s \<Longrightarrow> r[i \<^bold>\<mapsto> t] \<rightarrow>\<^sub>\<beta> s[i \<^bold>\<mapsto> t]"
  by (induct arbitrary: t i set: beta)
     (simp_all add: subst_subst [symmetric])

subsection \<open>Transitive \<beta>-Reduction\<close>

abbreviation
  beta_reds :: "dB \<Rightarrow> dB \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>\<beta>\<^sup>*" 50) where
  "s \<rightarrow>\<^sub>\<beta>\<^sup>* t == beta\<^sup>*\<^sup>* s t"

subsection \<open>Transitive \<beta>-Reduction Rules\<close>

lemma rtrancl_beta_Abs [intro!]:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<Longrightarrow> \<^bold>\<lambda> s \<rightarrow>\<^sub>\<beta>\<^sup>* \<^bold>\<lambda> s'"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_AppL:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<Longrightarrow> s \<cdot> t \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<cdot> t"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_AppR:
    "t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<Longrightarrow> s \<cdot> t \<rightarrow>\<^sub>\<beta>\<^sup>* s \<cdot> t'"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_App [intro]:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<Longrightarrow> t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<Longrightarrow> s \<cdot> t \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<cdot> t'"
  by (blast intro!: rtrancl_beta_AppL rtrancl_beta_AppR intro: rtranclp_trans)

theorem rtancl_lift_preserves_beta:
    "r \<rightarrow>\<^sub>\<beta>\<^sup>* s \<Longrightarrow> lift r i \<rightarrow>\<^sub>\<beta>\<^sup>* lift s i"
  by (induct rule: rtranclp.induct,
      blast,
      simp add: rtranclp.rtrancl_into_rtrancl)

theorem rtrancl_subst_preserves_beta:
    "r \<rightarrow>\<^sub>\<beta>\<^sup>* s \<Longrightarrow> r[i \<^bold>\<mapsto> t] \<rightarrow>\<^sub>\<beta>\<^sup>* s[i \<^bold>\<mapsto> t]"
  by (induct rule: rtranclp.induct,
      blast,
      meson rtranclp.simps subst_preserves_beta)

theorem rtancl_subst_preserves_beta_inner:
    "r \<rightarrow>\<^sub>\<beta>\<^sup>* s \<Longrightarrow> t[i \<^bold>\<mapsto> r] \<rightarrow>\<^sub>\<beta>\<^sup>* t[i \<^bold>\<mapsto> s]"
proof -
  {
    fix r s t
    have "r \<rightarrow>\<^sub>\<beta> s \<Longrightarrow> t[i \<^bold>\<mapsto> r] \<rightarrow>\<^sub>\<beta>\<^sup>* t[i \<^bold>\<mapsto> s]"
      by (induct t arbitrary: r s i,
          simp add: subst_Var r_into_rtranclp,
          simp add: rtrancl_beta_App,
          simp add: rtrancl_beta_Abs)
  } note \<dagger> = this
  show "r \<rightarrow>\<^sub>\<beta>\<^sup>* s \<Longrightarrow> t[i \<^bold>\<mapsto> r] \<rightarrow>\<^sub>\<beta>\<^sup>* t[i \<^bold>\<mapsto> s]"
    by (induct rule: rtranclp.induct,
        blast,
        metis \<dagger> rtranclp.rtrancl_into_rtrancl rtranclp_idemp)
qed

subsection \<open>Confluence Principles\<close>

subsubsection \<open>Definitions\<close>

definition square where
  "square R S T U = (\<forall>x y. R x y \<longrightarrow> (\<forall>z. S x z \<longrightarrow> (\<exists>u. T y u \<and> U z u)))"

definition commute where
  "commute R S = square R S S R"

definition diamond where
  "diamond R = commute R R"

abbreviation confluent where
  "confluent R \<equiv> diamond (R\<^sup>*\<^sup>*)"

abbreviation weakly_confluent where
  "weakly_confluent R \<equiv> square R R (R\<^sup>*\<^sup>*) (R\<^sup>*\<^sup>*)"

no_notation converse ("(_\<inverse>)" [1000] 999)
notation conversep  ("(_\<inverse>)" [1000] 1000)

definition
  Church_Rosser :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "Church_Rosser R =
    (\<forall>x y. (R \<squnion> R\<inverse>)\<^sup>*\<^sup>* x y \<longleftrightarrow> (\<exists>z. R\<^sup>*\<^sup>* x z \<and> R\<^sup>*\<^sup>* y z))"

subsubsection \<open>Church-Rosser Properties\<close>

lemma common_reduction_to_equiv:
  assumes
    "R\<^sup>*\<^sup>* x z"
    "R\<^sup>*\<^sup>* y z"
  shows "(R \<squnion> R\<inverse>)\<^sup>*\<^sup>* x y"
proof -
  have "(R \<squnion> R\<inverse>)\<^sup>*\<^sup>* x z"
    by (metis \<open>R\<^sup>*\<^sup>* x z\<close> mono_rtranclp sup2I1)
  moreover have "(R \<squnion> R\<inverse>)\<^sup>*\<^sup>* z y"
    by (metis (no_types, lifting)
          \<open>R\<^sup>*\<^sup>* y z\<close>
          conversep_conversep
          mono_rtranclp
          rtranclp_converseD
          sup2CI)
  ultimately show ?thesis
    by auto
qed

lemma Church_Rosser_alt_def:
  "Church_Rosser R =
    (\<forall>x y. (R \<squnion> R\<inverse>)\<^sup>*\<^sup>* x y \<longrightarrow> (\<exists>z. R\<^sup>*\<^sup>* x z \<and> R\<^sup>*\<^sup>* y z))"
  unfolding Church_Rosser_def
  by (rule iffI, blast, meson common_reduction_to_equiv)

lemma common_ancestor_to_equiv:
  assumes
    "R\<^sup>*\<^sup>* x y"
    "R\<^sup>*\<^sup>* x z"
  shows "(R \<squnion> R\<inverse>)\<^sup>*\<^sup>* y z"
proof -
  have "(R \<squnion> R\<inverse>)\<^sup>*\<^sup>* y x"
    by (meson
          \<open>R\<^sup>*\<^sup>* x y\<close>
          common_reduction_to_equiv
          rtranclp.rtrancl_refl)
  moreover have "(R \<squnion> R\<inverse>)\<^sup>*\<^sup>* x z"
    by (metis \<open>R\<^sup>*\<^sup>* x z\<close> mono_rtranclp sup2I1)
  ultimately show ?thesis by auto
qed

lemma Church_Rosser_confluent: "Church_Rosser R = confluent R"
unfolding square_def commute_def diamond_def Church_Rosser_alt_def
proof (rule iffI; (rule allI | rule impI)+ )
  fix x y z
  assume
    "\<forall>x y. (R \<squnion> R\<inverse>)\<^sup>*\<^sup>* x y \<longrightarrow> (\<exists>z. R\<^sup>*\<^sup>* x z \<and> R\<^sup>*\<^sup>* y z)"
    "R\<^sup>*\<^sup>* x y"
    "R\<^sup>*\<^sup>* x z"
  thus "\<exists>u. R\<^sup>*\<^sup>* y u \<and> R\<^sup>*\<^sup>* z u"
    by (meson common_ancestor_to_equiv)
next
  fix x y
  assume "(R \<squnion> R\<inverse>)\<^sup>*\<^sup>* x y"
         "\<forall>x y. R\<^sup>*\<^sup>* x y \<longrightarrow> (\<forall>z. R\<^sup>*\<^sup>* x z \<longrightarrow> (\<exists>u. R\<^sup>*\<^sup>* y u \<and> R\<^sup>*\<^sup>* z u))"
  thus "\<exists>z. R\<^sup>*\<^sup>* x z \<and> R\<^sup>*\<^sup>* y z"
    by (induct rule: rtranclp.induct)
       (auto, meson r_into_rtranclp rtranclp_trans)
qed

subsubsection \<open>Primitive Properties\<close>

lemma square_sym: "square R S T U \<Longrightarrow> square S R U T"
  by (metis (mono_tags, hide_lams) square_def)

lemma square_subset:
  assumes "square R S T U"
  and "T \<le> T'"
  shows "square R S T' U"
    using assms
    unfolding square_def
    by (meson predicate2D_conj)

lemma square_reflcl:
  assumes "square R S T (R\<^sup>=\<^sup>=)"
  and "S \<le> T"
  shows "square (R\<^sup>=\<^sup>=) S T (R\<^sup>=\<^sup>=)"
    using assms
    unfolding square_def
    by blast

lemma square_rtrancl:
  assumes "square R S S T"
  shows "square (R\<^sup>*\<^sup>*) S S (T\<^sup>*\<^sup>*)"
  unfolding square_def
proof (intro strip, erule rtranclp_induct)
  fix x y z
  assume "S x z"
  thus "\<exists>u. S x u \<and> T\<^sup>*\<^sup>* z u"
    by blast
next
  fix x y z y' z'
  assume "S x z"
         "R\<^sup>*\<^sup>* x y'"
         "R y' z'"
         "\<exists>u. S y' u \<and> T\<^sup>*\<^sup>* z u"
  thus "\<exists>u'. S z' u' \<and> T\<^sup>*\<^sup>* z u'"
    using \<open>square R S S T\<close>
    unfolding square_def
    by (meson rtranclp.rtrancl_into_rtrancl)
qed

lemma square_rtrancl_reflcl_commute:
  "square R S (S\<^sup>*\<^sup>*) (R\<^sup>=\<^sup>=) \<Longrightarrow> commute (R\<^sup>*\<^sup>*) (S\<^sup>*\<^sup>*)"
  unfolding commute_def
  by (metis
       predicate2I
       r_into_rtranclp
       rtranclp_idemp
       rtranclp_reflclp
       square_reflcl
       square_rtrancl
       square_sym)

lemma commute_sym: "commute R S \<Longrightarrow> commute S R"
  unfolding commute_def square_def
  by blast

lemma commute_rtrancl: "commute R S \<Longrightarrow> commute (R\<^sup>*\<^sup>*) (S\<^sup>*\<^sup>*)"
  unfolding commute_def
  by (blast intro: square_rtrancl square_sym)

lemma commute_Un:
  "commute R T \<Longrightarrow> commute S T \<Longrightarrow> commute (R \<squnion> S) T"
  unfolding commute_def square_def
  by (metis sup2CI sup2E)

lemma diamond_Un:
  assumes "diamond R"
  and "diamond S"
  and "commute R S"
  shows "diamond (sup R S)"
    using assms
    unfolding diamond_def
    by (blast intro: commute_Un commute_sym)

lemma diamond_confluent: "diamond R \<Longrightarrow> confluent R"
  unfolding diamond_def
  by (simp add: commute_rtrancl)

lemma square_reflcl_confluent:
    "square R R (R\<^sup>=\<^sup>=) (R\<^sup>=\<^sup>=) \<Longrightarrow> confluent R"
  unfolding diamond_def commute_def
  by (metis
       inf_sup_ord(3)
       rtranclp_reflclp
       square_reflcl
       square_rtrancl
       square_sym)

lemma confluent_Un:
  assumes "confluent R"
  and "confluent S"
  and "commute (R\<^sup>*\<^sup>*) (S\<^sup>*\<^sup>*)"
  shows "confluent (R \<squnion> S)"
    using assms
    by (metis diamond_Un diamond_confluent rtranclp_sup_rtranclp)

lemma diamond_to_confluence:
  assumes "diamond R"
  and "T \<le> R"
  and "R \<le> T\<^sup>*\<^sup>*"
  shows "confluent T"
    using assms diamond_confluent rtranclp_subset
    by fastforce

lemma basic_diamond_to_confluence:
  assumes "diamond R"
  and "T \<le> R"
  and "R \<le> T\<^sup>*\<^sup>*"
  shows "confluent R"
    using assms diamond_confluent rtranclp_subset
    by fastforce

theorem newman:
  assumes "wfP R\<inverse>"
  and "weakly_confluent R"
  shows "confluent R"
proof -
  {
    fix a b c
    have "R\<^sup>*\<^sup>* a b \<Longrightarrow> R\<^sup>*\<^sup>* a c \<Longrightarrow> \<exists>d. R\<^sup>*\<^sup>* b d \<and> R\<^sup>*\<^sup>* c d"
      using \<open>wfP R\<inverse>\<close>
    proof (induct arbitrary: b c)
      case (less x b c)
      have "R\<^sup>*\<^sup>* x c" by fact
      have "R\<^sup>*\<^sup>* x b" by fact
      thus ?case
      proof (rule converse_rtranclpE)
        assume "x = b"
        thus ?thesis
          using \<open>R\<^sup>*\<^sup>* x c\<close> by blast
      next
        fix y
        assume "R x y"
        and "R\<^sup>*\<^sup>* y b"
        from \<open>R\<^sup>*\<^sup>* x c\<close> show "\<exists>d. R\<^sup>*\<^sup>* b d \<and> R\<^sup>*\<^sup>* c d"
        proof (rule converse_rtranclpE)
          assume "x = c"
          thus ?thesis
            using \<open>R\<^sup>*\<^sup>* x b\<close> by blast
        next
          fix z
          assume "R\<^sup>*\<^sup>* z c" and "R x z"
          from this obtain u where "R\<^sup>*\<^sup>* y u" and "R\<^sup>*\<^sup>* z u"
            using \<open>weakly_confluent R\<close>
            unfolding square_def
            using \<open>R x y\<close> by blast
          from this  obtain v where "R\<^sup>*\<^sup>* b v" and "R\<^sup>*\<^sup>* u v"
            by (meson conversep.intros less.hyps \<open>R x y\<close> \<open>R\<^sup>*\<^sup>* y b\<close>)
          from this obtain w where "R\<^sup>*\<^sup>* v w" and "R\<^sup>*\<^sup>* c w"
            by (meson
                  \<open>R x z\<close>
                  \<open>R\<^sup>*\<^sup>* z c\<close>
                  \<open>R\<^sup>*\<^sup>* z u\<close>
                  conversep.intros
                  less.hyps
                  rtranclp_trans)
          thus ?thesis
            by (meson \<open>R\<^sup>*\<^sup>* b v\<close> rtranclp_trans)
        qed
      qed
    qed
  }
  thus ?thesis
    unfolding diamond_def commute_def square_def
    by auto
qed

section \<open>Confluence Of \<beta>-Reduction\<close>

text \<open>Here we present a proof of the confluence confluence of \<open>\<rightarrow>\<^sub>\<beta>\<close>.
      This proof is attributed to William Tait and Per Martin-Löf.
      The technique has been described in
      {@cite takahashiParallelReductionsLCalculus1995}\<close>

subsection \<open>Parallel Reduction\<close>

inductive par_beta :: "dB \<Rightarrow> dB \<Rightarrow> bool"  (infixl "\<Rrightarrow>\<^sub>\<beta>" 50)
  where
    var [simp, intro!]: "(\<langle>i\<rangle>) \<Rrightarrow>\<^sub>\<beta> (\<langle>i\<rangle>)"
  | abs [simp, intro!]: "s \<Rrightarrow>\<^sub>\<beta> t \<Longrightarrow> \<^bold>\<lambda> s \<Rrightarrow>\<^sub>\<beta> \<^bold>\<lambda> t"
  | app [simp, intro!]: "\<lbrakk> s \<Rrightarrow>\<^sub>\<beta> s'; t \<Rrightarrow>\<^sub>\<beta> t' \<rbrakk> \<Longrightarrow> s \<cdot> t \<Rrightarrow>\<^sub>\<beta> s' \<cdot> t'"
  | beta [simp, intro!]: "\<lbrakk> s \<Rrightarrow>\<^sub>\<beta> s'; t \<Rrightarrow>\<^sub>\<beta> t' \<rbrakk> \<Longrightarrow> (\<^bold>\<lambda> s) \<cdot> t \<Rrightarrow>\<^sub>\<beta> s'[0 \<^bold>\<mapsto> t']"

inductive_cases par_beta_cases [elim!]:
  "(\<langle>i\<rangle>) \<Rrightarrow>\<^sub>\<beta> t"
  "\<^bold>\<lambda> s \<Rrightarrow>\<^sub>\<beta> \<^bold>\<lambda> t"
  "(\<^bold>\<lambda> s) \<cdot> t \<Rrightarrow>\<^sub>\<beta> u"
  "s \<cdot> t \<Rrightarrow>\<^sub>\<beta> u"
  "\<^bold>\<lambda> s \<Rrightarrow>\<^sub>\<beta> t"

subsection \<open>Properties of Parallel Reduction\<close>

lemma par_beta_varL [simp]:
    "((\<langle>i\<rangle>) \<Rrightarrow>\<^sub>\<beta> t) = (t = (\<langle>i\<rangle>))"
  by blast

lemma par_beta_refl [simp]: "t \<Rrightarrow>\<^sub>\<beta> t"
  by (induct t) simp_all

lemma par_beta_lift [simp]:
    "t \<Rrightarrow>\<^sub>\<beta> t' \<Longrightarrow> lift t n \<Rrightarrow>\<^sub>\<beta> lift t' n"
  by (induct t arbitrary: t' n) fastforce+

lemma par_beta_subst:
    "s \<Rrightarrow>\<^sub>\<beta> s' \<Longrightarrow> t \<Rrightarrow>\<^sub>\<beta> t' \<Longrightarrow> t[n \<^bold>\<mapsto> s] \<Rrightarrow>\<^sub>\<beta> t'[n \<^bold>\<mapsto> s']"
  apply (induct t arbitrary: s s' t' n)
    apply (simp add: subst_Var)
   apply (erule par_beta_cases)
    apply (simp add: subst_subst [symmetric]
            | fastforce intro!: par_beta_lift)+
  done

subsection \<open>Parallel Reduction is Intermediate To
            Small-Step and Transitive \<beta>-reduction\<close>

lemma beta_subset_par_beta: "(\<rightarrow>\<^sub>\<beta>) \<le> (\<Rrightarrow>\<^sub>\<beta>)"
  by (rule predicate2I, erule beta.induct) simp_all

lemma beta_implies_par_beta: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> s \<Rrightarrow>\<^sub>\<beta> t"
  using beta_subset_par_beta by blast

lemma par_beta_subset_beta: "(\<Rrightarrow>\<^sub>\<beta>) \<le> (\<rightarrow>\<^sub>\<beta>\<^sup>*)"
  by (rule predicate2I, erule par_beta.induct)
     (blast, blast, blast,
        blast del: rtranclp.rtrancl_refl intro: rtranclp.rtrancl_into_rtrancl)

lemma par_beta_implies_transitive_beta: "s \<Rrightarrow>\<^sub>\<beta> t \<Longrightarrow> s \<rightarrow>\<^sub>\<beta>\<^sup>* t"
  using par_beta_subset_beta by blast

subsection \<open>Confluence Theorems Parallel Reduction And \<beta>-Reduction\<close>

lemma diamond_par_beta: "diamond (\<Rrightarrow>\<^sub>\<beta>)"
  apply (unfold diamond_def commute_def square_def)
  apply (rule impI [THEN allI [THEN allI]])
  apply (erule par_beta.induct)
     apply (blast intro!: par_beta_subst)+
  done

lemma par_beta_confluent: "confluent (\<Rrightarrow>\<^sub>\<beta>)"
  by (simp add: diamond_confluent diamond_par_beta)

lemma beta_confluent: "confluent (\<rightarrow>\<^sub>\<beta>)"
  using
    beta_subset_par_beta
    diamond_par_beta
    diamond_to_confluence
    par_beta_subset_beta
  by blast

section \<open>Equational Theory\<close>

inductive beta_equiv :: "dB \<Rightarrow> dB \<Rightarrow> bool"  (infixl "\<approx>\<^sub>\<beta>" 40) where
    refl [simp]: "t \<approx>\<^sub>\<beta> t"
  | subst [simp]: "(\<^bold>\<lambda> s) \<cdot> t \<approx>\<^sub>\<beta> s [ 0 \<^bold>\<mapsto> t]"
  | abs [simp]: "s \<approx>\<^sub>\<beta> t \<Longrightarrow> \<^bold>\<lambda> s \<approx>\<^sub>\<beta> \<^bold>\<lambda> t"
  | symm: "s \<approx>\<^sub>\<beta> t \<Longrightarrow> t \<approx>\<^sub>\<beta> s"
  | app [simp]: "s \<approx>\<^sub>\<beta> t \<Longrightarrow> p \<approx>\<^sub>\<beta> q \<Longrightarrow> s \<cdot> p \<approx>\<^sub>\<beta> t \<cdot> q"
  | trans [simp]: "s \<approx>\<^sub>\<beta> t \<Longrightarrow> t \<approx>\<^sub>\<beta> u \<Longrightarrow> s \<approx>\<^sub>\<beta> u"

lemma beta_equiv_alt_def:
  "(s \<approx>\<^sub>\<beta> t) = ((\<rightarrow>\<^sub>\<beta>) \<squnion> (\<rightarrow>\<^sub>\<beta>)\<inverse>)\<^sup>*\<^sup>* s t"
proof (rule iffI)
  {
    fix s t
    have "((\<rightarrow>\<^sub>\<beta>) \<squnion> (\<rightarrow>\<^sub>\<beta>)\<inverse>)\<^sup>*\<^sup>* s t \<Longrightarrow> ((\<rightarrow>\<^sub>\<beta>) \<squnion> (\<rightarrow>\<^sub>\<beta>)\<inverse>)\<^sup>*\<^sup>* (\<^bold>\<lambda> s) (\<^bold>\<lambda> t)"
      by (induct set: rtranclp,
            blast,
            metis
              beta.abs
              conversep_iff
              rtranclp.rtrancl_into_rtrancl
              sup2CI
              sup2E)
  } note \<dagger> = this
  {
    fix s t p q
    {
      fix s t p
      have "((\<rightarrow>\<^sub>\<beta>) \<squnion> (\<rightarrow>\<^sub>\<beta>)\<inverse>)\<^sup>*\<^sup>* s t \<Longrightarrow> ((\<rightarrow>\<^sub>\<beta>) \<squnion> (\<rightarrow>\<^sub>\<beta>)\<inverse>)\<^sup>*\<^sup>* (s \<cdot> p) (t \<cdot> p)"
        by (induct set: rtranclp)
           (blast intro: rtranclp.rtrancl_into_rtrancl)+
    }
    moreover
    {
      fix s t p
      have "((\<rightarrow>\<^sub>\<beta>) \<squnion> (\<rightarrow>\<^sub>\<beta>)\<inverse>)\<^sup>*\<^sup>* s t \<Longrightarrow> ((\<rightarrow>\<^sub>\<beta>) \<squnion> (\<rightarrow>\<^sub>\<beta>)\<inverse>)\<^sup>*\<^sup>* (p \<cdot> s) (p \<cdot> t)"
        by (induct set: rtranclp)
           (blast intro: rtranclp.rtrancl_into_rtrancl)+
    }
    ultimately have
      "((\<rightarrow>\<^sub>\<beta>) \<squnion> (\<rightarrow>\<^sub>\<beta>)\<inverse>)\<^sup>*\<^sup>* s t \<Longrightarrow>
         ((\<rightarrow>\<^sub>\<beta>) \<squnion> (\<rightarrow>\<^sub>\<beta>)\<inverse>)\<^sup>*\<^sup>* p q \<Longrightarrow>
         ((\<rightarrow>\<^sub>\<beta>) \<squnion> (\<rightarrow>\<^sub>\<beta>)\<inverse>)\<^sup>*\<^sup>* (s \<cdot> p) (t \<cdot> q)"
      by (meson rtranclp_trans)
  } note \<ddagger> = this
  show "s \<approx>\<^sub>\<beta> t \<Longrightarrow> ((\<rightarrow>\<^sub>\<beta>) \<squnion> (\<rightarrow>\<^sub>\<beta>)\<inverse>)\<^sup>*\<^sup>* s t"
    by (induct set: beta_equiv,
          blast+,
          blast intro: \<dagger>,
          metis
            converse_join
            conversep_conversep
            rtranclp_converseD
            sup_commute,
          blast intro: \<ddagger>,
          auto)
next
  show "((\<rightarrow>\<^sub>\<beta>) \<squnion> (\<rightarrow>\<^sub>\<beta>)\<inverse>)\<^sup>*\<^sup>* s t \<Longrightarrow> s \<approx>\<^sub>\<beta> t"
  proof (induct set: rtranclp)
    show "s \<approx>\<^sub>\<beta> s" by simp
  next
    fix x y
    assume "s \<approx>\<^sub>\<beta> x"
    moreover
    assume "((\<rightarrow>\<^sub>\<beta>) \<squnion> (\<rightarrow>\<^sub>\<beta>)\<inverse>) x y"
    hence "x \<rightarrow>\<^sub>\<beta> y \<or> y \<rightarrow>\<^sub>\<beta> x" by auto
    moreover
    {
      fix p q
      have "p \<rightarrow>\<^sub>\<beta> q \<Longrightarrow> p \<approx>\<^sub>\<beta> q"
        by (induct set: beta, auto)
    }
    ultimately show "s \<approx>\<^sub>\<beta> y"
      by (meson beta_equiv.symm beta_equiv.trans)
  qed
qed

end