/-
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
-/
import algebra.divisibility
import algebra.group_power.basic
import algebra.invertible

/-!
# Associated, prime, and irreducible elements.
-/

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}

theorem is_unit_iff_dvd_one [comm_monoid α] {x : α} : is_unit x ↔ x ∣ 1 :=
⟨by rintro ⟨u, rfl⟩; exact ⟨_, u.mul_inv.symm⟩,
 λ ⟨y, h⟩, ⟨⟨x, y, h.symm, by rw [h, mul_comm]⟩, rfl⟩⟩

theorem is_unit_iff_forall_dvd [comm_monoid α] {x : α} :
  is_unit x ↔ ∀ y, x ∣ y :=
is_unit_iff_dvd_one.trans ⟨λ h y, h.trans (one_dvd _), λ h, h _⟩

theorem is_unit_of_dvd_unit {α} [comm_monoid α] {x y : α}
  (xy : x ∣ y) (hu : is_unit y) : is_unit x :=
is_unit_iff_dvd_one.2 $ xy.trans $ is_unit_iff_dvd_one.1 hu

lemma is_unit_of_dvd_one [comm_monoid α] : ∀a ∣ 1, is_unit (a:α)
| a ⟨b, eq⟩ := ⟨units.mk_of_mul_eq_one a b eq.symm, rfl⟩

lemma not_is_unit_of_not_is_unit_dvd [comm_monoid α] {a b : α} (ha : ¬is_unit a) (hb : a ∣ b) :
  ¬ is_unit b :=
mt (is_unit_of_dvd_unit hb) ha

lemma dvd_and_not_dvd_iff [cancel_comm_monoid_with_zero α] {x y : α} :
  x ∣ y ∧ ¬y ∣ x ↔ dvd_not_unit x y :=
⟨λ ⟨⟨d, hd⟩, hyx⟩, ⟨λ hx0, by simpa [hx0] using hyx, ⟨d,
    mt is_unit_iff_dvd_one.1 (λ ⟨e, he⟩, hyx ⟨e, by rw [hd, mul_assoc, ← he, mul_one]⟩), hd⟩⟩,
  λ ⟨hx0, d, hdu, hdx⟩, ⟨⟨d, hdx⟩, λ ⟨e, he⟩, hdu (is_unit_of_dvd_one _
    ⟨e, mul_left_cancel₀ hx0 $ by conv {to_lhs, rw [he, hdx]};simp [mul_assoc]⟩)⟩⟩

lemma pow_dvd_pow_iff [cancel_comm_monoid_with_zero α]
  {x : α} {n m : ℕ} (h0 : x ≠ 0) (h1 : ¬ is_unit x) :
  x ^ n ∣ x ^ m ↔ n ≤ m :=
