/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Jens Wagemaker

TODO: Provide a GCD monoid instance for `ℕ`, port GCD facts about nats
TODO: Generalize normalization monoids commutative (cancellative) monoids with or without zero
TODO: Generalize GCD monoid to not require normalization in all cases
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.associated
import Mathlib.PostPort

universes u_2 l u_1

namespace Mathlib

/-!

# Monoids with normalization functions, `gcd`, and `lcm`

This file defines extra structures on `comm_cancel_monoid_with_zero`s, including `integral_domain`s.

## Main Definitions

* `normalization_monoid`
* `gcd_monoid`
* `gcd_monoid_of_exists_gcd`
* `gcd_monoid_of_exists_lcm`

## Implementation Notes

* `normalization_monoid` is defined by assigning to each element a `norm_unit` such that multiplying
by that unit normalizes the monoid, and `normalize` is an idempotent monoid homomorphism. This
definition as currently implemented does casework on `0`.

* `gcd_monoid` extends `normalization_monoid`, so the `gcd` and `lcm` are always normalized.
This makes `gcd`s of polynomials easier to work with, but excludes Euclidean domains, and monoids
without zero.

* `gcd_monoid_of_gcd` noncomputably constructs a `gcd_monoid` structure just from the `gcd`
  and its properties.

* `gcd_monoid_of_exists_gcd` noncomputably constructs a `gcd_monoid` structure just from a proof
  that any two elements have a (not necessarily normalized) `gcd`.

* `gcd_monoid_of_lcm` noncomputably constructs a `gcd_monoid` structure just from the `lcm`
  and its properties.

* `gcd_monoid_of_exists_lcm` noncomputably constructs a `gcd_monoid` structure just from a proof
  that any two elements have a (not necessarily normalized) `lcm`.

## TODO

* Provide a GCD monoid instance for `ℕ`, port GCD facts about nats, definition of coprime
* Generalize normalization monoids to commutative (cancellative) monoids with or without zero
* Generalize GCD monoid to not require normalization in all cases

## Tags

divisibility, gcd, lcm, normalize

-/

/-- Normalization monoid: multiplying with `norm_unit` gives a normal form for associated
elements. -/
class normalization_monoid (α : Type u_2) [nontrivial α] [comm_cancel_monoid_with_zero α] where
  norm_unit : α → units α
  norm_unit_zero : norm_unit 0 = 1
  norm_unit_mul : ∀ {a b : α}, a ≠ 0 → b ≠ 0 → norm_unit (a * b) = norm_unit a * norm_unit b
  norm_unit_coe_units : ∀ (u : units α), norm_unit ↑u = (u⁻¹)

@[simp] theorem norm_unit_one {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] : norm_unit 1 = 1 :=
  norm_unit_coe_units 1

/-- Chooses an element of each associate class, by multiplying by `norm_unit` -/
def normalize {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] : monoid_with_zero_hom α α :=
  monoid_with_zero_hom.mk (fun (x : α) => x * ↑(norm_unit x)) sorry sorry sorry

theorem associated_normalize {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] {x : α} : associated x (coe_fn normalize x) :=
  Exists.intro (norm_unit x) rfl

theorem normalize_associated {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] {x : α} : associated (coe_fn normalize x) x :=
  associated.symm associated_normalize

theorem associates.mk_normalize {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] {x : α} : associates.mk (coe_fn normalize x) = associates.mk x :=
  iff.mpr associates.mk_eq_mk_iff_associated normalize_associated

@[simp] theorem normalize_apply {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] {x : α} : coe_fn normalize x = x * ↑(norm_unit x) :=
  rfl

@[simp] theorem normalize_zero {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] : coe_fn normalize 0 = 0 :=
  monoid_with_zero_hom.map_zero normalize

@[simp] theorem normalize_one {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] : coe_fn normalize 1 = 1 :=
  monoid_with_zero_hom.map_one normalize

theorem normalize_coe_units {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] (u : units α) : coe_fn normalize ↑u = 1 :=
  sorry

theorem normalize_eq_zero {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] {x : α} : coe_fn normalize x = 0 ↔ x = 0 :=
  { mp :=
      fun (hx : coe_fn normalize x = 0) =>
        iff.mp (associated_zero_iff_eq_zero x) (hx ▸ associated_normalize),
    mpr := fun (ᾰ : x = 0) => Eq._oldrec normalize_zero (Eq.symm ᾰ) }

theorem normalize_eq_one {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] {x : α} : coe_fn normalize x = 1 ↔ is_unit x :=
  sorry

@[simp] theorem norm_unit_mul_norm_unit {α : Type u_1} [comm_cancel_monoid_with_zero α]
    [nontrivial α] [normalization_monoid α] (a : α) : norm_unit (a * ↑(norm_unit a)) = 1 :=
  sorry

theorem normalize_idem {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] (x : α) : coe_fn normalize (coe_fn normalize x) = coe_fn normalize x :=
  sorry

theorem normalize_eq_normalize {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] {a : α} {b : α} (hab : a ∣ b) (hba : b ∣ a) :
    coe_fn normalize a = coe_fn normalize b :=
  sorry

theorem normalize_eq_normalize_iff {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] {x : α} {y : α} :
    coe_fn normalize x = coe_fn normalize y ↔ x ∣ y ∧ y ∣ x :=
  sorry

theorem dvd_antisymm_of_normalize_eq {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] {a : α} {b : α} (ha : coe_fn normalize a = a)
    (hb : coe_fn normalize b = b) (hab : a ∣ b) (hba : b ∣ a) : a = b :=
  ha ▸ hb ▸ normalize_eq_normalize hab hba

--can be proven by simp

theorem dvd_normalize_iff {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] {a : α} {b : α} : a ∣ coe_fn normalize b ↔ a ∣ b :=
  units.dvd_mul_right

--can be proven by simp

theorem normalize_dvd_iff {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] {a : α} {b : α} : coe_fn normalize a ∣ b ↔ a ∣ b :=
  units.mul_right_dvd

namespace comm_group_with_zero

protected instance normalization_monoid {α : Type u_1} [DecidableEq α] [comm_group_with_zero α] :
    normalization_monoid α :=
  normalization_monoid.mk
    (fun (x : α) => dite (x = 0) (fun (h : x = 0) => 1) fun (h : ¬x = 0) => units.mk0 x h⁻¹) sorry
    sorry sorry

@[simp] theorem coe_norm_unit {α : Type u_1} [DecidableEq α] [comm_group_with_zero α] {a : α}
    (h0 : a ≠ 0) : ↑(norm_unit a) = (a⁻¹) :=
  sorry

end comm_group_with_zero

namespace associates

/-- Maps an element of `associates` back to the normalized element of its associate class -/
protected def out {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] : associates α → α :=
  quotient.lift ⇑normalize sorry

theorem out_mk {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] (a : α) : associates.out (associates.mk a) = coe_fn normalize a :=
  rfl

@[simp] theorem out_one {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] : associates.out 1 = 1 :=
  normalize_one

theorem out_mul {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] (a : associates α) (b : associates α) :
    associates.out (a * b) = associates.out a * associates.out b :=
  sorry

theorem dvd_out_iff {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] (a : α) (b : associates α) :
    a ∣ associates.out b ↔ associates.mk a ≤ b :=
  sorry

theorem out_dvd_iff {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] (a : α) (b : associates α) :
    associates.out b ∣ a ↔ b ≤ associates.mk a :=
  sorry

@[simp] theorem out_top {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] : associates.out ⊤ = 0 :=
  normalize_zero

@[simp] theorem normalize_out {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] (a : associates α) :
    coe_fn normalize (associates.out a) = associates.out a :=
  quotient.induction_on a normalize_idem

end associates

/-- GCD monoid: a `comm_cancel_monoid_with_zero` with normalization and `gcd`
(greatest common divisor) and `lcm` (least common multiple) operations. In this setting `gcd` and
`lcm` form a bounded lattice on the associated elements where `gcd` is the infimum, `lcm` is the
supremum, `1` is bottom, and `0` is top. The type class focuses on `gcd` and we derive the
corresponding `lcm` facts from `gcd`.
-/
class gcd_monoid (α : Type u_2) [comm_cancel_monoid_with_zero α] [nontrivial α]
    extends normalization_monoid α where
  gcd : α → α → α
  lcm : α → α → α
  gcd_dvd_left : ∀ (a b : α), gcd a b ∣ a
  gcd_dvd_right : ∀ (a b : α), gcd a b ∣ b
  dvd_gcd : ∀ {a b c : α}, a ∣ c → a ∣ b → a ∣ gcd c b
  normalize_gcd : ∀ (a b : α), coe_fn normalize (gcd a b) = gcd a b
  gcd_mul_lcm : ∀ (a b : α), gcd a b * lcm a b = coe_fn normalize (a * b)
  lcm_zero_left : ∀ (a : α), lcm 0 a = 0
  lcm_zero_right : ∀ (a : α), lcm a 0 = 0

