/-
Copyright (c) 2018 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis, Mario Carneiro, Johan Commelin
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.int.modeq
import Mathlib.data.zmod.basic
import Mathlib.linear_algebra.adic_completion
import Mathlib.data.padics.padic_numbers
import Mathlib.ring_theory.discrete_valuation_ring
import Mathlib.topology.metric_space.cau_seq_filter
import Mathlib.PostPort

namespace Mathlib

/-!
# p-adic integers

This file defines the p-adic integers `ℤ_p` as the subtype of `ℚ_p` with norm `≤ 1`.
We show that `ℤ_p`
* is complete
* is nonarchimedean
* is a normed ring
* is a local ring
* is a discrete valuation ring

The relation between `ℤ_[p]` and `zmod p` is established in another file.

## Important definitions

* `padic_int` : the type of p-adic numbers

## Notation

We introduce the notation `ℤ_[p]` for the p-adic integers.

## Implementation notes

Much, but not all, of this file assumes that `p` is prime. This assumption is inferred automatically
by taking `[fact (nat.prime p)] as a type class argument.

Coercions into `ℤ_p` are set up to work with the `norm_cast` tactic.

## References

* [F. Q. Gouêva, *p-adic numbers*][gouvea1997]
* [R. Y. Lewis, *A formal proof of Hensel's lemma over the p-adic integers*][lewis2019]
* <https://en.wikipedia.org/wiki/P-adic_number>

## Tags

p-adic, p adic, padic, p-adic integer
-/

/-- The p-adic integers ℤ_p are the p-adic numbers with norm ≤ 1. -/
def padic_int (p : ℕ) [fact (nat.prime p)] :=
  Subtype fun (x : padic p) => norm x ≤ 1

namespace padic_int

/-! ### Ring structure and coercion to `ℚ_[p]` -/

protected instance padic.has_coe {p : ℕ} [fact (nat.prime p)] : has_coe (padic_int p) (padic p) :=
  has_coe.mk subtype.val

theorem ext {p : ℕ} [fact (nat.prime p)] {x : padic_int p} {y : padic_int p} : ↑x = ↑y → x = y :=
  iff.mpr subtype.ext_iff_val

/-- Addition on ℤ_p is inherited from ℚ_p. -/
protected instance has_add {p : ℕ} [fact (nat.prime p)] : Add (padic_int p) :=
  { add := fun (_x : padic_int p) => sorry }

/-- Multiplication on ℤ_p is inherited from ℚ_p. -/
protected instance has_mul {p : ℕ} [fact (nat.prime p)] : Mul (padic_int p) :=
  { mul := fun (_x : padic_int p) => sorry }

/-- Negation on ℤ_p is inherited from ℚ_p. -/
protected instance has_neg {p : ℕ} [fact (nat.prime p)] : Neg (padic_int p) :=
  { neg := fun (_x : padic_int p) => sorry }

/-- Subtraction on ℤ_p is inherited from ℚ_p. -/
protected instance has_sub {p : ℕ} [fact (nat.prime p)] : Sub (padic_int p) :=
  { sub := fun (_x : padic_int p) => sorry }

/-- Zero on ℤ_p is inherited from ℚ_p. -/
protected instance has_zero {p : ℕ} [fact (nat.prime p)] : HasZero (padic_int p) :=
  { zero := { val := 0, property := sorry } }

protected instance inhabited {p : ℕ} [fact (nat.prime p)] : Inhabited (padic_int p) :=
  { default := 0 }

/-- One on ℤ_p is inherited from ℚ_p. -/
protected instance has_one {p : ℕ} [fact (nat.prime p)] : HasOne (padic_int p) :=
  { one := { val := 1, property := sorry } }

@[simp] theorem mk_zero {p : ℕ} [fact (nat.prime p)] {h : norm 0 ≤ 1} : { val := 0, property := h } = 0 :=
  rfl

@[simp] theorem val_eq_coe {p : ℕ} [fact (nat.prime p)] (z : padic_int p) : subtype.val z = ↑z :=
  rfl

@[simp] theorem coe_add {p : ℕ} [fact (nat.prime p)] (z1 : padic_int p) (z2 : padic_int p) : ↑(z1 + z2) = ↑z1 + ↑z2 := sorry

@[simp] theorem coe_mul {p : ℕ} [fact (nat.prime p)] (z1 : padic_int p) (z2 : padic_int p) : ↑(z1 * z2) = ↑z1 * ↑z2 := sorry

@[simp] theorem coe_neg {p : ℕ} [fact (nat.prime p)] (z1 : padic_int p) : ↑(-z1) = -↑z1 :=
  subtype.cases_on z1
    fun (z1_val : padic p) (z1_property : norm z1_val ≤ 1) =>
      idRhs (↑(-{ val := z1_val, property := z1_property }) = ↑(-{ val := z1_val, property := z1_property })) rfl

@[simp] theorem coe_sub {p : ℕ} [fact (nat.prime p)] (z1 : padic_int p) (z2 : padic_int p) : ↑(z1 - z2) = ↑z1 - ↑z2 := sorry

@[simp] theorem coe_one {p : ℕ} [fact (nat.prime p)] : ↑1 = 1 :=
  rfl

@[simp] theorem coe_coe {p : ℕ} [fact (nat.prime p)] (n : ℕ) : ↑↑n = ↑n := sorry

@[simp] theorem coe_coe_int {p : ℕ} [fact (nat.prime p)] (z : ℤ) : ↑↑z = ↑z := sorry

@[simp] theorem coe_zero {p : ℕ} [fact (nat.prime p)] : ↑0 = 0 :=
  rfl

protected instance ring {p : ℕ} [fact (nat.prime p)] : ring (padic_int p) :=
  ring.mk Add.add sorry 0 sorry sorry Neg.neg Sub.sub sorry sorry Mul.mul sorry 1 sorry sorry sorry sorry

/-- The coercion from ℤ[p] to ℚ[p] as a ring homomorphism. -/
def coe.ring_hom {p : ℕ} [fact (nat.prime p)] : padic_int p →+* padic p :=
  ring_hom.mk coe sorry coe_mul sorry coe_add

@[simp] theorem coe_pow {p : ℕ} [fact (nat.prime p)] (x : padic_int p) (n : ℕ) : ↑(x ^ n) = ↑x ^ n :=
  ring_hom.map_pow coe.ring_hom x n

@[simp] theorem mk_coe {p : ℕ} [fact (nat.prime p)] (k : padic_int p) : { val := ↑k, property := subtype.property k } = k := sorry

/-- The inverse of a p-adic integer with norm equal to 1 is also a p-adic integer. Otherwise, the
inverse is defined to be 0. -/
def inv {p : ℕ} [fact (nat.prime p)] : padic_int p → padic_int p :=
  sorry

protected instance char_zero {p : ℕ} [fact (nat.prime p)] : char_zero (padic_int p) :=
  char_zero.mk
    fun (m n : ℕ) (h : ↑m = ↑n) =>
      nat.cast_injective
        ((fun (this : ↑m = ↑n) => this)
          (eq.mp
            ((fun (a a_1 : padic p) (e_1 : a = a_1) (ᾰ ᾰ_1 : padic p) (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2)
              (↑↑m) (↑m) (coe_coe m) (↑↑n) (↑n) (coe_coe n))
            (eq.mp (Eq._oldrec (Eq.refl (↑m = ↑n)) (propext subtype.ext_iff)) h)))

@[simp] theorem coe_int_eq {p : ℕ} [fact (nat.prime p)] (z1 : ℤ) (z2 : ℤ) : ↑z1 = ↑z2 ↔ z1 = z2 := sorry

/--
A sequence of integers that is Cauchy with respect to the `p`-adic norm
converges to a `p`-adic integer.
-/
def of_int_seq {p : ℕ} [fact (nat.prime p)] (seq : ℕ → ℤ) (h : is_cau_seq (padic_norm p) fun (n : ℕ) => ↑(seq n)) : padic_int p :=
  { val := quotient.mk { val := fun (n : ℕ) => ↑(seq n), property := h }, property := sorry }

end padic_int

namespace padic_int

/-!
### Instances

We now show that `ℤ_[p]` is a
* complete metric space
* normed ring
* integral domain
-/

protected instance metric_space (p : ℕ) [fact (nat.prime p)] : metric_space (padic_int p) :=
  subtype.metric_space

protected instance complete_space (p : ℕ) [fact (nat.prime p)] : complete_space (padic_int p) := sorry

protected instance has_norm (p : ℕ) [fact (nat.prime p)] : has_norm (padic_int p) :=
  has_norm.mk fun (z : padic_int p) => norm ↑z

protected theorem mul_comm {p : ℕ} [fact (nat.prime p)] (z1 : padic_int p) (z2 : padic_int p) : z1 * z2 = z2 * z1 := sorry

protected theorem zero_ne_one {p : ℕ} [fact (nat.prime p)] : 0 ≠ 1 :=
  (fun (this : { val := 0, property := has_zero._proof_1 } ≠ { val := 1, property := has_one._proof_1 }) => this)
    (mt (iff.mp subtype.ext_iff_val) zero_ne_one)

protected theorem eq_zero_or_eq_zero_of_mul_eq_zero {p : ℕ} [fact (nat.prime p)] (a : padic_int p) (b : padic_int p) : a * b = 0 → a = 0 ∨ b = 0 := sorry

theorem norm_def {p : ℕ} [fact (nat.prime p)] {z : padic_int p} : norm z = norm ↑z :=
  rfl

protected instance normed_comm_ring (p : ℕ) [fact (nat.prime p)] : normed_comm_ring (padic_int p) :=
  normed_comm_ring.mk padic_int.mul_comm

protected instance norm_one_class (p : ℕ) [fact (nat.prime p)] : norm_one_class (padic_int p) :=
  norm_one_class.mk (Eq.trans norm_def norm_one)

protected instance is_absolute_value (p : ℕ) [fact (nat.prime p)] : is_absolute_value fun (z : padic_int p) => norm z :=
  is_absolute_value.mk norm_nonneg (fun (_x : padic_int p) => sorry) (fun (_x : padic_int p) => sorry)
    fun (_x _x_1 : padic_int p) =>
      eq.mpr
        (id
          ((fun (a a_1 : ℝ) (e_1 : a = a_1) (ᾰ ᾰ_1 : ℝ) (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2)
            (norm (_x * _x_1)) (norm ↑_x * norm ↑_x_1)
            (Eq.trans
              (Eq.trans norm_def
                ((fun (ᾰ ᾰ_1 : padic p) (e_2 : ᾰ = ᾰ_1) => congr_arg norm e_2) (↑(_x * _x_1)) (↑_x * ↑_x_1)
                  (coe_mul _x _x_1)))
              (padic_norm_e.mul ↑_x ↑_x_1))
            (norm _x * norm _x_1) (norm ↑_x * norm ↑_x_1)
            ((fun (ᾰ ᾰ_1 : ℝ) (e_2 : ᾰ = ᾰ_1) (ᾰ_2 ᾰ_3 : ℝ) (e_3 : ᾰ_2 = ᾰ_3) => congr (congr_arg Mul.mul e_2) e_3)
              (norm _x) (norm ↑_x) norm_def (norm _x_1) (norm ↑_x_1) norm_def)))
        (Eq.refl (norm ↑_x * norm ↑_x_1))

protected instance integral_domain {p : ℕ} [fact (nat.prime p)] : integral_domain (padic_int p) :=
  integral_domain.mk ring.add sorry ring.zero sorry sorry ring.neg ring.sub sorry sorry ring.mul sorry ring.one sorry
    sorry sorry sorry sorry sorry sorry

end padic_int

namespace padic_int

/-! ### Norm -/

theorem norm_le_one {p : ℕ} [fact (nat.prime p)] (z : padic_int p) : norm z ≤ 1 :=
  subtype.cases_on z fun (z_val : padic p) (z_property : norm z_val ≤ 1) => idRhs (norm z_val ≤ 1) z_property

@[simp] theorem norm_mul {p : ℕ} [fact (nat.prime p)] (z1 : padic_int p) (z2 : padic_int p) : norm (z1 * z2) = norm z1 * norm z2 := sorry

@[simp] theorem norm_pow {p : ℕ} [fact (nat.prime p)] (z : padic_int p) (n : ℕ) : norm (z ^ n) = norm z ^ n := sorry

theorem nonarchimedean {p : ℕ} [fact (nat.prime p)] (q : padic_int p) (r : padic_int p) : norm (q + r) ≤ max (norm q) (norm r) := sorry

theorem norm_add_eq_max_of_ne {p : ℕ} [fact (nat.prime p)] {q : padic_int p} {r : padic_int p} : norm q ≠ norm r → norm (q + r) = max (norm q) (norm r) := sorry

theorem norm_eq_of_norm_add_lt_right {p : ℕ} [fact (nat.prime p)] {z1 : padic_int p} {z2 : padic_int p} (h : norm (z1 + z2) < norm z2) : norm z1 = norm z2 := sorry

theorem norm_eq_of_norm_add_lt_left {p : ℕ} [fact (nat.prime p)] {z1 : padic_int p} {z2 : padic_int p} (h : norm (z1 + z2) < norm z1) : norm z1 = norm z2 := sorry

@[simp] theorem padic_norm_e_of_padic_int {p : ℕ} [fact (nat.prime p)] (z : padic_int p) : norm ↑z = norm z := sorry

theorem norm_int_cast_eq_padic_norm {p : ℕ} [fact (nat.prime p)] (z : ℤ) : norm ↑z = norm ↑z := sorry

@[simp] theorem norm_eq_padic_norm {p : ℕ} [fact (nat.prime p)] {q : padic p} (hq : norm q ≤ 1) : norm { val := q, property := hq } = norm q :=
  rfl

@[simp] theorem norm_p {p : ℕ} [fact (nat.prime p)] : norm ↑p = (↑p⁻¹) := sorry

@[simp] theorem norm_p_pow {p : ℕ} [fact (nat.prime p)] (n : ℕ) : norm (↑p ^ n) = ↑p ^ (-↑n) := sorry

protected instance complete (p : ℕ) [fact (nat.prime p)] : cau_seq.is_complete (padic_int p) norm :=
  cau_seq.is_complete.mk sorry

end padic_int

namespace padic_int

theorem exists_pow_neg_lt (p : ℕ) [hp_prime : fact (nat.prime p)] {ε : ℝ} (hε : 0 < ε) : ∃ (k : ℕ), ↑p ^ (-↑k) < ε := sorry

theorem exists_pow_neg_lt_rat (p : ℕ) [hp_prime : fact (nat.prime p)] {ε : ℚ} (hε : 0 < ε) : ∃ (k : ℕ), ↑p ^ (-↑k) < ε := sorry

theorem norm_int_lt_one_iff_dvd {p : ℕ} [hp_prime : fact (nat.prime p)] (k : ℤ) : norm ↑k < 1 ↔ ↑p ∣ k :=
  (fun (this : norm ↑k < 1 ↔ ↑p ∣ k) =>
      eq.mpr (id (Eq._oldrec (Eq.refl (norm ↑k < 1 ↔ ↑p ∣ k)) (norm_int_cast_eq_padic_norm k))) this)
    (padic_norm_e.norm_int_lt_one_iff_dvd k)

theorem norm_int_le_pow_iff_dvd {p : ℕ} [hp_prime : fact (nat.prime p)] {k : ℤ} {n : ℕ} : norm ↑k ≤ ↑p ^ (-↑n) ↔ ↑p ^ n ∣ k := sorry

/-! ### Valuation on `ℤ_[p]` -/

/-- `padic_int.valuation` lifts the p-adic valuation on `ℚ` to `ℤ_[p]`.  -/
def valuation {p : ℕ} [hp_prime : fact (nat.prime p)] (x : padic_int p) : ℤ :=
  padic.valuation ↑x

theorem norm_eq_pow_val {p : ℕ} [hp_prime : fact (nat.prime p)] {x : padic_int p} (hx : x ≠ 0) : norm x = ↑p ^ (-valuation x) := sorry

@[simp] theorem valuation_zero {p : ℕ} [hp_prime : fact (nat.prime p)] : valuation 0 = 0 :=
  padic.valuation_zero

@[simp] theorem valuation_one {p : ℕ} [hp_prime : fact (nat.prime p)] : valuation 1 = 0 :=
  padic.valuation_one

@[simp] theorem valuation_p {p : ℕ} [hp_prime : fact (nat.prime p)] : valuation ↑p = 1 := sorry

theorem valuation_nonneg {p : ℕ} [hp_prime : fact (nat.prime p)] (x : padic_int p) : 0 ≤ valuation x := sorry

@[simp] theorem valuation_p_pow_mul {p : ℕ} [hp_prime : fact (nat.prime p)] (n : ℕ) (c : padic_int p) (hc : c ≠ 0) : valuation (↑p ^ n * c) = ↑n + valuation c := sorry

/-! ### Units of `ℤ_[p]` -/

theorem mul_inv {p : ℕ} [hp_prime : fact (nat.prime p)] {z : padic_int p} : norm z = 1 → z * inv z = 1 := sorry

theorem inv_mul {p : ℕ} [hp_prime : fact (nat.prime p)] {z : padic_int p} (hz : norm z = 1) : inv z * z = 1 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (inv z * z = 1)) (mul_comm (inv z) z)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (z * inv z = 1)) (mul_inv hz))) (Eq.refl 1))

theorem is_unit_iff {p : ℕ} [hp_prime : fact (nat.prime p)] {z : padic_int p} : is_unit z ↔ norm z = 1 := sorry

theorem norm_lt_one_add {p : ℕ} [hp_prime : fact (nat.prime p)] {z1 : padic_int p} {z2 : padic_int p} (hz1 : norm z1 < 1) (hz2 : norm z2 < 1) : norm (z1 + z2) < 1 :=
  lt_of_le_of_lt (nonarchimedean z1 z2) (max_lt hz1 hz2)

theorem norm_lt_one_mul {p : ℕ} [hp_prime : fact (nat.prime p)] {z1 : padic_int p} {z2 : padic_int p} (hz2 : norm z2 < 1) : norm (z1 * z2) < 1 := sorry

@[simp] theorem mem_nonunits {p : ℕ} [hp_prime : fact (nat.prime p)] {z : padic_int p} : z ∈ nonunits (padic_int p) ↔ norm z < 1 := sorry

/-- A `p`-adic number `u` with `∥u∥ = 1` is a unit of `ℤ_[p]`. -/
def mk_units {p : ℕ} [hp_prime : fact (nat.prime p)] {u : padic p} (h : norm u = 1) : units (padic_int p) :=
  let z : padic_int p := { val := u, property := sorry };
  units.mk z (inv z) (mul_inv h) (inv_mul h)

@[simp] theorem mk_units_eq {p : ℕ} [hp_prime : fact (nat.prime p)] {u : padic p} (h : norm u = 1) : ↑↑(mk_units h) = u :=
  rfl

@[simp] theorem norm_units {p : ℕ} [hp_prime : fact (nat.prime p)] (u : units (padic_int p)) : norm ↑u = 1 :=
  iff.mp is_unit_iff (eq.mpr (id (propext ((fun {M : Type} (u : units M) => iff_true_intro (is_unit_unit u)) u))) trivial)

/-- `unit_coeff hx` is the unit `u` in the unique representation `x = u * p ^ n`.
See `unit_coeff_spec`. -/
def unit_coeff {p : ℕ} [hp_prime : fact (nat.prime p)] {x : padic_int p} (hx : x ≠ 0) : units (padic_int p) :=
  let u : padic p := ↑x * ↑p ^ (-valuation x);
  (fun (hu : norm u = 1) => mk_units hu) sorry

@[simp] theorem unit_coeff_coe {p : ℕ} [hp_prime : fact (nat.prime p)] {x : padic_int p} (hx : x ≠ 0) : ↑(unit_coeff hx) = ↑x * ↑p ^ (-valuation x) :=
  rfl

theorem unit_coeff_spec {p : ℕ} [hp_prime : fact (nat.prime p)] {x : padic_int p} (hx : x ≠ 0) : x = ↑(unit_coeff hx) * ↑p ^ int.nat_abs (valuation x) := sorry

/-! ### Various characterizations of open unit balls -/

theorem norm_le_pow_iff_le_valuation {p : ℕ} [hp_prime : fact (nat.prime p)] (x : padic_int p) (hx : x ≠ 0) (n : ℕ) : norm x ≤ ↑p ^ (-↑n) ↔ ↑n ≤ valuation x := sorry

theorem mem_span_pow_iff_le_valuation {p : ℕ} [hp_prime : fact (nat.prime p)] (x : padic_int p) (hx : x ≠ 0) (n : ℕ) : x ∈ ideal.span (singleton (↑p ^ n)) ↔ ↑n ≤ valuation x := sorry

theorem norm_le_pow_iff_mem_span_pow {p : ℕ} [hp_prime : fact (nat.prime p)] (x : padic_int p) (n : ℕ) : norm x ≤ ↑p ^ (-↑n) ↔ x ∈ ideal.span (singleton (↑p ^ n)) := sorry

theorem norm_le_pow_iff_norm_lt_pow_add_one {p : ℕ} [hp_prime : fact (nat.prime p)] (x : padic_int p) (n : ℤ) : norm x ≤ ↑p ^ n ↔ norm x < ↑p ^ (n + 1) := sorry

theorem norm_lt_pow_iff_norm_le_pow_sub_one {p : ℕ} [hp_prime : fact (nat.prime p)] (x : padic_int p) (n : ℤ) : norm x < ↑p ^ n ↔ norm x ≤ ↑p ^ (n - 1) := sorry

theorem norm_lt_one_iff_dvd {p : ℕ} [hp_prime : fact (nat.prime p)] (x : padic_int p) : norm x < 1 ↔ ↑p ∣ x := sorry

@[simp] theorem pow_p_dvd_int_iff {p : ℕ} [hp_prime : fact (nat.prime p)] (n : ℕ) (a : ℤ) : ↑p ^ n ∣ ↑a ↔ ↑p ^ n ∣ a := sorry

/-! ### Discrete valuation ring -/

protected instance local_ring {p : ℕ} [hp_prime : fact (nat.prime p)] : local_ring (padic_int p) :=
  local_of_nonunits_ideal zero_ne_one
    fun (x y : padic_int p) =>
      eq.mpr (id (imp_congr_eq (propext mem_nonunits) (imp_congr_eq (propext mem_nonunits) (propext mem_nonunits))))
        norm_lt_one_add

theorem p_nonnunit {p : ℕ} [hp_prime : fact (nat.prime p)] : ↑p ∈ nonunits (padic_int p) := sorry

theorem maximal_ideal_eq_span_p {p : ℕ} [hp_prime : fact (nat.prime p)] : local_ring.maximal_ideal (padic_int p) = ideal.span (singleton ↑p) := sorry

theorem prime_p {p : ℕ} [hp_prime : fact (nat.prime p)] : prime ↑p := sorry

theorem irreducible_p {p : ℕ} [hp_prime : fact (nat.prime p)] : irreducible ↑p :=
  irreducible_of_prime prime_p

protected instance discrete_valuation_ring {p : ℕ} [hp_prime : fact (nat.prime p)] : discrete_valuation_ring (padic_int p) :=
  discrete_valuation_ring.of_has_unit_mul_pow_irreducible_factorization
    (Exists.intro ↑p
      { left := irreducible_p,
        right :=
          fun (x : padic_int p) (hx : x ≠ 0) =>
            Exists.intro (int.nat_abs (valuation x))
              (Exists.intro (unit_coeff hx)
                (eq.mpr
                  (id
                    (Eq._oldrec (Eq.refl (↑p ^ int.nat_abs (valuation x) * ↑(unit_coeff hx) = x))
                      (mul_comm (↑p ^ int.nat_abs (valuation x)) ↑(unit_coeff hx))))
                  (eq.mpr
                    (id
                      (Eq._oldrec (Eq.refl (↑(unit_coeff hx) * ↑p ^ int.nat_abs (valuation x) = x))
                        (Eq.symm (unit_coeff_spec hx))))
                    (Eq.refl x)))) })

theorem ideal_eq_span_pow_p {p : ℕ} [hp_prime : fact (nat.prime p)] {s : ideal (padic_int p)} (hs : s ≠ ⊥) : ∃ (n : ℕ), s = ideal.span (singleton (↑p ^ n)) :=
  discrete_valuation_ring.ideal_eq_span_pow_irreducible hs irreducible_p


import tactic
import data.nat.prime
import ring_theory.int.basic
import data.real.sqrt
open nat
open int

-- 2022 USAMO Problem 4
-- https://artofproblemsolving.com/community/c5h2808839p24774670
-- Based on solution 1 by The_Turtle (post #5)

noncomputable theory
open_locale classical

lemma x_mod3_either_012: ∀ x, (x ≡ 0 [ZMOD 3] ∨ x ≡ 1 [ZMOD 3] ∨ x ≡ 2 [ZMOD 3]) := begin
  rintro x,
  have hx : x % 3 < 3,
  {
    have goal := @int.mod_lt x 3,
    have zero_lt_3 : (3 : ℤ) ≠ 0, {linarith,},
    refine goal zero_lt_3,
  },
  have hy : x % 3 ≥ 0,
  {
    have goal := @int.mod_nonneg x 3,
    have three_neq_0 : (3 : ℤ) ≠ 0, {linarith,},
    refine goal three_neq_0,
  },
  interval_cases (x % 3) with h,
  { have zero_eq_0mod3 : 0 % 3 = (0 : ℤ), {norm_num,},
    rw← zero_eq_0mod3 at h,
    rw← int.modeq at h,
    left, refine h,
  },
  { have one_eq_1mod3 : (1 : ℤ) = 1 % 3, {norm_num,},
    have goal : x % 3 = 1 % 3, {rw h, refine one_eq_1mod3,},
    rw← int.modeq at goal,
    right, left, refine goal,},
  {have two_eq_2mod3 : 2 % 3 = (2 : ℤ), {norm_num,},
    rw← two_eq_2mod3 at h,
    rw← int.modeq at h,
    right, right, refine h,}
end

lemma square_mod3_not_2 : ∀ x, ¬ (x * x ≡ 2 [ZMOD 3]) := begin
by_contradiction h,
push_neg at h,
cases h with x hx,
have x_either_012 := x_mod3_either_012 x,
cases x_either_012 with x_0 rest,
{
  have xx_0 := int.modeq.mul x_0 x_0,
  ring_nf at xx_0,
  ring_nf at hx,
  have xx0_2 := int.modeq.symm xx_0,
  have zero_eq_2 := int.modeq.trans xx0_2 hx,
  rw int.modeq at zero_eq_2,
  norm_num at zero_eq_2,
},
{
  cases rest with x_1 x_2,
  {
    have xx_0 := int.modeq.mul x_1 x_1,
    ring_nf at xx_0,
    ring_nf at hx,
    have xx0_2 := int.modeq.symm xx_0,
    have zero_eq_2 := int.modeq.trans xx0_2 hx,
    rw int.modeq at zero_eq_2,
    norm_num at zero_eq_2,
  },{
    have xx_0 := int.modeq.mul x_2 x_2,
    ring_nf at xx_0,
    ring_nf at hx,
    have xx0_2 := int.modeq.symm xx_0,
    have zero_eq_2 := int.modeq.trans xx0_2 hx,
    rw int.modeq at zero_eq_2,
    norm_num at zero_eq_2,
  },
},
end

theorem usamo_2022_problem_4 : ∀ (p : ℤ), ∀ (q : ℤ), (p > 0 ∧ q > 0 ∧ prime p ∧ prime q ∧ (∃ (x : ℕ), ↑x * ↑x = p - q) ∧ (∃ (y : ℕ), ↑y * ↑y = p * q - q)) → (p = 3 ∧ q = 2) := begin
rintro p,
rintro q,
rintro hypothesis,
have zero_le_p : 0 ≤ p, {linarith,},
have zero_le_q : 0 ≤ q, {linarith,},
set pnat := p.nat_abs with pnat_def,
set qnat := q.nat_abs with qnat_def,
have p_eq_pnat : p = pnat,
  {rw pnat_def, apply int.eq_nat_abs_of_zero_le, refine zero_le_p,},
have q_eq_qnat : q = qnat,
  {rw qnat_def, apply int.eq_nat_abs_of_zero_le, refine zero_le_q,},
cases hypothesis with p_pos rest1,
cases rest1 with q_pos rest2,
cases rest2 with p_prime rest3,
cases rest3 with q_prime rest4,
have pnat_prime : nat.prime pnat,
{rw pnat_def, rw← int.prime_iff_nat_abs_prime, refine p_prime},
have qnat_prime : nat.prime qnat,
{rw qnat_def, rw← int.prime_iff_nat_abs_prime, refine q_prime},
cases rest4 with pq_square pqq_square,
have qeq2_or_not := em (q = 2),

have one_lt_q : 1 < q, {
  by_contradiction, push_neg at h,
  have q_eq_1 : q = 1, {linarith,},
  rw q_eq_1 at q_prime, norm_num at q_prime,
},

cases qeq2_or_not with qeq2 qneq2,
{
  rw qeq2 at pq_square,
  rw qeq2 at pqq_square,
  have p_mod3_cases := x_mod3_either_012 p,
  cases p_mod3_cases with p_0 rest,
  {
    have p_div_3 := int.modeq.dvd (int.modeq.symm p_0),
    have tmp : p - 0 = p, {simp,},
    have three_prime : nat.prime 3, {norm_num,},
    rw tmp at p_div_3,
    rw p_eq_pnat at p_div_3,
    norm_cast at p_div_3,
    rw nat.prime_dvd_prime_iff_eq three_prime pnat_prime at p_div_3,
    split, repeat {linarith,},
  },{
    cases rest with p_1 p_2,
    {
      cases pq_square with x xkey,
      have xsq_modeq_2 : x * x ≡ 2 [ZMOD 3],
      {
        rw xkey,
        refine int.modeq.sub_right 2 p_1,
      },
      exfalso,
      refine (square_mod3_not_2 x) xsq_modeq_2,
    },
    {
      cases pqq_square with y ykey,
      have ysq_modeq_2 : y * y ≡ 2 [ZMOD 3],
      {
        rw ykey,
        have twop_1 := int.modeq.sub_right 2 (int.modeq.mul_right 2 p_2),
        ring_nf at twop_1,
        ring_nf,
        refine twop_1,
      },
      exfalso,
      refine (square_mod3_not_2 y) ysq_modeq_2,
    },
  },
},
{
  cases pq_square with x xkey,
  cases pqq_square with y ykey,
  have y_plus_x_y_minus_x_eq_p_q_minus_1 : (↑y + ↑x) * (↑y - ↑x) = p * (q - 1),
  {
    ring_nf,
    repeat {rw sq,},
    rw xkey, rw ykey,
    ring_nf,
  },
  have p_div_diff_sq : p ∣ (↑y + ↑x) * (↑y - ↑x),
  {
    use q - 1,
    refine y_plus_x_y_minus_x_eq_p_q_minus_1,
  },
  have y_nonzero : y ≠ 0, {
    by_contradiction,
    rw h at ykey,
    norm_num at ykey,
    have ykey' : 1 * q = p * q, {linarith,},
    have q_nonzero : q ≠ 0, {linarith,},
    rw mul_left_inj' q_nonzero at ykey',
    rw← ykey' at p_prime,
    norm_num at p_prime,
  },
  have x_add_y_ge_p : ↑x + ↑y ≥ p, {
    rw p_eq_pnat at p_div_diff_sq,
    have p_div_either := prime.dvd_mul pnat_prime p_div_diff_sq,
    cases p_div_either with p_div_add p_div_sub,
    {
      norm_cast,
      norm_cast at p_div_add,
      cases p_div_add with pfactor p_div_key,
      have pfactor_ge : pfactor ≥ 1, {
        by_contradiction,
        push_neg at h,
        have pfactor_0 : pfactor = 0, {linarith,},
        rw pfactor_0 at p_div_key,
        ring_nf at p_div_key,
        have y_zero : y = 0, {linarith,},
        refine y_nonzero y_zero,
      },
      have p_pfactor_ge : pnat * pfactor ≥ pnat, {
        rw ge, rw ge at pfactor_ge,
        have zero_le_pnat : 0 ≤ pnat, {linarith,},
        refine le_mul_of_one_le_right zero_le_pnat pfactor_ge,
      },
      rw p_eq_pnat,
      norm_cast, linarith,
    },{
      have diff_pos : 0 < (y : ℤ) - (x : ℤ), {
        have zero_le_p_q_sub_1 : 0 < p * (q - 1), {
          rw mul_pos_iff, left, split,
          {refine gt.lt p_pos,}, {linarith,},
        },
        rw← y_plus_x_y_minus_x_eq_p_q_minus_1 at zero_le_p_q_sub_1,
        rw mul_pos_iff at zero_le_p_q_sub_1,
        cases zero_le_p_q_sub_1 with case1 case2,
        {
          cases case1 with tmp1 tmp2, refine tmp2,
        },{
          cases case2 with sum_neg unused,
          norm_cast at sum_neg,
          linarith,
        },
      },
      have diff_pos2 : (x : ℤ) ≤ (y : ℤ), {linarith,},
      norm_cast at diff_pos2,
      have diff_cast_eq_cast_diff : (y : ℤ) - (x : ℤ) = ↑(y - x), {
        have goal := int.coe_nat_sub diff_pos2, linarith,
      },
      rw diff_cast_eq_cast_diff at p_div_sub,
      norm_cast at p_div_sub,
      cases p_div_sub with pfactor p_div_key,

      have pfactor_ge : pfactor ≥ 1, {
        by_contradiction,
        push_neg at h,
        have pfactor_0 : pfactor = 0, {linarith,},
        rw pfactor_0 at p_div_key,
        ring_nf at p_div_key,
        have y_eq_x : y = x, {linarith,},
        rw y_eq_x at ykey,
        rw xkey at ykey,
        have ykey' : p * 1 = p * q, {linarith,},
        have p_nonzero : p ≠ 0, {linarith,},
        rw mul_right_inj' p_nonzero at ykey',
        rw← ykey' at q_prime,
        norm_num at q_prime,
      },
      have p_pfactor_ge : pnat * pfactor ≥ pnat, {
        rw ge, rw ge at pfactor_ge,
        have zero_le_pnat : 0 ≤ pnat, {linarith,},
        refine le_mul_of_one_le_right zero_le_pnat pfactor_ge,
      },
      rw p_eq_pnat,
      norm_cast, linarith,
    },
  },
  set p_real : ℝ := ↑p with p_real_def,
  set q_real : ℝ := ↑q with q_real_def,
  set x_real : ℝ := ↑x with x_real_def,
  set y_real : ℝ := ↑y with y_real_def,
  have sqrt_p_pos : 0 < real.sqrt p_real, {
    rw real.sqrt_pos, rw p_real_def, norm_cast, linarith,},
  have sqrt_p_not_zero : real.sqrt p_real ≠ 0, {linarith,},

  have p_real_nonneg : 0 ≤ p_real, {rw p_real_def, norm_cast, refine zero_le_p,},
  have q_real_nonneg : 0 ≤ q_real, {rw q_real_def, norm_cast, refine zero_le_q,},
  have x_real_nonneg : 0 ≤ x_real, {rw x_real_def, norm_cast, linarith,},
  have y_real_nonneg : 0 ≤ y_real, {rw y_real_def, norm_cast, linarith,},
  have q_neq_y : q ≠ y, {
    by_contradiction,
    rw h at ykey,
    have y_eqn : ↑y = p - 1, {
      ring_nf at ykey, rw sq at ykey,
      have y_nonzero' : ↑y ≠ (0 : ℤ), {norm_cast, refine y_nonzero,},
      rw mul_left_inj' y_nonzero' at ykey,
      refine ykey,
    },
    rw← h at y_eqn,
    have q_2_or_odd := nat.prime.eq_two_or_odd' qnat_prime,
    cases q_2_or_odd with q2 qodd,
    {
      have q2_new : q = (2 : ℤ), {linarith,},
      refine qneq2 q2_new,
    },
    {
      have p_eq_q_add_one : ↑pnat = ↑qnat + 1, {linarith,},
      norm_cast at p_eq_q_add_one,
      rw nat.succ_eq_one_add at p_eq_q_add_one,
      rw add_comm at p_eq_q_add_one,
      have pnat_even := odd.add_odd qodd odd_one,
      rw← p_eq_q_add_one at pnat_even,
      rw nat.prime.even_iff pnat_prime at pnat_even,
      have pnat_two : (↑pnat) = (2 : ℤ), {norm_cast, refine pnat_even},
      rw← p_eq_pnat at pnat_two,
      have q_eq_1 : q = 1, {linarith,},
      have q_neq_1 := prime.ne_one q_prime,
      refine q_neq_1 q_eq_1,
    },
  },
  have q_div_y : q ∣ y, {
    have q_div_ysq : q ∣ y ^ 2, {
      use p - 1,
      ring_nf,
      ring_nf at ykey,
      ring_nf,
      refine ykey,
    },
    refine prime.dvd_of_dvd_pow q_prime q_div_ysq,
  },
  have y_ge_2q : ↑y ≥ 2 * q, {
    cases q_div_y with qfactor q_div_key,
    have two_le_qfactor_or_not := em (2 ≤ qfactor),
    cases two_le_qfactor_or_not with two_le_qfactor qfactor_lt_two,
    {
      have goal := mul_le_mul_of_nonneg_left two_le_qfactor zero_le_q,
      rw mul_comm q 2 at goal, linarith,
    },{
      push_neg at qfactor_lt_two,
      have qfactor_nonpos : qfactor ≤ 0, {
        by_contradiction, push_neg at h,
        have qfactor_eq_1 : qfactor = 1, {linarith,},
        rw qfactor_eq_1 at q_div_key,
        ring_nf at q_div_key,
        refine q_neq_y q_div_key.symm,
      },
      have q_qfactor_nonpos : q * qfactor ≤ 0, {
        rw mul_nonpos_iff, left,
        split, repeat {linarith,},
      },
      have y_le_zero : ↑y ≤ 0, {linarith,},
      norm_cast at y_le_zero,
      have y_eq_zero : y = 0, {linarith,},
      exfalso, refine y_nonzero y_eq_zero,
    },
  },
  have p_sub_1_ge_4q : p - 1 ≥ 4 * q, {
    have twoq_le_y := ge.le y_ge_2q,
    have twoq_nonneg : 0 ≤ 2 * q, {linarith,},
    have y_nonneg : 0 ≤ (y : ℤ), {norm_cast, linarith,},
    have squared_ineq := mul_le_mul twoq_le_y twoq_le_y twoq_nonneg y_nonneg,
    rw ykey at squared_ineq,
    ring_nf at squared_ineq,
    have squared_ineq' : 4 * q * q ≤ (p - 1) * q, {ring_nf, refine squared_ineq},
    have q_pos' : 0 < q, {linarith,},
    by_contradiction,
    push_neg at h,
    have h2 := mul_lt_mul_of_pos_right h q_pos',
    linarith,
  },
  have step1' : (real.sqrt q_real) + 1 =
    ((real.sqrt (p_real * q_real)) + (real.sqrt p_real)) / (real.sqrt p_real),
  {
    rw div_add_same sqrt_p_not_zero,
    rw real.sqrt_mul p_real_nonneg,
    rw mul_comm,
    rw mul_div_cancel,
    refine sqrt_p_not_zero,
  },
  have step1 : (real.sqrt q_real) + 1 ≥
    ((real.sqrt (p_real * q_real)) + (real.sqrt p_real)) / (real.sqrt p_real), {linarith,},
  have step2 : ((real.sqrt (p_real * q_real)) + (real.sqrt p_real)) / (real.sqrt p_real)
    ≥ ((real.sqrt (p_real * q_real - q_real)) + (real.sqrt (p_real - q_real))) / (real.sqrt p_real),
    {
      have pqq_le_pq : p_real * q_real - q_real ≤ p_real * q_real,
      {linarith,},
      have sqrt_pqq_le_pq := real.sqrt_le_sqrt pqq_le_pq,
      have pminusq_le_p : p_real - q_real ≤ p_real, {linarith,},
      have sqrt_pminusq_le_p := real.sqrt_le_sqrt pminusq_le_p,
      have numer_ineq := add_le_add sqrt_pqq_le_pq sqrt_pminusq_le_p,
      rw← div_le_div_right sqrt_p_pos at numer_ineq,
      linarith,
    },
  have step3' : ((real.sqrt (p_real * q_real - q_real)) + (real.sqrt (p_real - q_real))) / (real.sqrt p_real)
    = (y_real + x_real) / (real.sqrt p_real), {
      have pq_sub_q_real : y_real * y_real = p_real * q_real - q_real, {
        rw p_real_def, rw q_real_def, rw y_real_def,
        norm_cast, refine ykey,
      },
      have p_sub_q_real : x_real * x_real = p_real - q_real, {
        rw p_real_def, rw q_real_def, rw x_real_def,
        norm_cast, refine xkey,
      },
      rw← pq_sub_q_real, rw← p_sub_q_real,
      rw real.sqrt_mul_self x_real_nonneg,
      rw real.sqrt_mul_self y_real_nonneg,
    },
  have step3 : ((real.sqrt (p_real * q_real - q_real)) + (real.sqrt (p_real - q_real))) / (real.sqrt p_real)
    ≥ (y_real + x_real) / (real.sqrt p_real), {linarith,},
  have step4 : (y_real + x_real) / (real.sqrt p_real) ≥ real.sqrt p_real, {
    rw ge,
    have p_real_le_x_y_real : p_real ≤ y_real + x_real, {
      rw x_real_def, rw y_real_def, rw p_real_def,
      norm_cast, norm_cast at x_add_y_ge_p,
      rw add_comm at x_add_y_ge_p,
      refine x_add_y_ge_p,
    },
    rw← div_le_div_right sqrt_p_pos at p_real_le_x_y_real,
    rw real.div_sqrt at p_real_le_x_y_real,
    refine p_real_le_x_y_real,
  },
  have step5 : real.sqrt p_real ≥ real.sqrt (4 * q_real + 1), {
    have core : p_real ≥ 4 * q_real + 1, {
      rw p_real_def, rw q_real_def,
      norm_cast, linarith,
    },
    rw ge, rw ge at core,
    refine real.sqrt_le_sqrt core,
  },
  have steps_combined := ge_trans (
    ge_trans (ge_trans (ge_trans step1 step2) step3) step4) step5,
  rw ge at steps_combined,
  have lhs_nonneg := real.sqrt_nonneg (4 * q_real + 1),
  have rhs_nonneg : 0 ≤ (real.sqrt q_real) + 1, {
    have q_real_nonneg := real.sqrt_nonneg q_real, linarith,
  },
  have squared_ineq := mul_le_mul steps_combined steps_combined lhs_nonneg rhs_nonneg,
  have zero_le_4q_1 : 0 ≤ 4 * q_real + 1, {linarith,},
  rw real.mul_self_sqrt zero_le_4q_1 at squared_ineq,
  ring_nf at squared_ineq,
  have squared_ineq_2 : 4 * q_real ≤ (real.sqrt q_real + 2) * (real.sqrt q_real),
  {linarith,},
  rw right_distrib at squared_ineq_2,
  rw real.mul_self_sqrt q_real_nonneg at squared_ineq_2,
  have squared_ineq_3 : 3 * q_real ≤ 2 * real.sqrt q_real, {linarith,},
  have ineq_4 : q_real ≤ real.sqrt q_real, {linarith,},
  rw real.le_sqrt q_real_nonneg q_real_nonneg at ineq_4,
  have q_real_pos : 0 < q_real, {rw q_real_def, norm_cast, linarith,},
  have q_real_nonzero : q_real ≠ 0, {linarith,},
  rw← div_le_div_right q_real_pos at ineq_4,
  have q_real_le_1 : q_real ≤ 1, {
    rw div_self q_real_nonzero at ineq_4,
    rw sq at ineq_4,
    rw mul_div_cancel q_real q_real_nonzero at ineq_4,
    refine ineq_4,
  },
  rw q_real_def at q_real_le_1,
  norm_cast at q_real_le_1,
  rw q_eq_qnat at q_real_le_1,
  norm_cast at q_real_le_1,
  have two_le_qnat := nat.prime.two_le qnat_prime,
  linarith,
},
end


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Adam Topaz
-/
import algebra.algebra.subalgebra.basic
import algebra.monoid_algebra.basic

/-!
# Free Algebras

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

Given a commutative semiring `R`, and a type `X`, we construct the free unital, associative
`R`-algebra on `X`.

## Notation

1. `free_algebra R X` is the free algebra itself. It is endowed with an `R`-algebra structure.
2. `free_algebra.ι R` is the function `X → free_algebra R X`.
3. Given a function `f : X → A` to an R-algebra `A`, `lift R f` is the lift of `f` to an
  `R`-algebra morphism `free_algebra R X → A`.

## Theorems

1. `ι_comp_lift` states that the composition `(lift R f) ∘ (ι R)` is identical to `f`.
2. `lift_unique` states that whenever an R-algebra morphism `g : free_algebra R X → A` is
  given whose composition with `ι R` is `f`, then one has `g = lift R f`.
3. `hom_ext` is a variant of `lift_unique` in the form of an extensionality theorem.
4. `lift_comp_ι` is a combination of `ι_comp_lift` and `lift_unique`. It states that the lift
  of the composition of an algebra morphism with `ι` is the algebra morphism itself.
5. `equiv_monoid_algebra_free_monoid : free_algebra R X ≃ₐ[R] monoid_algebra R (free_monoid X)`
6. An inductive principle `induction`.

## Implementation details

We construct the free algebra on `X` as a quotient of an inductive type `free_algebra.pre` by an
inductively defined relation `free_algebra.rel`. Explicitly, the construction involves three steps:
1. We construct an inductive type `free_algebra.pre R X`, the terms of which should be thought
  of as representatives for the elements of `free_algebra R X`.
  It is the free type with maps from `R` and `X`, and with two binary operations `add` and `mul`.
2. We construct an inductive relation `free_algebra.rel R X` on `free_algebra.pre R X`.
  This is the smallest relation for which the quotient is an `R`-algebra where addition resp.
  multiplication are induced by `add` resp. `mul` from 1., and for which the map from `R` is the
  structure map for the algebra.
3. The free algebra `free_algebra R X` is the quotient of `free_algebra.pre R X` by
  the relation `free_algebra.rel R X`.
-/

variables (R : Type*) [comm_semiring R]
variables (X : Type*)

namespace free_algebra

/--
This inductive type is used to express representatives of the free algebra.
-/
inductive pre
| of : X → pre
| of_scalar : R → pre
| add : pre → pre → pre
| mul : pre → pre → pre

namespace pre

instance : inhabited (pre R X) := ⟨of_scalar 0⟩

-- Note: These instances are only used to simplify the notation.
/-- Coercion from `X` to `pre R X`. Note: Used for notation only. -/
def has_coe_generator : has_coe X (pre R X) := ⟨of⟩
/-- Coercion from `R` to `pre R X`. Note: Used for notation only. -/
def has_coe_semiring : has_coe R (pre R X) := ⟨of_scalar⟩
/-- Multiplication in `pre R X` defined as `pre.mul`. Note: Used for notation only. -/
def has_mul : has_mul (pre R X) := ⟨mul⟩
/-- Addition in `pre R X` defined as `pre.add`. Note: Used for notation only. -/
def has_add : has_add (pre R X) := ⟨add⟩
/-- Zero in `pre R X` defined as the image of `0` from `R`. Note: Used for notation only. -/
def has_zero : has_zero (pre R X) := ⟨of_scalar 0⟩
/-- One in `pre R X` defined as the image of `1` from `R`. Note: Used for notation only. -/
def has_one : has_one (pre R X) := ⟨of_scalar 1⟩
/--
Scalar multiplication defined as multiplication by the image of elements from `R`.
Note: Used for notation only.
-/
def has_smul : has_smul R (pre R X) := ⟨λ r m, mul (of_scalar r) m⟩

end pre

local attribute [instance]
  pre.has_coe_generator pre.has_coe_semiring pre.has_mul pre.has_add pre.has_zero
  pre.has_one pre.has_smul

/--
Given a function from `X` to an `R`-algebra `A`, `lift_fun` provides a lift of `f` to a function
from `pre R X` to `A`. This is mainly used in the construction of `free_algebra.lift`.
-/
def lift_fun {A : Type*} [semiring A] [algebra R A] (f : X → A) : pre R X → A :=
  λ t, pre.rec_on t f (algebra_map _ _) (λ _ _, (+)) (λ _ _, (*))

/--
An inductively defined relation on `pre R X` used to force the initial algebra structure on
the associated quotient.
-/
inductive rel : (pre R X) → (pre R X) → Prop
-- force `of_scalar` to be a central semiring morphism
| add_scalar {r s : R} : rel ↑(r + s) (↑r + ↑s)
| mul_scalar {r s : R} : rel ↑(r * s) (↑r * ↑s)
| central_scalar {r : R} {a : pre R X} : rel (r * a) (a * r)
-- commutative additive semigroup
| add_assoc {a b c : pre R X} : rel (a + b + c) (a + (b + c))
| add_comm {a b : pre R X} : rel (a + b) (b + a)
| zero_add {a : pre R X} : rel (0 + a) a
-- multiplicative monoid
| mul_assoc {a b c : pre R X} : rel (a * b * c) (a * (b * c))
| one_mul {a : pre R X} : rel (1 * a) a
| mul_one {a : pre R X} : rel (a * 1) a
-- distributivity
| left_distrib {a b c : pre R X} : rel (a * (b + c)) (a * b + a * c)
| right_distrib {a b c : pre R X} : rel ((a + b) * c) (a * c + b * c)
-- other relations needed for semiring
| zero_mul {a : pre R X} : rel (0 * a) 0
| mul_zero {a : pre R X} : rel (a * 0) 0
-- compatibility
| add_compat_left {a b c : pre R X} : rel a b → rel (a + c) (b + c)
| add_compat_right {a b c : pre R X} : rel a b → rel (c + a) (c + b)
| mul_compat_left {a b c : pre R X} : rel a b → rel (a * c) (b * c)
| mul_compat_right {a b c : pre R X} : rel a b → rel (c * a) (c * b)

end free_algebra

/--
The free algebra for the type `X` over the commutative semiring `R`.
-/
def free_algebra := quot (free_algebra.rel R X)

namespace free_algebra

local attribute [instance]
  pre.has_coe_generator pre.has_coe_semiring pre.has_mul pre.has_add pre.has_zero
  pre.has_one pre.has_smul

instance : semiring (free_algebra R X) :=
{ add := quot.map₂ (+) (λ _ _ _, rel.add_compat_right) (λ _ _ _, rel.add_compat_left),
  add_assoc := by { rintros ⟨⟩ ⟨⟩ ⟨⟩, exact quot.sound rel.add_assoc },
  zero := quot.mk _ 0,
  zero_add := by { rintro ⟨⟩, exact quot.sound rel.zero_add },
  add_zero := begin
    rintros ⟨⟩,
    change quot.mk _ _ = _,
    rw [quot.sound rel.add_comm, quot.sound rel.zero_add],
  end,
  add_comm := by { rintros ⟨⟩ ⟨⟩, exact quot.sound rel.add_comm },
  mul := quot.map₂ (*) (λ _ _ _, rel.mul_compat_right) (λ _ _ _, rel.mul_compat_left),
  mul_assoc := by { rintros ⟨⟩ ⟨⟩ ⟨⟩, exact quot.sound rel.mul_assoc },
  one := quot.mk _ 1,
  one_mul := by { rintros ⟨⟩, exact quot.sound rel.one_mul },
  mul_one := by { rintros ⟨⟩, exact quot.sound rel.mul_one },
  left_distrib := by { rintros ⟨⟩ ⟨⟩ ⟨⟩, exact quot.sound rel.left_distrib },
  right_distrib := by { rintros ⟨⟩ ⟨⟩ ⟨⟩, exact quot.sound rel.right_distrib },
  zero_mul := by { rintros ⟨⟩, exact quot.sound rel.zero_mul },
  mul_zero := by { rintros ⟨⟩, exact quot.sound rel.mul_zero } }

instance : inhabited (free_algebra R X) := ⟨0⟩

instance : has_smul R (free_algebra R X) :=
{ smul := λ r, quot.map ((*) ↑r) (λ a b, rel.mul_compat_right) }

instance : algebra R (free_algebra R X) :=
{ to_fun := λ r, quot.mk _ r,
  map_one' := rfl,
  map_mul' := λ _ _, quot.sound rel.mul_scalar,
  map_zero' := rfl,
  map_add' := λ _ _, quot.sound rel.add_scalar,
  commutes' := λ _, by { rintros ⟨⟩, exact quot.sound rel.central_scalar },
  smul_def' := λ _ _, rfl }

instance {S : Type*} [comm_ring S] : ring (free_algebra S X) := algebra.semiring_to_ring S

variables {X}

/--
The canonical function `X → free_algebra R X`.
-/
@[irreducible] def ι : X → free_algebra R X := λ m, quot.mk _ m

@[simp] lemma quot_mk_eq_ι (m : X) : quot.mk (free_algebra.rel R X) m = ι R m :=
by rw [ι]

variables {A : Type*} [semiring A] [algebra R A]

/-- Internal definition used to define `lift` -/
private def lift_aux (f : X → A) : (free_algebra R X →ₐ[R] A) :=
{ to_fun := λ a, quot.lift_on a (lift_fun _ _ f) $ λ a b h,
  begin
    induction h,
    { exact (algebra_map R A).map_add h_r h_s, },
    { exact (algebra_map R A).map_mul h_r h_s },
    { apply algebra.commutes },
    { change _ + _ + _ = _ + (_ + _),
      rw add_assoc },
    { change _ + _ = _ + _,
      rw add_comm, },
    { change (algebra_map _ _ _) + lift_fun R X f _ = lift_fun R X f _,
      simp, },
    { change _ * _ * _ = _ * (_ * _),
      rw mul_assoc },
    { change (algebra_map _ _ _) * lift_fun R X f _ = lift_fun R X f _,
      simp, },
    { change lift_fun R X f _ * (algebra_map _ _ _) = lift_fun R X f _,
      simp, },
    { change _ * (_ + _) = _ * _ + _ * _,
      rw left_distrib, },
    { change (_ + _) * _ = _ * _ + _ * _,
      rw right_distrib, },
    { change (algebra_map _ _ _) * _ = algebra_map _ _ _,
      simp },
    { change _ * (algebra_map _ _ _) = algebra_map _ _ _,
      simp },
    repeat { change lift_fun R X f _ + lift_fun R X f _ = _,
      rw h_ih,
      refl, },
    repeat { change lift_fun R X f _ * lift_fun R X f _ = _,
      rw h_ih,
      refl, },
  end,
  map_one' := by { change algebra_map _ _ _ = _, simp },
  map_mul' := by { rintros ⟨⟩ ⟨⟩, refl },
  map_zero' := by { change algebra_map _ _ _ = _, simp },
  map_add' := by { rintros ⟨⟩ ⟨⟩, refl },
  commutes' := by tauto }

/--
Given a function `f : X → A` where `A` is an `R`-algebra, `lift R f` is the unique lift
of `f` to a morphism of `R`-algebras `free_algebra R X → A`.
-/
@[irreducible] def lift : (X → A) ≃ (free_algebra R X →ₐ[R] A) :=
{ to_fun := lift_aux R,
  inv_fun := λ F, F ∘ (ι R),
  left_inv := λ f, by {ext, rw [ι], refl},
  right_inv := λ F, by
  { ext x,
    rcases x,
    induction x,
    case pre.of :
    { change ((F : free_algebra R X → A) ∘ (ι R)) _ = _,
      rw [ι],
      refl },
    case pre.of_scalar :
    { change algebra_map _ _ x = F (algebra_map _ _ x),
      rw alg_hom.commutes F x, },
    case pre.add : a b ha hb
    { change lift_aux R (F ∘ ι R) (quot.mk _ _ + quot.mk _ _) = F (quot.mk _ _ + quot.mk _ _),
      rw [alg_hom.map_add, alg_hom.map_add, ha, hb], },
    case pre.mul : a b ha hb
    { change lift_aux R (F ∘ ι R) (quot.mk _ _ * quot.mk _ _) = F (quot.mk _ _ * quot.mk _ _),
      rw [alg_hom.map_mul, alg_hom.map_mul, ha, hb], }, }, }

@[simp] lemma lift_aux_eq (f : X → A) : lift_aux R f = lift R f :=
by { rw [lift], refl }

@[simp]
lemma lift_symm_apply (F : free_algebra R X →ₐ[R] A) : (lift R).symm F = F ∘ (ι R) :=
by { rw [lift], refl }

variables {R X}

@[simp]
theorem ι_comp_lift (f : X → A) :
  (lift R f : free_algebra R X → A) ∘ (ι R) = f :=
by { ext, rw [ι, lift], refl }

@[simp]
theorem lift_ι_apply (f : X → A) (x) :
  lift R f (ι R x) = f x :=
by { rw [ι, lift], refl }

@[simp]
theorem lift_unique (f : X → A) (g : free_algebra R X →ₐ[R] A) :
  (g : free_algebra R X → A) ∘ (ι R) = f ↔ g = lift R f :=
by { rw [← (lift R).symm_apply_eq, lift], refl }

/-!
Since we have set the basic definitions as `@[irreducible]`, from this point onwards one
should only use the universal properties of the free algebra, and consider the actual implementation
as a quotient of an inductive type as completely hidden. -/

-- Marking `free_algebra` irreducible makes `ring` instances inaccessible on quotients.
-- https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/algebra.2Esemiring_to_ring.20breaks.20semimodule.20typeclass.20lookup/near/212580241
-- For now, we avoid this by not marking it irreducible.

@[simp]
theorem lift_comp_ι (g : free_algebra R X →ₐ[R] A) :
  lift R ((g : free_algebra R X → A) ∘ (ι R)) = g :=
by { rw ←lift_symm_apply, exact (lift R).apply_symm_apply g }

/-- See note [partially-applied ext lemmas]. -/
@[ext]
theorem hom_ext {f g : free_algebra R X →ₐ[R] A}
  (w : ((f : free_algebra R X → A) ∘ (ι R)) = ((g : free_algebra R X → A) ∘ (ι R))) : f = g :=
begin
  rw [←lift_symm_apply, ←lift_symm_apply] at w,
  exact (lift R).symm.injective w,
end

/--
The free algebra on `X` is "just" the monoid algebra on the free monoid on `X`.

This would be useful when constructing linear maps out of a free algebra,
for example.
-/
noncomputable
def equiv_monoid_algebra_free_monoid : free_algebra R X ≃ₐ[R] monoid_algebra R (free_monoid X) :=
alg_equiv.of_alg_hom
  (lift R (λ x, (monoid_algebra.of R (free_monoid X)) (free_monoid.of x)))
  ((monoid_algebra.lift R (free_monoid X) (free_algebra R X)) (free_monoid.lift (ι R)))
begin
  apply monoid_algebra.alg_hom_ext, intro x,
  apply free_monoid.rec_on x,
  { simp, refl, },
  { intros x y ih, simp at ih, simp [ih], }
end
(by { ext, simp, })

instance [nontrivial R] : nontrivial (free_algebra R X) :=
equiv_monoid_algebra_free_monoid.surjective.nontrivial

section

/-- The left-inverse of `algebra_map`. -/
def algebra_map_inv : free_algebra R X →ₐ[R] R :=
lift R (0 : X → R)

lemma algebra_map_left_inverse :
  function.left_inverse algebra_map_inv (algebra_map R $ free_algebra R X) :=
λ x, by simp [algebra_map_inv]

@[simp] lemma algebra_map_inj (x y : R) :
  algebra_map R (free_algebra R X) x = algebra_map R (free_algebra R X) y ↔ x = y :=
algebra_map_left_inverse.injective.eq_iff

@[simp] lemma algebra_map_eq_zero_iff (x : R) : algebra_map R (free_algebra R X) x = 0 ↔ x = 0 :=
map_eq_zero_iff (algebra_map _ _) algebra_map_left_inverse.injective

@[simp] lemma algebra_map_eq_one_iff (x : R) : algebra_map R (free_algebra R X) x = 1 ↔ x = 1 :=
map_eq_one_iff (algebra_map _ _) algebra_map_left_inverse.injective

-- this proof is copied from the approach in `free_abelian_group.of_injective`
lemma ι_injective [nontrivial R] : function.injective (ι R : X → free_algebra R X) :=
λ x y hoxy, classical.by_contradiction $ by classical; exact assume hxy : x ≠ y,
  let f : free_algebra R X →ₐ[R] R :=
    lift R (λ z, if x = z then (1 : R) else 0) in
  have hfx1 : f (ι R x) = 1, from (lift_ι_apply _ _).trans $ if_pos rfl,
  have hfy1 : f (ι R y) = 1, from hoxy ▸ hfx1,
  have hfy0 : f (ι R y) = 0, from (lift_ι_apply _ _).trans $ if_neg hxy,
  one_ne_zero $ hfy1.symm.trans hfy0

@[simp] lemma ι_inj [nontrivial R] (x y : X) : ι R x = ι R y ↔ x = y :=
ι_injective.eq_iff

@[simp] lemma ι_ne_algebra_map [nontrivial R] (x : X) (r : R) : ι R x ≠ algebra_map R _ r :=
λ h,
  let f0 : free_algebra R X →ₐ[R] R := lift R 0 in
  let f1 : free_algebra R X →ₐ[R] R := lift R 1 in
  have hf0 : f0 (ι R x) = 0, from lift_ι_apply _ _,
  have hf1 : f1 (ι R x) = 1, from lift_ι_apply _ _,
  begin
    rw [h, f0.commutes, algebra.id.map_eq_self] at hf0,
    rw [h, f1.commutes, algebra.id.map_eq_self] at hf1,
    exact zero_ne_one (hf0.symm.trans hf1),
  end

@[simp] lemma ι_ne_zero [nontrivial R] (x : X) : ι R x ≠ 0 :=
ι_ne_algebra_map x 0

@[simp]

end

end free_algebra

/- There is something weird in the above namespace that breaks the typeclass resolution of
`has_coe_to_sort` below. Closing it and reopening it fixes it... -/
namespace free_algebra

/-- An induction principle for the free algebra.

If `C` holds for the `algebra_map` of `r : R` into `free_algebra R X`, the `ι` of `x : X`, and is
preserved under addition and muliplication, then it holds for all of `free_algebra R X`.
-/
@[elab_as_eliminator]
lemma induction {C : free_algebra R X → Prop}
  (h_grade0 : ∀ r, C (algebra_map R (free_algebra R X) r))
  (h_grade1 : ∀ x, C (ι R x))
  (h_mul : ∀ a b, C a → C b → C (a * b))
  (h_add : ∀ a b, C a → C b → C (a + b))
  (a : free_algebra R X) :
  C a :=
begin
  -- the arguments are enough to construct a subalgebra, and a mapping into it from X
  let s : subalgebra R (free_algebra R X) :=
  { carrier := C,
    mul_mem' := h_mul,
    add_mem' := h_add,
    algebra_map_mem' := h_grade0, },
  let of : X → s := subtype.coind (ι R) h_grade1,
  -- the mapping through the subalgebra is the identity
  have of_id : alg_hom.id R (free_algebra R X) = s.val.comp (lift R of),
  { ext,
    simp [of, subtype.coind], },
  -- finding a proof is finding an element of the subalgebra
  convert subtype.prop (lift R of a),
  simp [alg_hom.ext_iff] at of_id,
  exact of_id a,
end

end free_algebra