section \<open>The Lucas--Lehmer test\<close>
theory Lucas_Lehmer
imports
  Lucas_Lehmer_Auxiliary
  "HOL-Algebra.Ring"
  "Probabilistic_Prime_Tests.Jacobi_Symbol"
  "Pell.Pell" (* only needed for irrationality of sqrt(3) *)
begin

subsection \<open>General properties of Mersenne numbers and Mersenne primes\<close>

text \<open>
  We mostly follow the proofs given on Wikipedia~\<^cite>\<open>"wiki:mersenne" and "wiki:lucas_lehmer"\<close> in the
  following sections.

  We first show some basic and theorems about Mersenne numbers and Mersenne primes in general,
  beginning with this: Mersenne primes are the only primes of the form $a^n - 1$ for $n > 1$.
\<close>
lemma prime_power_minus_oneD:
  fixes a n :: nat
  assumes "prime (a ^ n - 1)"
  shows   "n = 1 \<or> a = 2"
proof -
  from assms have "n > 0"
    by (intro Nat.gr0I) auto
  have "a \<noteq> 0" "a \<noteq> 1"
    by (rule notI, use \<open>n > 0\<close> assms in \<open>simp add: zero_power\<close>)+
  hence "a > 1" by auto
  have "[a - 1 + 1 = 0 + 1] (mod (a - 1))"
    by (rule cong_add) (auto simp: cong_def)
  hence "[a = 1] (mod (a - 1))"
    using \<open>a > 1\<close> by simp
  hence "[a ^ n - 1 = 1 ^ n - 1] (mod (a - 1))"
    using \<open>a > 1\<close> by (intro cong_pow cong_diff_nat) auto
  hence "(a - 1) dvd (a ^ n - 1)"
    by (simp add: cong_0_iff)
  have "a - 1 = 1 \<or> a - 1 = a ^ n - 1"
    using \<open>prime (a ^ n - 1)\<close> and \<open>(a - 1) dvd _\<close> by (rule prime_natD)
  thus ?thesis
  proof
    assume "a - 1 = 1"
    hence "a = 2" by simp
    thus ?thesis by simp
  next
    assume "a - 1 = a ^ n - 1"
    hence "a ^ n = a ^ 1"
      using \<open>a > 1\<close> by (simp add: Nat.eq_diff_iff)
    hence "n = 1"
      using \<open>a > 1\<close> by (subst (asm) power_inject_exp) auto
    thus ?thesis by simp
  qed
qed

text \<open>
  Next, we show that if a prime \<open>q\<close> divides a Mersenne number $2^p - 1$ with an odd prime
  exponent \<open>p\<close>, then \<open>q\<close> must be of the form $q = 1 + 2kp$ for some $k > 0$.
\<close>

  have "ord q 2 = p"
  proof -
    from assms have "[2 ^ p - 1 + 1 = 0 + 1] (mod q)"
      by (intro cong_add cong_refl) (auto simp: cong_0_iff)
    hence "[2 ^ p = 1] (mod q)" by simp
    hence "ord q 2 dvd p"
      by (subst (asm) ord_divides)
    hence "ord q 2 = 1 \<or> ord q 2 = p"
      using \<open>prime p\<close> and prime_natD by blast
    moreover have "ord q 2 \<noteq> 1"
      using ord_works[of 2 q] and \<open>prime q\<close> by (auto simp: cong_altdef_nat)
    ultimately show "ord q 2 = p" by blast
  qed

  have q_dvd_iff: "q dvd (2 ^ x - 1) \<longleftrightarrow> p dvd x" for x :: nat
  proof -
    have "q dvd (2 ^ x - 1) \<longleftrightarrow> [2 ^ x = 1] (mod q)"
      by (auto simp: cong_altdef_nat)
    also have "\<dots> \<longleftrightarrow> ord q 2 dvd x"
      by (rule ord_divides)
    also note \<open>ord q 2 = p\<close>
    finally show ?thesis .
  qed

  from \<open>q > 2\<close> and assms have "\<not>q dvd 2"
    using primes_dvd_imp_eq two_is_prime_nat by blast
  hence "[2 ^ (q - 1) - 1 = 1 - 1] (mod q)"
    using assms by (intro fermat_theorem cong_diff_nat) auto
  hence "q dvd (2 ^ (q - 1) - 1)"
    by (simp add: cong_0_iff)
  hence "p dvd (q - 1)"
    by (subst (asm) q_dvd_iff)
  hence "[q = 1] (mod p)"
    using \<open>q > 2\<close> by (auto simp: cong_altdef_nat prime_gt_1_nat)

  moreover have "[q = 1] (mod 2)"
    using \<open>odd q\<close> by (auto simp: cong_def odd_iff_mod_2_eq_one)
  ultimately show "[q = 1] (mod (2 * p))"
    using \<open>odd p\<close> by (intro coprime_cong_mult_nat) auto
qed

lemma prime_dvd_mersenneD':
  fixes p q :: nat
  assumes "prime p" "p \<noteq> 2" "prime q" "q dvd (2 ^ p - 1)"
  shows "\<exists>k>0. q = 1 + 2 * k * p"
proof -
  have "q \<noteq> 0" "q \<noteq> 1" "q \<noteq> 2"
    using assms by (auto intro!: Nat.gr0I)
  hence "q > 2" by simp

  have "[q = 1] (mod (2 * p))"
    by (rule prime_dvd_mersenneD) fact+
  hence "(2 * p) dvd (q - 1)"
    using \<open>q > 2\<close> by (auto simp: cong_altdef_nat)
  then obtain k where k: "q - 1 = (2 * p) * k"
    by blast
  hence "q = 1 + 2 * k * p"
    using \<open>q > 2\<close> by (simp add: algebra_simps)
  moreover have "k > 0"
    using \<open>q > 2\<close> and k by (intro Nat.gr0I) auto
  ultimately show ?thesis by blast
qed

text \<open>
  A Mersenne number is any number of the form $2^p - 1$ for a natural number $p$. To make things
  a bit more pleasant, we additionally exclude $2^2 - 1$, i.e. we require $p > 2$. It can
  be shown that $p$ is then always an odd prime.
\<close>
locale mersenne_prime =
  fixes p M :: nat
  defines "M \<equiv> 2 ^ p - 1"
  assumes p_gt_2: "p > 2" and prime: "prime M"
begin

lemma M_gt_6: "M > 6"
proof -
  from p_gt_2 have "2 ^ p \<ge> (2 ^ 3 :: nat)"
    by (intro power_increasing) auto
  thus ?thesis by (simp add: M_def)
qed

lemma M_odd: "odd M"
  using p_gt_2 by (auto simp: M_def)

theorem p_prime: "prime p"
proof (rule ccontr)
  assume "\<not>prime p"
  then obtain a b where ab: "p = a * b" "a > 1" "b > 1"
    using p_gt_2 not_prime_imp_ex_prod_nat[of p] by auto

  have geometric_sum_aux: "(x - (1 :: int)) * (\<Sum>k<a. x ^ k) = x ^ a - 1" for x
    by (induction a) (auto simp: algebra_simps)
  have "(2 ^ b - 1 :: int) * (\<Sum>k<a. (2 ^ b) ^ k) = (2 ^ b) ^ a - 1"
    by (rule geometric_sum_aux)
  hence "2 ^ (a*b) - 1 = (2 ^ b - 1 :: int) * (\<Sum>k<a. 2 ^ (k*b))"
    by (simp flip: power_mult add: algebra_simps)
  hence "(2 ^ b - 1) dvd (2 ^ (a*b) - 1 :: int)"
    by simp
  hence "int (2 ^ b - 1) dvd int (2 ^ (a * b) - 1)"
    by (subst of_nat_diff) (auto simp: of_nat_diff)
  hence "(2 ^ b - 1) dvd (2 ^ (a * b) - 1 :: nat)"
    by (subst (asm) int_dvd_int_iff)
  with prime have "2 ^ b - 1 = (1 :: nat) \<or> 2 ^ b - 1 = (2 ^ p - 1 :: nat)"
    unfolding ab M_def by (intro prime_natD) auto
  moreover have "2 ^ b > (2 ^ 1 :: nat)"
    using ab by (intro power_strict_increasing) auto
  moreover have "2 ^ b < (2 ^ p :: nat)"
    using ab by (intro power_strict_increasing) auto
  hence "2 ^ b - 1 < (2 ^ p - 1 :: nat)"
    by (subst less_diff_iff) auto
  ultimately show False by auto
qed

lemma p_odd: "odd p"
  using p_prime p_gt_2 prime_odd_nat by auto

text \<open>
  We now first show a few more properties of Mersenne primes regarding congruences
  and the Legendre symbol.
\<close>
lemma M_cong_7_mod_12: "[M = 7] (mod 12)"
proof -
  have "[M = 8 - 1] (mod 12)"
    using p_gt_2 p_odd unfolding M_def by (intro cong_diff_nat two_power_odd_mod_12) auto
  thus "[M = 7] (mod 12)" by simp
qed

lemma Legendre_3_M: "Legendre 3 M = -1"
  using prime M_cong_7_mod_12 by (subst Legendre_3_left) (auto simp: cong_def)

lemma M_cong_7_mod_8: "[M = 7] (mod 8)"
proof -
  have "2 ^ 3 dvd (2 ^ p :: int)"
    using p_gt_2 by (intro le_imp_power_dvd) auto
  hence "[2 ^ p - 1 = 0 - 1] (mod (8 :: int))"
    by (intro cong_diff) (auto simp: cong_def)
  also have "2 ^ p - 1 = int M"
    by (simp add: M_def of_nat_diff)
  finally have "int M mod int 8 = 7"
    by (simp add: cong_def)
  thus "[M = 7] (mod 8)"
    by (subst (asm) zmod_int [symmetric]) (auto simp: cong_def)
qed

