/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Scott Morrison, Ainsley Pahljina

! This file was ported from Lean 3 source module number_theory.lucas_lehmer
! leanprover-community/mathlib commit 10b4e499f43088dd3bb7b5796184ad5216648ab1
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Nat.Parity
import Mathbin.Data.Pnat.Interval
import Mathbin.Data.Zmod.Basic
import Mathbin.GroupTheory.OrderOfElement
import Mathbin.RingTheory.Fintype
import Mathbin.Tactic.IntervalCases
import Mathbin.Tactic.RingExp

/-!
# The Lucas-Lehmer test for Mersenne primes.

We define `lucas_lehmer_residue : Π p : ℕ, zmod (2^p - 1)`, and
prove `lucas_lehmer_residue p = 0 → prime (mersenne p)`.

We construct a tactic `lucas_lehmer.run_test`, which iteratively certifies the arithmetic
required to calculate the residue, and enables us to prove

```
example : prime (mersenne 127) :=
lucas_lehmer_sufficiency _ (by norm_num) (by lucas_lehmer.run_test)
```

## TODO

- Show reverse implication.
- Speed up the calculations using `n ≡ (n % 2^p) + (n / 2^p) [MOD 2^p - 1]`.
- Find some bigger primes!

## History

This development began as a student project by Ainsley Pahljina,
and was then cleaned up for mathlib by Scott Morrison.
The tactic for certified computation of Lucas-Lehmer residues was provided by Mario Carneiro.
-/

/-- The Mersenne numbers, 2^p - 1. -/
def mersenne (p : ℕ) : ℕ :=
  2 ^ p - 1
#align mersenne mersenne

theorem mersenne_pos {p : ℕ} (h : 0 < p) : 0 < mersenne p :=
  by
  dsimp [mersenne]
  calc
    0 < 2 ^ 1 - 1 := by norm_num
    _ ≤ 2 ^ p - 1 := Nat.pred_le_pred (Nat.pow_le_pow_of_le_right (Nat.succ_pos 1) h)

#align mersenne_pos mersenne_pos

@[simp]
theorem succ_mersenne (k : ℕ) : mersenne k + 1 = 2 ^ k :=
  by
  rw [mersenne, tsub_add_cancel_of_le]
  exact one_le_pow_of_one_le (by norm_num) k
#align succ_mersenne succ_mersenne

namespace LucasLehmer

open Nat

/-!
We now define three(!) different versions of the recurrence
`s (i+1) = (s i)^2 - 2`.

These versions take values either in `ℤ`, in `zmod (2^p - 1)`, or
in `ℤ` but applying `% (2^p - 1)` at each step.

They are each useful at different points in the proof,
so we take a moment setting up the lemmas relating them.
-/

/-- The recurrence `s (i+1) = (s i)^2 - 2` in `ℤ`. -/
def s : ℕ → ℤ
  | 0 => 4
  | i + 1 => s i ^ 2 - 2
#align lucas_lehmer.s LucasLehmer.s

/-- The recurrence `s (i+1) = (s i)^2 - 2` in `zmod (2^p - 1)`. -/
def sZmod (p : ℕ) : ℕ → ZMod (2 ^ p - 1)
  | 0 => 4
  | i + 1 => s_zmod i ^ 2 - 2
#align lucas_lehmer.s_zmod LucasLehmer.sZmod

/-- The recurrence `s (i+1) = ((s i)^2 - 2) % (2^p - 1)` in `ℤ`. -/
def sMod (p : ℕ) : ℕ → ℤ
  | 0 => 4 % (2 ^ p - 1)
  | i + 1 => (s_mod i ^ 2 - 2) % (2 ^ p - 1)
#align lucas_lehmer.s_mod LucasLehmer.sMod

theorem mersenne_int_ne_zero (p : ℕ) (w : 0 < p) : (2 ^ p - 1 : ℤ) ≠ 0 :=
  by
  apply ne_of_gt; simp only [gt_iff_lt, sub_pos]
  exact_mod_cast Nat.one_lt_two_pow p w
#align lucas_lehmer.mersenne_int_ne_zero LucasLehmer.mersenne_int_ne_zero

theorem sMod_nonneg (p : ℕ) (w : 0 < p) (i : ℕ) : 0 ≤ sMod p i :=
  by
  cases i <;> dsimp [s_mod]
  · exact sup_eq_right.mp rfl
  · apply Int.emod_nonneg
    exact mersenne_int_ne_zero p w
#align lucas_lehmer.s_mod_nonneg LucasLehmer.sMod_nonneg

theorem sMod_mod (p i : ℕ) : sMod p i % (2 ^ p - 1) = sMod p i := by cases i <;> simp [s_mod]
#align lucas_lehmer.s_mod_mod LucasLehmer.sMod_mod

theorem sMod_lt (p : ℕ) (w : 0 < p) (i : ℕ) : sMod p i < 2 ^ p - 1 :=
  by
  rw [← s_mod_mod]
  convert Int.emod_lt _ _
  · refine' (abs_of_nonneg _).symm
    simp only [sub_nonneg, ge_iff_le]
    exact_mod_cast Nat.one_le_two_pow p
  · exact mersenne_int_ne_zero p w
#align lucas_lehmer.s_mod_lt LucasLehmer.sMod_lt