begin
  split,
  { intro h, rw [← not_lt], intro hmn, apply h1,
    have : x ^ m * x ∣ x ^ m * 1,
    { rw [← pow_succ', mul_one], exact (pow_dvd_pow _ (nat.succ_le_of_lt hmn)).trans h },
    rwa [mul_dvd_mul_iff_left, ← is_unit_iff_dvd_one] at this, apply pow_ne_zero m h0 },
  { apply pow_dvd_pow }
end

section prime
variables [comm_monoid_with_zero α]

/-- prime element of a `comm_monoid_with_zero` -/
def prime (p : α) : Prop :=
p ≠ 0 ∧ ¬ is_unit p ∧ (∀a b, p ∣ a * b → p ∣ a ∨ p ∣ b)

namespace prime
variables {p : α} (hp : prime p)
include hp

lemma ne_zero : p ≠ 0 :=
hp.1

lemma not_unit : ¬ is_unit p :=
hp.2.1

lemma not_dvd_one : ¬ p ∣ 1 :=
mt (is_unit_of_dvd_one _) hp.not_unit

lemma ne_one : p ≠ 1 :=
λ h, hp.2.1 (h.symm ▸ is_unit_one)

lemma dvd_or_dvd (hp : prime p) {a b : α} (h : p ∣ a * b) :
  p ∣ a ∨ p ∣ b :=
hp.2.2 a b h

lemma dvd_of_dvd_pow (hp : prime p) {a : α} {n : ℕ} (h : p ∣ a^n) :
  p ∣ a :=
begin
  induction n with n ih,
  { rw pow_zero at h,
    have := is_unit_of_dvd_one _ h,
    have := not_unit hp,
    contradiction },
  rw pow_succ at h,
  cases dvd_or_dvd hp h with dvd_a dvd_pow,
  { assumption },
  exact ih dvd_pow
end

end prime

@[simp] lemma not_prime_zero : ¬ prime (0 : α) :=
λ h, h.ne_zero rfl

@[simp] lemma not_prime_one : ¬ prime (1 : α) :=
λ h, h.not_unit is_unit_one

end prime

lemma prime.left_dvd_or_dvd_right_of_dvd_mul [cancel_comm_monoid_with_zero α] {p : α}
  (hp : prime p) {a b : α} : a ∣ p * b → p ∣ a ∨ a ∣ b :=
begin
  rintro ⟨c, hc⟩,
  rcases hp.2.2 a c (hc ▸ dvd_mul_right _ _) with h | ⟨x, rfl⟩,
  { exact or.inl h },
  { rw [mul_left_comm, mul_right_inj' hp.ne_zero] at hc,
    exact or.inr (hc.symm ▸ dvd_mul_right _ _) }
end

lemma prime.pow_dvd_of_dvd_mul_left
  [cancel_comm_monoid_with_zero α]
  {p a b : α} (hp : prime p) (n : ℕ) (h : ¬p ∣ a) (h' : p ^ n ∣ a * b) : p ^ n ∣ b :=
begin
  induction n with n ih,
  { rw pow_zero, exact one_dvd b },
  { obtain ⟨c, rfl⟩ := ih (dvd_trans (pow_dvd_pow p n.le_succ) h'),
    rw pow_succ',
    apply mul_dvd_mul_left _ ((hp.dvd_or_dvd _).resolve_left h),
    rwa [←mul_dvd_mul_iff_left (pow_ne_zero n hp.ne_zero), ←pow_succ', mul_left_comm] }
end

lemma prime.pow_dvd_of_dvd_mul_right
  [cancel_comm_monoid_with_zero α]
  {p a b : α} (hp : prime p) (n : ℕ) (h : ¬p ∣ b) (h' : p ^ n ∣ a * b) : p ^ n ∣ a :=
by { rw [mul_comm] at h', exact hp.pow_dvd_of_dvd_mul_left n h h' }

/-- `irreducible p` states that `p` is non-unit and only factors into units.

We explicitly avoid stating that `p` is non-zero, this would require a semiring. Assuming only a
monoid allows us to reuse irreducible for associated elements.
-/
class irreducible [monoid α] (p : α) : Prop :=
(not_unit' : ¬ is_unit p)
(is_unit_or_is_unit' : ∀a b, p = a * b → is_unit a ∨ is_unit b)

namespace irreducible

lemma not_unit [monoid α] {p : α} (hp : irreducible p) : ¬ is_unit p :=
hp.1

lemma is_unit_or_is_unit [monoid α] {p : α} (hp : irreducible p) {a b : α} (h : p = a * b) :
  is_unit a ∨ is_unit b :=
irreducible.is_unit_or_is_unit' a b h

end irreducible

lemma irreducible_iff [monoid α] {p : α} :
  irreducible p ↔ ¬ is_unit p ∧ ∀a b, p = a * b → is_unit a ∨ is_unit b :=
⟨λ h, ⟨h.1, h.2⟩, λ h, ⟨h.1, h.2⟩⟩

@[simp] theorem not_irreducible_one [monoid α] : ¬ irreducible (1 : α) :=
by simp [irreducible_iff]

theorem irreducible.ne_one [monoid α] : ∀ {p:α}, irreducible p → p ≠ 1
| _ hp rfl := not_irreducible_one hp

@[simp] theorem not_irreducible_zero [monoid_with_zero α] : ¬ irreducible (0 : α)
| ⟨hn0, h⟩ := have is_unit (0:α) ∨ is_unit (0:α), from h 0 0 ((mul_zero 0).symm),
  this.elim hn0 hn0

theorem irreducible.ne_zero [monoid_with_zero α] : ∀ {p:α}, irreducible p → p ≠ 0
| _ hp rfl := not_irreducible_zero hp

theorem of_irreducible_mul {α} [monoid α] {x y : α} :
  irreducible (x * y) → is_unit x ∨ is_unit y
| ⟨_, h⟩ := h _ _ rfl

theorem irreducible_or_factor {α} [monoid α] (x : α) (h : ¬ is_unit x) :
  irreducible x ∨ ∃ a b, ¬ is_unit a ∧ ¬ is_unit b ∧ a * b = x :=
begin
  haveI := classical.dec,
  refine or_iff_not_imp_right.2 (λ H, _),
  simp [h, irreducible_iff] at H ⊢,
  refine λ a b h, classical.by_contradiction $ λ o, _,
  simp [not_or_distrib] at o,
  exact H _ o.1 _ o.2 h.symm
end

protected lemma prime.irreducible [cancel_comm_monoid_with_zero α] {p : α} (hp : prime p) :
  irreducible p :=
⟨hp.not_unit, λ a b hab,
  (show a * b ∣ a ∨ a * b ∣ b, from hab ▸ hp.dvd_or_dvd (hab ▸ dvd_rfl)).elim
    (λ ⟨x, hx⟩, or.inr (is_unit_iff_dvd_one.2
      ⟨x, mul_right_cancel₀ (show a ≠ 0, from λ h, by simp [*, prime] at *)
        $ by conv {to_lhs, rw hx}; simp [mul_comm, mul_assoc, mul_left_comm]⟩))
    (λ ⟨x, hx⟩, or.inl (is_unit_iff_dvd_one.2
      ⟨x, mul_right_cancel₀ (show b ≠ 0, from λ h, by simp [*, prime] at *)
        $ by conv {to_lhs, rw hx}; simp [mul_comm, mul_assoc, mul_left_comm]⟩))⟩

lemma succ_dvd_or_succ_dvd_of_succ_sum_dvd_mul [cancel_comm_monoid_with_zero α]
  {p : α} (hp : prime p) {a b : α} {k l : ℕ} :
  p ^ k ∣ a → p ^ l ∣ b → p ^ ((k + l) + 1) ∣ a * b → p ^ (k + 1) ∣ a ∨ p ^ (l + 1) ∣ b :=
λ ⟨x, hx⟩ ⟨y, hy⟩ ⟨z, hz⟩,
have h : p ^ (k + l) * (x * y) = p ^ (k + l) * (p * z),
  by simpa [mul_comm, pow_add, hx, hy, mul_assoc, mul_left_comm] using hz,
have hp0: p ^ (k + l) ≠ 0, from pow_ne_zero _ hp.ne_zero,
have hpd : p ∣ x * y, from ⟨z, by rwa [mul_right_inj' hp0] at h⟩,
(hp.dvd_or_dvd hpd).elim
  (λ ⟨d, hd⟩, or.inl ⟨d, by simp [*, pow_succ, mul_comm, mul_left_comm, mul_assoc]⟩)
  (λ ⟨d, hd⟩, or.inr ⟨d, by simp [*, pow_succ, mul_comm, mul_left_comm, mul_assoc]⟩)

/-- If `p` and `q` are irreducible, then `p ∣ q` implies `q ∣ p`. -/
lemma irreducible.dvd_symm [monoid α] {p q : α}
  (hp : irreducible p) (hq : irreducible q) : p ∣ q → q ∣ p :=
begin
  unfreezingI { rintros ⟨q', rfl⟩ },
  rw is_unit.mul_right_dvd (or.resolve_left (of_irreducible_mul hq) hp.not_unit),
end

lemma irreducible.dvd_comm [monoid α] {p q : α}
  (hp : irreducible p) (hq : irreducible q) : p ∣ q ↔ q ∣ p :=
⟨hp.dvd_symm hq, hq.dvd_symm hp⟩

/-- Two elements of a `monoid` are `associated` if one of them is another one
multiplied by a unit on the right. -/
def associated [monoid α] (x y : α) : Prop := ∃u:αˣ, x * u = y

local infix ` ~ᵤ ` : 50 := associated

namespace associated

@[refl] protected theorem refl [monoid α] (x : α) : x ~ᵤ x := ⟨1, by simp⟩

@[symm] protected theorem symm [monoid α] : ∀{x y : α}, x ~ᵤ y → y ~ᵤ x
| x _ ⟨u, rfl⟩ := ⟨u⁻¹, by rw [mul_assoc, units.mul_inv, mul_one]⟩

@[trans] protected theorem trans [monoid α] : ∀{x y z : α}, x ~ᵤ y → y ~ᵤ z → x ~ᵤ z
| x _ _ ⟨u, rfl⟩ ⟨v, rfl⟩ := ⟨u * v, by rw [units.coe_mul, mul_assoc]⟩

/-- The setoid of the relation `x ~ᵤ y` iff there is a unit `u` such that `x * u = y` -/
protected def setoid (α : Type*) [monoid α] : setoid α :=
{ r := associated, iseqv := ⟨associated.refl, λa b, associated.symm, λa b c, associated.trans⟩ }

end associated

local attribute [instance] associated.setoid

theorem unit_associated_one [monoid α] {u : αˣ} : (u : α) ~ᵤ 1 := ⟨u⁻¹, units.mul_inv u⟩

theorem associated_one_iff_is_unit [monoid α] {a : α} : (a : α) ~ᵤ 1 ↔ is_unit a :=
iff.intro
  (assume h, let ⟨c, h⟩ := h.symm in h ▸ ⟨c, (one_mul _).symm⟩)
  (assume ⟨c, h⟩, associated.symm ⟨c, by simp [h]⟩)

theorem associated_zero_iff_eq_zero [monoid_with_zero α] (a : α) : a ~ᵤ 0 ↔ a = 0 :=
iff.intro
  (assume h, let ⟨u, h⟩ := h.symm in by simpa using h.symm)
  (assume h, h ▸ associated.refl a)

theorem associated_one_of_mul_eq_one [comm_monoid α] {a : α} (b : α) (hab : a * b = 1) : a ~ᵤ 1 :=
show (units.mk_of_mul_eq_one a b hab : α) ~ᵤ 1, from unit_associated_one

theorem associated_one_of_associated_mul_one [comm_monoid α] {a b : α} :
  a * b ~ᵤ 1 → a ~ᵤ 1
| ⟨u, h⟩ := associated_one_of_mul_eq_one (b * u) $ by simpa [mul_assoc] using h

lemma associated_mul_unit_left {β : Type*} [monoid β] (a u : β) (hu : is_unit u) :
  associated (a * u) a :=
let ⟨u', hu⟩ := hu in ⟨u'⁻¹, hu ▸ units.mul_inv_cancel_right _ _⟩

lemma associated_unit_mul_left {β : Type*} [comm_monoid β] (a u : β) (hu : is_unit u) :
  associated (u * a) a :=
begin
  rw mul_comm,
  exact associated_mul_unit_left _ _ hu
end

lemma associated_mul_unit_right {β : Type*} [monoid β] (a u : β) (hu : is_unit u) :
  associated a (a * u) :=
(associated_mul_unit_left a u hu).symm

lemma associated_unit_mul_right {β : Type*} [comm_monoid β] (a u : β) (hu : is_unit u) :
  associated a (u * a) :=
(associated_unit_mul_left a u hu).symm

lemma associated.mul_mul [comm_monoid α] {a₁ a₂ b₁ b₂ : α} :
  a₁ ~ᵤ b₁ → a₂ ~ᵤ b₂ → (a₁ * a₂) ~ᵤ (b₁ * b₂)
| ⟨c₁, h₁⟩ ⟨c₂, h₂⟩ := ⟨c₁ * c₂, by simp [h₁.symm, h₂.symm, mul_assoc, mul_comm, mul_left_comm]⟩

lemma associated.mul_left [comm_monoid α] (a : α) {b c : α} (h : b ~ᵤ c) :
  (a * b) ~ᵤ (a * c) :=
(associated.refl a).mul_mul h

lemma associated.mul_right [comm_monoid α] {a b : α} (h : a ~ᵤ b) (c : α) :
  (a * c) ~ᵤ (b * c) :=
h.mul_mul (associated.refl c)

lemma associated.pow_pow [comm_monoid α] {a b : α} {n : ℕ} (h : a ~ᵤ b) :
  a ^ n ~ᵤ b ^ n :=
begin
  induction n with n ih, { simp [h] },
  convert h.mul_mul ih;
    rw pow_succ
end

protected lemma associated.dvd [monoid α] {a b : α} : a ~ᵤ b → a ∣ b := λ ⟨u, hu⟩, ⟨u, hu.symm⟩

protected lemma associated.dvd_dvd [monoid α] {a b : α} (h : a ~ᵤ b) : a ∣ b ∧ b ∣ a :=
⟨h.dvd, h.symm.dvd⟩

theorem associated_of_dvd_dvd [cancel_monoid_with_zero α]
  {a b : α} (hab : a ∣ b) (hba : b ∣ a) : a ~ᵤ b :=
begin
  rcases hab with ⟨c, rfl⟩,
  rcases hba with ⟨d, a_eq⟩,
  by_cases ha0 : a = 0,
  { simp [*] at * },
  have hac0 : a * c ≠ 0,
  { intro con, rw [con, zero_mul] at a_eq, apply ha0 a_eq, },
  have : a * (c * d) =  a * 1 := by rw [← mul_assoc, ← a_eq, mul_one],
  have hcd : (c * d) = 1, from mul_left_cancel₀ ha0 this,
  have : a * c * (d * c) = a * c * 1 := by rw [← mul_assoc, ← a_eq, mul_one],
  have hdc : d * c = 1, from mul_left_cancel₀ hac0 this,
  exact ⟨⟨c, d, hcd, hdc⟩, rfl⟩
end

theorem dvd_dvd_iff_associated [cancel_monoid_with_zero α] {a b : α} : a ∣ b ∧ b ∣ a ↔ a ~ᵤ b :=
⟨λ ⟨h1, h2⟩, associated_of_dvd_dvd h1 h2, associated.dvd_dvd⟩

lemma associated.dvd_iff_dvd_left [monoid α] {a b c : α} (h : a ~ᵤ b) : a ∣ c ↔ b ∣ c :=
let ⟨u, hu⟩ := h in hu ▸ units.mul_right_dvd.symm

lemma associated.dvd_iff_dvd_right [monoid α] {a b c : α} (h : b ~ᵤ c) : a ∣ b ↔ a ∣ c :=
let ⟨u, hu⟩ := h in hu ▸ units.dvd_mul_right.symm

lemma associated.eq_zero_iff [monoid_with_zero α] {a b : α} (h : a ~ᵤ b) : a = 0 ↔ b = 0 :=
⟨λ ha, let ⟨u, hu⟩ := h in by simp [hu.symm, ha],
  λ hb, let ⟨u, hu⟩ := h.symm in by simp [hu.symm, hb]⟩

lemma associated.ne_zero_iff [monoid_with_zero α] {a b : α} (h : a ~ᵤ b) : a ≠ 0 ↔ b ≠ 0 :=
not_congr h.eq_zero_iff

protected lemma associated.prime [comm_monoid_with_zero α] {p q : α} (h : p ~ᵤ q) (hp : prime p) :
  prime q :=
⟨h.ne_zero_iff.1 hp.ne_zero,
  let ⟨u, hu⟩ := h in
    ⟨λ ⟨v, hv⟩, hp.not_unit ⟨v * u⁻¹, by simp [hv, hu.symm]⟩,
      hu ▸ by { simp [units.mul_right_dvd], intros a b, exact hp.dvd_or_dvd }⟩⟩

lemma irreducible.associated_of_dvd [cancel_monoid_with_zero α] {p q : α}
  (p_irr : irreducible p) (q_irr : irreducible q) (dvd : p ∣ q) : associated p q :=
associated_of_dvd_dvd dvd (p_irr.dvd_symm q_irr dvd)

lemma irreducible.dvd_irreducible_iff_associated [cancel_monoid_with_zero α]
  {p q : α} (pp : irreducible p) (qp : irreducible q) :
  p ∣ q ↔ associated p q :=
⟨irreducible.associated_of_dvd pp qp, associated.dvd⟩

lemma prime.associated_of_dvd [cancel_comm_monoid_with_zero α] {p q : α}
  (p_prime : prime p) (q_prime : prime q) (dvd : p ∣ q) : associated p q :=
p_prime.irreducible.associated_of_dvd q_prime.irreducible dvd

theorem prime.dvd_prime_iff_associated [cancel_comm_monoid_with_zero α]
  {p q : α} (pp : prime p) (qp : prime q) :
  p ∣ q ↔ associated p q :=
pp.irreducible.dvd_irreducible_iff_associated qp.irreducible
lemma associated.prime_iff [comm_monoid_with_zero α] {p q : α}
  (h : p ~ᵤ q) : prime p ↔ prime q :=
⟨h.prime, h.symm.prime⟩

protected lemma associated.is_unit [monoid α] {a b : α} (h :  a ~ᵤ b) : is_unit a → is_unit b :=
let ⟨u, hu⟩ := h in λ ⟨v, hv⟩, ⟨v * u, by simp [hv, hu.symm]⟩

lemma associated.is_unit_iff [monoid α] {a b : α} (h :  a ~ᵤ b) : is_unit a ↔ is_unit b :=
⟨h.is_unit, h.symm.is_unit⟩

protected lemma associated.irreducible [monoid α] {p q : α} (h : p ~ᵤ q)
  (hp : irreducible p) : irreducible q :=
⟨mt h.symm.is_unit hp.1,
  let ⟨u, hu⟩ := h in λ a b hab,
  have hpab : p = a * (b * (u⁻¹ : αˣ)),
    from calc p = (p * u) * (u ⁻¹ : αˣ) : by simp
      ... = _ : by rw hu; simp [hab, mul_assoc],
  (hp.is_unit_or_is_unit hpab).elim or.inl (λ ⟨v, hv⟩, or.inr ⟨v * u, by simp [hv]⟩)⟩

protected lemma associated.irreducible_iff [monoid α] {p q : α} (h : p ~ᵤ q) :
  irreducible p ↔ irreducible q :=
⟨h.irreducible, h.symm.irreducible⟩

lemma associated.of_mul_left [cancel_comm_monoid_with_zero α] {a b c d : α}
  (h : a * b ~ᵤ c * d) (h₁ : a ~ᵤ c) (ha : a ≠ 0) : b ~ᵤ d :=
let ⟨u, hu⟩ := h in let ⟨v, hv⟩ := associated.symm h₁ in
⟨u * (v : αˣ), mul_left_cancel₀ ha
  begin
    rw [← hv, mul_assoc c (v : α) d, mul_left_comm c, ← hu],
    simp [hv.symm, mul_assoc, mul_comm, mul_left_comm]
  end⟩

lemma associated.of_mul_right [cancel_comm_monoid_with_zero α] {a b c d : α} :
  a * b ~ᵤ c * d → b ~ᵤ d → b ≠ 0 → a ~ᵤ c :=
by rw [mul_comm a, mul_comm c]; exact associated.of_mul_left

lemma associated.of_pow_associated_of_prime [cancel_comm_monoid_with_zero α] {p₁ p₂ : α}
  {k₁ k₂ : ℕ} (hp₁ : prime p₁) (hp₂ : prime p₂) (hk₁ : 0 < k₁) (h : p₁ ^ k₁ ~ᵤ p₂ ^ k₂) :
  p₁ ~ᵤ p₂ :=
begin
  have : p₁ ∣ p₂ ^ k₂,
  { rw ←h.dvd_iff_dvd_right,
    apply dvd_pow_self _ hk₁.ne' },
  rw ←hp₁.dvd_prime_iff_associated hp₂,
  exact hp₁.dvd_of_dvd_pow this,
end

lemma associated.of_pow_associated_of_prime' [cancel_comm_monoid_with_zero α] {p₁ p₂ : α}
  {k₁ k₂ : ℕ} (hp₁ : prime p₁) (hp₂ : prime p₂) (hk₂ : 0 < k₂) (h : p₁ ^ k₁ ~ᵤ p₂ ^ k₂) :
  p₁ ~ᵤ p₂ :=
(h.symm.of_pow_associated_of_prime hp₂ hp₁ hk₂).symm

section unique_units
variables [monoid α] [unique αˣ]

lemma units_eq_one (u : αˣ) : u = 1 := subsingleton.elim u 1

theorem associated_iff_eq {x y : α} : x ~ᵤ y ↔ x = y :=
begin
  split,
  { rintro ⟨c, rfl⟩, rw [units_eq_one c, units.coe_one, mul_one] },
  { rintro rfl, refl },
end

theorem associated_eq_eq : (associated : α → α → Prop) = eq :=
by { ext, rw associated_iff_eq }

end unique_units

/-- The quotient of a monoid by the `associated` relation. Two elements `x` and `y`
  are associated iff there is a unit `u` such that `x * u = y`. There is a natural
  monoid structure on `associates α`. -/
def associates (α : Type*) [monoid α] : Type* :=
quotient (associated.setoid α)

namespace associates
open associated

/-- The canonical quotient map from a monoid `α` into the `associates` of `α` -/
protected def mk {α : Type*} [monoid α] (a : α) : associates α :=
⟦ a ⟧

instance [monoid α] : inhabited (associates α) := ⟨⟦1⟧⟩

theorem mk_eq_mk_iff_associated [monoid α] {a b : α} :
  associates.mk a = associates.mk b ↔ a ~ᵤ b :=
iff.intro quotient.exact quot.sound

theorem quotient_mk_eq_mk [monoid α] (a : α) : ⟦ a ⟧ = associates.mk a := rfl

theorem quot_mk_eq_mk [monoid α] (a : α) : quot.mk setoid.r a = associates.mk a := rfl

theorem forall_associated [monoid α] {p : associates α → Prop} :
  (∀a, p a) ↔ (∀a, p (associates.mk a)) :=
iff.intro
  (assume h a, h _)
  (assume h a, quotient.induction_on a h)

theorem mk_surjective [monoid α] : function.surjective (@associates.mk α _) :=
forall_associated.2 (λ a, ⟨a, rfl⟩)

instance [monoid α] : has_one (associates α) := ⟨⟦ 1 ⟧⟩

theorem one_eq_mk_one [monoid α] : (1 : associates α) = associates.mk 1 := rfl

instance [monoid α] : has_bot (associates α) := ⟨1⟩

lemma exists_rep [monoid α] (a : associates α) : ∃ a0 : α, associates.mk a0 = a :=
quot.exists_rep a

instance [monoid α] [subsingleton α] : unique (associates α) :=
{ default := 1,
  uniq := λ a, by { apply quotient.rec_on_subsingleton₂, intros a b, congr } }

section comm_monoid
variable [comm_monoid α]

instance : has_mul (associates α) :=
⟨λa' b', quotient.lift_on₂ a' b' (λa b, ⟦ a * b ⟧) $
  assume a₁ a₂ b₁ b₂ ⟨c₁, h₁⟩ ⟨c₂, h₂⟩,
  quotient.sound $ ⟨c₁ * c₂, by simp [h₁.symm, h₂.symm, mul_assoc, mul_comm, mul_left_comm]⟩⟩

theorem mk_mul_mk {x y : α} : associates.mk x * associates.mk y = associates.mk (x * y) :=
rfl

instance : comm_monoid (associates α) :=
{ one       := 1,
  mul       := (*),
  mul_one   := assume a', quotient.induction_on a' $
    assume a, show ⟦a * 1⟧ = ⟦ a ⟧, by simp,
  one_mul   := assume a', quotient.induction_on a' $
    assume a, show ⟦1 * a⟧ = ⟦ a ⟧, by simp,
  mul_assoc := assume a' b' c', quotient.induction_on₃ a' b' c' $
    assume a b c, show ⟦a * b * c⟧ = ⟦a * (b * c)⟧, by rw [mul_assoc],
  mul_comm  := assume a' b', quotient.induction_on₂ a' b' $
    assume a b, show ⟦a * b⟧ = ⟦b * a⟧, by rw [mul_comm] }

instance : preorder (associates α) :=
{ le := has_dvd.dvd,
  le_refl := dvd_refl,
  le_trans := λ a b c, dvd_trans}

lemma bot_eq_one : (⊥ : associates α) = 1 := rfl

@[simp] lemma mk_one : associates.mk (1 : α) = 1 := rfl

/-- `associates.mk` as a `monoid_hom`. -/
protected def mk_monoid_hom : α →* (associates α) := ⟨associates.mk, mk_one, λ x y, mk_mul_mk⟩

@[simp] lemma mk_monoid_hom_apply (a : α) : associates.mk_monoid_hom a = associates.mk a := rfl

lemma associated_map_mk {f : associates α →* α}
  (hinv : function.right_inverse f associates.mk) (a : α) :
  a ~ᵤ f (associates.mk a) :=
associates.mk_eq_mk_iff_associated.1 (hinv (associates.mk a)).symm

lemma mk_pow (a : α) (n : ℕ) : associates.mk (a ^ n) = (associates.mk a) ^ n :=
by induction n; simp [*, pow_succ, associates.mk_mul_mk.symm]

lemma dvd_eq_le : ((∣) : associates α → associates α → Prop) = (≤) := rfl

theorem mul_eq_one_iff {x y : associates α} : x * y = 1 ↔ (x = 1 ∧ y = 1) :=
iff.intro
  (quotient.induction_on₂ x y $ assume a b h,
    have a * b ~ᵤ 1, from quotient.exact h,
    ⟨quotient.sound $ associated_one_of_associated_mul_one this,
      quotient.sound $ associated_one_of_associated_mul_one $ by rwa [mul_comm] at this⟩)
  (by simp {contextual := tt})

theorem units_eq_one (u : (associates α)ˣ) : u = 1 :=
units.ext (mul_eq_one_iff.1 u.val_inv).1

instance unique_units : unique ((associates α)ˣ) :=
{ default := 1, uniq := associates.units_eq_one }

theorem coe_unit_eq_one (u : (associates α)ˣ): (u : associates α) = 1 :=
by simp

theorem is_unit_iff_eq_one (a : associates α) : is_unit a ↔ a = 1 :=
iff.intro
  (assume ⟨u, h⟩, h ▸ coe_unit_eq_one _)
  (assume h, h.symm ▸ is_unit_one)

theorem is_unit_mk {a : α} : is_unit (associates.mk a) ↔ is_unit a :=
calc is_unit (associates.mk a) ↔ a ~ᵤ 1 :
    by rw [is_unit_iff_eq_one, one_eq_mk_one, mk_eq_mk_iff_associated]
  ... ↔ is_unit a : associated_one_iff_is_unit

lemma mk_injective [unique (units α)] : function.injective (@associates.mk α _) :=
λ a b h, associated_iff_eq.mp (associates.mk_eq_mk_iff_associated.mp h)

section order

theorem mul_mono {a b c d : associates α} (h₁ : a ≤ b) (h₂ : c ≤ d) :
  a * c ≤ b * d :=
let ⟨x, hx⟩ := h₁, ⟨y, hy⟩ := h₂ in
⟨x * y, by simp [hx, hy, mul_comm, mul_assoc, mul_left_comm]⟩

theorem one_le {a : associates α} : 1 ≤ a :=
dvd.intro _ (one_mul a)

theorem le_mul_right {a b : associates α} : a ≤ a * b := ⟨b, rfl⟩

theorem le_mul_left {a b : associates α} : a ≤ b * a :=
by rw [mul_comm]; exact le_mul_right

instance : order_bot (associates α) :=
{ bot := 1,
  bot_le := assume a, one_le }

end order

end comm_monoid

instance [has_zero α] [monoid α] : has_zero (associates α) := ⟨⟦ 0 ⟧⟩
instance [has_zero α] [monoid α] : has_top (associates α) := ⟨0⟩

section comm_monoid_with_zero

variables [comm_monoid_with_zero α]

@[simp] theorem mk_eq_zero {a : α} : associates.mk a = 0 ↔ a = 0 :=
⟨assume h, (associated_zero_iff_eq_zero a).1 $ quotient.exact h, assume h, h.symm ▸ rfl⟩

theorem mk_ne_zero {a : α} : associates.mk a ≠ 0 ↔ a ≠ 0 :=
not_congr mk_eq_zero

instance : comm_monoid_with_zero (associates α) :=
{ zero_mul := by { rintro ⟨a⟩, show associates.mk (0 * a) = associates.mk 0, rw [zero_mul] },
  mul_zero := by { rintro ⟨a⟩, show associates.mk (a * 0) = associates.mk 0, rw [mul_zero] },
  .. associates.comm_monoid, .. associates.has_zero }

instance : order_top (associates α) :=
{ top := 0,
  le_top := assume a, ⟨0, (mul_zero a).symm⟩ }

instance : bounded_order (associates α) :=
{ .. associates.order_top,
  .. associates.order_bot }

instance [nontrivial α] : nontrivial (associates α) :=
⟨⟨0, 1,
assume h,
have (0 : α) ~ᵤ 1, from quotient.exact h,
have (0 : α) = 1, from ((associated_zero_iff_eq_zero 1).1 this.symm).symm,
zero_ne_one this⟩⟩

lemma exists_non_zero_rep {a : associates α} : a ≠ 0 → ∃ a0 : α, a0 ≠ 0 ∧ associates.mk a0 = a :=
quotient.induction_on a (λ b nz, ⟨b, mt (congr_arg quotient.mk) nz, rfl⟩)

theorem dvd_of_mk_le_mk {a b : α} : associates.mk a ≤ associates.mk b → a ∣ b
| ⟨c', hc'⟩ := (quotient.induction_on c' $ assume c hc,
    let ⟨d, hd⟩ := (quotient.exact hc).symm in
    ⟨(↑d) * c,
      calc b = (a * c) * ↑d : hd.symm
        ... = a * (↑d * c) : by ac_refl⟩) hc'

theorem mk_le_mk_of_dvd {a b : α} : a ∣ b → associates.mk a ≤ associates.mk b :=
assume ⟨c, hc⟩, ⟨associates.mk c, by simp [hc]; refl⟩

theorem mk_le_mk_iff_dvd_iff {a b : α} : associates.mk a ≤ associates.mk b ↔ a ∣ b :=
iff.intro dvd_of_mk_le_mk mk_le_mk_of_dvd

theorem mk_dvd_mk {a b : α} : associates.mk a ∣ associates.mk b ↔ a ∣ b :=
iff.intro dvd_of_mk_le_mk mk_le_mk_of_dvd

lemma prime.le_or_le {p : associates α} (hp : prime p) {a b : associates α} (h : p ≤ a * b) :
  p ≤ a ∨ p ≤ b :=
hp.2.2 a b h

lemma prime_mk (p : α) : prime (associates.mk p) ↔ _root_.prime p :=
begin
  rw [prime, _root_.prime, forall_associated],
  transitivity,
  { apply and_congr, refl,
    apply and_congr, refl,
    apply forall_congr, assume a,
    exact forall_associated },
  apply and_congr mk_ne_zero,
  apply and_congr,
  { rw [is_unit_mk], },
  refine forall₂_congr (λ a b, _),
  rw [mk_mul_mk, mk_dvd_mk, mk_dvd_mk, mk_dvd_mk],
end

theorem irreducible_mk (a : α) : irreducible (associates.mk a) ↔ irreducible a :=
begin
  simp only [irreducible_iff, is_unit_mk],
  apply and_congr iff.rfl,
  split,
  { rintro h x y rfl,
    simpa [is_unit_mk] using h (associates.mk x) (associates.mk y) rfl },
  { intros h x y,
    refine quotient.induction_on₂ x y (assume x y a_eq, _),
    rcases quotient.exact a_eq.symm with ⟨u, a_eq⟩,
    rw mul_assoc at a_eq,
    show is_unit (associates.mk x) ∨ is_unit (associates.mk y),
    simpa [is_unit_mk] using h _ _ a_eq.symm }
end

theorem mk_dvd_not_unit_mk_iff {a b : α} :
  dvd_not_unit (associates.mk a) (associates.mk b) ↔
  dvd_not_unit a b :=
begin
  rw [dvd_not_unit, dvd_not_unit, mk_ne_zero],
  apply and_congr_right, intro ane0,
  split,
  { contrapose!, rw forall_associated,
    intros h x hx hbax,
    rw [mk_mul_mk, mk_eq_mk_iff_associated] at hbax,
    cases hbax with u hu,
    apply h (x * ↑u⁻¹),
    { rw is_unit_mk at hx,
      rw associated.is_unit_iff,
      apply hx,
      use u,
      simp, },
    simp [← mul_assoc, ← hu] },
  { rintro ⟨x, ⟨hx, rfl⟩⟩,
    use associates.mk x,
    simp [is_unit_mk, mk_mul_mk, hx], }
end

theorem dvd_not_unit_of_lt {a b : associates α} (hlt : a < b) :
  dvd_not_unit a b :=
begin
  split, { rintro rfl, apply not_lt_of_le _ hlt, apply dvd_zero },
  rcases hlt with ⟨⟨x, rfl⟩, ndvd⟩,
  refine ⟨x, _, rfl⟩,
  contrapose! ndvd,
  rcases ndvd with ⟨u, rfl⟩,
  simp,
end

end comm_monoid_with_zero

section cancel_comm_monoid_with_zero
variable [cancel_comm_monoid_with_zero α]

instance : partial_order (associates α) :=
{ le_antisymm := λ a' b', quotient.induction_on₂ a' b' (λ a b hab hba,
  quot.sound $ associated_of_dvd_dvd (dvd_of_mk_le_mk hab) (dvd_of_mk_le_mk hba))
  .. associates.preorder }

instance : no_zero_divisors (associates α) :=
⟨λ x y,
  (quotient.induction_on₂ x y $ assume a b h,
    have a * b = 0, from (associated_zero_iff_eq_zero _).1 (quotient.exact h),
    have a = 0 ∨ b = 0, from mul_eq_zero.1 this,
    this.imp (assume h, h.symm ▸ rfl) (assume h, h.symm ▸ rfl))⟩

theorem irreducible_iff_prime_iff :
  (∀ a : α, irreducible a ↔ prime a) ↔ (∀ a : (associates α), irreducible a ↔ prime a) :=
begin
  rw forall_associated, split;
  intros h a; have ha := h a; rw irreducible_mk at *; rw prime_mk at *; exact ha,
end

lemma eq_of_mul_eq_mul_left :
  ∀(a b c : associates α), a ≠ 0 → a * b = a * c → b = c :=
begin
  rintros ⟨a⟩ ⟨b⟩ ⟨c⟩ ha h,
  rcases quotient.exact' h with ⟨u, hu⟩,
  have hu : a * (b * ↑u) = a * c, { rwa [← mul_assoc] },
  exact quotient.sound' ⟨u, mul_left_cancel₀ (mk_ne_zero.1 ha) hu⟩
end

lemma eq_of_mul_eq_mul_right :
  ∀(a b c : associates α), b ≠ 0 → a * b = c * b → a = c :=
λ a b c bne0, (mul_comm b a) ▸ (mul_comm b c) ▸ (eq_of_mul_eq_mul_left b a c bne0)

lemma le_of_mul_le_mul_left (a b c : associates α) (ha : a ≠ 0) :
  a * b ≤ a * c → b ≤ c
| ⟨d, hd⟩ := ⟨d, eq_of_mul_eq_mul_left a _ _ ha $ by rwa ← mul_assoc⟩

lemma one_or_eq_of_le_of_prime :
  ∀(p m : associates α), prime p → m ≤ p → (m = 1 ∨ m = p)
| _ m ⟨hp0, hp1, h⟩ ⟨d, rfl⟩ :=
match h m d dvd_rfl with
| or.inl h := classical.by_cases (assume : m = 0, by simp [this]) $
  assume : m ≠ 0,
  have m * d ≤ m * 1, by simpa using h,
  have d ≤ 1, from associates.le_of_mul_le_mul_left m d 1 ‹m ≠ 0› this,
  have d = 1, from bot_unique this,
  by simp [this]
| or.inr h := classical.by_cases (assume : d = 0, by simp [this] at hp0; contradiction) $
  assume : d ≠ 0,
  have d * m ≤ d * 1, by simpa [mul_comm] using h,
  or.inl $ bot_unique $ associates.le_of_mul_le_mul_left d m 1 ‹d ≠ 0› this
end

instance : cancel_comm_monoid_with_zero (associates α) :=
{ mul_left_cancel_of_ne_zero := eq_of_mul_eq_mul_left,
  mul_right_cancel_of_ne_zero := eq_of_mul_eq_mul_right,
  .. (infer_instance : comm_monoid_with_zero (associates α)) }

theorem dvd_not_unit_iff_lt {a b : associates α} :
  dvd_not_unit a b ↔ a < b :=
dvd_and_not_dvd_iff.symm

end cancel_comm_monoid_with_zero

end associates

section cancel_comm_monoid_with_zero

lemma dvd_not_unit.is_unit_of_irreducible_right [cancel_comm_monoid_with_zero α] {p q : α}
  (h : dvd_not_unit p q) (hq : irreducible q) : is_unit p :=
begin
  obtain ⟨hp', x, hx, hx'⟩ := h,
  exact or.resolve_right ((irreducible_iff.1 hq).right p x hx') hx
end

lemma not_irreducible_of_not_unit_dvd_not_unit [cancel_comm_monoid_with_zero α] {p q : α}
  (hp : ¬is_unit p) (h : dvd_not_unit p q) : ¬ irreducible q :=
mt h.is_unit_of_irreducible_right hp

lemma dvd_not_unit.not_unit [cancel_comm_monoid_with_zero α] {p q : α}
  (hp : dvd_not_unit p q) : ¬ is_unit q :=
begin
  obtain ⟨-, x, hx, rfl⟩ := hp,
  exact λ hc, hx (is_unit_iff_dvd_one.mpr (dvd_of_mul_left_dvd (is_unit_iff_dvd_one.mp hc))),
end

lemma is_unit_of_associated_mul [cancel_comm_monoid_with_zero α]
  {p b : α} (h : associated (p * b) p) (hp : p ≠ 0) : is_unit b :=
begin
  cases h with a ha,
  refine is_unit_of_mul_eq_one b a ((mul_right_inj' hp).mp _),
  rwa [← mul_assoc, mul_one],
end

lemma dvd_not_unit.not_associated [cancel_comm_monoid_with_zero α] {p q : α}
  (h : dvd_not_unit p q) : ¬ associated p q :=
begin
  rintro ⟨a, rfl⟩,
  obtain ⟨hp, x, hx, hx'⟩ := h,
  rcases (mul_right_inj' hp).mp hx' with rfl,
  exact hx a.is_unit,
end

lemma dvd_not_unit_of_dvd_not_unit_associated [cancel_comm_monoid_with_zero α]
[nontrivial α] {p q r : α} (h : dvd_not_unit p q) (h' : associated q r) : dvd_not_unit p r :=
begin
  obtain ⟨u, rfl⟩ := associated.symm h',
  obtain ⟨hp, x, hx⟩ := h,
  refine ⟨hp, x * ↑(u⁻¹), dvd_not_unit.not_unit ⟨u⁻¹.ne_zero, x, hx.left, mul_comm _ _⟩, _⟩,
  rw [← mul_assoc, ← hx.right, mul_assoc, units.mul_inv, mul_one]
end

lemma dvd_not_unit.ne [cancel_comm_monoid_with_zero α] {p q : α}
  (h : dvd_not_unit p q) : p ≠ q :=
begin
  by_contra hcontra,
  obtain ⟨hp, x, hx', hx''⟩ := h,
  conv_lhs at hx'' {rw [← hcontra, ← mul_one p]},
  rw (mul_left_cancel₀ hp hx'').symm at hx',
  exact hx' is_unit_one,
end

lemma pow_injective_of_not_unit [cancel_comm_monoid_with_zero α] {q : α}
  (hq : ¬ is_unit q) (hq' : q ≠ 0): function.injective (λ (n : ℕ), q^n) :=
begin
  refine injective_of_lt_imp_ne (λ n m h, dvd_not_unit.ne ⟨pow_ne_zero n hq', q^(m - n), _, _⟩),
  { exact not_is_unit_of_not_is_unit_dvd hq (dvd_pow (dvd_refl _) (nat.sub_pos_of_lt h).ne') },
  { exact (pow_mul_pow_sub q h.le).symm  }
end

end cancel_comm_monoid_with_zero


/-
Copyright (c) 2022 Antoine Labelle. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Antoine Labelle
-/
import algebra.module.basic
import algebra.module.linear_map
import algebra.monoid_algebra.basic
import linear_algebra.trace
import linear_algebra.dual
import linear_algebra.free_module.basic

/-!
# Monoid representations

This file introduces monoid representations and their characters and defines a few ways to construct
representations.

## Main definitions

  * representation.representation
  * representation.character
  * representation.tprod
  * representation.lin_hom
  * represensation.dual

## Implementation notes

Representations of a monoid `G` on a `k`-module `V` are implemented as
homomorphisms `G →* (V →ₗ[k] V)`.
-/

open monoid_algebra (lift) (of)
open linear_map

section
variables (k G V : Type*) [comm_semiring k] [monoid G] [add_comm_monoid V] [module k V]

/--
A representation of `G` on the `k`-module `V` is an homomorphism `G →* (V →ₗ[k] V)`.
-/
abbreviation representation := G →* (V →ₗ[k] V)

end

namespace representation

section trivial

variables {k G V : Type*} [comm_semiring k] [monoid G] [add_comm_monoid V] [module k V]

/--
The trivial representation of `G` on the one-dimensional module `k`.
-/
def trivial : representation k G k := 1

@[simp]
lemma trivial_def (g : G) (v : k) : trivial g v = v := rfl

end trivial

section monoid_algebra

variables {k G V : Type*} [comm_semiring k] [monoid G] [add_comm_monoid V] [module k V]
variables (ρ : representation k G V)

/--
A `k`-linear representation of `G` on `V` can be thought of as
an algebra map from `monoid_algebra k G` into the `k`-linear endomorphisms of `V`.
-/
noncomputable def as_algebra_hom : monoid_algebra k G →ₐ[k] (module.End k V) :=
  (lift k G _) ρ

lemma as_algebra_hom_def :
  as_algebra_hom ρ = (lift k G _) ρ := rfl

@[simp]
lemma as_algebra_hom_single (g : G):
  (as_algebra_hom ρ (finsupp.single g 1)) = ρ g :=
by simp only [as_algebra_hom_def, monoid_algebra.lift_single, one_smul]

lemma as_algebra_hom_of (g : G):
  (as_algebra_hom ρ (of k G g)) = ρ g :=
by simp only [monoid_algebra.of_apply, as_algebra_hom_single]

/--
A `k`-linear representation of `G` on `V` can be thought of as
a module over `monoid_algebra k G`.
-/
noncomputable def as_module : module (monoid_algebra k G) V :=
  module.comp_hom V (as_algebra_hom ρ).to_ring_hom

end monoid_algebra

section group

variables {k G V : Type*} [comm_semiring k] [group G] [add_comm_monoid V] [module k V]
variables (ρ : representation k G V)

/--
When `G` is a group, a `k`-linear representation of `G` on `V` can be thought of as
a group homomorphism from `G` into the invertible `k`-linear endomorphisms of `V`.
-/
def as_group_hom : G →* units (V →ₗ[k] V) :=
  monoid_hom.to_hom_units ρ

end group

section tensor_product

variables {k G V W : Type*} [comm_semiring k] [monoid G]
variables [add_comm_monoid V] [module k V] [add_comm_monoid W] [module k W]
variables (ρV : representation k G V) (ρW : representation k G W)

open_locale tensor_product

/--
Given representations of `G` on `V` and `W`, there is a natural representation of `G` on their
tensor product `V ⊗[k] W`.
-/
def tprod : representation k G (V ⊗[k] W) :=
{ to_fun := λ g, tensor_product.map (ρV g) (ρW g),
  map_one' := by simp only [map_one, tensor_product.map_one],
  map_mul' := λ g h, by simp only [map_mul, tensor_product.map_mul] }

local notation ρV ` ⊗ ` ρW := tprod ρV ρW

@[simp]
lemma tprod_apply (g : G) : (ρV ⊗ ρW) g = tensor_product.map (ρV g) (ρW g) := rfl

end tensor_product

section linear_hom

variables {k G V W : Type*} [comm_semiring k] [group G]
variables [add_comm_monoid V] [module k V] [add_comm_monoid W] [module k W]
variables (ρV : representation k G V) (ρW : representation k G W)

/--
Given representations of `G` on `V` and `W`, there is a natural representation of `G` on the
module `V →ₗ[k] W`, where `G` acts by conjugation.
-/
def lin_hom : representation k G (V →ₗ[k] W) :=
{ to_fun := λ g,
  { to_fun := λ f, (ρW g) ∘ₗ f ∘ₗ (ρV g⁻¹),
    map_add' := λ f₁ f₂, by simp_rw [add_comp, comp_add],
    map_smul' := λ r f, by simp_rw [ring_hom.id_apply, smul_comp, comp_smul]},
  map_one' := linear_map.ext $ λ x,
    by simp_rw [coe_mk, inv_one, map_one, one_apply, one_eq_id, comp_id, id_comp],
  map_mul' := λ g h,  linear_map.ext $ λ x,
    by simp_rw [coe_mul, coe_mk, function.comp_apply, mul_inv_rev, map_mul, mul_eq_comp,
                comp_assoc ]}
@[simp]
lemma lin_hom_apply (g : G) (f : V →ₗ[k] W) : (lin_hom ρV ρW) g f = (ρW g) ∘ₗ f ∘ₗ (ρV g⁻¹) := rfl

/--
The dual of a representation `ρ` of `G` on a module `V`, given by `(dual ρ) g f = f ∘ₗ (ρ g⁻¹)`,
where `f : module.dual k V`.
-/
def dual : representation k G (module.dual k V) :=
{ to_fun := λ g,
  { to_fun := λ f, f ∘ₗ (ρV g⁻¹),
    map_add' := λ f₁ f₂, by simp only [add_comp],
    map_smul' := λ r f,
      by {ext, simp only [coe_comp, function.comp_app, smul_apply, ring_hom.id_apply]} },
  map_one' :=
    by {ext, simp only [coe_comp, function.comp_app, map_one, inv_one, coe_mk, one_apply]},
  map_mul' := λ g h,
    by {ext, simp only [coe_comp, function.comp_app, mul_inv_rev, map_mul, coe_mk, mul_apply]}}

@[simp]
lemma dual_apply (g : G) : (dual ρV) g = module.dual.transpose (ρV g⁻¹) := rfl

lemma dual_tensor_hom_comm (g : G) :
  (dual_tensor_hom k V W) ∘ₗ (tensor_product.map (ρV.dual g) (ρW g)) =
  (lin_hom ρV ρW) g ∘ₗ (dual_tensor_hom k V W) :=
begin
  ext, simp [module.dual.transpose_apply],
end

end linear_hom

end representation


import extra.number_theory.pos_rat_primes

/-! # IMO 2018 A1 -/

namespace IMOSL
namespace IMO2018A1

def good' (n : ℤ) {G : Type*} [add_group G] (f : G → G) :=
  ∀ x y : G, f (n • (x + f y)) = n • f x + f y

def good (n : ℤ) {G : Type*} [group G] (f : G → G) :=
  ∀ x y : G, f ((x * f y) ^ n) = f x ^ n * f y

/-- Final solution, additive version -/
theorem final_solution_additive {n : ℤ} (h : 1 < |n|) {G : Type*} [add_group G]
  {S : Type*} {ρ : G →+ S → ℤ} (h0 : function.injective ρ) :
  ∀ f : G → G, good' n f ↔ f = 0 :=
begin
  ---- First, remove the `←` direction
  intros f; symmetry; refine ⟨λ h1 x y, _, λ h1, _⟩,
  subst h1; simp_rw [pi.zero_apply, smul_zero, add_zero],

  ---- Initial setup
  simp_rw [injective_iff_map_eq_zero', function.funext_iff, pi.zero_apply] at h0,
  simp_rw [function.funext_iff, pi.zero_apply, ← h0],
  haveI _inst_2 : no_zero_smul_divisors ℤ G :=
  ⟨λ k x h2, begin
      rw [← h0, or_iff_not_imp_left]; intros h3 s,
      rw ← h0 at h2; replace h2 := h2 s,
      rwa [map_zsmul, pi.smul_apply, smul_eq_zero, or_iff_right h3] at h2
  end⟩,

  ---- Some more setup
  replace h0 := h1 (-f 0) 0,
  rw [neg_add_self, smul_zero, self_eq_add_left, smul_eq_zero,
      or_iff_right (abs_pos.mp (lt_trans one_pos h : 0 < |n|))] at h0,
  have h2 := λ x, h1 x (-f 0),
  simp_rw [h0, add_zero] at h2,
  replace h1 := h1 0,
  simp_rw [zero_add, h2] at h1,
  replace h0 := h2 0,
  replace h2 : n ≠ 1 := by rintros rfl; rw abs_one at h; exact ne_of_gt h rfl,
  rw [← one_zsmul (f (n • 0)), smul_zero, eq_comm, ← add_neg_eq_zero,
      ← sub_zsmul, smul_eq_zero, sub_eq_zero, or_iff_right h2] at h0,
  simp_rw [h0, smul_zero, zero_add] at h1,
  clear h0 h2,

  suffices : ∀ (s : S) (k : ℕ) (x : G), |n| ^ k ∣ ρ (f x) s,
  { intros x s; refine int.eq_zero_of_abs_lt_dvd (this s (ρ (f x) s).nat_abs x) _,
    lift |n| to ℕ using abs_nonneg n with N,
    rw nat.one_lt_cast at h,
    change |↑(ρ (f x) s)| < (N : ℤ) ^ (ρ (f x) s).nat_abs,
    rw [← nat.cast_pow, ← int.cast_nat_abs, nat.cast_lt],
    exact nat.lt_pow_self h (ρ (f x) s).nat_abs },

  ---- Induction step
  simp_rw [← abs_pow, abs_dvd],
  intros s k; induction k with k h0; intros x,
  rw pow_zero; exact one_dvd (ρ (f x) s),
  rw [← h1, map_zsmul, pi.smul_apply, smul_eq_mul, pow_succ],
  exact mul_dvd_mul_left n (h0 (f x))
end

/-- Final solution, multiplicative version -/
theorem final_solution_multiplicative {n : ℤ} (h : 1 < |n|) {G : Type*} [group G]
  {S : Type*} {ρ : additive G →+ S → ℤ} (h0 : function.injective ρ) :
  ∀ f : G → G, good n f ↔ f = 1 :=
  final_solution_additive h h0

/-- Final solution, `ℚ+` version -/
theorem final_solution_rat {n : ℤ} (h : 1 < |n|) :
  ∀ f : {q : ℚ // 0 < q} → {q : ℚ // 0 < q}, good n f ↔ f = λ _, 1 :=
  final_solution_multiplicative h extra.pos_rat_factor_hom.inj

end IMO2018A1
end IMOSL


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Seul Baek
-/

/-
Linear combination of constraints.
-/

import tactic.omega.clause

namespace omega

/-- Linear combination of constraints. The second
    argument is the list of constraints, and the first
    argument is the list of conefficients by which the
    constraints are multiplied -/
@[simp] def lin_comb : list nat → list term → term
| [] []     := ⟨0,[]⟩
| [] (_::_) := ⟨0,[]⟩
| (_::_) [] := ⟨0,[]⟩
| (n::ns) (t::ts) := term.add (t.mul ↑n) (lin_comb ns ts)

lemma lin_comb_holds {v : nat → int} :
  ∀ {ts} ns, (∀ t ∈ ts, 0 ≤ term.val v t) → (0 ≤ (lin_comb ns ts).val v)
| [] []     h := by simp only [add_zero, term.val, lin_comb, coeffs.val_nil]
| [] (_::_) h := by simp only [add_zero, term.val, lin_comb, coeffs.val_nil]
| (_::_) [] h := by simp only [add_zero, term.val, lin_comb, coeffs.val_nil]
| (t::ts) (n::ns) h :=
  begin
    have : 0 ≤ ↑n * term.val v t + term.val v (lin_comb ns ts),
    { apply add_nonneg,
      { apply mul_nonneg,
        apply int.coe_nat_nonneg,
        apply h _ (or.inl rfl) },
      { apply lin_comb_holds,
        apply list.forall_mem_of_forall_mem_cons h } },
    simpa only [lin_comb, term.val_mul, term.val_add],
  end

/-- `unsat_lin_comb ns ts` asserts that the linear combination
    `lin_comb ns ts` is unsatisfiable  -/
def unsat_lin_comb (ns : list nat) (ts : list term) : Prop :=
(lin_comb ns ts).fst < 0 ∧ ∀ x ∈ (lin_comb ns ts).snd, x = (0 : int)

lemma unsat_lin_comb_of (ns : list nat) (ts : list term) :
(lin_comb ns ts).fst < 0 →
(∀ x ∈ (lin_comb ns ts).snd, x = (0 : int)) →
unsat_lin_comb ns ts :=
by {intros h1 h2, exact ⟨h1,h2⟩}

lemma unsat_of_unsat_lin_comb
  (ns : list nat) (ts : list term) :
  (unsat_lin_comb ns ts) → clause.unsat ([], ts) :=
begin
  intros h1 h2, cases h2 with v h2,
  have h3 := lin_comb_holds ns h2.right,
  cases h1 with hl hr,
  cases (lin_comb ns ts) with b as,
  unfold term.val at h3,
  rw [coeffs.val_eq_zero hr, add_zero, ← not_lt] at h3,
  apply h3 hl
end

end omega


import combinatorics.simple_graph.coloring

--OUTPUT 1
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  apply iff.intro,
  -- If $G$ is two colorable, then we can color every vertex either red or blue, and no edge will have both endpoints colored the same color.
  -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue.
  -- Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$.
  -- This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
  assume h1 : (G.colorable 2),
  have h2 :  ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B),
  from by {
    cases h1,
    have h3 : disjoint (color_set 1) (color_set 2), from
      assume a1 a2 : V, assume h4 : a1 ∈ color_set (1),
      assume h5 : a2 ∈ color_set (2),
      assume h6 : (a1,a2) ∈ ℓ V,
      have h7 : (a1,a2) ∈ G.adjacency, from (adj_iff_line_graph).mp h6,
      have h8 : a1 ∈ color_set (1) ∧ a2 ∈ color_set (1), from by {
        left,
        exact h7.1,
        },
      have h9 : a1 ∈ color_set (2) ∧ a2 ∈ color_set (2), from by {
        right,
        exact h7.2,
        },
      have h10 : (a1,a2) ∉ ℓ V, from (adj_iff_line_graph).mpr (by {
        have h11 : color_set (1) ∩ color_set (2) = ∅,
        from by {
          apply empty_iff.mp,
          exact h3 a1 a2 h4 h5,
          },
        have h12 : a1 = a2, from by {
          apply eq_of_mem_singleton,
          apply h11.symm.mp,
          },
        apply or.cases_on h8,
        apply or.cases_on h9,
        exact h12,
        },
        ),
      exact h10 h6,
    have h4 : ∀ x : V, x ∈ color_set (1) ∨ x ∈ color_set (2), from by {
      assume x : V,
      cases (mem_or_compl_of_mem_union h5).elim (λh,or.inl h)(λh,or.inr h),
      },
    have h5 : color_set (1) ∪ color_set (2) = set.univ, from set.ext (λx,λh6, by {
      have h8 : x ∈ color_set (1) ∨ x ∈ color_set (2), from h4 x,
      cases h8 with h7 h7,
      exact set.mem_univ x,
      exact set.mem_univ x,
      }),
    have h6 : color_set (1) = set.univ ∪ color_set (2), from by {
      apply set.ext,
      assume x,
      assume h7 : x ∈ color_set (1),
      show x ∈ (set.univ ∪ color_set (2)), from by {
        apply set.mem_union_left,
        exact set.mem_univ x,
        },
      },
    have h7 : color_set (1) = set.univ, from set.ext (λx,λh8,by { rw [←h5,set.union_comm],}),
    have h8 : color_set (2) = set.univ, from set.ext (λx,λh9,by { rw [←h5,set.union_comm],}),
    have h9 : (disjoint color_set 1 color_set 2) = true, from by {
      apply propext,
      apply iff.intro,
      have h10 : color_set 1 = set.univ, from  h7,
      have h11 : color_set 2 = set.univ, from h8,
      have h12 : color_set 1 ∩ color_set 2 = ∅, from emp_disjoint_univ,
      exact h12.symm.mp,
      have h10 : (color_set 1) ∩ (color_set 2) = ∅, from by {
        apply h3,
        },
      have h11 : (color_set 1) = set.univ, from by {
        apply set.ext,
        assume x,
        assume h12 : x ∈ (color_set 1),
        exact set.mem_univ x,
        },
      have h12 : (color_set 2) = set.univ, from by {
        apply set.ext,
        assume x,
        assume h13 : x ∈ (color_set 2),
        exact set.mem_univ x,
        },
      exact h10.symm
      },
    have h10 : disjoint (color_set 1) (color_set 2), from (classical.prop_decidable (disjoint (color_set 1) (color_set 2))).mp h9,
    have h11 : (disjoint (color_set 1) (color_set 2)) = true, from by {
      apply propext,
      apply ⟨assume h12, by { exact classical.by_contradiction h10 },
      assume h12, by { exact h9 }⟩,
      },
    have h12 : (color_set 1) ∩ (color_set 2) = ∅, from by {
      apply h10,
      },
    have h13 : (color_set 1) ∪ (color_set 2) = set.univ, from by {
      apply set.ext,
      assume x,
      assume h14 : x ∈ (color_set 1) ∪ (color_set 2),
      exact set.mem_univ x,
      },
    let A : Type* := (equiv.set_compl (color_set 1)),
    have h14 : A = (color_set 2), from by {
      apply set.ext,
      assume x,
      assume h15 : x ∈ A,
      let h16 : (color_set 1) ∩ {x}, from by {
        split,
        apply h15.mp,
        },
      rw [←h12] at h16,
      have h17 : ∀ y, y ∈ {x} → y ∉ (color_set 1), from by {
        assume y,
        assume h18 : y ∈ {x},
        have h19 : y ∉ (color_set 1), from by {
          have h20 : (color_set 1) ∩ ({x}) = ∅, from h12,
          rw [←h20] at h16,
          exact h16.2 y h18,
          },
        exact h19,
        },
      rw [←h11] at h16,
      have h18 : ∀ y, y ∈ {x} → y ∈ (color_set 2), from by {
        assume y,
        assume h19 : y ∈ {x},
        have h20 : ∀ y, y ∉ (color_set 1) → y ∈ (color_set 2), from by {
          assume y,
          assume h21 : y ∉ (color_set 1),
          have h22 : ∀ y, y ∈ (color_set 1) ∨ y ∈ (color_set 2), from by {
            assume y,
            cases (mem_or_compl_of_mem_union h13).elim (λh,or.inl h)(λh,or.inr h),
            },
          cases h22 y with h23 h23,
          contradiction,
          exact h23,
          },
        have h21 : y ∉ (color_set 1), from h17 y h19,
end --Needs more than 2000 tokens!

--OUTPUT 2
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  --⟨⟩
  split, assume ⟨hL : G.colorable 2, hR : ∀ (V₁ V₂ : set V) (h : V₁ ∪ V₂ = V), (G ≤ cast (congr_arg _ h) (complete_bipartite_graph V₁ V₂)) → (false)⟩,
  {
    have h : ℕ = 2, from by {cases dec_trivial},
    have h' : V = (V → bool), from by rw eq_true,
    have h'' : V = (V → ℕ), from by {rw [h'], rw [h]},
    rw [h''],
    apply group_action.free_action_left_of_free_action_right,

    have h' : V → fin 2, by {
      assume x,
      have h''' : G.colorable 2, from hL,
      have h'' : (V → bool) → Prop, from @group_action.free_action_right _ _ _ hL,
      have h''' : (V → ℕ), from h'',
      have h'''' : ∀ x, x < 2, from by {
        assume x,
        have h' : ℕ = 2, from by {cases dec_trivial},
        exact ne_of_lt ((nat.lt_iff_succ_le _ _).2 (by rw [h']; exact nat.lt_succ_self _))
      },
      exact classical.some h''',
    },
    --right
    assume ⟨V₁ V₂ : set V⟩, assume h : (V₁ ∪ V₂ = V) ∧ ∀ (x y : V), (x ∈ V₁) ∧ (y ∈ V₂) → (x ≠ y) → ((G.to_multigraph).adj x y),
    {
      have h' : V → fin 2, by apply h',
      have h'' : (V → bool), from by {
        assume x,
        have h''' : V → fin 2, from by {assumption},
        have h'' : (V → fin 2) → (V → bool), from @group_action.free_action_left _ _ _ h''',
        have h''' : (V → bool), from h'',
        apply h'''
      },
      have h''' : (V → bool) → Prop, from @group_action.free_action_right _ _ _ hL,
      have h'''' : (V → bool), from h''',
      have h''''' : ∀ x, x < 2, from by {
        assume x,
        have h' : ℕ = 2, from by {cases dec_trivial},
        exact ne_of_lt ((nat.lt_iff_succ_le _ _).2 (by rw [h']; exact nat.lt_succ_self _))
      },
      exact classical.some h''',
    },

  },
  --⟨⟩
  assume ⟨V₁ V₂ : set V, h : (V₁ ∪ V₂ = V) ∧ ∀ (x y : V), (x ∈ V₁) ∧ (y ∈ V₂) → (x ≠ y) → ((G.to_multigraph).adj x y)⟩,
  {
    have h' : V → fin 2, by {
      assume x,
      have h2 : V → bool, from by {
        assume x,
        have h₁ : (V₁ ∪ V₂ = V) ∧ ∀ (x y : V), (x ∈ V₁) ∧ (y ∈ V₂) → (x ≠ y) → ((G.to_multigraph).adj x y), from h,
        by_cases (x ∈ V₁),
        exact (dec_trivial : fin 2),
        exact (dec_trivial : fin 2)
      },
      have h₁ : (V₁ ∪ V₂ = V) ∧ ∀ (x y : V), (x ∈ V₁) ∧ (y ∈ V₂) → (x ≠ y) → ((G.to_multigraph).adj x y), from h,
      have h₂ : (V → bool) → Prop, from @group_action.free_action_right _ _ _ hL,
      have h₃ : (V → bool), from h₂,
      have h₄ : ∀ x, x < 2, from by {
        assume x,
        have h' : ℕ = 2, from by {cases dec_trivial},
        exact ne_of_lt ((nat.lt_iff_succ_le _ _).2 (by rw [h']; exact nat.lt_succ_self _))
      },
      exact classical.some h₃
    },
    --left
    exact ⟨cast (congr_arg _ h) (complete_bipartite_graph V₁ V₂)⟩,
  },
end

--OUTPUT 3
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  -- $G$ is a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color
  assume h1 : G.colorable 2,
  -- let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue
  have h2 : ∃ A : set V, ∃ B : set V, ((∀ a : V, a ∈ A ∨ a ∈ B) ∧ (∀ a : V, a ∉ A ∨ a ∉ B) ∧
    ((∀ a b : V, (a = b ∨ ((a ∈ A ∧ b ∈ B) ∨ (a ∈ B ∧ b ∈ A)))))) ∧
    (∀ a : V, (a ∈ A ↔ (G.adj a ∧ ¬ G.adj⁻¹ a)) ∧ (a ∈ B ↔ (¬ G.adj a ∧ G.adj⁻¹ a))) :=
by {
  have h2a : ∃ A : set V, ∃ B : set V, ((∀ (a : V), a ∈ A ∨ a ∈ B) ∧ (∀ (a : V), a ∉ A ∨ a ∉ B) ∧ ((∀ (a b : V), (a = b ∨ ((a ∈ A ∧ b ∈ B) ∨ (a ∈ B ∧ b ∈ A)))))), from
  by {
    use h1.fst, use h1.snd, split, {
      -- $V$ can be partitioned into disjoint sets $A$ and $B$ holding the red- and blue-colored vertices, respectively.
      intro a, intro h2b,
      have h2c : ((G.e_coloring h1.snd) a = 1) ∨ ((G.e_coloring h1.snd) a = 0), from by {
        rw index_eq_one_or_two_of_not_eq_zero at h2b,
        rw h1.snd at h2b,
        have h2d : ((G.e_coloring h1.snd) a <= 2) ∧ ((G.e_coloring h1.snd) a > 0), from nat.le_iff_exists_add.mp h2b,
        cases h2d,
        have h2e : ((G.e_coloring h1.snd) a) + 1 = 2, from by {rw ← add_one (G.e_coloring h1.snd a), rw lt_add_one_iff, rw h2d_right, apply zero_lt_one,},
        have h2f : ((G.e_coloring h1.snd) a) + 1 > 0, from by {apply nat.succ_pos (G.e_coloring h1.snd a),},
        have h2g : ((G.e_coloring h1.snd) a) + 1 > 0 ∧ ((G.e_coloring h1.snd) a) + 1 <= 2, from by {split, exact h2f, exact h2d_left,},
        rw ← add_one ((G.e_coloring h1.snd) a) at h2g,
        rw ← add_one ((G.e_coloring h1.snd) a) at h2e,
        have h2h : ((nat.succ ((G.e_coloring h1.snd) a)) = (nat.succ 0)) ∨ ((nat.succ ((G.e_coloring h1.snd) a)) = (nat.succ 1)), from
        by {apply nat.eq_or_succ_of_le_succ h2g,},
        have h2k : ((G.e_coloring h1.snd) a) = 0 ∨ ((G.e_coloring h1.snd) a) = 1, from by {rw ← nat.succ_eq_add_one at h2h, simp at h2h, exact h2h,},
        show ((G.e_coloring h1.snd) a = 1) ∨ ((G.e_coloring h1.snd) a = 0), from by {rw ← nat.succ_eq_add_one, simp, exact h2k,},
      },
      cases h2c, {
        -- $a \in A$ if $(G.e_coloring h1.snd) a = 1$.
        exact or.inl h2c,}, {
        -- $a \in B$ if $(G.e_coloring h1.snd) a = 0$.
        exact or.inr h2c,},
    }, {
      -- $\forall a, a \notin A$ or $a \notin B$
      intro a, intro h2b,
      have h2c : ¬ (a ∈ (h1.fst)) ∧ ¬ (a ∈ (h1.snd)), from
      by {split, {
        -- If $a \in A$, then $(G.e_coloring h1.snd) a = 1$, which is impossible by the definition of $e_coloring$.
        rw [h1.snd] at h2b,
        have h2c1 : ((G.e_coloring h1.snd) a) > 0 ∧ ((G.e_coloring h1.snd) a) ≤ 2, from
        by {split, {
          -- $\forall a \in G.e_coloring h1.snd), (G.e_coloring h1.snd) a > 0$.
          apply nat.succ_pos (G.e_coloring h1.snd a),}, {
          -- $\forall a \in G.e_coloring h1.snd), (G.e_coloring h1.snd) a \leq 2$.
          apply nat.le_of_lt_succ,
          apply h2b,
        }},
        have h2d : (G.e_coloring h1.snd) a = 0 ∨ (G.e_coloring h1.snd) a = 1, from by {rw ← nat.succ_eq_add_one at h2c1, apply nat.eq_or_succ_of_le_succ h2c1,},
        cases h2d, {
          -- $\forall a \in G.e_coloring h1.snd), (G.e_coloring h1.snd) a \leq 1$.
          rw h2d, apply zero_not_one,}, {
          -- $\forall a \in G.e_coloring h1.snd), (G.e_coloring h1.snd) a \leq 1$.
          rw h2d, apply succ_ne_zero (G.e_coloring h1.snd a),}}, {
        -- If $a \in B$, then $(G.e_coloring h1.snd) a = 0$, which is impossible by the definition of $e_coloring$.
        rw [h1.snd] at h2b,
        have h2c1 : ((G.e_coloring h1.snd) a) > 0 ∧ ((G.e_coloring h1.snd) a) ≤ 2, from
        by {split, {
          -- $\forall a \in G.e_coloring h1.snd), (G.e_coloring h1.snd) a > 0$.
          apply nat.succ_pos (G.e_coloring h1.snd a),}, {
          -- $\forall a \in G.e_coloring h1.snd), (G.e_coloring h1.snd) a \leq 2$.
          apply nat.le_of_lt_succ,
          apply h2b,
        }},
        have h2d : (G.e_coloring h1.snd) a = 0 ∨ (G.e_coloring h1.snd) a = 1, from by {rw ←
end --Needs more than 2000 tokens!

--OUTPUT 4
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  have h1 : (G.colorable 2) → ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B) := assume gc : (G.colorable 2),
  begin
    have h1 : G.two_colorable := ⟨⟨gc,by simp [two_colorable], ⟨⟩⟩⟩,
    have h2 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from h1.two_colorable_iff_bipartite,
    exact h2,
  end,
  have h2 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B) → (G.colorable 2) := assume h2,
  begin
    have h1 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from h2,
    have h2 : G.two_colorable, from by {apply set.two_colorable_of_sub_complete_bipartite_graph,assumption},
    show (G.colorable 2), from by {apply set.colorable_of_two_colorable,assumption},
  end,
  exact iff.intro h1 h2,
end

--OUTPUT 5
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  -- Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color
  assume hColor : G.colorable 2,
  -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue
  have hPartition : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
    begin
      -- Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color
      have hColor : G.colorable 2, from hColor,

      -- Then there exists a coloring of $G$
      have hExists : ∃ c : coloring V 2, G.is_valid_coloring c, from hColor,
      -- There exists a function from $V$ to $\set{0,1}$
      have hExistsFunction : ∃ f : V → multiset ℕ 2, (∀ v : V, v ∈ V → f v = ι(0:ℕ) ∨ f v = ι(1:ℕ)), from
        begin
          -- The function $p$ takes any vertex $v \in V$ and returns the color of $v$
          have hP : ∃ p : V → multiset ℕ 2, (∀ v : V, v ∈ V → p v = c v), from
            begin
              have hP : ∃ p : V → multiset ℕ 2, (∀ v : V, (Σ' x, p v x) = c v), from
                begin
                  -- Pick an arbitrary function $p$ such that for any $v \in V$, $(\Sigma' x, p v x)$ = $c v$
                  have hP : ∃ p : V → multiset ℕ 2, (∀ v : V, v ∈ V → ∀ x : ℕ, p v x = c v x), from
                    begin
                      -- Let $p$ be the function such that for any $v \in V$, $p v = c v$
                      let p : V → multiset ℕ 2 := λ v, (c v),
                      -- Then for any $v \in V$, and $x$, $p v x$ = $c v x$
                      have h : ∀ v : V, v ∈ V → ∀ x : ℕ, p v x = c v x, from by obviously,
                      show ∃ p : V → multiset ℕ 2, (∀ v : V, v ∈ V → ∀ x : ℕ, p v x = c v x), from ⟨p,h⟩
                    end,

                  -- Take the function $p$ such that for any $v \in V$, $p v = c v$
                  let p : V → multiset ℕ 2 := classical.some hP,
                  -- Then for any $v \in V$, $p v = c v$
                  have hP : ∀ v : V, (Σ' x, p v x) = c v, from
                    begin
                      assume v : V,
                      -- By uniqueness of multiset from it's index pair, letting $p(v)$ = $c(v)$ is an injection
                      have hInj : (Σ' x, p v x) = (Σ' x, c v x), from by obviously,
                      -- The function $p$ ensures that for any $v$, $p v = c v$
                      have h : ∀ v : V, v ∈ V → ∀ x : ℕ, p v x = c v x, from classical.some_spec hP,
                      show (Σ' x, p v x) = c v, from by {apply congr_arg (Σ' x),apply funext,assumption,},
                    end,
                  show ∃ p : V → multiset ℕ 2, (∀ v : V, (Σ' x, p v x) = c v), from ⟨p, hP⟩,
                end,
              let p : V → multiset ℕ 2 := classical.some hP,
              -- Then for any $v \in V$, $p v = c v$
              have hP : ∀ v : V, v ∈ V → p v = c v, from by obviously,
              show ∃ p : V → multiset ℕ 2, (∀ v : V, v ∈ V → p v = c v), from ⟨p,hP⟩,
            end,
          let p : V → multiset ℕ 2 := classical.some hP,
          -- Then for any $v \in V$, $p v = c v$
          have hP : ∀ v : V, v ∈ V → p v = c v, from by obviously,
          -- Let $f$ be a function from $V$ to $\set{0,1}$
          let f : V → multiset ℕ 2 := λ v, (multiset.erase (p v) 0),

          -- Then for any $v \in V$, $f v = \iota(0)$ or $f v = \iota(1)$
          have hf : ∀ v : V, v ∈ V → f v = ι(0:ℕ) ∨ f v = ι(1:ℕ), from
            begin
              assume v : V,
              assume h : v ∈ V,
              -- Then $v$ is colored $0$ or $1$
              have hColor : ∃ (x: ℕ), p v x = 1, from (hColor.is_valid_coloring (classical.some (hColor.colorable 2))).right v h,
              have h0 : (multiset.erase (p v) 0) = (ι(0:ℕ) : multiset ℕ), from
                begin
                  have h0 : (c v 0 : multiset ℕ) = 0, from by obviously,
                  have h1 : (c v 1 : multiset ℕ) = 1, from by obviously,
                  rw [c,p,hColor,h0,h1,erase_eq_self_iff_mem],
                end,
              have h1 : (multiset.erase (p v) 0) = (ι(1:ℕ) : multiset ℕ), from
                begin
                  have h0 : (c v 0 : multiset ℕ) = 0, from by obviously,
                  have h1 : (c v 1 : multiset ℕ) = 1, from by obviously,
                  rw [c,p,hColor,h0,h1,erase_eq_self_iff_mem],
                end,
              show (multiset.erase (p v) 0) = ι(0:ℕ) ∨ (multiset.erase (p v) 0) = ι(1:ℕ), from by {exact or.inr (eq_of_heq h1)},
            end,
          show ∃ f : V → multiset ℕ 2, (∀ v : V, v ∈ V → f v = ι(0:ℕ) ∨ f v = ι(1:ℕ)), from ⟨f,hf⟩,
        end,
        let f : V → multiset ℕ 2 := classical.some hExistsFunction,
        -- Then for any $v \in V$, $f v = \iota(0)$ or $f v = \iota(1)$
        have hf : ∀ v : V, v ∈ V → f v = ι(0:ℕ) ∨ f v = ι(1:ℕ), from classical.some_spec hExistsFunction,
        -- Let $A$ be the set of all $v \in V$ such that $f v = \iota(0)$
        let A : Type* := {v : V | f v = ι(0:ℕ)},
        -- Let $B$ be the set
end --Needs more than 2000 tokens!

--OUTPUT 6
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  split,
  assume hcolorable : (G.colorable 2),
  -- define the red and blue vertices
  let A := {v : V | hcolorable v = 0},
  let B := {v : V | hcolorable v = 1},

  -- prove A, B are subsets of V
  have hsubsetA : A ⊆ V, from assume a ha, a ∈ V,
  have hsubsetB : B ⊆ V, from assume b hb, b ∈ V,

  -- prove A and B are disjoint
  have hdisjoint : A ∩ B = ∅, from begin
    let f : A → B := (λ a, arbitrary a),
    have : f ∈ A → B, from assume a ha, f a,
    apply funext,
    assume a,
    cases (em (a ∈ A ∩ B)) with h a_in_AB,
    rw h,
    rw mem_inter_iff at a_in_AB,
    rw eq_empty_iff_forall_not_mem,
    rw mem_inter_iff at a_in_AB,
    have := a_in_AB.left,
    have := a_in_AB.right,
    have hfalse := hcolorable a,
    cases hcolorable a with h0 h1,
    have := hfalse.right,
    rw h0 at this,
    have := hfalse.right,
    rw h1 at this,
    have := mem_nhds_sets_iff.mp (mem_nhds_sets this),
    rw mem_nhds_sets_iff,
    rw mem_nhds_sets_iff,
    split,
    assume hcontra,
    have := hdisjoint.mp hcontra,
    have := a_in_AB this,
    cases this,
    assumption,
    assume hcontra,
    have := hdisjoint.mp hcontra,
    have := a_in_AB this,
    cases this,
    assumption,
  end,

  -- define the map from A + B to V
  let h : (A ⊕ B) → V := (λ a, arbitrary a),

  have : f ∈ A → V, from assume a ha, f a,
  apply funext,
  assume a,
  cases (em (a ∈ A ∩ B)) with h a_in_AB,
  rw h,
  rw mem_inter_iff at a_in_AB,
  rw eq_empty_iff_forall_not_mem,
  rw mem_inter_iff at a_in_AB,
  have := a_in_AB.left,
  have := a_in_AB.right,
  have hfalse := hcolorable a,
  cases hcolorable a with h0 h1,
  have := hfalse.right,
  rw h0 at this,
  have := hfalse.right,
  rw h1 at this,
  have := mem_nhds_sets_iff.mp (mem_nhds_sets this),
  rw mem_nhds_sets_iff,
  rw mem_nhds_sets_iff,
  split,
  assume hcontra,
  have := hdisjoint.mp hcontra,
  have := a_in_AB this,
  cases this,
  assumption,
  assume hcontra,
  have := hdisjoint.mp hcontra,
  have := a_in_AB this,
  cases this,
  assumption,

  rw h,

  -- prove (A ⊕ B) is the same set as V
  let hab : (A ⊕ B) = V := hdisjoint.symm.ext,

  -- show every edge in G exists in the bipartite graph
  let hG : G ≤ cast (congr_arg _ hab) (complete_bipartite_graph A B), from
    assume (e : G.edge V) hedged,
    obtain (u v : V) (h : e = ⟨u, v⟩), from hedged,
    obtain (h1 : u ∈ A ∨ u ∈ B), from classical.by_cases
      (assume h : u ∈ A, or.inl h)
      (assume h : ¬ (u ∈ A), or.inr (
        or.inr h)),
    obtain (h2 : v ∈ A ∨ v ∈ B), from classical.by_cases
      (assume h : v ∈ A, or.inl h)
      (assume h : ¬ (v ∈ A), or.inr (
        or.inr h)),

    obtain (h0 : hcolorable u = 0), from (
      obtain (h0 : u ∈ A), from h1,
      obtain (h0 : hcolorable u = 0), from
        (assume (h1 : hcolorable u ≠ 0), or.inr h1),
      have : hcolorable u ∈ {0, 1}, by rw mem_range,
      have : hcolorable u - 1 ∈ {0, -1}, by rw mem_range,
      have : hcolorable u - 1 = 0,
        by {rw h0, apply eq.refl 0},
      have : hcolorable u = 1,
        by {rw h0, ring},
      -- obtain (h0 : u ∉ A), from h1,
      -- obtain (h0 : hcolorable u = 0), from
      --   (assume (h1 : hcolorable u ≠ 0), or.inr h1),
      -- have : hcolorable u ∈ {0, 1}, by rw mem_range,
      -- have : hcolorable u - 1 ∈ {0, -1}, by rw mem_range,
      -- have : hcolorable u - 1 = 0,
      --   by {rw h0, apply eq.refl 0},
      -- have : hcolorable u = 1,
      --   by {rw h0, ring},
    ),

    obtain (h1 : v ∈ A), from h2,
    obtain (h1 : hcolorable v = 0), from
      (assume (h1 : hcolorable v ≠ 0), or.inr h1),
    have : hcolorable v ∈ {0, 1}, by rw mem_range,
    have : hcolorable v - 1 ∈ {0, -1}, by rw mem_range,
    have : hcolorable v - 1 = 0,
      by {rw h1, apply eq.refl 0},
    have : hcolorable v = 1,
      by {rw h1, ring},
    have : hcolorable v ≠ 0, by {rw h1, ring},
    have : hcolorable v ∈ {0, 1}, by rw mem_range,
    have : hcolorable v - 1 ∈ {0, -1}, by rw mem_range,
    have : hcolorable v - 1 = 0,
      by {rw h1, apply eq.refl 0},
    have : hcolorable v = 1,
      by {rw h1, ring},
    rw h at h1,

    -- obtain (h1 : v ∈ A), from h2,
    -- obtain (h1 : hcolorable v = 0), from
    --   (assume (h1 : hcolorable v ≠ 0), or.inr h1),
    -- have : hcolorable v ∈ {0, 1}, by rw mem_range,
    -- have : hcolorable v - 1 ∈ {0, -1}, by rw mem_range,
    -- have : hcolorable v - 1 = 0,
    --   by {rw h1, apply eq.refl 0},
    -- have : hcolorable v = 1,
    --   by {rw h1, ring},
    -- have : hcolorable v ≠ 0, by {rw h1, ring},
    -- have : hcolorable v ∈ {0, 1}, by rw mem_range,
    -- have : hcolorable v - 1 ∈ {0, -1}, by rw mem_range,
    -- have : hcolorable v
end --Needs more than 2000 tokens!

--OUTPUT 7
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
    have h0 : G.colorable 2 → ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
    assume hc : G.colorable 2,
    let A := {a : V | G.col_1 a},
    let B := V \ A,
    let hs := or.inl rfl in
    have hh : (A ⊕ B) = V, from eq.symm (set.ext (
    assume x,
    show x ∈ (A ⊕ B) ↔ x ∈ V, from iff.intro
    (
      assume hin : x ∈ (A ⊕ B),
      have h1 : (A ⊕ B) ⊆ V, from set.subset_union,
      exact set.mem_of_subset_of_mem h1 hin
    )
    (
      assume hin : x ∈ V,
      have h1 : x ∈ A ∨ x ∈ B, from set.mem_or_mem_of_mem_union hin,
      or.by_cases
      (
        assume h2 : x ∈ A,
        have h3 : G.col_1 x = 1, from by apply mem_def.1 h2,
        have h4 : G.col_1 x = 0, from (G.two_colorable_def hc).left x,
        have h5 : (1 : ℕ) = 0, from eq_of_eq_true (eq.symm h3),
        have h6 : false, from dec_trivial,
        absurd h6 trivial
      )
      (
        assume h2 : x ∈ B,
        have h3 : x ∉ A, from set.not_mem_of_mem_diff h2,
        have h4 : G.col_1 x = 0, from decidable.rec_on (G.col_1 x = 0) (by {assume h5, exact h5}) begin assume h5,
        have h6 : G.col_1 x = 1, from by {rw h5, exact (G.two_colorable_def hc).right x},
        have h7 : x ∈ A, from set.mem_def.2 h6,
        have h8 : false, from h3 h7,
        exact dec_trivial end,
        have h5 : G.col_1 x = 1, from decidable.rec_on (G.col_1 x = 1) (by {assume h6, exact h6}) begin assume h6,
        have h7 : G.col_1 x = 0, from by {rw h6, exact (G.two_colorable_def hc).left x},
        have h8 : G.col_1 x = 0, from decidable.rec_on (G.col_1 x = 0) (by {assume h9, exact h9}) begin assume h9,
        have h10 : G.col_1 x = 1, from by {rw h9, exact (G.two_colorable_def hc).right x},
        have h11 : x ∈ A, from set.mem_def.2 h10,
        have h12 : false, from h3 h11,
        exact dec_trivial end,
        have h8 : (1 : ℕ) = 0, from eq_of_eq_true (eq.symm h7),
        have h9 : false, from dec_trivial,
        absurd h9 trivial end,
        have h6 : x ∈ A ⊕ B, from or.inr h4,
        exact set.mem_of_mem_union h6
      )
    )
    ),
    have h2 : complete_bipartite_graph A B = complete_bipartite_graph A B, from rfl,
    have h3 : A ≤ cast (congr_arg _ hs) (complete_bipartite_graph A B), from by {
      apply simple_graph.graph_mono,
      assume x y hxy,
      rw hs at hxy,
      rw h2 at hxy,
      have h4 : G.col_1 x = G.col_1 y, from by {rw ← hxy, apply (G.two_colorable_def hc).left, },
      have h5 : G.col_1 x ≠ G.col_1 y, from by {
        assume h6 : G.col_1 x = G.col_1 y,
        exact absurd h6 (G.two_colorable_def hc).right x y hxy,
      },
      have h6 : G.col_1 x = 0 ∨ G.col_1 x = 1, from by {
        have h7 : G.col_1 x = 0 ∨ G.col_1 x = 1, from by {
          have h8 : G.col_1 x = 0 ∨ G.col_1 x = 1, from decidable.em (G.col_1 x = 0) (G.col_1 x = 1),
          assumption,
        },
        have h9 : G.col_1 x = 0 ∨ G.col_1 x = 1, from by {
          have h10 : G.col_1 x ≠ 0 ∨ G.col_1 x ≠ 1, from decidable.em (G.col_1 x ≠ 0) (G.col_1 x ≠ 1),
          rw H10,
          apply two_colorable_def,
        },
        assumption,
      },
      or.by_cases
      (
        assume h7 : G.col_1 x = 0,
        have h8 : G.col_1 x = G.col_1 y, begin rw h7, exact h4 end,
        have h9 : G.col_1 x = 1, from eq.symm (eq.trans h8 h5),
        have h10 : G.col_1 x = 0, from eq_of_eq_true h7,
        have h11 : false, from eq.rec_on h10 h9,
        have h12 : false, from dec_trivial,
        exact absurd h12 trivial,
      )
      (
        assume h7 : G.col_1 x = 1,
        have h8 : G.col_1 x = G.col_1 y, begin rw h7, exact h4 end,
        have h9 : G.col_1 x = 0, from eq.symm (eq.trans h8 h5),
        have h10 : G.col_1 x = 1, from eq_of_eq_true h7,
        have h11 : false, from eq.rec_on h10 h9,
        have h12 : false, from dec_trivial,
        exact absurd h12 trivial,
      )
    },
    have h4 : B ≤ cast (congr_arg _ hs) (complete_bipartite_graph A B), from by {
      apply simple_graph.graph_mono,
      assume x y hxy,
      rw hs at hxy,
      rw h2 at hxy,
      have h5 : G.col_1 x = G.col_1 y, from by {rw ← hxy, apply (G.two_colorable_def hc).left, },
      have h6 : G.col_1 x ≠ G.col_1 y, from by {
        assume h7 : G.col_1 x = G.col_1 y,
        exact absurd h7 (G.two_colorable_def hc).right x y hxy,
      },
      have h7 : G.col_1 x = 0 ∨ G.col_1 x = 1, from by {
        have h8 : G.col_1 x = 0 ∨ G.col_1 x = 1, from decidable.em (G.col_1 x = 0) (G.col_1 x = 1),
        assumption,
      },
      have h8 : G.col_1 y = 0 ∨ G.col_1 y = 1, from by {
        have h9 : G.col_1 y = 0 ∨ G.col_1 y = 1, from decidable.em (G.col_1 y
end --Needs more than 2000 tokens!

--OUTPUT 8
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  have h : ∀A B, G.colorable 2 → G ≤ cast (congr_arg ((@sum.inl _ _) A B) (sum.inl_injective A B)) (complete_bipartite_graph A B) ∧ G ≤ cast (congr_arg ((@sum.inr _ _) A B) (sum.inr_injective A B)) (complete_bipartite_graph A B), from
  by {
    assume A B,
    assume h : G.colorable 2,
    cases h with f hf,
    let f0 := λ x : A ⊕ B, (if f x = 0 then sum.inl true else sum.inr false) in
    let f1 : (A ⊕ B) → (A ⊕ B) → Prop := λ x y, f x = f y,
    have hf0 : is_coloring (simple_graph.to_multigraph (cast (congr_arg ((@sum.inl _ _) A B) (sum.inl_injective A B)) (complete_bipartite_graph A B))) f0, from
    by {
        apply is_coloring.mk,
        have hf0 : ∀ x : A ⊕ B, (f x = 0) ∨ (f x = 1), from by {
          assume x,
          cases x;
            simp [f, hf.colors_nodup],
        },
        have hf0 : ∀ x : A ⊕ B, (f x = 0) → (f0 x = sum.inl tt), from by {
          assume x h,
          simp [f0, h],
        },
        have hf1 : ∀ x : A ⊕ B, (f x = 1) → (f0 x = sum.inr ff), from by {
          assume x h,
          simp [f0, h],
        },
        have hf2 : ∀ x : A ⊕ B, (f x = 0) → (f0 x ≠ sum.inr ff), from by {
          assume x h,
          simp [f0, h],
        },
        have hf3 : ∀ x : A ⊕ B, (f x = 1) → (f0 x ≠ sum.inl tt), from by {
          assume x h,
          simp [f0, h],
        },
        have hf4 : ∀ x y : A ⊕ B, (f x = f y) → f0 x = f0 y, from by {
          assume x y h,
          by_cases (f x = 0)
          ; simp [h, hf0,hf1],
        },
        have hf5 : ∀ x y : A ⊕ B, (f0 x = f0 y) → (f x = f y), from by {
          assume x y h,
          by_cases (f x = 0)
          ; simp [h, hf0,hf1],
        },
        have hf6 : ∀ x y : A ⊕ B, (f0 x ≠ f0 y) → (f x ≠ f y), from by {
          assume x y h,
          by_cases (f x = 0)
          ; simp [h, hf2,hf3],
        },
        have hf7 : ∀ x y : A ⊕ B, (f x ≠ f y) → (f0 x ≠ f0 y), from by {
          assume x y h,
          by_cases (f x = 0)
          ; simp [h, hf2,hf3],
        },
        intros x y h,
        apply hf7,
        apply hf.disjoint x y h,
      },
    have hf1 : is_coloring (simple_graph.to_multigraph (cast (congr_arg ((@sum.inr _ _) A B) (sum.inr_injective A B)) (complete_bipartite_graph A B))) f0, from
    by {
      apply is_coloring.mk,
        have hf0 : ∀ x : A ⊕ B, (f x = 0) ∨ (f x = 1), from by {
          assume x,
          cases x;
            simp [f, hf.colors_nodup],
        },
        have hf0 : ∀ x : A ⊕ B, (f x = 0) → (f0 x = sum.inl tt), from by {
          assume x h,
          simp [f0, h],
        },
        have hf1 : ∀ x : A ⊕ B, (f x = 1) → (f0 x = sum.inr ff), from by {
          assume x h,
          simp [f0, h],
        },
        have hf2 : ∀ x : A ⊕ B, (f x = 0) → (f0 x ≠ sum.inr ff), from by {
          assume x h,
          simp [f0, h],
        },
        have hf3 : ∀ x : A ⊕ B, (f x = 1) → (f0 x ≠ sum.inl tt), from by {
          assume x h,
          simp [f0, h],
        },
        have hf4 : ∀ x y : A ⊕ B, (f x = f y) → f0 x = f0 y, from by {
          assume x y h,
          by_cases (f x = 0)
          ; simp [h, hf0,hf1],
        },
        have hf5 : ∀ x y : A ⊕ B, (f0 x = f0 y) → (f x = f y), from by {
          assume x y h,
          by_cases (f x = 0)
          ; simp [h, hf0,hf1],
        },
        have hf6 : ∀ x y : A ⊕ B, (f0 x ≠ f0 y) → (f x ≠ f y), from by {
          assume x y h,
          by_cases (f x = 0)
          ; simp [h, hf2,hf3],
        },
        have hf7 : ∀ x y : A ⊕ B, (f x ≠ f y) → (f0 x ≠ f0 y), from by {
          assume x y h,
          by_cases (f x = 0)
          ; simp [h, hf2,hf3],
        },
        intros x y h,
        apply hf7,
        apply hf.disjoint x y h,
      },
    exact ⟨hf0, hf1⟩
  },
  have h1 : G.colorable 2 → ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
    by {
      assume h : G.colorable 2,
      cases G.colorable 2 with f hf,
      let f0 := λ x : A ⊕ B, (if f x = 0 then sum.inl true else sum.inr false) in
      let f1 : (A ⊕ B) → (A ⊕ B) → Prop := λ x y, f x = f y,
      have hf0 : is_coloring (simple_graph.to_multigraph (cast (congr_arg ((@sum.inl _ _) A B) (sum.inl_injective A B)) (complete_bipartite_graph A B))) f0, from
      by {
          apply is_coloring.mk,
          have hf0 : ∀ x : A ⊕ B, (f x = 0) ∨ (f x = 1), from by {
            assume x,
            cases x;
              simp [f, hf.colors_nodup],
          },
          have hf0 : ∀ x : A ⊕ B, (f x = 0) → (f0 x = sum.inl tt), from by {
            assume x h,
            sim
end --Needs more than 2000 tokens!

--OUTPUT 9
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  -- $V$ is the set of vertices of $G$. $f : V → ℕ$ is a function from the set $V$ to the set $\{0, 1\}$
  assume (f : V → ℕ) (h : ∀ {x y : V}, x ≠ y → (f x) ≠ (f y)),
  -- Let $A$ denote the subset of vertices colored 0, and let $B$ denote the subset of vertices colored 1.
  let A : Type* := {x // f x = 0},
  let B : Type* := {x // f x = 1},
  -- $V$ is the disjoint union of the vertices $A$ and $B$.
  have h1 : (A ⊕ B) = V, from ⟨λ⟨x, hx⟩, ⟨x, by {simp only [hx] at hx, exact (nat.eq_zero_of_mul_eq_zero hx)},
    λ v, ⟨f v, by {symmetry, rcases (f v) with rfl}⟩⟩,
    λ x, by {cases x with x y, simp, exact congr_arg (f x) (congr_arg subtype.val (eq_of_mem_singleton x.2)),
      simp, exact congr_arg (f y) (congr_arg subtype.val (eq_of_mem_singleton y.2))}⟩,
  -- Since all vertices of $A$ are colored 0, there are no edges within $A$, and similarly for $B$.
  have h2 : ∀ x ∈ A, ∀ (y : {y // (f x) = y}), x ≠ y → (f x) ≠ (f y), from assume x hx y hy hxy, by {
    exact λ h, by {apply hxy, have h3 : x = y, from eq_of_mem_singleton h, simp *, }},
  have h3 : ∀ x ∈ B, ∀ (y : {y // (f x) = y}), x ≠ y → (f x) ≠ (f y), from assume x hx y hy hxy, by {
    exact λ h, by {apply hxy, have h3 : x = y, from eq_of_mem_singleton h, simp *, }},
  -- This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
  have h4 : ∀ x : V, ∀ y : V, x ≠ y → (f x) ≠ (f y), from assume x y hxy, by {
    cases hxy, rcases (mem_singleton.1 hxy) with ⟨⟩, cases ((mem_singleton.1 (eq_of_mem_singleton hxy)).symm), simp *,
    rcases (mem_singleton.1 hxy) with ⟨⟩, cases ((mem_singleton.1 (eq_of_mem_singleton hxy)).symm), simp *,
  },
  show ∃ ⦃A B⦄ (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from ⟨A,B,h1, by {
    show G ≤ cast (congr_arg _ h1) (complete_bipartite_graph A B), from by {
      apply simple_graph.le_complete_bipartite_graph,
      exact h4,
    },
  }⟩,

  -- Suppose $G$ is bipartite, that is, we can partition the vertices into two subsets $V_{1}, V_{2}$.
  assume (A : Type*) (B : Type*) (h : (A ⊕ B) = V) (h1 : G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)),
  have h2 : ∀ u ∈ V, ∀ v ∈ V, u ≠ v → (u ∈ A) ∨ (v ∈ A), from by {
    assume (u v : V) (h1 : (u ∈ V)) (h2 : (v ∈ V)), assume h3 : u ≠ v, by {
      have h3 : u ∈ A ⊕ B, from by {
        rw ← h, exact h1, },
      rcases h3 with ⟨h4, rfl⟩ | ⟨h4, rfl⟩, exact or.inl h4, exact or.inr h4,
    },
  },
  -- Then coloring every vertex of $V_{1}$ 0 and every vertex of $V_{2}$ 1 yields a valid coloring, so $G$ is 2-colorable.
  have h3 : ∀ x : V, ∀ y : V, x ≠ y → (f x) ≠ (f y), from assume (x y : V) (h3 : x ≠ y), by {
    assume h4 : (f x) = (f y),
    have h5 : (f x) ∈ {0, 1}, from by {
      rw ← h4, exact (mem_singleton.2 h4), },
    rw ← h4,
    cases h3,
    rcases (mem_singleton.1 h3) with ⟨⟩,
    { have h6 : x ∈ A, from by {
        have h6 : x ∈ V, from by {
          have h6 : V ≃ A ⊕ B, from ⟨λ v, (cast (congr_arg _ h) (inl v)), λ v, cast (congr_arg _ h.symm) v,
            λ v, by {rcases (cast (congr_arg _ h) (inl v)) with ⟨v, rfl⟩, exact rfl, },
            λ v, by {rcases v with ⟨v, rfl⟩, rcases (cast (congr_arg _ h.symm) (inl v)) with ⟨v, rfl⟩, exact rfl, }⟩,
          have h7 := h6,
          rw set.image_id at h7,
          exact h7 h, },
        exact h2 x h6 y (inr rfl) h3, },
      exact (inl h6), },
    { have h6 : y ∈ A, from by {
        have h6 : y ∈ V, from by {
          have h6 : V ≃ A ⊕ B, from ⟨λ v, (cast (congr_arg _ h) (inl v)), λ v, cast (congr_arg _ h.symm) v,
            λ v, by {rcases (cast (congr_arg _ h) (inl v)) with ⟨v, rfl⟩, exact rfl, },
            λ v, by {rcases v with ⟨v, rfl⟩, rcases (cast (congr_arg _ h.symm) (inl v)) with ⟨v, rfl⟩, exact rfl, }⟩,
          have h7 := h6,
          rw set.image_id at h7,
          exact h7 h, },
        exact h2 y h6 x (inl rfl) h3, },
      exact (inl h6), },
    cases (h2 x (inl rfl) y (inr rfl) h3),
    cases (h2 y (inr rfl) x (inl rfl) h3),
    exact (h2 x (or.inr h3) y (or.inr h3) h3),
  },
  show G.colorable 2, from ⟨λ x, (f x), ⟨(λ x, ⟨f x, by {reflexivity, }⟩), λ ⟨x, hx⟩, by {rw ← hx, reflexivity}⟩, h3⟩,
end

--OUTPUT 10
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  show (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)), from
    begin
    split,
    {
      assume h1 : (G.colorable 2),
      have h2 : ∀ v : V, ∃ e : fin 2, ∀ (e' : fin 2), (e ∈ G v) ↔ (e' ≠ e), from
        assume (v : V), exists_congr (λ v, ∀ (e' : fin 2), (e ∈ G v) ↔ (e' ≠ e)),
        by { apply h1, intro v, },
      have h3 : ∀ (v : V), ∃ e : fin 2, ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ), from
        assume (v : V), exists_congr (λ (v : V), ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ)),
        by { apply h2, intro v, },
      have h4 : ∀ (v : V), (∃ (e : fin 2), ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ)) ∧
           (∃ (e : fin 2), ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ)), from
        assume (v : V), and.intro (h3 v) (h3 v),
      have h5 : ∀ (v : V), (∃ (e : fin 2), ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ)) ∧
           (∃ (e : fin 2), ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ)), from
        assume (v : V), and.intro (h3 v) (h3 v),
      have h6 : ∃ v : V, ∃ (e : fin 2), ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ), from exists.intro (set.arbitrary V) (h3 (set.arbitrary V)),
      have h7 : ∃ (e : fin 2), ∀ (e' : fin 2), (e ∈ G (some h6)) ↔ (e' = e.succ), from exists.intro (some (some (h6))) (some ((some h6).property.right)),
      have h8 : ∀ v : V, ∃ v, ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ), from
        assume v : V, show ∃ v, ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ), from
        exists.intro (some h6) (some (h6).property.right),
      have h9 : ∃ (A : Type*) (h : fin 2 = A), (∀ v : A, ∃ v, ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ)), from
        exists.intro (fin 2) (congr_fun (some (h6)).property.right),
      have h10 : ∃ (A : Type*) (h : fin 2 = A), (∀ v : A, ∃ v, ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ)), from
        exists.intro (fin 2) (congr_fun (some (h6)).property.right),
      have h11 : ∃ (A : Type*) (h : fin 2 = A), (∀ v : A, ∃ v, ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ)), from
        exists.intro (fin 2) (congr (not_imp_not h8 (type.mk ℕ) (type.mk ℕ) (type.mk ℕ)).symm),
      have h12 : ∃ (A : Type*) (h : fin 2 = A), (∀ v : A, ∃ v, ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ)), from
        exists.intro (fin 2) (congr (not_imp_not h8 (type.mk ℕ) (type.mk ℕ) (type.mk ℕ)).symm),
      have h13 : ∃ (A : Type*) (h : fin 2 = A), (∀ v : A, ∃ v, ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ)), from
        exists.intro (fin 2) (congr (not_imp_not h8 (type.mk ℕ) (type.mk ℕ) (type.mk ℕ)).symm),
      have h14 : ∃ (A : Type*) (h : fin 2 = A), (∀ v : A, ∃ v, ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ)), from
        exists.intro (fin 2) (congr (not_imp_not h8 (type.mk ℕ) (type.mk ℕ) (type.mk ℕ)).symm),
      have h15 : ∃ (A : Type*) (h : fin 2 = A), (∀ v : A, ∃ v, ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ)), from
        exists.intro (fin 2) (congr (not_imp_not h8 (type.mk ℕ) (type.mk ℕ) (type.mk ℕ)).symm),
      have h16 : ∃ (A : Type*) (h : fin 2 = A), (∀ v : A, ∃ v, ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ)), from
        exists.intro (fin 2) (congr (not_imp_not h8 (type.mk ℕ) (type.mk ℕ) (type.mk ℕ)).symm),
      have h17 : ∃ (A : Type*) (h : fin 2 = A), (∀ v : A, ∃ v, ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ)), from
        exists.intro (fin 2) (congr (not_imp_not h8 (type.mk ℕ) (type.mk ℕ) (type.mk ℕ)).symm),
      have h18 : ∃ (A : Type*) (h : fin 2 = A), (∀ v : A, ∃ v, ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ)), from
        exists.intro (fin 2) (congr (not_imp_not h8 (type.mk ℕ) (type.mk ℕ) (type.mk ℕ)).symm),
      have h19 : ∃ (A : Type*) (h : fin 2 = A), (∀ v : A, ∃ v, ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ)), from
        exists.intro (fin 2) (congr (not_imp_not h8 (type.mk ℕ) (type.mk ℕ) (type.mk ℕ)).symm),
      have h20 : ∃ (A : Type*) (h : fin 2 = A), (∀ v : A, ∃ v, ∀ (e' : fin 2), (e ∈ G v) ↔ (e' = e.succ)), from
        exists.intro (fin 2) (congr (not_imp_not h8 (type.mk ℕ) (type.mk ℕ) (type.mk
end --Needs more than 2000 tokens!

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  -- $A$ and $B$ are sets. $A$ and $B$ belong to power set of $S$
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  -- Then $A ⊆ S$ and $B ⊆ S$, by power set definition
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by {split,apply set.subset_of_mem_powerset,exact hA,apply set.subset_of_mem_powerset,exact hB},
  -- Then $(A ∩ B) ⊆ A$, by intersection of set is a subset
  have h2 : (A ∩ B) ⊆ A, from by apply set.inter_subset_left,
  -- Then $(A ∩ B) ⊆ S$, by subset relation is transitive
  have h3 : (A ∩ B) ⊆ S, from by {apply set.subset.trans h2 h1.left},
  -- Hence $(A ∩ B) ∈  𝒫 S$, by power set definition
  show (A ∩ B) ∈  𝒫 S, from by {apply set.mem_powerset h3},
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  -- expand the power
  calc (x + y)^2 = (x+y)*(x+y) : by rw sq
  -- distributive property of multiplication over addition gives:
  ... = x*(x+y) + y*(x+y) : by rw add_mul
  -- applying the above property further gives:
  ... = x*x + x*y + y*x + y*y : by {rw [mul_comm x (x+y),mul_comm y (x+y)], rw [add_mul,add_mul], ring}
  -- rearranging the terms using commutativity and adding gives:
  ... = x^2 + 2*x*y + y^2 : by {repeat {rw ← sq}, rw mul_comm y x, ring}
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  -- Group has Latin Square Property
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by {
    assume a b : G, use a⁻¹ * b, obviously, },
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by {
    assume a b : G, use b * a⁻¹, obviously, },

  -- Setting $b = a$, this becomes:
  have h3 : ∀ a : G, ∃! x : G, a * x = a, from
    assume a : G, h1 a a,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from
    assume a : G, h2 a a,

  -- These $x$ and $y$ are both $(1 : G)$, by definition of identity element
  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from assume a :G,
    exists_unique.unique (h3 a) (classical.some_spec (exists_unique.exists (h3 a)))
    (mul_one a),
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from assume a : G,
    exists_unique.unique (h4 a) (classical.some_spec (exists_unique.exists (h4 a))) (one_mul a),

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (hident : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a).exists, from assume (a : G),
        exists_unique.unique (h3 a) (hident a).right
        (classical.some_spec (exists_unique.exists (h3 a))),
      have h9 : ∀ a : G, e = classical.some (h4 a).exists, from assume (a : G),
        exists_unique.unique (h4 a) (hident a).left
        (classical.some_spec (exists_unique.exists (h4 a))),
      show e = (1 : G), from eq.trans (h9 e) (h6 _),
    },
    exact ⟨by obviously, h7⟩,
  }
end

/--`theorem`
Bipartite Graph is two colorable
Let $G$ be a graph. Then $G$ is 2-colorable if and only if $G$ is bipartite.
`proof`
Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color. Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue. Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$. This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.

Conversely, suppose $G$ is bipartite, that is, we can partition the vertices into two subsets $V_{1}, V_{2}$ every edge has one endpoint in $V_{1}$ and the other in $V_{2}$. Then coloring every vertex of $V_{1}$ red and every vertex of $V_{2}$ blue yields a valid coloring, so $G$ is 2-colorable.

QED

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
FEW SHOT PROMPTS TO CODEX(END)-/