lemma Legendre_2_M: "Legendre 2 M = 1"
  using prime M_gt_6 M_cong_7_mod_8
  by (subst supplement2_Legendre') (auto simp: cong_def nat_mod_as_int)

lemma M_not_dvd_24: "\<not>M dvd 24"
proof
  assume "M dvd 24"
  hence "M dvd 2 * 2 * 2 * 3"
    by simp
  also have "?this \<longleftrightarrow> M dvd 2 \<or> M dvd 3"
    using prime by (simp only: prime_dvd_mult_iff) auto
  finally show False using M_gt_6 by (auto dest: dvd_imp_le)
qed

end

subsection \<open>The Lucas--Lehmer sequence\<close>

text \<open>
  We now define the Lucas--Lehmer sequence $a_{n+1} = a_n ^ 2 - 2$. The starting value
  we will always use is $a_0 = 4$.
\<close>
primrec gen_lucas_lehmer_sequence :: "int \<Rightarrow> nat \<Rightarrow> int" where
  "gen_lucas_lehmer_sequence a 0 = a"
| "gen_lucas_lehmer_sequence a (Suc n) = gen_lucas_lehmer_sequence a n ^ 2 - 2"

lemma gen_lucas_lehmer_sequence_Suc':
  "gen_lucas_lehmer_sequence a (Suc n) = gen_lucas_lehmer_sequence (a ^ 2 - 2) n"
  by (induction n arbitrary: a) auto

lemmas gen_lucas_lehmer_code [code] =
  gen_lucas_lehmer_sequence.simps(1) gen_lucas_lehmer_sequence_Suc'

text \<open>
  For $a_0 = 4$, the recurrence has the closed form $a_{4,n} = \omega^{2^n} + \bar\omega^{2^n}$
  with $\omega = 2 + \sqrt{3}$ and $\bar\omega = 2 - \sqrt{3}$.
\<close>
lemma gen_lucas_lehmer_sequence_4_closed_form1:
  "real_of_int (gen_lucas_lehmer_sequence 4 n) = (2 + sqrt 3) ^ (2 ^ n) + (2 - sqrt 3) ^ (2 ^ n)"
  by (induction n)
     (auto simp: algebra_simps power2_eq_square power_mult simp flip: power_mult_distrib)

lemma gen_lucas_lehmer_sequence_4_closed_form2:
  "gen_lucas_lehmer_sequence 4 n = round ((2 + sqrt 3) ^ (2 ^ n))"
proof (rule sym, rule round_unique')
  have "5 / 3 < sqrt (3 :: real)"
    by (rule real_less_rsqrt) (auto simp: power2_eq_square)
  hence "(2 - sqrt 3) ^ (2 ^ n) < (1 / 3) ^ (2 ^ n)"
    by (intro power_strict_mono) (auto simp: real_le_lsqrt)
  also have "\<dots> \<le> (1 / 3) ^ 1"
    by (intro power_decreasing) auto
  finally have "(2 - sqrt 3) ^ (2 ^ n) < 1 / 2" by simp
  moreover have "(2 - sqrt 3) ^ (2 ^ n) \<ge> 0"
    by (intro zero_le_power) (auto simp: real_le_lsqrt)
  ultimately show "\<bar>(2 + sqrt 3) ^ 2 ^ n - real_of_int (gen_lucas_lehmer_sequence 4 n)\<bar> < 1 / 2"
    unfolding gen_lucas_lehmer_sequence_4_closed_form1 by linarith
qed

lemma gen_lucas_lehmer_sequence_4_closed_form3:
  "gen_lucas_lehmer_sequence 4 n = \<lceil>(2 + sqrt 3) ^ (2 ^ n)\<rceil>"
proof (rule sym, rule ceiling_unique)
  show "real_of_int (gen_lucas_lehmer_sequence 4 n) \<ge> (2 + sqrt 3) ^ 2 ^ n"
    unfolding gen_lucas_lehmer_sequence_4_closed_form1 by (auto intro!: zero_le_power real_le_lsqrt)
next
  have "5 / 3 < sqrt (3 :: real)"
    by (rule real_less_rsqrt) (auto simp: power2_eq_square)
  hence "(2 - sqrt 3) ^ (2 ^ n) < (1 / 3) ^ (2 ^ n)"
    by (intro power_strict_mono) (auto simp: real_le_lsqrt)
  also have "\<dots> \<le> (1 / 3) ^ 1"
    by (intro power_decreasing) auto
  finally have "(2 - sqrt 3) ^ (2 ^ n) < 1 / 2" by simp
  moreover have "(2 - sqrt 3) ^ (2 ^ n) \<ge> 0"
    by (intro zero_le_power) (auto simp: real_le_lsqrt)
  ultimately show "real_of_int (gen_lucas_lehmer_sequence 4 n) - 1 < (2 + sqrt 3) ^ 2 ^ n"
    unfolding gen_lucas_lehmer_sequence_4_closed_form1 by linarith
qed

subsection \<open>The ring $\mathbb{Z}[\sqrt{3}]$\<close>

text \<open>
  To relate this sequence to Mersenne primes, we now first need to define the ring
  $\mathbb{Z}[\sqrt{3}]$, which is a subring of $\mathbb{R}$. This ring can be seen as the
  lattice on $\mathbb{R}$ that is freely generated by $1$ and $\sqrt{3}$.

  It is, however, more convenient to explicitly describe it as a ring structure over the
  set $\mathbb{Z}\times\mathbb{Z}$ with a corresponding injective homomorphism
  $\mathbb{Z}\times\mathbb{Z} \to \mathbb{R}$.
\<close>

definition lucas_lehmer_add' :: "int \<times> int \<Rightarrow> int \<times> int \<Rightarrow> int \<times> int" where
  "lucas_lehmer_add' = (\<lambda>(a,b) (c,d). (a + c, b + d))"

definition lucas_lehmer_mult' :: "int \<times> int \<Rightarrow> int \<times> int \<Rightarrow> int \<times> int" where
  "lucas_lehmer_mult' = (\<lambda>(a,b) (c,d). (a * c + 3 * b * d, a * d + b * c))"

definition lucas_lehmer_ring :: "(int \<times> int) ring" where
  "lucas_lehmer_ring =
     \<lparr>carrier = UNIV,
      monoid.mult = lucas_lehmer_mult',
      one = (1, 0),
      ring.zero = (0, 0),
      add = lucas_lehmer_add'\<rparr>"

lemma carrier_lucas_lehmer_ring [simp]: "carrier lucas_lehmer_ring = UNIV"
  by (simp add: lucas_lehmer_ring_def)

lemma cring_lucas_lehmer_ring [intro]: "cring (lucas_lehmer_ring)"
proof
  have "\<exists>aa ba. lucas_lehmer_add' (aa, ba) (a, b) = (0, 0) \<and>
                lucas_lehmer_add' (a, b) (aa, ba) = (0, 0)" for a b
    by (rule exI[of _ "-a"], rule exI[of _ "-b"]) (auto simp: lucas_lehmer_add'_def)
  thus "carrier (add_monoid lucas_lehmer_ring) \<subseteq> Units (add_monoid lucas_lehmer_ring)"
    by (auto simp: Units_def lucas_lehmer_ring_def)
qed (auto simp: lucas_lehmer_ring_def lucas_lehmer_add'_def lucas_lehmer_mult'_def algebra_simps)

subsection \<open>The ring $(\mathbb{Z}/m\mathbb{Z})[\sqrt{3}]$\<close>

text \<open>
  We shall also need the ring $(\mathbb{Z}/m\mathbb{Z})[\sqrt{3}]$, which is obtained from
  $\mathbb{Z}[\sqrt{3}]$ by reducing each component separately modulo $m$. This essentially
  identifies any two points that are a multiple of $m$ apart and then all those that are
  a multiple of $m\sqrt{3}$ apart.
\<close>
definition lucas_lehmer_mult :: "nat \<Rightarrow> nat \<times> nat \<Rightarrow> nat \<times> nat \<Rightarrow> nat \<times> nat" where
  "lucas_lehmer_mult m = (\<lambda>(a,b) (c,d). ((a * c + 3 * b * d) mod m, (a * d + b * c) mod m))"

definition lucas_lehmer_add :: "nat \<Rightarrow> nat \<times> nat \<Rightarrow> nat \<times> nat \<Rightarrow> nat \<times> nat" where
  "lucas_lehmer_add m = (\<lambda>(a,b) (c,d). ((a + c) mod m, (b + d) mod m))"

definition lucas_lehmer_ring_mod :: "nat \<Rightarrow> (nat \<times> nat) ring" where
  "lucas_lehmer_ring_mod m =
     \<lparr>carrier = {..<m} \<times> {..<m},
      monoid.mult = lucas_lehmer_mult m,
      one = (1, 0),
      ring.zero = (0, 0),
      add = lucas_lehmer_add m\<rparr>"

lemma lucas_lehmer_add_in_carrier: "m > 0 \<Longrightarrow> lucas_lehmer_add m x y \<in> {..<m} \<times> {..<m}"
  by (auto simp: lucas_lehmer_add_def split: prod.splits)

lemma lucas_lehmer_mult_in_carrier: "m > 0 \<Longrightarrow> lucas_lehmer_mult m x y \<in> {..<m} \<times> {..<m}"
  by (auto simp: lucas_lehmer_mult_def split: prod.splits)

lemma lucas_lehmer_add_cong:
  "[fst (lucas_lehmer_add m x y) = fst x + fst y] (mod m)"
  "[snd (lucas_lehmer_add m x y) = snd x + snd y] (mod m)"
  by (simp_all add: lucas_lehmer_add_def cong_def case_prod_unfold)

lemma lucas_lehmer_mult_cong:
  "[fst (lucas_lehmer_mult m x y) = fst x * fst y + 3 * snd x * snd y] (mod m)"
  "[snd (lucas_lehmer_mult m x y) = fst x * snd y + snd x * fst y] (mod m)"
  by (simp_all add: lucas_lehmer_mult_def cong_def case_prod_unfold)

lemma lucas_lehmer_add_neutral [simp]:
  assumes "fst x < m" "snd x < m"
  shows   "lucas_lehmer_add m (0, 0) x = x"
    and   "lucas_lehmer_add m x (0, 0) = x"
  using assms by (auto simp: lucas_lehmer_add_def case_prod_unfold)

lemma lucas_lehmer_add_commute: "lucas_lehmer_add m x y = lucas_lehmer_add m y x"
  by (simp add: lucas_lehmer_add_def algebra_simps case_prod_unfold)

lemma lucas_lehmer_mult_commute: "lucas_lehmer_mult m x y = lucas_lehmer_mult m y x"
  by (simp add: lucas_lehmer_mult_def algebra_simps case_prod_unfold)

lemma lucas_lehmer_add_assoc:
  assumes m: "m > 0"
  shows   "lucas_lehmer_add m x (lucas_lehmer_add m y z) =
           lucas_lehmer_add m (lucas_lehmer_add m x y) z"
proof (rule prod_eqI)
  let ?add = "lucas_lehmer_add m"
  have "[fst (?add x (?add y z)) = fst x + (fst y + fst z)] (mod m)"
    by (rule lucas_lehmer_add_cong[THEN cong_trans] cong_add cong_mult cong_refl)+
  also have "fst x + (fst y + fst z) = (fst x + fst y) + fst z"
    by (simp add: add_ac)
  also have "[\<dots> = fst (?add (?add x y) z)] (mod m)"
    by (rule cong_sym, (rule lucas_lehmer_add_cong[THEN cong_trans] cong_add cong_mult cong_refl)+)
  finally show "fst (?add x (?add y z)) = fst (?add (?add x y) z)"
    by (rule cong_less_modulus_unique_nat)
       (use m in \<open>auto simp: lucas_lehmer_add_def case_prod_unfold\<close>)

  have "[snd (?add x (?add y z)) = snd x + (snd y + snd z)] (mod m)"
    by (rule lucas_lehmer_add_cong[THEN cong_trans] cong_add cong_mult cong_refl)+
  also have "snd x + (snd y + snd z) = (snd x + snd y) + snd z"
    by (simp add: add_ac)
  also have "[\<dots> = snd (?add (?add x y) z)] (mod m)"
    by (rule cong_sym, (rule lucas_lehmer_add_cong[THEN cong_trans] cong_add cong_mult cong_refl)+)
  finally show "snd (?add x (?add y z)) = snd (?add (?add x y) z)"
    by (rule cong_less_modulus_unique_nat)
       (use m in \<open>auto simp: lucas_lehmer_add_def case_prod_unfold\<close>)
qed

lemma lucas_lehmer_mult_assoc:
  assumes m: "m > 0"
  shows   "lucas_lehmer_mult m x (lucas_lehmer_mult m y z) =
           lucas_lehmer_mult m (lucas_lehmer_mult m x y) z"
proof (rule prod_eqI)
  let ?mul = "lucas_lehmer_mult m"
  have "[fst (?mul x (?mul y z)) = fst x * (fst y * fst z + 3 * snd y * snd z) +
           3 * snd x * (fst y * snd z + snd y * fst z)] (mod m)"
    by (rule lucas_lehmer_mult_cong[THEN cong_trans] cong_add cong_mult cong_refl)+
  also have "fst x * (fst y * fst z + 3 * snd y * snd z) +
               3 * snd x * (fst y * snd z + snd y * fst z) =
             (fst x * fst y + 3 * snd x * snd y) * fst z +
               3 * (fst x * snd y + snd x * fst y) * snd z"
    by (simp add: algebra_simps)
  also have "[\<dots> = fst (?mul (?mul x y) z)] (mod m)"
    by (rule cong_sym, (rule lucas_lehmer_mult_cong[THEN cong_trans] cong_add cong_mult cong_refl)+)
  finally show "fst (?mul x (?mul y z)) = fst (?mul (?mul x y) z)"
    by (rule cong_less_modulus_unique_nat)
       (use m in \<open>auto simp: lucas_lehmer_mult_def case_prod_unfold\<close>)

  have "[snd (?mul x (?mul y z)) = fst x * (fst y * snd z + snd y * fst z) +
     snd x * (fst y * fst z + 3 * snd y * snd z)] (mod m)"
    by (rule lucas_lehmer_mult_cong[THEN cong_trans] cong_add cong_mult cong_refl)+
  also have "fst x * (fst y * snd z + snd y * fst z) + snd x * (fst y * fst z + 3 * snd y * snd z) =
             (fst x * fst y + 3 * snd x * snd y) * snd z + (fst x * snd y + snd x * fst y) * fst z"
    by (simp add: algebra_simps)
  also have "[\<dots> = snd (?mul (?mul x y) z)] (mod m)"
    by (rule cong_sym, (rule lucas_lehmer_mult_cong[THEN cong_trans] cong_add cong_mult cong_refl)+)
  finally show "snd (?mul x (?mul y z)) = snd (?mul (?mul x y) z)"
    by (rule cong_less_modulus_unique_nat)
       (use m in \<open>auto simp: lucas_lehmer_mult_def case_prod_unfold\<close>)
qed

lemma lucas_lehmer_distrib_right:
  assumes m: "m > 1"
  shows "lucas_lehmer_mult m (lucas_lehmer_add m x y) z =
         lucas_lehmer_add m (lucas_lehmer_mult m x z) (lucas_lehmer_mult m y z)"
proof (rule prod_eqI)
  let ?mul = "lucas_lehmer_mult m" and ?add = "lucas_lehmer_add m"
  have "[fst (?mul (?add x y) z) = (fst x + fst y) * fst z + 3 * (snd x + snd y) * snd z] (mod m)"
    by (rule lucas_lehmer_mult_cong[THEN cong_trans] lucas_lehmer_add_cong[THEN cong_trans]
             cong_add cong_mult cong_refl)+
  also have "(fst x + fst y) * fst z + 3 * (snd x + snd y) * snd z =
               (fst x * fst z + 3 * snd x * snd z) + (fst y * fst z + 3 * snd y * snd z)"
    by (simp add: algebra_simps)
  also have "[\<dots> = fst (?add (?mul x z) (?mul y z))] (mod m)"
    by (rule cong_sym, (rule lucas_lehmer_mult_cong[THEN cong_trans]
          lucas_lehmer_add_cong[THEN cong_trans] cong_add cong_mult cong_refl)+)
  finally show "fst (?mul (?add x y) z) = fst (?add (?mul x z) (?mul y z))"
    by (rule cong_less_modulus_unique_nat)
       (use m in \<open>auto simp: lucas_lehmer_add_def lucas_lehmer_mult_def case_prod_unfold\<close>)

  have "[snd (?mul (?add x y) z) = (fst x + fst y) * snd z + (snd x + snd y) * fst z] (mod m)"
    by (rule lucas_lehmer_mult_cong[THEN cong_trans] lucas_lehmer_add_cong[THEN cong_trans]
             cong_add cong_mult cong_refl)+
  also have "(fst x + fst y) * snd z + (snd x + snd y) * fst z =
               (fst x * snd z + snd x * fst z) + (fst y * snd z + snd y * fst z)"
    by (simp add: algebra_simps)
  also have "[\<dots> = snd (?add (?mul x z) (?mul y z))] (mod m)"
    by (rule cong_sym, (rule lucas_lehmer_mult_cong[THEN cong_trans]
          lucas_lehmer_add_cong[THEN cong_trans] cong_add cong_mult cong_refl)+)
  finally show "snd (?mul (?add x y) z) = snd (?add (?mul x z) (?mul y z))"
    by (rule cong_less_modulus_unique_nat)
       (use m in \<open>auto simp: lucas_lehmer_add_def lucas_lehmer_mult_def case_prod_unfold\<close>)
qed

lemma lucas_lehmer_distrib_left:
  assumes "m > 1"
  shows "lucas_lehmer_mult m z (lucas_lehmer_add m x y) =
         lucas_lehmer_add m (lucas_lehmer_mult m z x) (lucas_lehmer_mult m z y)"
  using lucas_lehmer_distrib_right[of m x y z] assms
  by (simp add: lucas_lehmer_mult_commute)

lemma cring_lucas_lehmer_ring_mod [intro]:
  assumes "m > 1"
  shows   "cring (lucas_lehmer_ring_mod m)"
proof unfold_locales
  let ?neg = "\<lambda>x. if x = 0 then 0 else m - x"
  have "\<exists>x\<in>carrier (lucas_lehmer_ring_mod m).
           x \<oplus>\<^bsub>lucas_lehmer_ring_mod m\<^esub> (a, b) = \<zero>\<^bsub>lucas_lehmer_ring_mod m\<^esub> \<and>
           (a, b) \<oplus>\<^bsub>lucas_lehmer_ring_mod m\<^esub> x = \<zero>\<^bsub>lucas_lehmer_ring_mod m\<^esub>"
    if "(a, b) \<in> carrier (lucas_lehmer_ring_mod m)" for a b
    using that assms
    by (intro bexI[of _ "(?neg a, ?neg b)"])
       (auto simp: lucas_lehmer_ring_mod_def lucas_lehmer_add_def)
  thus "carrier (add_monoid (lucas_lehmer_ring_mod m)) \<subseteq> Units (add_monoid (lucas_lehmer_ring_mod m))"
    by (auto simp: Units_def)
qed (insert assms,
     auto simp: lucas_lehmer_ring_mod_def algebra_simps lucas_lehmer_mult_assoc
                lucas_lehmer_add_assoc lucas_lehmer_distrib_right lucas_lehmer_distrib_left
          intro: lucas_lehmer_mult_in_carrier lucas_lehmer_add_in_carrier
                 lucas_lehmer_add_commute lucas_lehmer_mult_commute)

text \<open>
  Since $0$ is clearly not a unit in the ring and its carrier has size $m ^ 2$, the
  number of units is strictly less than $m ^ 2$.
\<close>
lemma card_lucas_lehmer_Units:
  assumes "m > 1"
  shows   "card (Units (lucas_lehmer_ring_mod m)) < m ^ 2"
proof -
  interpret cring "lucas_lehmer_ring_mod m"
    using assms by auto
  have "m ^ 2 > 0"
    using assms by auto
  from assms have "card (Units (lucas_lehmer_ring_mod m)) \<le> card ({..<m} \<times> {..<m} - {(0, 0)})"
    by (intro card_mono) (auto simp: Units_def lucas_lehmer_ring_mod_def lucas_lehmer_mult_def)
  also have "\<dots> = m ^ 2 - 1"
    using assms by (subst card_Diff_subset) (auto simp: power2_eq_square)
  finally show ?thesis using \<open>m ^ 2 > 0\<close> by linarith
qed

text \<open>
  Consider now the case of a prime modulus $m$: Since $\mathbb{Z}/m\mathbb{Z} = \text{GF}(m)$
  is a field, any element of $\mathbb{Z}/m\mathbb{Z}$ is a unit in
  $(\mathbb{Z}/m\mathbb{Z})[\sqrt{3}]$.
\<close>
lemma int_in_Units_lucas_lehmer_ring_mod:
  assumes "prime p"
  assumes "x > 0" "x < p"
  shows   "(x, 0) \<in> Units (lucas_lehmer_ring_mod p)"
proof -
  define R where "R = lucas_lehmer_ring_mod p"
  have "[x * (x ^ (p - 2) mod p) = x * x ^ (p - 2)] (mod p)"
    by (intro cong_mult) (auto simp: cong_def)
  also have "x * x ^ (p - 2) = x ^ (Suc (p - 2))"
    by (simp add: mult_ac)
  also have "Suc (p - 2) = p - 1"
    using prime_gt_1_nat[of p] assms by simp
  also have "[x ^ (p - 1) = 1] (mod p)"
    using assms by (intro fermat_theorem) (auto dest: dvd_imp_le)
  finally have "(x, 0) \<otimes>\<^bsub>R\<^esub> (x ^ (p - 2) mod p, 0) = \<one>\<^bsub>R\<^esub>"
               "(x ^ (p - 2) mod p, 0) \<otimes>\<^bsub>R\<^esub> (x, 0) = \<one>\<^bsub>R\<^esub>"
               "(x ^ (p - 2) mod p, 0) \<in> carrier R"
    using prime_gt_1_nat[of p] assms
    by (auto simp: lucas_lehmer_mult_def cong_def lucas_lehmer_ring_mod_def mult_ac R_def)
  moreover from assms have "(x, 0) \<in> carrier R"
    by (auto simp: R_def lucas_lehmer_ring_mod_def)
  ultimately show ?thesis using assms
    by (auto simp: Units_def R_def)
qed

subsection \<open>$\mathbb{Z}[\sqrt{3}]$ as a subring of $\mathbb{R}$\<close>

text \<open>
  We now define the homomorphism from $\mathbb{Z}[\sqrt{3}]$ into the reals:
\<close>
definition lucas_lehmer_to_real :: "int \<times> int \<Rightarrow> real" where
  "lucas_lehmer_to_real = (\<lambda>(a,b). real_of_int a + real_of_int b * sqrt 3)"

context
begin

interpretation cring lucas_lehmer_ring ..

lemma minus_lucas_lehmer_ring: "\<ominus>\<^bsub>lucas_lehmer_ring\<^esub> x = (case x of (a, b) \<Rightarrow> (-a, -b))"
  by (rule sym, rule sum_zero_eq_neg)
     (auto simp: case_prod_unfold lucas_lehmer_ring_def lucas_lehmer_add'_def)

lemma lucas_lehmer_to_real_simps1:
      "lucas_lehmer_to_real (a, b) = of_int a + of_int b * sqrt 3"
      "lucas_lehmer_to_real (x \<oplus>\<^bsub>lucas_lehmer_ring\<^esub> y) =
       lucas_lehmer_to_real x + lucas_lehmer_to_real y"
      "lucas_lehmer_to_real (x \<otimes>\<^bsub>lucas_lehmer_ring\<^esub> y) =
       lucas_lehmer_to_real x * lucas_lehmer_to_real y"
      "lucas_lehmer_to_real (\<ominus>\<^bsub>lucas_lehmer_ring\<^esub> x) = -lucas_lehmer_to_real x"
      "lucas_lehmer_to_real (\<zero>\<^bsub>lucas_lehmer_ring\<^esub>) = 0"
      "lucas_lehmer_to_real (\<one>\<^bsub>lucas_lehmer_ring\<^esub>) = 1"
  using minus_lucas_lehmer_ring
  by (simp_all add: lucas_lehmer_to_real_def lucas_lehmer_add'_def lucas_lehmer_mult'_def
                    case_prod_unfold algebra_simps lucas_lehmer_ring_def)

lemma lucas_lehmer_to_add_pow_nat:
  "lucas_lehmer_to_real ([n] \<cdot>\<^bsub>lucas_lehmer_ring\<^esub> x) = of_nat n * lucas_lehmer_to_real x"
  by (induction n) (auto simp: lucas_lehmer_to_real_simps1 algebra_simps)

lemma lucas_lehmer_to_add_pow_int:
  "lucas_lehmer_to_real ([n] \<cdot>\<^bsub>lucas_lehmer_ring\<^esub> x) = of_int n * lucas_lehmer_to_real x"
proof (cases "n \<ge> 0")
  case True
  hence "lucas_lehmer_to_real ([n] \<cdot>\<^bsub>lucas_lehmer_ring\<^esub> x) =
         lucas_lehmer_to_real ([int (nat n)] \<cdot>\<^bsub>lucas_lehmer_ring\<^esub> x)"
    by simp
  also have "\<dots> = lucas_lehmer_to_real ([nat n] \<cdot>\<^bsub>lucas_lehmer_ring\<^esub> x)"
    by (simp add: add_pow_int_ge)
  also have "\<dots> = of_int n * lucas_lehmer_to_real x" using True
    by (simp add: lucas_lehmer_to_add_pow_nat algebra_simps)
  finally show ?thesis .
next
  case False
  hence "lucas_lehmer_to_real ([n] \<cdot>\<^bsub>lucas_lehmer_ring\<^esub> x) =
         lucas_lehmer_to_real (add_pow lucas_lehmer_ring (-int (nat (-n))) x)"
    by simp
  also have "add_pow lucas_lehmer_ring (-int (nat (-n))) x =
              \<ominus>\<^bsub>lucas_lehmer_ring\<^esub> (add_pow lucas_lehmer_ring (nat (-n)) x)"
    using False by (subst add.int_pow_neg_int) (auto simp: lucas_lehmer_ring_def)
  also have "lucas_lehmer_to_real \<dots> = of_int n * lucas_lehmer_to_real x" using False
    by (simp add: lucas_lehmer_to_add_pow_nat lucas_lehmer_to_real_simps1 algebra_simps)
  finally show ?thesis .
qed

lemma lucas_lehmer_to_real_power:
  "lucas_lehmer_to_real (x [^]\<^bsub>lucas_lehmer_ring\<^esub> (n :: nat)) = lucas_lehmer_to_real x ^ n"
  by (induction n) (auto simp: lucas_lehmer_to_real_simps1)

lemmas lucas_lehmer_to_real_simps =
  lucas_lehmer_to_real_simps1 lucas_lehmer_to_real_power
  lucas_lehmer_to_add_pow_nat lucas_lehmer_to_add_pow_int

end

lemma lucas_lehmer_to_real_inj: "inj lucas_lehmer_to_real"
proof (rule injI, clarify)
  fix a b c d :: int
  assume eq: "lucas_lehmer_to_real (a, b) = lucas_lehmer_to_real (c, d)"
  have "b = d"
  proof (rule ccontr)
    assume "b \<noteq> d"
    hence "sqrt 3 = (c - a) / (b - d)"
      using eq by (simp add: lucas_lehmer_to_real_def field_simps)
    also have "\<dots> \<in> \<rat>" by auto
    finally have "sqrt 3 \<in> \<rat>" .
    moreover have "sqrt 3 \<notin> \<rat>"
      using is_nth_power_prime_power_nat_iff[of 3 2 1] irrat_sqrt_nonsquare[of 3] by auto
    ultimately show False by contradiction
  qed
  moreover from this and eq have "a = c"
    by (auto simp: lucas_lehmer_to_real_def)
  ultimately show "a = c \<and> b = d" by blast
qed

subsection \<open>The canonical homomorphism $\mathbb{Z}[\sqrt 3] \to (\mathbb{Z}/m\mathbb{Z})[\sqrt 3]$\<close>

text \<open>
  Next, we show that reduction modulo $m$ is indeed a homomorphism.
\<close>
definition lucas_lehmer_hom :: "nat \<Rightarrow> (int \<times> int) \<Rightarrow> (nat \<times> nat)" where
  "lucas_lehmer_hom m = (\<lambda>(x,y). (nat (x mod m), nat (y mod m)))"

lemma lucas_lehmer_hom_cong:
  "[fst x = fst y] (mod int m) \<Longrightarrow> [snd x = snd y] (mod int m) \<Longrightarrow>
   lucas_lehmer_hom m x = lucas_lehmer_hom m y"
  by (auto simp: lucas_lehmer_hom_def cong_def case_prod_unfold)

lemma lucas_lehmer_hom_cong':
  "[a = b] (mod int m) \<Longrightarrow> [c = d] (mod int m) \<Longrightarrow>
   lucas_lehmer_hom m (a, c) = lucas_lehmer_hom m (b, d)"
  by (auto simp: lucas_lehmer_hom_def cong_def)

context
  fixes m :: nat
  assumes m: "m > 1"
begin

lemma lucas_lehmer_hom_in_carrier: "lucas_lehmer_hom m x \<in> {..<m} \<times> {..<m}"
  using m nat_less_iff by (auto simp: lucas_lehmer_hom_def case_prod_unfold)

lemma lucas_lehmer_hom_add:
  "lucas_lehmer_hom m (lucas_lehmer_add' x y) =
   lucas_lehmer_add m (lucas_lehmer_hom m x) (lucas_lehmer_hom m y)"
proof (rule prod_eqI)
  let ?add1 = "lucas_lehmer_add'" and ?add2 = "lucas_lehmer_add m"
  let ?\<phi> = "lucas_lehmer_hom m"
  have "fst (?\<phi> (?add1 x y)) = nat ((fst x + fst y) mod int m)"
    by (simp add: lucas_lehmer_hom_def lucas_lehmer_add'_def case_prod_unfold)
  also have "(fst x + fst y) mod int m = ((fst x mod m) + (fst y mod m)) mod int m"
    by (simp add: mod_add_eq)
  also have "nat \<dots> = (nat (fst x mod int m) + nat (fst y mod int m)) mod m"
    using m nat_add_distrib nat_mod_distrib by auto
  also have "\<dots> = fst (?add2 (?\<phi> x) (?\<phi> y))"
    by (auto simp: lucas_lehmer_hom_def lucas_lehmer_add_def case_prod_unfold)
  finally show "fst (?\<phi> (?add1 x y)) = fst (?add2 (?\<phi> x) (?\<phi> y))" .

  have "snd (?\<phi> (?add1 x y)) = nat ((snd x + snd y) mod int m)"
    by (simp add: lucas_lehmer_hom_def lucas_lehmer_add'_def case_prod_unfold)
  also have "(snd x + snd y) mod int m = ((snd x mod m) + (snd y mod m)) mod int m"
    by (simp add: mod_add_eq)
  also have "nat \<dots> = (nat (snd x mod int m) + nat (snd y mod int m)) mod m"
    using m nat_add_distrib nat_mod_distrib by auto
  also have "\<dots> = snd (?add2 (?\<phi> x) (?\<phi> y))"
    by (auto simp: lucas_lehmer_hom_def lucas_lehmer_add_def case_prod_unfold)
  finally show "snd (?\<phi> (?add1 x y)) = snd (?add2 (?\<phi> x) (?\<phi> y))" .
qed

lemma lucas_lehmer_hom_mult:
  "lucas_lehmer_hom m (lucas_lehmer_mult' x y) =
   lucas_lehmer_mult m (lucas_lehmer_hom m x) (lucas_lehmer_hom m y)"
proof (rule prod_eqI)
  let ?mul1 = "lucas_lehmer_mult'" and ?mul2 = "lucas_lehmer_mult m"
  let ?\<phi> = "lucas_lehmer_hom m"
  have "fst (?\<phi> (?mul1 x y)) = nat ((fst x * fst y + 3 * snd x * snd y) mod int m)"
    by (simp add: lucas_lehmer_hom_def lucas_lehmer_mult'_def case_prod_unfold)
  also have "(fst x * fst y + 3 * snd x * snd y) mod int m =
               ((fst x mod int m) * (fst y mod int m) +
                3 * (snd x mod int m) * (snd y mod int m)) mod m"
    by (intro congD cong_mult cong_add cong_refl) (auto simp: cong_def)
  also have "\<dots> = int (nat (((fst x mod int m) * (fst y mod int m) +
                3 * (snd x mod int m) * (snd y mod int m)) mod m))"
    using m by (subst of_nat_nat) auto
  also have "\<dots> = int (nat (fst x mod int m) * nat (fst y mod int m) +
                3 * (nat (snd x mod int m)) * nat (snd y mod int m)) mod m"
    using m by simp
  also have "nat \<dots> = (nat (fst x mod int m) * nat (fst y mod int m) +
           3 * nat (snd x mod int m) * nat (snd y mod int m)) mod m"
    using m by (metis nat_int zmod_int)
  also have "\<dots> = fst (?mul2 (?\<phi> x) (?\<phi> y))"
    by (simp add: lucas_lehmer_hom_def lucas_lehmer_mult_def case_prod_unfold)
  finally show "fst (?\<phi> (?mul1 x y)) = fst (?mul2 (?\<phi> x) (?\<phi> y))" .

  have "snd (?\<phi> (?mul1 x y)) = nat ((fst x * snd y + snd x * fst y) mod int m)"
    by (simp add: lucas_lehmer_hom_def lucas_lehmer_mult'_def case_prod_unfold)
  also have "(fst x * snd y + snd x * fst y) mod int m =
               ((fst x mod int m) * (snd y mod int m) +
                (snd x mod int m) * (fst y mod int m)) mod m"
    by (intro congD cong_mult cong_add cong_refl) (auto simp: cong_def)
  also have "\<dots> = int (nat (((fst x mod int m) * (snd y mod int m) +
                (snd x mod int m) * (fst y mod int m)) mod m))"
    using m by (subst of_nat_nat) auto
  also have "\<dots> = int (nat (fst x mod int m) * nat (snd y mod int m) +
                    (nat (snd x mod int m)) * nat (fst y mod int m)) mod m"
    using m by simp
  also have "nat \<dots> = (nat (fst x mod int m) * nat (snd y mod int m) +
               nat (snd x mod int m) * nat (fst y mod int m)) mod m"
    using m by (metis nat_int zmod_int)
  also have "\<dots> = snd (?mul2 (?\<phi> x) (?\<phi> y))"
    by (simp add: lucas_lehmer_hom_def lucas_lehmer_mult_def case_prod_unfold)
  finally show "snd (?\<phi> (?mul1 x y)) = snd (?mul2 (?\<phi> x) (?\<phi> y))" .
