/-
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
-/
import tactic.ring_exp
import tactic.interval_cases
import data.nat.parity
import data.zmod.basic
import group_theory.order_of_element
import ring_theory.fintype

/-!
# 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

lemma mersenne_pos {p : ℕ} (h : 0 < p) : 0 < mersenne p :=
begin
  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)
end

@[simp]
lemma succ_mersenne (k : ℕ) : mersenne k + 1 = 2 ^ k :=
begin
  rw [mersenne, nat.sub_add_cancel],
  exact one_le_pow_of_one_le (by norm_num) k
end

namespace lucas_lehmer

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

/-- The recurrence `s (i+1) = (s i)^2 - 2` in `zmod (2^p - 1)`. -/
def s_zmod (p : ℕ) : ℕ → zmod (2^p - 1)
| 0 := 4
| (i+1) := (s_zmod i)^2 - 2

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

lemma mersenne_int_ne_zero (p : ℕ) (w : 0 < p) : (2^p - 1 : ℤ) ≠ 0 :=
begin
  apply ne_of_gt, simp only [gt_iff_lt, sub_pos],
  exact_mod_cast nat.one_lt_two_pow p w,
end

lemma s_mod_nonneg (p : ℕ) (w : 0 < p) (i : ℕ) : 0 ≤ s_mod p i :=
begin
  cases i; dsimp [s_mod],
  { exact sup_eq_left.mp rfl },
  { apply int.mod_nonneg, exact mersenne_int_ne_zero p w },
end

lemma s_mod_mod (p i : ℕ) : s_mod p i % (2^p - 1) = s_mod p i :=
by cases i; simp [s_mod]

lemma s_mod_lt (p : ℕ) (w : 0 < p) (i : ℕ) : s_mod p i < 2^p - 1 :=
begin
  rw ←s_mod_mod,
  convert int.mod_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, },
end

