import algebra.group_power algebra.linear_algebra.prod_module algebra.module
import data.finsupp data.set.basic tactic.ring
noncomputable theory

universes u u₁ v v₁ w w₁

open classical set function
local attribute [instance] decidable_inhabited prop_decidable

namespace prod

@[simp] lemma prod_add_prod {α : Type u} {β : Type v} {γ : Type w}
  [comm_ring α] [module α β] [module α γ] (x₁ x₂ : β) (y₁ y₂ : γ) :
  (x₁, y₁) + (x₂, y₂) = (x₁ + x₂, y₁ + y₂) := rfl

@[simp] lemma smul_prod {α : Type u} {β : Type v} {γ : Type w}
  [comm_ring α] [module α β] [module α γ] (r : α) (x : β) (y : γ) :
  r • (x, y) = (r • x, r • y) := rfl

@[simp] lemma fst_smul {α : Type u} {β : Type v} {γ : Type w}
  [comm_ring α] [module α β] [module α γ] (r : α) (z : β × γ) :
  (r • z).fst = r • z.fst := rfl

@[simp] lemma snd_smul {α : Type u} {β : Type v} {γ : Type w}
  [comm_ring α] [module α β] [module α γ] (r : α) (z : β × γ) :
  (r • z).snd = r • z.snd := rfl

end prod

class type_singleton (α : Type u) : Type u :=
(default : α)
(unique : ∀ x : α, x = default)

namespace type_singleton

variables (α : Type u) [type_singleton α]
variables (β : Type v) [type_singleton β]

def equiv_unit : equiv α unit :=
{ to_fun    := λ x, unit.star,
  inv_fun   := λ x, type_singleton.default α,
  left_inv  := λ x, by rw type_singleton.unique x,
  right_inv := λ x, unit.cases_on x rfl }

def equiv_singleton : equiv α β :=
{ to_fun    := λ x, type_singleton.default β,
  inv_fun   := λ x, type_singleton.default α,
  left_inv  := λ x, by rw type_singleton.unique x,
  right_inv := λ x, by rw type_singleton.unique x }

end type_singleton

@[simp] lemma quotient.lift_beta {α : Sort u} {β : Sort v} [s : setoid α] (f : α → β) (h : ∀ (a b : α), a ≈ b → f a = f b) (x : α):
quotient.lift f h (quotient.mk x) = f x := rfl

@[simp] lemma quotient.lift_on_beta {α : Sort u} {β : Sort v} [s : setoid α] (f : α → β) (h : ∀ (a b : α), a ≈ b → f a = f b) (x : α):
quotient.lift_on (quotient.mk x) f h = f x := rfl

section bilinear

variables {α : Type u} [comm_ring α]
include α

variables {β : Type v} {γ : Type w} {α₁ : Type u₁} {β₁ : Type v₁}
variables [module α β] [module α γ] [module α α₁] [module α β₁]

structure is_bilinear_map {β γ α₁}
  [module α β] [module α γ] [module α α₁]
  (f : β → γ → α₁) : Prop :=
(add_pair : ∀ x y z, f (x + y) z = f x z + f y z)
(pair_add : ∀ x y z, f x (y + z) = f x y + f x z)
(smul_pair : ∀ r x y, f (r • x) y = r • f x y)
(pair_smul : ∀ r x y, f x (r • y) = r • f x y)

variables {f : β → γ → α₁} (hf : is_bilinear_map f)
include hf

theorem is_bilinear_map.zero_pair : ∀ y, f 0 y = 0 :=
λ y, calc f 0 y
        = f (0 + 0) y - f 0 y : by rw [hf.add_pair 0 0 y]; simp
    ... = 0 : by simp

theorem is_bilinear_map.pair_zero : ∀ x, f x 0 = 0 :=
λ x, calc f x 0
        = f x (0 + 0) - f x 0 : by rw [hf.pair_add x 0 0]; simp
    ... = 0 : by simp

theorem is_bilinear_map.linear_pair (y : γ) : is_linear_map (λ x, f x y) :=
{ add  := λ m n, hf.add_pair m n y,
  smul := λ r m, hf.smul_pair r m y }

theorem is_bilinear_map.pair_linear (x : β) : is_linear_map (λ y, f x y) :=
{ add  := λ m n, hf.pair_add x m n,
  smul := λ r m, hf.pair_smul r x m }

variables {g : α₁ → β₁} (hg : is_linear_map g)
include hg

theorem is_bilinear_map.comp : is_bilinear_map (λ x y, g (f x y)) :=
{ add_pair  := λ x y z, by rw [hf.add_pair, hg.add],
  pair_add  := λ x y z, by rw [hf.pair_add, hg.add],
  smul_pair := λ r x y, by rw [hf.smul_pair, hg.smul],
  pair_smul := λ r x y, by rw [hf.pair_smul, hg.smul] }

omit hf hg

variables (β γ)

structure module_iso (β γ) [module α β] [module α γ] extends equiv β γ :=
( linear : is_linear_map to_fun )

end bilinear

infix ` ≃ₘ `:25 := module_iso

namespace module_iso

variables (α : Type u) [comm_ring α]
variables (β : Type v) (γ : Type w) (α₁ : Type u₁) [module α β] [module α γ] [module α α₁]

variables {α β γ α₁}
include α

protected def refl : β ≃ₘ β :=
{ linear := is_linear_map.id
  ..equiv.refl β }

protected def symm (hbc : β ≃ₘ γ) : γ ≃ₘ β :=
{ linear := is_linear_map.inverse hbc.linear hbc.left_inv hbc.right_inv
  ..equiv.symm hbc.to_equiv }

protected def trans : β ≃ₘ γ → γ ≃ₘ α₁ → β ≃ₘ α₁ :=
λ hbc hca,
{ linear := is_linear_map.comp hca.linear hbc.linear
  ..equiv.trans hbc.to_equiv hca.to_equiv }

end module_iso

theorem gsmul_sub (α : Type u) [add_group α] (a : α) :
  ∀ i j : int, gsmul a (i - j) = gsmul a i - gsmul a j :=
begin
  intros i j,
  rw sub_eq_add_neg,
  rw sub_eq_add_neg,
  rw gsmul_add,
  rw gsmul_neg
end

theorem add_gsmul (α : Type u) [add_comm_group α] (a b : α) : ∀ n, gsmul (a + b) n = gsmul a n + gsmul b n :=
begin
  intro n,
  induction n,
  { rw ← int.coe_nat_eq,
    rw smul_coe_nat,
    rw smul_coe_nat,
    rw smul_coe_nat,
    rw add_monoid.add_smul },
  { rw int.neg_succ_of_nat_eq,
    rw gsmul_neg,
    rw gsmul_neg,
    rw gsmul_neg,
    rw gsmul_add,
    rw gsmul_add,
    rw gsmul_add,
    rw smul_coe_nat,
    rw smul_coe_nat,
    rw smul_coe_nat,
    rw add_monoid.add_smul,
    simp }
end

theorem sub_gsmul (α : Type u) [add_comm_group α] (a b : α) : ∀ n, gsmul (a - b) n = gsmul a n - gsmul b n :=
begin
  intro n,
  rw sub_eq_add_neg,
  rw sub_eq_add_neg,
  rw add_gsmul,
  rw neg_gsmul
end

theorem gsmul_smul (α : Type u) (β : Type v) [ring α] [module α β] (r : α) (x : β) :
  ∀ n:ℤ, gsmul (r • x) n = r • gsmul x n :=
begin
  intro n,
  cases n,
  { induction n with n ih,
    { simp },
    { rw nat.succ_eq_add_one,
      rw int.of_nat_add,
      simp [gsmul_add] at ih ⊢,
      rw ih,
      rw smul_add } },
  { rw int.neg_succ_of_nat_eq,
    rw gsmul_neg,
    rw gsmul_neg,
    rw gsmul_add,
    induction n with n ih,
    { simp [gsmul_one] },
    { simpa [gsmul_add, ih, smul_add] using ih } }
end

namespace multiset

variable {α : Type u}

@[simp] theorem map_id (s : multiset α) : map id s = s :=
quot.induction_on s $ λ l, congr_arg coe $ list.map_id _

end multiset

namespace list

theorem map_neg {α : Type u} [add_comm_group α] :
  ∀ L:list α, (L.map (λ x, -x)).sum = -L.sum
| []     := by simp
| (h::t) := by simp [map_neg t]

theorem sum_singleton {α : Type u} [add_group α] {x : α} :
  list.sum [x] = x :=
calc list.sum [x] = x + list.sum [] : list.sum_cons
              ... = x + 0 : congr_arg _ list.sum_nil
              ... = x : add_zero x

end list

namespace finsupp

variables {α : Type u} {β : Type v} [add_comm_group β] {a : α} {b b₁ b₂ : β}

variables {α₁ : Type u₁}

variables {γ : Type w} [add_comm_group γ]

@[simp] lemma single_neg : single a (-b) = -single a b :=
ext $ assume a',
begin
  by_cases h : a = a',
  { rw [h, neg_apply, single_eq_same, single_eq_same] },
  { rw [neg_apply, single_eq_of_ne h, single_eq_of_ne h, neg_zero] }
end

@[simp] lemma single_sub : single a (b₁ - b₂) = single a b₁ - single a b₂ :=
by simp

theorem sum_neg_index' {g : α →₀ β} {h : α → β → γ}:
  (∀ (a : α) (b₁ b₂ : β), h a (b₁ - b₂) = h a b₁ - h a b₂) → finsupp.sum (-g) h = -finsupp.sum g h :=
begin
  intro H,
  rw ← zero_sub,
  rw sum_sub_index H,
  rw sum_zero_index,
  rw zero_sub
end

@[simp] theorem finsum_apply {S : finset α₁} {f : α₁ → α →₀ β} {z : α} :
  (S.sum f) z = S.sum (λ x, f x z) :=
eq.symm $ finset.sum_hom (λ g : α →₀ β, g z) rfl (λ x y, rfl)

end finsupp

namespace tensor_product

variables (α : Type u) [comm_ring α]
variables (β : Type v) (γ : Type w) (α₁ : Type u₁) (β₁ : Type v₁) (γ₁ : Type w₁)
variables [module α β] [module α γ] [module α α₁] [module α β₁] [module α γ₁]

def free_abelian_group : Type (max v w) := β × γ →₀ ℤ

instance free_abelian_group.has_coe_to_fun : has_coe_to_fun (free_abelian_group β γ) :=
finsupp.has_coe_to_fun

instance free_abelian_group.add_comm_monoid : add_comm_monoid (free_abelian_group β γ) :=
finsupp.add_comm_monoid

instance free_abelian_group.add_comm_group : add_comm_group (free_abelian_group β γ) :=
finsupp.add_comm_group

theorem structural_theorem (f : free_abelian_group β γ) :
  ∃ S : finset (free_abelian_group β γ), (∀ g ∈ S, ∃ (x : β) (y : γ) (n : ℤ) (H : n ≠ 0), g = finsupp.single (x, y) n) ∧ S.sum id = f :=
begin
  rcases f with ⟨f, ⟨hf⟩⟩,
  cases hf with S hs,
  existsi S.image (λ z, finsupp.single z.val $ f z.val : {a : β × γ | f a ≠ 0} → free_abelian_group β γ),
  split,
  { intros g hg,
    rw finset.mem_image at hg,
    rcases hg with ⟨z, hzs, hg⟩,
    cases z with z hz,
    cases z with x y,
    exact ⟨x, y, f (x, y), hz, by simp [hg]⟩ },
  { rw finset.sum_image,
    { apply finsupp.ext,
      intro z,
      by_cases hz : f z = 0,
      { simp,
        rw ← finset.sum_subset (finset.empty_subset S),
        { simpa using hz.symm },
        { intros x hx hnx,
          rw id,
          rw finsupp.single_apply,
          have h2 : ¬x.val = z := λ hxz, x.property (by rwa hxz),
          rw if_neg h2 } },
      { simp,
        have h1 : finset.singleton (⟨z, hz⟩ : {a : β × γ | f a ≠ 0}) ⊆ S := λ x hx, hs x,
        rw ← finset.sum_subset h1,
        { rw finset.sum_singleton,
          rw id,
          rw finsupp.single_apply,
          rw if_pos rfl,
          refl  },
        { intros x hx hnxz,
          rw finset.mem_singleton at hnxz,
          rw id,
          rw finsupp.single_apply,
          have h2 : ¬x.val = z := λ hxz, hnxz (subtype.eq hxz),
          rw if_neg h2 } } },
    { intros x hx y hy hxy,
      by_contradiction hnxy,
      have hxyx : @@coe_fn (free_abelian_group.has_coe_to_fun β γ) (finsupp.single x.val (f x.val)) x.val
        = @@coe_fn (free_abelian_group.has_coe_to_fun β γ) (finsupp.single y.val (f y.val)) x.val := by rw hxy,
      rw finsupp.single_apply at hxyx,
      rw finsupp.single_apply at hxyx,
      rw if_pos rfl at hxyx,
      have h1 : ¬y.val = x.val := λ hyx, hnxy (subtype.eq hyx.symm),
      rw if_neg h1 at hxyx,
      exact x.property hxyx } }
end

variables α {β γ}
include α

namespace relators

def pair_add : β → γ → γ → ℤ → free_abelian_group β γ :=
λ x y₁ y₂ n, finsupp.single (x, y₁) n + finsupp.single (x, y₂) n - finsupp.single (x, y₁ + y₂) n

def add_pair : β → β → γ → ℤ → free_abelian_group β γ :=
λ x₁ x₂ y n, finsupp.single (x₁, y) n + finsupp.single (x₂, y) n - finsupp.single (x₁ + x₂, y) n

def smul_trans : α → β → γ → ℤ → free_abelian_group β γ :=
λ r x y n, finsupp.single (r • x, y) n - finsupp.single (x, r • y) n

variables α β γ

def smul_aux : α → β × γ → ℤ → free_abelian_group β γ :=
λ r f y, finsupp.single (r • f.fst, f.snd) y

variables {α β γ}

theorem pair_add.neg (x : β) (y₁ y₂ : γ) (n : ℤ) :
  -pair_add α x y₁ y₂ n = pair_add α x y₁ y₂ (-n) :=
begin
  unfold pair_add,
  rw finsupp.single_neg,
  rw finsupp.single_neg,
  rw finsupp.single_neg,
  simp,
  repeat { rw add_comm, rw add_assoc }
end

theorem pair_add.smul (r : α) (x : β) (y₁ y₂ : γ) (n : ℤ) :
  finsupp.sum (pair_add α x y₁ y₂ n) (smul_aux α β γ r) = relators.pair_add α (r • x) y₁ y₂ n :=
begin
  unfold pair_add,
  rw finsupp.sum_sub_index,
  rw finsupp.sum_add_index,
  repeat { rw finsupp.sum_single_index },
  repeat { intros, simp [smul_aux] },
  repeat { refl }
end

theorem add_pair.neg (x₁ x₂ : β) (y : γ) (n : ℤ) :
  -add_pair α x₁ x₂ y n = add_pair α x₁ x₂ y (-n) :=
begin
  unfold add_pair,
  rw finsupp.single_neg,
  rw finsupp.single_neg,
  rw finsupp.single_neg,
  simp,
  repeat { rw add_comm, rw add_assoc }
end

theorem add_pair.smul (r : α) (x₁ x₂ : β) (y : γ) (n : ℤ) :
  finsupp.sum (add_pair α x₁ x₂ y n) (smul_aux α β γ r) = relators.add_pair α (r • x₁) (r • x₂) y n :=
begin
  unfold add_pair,
  rw finsupp.sum_sub_index,
  rw finsupp.sum_add_index,
  repeat { rw finsupp.sum_single_index },
  repeat { intros, simp [smul_aux, smul_add] },
  repeat { refl }
end

theorem smul_trans.neg (r : α) (x : β) (y : γ) (n : ℤ) :
  -smul_trans α r x y n = smul_trans α r x y (-n) :=
begin
  unfold smul_trans,
  rw finsupp.single_neg,
  rw finsupp.single_neg,
  simp
end