theorem sZmod_eq_s (p' : ℕ) (i : ℕ) : sZmod (p' + 2) i = (s i : ZMod (2 ^ (p' + 2) - 1)) :=
  by
  induction' i with i ih
  · dsimp [s, s_zmod]
    norm_num
  · push_cast [s, s_zmod, ih]
#align lucas_lehmer.s_zmod_eq_s LucasLehmer.sZmod_eq_s

-- These next two don't make good `norm_cast` lemmas.
theorem Int.coe_nat_pow_pred (b p : ℕ) (w : 0 < b) : ((b ^ p - 1 : ℕ) : ℤ) = (b ^ p - 1 : ℤ) :=
  by
  have : 1 ≤ b ^ p := Nat.one_le_pow p b w
  norm_cast
#align lucas_lehmer.int.coe_nat_pow_pred LucasLehmer.Int.coe_nat_pow_pred

theorem Int.coe_nat_two_pow_pred (p : ℕ) : ((2 ^ p - 1 : ℕ) : ℤ) = (2 ^ p - 1 : ℤ) :=
  Int.coe_nat_pow_pred 2 p (by decide)
#align lucas_lehmer.int.coe_nat_two_pow_pred LucasLehmer.Int.coe_nat_two_pow_pred

theorem sZmod_eq_sMod (p : ℕ) (i : ℕ) : sZmod p i = (sMod p i : ZMod (2 ^ p - 1)) := by
  induction i <;> push_cast [← int.coe_nat_two_pow_pred p, s_mod, s_zmod, *]
#align lucas_lehmer.s_zmod_eq_s_mod LucasLehmer.sZmod_eq_sMod

/-- The Lucas-Lehmer residue is `s p (p-2)` in `zmod (2^p - 1)`. -/
def lucasLehmerResidue (p : ℕ) : ZMod (2 ^ p - 1) :=
  sZmod p (p - 2)
#align lucas_lehmer.lucas_lehmer_residue LucasLehmer.lucasLehmerResidue

theorem residue_eq_zero_iff_sMod_eq_zero (p : ℕ) (w : 1 < p) :
    lucasLehmerResidue p = 0 ↔ sMod p (p - 2) = 0 :=
  by
  dsimp [lucas_lehmer_residue]
  rw [s_zmod_eq_s_mod p]
  constructor
  · -- We want to use that fact that `0 ≤ s_mod p (p-2) < 2^p - 1`
    -- and `lucas_lehmer_residue p = 0 → 2^p - 1 ∣ s_mod p (p-2)`.
    intro h
    simp [ZMod.int_cast_zmod_eq_zero_iff_dvd] at h
    apply Int.eq_zero_of_dvd_of_nonneg_of_lt _ _ h <;> clear h
    apply s_mod_nonneg _ (Nat.lt_of_succ_lt w)
    exact s_mod_lt _ (Nat.lt_of_succ_lt w) (p - 2)
  · intro h
    rw [h]
    simp
#align lucas_lehmer.residue_eq_zero_iff_s_mod_eq_zero LucasLehmer.residue_eq_zero_iff_sMod_eq_zero

/-- A Mersenne number `2^p-1` is prime if and only if
the Lucas-Lehmer residue `s p (p-2) % (2^p - 1)` is zero.
-/
def LucasLehmerTest (p : ℕ) : Prop :=
  lucasLehmerResidue p = 0deriving DecidablePred
#align lucas_lehmer.lucas_lehmer_test LucasLehmer.LucasLehmerTest

/-- `q` is defined as the minimum factor of `mersenne p`, bundled as an `ℕ+`. -/
def q (p : ℕ) : ℕ+ :=
  ⟨Nat.minFac (mersenne p), Nat.minFac_pos (mersenne p)⟩
#align lucas_lehmer.q LucasLehmer.q

-- It would be nice to define this as (ℤ/qℤ)[x] / (x^2 - 3),
-- obtaining the ring structure for free,
-- but that seems to be more trouble than it's worth;
-- if it were easy to make the definition,
-- cardinality calculations would be somewhat more involved, too.
/-- We construct the ring `X q` as ℤ/qℤ + √3 ℤ/qℤ. -/
def X (q : ℕ+) : Type :=
  ZMod q × ZMod q deriving AddCommGroup, DecidableEq, Fintype, Inhabited
#align lucas_lehmer.X LucasLehmer.X

namespace X

variable {q : ℕ+}

@[ext]
theorem ext {x y : X q} (h₁ : x.1 = y.1) (h₂ : x.2 = y.2) : x = y :=
  by
  cases x; cases y
  congr <;> assumption
#align lucas_lehmer.X.ext LucasLehmer.X.ext

@[simp]
theorem add_fst (x y : X q) : (x + y).1 = x.1 + y.1 :=
  rfl
#align lucas_lehmer.X.add_fst LucasLehmer.X.add_fst

@[simp]
theorem add_snd (x y : X q) : (x + y).2 = x.2 + y.2 :=
  rfl
#align lucas_lehmer.X.add_snd LucasLehmer.X.add_snd

@[simp]
theorem neg_fst (x : X q) : (-x).1 = -x.1 :=
  rfl
#align lucas_lehmer.X.neg_fst LucasLehmer.X.neg_fst

@[simp]
theorem neg_snd (x : X q) : (-x).2 = -x.2 :=
  rfl
#align lucas_lehmer.X.neg_snd LucasLehmer.X.neg_snd

instance : Mul (X q) where mul x y := (x.1 * y.1 + 3 * x.2 * y.2, x.1 * y.2 + x.2 * y.1)

@[simp]
theorem mul_fst (x y : X q) : (x * y).1 = x.1 * y.1 + 3 * x.2 * y.2 :=
  rfl
#align lucas_lehmer.X.mul_fst LucasLehmer.X.mul_fst

@[simp]
theorem mul_snd (x y : X q) : (x * y).2 = x.1 * y.2 + x.2 * y.1 :=
  rfl
#align lucas_lehmer.X.mul_snd LucasLehmer.X.mul_snd

instance : One (X q) where one := ⟨1, 0⟩

@[simp]
theorem one_fst : (1 : X q).1 = 1 :=
  rfl
#align lucas_lehmer.X.one_fst LucasLehmer.X.one_fst

@[simp]
theorem one_snd : (1 : X q).2 = 0 :=
  rfl
#align lucas_lehmer.X.one_snd LucasLehmer.X.one_snd

@[simp]
theorem bit0_fst (x : X q) : (bit0 x).1 = bit0 x.1 :=
  rfl
#align lucas_lehmer.X.bit0_fst LucasLehmer.X.bit0_fst

@[simp]
theorem bit0_snd (x : X q) : (bit0 x).2 = bit0 x.2 :=
  rfl
#align lucas_lehmer.X.bit0_snd LucasLehmer.X.bit0_snd

@[simp]
theorem bit1_fst (x : X q) : (bit1 x).1 = bit1 x.1 :=
  rfl
#align lucas_lehmer.X.bit1_fst LucasLehmer.X.bit1_fst

@[simp]
theorem bit1_snd (x : X q) : (bit1 x).2 = bit0 x.2 :=
  by
  dsimp [bit1]
  simp
#align lucas_lehmer.X.bit1_snd LucasLehmer.X.bit1_snd

instance : Monoid (X q) :=
  {
    (inferInstance :
      Mul
        (X
          q)) with
    mul_assoc := fun x y z => by
      ext <;>
        · dsimp
          ring
    one := ⟨1, 0⟩
    one_mul := fun x => by ext <;> simp
    mul_one := fun x => by ext <;> simp }

instance : AddGroupWithOne (X q) :=
  { X.monoid, X.addCommGroup _ with
    natCast := fun n => ⟨n, 0⟩
    natCast_zero := by simp
    natCast_succ := by simp [Nat.cast, Monoid.one]
    intCast := fun n => ⟨n, 0⟩
    intCast_ofNat := fun n => by simp <;> rfl
    intCast_negSucc := fun n => by ext <;> simp <;> rfl }

theorem left_distrib (x y z : X q) : x * (y + z) = x * y + x * z := by
  ext <;>
    · dsimp
      ring
#align lucas_lehmer.X.left_distrib LucasLehmer.X.left_distrib

theorem right_distrib (x y z : X q) : (x + y) * z = x * z + y * z := by
  ext <;>
    · dsimp
      ring
#align lucas_lehmer.X.right_distrib LucasLehmer.X.right_distrib

instance : Ring (X q) :=
  { X.addGroupWithOne, (inferInstance : AddCommGroup (X q)),
    (inferInstance : Monoid (X q)) with
    left_distrib := left_distrib
    right_distrib := right_distrib }

instance : CommRing (X q) :=
  { (inferInstance : Ring (X q)) with
    mul_comm := fun x y => by
      ext <;>
        · dsimp
          ring }

instance [Fact (1 < (q : ℕ))] : Nontrivial (X q) :=
  ⟨⟨0, 1, fun h => by
      injection h with h1 _
      exact zero_ne_one h1⟩⟩

@[simp]
theorem nat_coe_fst (n : ℕ) : (n : X q).fst = (n : ZMod q) :=
  rfl
#align lucas_lehmer.X.nat_coe_fst LucasLehmer.X.nat_coe_fst

@[simp]
theorem nat_coe_snd (n : ℕ) : (n : X q).snd = (0 : ZMod q) :=
  rfl
#align lucas_lehmer.X.nat_coe_snd LucasLehmer.X.nat_coe_snd

@[simp]
theorem int_coe_fst (n : ℤ) : (n : X q).fst = (n : ZMod q) :=
  rfl
#align lucas_lehmer.X.int_coe_fst LucasLehmer.X.int_coe_fst

@[simp]
theorem int_coe_snd (n : ℤ) : (n : X q).snd = (0 : ZMod q) :=
  rfl
#align lucas_lehmer.X.int_coe_snd LucasLehmer.X.int_coe_snd

@[norm_cast]
theorem coe_mul (n m : ℤ) : ((n * m : ℤ) : X q) = (n : X q) * (m : X q) := by ext <;> simp <;> ring
#align lucas_lehmer.X.coe_mul LucasLehmer.X.coe_mul

@[norm_cast]
theorem coe_nat (n : ℕ) : ((n : ℤ) : X q) = (n : X q) := by ext <;> simp
#align lucas_lehmer.X.coe_nat LucasLehmer.X.coe_nat

/-- The cardinality of `X` is `q^2`. -/
theorem x_card : Fintype.card (X q) = q ^ 2 :=
  by
  dsimp [X]
  rw [Fintype.card_prod, ZMod.card q]
  ring
#align lucas_lehmer.X.X_card LucasLehmer.X.x_card

/-- There are strictly fewer than `q^2` units, since `0` is not a unit. -/
theorem units_card (w : 1 < q) : Fintype.card (X q)ˣ < q ^ 2 :=
  by
  haveI : Fact (1 < (q : ℕ)) := ⟨w⟩
  convert card_units_lt (X q)
  rw [X_card]
#align lucas_lehmer.X.units_card LucasLehmer.X.units_card

/-- We define `ω = 2 + √3`. -/
def ω : X q :=
  (2, 1)
#align lucas_lehmer.X.ω LucasLehmer.X.ω

/-- We define `ωb = 2 - √3`, which is the inverse of `ω`. -/
def ωb : X q :=
  (2, -1)
#align lucas_lehmer.X.ωb LucasLehmer.X.ωb

theorem ω_mul_ωb (q : ℕ+) : (ω : X q) * ωb = 1 :=
  by
  dsimp [ω, ωb]
  ext <;> simp <;> ring
#align lucas_lehmer.X.ω_mul_ωb LucasLehmer.X.ω_mul_ωb

theorem ωb_mul_ω (q : ℕ+) : (ωb : X q) * ω = 1 :=
  by
  dsimp [ω, ωb]
  ext <;> simp <;> ring
#align lucas_lehmer.X.ωb_mul_ω LucasLehmer.X.ωb_mul_ω

/-- A closed form for the recurrence relation. -/
theorem closed_form (i : ℕ) : (s i : X q) = (ω : X q) ^ 2 ^ i + (ωb : X q) ^ 2 ^ i :=
  by
  induction' i with i ih
  · dsimp [s, ω, ωb]
    ext <;> · simp <;> rfl
  ·
    calc
      (s (i + 1) : X q) = (s i ^ 2 - 2 : ℤ) := rfl
      _ = (s i : X q) ^ 2 - 2 := by push_cast
      _ = (ω ^ 2 ^ i + ωb ^ 2 ^ i) ^ 2 - 2 := by rw [ih]
      _ = (ω ^ 2 ^ i) ^ 2 + (ωb ^ 2 ^ i) ^ 2 + 2 * (ωb ^ 2 ^ i * ω ^ 2 ^ i) - 2 := by ring
      _ = (ω ^ 2 ^ i) ^ 2 + (ωb ^ 2 ^ i) ^ 2 := by
        rw [← mul_pow ωb ω, ωb_mul_ω, one_pow, mul_one, add_sub_cancel]
      _ = ω ^ 2 ^ (i + 1) + ωb ^ 2 ^ (i + 1) := by rw [← pow_mul, ← pow_mul, pow_succ']

#align lucas_lehmer.X.closed_form LucasLehmer.X.closed_form

end X

open X

/-!
Here and below, we introduce `p' = p - 2`, in order to avoid using subtraction in `ℕ`.
-/

/-- If `1 < p`, then `q p`, the smallest prime factor of `mersenne p`, is more than 2. -/
theorem two_lt_q (p' : ℕ) : 2 < q (p' + 2) :=
  by
  by_contra H
  simp at H
  interval_cases; clear H
  · -- If q = 1, we get a contradiction from 2^p = 2
    dsimp [q] at h
    injection h with h'
    clear h
    simp [mersenne] at h'
    exact
      lt_irrefl 2
        (calc
          2 ≤ p' + 2 := Nat.le_add_left _ _
          _ < 2 ^ (p' + 2) := (Nat.lt_two_pow _)
          _ = 2 := Nat.pred_inj (Nat.one_le_two_pow _) (by decide) h'
          )
  · -- If q = 2, we get a contradiction from 2 ∣ 2^p - 1
    dsimp [q] at h
    injection h with h'
    clear h
    rw [mersenne, PNat.one_coe, Nat.minFac_eq_two_iff, pow_succ] at h'
    exact Nat.two_not_dvd_two_mul_sub_one (Nat.one_le_two_pow _) h'
#align lucas_lehmer.two_lt_q LucasLehmer.two_lt_q

theorem ω_pow_formula (p' : ℕ) (h : lucasLehmerResidue (p' + 2) = 0) :
    ∃ k : ℤ,
      (ω : X (q (p' + 2))) ^ 2 ^ (p' + 1) =
        k * mersenne (p' + 2) * (ω : X (q (p' + 2))) ^ 2 ^ p' - 1 :=
  by
  dsimp [lucas_lehmer_residue] at h
  rw [s_zmod_eq_s p'] at h
  simp [ZMod.int_cast_zmod_eq_zero_iff_dvd] at h
  cases' h with k h
  use k
  replace h := congr_arg (fun n : ℤ => (n : X (q (p' + 2)))) h
  -- coercion from ℤ to X q
  dsimp at h
  rw [closed_form] at h
  replace h := congr_arg (fun x => ω ^ 2 ^ p' * x) h
  dsimp at h
  have t : 2 ^ p' + 2 ^ p' = 2 ^ (p' + 1) := by ring
  rw [mul_add, ← pow_add ω, t, ← mul_pow ω ωb (2 ^ p'), ω_mul_ωb, one_pow] at h
  rw [mul_comm, coe_mul] at h
  rw [mul_comm _ (k : X (q (p' + 2)))] at h
  replace h := eq_sub_of_add_eq h
  have : 1 ≤ 2 ^ (p' + 2) := Nat.one_le_pow _ _ (by decide)
  exact_mod_cast h
#align lucas_lehmer.ω_pow_formula LucasLehmer.ω_pow_formula

/-- `q` is the minimum factor of `mersenne p`, so `M p = 0` in `X q`. -/
theorem mersenne_coe_x (p : ℕ) : (mersenne p : X (q p)) = 0 :=
  by
  ext <;> simp [mersenne, q, ZMod.nat_cast_zmod_eq_zero_iff_dvd, -pow_pos]
  apply Nat.minFac_dvd
#align lucas_lehmer.mersenne_coe_X LucasLehmer.mersenne_coe_x

theorem ω_pow_eq_neg_one (p' : ℕ) (h : lucasLehmerResidue (p' + 2) = 0) :
    (ω : X (q (p' + 2))) ^ 2 ^ (p' + 1) = -1 :=
  by
  cases' ω_pow_formula p' h with k w
  rw [mersenne_coe_X] at w
  simpa using w
#align lucas_lehmer.ω_pow_eq_neg_one LucasLehmer.ω_pow_eq_neg_one

theorem ω_pow_eq_one (p' : ℕ) (h : lucasLehmerResidue (p' + 2) = 0) :
    (ω : X (q (p' + 2))) ^ 2 ^ (p' + 2) = 1 :=
  calc
    (ω : X (q (p' + 2))) ^ 2 ^ (p' + 2) = (ω ^ 2 ^ (p' + 1)) ^ 2 := by rw [← pow_mul, ← pow_succ']
    _ = (-1) ^ 2 := by rw [ω_pow_eq_neg_one p' h]
    _ = 1 := by simp

#align lucas_lehmer.ω_pow_eq_one LucasLehmer.ω_pow_eq_one

/-- `ω` as an element of the group of units. -/
def ωUnit (p : ℕ) : Units (X (q p)) where
  val := ω
  inv := ωb
  val_inv := by simp [ω_mul_ωb]
  inv_val := by simp [ωb_mul_ω]
#align lucas_lehmer.ω_unit LucasLehmer.ωUnit

@[simp]
theorem ωUnit_coe (p : ℕ) : (ωUnit p : X (q p)) = ω :=
  rfl
#align lucas_lehmer.ω_unit_coe LucasLehmer.ωUnit_coe

/-- The order of `ω` in the unit group is exactly `2^p`. -/
theorem order_ω (p' : ℕ) (h : lucasLehmerResidue (p' + 2) = 0) :
    orderOf (ωUnit (p' + 2)) = 2 ^ (p' + 2) :=
  by
  apply Nat.eq_prime_pow_of_dvd_least_prime_pow
  -- the order of ω divides 2^p
  · exact Nat.prime_two
  · intro o
    have ω_pow := orderOf_dvd_iff_pow_eq_one.1 o
    replace ω_pow :=
      congr_arg (Units.coeHom (X (q (p' + 2))) : Units (X (q (p' + 2))) → X (q (p' + 2))) ω_pow
    simp at ω_pow
    have h : (1 : ZMod (q (p' + 2))) = -1 :=
      congr_arg Prod.fst (ω_pow.symm.trans (ω_pow_eq_neg_one p' h))
    haveI : Fact (2 < (q (p' + 2) : ℕ)) := ⟨two_lt_q _⟩
    apply ZMod.neg_one_ne_one h.symm
  · apply orderOf_dvd_iff_pow_eq_one.2
    apply Units.ext
    push_cast
    exact ω_pow_eq_one p' h
#align lucas_lehmer.order_ω LucasLehmer.order_ω

theorem order_ineq (p' : ℕ) (h : lucasLehmerResidue (p' + 2) = 0) :
    2 ^ (p' + 2) < (q (p' + 2) : ℕ) ^ 2 :=
  calc
    2 ^ (p' + 2) = orderOf (ωUnit (p' + 2)) := (order_ω p' h).symm
    _ ≤ Fintype.card (X _)ˣ := orderOf_le_card_univ
    _ < (q (p' + 2) : ℕ) ^ 2 := units_card (Nat.lt_of_succ_lt (two_lt_q _))

#align lucas_lehmer.order_ineq LucasLehmer.order_ineq

end LucasLehmer

export LucasLehmer (LucasLehmerTest lucasLehmerResidue)

open LucasLehmer

theorem lucas_lehmer_sufficiency (p : ℕ) (w : 1 < p) : LucasLehmerTest p → (mersenne p).Prime :=
  by
  let p' := p - 2
  have z : p = p' + 2 := (tsub_eq_iff_eq_add_of_le w.nat_succ_le).mp rfl
  have w : 1 < p' + 2 := Nat.lt_of_sub_eq_succ rfl
  contrapose
  intro a t
  rw [z] at a
  rw [z] at t
  have h₁ := order_ineq p' t
  have h₂ := Nat.minFac_sq_le_self (mersenne_pos (Nat.lt_of_succ_lt w)) a
  have h := lt_of_lt_of_le h₁ h₂
  exact not_lt_of_ge (Nat.sub_le _ _) h
#align lucas_lehmer_sufficiency lucas_lehmer_sufficiency

-- Here we calculate the residue, very inefficiently, using `dec_trivial`. We can do much better.
example : (mersenne 5).Prime :=
  lucas_lehmer_sufficiency 5 (by norm_num) (by decide)

-- Next we use `norm_num` to calculate each `s p i`.
namespace LucasLehmer

open Tactic

theorem sMod_succ {p a i b c} (h1 : (2 ^ p - 1 : ℤ) = a) (h2 : sMod p i = b)
    (h3 : (b * b - 2) % a = c) : sMod p (i + 1) = c :=
  by
  dsimp [s_mod, mersenne]
  rw [h1, h2, sq, h3]
#align lucas_lehmer.s_mod_succ LucasLehmer.sMod_succ

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/-- Given a goal of the form `lucas_lehmer_test p`,
attempt to do the calculation using `norm_num` to certify each step.
-/
unsafe def run_test : tactic Unit := do
  let q(LucasLehmerTest $(p)) ← target
  sorry
  sorry
  let p ← eval_expr ℕ p
  let-- Calculate the candidate Mersenne prime
  M : ℤ := 2 ^ p - 1
  let t ← to_expr ``(2 ^ $(q(p)) - 1 = $(q(M)))
  let v ← to_expr ``((by norm_num : 2 ^ $(q(p)) - 1 = $(q(M))))
  let w ← assertv `w t v
  let t
    ←-- base case
        to_expr
        ``(sMod $(q(p)) 0 = 4)
  let v ← to_expr ``((by norm_num [LucasLehmer.sMod] : sMod $(q(p)) 0 = 4))
  let h ← assertv `h t v
  -- step case, repeated p-2 times
      iterate_exactly
      (p - 2) sorry
  let h
    ←-- now close the goal
        get_local
        `h
  exact h
#align lucas_lehmer.run_test lucas_lehmer.run_test

end LucasLehmer

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic lucas_lehmer.run_test -/
/-- We verify that the tactic works to prove `127.prime`. -/
example : (mersenne 7).Prime :=
  lucas_lehmer_sufficiency _ (by norm_num)
    (by
      run_tac
        lucas_lehmer.run_test)

/-!
This implementation works successfully to prove `(2^127 - 1).prime`,
and all the Mersenne primes up to this point appear in [archive/examples/mersenne_primes.lean].

`(2^127 - 1).prime` takes about 5 minutes to run (depending on your CPU!),
and unfortunately the next Mersenne prime `(2^521 - 1)`,
which was the first "computer era" prime,
is out of reach with the current implementation.

There's still low hanging fruit available to do faster computations
based on the formula
```
n ≡ (n % 2^p) + (n / 2^p) [MOD 2^p - 1]
```
and the fact that `% 2^p` and `/ 2^p` can be very efficient on the binary representation.
Someone should do this, too!
-/

theorem modEq_mersenne (n k : ℕ) : k ≡ k / 2 ^ n + k % 2 ^ n [MOD 2 ^ n - 1] :=
  by
  -- See https://leanprover.zulipchat.com/#narrow/stream/113489-new-members/topic/help.20finding.20a.20lemma/near/177698446
  conv in k => rw [← Nat.div_add_mod k (2 ^ n)]
  refine' Nat.ModEq.add_right _ _
  conv =>
    congr
    skip
    skip
    rw [← one_mul (k / 2 ^ n)]
  exact (Nat.modEq_sub <| Nat.succ_le_of_lt <| pow_pos zero_lt_two _).mul_right _
#align modeq_mersenne modEq_mersenne

-- It's hard to know what the limiting factor for large Mersenne primes would be.
-- In the purely computational world, I think it's the squaring operation in `s`.


import data.list.basic

open list

variables {α : Type*} (x y z : α) (xs ys zs : list α)

def mk_symm (xs : list α) := xs ++ reverse xs

theorem reverse_mk_symm (xs : list α) :
  reverse (mk_symm xs) = mk_symm xs :=
by simp [mk_symm]

section
local attribute [simp] reverse_mk_symm

example (xs ys : list ℕ) :
  reverse (xs ++ mk_symm ys) = mk_symm ys ++ reverse xs :=
by simp

example (xs ys : list ℕ) (p : list ℕ → Prop)
    (h : p (reverse (xs ++ (mk_symm ys)))) :
  p (mk_symm ys ++ reverse xs) :=
by simp at h; assumption

end

run_cmd mk_simp_attr `my_simps

attribute [my_simps] reverse_mk_symm

example (xs ys : list ℕ) :
  reverse (xs ++ mk_symm ys) = mk_symm ys ++ reverse xs :=
by {simp with my_simps}

example (xs ys : list ℕ) (p : list ℕ → Prop)
  (h : p (reverse (xs ++ (mk_symm ys)))) :
    p (mk_symm ys ++ reverse xs) :=
by simp with my_simps at h; assumption


/-
This file defines the boolean XOR constraint on n variables.

Authors: Cayden Codel, Marijn Heule, Jeremy Avigad
Carnegie Mellon University
-/

import basic
import cnf.literal cnf.assignment cnf.clause cnf.cnf cnf.encoding
import parity.explode
import data.list.basic data.finset.basic

universe u

open clause
open nat list
open encoding

-- Represents the type of the variable stored in the literal
variables {V : Type*} [decidable_eq V]

/- An n-variable XOR constraint is a map from a list of bools to an output bool -/
def parity : constraint := λ l, (l.foldr bxor ff)
def parityF : constraint := λ l, (l.foldr bxor tt)

namespace parity

/-! # eval -/
section eval

variables (τ : assignment V) (l l₁ l₂ : list (literal V)) (lit : literal V)

@[simp] theorem eval_nil : parity.eval τ [] = ff := rfl

@[simp] theorem eval_singleton : parity.eval τ [lit] = lit.eval τ :=
by simp only [constraint.eval, parity, map, bool.bxor_ff_right, foldr]

theorem eval_cons : parity.eval τ (lit :: l) = bxor (lit.eval τ) (parity.eval τ l) :=
by simp only [constraint.eval, parity, foldr, foldr_map]

theorem eval_append :
  parity.eval τ (l₁ ++ l₂) = bxor (parity.eval τ l₁) (parity.eval τ l₂) :=
begin
  induction l₁ with l ls ih,
  { simp only [bool.bxor_ff_left, eval_nil, nil_append] },
  { simp only [eval_cons, ih, cons_append, bool.bxor_assoc] }
end

/- Evaluates to true if an odd number of literals evaluates to true -/
theorem eval_eq_bodd_count_tt : parity.eval τ l = bodd (clause.count_tt τ l) :=
begin
  induction l with l ls ih,
  { simp only [bodd_zero, eval_nil, count_tt_nil] },
  { cases h : (l.eval τ); { simp [parity.eval_cons, count_tt_cons, h, ih] } }
end

theorem eval_eq_of_perm {l₁ l₂ : list (literal V)} : l₁ ~ l₂ →
  ∀ (τ : assignment V), parity.eval τ l₁ = parity.eval τ l₂ :=
begin
  intros hp τ,
  induction hp with x l₂ l₂' p IH  x y l₂  l₂ m₂ r₂ p₁ p₂ IH₁ IH₂,
  { refl },
  { simp [eval_cons, IH] },
  { simp [eval_cons, ← bool.bxor_assoc],
    rw bool.bxor_comm (literal.eval τ y) (literal.eval τ x) },
  { exact eq.trans IH₁ IH₂ }
end

open assignment

theorem eval_eq_of_agree_on [decidable_eq V] {τ₁ τ₂ : assignment V} {l : list (literal V)} :
  (agree_on τ₁ τ₂ (clause.vars l)) → parity.eval τ₁ l = parity.eval τ₂ l :=
begin
  induction l with l ls ih,
  { simp only [agree_on_nil, parity.eval_nil, forall_true_left, clause.vars_nil] },
  { intro h,
    simp only [parity.eval_cons],
    rw eval_eq_of_agree_on_of_var_mem h (mem_vars_of_mem (mem_cons_self l ls)),
    rw ih (agree_on_subset (vars_subset_of_vars_cons l ls) h) }
end

end eval

end parity


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov

! This file was ported from Lean 3 source module algebra.big_operators.option
! leanprover-community/mathlib commit 008205aa645b3f194c1da47025c5f110c8406eab
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.BigOperators.Basic
import Mathlib.Data.Finset.Option

/-!
# Lemmas about products and sums over finite sets in `Option α`

In this file we prove formulas for products and sums over `Finset.insertNone s` and
`Finset.eraseNone s`.
-/

open BigOperators

open Function

namespace Finset

variable {α M : Type _} [CommMonoid M]

@[to_additive (attr := simp)]
theorem prod_insertNone (f : Option α → M) (s : Finset α) :
    (∏ x in insertNone s, f x) = f none * ∏ x in s, f (some x) := by simp [insertNone]
#align finset.prod_insert_none Finset.prod_insertNone
#align finset.sum_insert_none Finset.sum_insertNone

@[to_additive]
theorem prod_eraseNone (f : α → M) (s : Finset (Option α)) :
    (∏ x in eraseNone s, f x) = ∏ x in s, Option.elim' 1 f x := by
  classical calc
      (∏ x in eraseNone s, f x) = ∏ x in (eraseNone s).map Embedding.some, Option.elim' 1 f x :=
        (prod_map (eraseNone s) Embedding.some <| Option.elim' 1 f).symm
      _ = ∏ x in s.erase none, Option.elim' 1 f x := by rw [map_some_eraseNone]
      _ = ∏ x in s, Option.elim' 1 f x := prod_erase _ rfl
#align finset.prod_erase_none Finset.prod_eraseNone
#align finset.sum_erase_none Finset.sum_eraseNone

end Finset


-- Pij means pigeon i is in pigeonhole j
variables P11 P12 P21 P22 P31 P32 : Prop

/- I have to prove that: if there are three pigeons and two pigeonholes
(and each pigeon are in a pigeonhole), there will be at least two pigeons
in the same pigeonhole:
(P11 ∨ P12) ∧ (P21 ∨ P22) ∧ (P31 ∨ P32) →
((P11 ∧ P21) ∨ (P11 ∧ P31) ∨ (P21 ∧ P31)) ∨
((P12 ∧ P22) ∨ (P12 ∧ P32) ∨ (P22 ∧ P32))
The whole exercise consists in dealing with or eliminations of the three or
statements in a chain. Example: I will assume P11, and I will have to deal with
P21 ∨ P22. But later I will assume P12, and I will also have to deal with P21 ∨ P22.
And for each P21 and P22 etc.-/

lemma fifth_or_elim {P11 P12 P21 P22 P31 P32 : Prop}
(h3 : P12) (h5 : P21) (h6 : P31 ∨ P32) :
((P11 ∧ P21) ∨ (P11 ∧ P31) ∨ (P21 ∧ P31)) ∨
((P12 ∧ P22) ∨ (P12 ∧ P32) ∨ (P22 ∧ P32)) :=
    or.elim h6
        (assume h7 : P31,
        or.inl (or.inr (or.inr (and.intro h5 h7))))
        (assume h7 : P32,
        or.inr (or.inr (or.inl (and.intro h3 h7))))

lemma fourth_or_elim {P11 P12 P21 P22 P31 P32 : Prop}
(h1 : (P11 ∨ P12) ∧ (P21 ∨ P22) ∧ (P31 ∨ P32)) (h3 : P12) (h4 : P21 ∨ P22) :
((P11 ∧ P21) ∨ (P11 ∧ P31) ∨ (P21 ∧ P31)) ∨
((P12 ∧ P22) ∨ (P12 ∧ P32) ∨ (P22 ∧ P32)) :=
    or.elim h4
    (assume h5 : P21,
    have h6 : P31 ∨ P32, from and.right (and.right h1),
    fifth_or_elim h3 h5 h6)
    (assume h5 : P22,
    or.inr (or.inl (and.intro h3 h5)))

lemma third_or_elim {P11 P12 P21 P22 P31 P32 : Prop}
(h3 : P11) (h5 : P22) (h6 : P31 ∨ P32) :
((P11 ∧ P21) ∨ (P11 ∧ P31) ∨ (P21 ∧ P31)) ∨
((P12 ∧ P22) ∨ (P12 ∧ P32) ∨ (P22 ∧ P32)) :=
    or.elim h6
        (assume h7 : P31,
        or.inl (or.inr (or.inl (and.intro h3 h7))))
        (assume h7 : P32,
        or.inr (or.inr (or.inr (and.intro h5 h7))))

lemma second_or_elim {P11 P12 P21 P22 P31 P32 : Prop}
(h1 : (P11 ∨ P12) ∧ (P21 ∨ P22) ∧ (P31 ∨ P32)) (h3 : P11) (h4 : P21 ∨ P22) :
((P11 ∧ P21) ∨ (P11 ∧ P31) ∨ (P21 ∧ P31)) ∨
((P12 ∧ P22) ∨ (P12 ∧ P32) ∨ (P22 ∧ P32)) :=
    or.elim h4
        (assume h5 : P21,
        have h6 : P31 ∨ P32, from and.right (and.right h1),
        or.inl (or.inl (and.intro h3 h5)))
        (assume h5 : P22,
        have h6 : P31 ∨ P32, from and.right (and.right h1),
        third_or_elim h3 h5 h6)

lemma first_or_elim {P11 P12 P21 P22 P31 P32 : Prop}
(h1 : (P11 ∨ P12) ∧ (P21 ∨ P22) ∧ (P31 ∨ P32)) (h2 : P11 ∨ P12) :
((P11 ∧ P21) ∨ (P11 ∧ P31) ∨ (P21 ∧ P31)) ∨
((P12 ∧ P22) ∨ (P12 ∧ P32) ∨ (P22 ∧ P32)) :=
    or.elim h2
        (assume h3 : P11,
        have h4 : P21 ∨ P22, from and.left (and.right h1),
        second_or_elim h1 h3 h4)
        (assume h3 : P12,
        have h4 : P21 ∨ P22, from and.left (and.right h1),
        fourth_or_elim h1 h3 h4)

theorem PHP3 : (P11 ∨ P12) ∧ (P21 ∨ P22) ∧ (P31 ∨ P32) →
((P11 ∧ P21) ∨ (P11 ∧ P31) ∨ (P21 ∧ P31)) ∨
((P12 ∧ P22) ∨ (P12 ∧ P32) ∨ (P22 ∧ P32)) :=
    assume h1 : (P11 ∨ P12) ∧ (P21 ∨ P22) ∧ (P31 ∨ P32),
    have h2 : P11 ∨ P12, from and.left h1,
    first_or_elim h1 h2


/-
Copyright (c) 2019 Minchao Wu. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Minchao Wu, Chris Hughes, Mantas Bakšys

! This file was ported from Lean 3 source module data.list.min_max
! leanprover-community/mathlib commit 6d0adfa76594f304b4650d098273d4366edeb61b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.List.Basic

/-!
# Minimum and maximum of lists

## Main definitions

The main definitions are `argmax`, `argmin`, `minimum` and `maximum` for lists.

`argmax f l` returns `some a`, where `a` of `l` that maximises `f a`. If there are `a b` such that
  `f a = f b`, it returns whichever of `a` or `b` comes first in the list.
  `argmax f []` = none`

`minimum l` returns an `WithTop α`, the smallest element of `l` for nonempty lists, and `⊤` for
`[]`
-/

namespace List

variable {α β : Type _}

section ArgAux

variable (r : α → α → Prop) [DecidableRel r] {l : List α} {o : Option α} {a m : α}

/-- Auxiliary definition for `argmax` and `argmin`. -/
def argAux (a : Option α) (b : α) : Option α :=
  Option.casesOn a (some b) fun c => if r b c then some b else some c
#align list.arg_aux List.argAux

@[simp]
theorem foldl_argAux_eq_none : l.foldl (argAux r) o = none ↔ l = [] ∧ o = none :=
  List.reverseRecOn l (by simp) fun tl hd => by
    simp [argAux]; cases foldl (argAux r) o tl <;> simp; try split_ifs <;> simp
#align list.foldl_arg_aux_eq_none List.foldl_argAux_eq_none

private theorem foldl_argAux_mem (l) : ∀ a m : α, m ∈ foldl (argAux r) (some a) l → m ∈ a :: l :=
  List.reverseRecOn l (by simp [eq_comm])
    (by
      intro tl hd ih a m
      simp only [foldl_append, foldl_cons, foldl_nil, argAux]
      cases hf : foldl (argAux r) (some a) tl
      · simp (config := { contextual := true })
      · dsimp only
        split_ifs
        · simp (config := { contextual := true })
        · -- `finish [ih _ _ hf]` closes this goal
          simp only [List.mem_cons] at ih
          rcases ih _ _ hf with rfl | H
          · simp (config := { contextual := true }) only [Option.mem_def, Option.some.injEq,
              find?, eq_comm, mem_cons, mem_append, mem_singleton, true_or, implies_true]
          · simp (config := { contextual := true }) [@eq_comm _ _ m, H])

@[simp]
theorem argAux_self (hr₀ : Irreflexive r) (a : α) : argAux r (some a) a = a :=
  if_neg <| hr₀ _
#align list.arg_aux_self List.argAux_self

theorem not_of_mem_foldl_argAux (hr₀ : Irreflexive r) (hr₁ : Transitive r) :
    ∀ {a m : α} {o : Option α}, a ∈ l → m ∈ foldl (argAux r) o l → ¬r a m := by
  induction' l using List.reverseRecOn with tl a ih
  · simp
  intro b m o hb ho
  rw [foldl_append, foldl_cons, foldl_nil, argAux] at ho
  cases' hf : foldl (argAux r) o tl with c
  · rw [hf] at ho
    rw [foldl_argAux_eq_none] at hf
    simp_all [hf.1, hf.2, hr₀ _]
  rw [hf, Option.mem_def] at ho
  dsimp only at ho
  split_ifs at ho with hac <;> cases' mem_append.1 hb with h h <;>
    injection ho with ho <;> subst ho
  · exact fun hba => ih h hf (hr₁ hba hac)
  · simp_all [hr₀ _]
  · exact ih h hf
  · simp_all
#align list.not_of_mem_foldl_arg_aux List.not_of_mem_foldl_argAux

end ArgAux

section Preorder

variable [Preorder β] [@DecidableRel β (· < ·)] {f : α → β} {l : List α} {o : Option α} {a m : α}

/-- `argmax f l` returns `some a`, where `f a` is maximal among the elements of `l`, in the sense
that there is no `b ∈ l` with `f a < f b`. If `a`, `b` are such that `f a = f b`, it returns
whichever of `a` or `b` comes first in the list. `argmax f []` = none`. -/
def argmax (f : α → β) (l : List α) : Option α :=
  l.foldl (argAux fun b c => f c < f b) none
#align list.argmax List.argmax

/-- `argmin f l` returns `some a`, where `f a` is minimal among the elements of `l`, in the sense
that there is no `b ∈ l` with `f b < f a`. If `a`, `b` are such that `f a = f b`, it returns
whichever of `a` or `b` comes first in the list. `argmin f []` = none`. -/
def argmin (f : α → β) (l : List α) :=
  l.foldl (argAux fun b c => f b < f c) none
#align list.argmin List.argmin

@[simp]
theorem argmax_nil (f : α → β) : argmax f [] = none :=
  rfl
#align list.argmax_nil List.argmax_nil

@[simp]
theorem argmin_nil (f : α → β) : argmin f [] = none :=
  rfl
#align list.argmin_nil List.argmin_nil

@[simp]
theorem argmax_singleton {f : α → β} {a : α} : argmax f [a] = a :=
  rfl
#align list.argmax_singleton List.argmax_singleton

@[simp]
theorem argmin_singleton {f : α → β} {a : α} : argmin f [a] = a :=
  rfl
#align list.argmin_singleton List.argmin_singleton

theorem not_lt_of_mem_argmax : a ∈ l → m ∈ argmax f l → ¬f m < f a :=
  not_of_mem_foldl_argAux _ (fun x h => lt_irrefl (f x) h)
    (fun _ _ z hxy hyz => lt_trans (a := f z) hyz hxy)
#align list.not_lt_of_mem_argmax List.not_lt_of_mem_argmax

theorem not_lt_of_mem_argmin : a ∈ l → m ∈ argmin f l → ¬f a < f m :=
  not_of_mem_foldl_argAux _ (fun x h => lt_irrefl (f x) h)
    (fun x _ _ hxy hyz => lt_trans (a := f x) hxy hyz)
#align list.not_lt_of_mem_argmin List.not_lt_of_mem_argmin

theorem argmax_concat (f : α → β) (a : α) (l : List α) :
    argmax f (l ++ [a]) =
      Option.casesOn (argmax f l) (some a) fun c => if f c < f a then some a else some c :=
  by rw [argmax, argmax]; simp [argAux]
#align list.argmax_concat List.argmax_concat

theorem argmin_concat (f : α → β) (a : α) (l : List α) :
    argmin f (l ++ [a]) =
      Option.casesOn (argmin f l) (some a) fun c => if f a < f c then some a else some c :=
  @argmax_concat _ βᵒᵈ _ _ _ _ _
#align list.argmin_concat List.argmin_concat

theorem argmax_mem : ∀ {l : List α} {m : α}, m ∈ argmax f l → m ∈ l
  | [], m => by simp
  | hd :: tl, m => by simpa [argmax, argAux] using foldl_argAux_mem _ tl hd m
#align list.argmax_mem List.argmax_mem

theorem argmin_mem : ∀ {l : List α} {m : α}, m ∈ argmin f l → m ∈ l :=
  @argmax_mem _ βᵒᵈ _ _ _
#align list.argmin_mem List.argmin_mem

@[simp]
theorem argmax_eq_none : l.argmax f = none ↔ l = [] := by simp [argmax]
#align list.argmax_eq_none List.argmax_eq_none

@[simp]
theorem argmin_eq_none : l.argmin f = none ↔ l = [] :=
  @argmax_eq_none _ βᵒᵈ _ _ _ _
#align list.argmin_eq_none List.argmin_eq_none

end Preorder

section LinearOrder

variable [LinearOrder β] {f : α → β} {l : List α} {o : Option α} {a m : α}

theorem le_of_mem_argmax : a ∈ l → m ∈ argmax f l → f a ≤ f m := fun ha hm =>
  le_of_not_lt <| not_lt_of_mem_argmax ha hm
#align list.le_of_mem_argmax List.le_of_mem_argmax

theorem le_of_mem_argmin : a ∈ l → m ∈ argmin f l → f m ≤ f a :=
  @le_of_mem_argmax _ βᵒᵈ _ _ _ _ _
#align list.le_of_mem_argmin List.le_of_mem_argmin

theorem argmax_cons (f : α → β) (a : α) (l : List α) :
    argmax f (a :: l) =
      Option.casesOn (argmax f l) (some a) fun c => if f a < f c then some c else some a :=
  List.reverseRecOn l rfl fun hd tl ih => by
    rw [← cons_append, argmax_concat, ih, argmax_concat]
    cases' h : argmax f hd with m
    · simp [h]
    dsimp
    rw [← apply_ite, ← apply_ite]
    dsimp
    split_ifs <;> try rfl
    · exact absurd (lt_trans ‹f a < f m› ‹_›) ‹_›
    · cases (‹f a < f tl›.lt_or_lt _).elim ‹_› ‹_›
#align list.argmax_cons List.argmax_cons

theorem argmin_cons (f : α → β) (a : α) (l : List α) :
    argmin f (a :: l) =
      Option.casesOn (argmin f l) (some a) fun c => if f c < f a then some c else some a :=
  @argmax_cons α βᵒᵈ _ _ _ _
#align list.argmin_cons List.argmin_cons

variable [DecidableEq α]

theorem index_of_argmax :
    ∀ {l : List α} {m : α}, m ∈ argmax f l → ∀ {a}, a ∈ l → f m ≤ f a → l.indexOf m ≤ l.indexOf a
  | [], m, _, _, _, _ => by simp
  | hd :: tl, m, hm, a, ha, ham => by
    simp only [indexOf_cons, argmax_cons, Option.mem_def] at hm⊢
    cases h : argmax f tl
    · rw [h] at hm
      simp_all
    rw [h] at hm
    dsimp only at hm
    obtain ha | ha := ha <;> split_ifs at hm <;> injection hm with hm <;> subst hm
    · cases not_le_of_lt ‹_› ‹_›
    · rw [if_pos rfl]
    . rw [if_neg, if_neg]
      exact Nat.succ_le_succ (index_of_argmax h (by assumption) ham)
      · exact ne_of_apply_ne f (lt_of_lt_of_le ‹_› ‹_›).ne'
      · exact ne_of_apply_ne _ ‹f hd < f _›.ne'
    . rw [if_pos rfl]
      exact Nat.zero_le _
#align list.index_of_argmax List.index_of_argmax

theorem index_of_argmin :
    ∀ {l : List α} {m : α}, m ∈ argmin f l → ∀ {a}, a ∈ l → f a ≤ f m → l.indexOf m ≤ l.indexOf a :=
  @index_of_argmax _ βᵒᵈ _ _ _
#align list.index_of_argmin List.index_of_argmin

theorem mem_argmax_iff :
    m ∈ argmax f l ↔
      m ∈ l ∧ (∀ a ∈ l, f a ≤ f m) ∧ ∀ a ∈ l, f m ≤ f a → l.indexOf m ≤ l.indexOf a :=
  ⟨fun hm => ⟨argmax_mem hm, fun a ha => le_of_mem_argmax ha hm, fun _ => index_of_argmax hm⟩,
    by
    rintro ⟨hml, ham, hma⟩
    cases' harg : argmax f l with n
    · simp_all
    · have :=
        _root_.le_antisymm (hma n (argmax_mem harg) (le_of_mem_argmax hml harg))
          (index_of_argmax harg hml (ham _ (argmax_mem harg)))
      rw [(indexOf_inj hml (argmax_mem harg)).1 this, Option.mem_def]⟩
#align list.mem_argmax_iff List.mem_argmax_iff

theorem argmax_eq_some_iff :
    argmax f l = some m ↔
      m ∈ l ∧ (∀ a ∈ l, f a ≤ f m) ∧ ∀ a ∈ l, f m ≤ f a → l.indexOf m ≤ l.indexOf a :=
  mem_argmax_iff
#align list.argmax_eq_some_iff List.argmax_eq_some_iff

theorem mem_argmin_iff :
    m ∈ argmin f l ↔
      m ∈ l ∧ (∀ a ∈ l, f m ≤ f a) ∧ ∀ a ∈ l, f a ≤ f m → l.indexOf m ≤ l.indexOf a :=
  @mem_argmax_iff _ βᵒᵈ _ _ _ _ _
#align list.mem_argmin_iff List.mem_argmin_iff

theorem argmin_eq_some_iff :
    argmin f l = some m ↔
      m ∈ l ∧ (∀ a ∈ l, f m ≤ f a) ∧ ∀ a ∈ l, f a ≤ f m → l.indexOf m ≤ l.indexOf a :=
  mem_argmin_iff
#align list.argmin_eq_some_iff List.argmin_eq_some_iff

end LinearOrder

section MaximumMinimum

section Preorder

variable [Preorder α] [@DecidableRel α (· < ·)] {l : List α} {a m : α}

/-- `maximum l` returns an `WithBot α`, the largest element of `l` for nonempty lists, and `⊥` for
`[]`  -/
def maximum (l : List α) : WithBot α :=
  argmax id l
#align list.maximum List.maximum

/-- `minimum l` returns an `WithTop α`, the smallest element of `l` for nonempty lists, and `⊤` for
`[]`  -/
def minimum (l : List α) : WithTop α :=
  argmin id l
#align list.minimum List.minimum

@[simp]
theorem maximum_nil : maximum ([] : List α) = ⊥ :=
  rfl
#align list.maximum_nil List.maximum_nil

@[simp]
theorem minimum_nil : minimum ([] : List α) = ⊤ :=
  rfl
#align list.minimum_nil List.minimum_nil

@[simp]
theorem maximum_singleton (a : α) : maximum [a] = a :=
  rfl
#align list.maximum_singleton List.maximum_singleton

@[simp]
theorem minimum_singleton (a : α) : minimum [a] = a :=
  rfl
#align list.minimum_singleton List.minimum_singleton

theorem maximum_mem {l : List α} {m : α} : (maximum l : WithTop α) = m → m ∈ l :=
  argmax_mem
#align list.maximum_mem List.maximum_mem

theorem minimum_mem {l : List α} {m : α} : (minimum l : WithBot α) = m → m ∈ l :=
  argmin_mem
#align list.minimum_mem List.minimum_mem

@[simp]
theorem maximum_eq_none {l : List α} : l.maximum = none ↔ l = [] :=
  argmax_eq_none
#align list.maximum_eq_none List.maximum_eq_none

@[simp]
theorem minimum_eq_none {l : List α} : l.minimum = none ↔ l = [] :=
  argmin_eq_none
#align list.minimum_eq_none List.minimum_eq_none

theorem not_lt_maximum_of_mem : a ∈ l → (maximum l : WithBot α) = m → ¬m < a :=
  not_lt_of_mem_argmax
#align list.not_lt_maximum_of_mem List.not_lt_maximum_of_mem

theorem not_lt_maximum_of_mem' (ha : a ∈ l) : ¬maximum l < (a : WithBot α) := by
  cases h : l.maximum
  · simp_all
  · simp [WithBot.some_eq_coe, WithBot.coe_lt_coe, not_lt_maximum_of_mem ha h, not_false_iff]
#align list.not_lt_maximum_of_mem' List.not_lt_maximum_of_mem'

theorem not_lt_minimum_of_mem' (ha : a ∈ l) : ¬(a : WithTop α) < minimum l :=
  @not_lt_maximum_of_mem' αᵒᵈ _ _ _ _ ha
#align list.not_lt_minimum_of_mem' List.not_lt_minimum_of_mem'

end Preorder

section LinearOrder

variable [LinearOrder α] {l : List α} {a m : α}

theorem maximum_concat (a : α) (l : List α) : maximum (l ++ [a]) = max (maximum l) a := by
  simp only [maximum, argmax_concat, id]
  cases h : argmax id l
  · exact (max_eq_right bot_le).symm
  · simp [WithBot.some_eq_coe, max_def_lt, WithBot.coe_lt_coe]
#align list.maximum_concat List.maximum_concat

theorem le_maximum_of_mem : a ∈ l → (maximum l : WithBot α) = m → a ≤ m :=
  le_of_mem_argmax
#align list.le_maximum_of_mem List.le_maximum_of_mem

theorem minimum_le_of_mem : a ∈ l → (minimum l : WithTop α) = m → m ≤ a :=
  le_of_mem_argmin
#align list.minimum_le_of_mem List.minimum_le_of_mem

theorem le_maximum_of_mem' (ha : a ∈ l) : (a : WithBot α) ≤ maximum l :=
  le_of_not_lt <| not_lt_maximum_of_mem' ha
#align list.le_maximum_of_mem' List.le_maximum_of_mem'

theorem le_minimum_of_mem' (ha : a ∈ l) : minimum l ≤ (a : WithTop α) :=
  @le_maximum_of_mem' αᵒᵈ _ _ _ ha
#align list.le_minimum_of_mem' List.le_minimum_of_mem'

theorem minimum_concat (a : α) (l : List α) : minimum (l ++ [a]) = min (minimum l) a :=
  @maximum_concat αᵒᵈ _ _ _
#align list.minimum_concat List.minimum_concat

theorem maximum_cons (a : α) (l : List α) : maximum (a :: l) = max ↑a (maximum l) :=
  List.reverseRecOn l (by simp [@max_eq_left (WithBot α) _ _ _ bot_le]) fun tl hd ih => by
    rw [← cons_append, maximum_concat, ih, maximum_concat, max_assoc]
#align list.maximum_cons List.maximum_cons

theorem minimum_cons (a : α) (l : List α) : minimum (a :: l) = min ↑a (minimum l) :=
  @maximum_cons αᵒᵈ _ _ _
#align list.minimum_cons List.minimum_cons

theorem maximum_eq_coe_iff : maximum l = m ↔ m ∈ l ∧ ∀ a ∈ l, a ≤ m := by
  rw [maximum, ← WithBot.some_eq_coe, argmax_eq_some_iff]
  simp only [id_eq, and_congr_right_iff, and_iff_left_iff_imp]
  intro _ h a hal hma
  rw [_root_.le_antisymm hma (h a hal)]
#align list.maximum_eq_coe_iff List.maximum_eq_coe_iff

theorem minimum_eq_coe_iff : minimum l = m ↔ m ∈ l ∧ ∀ a ∈ l, m ≤ a :=
  @maximum_eq_coe_iff αᵒᵈ _ _ _
#align list.minimum_eq_coe_iff List.minimum_eq_coe_iff

end LinearOrder

end MaximumMinimum

section Fold

variable [LinearOrder α]

section OrderBot

variable [OrderBot α] {l : List α}

@[simp]
theorem foldr_max_of_ne_nil (h : l ≠ []) : ↑(l.foldr max ⊥) = l.maximum := by
  induction' l with hd tl IH
  · contradiction
  · rw [maximum_cons, foldr, WithBot.coe_max]
    by_cases h : tl = []
    · simp [h]
    · simp [IH h]
#align list.foldr_max_of_ne_nil List.foldr_max_of_ne_nil

theorem max_le_of_forall_le (l : List α) (a : α) (h : ∀ x ∈ l, x ≤ a) : l.foldr max ⊥ ≤ a := by
  induction' l with y l IH
  · simp
  · simpa [h y (mem_cons_self _ _)] using IH fun x hx => h x <| mem_cons_of_mem _ hx
#align list.max_le_of_forall_le List.max_le_of_forall_le

theorem le_max_of_le {l : List α} {a x : α} (hx : x ∈ l) (h : a ≤ x) : a ≤ l.foldr max ⊥ := by
  induction' l with y l IH
  · exact absurd hx (not_mem_nil _)
  · obtain hl | hl := hx
    simp only [foldr, foldr_cons]
    · exact le_max_of_le_left h
    · exact le_max_of_le_right (IH (by assumption))
#align list.le_max_of_le List.le_max_of_le

end OrderBot

section OrderTop

variable [OrderTop α] {l : List α}

@[simp]
theorem foldr_min_of_ne_nil (h : l ≠ []) : ↑(l.foldr min ⊤) = l.minimum :=
  @foldr_max_of_ne_nil αᵒᵈ _ _ _ h
#align list.foldr_min_of_ne_nil List.foldr_min_of_ne_nil

theorem le_min_of_forall_le (l : List α) (a : α) (h : ∀ x ∈ l, a ≤ x) : a ≤ l.foldr min ⊤ :=
  @max_le_of_forall_le αᵒᵈ _ _ _ _ h
#align list.le_min_of_forall_le List.le_min_of_forall_le

theorem min_le_of_le (l : List α) (a : α) {x : α} (hx : x ∈ l) (h : x ≤ a) : l.foldr min ⊤ ≤ a :=
  @le_max_of_le αᵒᵈ _ _ _ _ _ hx h
#align list.min_le_of_le List.min_le_of_le

end OrderTop

end Fold

end List


import tactic.finish

import .transfer

-- EXAMPLE 1: transfering ordering <= from nat to custom nat (bijection)
-- this example is based on the one in the article by Zimmermann and Herbelin, 2015
namespace example1

-- a custom type N that is the natural numbers, with an ordering like <=
def N : Type := sorry
def ordern : N → N → Prop := sorry

-- functions mapping N to nat and back
def nto : N → nat := sorry
def nof : nat → N := sorry

axiom nto_surj : function.surjective nto
axiom nof_surj : function.surjective nof
axiom le_ordern_nof : ∀ m n : nat, m <= n → ordern (nof m) (nof n)
axiom ordern_nof_le : ∀ m n : nat, ordern (nof m) (nof n) → m <= n

--suppose we have proven transitivity for <= in nat, and want to now prove it in N without doing the proof again
theorem transitiveorder_nat : ∀ x y z : nat, x <= y → y <= z → x <= z := sorry

theorem transitiveorder_N : ∀ x y z : N, ordern x y → ordern y z → ordern x z :=
begin
  transfer.transfer1 ``(nof_surj) [``(ordern_nof_le _ _)] [``(le_ordern_nof), ``(transitiveorder_nat)],
end

--we could also prove it the other way, the proof is symmetric: using ax1 instead of ax2 and swapping ax3 and ax4
theorem transitiveorder_nat' : ∀ x y z : nat, x <= y → y <= z → x <= z :=
begin
  transfer.transfer1 ``(nof_surj) [``(ordern_nof_le _ _)] [``(le_ordern_nof), ``(transitiveorder_nat)],
  -- ! exact same command
end

end example1

-- EXAMPLE 2: transfer the theorem that odd+odd=even from z to z mod 2 and back.
namespace example2

definition even (n : int) : Prop := n % 2 = 0

-- a custom type Z/2Z, with operation add and predicate even
inductive Z2 : Type
| zero : Z2
| one : Z2

open Z2

def Z2.add : Z2 → Z2 → Z2
| zero y := y
| one zero := one
| one one := zero

inductive Z2.even : Z2 → Prop
| zeroiseven : Z2.even zero

-- mapping from int to Z2 (no inverse mapping)
def ztoz2 : int → Z2 := λ n, if n % 2 = 0 then zero else one

-- axioms needed for transfer:
axiom surjectivemap : function.surjective ztoz2
-- axiom transfer_add : ∀ m n : int, (ztoz2 m).add (ztoz2 n) = ztoz2(m + n)
axiom transfer_add' : ∀ m n : int, ztoz2(m + n) = (ztoz2 m).add (ztoz2 n)
axiom eventoz2 : ∀ n : int, even n → Z2.even (ztoz2 n)
axiom evenfromz2 : ∀ n : int, Z2.even (ztoz2 n) → even n  -- specific wording of the axioms makes the proof go nicely

-- theorem about adding two odd integers, now we want the same result in Z2
theorem thetheoremforint : ∀ m n : int, ¬ even m → ¬ even n → even (m + n) := sorry

theorem thetheoremforZ2 : ∀ x y : Z2, ¬ Z2.even x → ¬ Z2.even y → Z2.even (Z2.add x y) :=
begin
  transfer.transfer1 ``(surjectivemap) [``(transfer_add'), ``(eventoz2)] [``(thetheoremforint), ``(eventoz2)],
end

-- the other direction can also be shown
theorem thetheoremforint' : ∀ x y : int, ¬ even x → ¬ even y → even (x + y) :=
begin
    transfer.transfer1 ``(surjectivemap) [``(transfer_add'), ``(eventoz2)] [``(thetheoremforint), ``(eventoz2)],
end

end example2

-- EXAMPLE 3: even theorem but with injection natural numbers to integers
namespace example3

definition even (n : nat) : Prop := n % 2 = 0
definition evenint (x : int) : Prop := x % 2 = 0

-- mapping between nat and int
def ntoi : nat → int := int.of_nat
def nofi : int → nat := int.nat_abs

-- axioms needed for transfer:
-- axiom inverse1way : ∀ n : nat, nofi(ntoi n) = n
axiom nofi_surj : function.surjective nofi
axiom transfer_add : ∀ x y : int, nofi x + nofi y = nofi (x + y)
axiom eventoint: ∀ x : int, even (nofi x) → evenint x
axiom evenfromint : ∀ x : int, evenint x → even (nofi x)

theorem thetheoremfornat : ∀ m n : nat, ¬ even m → ¬ even n → even (m + n) := sorry

theorem thetheoremforint : ∀ x y : int, ¬ evenint x → ¬ evenint y → evenint (x + y) :=
begin
  transfer.transfer1 ``(nofi_surj) [``(eventoint), ``(transfer_add)] [``(thetheoremfornat), ``(eventoint)]
end

theorem thetheoremfornat' : ∀ m n : nat, ¬ even m → ¬ even n → even (m + n) :=
begin
  transfer.transfer1 ``(nofi_surj) [``(eventoint), ``(transfer_add)] [``(thetheoremfornat), ``(eventoint)]
end

end example3


/-
Copyright (c) 2021 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel, Yaël Dillies
-/
import analysis.normed.group.basic
import topology.metric_space.hausdorff_distance

/-!
# Properties of pointwise addition of sets in normed groups

We explore the relationships between pointwise addition of sets in normed groups, and the norm.
Notably, we show that the sum of bounded sets remain bounded.
-/

open metric set
open_locale pointwise topology

variables {E : Type*}

section seminormed_group
variables [seminormed_group E] {ε δ : ℝ} {s t : set E} {x y : E}

@[to_additive] lemma metric.bounded.mul (hs : bounded s) (ht : bounded t) : bounded (s * t) :=
begin
  obtain ⟨Rs, hRs⟩ : ∃ R, ∀ x ∈ s, ‖x‖ ≤ R := hs.exists_norm_le',
  obtain ⟨Rt, hRt⟩ : ∃ R, ∀ x ∈ t, ‖x‖ ≤ R := ht.exists_norm_le',
  refine bounded_iff_forall_norm_le'.2 ⟨Rs + Rt, _⟩,
  rintro z ⟨x, y, hx, hy, rfl⟩,
  exact norm_mul_le_of_le (hRs x hx) (hRt y hy),
end

@[to_additive] lemma metric.bounded.inv : bounded s → bounded s⁻¹ :=
by { simp_rw [bounded_iff_forall_norm_le', ←image_inv, ball_image_iff, norm_inv'], exact id }

@[to_additive] lemma metric.bounded.div (hs : bounded s) (ht : bounded t) : bounded (s / t) :=
(div_eq_mul_inv _ _).symm.subst $ hs.mul ht.inv

end seminormed_group

section seminormed_comm_group
variables [seminormed_comm_group E] {ε δ : ℝ} {s t : set E} {x y : E}

section emetric
open emetric

@[to_additive]
lemma inf_edist_inv (x : E) (s : set E) : inf_edist x⁻¹ s = inf_edist x s⁻¹ :=
eq_of_forall_le_iff $ λ r, by simp_rw [le_inf_edist, ←image_inv, ball_image_iff, edist_inv]

@[simp, to_additive]
lemma inf_edist_inv_inv (x : E) (s : set E) : inf_edist x⁻¹ s⁻¹ = inf_edist x s :=
by rw [inf_edist_inv, inv_inv]

end emetric

variables (ε δ s t x y)

@[simp, to_additive] lemma inv_thickening : (thickening δ s)⁻¹ = thickening δ s⁻¹ :=
by { simp_rw [thickening, ←inf_edist_inv], refl }

@[simp, to_additive] lemma inv_cthickening : (cthickening δ s)⁻¹ = cthickening δ s⁻¹ :=
by { simp_rw [cthickening, ←inf_edist_inv], refl }

@[simp, to_additive] lemma inv_ball : (ball x δ)⁻¹ = ball x⁻¹ δ :=
by { simp_rw [ball, ←dist_inv], refl }

@[simp, to_additive] lemma inv_closed_ball : (closed_ball x δ)⁻¹ = closed_ball x⁻¹ δ :=
by { simp_rw [closed_ball, ←dist_inv], refl }

@[to_additive] lemma singleton_mul_ball : {x} * ball y δ = ball (x * y) δ :=
by simp only [preimage_mul_ball, image_mul_left, singleton_mul, div_inv_eq_mul, mul_comm y x]

@[to_additive] lemma singleton_div_ball : {x} / ball y δ = ball (x / y) δ :=
by simp_rw [div_eq_mul_inv, inv_ball, singleton_mul_ball]

@[to_additive] lemma ball_mul_singleton : ball x δ * {y} = ball (x * y) δ :=
by rw [mul_comm, singleton_mul_ball, mul_comm y]

@[to_additive] lemma ball_div_singleton : ball x δ / {y} = ball (x / y) δ :=
by simp_rw [div_eq_mul_inv, inv_singleton, ball_mul_singleton]

@[to_additive] lemma singleton_mul_ball_one : {x} * ball 1 δ = ball x δ := by simp

@[to_additive] lemma singleton_div_ball_one : {x} / ball 1 δ = ball x δ :=
by simp [singleton_div_ball]

@[to_additive] lemma ball_one_mul_singleton : ball 1 δ * {x} = ball x δ :=
by simp [ball_mul_singleton]

@[to_additive] lemma ball_one_div_singleton : ball 1 δ / {x} = ball x⁻¹ δ :=
by simp [ball_div_singleton]

@[to_additive] lemma smul_ball_one : x • ball 1 δ = ball x δ :=
by { ext, simp [mem_smul_set_iff_inv_smul_mem, inv_mul_eq_div, dist_eq_norm_div] }

@[simp, to_additive]
lemma singleton_mul_closed_ball : {x} * closed_ball y δ = closed_ball (x * y) δ :=
by simp only [mul_comm y x, preimage_mul_closed_ball, image_mul_left, singleton_mul, div_inv_eq_mul]

@[simp, to_additive]
lemma singleton_div_closed_ball : {x} / closed_ball y δ = closed_ball (x / y) δ :=
by simp_rw [div_eq_mul_inv, inv_closed_ball, singleton_mul_closed_ball]

@[simp, to_additive]
lemma closed_ball_mul_singleton : closed_ball x δ * {y} = closed_ball (x * y) δ :=
by simp [mul_comm _ {y}, mul_comm y]

@[simp, to_additive]
lemma closed_ball_div_singleton : closed_ball x δ / {y} = closed_ball (x / y) δ :=
by simp [div_eq_mul_inv]

@[to_additive]
lemma singleton_mul_closed_ball_one : {x} * closed_ball 1 δ = closed_ball x δ := by simp

@[to_additive]
lemma singleton_div_closed_ball_one : {x} / closed_ball 1 δ = closed_ball x δ := by simp

@[to_additive]
lemma closed_ball_one_mul_singleton : closed_ball 1 δ * {x} = closed_ball x δ := by simp

@[to_additive]
lemma closed_ball_one_div_singleton : closed_ball 1 δ / {x} = closed_ball x⁻¹ δ := by simp

-- This is the `to_additive` version of the below, but it will later follow as a special case of
-- `vadd_closed_ball` for `normed_add_torsor`s, so we give it higher simp priority.
-- (There is no `normed_mul_torsor`, hence the asymmetry between additive and multiplicative
-- versions.)
@[simp, priority 1100] lemma vadd_closed_ball_zero {E : Type*} [seminormed_add_comm_group E] (δ : ℝ)
  (x : E) :
  x +ᵥ metric.closed_ball 0 δ = metric.closed_ball x δ :=
by { ext, simp [mem_vadd_set_iff_neg_vadd_mem, neg_add_eq_sub, dist_eq_norm_sub] }

@[simp] lemma smul_closed_ball_one : x • closed_ball 1 δ = closed_ball x δ :=
by { ext, simp [mem_smul_set_iff_inv_smul_mem, inv_mul_eq_div, dist_eq_norm_div] }

attribute [to_additive] smul_closed_ball_one

@[to_additive] lemma mul_ball_one : s * ball 1 δ = thickening δ s :=
begin
  rw thickening_eq_bUnion_ball,
  convert Union₂_mul (λ x (_ : x ∈ s), {x}) (ball (1 : E) δ),
  exact s.bUnion_of_singleton.symm,
  ext x y,
  simp_rw [singleton_mul_ball, mul_one],
end

@[to_additive]
lemma div_ball_one : s / ball 1 δ = thickening δ s := by simp [div_eq_mul_inv, mul_ball_one]

@[to_additive]
lemma ball_mul_one : ball 1 δ * s = thickening δ s := by rw [mul_comm, mul_ball_one]

@[to_additive]
lemma ball_div_one : ball 1 δ / s = thickening δ s⁻¹ := by simp [div_eq_mul_inv, ball_mul_one]

@[simp, to_additive] lemma mul_ball : s * ball x δ = x • thickening δ s :=
by rw [←smul_ball_one, mul_smul_comm, mul_ball_one]

@[simp, to_additive] lemma div_ball : s / ball x δ = x⁻¹ • thickening δ s :=
by simp [div_eq_mul_inv]

@[simp, to_additive] lemma ball_mul : ball x δ * s = x • thickening δ s :=
by rw [mul_comm, mul_ball]

@[simp, to_additive] lemma ball_div : ball x δ / s = x • thickening δ s⁻¹ :=
by simp [div_eq_mul_inv]

variables {ε δ s t x y}

@[to_additive] lemma is_compact.mul_closed_ball_one (hs : is_compact s) (hδ : 0 ≤ δ) :
  s * closed_ball 1 δ = cthickening δ s :=
begin
  rw hs.cthickening_eq_bUnion_closed_ball hδ,
  ext x,
  simp only [mem_mul, dist_eq_norm_div, exists_prop, mem_Union, mem_closed_ball,
    exists_and_distrib_left, mem_closed_ball_one_iff, ← eq_div_iff_mul_eq'', exists_eq_right],
end

@[to_additive] lemma is_compact.div_closed_ball_one (hs : is_compact s) (hδ : 0 ≤ δ) :
  s / closed_ball 1 δ = cthickening δ s :=
by simp [div_eq_mul_inv, hs.mul_closed_ball_one hδ]

@[to_additive] lemma is_compact.closed_ball_one_mul (hs : is_compact s) (hδ : 0 ≤ δ) :
  closed_ball 1 δ * s = cthickening δ s :=
by rw [mul_comm, hs.mul_closed_ball_one hδ]

@[to_additive] lemma is_compact.closed_ball_one_div (hs : is_compact s) (hδ : 0 ≤ δ) :
  closed_ball 1 δ / s = cthickening δ s⁻¹ :=
by simp [div_eq_mul_inv, mul_comm, hs.inv.mul_closed_ball_one hδ]

@[to_additive] lemma is_compact.mul_closed_ball (hs : is_compact s) (hδ : 0 ≤ δ) (x : E) :
  s * closed_ball x δ = x • cthickening δ s :=
by rw [←smul_closed_ball_one, mul_smul_comm, hs.mul_closed_ball_one hδ]

@[to_additive] lemma is_compact.div_closed_ball (hs : is_compact s) (hδ : 0 ≤ δ) (x : E) :
  s / closed_ball x δ = x⁻¹ • cthickening δ s :=
by simp [div_eq_mul_inv, mul_comm, hs.mul_closed_ball hδ]

@[to_additive] lemma is_compact.closed_ball_mul (hs : is_compact s) (hδ : 0 ≤ δ) (x : E) :
  closed_ball x δ * s = x • cthickening δ s :=
by rw [mul_comm, hs.mul_closed_ball hδ]

@[to_additive] lemma is_compact.closed_ball_div (hs : is_compact s) (hδ : 0 ≤ δ) (x : E) :
  closed_ball x δ * s = x • cthickening δ s :=
by simp [div_eq_mul_inv, mul_comm, hs.closed_ball_mul hδ]

end seminormed_comm_group


import .love02_backward_proofs_exercise_sheet

/-! # LoVe Homework 2: Backward Proofs

Homework must be done individually. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

namespace backward_proofs

/-! ## Question 1 (4 points): Connectives and Quantifiers

1.1 (3 points). Complete the following proofs using basic tactics such as
`intro`, `apply`, and `exact`.

Hint: Some strategies for carrying out such proofs are described at the end of
Section 2.3 in the Hitchhiker's Guide. -/

lemma B (a b c : Prop) :
  (a → b) → (c → a) → c → b :=
sorry

lemma S (a b c : Prop) :
  (a → b → c) → (a → b) → a → c :=
sorry

lemma more_nonsense (a b c : Prop) :
  (c → (a → b) → a) → c → b → a :=
sorry

lemma even_more_nonsense (a b c : Prop) :
  (a → a → b) → (b → c) → a → b → c :=
sorry

/-! 1.2 (1 point). Prove the following lemma using basic tactics. -/

lemma weak_peirce (a b : Prop) :
  ((((a → b) → a) → a) → b) → b :=
sorry

/-! ## Question 2 (5 points): Logical Connectives

2.1 (1 point). Prove the following property about implication using basic
tactics.

Hints:

* Keep in mind that `¬ a` is the same as `a → false`. You can start by invoking
  `rw not_def` if this helps you.

* You will need to apply the elimination rules for `∨` and `false` at some
  point. -/

lemma about_implication (a b : Prop) :
  ¬ a ∨ b → a → b :=
sorry

/-! 2.2 (2 points). Prove the missing link in our chain of classical axiom
implications.

Hints:

* You can use `rw double_negation` to unfold the definition of
  `double_negation`, and similarly for the other definitions.

* You will need to apply the double negation hypothesis for `a ∨ ¬ a`. You will
  also need the left and right introduction rules for `∨` at some point. -/

#check excluded_middle
#check peirce
#check double_negation

lemma em_of_dn :
  double_negation → excluded_middle :=
sorry

/-! 2.3 (2 points). We have proved three of the six possible implications
between `excluded_middle`, `peirce`, and `double_negation`. State and prove the
three missing implications, exploiting the three theorems we already have. -/

#check peirce_of_em
#check dn_of_peirce
#check em_of_dn

-- enter your solution here

end backward_proofs

end LoVe


/-
Copyright (c) 2021 Alex Kontorovich and Heather Macbeth and Marc Masdeu. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alex Kontorovich, Heather Macbeth, Marc Masdeu
-/

import analysis.complex.upper_half_plane.basic
import linear_algebra.general_linear_group
import analysis.matrix

/-!
# The action of the modular group SL(2, ℤ) on the upper half-plane

We define the action of `SL(2,ℤ)` on `ℍ` (via restriction of the `SL(2,ℝ)` action in
`analysis.complex.upper_half_plane`). We then define the standard fundamental domain
(`modular_group.fd`, `𝒟`) for this action and show
(`modular_group.exists_smul_mem_fd`) that any point in `ℍ` can be
moved inside `𝒟`.

## Main definitions

The standard (closed) fundamental domain of the action of `SL(2,ℤ)` on `ℍ`, denoted `𝒟`:
`fd := {z | 1 ≤ (z : ℂ).norm_sq ∧ |z.re| ≤ (1 : ℝ) / 2}`

The standard open fundamental domain of the action of `SL(2,ℤ)` on `ℍ`, denoted `𝒟ᵒ`:
`fdo := {z | 1 < (z : ℂ).norm_sq ∧ |z.re| < (1 : ℝ) / 2}`

These notations are localized in the `modular` locale and can be enabled via `open_locale modular`.

## Main results

Any `z : ℍ` can be moved to `𝒟` by an element of `SL(2,ℤ)`:
`exists_smul_mem_fd (z : ℍ) : ∃ g : SL(2,ℤ), g • z ∈ 𝒟`

If both `z` and `γ • z` are in the open domain `𝒟ᵒ` then `z = γ • z`:
`eq_smul_self_of_mem_fdo_mem_fdo {z : ℍ} {g : SL(2,ℤ)} (hz : z ∈ 𝒟ᵒ) (hg : g • z ∈ 𝒟ᵒ) : z = g • z`

# Discussion

Standard proofs make use of the identity

`g • z = a / c - 1 / (c (cz + d))`

for `g = [[a, b], [c, d]]` in `SL(2)`, but this requires separate handling of whether `c = 0`.
Instead, our proof makes use of the following perhaps novel identity (see
`modular_group.smul_eq_lc_row0_add`):

`g • z = (a c + b d) / (c^2 + d^2) + (d z - c) / ((c^2 + d^2) (c z + d))`

where there is no issue of division by zero.

Another feature is that we delay until the very end the consideration of special matrices
`T=[[1,1],[0,1]]` (see `modular_group.T`) and `S=[[0,-1],[1,0]]` (see `modular_group.S`), by
instead using abstract theory on the properness of certain maps (phrased in terms of the filters
`filter.cocompact`, `filter.cofinite`, etc) to deduce existence theorems, first to prove the
existence of `g` maximizing `(g•z).im` (see `modular_group.exists_max_im`), and then among
those, to minimize `|(g•z).re|` (see `modular_group.exists_row_one_eq_and_min_re`).
-/

/- Disable these instances as they are not the simp-normal form, and having them disabled ensures
we state lemmas in this file without spurious `coe_fn` terms. -/
local attribute [-instance] matrix.special_linear_group.has_coe_to_fun
local attribute [-instance] matrix.general_linear_group.has_coe_to_fun

open complex (hiding abs_one abs_two abs_mul abs_add)
open matrix (hiding mul_smul) matrix.special_linear_group upper_half_plane
noncomputable theory

local notation `SL(` n `, ` R `)`:= special_linear_group (fin n) R
local prefix `↑ₘ`:1024 := @coe _ (matrix (fin 2) (fin 2) ℤ) _

open_locale upper_half_plane complex_conjugate

local attribute [instance] fintype.card_fin_even

namespace modular_group

variables {g : SL(2, ℤ)} (z : ℍ)

section bottom_row

/-- The two numbers `c`, `d` in the "bottom_row" of `g=[[*,*],[c,d]]` in `SL(2, ℤ)` are coprime. -/
lemma bottom_row_coprime {R : Type*} [comm_ring R] (g : SL(2, R)) :
  is_coprime ((↑g : matrix (fin 2) (fin 2) R) 1 0) ((↑g : matrix (fin 2) (fin 2) R) 1 1) :=
begin
  use [- (↑g : matrix (fin 2) (fin 2) R) 0 1, (↑g : matrix (fin 2) (fin 2) R) 0 0],
  rw [add_comm, neg_mul, ←sub_eq_add_neg, ←det_fin_two],
  exact g.det_coe,
end

/-- Every pair `![c, d]` of coprime integers is the "bottom_row" of some element `g=[[*,*],[c,d]]`
of `SL(2,ℤ)`. -/
lemma bottom_row_surj {R : Type*} [comm_ring R] :
  set.surj_on (λ g : SL(2, R), @coe _ (matrix (fin 2) (fin 2) R) _ g 1) set.univ
    {cd | is_coprime (cd 0) (cd 1)} :=
begin
  rintros cd ⟨b₀, a, gcd_eqn⟩,
  let A := ![![a, -b₀], cd],
  have det_A_1 : det A = 1,
  { convert gcd_eqn,
    simp [A, det_fin_two, (by ring : a * (cd 1) + b₀ * (cd 0) = b₀ * (cd 0) + a * (cd 1))] },
  refine ⟨⟨A, det_A_1⟩, set.mem_univ _, _⟩,
  ext; simp [A]
end

end bottom_row

section tendsto_lemmas

open filter continuous_linear_map
local attribute [instance] matrix.normed_group matrix.normed_space
local attribute [simp] coe_smul

/-- The function `(c,d) → |cz+d|^2` is proper, that is, preimages of bounded-above sets are finite.
-/
lemma tendsto_norm_sq_coprime_pair :
  filter.tendsto (λ p : fin 2 → ℤ, ((p 0 : ℂ) * z + p 1).norm_sq)
  cofinite at_top :=
begin
  let π₀ : (fin 2 → ℝ) →ₗ[ℝ] ℝ := linear_map.proj 0,
  let π₁ : (fin 2 → ℝ) →ₗ[ℝ] ℝ := linear_map.proj 1,
  let f : (fin 2 → ℝ) →ₗ[ℝ] ℂ := π₀.smul_right (z:ℂ) + π₁.smul_right 1,
  have f_def : ⇑f = λ (p : fin 2 → ℝ), (p 0 : ℂ) * ↑z + p 1,
  { ext1,
    dsimp only [linear_map.coe_proj, real_smul,
      linear_map.coe_smul_right, linear_map.add_apply],
    rw mul_one, },
  have : (λ (p : fin 2 → ℤ), norm_sq ((p 0 : ℂ) * ↑z + ↑(p 1)))
    = norm_sq ∘ f ∘ (λ p : fin 2 → ℤ, (coe : ℤ → ℝ) ∘ p),
  { ext1,
    rw f_def,
    dsimp only [function.comp],
    rw [of_real_int_cast, of_real_int_cast], },
  rw this,
  have hf : f.ker = ⊥,
  { let g : ℂ →ₗ[ℝ] (fin 2 → ℝ) :=
      linear_map.pi ![im_lm, im_lm.comp ((z:ℂ) • (conj_ae  : ℂ →ₗ[ℝ] ℂ))],
    suffices : ((z:ℂ).im⁻¹ • g).comp f = linear_map.id,
    { exact linear_map.ker_eq_bot_of_inverse this },
    apply linear_map.ext,
    intros c,
    have hz : (z:ℂ).im ≠ 0 := z.2.ne',
    rw [linear_map.comp_apply, linear_map.smul_apply, linear_map.id_apply],
    ext i,
    dsimp only [g, pi.smul_apply, linear_map.pi_apply, smul_eq_mul],
    fin_cases i,
    { show ((z : ℂ).im)⁻¹ * (f c).im = c 0,
      rw [f_def, add_im, of_real_mul_im, of_real_im, add_zero, mul_left_comm,
        inv_mul_cancel hz, mul_one], },
    { show ((z : ℂ).im)⁻¹ * ((z : ℂ) * conj (f c)).im = c 1,
      rw [f_def, ring_hom.map_add, ring_hom.map_mul, mul_add, mul_left_comm, mul_conj,
        conj_of_real, conj_of_real, ← of_real_mul, add_im, of_real_im, zero_add,
        inv_mul_eq_iff_eq_mul₀ hz],
      simp only [of_real_im, of_real_re, mul_im, zero_add, mul_zero] } },
  have h₁ := (linear_equiv.closed_embedding_of_injective hf).tendsto_cocompact,
  have h₂ : tendsto (λ p : fin 2 → ℤ, (coe : ℤ → ℝ) ∘ p) cofinite (cocompact _),
  { convert tendsto.pi_map_Coprod (λ i, int.tendsto_coe_cofinite),
    { rw Coprod_cofinite },
    { rw Coprod_cocompact } },
  exact tendsto_norm_sq_cocompact_at_top.comp (h₁.comp h₂)
end

/-- Given `coprime_pair` `p=(c,d)`, the matrix `[[a,b],[*,*]]` is sent to `a*c+b*d`.
  This is the linear map version of this operation.
-/
def lc_row0 (p : fin 2 → ℤ) : (matrix (fin 2) (fin 2) ℝ) →ₗ[ℝ] ℝ :=
((p 0:ℝ) • linear_map.proj 0 + (p 1:ℝ) • linear_map.proj 1 : (fin 2 → ℝ) →ₗ[ℝ] ℝ).comp
  (linear_map.proj 0)

@[simp] lemma lc_row0_apply (p : fin 2 → ℤ) (g : matrix (fin 2) (fin 2) ℝ) :
  lc_row0 p g = p 0 * g 0 0 + p 1 * g 0 1 :=
rfl

/-- Linear map sending the matrix [a, b; c, d] to the matrix [ac₀ + bd₀, - ad₀ + bc₀; c, d], for
some fixed `(c₀, d₀)`. -/
@[simps] def lc_row0_extend {cd : fin 2 → ℤ} (hcd : is_coprime (cd 0) (cd 1)) :
  (matrix (fin 2) (fin 2) ℝ) ≃ₗ[ℝ] matrix (fin 2) (fin 2) ℝ :=
linear_equiv.Pi_congr_right
![begin
    refine linear_map.general_linear_group.general_linear_equiv ℝ (fin 2 → ℝ)
      (general_linear_group.to_linear (plane_conformal_matrix (cd 0 : ℝ) (-(cd 1 : ℝ)) _)),
    norm_cast,
    rw neg_sq,
    exact hcd.sq_add_sq_ne_zero
  end,
  linear_equiv.refl ℝ (fin 2 → ℝ)]

/-- The map `lc_row0` is proper, that is, preimages of cocompact sets are finite in
`[[* , *], [c, d]]`.-/
theorem tendsto_lc_row0 {cd : fin 2 → ℤ} (hcd : is_coprime (cd 0) (cd 1)) :
  tendsto (λ g : {g : SL(2, ℤ) // ↑ₘg 1 = cd}, lc_row0 cd ↑(↑g : SL(2, ℝ)))
    cofinite (cocompact ℝ) :=
begin
  let mB : ℝ → (matrix (fin 2) (fin 2)  ℝ) := λ t, ![![t, (-(1:ℤ):ℝ)], coe ∘ cd],
  have hmB : continuous mB,
  { simp only [continuous_pi_iff, fin.forall_fin_two, mB, continuous_const, continuous_id',
      cons_val_zero, cons_val_one, and_self ] },
  refine filter.tendsto.of_tendsto_comp _ (comap_cocompact_le hmB),
  let f₁ : SL(2, ℤ) → matrix (fin 2) (fin 2) ℝ :=
    λ g, matrix.map (↑g : matrix _ _ ℤ) (coe : ℤ → ℝ),
  have cocompact_ℝ_to_cofinite_ℤ_matrix :
    tendsto (λ m : matrix (fin 2) (fin 2) ℤ, matrix.map m (coe : ℤ → ℝ)) cofinite (cocompact _),
  { simpa only [Coprod_cofinite, Coprod_cocompact]
      using tendsto.pi_map_Coprod (λ i : fin 2, tendsto.pi_map_Coprod
        (λ j : fin 2, int.tendsto_coe_cofinite)) },
  have hf₁ : tendsto f₁ cofinite (cocompact _) :=
    cocompact_ℝ_to_cofinite_ℤ_matrix.comp subtype.coe_injective.tendsto_cofinite,
  have hf₂ : closed_embedding (lc_row0_extend hcd) :=
    (lc_row0_extend hcd).to_continuous_linear_equiv.to_homeomorph.closed_embedding,
  convert hf₂.tendsto_cocompact.comp (hf₁.comp subtype.coe_injective.tendsto_cofinite) using 1,
  ext ⟨g, rfl⟩ i j : 3,
  fin_cases i; [fin_cases j, skip],
  -- the following are proved by `simp`, but it is replaced by `simp only` to avoid timeouts.
  { simp only [mB, mul_vec, dot_product, fin.sum_univ_two, _root_.coe_coe, coe_matrix_coe,
      int.coe_cast_ring_hom, lc_row0_apply, function.comp_app, cons_val_zero, lc_row0_extend_apply,
      linear_map.general_linear_group.coe_fn_general_linear_equiv,
      general_linear_group.to_linear_apply, coe_plane_conformal_matrix, neg_neg, mul_vec_lin_apply,
      cons_val_one, head_cons] },
  { convert congr_arg (λ n : ℤ, (-n:ℝ)) g.det_coe.symm using 1,
    simp only [f₁, mul_vec, dot_product, fin.sum_univ_two, matrix.det_fin_two, function.comp_app,
      subtype.coe_mk, lc_row0_extend_apply, cons_val_zero,
      linear_map.general_linear_group.coe_fn_general_linear_equiv,
      general_linear_group.to_linear_apply, coe_plane_conformal_matrix, mul_vec_lin_apply,
      cons_val_one, head_cons, map_apply, neg_mul, int.cast_sub, int.cast_mul, neg_sub],
    ring },
  { refl }
end

/-- This replaces `(g•z).re = a/c + *` in the standard theory with the following novel identity:
  `g • z = (a c + b d) / (c^2 + d^2) + (d z - c) / ((c^2 + d^2) (c z + d))`
  which does not need to be decomposed depending on whether `c = 0`. -/
lemma smul_eq_lc_row0_add {p : fin 2 → ℤ} (hp : is_coprime (p 0) (p 1)) (hg : ↑ₘg 1 = p) :
  ↑(g • z) = ((lc_row0 p ↑(g : SL(2, ℝ))) : ℂ) / (p 0 ^ 2 + p 1 ^ 2)
    + ((p 1 : ℂ) * z - p 0) / ((p 0 ^ 2 + p 1 ^ 2) * (p 0 * z + p 1)) :=
begin
  have nonZ1 : (p 0 : ℂ) ^ 2 + (p 1) ^ 2 ≠ 0 := by exact_mod_cast hp.sq_add_sq_ne_zero,
  have : (coe : ℤ → ℝ) ∘ p ≠ 0 := λ h, hp.ne_zero (by ext i; simpa using congr_fun h i),
  have nonZ2 : (p 0 : ℂ) * z + p 1 ≠ 0 := by simpa using linear_ne_zero _ z this,
  field_simp [nonZ1, nonZ2, denom_ne_zero, -upper_half_plane.denom, -denom_apply],
  rw (by simp : (p 1 : ℂ) * z - p 0 = ((p 1) * z - p 0) * ↑(det (↑g : matrix (fin 2) (fin 2) ℤ))),
  rw [←hg, det_fin_two],
  simp only [int.coe_cast_ring_hom, coe_matrix_coe, int.cast_mul, of_real_int_cast, map_apply,
  denom, int.cast_sub, _root_.coe_coe,coe_GL_pos_coe_GL_coe_matrix],
  ring,
end

lemma tendsto_abs_re_smul {p : fin 2 → ℤ} (hp : is_coprime (p 0) (p 1)) :
  tendsto (λ g : {g : SL(2, ℤ) // ↑ₘg 1 = p}, |((g : SL(2, ℤ)) • z).re|)
    cofinite at_top :=
begin
  suffices : tendsto (λ g : (λ g : SL(2, ℤ), ↑ₘg 1) ⁻¹' {p}, (((g : SL(2, ℤ)) • z).re))
    cofinite (cocompact ℝ),
  { exact tendsto_norm_cocompact_at_top.comp this },
  have : ((p 0 : ℝ) ^ 2 + p 1 ^ 2)⁻¹ ≠ 0,
  { apply inv_ne_zero,
    exact_mod_cast hp.sq_add_sq_ne_zero },
  let f := homeomorph.mul_right₀ _ this,
  let ff := homeomorph.add_right (((p 1:ℂ)* z - p 0) / ((p 0 ^ 2 + p 1 ^ 2) * (p 0 * z + p 1))).re,
  convert ((f.trans ff).closed_embedding.tendsto_cocompact).comp (tendsto_lc_row0 hp),
  ext g,
  change ((g : SL(2, ℤ)) • z).re = (lc_row0 p ↑(↑g : SL(2, ℝ))) / (p 0 ^ 2 + p 1 ^ 2)
  + (((p 1:ℂ )* z - p 0) / ((p 0 ^ 2 + p 1 ^ 2) * (p 0 * z + p 1))).re,
  exact_mod_cast (congr_arg complex.re (smul_eq_lc_row0_add z hp g.2))
end

end tendsto_lemmas

section fundamental_domain

local attribute [simp] coe_smul re_smul

/-- For `z : ℍ`, there is a `g : SL(2,ℤ)` maximizing `(g•z).im` -/
lemma exists_max_im :
  ∃ g : SL(2, ℤ), ∀ g' : SL(2, ℤ), (g' • z).im ≤ (g • z).im :=
begin
  classical,
  let s : set (fin 2 → ℤ) := {cd | is_coprime (cd 0) (cd 1)},
  have hs : s.nonempty := ⟨![1, 1], is_coprime_one_left⟩,
  obtain ⟨p, hp_coprime, hp⟩ :=
    filter.tendsto.exists_within_forall_le hs (tendsto_norm_sq_coprime_pair z),
  obtain ⟨g, -, hg⟩ := bottom_row_surj hp_coprime,
  refine ⟨g, λ g', _⟩,
  rw [special_linear_group.im_smul_eq_div_norm_sq, special_linear_group.im_smul_eq_div_norm_sq,
    div_le_div_left],
  { simpa [← hg] using hp (↑ₘg' 1) (bottom_row_coprime g') },
  { exact z.im_pos },
  { exact norm_sq_denom_pos g' z },
  { exact norm_sq_denom_pos g z },
end

/-- Given `z : ℍ` and a bottom row `(c,d)`, among the `g : SL(2,ℤ)` with this bottom row, minimize
  `|(g•z).re|`.  -/
lemma exists_row_one_eq_and_min_re {cd : fin 2 → ℤ} (hcd : is_coprime (cd 0) (cd 1)) :
  ∃ g : SL(2,ℤ), ↑ₘg 1 = cd ∧ (∀ g' : SL(2,ℤ), ↑ₘg 1 = ↑ₘg' 1 →
  |(g • z).re| ≤ |(g' • z).re|) :=
begin
  haveI : nonempty {g : SL(2, ℤ) // ↑ₘg 1 = cd} :=
    let ⟨x, hx⟩ := bottom_row_surj hcd in ⟨⟨x, hx.2⟩⟩,
  obtain ⟨g, hg⟩ := filter.tendsto.exists_forall_le (tendsto_abs_re_smul z hcd),
  refine ⟨g, g.2, _⟩,
  { intros g1 hg1,
    have : g1 ∈ ((λ g : SL(2, ℤ), ↑ₘg 1) ⁻¹' {cd}),
    { rw [set.mem_preimage, set.mem_singleton_iff],
      exact eq.trans hg1.symm (set.mem_singleton_iff.mp (set.mem_preimage.mp g.2)) },
    exact hg ⟨g1, this⟩ },
end

/-- The matrix `T = [[1,1],[0,1]]` as an element of `SL(2,ℤ)` -/
def T : SL(2,ℤ) := ⟨![![1, 1], ![0, 1]], by norm_num [matrix.det_fin_two]⟩

/-- The matrix `S = [[0,-1],[1,0]]` as an element of `SL(2,ℤ)` -/
def S : SL(2,ℤ) := ⟨![![0, -1], ![1, 0]], by norm_num [matrix.det_fin_two]⟩

lemma coe_S : ↑ₘS = ![![0, -1], ![1, 0]] := rfl

lemma coe_T : ↑ₘT = ![![1, 1], ![0, 1]] := rfl

lemma coe_T_inv : ↑ₘ(T⁻¹) = ![![1, -1], ![0, 1]] := by simp [coe_inv, coe_T, adjugate_fin_two]

lemma coe_T_zpow (n : ℤ) : ↑ₘ(T ^ n) = ![![1, n], ![0,1]] :=
begin
  induction n using int.induction_on with n h n h,
  { ext i j, fin_cases i; fin_cases j;
    simp, },
  { rw [zpow_add, zpow_one, coe_mul, h, coe_T],
    ext i j, fin_cases i; fin_cases j;
    simp [matrix.mul_apply, fin.sum_univ_succ, add_comm (1 : ℤ)], },
  { rw [zpow_sub, zpow_one, coe_mul, h, coe_T_inv],
    ext i j, fin_cases i; fin_cases j;
    simp [matrix.mul_apply, fin.sum_univ_succ, neg_add_eq_sub (1 : ℤ)], },
end

variables {z}

lemma coe_T_zpow_smul_eq {n : ℤ} : (↑((T^n) • z) : ℂ) = z + n :=
by simp [coe_T_zpow]

-- If instead we had `g` and `T` of type `PSL(2, ℤ)`, then we could simply state `g = T^n`.
lemma exists_eq_T_zpow_of_c_eq_zero (hc : ↑ₘg 1 0 = 0) :
  ∃ (n : ℤ), ∀ (z : ℍ), g • z = T^n • z :=
begin
  have had := g.det_coe,
  replace had : ↑ₘg 0 0 * ↑ₘg 1 1 = 1, { rw [det_fin_two, hc] at had, linarith, },
  rcases int.eq_one_or_neg_one_of_mul_eq_one' had with ⟨ha, hd⟩ | ⟨ha, hd⟩,
  { use ↑ₘg 0 1,
    suffices : g = T^(↑ₘg 0 1), { intros z, conv_lhs { rw this, }, },
    ext i j, fin_cases i; fin_cases j;
    simp [ha, hc, hd, coe_T_zpow], },
  { use -↑ₘg 0 1,
    suffices : g = -T^(-↑ₘg 0 1), { intros z, conv_lhs { rw [this, SL_neg_smul], }, },
    ext i j, fin_cases i; fin_cases j;
    simp [ha, hc, hd, coe_T_zpow], },
end

/- If `c = 1`, then `g` factorises into a product terms involving only `T` and `S`. -/
lemma g_eq_of_c_eq_one (hc : ↑ₘg 1 0 = 1) :
  g = T^(↑ₘg 0 0) * S * T^(↑ₘg 1 1) :=
begin
  have hg := g.det_coe.symm,
  replace hg : ↑ₘg 0 1 = ↑ₘg 0 0 * ↑ₘg 1 1 - 1, { rw [det_fin_two, hc] at hg, linarith, },
  ext i j, fin_cases i; fin_cases j;
  simp [coe_S, coe_T_zpow, matrix.mul_apply, fin.sum_univ_succ, hg, hc],
end

/-- If `1 < |z|`, then `|S • z| < 1`. -/
lemma norm_sq_S_smul_lt_one (h: 1 < norm_sq z) : norm_sq ↑(S • z) < 1 :=
by simpa [coe_S] using (inv_lt_inv z.norm_sq_pos zero_lt_one).mpr h

/-- If `|z| < 1`, then applying `S` strictly decreases `im`. -/
lemma im_lt_im_S_smul (h: norm_sq z < 1) : z.im < (S • z).im :=
begin
  have : z.im < z.im / norm_sq (z:ℂ),
  { have imz : 0 < z.im := im_pos z,
    apply (lt_div_iff z.norm_sq_pos).mpr,
    nlinarith },
  convert this,
  simp only [special_linear_group.im_smul_eq_div_norm_sq],
  field_simp [norm_sq_denom_ne_zero, norm_sq_ne_zero, S]
end

/-- The standard (closed) fundamental domain of the action of `SL(2,ℤ)` on `ℍ`. -/
def fd : set ℍ :=
{z | 1 ≤ (z : ℂ).norm_sq ∧ |z.re| ≤ (1 : ℝ) / 2}

/-- The standard open fundamental domain of the action of `SL(2,ℤ)` on `ℍ`. -/
def fdo : set ℍ :=
{z | 1 < (z : ℂ).norm_sq ∧ |z.re| < (1 : ℝ) / 2}

localized "notation `𝒟` := modular_group.fd" in modular

localized "notation `𝒟ᵒ` := modular_group.fdo" in modular

lemma abs_two_mul_re_lt_one_of_mem_fdo (h : z ∈ 𝒟ᵒ) : |2 * z.re| < 1 :=
begin
  rw [abs_mul, abs_two, ← lt_div_iff' (@two_pos ℝ _ _)],
  exact h.2,
end

lemma three_lt_four_mul_im_sq_of_mem_fdo (h : z ∈ 𝒟ᵒ) : 3 < 4 * z.im^2 :=
begin
  have : 1 < z.re * z.re + z.im * z.im := by simpa [complex.norm_sq_apply] using h.1,
  have := h.2,
  cases abs_cases z.re;
  nlinarith,
end

/-- If `z ∈ 𝒟ᵒ`, and `n : ℤ`, then `|z + n| > 1`. -/
lemma one_lt_norm_sq_T_zpow_smul (hz : z ∈ 𝒟ᵒ) (n : ℤ) : 1 < norm_sq (((T^n) • z) : ℍ) :=
begin
  have hz₁ : 1 < z.re * z.re + z.im * z.im := hz.1,
  have hzn := int.nneg_mul_add_sq_of_abs_le_one n (abs_two_mul_re_lt_one_of_mem_fdo hz).le,
  have : 1 < (z.re + ↑n) * (z.re + ↑n) + z.im * z.im, { linarith, },
  simpa [coe_T_zpow, norm_sq],
end

lemma eq_zero_of_mem_fdo_of_T_zpow_mem_fdo {n : ℤ} (hz : z ∈ 𝒟ᵒ) (hg : (T^n) • z ∈ 𝒟ᵒ) : n = 0 :=
begin
  suffices : |(n : ℝ)| < 1,
  { rwa [← int.cast_abs, ← int.cast_one, int.cast_lt, int.abs_lt_one_iff] at this, },
  have h₁ := hz.2,
  have h₂ := hg.2,
  rw [← coe_re, coe_T_zpow_smul_eq, add_re, int_cast_re, coe_re] at h₂,
  calc |(n : ℝ)| ≤ |z.re| + |z.re + (n : ℝ)| : abs_add' (n : ℝ) z.re
             ... < 1/2 + 1/2 : add_lt_add h₁ h₂
             ... = 1 : add_halves 1,
end

/-- Any `z : ℍ` can be moved to `𝒟` by an element of `SL(2,ℤ)`  -/
lemma exists_smul_mem_fd (z : ℍ) : ∃ g : SL(2,ℤ), g • z ∈ 𝒟 :=
begin
  -- obtain a g₀ which maximizes im (g • z),
  obtain ⟨g₀, hg₀⟩ := exists_max_im z,
  -- then among those, minimize re
  obtain ⟨g, hg, hg'⟩ := exists_row_one_eq_and_min_re z (bottom_row_coprime g₀),
  refine ⟨g, _⟩,
  -- `g` has same max im property as `g₀`
  have hg₀' : ∀ (g' : SL(2,ℤ)), (g' • z).im ≤ (g • z).im,
  { have hg'' : (g • z).im = (g₀ • z).im,
    { rw [special_linear_group.im_smul_eq_div_norm_sq, special_linear_group.im_smul_eq_div_norm_sq,
      denom_apply, denom_apply, hg]},
    simpa only [hg''] using hg₀ },
  split,
  { -- Claim: `1 ≤ ⇑norm_sq ↑(g • z)`. If not, then `S•g•z` has larger imaginary part
    contrapose! hg₀',
    refine ⟨S * g, _⟩,
    rw mul_action.mul_smul,
    exact im_lt_im_S_smul hg₀' },
  { show |(g • z).re| ≤ 1 / 2, -- if not, then either `T` or `T'` decrease |Re|.
    rw abs_le,
    split,
    { contrapose! hg',
      refine ⟨T * g, by simp [T, matrix.mul, matrix.dot_product, fin.sum_univ_succ], _⟩,
      rw mul_action.mul_smul,
      have : |(g • z).re + 1| < |(g • z).re| :=
        by cases abs_cases ((g • z).re + 1); cases abs_cases (g • z).re; linarith,
      convert this,
      simp [T] },
    { contrapose! hg',
      refine ⟨T⁻¹ * g, by simp [coe_T_inv, matrix.mul, matrix.dot_product, fin.sum_univ_succ], _⟩,
      rw mul_action.mul_smul,
      have : |(g • z).re - 1| < |(g • z).re| :=
        by cases abs_cases ((g • z).re - 1); cases abs_cases (g • z).re; linarith,
      convert this,
      simp [coe_T_inv, sub_eq_add_neg] } }
end

section unique_representative

variables {z}

/-- An auxiliary result en route to `modular_group.c_eq_zero`. -/
lemma abs_c_le_one (hz : z ∈ 𝒟ᵒ) (hg : g • z ∈ 𝒟ᵒ) : |↑ₘg 1 0| ≤ 1 :=
begin
  let c' : ℤ := ↑ₘg 1 0,
  let c : ℝ := (c' : ℝ),
  suffices : 3 * c^2 < 4,
  { rw [← int.cast_pow, ← int.cast_three, ← int.cast_four, ← int.cast_mul, int.cast_lt] at this,
    replace this : c' ^ 2 ≤ 1 ^ 2, { linarith, },
    rwa [sq_le_sq, abs_one] at this },
  suffices : c ≠ 0 → 9 * c^4 < 16,
  { rcases eq_or_ne c 0 with hc | hc,
    { rw hc, norm_num, },
    { refine (abs_lt_of_sq_lt_sq' _ (by norm_num)).2,
      specialize this hc,
      linarith, }, },
  intros hc,
  replace hc : 0 < c^4, { rw pow_bit0_pos_iff; trivial, },
  have h₁ := mul_lt_mul_of_pos_right (mul_lt_mul'' (three_lt_four_mul_im_sq_of_mem_fdo hg)
      (three_lt_four_mul_im_sq_of_mem_fdo hz) (by linarith) (by linarith)) hc,
  have h₂ : (c * z.im) ^ 4 / norm_sq (denom ↑g z) ^ 2 ≤ 1 :=
    div_le_one_of_le (pow_four_le_pow_two_of_pow_two_le
      (upper_half_plane.c_mul_im_sq_le_norm_sq_denom z g)) (sq_nonneg _),
  let nsq := norm_sq (denom g z),
  calc 9 * c^4 < c^4 * z.im^2 * (g • z).im^2 * 16 : by linarith
           ... = c^4 * z.im^4 / nsq^2 * 16 : by { rw [special_linear_group.im_smul_eq_div_norm_sq,
            div_pow], ring, }
           ... ≤ 16 : by { rw ← mul_pow, linarith, },
end

/-- An auxiliary result en route to `modular_group.eq_smul_self_of_mem_fdo_mem_fdo`. -/
lemma c_eq_zero (hz : z ∈ 𝒟ᵒ) (hg : g • z ∈ 𝒟ᵒ) : ↑ₘg 1 0 = 0 :=
begin
  have hp : ∀ {g' : SL(2, ℤ)} (hg' : g' • z ∈ 𝒟ᵒ), ↑ₘg' 1 0 ≠ 1,
  { intros,
    by_contra hc,
    let a := ↑ₘg' 0 0,
    let d := ↑ₘg' 1 1,
    have had : T^(-a) * g' = S * T^d, { rw g_eq_of_c_eq_one hc, group, },
    let w := T^(-a) • (g' • z),
    have h₁ : w = S • (T^d • z), { simp only [w, ← mul_smul, had], },
    replace h₁ : norm_sq w < 1 := h₁.symm ▸ norm_sq_S_smul_lt_one (one_lt_norm_sq_T_zpow_smul hz d),
    have h₂ : 1 < norm_sq w := one_lt_norm_sq_T_zpow_smul hg' (-a),
    linarith, },
  have hn : ↑ₘg 1 0 ≠ -1,
  { intros hc,
    replace hc : ↑ₘ(-g) 1 0 = 1, { simp [eq_neg_of_eq_neg hc], },
    replace hg : (-g) • z ∈ 𝒟ᵒ := (SL_neg_smul g z).symm ▸ hg,
    exact hp hg hc, },
  specialize hp hg,
  rcases (int.abs_le_one_iff.mp $ abs_c_le_one hz hg);
  tauto,
end

/-- Second Main Fundamental Domain Lemma: if both `z` and `g • z` are in the open domain `𝒟ᵒ`,
where `z : ℍ` and `g : SL(2,ℤ)`, then `z = g • z`. -/
lemma eq_smul_self_of_mem_fdo_mem_fdo (hz : z ∈ 𝒟ᵒ) (hg : g • z ∈ 𝒟ᵒ) : z = g • z :=
begin
  obtain ⟨n, hn⟩ := exists_eq_T_zpow_of_c_eq_zero (c_eq_zero hz hg),
  rw hn at hg ⊢,
  simp [eq_zero_of_mem_fdo_of_T_zpow_mem_fdo hz hg, one_smul],
end

end unique_representative

end fundamental_domain

end modular_group