/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/

import algebra.star.unitary
import data.nat.modeq
import number_theory.zsqrtd.basic

/-!
# Pell's equation and Matiyasevic's theorem

This file solves Pell's equation, i.e. integer solutions to `x ^ 2 - d * y ^ 2 = 1`
*in the special case that `d = a ^ 2 - 1`*.
This is then applied to prove Matiyasevic's theorem that the power
function is Diophantine, which is the last key ingredient in the solution to Hilbert's tenth
problem. For the definition of Diophantine function, see `number_theory.dioph.lean`.

For results on Pell's equation for arbitrary (positive, non-square) `d`, see
`number_theory.pell`.

## Main definition

* `pell` is a function assigning to a natural number `n` the `n`-th solution to Pell's equation
  constructed recursively from the initial solution `(0, 1)`.

## Main statements

* `eq_pell` shows that every solution to Pell's equation is recursively obtained using `pell`
* `matiyasevic` shows that a certain system of Diophantine equations has a solution if and only if
  the first variable is the `x`-component in a solution to Pell's equation - the key step towards
  Hilbert's tenth problem in Davis' version of Matiyasevic's theorem.
* `eq_pow_of_pell` shows that the power function is Diophantine.

## Implementation notes

The proof of Matiyasevic's theorem doesn't follow Matiyasevic's original account of using Fibonacci
numbers but instead Davis' variant of using solutions to Pell's equation.

## References