lemma s_zmod_eq_s (p' : ℕ) (i : ℕ) : s_zmod (p'+2) i = (s i : zmod (2^(p'+2) - 1)):=
begin
  induction i with i ih,
  { dsimp [s, s_zmod], norm_num, },
  { push_cast [s, s_zmod, ih] },
end

-- These next two don't make good `norm_cast` lemmas.
lemma int.coe_nat_pow_pred (b p : ℕ) (w : 0 < b) : ((b^p - 1 : ℕ) : ℤ) = (b^p - 1 : ℤ) :=
begin
  have : 1 ≤ b^p := nat.one_le_pow p b w,
  push_cast [this],
end

lemma int.coe_nat_two_pow_pred (p : ℕ) : ((2^p - 1 : ℕ) : ℤ) = (2^p - 1 : ℤ) :=
int.coe_nat_pow_pred 2 p dec_trivial

lemma s_zmod_eq_s_mod (p : ℕ) (i : ℕ) : s_zmod p i = (s_mod p i : zmod (2^p - 1)) :=
by induction i; push_cast [←int.coe_nat_two_pow_pred p, s_mod, s_zmod, *]

/-- The Lucas-Lehmer residue is `s p (p-2)` in `zmod (2^p - 1)`. -/
def lucas_lehmer_residue (p : ℕ) : zmod (2^p - 1) := s_zmod p (p-2)

lemma residue_eq_zero_iff_s_mod_eq_zero (p : ℕ) (w : 1 < p) :
  lucas_lehmer_residue p = 0 ↔ s_mod p (p-2) = 0 :=
begin
  dsimp [lucas_lehmer_residue],
  rw s_zmod_eq_s_mod p,
  split,
  { -- 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_coe_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),
    convert s_mod_lt _ (nat.lt_of_succ_lt w) (p-2),
    push_cast [nat.one_le_two_pow p],
    refl, },
  { intro h, rw h, simp, },
end

/--
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.
-/
@[derive decidable_pred]
def lucas_lehmer_test (p : ℕ) : Prop := lucas_lehmer_residue p = 0

/-- `q` is defined as the minimum factor of `mersenne p`, bundled as an `ℕ+`. -/
def q (p : ℕ) : ℕ+ := ⟨nat.min_fac (mersenne p), nat.min_fac_pos (mersenne p)⟩

local attribute [instance]
lemma fact_pnat_pos (q : ℕ+) : fact (0 < (q : ℕ)) := ⟨q.2⟩

/-- We construct the ring `X q` as ℤ/qℤ + √3 ℤ/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.
@[derive [add_comm_group, decidable_eq, fintype, inhabited]]
def X (q : ℕ+) : Type := (zmod q) × (zmod q)

namespace X
variable {q : ℕ+}

@[ext]
lemma ext {x y : X q} (h₁ : x.1 = y.1) (h₂ : x.2 = y.2) : x = y :=
begin
  cases x, cases y,
  congr; assumption
end

@[simp] lemma add_fst (x y : X q) : (x + y).1 = x.1 + y.1 := rfl
@[simp]

@[simp] lemma neg_fst (x : X q) : (-x).1 = -x.1 := rfl
@[simp] lemma neg_snd (x : X q) : (-x).2 = -x.2 := rfl

instance : has_mul (X q) :=
{ mul := λ x y, (x.1*y.1 + 3*x.2*y.2, x.1*y.2 + x.2*y.1) }

@[simp] lemma mul_fst (x y : X q) : (x * y).1 = x.1 * y.1 + 3 * x.2 * y.2 := rfl
@[simp] lemma mul_snd (x y : X q) : (x * y).2 = x.1 * y.2 + x.2 * y.1 := rfl

instance : has_one (X q) :=
{ one := ⟨1,0⟩ }

@[simp] lemma one_fst : (1 : X q).1 = 1 := rfl
@[simp] lemma one_snd : (1 : X q).2 = 0 := rfl

@[simp] lemma bit0_fst (x : X q) : (bit0 x).1 = bit0 x.1 := rfl
@[simp] lemma bit0_snd (x : X q) : (bit0 x).2 = bit0 x.2 := rfl
@[simp] lemma bit1_fst (x : X q) : (bit1 x).1 = bit1 x.1 := rfl
@[simp] lemma bit1_snd (x : X q) : (bit1 x).2 = bit0 x.2 := by { dsimp [bit1], simp, }

instance : monoid (X q) :=
{ mul_assoc := λ x y z, by { ext; { dsimp, ring }, },
  one := ⟨1,0⟩,
  one_mul := λ x, by { ext; simp, },
  mul_one := λ x, by { ext; simp, },
  ..(infer_instance : has_mul (X q)) }

lemma left_distrib (x y z : X q) : x * (y + z) = x * y + x * z :=
by { ext; { dsimp, ring }, }

lemma right_distrib (x y z : X q) : (x + y) * z = x * z + y * z :=
by { ext; { dsimp, ring }, }

instance : ring (X q) :=
{ left_distrib := left_distrib,
  right_distrib := right_distrib,
  ..(infer_instance : add_comm_group (X q)),
  ..(infer_instance : monoid (X q)) }

instance : comm_ring (X q) :=
{ mul_comm := λ x y, by { ext; { dsimp, ring }, },
  ..(infer_instance : ring (X q))}

instance [fact (1 < (q : ℕ))] : nontrivial (X q) :=
⟨⟨0, 1, λ h, by { injection h with h1 _, exact zero_ne_one h1 } ⟩⟩

@[simp]
lemma nat_coe_fst (n : ℕ) : (n : X q).fst = (n : zmod q) :=
begin
  induction n,
  { refl, },
  { dsimp, simp only [add_left_inj], exact n_ih, }
end
@[simp]
lemma nat_coe_snd (n : ℕ) : (n : X q).snd = (0 : zmod q) :=
begin
  induction n,
  { refl, },
  { dsimp, simp only [add_zero], exact n_ih, }
end

@[simp]
lemma int_coe_fst (n : ℤ) : (n : X q).fst = (n : zmod q) :=
by { induction n; simp, }
@[simp]
lemma int_coe_snd (n : ℤ) : (n : X q).snd = (0 : zmod q) :=
by { induction n; simp, }

@[norm_cast]
lemma coe_mul (n m : ℤ) : ((n * m : ℤ) : X q) = (n : X q) * (m : X q) :=
by { ext; simp; ring }

@[norm_cast]
lemma coe_nat (n : ℕ) : ((n : ℤ) : X q) = (n : X q) :=
by { ext; simp, }

/-- The cardinality of `X` is `q^2`. -/
lemma X_card : fintype.card (X q) = q^2 :=
begin
  dsimp [X],
  rw [fintype.card_prod, zmod.card q],
  ring,
end

/-- There are strictly fewer than `q^2` units, since `0` is not a unit. -/
lemma units_card (w : 1 < q) : fintype.card (units (X q)) < q^2 :=
begin
  haveI : fact (1 < (q:ℕ)) := ⟨w⟩,
  convert card_units_lt (X q),
  rw X_card,
end

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

lemma ω_mul_ωb (q : ℕ+) : (ω : X q) * ωb = 1 :=
begin
  dsimp [ω, ωb],
  ext; simp; ring,
end

lemma ωb_mul_ω (q : ℕ+) : (ωb : X q) * ω = 1 :=
begin
  dsimp [ω, ωb],
  ext; simp; ring,
end

/-- A closed form for the recurrence relation. -/
lemma closed_form (i : ℕ) : (s i : X q) = (ω : X q)^(2^i) + (ωb : X q)^(2^i) :=
begin
  induction i with i ih,
  { dsimp [s, ω, ωb],
    ext; { simp; refl, }, },
  { 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'] }
end

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. -/
lemma two_lt_q (p' : ℕ) : 2 < q (p'+2) := begin
  by_contradiction H,
  simp at H,
  interval_cases q (p'+2); 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 _) dec_trivial 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.min_fac_eq_two_iff, pow_succ] at h',
    exact nat.two_not_dvd_two_mul_sub_one (nat.one_le_two_pow _) h', }
end

theorem ω_pow_formula (p' : ℕ) (h : lucas_lehmer_residue (p'+2) = 0) :
  ∃ (k : ℤ), (ω : X (q (p'+2)))^(2^(p'+1)) =
    k * (mersenne (p'+2)) * ((ω : X (q (p'+2)))^(2^p')) - 1 :=
begin
  dsimp [lucas_lehmer_residue] at h,
  rw s_zmod_eq_s p' at h,
  simp [zmod.int_coe_zmod_eq_zero_iff_dvd] at h,
  cases h with k h,
  use k,
  replace h := congr_arg (λ (n : ℤ), (n : X (q (p'+2)))) h, -- coercion from ℤ to X q
  dsimp at h,
  rw closed_form at h,
  replace h := congr_arg (λ x, ω^2^p' * x) h,
  dsimp at h,
  have t : 2^p' + 2^p' = 2^(p'+1) := by ring_exp,
  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,
  exact_mod_cast h,
end

/-- `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 :=
begin
  ext; simp [mersenne, q, zmod.nat_coe_zmod_eq_zero_iff_dvd, -pow_pos],
  apply nat.min_fac_dvd,
end

theorem ω_pow_eq_neg_one (p' : ℕ) (h : lucas_lehmer_residue (p'+2) = 0) :
  (ω : X (q (p'+2)))^(2^(p'+1)) = -1 :=
begin
  cases ω_pow_formula p' h with k w,
  rw [mersenne_coe_X] at w,
  simpa using w,
end

theorem ω_pow_eq_one (p' : ℕ) (h : lucas_lehmer_residue (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

/-- `ω` as an element of the group of units. -/
def ω_unit (p : ℕ) : units (X (q p)) :=
{ val := ω,
  inv := ωb,
  val_inv := by simp [ω_mul_ωb],
  inv_val := by simp [ωb_mul_ω], }

@[simp] lemma ω_unit_coe (p : ℕ) : (ω_unit p : X (q p)) = ω := rfl

/-- The order of `ω` in the unit group is exactly `2^p`. -/
theorem order_ω (p' : ℕ) (h : lucas_lehmer_residue (p'+2) = 0) :
  order_of (ω_unit (p'+2)) = 2^(p'+2) :=
begin
  apply nat.eq_prime_pow_of_dvd_least_prime_pow, -- the order of ω divides 2^p
  { norm_num, },
  { intro o,
    have ω_pow := order_of_dvd_iff_pow_eq_one.1 o,
    replace ω_pow := congr_arg (units.coe_hom (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 order_of_dvd_iff_pow_eq_one.2,
    apply units.ext,
    push_cast,
    exact ω_pow_eq_one p' h, }
end

lemma order_ineq (p' : ℕ) (h : lucas_lehmer_residue (p'+2) = 0) : 2^(p'+2) < (q (p'+2) : ℕ)^2 :=
calc 2^(p'+2) = order_of (ω_unit (p'+2)) : (order_ω p' h).symm
     ... ≤ fintype.card (units (X _))    : order_of_le_card_univ
     ... < (q (p'+2) : ℕ)^2              : units_card (nat.lt_of_succ_lt (two_lt_q _))

end lucas_lehmer

export lucas_lehmer (lucas_lehmer_test lucas_lehmer_residue)

open lucas_lehmer

theorem lucas_lehmer_sufficiency (p : ℕ) (w : 1 < p) : lucas_lehmer_test p → (mersenne p).prime :=
begin
  let p' := p - 2,
  have z : p = p' + 2 := (nat.sub_eq_iff_eq_add w).mp rfl,
  have w : 1 < p' + 2 := (nat.lt_of_sub_eq_succ rfl),
  contrapose,
  intros a t,
  rw z at a,
  rw z at t,
  have h₁ := order_ineq p' t,
  have h₂ := nat.min_fac_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,
end

-- 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) dec_trivial

-- Next we use `norm_num` to calculate each `s p i`.
namespace lucas_lehmer
open tactic

meta instance nat_pexpr : has_to_pexpr ℕ := ⟨pexpr.of_expr ∘ λ n, reflect n⟩
meta instance int_pexpr : has_to_pexpr ℤ := ⟨pexpr.of_expr ∘ λ n, reflect n⟩

lemma s_mod_succ {p a i b c}
  (h1 : (2^p - 1 : ℤ) = a)
  (h2 : s_mod p i = b)
  (h3 : (b * b - 2) % a = c) :
  s_mod p (i+1) = c :=
by { dsimp [s_mod, mersenne], rw [h1, h2, sq, h3] }

/--
Given a goal of the form `lucas_lehmer_test p`,
attempt to do the calculation using `norm_num` to certify each step.
-/
meta def run_test : tactic unit :=
do `(lucas_lehmer_test %%p) ← target,
   `[dsimp [lucas_lehmer_test]],
   `[rw lucas_lehmer.residue_eq_zero_iff_s_mod_eq_zero, swap, norm_num],
   p ← eval_expr ℕ p,
   -- Calculate the candidate Mersenne prime
   let M : ℤ := 2^p - 1,
   t ← to_expr ``(2^%%p - 1 = %%M),
   v ← to_expr ``(by norm_num : 2^%%p - 1 = %%M),
   w ← assertv `w t v,
   -- Unfortunately this creates something like `w : 2^5 - 1 = int.of_nat 31`.
   -- We could make a better `has_to_pexpr ℤ` instance, or just:
   `[simp only [int.coe_nat_zero, int.coe_nat_succ,
       int.of_nat_eq_coe, zero_add, int.coe_nat_bit1] at w],
   -- base case
   t ← to_expr ``(s_mod %%p 0 = 4),
   v ← to_expr ``(by norm_num [lucas_lehmer.s_mod] : s_mod %%p 0 = 4),
   h ← assertv `h t v,
   -- step case, repeated p-2 times
   iterate_exactly (p-2) `[replace h := lucas_lehmer.s_mod_succ w h (by { norm_num, refl })],
   -- now close the goal
   h ← get_local `h,
   exact h

end lucas_lehmer

/-- We verify that the tactic works to prove `127.prime`. -/
example : (mersenne 7).prime := lucas_lehmer_sufficiency _ (by norm_num) (by 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!
-/

lemma modeq_mersenne (n k : ℕ) : k ≡ ((k / 2^n) + (k % 2^n)) [MOD 2^n - 1] :=
-- See https://leanprover.zulipchat.com/#narrow/stream/113489-new-members/topic/help.20finding.20a.20lemma/near/177698446
begin
  conv in k { rw ← nat.div_add_mod k (2^n) },
  refine nat.modeq.modeq_add _ (by refl),
  conv { congr, skip, skip, rw ← one_mul (k/2^n) },
  refine nat.modeq.modeq_mul _ (by refl),
  symmetry,
  rw [nat.modeq.modeq_iff_dvd, int.coe_nat_sub],
  exact pow_pos (show 0 < 2, from dec_trivial) _
end

-- 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`.


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tim Baumann, Stephen Morgan, Scott Morrison, Floris van Doorn

Defines natural transformations between functors.

Introduces notations
  `τ.app X` for the components of natural transformations,
  `F ⟶ G` for the type of natural transformations between functors `F` and `G`,
  `σ ≫ τ` for vertical compositions, and
  `σ ◫ τ` for horizontal compositions.
-/
import category_theory.functor

namespace category_theory

-- declare the `v`'s first; see `category_theory.category` for an explanation
universes v₁ v₂ v₃ v₄ u₁ u₂ u₃ u₄

variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]

/--
`nat_trans F G` represents a natural transformation between functors `F` and `G`.

The field `app` provides the components of the natural transformation.

Naturality is expressed by `α.naturality_lemma`.
-/
@[ext]
structure nat_trans (F G : C ⥤ D) : Type (max u₁ v₂) :=
(app : Π X : C, (F.obj X) ⟶ (G.obj X))
(naturality' : ∀ {{X Y : C}} (f : X ⟶ Y), (F.map f) ≫ (app Y) = (app X) ≫ (G.map f) . obviously)

restate_axiom nat_trans.naturality'
-- Rather arbitrarily, we say that the 'simpler' form is
-- components of natural transfomations moving earlier.
attribute [simp, reassoc] nat_trans.naturality

lemma congr_app {F G : C ⥤ D} {α β : nat_trans F G} (h : α = β) (X : C) : α.app X = β.app X :=
congr_fun (congr_arg nat_trans.app h) X

namespace nat_trans

/-- `nat_trans.id F` is the identity natural transformation on a functor `F`. -/
protected def id (F : C ⥤ D) : nat_trans F F :=
{ app := λ X, 𝟙 (F.obj X) }

@[simp] lemma id_app' (F : C ⥤ D) (X : C) : (nat_trans.id F).app X = 𝟙 (F.obj X) := rfl

instance (F : C ⥤ D) : inhabited (nat_trans F F) := ⟨nat_trans.id F⟩

open category
open category_theory.functor

section
variables {F G H I : C ⥤ D}

/-- `vcomp α β` is the vertical compositions of natural transformations. -/
def vcomp (α : nat_trans F G) (β : nat_trans G H) : nat_trans F H :=
{ app := λ X, (α.app X) ≫ (β.app X) }

-- functor_category will rewrite (vcomp α β) to (α ≫ β), so this is not a
-- suitable simp lemma.  We will declare the variant vcomp_app' there.
lemma vcomp_app (α : nat_trans F G) (β : nat_trans G H) (X : C) :
  (vcomp α β).app X = (α.app X) ≫ (β.app X) := rfl

end

/--
The diagram
    F(f)      F(g)      F(h)
F X ----> F Y ----> F U ----> F U
 |         |         |         |
 | α(X)    | α(Y)    | α(U)    | α(V)
 v         v         v         v
G X ----> G Y ----> G U ----> G V
    G(f)      G(g)      G(h)
commutes.
-/
example {F G : C ⥤ D} (α : nat_trans F G) {X Y U V : C} (f : X ⟶ Y) (g : Y ⟶ U) (h : U ⟶ V) :
  α.app X ≫ G.map f ≫ G.map g ≫ G.map h =
    F.map f ≫ F.map g ≫ F.map h ≫ α.app V :=
by simp

end nat_trans

end category_theory


/-
Copyright (c) 2021 Thomas Browning. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning
-/
import algebra.big_operators.order
import combinatorics.hall.basic
import data.fintype.card
import set_theory.fincard

/-!
# Configurations of Points and lines
This file introduces abstract configurations of points and lines, and proves some basic properties.

## Main definitions
* `configuration.nondegenerate`: Excludes certain degenerate configurations,
  and imposes uniqueness of intersection points.
* `configuration.has_points`: A nondegenerate configuration in which
  every pair of lines has an intersection point.
* `configuration.has_lines`:  A nondegenerate configuration in which
  every pair of points has a line through them.
* `configuration.line_count`: The number of lines through a given point.
* `configuration.point_count`: The number of lines through a given line.

## Main statements
* `configuration.has_lines.card_le`: `has_lines` implies `|P| ≤ |L|`.
* `configuration.has_points.card_le`: `has_points` implies `|L| ≤ |P|`.
* `configuration.has_lines.has_points`: `has_lines` and `|P| = |L|` implies `has_points`.
* `configuration.has_points.has_lines`: `has_points` and `|P| = |L|` implies `has_lines`.
Together, these four statements say that any two of the following properties imply the third:
(a) `has_lines`, (b) `has_points`, (c) `|P| = |L|`.

-/

open_locale big_operators

namespace configuration

universe u

variables (P L : Type u) [has_mem P L]

/-- A type synonym. -/
def dual := P

instance [this : inhabited P] : inhabited (dual P) := this

instance [this : fintype P] : fintype (dual P) := this

instance : has_mem (dual L) (dual P) :=
⟨function.swap (has_mem.mem : P → L → Prop)⟩

/-- A configuration is nondegenerate if:
  1) there does not exist a line that passes through all of the points,
  2) there does not exist a point that is on all of the lines,
  3) there is at most one line through any two points,
  4) any two lines have at most one intersection point.
  Conditions 3 and 4 are equivalent. -/
class nondegenerate : Prop :=
(exists_point : ∀ l : L, ∃ p, p ∉ l)
(exists_line : ∀ p, ∃ l : L, p ∉ l)
(eq_or_eq : ∀ {p₁ p₂ : P} {l₁ l₂ : L}, p₁ ∈ l₁ → p₂ ∈ l₁ → p₁ ∈ l₂ → p₂ ∈ l₂ → p₁ = p₂ ∨ l₁ = l₂)

/-- A nondegenerate configuration in which every pair of lines has an intersection point. -/
class has_points extends nondegenerate P L : Type u :=
(mk_point : ∀ {l₁ l₂ : L} (h : l₁ ≠ l₂), P)
(mk_point_ax : ∀ {l₁ l₂ : L} (h : l₁ ≠ l₂), mk_point h ∈ l₁ ∧ mk_point h ∈ l₂)

/-- A nondegenerate configuration in which every pair of points has a line through them. -/
class has_lines extends nondegenerate P L : Type u :=
(mk_line : ∀ {p₁ p₂ : P} (h : p₁ ≠ p₂), L)
(mk_line_ax : ∀ {p₁ p₂ : P} (h : p₁ ≠ p₂), p₁ ∈ mk_line h ∧ p₂ ∈ mk_line h)

open nondegenerate has_points has_lines

instance [nondegenerate P L] : nondegenerate (dual L) (dual P) :=
{ exists_point := @exists_line P L _ _,
  exists_line := @exists_point P L _ _,
  eq_or_eq := λ l₁ l₂ p₁ p₂ h₁ h₂ h₃ h₄, (@eq_or_eq P L _ _ p₁ p₂ l₁ l₂ h₁ h₃ h₂ h₄).symm }

instance [has_points P L] : has_lines (dual L) (dual P) :=
{ mk_line := @mk_point P L _ _,
  mk_line_ax := λ _ _, mk_point_ax }

instance [has_lines P L] : has_points (dual L) (dual P) :=
{ mk_point := @mk_line P L _ _,
  mk_point_ax := λ _ _, mk_line_ax }

lemma has_points.exists_unique_point [has_points P L] (l₁ l₂ : L) (hl : l₁ ≠ l₂) :
  ∃! p, p ∈ l₁ ∧ p ∈ l₂ :=
⟨mk_point hl, mk_point_ax hl,
  λ p hp, (eq_or_eq hp.1 (mk_point_ax hl).1 hp.2 (mk_point_ax hl).2).resolve_right hl⟩

lemma has_lines.exists_unique_line [has_lines P L] (p₁ p₂ : P) (hp : p₁ ≠ p₂) :
  ∃! l : L, p₁ ∈ l ∧ p₂ ∈ l :=
has_points.exists_unique_point (dual L) (dual P) p₁ p₂ hp

variables {P L}

/-- If a nondegenerate configuration has at least as many points as lines, then there exists
  an injective function `f` from lines to points, such that `f l` does not lie on `l`. -/
lemma nondegenerate.exists_injective_of_card_le [nondegenerate P L]
  [fintype P] [fintype L] (h : fintype.card L ≤ fintype.card P) :
  ∃ f : L → P, function.injective f ∧ ∀ l, (f l) ∉ l :=
begin
  classical,
  let t : L → finset P := λ l, (set.to_finset {p | p ∉ l}),
  suffices : ∀ s : finset L, s.card ≤ (s.bUnion t).card, -- Hall's marriage theorem
  { obtain ⟨f, hf1, hf2⟩ := (finset.all_card_le_bUnion_card_iff_exists_injective t).mp this,
    exact ⟨f, hf1, λ l, set.mem_to_finset.mp (hf2 l)⟩ },
  intro s,
  by_cases hs₀ : s.card = 0, -- If `s = ∅`, then `s.card = 0 ≤ (s.bUnion t).card`
  { simp_rw [hs₀, zero_le] },
  by_cases hs₁ : s.card = 1, -- If `s = {l}`, then pick a point `p ∉ l`
  { obtain ⟨l, rfl⟩ := finset.card_eq_one.mp hs₁,
    obtain ⟨p, hl⟩ := exists_point l,
    rw [finset.card_singleton, finset.singleton_bUnion, nat.one_le_iff_ne_zero],
    exact finset.card_ne_zero_of_mem (set.mem_to_finset.mpr hl) },
  suffices : (s.bUnion t)ᶜ.card ≤ sᶜ.card, -- Rephrase in terms of complements (uses `h`)
  { rw [finset.card_compl, finset.card_compl, tsub_le_iff_left] at this,
    replace := h.trans this,
    rwa [←add_tsub_assoc_of_le s.card_le_univ, le_tsub_iff_left
      (le_add_left s.card_le_univ), add_le_add_iff_right] at this },
  have hs₂ : (s.bUnion t)ᶜ.card ≤ 1, -- At most one line through two points of `s`
  { refine finset.card_le_one_iff.mpr (λ p₁ p₂ hp₁ hp₂, _),
    simp_rw [finset.mem_compl, finset.mem_bUnion, exists_prop, not_exists, not_and,
      set.mem_to_finset, set.mem_set_of_eq, not_not] at hp₁ hp₂,
    obtain ⟨l₁, l₂, hl₁, hl₂, hl₃⟩ :=
    finset.one_lt_card_iff.mp (nat.one_lt_iff_ne_zero_and_ne_one.mpr ⟨hs₀, hs₁⟩),
    exact (eq_or_eq (hp₁ l₁ hl₁) (hp₂ l₁ hl₁) (hp₁ l₂ hl₂) (hp₂ l₂ hl₂)).resolve_right hl₃ },
  by_cases hs₃ : sᶜ.card = 0,
  { rw [hs₃, nat.le_zero_iff],
    rw [finset.card_compl, tsub_eq_zero_iff_le, has_le.le.le_iff_eq (finset.card_le_univ _),
        eq_comm, finset.card_eq_iff_eq_univ, hs₃, finset.eq_univ_iff_forall] at hs₃ ⊢,
    exact λ p, exists.elim (exists_line p) -- If `s = univ`, then show `s.bUnion t = univ`
      (λ l hl, finset.mem_bUnion.mpr ⟨l, finset.mem_univ l, set.mem_to_finset.mpr hl⟩) },
  { exact hs₂.trans (nat.one_le_iff_ne_zero.mpr hs₃) }, -- If `s < univ`, then consequence of `hs₂`
end

variables {P} (L)

/-- Number of points on a given line. -/
noncomputable def line_count (p : P) : ℕ := nat.card {l : L // p ∈ l}

variables (P) {L}

/-- Number of lines through a given point. -/
noncomputable def point_count (l : L) : ℕ := nat.card {p : P // p ∈ l}

variables (P L)

lemma sum_line_count_eq_sum_point_count [fintype P] [fintype L] :
  ∑ p : P, line_count L p = ∑ l : L, point_count P l :=
begin
  classical,
  simp only [line_count, point_count, nat.card_eq_fintype_card, ←fintype.card_sigma],
  apply fintype.card_congr,
  calc (Σ p, {l : L // p ∈ l}) ≃ {x : P × L // x.1 ∈ x.2} :
    (equiv.subtype_prod_equiv_sigma_subtype (∈)).symm
  ... ≃ {x : L × P // x.2 ∈ x.1} : (equiv.prod_comm P L).subtype_equiv (λ x, iff.rfl)
  ... ≃ (Σ l, {p // p ∈ l}) : equiv.subtype_prod_equiv_sigma_subtype (λ (l : L) (p : P), p ∈ l),
end

variables {P L}

lemma has_lines.point_count_le_line_count [has_lines P L] {p : P} {l : L} (h : p ∉ l)
  [fintype {l : L // p ∈ l}] : point_count P l ≤ line_count L p :=
begin
  by_cases hf : infinite {p : P // p ∈ l},
  { exactI (le_of_eq nat.card_eq_zero_of_infinite).trans (zero_le (line_count L p)) },
  haveI := fintype_of_not_infinite hf,
  rw [line_count, point_count, nat.card_eq_fintype_card, nat.card_eq_fintype_card],
  have : ∀ p' : {p // p ∈ l}, p ≠ p' := λ p' hp', h ((congr_arg (∈ l) hp').mpr p'.2),
  exact fintype.card_le_of_injective (λ p', ⟨mk_line (this p'), (mk_line_ax (this p')).1⟩)
    (λ p₁ p₂ hp, subtype.ext ((eq_or_eq p₁.2 p₂.2 (mk_line_ax (this p₁)).2
      ((congr_arg _ (subtype.ext_iff.mp hp)).mpr (mk_line_ax (this p₂)).2)).resolve_right
        (λ h', (congr_arg _ h').mp h (mk_line_ax (this p₁)).1))),
end

lemma has_points.line_count_le_point_count [has_points P L] {p : P} {l : L} (h : p ∉ l)
  [hf : fintype {p : P // p ∈ l}] : line_count L p ≤ point_count P l :=
@has_lines.point_count_le_line_count (dual L) (dual P) _ _ l p h hf

variables (P L)

/-- If a nondegenerate configuration has a unique line through any two points, then `|P| ≤ |L|`. -/
lemma has_lines.card_le [has_lines P L] [fintype P] [fintype L] :
  fintype.card P ≤ fintype.card L :=
begin
  classical,
  by_contradiction hc₂,
  obtain ⟨f, hf₁, hf₂⟩ := nondegenerate.exists_injective_of_card_le (le_of_not_le hc₂),
  have := calc ∑ p, line_count L p = ∑ l, point_count P l : sum_line_count_eq_sum_point_count P L
  ... ≤ ∑ l, line_count L (f l) :
    finset.sum_le_sum (λ l hl, has_lines.point_count_le_line_count (hf₂ l))
  ... = ∑ p in finset.univ.image f, line_count L p :
    finset.sum_bij (λ l hl, f l) (λ l hl, finset.mem_image_of_mem f hl) (λ l hl, rfl)
      (λ l₁ l₂ hl₁ hl₂ hl₃, hf₁ hl₃) (λ p, by simp_rw [finset.mem_image, eq_comm, imp_self])
  ... < ∑ p, line_count L p : _,
  { exact lt_irrefl _ this },
  { obtain ⟨p, hp⟩ := not_forall.mp (mt (fintype.card_le_of_surjective f) hc₂),
    refine finset.sum_lt_sum_of_subset ((finset.univ.image f).subset_univ) (finset.mem_univ p)
      _ _ (λ p hp₁ hp₂, zero_le (line_count L p)),
    { simpa only [finset.mem_image, exists_prop, finset.mem_univ, true_and] },
    { rw [line_count, nat.card_eq_fintype_card, fintype.card_pos_iff],
      obtain ⟨l, hl⟩ := @exists_line P L _ _ p,
      exact let this := not_exists.mp hp l in ⟨⟨mk_line this, (mk_line_ax this).2⟩⟩ } },
end

/-- If a nondegenerate configuration has a unique point on any two lines, then `|L| ≤ |P|`. -/
lemma has_points.card_le [has_points P L] [fintype P] [fintype L] :
  fintype.card L ≤ fintype.card P :=
@has_lines.card_le (dual L) (dual P) _ _ _ _

variables {P L}

lemma has_lines.exists_bijective_of_card_eq [has_lines P L]
  [fintype P] [fintype L] (h : fintype.card P = fintype.card L) :
  ∃ f : L → P, function.bijective f ∧ ∀ l, point_count P l = line_count L (f l) :=
begin
  classical,
  obtain ⟨f, hf1, hf2⟩ := nondegenerate.exists_injective_of_card_le (ge_of_eq h),
  have hf3 := (fintype.bijective_iff_injective_and_card f).mpr ⟨hf1, h.symm⟩,
  refine ⟨f, hf3, λ l, (finset.sum_eq_sum_iff_of_le
    (by exact λ l hl, has_lines.point_count_le_line_count (hf2 l))).mp
      ((sum_line_count_eq_sum_point_count P L).symm.trans ((finset.sum_bij (λ l hl, f l)
        (λ l hl, finset.mem_univ (f l)) (λ l hl, refl (line_count L (f l)))
          (λ l₁ l₂ hl₁ hl₂ hl, hf1 hl) (λ p hp, _)).symm)) l (finset.mem_univ l)⟩,
  obtain ⟨l, rfl⟩ := hf3.2 p,
  exact ⟨l, finset.mem_univ l, rfl⟩,
end

lemma has_lines.line_count_eq_point_count [has_lines P L] [fintype P] [fintype L]
  (hPL : fintype.card P = fintype.card L) {p : P} {l : L} (hpl : p ∉ l) :
  line_count L p = point_count P l :=
begin
  classical,
  obtain ⟨f, hf1, hf2⟩ := has_lines.exists_bijective_of_card_eq hPL,
  let s : finset (P × L) := set.to_finset {i | i.1 ∈ i.2},
  have step1 : ∑ i : P × L, line_count L i.1 = ∑ i : P × L, point_count P i.2,
  { rw [←finset.univ_product_univ, finset.sum_product_right, finset.sum_product],
    simp_rw [finset.sum_const, finset.card_univ, hPL, sum_line_count_eq_sum_point_count] },
  have step2 : ∑ i in s, line_count L i.1 = ∑ i in s, point_count P i.2,
  { rw [s.sum_finset_product finset.univ (λ p, set.to_finset {l | p ∈ l})],
    rw [s.sum_finset_product_right finset.univ (λ l, set.to_finset {p | p ∈ l})],
    refine (finset.sum_bij (λ l hl, f l) (λ l hl, finset.mem_univ (f l)) (λ l hl, _)
      (λ _ _ _ _ h, hf1.1 h) (λ p hp, _)).symm,
    { simp_rw [finset.sum_const, set.to_finset_card, ←nat.card_eq_fintype_card],
      change (point_count P l) • (point_count P l) = (line_count L (f l)) • (line_count L (f l)),
      rw hf2 },
    { obtain ⟨l, hl⟩ := hf1.2 p,
      exact ⟨l, finset.mem_univ l, hl.symm⟩ },
    all_goals { simp_rw [finset.mem_univ, true_and, set.mem_to_finset], exact λ p, iff.rfl } },
  have step3 : ∑ i in sᶜ, line_count L i.1 = ∑ i in sᶜ, point_count P i.2,
  { rwa [←s.sum_add_sum_compl, ←s.sum_add_sum_compl, step2, add_left_cancel_iff] at step1 },
  rw ← set.to_finset_compl at step3,
  exact ((finset.sum_eq_sum_iff_of_le (by exact λ i hi, has_lines.point_count_le_line_count
    (set.mem_to_finset.mp hi))).mp step3.symm (p, l) (set.mem_to_finset.mpr hpl)).symm,
end

lemma has_points.line_count_eq_point_count [has_points P L] [fintype P] [fintype L]
  (hPL : fintype.card P = fintype.card L) {p : P} {l : L} (hpl : p ∉ l) :
  line_count L p = point_count P l :=
(@has_lines.line_count_eq_point_count (dual L) (dual P) _ _  _ _ hPL.symm l p hpl).symm

/-- If a nondegenerate configuration has a unique line through any two points, and if `|P| = |L|`,
  then there is a unique point on any two lines. -/
noncomputable def has_lines.has_points [has_lines P L] [fintype P] [fintype L]
  (h : fintype.card P = fintype.card L) : has_points P L :=
let this : ∀ l₁ l₂ : L, l₁ ≠ l₂ → ∃ p : P, p ∈ l₁ ∧ p ∈ l₂ := λ l₁ l₂ hl, begin
  classical,
  obtain ⟨f, hf1, hf2⟩ := has_lines.exists_bijective_of_card_eq h,
  haveI : nontrivial L := ⟨⟨l₁, l₂, hl⟩⟩,
  haveI := fintype.one_lt_card_iff_nontrivial.mp ((congr_arg _ h).mpr fintype.one_lt_card),
  have h₁ : ∀ p : P, 0 < line_count L p := λ p, exists.elim (exists_ne p) (λ q hq, (congr_arg _
    nat.card_eq_fintype_card).mpr (fintype.card_pos_iff.mpr ⟨⟨mk_line hq, (mk_line_ax hq).2⟩⟩)),
  have h₂ : ∀ l : L, 0 < point_count P l := λ l, (congr_arg _ (hf2 l)).mpr (h₁ (f l)),
  obtain ⟨p, hl₁⟩ := fintype.card_pos_iff.mp ((congr_arg _ nat.card_eq_fintype_card).mp (h₂ l₁)),
  by_cases hl₂ : p ∈ l₂, exact ⟨p, hl₁, hl₂⟩,
  have key' : fintype.card {q : P // q ∈ l₂} = fintype.card {l : L // p ∈ l},
  { exact ((has_lines.line_count_eq_point_count h hl₂).trans nat.card_eq_fintype_card).symm.trans
    nat.card_eq_fintype_card, },
  have : ∀ q : {q // q ∈ l₂}, p ≠ q := λ q hq, hl₂ ((congr_arg (∈ l₂) hq).mpr q.2),
  let f : {q : P // q ∈ l₂} → {l : L // p ∈ l} := λ q, ⟨mk_line (this q), (mk_line_ax (this q)).1⟩,
  have hf : function.injective f := λ q₁ q₂ hq, subtype.ext ((eq_or_eq q₁.2 q₂.2
    (mk_line_ax (this q₁)).2 ((congr_arg _ (subtype.ext_iff.mp hq)).mpr (mk_line_ax
      (this q₂)).2)).resolve_right (λ h, (congr_arg _ h).mp hl₂ (mk_line_ax (this q₁)).1)),
  have key' := ((fintype.bijective_iff_injective_and_card f).mpr ⟨hf, key'⟩).2,
  obtain ⟨q, hq⟩ := key' ⟨l₁, hl₁⟩,
  exact ⟨q, (congr_arg _ (subtype.ext_iff.mp hq)).mp (mk_line_ax (this q)).2, q.2⟩,
end in
{ mk_point := λ l₁ l₂ hl, classical.some (this l₁ l₂ hl),
  mk_point_ax := λ l₁ l₂ hl, classical.some_spec (this l₁ l₂ hl) }

/-- If a nondegenerate configuration has a unique point on any two lines, and if `|P| = |L|`,
  then there is a unique line through any two points. -/
noncomputable def has_points.has_lines [has_points P L] [fintype P] [fintype L]
  (h : fintype.card P = fintype.card L) : has_lines P L :=
let this := @has_lines.has_points (dual L) (dual P) _ _ _ _ h.symm in
{ mk_line := this.mk_point,
  mk_line_ax := this.mk_point_ax }

variables (P L)

/-- A projective plane is a nondegenerate configuration in which every pair of lines has
  an intersection point, every pair of points has a line through them,
  and which has three points in general position. -/
class projective_plane extends nondegenerate P L : Type u :=
(mk_point : ∀ {l₁ l₂ : L} (h : l₁ ≠ l₂), P)
(mk_point_ax : ∀ {l₁ l₂ : L} (h : l₁ ≠ l₂), mk_point h ∈ l₁ ∧ mk_point h ∈ l₂)
(mk_line : ∀ {p₁ p₂ : P} (h : p₁ ≠ p₂), L)
(mk_line_ax : ∀ {p₁ p₂ : P} (h : p₁ ≠ p₂), p₁ ∈ mk_line h ∧ p₂ ∈ mk_line h)
(exists_config : ∃ (p₁ p₂ p₃ : P) (l₁ l₂ l₃ : L), p₁ ∉ l₂ ∧ p₁ ∉ l₃ ∧
  p₂ ∉ l₁ ∧ p₂ ∈ l₂ ∧ p₂ ∈ l₃ ∧ p₃ ∉ l₁ ∧ p₃ ∈ l₂ ∧ p₃ ∉ l₃)

namespace projective_plane

@[priority 100] -- see Note [lower instance priority]
instance has_points [h : projective_plane P L] : has_points P L := { .. h }

@[priority 100] -- see Note [lower instance priority]
instance has_lines [h : projective_plane P L] : has_lines P L := { .. h }

instance [projective_plane P L] : projective_plane (dual L) (dual P) :=
{ mk_line := @mk_point P L _ _,
  mk_line_ax := λ _ _, mk_point_ax,
  mk_point := @mk_line P L _ _,
  mk_point_ax := λ _ _, mk_line_ax,
  exists_config := by
  { obtain ⟨p₁, p₂, p₃, l₁, l₂, l₃, h₁₂, h₁₃, h₂₁, h₂₂, h₂₃, h₃₁, h₃₂, h₃₃⟩ :=
    @exists_config P L _ _,
    exact ⟨l₁, l₂, l₃, p₁, p₂, p₃, h₂₁, h₃₁, h₁₂, h₂₂, h₃₂, h₁₃, h₂₃, h₃₃⟩ },
  .. dual.nondegenerate P L }

/-- The order of a projective plane is one less than the number of lines through an arbitrary point.
Equivalently, it is one less than the number of points on an arbitrary line. -/
noncomputable def order [projective_plane P L] : ℕ :=
line_count L (classical.some (@exists_config P L _ _)) - 1

variables [fintype P] [fintype L]

lemma card_points_eq_card_lines [projective_plane P L] : fintype.card P = fintype.card L :=
le_antisymm (has_lines.card_le P L) (has_points.card_le P L)

variables {P} (L)

lemma line_count_eq_line_count [projective_plane P L] (p q : P) :
  line_count L p = line_count L q :=
begin
  obtain ⟨p₁, p₂, p₃, l₁, l₂, l₃, h₁₂, h₁₃, h₂₁, h₂₂, h₂₃, h₃₁, h₃₂, h₃₃⟩ := exists_config,
  have h := card_points_eq_card_lines P L,
  let n := line_count L p₂,
  have hp₂ : line_count L p₂ = n := rfl,
  have hl₁ : point_count P l₁ = n := (has_lines.line_count_eq_point_count h h₂₁).symm.trans hp₂,
  have hp₃ : line_count L p₃ = n := (has_lines.line_count_eq_point_count h h₃₁).trans hl₁,
  have hl₃ : point_count P l₃ = n := (has_lines.line_count_eq_point_count h h₃₃).symm.trans hp₃,
  have hp₁ : line_count L p₁ = n := (has_lines.line_count_eq_point_count h h₁₃).trans hl₃,
  have hl₂ : point_count P l₂ = n := (has_lines.line_count_eq_point_count h h₁₂).symm.trans hp₁,
  suffices : ∀ p : P, line_count L p = n, { exact (this p).trans (this q).symm },
  refine λ p, or_not.elim (λ h₂, _) (λ h₂, (has_lines.line_count_eq_point_count h h₂).trans hl₂),
  refine or_not.elim (λ h₃, _) (λ h₃, (has_lines.line_count_eq_point_count h h₃).trans hl₃),
  rwa (eq_or_eq h₂ h₂₂ h₃ h₂₃).resolve_right (λ h, h₃₃ ((congr_arg (has_mem.mem p₃) h).mp h₃₂)),
end

variables (P) {L}

lemma point_count_eq_point_count [projective_plane P L] (l m : L) :
  point_count P l = point_count P m :=
line_count_eq_line_count (dual P) l m

variables {P L}

lemma line_count_eq_point_count [projective_plane P L] (p : P) (l : L) :
  line_count L p = point_count P l :=
exists.elim (exists_point l) (λ q hq, (line_count_eq_line_count L p q).trans
  (has_lines.line_count_eq_point_count (card_points_eq_card_lines P L) hq))

variables (P L)

lemma dual.order [projective_plane P L] : order (dual L) (dual P) = order P L :=
congr_arg (λ n, n - 1) (line_count_eq_point_count _ _)

variables {P} (L)

lemma line_count_eq [projective_plane P L] (p : P) : line_count L p = order P L + 1 :=
begin
  classical,
  obtain ⟨q, -, -, l, -, -, -, -, h, -⟩ := classical.some_spec (@exists_config P L _ _),
  rw [order, line_count_eq_line_count L p q, line_count_eq_line_count L (classical.some _) q,
      line_count, nat.card_eq_fintype_card, nat.sub_add_cancel],
  exact fintype.card_pos_iff.mpr ⟨⟨l, h⟩⟩,
end

variables (P) {L}

lemma point_count_eq [projective_plane P L] (l : L) : point_count P l = order P L + 1 :=
(line_count_eq (dual P) l).trans (congr_arg (λ n, n + 1) (dual.order P L))

variables (P L)

lemma one_lt_order [projective_plane P L] : 1 < order P L :=
begin
  obtain ⟨p₁, p₂, p₃, l₁, l₂, l₃, -, -, h₂₁, h₂₂, h₂₃, h₃₁, h₃₂, h₃₃⟩ := @exists_config P L _ _,
  classical,
  rw [←add_lt_add_iff_right, ←point_count_eq, point_count, nat.card_eq_fintype_card],
  simp_rw [fintype.two_lt_card_iff, ne, subtype.ext_iff],
  have h := mk_point_ax (λ h, h₂₁ ((congr_arg _ h).mpr h₂₂)),
  exact ⟨⟨mk_point _, h.2⟩, ⟨p₂, h₂₂⟩, ⟨p₃, h₃₂⟩,
    ne_of_mem_of_not_mem h.1 h₂₁, ne_of_mem_of_not_mem h.1 h₃₁, ne_of_mem_of_not_mem h₂₃ h₃₃⟩,
end

variables {P} (L)

lemma two_lt_line_count [projective_plane P L] (p : P) : 2 < line_count L p :=
by simpa only [line_count_eq L p, nat.succ_lt_succ_iff] using one_lt_order P L

variables (P) {L}

lemma two_lt_point_count [projective_plane P L] (l : L) : 2 < point_count P l :=
by simpa only [point_count_eq P l, nat.succ_lt_succ_iff] using one_lt_order P L

variables (P) (L)

lemma card_points [projective_plane P L] : fintype.card P = order P L ^ 2 + order P L + 1 :=
begin
  let p : P := (classical.some (@exists_config P L _ _)),
  let ϕ : {q // q ≠ p} ≃ Σ (l : {l : L // p ∈ l}), {q // q ∈ l.1 ∧ q ≠ p} :=
  { to_fun := λ q, ⟨⟨mk_line q.2, (mk_line_ax q.2).2⟩, q, (mk_line_ax q.2).1, q.2⟩,
    inv_fun := λ lq, ⟨lq.2, lq.2.2.2⟩,
    left_inv := λ q, subtype.ext rfl,
    right_inv := λ lq, sigma.subtype_ext (subtype.ext ((eq_or_eq (mk_line_ax lq.2.2.2).1
      (mk_line_ax lq.2.2.2).2 lq.2.2.1 lq.1.2).resolve_left lq.2.2.2)) rfl },
  classical,
  have h1 : fintype.card {q // q ≠ p} + 1 = fintype.card P,
  { apply (eq_tsub_iff_add_eq_of_le (nat.succ_le_of_lt (fintype.card_pos_iff.mpr ⟨p⟩))).mp,
    convert (fintype.card_subtype_compl).trans (congr_arg _ (fintype.card_subtype_eq p)) },
  have h2 : ∀ l : {l : L // p ∈ l}, fintype.card {q // q ∈ l.1 ∧ q ≠ p} = order P L,
  { intro l,
    rw [←fintype.card_congr (equiv.subtype_subtype_equiv_subtype_inter _ _),
        fintype.card_subtype_compl, ←nat.card_eq_fintype_card],
    refine tsub_eq_of_eq_add ((point_count_eq P l.1).trans _),
    rw ← fintype.card_subtype_eq (⟨p, l.2⟩ : {q : P // q ∈ l.1}),
    simp_rw subtype.ext_iff_val },
  simp_rw [←h1, fintype.card_congr ϕ, fintype.card_sigma, h2, finset.sum_const, finset.card_univ],
  rw [←nat.card_eq_fintype_card, ←line_count, line_count_eq, smul_eq_mul, nat.succ_mul, sq],
end

lemma card_lines [projective_plane P L] : fintype.card L = order P L ^ 2 + order P L + 1 :=
(card_points (dual L) (dual P)).trans (congr_arg (λ n, n ^ 2 + n + 1) (dual.order P L))

end projective_plane

end configuration


-- https://www.youtube.com/watch?v=9Efsz2hIpxE
-- deriving some results of the theory of fields, in Lean.

namespace hidden

class myfield (α : Type)
extends has_mul α, has_inv α, has_add α, has_neg α, has_zero α, has_one α :=
-- this axiom can be deduced, so we prove it as a theorem, near the
-- end.
-- (A1 (a b: α): a + b = b + a)
(A2 (a b c: α): a + (b + c) =  (a + b) + c)
(A3 (a: α): a + 0 = a)
(A4 (a: α): a + (-a) = 0)
(M1 (a b: α): a * b = b * a)
(M2 (a b c: α): a * (b * c) = (a * b) * c)
(M3 (a: α): a * 1 = a)
(M4 (a: α): a ≠ 0 → a * (a⁻¹) = 1)
(D (a b c: α): a * (b + c) = a * b + a * c)
(Z: (0: α) ≠ 1)

namespace myfield

variables {α: Type} [myfield α]

variables (a b c x y: α)

-- "Axiom" A1 is proved as Theorem A1.
-- Problems 1-12 are labelled as "theorem p_".
-- There are also some lemmas.
-- This somewhat obscure naming scheme is used for compatibility with the video.

lemma Z': (1: α) ≠ 0 :=
begin
  from (λ h, Z h.symm),
end

lemma l1: a + b = 0 → b + a = 0 :=
begin
  assume h,
  rw ←A4 b,
  conv {
    to_rhs,
    congr,
    rw ←A3 b,
    rw ←h,
  },
  rw ←A2 b (a + b) (-b),
  rw ←A2 a b (-b),
  rw A4 b,
  rw A3 a,
end

lemma l2: (-a) + a = 0 :=
begin
  rw l1 a (-a) (A4 a),
end

lemma l3: 0 + a = a :=
begin
  rw ←A4 a,
  rw ←A2 a (-a) a,
  rw l2 a,
  rw A3 a,
end

lemma l4: a + b = 0 → a + c = 0 → b = c :=
begin
  assume hab hac,
  rw ←l3 c,
  rw ←l1 a b hab,
  rw ←A2 b a c,
  rw hac,
  rw A3 b,
end

lemma l5: a + b = a → b = 0 :=
begin
  assume haba,
  rw ←l2 a,
  conv {
    to_rhs,
    congr, skip,
    rw ←haba,
  },
  rw A2 (-a) a b,
  rw l2 a,
  rw l3 b,
end

lemma l6: (∃ a: α, a + x = a) → x = 0 :=
begin
  assume h,
  cases h with a ha,
  rw ←l3 x,
  rw ←l2 a,
  rw ←A2 (-a) a x,
  rw ha,
end

lemma l7: -(a + b) = -b + (-a) :=
begin
  apply l4 (a + b) (-(a + b)) (-b + -a) (A4 (a + b)),
  rw ←A2 a b (-b + -a),
  rw A2 b (-b) (-a),
  rw A4 b,
  rw l3 (-a),
  rw A4 a,
end

lemma l8: (∃ a, a ≠ 0 ∧ a * x = a) → x = 1 :=
begin
  assume h,
  cases h with a ha,
  rw ←M4 a ha.left,
  conv {
    to_rhs,
    congr,
    rw ←ha.right,
  },
  rw M1 a x,
  rw ←M2 x a (a⁻¹),
  rw M4 a ha.left,
  rw M3 x,
end

theorem p1: a + x = a + y → x = y :=
begin
  assume haxay,
  rw ←l3 x,
  rw ←l2 a,
  rw ←A2 (-a) a x,
  rw haxay,
  rw A2 (-a) a y,
  rw l2 a,
  rw l3 y,
end

theorem p2: a * 0 = 0 :=
begin
  apply p1 (a * 0),
  rw ←D a 0 0,
  rw A3 (0: α),
  rw A3 (a * 0),
end

lemma l9: (-1) * a = -a :=
begin
  apply l4 a ((-1) * a) (-a) _ (A4 a),
  conv {
    to_lhs,
    congr,
    rw ←M3 a,
  },
  rw ←M1 a,
  rw ←D a 1 (-1),
  rw A4 (1: α),
  rw p2 a,
end

lemma l10: a ≠ 0 → a⁻¹ * a = 1 :=
begin
  assume han0,
  rw M1 (a⁻¹) a,
  rw M4 a han0,
end

lemma l11: 1 * a = a :=
begin
  rw M1 1 a,
  rw M3 a,
end

-- hypothesis is much stronger than we need, since we know α is
-- inhabited.
theorem p3: (∀ a: α, a + x = a) → x = 0 :=
begin
  assume h,
  from l6 x ⟨0, h 0⟩,
end

theorem p4: -(0: α) = 0 :=
begin
  from l4 (0: α) (-0) 0 (A4 0) (A3 0),
end

theorem p5: -(-a) = a :=
begin
  from l4 (-a) (- -a) a (A4 (-a)) (l2 a),
end

theorem p6: -(a + b) = -a + (-b) :=
begin
  rw ←l9 (a + b),
  rw D (-1) a b,
  rw l9 a,
  rw l9 b,
end

theorem A1: a + b = b + a :=
begin
  rw ←p5 a,
  rw ←p5 b,
  rw ←p6 (-a) (-b),
  rw ←l7 (-a) (-b),
end

theorem p7: (∀ a, a ≠ 0 → a * x = a) → x = 1 :=
begin
  assume h,
  from l8 x ⟨1, ⟨Z', h 1 Z'⟩⟩,
end

theorem p8: a ≠ 0 → a * x = a * y → x = y :=
begin
  assume han0 haxay,
  rw ←l11 x,
  rw ←l10 a han0,
  rw ←M2 (a⁻¹) a x,
  rw haxay,
  rw M2 (a⁻¹) a y,
  rw l10 a han0,
  rw l11 y,
end

lemma l12: a ≠ 0 → a⁻¹ ≠ 0 :=
begin
  assume han0,
  assume hai0,
  apply @Z α _,
  rw ←M4 a han0,
  rw hai0,
  rw p2 a,
end

theorem p9: a ≠ 0 → (a⁻¹)⁻¹ = a :=
begin
  assume han0,
  conv {
    to_lhs,
    rw ←M3 (a⁻¹⁻¹),
    rw ←l10 a han0,
    rw M2 (a⁻¹⁻¹) (a⁻¹) a,
    rw l10 (a⁻¹) (l12 a han0),
  },
  rw l11 a,
end

theorem p10: (a + b) * c = a * c + b * c :=
begin
  rw M1 (a + b) c,
  rw D,
  rw M1 c a,
  rw M1 c b,
end

theorem p11: a * (-b) = -(a * b) :=
begin
  rw ←l9 b,
  rw ←l9 (a * b),
  rw M2 a (-1) b,
  rw M1 a (-1),
  rw ←M2 (-1) a b,
end

theorem p12: (-1: α) * (-1) = 1 :=
begin
  rw p11 (-1: α) 1,
  rw M1 (-1: α) 1,
  rw p11 (1: α) 1,
  rw p5 (1 * 1: α),
  rw M3 (1: α),
end

end myfield

end hidden