qed

lemma lucas_lehmer_hom_1 [simp]: "lucas_lehmer_hom m (1, 0) = (1, 0)"
  using m by (simp add: lucas_lehmer_hom_def)

lemma ring_hom_lucas_lehmer_hom:
  "lucas_lehmer_hom m \<in> ring_hom lucas_lehmer_ring (lucas_lehmer_ring_mod m)"
proof -
  interpret R: cring lucas_lehmer_ring ..
  from m interpret S: cring "lucas_lehmer_ring_mod m" ..
  show ?thesis
    unfolding ring_hom_def using lucas_lehmer_hom_in_carrier m
    by (auto simp: lucas_lehmer_ring_mod_def lucas_lehmer_hom_add
                   lucas_lehmer_ring_def lucas_lehmer_hom_mult)
qed

end

subsection \<open>Correctness of the Lucas--Lehmer test\<close>

text \<open>
  In this section, we will prove that the Lucas--Lehmer test is both a necessary and sufficient
  condition for the primality of a Mersenne number of the form $2^p - 1$ for an odd prime $p$.
  The proof that shall be given here is rather explicit and heavily draws from the Wikipedia
  article on the Lucas--Lehmer test~\<^cite>\<open>"wiki:lucas_lehmer"\<close>.

  A shorter and more high-level proof of a more general statement can be obtained using more
  theory on finite fields (in particular the field $\text{GF}(q^2)$ (cf.\ e.\,g.\
  Rödseth~\<^cite>\<open>"roedseth94"\<close>).
\<close>

definition lucas_lehmer_test where
  "lucas_lehmer_test p = (p > 2 \<and>
     (2 ^ p - 1) dvd gen_lucas_lehmer_sequence 4 (p - 2))"