* [M. Carneiro, _A Lean formalization of Matiyasevič's theorem_][carneiro2018matiyasevic]
* [M. Davis, _Hilbert's tenth problem is unsolvable_][MR317916]

## Tags

Pell's equation, Matiyasevic's theorem, Hilbert's tenth problem

-/

namespace pell
open nat

section
variables {d : ℤ}

/-- The property of being a solution to the Pell equation, expressed
  as a property of elements of `ℤ√d`. -/
def is_pell : ℤ√d → Prop | ⟨x, y⟩ := x*x - d*y*y = 1

theorem is_pell_norm : Π {b : ℤ√d}, is_pell b ↔ b * star b = 1
| ⟨x, y⟩ := by simp [zsqrtd.ext, is_pell, mul_comm]; ring_nf

theorem is_pell_iff_mem_unitary : Π {b : ℤ√d}, is_pell b ↔ b ∈ unitary ℤ√d
| ⟨x, y⟩ := by rw [unitary.mem_iff, is_pell_norm, mul_comm (star _), and_self]

theorem is_pell_mul {b c : ℤ√d} (hb : is_pell b) (hc : is_pell c) : is_pell (b * c) :=
is_pell_norm.2 (by simp [mul_comm, mul_left_comm, star_mul, is_pell_norm.1 hb, is_pell_norm.1 hc])

theorem is_pell_star : ∀ {b : ℤ√d}, is_pell b ↔ is_pell (star b) | ⟨x, y⟩ :=
by simp [is_pell, zsqrtd.star_mk]

end

section
parameters {a : ℕ} (a1 : 1 < a)

include a1
private def d := a*a - 1

@[simp] theorem d_pos : 0 < d :=
tsub_pos_of_lt (mul_lt_mul a1 (le_of_lt a1) dec_trivial dec_trivial : 1*1<a*a)

/-- The Pell sequences, i.e. the sequence of integer solutions to `x ^ 2 - d * y ^ 2 = 1`, where
`d = a ^ 2 - 1`, defined together in mutual recursion. -/
-- TODO(lint): Fix double namespace issue
@[nolint dup_namespace] def pell : ℕ → ℕ × ℕ :=
λn, nat.rec_on n (1, 0) (λn xy, (xy.1*a + d*xy.2, xy.1 + xy.2*a))

/-- The Pell `x` sequence. -/
def xn (n : ℕ) : ℕ := (pell n).1
/-- The Pell `y` sequence. -/
def yn (n : ℕ) : ℕ := (pell n).2

@[simp] theorem pell_val (n : ℕ) : pell n = (xn n, yn n) :=
show pell n = ((pell n).1, (pell n).2), from match pell n with (a, b) := rfl end

@[simp] theorem xn_zero : xn 0 = 1 := rfl
@[simp] theorem yn_zero : yn 0 = 0 := rfl

@[simp] theorem xn_succ (n : ℕ) : xn (n+1) = xn n * a + d * yn n := rfl
@[simp] theorem yn_succ (n : ℕ) : yn (n+1) = xn n + yn n * a := rfl

@[simp] theorem xn_one : xn 1 = a := by simp
@[simp] theorem yn_one : yn 1 = 1 := by simp

/-- The Pell `x` sequence, considered as an integer sequence.-/
def xz (n : ℕ) : ℤ := xn n
/-- The Pell `y` sequence, considered as an integer sequence.-/
def yz (n : ℕ) : ℤ := yn n

section
omit a1

/-- The element `a` such that `d = a ^ 2 - 1`, considered as an integer.-/
def az : ℤ := a

end

theorem asq_pos : 0 < a*a :=
le_trans (le_of_lt a1) (by have := @nat.mul_le_mul_left 1 a a (le_of_lt a1); rwa mul_one at this)

theorem dz_val : ↑d = az*az - 1 :=
have 1 ≤ a*a, from asq_pos,
show ↑(a*a - 1) = _, by rw int.coe_nat_sub this; refl

@[simp] theorem xz_succ (n : ℕ) : xz (n+1) = xz n * az + ↑d * yz n := rfl
@[simp] theorem yz_succ (n : ℕ) : yz (n+1) = xz n + yz n * az := rfl

/-- The Pell sequence can also be viewed as an element of `ℤ√d` -/
def pell_zd (n : ℕ) : ℤ√d := ⟨xn n, yn n⟩
@[simp] theorem pell_zd_re (n : ℕ) : (pell_zd n).re = xn n := rfl
@[simp] theorem pell_zd_im (n : ℕ) : (pell_zd n).im = yn n := rfl

theorem is_pell_nat {x y : ℕ} : is_pell (⟨x, y⟩ : ℤ√d) ↔ x*x - d*y*y = 1 :=
⟨λh, int.coe_nat_inj
  (by rw int.coe_nat_sub (int.le_of_coe_nat_le_coe_nat $ int.le.intro_sub h); exact h),
λh, show ((x*x : ℕ) - (d*y*y:ℕ) : ℤ) = 1,
  by rw [← int.coe_nat_sub $ le_of_lt $ nat.lt_of_sub_eq_succ h, h]; refl⟩

@[simp] theorem pell_zd_succ (n : ℕ) : pell_zd (n+1) = pell_zd n * ⟨a, 1⟩ :=
by simp [zsqrtd.ext]

theorem is_pell_one : is_pell (⟨a, 1⟩ : ℤ√d) :=
show az*az-d*1*1=1, by simp [dz_val]; ring

theorem is_pell_pell_zd : ∀ (n : ℕ), is_pell (pell_zd n)
| 0     := rfl
| (n+1) := let o := is_pell_one in by simp; exact pell.is_pell_mul (is_pell_pell_zd n) o

@[simp] theorem pell_eqz (n : ℕ) : xz n * xz n - d * yz n * yz n = 1 := is_pell_pell_zd n

@[simp] theorem pell_eq (n : ℕ) : xn n * xn n - d * yn n * yn n = 1 :=
let pn := pell_eqz n in
have h : (↑(xn n * xn n) : ℤ) - ↑(d * yn n * yn n) = 1,
  by repeat {rw int.coe_nat_mul}; exact pn,
have hl : d * yn n * yn n ≤ xn n * xn n, from
  int.le_of_coe_nat_le_coe_nat $ int.le.intro $ add_eq_of_eq_sub' $ eq.symm h,
int.coe_nat_inj (by rw int.coe_nat_sub hl; exact h)

instance dnsq : zsqrtd.nonsquare d := ⟨λn h,
  have n*n + 1 = a*a, by rw ← h; exact nat.succ_pred_eq_of_pos (asq_pos a1),
  have na : n < a, from nat.mul_self_lt_mul_self_iff.2 (by rw ← this; exact nat.lt_succ_self _),
  have (n+1)*(n+1) ≤ n*n + 1, by rw this; exact nat.mul_self_le_mul_self na,
  have n+n ≤ 0, from @nat.le_of_add_le_add_right (n*n + 1) _ _ (by ring_nf at this ⊢; assumption),
  ne_of_gt d_pos $ by rwa nat.eq_zero_of_le_zero ((nat.le_add_left _ _).trans this) at h⟩

theorem xn_ge_a_pow : ∀ (n : ℕ), a^n ≤ xn n
| 0     := le_refl 1
| (n+1) := by simp [pow_succ']; exact le_trans
  (nat.mul_le_mul_right _ (xn_ge_a_pow n)) (nat.le_add_right _ _)

theorem n_lt_a_pow : ∀ (n : ℕ), n < a^n
| 0     := nat.le_refl 1
| (n+1) := begin have IH := n_lt_a_pow n,
  have : a^n + a^n ≤ a^n * a,
  { rw ← mul_two, exact nat.mul_le_mul_left _ a1 },
  simp [pow_succ'], refine lt_of_lt_of_le _ this,
  exact add_lt_add_of_lt_of_le IH (lt_of_le_of_lt (nat.zero_le _) IH)
end

theorem n_lt_xn (n) : n < xn n :=
lt_of_lt_of_le (n_lt_a_pow n) (xn_ge_a_pow n)

theorem x_pos (n) : 0 < xn n :=
lt_of_le_of_lt (nat.zero_le n) (n_lt_xn n)

lemma eq_pell_lem : ∀n (b:ℤ√d), 1 ≤ b → is_pell b → b ≤ pell_zd n → ∃n, b = pell_zd n
| 0     b := λh1 hp hl, ⟨0, @zsqrtd.le_antisymm _ dnsq _ _ hl h1⟩
| (n+1) b := λh1 hp h,
  have a1p : (0:ℤ√d) ≤ ⟨a, 1⟩, from trivial,
  have am1p : (0:ℤ√d) ≤ ⟨a, -1⟩, from show (_:nat) ≤ _, by simp; exact nat.pred_le _,
  have a1m : (⟨a, 1⟩ * ⟨a, -1⟩ : ℤ√d) = 1, from is_pell_norm.1 is_pell_one,
  if ha : (⟨↑a, 1⟩ : ℤ√d) ≤ b then
    let ⟨m, e⟩ := eq_pell_lem n (b * ⟨a, -1⟩)
      (by rw ← a1m; exact mul_le_mul_of_nonneg_right ha am1p)
      (is_pell_mul hp (is_pell_star.1 is_pell_one))
      (by have t := mul_le_mul_of_nonneg_right h am1p;
        rwa [pell_zd_succ, mul_assoc, a1m, mul_one] at t) in
    ⟨m+1, by rw [show b = b * ⟨a, -1⟩ * ⟨a, 1⟩, by rw [mul_assoc, eq.trans (mul_comm _ _) a1m];
      simp, pell_zd_succ, e]⟩
  else
    suffices ¬1 < b, from ⟨0, show b = 1, from (or.resolve_left (lt_or_eq_of_le h1) this).symm⟩,
    λ h1l, by cases b with x y; exact
    have bm : (_*⟨_,_⟩ :ℤ√(d a1)) = 1, from pell.is_pell_norm.1 hp,
    have y0l : (0:ℤ√(d a1)) < ⟨x - x, y - -y⟩,
      from sub_lt_sub h1l $ λ(hn : (1:ℤ√(d a1)) ≤ ⟨x, -y⟩),
        by have t := mul_le_mul_of_nonneg_left hn (le_trans zero_le_one h1);
          rw [bm, mul_one] at t; exact h1l t,
    have yl2 : (⟨_, _⟩ : ℤ√_) < ⟨_, _⟩, from
      show (⟨x, y⟩ - ⟨x, -y⟩ : ℤ√(d a1)) < ⟨a, 1⟩ - ⟨a, -1⟩, from
      sub_lt_sub (by exact ha) $ λ(hn : (⟨x, -y⟩ : ℤ√(d a1)) ≤ ⟨a, -1⟩),
      by have t := mul_le_mul_of_nonneg_right
        (mul_le_mul_of_nonneg_left hn (le_trans zero_le_one h1)) a1p;
          rw [bm, one_mul, mul_assoc, eq.trans (mul_comm _ _) a1m, mul_one] at t; exact ha t,
    by simp at y0l; simp at yl2; exact
    match y, y0l, (yl2 : (⟨_, _⟩ : ℤ√_) < ⟨_, _⟩) with
    | 0, y0l, yl2 := y0l (le_refl 0)
    | (y+1 : ℕ), y0l, yl2 := yl2 (zsqrtd.le_of_le_le (le_refl 0)
        (let t := int.coe_nat_le_coe_nat_of_le (nat.succ_pos y) in add_le_add t t))
    | -[1+y], y0l, yl2 := y0l trivial
    end

theorem eq_pell_zd (b : ℤ√d) (b1 : 1 ≤ b) (hp : is_pell b) : ∃n, b = pell_zd n :=
let ⟨n, h⟩ := @zsqrtd.le_arch d b in
eq_pell_lem n b b1 hp $ h.trans $ by rw zsqrtd.coe_nat_val; exact
zsqrtd.le_of_le_le
  (int.coe_nat_le_coe_nat_of_le $ le_of_lt $ n_lt_xn _ _) (int.coe_zero_le _)

/-- Every solution to **Pell's equation** is recursively obtained from the initial solution
`(1,0)` using the recursion `pell`. -/
theorem eq_pell {x y : ℕ} (hp : x*x - d*y*y = 1) : ∃n, x = xn n ∧ y = yn n :=
have (1:ℤ√d) ≤ ⟨x, y⟩, from match x, hp with
| 0,    (hp : 0 - _ = 1) := by rw zero_tsub at hp; contradiction
| (x+1), hp := zsqrtd.le_of_le_le (int.coe_nat_le_coe_nat_of_le $ nat.succ_pos x)
                (int.coe_zero_le _)
end,
let ⟨m, e⟩ := eq_pell_zd ⟨x, y⟩ this (is_pell_nat.2 hp) in
⟨m, match x, y, e with ._, ._, rfl := ⟨rfl, rfl⟩ end⟩

theorem pell_zd_add (m) : ∀ n, pell_zd (m + n) = pell_zd m * pell_zd n
| 0     := (mul_one _).symm
| (n+1) := by rw[← add_assoc, pell_zd_succ, pell_zd_succ, pell_zd_add n, ← mul_assoc]

theorem xn_add (m n) : xn (m + n) = xn m * xn n + d * yn m * yn n :=
by injection (pell_zd_add _ m n) with h _;
    repeat {rw ← int.coe_nat_add at h <|> rw ← int.coe_nat_mul at h};
    exact int.coe_nat_inj h

theorem yn_add (m n) : yn (m + n) = xn m * yn n + yn m * xn n :=
by injection (pell_zd_add _ m n) with _ h;
    repeat {rw ← int.coe_nat_add at h <|> rw ← int.coe_nat_mul at h};
    exact int.coe_nat_inj h

theorem pell_zd_sub {m n} (h : n ≤ m) : pell_zd (m - n) = pell_zd m * star (pell_zd n) :=
let t := pell_zd_add n (m - n) in
by rw [add_tsub_cancel_of_le h] at t;
    rw [t, mul_comm (pell_zd _ n) _, mul_assoc, is_pell_norm.1 (is_pell_pell_zd _ _), mul_one]

theorem xz_sub {m n} (h : n ≤ m) : xz (m - n) = xz m * xz n - d * yz m * yz n :=
by { rw [sub_eq_add_neg, ←mul_neg], exact congr_arg zsqrtd.re (pell_zd_sub a1 h) }

theorem yz_sub {m n} (h : n ≤ m) : yz (m - n) = xz n * yz m - xz m * yz n :=
by { rw [sub_eq_add_neg, ←mul_neg, mul_comm, add_comm],
  exact congr_arg zsqrtd.im (pell_zd_sub a1 h) }

theorem strict_mono_y : strict_mono yn
| m 0     h := absurd h $ nat.not_lt_zero _
| m (n+1) h :=
  have yn m ≤ yn n, from or.elim (lt_or_eq_of_le $ nat.le_of_succ_le_succ h)
    (λhl, le_of_lt $ strict_mono_y hl) (λe, by rw e),
  by simp; refine lt_of_le_of_lt _ (nat.lt_add_of_pos_left $ x_pos a1 n);
      rw ← mul_one (yn a1 m);
      exact mul_le_mul this (le_of_lt a1) (nat.zero_le _) (nat.zero_le _)

theorem strict_mono_x : strict_mono xn
| m 0     h := absurd h $ nat.not_lt_zero _
| m (n+1) h :=
  have xn m ≤ xn n, from or.elim (lt_or_eq_of_le $ nat.le_of_succ_le_succ h)
    (λhl, le_of_lt $ strict_mono_x hl) (λe, by rw e),
  by simp; refine lt_of_lt_of_le (lt_of_le_of_lt this _) (nat.le_add_right _ _);
      have t := nat.mul_lt_mul_of_pos_left a1 (x_pos a1 n); rwa mul_one at t

theorem yn_ge_n : Π n, n ≤ yn n
| 0 := nat.zero_le _
| (n+1) := show n < yn (n+1), from lt_of_le_of_lt (yn_ge_n n) (strict_mono_y $ nat.lt_succ_self n)

theorem y_mul_dvd (n) : ∀k, yn n ∣ yn (n * k)
| 0     := dvd_zero _
| (k+1) := by rw [nat.mul_succ, yn_add]; exact
  dvd_add (dvd_mul_left _ _) ((y_mul_dvd k).mul_right _)

theorem y_dvd_iff (m n) : yn m ∣ yn n ↔ m ∣ n :=
⟨λh, nat.dvd_of_mod_eq_zero $ (nat.eq_zero_or_pos _).resolve_right $ λhp,
  have co : nat.coprime (yn m) (xn (m * (n / m))), from nat.coprime.symm $
    (xy_coprime _).coprime_dvd_right (y_mul_dvd m (n / m)),
  have m0 : 0 < m, from m.eq_zero_or_pos.resolve_left $
    λe, by rw [e, nat.mod_zero] at hp; rw [e] at h; exact
    ne_of_lt (strict_mono_y a1 hp) (eq_zero_of_zero_dvd h).symm,
  by rw [← nat.mod_add_div n m, yn_add] at h; exact
  not_le_of_gt (strict_mono_y _ $ nat.mod_lt n m0)
    (nat.le_of_dvd (strict_mono_y _ hp) $ co.dvd_of_dvd_mul_right $
    (nat.dvd_add_iff_right $ (y_mul_dvd _ _ _).mul_left _).2 h),
λ⟨k, e⟩, by rw e; apply y_mul_dvd⟩

theorem xy_modeq_yn (n) :
  ∀ k, xn (n * k) ≡ (xn n)^k [MOD (yn n)^2]
    ∧ yn (n * k) ≡ k * (xn n)^(k-1) * yn n [MOD (yn n)^3]
| 0     := by constructor; simp
| (k+1) :=
  let ⟨hx, hy⟩ := xy_modeq_yn k in
  have L : xn (n * k) * xn n + d * yn (n * k) * yn n ≡ xn n^k * xn n + 0 [MOD yn n^2], from
    (hx.mul_right _ ).add $ modeq_zero_iff_dvd.2 $
    by rw pow_succ'; exact
    mul_dvd_mul_right (dvd_mul_of_dvd_right (modeq_zero_iff_dvd.1 $
      (hy.of_dvd $ by simp [pow_succ']).trans $ modeq_zero_iff_dvd.2 $
      by simp [-mul_comm, -mul_assoc]) _) _,
  have R : xn (n * k) * yn n + yn (n * k) * xn n ≡
            xn n^k * yn n + k * xn n^k * yn n [MOD yn n^3], from
  modeq.add (by { rw pow_succ', exact hx.mul_right' _ }) $
    have k * xn n^(k - 1) * yn n * xn n = k * xn n^k * yn n,
      by clear _let_match; cases k with k; simp [pow_succ', mul_comm, mul_left_comm],
    by { rw ← this, exact hy.mul_right _ },
  by { rw [add_tsub_cancel_right, nat.mul_succ, xn_add, yn_add, pow_succ' (xn _ n),
          nat.succ_mul, add_comm (k * xn _ n^k) (xn _ n^k), right_distrib],
      exact ⟨L, R⟩ }

theorem ysq_dvd_yy (n) : yn n * yn n ∣ yn (n * yn n) :=
modeq_zero_iff_dvd.1 $
  ((xy_modeq_yn n (yn n)).right.of_dvd $ by simp [pow_succ]).trans
  (modeq_zero_iff_dvd.2 $ by simp [mul_dvd_mul_left, mul_assoc])

theorem dvd_of_ysq_dvd {n t} (h : yn n * yn n ∣ yn t) : yn n ∣ t :=
have nt : n ∣ t, from (y_dvd_iff n t).1 $ dvd_of_mul_left_dvd h,
n.eq_zero_or_pos.elim (λ n0, by rwa n0 at ⊢ nt) $ λ (n0l : 0 < n),
let ⟨k, ke⟩ := nt in
have yn n ∣ k * (xn n)^(k-1), from
nat.dvd_of_mul_dvd_mul_right (strict_mono_y n0l) $ modeq_zero_iff_dvd.1 $
  by have xm := (xy_modeq_yn a1 n k).right; rw ← ke at xm; exact
  (xm.of_dvd $ by simp [pow_succ]).symm.trans h.modeq_zero_nat,
by rw ke; exact dvd_mul_of_dvd_right
  (((xy_coprime _ _).pow_left _).symm.dvd_of_dvd_mul_right this) _

theorem pell_zd_succ_succ (n) : pell_zd (n + 2) + pell_zd n = (2 * a : ℕ) * pell_zd (n + 1) :=
have (1:ℤ√d) + ⟨a, 1⟩ * ⟨a, 1⟩ = ⟨a, 1⟩ * (2 * a),
by { rw zsqrtd.coe_nat_val, change (⟨_,_⟩:ℤ√(d a1))=⟨_,_⟩,
    rw dz_val, dsimp [az], rw zsqrtd.ext, dsimp, split; ring },
by simpa [mul_add, mul_comm, mul_left_comm, add_comm] using congr_arg (* pell_zd a1 n) this

theorem xy_succ_succ (n) : xn (n + 2) + xn n = (2 * a) * xn (n + 1) ∧
                            yn (n + 2) + yn n = (2 * a) * yn (n + 1) := begin
  have := pell_zd_succ_succ a1 n, unfold pell_zd at this,
  erw [zsqrtd.smul_val (2 * a : ℕ)] at this,
  injection this with h₁ h₂,
  split; apply int.coe_nat_inj; [simpa using h₁, simpa using h₂]
end

theorem xn_succ_succ (n) : xn (n + 2) + xn n = (2 * a) * xn (n + 1) := (xy_succ_succ n).1
theorem yn_succ_succ (n) : yn (n + 2) + yn n = (2 * a) * yn (n + 1) := (xy_succ_succ n).2

theorem xz_succ_succ (n) : xz (n + 2) = (2 * a : ℕ) * xz (n + 1) - xz n :=
eq_sub_of_add_eq $ by delta xz; rw [← int.coe_nat_add, ← int.coe_nat_mul, xn_succ_succ]

theorem yz_succ_succ (n) : yz (n + 2) = (2 * a : ℕ) * yz (n + 1) - yz n :=
eq_sub_of_add_eq $ by delta yz; rw [← int.coe_nat_add, ← int.coe_nat_mul, yn_succ_succ]

theorem yn_modeq_a_sub_one : ∀ n, yn n ≡ n [MOD a-1]
| 0 := by simp
| 1 := by simp
| (n+2) := (yn_modeq_a_sub_one n).add_right_cancel $
  begin
    rw [yn_succ_succ, (by ring : n + 2 + n = 2 * (n + 1))],
    exact ((modeq_sub a1.le).mul_left 2).mul (yn_modeq_a_sub_one (n+1)),
  end

theorem yn_modeq_two : ∀ n, yn n ≡ n [MOD 2]
| 0 := by simp
| 1 := by simp
| (n+2) := (yn_modeq_two n).add_right_cancel $
  begin
    rw [yn_succ_succ, mul_assoc, (by ring : n + 2 + n = 2 * (n + 1))],
    exact (dvd_mul_right 2 _).modeq_zero_nat.trans (dvd_mul_right 2 _).zero_modeq_nat,
  end

section

omit a1
lemma x_sub_y_dvd_pow_lem (y2 y1 y0 yn1 yn0 xn1 xn0 ay a2 : ℤ) :
  (a2 * yn1 - yn0) * ay + y2 - (a2 * xn1 - xn0) =
    y2 - a2 * y1 + y0 + a2 * (yn1 * ay + y1 - xn1) - (yn0 * ay + y0 - xn0) := by ring

end

theorem x_sub_y_dvd_pow (y : ℕ) :
  ∀ n, (2*a*y - y*y - 1 : ℤ) ∣ yz n * (a - y) + ↑(y^n) - xz n
| 0 := by simp [xz, yz, int.coe_nat_zero, int.coe_nat_one]
| 1 := by simp [xz, yz, int.coe_nat_zero, int.coe_nat_one]
| (n+2) :=
  have (2*a*y - y*y - 1 : ℤ) ∣ ↑(y^(n + 2)) - ↑(2 * a) * ↑(y^(n + 1)) + ↑(y^n), from
  ⟨-↑(y^n), by { simp [pow_succ, mul_add, int.coe_nat_mul,
      show ((2:ℕ):ℤ) = 2, from rfl, mul_comm, mul_left_comm], ring }⟩,
  by { rw [xz_succ_succ, yz_succ_succ, x_sub_y_dvd_pow_lem ↑(y^(n+2)) ↑(y^(n+1)) ↑(y^n)],
  exact
    dvd_sub (dvd_add this $ (x_sub_y_dvd_pow (n+1)).mul_left _) (x_sub_y_dvd_pow n) }

theorem xn_modeq_x2n_add_lem (n j) : xn n ∣ d * yn n * (yn n * xn j) + xn j :=
have h1 : d * yn n * (yn n * xn j) + xn j = (d * yn n * yn n + 1) * xn j,
  by simp [add_mul, mul_assoc],
have h2 : d * yn n * yn n + 1 = xn n * xn n, by apply int.coe_nat_inj;
  repeat {rw int.coe_nat_add <|> rw int.coe_nat_mul}; exact
  add_eq_of_eq_sub' (eq.symm $ pell_eqz _ _),
by rw h2 at h1; rw [h1, mul_assoc]; exact dvd_mul_right _ _

theorem xn_modeq_x2n_add (n j) : xn (2 * n + j) + xn j ≡ 0 [MOD xn n] :=
begin
  rw [two_mul, add_assoc, xn_add, add_assoc, ←zero_add 0],
  refine (dvd_mul_right (xn a1 n) (xn a1 (n + j))).modeq_zero_nat.add _,
  rw [yn_add, left_distrib, add_assoc, ←zero_add 0],
  exact ((dvd_mul_right _ _).mul_left _).modeq_zero_nat.add
    (xn_modeq_x2n_add_lem _ _ _).modeq_zero_nat,
end

lemma xn_modeq_x2n_sub_lem {n j} (h : j ≤ n) : xn (2 * n - j) + xn j ≡ 0 [MOD xn n] :=
have h1 : xz n ∣ ↑d * yz n * yz (n - j) + xz j,
  by rw [yz_sub _ h, mul_sub_left_distrib, sub_add_eq_add_sub]; exact
dvd_sub
  (by delta xz; delta yz;
      repeat {rw ← int.coe_nat_add <|> rw ← int.coe_nat_mul}; rw mul_comm (xn a1 j) (yn a1 n);
      exact int.coe_nat_dvd.2 (xn_modeq_x2n_add_lem _ _ _))
  ((dvd_mul_right _ _).mul_left _),
begin
  rw [two_mul, add_tsub_assoc_of_le h, xn_add, add_assoc, ←zero_add 0],
  exact (dvd_mul_right _ _).modeq_zero_nat.add
    (int.coe_nat_dvd.1 $ by simpa [xz, yz] using h1).modeq_zero_nat,
end

theorem xn_modeq_x2n_sub {n j} (h : j ≤ 2 * n) : xn (2 * n - j) + xn j ≡ 0 [MOD xn n] :=
(le_total j n).elim xn_modeq_x2n_sub_lem
  (λjn, have 2 * n - j + j ≤ n + j, by rw [tsub_add_cancel_of_le h, two_mul];
    exact nat.add_le_add_left jn _,
    let t := xn_modeq_x2n_sub_lem (nat.le_of_add_le_add_right this) in
      by rwa [tsub_tsub_cancel_of_le h, add_comm] at t)

theorem xn_modeq_x4n_add (n j) : xn (4 * n + j) ≡ xn j [MOD xn n] :=
modeq.add_right_cancel' (xn (2 * n + j)) $
by refine @modeq.trans _ _ 0 _ _ (by rw add_comm; exact (xn_modeq_x2n_add _ _ _).symm);
    rw [show 4*n = 2*n + 2*n, from right_distrib 2 2 n, add_assoc]; apply xn_modeq_x2n_add

theorem xn_modeq_x4n_sub {n j} (h : j ≤ 2 * n) : xn (4 * n - j) ≡ xn j [MOD xn n] :=
have h' : j ≤ 2*n, from le_trans h (by rw nat.succ_mul; apply nat.le_add_left),
modeq.add_right_cancel' (xn (2 * n - j)) $
by refine @modeq.trans _ _ 0 _ _ (by rw add_comm; exact (xn_modeq_x2n_sub _ h).symm);
    rw [show 4*n = 2*n + 2*n, from right_distrib 2 2 n, add_tsub_assoc_of_le h'];
      apply xn_modeq_x2n_add

theorem eq_of_xn_modeq_lem1 {i n} : Π {j}, i < j → j < n → xn i % xn n < xn j % xn n
| 0     ij _  := absurd ij (nat.not_lt_zero _)
| (j+1) ij jn :=
    suffices xn j % xn n < xn (j + 1) % xn n, from
    (lt_or_eq_of_le (nat.le_of_succ_le_succ ij)).elim
      (λh, lt_trans (eq_of_xn_modeq_lem1 h (le_of_lt jn)) this)
      (λh, by rw h; exact this),
  by rw [nat.mod_eq_of_lt (strict_mono_x _ (nat.lt_of_succ_lt jn)),
          nat.mod_eq_of_lt (strict_mono_x _ jn)];
      exact strict_mono_x _ (nat.lt_succ_self _)

theorem eq_of_xn_modeq_lem2 {n} (h : 2 * xn n = xn (n + 1)) : a = 2 ∧ n = 0 :=
by rw [xn_succ, mul_comm] at h; exact
have n = 0, from n.eq_zero_or_pos.resolve_right $ λnp,
  ne_of_lt (lt_of_le_of_lt (nat.mul_le_mul_left _ a1)
    (nat.lt_add_of_pos_right $ mul_pos (d_pos a1) (strict_mono_y a1 np))) h,
by cases this; simp at h; exact ⟨h.symm, rfl⟩

theorem eq_of_xn_modeq_lem3 {i n} (npos : 0 < n) :
  Π {j}, i < j → j ≤ 2 * n → j ≠ n → ¬(a = 2 ∧ n = 1 ∧ i = 0 ∧ j = 2) → xn i % xn n < xn j % xn n
| 0     ij _   _   _     := absurd ij (nat.not_lt_zero _)
| (j+1) ij j2n jnn ntriv :=
  have lem2 : ∀k > n, k ≤ 2*n → (↑(xn k % xn n) : ℤ) = xn n - xn (2 * n - k), from λk kn k2n,
    let k2nl := lt_of_add_lt_add_right $ show 2*n-k+k < n+k, by
      {rw tsub_add_cancel_of_le, rw two_mul; exact (add_lt_add_left kn n), exact k2n } in
    have xle : xn (2 * n - k) ≤ xn n, from le_of_lt $ strict_mono_x k2nl,
    suffices xn k % xn n = xn n - xn (2 * n - k), by rw [this, int.coe_nat_sub xle],
    by
    { rw ← nat.mod_eq_of_lt (nat.sub_lt (x_pos a1 n) (x_pos a1 (2 * n - k))),
      apply modeq.add_right_cancel' (xn a1 (2 * n - k)),
      rw [tsub_add_cancel_of_le xle],
      have t := xn_modeq_x2n_sub_lem a1 k2nl.le,
      rw tsub_tsub_cancel_of_le k2n at t,
      exact t.trans dvd_rfl.zero_modeq_nat },
  (lt_trichotomy j n).elim
  (λ (jn : j < n), eq_of_xn_modeq_lem1 ij (lt_of_le_of_ne jn jnn)) $ λ o, o.elim
  (λ (jn : j = n), by
  { cases jn,
    apply int.lt_of_coe_nat_lt_coe_nat,
    rw [lem2 (n+1) (nat.lt_succ_self _) j2n,
        show 2 * n - (n + 1) = n - 1, by rw[two_mul, tsub_add_eq_tsub_tsub, add_tsub_cancel_right]],
    refine lt_sub_left_of_add_lt (int.coe_nat_lt_coe_nat_of_lt _),
    cases (lt_or_eq_of_le $ nat.le_of_succ_le_succ ij) with lin ein,
    { rw nat.mod_eq_of_lt (strict_mono_x _ lin),
      have ll : xn a1 (n-1) + xn a1 (n-1) ≤ xn a1 n,
      { rw [← two_mul, mul_comm, show xn a1 n = xn a1 (n-1+1),
                                  by rw [tsub_add_cancel_of_le (succ_le_of_lt npos)], xn_succ],
        exact le_trans (nat.mul_le_mul_left _ a1) (nat.le_add_right _ _) },
      have npm : (n-1).succ = n := nat.succ_pred_eq_of_pos npos,
      have il : i ≤ n - 1, { apply nat.le_of_succ_le_succ, rw npm, exact lin },
      cases lt_or_eq_of_le il with ill ile,
      { exact lt_of_lt_of_le (nat.add_lt_add_left (strict_mono_x a1 ill) _) ll },
      { rw ile,
        apply lt_of_le_of_ne ll,
        rw ← two_mul,
        exact λe, ntriv $
          let ⟨a2, s1⟩ := @eq_of_xn_modeq_lem2 _ a1 (n-1)
            (by rwa [tsub_add_cancel_of_le (succ_le_of_lt npos)]) in
          have n1 : n = 1, from le_antisymm (tsub_eq_zero_iff_le.mp s1) npos,
          by rw [ile, a2, n1]; exact ⟨rfl, rfl, rfl, rfl⟩ } },
    { rw [ein, nat.mod_self, add_zero],
      exact strict_mono_x _ (nat.pred_lt npos.ne') } })
  (λ (jn : j > n),
    have lem1 : j ≠ n → xn j % xn n < xn (j + 1) % xn n → xn i % xn n < xn (j + 1) % xn n,
      from λjn s,
    (lt_or_eq_of_le (nat.le_of_succ_le_succ ij)).elim
      (λh, lt_trans (eq_of_xn_modeq_lem3 h (le_of_lt j2n) jn $ λ⟨a1, n1, i0, j2⟩,
        by rw [n1, j2] at j2n; exact absurd j2n dec_trivial) s)
      (λh, by rw h; exact s),
    lem1 (ne_of_gt jn) $ int.lt_of_coe_nat_lt_coe_nat $ by
    { rw [lem2 j jn (le_of_lt j2n), lem2 (j+1) (nat.le_succ_of_le jn) j2n],
      refine sub_lt_sub_left (int.coe_nat_lt_coe_nat_of_lt $ strict_mono_x _ _) _,
      rw [nat.sub_succ],
      exact nat.pred_lt (ne_of_gt $ tsub_pos_of_lt j2n) })

theorem eq_of_xn_modeq_le {i j n} (ij : i ≤ j) (j2n : j ≤ 2 * n)
  (h : xn i ≡ xn j [MOD xn n]) (ntriv : ¬(a = 2 ∧ n = 1 ∧ i = 0 ∧ j = 2)) : i = j :=
if npos : n = 0 then by simp [*] at * else
(lt_or_eq_of_le ij).resolve_left $ λij',
if jn : j = n then by
{ refine ne_of_gt _ h,
  rw [jn, nat.mod_self],
  have x0 : 0 < xn a1 0 % xn a1 n :=
    by rw [nat.mod_eq_of_lt (strict_mono_x a1 (nat.pos_of_ne_zero npos))]; exact dec_trivial,
  cases i with i, exact x0,
  rw jn at ij',
  exact x0.trans (eq_of_xn_modeq_lem3 _ (nat.pos_of_ne_zero npos) (nat.succ_pos _)
    (le_trans ij j2n) (ne_of_lt ij') $
    λ⟨a1, n1, _, i2⟩, by rw [n1, i2] at ij'; exact absurd ij' dec_trivial) }
else ne_of_lt (eq_of_xn_modeq_lem3 (nat.pos_of_ne_zero npos) ij' j2n jn ntriv) h

theorem eq_of_xn_modeq {i j n} (i2n : i ≤ 2 * n) (j2n : j ≤ 2 * n)
  (h : xn i ≡ xn j [MOD xn n]) (ntriv : a = 2 → n = 1 → (i = 0 → j ≠ 2) ∧ (i = 2 → j ≠ 0)) :
  i = j :=
(le_total i j).elim
  (λij, eq_of_xn_modeq_le ij j2n h $ λ⟨a2, n1, i0, j2⟩, (ntriv a2 n1).left i0 j2)
  (λij, (eq_of_xn_modeq_le ij i2n h.symm $ λ⟨a2, n1, j0, i2⟩,
    (ntriv a2 n1).right i2 j0).symm)

theorem eq_of_xn_modeq' {i j n} (ipos : 0 < i) (hin : i ≤ n) (j4n : j ≤ 4 * n)
  (h : xn j ≡ xn i [MOD xn n]) : j = i ∨ j + i = 4 * n :=
have i2n : i ≤ 2*n, by apply le_trans hin; rw two_mul; apply nat.le_add_left,
(le_or_gt j (2 * n)).imp
  (λj2n : j ≤ 2 * n, eq_of_xn_modeq j2n i2n h $
    λa2 n1, ⟨λj0 i2, by rw [n1, i2] at hin; exact absurd hin dec_trivial,
              λj2 i0, ne_of_gt ipos i0⟩)
  (λj2n : 2 * n < j, suffices i = 4*n - j, by rw [this, add_tsub_cancel_of_le j4n],
    have j42n : 4*n - j ≤ 2*n, from @nat.le_of_add_le_add_right j _ _ $
    by rw [tsub_add_cancel_of_le j4n, show 4*n = 2*n + 2*n, from right_distrib 2 2 n];
      exact nat.add_le_add_left (le_of_lt j2n) _,
    eq_of_xn_modeq i2n j42n
      (h.symm.trans $ let t := xn_modeq_x4n_sub j42n in by rwa [tsub_tsub_cancel_of_le j4n] at t)
      (λa2 n1, ⟨λi0, absurd i0 (ne_of_gt ipos), λi2, by { rw [n1, i2] at hin,
        exact absurd hin dec_trivial }⟩))

theorem modeq_of_xn_modeq {i j n} (ipos : 0 < i) (hin : i ≤ n) (h : xn j ≡ xn i [MOD xn n]) :
  j ≡ i [MOD 4 * n] ∨ j + i ≡ 0 [MOD 4 * n] :=
let j' := j % (4 * n) in
have n4 : 0 < 4 * n, from mul_pos dec_trivial (ipos.trans_le hin),
have jl : j' < 4 * n, from nat.mod_lt _ n4,
have jj : j ≡ j' [MOD 4 * n], by delta modeq; rw nat.mod_eq_of_lt jl,
have ∀j q, xn (j + 4 * n * q) ≡ xn j [MOD xn n], begin
  intros j q, induction q with q IH, { simp },
  rw [nat.mul_succ, ← add_assoc, add_comm],
  exact (xn_modeq_x4n_add _ _ _).trans IH
end,
or.imp
  (λ(ji : j' = i), by rwa ← ji)
  (λ(ji : j' + i = 4 * n), (jj.add_right _).trans $
    by { rw ji, exact dvd_rfl.modeq_zero_nat })
  (eq_of_xn_modeq' ipos hin jl.le $
    (h.symm.trans $ by { rw ← nat.mod_add_div j (4*n), exact this j' _ }).symm)
end

theorem xy_modeq_of_modeq {a b c} (a1 : 1 < a) (b1 : 1 < b) (h : a ≡ b [MOD c]) :
  ∀ n, xn a1 n ≡ xn b1 n [MOD c] ∧ yn a1 n ≡ yn b1 n [MOD c]
| 0 := by constructor; refl
| 1 := by simp; exact ⟨h, modeq.refl 1⟩
| (n+2) := ⟨
  (xy_modeq_of_modeq n).left.add_right_cancel $
    by { rw [xn_succ_succ a1, xn_succ_succ b1], exact
    (h.mul_left _ ).mul (xy_modeq_of_modeq (n+1)).left },
  (xy_modeq_of_modeq n).right.add_right_cancel $
    by { rw [yn_succ_succ a1, yn_succ_succ b1], exact
    (h.mul_left _ ).mul (xy_modeq_of_modeq (n+1)).right }⟩

theorem matiyasevic {a k x y} : (∃ a1 : 1 < a, xn a1 k = x ∧ yn a1 k = y) ↔
1 < a ∧ k ≤ y ∧
(x = 1 ∧ y = 0 ∨
∃ (u v s t b : ℕ),
  x * x - (a * a - 1) * y * y = 1 ∧
  u * u - (a * a - 1) * v * v = 1 ∧
  s * s - (b * b - 1) * t * t = 1 ∧
  1 < b ∧ b ≡ 1 [MOD 4 * y] ∧ b ≡ a [MOD u] ∧
  0 < v ∧ y * y ∣ v ∧
  s ≡ x [MOD u] ∧
  t ≡ k [MOD 4 * y]) :=
⟨λ⟨a1, hx, hy⟩, by rw [← hx, ← hy];
  refine ⟨a1, (nat.eq_zero_or_pos k).elim
    (λk0, by rw k0; exact ⟨le_rfl, or.inl ⟨rfl, rfl⟩⟩) (λkpos, _)⟩; exact
  let x := xn a1 k, y := yn a1 k,
      m := 2 * (k * y),
      u := xn a1 m, v := yn a1 m in
  have ky : k ≤ y, from yn_ge_n a1 k,
  have yv : y * y ∣ v, from (ysq_dvd_yy a1 k).trans $ (y_dvd_iff _ _ _).2 $ dvd_mul_left _ _,
  have uco : nat.coprime u (4 * y), from
    have 2 ∣ v, from modeq_zero_iff_dvd.1 $ (yn_modeq_two _ _).trans
      (dvd_mul_right _ _).modeq_zero_nat,
    have nat.coprime u 2, from
      (xy_coprime a1 m).coprime_dvd_right this,
    (this.mul_right this).mul_right $
      (xy_coprime _ _).coprime_dvd_right (dvd_of_mul_left_dvd yv),
  let ⟨b, ba, bm1⟩ := chinese_remainder uco a 1 in
  have m1 : 1 < m, from
    have 0 < k * y, from mul_pos kpos (strict_mono_y a1 kpos),
    nat.mul_le_mul_left 2 this,
  have vp : 0 < v, from strict_mono_y a1 (lt_trans zero_lt_one m1),
  have b1 : 1 < b, from
    have xn a1 1 < u, from strict_mono_x a1 m1,
    have a < u, by simp at this; exact this,
    lt_of_lt_of_le a1 $ by delta modeq at ba;
      rw nat.mod_eq_of_lt this at ba; rw ← ba; apply nat.mod_le,
  let s := xn b1 k, t := yn b1 k in
  have sx : s ≡ x [MOD u], from (xy_modeq_of_modeq b1 a1 ba k).left,
  have tk : t ≡ k [MOD 4 * y], from
      have 4 * y ∣ b - 1, from int.coe_nat_dvd.1 $
        by rw int.coe_nat_sub (le_of_lt b1);
           exact bm1.symm.dvd,
      (yn_modeq_a_sub_one _ _).of_dvd this,
  ⟨ky, or.inr ⟨u, v, s, t, b,
    pell_eq _ _, pell_eq _ _, pell_eq _ _, b1, bm1, ba, vp, yv, sx, tk⟩⟩,
λ⟨a1, ky, o⟩, ⟨a1, match o with
| or.inl ⟨x1, y0⟩ := by rw y0 at ky; rw [nat.eq_zero_of_le_zero ky, x1, y0]; exact ⟨rfl, rfl⟩
| or.inr ⟨u, v, s, t, b, xy, uv, st, b1, rem⟩ :=
  match x, y, eq_pell a1 xy, u, v, eq_pell a1 uv, s, t, eq_pell b1 st, rem, ky with
  | ._, ._, ⟨i, rfl, rfl⟩, ._, ._, ⟨n, rfl, rfl⟩, ._, ._, ⟨j, rfl, rfl⟩,
    ⟨(bm1 : b ≡ 1 [MOD 4 * yn a1 i]),
     (ba : b ≡ a [MOD xn a1 n]),
     (vp : 0 < yn a1 n),
     (yv : yn a1 i * yn a1 i ∣ yn a1 n),
     (sx : xn b1 j ≡ xn a1 i [MOD xn a1 n]),
     (tk : yn b1 j ≡ k [MOD 4 * yn a1 i])⟩,
     (ky : k ≤ yn a1 i) :=
    (nat.eq_zero_or_pos i).elim
      (λi0, by simp [i0] at ky; rw [i0, ky]; exact ⟨rfl, rfl⟩) $ λipos,
    suffices i = k, by rw this; exact ⟨rfl, rfl⟩,
    by clear _x o rem xy uv st _match _match _fun_match; exact
    have iln : i ≤ n, from le_of_not_gt $ λhin,
    not_lt_of_ge (nat.le_of_dvd vp (dvd_of_mul_left_dvd yv)) (strict_mono_y a1 hin),
    have yd : 4 * yn a1 i ∣ 4 * n, from mul_dvd_mul_left _ $ dvd_of_ysq_dvd a1 yv,
    have jk : j ≡ k [MOD 4 * yn a1 i], from
      have 4 * yn a1 i ∣ b - 1, from int.coe_nat_dvd.1 $
        by rw int.coe_nat_sub (le_of_lt b1); exact bm1.symm.dvd,
      ((yn_modeq_a_sub_one b1 _).of_dvd this).symm.trans tk,
    have ki : k + i < 4 * yn a1 i, from
      lt_of_le_of_lt (add_le_add ky (yn_ge_n a1 i)) $
      by rw ← two_mul; exact nat.mul_lt_mul_of_pos_right dec_trivial (strict_mono_y a1 ipos),
    have ji : j ≡ i [MOD 4 * n], from
      have xn a1 j ≡ xn a1 i [MOD xn a1 n], from (xy_modeq_of_modeq b1 a1 ba j).left.symm.trans sx,
      (modeq_of_xn_modeq a1 ipos iln this).resolve_right $ λ (ji : j + i ≡ 0 [MOD 4 * n]),
      not_le_of_gt ki $ nat.le_of_dvd (lt_of_lt_of_le ipos $ nat.le_add_left _ _) $
      modeq_zero_iff_dvd.1 $ (jk.symm.add_right i).trans $
      ji.of_dvd yd,
    by have : i % (4 * yn a1 i) = k % (4 * yn a1 i) :=
         (ji.of_dvd yd).symm.trans jk;
       rwa [nat.mod_eq_of_lt (lt_of_le_of_lt (nat.le_add_left _ _) ki),
            nat.mod_eq_of_lt (lt_of_le_of_lt (nat.le_add_right _ _) ki)] at this
  end
end⟩⟩

lemma eq_pow_of_pell_lem {a y k} (hy0 : y ≠ 0) (hk0 : k ≠ 0) (hyk : y^k < a) :
  (↑(y^k) : ℤ) < 2*a*y - y*y - 1 :=
have hya : y < a, from (nat.le_self_pow hk0 _).trans_lt hyk,
calc (↑(y ^ k) : ℤ) < a : nat.cast_lt.2 hyk
... ≤ a ^ 2 - (a - 1) ^ 2 - 1 :
  begin
    rw [sub_sq, mul_one, one_pow, sub_add, sub_sub_cancel, two_mul, sub_sub, ← add_sub,
      le_add_iff_nonneg_right, ← bit0, sub_nonneg, ← nat.cast_two, nat.cast_le, nat.succ_le_iff],
    exact (one_le_iff_ne_zero.2 hy0).trans_lt hya
  end
... ≤ a ^ 2 - (a - y) ^ 2 - 1 : have _ := hya.le,
  by { mono*; simpa only [sub_nonneg, nat.cast_le, nat.one_le_cast, nat.one_le_iff_ne_zero] }
... = 2*a*y - y*y - 1 : by ring

theorem eq_pow_of_pell {m n k} : n^k = m ↔
  k = 0 ∧ m = 1 ∨
    0 < k ∧ (n = 0 ∧ m = 0 ∨
      0 < n ∧ ∃ (w a t z : ℕ) (a1 : 1 < a),
        xn a1 k ≡ yn a1 k * (a - n) + m [MOD t] ∧
        2 * a * n = t + (n * n + 1) ∧
        m < t ∧ n ≤ w ∧ k ≤ w ∧
        a * a - ((w + 1) * (w + 1) - 1) * (w * z) * (w * z) = 1) :=
begin
  split,
  { rintro rfl,
    refine k.eq_zero_or_pos.imp (λ k0, k0.symm ▸ ⟨rfl, rfl⟩) (λ hk, ⟨hk, _⟩),
    refine n.eq_zero_or_pos.imp (λ n0, n0.symm ▸ ⟨rfl, zero_pow hk⟩) (λ hn, ⟨hn, _⟩),
    set w := max n k,
    have nw : n ≤ w, from le_max_left _ _,
    have kw : k ≤ w, from le_max_right _ _,
    have wpos : 0 < w, from hn.trans_le nw,
    have w1 : 1 < w + 1, from nat.succ_lt_succ wpos,
    set a := xn w1 w,
    have a1 : 1 < a, from strict_mono_x w1 wpos,
    have na : n ≤ a, from nw.trans (n_lt_xn w1 w).le,
    set x := xn a1 k, set y := yn a1 k,
    obtain ⟨z, ze⟩ : w ∣ yn w1 w,
      from modeq_zero_iff_dvd.1 ((yn_modeq_a_sub_one w1 w).trans dvd_rfl.modeq_zero_nat),
    have nt : (↑(n^k) : ℤ) < 2 * a * n - n * n - 1,
    { refine eq_pow_of_pell_lem hn.ne' hk.ne' _,
      calc n^k ≤ n^w       : nat.pow_le_pow_of_le_right hn kw
           ... < (w + 1)^w : nat.pow_lt_pow_of_lt_left (nat.lt_succ_of_le nw) wpos
           ... ≤ a         : xn_ge_a_pow w1 w },
    lift (2 * a * n - n * n - 1 : ℤ) to ℕ using ((nat.cast_nonneg _).trans nt.le) with t te,
    have tm : x ≡ y * (a - n) + n^k [MOD t],
    { apply modeq_of_dvd,
      rw [int.coe_nat_add, int.coe_nat_mul, int.coe_nat_sub na, te],
      exact x_sub_y_dvd_pow a1 n k },
    have ta : 2 * a * n = t + (n * n + 1),
    { rw [← @nat.cast_inj ℤ, int.coe_nat_add, te, sub_sub],
      repeat { rw nat.cast_add <|> rw nat.cast_mul },
      rw [nat.cast_one, sub_add_cancel, nat.cast_two] },
    have zp : a * a - ((w + 1) * (w + 1) - 1) * (w * z) * (w * z) = 1,
      from ze ▸ pell_eq w1 w,
    exact ⟨w, a, t, z, a1, tm, ta, nat.cast_lt.1 nt, nw, kw, zp⟩ },
  { rintro (⟨rfl, rfl⟩ | ⟨hk0, ⟨rfl, rfl⟩ | ⟨hn0, w, a, t, z, a1, tm, ta, mt, nw, kw, zp⟩⟩),
    { exact pow_zero n }, { exact zero_pow hk0 },
    have hw0 : 0 < w, from hn0.trans_le nw,
    have hw1 : 1 < w + 1, from nat.succ_lt_succ hw0,
    rcases eq_pell hw1 zp with ⟨j, rfl, yj⟩,
    have hj0 : 0 < j,
    { apply nat.pos_of_ne_zero,
      rintro rfl,
      exact lt_irrefl 1 a1 },
    have wj : w ≤ j := nat.le_of_dvd hj0 (modeq_zero_iff_dvd.1 $
      (yn_modeq_a_sub_one hw1 j).symm.trans $ modeq_zero_iff_dvd.2 ⟨z, yj.symm⟩),
    have hnka : n ^ k < xn hw1 j,
    calc n^k ≤ n^j       : nat.pow_le_pow_of_le_right hn0 (le_trans kw wj)
         ... < (w + 1)^j : nat.pow_lt_pow_of_lt_left (nat.lt_succ_of_le nw) hj0
         ... ≤ xn hw1 j  : xn_ge_a_pow hw1 j,
    have nt : (↑(n^k) : ℤ) < 2 * xn hw1 j * n - n * n - 1,
      from eq_pow_of_pell_lem hn0.ne' hk0.ne' hnka,
    have na : n ≤ xn hw1 j, from (nat.le_self_pow hk0.ne' _).trans hnka.le,
    have te : (t : ℤ) = 2 * xn hw1 j * n - n * n - 1,
    { rw [sub_sub, eq_sub_iff_add_eq],
      exact_mod_cast ta.symm },
    have : xn a1 k ≡ yn a1 k * (xn hw1 j - n) + n^k [MOD t],
    { apply modeq_of_dvd,
      rw [te, nat.cast_add, nat.cast_mul, int.coe_nat_sub na],
      exact x_sub_y_dvd_pow a1 n k },
    have : n^k % t = m % t, from (this.symm.trans tm).add_left_cancel' _,
    rw [← te] at nt,
    rwa [nat.mod_eq_of_lt (nat.cast_lt.1 nt), nat.mod_eq_of_lt mt] at this }
end

end pell


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import order.filter.cofinite

/-!
# Computational realization of filters (experimental)

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file provides infrastructure to compute with filters.

## Main declarations

* `cfilter`: Realization of a filter base. Note that this is in the generality of filters on
  lattices, while `filter` is filters of sets (so corresponding to `cfilter (set α) σ`).
* `filter.realizer`: Realization of a `filter`. `cfilter` that generates the given filter.
-/

open set filter

/-- A `cfilter α σ` is a realization of a filter (base) on `α`,
  represented by a type `σ` together with operations for the top element and
  the binary inf operation. -/
structure cfilter (α σ : Type*) [partial_order α] :=
(f : σ → α)
(pt : σ)
(inf : σ → σ → σ)
(inf_le_left : ∀ a b : σ, f (inf a b) ≤ f a)
(inf_le_right : ∀ a b : σ, f (inf a b) ≤ f b)

variables {α : Type*} {β : Type*} {σ : Type*} {τ : Type*}

instance [inhabited α] [semilattice_inf α] : inhabited (cfilter α α) :=
⟨{ f := id,
  pt := default,
  inf := (⊓),
  inf_le_left := λ _ _, inf_le_left,
  inf_le_right := λ _ _, inf_le_right }⟩

namespace cfilter
section
variables [partial_order α] (F : cfilter α σ)

instance : has_coe_to_fun (cfilter α σ) (λ _, σ → α) := ⟨cfilter.f⟩

@[simp] theorem coe_mk (f pt inf h₁ h₂ a) : (@cfilter.mk α σ _ f pt inf h₁ h₂) a = f a := rfl

/-- Map a cfilter to an equivalent representation type. -/
def of_equiv (E : σ ≃ τ) : cfilter α σ → cfilter α τ
| ⟨f, p, g, h₁, h₂⟩ :=
  { f            := λ a, f (E.symm a),
    pt           := E p,
    inf          := λ a b, E (g (E.symm a) (E.symm b)),
    inf_le_left  := λ a b, by simpa using h₁ (E.symm a) (E.symm b),
    inf_le_right := λ a b, by simpa using h₂ (E.symm a) (E.symm b) }

@[simp] theorem of_equiv_val (E : σ ≃ τ) (F : cfilter α σ) (a : τ) :
  F.of_equiv E a = F (E.symm a) := by cases F; refl

end

/-- The filter represented by a `cfilter` is the collection of supersets of
  elements of the filter base. -/
def to_filter (F : cfilter (set α) σ) : filter α :=
{ sets             := {a | ∃ b, F b ⊆ a},
  univ_sets        := ⟨F.pt, subset_univ _⟩,
  sets_of_superset := λ x y ⟨b, h⟩ s, ⟨b, subset.trans h s⟩,
  inter_sets       := λ x y ⟨a, h₁⟩ ⟨b, h₂⟩, ⟨F.inf a b,
    subset_inter (subset.trans (F.inf_le_left _ _) h₁) (subset.trans (F.inf_le_right _ _) h₂)⟩ }

@[simp] theorem mem_to_filter_sets (F : cfilter (set α) σ) {a : set α} :
  a ∈ F.to_filter ↔ ∃ b, F b ⊆ a := iff.rfl

end cfilter

/-- A realizer for filter `f` is a cfilter which generates `f`. -/
structure filter.realizer (f : filter α) :=
(σ : Type*)
(F : cfilter (set α) σ)
(eq : F.to_filter = f)

/-- A `cfilter` realizes the filter it generates. -/
protected def cfilter.to_realizer (F : cfilter (set α) σ) : F.to_filter.realizer := ⟨σ, F, rfl⟩

namespace filter.realizer

theorem mem_sets {f : filter α} (F : f.realizer) {a : set α} : a ∈ f ↔ ∃ b, F.F b ⊆ a :=
by cases F; subst f; simp

/-- Transfer a realizer along an equality of filter. This has better definitional equalities than
the `eq.rec` proof. -/
def of_eq {f g : filter α} (e : f = g) (F : f.realizer) : g.realizer :=
⟨F.σ, F.F, F.eq.trans e⟩

/-- A filter realizes itself. -/
def of_filter (f : filter α) : f.realizer := ⟨f.sets,
{ f            := subtype.val,
  pt           := ⟨univ, univ_mem⟩,
  inf          := λ ⟨x, h₁⟩ ⟨y, h₂⟩, ⟨_, inter_mem h₁ h₂⟩,
  inf_le_left  := λ ⟨x, h₁⟩ ⟨y, h₂⟩, inter_subset_left x y,
  inf_le_right := λ ⟨x, h₁⟩ ⟨y, h₂⟩, inter_subset_right x y },
filter_eq $ set.ext $ λ x, set_coe.exists.trans exists_mem_subset_iff⟩

/-- Transfer a filter realizer to another realizer on a different base type. -/
def of_equiv {f : filter α} (F : f.realizer) (E : F.σ ≃ τ) : f.realizer :=
⟨τ, F.F.of_equiv E, by refine eq.trans _ F.eq; exact filter_eq (set.ext $ λ x,
⟨λ ⟨s, h⟩, ⟨E.symm s, by simpa using h⟩, λ ⟨t, h⟩, ⟨E t, by simp [h]⟩⟩)⟩

@[simp] theorem of_equiv_σ {f : filter α} (F : f.realizer) (E : F.σ ≃ τ) :
  (F.of_equiv E).σ = τ := rfl
@[simp]

/-- `unit` is a realizer for the principal filter -/
protected def principal (s : set α) : (principal s).realizer := ⟨unit,
{ f            := λ _, s,
  pt           := (),
  inf          := λ _ _, (),
  inf_le_left  := λ _ _, le_rfl,
  inf_le_right := λ _ _, le_rfl },
filter_eq $ set.ext $ λ x,
⟨λ ⟨_, s⟩, s, λ h, ⟨(), h⟩⟩⟩

@[simp] theorem principal_σ (s : set α) : (realizer.principal s).σ = unit := rfl
@[simp] theorem principal_F (s : set α) (u : unit) : (realizer.principal s).F u = s := rfl

instance (s : set α) : inhabited (principal s).realizer := ⟨realizer.principal s⟩

/-- `unit` is a realizer for the top filter -/
protected def top : (⊤ : filter α).realizer :=
(realizer.principal _).of_eq principal_univ

@[simp] theorem top_σ : (@realizer.top α).σ = unit := rfl
@[simp] theorem top_F (u : unit) : (@realizer.top α).F u = univ := rfl

/-- `unit` is a realizer for the bottom filter -/
protected def bot : (⊥ : filter α).realizer :=
(realizer.principal _).of_eq principal_empty

@[simp] theorem bot_σ : (@realizer.bot α).σ = unit := rfl
@[simp] theorem bot_F (u : unit) : (@realizer.bot α).F u = ∅ := rfl

/-- Construct a realizer for `map m f` given a realizer for `f` -/
protected def map (m : α → β) {f : filter α} (F : f.realizer) : (map m f).realizer := ⟨F.σ,
{ f            := λ s, image m (F.F s),
  pt           := F.F.pt,
  inf          := F.F.inf,
  inf_le_left  := λ a b, image_subset _ (F.F.inf_le_left _ _),
  inf_le_right := λ a b, image_subset _ (F.F.inf_le_right _ _) },
filter_eq $ set.ext $ λ x, by simp [cfilter.to_filter]; rw F.mem_sets; refl ⟩

@[simp] theorem map_σ (m : α → β) {f : filter α} (F : f.realizer) : (F.map m).σ = F.σ := rfl
@[simp] theorem map_F (m : α → β) {f : filter α} (F : f.realizer) (s) :
  (F.map m).F s = image m (F.F s) := rfl

/-- Construct a realizer for `comap m f` given a realizer for `f` -/
protected def comap (m : α → β) {f : filter β} (F : f.realizer) : (comap m f).realizer := ⟨F.σ,
{ f            := λ s, preimage m (F.F s),
  pt           := F.F.pt,
  inf          := F.F.inf,
  inf_le_left  := λ a b, preimage_mono (F.F.inf_le_left _ _),
  inf_le_right := λ a b, preimage_mono (F.F.inf_le_right _ _) },
filter_eq $ set.ext $ λ x, by cases F; subst f; simp [cfilter.to_filter, mem_comap]; exact
⟨λ ⟨s, h⟩, ⟨_, ⟨s, subset.refl _⟩, h⟩,
 λ ⟨y, ⟨s, h⟩, h₂⟩, ⟨s, subset.trans (preimage_mono h) h₂⟩⟩⟩

/-- Construct a realizer for the sup of two filters -/
protected def sup {f g : filter α} (F : f.realizer) (G : g.realizer) :
  (f ⊔ g).realizer := ⟨F.σ × G.σ,
{ f            := λ ⟨s, t⟩, F.F s ∪ G.F t,
  pt           := (F.F.pt, G.F.pt),
  inf          := λ ⟨a, a'⟩ ⟨b, b'⟩, (F.F.inf a b, G.F.inf a' b'),
  inf_le_left  := λ ⟨a, a'⟩ ⟨b, b'⟩, union_subset_union (F.F.inf_le_left _ _) (G.F.inf_le_left _ _),
  inf_le_right := λ ⟨a, a'⟩ ⟨b, b'⟩, union_subset_union (F.F.inf_le_right _ _)
                    (G.F.inf_le_right _ _) },
filter_eq $ set.ext $ λ x, by cases F; cases G; substs f g; simp [cfilter.to_filter]; exact
⟨λ ⟨s, t, h⟩, ⟨⟨s, subset.trans (subset_union_left _ _) h⟩,
               ⟨t, subset.trans (subset_union_right _ _) h⟩⟩,
 λ ⟨⟨s, h₁⟩, ⟨t, h₂⟩⟩, ⟨s, t, union_subset h₁ h₂⟩⟩⟩

/-- Construct a realizer for the inf of two filters -/
protected def inf {f g : filter α} (F : f.realizer) (G : g.realizer) :
  (f ⊓ g).realizer := ⟨F.σ × G.σ,
{ f            := λ ⟨s, t⟩, F.F s ∩ G.F t,
  pt           := (F.F.pt, G.F.pt),
  inf          := λ ⟨a, a'⟩ ⟨b, b'⟩, (F.F.inf a b, G.F.inf a' b'),
  inf_le_left  := λ ⟨a, a'⟩ ⟨b, b'⟩, inter_subset_inter (F.F.inf_le_left _ _) (G.F.inf_le_left _ _),
  inf_le_right := λ ⟨a, a'⟩ ⟨b, b'⟩, inter_subset_inter (F.F.inf_le_right _ _)
                    (G.F.inf_le_right _ _) },
 begin
   ext x,
   cases F; cases G; substs f g; simp [cfilter.to_filter],
   split,
   { rintro ⟨s : F_σ, t : G_σ, h⟩,
     apply mem_inf_of_inter _ _ h,
     use s,
     use t, },
   { rintros ⟨s, ⟨a, ha⟩, t, ⟨b, hb⟩, rfl⟩,
     exact ⟨a, b, inter_subset_inter ha hb⟩ }
 end⟩

/-- Construct a realizer for the cofinite filter -/
protected def cofinite [decidable_eq α] : (@cofinite α).realizer := ⟨finset α,
{ f            := λ s, {a | a ∉ s},
  pt           := ∅,
  inf          := (∪),
  inf_le_left  := λ s t a, mt (finset.mem_union_left _),
  inf_le_right := λ s t a, mt (finset.mem_union_right _) },
filter_eq $ set.ext $ λ x,
⟨λ ⟨s, h⟩, s.finite_to_set.subset (compl_subset_comm.1 h),
 λ h, ⟨h.to_finset, by simp⟩⟩⟩

/-- Construct a realizer for filter bind -/
protected def bind {f : filter α} {m : α → filter β} (F : f.realizer) (G : ∀ i, (m i).realizer) :
  (f.bind m).realizer :=
⟨Σ s : F.σ, Π i ∈ F.F s, (G i).σ,
{ f            := λ ⟨s, f⟩, ⋃ i ∈ F.F s, (G i).F (f i H),
  pt           := ⟨F.F.pt, λ i H, (G i).F.pt⟩,
  inf          := λ ⟨a, f⟩ ⟨b, f'⟩, ⟨F.F.inf a b, λ i h,
    (G i).F.inf (f i (F.F.inf_le_left _ _ h)) (f' i (F.F.inf_le_right _ _ h))⟩,
  inf_le_left  := λ ⟨a, f⟩ ⟨b, f'⟩ x,
    show (x ∈ ⋃ (i : α) (H : i ∈ F.F (F.F.inf a b)), _) →
          x ∈ ⋃ i (H : i ∈ F.F a), ((G i).F) (f i H), by simp; exact
    λ i h₁ h₂, ⟨i, F.F.inf_le_left _ _ h₁, (G i).F.inf_le_left _ _ h₂⟩,
  inf_le_right := λ ⟨a, f⟩ ⟨b, f'⟩ x,
    show (x ∈ ⋃ (i : α) (H : i ∈ F.F (F.F.inf a b)), _) →
          x ∈ ⋃ i (H : i ∈ F.F b), ((G i).F) (f' i H), by simp; exact
    λ i h₁ h₂, ⟨i, F.F.inf_le_right _ _ h₁, (G i).F.inf_le_right _ _ h₂⟩ },
filter_eq $ set.ext $ λ x,
by cases F with _ F _; subst f; simp [cfilter.to_filter, mem_bind]; exact
⟨λ ⟨s, f, h⟩, ⟨F s, ⟨s, subset.refl _⟩, λ i H, (G i).mem_sets.2
   ⟨f i H, λ a h', h ⟨_, ⟨i, rfl⟩, _, ⟨H, rfl⟩, h'⟩⟩⟩,
 λ ⟨y, ⟨s, h⟩, f⟩,
  let ⟨f', h'⟩ := classical.axiom_of_choice (λ i:F s, (G i).mem_sets.1 (f i (h i.2))) in
  ⟨s, λ i h, f' ⟨i, h⟩, λ a ⟨_, ⟨i, rfl⟩, _, ⟨H, rfl⟩, m⟩, h' ⟨_, H⟩ m⟩⟩⟩

/-- Construct a realizer for indexed supremum -/
protected def Sup {f : α → filter β} (F : ∀ i, (f i).realizer) : (⨆ i, f i).realizer :=
let F' : (⨆ i, f i).realizer :=
  ((realizer.bind realizer.top F).of_eq $
    filter_eq $ set.ext $ by simp [filter.bind, eq_univ_iff_forall, supr_sets_eq]) in
F'.of_equiv $ show (Σ u:unit, Π (i : α), true → (F i).σ) ≃ Π i, (F i).σ, from
⟨λ⟨_,f⟩ i, f i ⟨⟩, λ f, ⟨(), λ i _, f i⟩,
 λ ⟨⟨⟩, f⟩, by dsimp; congr; simp, λ f, rfl⟩

/-- Construct a realizer for the product of filters -/
protected def prod {f g : filter α} (F : f.realizer) (G : g.realizer) : (f.prod g).realizer :=
(F.comap _).inf (G.comap _)

theorem le_iff {f g : filter α} (F : f.realizer) (G : g.realizer) :
  f ≤ g ↔ ∀ b : G.σ, ∃ a : F.σ, F.F a ≤ G.F b :=
⟨λ H t, F.mem_sets.1 (H (G.mem_sets.2 ⟨t, subset.refl _⟩)),
 λ H x h, F.mem_sets.2 $
   let ⟨s, h₁⟩ := G.mem_sets.1 h, ⟨t, h₂⟩ := H s in ⟨t, subset.trans h₂ h₁⟩⟩

theorem tendsto_iff (f : α → β) {l₁ : filter α} {l₂ : filter β} (L₁ : l₁.realizer)
  (L₂ : l₂.realizer) :
  tendsto f l₁ l₂ ↔ ∀ b, ∃ a, ∀ x ∈ L₁.F a, f x ∈ L₂.F b :=
(le_iff (L₁.map f) L₂).trans $ forall_congr $ λ b, exists_congr $ λ a, image_subset_iff

theorem ne_bot_iff {f : filter α} (F : f.realizer) :
  f ≠ ⊥ ↔ ∀ a : F.σ, (F.F a).nonempty :=
begin
  classical,
  rw [not_iff_comm, ← le_bot_iff, F.le_iff realizer.bot, not_forall],
  simp only [set.not_nonempty_iff_eq_empty],
  exact ⟨λ ⟨x, e⟩ _, ⟨x, le_of_eq e⟩,
    λ h, let ⟨x, h⟩ := h () in ⟨x, le_bot_iff.1 h⟩⟩
end

end filter.realizer


/-
Copyright (c) 2020 Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Heather Macbeth

! This file was ported from Lean 3 source module analysis.normed_space.units
! leanprover-community/mathlib commit 9a59dcb7a2d06bf55da57b9030169219980660cd
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.Algebra.Ring.Ideal
import Mathbin.Analysis.SpecificLimits.Normed

/-!
# The group of units of a complete normed ring

This file contains the basic theory for the group of units (invertible elements) of a complete
normed ring (Banach algebras being a notable special case).

## Main results

The constructions `one_sub`, `add` and `unit_of_nearby` state, in varying forms, that perturbations
of a unit are units.  The latter two are not stated in their optimal form; more precise versions
would use the spectral radius.

The first main result is `is_open`:  the group of units of a complete normed ring is an open subset
of the ring.

The function `inverse` (defined in `algebra.ring`), for a ring `R`, sends `a : R` to `a⁻¹` if `a` is
a unit and 0 if not.  The other major results of this file (notably `inverse_add`,
`inverse_add_norm` and `inverse_add_norm_diff_nth_order`) cover the asymptotic properties of
`inverse (x + t)` as `t → 0`.

-/

noncomputable section

open Topology

variable {R : Type _} [NormedRing R] [CompleteSpace R]

namespace Units

/-- In a complete normed ring, a perturbation of `1` by an element `t` of distance less than `1`
from `1` is a unit.  Here we construct its `units` structure.  -/
@[simps coe]
def oneSub (t : R) (h : ‖t‖ < 1) : Rˣ where
  val := 1 - t
  inv := ∑' n : ℕ, t ^ n
  val_inv := mul_neg_geom_series t h
  inv_val := geom_series_mul_neg t h
#align units.one_sub Units.oneSub

/-- In a complete normed ring, a perturbation of a unit `x` by an element `t` of distance less than
`‖x⁻¹‖⁻¹` from `x` is a unit.  Here we construct its `units` structure. -/
@[simps coe]
def add (x : Rˣ) (t : R) (h : ‖t‖ < ‖(↑x⁻¹ : R)‖⁻¹) : Rˣ :=
  Units.copy
    (-- to make `coe_add` true definitionally, for convenience
      x *
      Units.oneSub (-(↑x⁻¹ * t))
        (by
          nontriviality R using zero_lt_one
          have hpos : 0 < ‖(↑x⁻¹ : R)‖ := Units.norm_pos x⁻¹
          calc
            ‖-(↑x⁻¹ * t)‖ = ‖↑x⁻¹ * t‖ := by rw [norm_neg]
            _ ≤ ‖(↑x⁻¹ : R)‖ * ‖t‖ := (norm_mul_le ↑x⁻¹ _)
            _ < ‖(↑x⁻¹ : R)‖ * ‖(↑x⁻¹ : R)‖⁻¹ := by nlinarith only [h, hpos]
            _ = 1 := mul_inv_cancel (ne_of_gt hpos)
            ))
    (x + t) (by simp [mul_add]) _ rfl
#align units.add Units.add

/-- In a complete normed ring, an element `y` of distance less than `‖x⁻¹‖⁻¹` from `x` is a unit.
Here we construct its `units` structure. -/
@[simps coe]
def unitOfNearby (x : Rˣ) (y : R) (h : ‖y - x‖ < ‖(↑x⁻¹ : R)‖⁻¹) : Rˣ :=
  Units.copy (x.add (y - x : R) h) y (by simp) _ rfl
#align units.unit_of_nearby Units.unitOfNearby

/-- The group of units of a complete normed ring is an open subset of the ring. -/
protected theorem isOpen : IsOpen { x : R | IsUnit x } :=
  by
  nontriviality R
  apply metric.is_open_iff.mpr
  rintro x' ⟨x, rfl⟩
  refine' ⟨‖(↑x⁻¹ : R)‖⁻¹, _root_.inv_pos.mpr (Units.norm_pos x⁻¹), _⟩
  intro y hy
  rw [Metric.mem_ball, dist_eq_norm] at hy
  exact (x.unit_of_nearby y hy).IsUnit
#align units.is_open Units.isOpen

protected theorem nhds (x : Rˣ) : { x : R | IsUnit x } ∈ 𝓝 (x : R) :=
  IsOpen.mem_nhds Units.isOpen x.IsUnit
#align units.nhds Units.nhds

end Units

namespace nonunits

/-- The `nonunits` in a complete normed ring are contained in the complement of the ball of radius
`1` centered at `1 : R`. -/
theorem subset_compl_ball : nonunits R ⊆ Metric.ball (1 : R) 1ᶜ :=
  Set.subset_compl_comm.mp fun x hx => by
    simpa [sub_sub_self, Units.coe_oneSub] using
      (Units.oneSub (1 - x) (by rwa [Metric.mem_ball, dist_eq_norm, norm_sub_rev] at hx)).IsUnit
#align nonunits.subset_compl_ball nonunits.subset_compl_ball

-- The `nonunits` in a complete normed ring are a closed set
protected theorem isClosed : IsClosed (nonunits R) :=
  Units.isOpen.isClosed_compl
#align nonunits.is_closed nonunits.isClosed

end nonunits

namespace NormedRing

open Classical BigOperators

open Asymptotics Filter Metric Finset Ring

theorem inverse_oneSub (t : R) (h : ‖t‖ < 1) : inverse (1 - t) = ↑(Units.oneSub t h)⁻¹ := by
  rw [← inverse_unit (Units.oneSub t h), Units.coe_oneSub]
#align normed_ring.inverse_one_sub NormedRing.inverse_oneSub

/-- The formula `inverse (x + t) = inverse (1 + x⁻¹ * t) * x⁻¹` holds for `t` sufficiently small. -/
theorem inverse_add (x : Rˣ) : ∀ᶠ t in 𝓝 0, inverse ((x : R) + t) = inverse (1 + ↑x⁻¹ * t) * ↑x⁻¹ :=
  by
  nontriviality R
  rw [eventually_iff, Metric.mem_nhds_iff]
  have hinv : 0 < ‖(↑x⁻¹ : R)‖⁻¹ := by cancel_denoms
  use ‖(↑x⁻¹ : R)‖⁻¹, hinv
  intro t ht
  simp only [mem_ball, dist_zero_right] at ht
  have ht' : ‖-↑x⁻¹ * t‖ < 1 :=
    by
    refine' lt_of_le_of_lt (norm_mul_le _ _) _
    rw [norm_neg]
    refine' lt_of_lt_of_le (mul_lt_mul_of_pos_left ht x⁻¹.norm_pos) _
    cancel_denoms
  have hright := inverse_one_sub (-↑x⁻¹ * t) ht'
  have hleft := inverse_unit (x.add t ht)
  simp only [neg_mul, sub_neg_eq_add] at hright
  simp only [Units.coe_add] at hleft
  simp [hleft, hright, Units.add]
#align normed_ring.inverse_add NormedRing.inverse_add

theorem inverse_one_sub_nth_order (n : ℕ) :
    ∀ᶠ t in 𝓝 0, inverse ((1 : R) - t) = (∑ i in range n, t ^ i) + t ^ n * inverse (1 - t) :=
  by
  simp only [eventually_iff, Metric.mem_nhds_iff]
  use 1, by norm_num
  intro t ht
  simp only [mem_ball, dist_zero_right] at ht
  simp only [inverse_one_sub t ht, Set.mem_setOf_eq]
  have h : 1 = ((range n).Sum fun i => t ^ i) * Units.oneSub t ht + t ^ n :=
    by
    simp only [Units.coe_oneSub]
    rw [geom_sum_mul_neg]
    simp
  rw [← one_mul ↑(Units.oneSub t ht)⁻¹, h, add_mul]
  congr
  · rw [mul_assoc, (Units.oneSub t ht).mul_inv]
    simp
  · simp only [Units.coe_oneSub]
    rw [← add_mul, geom_sum_mul_neg]
    simp
#align normed_ring.inverse_one_sub_nth_order NormedRing.inverse_one_sub_nth_order

/-- The formula
`inverse (x + t) = (∑ i in range n, (- x⁻¹ * t) ^ i) * x⁻¹ + (- x⁻¹ * t) ^ n * inverse (x + t)`
holds for `t` sufficiently small. -/
theorem inverse_add_nth_order (x : Rˣ) (n : ℕ) :
    ∀ᶠ t in 𝓝 0,
      inverse ((x : R) + t) =
        (∑ i in range n, (-↑x⁻¹ * t) ^ i) * ↑x⁻¹ + (-↑x⁻¹ * t) ^ n * inverse (x + t) :=
  by
  refine' (inverse_add x).mp _
  have hzero : tendsto (fun t : R => -↑x⁻¹ * t) (𝓝 0) (𝓝 0) :=
    by
    convert((mulLeft_continuous (-(↑x⁻¹ : R))).Tendsto 0).comp tendsto_id
    simp
  refine' (hzero.eventually (inverse_one_sub_nth_order n)).mp (eventually_of_forall _)
  simp only [neg_mul, sub_neg_eq_add]
  intro t h1 h2
  have h := congr_arg (fun a : R => a * ↑x⁻¹) h1
  dsimp at h
  convert h
  rw [add_mul, mul_assoc]
  simp [h2.symm]
#align normed_ring.inverse_add_nth_order NormedRing.inverse_add_nth_order

theorem inverse_one_sub_norm : (fun t : R => inverse (1 - t)) =O[𝓝 0] (fun t => 1 : R → ℝ) :=
  by
  simp only [is_O, is_O_with, eventually_iff, Metric.mem_nhds_iff]
  refine' ⟨‖(1 : R)‖ + 1, (2 : ℝ)⁻¹, by norm_num, _⟩
  intro t ht
  simp only [ball, dist_zero_right, Set.mem_setOf_eq] at ht
  have ht' : ‖t‖ < 1 := by
    have : (2 : ℝ)⁻¹ < 1 := by cancel_denoms
    linarith
  simp only [inverse_one_sub t ht', norm_one, mul_one, Set.mem_setOf_eq]
  change ‖∑' n : ℕ, t ^ n‖ ≤ _
  have := NormedRing.tsum_geometric_of_norm_lt_1 t ht'
  have : (1 - ‖t‖)⁻¹ ≤ 2 := by
    rw [← inv_inv (2 : ℝ)]
    refine' inv_le_inv_of_le (by norm_num) _
    have : (2 : ℝ)⁻¹ + (2 : ℝ)⁻¹ = 1 := by ring
    linarith
  linarith
#align normed_ring.inverse_one_sub_norm NormedRing.inverse_one_sub_norm

/-- The function `λ t, inverse (x + t)` is O(1) as `t → 0`. -/
theorem inverse_add_norm (x : Rˣ) : (fun t : R => inverse (↑x + t)) =O[𝓝 0] fun t => (1 : ℝ) :=
  by
  simp only [is_O_iff, norm_one, mul_one]
  cases' is_O_iff.mp (@inverse_one_sub_norm R _ _) with C hC
  use C * ‖((x⁻¹ : Rˣ) : R)‖
  have hzero : tendsto (fun t => -(↑x⁻¹ : R) * t) (𝓝 0) (𝓝 0) :=
    by
    convert((mulLeft_continuous (-↑x⁻¹ : R)).Tendsto 0).comp tendsto_id
    simp
  refine' (inverse_add x).mp ((hzero.eventually hC).mp (eventually_of_forall _))
  intro t bound iden
  rw [iden]
  simp at bound
  have hmul := norm_mul_le (inverse (1 + ↑x⁻¹ * t)) ↑x⁻¹
  nlinarith [norm_nonneg (↑x⁻¹ : R)]
#align normed_ring.inverse_add_norm NormedRing.inverse_add_norm

/-- The function
`λ t, inverse (x + t) - (∑ i in range n, (- x⁻¹ * t) ^ i) * x⁻¹`
is `O(t ^ n)` as `t → 0`. -/
theorem inverse_add_norm_diff_nth_order (x : Rˣ) (n : ℕ) :
    (fun t : R => inverse (↑x + t) - (∑ i in range n, (-↑x⁻¹ * t) ^ i) * ↑x⁻¹) =O[𝓝 (0 : R)]
      fun t => ‖t‖ ^ n :=
  by
  by_cases h : n = 0
  · simpa [h] using inverse_add_norm x
  have hn : 0 < n := Nat.pos_of_ne_zero h
  simp [is_O_iff]
  cases' is_O_iff.mp (inverse_add_norm x) with C hC
  use C * ‖(1 : ℝ)‖ * ‖(↑x⁻¹ : R)‖ ^ n
  have h :
    eventually_eq (𝓝 (0 : R)) (fun t => inverse (↑x + t) - (∑ i in range n, (-↑x⁻¹ * t) ^ i) * ↑x⁻¹)
      fun t => (-↑x⁻¹ * t) ^ n * inverse (x + t) :=
    by
    refine' (inverse_add_nth_order x n).mp (eventually_of_forall _)
    intro t ht
    convert congr_arg (fun a => a - (range n).Sum (pow (-↑x⁻¹ * t)) * ↑x⁻¹) ht
    simp
  refine' h.mp (hC.mp (eventually_of_forall _))
  intro t _ hLHS
  simp only [neg_mul] at hLHS
  rw [hLHS]
  refine' le_trans (norm_mul_le _ _) _
  have h' : ‖(-(↑x⁻¹ * t)) ^ n‖ ≤ ‖(↑x⁻¹ : R)‖ ^ n * ‖t‖ ^ n :=
    by
    calc
      ‖(-(↑x⁻¹ * t)) ^ n‖ ≤ ‖-(↑x⁻¹ * t)‖ ^ n := norm_pow_le' _ hn
      _ = ‖↑x⁻¹ * t‖ ^ n := by rw [norm_neg]
      _ ≤ (‖(↑x⁻¹ : R)‖ * ‖t‖) ^ n := _
      _ = ‖(↑x⁻¹ : R)‖ ^ n * ‖t‖ ^ n := mul_pow _ _ n

    exact pow_le_pow_of_le_left (norm_nonneg _) (norm_mul_le (↑x⁻¹) t) n
  have h'' : 0 ≤ ‖(↑x⁻¹ : R)‖ ^ n * ‖t‖ ^ n := by
    refine' mul_nonneg _ _ <;> exact pow_nonneg (norm_nonneg _) n
  nlinarith [norm_nonneg (inverse (↑x + t))]
#align normed_ring.inverse_add_norm_diff_nth_order NormedRing.inverse_add_norm_diff_nth_order

/-- The function `λ t, inverse (x + t) - x⁻¹` is `O(t)` as `t → 0`. -/
theorem inverse_add_norm_diff_first_order (x : Rˣ) :
    (fun t : R => inverse (↑x + t) - ↑x⁻¹) =O[𝓝 0] fun t => ‖t‖ := by
  simpa using inverse_add_norm_diff_nth_order x 1
#align normed_ring.inverse_add_norm_diff_first_order NormedRing.inverse_add_norm_diff_first_order

/-- The function
`λ t, inverse (x + t) - x⁻¹ + x⁻¹ * t * x⁻¹`
is `O(t ^ 2)` as `t → 0`. -/
theorem inverse_add_norm_diff_second_order (x : Rˣ) :
    (fun t : R => inverse (↑x + t) - ↑x⁻¹ + ↑x⁻¹ * t * ↑x⁻¹) =O[𝓝 0] fun t => ‖t‖ ^ 2 :=
  by
  convert inverse_add_norm_diff_nth_order x 2
  ext t
  simp only [range_succ, range_one, sum_insert, mem_singleton, sum_singleton, not_false_iff,
    one_ne_zero, pow_zero, add_mul, pow_one, one_mul, neg_mul, sub_add_eq_sub_sub_swap,
    sub_neg_eq_add]
#align normed_ring.inverse_add_norm_diff_second_order NormedRing.inverse_add_norm_diff_second_order

/-- The function `inverse` is continuous at each unit of `R`. -/
theorem inverse_continuousAt (x : Rˣ) : ContinuousAt inverse (x : R) :=
  by
  have h_is_o : (fun t : R => inverse (↑x + t) - ↑x⁻¹) =o[𝓝 0] (fun _ => 1 : R → ℝ) :=
    (inverse_add_norm_diff_first_order x).trans_isOCat (is_o.norm_left <| is_o_id_const one_ne_zero)
  have h_lim : tendsto (fun y : R => y - x) (𝓝 x) (𝓝 0) :=
    by
    refine' tendsto_zero_iff_norm_tendsto_zero.mpr _
    exact tendsto_iff_norm_tendsto_zero.mp tendsto_id
  rw [ContinuousAt, tendsto_iff_norm_tendsto_zero, inverse_unit]
  simpa [(· ∘ ·)] using h_is_o.norm_left.tendsto_div_nhds_zero.comp h_lim
#align normed_ring.inverse_continuous_at NormedRing.inverse_continuousAt

end NormedRing

namespace Units

open MulOpposite Filter NormedRing

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- In a normed ring, the coercion from `Rˣ` (equipped with the induced topology from the
embedding in `R × R`) to `R` is an open map. -/
theorem isOpenMap_coe : IsOpenMap (coe : Rˣ → R) :=
  by
  rw [isOpenMap_iff_nhds_le]
  intro x s
  rw [mem_map, mem_nhds_induced]
  rintro ⟨t, ht, hts⟩
  obtain ⟨u, hu, v, hv, huvt⟩ :
    ∃ u : Set R, u ∈ 𝓝 ↑x ∧ ∃ v : Set Rᵐᵒᵖ, v ∈ 𝓝 (op ↑x⁻¹) ∧ u ×ˢ v ⊆ t := by
    simpa [embed_product, mem_nhds_prod_iff] using ht
  have : u ∩ op ∘ Ring.inverse ⁻¹' v ∩ Set.range (coe : Rˣ → R) ∈ 𝓝 ↑x :=
    by
    refine' inter_mem (inter_mem hu _) (Units.nhds x)
    refine' (continuous_op.continuous_at.comp (inverse_continuous_at x)).preimage_mem_nhds _
    simpa using hv
  refine' mem_of_superset this _
  rintro _ ⟨⟨huy, hvy⟩, ⟨y, rfl⟩⟩
  have : embed_product R y ∈ u ×ˢ v := ⟨huy, by simpa using hvy⟩
  simpa using hts (huvt this)
#align units.is_open_map_coe Units.isOpenMap_coe

/-- In a normed ring, the coercion from `Rˣ` (equipped with the induced topology from the
embedding in `R × R`) to `R` is an open embedding. -/
theorem openEmbedding_coe : OpenEmbedding (coe : Rˣ → R) :=
  openEmbedding_of_continuous_injective_open continuous_val ext isOpenMap_coe
#align units.open_embedding_coe Units.openEmbedding_coe

end Units

namespace Ideal

/-- An ideal which contains an element within `1` of `1 : R` is the unit ideal. -/
theorem eq_top_of_norm_lt_one (I : Ideal R) {x : R} (hxI : x ∈ I) (hx : ‖1 - x‖ < 1) : I = ⊤ :=
  let u := Units.oneSub (1 - x) hx
  I.eq_top_iff_one.mpr <| by simpa only [show u.inv * x = 1 by simp] using I.mul_mem_left u.inv hxI
#align ideal.eq_top_of_norm_lt_one Ideal.eq_top_of_norm_lt_one

/-- The `ideal.closure` of a proper ideal in a complete normed ring is proper. -/
theorem closure_ne_top (I : Ideal R) (hI : I ≠ ⊤) : I.closure ≠ ⊤ :=
  by
  have h := closure_minimal (coe_subset_nonunits hI) nonunits.isClosed
  simpa only [I.closure.eq_top_iff_one, Ne.def] using mt (@h 1) one_not_mem_nonunits
#align ideal.closure_ne_top Ideal.closure_ne_top

/-- The `ideal.closure` of a maximal ideal in a complete normed ring is the ideal itself. -/
theorem IsMaximal.closure_eq {I : Ideal R} (hI : I.IsMaximal) : I.closure = I :=
  (hI.eq_of_le (I.closure_ne_top hI.ne_top) subset_closure).symm
#align ideal.is_maximal.closure_eq Ideal.IsMaximal.closure_eq

/-- Maximal ideals in complete normed rings are closed. -/
instance IsMaximal.isClosed {I : Ideal R} [hI : I.IsMaximal] : IsClosed (I : Set R) :=
  isClosed_of_closure_subset <| Eq.subset <| congr_arg (coe : Ideal R → Set R) hI.closure_eq
#align ideal.is_maximal.is_closed Ideal.IsMaximal.isClosed

end Ideal


import init.data.set

section List
  inductive List (α : Type)
  | nil : List
  | cons : α → List → List

  def List.mem {α : Type} (a : α) : List α → Prop
  | List.nil := false
  | (List.cons b l) := a = b ∨ List.mem l

  notation x ` ∈κ ` xs := List.mem x xs

  theorem List.mem_cons_of_mem {α : Type} {a b : α} {l : List α} (h : a ∈κ l) :
    a ∈κ (List.cons b l) :=
    begin
      exact or.inr h
    end

  theorem List.mem_cons_self {α : Type } (a : α) (l : List α) : a ∈κ List.cons a l :=
    or.inl rfl

  theorem List.mem_nil {α : Type} (a : α) : ¬ (List.mem a List.nil) := λ h, h

  notation `[]` := List.nil
  infixr `::` := List.cons

  def List.append {α : Type} : List α → List α → List α
  | List.nil ys := ys
  | (List.cons x xs) ys := List.cons x (List.append xs ys)

  notation xs `++` ys := List.append xs ys

  def A : List ℕ := 3 :: 4 :: 5 :: []
  def B : List ℕ := 1 :: 2 :: 3 :: 4 :: 5 :: 6 :: []

  @[simp]
  def List.subset { α : Type } (A : List α) (B : List α) : Prop := ∀ x : α, ((x ∈κ A) -> (x ∈κ B))

  notation A ` ⊆κ ` B := List.subset A B

  example : A ⊆κ B :=
    begin
      intro x,
      intro ha,
      cases ha,
      { rw [ha],
        repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }
      },
      {
          cases ha,
          { rw [ha],
            repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }
          },
          {
            cases ha,
            { rw [ha],
              repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }
            },
            {
              cases ha
            }
          }
      }
    end

end List

-- language --
inductive message (σ : ℕ) : Type
  | null : fin σ -> message
  | conc : message -> message -> message
  | nonc : message -> message
  | pk : message -> message
  | sk : message -> message
  | keys : message -> message -> message -> message
  | encr : message -> message -> message
  | decr : message -> message -> message
  | tupl : message -> message -> message
  | func : message -> message -> message

inductive program (σ : ℕ) : Type
  | skip : program
  | secv : program -> program -> program
  | reun : program -> program -> program
  | send : program
  | recv : program
  | star : program -> program
  | agP : program -> message σ -> message σ -> program

inductive form (σ : ℕ) : Type
  | atom : fin σ -> form
  | botm : form
  | impl : form -> form -> form
  | k : message σ -> form -> form
  | b : message σ -> form -> form
  | pdl : program σ -> message σ → message σ → form -> form
  | receive : program σ -> message σ -> form -> form
  | toP : program σ -> form -> form
  | mesg : message σ -> form
  | awareness : message σ -> form -> form
  | explicit : message σ -> form -> form

section Notations
  prefix `#` := form.atom
  notation `⊥` := form.botm
  infix `⊃` := form.impl
  notation `~`:40 p := form.impl p ⊥
  notation p `&` q := ~(p ⊃ (~q))
  notation p `or` q := ~((~p) & (~q))
  notation `K`:80 m `,` p := form.k m p
  notation `E`:80 m `,` p := form.awareness m p
  notation `X`:80 m `,` p := form.explicit m p
  notation `B`:80 m `,` p := form.b m p
  notation `[` α ` : ` i ` , ` j ` ] `:80  p := form.pdl α i j p
  notation `[` α ` : ` i ` ] `:80  p := form.receive α i p
  notation `[` α `]`:80 p := form.toP α p
  notation α `*`:80 := program.star α
  notation `ι` m := form.mesg m
  notation α `;` β := program.secv α β
end Notations

@[reducible]
def ctx (σ : nat) : Type := List (form σ)

@[reducible]
def constCtx (σ : nat) : Type := List (message σ)

/-
  Proof system
-/

open form
open message
open program
open List

section ProofSystem
  inductive Proof { σ : ℕ } : ctx σ → constCtx σ → form σ → Prop
  -- Propositional logic
  | ax { Λ } { ℂ : constCtx σ } { p : form σ } (h : p ∈κ Λ) : Proof Λ ℂ p
  | pl1 { Λ } { ℂ : constCtx σ } { p q : form σ } : Proof Λ ℂ (p ⊃ (q ⊃ p))
  | pl2 { Λ } { ℂ : constCtx σ } { p q r : form σ } : Proof Λ ℂ ((p ⊃ (q ⊃ r)) ⊃ ((p ⊃ q) ⊃ (p ⊃ r)))
  | pl3 { Λ } { ℂ : constCtx σ } { p q } : Proof Λ ℂ (((~p) ⊃ ~q) ⊃ (((~p) ⊃ q) ⊃ p))
  | andelim₁ { Λ } { ℂ : constCtx σ } { p q } (hp : Proof Λ ℂ (p & q)) : Proof Λ ℂ p
  | andelim₂ { Λ } { ℂ : constCtx σ } { p q } (hp : Proof Λ ℂ (p & q)) : Proof Λ ℂ q
  | andintro { Λ } { ℂ : constCtx σ } { p q } (hp : Proof Λ ℂ p) (hq : Proof Λ ℂ q ) : Proof Λ ℂ (p & q)
  | trans { Λ } { ℂ : constCtx σ } { p q r : form σ } (hp : Proof Λ ℂ (p ⊃ q)) (hq: Proof Λ ℂ (q ⊃ r)) : Proof Λ ℂ (p ⊃ r)
  -- S5
  | kk { Λ } { ℂ : constCtx σ } { i : message σ } { p q } : Proof Λ ℂ (K i, (p ⊃ q) ⊃ (K i, p ⊃ K i, q))
  | t { Λ } { ℂ : constCtx σ } { i : message σ } { p } : Proof Λ ℂ ((K i, p) ⊃ p)
  | s4 { Λ } { ℂ : constCtx σ } { i : message σ } { p } : Proof Λ ℂ (K i, p ⊃ K i, K i, p)
  -- KD
  | bk { Λ } { ℂ : constCtx σ } { i : message σ } { p q } : Proof Λ ℂ ((B i, (p ⊃ q)) ⊃ ((B i, p) ⊃ (B i, q)))
  | dox { Λ } { ℂ : constCtx σ } { i : message σ } { p } : Proof Λ ℂ (B i, p ⊃ ~B i, (~p))
  | kb { Λ } { ℂ : constCtx σ } { i : message σ } { p } : Proof Λ ℂ ((K i, p) ⊃ (B i, p))
  -- PDL
  | pdlk { Λ } { ℂ : constCtx σ } { i j : message σ } { p q } (α : program σ) : Proof Λ ℂ (([α : i, j](p ⊃ q)) ⊃ ([α : i, j]p  ⊃ [α : i, j] q))
  | pdt { Λ } { ℂ : constCtx σ } { i j : message σ } { p : form σ } {α : program σ } : Proof Λ ℂ (([α : i, j] p) ⊃ p)
  -- PDL*
  | pdlstar₁ { Λ } { ℂ : constCtx σ } { φ : form σ } { α : program σ } (h : Proof Λ ℂ (φ & [α][α*]φ)) : Proof Λ ℂ ([α*]φ)
  | pdlstar₂ { Λ } { ℂ : constCtx σ } { φ : form σ } { α : program σ } (h : Proof Λ ℂ (φ & [α*](φ ⊃ [α]φ))) : Proof Λ ℂ ([α*]φ)
  -- Deductive rules
  | mp { Λ } { ℂ : constCtx σ } { p q } (hpq: Proof Λ ℂ (p ⊃ q)) (hp : Proof Λ ℂ p) : Proof Λ ℂ q
  | knec { Λ } { ℂ : constCtx σ } { i : message σ } { p } (h : Proof [] ℂ p) : Proof Λ ℂ (K i, p)
  | bnec { Λ } { ℂ : constCtx σ } { p } { i : message σ } (h : Proof Λ ℂ p) : Proof Λ ℂ (B i, p)
  | gen { Λ } { ℂ : constCtx σ } { p } { i j : message σ } (α : program σ) (h : Proof Λ ℂ p) : Proof Λ ℂ ([α : i, j]p)
  -- theory of modal constants
  | c₁left { Λ } { ℂ : constCtx σ } { i m₁ m₂ : message σ}
    (h₁ : m₁ ∈κ ℂ)
    (h₂ : m₂ ∈κ ℂ)
    (hp₁ : Proof Λ ℂ (K i, ι m₁))
    (hp₂ : Proof Λ ℂ (K i, ι m₂))
    : Proof Λ ℂ (K i, (ι m₁.conc m₂))
  | c₁right₁ { Λ } { ℂ : constCtx σ } { i m₁ m₂ : message σ}
    (h₁ : m₁ ∈κ ℂ)
    (h₂ : m₂ ∈κ ℂ)
    (hp : Proof Λ ℂ (K i, (ι m₁.conc m₂)))
    : Proof Λ ℂ (K i, ι m₁)
  | c₁right₂ { Λ } { ℂ : constCtx σ } { i m₁ m₂ : message σ}
    (h₁ : m₁ ∈κ ℂ)
    (h₂ : m₂ ∈κ ℂ)
    (hp : Proof Λ ℂ (K i, (ι m₁.conc m₂)))
    : Proof Λ ℂ (K i, ι m₂)
  | c₂ { Λ } { ℂ : constCtx σ } { k j l : message σ }
    (h : (k.keys j l) ∈κ ℂ)
    : Proof Λ ℂ (ι k.keys l j)
  | c₃ { Λ } { ℂ : constCtx σ } { i j m : message σ }
    (h : m ∈κ ℂ)
    (hp₁ : Proof Λ ℂ (K i, ι m.encr j.pk))
    (hp₂ : Proof Λ ℂ (K i, ι j.sk))
    : Proof Λ ℂ (K i, ι m)
  | c₄ { Λ } { ℂ : constCtx σ } { i j m : message σ }
    (h : m ∈κ ℂ)
    (hp₁ : Proof Λ ℂ (K i, ι m.encr j.sk))
    (hp₂ : Proof Λ ℂ (K i, ι j.pk))
    : Proof Λ ℂ (K i, ι m)
  | c₅ { Λ } { ℂ : constCtx σ } {i m k : message σ }
    (h₁ : m ∈κ ℂ)
    (hp₁ : Proof Λ ℂ (K i, ι m))
    (hp₂ : Proof Λ ℂ (K i, ι k))
    : Proof Λ ℂ (K i, ι m.encr k)
  | c₆ { Λ } { ℂ : constCtx σ } { i j k l m : message σ }
    (h : m ∈κ ℂ)
    (hp₁ : Proof Λ ℂ (K i, ι m.encr k))
    (hp₂ : Proof Λ ℂ (K i, ι k.keys j l))
    : Proof Λ ℂ (K i, ι m)
  -- awareness
  | e₁left₁ { Λ } { ℂ : constCtx σ } { i m₁ m₂ : message σ }
    (h₁ : m₁ ∈κ ℂ)
    (h₂ : m₂ ∈κ ℂ)
    (hp : Proof Λ ℂ (E i, (ι m₁.conc m₂)))
    : Proof Λ ℂ (E i, ι m₁)
  | e₁left₂ { Λ } { ℂ : constCtx σ } { i m₁ m₂ : message σ }
    (h₁ : m₁ ∈κ ℂ)
    (h₂ : m₂ ∈κ ℂ)
    (hp : Proof Λ ℂ (E i, (ι m₁.conc m₂)))
    : Proof Λ ℂ (E i, ι m₂)
  | e₂right { Λ } { ℂ : constCtx σ } { i m₁ m₂ : message σ }
    (h₁ : m₁ ∈κ ℂ)
    (h₂ : m₂ ∈κ ℂ)
    (hp₁ : Proof Λ ℂ (E i, ι m₁))
    (hp₂ : Proof Λ ℂ (E i, ι m₂))
    : Proof Λ ℂ (E i, (ι m₁.conc m₂))
  | e₂ { Λ } { ℂ : constCtx σ } { i j k l : message σ }
    (h : k ∈κ ℂ)
    (hp : Proof Λ ℂ (E i, ι k.keys j l))
    : Proof Λ ℂ (E i, ι k.keys l j)
  | e₃ { Λ } { ℂ : constCtx σ } { i j m : message σ }
    (h : m ∈κ ℂ)
    (hp₁ : Proof Λ ℂ (E i, ι m.encr (j.pk)))
    (hp₂ : Proof Λ ℂ (E i, ι (j.sk)))
    : Proof Λ ℂ (E i, ι m)
  | e₄ { Λ } { ℂ : constCtx σ } { i j m : message σ }
    (h : m ∈κ ℂ)
    (hp₁ : Proof Λ ℂ (E i, ι m.encr (j.sk)))
    (hp₂ : Proof Λ ℂ (E i, ι (j.pk)))
    : Proof Λ ℂ (E i, ι m)
  | e₅ { Λ } { ℂ : constCtx σ } { i m k : message σ }
    (h : m ∈κ ℂ)
    (hp₁ : Proof Λ ℂ (E i, ι m))
    (hp₂ : Proof Λ ℂ (E i, ι k))
    : Proof Λ ℂ (E i, ι m.encr k)
  | e₆ { Λ } { ℂ : constCtx σ } { i j k l m : message σ }
    (h : m ∈κ ℂ)
    (hp₁ : Proof Λ ℂ (E i, ι m.encr k))
    (hp₂ : Proof Λ ℂ (E i, ι k.keys j l))
    : Proof Λ ℂ (E i, ι m)
  -- explicit knowledge
  | explicit₁₀ { Λ } { ℂ : constCtx σ } { i m : message σ }
    : Proof Λ ℂ ((X i, ι m) ⊃ (K i, ι m))
  | explicit₁₁ { Λ } { ℂ : constCtx σ } { i m : message σ }
    (h : Proof Λ ℂ (X i, ι m))
    : Proof Λ ℂ (K i, ι m)
  | explicit₁₂ { Λ } { ℂ : constCtx σ } { i m : message σ }
    (h : Proof Λ ℂ (X i, ι m))
    : Proof Λ ℂ (E i, ι m)
  | explicit₂ { Λ } { ℂ : constCtx σ } { i m : message σ }
    (h₁ : Proof Λ ℂ (K i, ι m))
    (h₂ : Proof Λ ℂ (E i, ι m))
    : Proof Λ ℂ (X i, ι m)
  -- axioms for protocols
  | H₀₀ { Λ } { ℂ : constCtx σ } { i j m : message σ }
    : Proof Λ ℂ (([send : i, j] (ι m)) ⊃ ([recv : j] (ι m)))
  | H₀ { Λ } { ℂ : constCtx σ } { i j m : message σ }
    (h : Proof Λ ℂ ([send : i, j] (ι m)))
    : Proof Λ ℂ ([recv : j] (ι m))
  | H₁₀ { Λ } { ℂ : constCtx σ } { i j m : message σ }
    : Proof Λ ℂ (([send : i, j] ι m) ⊃ (X i, ι m))
  | H₁ { Λ } { ℂ : constCtx σ } { i j m : message σ }
    (hp : Proof Λ ℂ ([send : i, j] ι m))
    : Proof Λ ℂ (X i, ι m)
  | H₂₀ { Λ } { ℂ : constCtx σ } { i m : message σ }
    : Proof Λ ℂ (([recv : i] ι m) ⊃ (X i, ι m))
  | H₂ { Λ } { ℂ : constCtx σ } { i m : message σ }
    (hp : Proof Λ ℂ ([recv : i] ι m))
    : Proof Λ ℂ (X i, ι m)
end ProofSystem

notation Λ `-` ℂ ` ⊢κ ` p := Proof Λ ℂ p

open Proof

variable { σ : nat }
variable { p : form σ }

theorem extension_is_consistent { σ : ℕ } { Λ : ctx σ } { Λ' : ctx σ } { ℂ : constCtx σ } { φ : form σ }
  (h₁ : φ ∈κ Λ)
  (h₂ : Λ ⊆κ Λ')
  : Λ'-ℂ ⊢κ φ :=
  begin
    simp [List.subset] at h₂,
    specialize h₂ φ,
    have h₃ := h₂ h₁,
    exact ax h₃
  end

section OSS
  /-
    OSS Theory
  -/

  variables { i r ni : message σ }

  def OSSPK₁₁ : form σ := (X i, ((ι r.pk) & (ι i.pk)))
  def OSSPK₁₂ : form σ := (X r, ((ι r.pk) & (ι i.pk)))
  def OSSPK₂₁ : form σ := (X i, ι i.sk)
  def OSSPK₂₂ : form σ := (X r, ι r.sk)
  def OSS : form σ := ([send : i, r] (ι ((i.conc ni).encr (r.pk))))
  def OSSI : form σ := (X i, ι ni)
  def OSSB : form σ := (([recv : r] (ι (i.conc ni).encr (r.pk)))
    ⊃ ((B r, [send : i, r] ι ((i.conc ni).encr (r.pk))) & (B r, (X i, ι ni))))

  def ΛOSS : ctx σ := (@OSS σ i r ni) :: (@OSSI σ i ni) :: (@OSSB σ i r ni)
    :: (@OSSPK₁₁ σ i r) :: (@OSSPK₁₂ σ i r) :: (@OSSPK₂₁ σ i) :: (@OSSPK₂₂ σ r) :: []
  def ℂOSS : constCtx σ := ni :: (i.conc ni) :: i :: []

  theorem OSS_r_knows_ni { σ : nat } { i r ni : message σ }
    : (@ΛOSS σ i r ni)-(@ℂOSS σ i ni) ⊢κ X r, ι ni :=
    begin
      have pk₁₂ : (@ΛOSS σ i r ni)-(@ℂOSS σ i ni) ⊢κ (X r, ((ι r.pk) & (ι i.pk))) :=
        ax (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }),
      have pk₂₂ : (@ΛOSS σ i r ni)-(@ℂOSS σ i ni) ⊢κ (X r, ι r.sk) :=
        ax (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }),
      have oss : (@ΛOSS σ i r ni)-(@ℂOSS σ i ni) ⊢κ ([send : i, r] (ι ((i.conc ni).encr (r.pk)))) :=
        ax (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }),
      have h₁ := c₃ (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem })
        (explicit₁₁ (H₂ (H₀ oss)))
        (explicit₁₁ pk₂₂),
      have h₂ : (@ΛOSS σ i r ni)-(@ℂOSS σ i ni) ⊢κ E r, ι (i.conc ni) := e₃
        (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem })
        (explicit₁₂ (H₂ (H₀ oss)))
        (explicit₁₂ pk₂₂),
      have h₃ := @c₁right₂ σ (@ΛOSS σ i r ni) (@ℂOSS σ i ni)
        r i ni
        (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem })
        (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem })
        h₁,
      have h₄ := @e₁left₂ σ (@ΛOSS σ i r ni) (@ℂOSS σ i ni)
        r i ni
        (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem })
        (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem })
        h₂,
        exact explicit₂ h₃ h₄,
    end

  theorem OSS_r_believes_i_knows_ni { σ : nat } { i r ni : message σ }
    : (@ΛOSS σ i r ni)-(@ℂOSS σ i ni) ⊢κ B r, (X i, ι ni) :=
    begin
      have oss : (@ΛOSS σ i r ni)-(@ℂOSS σ i ni) ⊢κ ([send : i, r] (ι ((i.conc ni).encr (r.pk)))) :=
        ax (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }),
      have ossb : (@ΛOSS σ i r ni)-(@ℂOSS σ i ni) ⊢κ (([recv : r] (ι (i.conc ni).encr (r.pk)))
        ⊃ ((B r, [send : i, r] ι ((i.conc ni).encr (r.pk))) & (B r, (X i, ι ni)))) :=
        ax (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }),
      exact andelim₂ (mp ossb (H₀ oss))
    end

  /-
    Attack in OSS
  -/
  variables { e ne : message σ }
  def ATT : form σ := (((X e, ι ne) & ~(X i, ι ne)) & [send : e, r] ι (i.conc ne).encr (r.pk))
  def OSSBATT : form σ := (([recv : r] (ι (i.conc ne).encr (r.pk)))
    ⊃ ((B r, [send : i, r] ι ((i.conc ne).encr (r.pk))) & (B r, (X i, ι ne))))

  def ΛOSSATT : ctx σ := (@ΛOSS σ i r ni) ++ ((@ATT σ i r e ne) :: (@OSSBATT σ i r ne) :: [])
  def ℂOSSATT : constCtx σ := (@ℂOSS σ i ni) ++ (e :: ne :: [])

  theorem OSS_attack { σ : nat } { i r ni e ne : message σ }
    : (@ΛOSSATT σ i r ni e ne)-(@ℂOSSATT σ i ni e ne) ⊢κ (B r, [send : i, r] ι ((i.conc ne).encr (r.pk)) & (B r, (X i, ι ne))) :=
    begin
      have ossatt : (@ΛOSSATT σ i r ni e ne)-(@ℂOSSATT σ i ni e ne) ⊢κ
        (((X e, ι ne) & ~(X i, ι ne)) & [send : e, r] ι (i.conc ne).encr (r.pk)) :=
          ax (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }),
        have ossb : (@ΛOSSATT σ i r ni e ne)-(@ℂOSSATT σ i ni e ne) ⊢κ (([recv : r] (ι (i.conc ne).encr (r.pk)))
          ⊃ ((B r, [send : i, r] ι ((i.conc ne).encr (r.pk))) & (B r, (X i, ι ne)))) :=
          ax (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }),
        exact mp ossb (H₀ (andelim₂ ossatt)),
    end

end OSS

section NeedhamSchroeder
  /-
    Needham-Schroeder
  -/
  def agent := message

  variables { i r n₁ n₂ : message σ }

  def NSPK₁₁ : form σ := (X i, ι i.pk)
  def NSPK₁₂ : form σ := (X i, ι i.sk)
  def NSPK₁₃ : form σ := (X i, ι r.pk)

  def NSPK₂₁ : form σ := (X r, ι r.pk)
  def NSPK₂₂ : form σ := (X r, ι r.sk)
  def NSPK₂₃ : form σ := (X r, ι i.pk)

  def NS₁ : form σ := (((X r, ι (i.conc n₁).encr (r.pk)) & (X r, ι n₂)) ⊃ [send : r, i] ι ((n₁.conc n₂).encr (i.pk)))
  def NS₂ : form σ := ((((X i, ι n₁) & ([send : i, r] ι (i.conc n₁).encr (r.pk))) & (X i, ι (n₁.conc n₂))) ⊃ [send : i, r] ι (n₂.encr (r.pk)))
  def NS₃ : form σ := (([recv : r] ι (i.conc n₁).encr (r.pk)) ⊃ ((B r, [send : i, r] ι ((i.conc n₁).encr (r.pk))) & (B r, (X i, ι n₁))))
  def NS₄ : form σ := ((((X i, ι n₁) & ([send : i, r] ι (i.conc n₁).encr (r.pk))) & ([recv : i] ι (n₁.conc n₂).encr (i.pk))) ⊃ ((B i, [send : r, i] ι ((n₁.conc n₂).encr (i.pk))) & (B i, (X r, ι n₂))))
  def NS₅ : form σ := ((((X r, ι n₂) & ([send : r, i] ι ((n₁.conc n₂).encr (i.pk)))) & ([recv : r] ι (n₂.encr (r.pk)))) ⊃ (B r, (X i, ι n₂)))

  def NSI₁ : form σ := (X i, ι n₁)
  def NSI₂ : form σ := (X r, ι n₂)
  def NSI₃ : form σ := ([send : i, r] ι ((i.conc n₁).encr (r.pk)))

  def ΛNSPK : ctx σ := (@NSPK₁₁ σ i) :: (@NSPK₁₂ σ i) :: (@NSPK₁₃ σ i r)
    :: (@NSPK₂₁ σ r) :: (@NSPK₂₂ σ r) :: (@NSPK₂₃ σ i r)
    :: (@NS₁ σ i r n₁ n₂) :: (@NS₂ σ i r n₁ n₂) :: (@NS₃ σ i r n₁) :: (@NS₄ σ i r n₁ n₂) :: (@NS₅ σ i r n₁ n₂)
    :: (@NSI₁ σ i n₁) :: (@NSI₂ σ r n₂) :: (@NSI₃ σ i r n₁) :: []

  def C₁ : message σ := ((i.conc n₁))

  def ℂNSPK : constCtx σ := (@C₁ σ i n₁) :: (i) :: (n₁) :: []

  theorem NSPK_Xr_ni { σ : nat } { i r n₁ n₂ : message σ }
    : (@ΛNSPK σ i r n₁ n₂)-(@ℂNSPK σ i n₁) ⊢κ X r, ι n₁ :=
  begin
    have nsi₃ : (@ΛNSPK σ i r n₁ n₂)-(@ℂNSPK σ i n₁) ⊢κ ([send : i, r] ι ((i.conc n₁).encr (r.pk))) :=
      ax (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }),
    have h₁ := H₂ (H₀ nsi₃),
    have nspk₂₂ :  (@ΛNSPK σ i r n₁ n₂)-(@ℂNSPK σ i n₁) ⊢κ (X r, ι r.sk) :=
      ax (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }),
    have h₂ := c₃ ((by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem })) (explicit₁₁ h₁) (explicit₁₁ nspk₂₂),
    have h₃ := e₃ ((by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem })) (explicit₁₂ h₁) (explicit₁₂ nspk₂₂),
    have h₄ := @c₁right₂ σ  (@ΛNSPK σ i r n₁ n₂) (@ℂNSPK σ i n₁) r i n₁
      ((by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }))
      ((by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }))
      h₂,
    have h₅ := @e₁left₂ σ  (@ΛNSPK σ i r n₁ n₂) (@ℂNSPK σ i n₁) r i n₁
      ((by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }))
      ((by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }))
      h₃,
    exact explicit₂ h₄ h₅
  end

  /-
    Man-in-the-Middle Attack in NSPK
  -/

  variables { e : agent σ }
  def MITM₁ : form σ := (X i, ι n₁)
  def MITM₂ : form σ := (X r, ι n₂)
  def MITM₃ : form σ := ([send : i, e] ι (i.conc n₁).encr (e.pk))
  def MITM₄ : form σ := (~([send : i, r] ι (i.conc n₁).encr (i.pk)))

  def ΛMITM : ctx σ := ((@MITM₁ σ i n₁) :: (@MITM₂ σ r n₂) :: (@MITM₃ σ i n₁ e) :: (@MITM₄ σ i r n₁) :: [])
    ++ (@ΛNSPK σ i r n₁ n₂)

  theorem MITM_attack { σ : nat } { i r n₁ n₂ e : message σ }
    : (@ΛMITM σ i r n₁ n₂ e)-(@ℂNSPK σ i n₁) ⊢κ B r, ([send : i, r] ι ((i.conc n₁).encr (r.pk))) :=
    begin
      have nsi₃ : (@ΛMITM σ i r n₁ n₂ e)-(@ℂNSPK σ i n₁) ⊢κ ([send : i, r] ι ((i.conc n₁).encr (r.pk))) :=
        ax (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }),
      have h₁ := H₀ nsi₃,
      have hns₃ : (@ΛMITM σ i r n₁ n₂ e)-(@ℂNSPK σ i n₁) ⊢κ (([recv : r] ι (i.conc n₁).encr (r.pk)) ⊃ ((B r, [send : i, r] ι ((i.conc n₁).encr (r.pk))) & (B r, (X i, ι n₁)))) :=
        ax (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }),
      have h₂ := mp hns₃ h₁,
      exact andelim₁ h₂,
    end