@[simp] theorem normalize_gcd {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) (b : α) : coe_fn normalize (gcd a b) = gcd a b :=
  gcd_monoid.normalize_gcd

@[simp] theorem gcd_mul_lcm {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) (b : α) : gcd a b * lcm a b = coe_fn normalize (a * b) :=
  gcd_monoid.gcd_mul_lcm

theorem dvd_gcd_iff {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α]
    (a : α) (b : α) (c : α) : a ∣ gcd b c ↔ a ∣ b ∧ a ∣ c :=
  sorry

theorem gcd_comm {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α]
    (a : α) (b : α) : gcd a b = gcd b a :=
  dvd_antisymm_of_normalize_eq (normalize_gcd a b) (normalize_gcd b a)
    (dvd_gcd (gcd_dvd_right a b) (gcd_dvd_left a b))
    (dvd_gcd (gcd_dvd_right b a) (gcd_dvd_left b a))

theorem gcd_assoc {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α]
    (m : α) (n : α) (k : α) : gcd (gcd m n) k = gcd m (gcd n k) :=
  sorry

protected instance gcd_monoid.gcd.is_commutative {α : Type u_1} [comm_cancel_monoid_with_zero α]
    [nontrivial α] [gcd_monoid α] : is_commutative α gcd :=
  is_commutative.mk gcd_comm

protected instance gcd_monoid.gcd.is_associative {α : Type u_1} [comm_cancel_monoid_with_zero α]
    [nontrivial α] [gcd_monoid α] : is_associative α gcd :=
  is_associative.mk gcd_assoc

theorem gcd_eq_normalize {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] {a : α} {b : α} {c : α} (habc : gcd a b ∣ c) (hcab : c ∣ gcd a b) :
    gcd a b = coe_fn normalize c :=
  normalize_gcd a b ▸ normalize_eq_normalize habc hcab

@[simp] theorem gcd_zero_left {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) : gcd 0 a = coe_fn normalize a :=
  gcd_eq_normalize (gcd_dvd_right 0 a) (dvd_gcd (dvd_zero a) (dvd_refl a))

@[simp] theorem gcd_zero_right {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) : gcd a 0 = coe_fn normalize a :=
  gcd_eq_normalize (gcd_dvd_left a 0) (dvd_gcd (dvd_refl a) (dvd_zero a))

@[simp] theorem gcd_eq_zero_iff {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) (b : α) : gcd a b = 0 ↔ a = 0 ∧ b = 0 :=
  sorry

@[simp] theorem gcd_one_left {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) : gcd 1 a = 1 :=
  dvd_antisymm_of_normalize_eq (normalize_gcd 1 a) normalize_one (gcd_dvd_left 1 a)
    (one_dvd (gcd 1 a))

@[simp] theorem gcd_one_right {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) : gcd a 1 = 1 :=
  dvd_antisymm_of_normalize_eq (normalize_gcd a 1) normalize_one (gcd_dvd_right a 1)
    (one_dvd (gcd a 1))

theorem gcd_dvd_gcd {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α]
    {a : α} {b : α} {c : α} {d : α} (hab : a ∣ b) (hcd : c ∣ d) : gcd a c ∣ gcd b d :=
  dvd_gcd (dvd.trans (gcd_dvd_left a c) hab) (dvd.trans (gcd_dvd_right a c) hcd)

@[simp] theorem gcd_same {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) : gcd a a = coe_fn normalize a :=
  gcd_eq_normalize (gcd_dvd_left a a) (dvd_gcd (dvd_refl a) (dvd_refl a))

@[simp] theorem gcd_mul_left {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) (b : α) (c : α) : gcd (a * b) (a * c) = coe_fn normalize a * gcd b c :=
  sorry

@[simp] theorem gcd_mul_right {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) (b : α) (c : α) : gcd (b * a) (c * a) = gcd b c * coe_fn normalize a :=
  sorry

theorem gcd_eq_left_iff {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) (b : α) (h : coe_fn normalize a = a) : gcd a b = a ↔ a ∣ b :=
  sorry

theorem gcd_eq_right_iff {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) (b : α) (h : coe_fn normalize b = b) : gcd a b = b ↔ b ∣ a :=
  sorry

theorem gcd_dvd_gcd_mul_left {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (m : α) (n : α) (k : α) : gcd m n ∣ gcd (k * m) n :=
  gcd_dvd_gcd (dvd_mul_left m k) (dvd_refl n)

theorem gcd_dvd_gcd_mul_right {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (m : α) (n : α) (k : α) : gcd m n ∣ gcd (m * k) n :=
  gcd_dvd_gcd (dvd_mul_right m k) (dvd_refl n)

theorem gcd_dvd_gcd_mul_left_right {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (m : α) (n : α) (k : α) : gcd m n ∣ gcd m (k * n) :=
  gcd_dvd_gcd (dvd_refl m) (dvd_mul_left n k)

theorem gcd_dvd_gcd_mul_right_right {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (m : α) (n : α) (k : α) : gcd m n ∣ gcd m (n * k) :=
  gcd_dvd_gcd (dvd_refl m) (dvd_mul_right n k)

theorem gcd_eq_of_associated_left {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] {m : α} {n : α} (h : associated m n) (k : α) : gcd m k = gcd n k :=
  dvd_antisymm_of_normalize_eq (normalize_gcd m k) (normalize_gcd n k)
    (gcd_dvd_gcd (dvd_of_associated h) (dvd_refl k))
    (gcd_dvd_gcd (dvd_of_associated (associated.symm h)) (dvd_refl k))

theorem gcd_eq_of_associated_right {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] {m : α} {n : α} (h : associated m n) (k : α) : gcd k m = gcd k n :=
  dvd_antisymm_of_normalize_eq (normalize_gcd k m) (normalize_gcd k n)
    (gcd_dvd_gcd (dvd_refl k) (dvd_of_associated h))
    (gcd_dvd_gcd (dvd_refl k) (dvd_of_associated (associated.symm h)))

theorem dvd_gcd_mul_of_dvd_mul {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] {m : α} {n : α} {k : α} (H : k ∣ m * n) : k ∣ gcd k m * n :=
  sorry

theorem dvd_mul_gcd_of_dvd_mul {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] {m : α} {n : α} {k : α} (H : k ∣ m * n) : k ∣ m * gcd k n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (k ∣ m * gcd k n)) (mul_comm m (gcd k n))))
    (dvd_gcd_mul_of_dvd_mul (eq.mp (Eq._oldrec (Eq.refl (k ∣ m * n)) (mul_comm m n)) H))

/-- Represent a divisor of `m * n` as a product of a divisor of `m` and a divisor of `n`.

 Note: In general, this representation is highly non-unique. -/
theorem exists_dvd_and_dvd_of_dvd_mul {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] {m : α} {n : α} {k : α} (H : k ∣ m * n) :
    ∃ (d₁ : α), ∃ (hd₁ : d₁ ∣ m), ∃ (d₂ : α), ∃ (hd₂ : d₂ ∣ n), k = d₁ * d₂ :=
  sorry

theorem gcd_mul_dvd_mul_gcd {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (k : α) (m : α) (n : α) : gcd k (m * n) ∣ gcd k m * gcd k n :=
  sorry

theorem gcd_pow_right_dvd_pow_gcd {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] {a : α} {b : α} {k : ℕ} : gcd a (b ^ k) ∣ gcd a b ^ k :=
  sorry

theorem gcd_pow_left_dvd_pow_gcd {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] {a : α} {b : α} {k : ℕ} : gcd (a ^ k) b ∣ gcd a b ^ k :=
  eq.mpr (id (Eq._oldrec (Eq.refl (gcd (a ^ k) b ∣ gcd a b ^ k)) (gcd_comm (a ^ k) b)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (gcd b (a ^ k) ∣ gcd a b ^ k)) (gcd_comm a b)))
      gcd_pow_right_dvd_pow_gcd)

theorem pow_dvd_of_mul_eq_pow {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] {a : α} {b : α} {c : α} {d₁ : α} {d₂ : α} (ha : a ≠ 0) (hab : gcd a b = 1)
    {k : ℕ} (h : a * b = c ^ k) (hc : c = d₁ * d₂) (hd₁ : d₁ ∣ a) : d₁ ^ k ≠ 0 ∧ d₁ ^ k ∣ a :=
  sorry