text \<open>
  We can now prove that any Mersenne number $2^p - 1$ for $p$ prime that passes the
  Lucas--Lehmer test is prime. We follow the simple argument given by Bruce~\<^cite>\<open>"bruce93"\<close>,
  which is also given on Wikipedia~\<^cite>\<open>"wiki:lucas_lehmer"\<close>.
\<close>
theorem lucas_lehmer_sufficient:
  assumes "prime p" "odd p"
  assumes "(2 ^ p - 1) dvd gen_lucas_lehmer_sequence 4 (p - 2)"
  shows   "prime (2 ^ p - 1 :: nat)"
proof (rule ccontr)
  assume not_prime: "\<not>prime (2 ^ p - 1 :: nat)"
  from assms obtain k :: int where k: "gen_lucas_lehmer_sequence 4 (p - 2) = k * (2 ^ p - 1)"
    by (elim dvdE) (auto simp: mult_ac)
  from assms have "p > 2"
    using odd_prime_gt_2_nat by blast
  from \<open>p > 2\<close> have "2 ^ p \<ge> (2 ^ 3 :: nat)" by (intro power_increasing) auto
  hence "2 ^ p \<ge> (8 :: nat)" by simp

  define q :: nat where "q = Min (prime_factors (2 ^ p - 1))"
  have "q \<in> prime_factors (2 ^ p - 1)" using \<open>2 ^ p \<ge> 8\<close>
    unfolding q_def by (intro Min_in) (auto simp: prime_factorization_empty_iff)
  hence q: "prime q" "q dvd (2 ^ p - 1 :: nat)"
    by (auto simp: in_prime_factors_iff)
  have q_minimal: "q \<le> q'" if "q' \<in> prime_factors (2 ^ p - 1)" for q'
    unfolding q_def by (rule Min_le) (use that in auto)

  have "2 ^ p - 1 \<ge> q ^ 2"
  proof -
    from q obtain k where k: "2 ^ p - 1 = q * k" by auto
    have "prime_factorization (2 ^ p - 1 :: nat) \<noteq> {#q#}"
    proof
      assume *: "prime_factorization (2 ^ p - 1 :: nat) = {#q#}"
      have "2 ^ p - 1 = prod_mset (prime_factorization (2 ^ p - 1 :: nat))"
        using \<open>2 ^ p \<ge> 8\<close> by (subst prod_mset_prime_factorization_nat) auto
      also have "\<dots> = q" by (subst *) auto
      finally show False using not_prime q by simp
    qed
    hence "prime_factorization k \<noteq> {#}" using q k \<open>2 ^ p \<ge> 8\<close>
      by (subst (asm) k, subst (asm) prime_factorization_mult)
         (auto intro!: Nat.gr0I simp: prime_factorization_prime)
    hence "k \<noteq> 1" by (auto simp: prime_factorization_empty_iff)
    then obtain q' where q': "prime q'" "q' dvd k"
      using prime_factor_nat by blast
    from q' k \<open>2 ^ p \<ge> 8\<close> have "q \<le> q'"
      by (intro q_minimal) (auto simp: in_prime_factors_iff intro!: Nat.gr0I)
    hence "q ^ 2 \<le> q * q'"
      unfolding power2_eq_square by (intro mult_mono) auto
    also have "q * q' \<le> 2 ^ p - 1"
      using q q' k \<open>2 ^ p \<ge> 8\<close> by (intro dvd_imp_le) (auto intro!: Nat.gr0I)
    finally show "2 ^ p - 1 \<ge> q ^ 2" .
  qed

  have "q \<noteq> 2" using q \<open>p > 2\<close> by auto
  moreover from q have "q \<noteq> 0" "q \<noteq> 1" by auto
  ultimately have "q > 2" by auto

  write lucas_lehmer_ring ("R")
  define S where "S = lucas_lehmer_ring_mod q"
  define S' where "S' = units_of S"
  define \<phi> where "\<phi> = lucas_lehmer_hom q"

  interpret R: cring R ..
  interpret S: cring S
    unfolding S_def by (rule cring_lucas_lehmer_ring_mod) (use \<open>q > 2\<close> in auto)
  interpret S': comm_group S'
    unfolding S'_def by (rule S.units_comm_group)
  have "\<phi> \<in> ring_hom R S"
    unfolding \<phi>_def S_def by (rule ring_hom_lucas_lehmer_hom) (use \<open>q > 2\<close> in auto)
  interpret \<phi>: ring_hom_cring R S \<phi>
    by standard fact

  have "(2 + sqrt 3) ^ (2 ^ (p - 2)) + (2 - sqrt 3) ^ (2 ^ (p - 2)) =
          real_of_int (gen_lucas_lehmer_sequence 4 (p - 2))"
    unfolding gen_lucas_lehmer_sequence_4_closed_form1 ..
  also have "\<dots> = real_of_int k * (2 ^ p - 1)"
    by (simp add: k)
  finally have *: "(2 + sqrt 3) ^ (2 ^ (p - 2)) =
                     real_of_int k * (2 ^ p - 1) - (2 - sqrt 3) ^ (2 ^ (p - 2))"
    by (simp add: algebra_simps)
  have "((2 + sqrt 3) ^ (2 ^ (p - 2))) ^ 2 =
             real_of_int k * (2 ^ p - 1) * (2 + sqrt 3) ^ (2 ^ (p - 2)) -
             (2 - sqrt 3) ^ (2 ^ (p - 2)) * (2 + sqrt 3) ^ (2 ^ (p - 2))"
    unfolding power2_eq_square by (subst *) (simp add: algebra_simps)
  also have "((2 + sqrt 3) ^ (2 ^ (p - 2))) ^ 2 = (2 + sqrt 3) ^ (2 * 2 ^ (p - 2))"
    by (simp flip: power_mult add: mult_ac)
  also have "2 * 2 ^ (p - 2) = 2 ^ (Suc (p - 2))"
    by simp
  also from \<open>p > 2\<close> have "Suc (p - 2) = p - 1"
    by linarith
  also have "(2 - sqrt 3) ^ (2 ^ (p - 2)) * (2 + sqrt 3) ^ (2 ^ (p - 2)) = 1"
    by (subst power_mult_distrib [symmetric]) (auto simp: algebra_simps)
  finally have "(2 + sqrt 3) ^ (2 ^ (p - 1)) =
                  real_of_int k * (2 ^ p - 1) * (2 + sqrt 3) ^ (2 ^ (p - 2)) - 1" .

  also have "(2 + sqrt 3) ^ (2 ^ (p - 1)) =
               lucas_lehmer_to_real ((2, 1) [^]\<^bsub>R\<^esub> (2 ^ (p - 1) :: nat))"
    by (simp add: lucas_lehmer_to_real_simps)
  also have "real_of_int k * (2 ^ p - 1) * (2 + sqrt 3) ^ (2 ^ (p - 2)) - 1 =
               lucas_lehmer_to_real ((k * (2 ^ p - 1), 0) \<otimes>\<^bsub>R\<^esub>
                 (2, 1) [^]\<^bsub>R\<^esub> (2 ^ (p - 2) :: nat) \<oplus>\<^bsub>R\<^esub> \<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>)"
    by (simp add: lucas_lehmer_to_real_simps)
  finally have "((2, 1) [^]\<^bsub>R\<^esub> (2 ^ (p - 1) :: nat)) =
                ((k * (2 ^ p - 1), 0) \<otimes>\<^bsub>R\<^esub> (2, 1) [^]\<^bsub>R\<^esub> (2 ^ (p - 2) :: nat) \<oplus>\<^bsub>R\<^esub> \<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>)"
    by (rule injD[OF lucas_lehmer_to_real_inj])

  hence "\<phi> ((2, 1) [^]\<^bsub>R\<^esub> (2 ^ (p - 1) :: nat)) =
           \<phi> ((k * (2 ^ p - 1), 0) \<otimes>\<^bsub>R\<^esub> (2, 1) [^]\<^bsub>R\<^esub> (2 ^ (p - 2) :: nat) \<oplus>\<^bsub>R\<^esub> \<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>)"
    by (simp only:)
  also have "\<phi> ((2, 1) [^]\<^bsub>R\<^esub> (2 ^ (p - 1) :: nat)) = \<phi> (2, 1) [^]\<^bsub>S\<^esub> (2 ^ (p - 1) :: nat)"
    by simp
  also {
    have "int q dvd int (2 ^ p - 1)"
      by (subst int_dvd_int_iff) (use q in auto)
    also have "int (2 ^ p - 1) = 2 ^ p - 1"
      by (simp add: of_nat_diff)
    finally have "\<phi> (k * (2 ^ p - 1), 0) = \<zero>\<^bsub>S\<^esub>"
      by (simp add: \<phi>_def lucas_lehmer_hom_def S_def lucas_lehmer_ring_mod_def)
  }
  hence "\<phi> ((k * (2 ^ p - 1), 0) \<otimes>\<^bsub>R\<^esub> (2, 1) [^]\<^bsub>R\<^esub> (2 ^ (p - 2) :: nat) \<oplus>\<^bsub>R\<^esub> \<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) =
           \<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub>"
    by simp
  finally have eq: "\<phi> (2, 1) [^]\<^bsub>S\<^esub> (2 ^ (p - 1) :: nat) = \<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub>" .

  have "\<phi> (2, 1) [^]\<^bsub>S\<^esub> (2 ^ p :: nat) = \<phi> (2, 1) [^]\<^bsub>S\<^esub> (2 ^ (p - 1) * 2 :: nat)"
    using \<open>p > 2\<close> by (cases p) (auto simp: mult_ac)
  also have "\<dots> = (\<phi> (2, 1) [^]\<^bsub>S\<^esub> (2 ^ (p - 1) :: nat)) [^]\<^bsub>S\<^esub> (2 :: nat)"
    by (subst S.nat_pow_pow) auto
  also have "\<dots> = \<one>\<^bsub>S\<^esub>"
    by (subst eq) (auto simp: numeral_2_eq_2 S.l_minus)
  finally have eq': "\<phi> (2, 1) [^]\<^bsub>S\<^esub> (2 ^ p :: nat) = \<one>\<^bsub>S\<^esub>" .

  from eq' have unit: "\<phi> (2, 1) \<in> Units S"
    by (rule S.pow_nat_eq_1_imp_unit) auto

  have neg_one_not_one: "\<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub> \<noteq> \<one>\<^bsub>S\<^esub>"
  proof
    assume *: "\<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub> = \<one>\<^bsub>S\<^esub>"
    have "(\<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub>) \<oplus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub> = \<zero>\<^bsub>S\<^esub>"
      by (rule S.l_neg) auto
    hence "\<one>\<^bsub>S\<^esub> \<oplus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub> = \<zero>\<^bsub>S\<^esub>"
      by (simp only: *)
    thus False using \<open>q > 2\<close>
      by (auto simp: S_def lucas_lehmer_ring_mod_def lucas_lehmer_add_def)
  qed

  have fin: "finite (Units S)"
    by (rule finite_subset[of _ "carrier S"]) (auto simp: Units_def S_def lucas_lehmer_ring_mod_def)

  have "group.ord S' (\<phi> (2, 1)) = 2 ^ p"
    using \<open>p > 2\<close> eq eq' unit neg_one_not_one
    by (intro S'.ord_eqI_prime_factors)
       (auto simp: prime_factors_power prime_factorization_prime
                   S'_def S.units_of_pow units_of_carrier units_of_one power_diff)
  hence "2 ^ p = group.ord S' (\<phi> (2, 1))"
    by simp
  also have "\<dots> = card (generate S' {\<phi> (2, 1)})"
    using unit fin
    by (intro S'.generate_pow_card) (auto simp: S'_def units_of_carrier)
  also have "\<dots> \<le> card (carrier S')"
    using fin unit by (intro card_mono S'.generate_incl) (auto simp: S'_def units_of_carrier)
  also have "\<dots> < q ^ 2"
    unfolding S'_def S_def using card_lucas_lehmer_Units[of q] \<open>q > 2\<close>
    by (auto simp: units_of_carrier)
  also note \<open>q ^ 2 \<le> 2 ^ p - 1\<close>
  finally show False by simp
qed

text \<open>
  Next, we show that any Mersenne prime passes the Lucas--Lehmer test. We again follow the
  rather explicit proof outlined on Wikipedia~\<^cite>\<open>"wiki:lucas_lehmer"\<close>, which is a simplified
  (but less general and less abstract) version of the proof by Rödseth~\<^cite>\<open>"roedseth94"\<close>.
\<close>
theorem (in mersenne_prime) lucas_lehmer_necessary:
  "(2 ^ p - 1) dvd gen_lucas_lehmer_sequence 4 (p - 2)"
proof -
  write lucas_lehmer_ring ("R")
  define S where "S = lucas_lehmer_ring_mod M"
  define S' where "S' = units_of S"
  define \<phi> where "\<phi> = lucas_lehmer_hom M"

  interpret R: cring R ..
  interpret S: cring S unfolding S_def
    by (rule cring_lucas_lehmer_ring_mod) (use M_gt_6 in auto)
  interpret S': comm_group S'
    unfolding S'_def by (rule S.units_comm_group)
  have "\<phi> \<in> ring_hom R S" unfolding \<phi>_def S_def
    by (rule ring_hom_lucas_lehmer_hom) (use M_gt_6 in auto)
  interpret \<phi>: ring_hom_cring R S \<phi>
    by standard fact

  have R_pow_int: "(n, 0) [^]\<^bsub>R\<^esub> m = (n ^ m, 0)" for n :: int and m :: nat
    by (induction m; simp; simp add: lucas_lehmer_ring_def lucas_lehmer_mult'_def)

  have "add_pow R n \<one>\<^bsub>R\<^esub> = (int n, 0)" for n
    by (induction n; simp; simp add: lucas_lehmer_ring_def lucas_lehmer_add'_def)
  hence "add_pow R M \<one>\<^bsub>R\<^esub> = (int M, 0)"
    by simp
  also have "\<phi> \<dots> = \<zero>\<^bsub>S\<^esub>"
    by (simp add: \<phi>_def S_def lucas_lehmer_ring_mod_def lucas_lehmer_hom_def)
  finally have "add_pow S M \<one>\<^bsub>S\<^esub> = \<zero>\<^bsub>S\<^esub>"
    by (simp add: \<phi>.hom_add_pow_nat)

  define \<sigma> :: "int \<times> int" where "\<sigma> = (0, 2)"
  have eq1: "\<phi> ((6, 2) [^]\<^bsub>R\<^esub> M) = \<phi> (6, -2)"
  proof -
    have "(6, 2) = (6, 0) \<oplus>\<^bsub>R\<^esub> \<sigma>"
      by (simp add: lucas_lehmer_ring_def \<sigma>_def lucas_lehmer_add'_def)
    also have "\<phi> (\<dots> [^]\<^bsub>R\<^esub> M) = \<phi> ((6, 0) [^]\<^bsub>R\<^esub> M) \<oplus>\<^bsub>S\<^esub> \<phi> (\<sigma> [^]\<^bsub>R\<^esub> M)"
      using prime and \<open>add_pow S M \<one>\<^bsub>S\<^esub> = \<zero>\<^bsub>S\<^esub>\<close>
      by (simp add: S.binomial_finite_char)
    also have "(6, 0) [^]\<^bsub>R\<^esub> M = (6 ^ M, 0)"
      by (simp add: R_pow_int)
    also have "[6 ^ M = 6] (mod (int M))" using M_gt_6
      by (intro little_Fermat_int) (use prime in \<open>auto simp flip: dvd_nat_abs_iff\<close>)
    hence "\<phi> (6 ^ M, 0) = \<phi> (6, 0)"
      unfolding \<phi>_def by (intro lucas_lehmer_hom_cong) auto
    also have "\<sigma> = (2, 0) \<otimes>\<^bsub>R\<^esub> (0, 1)"
      by (simp add: \<sigma>_def lucas_lehmer_ring_def lucas_lehmer_mult'_def)
    hence "\<phi> (\<sigma> [^]\<^bsub>R\<^esub> M) = \<phi> ((2, 0) [^]\<^bsub>R\<^esub> M \<otimes>\<^bsub>R\<^esub> (0, 1) [^]\<^bsub>R\<^esub> M)"
      by (subst R.nat_pow_distrib [symmetric]) auto
    also have "\<dots> = \<phi> ((2, 0) [^]\<^bsub>R\<^esub> M) \<otimes>\<^bsub>S\<^esub> \<phi> ((0, 1) [^]\<^bsub>R\<^esub> M)"
      by simp
    also have "(2, 0) [^]\<^bsub>R\<^esub> M = (2 ^ M, 0)"
      by (simp add: R_pow_int)
    also have "[2 ^ M = 2] (mod int M)" using M_gt_6 prime
      by (intro little_Fermat_int) (auto simp flip: dvd_nat_abs_iff dest: dvd_imp_le)
    hence "\<phi> (2 ^ M, 0) = \<phi> (2, 0)"
      unfolding \<phi>_def by (intro lucas_lehmer_hom_cong) auto
    also have M_eq: "M = Suc (2 * ((M - 1) div 2))"
      using M_odd by auto
    have "(0, 1) [^]\<^bsub>R\<^esub> M = (0, 1) \<otimes>\<^bsub>R\<^esub> ((0, 1) [^]\<^bsub>R\<^esub> (2::nat)) [^]\<^bsub>R\<^esub> ((M - 1) div 2)"
      by (subst M_eq) (auto simp: R.nat_pow_mult R.nat_pow_pow R.cring_simprules)
    also have "(0, 1) [^]\<^bsub>R\<^esub> (2::nat) = (3, 0)"
      by (simp add: eval_nat_numeral) (simp add: lucas_lehmer_ring_def lucas_lehmer_mult'_def)
    also have "\<phi> ((0, 1) \<otimes>\<^bsub>R\<^esub> (3, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2)) =
                 \<phi> ((3, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2)) \<otimes>\<^bsub>S\<^esub> \<phi> (0, 1)"
      by (simp add: S.cring_simprules)
    also have "(3, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2) = (3 ^ ((M - 1) div 2), 0)"
      by (simp add: R_pow_int)
    also have "\<phi> (3 ^ ((M - 1) div 2), 0) = \<phi> (-1, 0)"
      unfolding \<phi>_def
    proof (intro lucas_lehmer_hom_cong')
      have "[3 ^ ((M - 1) div 2) = Legendre 3 M] (mod int M)"
        by (rule cong_sym, rule euler_criterion) (use prime M_gt_6 in auto)
      thus "[3 ^ ((M - 1) div 2) = -1] (mod int M)"
        by (simp add: Legendre_3_M)
    qed auto
    also have "\<phi> (2, 0) \<otimes>\<^bsub>S\<^esub> (\<phi> (- 1, 0) \<otimes>\<^bsub>S\<^esub> \<phi> (0, 1)) = \<phi> ((2, 0) \<otimes>\<^bsub>R\<^esub> (-1, 0) \<otimes>\<^bsub>R\<^esub> (0, 1))"
      by (simp add: R.cring_simprules S.cring_simprules)
    also have "\<phi> (6, 0) \<oplus>\<^bsub>S\<^esub> \<phi> ((2, 0) \<otimes>\<^bsub>R\<^esub> (- 1, 0) \<otimes>\<^bsub>R\<^esub> (0, 1)) =
                 \<phi> ((6, 0) \<oplus>\<^bsub>R\<^esub> (2, 0) \<otimes>\<^bsub>R\<^esub> (- 1, 0) \<otimes>\<^bsub>R\<^esub> (0, 1))"
      by simp
    also have "\<dots> = \<phi> (6, -2)" unfolding \<phi>_def
      by (intro lucas_lehmer_hom_cong)
         (auto simp: lucas_lehmer_ring_def lucas_lehmer_mult'_def lucas_lehmer_add'_def)
    finally show "\<phi> ((6, 2) [^]\<^bsub>R\<^esub> M) = \<phi> (6, -2)"
      by (simp add: R.cring_simprules S.cring_simprules)
  qed

  have eq2: "\<phi> ((24, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2)) = \<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub>"
  proof -
    have "(24, 0) = (2, 0) [^]\<^bsub>R\<^esub> (3::nat) \<otimes>\<^bsub>R\<^esub> (3, 0)"
      by (simp add: eval_nat_numeral) (auto simp: lucas_lehmer_ring_def lucas_lehmer_mult'_def)
    also have "\<dots> [^]\<^bsub>R\<^esub> ((M - 1) div 2) =
                 ((2, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2)) [^]\<^bsub>R\<^esub> (3::nat) \<otimes>\<^bsub>R\<^esub> (3, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2)"
      by (simp add: R.cring_simprules R.nat_pow_distrib R.nat_pow_pow mult_ac)
    also have "\<phi> \<dots> = (\<phi> ((2, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2))) [^]\<^bsub>S\<^esub> (3::nat) \<otimes>\<^bsub>S\<^esub>
                      \<phi> ((3, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2))" by simp
    also have "(2, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2) = (2 ^ ((M - 1) div 2), 0)"
      by (simp add: R_pow_int)
    also have "\<phi> \<dots> = \<phi> (1, 0)"
      unfolding \<phi>_def
    proof (intro lucas_lehmer_hom_cong')
      have "[2 ^ ((M - 1) div 2) = Legendre 2 M] (mod int M)"
        by (rule cong_sym, rule euler_criterion) (use prime M_gt_6 in auto)
      thus "[2 ^ ((M - 1) div 2) = 1] (mod int M)"
        using Legendre_2_M by simp
    qed auto
    also have "(1, 0) = \<one>\<^bsub>R\<^esub>"
      by (simp add: lucas_lehmer_ring_def)
    also have "(3, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2) = (3 ^ ((M - 1) div 2), 0)"
      by (simp add: R_pow_int)
    also have "\<phi> \<dots> = \<phi> (-1, 0)"
      unfolding \<phi>_def
    proof  (intro lucas_lehmer_hom_cong')
      have "[3 ^ ((M - 1) div 2) = Legendre 3 M] (mod int M)"
        by (rule cong_sym, rule euler_criterion) (use prime M_gt_6 in auto)
      thus "[3 ^ ((M - 1) div 2) = -1] (mod int M)"
        using Legendre_3_M by simp
    qed auto
    also have "(-1, 0) = \<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>"
      using minus_lucas_lehmer_ring by (simp add: lucas_lehmer_ring_def)
    finally show "\<phi> ((24, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2)) = \<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub>"
      by simp
  qed

  define \<omega> \<omega>' :: "int \<times> int" where "\<omega> = (2, 1)" and "\<omega>' = (2, -1)"
  have eq3: "\<phi> (\<omega> [^]\<^bsub>R\<^esub> ((M + 1) div 2)) = \<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub>"
  proof -
    have "(M + 1) div 2 = Suc ((M - 1) div 2)"
      using M_odd M_gt_6 by (auto elim!: oddE)
    have *: "\<phi> ((24, 0) \<otimes>\<^bsub>R\<^esub> \<omega>) = \<phi> ((6, 2) [^]\<^bsub>R\<^esub> (2 :: nat))" unfolding \<phi>_def
      by (intro lucas_lehmer_hom_cong)
         (simp_all add: eval_nat_numeral,
          auto simp: lucas_lehmer_ring_def lucas_lehmer_mult'_def \<omega>_def)
    have "\<phi> (\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<otimes>\<^bsub>S\<^esub> \<phi> ((24, 0) \<otimes>\<^bsub>R\<^esub> \<omega>) [^]\<^bsub>S\<^esub> ((M + 1) div 2) =
            \<phi> (\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<otimes>\<^bsub>S\<^esub> \<phi> ((6, 2) [^]\<^bsub>R\<^esub> (2 :: nat)) [^]\<^bsub>S\<^esub> ((M + 1) div 2)"
      by (subst *) auto
    hence "\<phi> (\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<otimes>\<^bsub>S\<^esub> \<phi> ((24, 0) [^]\<^bsub>R\<^esub> ((M + 1) div 2)) \<otimes>\<^bsub>S\<^esub> \<phi> (\<omega> [^]\<^bsub>R\<^esub> ((M + 1) div 2)) =
            \<phi> (\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<otimes>\<^bsub>S\<^esub> \<phi> ((6, 2) [^]\<^bsub>R\<^esub> (2 * ((M + 1) div 2)))"
      by (simp add: R.nat_pow_distrib S.nat_pow_distrib R.nat_pow_pow
                    S.nat_pow_pow R.cring_simprules S.cring_simprules)
    also have "2 * ((M + 1) div 2) = M + 1"
      using M_odd by auto
    finally have "\<phi> (24, 0) \<otimes>\<^bsub>S\<^esub> (\<phi> (\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<otimes>\<^bsub>S\<^esub> \<phi> ((24, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2))) \<otimes>\<^bsub>S\<^esub>
                    \<phi> (\<omega> [^]\<^bsub>R\<^esub> ((M + 1) div 2)) =
                  \<phi> (\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<otimes>\<^bsub>S\<^esub> (\<phi> (6, 2) \<otimes>\<^bsub>S\<^esub> \<phi> ((6, 2) [^]\<^bsub>R\<^esub> M))"
      by (subst (asm) \<open>(M + 1) div 2 = _\<close>) (simp add: S.cring_simprules R.cring_simprules)

    also have "\<phi> ((24, 0) [^]\<^bsub>R\<^esub> ((M - 1) div 2)) = \<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub>"
      by (subst eq2) auto
    also have "(\<phi> (\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>) \<otimes>\<^bsub>S\<^esub> \<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub>) = \<one>\<^bsub>S\<^esub>"
      by (simp add: S.cring_simprules)
    also have "\<phi> ((6, 2) [^]\<^bsub>R\<^esub> M) = \<phi> (6, -2)"
      by (subst eq1) auto
    also have "\<phi> (6, 2) \<otimes>\<^bsub>S\<^esub> \<phi> (6, -2) = \<phi> ((6, 2) \<otimes>\<^bsub>R\<^esub> (6, -2))"
      by simp
    also have "\<dots> = \<phi> (24, 0)" unfolding \<phi>_def
      by (intro lucas_lehmer_hom_cong) (auto simp: lucas_lehmer_ring_def lucas_lehmer_mult'_def)
    finally have "\<phi> (24, 0) \<otimes>\<^bsub>S\<^esub> (\<phi> (\<omega> [^]\<^bsub>R\<^esub> ((M + 1) div 2))) =
                  \<phi> (24, 0) \<otimes>\<^bsub>S\<^esub> \<phi> (\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>)"
      by (simp add: S.cring_simprules)
    also have "\<phi> (24, 0) = (24 mod M, 0)"
      by (simp add: \<phi>_def lucas_lehmer_hom_def nat_mod_as_int)
    finally have "(24 mod M, 0) \<otimes>\<^bsub>S\<^esub> (\<phi> (\<omega> [^]\<^bsub>R\<^esub> ((M + 1) div 2))) =
                  (24 mod M, 0) \<otimes>\<^bsub>S\<^esub> \<phi> (\<ominus>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>)" .
    moreover have "(24 mod M, 0) \<in> Units S"
      unfolding S_def using M_gt_6 prime M_not_dvd_24
      by (intro int_in_Units_lucas_lehmer_ring_mod) (auto simp: dvd_mod_iff intro!: Nat.gr0I)
    ultimately show "\<phi> (\<omega> [^]\<^bsub>R\<^esub> ((M + 1) div 2)) = \<ominus>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub>"
      by (subst (asm) S.Units_l_cancel) auto
  qed

  have eq4: "\<phi> (\<omega> [^]\<^bsub>R\<^esub> (2 ^ (p - 2) :: nat) \<oplus>\<^bsub>R\<^esub> \<omega>' [^]\<^bsub>R\<^esub> (2 ^ (p - 2) :: nat)) = \<zero>\<^bsub>S\<^esub>"
    (is "\<phi> ?lhs = _")
  proof -
    have "\<phi> (\<omega> [^]\<^bsub>R\<^esub> ((M + 1) div 2)) \<otimes>\<^bsub>S\<^esub> \<phi> (\<omega>' [^]\<^bsub>R\<^esub> ((M + 1) div 4)) \<oplus>\<^bsub>S\<^esub>
            \<phi> (\<omega>' [^]\<^bsub>R\<^esub> ((M + 1) div 4)) = \<zero>\<^bsub>S\<^esub>"
      by (subst eq3) (auto simp: S.cring_simprules)
    also have "2 ^ 2 dvd (2 ^ p :: nat)"
      by (intro le_imp_power_dvd) (use p_gt_2 in auto)
    hence "4 dvd (M + 1)" by (auto simp: M_def)
    hence "(M + 1) div 2 = (M + 1) div 4 + (M + 1) div 4"
      by presburger
    also have "\<phi> (\<omega> [^]\<^bsub>R\<^esub> \<dots>) \<otimes>\<^bsub>S\<^esub> \<phi> (\<omega>' [^]\<^bsub>R\<^esub> ((M + 1) div 4)) =
               \<phi> (\<omega> \<otimes>\<^bsub>R\<^esub> \<omega>') [^]\<^bsub>S\<^esub> ((M + 1) div 4) \<otimes>\<^bsub>S\<^esub> \<phi> (\<omega> [^]\<^bsub>R\<^esub> ((M + 1) div 4))"
      by (simp add: S.cring_simprules S.nat_pow_distrib flip: S.nat_pow_mult)
    also have "\<phi> (\<omega> \<otimes>\<^bsub>R\<^esub> \<omega>') = \<phi> \<one>\<^bsub>R\<^esub>" unfolding \<phi>_def
      by (intro lucas_lehmer_hom_cong)
         (auto simp: \<omega>_def \<omega>'_def lucas_lehmer_ring_def lucas_lehmer_mult'_def)
    also have "(M + 1) div 4 = 2 ^ (p - 2)"
      using p_gt_2 by (auto simp: M_def power_diff)
    finally show eq4: "\<phi> (\<omega> [^]\<^bsub>R\<^esub> (2 ^ (p - 2) :: nat) \<oplus>\<^bsub>R\<^esub> \<omega>' [^]\<^bsub>R\<^esub> (2 ^ (p - 2) :: nat)) = \<zero>\<^bsub>S\<^esub>"
      by simp
  qed

  have "\<phi> ?lhs = \<zero>\<^bsub>S\<^esub>"
    by (rule eq4)
  also have "lucas_lehmer_to_real ?lhs =
             lucas_lehmer_to_real (gen_lucas_lehmer_sequence 4 (p - 2), 0)"
    by (simp add: \<omega>_def \<omega>'_def lucas_lehmer_to_real_simps gen_lucas_lehmer_sequence_4_closed_form1)
  hence "?lhs = (gen_lucas_lehmer_sequence 4 (p - 2), 0)"
    by (rule injD[OF lucas_lehmer_to_real_inj])
  finally have "gen_lucas_lehmer_sequence 4 (p - 2) mod M = 0" using M_gt_6
    by (auto simp: \<phi>_def lucas_lehmer_hom_def S_def lucas_lehmer_ring_mod_def)
  thus "(2 ^ p - 1) dvd gen_lucas_lehmer_sequence 4 (p - 2)"
    by (simp add: M_def mod_eq_0_iff_dvd of_nat_diff)
qed

corollary lucas_lehmer_correct:
  "prime (2 ^ p - 1 :: nat) \<longleftrightarrow>
     prime p \<and> (p = 2 \<or> (2 ^ p - 1) dvd gen_lucas_lehmer_sequence 4 (p - 2))"
proof (intro iffI; (elim conjE)?)
  assume prime: "prime (2 ^ p - 1 :: nat)"
  from prime have "p \<noteq> 0" "p \<noteq> 1"
    by (auto intro!: Nat.gr0I)
  hence "p = 2 \<or> p > 2" by auto
  thus "prime p \<and> (p = 2 \<or> (2 ^ p - 1) dvd gen_lucas_lehmer_sequence 4 (p - 2))"
  proof (elim disjE)
    assume "p > 2"
    with prime interpret mersenne_prime p "2 ^ p - 1"
      by unfold_locales
    from lucas_lehmer_necessary p_prime show ?thesis by auto
  qed auto
next
  assume prime: "prime p" and *: "p = 2 \<or> (2 ^ p - 1) dvd gen_lucas_lehmer_sequence 4 (p - 2)"
  from * consider "p = 2" | "p \<noteq> 2" "(2 ^ p - 1) dvd gen_lucas_lehmer_sequence 4 (p - 2)"
    by auto
  thus "prime (2 ^ p - 1 :: nat)"
  proof cases
    assume "p \<noteq> 2" and dvd: "(2 ^ p - 1) dvd gen_lucas_lehmer_sequence 4 (p - 2)"
    from \<open>prime p\<close> and \<open>p \<noteq> 2\<close> have "p > 2"
      using prime_gt_1_nat[of p] by auto
    with prime have "odd p" by (auto simp: prime_odd_nat)
    with prime dvd show ?thesis
      by (intro lucas_lehmer_sufficient)
  qed auto
qed

corollary lucas_lehmer_correct':
  "prime (2 ^ p - 1 :: nat) \<longleftrightarrow> prime p \<and> (p = 2 \<or> lucas_lehmer_test p)"
  using lucas_lehmer_correct[of p] prime_gt_1_nat[of p]
  by (auto simp: lucas_lehmer_test_def)

subsection \<open>A first executable version Lucas--Lehmer test\<close>

text \<open>
  The following is an implementation of the Lucas--Lehmer test using modular
  arithmetic on the integers. This is not the most efficient implementation --
  the modular arithmetic can be replaced by much cheaper bitwise operations,
  and we will do that in the next section.
\<close>

primrec gen_lucas_lehmer_sequence' :: "int \<Rightarrow> int \<Rightarrow> nat \<Rightarrow> int" where
  "gen_lucas_lehmer_sequence' m a 0 = a"
| "gen_lucas_lehmer_sequence' m a (Suc n) = gen_lucas_lehmer_sequence' m ((a ^ 2 - 2) mod m) n"

lemma gen_lucas_lehmer_sequence'_Suc':
  "gen_lucas_lehmer_sequence' m a (Suc n) = (gen_lucas_lehmer_sequence' m a n ^ 2 - 2) mod m"
  by (induction n arbitrary: a) auto

lemma gen_lucas_lehmer_sequence'_correct:
  assumes "a \<in> {0..<m}"
  shows   "gen_lucas_lehmer_sequence' m a n = gen_lucas_lehmer_sequence a n mod m"
  using assms
proof (induction n)
  case (Suc n)
  have "gen_lucas_lehmer_sequence' m a (Suc n) =
          ((gen_lucas_lehmer_sequence a n mod m)\<^sup>2 - 2) mod m"
    using Suc unfolding gen_lucas_lehmer_sequence'_Suc' by simp
  also have "\<dots> = ((gen_lucas_lehmer_sequence a n)\<^sup>2 - 2) mod m"
    by (intro congD cong_diff cong_pow cong_refl) (auto simp: cong_def)
  finally show ?case by simp
qed auto

lemma lucas_lehmer_test_code_arithmetic [code]:
  "lucas_lehmer_test p = (p > 2 \<and>
     gen_lucas_lehmer_sequence' (2 ^ p - 1) 4 (p - 2) = 0)"
  unfolding lucas_lehmer_test_def
proof (intro conj_cong refl)
  assume p: "p > 2"
  from p have "2 ^ p \<ge> (2 ^ 3 :: int)" by (intro power_increasing) auto
  have "(2 ^ p - 1 dvd gen_lucas_lehmer_sequence 4 (p - 2)) \<longleftrightarrow>
          gen_lucas_lehmer_sequence 4 (p - 2) mod (2 ^ p - 1) = 0"
    by auto
  also have "gen_lucas_lehmer_sequence 4 (p - 2) mod (2 ^ p - 1) =
             gen_lucas_lehmer_sequence' (2 ^ p - 1) 4 (p - 2)"
    using \<open>2 ^ p \<ge> 2 ^ 3\<close>
    by (intro gen_lucas_lehmer_sequence'_correct [symmetric]) auto
  finally show "(2 ^ p - 1 dvd gen_lucas_lehmer_sequence 4 (p - 2)) =
                (gen_lucas_lehmer_sequence' (2 ^ p - 1) 4 (p - 2) = 0)" .
qed

lemma mersenne_prime_iff: "mersenne_prime p \<longleftrightarrow> p > 2 \<and> prime (2 ^ p - 1 :: nat)"
  by (simp add: mersenne_prime_def)

lemma mersenne_prime_code [code]:
  "mersenne_prime p \<longleftrightarrow> prime p \<and> lucas_lehmer_test p"
  unfolding mersenne_prime_iff using lucas_lehmer_correct'[of p]
  by (auto simp: lucas_lehmer_test_def)

end


theory bin_plus_assoc
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Bin => Bin => Bin" where
"plus (One) y = s y"
| "plus (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus z ys)"
| "plus (ZeroAnd z) (OneAnd xs) = OneAnd (plus z xs)"
| "plus (OneAnd x2) (One) = s (OneAnd x2)"
| "plus (OneAnd x2) (ZeroAnd zs) = OneAnd (plus x2 zs)"
| "plus (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus x2 ys2))"

(*hipster s plus *)

theorem x0 :
  "!! (x :: Bin) (y :: Bin) (z :: Bin) .
     (plus x (plus y z)) = (plus (plus x y) z)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory prop_37
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun elem :: "Nat => Nat list => bool" where
  "elem x (Nil2) = False"
  | "elem x (Cons2 z xs) = (if equal2 x z then True else elem x xs)"
  fun delete :: "Nat => Nat list => Nat list" where
  "delete x (Nil2) = Nil2"
  | "delete x (Cons2 z xs) =
       (if equal2 x z then delete x xs else Cons2 z (delete x xs))"
  (*hipster equal2 elem delete *)
  theorem x0 :
    "~ (elem x (delete x xs))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory Base

imports Main

begin

type_synonym varName = nat
type_synonym typeName = nat

datatype "type" =
	Atom typeName
	| Arrow type type (infixr "->" 200)
	| Unit
        | Top

type_synonym varCtx = "varName => type"

datatype "term" =
      var "varName"
      | abs varName "type" "term"
      | app "term" "term"
      | unit

definition
  shift :: "(varName \<Rightarrow> 'a) \<Rightarrow> varName \<Rightarrow> 'a \<Rightarrow> varName \<Rightarrow> 'a"  ("_, <_:_>" [90, 0, 0] 91)
    where
      "\<Gamma>, <i:a> = (\<lambda>j. if j < i then \<Gamma> j else if j = i then a else \<Gamma> (j - 1))"

lemma shift_gt [simp]: "j < i \<Longrightarrow> (\<Gamma>, <i:T>) j = \<Gamma> j"
  by (simp add: shift_def)

lemma shift_lt [simp]: "i < j \<Longrightarrow> (\<Gamma>, <i:T>) j = \<Gamma> (j - 1)"
  by (simp add: shift_def)

primrec
  lift :: "[term, varName] => term"
where
    "lift (var i) x = (if i < x then var i else var (i + 1))"
  | "lift (app s t) x = app (lift s x) (lift t x)"
  | "lift (abs x T s) y = abs x T (lift s (y + 1))"
  | "lift unit x = unit"

primrec subst_term :: "[term, varName, term] => term" ("_[_ ~> _]" [300, 0, 0] 300)
	where
	subst_var: "(var x)[y ~> t] = (if x = y then t else if x < y then var x else var (x - 1))"
	| subst_app: "(app t1 t2)[y ~> t] = app (t1[y ~> t]) (t2[y ~> t])"
	| subst_abs: "(abs x T1 t1)[y ~> t] = abs x T1 (t1[y + 1 ~> lift t 0])"
	| subst_unit: "unit[y ~> t] = unit"

inductive "value" :: "term => bool"
  where
      val_abs: "value (abs _ _ _)"
      | val_unit: "value unit"

inductive "evaluation" :: "[term, term] \<Rightarrow> bool" (infixl "\<rightarrow>" 50)
  where
    e_app_1 [intro!]: "t1 \<rightarrow> t1' \<Longrightarrow> app t1 t2 \<rightarrow> app t1' t2"
  | e_app_2 [intro!]: "value t1 \<Longrightarrow> t2 \<rightarrow> t2' \<Longrightarrow> app t1 t2 \<rightarrow> app t1 t2'"
  | e_app_abs [intro!]: "value t2 \<Longrightarrow> app (abs x T t) t2 \<rightarrow> (t[x ~> t2])"

inductive subtyping :: "[type, type] => bool" (infixl "<:" 50)
  where
    s_refl [intro!]: "T <: T"
    | s_trans [intro!]: "T1 <: T2 ==> T2 <: T3 ==> T1 <: T3"
    | s_top [intro!]: "T <: Top"
    | s_arr [intro!]: "T1 <: S1 ==> S2 <: T2 ==> (S1 -> S2) <: (T1 -> T2)"

inductive typing :: "varCtx => term => type => bool" ("_ ⊢ _ : _" [50, 50, 50] 50)
  where
    t_abs [intro!]: "\<Gamma>, <x:T1> ⊢ t2 : T2 ==> \<Gamma> ⊢ abs x T1 t2 : (T1 -> T2)"
  | t_var [intro!]: "\<Gamma>(x) = T ==> \<Gamma> ⊢ var x : T"
  | t_app [intro!]: "\<Gamma> ⊢ t1 : (T1 -> T2) ==> \<Gamma> ⊢ t2 : T1 ==> \<Gamma>  ⊢ app t1 t2 : T2"
  | t_unit [intro!]: "\<Gamma> ⊢ unit : Unit"
  | t_sub [intro!]: "\<Gamma> ⊢ t : S ==> (S <: T) ==> \<Gamma> ⊢ t : T"

inductive_cases typing_elims [elim!]:
  "\<Gamma> ⊢ var x : T"
  "\<Gamma> ⊢ app t u : T"
  "\<Gamma> ⊢ abs x T1 t : T"
  "\<Gamma> ⊢ unit : Unit"

lemma subst_eq [simp]: "(var x)[x ~> t] = t"
  by simp

lemma subst_gt [simp]: "y < x ==> (var x)[y ~> t] = var (x - 1)"
  by simp

lemma subst_lt [simp]: "y > x ==> (var x)[y ~> t] = var x"
  by simp

lemma subtype_inversion_arrow [simp]:
  fixes T T1 T2 :: type
  assumes dt: "T = T1 -> T2"
  assumes s: "S <: T"
  shows "\<exists> S1 S2 . S = S1 -> S2 & S2 <: T2 & T1 <: S1"
  using s dt proof (induction arbitrary: T1 T2)
case (s_refl T)
  then show ?case
    by (simp add: subtyping.s_refl)
next
  case (s_trans T1 T2 T3)
  then show ?case
    by blast
next
  case (s_top T)
  then show ?case
    by auto
next
  case (s_arr T1 S1 S2 T2)
  then show ?case
    by auto
qed

lemma canonical_forms_abs [simp]:
  fixes t :: "term"
	assumes d: "\<Gamma> ⊢ t : (T1 -> T2)"
		and v: "value t"
assumes empty_context: "\<forall> x T . \<Gamma>(x) \<noteq> T"
	shows "\<exists> x T1 t2 . t = abs x T1 t2"
  using d v proof induction
  case (t_abs \<Gamma> x T1 t2 T2)
  then show ?case
    by simp
next
  case (t_var \<Gamma> x T)
  then show ?case
    using value.cases by blast
next
  case (t_app \<Gamma> t1 T1 T2 t2)
  then show ?case
    by (metis Base.term.simps(15) value.cases)
next
  case (t_unit \<Gamma>)
  then show ?case
    using empty_context by auto
next
  case (t_sub \<Gamma> t S T)
  then show ?case
    by blast
qed

lemma only_unit_subtype_unit:
  fixes T :: "type"
  assumes  s: "T <: Unit"
  assumes empty_context: "\<forall> x T . \<Gamma>(x) \<noteq> T"
  shows "T = Unit"
  using empty_context by auto

lemma canonical_forms_unit [simp]:
	fixes t :: "term"
	assumes d: "\<Gamma> ⊢ t : Unit"
	  and v: "value t"
	assumes empty_context: "\<forall> x T . \<Gamma>(x) \<noteq> T"
	shows "t = unit"
	using empty_context by auto

theorem progress:
  fixes t t' :: "term"
  fixes T :: "type"
	assumes d: "\<Gamma> ⊢ t : T"
  assumes empty_context: "\<forall> x T . \<Gamma>(x) \<noteq> T"
	shows "(value t) | (\<exists> t' . t \<rightarrow> t')"
	using d
  proof induction
    case (t_abs \<Gamma> x T1 t2 T2)
    then show ?case
      by (simp add: value.simps)
  next
    case (t_var \<Gamma> x T)
    from this empty_context show ?case
      by blast
  next
    case (t_app \<Gamma> t1 T1 T2 t2)
    then obtain t1' t2' where
        pt1: "\<Gamma> ⊢ t1 : T1 -> T2"
        and pt2: "\<Gamma> ⊢ t2 : T1"
        and t1ih: "value t1 | t1 \<rightarrow> t1'"
        and t2ih: "value t2 | t2 \<rightarrow> t2'"
      by auto
    from t1ih show ?case
    proof
      assume t1v: "value t1"
      from t2ih show ?case
      proof
        assume t2v: "value t2"
        then obtain x T3 t3 where
          t1_abs: "t1 = abs x T3 t3"
          using empty_context by blast
        then have d: "app (abs x T3 t3) t2 \<rightarrow> t3[x ~> t2]"  by (simp add: e_app_abs t2v t1_abs)
        show ?case
          using d t1_abs by blast
      next
        assume t2e: "t2 \<rightarrow> t2'"
        have te: "app t1 t2 \<rightarrow> app t1 t2'"
          by (simp add: e_app_2 t1v t2e)
        from te show ?case by auto
      qed
    next
      assume t1e: "t1 \<rightarrow> t1'"
      have te: "app t1 t2 \<rightarrow> app t1' t2"
        by (simp add: e_app_1 t1e)
      then show ?case by auto
    qed
  next
    case (t_unit \<Gamma>)
    then show ?case by (simp add: value.simps)
qed

lemma subst_lemma:
  fixes t1 t2 :: "term"
  fixes T1 T2 :: "type"
  fixes \<Gamma> :: "varCtx"
	assumes d1: "\<Gamma>, <x:T2> ⊢ t1 : T1"
		and d2: "\<Gamma> ⊢ t2 : T2"
	  and empty_context: "\<forall> x T . \<Gamma>(x) \<noteq> T"
	shows "\<Gamma> ⊢ t1[x ~> t2] : T1"
  using d1 d2 empty_context
  proof induction
    case (t_sub \<Gamma> t S T)
    then show ?case
      by auto
  next
    case (t_abs \<Gamma> x T1 t2 T2)
    then show ?case
      by auto
  next
    case (t_var \<Gamma> x T)
    then show ?case
      by auto
  next
    case (t_app \<Gamma> t1 T1 T2 t2)
    then show ?case
      by auto
  next
    case (t_unit \<Gamma>)
    then show ?case by auto
  qed

lemma values_dont_evaluate:
  fixes t :: "term"
  assumes v: "value t"
    and e: "\<exists> t'. t \<rightarrow> t'"
  shows False
  using e evaluation.cases v value.simps by blast

theorem preservation:
  fixes t t' :: "term"
	assumes d: "\<Gamma> ⊢ t : T"
		and e: "t \<rightarrow> t'"
		and empty_context: "\<forall> x T . \<Gamma>(x) \<noteq> T"
	shows "\<Gamma> ⊢ t' : T"
	using d e
  proof (induction arbitrary: t')
    case (t_sub \<Gamma> t S T)
    then show ?case
      using empty_context by auto
  next
    case (t_unit \<Gamma>)
    then show ?case
      using empty_context by auto
  next
    case (t_abs \<Gamma> x T1 t2 T2)
    then show ?case
      using empty_context by auto
  next
    case (t_var \<Gamma> x T)
    then show ?case
      using empty_context by auto
  next
    case (t_app \<Gamma> t1 T1 T2 t2)

    from this(5) this(1-4) show ?case
    proof (cases)
      case (e_app_1 t1')
      from this t_app have d1': "\<Gamma> ⊢ t1' : T1 -> T2"
        by simp
      show ?thesis
        using empty_context by auto
    next
        case (e_app_2 t2')
        from this have "app t1 t2 \<rightarrow> app t1 t2'"
          using t_app.prems by blast
        from this have "t2 \<rightarrow> t2'"
          by (simp add: local.e_app_2(3))
        from this(1) t_app(4) have "\<Gamma> ⊢ t2' : T1"
          by simp
        from this show ?thesis
          using empty_context by auto
    next
        case (e_app_abs x T t)
        from this have "app t1 t2 \<rightarrow> t[x ~> t2]"
          using t_app.prems by blast
      from this show ?thesis
        using empty_context by auto
    qed
  qed

end


           (*-------------------------------------------*
            |                                           |
            |      LW-CSP-Prover on Isabelle2021        |
            |                                           |
            *-------------------------------------------*)

theory CSP_semantics
imports CSP_syntax CSP_trace
begin

(*************************************************************

         1. Operational semantics of CSP
         2. Traces
         3. Trace refinement
         4.

 *************************************************************)

(* ----------------------------------------- *
 |       Operational semantics of CSP        |
 |           (all the transitions)           |
 * ----------------------------------------- *)

inductive
   trn :: "('p,'a) proc \<Rightarrow> 'a event \<Rightarrow> ('p,'a) proc \<Rightarrow> bool"
                     ("(1_ /---_---> _)" [60,1000,61] 61)
where
   Prefix:
    "a -> P ---(Ev a)---> P"
 | ExtCh1:
    "P ---(Ev a)---> P' \<Longrightarrow>
     P [+] Q ---(Ev a)---> P'"
 | ExtCh2:
    "Q ---(Ev a)---> Q' \<Longrightarrow>
     P [+] Q ---(Ev a)---> Q'"
 | ExtCh3:
    "P ---Tau---> P' \<Longrightarrow>
     P [+] Q ---Tau---> P' [+] Q"
 | ExtCh4:
    "Q ---Tau---> Q' \<Longrightarrow>
     P [+] Q ---Tau---> P [+] Q'"
 | IntCh1:
    "P |~| Q ---Tau---> P"
 | IntCh2:
    "P |~| Q ---Tau---> Q"
 | NatExtCh1:
    "Pf n ---(Ev a)---> P' \<and> n \<in> N \<Longrightarrow>
     [nat] :N .. Pf ---(Ev a)---> P'"
 | NatExtCh2:
    "Pf n ---Tau---> P' \<and> n \<in> N \<Longrightarrow>
     [nat] :N .. Pf ---Tau--->
     [nat] :N ..(%m. if n=m then P' else Pf m)"
 | RepIntCh:
    "a \<in> X \<Longrightarrow>
     !! :X .. Pf ---Tau---> Pf a"
 | If1:
    "P ---e---> P' \<and> b \<Longrightarrow>
     IF b THEN P ELSE Q ---e---> P'"
 | If2:
    "Q ---e---> Q' \<and> \<not>b \<Longrightarrow>
     IF b THEN P ELSE Q ---e---> Q'"
 | Para1:
    "P ---e---> P' \<and> e \<notin> Ev ` X \<Longrightarrow>
     P |[X]| Q ---e---> P' |[X]| Q"
 | Para2:
    "Q ---e---> Q' \<and> e \<notin> Ev ` X \<Longrightarrow>
     P |[X]| Q ---e---> P |[X]| Q'"
 | Para3:
    "P ---(Ev a)---> P' \<and> Q ---(Ev a)---> Q' \<and> a \<in> X \<Longrightarrow>
     P |[X]| Q ---(Ev a)---> P' |[X]| Q'"
 | Hide1:
    "P ---e---> P' \<and> e \<notin> Ev ` X \<Longrightarrow>
     P ~~ X ---e---> P' ~~ X"
 | Hide2:
    "P ---(Ev a)---> P' \<and> a \<in> X \<Longrightarrow>
     P ~~ X ---Tau---> P' ~~ X"
 | Ren1:
    "P ---(Ev a)---> P' \<and> (a,b) \<in> r \<Longrightarrow>
     P [[r]] ---(Ev b)---> P' [[r]]"
 | Ren2:
    "P ---e---> P' \<and> e \<notin> Ev ` fst ` r \<Longrightarrow>
     P [[r]] ---e---> P' [[r]]"
 | PName:
    "PNfun p ---e---> P' \<Longrightarrow>
     $p ---e---> P'"

(*OK*)
(* a transition to P' for some P' *)

definition
  trn_ex :: "('p,'a) proc => 'a event => bool"
               ("(1_ /---_--->+)" [60,1000] 61)
where
  "P ---e--->+ == (EX P'. P ---e---> P')"

(* ----------------------------------------- *
 |              Traces model                 |
 * ----------------------------------------- *)

(* Sequential transition *)

inductive
  seq_trn :: "('p,'a) proc => 'a ev_list => ('p,'a) proc => bool"
                     ("(1_ /---_--->> _)" [60,1000,61] 61)
where
   Nil:
    "P ---[]--->> P"
 | Base:
    "P ---e---> P' ==>
     P ---[e]--->> P'"
 | Step:
    "(EX P1 e s. P ---e---> P1 & P1 ---s--->> P' & s' = e#s) ==>
     P ---s'--->> P'"

(* the set of traces *)

definition
  traces  :: "('p,'a) proc => 'a list set"
where
  "traces(P) == {t. EX s P'. t = rem_tau(s) & P ---s--->> P'}"

(* trace-refinement *)

definition
  refT :: "('p,'a) proc => ('q,'a) proc => bool"
                               ("(0_ /[T= /_)" [51,50] 50)
  where
  "P1 [T= P2 == traces(P2) <= traces(P1)"

definition
  eqT :: "('p,'a) proc => ('q,'a) proc => bool"
                               ("(0_ /=T /_)" [51,50] 50)
  where
  "P1 =T P2 == traces(P1) = traces(P2)"

(* ----------------------------------------- *
 |             failures model                |
 * ----------------------------------------- *)

definition
  stable ::"('p,'a) proc => bool"
where
  "stable(P) == (~ (P ---Tau--->+))"

definition
  refs ::"('p,'a) proc => 'a set"
where
  "refs(P) == {a. ~(P ---(Ev a)--->+) & stable(P)}"

definition
  failures ::"('p,'a) proc => ('a list * 'a set) set"
where
  "failures(P)
    == {(t,X). EX s P'. t = rem_tau(s) & stable(P')
                     & P---s--->> P' & X <= refs(P')}"

definition
  refF :: "('p,'a) proc => ('q,'a) proc => bool"
                               ("(0_ /[F= /_)" [51,50] 50)
  where
  "P1 [F= P2 == (  (traces(P2) <= traces(P1))
                 & (failures(P2) <= failures(P1)))"

definition
  DeadlockFree ::"('p,'a) proc => 'a set => 'a => bool"
where
  "DeadlockFree P E f
    == ALL t X. (t,X):failures(P) --> ( E ~= X | f : set t)"

(* ----------------------------------------- *
 |           Weak transition (Tau)           |
 * ----------------------------------------- *)

(* tau transition *)

definition
  tau_trn :: "('p,'a) proc => ('p,'a) proc => bool"
                     ("(1_ /====> _)" [60,61] 61)
where
  "P ====> P' == EX s. P ---s--->> P' & rem_tau(s) = []"

(* weak transition *)

definition
  weak_trn :: "('p,'a) proc => 'a event => ('p,'a) proc => bool"
                     ("(1_ /===_===> _)" [60,1000, 61] 61)
where
  "P ===e===> P' == EX P1 P2. P ====> P1 & P1 ---e---> P2 & P2 ====> P'"

(* rem weak transition *)

definition
  weak_tau_trn :: "('p,'a) proc => 'a event => ('p,'a) proc => bool"
                     ("(1_ /===^_===> _)" [60,1000, 61] 61)
where
  "P ===^e===> P' == (EX a. P ===(Ev a)===> P' & e = Ev a) | (P ====> P' & e = Tau)"

(* ----------------------------------------- *
 |                    lemmas                 |
 * ----------------------------------------- *)

lemma DeadlockFree_refF:
  "DeadlockFree P1 E f ==> P1 [F= P2 ==> DeadlockFree P2 E f"
  apply (simp add: DeadlockFree_def)
  apply (simp add: refF_def)
  apply (intro allI impI)
  apply (drule_tac x="t" in spec)
  apply (auto)
  done

lemma seq_trn_nil:
  "(P ---[]--->> P') = (P = P')"
  apply (rule iffI)
   (* --> *)
   apply (erule seq_trn.cases)
     apply (simp_all)
   (* <-- *)
   apply (rule seq_trn.intros)
  done

lemma seq_trn_step:
  "(P ---(a#s)--->> P') =
   (EX P1. P ---a---> P1 & P1---s--->> P')"
  apply (rule iffI)

   (* --> *)
   apply (erule seq_trn.cases)
     apply (simp_all)

    apply (rule_tac x="P'a" in exI)
    apply (simp)
    apply (rule seq_trn.intros)

   apply (elim exE conjE)
   apply (rule_tac x="P1" in exI)
   apply (simp)

   (* <-- *)

  apply (rule Step)
  apply (elim exE conjE)   (* apply (auto) *)
  apply (simp)
  apply (rule_tac x="P1" in exI)
  apply (simp)
  done

lemma seq_trn_base:
  "(P ---[Ev a]--->> P') = (P ---(Ev a)---> P')"
  apply (insert seq_trn_step[of P "Ev a" "[]" P'])
  apply (simp add: seq_trn_nil)
  done

lemma seq_trn_append_ALL:
  "ALL s1 s2 P P'.
   (P ---(s1@s2)--->> P') =
   (EX P1. P ---s1--->> P1 & P1---s2--->> P')"
  apply (rule allI)
  apply (induct_tac s1)

   (* nil case *)
   apply (simp add: seq_trn_nil)

  (* step case *)
  apply (simp)
  apply (intro allI)
  apply (simp add: seq_trn_step)
  apply (rule iffI)

  (* --> *)
   apply (elim exE conjE)
   apply (rule_tac x="P1a" in exI)
   apply (simp)
   apply (rule_tac x="P1" in exI)
   apply (simp)

  (* <-- *)
  apply (elim exE conjE)
  apply (rule_tac x="P1a" in exI)
  apply (simp)
  apply (rule_tac x="P1" in exI)
  apply (simp)
  done

lemma seq_trn_append:
  "(P ---(s1@s2)--->> P') =
   (EX P1. P ---s1--->> P1 & P1---s2--->> P')"
  apply (simp add: seq_trn_append_ALL)
  done

lemma seq_trn_conc:
  "(P ---(Ev a#s2)--->> P') =
   (EX P1. P ---(Ev a)---> P1 & P1---s2--->> P')"
  apply (insert seq_trn_append[of P "[Ev a]" "s2" P'])
  apply (simp add: seq_trn_base)
  done

lemma seq_trn_STOP:
  "(STOP ---t--->> P') = (t = [] & P' = STOP)"
  apply (rule iffI)
   (* --> *)
   apply (erule seq_trn.cases, auto)
   apply (erule trn.cases, auto)+
   (* <-- *)
   apply (simp add: seq_trn_nil)
  done

lemma weak_trn_seq_trn:
  "(P ===(Ev a)===> P') =
   (EX t. P ---t--->> P' & rem_tau t = [a])"
  apply (simp add: weak_trn_def)
  apply (simp add: tau_trn_def)
  apply (rule iffI)

   (* --> *)
   apply (elim exE conjE)
   apply (rule_tac x="s@[Ev a]@sa" in exI)
   apply (simp add: seq_trn_append)
   apply (simp add: rem_tau_append)
   apply (rule_tac x="P1" in exI)
   apply (simp)
   apply (rule Step)
   apply (simp)
   apply (rule_tac x="P2" in exI)
   apply (simp)

   (* <-- *)
  apply (simp add: rem_tau_ev)
  apply (elim exE conjE)
  apply (simp add: seq_trn_append)
  apply (elim exE conjE)
  apply (simp add: seq_trn_conc)
  apply (elim exE conjE)

  apply (rule_tac x="P1" in exI)
  apply (rule conjI)
   apply (rule_tac x="s1" in exI)
   apply (simp)
  apply (rule_tac x="P1a" in exI)
  apply (simp)
  apply (rule_tac x="s2" in exI)
  apply (simp)
  done

lemma weak_tau_trn_seq_trn:
  "(P ===^e===> P') =
   (EX t. P ---t--->> P' & rem_tau t = obs e)"
  apply (simp add: weak_tau_trn_def)
  apply (simp add: weak_trn_seq_trn)
  apply (rule iffI)

   (* --> *)
   apply (elim disjE exE conjE)
    apply (rule_tac x="t" in exI)
    apply (simp)

   apply (simp add: tau_trn_def)

   (* <-- *)
  apply (insert ev_or_tau)
  apply (drule_tac x="e" in spec)
  apply (elim disjE exE conjE)

   (* Ev *)
  apply (simp)
   apply (rule_tac x="t" in exI)
   apply (simp)

   (* Tau *)
  apply (simp add: tau_trn_def)
  apply (rule_tac x="t" in exI)
  apply (simp)
  done

lemma weak_tau_trn_id:
  "P ===^Tau===> P"
  apply (simp add: weak_tau_trn_seq_trn)
  apply (rule_tac x="[]" in exI)
  apply (simp)
  apply (simp add: seq_trn_nil)
  done

lemma stop_trn_asm:
"STOP ---a---> P' ==> x"
  apply (erule trn.cases, auto)
  done

lemma stop_no_trn:
"~(STOP ---a---> P')"
  apply (case_tac "~(STOP ---a---> P')")
   apply (simp)
  apply (simp)
  apply (rule stop_trn_asm)
  apply (simp)
  done

lemma stop_seq_trn:
"ALL t P'. STOP ---t--->> P' --> t = [] & P' = STOP"
  apply (rule allI)
  apply (rule allI)
  apply (induct_tac t)
   apply (simp)
   apply (simp add: seq_trn_nil)

  apply (simp)
  apply (simp add: seq_trn_step)
  apply (rule allI)
  apply (rule impI)
  apply (simp add: stop_no_trn)
  done

end