end NeedhamSchroeder

section BAN
  /-
    BAN Logic
  -/

  section BANAux

    theorem explicit_implies_message { σ : nat } { Λ : ctx σ } { ℂ : constCtx σ }
      { i m : message σ }
      : Λ-ℂ ⊢κ (X i, ι m) ⊃ ι m := trans explicit₁₀ t

  end BANAux

  variables { i r m m₁ m₂ k kir : message σ }

  def MMSKBAN : form σ := (((X i, ι kir.keys i r) & ([recv : i] ι m.encr kir)) ⊃ (B i, [send : r, i] ι m))
  def MMPKBAN : form σ := (((X i, ι r.pk) & ([recv : i] ι m.encr (r.sk))) ⊃ (B i, [send : r, i] ι m))

  def BC₁ : form σ := (ι m₁ & ι m₂) ⊃ ι (m₁.conc m₂)
  def BC₂ : form σ := (ι kir.keys i r) ⊃ (ι kir.keys r i)
  def BC₃ : form σ := (ι (m.encr r.pk) & ι r.sk) ⊃ ι m
  def BC₄ : form σ := (ι (m.encr r.sk) & ι r.pk) ⊃ ι m
  def BC₅ : form σ := ((ι m) & (ι k)) ⊃ ι (m.encr k)
  def BC₆ : form σ := ((ι m.encr (kir.keys i r)) & (ι k.keys i r)) ⊃ ι m
  def BH : agent σ -> form σ := λ a, (X a, ι m) ⊃ ([recv : a] (ι m))

  def ΛBAN : ctx σ := (@MMSKBAN σ i r m kir) :: (@MMPKBAN σ i r m) :: []

  theorem JR { σ : nat } { Λ : ctx σ } { ℂ : constCtx σ }
    { i j k : message σ }
    (h₁ : Λ-ℂ ⊢κ B i, B j, ι k)
    (h₂ : Λ-ℂ ⊢κ B i, ((B j, ι k) ⊃ (X j, ι k)))
    : Λ-ℂ ⊢κ B i, ι k := mp
      (mp bk (bnec explicit_implies_message))
      (mp (mp bk h₂) h₁)

  theorem NV { σ : nat } { Λ : ctx σ } { ℂ : constCtx σ }
    { i r n : message σ }
    : Λ-ℂ ⊢κ ((B i, ([send : r, i] ι n)) ⊃ (B i, (X r, ι n))) := mp bk (bnec H₁₀)

  theorem MMSK { σ : nat } { ℂ : constCtx σ }
    { i r m kir : message σ }
    (h₁ : (@ΛBAN σ i r m kir)-ℂ ⊢κ X i, ι kir.keys i r)
    (h₂ : (@ΛBAN σ i r m kir)-ℂ ⊢κ [recv : i] ι m.encr kir)
    : (@ΛBAN σ i r m kir)-ℂ ⊢κ B i, ([send : r, i] ι m) :=
    begin
      have ban : (@ΛBAN σ i r m kir)-ℂ ⊢κ
        (((X i, ι kir.keys i r) & ([recv : i] ι m.encr kir)) ⊃ (B i, [send : r, i] ι m)) :=
        ax (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }),
      exact mp ban (andintro h₁ h₂)
    end

  theorem MMPK { σ : nat } { ℂ : constCtx σ }
    { i r m kir : message σ }
    (h₁ : (@ΛBAN σ i r m kir)-ℂ ⊢κ (X i, ι r.pk))
    (h₂ : (@ΛBAN σ i r m kir)-ℂ ⊢κ ([recv : i] ι m.encr (r.sk)))
    : (@ΛBAN σ i r m kir)-ℂ ⊢κ B i, ([send : r, i] ι m) :=
    begin
      have ban : (@ΛBAN σ i r m kir)-ℂ ⊢κ (((X i, ι r.pk) & ([recv : i] ι m.encr (r.sk))) ⊃ (B i, [send : r, i] ι m)) :=
        ax (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }),
      exact mp ban (andintro h₁ h₂)
    end

    section ProtocolExample
      -- S -> R: {I, pk(I)}sk(S)
      -- R -> I: {R, nR}sk(R)
      -- I -> R : {nR, I}sk(I)

      variables { I R S n : message σ }

      -- BAN Idealization
      def P₁ : form σ := ([recv : R] ι (n.encr (S.sk)))
      def P₂ : form σ := ([recv : I] ι (n.encr (R.sk)))
      def P₃ : form σ := ([recv : R] ι (n.encr (I.sk)))

      -- BAN Assumptions
      def A₁ : form σ := (X R, ι S.pk)
      def A₂ : form σ := (X I, ι R.pk)
      def A₃ : form σ := B R, (X S, ι I.pk)
      def A₄ : form σ := B I, (X R, ι n)

      -- Logic defined by (P₁ - P₃) ∪ (A₁ - A₄) ∪ ΛBAN

      def ΛBANP : ctx σ := (@P₁ σ I R S) :: (@P₂ σ I R n) :: (@P₃ σ I R n)
        :: (@A₁ σ R S) :: (@A₂ σ I R) :: (@A₃ σ I R S) :: (@A₄ σ I R n) :: [] ++ (@ΛBAN σ I R n n)

      -- We want to prove that I and R are mutual authenticated to each other through nR
      -- in BAN: I believes that R believes that nR

      theorem BAN_theory_subset_of_BANP_theory : (@ΛBAN σ I R n n) ⊆κ (@ΛBANP σ I R S n) :=
      begin
        intro x,
        intro ha,
        cases ha,
        {
          rw [ha],
          repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }
        },
        {
          cases ha,
          {
            rw [ha],
            repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }
          },
          {
            cases ha,
          }
        }
      end

      theorem BAN_auth_from_I { σ : nat } { ℂ : constCtx σ }
        { I R S n : message σ }
        : (@ΛBANP σ I R S n)-ℂ ⊢κ B I, (X R, ι n) :=
        begin
          have p₂ : (@ΛBANP σ I R S n)-ℂ ⊢κ ([recv : I] ι (n.encr (R.sk))) :=
            ax (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }),
          have a₂ : (@ΛBANP σ I R S n)-ℂ ⊢κ (X I, ι R.pk) :=
            ax (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }),
          have mmpk : (@ΛBAN σ I R n n)-ℂ ⊢κ (((X I, ι R.pk) & ([recv : I] ι n.encr (R.sk))) ⊃ (B I, [send : R, I] ι n)) :=
            ax (by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }),
          have h₀ : (@ΛBANP σ I R S n)-ℂ ⊢κ (((X I, ι R.pk) & ([recv : I] ι n.encr (R.sk))) ⊃ (B I, [send : R, I] ι n)) :=
            extension_is_consistent
              ((by repeat { apply List.mem_cons_self <|> apply List.mem_cons_of_mem }))
              (BAN_theory_subset_of_BANP_theory),
          have h₁ := mp h₀ (andintro a₂ p₂),
          exact mp NV h₁
        end

    end ProtocolExample