theorem exists_associated_pow_of_mul_eq_pow {α : Type u_1} [comm_cancel_monoid_with_zero α]
    [nontrivial α] [gcd_monoid α] {a : α} {b : α} {c : α} (hab : gcd a b = 1) {k : ℕ}
    (h : a * b = c ^ k) : ∃ (d : α), associated (d ^ k) a :=
  sorry

theorem lcm_dvd_iff {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α]
    {a : α} {b : α} {c : α} : lcm a b ∣ c ↔ a ∣ c ∧ b ∣ c :=
  sorry

theorem dvd_lcm_left {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α]
    (a : α) (b : α) : a ∣ lcm a b :=
  and.left (iff.mp lcm_dvd_iff (dvd_refl (lcm a b)))

theorem dvd_lcm_right {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α]
    (a : α) (b : α) : b ∣ lcm a b :=
  and.right (iff.mp lcm_dvd_iff (dvd_refl (lcm a b)))

theorem lcm_dvd {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α]
    {a : α} {b : α} {c : α} (hab : a ∣ b) (hcb : c ∣ b) : lcm a c ∣ b :=
  iff.mpr lcm_dvd_iff { left := hab, right := hcb }

@[simp] theorem lcm_eq_zero_iff {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) (b : α) : lcm a b = 0 ↔ a = 0 ∨ b = 0 :=
  sorry

@[simp] theorem normalize_lcm {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) (b : α) : coe_fn normalize (lcm a b) = lcm a b :=
  sorry

theorem lcm_comm {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α]
    (a : α) (b : α) : lcm a b = lcm b a :=
  dvd_antisymm_of_normalize_eq (normalize_lcm a b) (normalize_lcm b a)
    (lcm_dvd (dvd_lcm_right b a) (dvd_lcm_left b a))
    (lcm_dvd (dvd_lcm_right a b) (dvd_lcm_left a b))

theorem lcm_assoc {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α]
    (m : α) (n : α) (k : α) : lcm (lcm m n) k = lcm m (lcm n k) :=
  sorry

protected instance gcd_monoid.lcm.is_commutative {α : Type u_1} [comm_cancel_monoid_with_zero α]
    [nontrivial α] [gcd_monoid α] : is_commutative α lcm :=
  is_commutative.mk lcm_comm

protected instance gcd_monoid.lcm.is_associative {α : Type u_1} [comm_cancel_monoid_with_zero α]
    [nontrivial α] [gcd_monoid α] : is_associative α lcm :=
  is_associative.mk lcm_assoc

theorem lcm_eq_normalize {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] {a : α} {b : α} {c : α} (habc : lcm a b ∣ c) (hcab : c ∣ lcm a b) :
    lcm a b = coe_fn normalize c :=
  normalize_lcm a b ▸ normalize_eq_normalize habc hcab

theorem lcm_dvd_lcm {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α]
    {a : α} {b : α} {c : α} {d : α} (hab : a ∣ b) (hcd : c ∣ d) : lcm a c ∣ lcm b d :=
  lcm_dvd (dvd.trans hab (dvd_lcm_left b d)) (dvd.trans hcd (dvd_lcm_right b d))

