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


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_weird_nat_mul3_spec
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun times :: "Nat => Nat => Nat" where
  "times (Z) y = Z"
| "times (S z) y = plus y (times z y)"

fun add3 :: "Nat => Nat => Nat => Nat" where
  "add3 (Z) (Z) z = z"
| "add3 (Z) (S x3) z = plus (S Z) (add3 Z x3 z)"
| "add3 (S x2) y z = plus (S Z) (add3 x2 y z)"

fun mul3 :: "Nat => Nat => Nat => Nat" where
  "mul3 (Z) y z = Z"
| "mul3 (S x2) (Z) z = Z"
| "mul3 (S x2) (S x3) (Z) = Z"
| "mul3 (S x2) (S x3) (S x4) =
     (let fail :: Nat =
       plus
         (S Z)
         (add3
            (mul3 x2 x3 x4)
            (add3 (mul3 (S Z) x3 x4) (mul3 x2 (S Z) x4) (mul3 x2 x3 (S Z)))
            (add3 x2 x3 x4))
     in (if (x2 = Z) then
           (if (x3 = Z) then (if (x4 = Z) then S Z else fail) else fail)
           else
           fail))"

theorem property0 :
  "((mul3 x y z) = (times (times x y) z))"
  oops

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