end BAN


import algebra.group.basic

-- 定义 1-1
-- #print semigroup
-- #check @semigroup.mul
-- #check @semigroup.mul_assoc

-- #print monoid
-- #check @monoid.one
-- #check @monoid.one_mul
-- #check @monoid.mul_one

-- 定义 1-2
-- #print group
-- #check @group.inv
-- #check @mul_left_inv
-- #check @mul_right_inv
-- TODO: 交换群，有限群，n 阶群

-- TODO 例子 1-10

namespace dasda

universes u v
variables (σ : Sort u) (τ : Sort v)
#check σ → τ
end dasda

namespace dasda1

universes u v
variables (σ : Sort u) (τ : Sort 0)
#check σ → τ

#print subtype
#check @subtype.mk
#check @subtype.val
#check @subtype.property

end dasda1

namespace dsafas

def foo (h: ∃ n : ℕ, n = n) : ℕ :=
match h with
| Exists.intro n _ := n
end

def foo1 {p q} (h: p ∧ q)  :=
match h with
| and.intro n _ := n
end

#check @foo1
end dsafas
-- variables {G H : Type} [group G] [group H]
namespace chapter2.section1
variables {G : Type*} [group G]
-- 性质 1-1
lemma group_id_uniq (e e': G) :
  (∀ a, e * a = a ∧ a * e = a) ∧ (∀ a, e' * a = a ∧ a * e' = a) → e = e' :=
begin
  rintro ⟨he, he'⟩,
  have h1 := (he e').1,
  have h2 := (he' e).2,
  rw h2 at h1,
  exact h1,
end

-- 性质 1-2
lemma group_inv_uniq (a a₁ a₂: G):
  (a₁ * a = 1 ∧ a * a₁ = 1) ∧ (a₂ * a = 1 ∧ a * a₂ = 1) → a₁ = a₂ :=
begin
  rintro ⟨⟨ha₁l, ha₁r⟩, ⟨ha₂l, ha₂r⟩⟩,
  exact by calc
  a₁  = a₁ * (a * a₂) : by rw [ha₂r, mul_one]
  ... = (a₁ * a) * a₂ : by rw mul_assoc
  ... = a₂ : by rw [ha₁l, one_mul]
end

-- 性质 1-3
lemma my_inv_inv (a : G) : (a⁻¹)⁻¹ = a :=
begin
  have h: a * ((a⁻¹) * (a⁻¹)⁻¹) = a * ((a⁻¹) * a) := begin
    rw mul_inv_self,
    rw inv_mul_self,
  end,
  rw ← mul_assoc at h,
  rw ← mul_assoc at h,
  simp only [mul_inv_self, one_mul] at h,
  exact h,
end
-- 性质 1-4
lemma my_mul_inv_rev (a b : G) : (a * b)⁻¹ = b⁻¹ * a⁻¹ :=
begin
  have h: (a * b)⁻¹ * (a * b * (a * b)⁻¹) =  (a * b)⁻¹ * (a * b * (b⁻¹ * a⁻¹)) := by simp,
  rw ← mul_assoc (a * b)⁻¹ (a * b) at h,
  rw ← mul_assoc (a * b)⁻¹ (a * b) at h,
  rw inv_mul_self at h,
  rw one_mul at h,
  rw one_mul at h,
  exact h,
end

-- 性质 1-5

lemma my_mul_inv_rev1 (a b : G) : ∃ x y, a * x = b ∧ y * a = b :=
begin
  use [a⁻¹ * b, b * a⁻¹],
  simp,
end

-- 性质 1-6

lemma my_mul_left_cancel (a b c: G) : a * b = a * c → b = c :=
begin
  intro h,
  convert_to a⁻¹ * a * b = a⁻¹ * a * c,
  { rw inv_mul_self, rw one_mul },
  { rw inv_mul_self, rw one_mul },
  rw mul_assoc,
  rw mul_assoc,
  rw h,
end

-- 略

end chapter2.section1