@[simp] theorem lcm_units_coe_left {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (u : units α) (a : α) : lcm (↑u) a = coe_fn normalize a :=
  lcm_eq_normalize (lcm_dvd units.coe_dvd (dvd_refl a)) (dvd_lcm_right (↑u) a)

@[simp] theorem lcm_units_coe_right {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) (u : units α) : lcm a ↑u = coe_fn normalize a :=
  Eq.trans (lcm_comm a ↑u) (lcm_units_coe_left u a)

@[simp] theorem lcm_one_left {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) : lcm 1 a = coe_fn normalize a :=
  lcm_units_coe_left 1 a

@[simp] theorem lcm_one_right {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) : lcm a 1 = coe_fn normalize a :=
  lcm_units_coe_right a 1

@[simp] theorem lcm_same {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) : lcm a a = coe_fn normalize a :=
  lcm_eq_normalize (lcm_dvd (dvd_refl a) (dvd_refl a)) (dvd_lcm_left a a)

@[simp] theorem lcm_eq_one_iff {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) (b : α) : lcm a b = 1 ↔ a ∣ 1 ∧ b ∣ 1 :=
  sorry

@[simp] theorem lcm_mul_left {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) (b : α) (c : α) : lcm (a * b) (a * c) = coe_fn normalize a * lcm b c :=
  sorry

@[simp] theorem lcm_mul_right {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) (b : α) (c : α) : lcm (b * a) (c * a) = lcm b c * coe_fn normalize a :=
  sorry

theorem lcm_eq_left_iff {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) (b : α) (h : coe_fn normalize a = a) : lcm a b = a ↔ b ∣ a :=
  sorry

theorem lcm_eq_right_iff {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (a : α) (b : α) (h : coe_fn normalize b = b) : lcm a b = b ↔ a ∣ b :=
  sorry

theorem lcm_dvd_lcm_mul_left {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (m : α) (n : α) (k : α) : lcm m n ∣ lcm (k * m) n :=
  lcm_dvd_lcm (dvd_mul_left m k) (dvd_refl n)

theorem lcm_dvd_lcm_mul_right {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (m : α) (n : α) (k : α) : lcm m n ∣ lcm (m * k) n :=
  lcm_dvd_lcm (dvd_mul_right m k) (dvd_refl n)

theorem lcm_dvd_lcm_mul_left_right {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (m : α) (n : α) (k : α) : lcm m n ∣ lcm m (k * n) :=
  lcm_dvd_lcm (dvd_refl m) (dvd_mul_left n k)

theorem lcm_dvd_lcm_mul_right_right {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] (m : α) (n : α) (k : α) : lcm m n ∣ lcm m (n * k) :=
  lcm_dvd_lcm (dvd_refl m) (dvd_mul_right n k)

theorem lcm_eq_of_associated_left {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] {m : α} {n : α} (h : associated m n) (k : α) : lcm m k = lcm n k :=
  dvd_antisymm_of_normalize_eq (normalize_lcm m k) (normalize_lcm n k)
    (lcm_dvd_lcm (dvd_of_associated h) (dvd_refl k))
    (lcm_dvd_lcm (dvd_of_associated (associated.symm h)) (dvd_refl k))

theorem lcm_eq_of_associated_right {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] {m : α} {n : α} (h : associated m n) (k : α) : lcm k m = lcm k n :=
  dvd_antisymm_of_normalize_eq (normalize_lcm k m) (normalize_lcm k n)
    (lcm_dvd_lcm (dvd_refl k) (dvd_of_associated h))
    (lcm_dvd_lcm (dvd_refl k) (dvd_of_associated (associated.symm h)))

namespace gcd_monoid

theorem prime_of_irreducible {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] {x : α} (hi : irreducible x) : prime x :=
  sorry

theorem irreducible_iff_prime {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [gcd_monoid α] {p : α} : irreducible p ↔ prime p :=
  { mp := prime_of_irreducible, mpr := irreducible_of_prime }

end gcd_monoid

theorem units_eq_one {α : Type u_1} [comm_cancel_monoid_with_zero α] [unique (units α)]
    (u : units α) : u = 1 :=
  subsingleton.elim u 1

protected instance normalization_monoid_of_unique_units {α : Type u_1}
    [comm_cancel_monoid_with_zero α] [unique (units α)] [nontrivial α] : normalization_monoid α :=
  normalization_monoid.mk (fun (x : α) => 1) sorry sorry sorry

@[simp] theorem norm_unit_eq_one {α : Type u_1} [comm_cancel_monoid_with_zero α] [unique (units α)]
    [nontrivial α] (x : α) : norm_unit x = 1 :=
  rfl

@[simp] theorem normalize_eq {α : Type u_1} [comm_cancel_monoid_with_zero α] [unique (units α)]
    [nontrivial α] (x : α) : coe_fn normalize x = x :=
  mul_one x

theorem gcd_eq_of_dvd_sub_right {α : Type u_1} [integral_domain α] [gcd_monoid α] {a : α} {b : α}
    {c : α} (h : a ∣ b - c) : gcd a b = gcd a c :=
  sorry

theorem gcd_eq_of_dvd_sub_left {α : Type u_1} [integral_domain α] [gcd_monoid α] {a : α} {b : α}
    {c : α} (h : a ∣ b - c) : gcd b a = gcd c a :=
  eq.mpr (id (Eq._oldrec (Eq.refl (gcd b a = gcd c a)) (gcd_comm b a)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (gcd a b = gcd c a)) (gcd_comm c a)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (gcd a b = gcd a c)) (gcd_eq_of_dvd_sub_right h)))
        (Eq.refl (gcd a c))))

/-- Define `normalization_monoid` on a structure from a `monoid_hom` inverse to `associates.mk`. -/
def normalization_monoid_of_monoid_hom_right_inverse {α : Type u_1} [comm_cancel_monoid_with_zero α]
    [nontrivial α] [DecidableEq α] (f : associates α →* α)
    (hinv : function.right_inverse (⇑f) associates.mk) : normalization_monoid α :=
  normalization_monoid.mk (fun (a : α) => ite (a = 0) 1 (classical.some sorry)) sorry sorry sorry

/-- Define `gcd_monoid` on a structure just from the `gcd` and its properties. -/
def gcd_monoid_of_gcd {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] [DecidableEq α] (gcd : α → α → α)
    (gcd_dvd_left : ∀ (a b : α), gcd a b ∣ a) (gcd_dvd_right : ∀ (a b : α), gcd a b ∣ b)
    (dvd_gcd : ∀ {a b c : α}, a ∣ c → a ∣ b → a ∣ gcd c b)
    (normalize_gcd : ∀ (a b : α), coe_fn normalize (gcd a b) = gcd a b) : gcd_monoid α :=
  gcd_monoid.mk norm_unit sorry sorry sorry gcd
    (fun (a b : α) => ite (a = 0) 0 (classical.some sorry)) gcd_dvd_left gcd_dvd_right sorry
    normalize_gcd sorry sorry sorry

/-- Define `gcd_monoid` on a structure just from the `lcm` and its properties. -/
def gcd_monoid_of_lcm {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] [DecidableEq α] (lcm : α → α → α)
    (dvd_lcm_left : ∀ (a b : α), a ∣ lcm a b) (dvd_lcm_right : ∀ (a b : α), b ∣ lcm a b)
    (lcm_dvd : ∀ {a b c : α}, c ∣ a → b ∣ a → lcm c b ∣ a)
    (normalize_lcm : ∀ (a b : α), coe_fn normalize (lcm a b) = lcm a b) : gcd_monoid α :=
  let exists_gcd : ∀ (a b : α), lcm a b ∣ coe_fn normalize (a * b) := sorry;
  gcd_monoid.mk norm_unit sorry sorry sorry
    (fun (a b : α) =>
      ite (a = 0) (coe_fn normalize b)
        (ite (b = 0) (coe_fn normalize a) (classical.some (exists_gcd a b))))
    lcm sorry sorry sorry sorry sorry sorry sorry

/-- Define a `gcd_monoid` structure on a monoid just from the existence of a `gcd`. -/
def gcd_monoid_of_exists_gcd {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] [DecidableEq α]
    (h : ∀ (a b : α), ∃ (c : α), ∀ (d : α), d ∣ a ∧ d ∣ b ↔ d ∣ c) : gcd_monoid α :=
  gcd_monoid_of_gcd (fun (a b : α) => coe_fn normalize (classical.some (h a b))) sorry sorry sorry
    sorry

/-- Define a `gcd_monoid` structure on a monoid just from the existence of an `lcm`. -/
def gcd_monoid_of_exists_lcm {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α]
    [normalization_monoid α] [DecidableEq α]
    (h : ∀ (a b : α), ∃ (c : α), ∀ (d : α), a ∣ d ∧ b ∣ d ↔ c ∣ d) : gcd_monoid α :=
  gcd_monoid_of_lcm (fun (a b : α) => coe_fn normalize (classical.some (h a b))) sorry sorry sorry
    sorry

end Mathlib


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.set.finite
import Mathlib.algebra.big_operators.basic
import Mathlib.PostPort

universes u v u_1 x

namespace Mathlib

/-!
# Preimage of a `finset` under an injective map.
-/

namespace finset

/-- Preimage of `s : finset β` under a map `f` injective of `f ⁻¹' s` as a `finset`.  -/
def preimage {α : Type u} {β : Type v} (s : finset β) (f : α → β) (hf : set.inj_on f (f ⁻¹' ↑s)) :
    finset α :=
  set.finite.to_finset sorry

@[simp] theorem mem_preimage {α : Type u} {β : Type v} {f : α → β} {s : finset β}
    {hf : set.inj_on f (f ⁻¹' ↑s)} {x : α} : x ∈ preimage s f hf ↔ f x ∈ s :=
  set.finite.mem_to_finset

@[simp] theorem coe_preimage {α : Type u} {β : Type v} {f : α → β} (s : finset β)
    (hf : set.inj_on f (f ⁻¹' ↑s)) : ↑(preimage s f hf) = f ⁻¹' ↑s :=
  set.finite.coe_to_finset (preimage._proof_1 s f hf)

@[simp] theorem preimage_empty {α : Type u} {β : Type v} {f : α → β} :
    preimage ∅ f
          (eq.mpr
            (id
              (Eq.trans
                (Eq.trans
                  (Eq.trans
                    ((fun (f f_1 : α → β) (e_1 : f = f_1) (s s_1 : set α) (e_2 : s = s_1) =>
                        congr (congr_arg set.inj_on e_1) e_2)
                      f f (Eq.refl f) (f ⁻¹' ↑∅) ∅
                      (Eq.trans
                        ((fun (f f_1 : α → β) (e_1 : f = f_1) (s s_1 : set β) (e_2 : s = s_1) =>
                            congr (congr_arg set.preimage e_1) e_2)
                          f f (Eq.refl f) ↑∅ ∅ coe_empty)
                        set.preimage_empty))
                    (set.inj_on.equations._eqn_1 f ∅))
                  (forall_congr_eq
                    fun (x₁ : α) =>
                      Eq.trans
                        (imp_congr_eq (set.mem_empty_eq x₁)
                          (Eq.trans
                            (forall_congr_eq
                              fun (x₂ : α) =>
                                Eq.trans
                                  (imp_congr_eq (set.mem_empty_eq x₂)
                                    (Eq.refl (f x₁ = f x₂ → x₁ = x₂)))
                                  (propext
                                    (forall_prop_of_false (iff.mpr not_false_iff True.intro))))
                            (propext forall_true_iff)))
                        (propext (forall_prop_of_false (iff.mpr not_false_iff True.intro)))))
                (propext forall_true_iff)))
            trivial) =
        ∅ :=
  sorry

@[simp] theorem preimage_univ {α : Type u} {β : Type v} {f : α → β} [fintype α] [fintype β]
    (hf : set.inj_on f (f ⁻¹' ↑univ)) : preimage univ f hf = univ :=
  sorry

@[simp] theorem preimage_inter {α : Type u} {β : Type v} [DecidableEq α] [DecidableEq β] {f : α → β}
    {s : finset β} {t : finset β} (hs : set.inj_on f (f ⁻¹' ↑s)) (ht : set.inj_on f (f ⁻¹' ↑t)) :
    (preimage (s ∩ t) f
          fun (x₁ : α) (hx₁ : x₁ ∈ f ⁻¹' ↑(s ∩ t)) (x₂ : α) (hx₂ : x₂ ∈ f ⁻¹' ↑(s ∩ t)) =>
            hs (mem_of_mem_inter_left hx₁) (mem_of_mem_inter_left hx₂)) =
        preimage s f hs ∩ preimage t f ht :=
  sorry

@[simp] theorem preimage_union {α : Type u} {β : Type v} [DecidableEq α] [DecidableEq β] {f : α → β}
    {s : finset β} {t : finset β} (hst : set.inj_on f (f ⁻¹' ↑(s ∪ t))) :
    preimage (s ∪ t) f hst =
        (preimage s f
            fun (x₁ : α) (hx₁ : x₁ ∈ f ⁻¹' ↑s) (x₂ : α) (hx₂ : x₂ ∈ f ⁻¹' ↑s) =>
              hst (mem_union_left t hx₁) (mem_union_left t hx₂)) ∪
          preimage t f
            fun (x₁ : α) (hx₁ : x₁ ∈ f ⁻¹' ↑t) (x₂ : α) (hx₂ : x₂ ∈ f ⁻¹' ↑t) =>
              hst (mem_union_right s hx₁) (mem_union_right s hx₂) :=
  sorry

@[simp] theorem preimage_compl {α : Type u} {β : Type v} [DecidableEq α] [DecidableEq β] [fintype α]
    [fintype β] {f : α → β} (s : finset β) (hf : function.injective f) :
    preimage (sᶜ) f (function.injective.inj_on hf (f ⁻¹' ↑(sᶜ))) =
        (preimage s f (function.injective.inj_on hf (f ⁻¹' ↑s))ᶜ) :=
  sorry

theorem monotone_preimage {α : Type u} {β : Type v} {f : α → β} (h : function.injective f) :
    monotone fun (s : finset β) => preimage s f (function.injective.inj_on h (f ⁻¹' ↑s)) :=
  fun (s t : finset β) (hst : s ≤ t) (x : α)
    (hx : x ∈ (fun (s : finset β) => preimage s f (function.injective.inj_on h (f ⁻¹' ↑s))) s) =>
    iff.mpr mem_preimage (hst (iff.mp mem_preimage hx))

theorem image_subset_iff_subset_preimage {α : Type u} {β : Type v} [DecidableEq β] {f : α → β}
    {s : finset α} {t : finset β} (hf : set.inj_on f (f ⁻¹' ↑t)) :
    image f s ⊆ t ↔ s ⊆ preimage t f hf :=
  sorry

theorem map_subset_iff_subset_preimage {α : Type u} {β : Type v} {f : α ↪ β} {s : finset α}
    {t : finset β} :
    map f s ⊆ t ↔
        s ⊆
          preimage t (⇑f)
            (function.injective.inj_on (function.embedding.injective f) (⇑f ⁻¹' ↑t)) :=
  sorry

theorem image_preimage {α : Type u} {β : Type v} [DecidableEq β] (f : α → β) (s : finset β)
    [(x : β) → Decidable (x ∈ set.range f)] (hf : set.inj_on f (f ⁻¹' ↑s)) :
    image f (preimage s f hf) = filter (fun (x : β) => x ∈ set.range f) s :=
  sorry

theorem image_preimage_of_bij {α : Type u} {β : Type v} [DecidableEq β] (f : α → β) (s : finset β)
    (hf : set.bij_on f (f ⁻¹' ↑s) ↑s) : image f (preimage s f (set.bij_on.inj_on hf)) = s :=
  sorry

theorem sigma_preimage_mk {α : Type u} {β : α → Type u_1} [DecidableEq α]
    (s : finset (sigma fun (a : α) => β a)) (t : finset α) :
    (finset.sigma t
          fun (a : α) =>
            preimage s (sigma.mk a)
              (function.injective.inj_on sigma_mk_injective (sigma.mk a ⁻¹' ↑s))) =
        filter (fun (a : sigma fun (a : α) => β a) => sigma.fst a ∈ t) s :=
  sorry

theorem sigma_preimage_mk_of_subset {α : Type u} {β : α → Type u_1} [DecidableEq α]
    (s : finset (sigma fun (a : α) => β a)) {t : finset α} (ht : image sigma.fst s ⊆ t) :
    (finset.sigma t
          fun (a : α) =>
            preimage s (sigma.mk a)
              (function.injective.inj_on sigma_mk_injective (sigma.mk a ⁻¹' ↑s))) =
        s :=
  sorry

theorem sigma_image_fst_preimage_mk {α : Type u} {β : α → Type u_1} [DecidableEq α]
    (s : finset (sigma fun (a : α) => β a)) :
    (finset.sigma (image sigma.fst s)
          fun (a : α) =>
            preimage s (sigma.mk a)
              (function.injective.inj_on sigma_mk_injective (sigma.mk a ⁻¹' ↑s))) =
        s :=
  sigma_preimage_mk_of_subset s (subset.refl (image sigma.fst s))

theorem prod_preimage' {α : Type u} {β : Type v} {γ : Type x} [comm_monoid β] (f : α → γ)
    [decidable_pred fun (x : γ) => x ∈ set.range f] (s : finset γ) (hf : set.inj_on f (f ⁻¹' ↑s))
    (g : γ → β) :
    (finset.prod (preimage s f hf) fun (x : α) => g (f x)) =
        finset.prod (filter (fun (x : γ) => x ∈ set.range f) s) fun (x : γ) => g x :=
  sorry

theorem prod_preimage {α : Type u} {β : Type v} {γ : Type x} [comm_monoid β] (f : α → γ)
    (s : finset γ) (hf : set.inj_on f (f ⁻¹' ↑s)) (g : γ → β)
    (hg : ∀ (x : γ), x ∈ s → ¬x ∈ set.range f → g x = 1) :
    (finset.prod (preimage s f hf) fun (x : α) => g (f x)) = finset.prod s fun (x : γ) => g x :=
  sorry

theorem sum_preimage_of_bij {α : Type u} {β : Type v} {γ : Type x} [add_comm_monoid β] (f : α → γ)
    (s : finset γ) (hf : set.bij_on f (f ⁻¹' ↑s) ↑s) (g : γ → β) :
    (finset.sum (preimage s f (set.bij_on.inj_on hf)) fun (x : α) => g (f x)) =
        finset.sum s fun (x : γ) => g x :=
  sum_preimage f s (set.bij_on.inj_on hf) g
    fun (x : γ) (hxs : x ∈ s) (hxf : ¬x ∈ set.range f) =>
      false.elim (hxf (set.bij_on.subset_range hf hxs))

end Mathlib


import order.monotone.basic
import init.data.fin.basic
import order.hom.basic
import tactic
import set_theory.cardinal.finite
import combinatorics.pigeonhole

#check order_embedding

noncomputable theory
open_locale classical
variables {α β γ : Type*} [preorder α] [preorder β] [preorder γ]

def order_embedding.refl : α ↪o α:=
  (order_iso.refl α).to_order_embedding

@[reducible] def order_embedding.remap (f: α ↪o β) {Y: finset β} (h: ∀ x : α, f x ∈ Y): (α ↪o Y):=
{ to_fun := λ x, ⟨f x, h x⟩,
  inj' := λ x y, by simp,
  map_rel_iff' := λ x y, by simp }

@[reducible] def order_embedding.unmap {Y: finset β} (f: α ↪o Y) : {f : α ↪o β // ∀ x : α, f x ∈ Y}:=
{ val := { to_fun := λ x, f x,
  inj' := begin
    intros a b abeq, apply f.inj', apply subtype.ext_iff_val.2 abeq,
  end,
  map_rel_iff' := begin
    intros a b, simp,
  end
  },
  property := λ x, (f x).2 }

lemma order_embedding.iso_restricted {Y: finset β} : {f : α ↪o β // ∀ x : α, f x ∈ Y} ≃ (α ↪o Y):=
{ to_fun := λ x, order_embedding.remap x.1 x.2,
  inv_fun := λ x, x.unmap,
  left_inv := begin
    intro x, ext, simp,
  end,
  right_inv := begin
    intro x, ext, simp,
  end }

def order_embedding.comp (f: α ↪o β) (g: β ↪o γ)
: α ↪o γ:=
{ to_fun := g ∘ f,
  inj' := function.injective.comp g.inj' f.inj',
  map_rel_iff' := by simp }

@[simp] lemma order_embedding.comp_apply (f: α ↪o β) (g: β ↪o γ) (x : α) :
  f.comp g x = g (f x) :=
by {unfold order_embedding.comp, refl}

@[simp] lemma order_embedding.refl_comp (f: α ↪o β):
  order_embedding.refl.comp f = f :=
begin
  ext, refl,
end

def order_embedding.of_is_empty {a b : Type*} [preorder a] [preorder b] [is_empty a] : a ↪o b :=
⟨function.embedding.of_is_empty, is_empty_elim⟩

instance order_embedding.fintype [fintype α] [fintype β] : fintype (α ↪o β) :=
@fintype.of_finite (α ↪o β)
  (@finite.of_injective (α ↪o β) (α → β) _ (λ f, (f : α → β)) (fun_like.coe_injective))

@[simp] lemma order_embedding.comp_refl (f: α ↪o β):
  f.comp order_embedding.refl = f :=
begin
  ext, refl,
end

lemma mem_fin_2 (x : fin 2) : x = 0 ∨ x = 1 :=
begin
  cases x, cases x_val, left, refl,
  cases x_val, right, refl,
  exfalso, repeat {rw nat.succ_lt_succ_iff at x_property}, norm_num at x_property,
end

instance embedding_unique_of_linear_order {k : ℕ} : unique (fin k ↪o fin k):=
begin
  refine ⟨⟨order_embedding.refl⟩, _⟩, intro a, apply fin.order_embedding_eq, repeat {rw function.surjective.range_eq},
  all_goals{ apply finite.injective_iff_surjective.1 _, apply fintype.finite, apply fin.fintype, exact (_ : fin k ↪o fin k).inj', },
end

@[reducible] def E (n : ℕ): Type := fin 2 ↪o fin n --no longer used

--instance edge_order {n : ℕ} : linear_order (E n):= sorry

variables {η ζ : Type*}
theorem finset.exists_le_card_fiber_of_mul_le_card_to_type [decidable_eq ζ] [fintype ζ] [nonempty ζ] {s : finset η} (f : η → ζ) {n : ℕ} (hn : fintype.card ζ * n ≤ s.card) :
∃ (y : ζ), n ≤ (finset.filter (λ (x : η), f x = y) s).card:=
begin
  set t: finset ζ:= finset.univ with t_def, have hf: ∀ a: η, a ∈ s → f a ∈ t:= by simp,
  have ht: t.nonempty, rw finset.nonempty, simp,
  rw ← finset.card_univ at hn, rw ← t_def at hn,
  rcases finset.exists_le_card_fiber_of_mul_le_card_of_maps_to hf ht hn with ⟨y, h, hy⟩,
  use y, apply hy,
end

def order_embedding_equiv_finset {α : Type*} [linear_order α] (k : ℕ) :
  {s : finset α // s.card = k} ≃ (fin k ↪o α) :=
{ to_fun := λ p, finset.order_emb_of_fin p.1 p.2,
  inv_fun := λ f, ⟨(set.range f).to_finset,
  begin
    convert fintype.card_range (f.to_embedding) using 1, swap, simp,
    simp only [set.to_finset_range, rel_embedding.coe_fn_to_embedding, fintype.card_of_finset],
    congr,
    ext, simp,
  end ⟩   ,
  left_inv := begin
    rintro ⟨s, hs⟩, simp,
  end ,
  right_inv := begin
    intro f,
    simp only [set.to_finset_range],
    rw ←finset.order_emb_of_fin_unique', simp,
  end  }

@[reducible] def edge : Type:= fin 2 ↪o ℕ

def edge_of {i j : ℕ} (h : i < j) : edge:= --disgusting, do not use definitionally
{ to_fun := λ x, if xe0: x = 0 then i else j,
  inj' := begin
    intros x y xyeq, cases mem_fin_2 x, {
      cases mem_fin_2 y,
      {
        simp[h_1, h_2],
      },
      simp only [h_1, h_2, eq_self_iff_true, dite_eq_ite, if_true, fin.one_eq_zero_iff, nat.succ_succ_ne_one, if_false] at xyeq,
      apply absurd xyeq (ne_of_lt h),
    },
    cases mem_fin_2 y,
    {
      simp only [h_1, h_2, eq_self_iff_true, dite_eq_ite, if_true, fin.one_eq_zero_iff, nat.succ_succ_ne_one, if_false] at xyeq,
      apply absurd xyeq.symm (ne_of_lt h),
    },
    simp [h_1, h_2],
  end,
  map_rel_iff' := begin
    intros x y, cases mem_fin_2 x,{
      cases mem_fin_2 y,
      {
        simp [h_1, h_2],
      },
      simp [h_1, h_2, h, le_of_lt],
    },
    cases mem_fin_2 y,
    {
      simp [h_1, h_2, h, le_of_lt],
    },
    simp [h_1, h_2],
  end}

theorem edge_of_0 {i j : ℕ} (h : i < j) : (edge_of h) 0 = i:=
begin
  rw edge_of, simp,
end

theorem edge_of_1 {i j : ℕ} (h : i < j) : (edge_of h) 1 = j:=
begin
  rw edge_of, simp,
end

instance edges_from_finset_fin (Y: finset ℕ) (v : ℕ) : fintype {e : edge | e 0 = v ∧ e 1 ∈ Y} :=
begin
  set f : {e : edge | e 0 = v ∧ e 1 ∈ Y} → Y := λ e, ⟨e.1 1, e.2.2⟩ with hfdef,
  have hf : f.injective,
  { rintros ⟨x,⟨hx,hx'⟩⟩ ⟨y,⟨hy,hy'⟩⟩ hxy, simp [hfdef] at hxy, ext a, cases mem_fin_2 a, rw h, simp [hx, hy], rw h, simp [hxy], },
  apply fintype.of_injective f hf,
end

@[reducible] def edges_from_finset (Y: finset ℕ) (v : ℕ) : finset edge :=
  set.to_finset {e : edge | e 0 = v ∧ e 1 ∈ Y}

lemma edges_from_finset_subset (Y s: finset ℕ) (v : ℕ) (hs: s ⊆ Y) : edges_from_finset s v ⊆ edges_from_finset Y v:=
begin
  intros e esv, rw set.mem_to_finset at esv ⊢, use [esv.1, hs esv.2],
end

-- example {α : Type} (f : α → β) (hf : f.injective) (s : finset β) (h : ∀ a, f a ∈ s) : finite α :=
-- begin

-- end

lemma edges_from_finset_card (Y: finset ℕ) {v k : ℕ} (hvy : ∀ y ∈ (Y.erase v), v < y):
(Y.erase v).card ≤ (edges_from_finset Y v).card:=
begin
  set f : ℕ → edge := λ x, if h: x ∈ (Y.erase v) then edge_of (hvy x h) else edge_of (nat.lt_succ_self x) with f_def,
  apply @finset.card_le_card_of_inj_on _ _ (Y.erase v) (edges_from_finset Y v) f,
  {
    intros a aye, rw f_def, simp [aye],
    have e0:= edge_of_0 (hvy a aye), have e1:= edge_of_1 (hvy a aye), simp [e0, e1, aye], exact finset.mem_of_mem_erase aye,
  },
  intros a aye b bye fabeq, rw f_def at fabeq,
  simp [aye, bye] at fabeq, have a1:= edge_of_1 (hvy a aye), have b1:= edge_of_1 (hvy b bye),
  rw fabeq at a1, rw b1 at a1, exact a1.symm,
end

@[reducible] def has_fav (c: ℕ)(f : edge → fin c) (Y : finset ℕ):=
∀ y ∈ Y, ∃ c : fin c,
∀ e ∈ (edges_from_finset Y y), f e = c

lemma favcolor_procession (k c : ℕ) [nonempty (fin c)]:
∃ n₀: ℕ, ∀ X : finset ℕ, n₀ ≤ X.card  → ∀ f: edge → fin c, ∃ Y ⊆ X,
Y.card = k ∧ has_fav c f Y :=
begin
  induction k with k ih,
  {
    use 0, intros x xg f, use finset.empty, refine ⟨finset.empty_subset x, finset.card_empty, _⟩,
    intros y yinf, apply absurd yinf (finset.not_mem_empty y),
  },
  cases ih with n₀ hn₀, use (c*n₀)+1, intros X Xcge f,
  have xnone: X.nonempty, apply finset.card_pos.1, by_contradiction, push_neg at h,
  have:= nat.eq_zero_of_le_zero h, cases nat.eq_zero_or_pos (c*n₀); linarith,
  set xmin:= X.min' xnone,
  set xfmin:= edges_from_finset X xmin,
  have xfc: (X.erase xmin).card ≤ xfmin.card, apply edges_from_finset_card X (λ y yxe, finset.min'_lt_of_mem_erase_min' X xnone yxe),
  exact xmin, rw (finset.card_erase_of_mem (finset.min'_mem X xnone)) at xfc,
  have xfcn: c*n₀ ≤ xfmin.card, linarith [finset.card_pos.2 xnone], --finally fully proved cardinality!
  have pigeonhole: ∃ friends : (finset edge), friends ⊆ xfmin ∧ n₀ ≤ friends.card ∧ ∃ c : fin c, ∀ e ∈ friends, f e = c,
  {
    rw ← fintype.card_fin c at xfcn,
    cases finset.exists_le_card_fiber_of_mul_le_card_to_type f xfcn with y hy,
    use finset.filter (λ (x : edge), f x = y) xfmin,
    refine ⟨_, hy, _⟩, exact finset.filter_subset (λ (x : edge), f x = y) xfmin,
    use y, intros e emem, exact (finset.mem_filter.1 emem).2,
  },
  rcases pigeonhole with ⟨friends, fss, fcard, ⟨color, fcolor ⟩ ⟩,
  set friendvs:= finset.image (λ x : edge, x 1) friends,
  have vinj: set.inj_on (λ (x : edge), x 1) friends, {
    intros x xf y yf xyv, ext, cases mem_fin_2 x_1,
    have xfm: x ∈ xfmin, apply fss xf, have yfm: y ∈ xfmin, apply fss yf,
    rw h, simp at xfm yfm, simp [xfm, yfm], rw h, dsimp at xyv, rw xyv,
  },
  have fvcard : friendvs.card = friends.card := finset.card_image_of_inj_on vinj, rw ← fvcard at fcard,
  rcases hn₀ friendvs fcard f with ⟨y, yss, yc, yf⟩,
  have fvx: friendvs ⊆ X,
  {
    intros v vfvs, rw finset.mem_image at vfvs, rcases vfvs with ⟨a, af, ha⟩,
    have a1x:= (set.mem_to_finset.1 (fss af)).2, rw ha at a1x, exact a1x,
  },
  have xmny: xmin ∉ y,
  {
    intro xmy, rcases (finset.mem_image.1 (yss xmy)) with ⟨a, af, a1⟩,
    have a0:=(set.mem_to_finset.1 (fss af)).1, rw ← a1 at a0,
    apply absurd (a.inj' a0) zero_ne_one,
  },
  set Z:= finset.cons xmin y xmny, use Z, refine ⟨_, _, _⟩,
  {
    refine finset.cons_subset.2 ⟨_, _⟩, exact finset.min'_mem X xnone,
    exact finset.subset.trans yss fvx,
  },
  {
    rw finset.card_cons xmny, rw yc,
  },
  {
    intros vertex vz, cases finset.mem_cons.1 vz, use color, intros e efz, rw h at efz,
    apply fcolor e, cases (set.mem_to_finset.1 efz) with e0m e1z, cases finset.mem_cons.1 e1z with e1m e1y,
    rw ← e0m at e1m, apply absurd (e.inj' e1m).symm zero_ne_one,
    rcases (finset.mem_image.1 (yss e1y)) with ⟨a, af, a1⟩, have aeqe: a = e,
    { ext, cases mem_fin_2 x, rw h_1, rw (set.mem_to_finset.1 (fss af)).1,
      exact e0m.symm, rw h_1, exact a1,
    },
    rw ← aeqe, exact af,
    cases yf vertex h with c hc, use c, intros e efz, cases (set.mem_to_finset.1 efz) with e0m e1z,
    cases finset.mem_cons.1 e1z with e1m e1y, have e0x: e 0 ∈ X, rw e0m, exact fvx (yss h),
    have e1le0: e 1 ≤ e 0, rw e1m, apply finset.min'_le X (e 0) e0x, have:= e.map_rel_iff'.1 e1le0,
    norm_num at this, have eefy: e ∈ edges_from_finset y vertex, apply set.mem_to_finset.2,
    use [e0m, e1y], exact hc e eefy,
  },
end

#check function.surjective.range_eq
#check finite.injective_iff_surjective
#check fin_zero_elim

#check fintype.exists_le_card_fiber_of_mul_le_card
#check finset.order_emb_of_fin

--@[reducible] def favcolorfun {y: finset ℕ} {f: edge → fin 2} (h: has_fav f y): ℕ → fin 2:=
--λ x, if hx: x ∈ y then classical.some (h x hx) else ⊥

#check edges_from_finset_subset

theorem finramsey:
∀ k c: ℕ,  ∃ n₀: ℕ, ∀ n : finset ℕ, n₀ ≤ n.card →
∀ f: edge → fin c,
∃ s ⊆ n, k ≤ s.card ∧
∃ c : fin c, ∀ v ∈ s, ∀ e ∈ edges_from_finset s v, f e = c:=
begin
  intros k c, cases nat.eq_zero_or_eq_succ_pred c with c0 cp, use 0, intros n nc f,
  have f0:= f (edge_of nat.zero_lt_one), rw c0 at f0, apply fin_zero_elim f0,
  haveI: inhabited (fin c), rw cp, apply fin.inhabited,
  haveI: nonempty (fin c), apply nonempty_of_inhabited,
   cases favcolor_procession (c*k) c with n₀ hn₀, use n₀, intros n ncard f,
  rcases hn₀ n ncard f with ⟨y, ysubn, yc, yfav⟩,
  have ycfinc: fintype.card (fin c) * k ≤ y.card, rw fintype.card_fin c, linarith,
  unfold has_fav at yfav,
  choose! fn h_fn using yfav,
  cases finset.exists_le_card_fiber_of_mul_le_card_to_type fn ycfinc with color hc,
  set clique:= finset.filter (λ (x : ℕ), fn x = color) y,
  have csuby: clique ⊆ y:= finset.filter_subset (λ (x : ℕ), fn x = color) y,
  use clique, refine ⟨finset.subset.trans csuby ysubn, hc, _⟩,
  use color, intros v vclique e eefromsv, rw finset.mem_filter at vclique, cases vclique with vy vcolor,
  have ecsy:= edges_from_finset_subset y clique v csuby,
  have:= h_fn v vy e (ecsy eefromsv), rw vcolor at this, exact this,
  end


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang

! This file was ported from Lean 3 source module ring_theory.ideal.cotangent
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.Ideal.Operations
import Mathbin.Algebra.Module.Torsion
import Mathbin.Algebra.Ring.Idempotents
import Mathbin.LinearAlgebra.FiniteDimensional
import Mathbin.RingTheory.Ideal.LocalRing

/-!
# The module `I ⧸ I ^ 2`

In this file, we provide special API support for the module `I ⧸ I ^ 2`. The official
definition is a quotient module of `I`, but the alternative definition as an ideal of `R ⧸ I ^ 2` is
also given, and the two are `R`-equivalent as in `ideal.cotangent_equiv_ideal`.

Additional support is also given to the cotangent space `m ⧸ m ^ 2` of a local ring.

-/

namespace Ideal

variable {R S S' : Type _} [CommRing R] [CommSemiring S] [Algebra S R]

variable [CommSemiring S'] [Algebra S' R] [Algebra S S'] [IsScalarTower S S' R] (I : Ideal R)

/- ./././Mathport/Syntax/Translate/Command.lean:42:9: unsupported derive handler module[module] «expr ⧸ »(R, I) -/
/-- `I ⧸ I ^ 2` as a quotient of `I`. -/
def Cotangent : Type _ :=
  I ⧸ (I • ⊤ : Submodule R I)deriving AddCommGroup,
  ./././Mathport/Syntax/Translate/Command.lean:42:9: unsupported derive handler module[module] «expr ⧸ »(R, I)
#align ideal.cotangent Ideal.Cotangent

instance : Inhabited I.Cotangent :=
  ⟨0⟩

instance Cotangent.moduleOfTower : Module S I.Cotangent :=
  Submodule.Quotient.module' _
#align ideal.cotangent.module_of_tower Ideal.Cotangent.moduleOfTower

instance : IsScalarTower S S' I.Cotangent :=
  by
  delta cotangent
  constructor
  intro s s' x
  rw [← @IsScalarTower.algebraMap_smul S' R, ← @IsScalarTower.algebraMap_smul S' R, ← smul_assoc, ←
    IsScalarTower.toAlgHom_apply S S' R, map_smul]
  rfl

instance [IsNoetherian R I] : IsNoetherian R I.Cotangent :=
  by
  delta cotangent
  infer_instance

/-- The quotient map from `I` to `I ⧸ I ^ 2`. -/
@[simps (config := lemmasOnly) apply]
def toCotangent : I →ₗ[R] I.Cotangent :=
  Submodule.mkQ _
#align ideal.to_cotangent Ideal.toCotangent

theorem map_toCotangent_ker : I.toCotangent.ker.map I.Subtype = I ^ 2 := by
  simp [Ideal.toCotangent, Submodule.map_smul'', pow_two]
#align ideal.map_to_cotangent_ker Ideal.map_toCotangent_ker

theorem mem_toCotangent_ker {x : I} : x ∈ I.toCotangent.ker ↔ (x : R) ∈ I ^ 2 :=
  by
  rw [← I.map_to_cotangent_ker]
  simp
#align ideal.mem_to_cotangent_ker Ideal.mem_toCotangent_ker

theorem toCotangent_eq {x y : I} : I.toCotangent x = I.toCotangent y ↔ (x - y : R) ∈ I ^ 2 :=
  by
  rw [← sub_eq_zero, ← map_sub]
  exact I.mem_to_cotangent_ker
#align ideal.to_cotangent_eq Ideal.toCotangent_eq

theorem toCotangent_eq_zero (x : I) : I.toCotangent x = 0 ↔ (x : R) ∈ I ^ 2 :=
  I.mem_toCotangent_ker
#align ideal.to_cotangent_eq_zero Ideal.toCotangent_eq_zero

theorem toCotangent_surjective : Function.Surjective I.toCotangent :=
  Submodule.mkQ_surjective _
#align ideal.to_cotangent_surjective Ideal.toCotangent_surjective

theorem toCotangent_range : I.toCotangent.range = ⊤ :=
  Submodule.range_mkQ _
#align ideal.to_cotangent_range Ideal.toCotangent_range

theorem cotangent_subsingleton_iff : Subsingleton I.Cotangent ↔ IsIdempotentElem I :=
  by
  constructor
  · intro H
    refine' (pow_two I).symm.trans (le_antisymm (Ideal.pow_le_self two_ne_zero) _)
    exact fun x hx => (I.to_cotangent_eq_zero ⟨x, hx⟩).mp (Subsingleton.elim _ _)
  ·
    exact fun e =>
      ⟨fun x y =>
        Quotient.inductionOn₂' x y fun x y =>
          I.to_cotangent_eq.mpr <| ((pow_two I).trans e).symm ▸ I.sub_mem x.Prop y.Prop⟩
#align ideal.cotangent_subsingleton_iff Ideal.cotangent_subsingleton_iff

/-- The inclusion map `I ⧸ I ^ 2` to `R ⧸ I ^ 2`. -/
def cotangentToQuotientSquare : I.Cotangent →ₗ[R] R ⧸ I ^ 2 :=
  Submodule.mapQ (I • ⊤) (I ^ 2) I.Subtype
    (by
      rw [← Submodule.map_le_iff_le_comap, Submodule.map_smul'', Submodule.map_top,
        Submodule.range_subtype, smul_eq_mul, pow_two]
      exact rfl.le)
#align ideal.cotangent_to_quotient_square Ideal.cotangentToQuotientSquare

theorem to_quotient_square_comp_toCotangent :
    I.cotangentToQuotientSquare.comp I.toCotangent = (I ^ 2).mkQ.comp (Submodule.subtype I) :=
  LinearMap.ext fun _ => rfl
#align ideal.to_quotient_square_comp_to_cotangent Ideal.to_quotient_square_comp_toCotangent

@[simp]
theorem toCotangent_to_quotient_square (x : I) :
    I.cotangentToQuotientSquare (I.toCotangent x) = (I ^ 2).mkQ x :=
  rfl
#align ideal.to_cotangent_to_quotient_square Ideal.toCotangent_to_quotient_square

/-- `I ⧸ I ^ 2` as an ideal of `R ⧸ I ^ 2`. -/
def cotangentIdeal (I : Ideal R) : Ideal (R ⧸ I ^ 2) :=
  by
  haveI : @RingHomSurjective R (R ⧸ I ^ 2) _ _ _ := ⟨Ideal.Quotient.mk_surjective⟩
  let rq := (I ^ 2).Quotient.mk
  exact Submodule.map rq.to_semilinear_map I
#align ideal.cotangent_ideal Ideal.cotangentIdeal

theorem cotangentIdeal_square (I : Ideal R) : I.cotangentIdeal ^ 2 = ⊥ :=
  by
  rw [eq_bot_iff, pow_two I.cotangent_ideal, ← smul_eq_mul]
  intro x hx
  apply Submodule.smul_induction_on hx
  · rintro _ ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩
    apply (Submodule.Quotient.eq _).mpr _
    rw [sub_zero, pow_two]
    exact Ideal.mul_mem_mul hx hy
  · intro x y hx hy
    exact add_mem hx hy
#align ideal.cotangent_ideal_square Ideal.cotangentIdeal_square

theorem to_quotient_square_range :
    I.cotangentToQuotientSquare.range = I.cotangentIdeal.restrictScalars R :=
  by
  trans (I.cotangent_to_quotient_square.comp I.to_cotangent).range
  · rw [LinearMap.range_comp, I.to_cotangent_range, Submodule.map_top]
  · rw [to_quotient_square_comp_to_cotangent, LinearMap.range_comp, I.range_subtype]
    ext
    rfl
#align ideal.to_quotient_square_range Ideal.to_quotient_square_range

/-- The equivalence of the two definitions of `I / I ^ 2`, either as the quotient of `I` or the
ideal of `R / I ^ 2`. -/
noncomputable def cotangentEquivIdeal : I.Cotangent ≃ₗ[R] I.cotangentIdeal :=
  by
  refine'
    {
      I.cotangent_to_quotient_square.cod_restrict (I.cotangent_ideal.restrict_scalars R) fun x =>
        by
        rw [← to_quotient_square_range]
        exact LinearMap.mem_range_self _ _,
      Equiv.ofBijective _ ⟨_, _⟩ with }
  · rintro x y e
    replace e := congr_arg Subtype.val e
    obtain ⟨x, rfl⟩ := I.to_cotangent_surjective x
    obtain ⟨y, rfl⟩ := I.to_cotangent_surjective y
    rw [I.to_cotangent_eq]
    dsimp only [to_cotangent_to_quotient_square, Submodule.mkQ_apply] at e
    rwa [Submodule.Quotient.eq] at e
  · rintro ⟨_, x, hx, rfl⟩
    refine' ⟨I.to_cotangent ⟨x, hx⟩, Subtype.ext rfl⟩
#align ideal.cotangent_equiv_ideal Ideal.cotangentEquivIdeal

@[simp, nolint simp_nf]
theorem cotangentEquivIdeal_apply (x : I.Cotangent) :
    ↑(I.cotangentEquivIdeal x) = I.cotangentToQuotientSquare x :=
  rfl
#align ideal.cotangent_equiv_ideal_apply Ideal.cotangentEquivIdeal_apply

theorem cotangentEquivIdeal_symm_apply (x : R) (hx : x ∈ I) :
    I.cotangentEquivIdeal.symm ⟨(I ^ 2).mkQ x, Submodule.mem_map_of_mem hx⟩ =
      I.toCotangent ⟨x, hx⟩ :=
  by
  apply I.cotangent_equiv_ideal.injective
  rw [I.cotangent_equiv_ideal.apply_symm_apply]
  ext
  rfl
#align ideal.cotangent_equiv_ideal_symm_apply Ideal.cotangentEquivIdeal_symm_apply

variable {A B : Type _} [CommRing A] [CommRing B] [Algebra R A] [Algebra R B]

/-- The lift of `f : A →ₐ[R] B` to `A ⧸ J ^ 2 →ₐ[R] B` with `J` being the kernel of `f`. -/
def AlgHom.kerSquareLift (f : A →ₐ[R] B) : A ⧸ f.toRingHom.ker ^ 2 →ₐ[R] B :=
  by
  refine' { Ideal.Quotient.lift (f.to_ring_hom.ker ^ 2) f.to_ring_hom _ with commutes' := _ }
  · intro a ha
    exact Ideal.pow_le_self two_ne_zero ha
  · intro r
    rw [IsScalarTower.algebraMap_apply R A, RingHom.toFun_eq_coe, Ideal.Quotient.algebraMap_eq,
      Ideal.Quotient.lift_mk]
    exact f.map_algebra_map r
#align alg_hom.ker_square_lift AlgHom.kerSquareLift

theorem AlgHom.ker_ker_sqare_lift (f : A →ₐ[R] B) :
    f.kerSquareLift.toRingHom.ker = f.toRingHom.ker.cotangentIdeal :=
  by
  apply le_antisymm
  · intro x hx
    obtain ⟨x, rfl⟩ := Ideal.Quotient.mk_surjective x
    exact ⟨x, hx, rfl⟩
  · rintro _ ⟨x, hx, rfl⟩
    exact hx
#align alg_hom.ker_ker_sqare_lift AlgHom.ker_ker_sqare_lift

/-- The quotient ring of `I ⧸ I ^ 2` is `R ⧸ I`. -/
def quotCotangent : (R ⧸ I ^ 2) ⧸ I.cotangentIdeal ≃+* R ⧸ I :=
  by
  refine' (Ideal.quotEquivOfEq (Ideal.map_eq_submodule_map _ _).symm).trans _
  refine' (DoubleQuot.quotQuotEquivQuotSup _ _).trans _
  exact Ideal.quotEquivOfEq (sup_eq_right.mpr <| Ideal.pow_le_self two_ne_zero)
#align ideal.quot_cotangent Ideal.quotCotangent

end Ideal

namespace LocalRing

variable (R : Type _) [CommRing R] [LocalRing R]

/-- The `A ⧸ I`-vector space `I ⧸ I ^ 2`. -/
@[reducible]
def CotangentSpace : Type _ :=
  (maximalIdeal R).Cotangent
#align local_ring.cotangent_space LocalRing.CotangentSpace

instance : Module (ResidueField R) (CotangentSpace R) :=
  Ideal.Cotangent.module _

instance : IsScalarTower R (ResidueField R) (CotangentSpace R) :=
  Module.IsTorsionBySet.isScalarTower _

instance [IsNoetherianRing R] : FiniteDimensional (ResidueField R) (CotangentSpace R) :=
  Module.Finite.of_restrictScalars_finite R _ _

end LocalRing