theorem smul_trans.smul (r r' : α) (x : β) (y : γ) (n : ℤ) :
  finsupp.sum (smul_trans α r' x y n) (smul_aux α β γ r) = relators.smul_trans α r' (r • x) y n :=
begin
  unfold smul_trans,
  rw finsupp.sum_sub_index,
  repeat { rw finsupp.sum_single_index },
  repeat { intros, simp [smul_aux, smul_add, smul_smul, mul_comm] },
  repeat { refl },
end

end relators

variables (α β γ)

def relators : set (free_abelian_group β γ) :=
{f | (∃ x y₁ y₂ n, f = relators.pair_add α x y₁ y₂ n) ∨
  (∃ x₁ x₂ y n, f = relators.add_pair α x₁ x₂ y n) ∨
  (∃ r x y n, f = relators.smul_trans α r x y n)}

theorem relators.zero_mem : (0 : free_abelian_group β γ ) ∈ relators α β γ :=
or.inl ⟨0, 0, 0, 0, by simpa [relators.pair_add, finsupp.single_zero]⟩

theorem relators.neg_mem : ∀ f, f ∈ relators α β γ → -f ∈ relators α β γ :=
begin
  intros f hf,
  rcases hf with hf | hf | hf;
  rcases hf with ⟨a, b, c, d, hf⟩,
  { from or.inl ⟨a, b, c, -d, by rw [hf, relators.pair_add.neg]⟩ },
  { from or.inr (or.inl ⟨a, b, c, -d, by rw [hf, relators.add_pair.neg]⟩) },
  { from or.inr (or.inr ⟨a, b, c, -d, by rw [hf, relators.smul_trans.neg]⟩) }
end

def closure : set (free_abelian_group β γ) :=
{f | ∃ (L : list (free_abelian_group β γ)),
  (∀ x ∈ L, x ∈ relators α β γ) ∧ L.sum = f}

def r : free_abelian_group β γ → free_abelian_group β γ → Prop :=
λ f g, f - g ∈ closure α β γ

local infix ≈ := r α β γ

theorem refl (f : free_abelian_group β γ) : f ≈ f :=
⟨[], by simp⟩

theorem symm (f g : free_abelian_group β γ) : f ≈ g → g ≈ f :=
λ ⟨L, hL, hLfg⟩, ⟨L.map (λ x, -x),
  λ x hx, let ⟨y, hyL, hyx⟩ := list.exists_of_mem_map hx in
    by rw ← hyx; exact relators.neg_mem α β γ y (hL y hyL),
  by simp [list.map_neg, hLfg]⟩

theorem trans (f g h : free_abelian_group β γ) : f ≈ g → g ≈ h → f ≈ h :=
λ ⟨L₁, hL₁, hLfg₁⟩ ⟨L₂, hL₂, hLfg₂⟩,
⟨L₁ ++ L₂,
 λ x hx, by rw [list.mem_append] at hx; from or.cases_on hx (hL₁ x) (hL₂ x),
 by simp [hLfg₁, hLfg₂]⟩

instance : setoid (free_abelian_group β γ) :=
⟨r α β γ, refl α β γ, symm α β γ, trans α β γ⟩

end tensor_product

def tensor_product {α} (β γ) [comm_ring α] [module α β] [module α γ] : Type (max v w) :=
quotient (tensor_product.setoid α β γ)

local infix ` ⊗ `:100 := tensor_product

namespace tensor_product

variables (α : Type u) [comm_ring α]
variables (β : Type v) (γ : Type w) (α₁ : Type u₁) (β₁ : Type v₁) (γ₁ : Type w₁)
variables [module α β] [module α γ] [module α α₁] [module α β₁] [module α γ₁]

include α

def add : β ⊗ γ → β ⊗ γ → β ⊗ γ :=
quotient.lift₂ (λ f g, ⟦f + g⟧ : free_abelian_group β γ → free_abelian_group β γ → β ⊗ γ) $
λ f₁ f₂ g₁ g₂ ⟨L₁, hL₁, hLfg₁⟩ ⟨L₂, hL₂, hLfg₂⟩, quotient.sound
⟨L₁ ++ L₂,
 λ x hx, by rw [list.mem_append] at hx; from or.cases_on hx (hL₁ x) (hL₂ x),
 by rw [list.sum_append, hLfg₁, hLfg₂]; simp⟩

protected theorem add_assoc (f g h : β ⊗ γ) : add α β γ (add α β γ f g) h = add α β γ f (add α β γ g h) :=
quotient.induction_on₃ f g h $ λ m n k, quotient.sound $ by simp

def zero : β ⊗ γ := ⟦0⟧

protected theorem zero_add (f : β ⊗ γ) : add α β γ (zero α β γ) f = f :=
quotient.induction_on f $ λ m, quotient.sound $ by simp

protected theorem add_zero (f : β ⊗ γ) : add α β γ f (zero α β γ) = f :=
quotient.induction_on f $ λ m, quotient.sound $ by simp

def neg : β ⊗ γ → β ⊗ γ :=
quotient.lift (λ f, ⟦-f⟧ : free_abelian_group β γ → β ⊗ γ) $
λ f g ⟨L, hL, hLfg⟩, quotient.sound ⟨L.map (λ x, -x),
  λ x hx, let ⟨y, hyL, hyx⟩ := list.exists_of_mem_map hx in
    by rw ← hyx; exact relators.neg_mem α β γ y (hL y hyL),
  by simp [list.map_neg, hLfg]⟩

protected theorem add_left_neg (f : β ⊗ γ) : add α β γ (neg α β γ f) f = zero α β γ :=
quotient.induction_on f $ λ m, quotient.sound $ by simp

protected theorem add_comm (f g : β ⊗ γ) : add α β γ f g = add α β γ g f :=
quotient.induction_on₂ f g $ λ m n, quotient.sound $ by simp

instance : add_comm_group (β ⊗ γ) :=
{ add          := add α β γ,
  add_assoc    := tensor_product.add_assoc α β γ,
  zero         := zero α β γ,
  zero_add     := tensor_product.zero_add α β γ,
  add_zero     := tensor_product.add_zero α β γ,
  neg          := neg α β γ,
  add_left_neg := tensor_product.add_left_neg α β γ,
  add_comm     := tensor_product.add_comm α β γ }

theorem mem_closure_of_finset {f : free_abelian_group β γ} :
  (∃ (S : finset (free_abelian_group β γ)) g,
     S.sum g = f ∧ ∀ x ∈ S, g x ∈ relators α β γ) →
  f ∈ closure α β γ :=
λ ⟨S, g, hSf, hSr⟩, begin
  cases S with ms hms,
  cases quot.exists_rep ms with L hL,
  existsi L.map g,
  split,
  { intros x hxL,
    rcases list.exists_of_mem_map hxL with ⟨y, hyL, hyx⟩,
    have hyms : y ∈ ms,
    { unfold has_mem.mem,
      unfold multiset.mem,
      rw ← hL,
      rw quot.lift_on,
      rwa @quot.lift_beta _ (list.perm.setoid (free_abelian_group β γ)).r,
      exact multiset.mem._proof_1 y },
    rw ← hyx,
    exact hSr y hyms },
  { change multiset.sum (multiset.map g ms) = f at hSf,
    rw ← hL at hSf,
    rw ← multiset.coe_sum,
    exact hSf }
end

private lemma zero_eq_zero : (0 : free_abelian_group β γ) = (0 : β × γ →₀ ℤ) := rfl

private lemma sum_zero_index (f : β × γ → ℤ → free_abelian_group β γ) :
  @finsupp.sum (β × γ) ℤ (free_abelian_group β γ) int.has_zero _ (0 : free_abelian_group β γ) f = 0 :=
begin
  rw zero_eq_zero,
  simp [finsupp.sum],
  refl
end

private lemma sum_zero_index' [add_comm_group α₁] (f : β × γ → ℤ → α₁) :
  @finsupp.sum (β × γ) ℤ α₁ int.has_zero _ (0 : free_abelian_group β γ) f = 0 :=
begin
  rw zero_eq_zero,
  simp [finsupp.sum]
end

def smul : α → β ⊗ γ → β ⊗ γ :=
λ r, quotient.lift (λ f, ⟦f.sum (relators.smul_aux α β γ r)⟧ : free_abelian_group β γ → β ⊗ γ) $
λ f g ⟨L, hL, hLfg⟩, quotient.sound
begin
  clear _fun_match,
  induction L generalizing f g,
  { existsi [],
    have : f = g,
      by simpa [add_neg_eq_zero] using hLfg.symm,
    simp [this] },
  { specialize L_ih (λ z hzt, hL z (or.inr hzt)) L_tl.sum (0:free_abelian_group β γ),
    specialize L_ih ⟨L_tl,
      λ z hzt, hL z (or.inr hzt),
      eq.symm (sub_zero _)⟩,
    specialize L_ih (eq.symm $ sub_zero _),
    rcases L_ih with ⟨L', hL', hLfg'⟩,
    rw [sum_zero_index] at hLfg',
    simp at hLfg',
    rcases hL L_hd (or.inl rfl) with h | h | h,
    { rcases h with ⟨x, y₁, y₂, n, h⟩,
      existsi list.cons (relators.pair_add α (r • x) y₁ y₂ n) L',
      split,
      { exact λ z hz, or.cases_on (list.eq_or_mem_of_mem_cons hz)
          (λ hzh, or.inl ⟨r • x, y₁, y₂, n, hzh⟩)
          (λ hzt, hL' z hzt) },
      { rw ← finsupp.sum_sub_index,
        rw ← hLfg,
        rw list.sum_cons,
        rw list.sum_cons,
        rw finsupp.sum_add_index,
        rw ← hLfg',
        rw h,
        rw relators.pair_add.smul,
        all_goals { intros, simp [relators.smul_aux], try {refl} } } },
    { rcases h with ⟨x₁, x₂, y, n, h⟩,
      existsi list.cons (relators.add_pair α (r • x₁) (r • x₂) y n) L',
      split,
      { exact λ z hz, or.cases_on (list.eq_or_mem_of_mem_cons hz)
          (λ hzh, or.inr $ or.inl ⟨r • x₁, r • x₂, y, n, hzh⟩)
          (λ hzt, hL' z hzt) },
      { rw ← finsupp.sum_sub_index,
        rw ← hLfg,
        rw list.sum_cons,
        rw list.sum_cons,
        rw finsupp.sum_add_index,
        rw ← hLfg',
        rw h,
        rw relators.add_pair.smul,
        all_goals { intros, simp [relators.smul_aux], try {refl} } } },
    { rcases h with ⟨r', x, y, n, h⟩,
      existsi list.cons (relators.smul_trans α r' (r • x) y n) L',
      split,
      { exact λ z hz, or.cases_on (list.eq_or_mem_of_mem_cons hz)
          (λ hzh, or.inr $ or.inr ⟨r', r • x, y, n, hzh⟩)
          (λ hzt, hL' z hzt) },
      { rw ← finsupp.sum_sub_index,
        rw ← hLfg,
        rw list.sum_cons,
        rw list.sum_cons,
        rw finsupp.sum_add_index,
        rw ← hLfg',
        rw h,
        rw relators.smul_trans.smul,
        all_goals { intros, simp [relators.smul_aux], try {refl} } } } }
end

protected theorem smul_add (r : α) (f g : β ⊗ γ) : smul α β γ r (add α β γ f g) = add α β γ (smul α β γ r f) (smul α β γ r g) :=
quotient.induction_on₂ f g $ λ m n, quotient.sound $ by rw [finsupp.sum_add_index]; all_goals { intros, simp [relators.smul_aux], try {refl} }

protected theorem add_smul (r₁ r₂ : α) (f : β ⊗ γ) : smul α β γ (r₁ + r₂) f = add α β γ (smul α β γ r₁ f) (smul α β γ r₂ f) :=
quotient.induction_on f $ λ m, quotient.sound $
begin
  unfold relators.smul_aux,
  simp [add_smul],
  rcases structural_theorem β γ m with ⟨S, hS, hSm⟩,
  rw ← hSm,
  apply symm,
  apply mem_closure_of_finset,
  existsi S,
  revert m hS hSm,
  apply finset.induction_on S,
  { intros m hS hSm,
    existsi id,
    split,
    { simp,
      rw sum_zero_index,
      rw sum_zero_index,
      rw sum_zero_index,
      simp },
    { intros x hx,
      exfalso,
      exact hx } },
  { intros g T hgT ih m hS hSm,
    rcases hS g (finset.mem_insert_self g T) with ⟨x, y, n, H, h⟩,
    rcases ih (T.sum id) (λ g' hg', hS g' $
      finset.mem_insert_of_mem hg') rfl with ⟨φ', hst', hss'⟩,
    existsi (λ f, if f = g then finsupp.single (r₁ • x, y) n +
      finsupp.single (r₂ • x, y) n -
      finsupp.single (r₁ • x + r₂ • x, y) n else φ' f),
    split,
    { rw finset.sum_insert,
      rw finset.sum_insert,
      rw finsupp.sum_add_index,
      rw finsupp.sum_add_index,
      rw finsupp.sum_add_index,
      rw if_pos rfl,
      rw h,
      rw id.def,
      rw finsupp.sum_single_index,
      rw finsupp.sum_single_index,
      rw finsupp.sum_single_index,
      have h1 : finset.sum T
        (λ (f : free_abelian_group β γ),
           ite (f = finsupp.single (x, y) n)
             (finsupp.single (r₁ • x, y) n + finsupp.single (r₂ • x, y) n -
                finsupp.single (r₁ • x + r₂ • x, y) n)
             (φ' f)) = finset.sum T φ',
      { apply finset.sum_congr,
        { refl },
        { intros g' hg',
          have h1 : g' ≠ g,
          { intro hgg',
            rw hgg' at hg',
            exact hgT hg' },
          rw h at h1,
          rw if_neg h1 } },
      rw h1,
      rw hst',
      unfold prod.fst,
      unfold prod.snd,
      simp,
      all_goals { intros,
        try {rw finsupp.single_zero},
        try {rw finsupp.single_zero},
        try {rw finsupp.single_add},
        try {refl},
        try {refl},
        try {exact hgT} } },
    { intros f' hf',
      rw finset.mem_insert at hf',
      cases hf',
      { dsimp,
        rw if_pos hf',
        from or.inr (or.inl ⟨r₁ • x, r₂ • x, y, n, rfl⟩) },
      { have h1 : f' ≠ g,
        { intro hfg',
          rw hfg' at hf',
          exact hgT hf' },
        dsimp,
        rw if_neg h1,
        from hss' f' hf' } } }
end

protected theorem mul_smul (r₁ r₂ : α) (f : β ⊗ γ) : smul α β γ (r₁ * r₂) f = smul α β γ r₁ (smul α β γ r₂ f) :=
quotient.induction_on f $ λ m, quotient.sound $
begin
  unfold relators.smul_aux,
  simp [mul_smul],
  rcases structural_theorem β γ m with ⟨S, hS, hSm⟩,
  rw ← hSm,
  apply symm,
  apply mem_closure_of_finset,
  existsi S,
  existsi (λ f, 0 : free_abelian_group β γ → free_abelian_group β γ),
  revert m hS hSm,
  apply finset.induction_on S,
  { intros m hS hSm,
    split,
    { simp,
      rw sum_zero_index,
      rw sum_zero_index,
      rw sum_zero_index,
      simp },
    { intros x hx,
      exfalso,
      exact hx } },
  { intros g T hgT ih m hS hSm,
    rcases hS g (finset.mem_insert_self g T) with ⟨x, y, n, H, h⟩,
    rcases ih (T.sum id) (λ g' hg', hS g' $
      finset.mem_insert_of_mem hg') rfl with ⟨hst', hss'⟩,
    split,
    { rw finset.sum_insert,
      rw finset.sum_insert,
      rw finset.sum_const_zero,
      rw finset.sum_const_zero at hst',
      rw finsupp.sum_add_index,
      rw finsupp.sum_add_index,
      rw finsupp.sum_add_index,
      rw h,
      rw id.def,
      rw finsupp.sum_single_index,
      rw finsupp.sum_single_index,
      rw finsupp.sum_single_index,
      unfold prod.fst,
      unfold prod.snd,
      rw add_comm_group.zero_add,
      rw hst',
      simp,
      all_goals { intros,
        try {rw finsupp.single_zero},
        try {rw finsupp.single_zero},
        try {rw finsupp.single_add},
        try {refl},
        try {refl},
        try {exact hgT} } },
    { intros f' hf',
      dsimp,
      exact relators.zero_mem α β γ } }
end

protected theorem one_smul (f : β ⊗ γ) : smul α β γ 1 f = f :=
quotient.induction_on f $ λ m, quotient.sound $ by simp [relators.smul_aux]

instance : module α (β ⊗ γ) :=
{ smul     := smul α β γ,
  smul_add := tensor_product.smul_add α β γ,
  add_smul := tensor_product.add_smul α β γ,
  mul_smul := tensor_product.mul_smul α β γ,
  one_smul := tensor_product.one_smul α β γ }

@[simp] lemma add_quot (f g : free_abelian_group β γ) : @has_add.add (β ⊗ γ) _ (⟦f⟧ : β ⊗ γ) ⟦g⟧ = ⟦f + g⟧ := rfl
@[simp] lemma neg_quot (f : free_abelian_group β γ) : @has_neg.neg (β ⊗ γ) _ (⟦f⟧ : β ⊗ γ) = ⟦-f⟧ := rfl

variables {α β γ}

def tprod : β → γ → β ⊗ γ :=
λ x y, ⟦finsupp.single (x, y) 1⟧

infix ` ⊗ₛ `:100 := tprod

variables {r r₁ r₂ : α} {x x₁ x₂ : β} {y y₁ y₂ : γ}

theorem tprod_unfold : x ⊗ₛ y = tprod x y := rfl

theorem tprod.is_bilinear_map : is_bilinear_map (@tprod α _ β γ _ _) :=
{ add_pair   := λ x y z, quotient.sound $ setoid.symm $
    ⟨[(finsupp.single (x, z) 1 +
         finsupp.single (y, z) 1 -
         finsupp.single (x + y, z) 1 : free_abelian_group β γ)],
     λ u hu, or.inr $ or.inl ⟨x, y, z, 1, list.eq_of_mem_singleton hu⟩,
     list.sum_singleton⟩,
  pair_add   := λ x y z, quotient.sound $ setoid.symm $
    ⟨[(finsupp.single (x, y) 1 +
         finsupp.single (x, z) 1 -
         finsupp.single (x, y + z) 1 : free_abelian_group β γ)],
     λ u hu, or.inl ⟨x, y, z, 1, list.eq_of_mem_singleton hu⟩,
     list.sum_singleton⟩,
  smul_pair  := λ r x y, quotient.sound $ setoid.symm $
    begin
      simp [relators.smul_aux],
      rw finsupp.sum_single_index,
      exact finsupp.single_zero
    end,
  pair_smul := λ r x y, quotient.sound $ setoid.symm $
    begin
      simp [relators.smul_aux],
      rw finsupp.sum_single_index,
      unfold prod.fst,
      unfold prod.snd,
      existsi ([(finsupp.single (r • x, y) 1 -
        finsupp.single (x, r • y) 1 : free_abelian_group β γ)]),
      split,
      { intros z hz,
        rw list.mem_singleton at hz,
        rw hz,
        from or.inr (or.inr ⟨r, x, y, 1, by simp [relators.smul_trans]⟩) },
      simp [list.sum_singleton],
      { rw finsupp.single_zero,
        refl }
    end }

@[simp] lemma add_tprod : (x₁ + x₂) ⊗ₛ y = x₁ ⊗ₛ y + x₂ ⊗ₛ y :=
tprod.is_bilinear_map.add_pair x₁ x₂ y

@[simp] lemma tprod_add : x ⊗ₛ (y₁ + y₂) = x ⊗ₛ y₁ + x ⊗ₛ y₂ :=
tprod.is_bilinear_map.pair_add x y₁ y₂

@[simp] lemma smul_tprod : (r • x) ⊗ₛ y = r • x ⊗ₛ y :=
tprod.is_bilinear_map.smul_pair r x y

@[simp] lemma tprod_smul : x ⊗ₛ (r • y) = r • x ⊗ₛ y :=
tprod.is_bilinear_map.pair_smul r x y

@[simp] lemma zero_tprod : (0:β) ⊗ₛ y = 0 :=
tprod.is_bilinear_map.zero_pair y

@[simp] lemma tprod_zero {x : β} : x ⊗ₛ (0:γ) = 0 :=
tprod.is_bilinear_map.pair_zero x

namespace universal_property

variables {β γ α₁}
variables {f : β → γ → α₁} (hf : is_bilinear_map f)
include β γ α₁ hf

def factor_aux : free_abelian_group β γ → α₁ :=
λ g : free_abelian_group β γ, (g.sum (λ z n, gsmul (f z.fst z.snd) n))

theorem factor_equiv : ∀ g₁ g₂ : free_abelian_group β γ, g₁ ≈ g₂ → factor_aux hf g₁ = factor_aux hf g₂ :=
λ g₁ g₂ ⟨L, hL, hgL⟩,
begin
  clear _fun_match _x,
  induction L generalizing hgL hL g₂ g₁,
  { simp at hgL,
    replace hgL := hgL.symm,
    rw add_neg_eq_zero at hgL,
    rw hgL },
  { specialize L_ih L_tl.sum 0,
    specialize L_ih (λ x hx, hL x (list.mem_cons_of_mem L_hd hx)),
    specialize L_ih (sub_zero _).symm,
    rw ← sub_eq_zero,
    unfold factor_aux at L_ih ⊢,
    rw ← finsupp.sum_sub_index,
    rw ← hgL,
    rw list.sum_cons,
    rw finsupp.sum_add_index,
    rw L_ih,
    rw sum_zero_index',
    specialize hL L_hd,
    specialize hL (or.inl rfl),
    rcases hL with h | h | h,
    { rcases h with ⟨x, y₁, y₂, n, h⟩,
      rw h,
      unfold relators.pair_add,
      rw finsupp.sum_sub_index,
      rw finsupp.sum_add_index,
      rw finsupp.sum_single_index,
      rw finsupp.sum_single_index,
      rw finsupp.sum_single_index,
      rw ← add_gsmul,
      rw ← sub_gsmul,
      rw hf.pair_add,
      simp,
      { rw gsmul_zero },
      { rw gsmul_zero },
      { rw gsmul_zero },
      { intros, rw gsmul_zero },
      { intros, rw gsmul_add },
      { intros, rw gsmul_sub } },
    { rcases h with ⟨x₁, x₂, y, n, h⟩,
      rw h,
      unfold relators.add_pair,
      rw finsupp.sum_sub_index,
      rw finsupp.sum_add_index,
      rw finsupp.sum_single_index,
      rw finsupp.sum_single_index,
      rw finsupp.sum_single_index,
      rw ← add_gsmul,
      rw ← sub_gsmul,
      rw hf.add_pair,
      simp,
      { rw gsmul_zero },
      { rw gsmul_zero },
      { rw gsmul_zero },
      { intros, rw gsmul_zero },
      { intros, rw gsmul_add },
      { intros, rw gsmul_sub } },
    { rcases h with ⟨r, x, y, n, h⟩,
      rw h,
      unfold relators.smul_trans,
      rw finsupp.sum_sub_index,
      rw finsupp.sum_single_index,
      rw finsupp.sum_single_index,
      rw ← sub_gsmul,
      rw hf.smul_pair,
      rw hf.pair_smul,
      simp,
      { rw gsmul_zero },
      { rw gsmul_zero },
      { intros, rw gsmul_sub } },
    { intros, rw gsmul_zero },
    { intros, rw gsmul_add },
    { intros, rw gsmul_sub } }
end

def factor : β ⊗ γ → α₁ :=
quotient.lift (factor_aux hf) (factor_equiv hf)

theorem factor_add : ∀ g₁ g₂ : β ⊗ γ, factor hf (g₁ + g₂) = factor hf g₁ + factor hf g₂ :=
λ x y, quotient.induction_on₂ x y
begin
  intros m n,
  simp [universal_property.factor],
  simp [universal_property.factor_aux],
  rw finsupp.sum_add_index,
  { intros, rw gsmul_zero },
  { intros, rw gsmul_add }
end

theorem factor_smul : ∀ (r : α) (g : β ⊗ γ), factor hf (r • g) = r • factor hf g :=
λ r x, quotient.induction_on x
begin
  intros m,
  simp [has_scalar.smul, smul, relators.smul_aux],
  rcases structural_theorem β γ m with ⟨S, hS, hSm⟩,
  rw ← hSm,
  revert m hS hSm,
  apply finset.induction_on S,
  { intros m hS hSm,
    unfold universal_property.factor,
    unfold universal_property.factor_aux,
    simp [finsupp.sum_zero_index],
    rw sum_zero_index,
    rw sum_zero_index',
    simp },
  { intros n T hnT ih m hS hSm,
    unfold universal_property.factor,
    unfold universal_property.factor_aux,
    simp,
    specialize ih (finset.sum T id),
    specialize ih (λ g hg, hS g (finset.mem_insert_of_mem hg)),
    specialize ih rfl,
    unfold universal_property.factor at ih,
    unfold universal_property.factor_aux at ih,
    simp at ih,
    rw finset.sum_insert,
    rw finsupp.sum_add_index,
    rw finsupp.sum_add_index,
    rw finsupp.sum_add_index,
    rw ih,
    specialize hS n (finset.mem_insert_self n T),
    rcases hS with ⟨x', y', n', H', hn'⟩,
    rw hn',
    rw finsupp.sum_single_index,
    rw finsupp.sum_single_index,
    rw finsupp.sum_single_index,
    rw hf.smul_pair,
    rw gsmul_smul,
    rw smul_add,
    { rw gsmul_zero },
    { rw gsmul_zero },
    { rw finsupp.single_zero, refl },
    { intros, rw gsmul_zero },
    { intros, rw gsmul_add },
    { intros, rw gsmul_zero },
    { intros, rw gsmul_add },
    { intros, rw finsupp.single_zero, refl },
    { intros, rw finsupp.single_add },
    { exact hnT } }
end

theorem factor_linear : is_linear_map (factor hf) :=
{ add  := factor_add hf,
  smul := factor_smul hf }

theorem factor_commutes : ∀ x y, factor hf (x ⊗ₛ y) = f x y :=
begin
  intros,
  simp [function.comp, tprod, factor, factor_aux],
  simp [finsupp.sum_single_index]
end

theorem factor_unique (h : β ⊗ γ → α₁) (H : is_linear_map h)
  (hh : ∀ x y, h (x ⊗ₛ y) = f x y) :
  h = factor hf :=
begin
  apply funext,
  intro x,
  apply quotient.induction_on x,
  intro y,
  unfold universal_property.factor,
  unfold universal_property.factor_aux,
  simp,
  rcases structural_theorem β γ y with ⟨S, hS, hSy⟩,
  revert hSy hS y,
  apply finset.induction_on S,
  { intros y hS hSy,
    rw ← hSy,
    rw finset.sum_empty,
    rw sum_zero_index',
    exact H.zero },
  { intros n T hnT ih y hS hSy,
    rw ← hSy,
    rw finset.sum_insert,
    rw ← add_quot,
    rw H.add,
    rw finsupp.sum_add_index,
    rw id.def,
    specialize ih (T.sum id),
    specialize ih (λ z hz, hS z (finset.mem_insert_of_mem hz)),
    specialize ih rfl,
    rw ih,
    specialize hS n,
    specialize hS (finset.mem_insert_self n T),
    rcases hS with ⟨x', y', n', H', hn'⟩,
    rw hn',
    rw finsupp.sum_single_index,
    specialize hh x' y',
    simp [function.comp, tprod] at hh,
    clear H' hn',
    suffices : h ⟦finsupp.single (x', y') n'⟧ = gsmul (f x' y') n',
    { rw this },
    cases n',
    { induction n' with n' ih',
      { rw int.of_nat_zero,
        rw finsupp.single_zero,
        rw gsmul_zero,
        exact H.zero },
      { rw int.of_nat_succ,
        rw finsupp.single_add,
        rw ← add_quot,
        rw H.add,
        rw [ih', hh],
        rw gsmul_add,
        rw gsmul_one } },
    { induction n' with n' ih',
      { rw int.neg_succ_of_nat_eq,
        rw finsupp.single_neg,
        rw gsmul_neg,
        rw finsupp.single_add,
        simp,
        rw ← neg_quot,
        rw H.neg,
        rw hh },
      { rw int.neg_succ_of_nat_coe,
        rw int.neg_succ_of_nat_eq at ih',
        rw int.coe_nat_add,
        rw finsupp.single_neg at ih' ⊢,
        rw ← neg_quot at ih' ⊢,
        rw H.neg at ih' ⊢,
        rw nat.succ_eq_add_one,
        rw finsupp.single_add,
        rw ← add_quot,
        rw H.add,
        rw neg_add,
        rw int.coe_nat_add,
        rw int.coe_nat_eq 1,
        rw int.of_nat_one,
        rw ih',
        rw hh,
        simp [gsmul_add, gsmul_neg] } },
    { rw gsmul_zero },
    { intros, rw gsmul_zero },
    { intros, rw gsmul_add },
    { exact hnT } }
end

end universal_property

instance universal_property {f : β → γ → α₁} (hf : is_bilinear_map f) :
  type_singleton { h : β ⊗ γ → α₁ // ∃ (H : is_linear_map h), ∀ x y, h (x ⊗ₛ y) = f x y } :=
{ default := ⟨universal_property.factor hf,
    universal_property.factor_linear hf,
    universal_property.factor_commutes hf⟩,
  unique  := λ ⟨h, H, hh⟩, subtype.eq $
    universal_property.factor_unique hf h H hh }

variables {β γ α₁}
protected theorem ext {f g : β ⊗ γ → α₁} (hf : is_linear_map f) (hg : is_linear_map g)
  (h : ∀ x y, f (x ⊗ₛ y) = g (x ⊗ₛ y)) (z : β ⊗ γ) : f z = g z :=
have h1 : _ := universal_property.factor_unique
  (tprod.is_bilinear_map.comp hg)
  f hf h,
have h2 : _ := universal_property.factor_unique
  (tprod.is_bilinear_map.comp hg)
  g hg (λ x y, rfl),
congr_fun (h1.trans h2.symm) z

variables (β γ)

protected def id : β ⊗ α ≃ₘ β :=
let hba1 : β → α → β := λ x y, y • x in
have hba2 : is_bilinear_map hba1,
by refine {..}; intros; simp [hba1, smul_add, add_smul, smul_smul, mul_comm, mul_left_comm],
let hba3 : β ⊗ α → β := universal_property.factor hba2 in
have hba4 : _ := universal_property.factor_linear hba2,
have hba5 : _ := universal_property.factor_commutes hba2,
let hb1 : β → β ⊗ α := λ x, x ⊗ₛ 1 in
have hb2 : is_linear_map hb1, from
{ add  := λ x y, add_tprod,
  smul := λ r x, smul_tprod },
have hbb1 : ∀ (x : β) (y : α), hb1 (hba3 (x ⊗ₛ y)) = x ⊗ₛ y,
from λ x y, calc
        hb1 (hba3 (x ⊗ₛ y))
      = (y • x) ⊗ₛ 1 : congr_arg hb1 (hba5 _ _)
  ... = y • x ⊗ₛ 1 : smul_tprod
  ... = x ⊗ₛ (y • 1) : eq.symm $ tprod_smul
  ... = x ⊗ₛ y : by simp,
{ to_fun    := hba3,
  inv_fun   := hb1,
  left_inv  := tensor_product.ext (hb2.comp hba4) is_linear_map.id hbb1,
  right_inv := λ x, by simp *,
  linear    := hba4 }

protected def comm : β ⊗ γ ≃ₘ γ ⊗ β :=
let hbg1 : β → γ → γ ⊗ β := λ x y, y ⊗ₛ x in
have hbg2 : is_bilinear_map hbg1, from
{ add_pair  := λ x y z, tprod_add,
  pair_add  := λ x y z, add_tprod,
  smul_pair := λ r x y, tprod_smul,
  pair_smul := λ r x y, smul_tprod },
let hbg3 : β ⊗ γ → γ ⊗ β := universal_property.factor hbg2 in
have hbg4 : _ := universal_property.factor_linear hbg2,
have hbg5 : _ := universal_property.factor_commutes hbg2,
let hgb1 : γ → β → β ⊗ γ := λ y x , x ⊗ₛ y in
have hgb2 : is_bilinear_map hgb1, from
{ add_pair  := λ x y z, tprod_add,
  pair_add  := λ x y z, add_tprod,
  smul_pair := λ r x y, tprod_smul,
  pair_smul := λ r x y, smul_tprod },
let hgb3 : γ ⊗ β → β ⊗ γ := universal_property.factor hgb2 in
have hgb4 : _ := universal_property.factor_linear hgb2,
have hgb5 : _ := universal_property.factor_commutes hgb2,
have hbb1 : ∀ x y, (hgb3 ∘ hbg3) (x ⊗ₛ y) = x ⊗ₛ y,
from λ x y, by simp [function.comp, *],
have hbb2 : is_linear_map (hgb3 ∘ hbg3) := hgb4.comp hbg4,
have hbb3 : _ := tensor_product.ext hbb2 is_linear_map.id hbb1,
have hgg1 : ∀ y x, (hbg3 ∘ hgb3) (y ⊗ₛ x) = y ⊗ₛ x,
from λ x y, by simp [function.comp, *],
have hgg2 : is_linear_map (hbg3 ∘ hgb3) := hbg4.comp hgb4,
have hgg3 : _ := tensor_product.ext hgg2 is_linear_map.id hgg1,
{ to_fun    := hbg3,
  inv_fun   := hgb3,
  left_inv  := hbb3,
  right_inv := hgg3,
  linear    := hbg4 }

protected def prod_tensor : (β × γ) ⊗ α₁ ≃ₘ β ⊗ α₁ × γ ⊗ α₁ :=
let ha1 : β × γ → α₁ → β ⊗ α₁ × γ ⊗ α₁ :=
  λ z r, (z.fst ⊗ₛ r, z.snd ⊗ₛ r) in
have ha2 : is_bilinear_map ha1, from
{ add_pair  := λ x y z, prod.ext.2 ⟨add_tprod, add_tprod⟩,
  pair_add  := λ x y z, prod.ext.2 ⟨tprod_add, tprod_add⟩,
  smul_pair := λ r x y, prod.ext.2 ⟨smul_tprod, smul_tprod⟩ ,
  pair_smul := λ r x y, prod.ext.2 ⟨tprod_smul, tprod_smul⟩ },
let ha3 : (β × γ) ⊗ α₁ → β ⊗ α₁ × γ ⊗ α₁ :=
  universal_property.factor ha2 in
have ha4 : _ := universal_property.factor_linear ha2,
have ha5 : _ := universal_property.factor_commutes ha2,
let hb1 : β → α₁ → (β × γ) ⊗ α₁ :=
  λ x r, (x, 0) ⊗ₛ r in
have hb2 : is_bilinear_map hb1, from
{ add_pair  := λ x y z, calc
          (x + y, (0:γ)) ⊗ₛ z
        = (x + y, 0 + 0) ⊗ₛ z : congr_arg (λ r, (x + y, r) ⊗ₛ z) (zero_add 0).symm
    ... = ((x, 0) + (y, 0)) ⊗ₛ z : rfl
    ... = (x, 0) ⊗ₛ z + (y, 0) ⊗ₛ z : add_tprod,
  pair_add  := λ x y z, tprod_add,
  smul_pair := λ r x y, calc
          (r • x, (0:γ)) ⊗ₛ y
        = (r • (x, 0)) ⊗ₛ y : by simp only [prod.smul_prod, smul_zero]
    ... = r • (x, 0) ⊗ₛ y : smul_tprod,
  pair_smul := λ r x y, tprod_smul },
let hb3 : β ⊗ α₁ → (β × γ) ⊗ α₁ :=
  universal_property.factor hb2 in
have hb4 : _ := universal_property.factor_linear hb2,
have hb5 : _ := universal_property.factor_commutes hb2,
have hb6 : ∀ x, ha3 (hb3 x) = prod.inl x := tensor_product.ext (ha4.comp hb4) prod.is_linear_map_prod_inl $ λ x y, calc
          ha3 (hb3 (x ⊗ₛ y))
        = ha3 ((x, 0) ⊗ₛ y) : congr_arg ha3 (hb5 x y)
    ... = (x ⊗ₛ y, 0 ⊗ₛ y) : ha5 (x, 0) y
    ... = (x ⊗ₛ y, 0) : congr_arg (λ z, (x ⊗ₛ y, z)) zero_tprod,
let hc1 : γ → α₁ → (β × γ) ⊗ α₁ :=
  λ x r, (0, x) ⊗ₛ r in
have hc2 : is_bilinear_map hc1, from
{ add_pair   := λ x y z, calc
          ((0:β), x + y) ⊗ₛ z
        = (0 + 0, x + y) ⊗ₛ z : congr_arg (λ r, (r, x + y) ⊗ₛ z) (zero_add 0).symm
    ... = ((0, x) + (0, y)) ⊗ₛ z : rfl
    ... = (0, x) ⊗ₛ z + (0, y) ⊗ₛ z : add_tprod,
  pair_add   := λ x y z, tprod_add,
  smul_pair := λ r x y, calc
          ((0:β), r • x) ⊗ₛ y
        = (r • (0, x)) ⊗ₛ y : by simp only [prod.smul_prod, smul_zero]
    ... = r • (0, x) ⊗ₛ y : smul_tprod,
  pair_smul := λ r x y, tprod_smul },
let hc3 : γ ⊗ α₁ → (β × γ) ⊗ α₁ :=
  universal_property.factor hc2 in
have hc4 : _ := universal_property.factor_linear hc2,
have hc5 : _ := universal_property.factor_commutes hc2,
have hc6 : ∀ y, ha3 (hc3 y) = prod.inr y := tensor_product.ext (ha4.comp hc4) prod.is_linear_map_prod_inr $ λ x y, calc
          ha3 (hc3 (x ⊗ₛ y))
        = ha3 ((0, x) ⊗ₛ y) : congr_arg ha3 (hc5 x y)
    ... = (0 ⊗ₛ y, x ⊗ₛ y) : ha5 (0, x) y
    ... = (0, x ⊗ₛ y) : congr_arg (λ z, (z, x ⊗ₛ y)) zero_tprod,
let hd1 : β ⊗ α₁ × γ ⊗ α₁ → (β × γ) ⊗ α₁ :=
  λ z, hb3 z.fst + hc3 z.snd in
have hd2 : is_linear_map hd1, from
{ add  := λ x y, calc
          hb3 (x + y).fst + hc3 (x + y).snd
        = hb3 (x.fst + y.fst) + hc3 (x.snd + y.snd) : rfl
    ... = (hb3 x.fst + hb3 y.fst) + hc3 (x.snd + y.snd) : congr_arg (λ z, z + hc3 (x.snd + y.snd)) (hb4.add x.fst y.fst)
    ... = (hb3 x.fst + hb3 y.fst) + (hc3 x.snd + hc3 y.snd) : congr_arg (λ z, (hb3 x.fst + hb3 y.fst) + z) (hc4.add x.snd y.snd)
    ... = hb3 x.fst + (hb3 y.fst + (hc3 x.snd + hc3 y.snd)) : add_assoc _ _ _
    ... = hb3 x.fst + ((hc3 x.snd + hc3 y.snd) + hb3 y.fst) : congr_arg _ (add_comm _ _)
    ... = hb3 x.fst + (hc3 x.snd + (hc3 y.snd + hb3 y.fst)) : congr_arg _ (add_assoc _ _ _)
    ... = hb3 x.fst + (hc3 x.snd + (hb3 y.fst + hc3 y.snd)) : by have := congr_arg (λ z, hb3 x.fst + (hc3 x.snd + z)) (add_comm (hc3 y.snd) (hb3 y.fst)); dsimp at this; exact this
    ... = (hb3 x.fst + hc3 x.snd) + (hb3 y.fst + hc3 y.snd) : eq.symm $ add_assoc _ _ _,
  smul := λ r x, calc
          hb3 (r • x.fst) + hc3 (r • x.snd)
        = hb3 (r • x.fst) + r • (hc3 x.snd) : congr_arg _ (hc4.smul r x.snd)
    ... = r • (hb3 x.fst) + r • (hc3 x.snd) : congr_arg (λ z, z + r • (hc3 x.snd)) (hb4.smul r x.fst)
    ... = r • (hb3 x.fst + hc3 x.snd) : eq.symm $ @smul_add _ _ _ _ r (hb3 x.fst) (hc3 x.snd)
    ... = r • hd1 x : rfl },
have h1 : is_linear_map (hd1 ∘ ha3), from hd2.comp ha4,
have h2 : _ := tensor_product.ext h1 is_linear_map.id (λ x y, by simp [function.comp, *, add_tprod.symm]),
have h3 : ∀ z, (ha3 ∘ hd1) z = id z, from λ z, calc
        ha3 (hd1 z)
      = ha3 (hb3 z.fst + hc3 z.snd) : rfl
  ... = ha3 (hb3 z.fst) + ha3 (hc3 z.snd) : ha4.add _ _
  ... = prod.inl z.fst + prod.inr z.snd : by rw [hb6, hc6]
  ... = (z.fst + 0, 0 + z.snd) : rfl
  ... = z : by cases z; simp [prod.inl, prod.inr],
{ to_fun    := ha3,
  inv_fun   := hd1,
  left_inv  := h2,
  right_inv := h3,
  linear    := ha4 }

protected def assoc : (β ⊗ γ) ⊗ α₁ ≃ₘ β ⊗ (γ ⊗ α₁) :=
let ha1 (z : α₁) : β → γ → β ⊗ (γ ⊗ α₁) :=
  λ x y, x ⊗ₛ (y ⊗ₛ z) in
have ha2 : Π (z : α₁), is_bilinear_map (ha1 z), from λ z,
{ add_pair  := λ m n k, add_tprod,
  pair_add  := λ m n k, calc
          m ⊗ₛ ((n + k) ⊗ₛ z)
        = m ⊗ₛ (n ⊗ₛ z + k ⊗ₛ z) : congr_arg (λ b, m ⊗ₛ b) add_tprod
    ... = m ⊗ₛ (n ⊗ₛ z) + m ⊗ₛ (k ⊗ₛ z) : tprod_add,
  smul_pair := λ r m n, smul_tprod,
  pair_smul := λ r m n, calc
          m ⊗ₛ ((r • n) ⊗ₛ z)
        = m ⊗ₛ (r • n ⊗ₛ z) : congr_arg _ smul_tprod
    ... = r • m ⊗ₛ (n ⊗ₛ z) : tprod_smul },
let ha3 : β ⊗ γ → α₁ → β ⊗ (γ ⊗ α₁) :=
  λ xy z, universal_property.factor (ha2 z) xy in
have ha4 : _ := λ z, universal_property.factor_linear (ha2 z),
have ha5 : _ := λ z, universal_property.factor_commutes (ha2 z),
have ha6 : is_bilinear_map ha3, from
{ add_pair  := λ m n k, (ha4 k).add m n,
  pair_add  := λ m n k, (tensor_product.ext (ha4 $ n + k) ((ha4 n).map_add (ha4 k)) $ λ x y, calc
            ha3 (x ⊗ₛ y) (n + k)
          = x ⊗ₛ (y ⊗ₛ (n + k)) : ha5 (n + k) x y
      ... = x ⊗ₛ (y ⊗ₛ n + y ⊗ₛ k) : congr_arg ((⊗ₛ) x) tprod_add
      ... = x ⊗ₛ (y ⊗ₛ n) + x ⊗ₛ (y ⊗ₛ k) : tprod_add
      ... = x ⊗ₛ (y ⊗ₛ n) + ha3 (x ⊗ₛ y) k : congr_arg (λ b, x ⊗ₛ (y ⊗ₛ n) + b) (ha5 k _ _).symm
      ... = ha3 (x ⊗ₛ y) n + ha3 (x ⊗ₛ y) k : congr_arg (λ b, b + ha3 (x ⊗ₛ y) k) (ha5 n _ _).symm)
    m,
  smul_pair := λ r x y, (ha4 y).smul r x,
  pair_smul := λ r x y, (tensor_product.ext (ha4 $ r • y) (ha4 y).map_smul_right $ λ m n, calc
            ha3 (m ⊗ₛ n) (r • y)
          = m ⊗ₛ (n ⊗ₛ (r • y)) : ha5 (r • y) m n
      ... = m ⊗ₛ (r • n ⊗ₛ y) : congr_arg _ tprod_smul
      ... = r • m ⊗ₛ (n ⊗ₛ y) : tprod_smul
      ... = r • ha3 (m ⊗ₛ n) y : congr_arg _ (ha5 y m n).symm)
    x },
let ha7 : (β ⊗ γ) ⊗ α₁ → β ⊗ (γ ⊗ α₁) :=
  universal_property.factor ha6 in
have ha8 : _ := universal_property.factor_linear ha6,
have ha9 : _ := universal_property.factor_commutes ha6,
let hb1 (x : β) : γ → α₁ → (β ⊗ γ) ⊗ α₁ :=
  λ y z, (x ⊗ₛ y) ⊗ₛ z in
have hb2 : Π (x : β), is_bilinear_map (hb1 x), from λ x,
{ add_pair  := λ m n k, calc
          (x ⊗ₛ (m + n)) ⊗ₛ k
        = (x ⊗ₛ m + x ⊗ₛ n) ⊗ₛ k : congr_arg (λ z, z ⊗ₛ k) tprod_add
    ... = (x ⊗ₛ m) ⊗ₛ k + (x ⊗ₛ n) ⊗ₛ k : add_tprod,
  pair_add  := λ m n k, tprod_add,
  smul_pair := λ r m n, calc
          (x ⊗ₛ (r • m)) ⊗ₛ n
        = (r • x ⊗ₛ m) ⊗ₛ n : congr_arg (λ z, z ⊗ₛ n) tprod_smul
    ... = r • (x ⊗ₛ m) ⊗ₛ n : smul_tprod,
  pair_smul := λ r m n, tprod_smul },
let hb3 : β → γ ⊗ α₁ → (β ⊗ γ) ⊗ α₁ :=
  λ x, universal_property.factor (hb2 x) in
have hb4 : _ := λ x, universal_property.factor_linear (hb2 x),
have hb5 : _ := λ x, universal_property.factor_commutes (hb2 x),
have hb6 : is_bilinear_map hb3, from
{ add_pair  := λ m n k, (tensor_product.ext (hb4 $ m + n) ((hb4 m).map_add (hb4 n)) $ λ x y, calc
            hb3 (m + n) (x ⊗ₛ y)
          = ((m + n) ⊗ₛ x) ⊗ₛ y : (hb5 $ m + n) x y
      ... = (m ⊗ₛ x + n ⊗ₛ x) ⊗ₛ y : congr_arg (λ z, z ⊗ₛ y) add_tprod
      ... = (m ⊗ₛ x) ⊗ₛ y + (n ⊗ₛ x) ⊗ₛ y : add_tprod
      ... = (m ⊗ₛ x) ⊗ₛ y + hb3 n (x ⊗ₛ y) : congr_arg _ ((hb5 n) x y).symm
      ... = hb3 m (x ⊗ₛ y) + hb3 n (x ⊗ₛ y) : congr_arg (λ z, z + hb3 n (x ⊗ₛ y)) ((hb5 m) x y).symm)
    k,
  pair_add  := λ m n k, (hb4 m).add n k,
  smul_pair := λ r x y, (tensor_product.ext (hb4 $ r • x) (hb4 x).map_smul_right $ λ m n, calc
            hb3 (r • x) (m ⊗ₛ n)
          = ((r • x) ⊗ₛ m) ⊗ₛ n : (hb5 $ r • x) m n
      ... = (r • x ⊗ₛ m) ⊗ₛ n : congr_arg (λ z, z ⊗ₛ n) smul_tprod
      ... = r • (x ⊗ₛ m) ⊗ₛ n : smul_tprod
      ... = r • hb3 x (m ⊗ₛ n) : congr_arg _ ((hb5 $ x) m n).symm)
    y,
  pair_smul := λ r x y, (hb4 x).smul r y },
let hb7 : β ⊗ (γ ⊗ α₁) → (β ⊗ γ) ⊗ α₁ :=
  universal_property.factor hb6 in
have hb8 : _ := universal_property.factor_linear hb6,
have hb9 : _ := universal_property.factor_commutes hb6,
have hc1 : _ := λ z, tensor_product.ext (hb8.comp $ ha6.linear_pair z) (tprod.is_bilinear_map.linear_pair z) $ λ x y, calc
        hb7 (ha3 (x ⊗ₛ y) z)
      = hb7 (x ⊗ₛ (y ⊗ₛ z)) : congr_arg hb7 (ha5 z x y)
  ... = hb3 x (y ⊗ₛ z) : hb9 x (y ⊗ₛ z)
  ... = (x ⊗ₛ y) ⊗ₛ z : hb5 x y z,
have hc2 : _ := tensor_product.ext (hb8.comp ha8) is_linear_map.id $ λ xy z, calc
        hb7 (ha7 (xy ⊗ₛ z))
      = hb7 (ha3 xy z) : congr_arg hb7 (ha9 xy z)
  ... = xy ⊗ₛ z : hc1 z xy,
have hd1 : _ := λ x, tensor_product.ext (ha8.comp $ hb6.pair_linear x) (tprod.is_bilinear_map.pair_linear x) $ λ y z, calc
        ha7 (hb3 x (y ⊗ₛ z))
      = ha7 ((x ⊗ₛ y) ⊗ₛ z) : congr_arg ha7 (hb5 x y z)
  ... = ha3 (x ⊗ₛ y) z : ha9 (x ⊗ₛ y) z
  ... = x ⊗ₛ (y ⊗ₛ z) : ha5 z x y,
have hd2 : _ := tensor_product.ext (ha8.comp hb8) is_linear_map.id $ λ x yz, calc
        ha7 (hb7 (x ⊗ₛ yz))
      = ha7 (hb3 x yz) : congr_arg ha7 (hb9 x yz)
  ... = x ⊗ₛ yz : hd1 x yz,
{ to_fun    := ha7,
  inv_fun   := hb7,
  left_inv  := hc2,
  right_inv := hd2,
  linear    := ha8 }

variables {α β γ α₁ β₁ γ₁}
variables {f : β → γ} (hf : is_linear_map f)
variables {g : β₁ → γ₁} (hg : is_linear_map g)
include hf hg
def tprod_map : β ⊗ β₁ → γ ⊗ γ₁ :=
let h1 : β → β₁ → γ ⊗ γ₁ :=
  λ x y, f x ⊗ₛ g y in
have h2 : is_bilinear_map h1 :=
{ add_pair  := λ m n k, by simp [h1]; rw [hf.add, add_tprod],
  pair_add  := λ m n k, by simp [h1]; rw [hg.add, tprod_add],
  smul_pair := λ r m n, by simp [h1]; rw [hf.smul, smul_tprod],
  pair_smul := λ r m n, by simp [h1]; rw [hg.smul, tprod_smul] },
universal_property.factor h2

end tensor_product

class is_ring_hom {α : Type u} {β : Type v} [comm_ring α] [comm_ring β] (f : α → β) : Prop :=
(map_add : ∀ {x y}, f (x + y) = f x + f y)
(map_mul : ∀ {x y}, f (x * y) = f x * f y)
(map_one : f 1 = 1)

namespace is_ring_hom

variables {α : Type u} {β : Type v} [comm_ring α] [comm_ring β]
variables (f : α → β) [is_ring_hom f] {x y : α}

lemma map_zero : f 0 = 0 :=
calc f 0 = f (0 + 0) - f 0 : by rw [map_add f]; simp
     ... = 0 : by simp

lemma map_neg : f (-x) = -f x :=
calc f (-x) = f (-x + x) - f x : by rw [map_add f]; simp
        ... = -f x : by simp [map_zero f]

lemma map_sub : f (x - y) = f x - f y :=
by simp [map_add f, map_neg f]

end is_ring_hom

instance is_ring_hom.to_module {α : Type u} {β : Type v}
  [comm_ring α] [comm_ring β]
  (f : α → β) [is_ring_hom f] : module α β :=
{ smul     := λ r x, f r * x,
  smul_add := λ r x y, by simp [mul_add],
  add_smul := λ r₁ r₂ x, by simp [is_ring_hom.map_add f, add_mul],
  mul_smul := λ r₁ r₂ x, by simp [is_ring_hom.map_mul f, mul_assoc],
  one_smul := λ x, by simp [is_ring_hom.map_one f] }

section algebra_tensor

parameters {α : Type u} {β : Type v} {γ : Type w}
parameters [comm_ring α] [comm_ring β] [comm_ring γ]
parameters (f : α → β) [is_ring_hom f]
parameters (g : α → γ) [is_ring_hom g]
variables {r r₁ r₂ : α} {x x₁ x₂ : β} {y y₁ y₂ : γ}
include α f g

def module_f := is_ring_hom.to_module f
def module_g := is_ring_hom.to_module g
local attribute [instance] module_f module_g

def h1 : β → γ → β → γ → β ⊗ γ :=
λ x₁ y₁ x₂ y₂, (x₁ * x₂) ⊗ₛ (y₁ * y₂)

def δ := @tensor_product α β γ _ (is_ring_hom.to_module f) (is_ring_hom.to_module g)

instance η : module α δ := tensor_product.module α β γ

theorem h2 : Π (x : β) (y : γ), is_bilinear_map (h1 x y) :=
λ x y,
{ add_pair  := λ m n k, by simp [h1]; rw [mul_add, tensor_product.add_tprod],
  pair_add  := λ m n k, by simp [h1]; rw [mul_add, tensor_product.tprod_add],
  smul_pair := λ r m n, calc
          (x * (f r * m)) ⊗ₛ (y * n)
        = (f r * (x * m)) ⊗ₛ (y * n) : by rw [mul_left_comm]
    ... = r • (x * m) ⊗ₛ (y * n) : tensor_product.smul_tprod,
  pair_smul := λ r m n, calc
          (x * m) ⊗ₛ (y * (g r * n))
        = (x * m) ⊗ₛ (g r * (y * n)) : by rw [mul_left_comm]
    ... = r • (x * m) ⊗ₛ (y * n) : tensor_product.tprod_smul }

def h3 (z : β ⊗ γ) : β → γ → δ :=
λ x y, tensor_product.universal_property.factor (h2 x y) z

def h4 : Π x y, is_linear_map (λ z, h3 z x y) :=
λ x y, tensor_product.universal_property.factor_linear (h2 x y)

theorem h5 : ∀ x₁ y₁ x₂ y₂, h3 (x₂ ⊗ₛ y₂) x₁ y₁ = (x₁ * x₂) ⊗ₛ (y₁ * y₂) :=
λ x y, tensor_product.universal_property.factor_commutes (h2 x y)

theorem h6 : ∀ t, is_bilinear_map (h3 t) :=
λ t,
{ add_pair  := λ x y z, (tensor_product.ext (h4 (x + y) z)
      ((h4 x z).map_add (h4 y z)) $ λ m n, calc
              h3 (m ⊗ₛ n) (x + y) z
            = ((x + y) * m) ⊗ₛ (z * n) : h5 (x + y) z m n
        ... = (x * m) ⊗ₛ (z * n) + (y * m) ⊗ₛ (z * n) : by rw [add_mul, tensor_product.add_tprod]
        ... = (x * m) ⊗ₛ (z * n) + h3 (m ⊗ₛ n) y z : congr_arg _ (h5 y z m n).symm
        ... = h3 (m ⊗ₛ n) x z + h3 (m ⊗ₛ n) y z : congr_arg (λ b, b + h3 (m ⊗ₛ n) y z) (h5 x z m n).symm)
    t,
  pair_add  := λ x y z, (tensor_product.ext (h4 x (y + z))
      ((h4 x y).map_add (h4 x z)) $ λ m n, calc
              h3 (m ⊗ₛ n) x (y + z)
            = (x * m) ⊗ₛ ((y + z) * n) : h5 x (y + z) m n
        ... = (x * m) ⊗ₛ (y * n) + (x * m) ⊗ₛ (z * n) : by rw [add_mul, tensor_product.tprod_add]
        ... = (x * m) ⊗ₛ (y * n) + h3 (m ⊗ₛ n) x z : congr_arg _ (h5 x z m n).symm
        ... = h3 (m ⊗ₛ n) x y + h3 (m ⊗ₛ n) x z : congr_arg (λ b, b + h3 (m ⊗ₛ n) x z) (h5 x y m n).symm)
    t,
  smul_pair := λ r x y, (tensor_product.ext (h4 (r • x) y)
      (h4 x y).map_smul_right $ λ m n, calc
              h3 (m ⊗ₛ n) (f r * x) y
            = ((f r * x) * m) ⊗ₛ (y * n) : h5 (r • x) y m n
        ... = (f r * (x * m)) ⊗ₛ (y * n) : congr_arg (λ z, z ⊗ₛ (y * n)) (mul_assoc _ _ _)
        ... = r • (x * m) ⊗ₛ (y * n) : tensor_product.smul_tprod
        ... = r • h3 (m ⊗ₛ n) x y : congr_arg _ (h5 x y m n).symm)
    t,
  pair_smul := λ r x y, (tensor_product.ext (h4 x (r • y))
      (h4 x y).map_smul_right $ λ m n, calc
              h3 (m ⊗ₛ n) x (g r * y)
            = (x * m) ⊗ₛ ((g r * y) * n) : h5 x (r • y) m n
        ... = (x * m) ⊗ₛ (g r * (y * n)) : congr_arg _ (mul_assoc _ _ _)
        ... = r • (x * m) ⊗ₛ (y * n) : tensor_product.tprod_smul
        ... = r • h3 (m ⊗ₛ n) x y : congr_arg _ (h5 x y m n).symm)
    t }

def algebra_tensor.mul : β ⊗ γ → β ⊗ γ → β ⊗ γ :=
λ x, tensor_product.universal_property.factor (h6 x)

theorem h7 : ∀ x, is_linear_map (algebra_tensor.mul x) :=
λ x, tensor_product.universal_property.factor_linear (h6 x)

theorem h8 : ∀ x y z, algebra_tensor.mul x (y ⊗ₛ z) = h3 x y z :=
λ x, tensor_product.universal_property.factor_commutes (h6 x)

theorem h9 : is_bilinear_map algebra_tensor.mul :=
{ add_pair  := λ x y, tensor_product.ext (h7 $ x + y) ((h7 x).map_add (h7 y)) $
    λ m n, by rw [h8, h8, h8]; exact (h4 m n).add x y,
  pair_add  := λ x, (h7 x).add,
  smul_pair := λ r x, tensor_product.ext (h7 $ r • x) (h7 x).map_smul_right $
    λ m n, by rw [h8, h8]; exact (h4 m n).smul r x,
  pair_smul := λ r x, (h7 x).smul r }

theorem algebra_tensor.mul.comm : ∀ x y, algebra_tensor.mul x y = algebra_tensor.mul y x :=
λ x, tensor_product.ext
  (h9.pair_linear x)
  (h9.linear_pair x)
  (λ y z, (tensor_product.ext
    (h9.linear_pair $ y ⊗ₛ z)
    (h9.pair_linear $ y ⊗ₛ z)
    (λ m n, by rw [h8, h8, h5, h5]; simp [mul_comm]))
  x)

theorem algebra_tensor.mul.assoc : ∀ x y z, algebra_tensor.mul (algebra_tensor.mul x y) z = algebra_tensor.mul x (algebra_tensor.mul y z) :=
begin
  intros x y,
  apply tensor_product.ext,
  { exact h9.pair_linear (algebra_tensor.mul x y) },
  { exact (h9.pair_linear x).comp (h9.pair_linear y) },
  { intros m n,
    revert y,
    apply tensor_product.ext,
    { exact (h9.linear_pair (m ⊗ₛ n)).comp (h9.pair_linear x) },
    { exact (h9.pair_linear x).comp (h9.linear_pair (m ⊗ₛ n)) },
    { intros c d,
      revert x,
      apply tensor_product.ext,
      { exact (h9.linear_pair (m ⊗ₛ n)).comp (h9.linear_pair (c ⊗ₛ d)) },
      { exact h9.linear_pair (algebra_tensor.mul (c ⊗ₛ d) (m ⊗ₛ n)) },
      { intros p q,
        rw [h8, h8, h8, h5, h5, h5, h8, h5],
        simp only [mul_assoc] } } }
end

def algebra_tensor.hom : α → (β ⊗ γ) :=
λ x, f x ⊗ₛ 1

instance algebra_tensor.to_comm_ring : comm_ring (β ⊗ γ) :=
{ module.to_add_comm_group (β ⊗ γ) with
  mul           := algebra_tensor.mul,
  mul_assoc     := algebra_tensor.mul.assoc,
  one           := 1 ⊗ₛ 1,
  one_mul       := tensor_product.ext (h9.pair_linear $ 1 ⊗ₛ 1) is_linear_map.id $
    λ x y, by rw [h8, h5, mul_one, mul_one],
  mul_one       := tensor_product.ext (h9.linear_pair $ 1 ⊗ₛ 1) is_linear_map.id $
    λ x y, by simp only [(*)]; rw [h8, h5, one_mul, one_mul],
  left_distrib  := h9.pair_add,
  right_distrib := h9.add_pair,
  mul_comm      := algebra_tensor.mul.comm }

instance algebra_tensor.is_ring_hom : is_ring_hom algebra_tensor.hom :=
{ map_add := λ x y, by simp [algebra_tensor.hom, is_ring_hom.map_add f],
  map_mul := λ x y, calc
          algebra_tensor.hom (x * y)
        = f (x * y) ⊗ₛ 1 : rfl
    ... = (f x * f y) ⊗ₛ 1 : by rw is_ring_hom.map_mul f
    ... = (f y * f x) ⊗ₛ (1 * 1) : by simp [mul_comm]
    ... = h3 (f x ⊗ₛ 1) (f y) 1 : (h5 _ _ _ 1).symm
    ... = (f x ⊗ₛ 1) * (f y ⊗ₛ 1) : (h8 _ _ _).symm
    ... = algebra_tensor.hom x * algebra_tensor.hom y : rfl,
  map_one := by simp [algebra_tensor.hom, is_ring_hom.map_one f]; refl }

end algebra_tensor


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.sites.sheaf_of_types
import order.closure

/-!
# Closed sieves

A natural closure operator on sieves is a closure operator on `sieve X` for each `X` which commutes
with pullback.
We show that a Grothendieck topology `J` induces a natural closure operator, and define what the
closed sieves are. The collection of `J`-closed sieves forms a presheaf which is a sheaf for `J`,
and further this presheaf can be used to determine the Grothendieck topology from the sheaf
predicate.
Finally we show that a natural closure operator on sieves induces a Grothendieck topology, and hence
that natural closure operators are in bijection with Grothendieck topologies.

## Main definitions

* `category_theory.grothendieck_topology.close`: Sends a sieve `S` on `X` to the set of arrows
  which it covers. This has all the usual properties of a closure operator, as well as commuting
  with pullback.
* `category_theory.grothendieck_topology.closure_operator`: The bundled `closure_operator` given
  by `category_theory.grothendieck_topology.close`.
* `category_theory.grothendieck_topology.closed`: A sieve `S` on `X` is closed for the topology `J`
   if it contains every arrow it covers.
* `category_theory.functor.closed_sieves`: The presheaf sending `X` to the collection of `J`-closed
  sieves on `X`. This is additionally shown to be a sheaf for `J`, and if this is a sheaf for a
  different topology `J'`, then `J' ≤ J`.
* `category_theory.grothendieck_topology.topology_of_closure_operator`: A closure operator on the
  set of sieves on every object which commutes with pullback additionally induces a Grothendieck
  topology, giving a bijection with `category_theory.grothendieck_topology.closure_operator`.

## Tags

closed sieve, closure, Grothendieck topology

## References

* [S. MacLane, I. Moerdijk, *Sheaves in Geometry and Logic*][MM92]
-/

universes v u

namespace category_theory

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

variables (J₁ J₂ : grothendieck_topology C)

namespace grothendieck_topology

/-- The `J`-closure of a sieve is the collection of arrows which it covers. -/
@[simps]
def close {X : C} (S : sieve X) : sieve X :=
{ arrows := λ Y f, J₁.covers S f,
  downward_closed' := λ Y Z f hS, J₁.arrow_stable _ _ hS }

/-- Any sieve is smaller than its closure. -/
lemma le_close {X : C} (S : sieve X) : S ≤ J₁.close S :=
λ Y g hg, J₁.covering_of_eq_top (S.pullback_eq_top_of_mem hg)

/--
A sieve is closed for the Grothendieck topology if it contains every arrow it covers.
In the case of the usual topology on a topological space, this means that the open cover contains
every open set which it covers.

Note this has no relation to a closed subset of a topological space.
-/
def is_closed {X : C} (S : sieve X) : Prop :=
∀ ⦃Y : C⦄ (f : Y ⟶ X), J₁.covers S f → S f

/-- If `S` is `J₁`-closed, then `S` covers exactly the arrows it contains. -/
lemma covers_iff_mem_of_closed {X : C} {S : sieve X}
  (h : J₁.is_closed S) {Y : C} (f : Y ⟶ X) :
  J₁.covers S f ↔ S f :=
⟨h _, J₁.arrow_max _ _⟩

/-- Being `J`-closed is stable under pullback. -/

/--
The closure of a sieve `S` is the largest closed sieve which contains `S` (justifying the name
"closure").
-/
lemma le_close_of_is_closed {X : C} {S T : sieve X}
  (h : S ≤ T) (hT : J₁.is_closed T) :
  J₁.close S ≤ T :=
λ Y f hf, hT _ (J₁.superset_covering (sieve.pullback_monotone f h) hf)

/-- The closure of a sieve is closed. -/
lemma close_is_closed {X : C} (S : sieve X) : J₁.is_closed (J₁.close S) :=
λ Y g hg, J₁.arrow_trans g _ S hg (λ Z h hS, hS)

/-- The sieve `S` is closed iff its closure is equal to itself. -/
lemma is_closed_iff_close_eq_self {X : C} (S : sieve X) :
  J₁.is_closed S ↔ J₁.close S = S :=
begin
  split,
  { intro h,
    apply le_antisymm,
    { intros Y f hf,
      rw ← J₁.covers_iff_mem_of_closed h,
      apply hf },
    { apply J₁.le_close } },
  { intro e,
    rw ← e,
    apply J₁.close_is_closed }
end

lemma close_eq_self_of_is_closed {X : C} {S : sieve X} (hS : J₁.is_closed S) :
  J₁.close S = S :=
(J₁.is_closed_iff_close_eq_self S).1 hS

/-- Closing under `J` is stable under pullback. -/
lemma pullback_close {X Y : C} (f : Y ⟶ X) (S : sieve X) :
  J₁.close (S.pullback f) = (J₁.close S).pullback f :=
begin
  apply le_antisymm,
  { refine J₁.le_close_of_is_closed (sieve.pullback_monotone _ (J₁.le_close S)) _,
    apply J₁.is_closed_pullback _ _ (J₁.close_is_closed _) },
  { intros Z g hg,
    change _ ∈ J₁ _,
    rw ← sieve.pullback_comp,
    apply hg }
end

@[mono]
lemma monotone_close {X : C} :
  monotone (J₁.close : sieve X → sieve X) :=
λ S₁ S₂ h, J₁.le_close_of_is_closed (h.trans (J₁.le_close _)) (J₁.close_is_closed S₂)

@[simp]
lemma close_close {X : C} (S : sieve X) :
  J₁.close (J₁.close S) = J₁.close S :=
le_antisymm
  (J₁.le_close_of_is_closed le_rfl (J₁.close_is_closed S))
  (J₁.monotone_close (J₁.le_close _))

/--
The sieve `S` is in the topology iff its closure is the maximal sieve. This shows that the closure
operator determines the topology.
-/
lemma close_eq_top_iff_mem {X : C} (S : sieve X) :
  J₁.close S = ⊤ ↔ S ∈ J₁ X :=
begin
  split,
  { intro h,
    apply J₁.transitive (J₁.top_mem X),
    intros Y f hf,
    change J₁.close S f,
    rwa h },
  { intro hS,
    rw eq_top_iff,
    intros Y f hf,
    apply J₁.pullback_stable _ hS }
end

/-- A Grothendieck topology induces a natural family of closure operators on sieves. -/
@[simps {rhs_md := semireducible}]
def closure_operator (X : C) : closure_operator (sieve X) :=
closure_operator.mk'
  J₁.close
  (λ S₁ S₂ h, J₁.le_close_of_is_closed (h.trans (J₁.le_close _)) (J₁.close_is_closed S₂))
  J₁.le_close
  (λ S, J₁.le_close_of_is_closed le_rfl (J₁.close_is_closed S))

@[simp]
lemma closed_iff_closed {X : C} (S : sieve X) :
  S ∈ (J₁.closure_operator X).closed ↔ J₁.is_closed S :=
(J₁.is_closed_iff_close_eq_self S).symm

end grothendieck_topology

/--
The presheaf sending each object to the set of `J`-closed sieves on it. This presheaf is a `J`-sheaf
(and will turn out to be a subobject classifier for the category of `J`-sheaves).
-/
@[simps]
def functor.closed_sieves : Cᵒᵖ ⥤ Type (max v u) :=
{ obj := λ X, {S : sieve X.unop // J₁.is_closed S},
  map := λ X Y f S, ⟨S.1.pullback f.unop, J₁.is_closed_pullback f.unop _ S.2⟩ }

/--
The presheaf of `J`-closed sieves is a `J`-sheaf.
The proof of this is adapted from [MM92], Chatper III, Section 7, Lemma 1.
-/
lemma classifier_is_sheaf : presieve.is_sheaf J₁ (functor.closed_sieves J₁) :=
begin
  intros X S hS,
  rw ← presieve.is_separated_for_and_exists_is_amalgamation_iff_sheaf_for,
  refine ⟨_, _⟩,
  { rintro x ⟨M, hM⟩ ⟨N, hN⟩ hM₂ hN₂,
    ext,
    dsimp only [subtype.coe_mk],
    rw [← J₁.covers_iff_mem_of_closed hM, ← J₁.covers_iff_mem_of_closed hN],
    have q : ∀ ⦃Z : C⦄ (g : Z ⟶ X) (hg : S g), M.pullback g = N.pullback g,
    { intros Z g hg,
      apply congr_arg subtype.val ((hM₂ g hg).trans (hN₂ g hg).symm) },
    have MSNS : M ⊓ S = N ⊓ S,
    { ext Z g,
      rw [sieve.inter_apply, sieve.inter_apply, and_comm (N g), and_comm],
      apply and_congr_right,
      intro hg,
      rw [sieve.pullback_eq_top_iff_mem, sieve.pullback_eq_top_iff_mem, q g hg] },
    split,
    { intro hf,
      rw J₁.covers_iff,
      apply J₁.superset_covering (sieve.pullback_monotone f inf_le_left),
      rw ← MSNS,
      apply J₁.arrow_intersect f M S hf (J₁.pullback_stable _ hS) },
    { intro hf,
      rw J₁.covers_iff,
      apply J₁.superset_covering (sieve.pullback_monotone f inf_le_left),
      rw MSNS,
      apply J₁.arrow_intersect f N S hf (J₁.pullback_stable _ hS) } },
  { intros x hx,
    rw presieve.compatible_iff_sieve_compatible at hx,
    let M := sieve.bind S (λ Y f hf, (x f hf).1),
    have : ∀ ⦃Y⦄ (f : Y ⟶ X) (hf : S f), M.pullback f = (x f hf).1,
    { intros Y f hf,
      apply le_antisymm,
      { rintro Z u ⟨W, g, f', hf', (hg : (x f' hf').1 _), c⟩,
        rw [sieve.pullback_eq_top_iff_mem,
          ←(show (x (u ≫ f) _).1 = (x f hf).1.pullback u, from congr_arg subtype.val (hx f u hf))],
        simp_rw ← c,
        rw (show (x (g ≫ f') _).1 = _, from congr_arg subtype.val (hx f' g hf')),
        apply sieve.pullback_eq_top_of_mem _ hg },
      { apply sieve.le_pullback_bind S (λ Y f hf, (x f hf).1) } },
    refine ⟨⟨_, J₁.close_is_closed M⟩, _⟩,
    { intros Y f hf,
      ext1,
      dsimp,
      rw [← J₁.pullback_close, this _ hf],
      apply le_antisymm (J₁.le_close_of_is_closed le_rfl (x f hf).2) (J₁.le_close _) } },
end

/--
If presheaf of `J₁`-closed sieves is a `J₂`-sheaf then `J₁ ≤ J₂`. Note the converse is true by
`classifier_is_sheaf` and `is_sheaf_of_le`.
-/
lemma le_topology_of_closed_sieves_is_sheaf {J₁ J₂ : grothendieck_topology C}
  (h : presieve.is_sheaf J₁ (functor.closed_sieves J₂)) :
  J₁ ≤ J₂ :=
λ X S hS,
begin
  rw ← J₂.close_eq_top_iff_mem,
  have : J₂.is_closed (⊤ : sieve X),
  { intros Y f hf,
    trivial },
  suffices : (⟨J₂.close S, J₂.close_is_closed S⟩ : subtype _) = ⟨⊤, this⟩,
  { rw subtype.ext_iff at this,
    exact this },
  apply (h S hS).is_separated_for.ext,
  { intros Y f hf,
    ext1,
    dsimp,
    rw [sieve.pullback_top, ← J₂.pullback_close, S.pullback_eq_top_of_mem hf,
        J₂.close_eq_top_iff_mem],
    apply J₂.top_mem },
end

/-- If being a sheaf for `J₁` is equivalent to being a sheaf for `J₂`, then `J₁ = J₂`. -/
lemma topology_eq_iff_same_sheaves {J₁ J₂ : grothendieck_topology C} :
  J₁ = J₂ ↔ (∀ (P : Cᵒᵖ ⥤ Type (max v u)), presieve.is_sheaf J₁ P ↔ presieve.is_sheaf J₂ P) :=
begin
  split,
  { rintro rfl,
    intro P,
    refl },
  { intro h,
    apply le_antisymm,
    { apply le_topology_of_closed_sieves_is_sheaf,
      rw h,
      apply classifier_is_sheaf },
    { apply le_topology_of_closed_sieves_is_sheaf,
      rw ← h,
      apply classifier_is_sheaf } }
end

/--
A closure (increasing, inflationary and idempotent) operation on sieves that commutes with pullback
induces a Grothendieck topology.
In fact, such operations are in bijection with Grothendieck topologies.
-/
@[simps]
def topology_of_closure_operator
  (c : Π (X : C), closure_operator (sieve X))
  (hc : Π ⦃X Y : C⦄ (f : Y ⟶ X) (S : sieve X), c _ (S.pullback f) = (c _ S).pullback f) :
  grothendieck_topology C :=
{ sieves := λ X, {S | c X S = ⊤},
  top_mem' := λ X, top_unique ((c X).le_closure _),
  pullback_stable' := λ X Y S f hS,
  begin
    rw set.mem_set_of_eq at hS,
    rw [set.mem_set_of_eq, hc, hS, sieve.pullback_top],
  end,
  transitive' := λ X S hS R hR,
  begin
    rw set.mem_set_of_eq at hS,
    rw [set.mem_set_of_eq, ←(c X).idempotent, eq_top_iff, ←hS],
    apply (c X).monotone (λ Y f hf, _),
    rw [sieve.pullback_eq_top_iff_mem, ←hc],
    apply hR hf,
  end }

/--
The topology given by the closure operator `J.close` on a Grothendieck topology is the same as `J`.
-/
lemma topology_of_closure_operator_self :
  topology_of_closure_operator J₁.closure_operator (λ X Y, J₁.pullback_close) = J₁ :=
begin
  ext X S,
  apply grothendieck_topology.close_eq_top_iff_mem,
end

lemma topology_of_closure_operator_close
  (c : Π (X : C), closure_operator (sieve X))
  (pb : Π ⦃X Y : C⦄ (f : Y ⟶ X) (S : sieve X), c Y (S.pullback f) = (c X S).pullback f)
  (X : C) (S : sieve X) :
  (topology_of_closure_operator c pb).close S = c X S :=
begin
  ext,
  change c _ (sieve.pullback f S) = ⊤ ↔ c _ S f,
  rw [pb, sieve.pullback_eq_top_iff_mem],
end

end category_theory


/-
Copyright (c) 2023 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser

! This file was ported from Lean 3 source module linear_algebra.bilinear_form.tensor_product
! leanprover-community/mathlib commit f91d3736cbfcff4614caabcf9ae32d4a880f8813
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.BilinearForm
import Mathbin.LinearAlgebra.TensorProduct
import Mathbin.LinearAlgebra.Contraction

/-!
# The bilinear form on a tensor product

## Main definitions

* `bilin_form.tensor_distrib (B₁ ⊗ₜ B₂)`: the bilinear form on `M₁ ⊗ M₂` constructed by applying
  `B₁` on `M₁` and `B₂` on `M₂`.
* `bilin_form.tensor_distrib_equiv`: `bilin_form.tensor_distrib` as an equivalence on finite free
  modules.

-/

universe u v w

variable {ι : Type _} {R : Type _} {M₁ M₂ : Type _}

open TensorProduct

namespace BilinForm

section CommSemiring

variable [CommSemiring R]

variable [AddCommMonoid M₁] [AddCommMonoid M₂]

variable [Module R M₁] [Module R M₂]

/-- The tensor product of two bilinear forms injects into bilinear forms on tensor products. -/
def tensorDistrib : BilinForm R M₁ ⊗[R] BilinForm R M₂ →ₗ[R] BilinForm R (M₁ ⊗[R] M₂) :=
  ((TensorProduct.tensorTensorTensorComm R _ _ _ _).dualMap ≪≫ₗ
          (TensorProduct.lift.equiv R _ _ _).symm ≪≫ₗ
        LinearMap.toBilin).toLinearMap ∘ₗ
    TensorProduct.dualDistrib R _ _ ∘ₗ
      (TensorProduct.congr (BilinForm.toLin ≪≫ₗ TensorProduct.lift.equiv R _ _ _)
          (BilinForm.toLin ≪≫ₗ TensorProduct.lift.equiv R _ _ _)).toLinearMap
#align bilin_form.tensor_distrib BilinForm.tensorDistrib

@[simp]
theorem tensorDistrib_tmul (B₁ : BilinForm R M₁) (B₂ : BilinForm R M₂) (m₁ : M₁) (m₂ : M₂)
    (m₁' : M₁) (m₂' : M₂) :
    tensorDistrib (B₁ ⊗ₜ B₂) (m₁ ⊗ₜ m₂) (m₁' ⊗ₜ m₂') = B₁ m₁ m₁' * B₂ m₂ m₂' :=
  rfl
#align bilin_form.tensor_distrib_tmul BilinForm.tensorDistrib_tmul

/-- The tensor product of two bilinear forms, a shorthand for dot notation. -/
@[reducible]
protected def tmul (B₁ : BilinForm R M₁) (B₂ : BilinForm R M₂) : BilinForm R (M₁ ⊗[R] M₂) :=
  tensorDistrib (B₁ ⊗ₜ[R] B₂)
#align bilin_form.tmul BilinForm.tmul

end CommSemiring

section CommRing

variable [CommRing R]

variable [AddCommGroup M₁] [AddCommGroup M₂]

variable [Module R M₁] [Module R M₂]

variable [Module.Free R M₁] [Module.Finite R M₁]

variable [Module.Free R M₂] [Module.Finite R M₂]

variable [Nontrivial R]

/-- `tensor_distrib` as an equivalence. -/
noncomputable def tensorDistribEquiv :
    BilinForm R M₁ ⊗[R] BilinForm R M₂ ≃ₗ[R] BilinForm R (M₁ ⊗[R] M₂) :=
  -- the same `linear_equiv`s as from `tensor_distrib`, but with the inner linear map also as an
            -- equiv
            TensorProduct.congr
            (BilinForm.toLin ≪≫ₗ TensorProduct.lift.equiv R _ _ _)
            (BilinForm.toLin ≪≫ₗ TensorProduct.lift.equiv R _ _ _) ≪≫ₗ
          TensorProduct.dualDistribEquiv R (M₁ ⊗ M₁) (M₂ ⊗ M₂) ≪≫ₗ
        (TensorProduct.tensorTensorTensorComm R _ _ _ _).dualMap ≪≫ₗ
      (TensorProduct.lift.equiv R _ _ _).symm ≪≫ₗ
    LinearMap.toBilin
#align bilin_form.tensor_distrib_equiv BilinForm.tensorDistribEquiv

@[simp]
theorem tensorDistribEquiv_apply (B : BilinForm R M₁ ⊗ BilinForm R M₂) :
    tensorDistribEquiv B = tensorDistrib B :=
  rfl
#align bilin_form.tensor_distrib_equiv_apply BilinForm.tensorDistribEquiv_apply

end CommRing

end BilinForm


-- main theorem: add_iter_monotonic
import algebra
import algebra.group
import algebra.group.defs
import tactic
import logic.relation

import combinators

namespace iter

section params_unary
variables {σ I V : Type} [linear_order I]
{a : iter σ I V}
variables (s t : σ)

lemma mono_iff_delta_mono  : a.monotonic ↔ ∀ s, a.ι s ≤ a.ι (a.δ s) := begin
split,
{ intros m t,
  exact m _ _ (transition.step a)},
{ intros hstep s t path,
  obtain ⟨len, h⟩ := index_of_path path,
  rw h at *,
  clear h t path,
  induction len with _ h generalizing s,
    { exact le_refl _ },
    { rw step_succ,
      exact (hstep s).trans (h (a.δ s)) }
},
end

end params_unary

section params_binary
variables {σ₁ σ₂ I V : Type} [linear_order I] [add_monoid V]
{a : iter σ₁ I V} {b : iter σ₂ I V}

lemma add_ι_min {s} : (a+'b).ι s = min (a.ι s.1) (b.ι s.2) := begin
cases s with s₁ s₂,
simp only [ι, add_iter, add_emit, min_def],
split_ifs with h1 h2 h3,
repeat {refl}, -- 2
repeat {simp only [gt_iff_lt, not_lt] at *},
{ exfalso, exact h2 (le_of_lt h1) },
{ exfalso, exact not_lt_of_le h h3 },
{ -- main case
  replace h := h.antisymm h1,
  cases h4 : a.emit s₁ with v1; cases h5 : b.emit s₂ with v2,
  repeat { try {cases v1}, try {cases v2}, simpa only [iter.ι, h4, h5] using h },
},
{ exfalso, exact h h3 },
end

lemma step_dichotomy_left (s₁:σ₁)(s₂:σ₂) : ((a +'b).δ (s₁,s₂)).1 = a.δ s₁ ∨ ((a +'b).δ (s₁,s₂)).1 = s₁ := begin
simp only [add_iter, iter.δ], split_ifs, tidy,
end
lemma step_dichotomy_right (s₁:σ₁)(s₂:σ₂) : ((a +'b).δ (s₁,s₂)).2 = b.δ s₂ ∨ ((a +'b).δ (s₁,s₂)).2 = s₂ := begin
simp only [add_iter, iter.δ], split_ifs, tidy,
end

theorem add_iter_monotonic : a.monotonic → b.monotonic → (a +' b).monotonic := begin
intros m1 m2, simp only [mono_iff_delta_mono],

rintro ⟨t₁, t₂⟩, simp only [add_ι_min],
apply min_le_min _ _,

{ obtain (h|h) := step_dichotomy_left t₁ t₂; rw h,
  apply mono_iff_delta_mono.1 m1,
  exact le_refl _ },

{ obtain (h|h) := step_dichotomy_right t₁ t₂; rw h,
  apply mono_iff_delta_mono.1 m2,
  exact le_refl _ }
end

end params_binary

end iter


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import algebra.big_operators.multiset
import data.fun_like.basic

/-!
# Freiman homomorphisms

In this file, we define Freiman homomorphisms. A `n`-Freiman homomorphism on `A` is a function
`f : α → β` such that `f (x₁) * ... * f (xₙ) = f (y₁) * ... * f (yₙ)` for all
`x₁, ..., xₙ, y₁, ..., yₙ ∈ A` such that `x₁ * ... * xₙ = y₁ * ... * yₙ`. In particular, any
`mul_hom` is a Freiman homomorphism.

They are of interest in additive combinatorics.

## Main declaration

* `freiman_hom`: Freiman homomorphism.
* `add_freiman_hom`: Additive Freiman homomorphism.

## Notation

* `A →*[n] β`: Multiplicative `n`-Freiman homomorphism on `A`
* `A →+[n] β`: Additive `n`-Freiman homomorphism on `A`

## Implementation notes

In the context of combinatorics, we are interested in Freiman homomorphisms over sets which are not
necessarily closed under addition/multiplication. This means we must parametrize them with a set in
an `add_monoid`/`monoid` instead of the `add_monoid`/`monoid` itself.

## References

[Yufei Zhao, *18.225: Graph Theory and Additive Combinatorics][https://yufeizhao.com/gtac/]

## TODO

`monoid_hom.to_freiman_hom` could be relaxed to `mul_hom.to_freiman_hom` by proving
`(s.map f).prod = (t.map f).prod` directly by induction instead of going through `f s.prod`.

Define `n`-Freiman isomorphisms.

Affine maps induce Freiman homs. Concretely, provide the `add_freiman_hom_class (α →ₐ[𝕜] β) A β n`
instance.
-/

open multiset

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

/-- An additive `n`-Freiman homomorphism is a map which preserves sums of `n` elements. -/
structure add_freiman_hom (A : set α) (β : Type*) [add_comm_monoid α] [add_comm_monoid β] (n : ℕ) :=
(to_fun : α → β)
(map_sum_eq_map_sum' {s t : multiset α} (hsA : ∀ ⦃x⦄, x ∈ s → x ∈ A) (htA : ∀ ⦃x⦄, x ∈ t → x ∈ A)
  (hs : s.card = n) (ht : t.card = n) (h : s.sum = t.sum) :
  (s.map to_fun).sum = (t.map to_fun).sum)

/-- A `n`-Freiman homomorphism on a set `A` is a map which preserves products of `n` elements. -/
@[to_additive add_freiman_hom]
structure freiman_hom (A : set α) (β : Type*) [comm_monoid α] [comm_monoid β] (n : ℕ) :=
(to_fun : α → β)
(map_prod_eq_map_prod' {s t : multiset α} (hsA : ∀ ⦃x⦄, x ∈ s → x ∈ A) (htA : ∀ ⦃x⦄, x ∈ t → x ∈ A)
  (hs : s.card = n) (ht : t.card = n) (h : s.prod = t.prod) :
  (s.map to_fun).prod = (t.map to_fun).prod)

notation A ` →+[`:25 n:25 `] `:0 β:0 := add_freiman_hom A β n
notation A ` →*[`:25 n:25 `] `:0 β:0 := freiman_hom A β n

/-- `add_freiman_hom_class F s β n` states that `F` is a type of `n`-ary sums-preserving morphisms.
You should extend this class when you extend `add_freiman_hom`. -/
class add_freiman_hom_class (F : Type*) (A : out_param $ set α) (β : out_param $ Type*)
  [add_comm_monoid α] [add_comm_monoid β] (n : ℕ) [fun_like F α (λ _, β)] :=
(map_sum_eq_map_sum' (f : F) {s t : multiset α} (hsA : ∀ ⦃x⦄, x ∈ s → x ∈ A)
  (htA : ∀ ⦃x⦄, x ∈ t → x ∈ A) (hs : s.card = n) (ht : t.card = n) (h : s.sum = t.sum) :
  (s.map f).sum = (t.map f).sum)

/-- `freiman_hom_class F A β n` states that `F` is a type of `n`-ary products-preserving morphisms.
You should extend this class when you extend `freiman_hom`. -/
@[to_additive add_freiman_hom_class]
class freiman_hom_class (F : Type*) (A : out_param $ set α) (β : out_param $ Type*) [comm_monoid α]
  [comm_monoid β] (n : ℕ) [fun_like F α (λ _, β)] :=
(map_prod_eq_map_prod' (f : F) {s t : multiset α} (hsA : ∀ ⦃x⦄, x ∈ s → x ∈ A)
  (htA : ∀ ⦃x⦄, x ∈ t → x ∈ A) (hs : s.card = n) (ht : t.card = n) (h : s.prod = t.prod) :
  (s.map f).prod = (t.map f).prod)

variables [fun_like F α (λ _, β)]

section comm_monoid
variables [comm_monoid α] [comm_monoid β] [comm_monoid γ] [comm_monoid δ] [comm_group G] {A : set α}
  {B : set β} {C : set γ} {n : ℕ}

@[to_additive]
lemma map_prod_eq_map_prod [freiman_hom_class F A β n] (f : F) {s t : multiset α}
  (hsA : ∀ ⦃x⦄, x ∈ s → x ∈ A) (htA : ∀ ⦃x⦄, x ∈ t → x ∈ A) (hs : s.card = n) (ht : t.card = n)
  (h : s.prod = t.prod) :
  (s.map f).prod = (t.map f).prod :=
freiman_hom_class.map_prod_eq_map_prod' f hsA htA hs ht h

namespace freiman_hom

@[to_additive]
instance fun_like : fun_like (A →*[n] β) α (λ _, β) :=
{ coe := to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr' }

@[to_additive]
instance freiman_hom_class : freiman_hom_class (A →*[n] β) A β n :=
{ map_prod_eq_map_prod' := map_prod_eq_map_prod' }

/-- Helper instance for when there's too many metavariables to apply
`fun_like.has_coe_to_fun` directly. -/
@[to_additive]
instance : has_coe_to_fun (A →*[n] β) (λ _, α → β) := ⟨to_fun⟩

initialize_simps_projections freiman_hom (to_fun → apply)

@[simp, to_additive]
lemma to_fun_eq_coe (f : A →*[n] β) : f.to_fun = f := rfl

@[ext, to_additive]
lemma ext ⦃f g : A →*[n] β⦄ (h : ∀ x, f x = g x) : f = g := fun_like.ext f g h

@[simp, to_additive]
lemma coe_mk (f : α → β) (h : ∀ s t : multiset α, (∀ ⦃x⦄, x ∈ s → x ∈ A) → (∀ ⦃x⦄, x ∈ t → x ∈ A) →
  s.card = n → t.card = n → s.prod = t.prod → (s.map f).prod = (t.map f).prod) :
  ⇑(mk f h) = f := rfl

@[simp, to_additive] lemma mk_coe (f : A →*[n] β) (h) : mk f h = f := ext $ λ _, rfl

/-- The identity map from a commutative monoid to itself. -/
@[to_additive "The identity map from an additive commutative monoid to itself.", simps]
protected def id (A : set α) (n : ℕ) : A →*[n] α  :=
{ to_fun := λ x, x, map_prod_eq_map_prod' := λ s t _ _ _ _ h, by rw [map_id', map_id', h] }

/-- Composition of Freiman homomorphisms as a Freiman homomorphism. -/
@[to_additive "Composition of additive Freiman homomorphisms as an additive Freiman homomorphism."]
protected def comp (f : B →*[n] γ) (g : A →*[n] β) (hAB : A.maps_to g B) : A →*[n] γ :=
{ to_fun := f ∘ g,
  map_prod_eq_map_prod' := λ s t hsA htA hs ht h, begin
    rw [←map_map,
    map_prod_eq_map_prod f _ _ ((s.card_map _).trans hs) ((t.card_map _).trans ht)
      (map_prod_eq_map_prod g hsA htA hs ht h), map_map],
    { simpa using (λ a h, hAB (hsA h)) },
    { simpa using (λ a h, hAB (htA h)) }
  end }

@[simp, to_additive]
lemma coe_comp (f : B →*[n] γ) (g : A →*[n] β) {hfg} : ⇑(f.comp g hfg) = f ∘ g := rfl

@[to_additive]
lemma comp_apply (f : B →*[n] γ) (g : A →*[n] β) {hfg} (x : α) : f.comp g hfg x = f (g x) := rfl

@[to_additive]
lemma comp_assoc (f : A →*[n] β) (g : B →*[n] γ) (h : C →*[n] δ) {hf hhg hgf}
  {hh : A.maps_to (g.comp f hgf) C} :
  (h.comp g hhg).comp f hf = h.comp (g.comp f hgf) hh := rfl

@[to_additive]
lemma cancel_right {g₁ g₂ : B →*[n] γ} {f : A →*[n] β} (hf : function.surjective f) {hg₁ hg₂} :
  g₁.comp f hg₁ = g₂.comp f hg₂ ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 $ fun_like.ext_iff.1 h, λ h, h ▸ rfl⟩

@[to_additive]
lemma cancel_right_on {g₁ g₂ : B →*[n] γ} {f : A →*[n] β} (hf : A.surj_on f B) {hf'} :
  A.eq_on (g₁.comp f hf') (g₂.comp f hf') ↔ B.eq_on g₁ g₂ :=
hf.cancel_right hf'

@[to_additive]
lemma cancel_left_on {g : B →*[n] γ} {f₁ f₂ : A →*[n] β} (hg : B.inj_on g) {hf₁ hf₂} :
  A.eq_on (g.comp f₁ hf₁) (g.comp f₂ hf₂) ↔ A.eq_on f₁ f₂ :=
hg.cancel_left hf₁ hf₂

@[simp, to_additive] lemma comp_id (f : A →*[n] β) {hf} : f.comp (freiman_hom.id A n) hf = f :=
ext $ λ x, rfl

@[simp, to_additive] lemma id_comp (f : A →*[n] β) {hf} : (freiman_hom.id B n).comp f hf = f :=
ext $ λ x, rfl

/-- `freiman_hom.const A n b` is the Freiman homomorphism sending everything to `b`. -/
@[to_additive "`add_freiman_hom.const n b` is the Freiman homomorphism sending everything to `b`."]
def const (A : set α) (n : ℕ) (b : β) : A →*[n] β :=
{ to_fun := λ _, b,
  map_prod_eq_map_prod' := λ s t _ _ hs ht _,
    by rw [multiset.map_const, multiset.map_const, prod_repeat, prod_repeat, hs, ht] }

@[simp, to_additive] lemma const_apply (n : ℕ) (b : β) (x : α) : const A n b x = b := rfl

@[simp, to_additive]
lemma const_comp (n : ℕ) (c : γ) (f : A →*[n] β) {hf} : (const B n c).comp f hf = const A n c := rfl

/-- `1` is the Freiman homomorphism sending everything to `1`. -/
@[to_additive "`0` is the Freiman homomorphism sending everything to `0`."]
instance : has_one (A →*[n] β) := ⟨const A n 1⟩

@[simp, to_additive] lemma one_apply (x : α) : (1 : A →*[n] β) x = 1 := rfl

@[simp, to_additive] lemma one_comp (f : A →*[n] β) {hf} : (1 : B →*[n] γ).comp f hf = 1 := rfl

@[to_additive] instance : inhabited (A →*[n] β) := ⟨1⟩

/-- `f * g` is the Freiman homomorphism  sends `x` to `f x * g x`. -/
@[to_additive "`f + g` is the Freiman homomorphism sending `x` to `f x + g x`."]
instance : has_mul (A →*[n] β) :=
⟨λ f g, { to_fun := λ x, f x * g x,
  map_prod_eq_map_prod' := λ s t hsA htA hs ht h,
    by rw [prod_map_mul, prod_map_mul, map_prod_eq_map_prod f hsA htA hs ht h,
           map_prod_eq_map_prod g hsA htA hs ht h] }⟩

@[simp, to_additive] lemma mul_apply (f g : A →*[n] β) (x : α) : (f * g) x = f x * g x := rfl

@[to_additive] lemma mul_comp (g₁ g₂ : B →*[n] γ) (f : A →*[n] β) {hg hg₁ hg₂} :
  (g₁ * g₂).comp f hg = g₁.comp f hg₁ * g₂.comp f hg₂ := rfl

/-- If `f` is a Freiman homomorphism to a commutative group, then `f⁻¹` is the Freiman homomorphism
sending `x` to `(f x)⁻¹`. -/
@[to_additive]
instance : has_inv (A →*[n] G) :=
⟨λ f, { to_fun := λ x, (f x)⁻¹,
  map_prod_eq_map_prod' := λ s t hsA htA hs ht h,
    by rw [prod_map_inv', prod_map_inv', map_prod_eq_map_prod f hsA htA hs ht h] }⟩

@[simp, to_additive] lemma inv_apply (f : A →*[n] G) (x : α) : f⁻¹ x = (f x)⁻¹ := rfl

@[simp, to_additive] lemma inv_comp (f : B →*[n] G) (g : A →*[n] β) {hf hf'} :
  f⁻¹.comp g hf = (f.comp g hf')⁻¹ :=
ext $ λ x, rfl

/-- If `f` and `g` are Freiman homomorphisms to a commutative group, then `f / g` is the Freiman
homomorphism sending `x` to `f x / g x`. -/
@[to_additive "If `f` and `g` are additive Freiman homomorphisms to an additive commutative group,
then `f - g` is the additive Freiman homomorphism sending `x` to `f x - g x`"]
instance : has_div (A →*[n] G) :=
⟨λ f g, { to_fun := λ x, f x / g x,
  map_prod_eq_map_prod' := λ s t hsA htA hs ht h,
    by rw [prod_map_div, prod_map_div, map_prod_eq_map_prod f hsA htA hs ht h,
           map_prod_eq_map_prod g hsA htA hs ht h] }⟩

@[simp, to_additive] lemma div_apply (f g : A →*[n] G) (x : α) : (f / g) x = f x / g x := rfl

@[simp, to_additive] lemma div_comp (f₁ f₂ : B →*[n] G) (g : A →*[n] β) {hf hf₁ hf₂} :
  (f₁ / f₂).comp g hf = f₁.comp g hf₁ / f₂.comp g hf₂ :=
ext $ λ x, rfl

/-! ### Instances -/

/-- `A →*[n] β` is a `comm_monoid`. -/
@[to_additive "`α →+[n] β` is an `add_comm_monoid`."]
instance : comm_monoid (A →*[n] β) :=
{ mul := (*),
  mul_assoc := λ a b c, by { ext, apply mul_assoc },
  one := 1,
  one_mul := λ a, by { ext, apply one_mul },
  mul_one := λ a, by { ext, apply mul_one },
  mul_comm :=  λ a b, by { ext, apply mul_comm },
  npow := λ m f,
  { to_fun := λ x, f x ^ m,
    map_prod_eq_map_prod' := λ s t hsA htA hs ht h,
      by rw [prod_map_pow, prod_map_pow, map_prod_eq_map_prod f hsA htA hs ht h] },
  npow_zero' := λ f, by { ext x, exact pow_zero _ },
  npow_succ' := λ n f, by { ext x, exact pow_succ _ _ } }

/-- If `β` is a commutative group, then `A →*[n] β` is a commutative group too. -/
@[to_additive "If `β` is an additive commutative group, then `A →*[n] β` is an additive commutative
group too."]
instance {β} [comm_group β] : comm_group (A →*[n] β) :=
{ inv := has_inv.inv,
  div := has_div.div,
  div_eq_mul_inv := by { intros, ext, apply div_eq_mul_inv },
  mul_left_inv := by { intros, ext, apply mul_left_inv },
  zpow := λ n f, { to_fun := λ x, (f x) ^ n,
    map_prod_eq_map_prod' := λ s t hsA htA hs ht h,
      by rw [prod_map_zpow, prod_map_zpow, map_prod_eq_map_prod f hsA htA hs ht h] },
  zpow_zero' := λ f, by { ext x, exact zpow_zero _ },
  zpow_succ' := λ n f, by { ext x, simp_rw [zpow_of_nat, pow_succ, mul_apply, coe_mk] },
  zpow_neg'  := λ n f, by { ext x, simp_rw [zpow_neg_succ_of_nat, zpow_coe_nat], refl },
  ..freiman_hom.comm_monoid }

end freiman_hom

/-! ### Hom hierarchy -/

--TODO: change to `monoid_hom_class F A β → freiman_hom_class F A β n` once `map_multiset_prod` is
-- generalized
/-- A monoid homomorphism is naturally a `freiman_hom` on its entire domain.

We can't leave the domain `A : set α` of the `freiman_hom` a free variable, since it wouldn't be
inferrable. -/
@[to_additive]
instance monoid_hom.freiman_hom_class : freiman_hom_class (α →* β) set.univ β n :=
{ map_prod_eq_map_prod' := λ f s t _ _ _ _ h, by rw [←f.map_multiset_prod, h, f.map_multiset_prod] }

/-- A `monoid_hom` is naturally a `freiman_hom`. -/
@[to_additive add_monoid_hom.to_add_freiman_hom "An `add_monoid_hom` is naturally an
`add_freiman_hom`"]
def monoid_hom.to_freiman_hom (A : set α) (n : ℕ) (f : α →* β) : A →*[n] β :=
{ to_fun := f,
  map_prod_eq_map_prod' := λ s t hsA htA, map_prod_eq_map_prod f
    (λ _ _, set.mem_univ _) (λ _ _, set.mem_univ _) }

@[simp, to_additive]
lemma monoid_hom.to_freiman_hom_coe (f : α →* β) : (f.to_freiman_hom A n : α → β) = f := rfl

@[to_additive]
lemma monoid_hom.to_freiman_hom_injective :
  function.injective (monoid_hom.to_freiman_hom A n : (α →* β) → A →*[n] β) :=
λ f g h, monoid_hom.ext $ show _, from fun_like.ext_iff.mp h

end comm_monoid

section cancel_comm_monoid
variables [comm_monoid α] [cancel_comm_monoid β] {A : set α} {m n : ℕ}

@[to_additive]
lemma map_prod_eq_map_prod_of_le [freiman_hom_class F A β n] (f : F) {s t : multiset α}
  (hsA : ∀ x ∈ s, x ∈ A) (htA : ∀ x ∈ t, x ∈ A) (hs : s.card = m)
  (ht : t.card = m) (hst : s.prod = t.prod) (h : m ≤ n) :
  (s.map f).prod = (t.map f).prod :=
begin
  obtain rfl | hm := m.eq_zero_or_pos,
  { rw card_eq_zero at hs ht,
    rw [hs, ht] },
  rw [←hs, card_pos_iff_exists_mem] at hm,
  obtain ⟨a, ha⟩ := hm,
  suffices : ((s + repeat a (n - m)).map f).prod = ((t + repeat a (n - m)).map f).prod,
  { simp_rw [multiset.map_add, prod_add] at this,
    exact mul_right_cancel this },
  replace ha := hsA _ ha,
  refine map_prod_eq_map_prod f (λ x hx, _) (λ x hx, _) _ _ _,
  rotate 2, assumption, -- Can't infer `A` and `n` from the context, so do it manually.
  { rw mem_add at hx,
    refine hx.elim (hsA _) (λ h, _),
    rwa eq_of_mem_repeat h },
  { rw mem_add at hx,
    refine hx.elim (htA _) (λ h, _),
    rwa eq_of_mem_repeat h },
  { rw [card_add, hs, card_repeat, add_tsub_cancel_of_le h] },
  { rw [card_add, ht, card_repeat, add_tsub_cancel_of_le h] },
  { rw [prod_add, prod_add, hst] }
end

/-- `α →*[n] β` is naturally included in  `A →*[m] β` for any `m ≤ n`. -/
@[to_additive add_freiman_hom.to_add_freiman_hom "`α →+[n] β` is naturally included in  `α →+[m] β`
for any `m ≤ n`"]
def freiman_hom.to_freiman_hom (h : m ≤ n) (f : A →*[n] β) : A →*[m] β :=
{ to_fun := f,
  map_prod_eq_map_prod' := λ s t hsA htA hs ht hst,
    map_prod_eq_map_prod_of_le f hsA htA hs ht hst h }

/-- A `n`-Freiman homomorphism is also a `m`-Freiman homomorphism for any `m ≤ n`. -/
@[to_additive add_freiman_hom.add_freiman_hom_class_of_le "An additive `n`-Freiman homomorphism is
also an additive `m`-Freiman homomorphism for any `m ≤ n`."]
def freiman_hom.freiman_hom_class_of_le [freiman_hom_class F A β n] (h : m ≤ n) :
  freiman_hom_class F A β m :=
{ map_prod_eq_map_prod' := λ f s t hsA htA hs ht hst,
    map_prod_eq_map_prod_of_le f hsA htA hs ht hst h }

@[simp, to_additive add_freiman_hom.to_add_freiman_hom_coe]
lemma freiman_hom.to_freiman_hom_coe (h : m ≤ n) (f : A →*[n] β) :
  (f.to_freiman_hom h : α → β) = f := rfl

@[to_additive]
lemma freiman_hom.to_freiman_hom_injective (h : m ≤ n) :
  function.injective (freiman_hom.to_freiman_hom h : (A →*[n] β) → A →*[m] β) :=
λ f g hfg, freiman_hom.ext $ by convert fun_like.ext_iff.1 hfg

end cancel_comm_monoid


import config

variables {α : Type*} [linear_order α] (C : config α)

namespace config

def has_laced (n : ℕ) (S : finset α) (p q : α) : Prop :=
  ∃ {a b : ℕ} {cp c cq : list α}
    (hcp : C.ncup a cp) (hc : C.ncup n c) (hcQ : C.ncup b cq),
    (cp.in S ∧ c.in S ∧ cq.in S) ∧ a + b = n ∧
    (p ∈ cp.last' ∧ p ∈ c.head' ∧ q ∈ c.last' ∧ q ∈ cq.head')

theorem has_laced.mem_ends {C : config α} {n : ℕ} {S : finset α} {p q : α}
  (h : C.has_laced n S p q) : p ∈ S ∧ q ∈ S :=
begin
  rcases h with ⟨-, -, -, c, -, -, -, -,
    ⟨-, c_in_S, -⟩, -, ⟨-, c_head, c_last, -⟩⟩,
  exact ⟨c_in_S _ (list.mem_of_mem_head' c_head),
    c_in_S _ (list.mem_of_mem_last' c_last)⟩,
end

def has_interweaved_laced
  (n : ℕ) (S : finset α) (p q r s : α) : Prop :=
  (p < q ∧ q ≤ r ∧ r < s) ∧
  (C.has_laced n S p r ∧ C.has_laced n S q s)

def has_join (a b : ℕ) (S : finset α) : Prop :=
  ∃ (p : α) (cl cr : list α),
    (C.ncup a cl ∧ cl.in S ∧ p ∈ cl.last') ∧
    (C.ncup b cr ∧ cr.in S ∧ p ∈ cr.head')

end config


import game.world10.level9 -- hide
namespace mynat -- hide
/-

# Inequality world.

## Level 10: `le_succ_self`

Can you find the two-line proof?
-/

/- Lemma
For all naturals $a$, $a\le\operatorname{succ}(a).$
-/
lemma le_succ_self (a : mynat) : a ≤ succ a :=
begin [nat_num_game]
  use 1,
  refl,

end

end mynat -- hide


/-
Copyright (c) 2020 Ruben Van de Velde. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

import algebraic_geometry.elliptic_curve.weierstrass
import number_theory.fermat4
import .primes
import .odd_prime_or_four
import .euler

lemma flt_four
  {a b c : ℤ} (ha : a ≠ 0) (hb : b ≠ 0) (hc : c ≠ 0) :
  a ^ 4 + b ^ 4 ≠ c ^ 4 :=
not_fermat_4 ha hb

lemma flt_primes
  {p : ℕ} {a b c : ℤ} (h : 5 ≤ p) (hp : p.prime) (ha : a ≠ 0) (hb : b ≠ 0) (hc : c ≠ 0) :
  a ^ p + b ^ p ≠ c ^ p :=
begin
  intro H,
  let disc : ℚ := 16 * (a ^ p * b ^ p * c ^ p) ^ 2,
  have disc_ne_zero : disc ≠ 0,
  { dsimp [disc],
    refine mul_ne_zero (by norm_num) (pow_ne_zero 2 (mul_ne_zero (mul_ne_zero _ _) _));
    apply pow_ne_zero; assumption_mod_cast },
  let frey : elliptic_curve ℚ :=
  { a₁ := 0,
    a₂ := b ^ p - a ^p,
    a₃ := 0,
    a₄ := - (a ^ p * b ^ p),
    a₆ := 0,
    Δ' := units.mk0 _ disc_ne_zero,
    coe_Δ' := by {
      rw [←@int.cast_inj ℚ, int.cast_pow] at H, simp [elliptic_curve.Δ', ←H], ring } },
  -- by wiles
  sorry,
end

lemma flt_composite
  {p n : ℕ} {a b c : ℤ} (h : p ∣ n) (ha : a ≠ 0) (hb : b ≠ 0) (hc : c ≠ 0)
  (g : a ^ n + b ^ n = c ^ n):
  ∃ a' b' c' : ℤ, a' ≠ 0 ∧ b' ≠ 0 ∧ c' ≠ 0 ∧ a' ^ p + b' ^ p = c' ^ p :=
begin
  obtain ⟨m, rfl⟩ := h,
  rw [mul_comm, pow_mul, pow_mul, pow_mul] at g,
  exact ⟨a ^ m, b ^ m, c ^ m, pow_ne_zero _ ha, pow_ne_zero _ hb, pow_ne_zero _ hc, g⟩,
end

theorem flt {n : ℕ} {a b c : ℤ} (h : 2 < n) (ha : a ≠ 0) (hb : b ≠ 0) (hc : c ≠ 0) :
  a ^ n + b ^ n ≠ c ^ n :=
begin
  intro H,
  zify at h,
  obtain ⟨p, hdvd, hp⟩ := odd_prime_or_four.exists_and_dvd h,
  rw [int.coe_nat_dvd_right] at hdvd,
  obtain ⟨a', b', c', ha', hb', hc', hcomp⟩ := flt_composite hdvd ha hb hc H,
  obtain rfl|⟨hp, hodd⟩ := hp,
  { exact flt_four ha' hb' hc' hcomp },
  { by_cases h3 : p.nat_abs = 3,
    { rw h3 at hcomp,
      apply flt_three ha' hb' hc' hcomp },
    { rw int.prime_iff_nat_abs_prime at hp,
      rw [←int.nat_abs_odd, nat.odd_iff_not_even] at hodd,
      refine flt_primes _ hp ha' hb' hc' hcomp,
      by_contradiction hcon,
      push_neg at hcon,
      have := hp.two_le,
      interval_cases p.nat_abs with hp',
      { rw hp' at hodd, exact hodd (even_bit0 1) },
      { exact h3 hp' },
      { rw hp' at hodd, exact hodd (even_bit0 2) } } },
end


import linalg
  analysis.inner_product_space.basic
  analysis.convex.basic
  topology.basic
  topology.subset_properties
  topology.metric_space.basic
  linear_algebra.affine_space.affine_subspace
  data.set.basic
  data.set.pointwise
  topology.basic
  analysis.inner_product_space.dual

open_locale pointwise
open_locale topological_space

-- needed to get decidable_eq for sets!
open classical
local attribute [instance] prop_decidable

variables {V: Type} [inner_product_space ℝ V] [finite_dimensional ℝ V]

lemma convex_sum {A B : set V}
(Acv : convex ℝ A) (Bcv : convex ℝ B) :
convex ℝ (A + B) :=
begin
  rintro - - ⟨xa, xb, xaA, xbB, rfl⟩ ⟨ya, yb, yaA, ybB, rfl⟩,
  rintro a b a0 b0 ab1,
  refine ⟨a • xa + b • ya, a • xb + b • yb, _, _, _⟩,
  {
    apply Acv,
    all_goals {assumption},
  },
  {
    apply Bcv,
    all_goals {assumption},
  },
  {
    simp only [smul_add],
    abel,
  },
end

def is_convex_body (K : set V) : Prop :=
convex ℝ K ∧ is_compact K ∧ set.nonempty K

lemma convex_convex_body {K : set V} (Kcv : is_convex_body K) :
convex ℝ K := Kcv.1

def is_polytope (P : set V) : Prop :=
  ∃ S : set V, S.finite ∧ S.nonempty ∧ P = convex_hull ℝ S

def normal_face (K : set V) (u : V): set V :=
  { x | x ∈ K ∧ ∀ y ∈ K, ⟪x, u⟫_ℝ ≥ ⟪y, u⟫_ℝ }

lemma mem_normal_face {K : set V} {u : V} {x : V} :
x ∈ normal_face K u ↔ x ∈ K ∧ ∀ y ∈ K, ⟪x, u⟫_ℝ ≥ ⟪y, u⟫_ℝ :=
begin
  simp only [normal_face, set.mem_set_of],
end

lemma normal_face_subset {K : set V} {u : V} :
normal_face K u ⊆ K :=
begin
  rintro x hx,
  simp only [mem_normal_face] at hx,
  tauto,
end

lemma subset_normal_face {K : set V} {u : V} {S : set V}:
S ⊆ normal_face K u ↔ S ⊆ K ∧ ∀ s ∈ S, ∀ y ∈ K, ⟪s, u⟫_ℝ ≥ ⟪y, u⟫_ℝ :=
begin
  simp only [set.subset_def, mem_normal_face],
  split,
  {
    rintro h,
    split,
    {rintro x hx, exact (h x hx).1},
    {rintro s hs y hy, exact (h s hs).2 y hy},
  },
  {
    rintro h x hx,
    split,
    {exact h.1 x hx},
    {rintro y hy, exact h.2 x hx y hy},
  }
end

def is_face (A : set V) (F : set V) :=
F ⊆ A ∧ convex ℝ F ∧
∀ x y ∈ A, (∃ z ∈ open_segment ℝ x y, z ∈ F)
→ segment ℝ x y ⊆ F

lemma face_convex {A F: set V} (h : is_face A F) : convex ℝ F :=
begin
  simp only [is_face] at h,
  cases_matching* [_ ∧ _],
  assumption,
end

lemma face_subset {A F : set V} (h : is_face A F) : F ⊆ A :=
begin
  simp only [is_face] at h,
  cases_matching* [_ ∧ _],
  assumption,
end

lemma face_absorbs_segments {A F : set V} (h : is_face A F) :
∀ x y ∈ A, (∃ z ∈ open_segment ℝ x y, z ∈ F)
→ segment ℝ x y ⊆ F :=
begin
  simp only [is_face] at h,
  cases_matching* [_ ∧ _],
  assumption,
end

-- wrong for empty face
/- lemma polytope_face_normal {A F : set V} (h : is_polytope A) :
is_face A F → ∃ u : V, F = normal_face A u := sorry -/

/- lemma eq_inter_halfspaces_of_closed_convex
{A : set V} (Acv : convex ℝ A) (Acl : is_closed A) :
∃ S : set (V × ℝ), A = ⋂ pr ∈ S, { x : V | ⟪x, prod.fst pr⟫_ℝ ≤ pr.2 } :=
sorry -/

/- lemma closedify {A : set V} {u : V} :
∃ ε : ℝ, ε > 0 ∧ metric.ball u ε ⊆ A ↔ ∃ ε : ℝ, ε > 0 ∧ metric.closed_ball u ε ⊆ A :=
begin
  admit,
end -/

lemma closedify {A : set V} {u : V} :
(∃ (ε : ℝ) (εpos : ε > 0), metric.ball u ε ⊆ A) → ∃ (ε : ℝ) (εpos : ε > 0), metric.closed_ball u ε ⊆ A :=
begin
  rintro ⟨ε, εpos, εball⟩,
  refine ⟨ε / 2, half_pos εpos, _⟩,
  exact subset_trans (metric.closed_ball_subset_ball (half_lt_self εpos)) εball,
end

noncomputable def std_osegment_to_osegment (v w : V) :
open_segment ℝ (0 : ℝ) 1 → open_segment ℝ v w :=
begin
  intro s,
  refine ⟨(1 - s.val) • v + s.val • w, _⟩,
  rcases s with ⟨sval, sprop⟩,
  rw [open_segment_eq_Ioo (zero_lt_one : (0 : ℝ) < 1), set.mem_Ioo] at sprop,
  simp only,
  refine ⟨1 - sval, sval, _, _, _, rfl⟩,
  {
    simp only [sub_pos, sprop.2],
  },
  {
    exact sprop.1,
  },
  {
    simp only [sub_add_cancel],
  },
end

lemma mem_open_segment' {x y z : V} :
z ∈ open_segment ℝ x y ↔ ∃ c : ℝ, c ∈ set.Ioo (0 : ℝ) 1 ∧
z = c • x + (1 - c) • y :=
begin
  rw [open_segment, set.mem_set_of],
  split,
  {
    rintro ⟨a, b, ha, hb, hab, rfl⟩,
    refine ⟨a, _, _⟩,
    {
      rw [set.mem_Ioo],
      refine ⟨ha, _⟩,
      linarith,
    },
    {
      rw [←hab, add_tsub_cancel_left],
    },
  },
  {
    rintro ⟨c, hc, rfl⟩,
    rw [set.mem_Ioo] at hc,
    refine ⟨c, 1 - c, _, _, _, rfl⟩,
    {
      exact hc.1,
    },
    {
      simp only [sub_pos, hc.2],
    },
    {
      simp only [add_sub_cancel'_right],
    },
  },
end

lemma segments_closable_of_closed {A : set V}
(h : is_closed A) :
∀ x y : V, open_segment ℝ x y ⊆ A → segment ℝ x y ⊆ A :=
begin
  --rw [←is_open_compl_iff] at h,
  intros x y hseg,
  intros z hz,
  rcases hz with ⟨a, b, ha, hb, hab, rfl⟩,
  by_cases hc : a = 0 ∨ b = 0,
  {
    cases hc with hc hc,
    {
      rcases hc with rfl,
      rw [zero_add] at hab,
      rcases hab with rfl,
      rw [zero_smul, zero_add, one_smul],
      let f : ℝ → V := λ t, t • x + (1 - t) • y,
      have fc : continuous f := by continuity,
      have : filter.tendsto f (𝓝[set.Ioo 0 1] 0) (𝓝 y),
      {
        convert fc.continuous_within_at,
        simp only [f],
        simp only [zero_smul, sub_zero, zero_add, one_smul],
      },
      haveI : (𝓝[set.Ioo (0 : ℝ) 1] 0).ne_bot := left_nhds_within_Ioo_ne_bot zero_lt_one,
      refine is_closed.mem_of_tendsto h this _,
      refine filter.eventually.mp
        eventually_mem_nhds_within
        (filter.eventually_of_forall _),
      intros z hz,
      apply hseg,
      simp only [mem_open_segment', f],
      exact ⟨z, hz, rfl⟩,
    },
    {
      rcases hc with rfl,
      rw [add_zero] at hab,
      rcases hab with rfl,
      rw [zero_smul, add_zero, one_smul],
      let f : ℝ → V := λ t, t • x + (1 - t) • y,
      have fc : continuous f := by continuity,
      have : filter.tendsto f (𝓝[set.Ioo 0 1] 1) (𝓝 x),
      {
        convert fc.continuous_within_at,
        simp only [f],
        simp only [one_smul, sub_self, add_zero, zero_smul],
      },
      haveI : (𝓝[set.Ioo (0 : ℝ) 1] 1).ne_bot := right_nhds_within_Ioo_ne_bot zero_lt_one,
      refine is_closed.mem_of_tendsto h this _,
      refine filter.eventually.mp
        eventually_mem_nhds_within
        (filter.eventually_of_forall _),
      intros z hz,
      apply hseg,
      simp only [mem_open_segment', f],
      exact ⟨z, hz, rfl⟩,
    },
  },
  {
    push_neg at hc,
    replace ha := lt_of_le_of_ne ha (hc.1 ∘ eq.symm),
    replace hb := lt_of_le_of_ne hb (hc.2 ∘ eq.symm),
    apply hseg,
    simp only [open_segment],
    refine ⟨a, b, ha, hb, hab, rfl⟩,
  },
end

lemma open_segment_nonempty (x y : V) :
(open_segment ℝ x y).nonempty :=
begin
  let half : ℝ := 1 / 2,
  refine ⟨half • x + half • y, half, half, _, _, _, rfl⟩,
  all_goals {simp only [half]},
  {positivity},
  {positivity},
  {ring},
end

lemma tmp
{A : set V} {B : finset V}
(Ao : is_open A) (BA : ↑B ⊆ A) :
∃ ε : ℝ, ε > 0 ∧ ∀ x ∈ B, metric.ball x ε ⊆ A :=
begin
  induction B using finset.induction with b B bB ih,
  {
    simp only [gt_iff_lt, finset.not_mem_empty, is_empty.forall_iff, forall_const, and_true],
    exact ⟨1, zero_lt_one⟩,
  },
  {
    simp only [gt_iff_lt, finset.mem_insert, forall_eq_or_imp],
    simp only [set.insert_subset, finset.coe_insert] at BA,
    rw [metric.is_open_iff] at Ao,
    obtain ⟨ε, εpos, εball⟩ := Ao b BA.1,
    obtain ⟨δ, δpos, δball⟩ := ih BA.2,
    refine ⟨min ε δ, _, _, _⟩,
    {
      simp only [lt_min_iff],
      exact ⟨εpos, δpos⟩,
    },
    {
      exact subset_trans (metric.ball_subset_ball (min_le_left _ _)) εball,
    },
    {
      intros x xB,
      exact subset_trans (metric.ball_subset_ball (min_le_right _ _)) (δball x xB),
    },
  },
end

lemma is_open_convex_hull
{A : set V} (Ao : is_open A) :
is_open (convex_hull ℝ A) :=
begin
  rw [metric.is_open_iff],
  intros x hx,
  rw [convex_hull_eq, set.mem_set_of] at hx,
  obtain ⟨ι, t, w, z, h₁, h₂, h₃, h₄⟩ := hx,
  let f := finset.image z t,
  have hf : ↑f ⊆ A,
  {
    intros y hy,
    simp only [finset.coe_image, set.mem_image, finset.mem_coe] at hy,
    obtain ⟨v, hv, rfl⟩ := hy,
    exact h₃ v hv,
  },
  obtain ⟨ε, εpos, εball⟩ := tmp Ao hf,
  refine ⟨ε, εpos, _⟩,
  intros y hy,
  suffices hs : x ∈ convex_hull ℝ (A + {x - y}),
  {
    rw [convex_hull_add] at hs,
    simp only [convex_hull_singleton, set.add_singleton, set.image_add_right, neg_sub, set.mem_preimage, add_sub_cancel'_right] at hs,
    exact hs,
  },
  have h₃' : ∀ i : ι, i ∈ t → z i ∈ A + {x - y},
  {
    intros i it,
    simp only [set.add_singleton, set.image_add_right, neg_sub, set.mem_preimage],
    simp only [finset.mem_image, forall_exists_index, forall_apply_eq_imp_iff₂] at εball,
    apply εball i it,
    simpa only [mem_ball_iff_norm, add_sub_cancel'] using hy,
  },
  rw [convex_hull_eq, set.mem_set_of],
  refine ⟨ι, t, w, z, h₁, h₂, h₃', h₄⟩,
end