import algebra.group_power linear_algebra.prod_module algebra.module
import data.finsupp data.set.basic tactic.ring Kenny_comm_alg.temp
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, punit.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

-- (moved to temp)

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

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
--  apply finsupp.induction f,
  rcases f with ⟨S, f, hs⟩,
  existsi S.image (λ z, finsupp.single z $ f z),
  split,
  { intros g hg,
    rw finset.mem_image at hg,
    rcases hg with ⟨z, hzs, hg⟩,
    cases z with x y,
    exact ⟨x, y, f (x, y), (hs (x, y)).1 hzs, by simp [hg]⟩ },
  { rw @finset.sum_image _ _ _  _  _ _  _  (λ (z : β × γ),finsupp.single z (f z)) _,
  --finset.sum_image : ∀ {α : Type ?} {β : Type ?} {γ : Type ?} {f : α → β}
  -- [_inst_1 : add_comm_monoid β] [_inst_2 : decidable_eq α] [_inst_3 : decidable_eq γ]
  --{s : finset γ} {g : γ → α}, (∀ (x : γ), x ∈ s → ∀ (y : γ), y ∈ s → g x = g y → x = y)
  -- → finset.sum (finset.image g s) f = finset.sum s (λ (x : γ), f (g x))

    { 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,
          by_cases x = z; simp [h, hz] } },
      { simp,
        have h1 : finset.singleton z ⊆ S,
        { intros x hx,
          rw finset.mem_singleton at hx,
          rw hs, subst hx, exact hz },
        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,
          rw if_neg hnxz } } },
    { intros x hx y hy hxy,
      by_contradiction hnxy,
      have hxyx : (finsupp.single x (f x) : β × γ →₀ ℤ) x = (finsupp.single y (f y) : β × γ →₀ ℤ) x,
      { change finsupp.single x (f x) = finsupp.single y (f y) at hxy,
        rw hxy },
      rw finsupp.single_apply at hxyx,
      rw finsupp.single_apply at hxyx,
      rw if_pos rfl at hxyx,
      rw if_neg (ne.symm hnxy) at hxyx,
      rw hs at hx,
      exact hx 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 smul_aux_zero {r : α} (xy : β × γ) :
  smul_aux α β γ r xy (0:ℤ) = 0 :=
by simp [smul_aux]; refl

theorem smul_aux_add {r : α} (xy : β × γ) (m n : ℤ) :
  smul_aux α β γ r xy (m + n) = smul_aux α β γ r xy m + smul_aux α β γ r xy n :=
by simp [smul_aux]

theorem smul_aux_sub {r : α} (xy : β × γ) (m n : ℤ) :
  smul_aux α β γ r xy (m - n) = smul_aux α β γ r xy m - smul_aux α β γ r xy n :=
by simp [smul_aux]

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 smul_aux_sub,
  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 smul_aux_sub,
  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 smul_aux_sub,
  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 _ _ L₁ L₂, 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 (list.map g L),
    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

set_option pp.all true
private lemma sum_zero_index' (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 _ _ L',
        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 _ _ L',
        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 _ _ L',
        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, n • (f z.fst z.snd)))

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 _ _ L_tl,
    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 ← smul_add,
      rw ← smul_sub,
      rw hf.pair_add,
      simp,
      { dsimp, rw zero_smul },
      { dsimp, rw zero_smul },
      { dsimp, rw zero_smul },
      { intros, dsimp, rw zero_smul },
      { intros, simp, rw add_smul },
      { intros, simp [add_smul] } },
    { 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 ← smul_add,
      rw ← smul_sub,
      rw hf.add_pair,
      simp,
      { dsimp, rw zero_smul },
      { dsimp, rw zero_smul },
      { dsimp, rw zero_smul },
      { intros, dsimp, rw zero_smul },
      { intros, simp, rw add_smul },
      { intros, simp [add_smul] } },
    { 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 ← smul_sub,
      rw hf.smul_pair,
      rw hf.pair_smul,
      simp,
      { dsimp, rw zero_smul },
      { dsimp, rw zero_smul },
      { intros, simp [add_smul] } },
    { intros, dsimp, rw zero_smul },
    { intros, simp, rw add_smul },
    { intros, simp [add_smul] } }
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, dsimp, rw zero_smul },
  { intros, simp [add_smul] }
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,
    simp [smul_add, smul_smul, mul_comm],
    { dsimp, rw zero_smul },
    { dsimp, rw zero_smul },
    { rw finsupp.single_zero, refl },
    { intros, dsimp, rw zero_smul },
    { intros, simp [add_smul] },
    { intros, dsimp, rw zero_smul },
    { intros, simp [add_smul] },
    { 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'⟧ = n' • (f x' y'),
    { rw this },
    cases n',
    { induction n' with n' ih',
      { rw int.of_nat_zero,
        rw finsupp.single_zero,
        dsimp, rw zero_smul,
        exact H.zero },
      { rw int.of_nat_succ,
        rw finsupp.single_add,
        rw ← add_quot,
        rw H.add,
        rw [ih', hh],
        simp, rw add_smul,
        rw one_smul } },
    { induction n' with n' ih',
      { rw int.neg_succ_of_nat_eq,
        rw finsupp.single_neg,
        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 [add_smul] } },
    { dsimp, rw zero_smul },
    { intros, dsimp, rw zero_smul },
    { intros, simp [add_smul] },
    { 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_iff.2 ⟨add_tprod, add_tprod⟩,
  pair_add  := λ x y z, prod.ext_iff.2 ⟨tprod_add, tprod_add⟩,
  smul_pair := λ r x y, prod.ext_iff.2 ⟨smul_tprod, smul_tprod⟩ ,
  pair_smul := λ r x y, prod.ext_iff.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

theorem tprod_map.linear : is_linear_map (tprod_map hf hg) :=
universal_property.factor_linear _

theorem tprod_map.commutes (x : β) (y : β₁) :
  tprod_map hf hg (x ⊗ₛ y) = f x ⊗ₛ g y :=
universal_property.factor_commutes
  (tprod_map._proof_1 hf hg) x y

end tensor_product

def 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] }


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.shapes.reflexive
import Mathlib.category_theory.limits.preserves.shapes.equalizers
import Mathlib.category_theory.limits.preserves.limits
import Mathlib.category_theory.monad.adjunction
import Mathlib.PostPort

universes v₁ u₁

namespace Mathlib

/-!
# Special coequalizers associated to a monad

Associated to a monad `T : C ⥤ C` we have important coequalizer constructions:
Any algebra is a coequalizer (in the category of algebras) of free algebras. Furthermore, this
coequalizer is reflexive.
In `C`, this cofork diagram is a split coequalizer (in particular, it is still a coequalizer).
This split coequalizer is known as the Beck coequalizer (as it features heavily in Beck's
monadicity theorem).
-/

namespace category_theory

namespace monad

/-!
Show that any algebra is a coequalizer of free algebras.
-/

/-- The top map in the coequalizer diagram we will construct. -/
@[simp] theorem free_coequalizer.top_map_f {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (X : algebra T) : algebra.hom.f (free_coequalizer.top_map X) = functor.map T (algebra.a X) :=
  Eq.refl (functor.map T (algebra.a X))

/-- The bottom map in the coequalizer diagram we will construct. -/
def free_coequalizer.bottom_map {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (X : algebra T) : functor.obj (free T) (functor.obj T (algebra.A X)) ⟶ functor.obj (free T) (algebra.A X) :=
  algebra.hom.mk (nat_trans.app μ_ (algebra.A X))

/-- The cofork map in the coequalizer diagram we will construct. -/
def free_coequalizer.π {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (X : algebra T) : functor.obj (free T) (algebra.A X) ⟶ X :=
  algebra.hom.mk (algebra.a X)

theorem free_coequalizer.condition {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (X : algebra T) : free_coequalizer.top_map X ≫ free_coequalizer.π X = free_coequalizer.bottom_map X ≫ free_coequalizer.π X :=
  algebra.hom.ext (free_coequalizer.top_map X ≫ free_coequalizer.π X)
    (free_coequalizer.bottom_map X ≫ free_coequalizer.π X) (Eq.symm (algebra.assoc X))

protected instance free_coequalizer.bottom_map.category_theory.is_reflexive_pair {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (X : algebra T) : is_reflexive_pair (free_coequalizer.top_map X) (free_coequalizer.bottom_map X) :=
  is_reflexive_pair.mk' (functor.map (free T) (nat_trans.app η_ (algebra.A X)))
    (algebra.hom.ext (functor.map (free T) (nat_trans.app η_ (algebra.A X)) ≫ free_coequalizer.top_map X) 𝟙
      (id
        (eq.mpr
          (id
            (Eq._oldrec (Eq.refl (functor.map T (nat_trans.app η_ (algebra.A X)) ≫ functor.map T (algebra.a X) = 𝟙))
              (Eq.symm (functor.map_comp T (nat_trans.app η_ (algebra.A X)) (algebra.a X)))))
          (eq.mpr
            (id
              (Eq._oldrec (Eq.refl (functor.map T (nat_trans.app η_ (algebra.A X) ≫ algebra.a X) = 𝟙)) (algebra.unit X)))
            (eq.mpr (id (Eq._oldrec (Eq.refl (functor.map T 𝟙 = 𝟙)) (functor.map_id T (algebra.A X)))) (Eq.refl 𝟙))))))
    (algebra.hom.ext (functor.map (free T) (nat_trans.app η_ (algebra.A X)) ≫ free_coequalizer.bottom_map X) 𝟙
      (right_unit (functor.obj 𝟭 (algebra.A X))))

/--
Construct the Beck cofork in the category of algebras. This cofork is reflexive as well as a
coequalizer.
-/
@[simp] theorem beck_algebra_cofork_X {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (X : algebra T) : limits.cocone.X (beck_algebra_cofork X) = X :=
  Eq.refl X

/--
The cofork constructed is a colimit. This shows that any algebra is a (reflexive) coequalizer of
free algebras.
-/
def beck_algebra_coequalizer {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (X : algebra T) : limits.is_colimit (beck_algebra_cofork X) :=
  limits.cofork.is_colimit.mk' (beck_algebra_cofork X)
    fun (s : limits.cofork (free_coequalizer.top_map X) (free_coequalizer.bottom_map X)) =>
      { val :=
          algebra.hom.mk
            (nat_trans.app η_ (algebra.A (limits.cocone.X (beck_algebra_cofork X))) ≫ algebra.hom.f (limits.cofork.π s)),
        property := sorry }

/-- The Beck cofork is a split coequalizer. -/
def beck_split_coequalizer {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (X : algebra T) : is_split_coequalizer (functor.map T (algebra.a X)) (nat_trans.app μ_ (algebra.A X)) (algebra.a X) :=
  is_split_coequalizer.mk (nat_trans.app η_ (algebra.A X)) (nat_trans.app η_ (functor.obj T (algebra.A X))) sorry
    (algebra.unit X) sorry sorry

/-- This is the Beck cofork. It is a split coequalizer, in particular a coequalizer. -/
@[simp] theorem beck_cofork_X {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (X : algebra T) : limits.cocone.X (beck_cofork X) = algebra.A X :=
  Eq.refl (algebra.A X)

/-- The Beck cofork is a coequalizer. -/
def beck_coequalizer {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (X : algebra T) : limits.is_colimit (beck_cofork X) :=
  is_split_coequalizer.is_coequalizer (beck_split_coequalizer X)


import .affnKcoord_transforms

abbreviation K := ℚ
def dim := 1
def first_id := 1
def std_fm : fm K dim (λi,first_id) := fm.base dim first_id
def std_sp := mk_space std_fm
#check std_fm

def p1 : point std_sp :=
  mk_point std_sp ⟨[1], rfl⟩

def prod2_point : point (mk_prod_spc std_sp std_sp) :=
  mk_point_prod p1 p1

example : (add_maps (λ (i : fin dim), first_id) (λ (i : fin dim), first_id))= (λ i : fin 2 , first_id)
  := begin
    intros,
    simp * ,
    refl,
  end

  #check eq.rec_on

@[reducible, simp]
def fmtest : fm K (2) (λi, first_id) :=--(add_maps (λ (i : fin dim), first_id) (λ (i : fin dim), first_id)) :=--(λ i, first_id) :=
  let pf:(add_maps (λ (i : fin dim), first_id) (λ (i : fin dim), first_id))=(λi, first_id)
    := begin
    intros,
    simp * ,
    end in
    (eq.rec_on pf prod2_point.space.fm)
  /-begin
    let h : fm K (2) (λi, first_id) :=
      eq.rec_on
  end-/
  /-
  (eq.rec_on begin

  end prod2_point.space.fm : fm K (2) (λi, first_id))
-/
def prod3_point : point _ :=
  mk_point_prod prod2_point p1

def v1 : vectr std_sp :=
  mk_vectr std_sp ⟨[1],rfl⟩

def prod2_vectr :=
  mk_vectr_prod v1 v1

def prod3_vectr :=
  mk_vectr_prod prod2_vectr v1

def prod3_vectr_alt :=
  mk_vectr_prod v1 prod2_vectr

#check prod3_vectr +ᵥ prod3_point --works!
#check prod3_vectr +ᵥ prod3_vectr_alt -- same space, BUT NOT definitionally equal

--construct space directly
def prod3_spc := mk_prod_spc (mk_prod_spc std_sp std_sp) std_sp

def my_pt : point prod3_spc := mk_point prod3_spc ⟨[1,1,1],rfl⟩

def u1 : vectr prod3_spc := mk_vectr prod3_spc ⟨[2,0,0],rfl⟩
def u2 : vectr prod3_spc := mk_vectr prod3_spc ⟨[0,2,0],rfl⟩
def u3 : vectr prod3_spc := mk_vectr prod3_spc ⟨[0,0,2],rfl⟩

def prod3_der_fm : fm K (3) (add_maps (add_maps ↑first_id ↑first_id) ↑first_id)
    := fm.deriv my_pt.coords (λi, match i.1 with
    | 0 := u1.coords
    | 1 := u2.coords
    | _ := u3.coords
    end) sorry sorry prod3_spc.fm

def prod3_der_sp : spc K prod3_der_fm := mk_space prod3_der_fm

def der_pt : point prod3_der_sp :=  mk_point _ ⟨[1,1,1],rfl⟩

-- get coords of der_pt in the prod3_spc coordinate system?

def der_to_p3 := prod3_der_sp.fm_tr prod3_spc

#check der_to_p3.transform_point der_pt
#eval der_to_p3.transform_point der_pt

--error, noncomputable!
def der_pt_in_p3 : point prod3_spc := der_to_p3.transform_point der_pt
--OK
noncomputable def nc_der_pt_in_p3 : point prod3_spc := der_to_p3.transform_point der_pt

#check der_pt -ᵥ my_pt

--still works
#check prod3_point -ᵥ my_pt


/-
Copyright (c) 2022 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import analysis.complex.upper_half_plane.basic
import analysis.convex.contractible
import analysis.convex.normed
import analysis.convex.complex
import analysis.complex.re_im_topology
import topology.homotopy.contractible
import geometry.manifold.mfderiv
import geometry.manifold.cont_mdiff_mfderiv

/-!
# Topology on the upper half plane

In this file we introduce a `topological_space` structure on the upper half plane and provide
various instances.
-/

noncomputable theory
open set filter function topological_space complex
open_locale filter topology upper_half_plane manifold

namespace upper_half_plane

instance : topological_space ℍ := subtype.topological_space

lemma open_embedding_coe : open_embedding (coe : ℍ → ℂ) :=
is_open.open_embedding_subtype_coe $ is_open_lt continuous_const complex.continuous_im

lemma embedding_coe : embedding (coe : ℍ → ℂ) := embedding_subtype_coe
lemma continuous_coe : continuous (coe : ℍ → ℂ) := embedding_coe.continuous

lemma continuous_re : continuous re := complex.continuous_re.comp continuous_coe
lemma continuous_im : continuous im := complex.continuous_im.comp continuous_coe

instance : topological_space.second_countable_topology ℍ :=
topological_space.subtype.second_countable_topology _ _

instance : t3_space ℍ := subtype.t3_space
instance : normal_space ℍ := normal_space_of_t3_second_countable ℍ

instance : contractible_space ℍ :=
(convex_halfspace_im_gt 0).contractible_space ⟨I, one_pos.trans_eq I_im.symm⟩

instance : loc_path_connected_space ℍ :=
loc_path_connected_of_is_open $ is_open_lt continuous_const complex.continuous_im

instance : noncompact_space ℍ :=
begin
  refine ⟨λ h, _⟩,
  have : is_compact (complex.im ⁻¹' Ioi 0), from is_compact_iff_is_compact_univ.2 h,
  replace := this.is_closed.closure_eq,
  rw [closure_preimage_im, closure_Ioi, set.ext_iff] at this,
  exact absurd ((this 0).1 left_mem_Ici) (lt_irrefl _)
end

instance : locally_compact_space ℍ := open_embedding_coe.locally_compact_space

instance upper_half_plane.charted_space : charted_space ℂ ℍ :=
upper_half_plane.open_embedding_coe.singleton_charted_space

instance upper_half_plane.smooth_manifold_with_corners : smooth_manifold_with_corners 𝓘(ℂ) ℍ :=
upper_half_plane.open_embedding_coe.singleton_smooth_manifold_with_corners 𝓘(ℂ)

/-- The inclusion map `ℍ → ℂ` is a smooth map of manifolds. -/
lemma smooth_coe : smooth 𝓘(ℂ) 𝓘(ℂ) (coe : ℍ → ℂ) :=
λ x, cont_mdiff_at_ext_chart_at

/-- The inclusion map `ℍ → ℂ` is a differentiable map of manifolds. -/
lemma mdifferentiable_coe : mdifferentiable 𝓘(ℂ) 𝓘(ℂ) (coe : ℍ → ℂ) :=
smooth_coe.mdifferentiable

end upper_half_plane


-- by Johan Commelin
import tactic
import tactic.find
import init.function
import algebra.group
import group_theory.subgroup

open function

section five_lemma

universes u

local notation `im` := set.range

variables {A₁ B₁ C₁ D₁ E₁ : Type u}
variables {A₂ B₂ C₂ D₂ E₂ : Type u}

variables  [group A₁]    {f₁ : A₁ → B₁}   [group B₁]    {g₁ : B₁ → C₁}   [group C₁]    {h₁ : C₁ → D₁}   [group D₁]    {i₁ : D₁ → E₁}   [group E₁]
variables {j : A₁ → A₂}                  {k : B₁ → B₂}                  {l : C₁ → C₂}                  {m : D₁ → D₂}                  {n : E₁ → E₂}
variables  [group A₂]    {f₂ : A₂ → B₂}   [group B₂]    {g₂ : B₂ → C₂}   [group C₂]    {h₂ : C₂ → D₂}   [group D₂]    {i₂ : D₂ → E₂}   [group E₂]

variables [is_group_hom f₁] [is_group_hom g₁] [is_group_hom h₁] [is_group_hom i₁]
variables [is_group_hom f₂] [is_group_hom g₂] [is_group_hom h₂] [is_group_hom i₂]
variables [is_group_hom j] [is_group_hom k] [is_group_hom l] [is_group_hom m] [is_group_hom n]

open is_group_hom

lemma four_lemma₁
(com₁ : k ∘ f₁ = f₂ ∘ j)
(com₂ : l ∘ g₁ = g₂ ∘ k)
(com₃ : m ∘ h₁ = h₂ ∘ l)
(eB₁ : im f₁ = ker g₁)
(eC₁ : im g₁ = ker h₁)
(eB₂ : im f₂ = ker g₂)
(eC₂ : im g₂ = ker h₂)
(hj : surjective j)
(hk : injective k)
(hm : injective m)
: injective l :=
begin
 have := one f₁, have := one g₁, have := one h₁,
 have := one f₂, have := one g₂, have := one h₂,
 have := one j, have := one k, have := one l, have := one m,
 apply inj_of_trivial_ker l,
 apply set.ext,
 intro x,
 split, { -- x ∈ ker l → x = 1
  intro hx,
  rw mem_ker at hx,
  simp,
  have : (h₂ ∘ l) x = 1,                     unfold comp, cc,
  have : (m ∘ h₁) x = 1,                     cc,
  have : m (h₁ x) = 1,                       apply_assumption,
  have : h₁ x = 1,                           apply_assumption, cc,
  have : x ∈ ker h₁,                         rwa mem_ker h₁,
  have : x ∈ im g₁,                          cc,
  have : ∃ y : B₁, g₁ y = x,                 apply_assumption,
  cases this with y,
  have : (l ∘ g₁) y = 1,                     unfold comp, cc,
  have : (g₂ ∘ k) y = 1,                     cc,
  have : g₂ (k y) = 1,                       apply_assumption,
  have : k y ∈ ker g₂,                       rwa mem_ker g₂,
  have : k y ∈ im f₂,                        cc,
  have : ∃ z : A₂, f₂ z = k y,               apply_assumption,
  cases this with z,
  have : ∃ w : A₁, j w = z,                  apply_assumption,
  cases this with w,
  have : (f₂ ∘ j) w = k y,                   unfold comp, cc,
  have : (k ∘ f₁) w = k y,                   cc,
  have : k (f₁ w) = k y,                     apply_assumption,
  have H : f₁ w = y,                         apply_assumption, apply_assumption,
  have : f₁ w ∈ im f₁,                       apply set.mem_range_self,
  have : y ∈ im f₁, rw ←H,                   apply_assumption,
  have : y ∈ ker g₁,                         cc,
  have : g₁ y = 1,                           rwa ←mem_ker g₁,
  have : x = 1,                              cc,
  apply_assumption
 }, { -- x = 1 → x ∈ ker l
  intro hx,
  simp at hx,
  rw is_group_hom.mem_ker,
  cc
 }
end

lemma four_lemma₂
(com₂ : l ∘ g₁ = g₂ ∘ k)
(com₃ : m ∘ h₁ = h₂ ∘ l)
(com₄ : n ∘ i₁ = i₂ ∘ m)
(eC₁ : im g₁ = ker h₁)
(eD₁ : im h₁ = ker i₁)
(eC₂ : im g₂ = ker h₂)
(eD₂ : im h₂ = ker i₂)
(hk : surjective k)
(hm : surjective m)
(hn : injective n)
: surjective l :=
begin
 have := one g₁, have := one h₁, have := one i₁,
 have := one g₂, have := one h₂, have := one i₂,
 have := one k, have := one l, have := one m, have := one n,
 rw ←set.range_iff_surjective,
 apply set.ext,
 intro x,
 split, { -- x ∈ im l → x ∈ set.univ
  intro hx,
  simp,
 }, { -- x ∈ set.univ → x ∈ im l
  intros,
  have : h₂ x ∈ im h₂,                       apply set.mem_range_self,
  have : h₂ x ∈ ker i₂,                      cc,
  have : i₂ (h₂ x) = 1,                      rwa ←(mem_ker i₂),
  have : ∃ y : D₁, m y = h₂ x,               apply_assumption,
  cases this with y,
  have : i₂ (m y) = 1,                       cc,
  have : (i₂ ∘ m) y = 1,                     unfold comp, cc,
  have : (n ∘ i₁) y = 1,                     cc,
  have : n (i₁ y) = 1,                       apply_assumption,
  have : i₁ y = 1,                           apply_assumption, cc,
  have : y ∈ ker i₁,                         rwa mem_ker i₁,
  have : y ∈ im h₁,                          cc,
  have : ∃ z : C₁, h₁ z = y,                 apply_assumption,
  cases this with z,
  have : m (h₁ z) = h₂ x,                    cc,
  have : (m ∘ h₁) z = h₂ x,                  apply_assumption,
  have : (h₂ ∘ l) z = h₂ x,                  cc,
  have H : h₂ (l z) = h₂ x,                  apply_assumption,
  have : (h₂ (l z))⁻¹ * (h₂ x) = 1,          rw H, simp,
  have invh₂ : h₂ (l z)⁻¹ = (h₂ (l z))⁻¹,    apply inv,
  have : h₂ ((l z)⁻¹ * x) = 1,               rw mul h₂, rwa invh₂,
  have : (l z)⁻¹ * x ∈ ker h₂,               rwa mem_ker h₂,
  have : (l z)⁻¹ * x ∈ im g₂,                cc,
  have : ∃ w : B₂, g₂ w = (l z)⁻¹ * x,       apply_assumption,
  cases this with w,
  have : ∃ v : B₁, k v = w,                  apply_assumption,
  cases this with v,
  have : g₂ (k v) = (l z)⁻¹ * x,             cc,
  have : (g₂ ∘ k) v = (l z)⁻¹ * x,           apply_assumption,
  have : (l ∘ g₁) v = (l z)⁻¹ * x,           cc,
  have H' : l (g₁ v) = (l z)⁻¹ * x,          apply_assumption,
  have : (l z) * l (g₁ v) = x,               rw H', simpa [mul_assoc],
  have : l (z * g₁ v) = x,                   rwa mul l,
  have : l (z * g₁ v) ∈ im l,                apply set.mem_range_self,
  cc
 }
end

lemma five_lemma
(com₁ : k ∘ f₁ = f₂ ∘ j)
(com₂ : l ∘ g₁ = g₂ ∘ k)
(com₃ : m ∘ h₁ = h₂ ∘ l)
(com₄ : n ∘ i₁ = i₂ ∘ m)
(eB₁ : im f₁ = ker g₁)
(eC₁ : im g₁ = ker h₁)
(eD₁ : im h₁ = ker i₁)
(eB₂ : im f₂ = ker g₂)
(eC₂ : im g₂ = ker h₂)
(eD₂ : im h₂ = ker i₂)
(hj : surjective j)
(hk : bijective k)
(hm : bijective m)
(hn : injective n)
: bijective l :=
begin
 split,
 apply four_lemma₁ com₁ com₂ com₃ eB₁ eC₁ eB₂ eC₂ hj hk.1 hm.1,
 apply four_lemma₂ com₂ com₃ com₄ eC₁ eD₁ eC₂ eD₂ hk.2 hm.2 hn,
end

#print is_subgroup.trivial

lemma four_lemma_KB₁
(com₁ : k ∘ f₁ = f₂ ∘ j)
(com₂ : l ∘ g₁ = g₂ ∘ k)
(com₃ : m ∘ h₁ = h₂ ∘ l)
(eB₁ : im f₁ = ker g₁)
(eC₁ : im g₁ = ker h₁)
(eB₂ : im f₂ = ker g₂)
(eC₂ : im g₂ = ker h₂)
(hj : surjective j)
(hk : injective k)
(hm : injective m)
: injective l :=
begin
 have := one f₁, have := one g₁, have := one h₁,
 have := one f₂, have := one g₂, have := one h₂,
 have := one j, have := one k, have := one l, have := one m,
 apply inj_of_trivial_ker l,
 apply set.ext,
 intro x,
 split, { show x ∈ ker l → x ∈ {(1 : C₁)}, -- I like my style a bit better
  intro hx, -- brackets are good though -- they make the tactic state less complex
  simp,
  rw mem_ker at hx,
  have : (h₂ ∘ l) x = 1,                     unfold comp, cc,
  have : (m ∘ h₁) x = 1,                     cc,
  have : m (h₁ x) = 1,                       apply_assumption,
  have : h₁ x = 1,                           apply_assumption, cc,
  have : x ∈ ker h₁,                         rwa mem_ker h₁,
  have : x ∈ im g₁,                          cc,
  have : ∃ y : B₁, g₁ y = x,                 apply_assumption,
  cases this with y,
  have : (l ∘ g₁) y = 1,                     unfold comp, cc,
  have : (g₂ ∘ k) y = 1,                     cc,
  have : g₂ (k y) = 1,                       apply_assumption,
  have : k y ∈ ker g₂,                       rwa mem_ker g₂,
  have : k y ∈ im f₂,                        cc,
  have : ∃ z : A₂, f₂ z = k y,               apply_assumption,
  cases this with z,
  have : ∃ w : A₁, j w = z,                  apply_assumption,
  cases this with w,
  have : (f₂ ∘ j) w = k y,                   unfold comp, cc,
  have : (k ∘ f₁) w = k y,                   cc,
  have : k (f₁ w) = k y,                     apply_assumption,
  have H : f₁ w = y,                         apply_assumption, apply_assumption,
  have : f₁ w ∈ im f₁,                       apply set.mem_range_self,
  have : y ∈ im f₁, rw ←H,                   apply_assumption,
  have : y ∈ ker g₁,                         cc,
  have : g₁ y = 1,                           rwa ←mem_ker g₁,
  have : x = 1,                              cc,
  apply_assumption
 }, { -- x = 1 → x ∈ ker l
  intro hx,
  simp at hx,
  rw is_group_hom.mem_ker,
  cc
 }
end

#check @five_lemma

end five_lemma


import tactic
import tactic.slim_check

mk_simp_attribute props ""
variables {α : Type*}
@[props] def is_reflexive (r : α → α → Prop) : Prop := ∀ a, r a a
@[props] def is_irreflexive (r : α → α → Prop) : Prop := ∀ a, ¬ r a a
@[props] def is_symmetric (r : α → α → Prop) : Prop := ∀ a b, r a b → r b a
@[props] def is_transitive (r : α → α → Prop) : Prop := ∀ a b c, r a b → r b c → r a c
@[props] def is_asymmetric (r : α → α → Prop) : Prop := ∀ a b, r a b → ¬ r b a
@[props] def is_total' (r : α → α → Prop) : Prop := ∀ a b, r a b ∨ r b a
@[props] def is_antisymmetric (r : α → α → Prop) : Prop := ∀ a b, r a b → r b a → a = b
@[props] def is_partial_equivalence (r : α → α → Prop) : Prop := is_symmetric r ∧ is_transitive r
@[props] def is_trichotomous' (r : α → α → Prop) : Prop := ∀ a b, r a b ∨ a = b ∨ r b a
@[props] def is_preorder' (r : α → α → Prop) : Prop := is_reflexive r ∧ is_transitive r
@[props] def is_total_preorder' (r : α → α → Prop) : Prop := is_transitive r ∧ is_total' r
@[props] def is_partial_order' (r : α → α → Prop) : Prop := is_preorder' r ∧ is_antisymmetric r
@[props] def is_linear_order' (r : α → α → Prop) : Prop := is_partial_order' r ∧ is_total' r
@[props] def is_equivalence (r : α → α → Prop) : Prop := is_preorder' r ∧ is_symmetric r
@[props] def is_strict_order' (r : α → α → Prop) : Prop := is_irreflexive r ∧ is_transitive r
-- def is_strict_weak_order' (r : α → α → Prop) : Prop := is_strict_order' r ∧ is_incomp_trans' r
-- def is_strict_total_order' (r : α → α → Prop) : Prop := is_trichotomous' r ∧ is_strict_weak_order' r

open tactic expr sum

meta def props : list (name × string) :=
[(`is_reflexive, "reflexive"),
 (`is_irreflexive, "irreflexive"),
 (`is_symmetric, "symmetric"),
 (`is_transitive, "transitive"),
 (`is_asymmetric, "asymmetric"),
 (`is_total', "total"),
 (`is_antisymmetric, "antisymmetric"),
 (`is_trichotomous', "trichotomous")]

meta def omega_that_fails_on_false : tactic unit :=
done <|> all_goals' (target >>= λ tgt, guard (tgt.const_name ≠ `false) >> interactive.omega [])

meta def try_slim_check (cfg : slim_check.slim_check_cfg) :
  tactic (option string) := do
result ← try_or_report_error (interactive.slim_check {quiet := tt, ..cfg}),
inr n ← return result | return none,
when (n.starts_with "Failed to create a") failed,
return (some n)

meta def finds_slim_check_example (cfg : slim_check.slim_check_cfg := {}) : tactic unit := do
n ← try_slim_check cfg,
guard n.is_some

meta def test_init : tactic unit := do
  t ← target,
  let ⟨f, args⟩ := t.get_app_fn_args,
  let prop_name := f.const_name,
  let rel_name := args.ilast.const_name,
  dsimp_target none [prop_name, rel_name] {fail_if_unchanged := ff}

meta def test_init_main (t : expr) (R : name) : tactic expr := do
  t.dsimp {} ff [`props] [simp_arg_type.expr $ expr.const R []]

meta def test_main (t : expr) (cfg : slim_check.slim_check_cfg := {}) : tactic (ℕ ⊕ string) := do
-- trace t,
  let not_t := const `not [] t,
  retrieve (tactic.assert `this t >> focus1 (tidy >> omega_that_fails_on_false >> done) >> return (inl 0)) <|>
  retrieve (tactic.assert `this not_t >> focus1 (tidy >> omega_that_fails_on_false >> done) >> return (inl 1)) <|>
  retrieve (do tactic.assert `this t, some error ← focus1 (try_slim_check cfg), return (inr error)) <|>
  return (inl 2)

meta def test_core (cfg : slim_check.slim_check_cfg := {}) : tactic (ℕ ⊕ string) := do
  test_init,
  t ← target,
  r ← test_main t cfg,
  when (r = inl 0) (get_local `this >>= exact),
  return r

meta def test (cfg : slim_check.slim_check_cfg := {}) : tactic unit := do
  result ← test_core cfg,
  when (result = inl 0) (trace "succeeded!"),
  when (result = inl 1) (trace "proved the negation!"),
  when (result.is_right) (trace "found a counterexample!" >> trace result.get_right.iget),
  when (result = inl 2) (trace "couldn't make progress."),
  skip

meta def test_all (R : name) (cfg : slim_check.slim_check_cfg := {}) : tactic unit :=
props.mmap' $ λ ⟨prop_nm, prop_str⟩, retrieve $ do {
  -- let t : expr := (const rel [level.zero]) (const `nat []) (const R []),
  rel ← mk_const R,
  prop ← mk_const prop_nm,
  t ← to_expr ``(%%prop %%rel),
  t ← test_init_main t R,
  result ← test_main t cfg,
  -- trace result,
  when (result = inl 0) (trace!"{R} is     {prop_str}!"),
  when (result = inl 1) (trace!"{R} is not {prop_str}!"),
  when (result.is_right) (trace!"{R} is not {prop_str}!"),
  when (result = inl 2) (trace!"Cannot resolve whether {R} is {prop_str}.") }

@[user_attribute] meta def test_attr : user_attribute :=
{ name := `test,
  descr := "Automatically tests whether a relation `ℕ → ℕ → Prop` satisfies some properties.",
  after_set := some $
    λ R _ _, do test_all R }

-- def dummy : false ↔ 0 = 1 := by simp

@[test]
def R (n m : ℕ) : Prop :=
n < m ∨ n > 10

example : is_transitive R :=
by { test, sorry }


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.natural_isomorphism
import data.equiv.basic

/-!
# Full and faithful functors

We define typeclasses `full` and `faithful`, decorating functors.

Use `F.map_injective` to retrieve the fact that `F.map` is injective when `[faithful F]`,
and `F.preimage` to obtain preimages of morphisms when `[full F]`.

We prove some basic "cancellation" lemmas for full and/or faithful functors.

See `category_theory.equivalence` for the fact that a functor is an equivalence if and only if
it is fully faithful and essentially surjective.

-/

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

namespace category_theory

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

/--
A functor `F : C ⥤ D` is full if for each `X Y : C`, `F.map` is surjective.
In fact, we use a constructive definition, so the `full F` typeclass contains data,
specifying a particular preimage of each `f : F.obj X ⟶ F.obj Y`.

See https://stacks.math.columbia.edu/tag/001C.
-/
class full (F : C ⥤ D) :=
(preimage : ∀ {X Y : C} (f : (F.obj X) ⟶ (F.obj Y)), X ⟶ Y)
(witness' : ∀ {X Y : C} (f : (F.obj X) ⟶ (F.obj Y)), F.map (preimage f) = f . obviously)

restate_axiom full.witness'
attribute [simp] full.witness

/--
A functor `F : C ⥤ D` is faithful if for each `X Y : C`, `F.map` is injective.

See https://stacks.math.columbia.edu/tag/001C.
-/
class faithful (F : C ⥤ D) : Prop :=
(map_injective' [] : ∀ {X Y : C}, function.injective (@functor.map _ _ _ _ F X Y) . obviously)

restate_axiom faithful.map_injective'

namespace functor
lemma map_injective (F : C ⥤ D) [faithful F] {X Y : C} :
  function.injective $ @functor.map _ _ _ _ F X Y :=
faithful.map_injective F

/-- The specified preimage of a morphism under a full functor. -/
def preimage (F : C ⥤ D) [full F] {X Y : C} (f : F.obj X ⟶ F.obj Y) : X ⟶ Y :=
full.preimage.{v₁ v₂} f
@[simp] lemma image_preimage (F : C ⥤ D) [full F] {X Y : C} (f : F.obj X ⟶ F.obj Y) :
  F.map (preimage F f) = f :=
by unfold preimage; obviously
end functor

variables {F : C ⥤ D} [full F] [faithful F] {X Y Z : C}

@[simp] lemma preimage_id : F.preimage (𝟙 (F.obj X)) = 𝟙 X :=
F.map_injective (by simp)
@[simp] lemma preimage_comp (f : F.obj X ⟶ F.obj Y) (g : F.obj Y ⟶ F.obj Z) :
  F.preimage (f ≫ g) = F.preimage f ≫ F.preimage g :=
F.map_injective (by simp)
@[simp] lemma preimage_map (f : X ⟶ Y) :
  F.preimage (F.map f) = f :=
F.map_injective (by simp)

/-- If `F : C ⥤ D` is fully faithful, every isomorphism `F.obj X ≅ F.obj Y` has a preimage. -/
def preimage_iso (f : (F.obj X) ≅ (F.obj Y)) : X ≅ Y :=
{ hom := F.preimage f.hom,
  inv := F.preimage f.inv,
  hom_inv_id' := F.map_injective (by simp),
  inv_hom_id' := F.map_injective (by simp), }

@[simp] lemma preimage_iso_hom (f : (F.obj X) ≅ (F.obj Y)) :
  (preimage_iso f).hom = F.preimage f.hom := rfl
@[simp] lemma preimage_iso_inv (f : (F.obj X) ≅ (F.obj Y)) :
  (preimage_iso f).inv = F.preimage (f.inv) := rfl
@[simp] lemma preimage_iso_map_iso (f : X ≅ Y) : preimage_iso (F.map_iso f) = f :=
by tidy

variables (F)

/--
If the image of a morphism under a fully faithful functor in an isomorphism,
then the original morphisms is also an isomorphism.
-/
lemma is_iso_of_fully_faithful (f : X ⟶ Y) [is_iso (F.map f)] : is_iso f :=
⟨⟨F.preimage (inv (F.map f)),
  ⟨F.map_injective (by simp), F.map_injective (by simp)⟩⟩⟩

/-- If `F` is fully faithful, we have an equivalence of hom-sets `X ⟶ Y` and `F X ⟶ F Y`. -/
def equiv_of_fully_faithful {X Y} : (X ⟶ Y) ≃ (F.obj X ⟶ F.obj Y) :=
{ to_fun := λ f, F.map f,
  inv_fun := λ f, F.preimage f,
  left_inv := λ f, by simp,
  right_inv := λ f, by simp }

@[simp]
lemma equiv_of_fully_faithful_apply {X Y : C} (f : X ⟶ Y) :
  equiv_of_fully_faithful F f = F.map f := rfl
@[simp]
lemma equiv_of_fully_faithful_symm_apply {X Y} (f : F.obj X ⟶ F.obj Y) :
  (equiv_of_fully_faithful F).symm f = F.preimage f := rfl

end category_theory

namespace category_theory

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

instance full.id : full (𝟭 C) :=
{ preimage := λ _ _ f, f }

instance faithful.id : faithful (𝟭 C) := by obviously

variables {D : Type u₂} [category.{v₂} D] {E : Type u₃} [category.{v₃} E]
variables (F F' : C ⥤ D) (G : D ⥤ E)

instance faithful.comp [faithful F] [faithful G] : faithful (F ⋙ G) :=
{ map_injective' := λ _ _ _ _ p, F.map_injective (G.map_injective p) }

lemma faithful.of_comp [faithful $ F ⋙ G] : faithful F :=
{ map_injective' := λ X Y, (F ⋙ G).map_injective.of_comp }

section
variables {F F'}

/-- If `F` is full, and naturally isomorphic to some `F'`, then `F'` is also full. -/
def full.of_iso [full F] (α : F ≅ F') : full F' :=
{ preimage := λ X Y f, F.preimage ((α.app X).hom ≫ f ≫ (α.app Y).inv),
  witness' := λ X Y f, by simp [←nat_iso.naturality_1 α], }

lemma faithful.of_iso [faithful F] (α : F ≅ F') : faithful F' :=
{ map_injective' := λ X Y f f' h, F.map_injective
  (by rw [←nat_iso.naturality_1 α.symm, h, nat_iso.naturality_1 α.symm]) }
end

variables {F G}

lemma faithful.of_comp_iso {H : C ⥤ E} [ℋ : faithful H] (h : F ⋙ G ≅ H) : faithful F :=
@faithful.of_comp _ _ _ _ _ _ F G (faithful.of_iso h.symm)

alias faithful.of_comp_iso ← category_theory.iso.faithful_of_comp

-- We could prove this from `faithful.of_comp_iso` using `eq_to_iso`,
-- but that would introduce a cyclic import.
lemma faithful.of_comp_eq {H : C ⥤ E} [ℋ : faithful H] (h : F ⋙ G = H) : faithful F :=
@faithful.of_comp _ _ _ _ _ _ F G (h.symm ▸ ℋ)

alias faithful.of_comp_eq ← eq.faithful_of_comp

variables (F G)

/-- “Divide” a functor by a faithful functor. -/
protected def faithful.div (F : C ⥤ E) (G : D ⥤ E) [faithful G]
  (obj : C → D) (h_obj : ∀ X, G.obj (obj X) = F.obj X)
  (map : Π {X Y}, (X ⟶ Y) → (obj X ⟶ obj Y))
  (h_map : ∀ {X Y} {f : X ⟶ Y}, G.map (map f) == F.map f) :
  C ⥤ D :=
{ obj := obj,
  map := @map,
  map_id' :=
  begin
    assume X,
    apply G.map_injective,
    apply eq_of_heq,
    transitivity F.map (𝟙 X), from h_map,
    rw [F.map_id, G.map_id, h_obj X]
  end,
  map_comp' :=
  begin
    assume X Y Z f g,
    apply G.map_injective,
    apply eq_of_heq,
    transitivity F.map (f ≫ g), from h_map,
    rw [F.map_comp, G.map_comp],
    congr' 1;
      try { exact (h_obj _).symm };
      exact h_map.symm
  end }

-- This follows immediately from `functor.hext` (`functor.hext h_obj @h_map`),
-- but importing `category_theory.eq_to_hom` causes an import loop:
-- category_theory.eq_to_hom → category_theory.opposites →
-- category_theory.equivalence → category_theory.fully_faithful
lemma faithful.div_comp (F : C ⥤ E) [faithful F] (G : D ⥤ E) [faithful G]
  (obj : C → D) (h_obj : ∀ X, G.obj (obj X) = F.obj X)
  (map : Π {X Y}, (X ⟶ Y) → (obj X ⟶ obj Y))
  (h_map : ∀ {X Y} {f : X ⟶ Y}, G.map (map f) == F.map f) :
  (faithful.div F G obj @h_obj @map @h_map) ⋙ G = F :=
begin
  casesI F with F_obj _ _ _, casesI G with G_obj _ _ _,
  unfold faithful.div functor.comp,
  unfold_projs at h_obj,
  have: F_obj = G_obj ∘ obj := (funext h_obj).symm,
  substI this,
  congr,
  funext,
  exact eq_of_heq h_map
end

lemma faithful.div_faithful (F : C ⥤ E) [faithful F] (G : D ⥤ E) [faithful G]
  (obj : C → D) (h_obj : ∀ X, G.obj (obj X) = F.obj X)
  (map : Π {X Y}, (X ⟶ Y) → (obj X ⟶ obj Y))
  (h_map : ∀ {X Y} {f : X ⟶ Y}, G.map (map f) == F.map f) :
  faithful (faithful.div F G obj @h_obj @map @h_map) :=
(faithful.div_comp F G _ h_obj _ @h_map).faithful_of_comp

instance full.comp [full F] [full G] : full (F ⋙ G) :=
{ preimage := λ _ _ f, F.preimage (G.preimage f) }

/-- If `F ⋙ G` is full and `G` is faithful, then `F` is full -/
def full.of_comp_faithful [full $ F ⋙ G] [faithful G] : full F :=
{ preimage := λ X Y f, (F ⋙ G).preimage (G.map f),
  witness' := λ X Y f, G.map_injective ((F ⋙ G).image_preimage _) }

/--
Given a natural isomorphism between `F ⋙ H` and `G ⋙ H` for a fully faithful functor `H`, we
can 'cancel' it to give a natural iso between `F` and `G`.
-/
def fully_faithful_cancel_right {F G : C ⥤ D} (H : D ⥤ E)
  [full H] [faithful H] (comp_iso: F ⋙ H ≅ G ⋙ H) : F ≅ G :=
nat_iso.of_components
  (λ X, preimage_iso (comp_iso.app X))
  (λ X Y f, H.map_injective (by simpa using comp_iso.hom.naturality f))

@[simp]
lemma fully_faithful_cancel_right_hom_app {F G : C ⥤ D} {H : D ⥤ E}
  [full H] [faithful H] (comp_iso: F ⋙ H ≅ G ⋙ H) (X : C) :
  (fully_faithful_cancel_right H comp_iso).hom.app X = H.preimage (comp_iso.hom.app X) :=
rfl

@[simp]
lemma fully_faithful_cancel_right_inv_app {F G : C ⥤ D} {H : D ⥤ E}
  [full H] [faithful H] (comp_iso: F ⋙ H ≅ G ⋙ H) (X : C) :
  (fully_faithful_cancel_right H comp_iso).inv.app X = H.preimage (comp_iso.inv.app X) :=
rfl

end category_theory


/-
Copyright (c) 2022 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import algebra.big_operators.basic
import order.atoms.finite
import order.sup_indep

/-!
# Finite partitions

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

In this file, we define finite partitions. A finpartition of `a : α` is a finite set of pairwise
disjoint parts `parts : finset α` which does not contain `⊥` and whose supremum is `a`.

Finpartitions of a finset are at the heart of Szemerédi's regularity lemma. They are also studied
purely order theoretically in Sperner theory.

## Constructions

We provide many ways to build finpartitions:
* `finpartition.of_erase`: Builds a finpartition by erasing `⊥` for you.
* `finpartition.of_subset`: Builds a finpartition from a subset of the parts of a previous
  finpartition.
* `finpartition.empty`: The empty finpartition of `⊥`.
* `finpartition.indiscrete`: The indiscrete, aka trivial, aka pure, finpartition made of a single
  part.
* `finpartition.discrete`: The discrete finpartition of `s : finset α` made of singletons.
* `finpartition.bind`: Puts together the finpartitions of the parts of a finpartition into a new
  finpartition.
* `finpartition.atomise`: Makes a finpartition of `s : finset α` by breaking `s` along all finsets
  in `F : finset (finset α)`. Two elements of `s` belong to the same part iff they belong to the
  same elements of `F`.

`finpartition.indiscrete` and `finpartition.bind` together form the monadic structure of
`finpartition`.

## Implementation notes

Forbidding `⊥` as a part follows mathematical tradition and is a pragmatic choice concerning
operations on `finpartition`. Not caring about `⊥` being a part or not breaks extensionality (it's
not because the parts of `P` and the parts of `Q` have the same elements that `P = Q`). Enforcing
`⊥` to be a part makes `finpartition.bind` uglier and doesn't rid us of the need of
`finpartition.of_erase`.

## TODO

Link `finpartition` and `setoid.is_partition`.

The order is the wrong way around to make `finpartition a` a graded order. Is it bad to depart from
the literature and turn the order around?
-/

open finset function
open_locale big_operators

variables {α : Type*}

/-- A finite partition of `a : α` is a pairwise disjoint finite set of elements whose supremum is
`a`. We forbid `⊥` as a part. -/
@[ext, derive decidable_eq] structure finpartition [lattice α] [order_bot α] (a : α) :=
(parts : finset α)
(sup_indep : parts.sup_indep id)
(sup_parts : parts.sup id = a)
(not_bot_mem : ⊥ ∉ parts)

attribute [protected] finpartition.sup_indep

namespace finpartition
section lattice
variables [lattice α] [order_bot α]

/-- A `finpartition` constructor which does not insist on `⊥` not being a part. -/
@[simps] def of_erase [decidable_eq α] {a : α} (parts : finset α)
  (sup_indep : parts.sup_indep id) (sup_parts : parts.sup id = a) :
  finpartition a :=
{ parts := parts.erase ⊥,
  sup_indep := sup_indep.subset (erase_subset _ _),
  sup_parts := (sup_erase_bot _).trans sup_parts,
  not_bot_mem := not_mem_erase _ _ }

/-- A `finpartition` constructor from a bigger existing finpartition. -/
@[simps] def of_subset {a b : α} (P : finpartition a) {parts : finset α}
  (subset : parts ⊆ P.parts) (sup_parts : parts.sup id = b) :
  finpartition b :=
{ parts := parts,
  sup_indep := P.sup_indep.subset subset,
  sup_parts := sup_parts,
  not_bot_mem := λ h, P.not_bot_mem (subset h) }

/-- Changes the type of a finpartition to an equal one. -/
@[simps] def copy {a b : α} (P : finpartition a) (h : a = b) : finpartition b :=
{ parts := P.parts,
  sup_indep := P.sup_indep,
  sup_parts := h ▸ P.sup_parts,
  not_bot_mem := P.not_bot_mem }

variables (α)

/-- The empty finpartition. -/
@[simps] protected def empty : finpartition (⊥ : α) :=
{ parts := ∅,
  sup_indep := sup_indep_empty _,
  sup_parts := finset.sup_empty,
  not_bot_mem := not_mem_empty ⊥ }

instance : inhabited (finpartition (⊥ : α)) := ⟨finpartition.empty α⟩

@[simp] lemma default_eq_empty : (default : finpartition (⊥ : α)) = finpartition.empty α := rfl

variables {α} {a : α}

/-- The finpartition in one part, aka indiscrete finpartition. -/
@[simps] def indiscrete (ha : a ≠ ⊥) : finpartition a :=
{ parts := {a},
  sup_indep := sup_indep_singleton _ _,
  sup_parts := finset.sup_singleton,
  not_bot_mem := λ h, ha (mem_singleton.1 h).symm }

variables (P : finpartition a)

protected lemma le {b : α} (hb : b ∈ P.parts) : b ≤ a := (le_sup hb).trans P.sup_parts.le

lemma ne_bot {b : α} (hb : b ∈ P.parts) : b ≠ ⊥ := λ h, P.not_bot_mem $ h.subst hb

protected lemma disjoint : (P.parts : set α).pairwise_disjoint id := P.sup_indep.pairwise_disjoint

variables {P}

lemma parts_eq_empty_iff : P.parts = ∅ ↔ a = ⊥ :=
begin
  simp_rw ←P.sup_parts,
  refine ⟨λ h, _, λ h, eq_empty_iff_forall_not_mem.2 (λ b hb, P.not_bot_mem _)⟩,
  { rw h,
    exact finset.sup_empty },
  { rwa ←le_bot_iff.1 ((le_sup hb).trans h.le) }
end

lemma parts_nonempty_iff : P.parts.nonempty ↔ a ≠ ⊥ :=
by rw [nonempty_iff_ne_empty, not_iff_not, parts_eq_empty_iff]

lemma parts_nonempty (P : finpartition a) (ha : a ≠ ⊥) : P.parts.nonempty := parts_nonempty_iff.2 ha

instance : unique (finpartition (⊥ : α)) :=
{ uniq := λ P,
    by { ext a, exact iff_of_false (λ h, P.ne_bot h $ le_bot_iff.1 $ P.le h) (not_mem_empty a) },
  ..finpartition.inhabited α }

/-- There's a unique partition of an atom. -/
@[reducible] -- See note [reducible non instances]
def _root_.is_atom.unique_finpartition (ha : is_atom a) : unique (finpartition a) :=
{ default := indiscrete ha.1,
  uniq := λ P, begin
    have h : ∀ b ∈ P.parts, b = a,
    { exact λ b hb, (ha.le_iff.mp $ P.le hb).resolve_left (P.ne_bot hb) },
    ext b,
    refine iff.trans ⟨h b, _⟩ mem_singleton.symm,
    rintro rfl,
    obtain ⟨c, hc⟩ := P.parts_nonempty ha.1,
    simp_rw ←h c hc,
    exact hc,
  end }

instance [fintype α] [decidable_eq α] (a : α) :
  fintype (finpartition a) :=
@fintype.of_surjective {p : finset α // p.sup_indep id ∧ p.sup id = a ∧ ⊥ ∉ p} (finpartition a) _
  (subtype.fintype _) (λ i, ⟨i.1, i.2.1, i.2.2.1, i.2.2.2⟩) (λ ⟨_, y, z, w⟩, ⟨⟨_, y, z, w⟩, rfl⟩)

/-! ### Refinement order -/

section order

/-- We say that `P ≤ Q` if `P` refines `Q`: each part of `P` is less than some part of `Q`. -/
instance : has_le (finpartition a) := ⟨λ P Q, ∀ ⦃b⦄, b ∈ P.parts → ∃ c ∈ Q.parts, b ≤ c⟩

instance : partial_order (finpartition a) :=
{ le_refl := λ P b hb, ⟨b, hb, le_rfl⟩,
  le_trans := λ P Q R hPQ hQR b hb, begin
    obtain ⟨c, hc, hbc⟩ := hPQ hb,
    obtain ⟨d, hd, hcd⟩ := hQR hc,
    exact ⟨d, hd, hbc.trans hcd⟩,
  end,
  le_antisymm := λ P Q hPQ hQP, begin
    ext b,
    refine ⟨λ hb, _, λ hb, _⟩,
    { obtain ⟨c, hc, hbc⟩ := hPQ hb,
      obtain ⟨d, hd, hcd⟩ := hQP hc,
      rwa hbc.antisymm,
      rwa P.disjoint.eq_of_le hb hd (P.ne_bot hb) (hbc.trans hcd) },
    { obtain ⟨c, hc, hbc⟩ := hQP hb,
      obtain ⟨d, hd, hcd⟩ := hPQ hc,
      rwa hbc.antisymm,
      rwa Q.disjoint.eq_of_le hb hd (Q.ne_bot hb) (hbc.trans hcd) }
  end,
  ..finpartition.has_le }

instance [decidable (a = ⊥)] : order_top (finpartition a) :=
{ top := if ha : a = ⊥ then (finpartition.empty α).copy ha.symm else indiscrete ha,
  le_top := λ P,
  begin
    split_ifs,
    { intros x hx,
      simpa [h, P.ne_bot hx] using P.le hx },
    { exact λ b hb, ⟨a, mem_singleton_self _, P.le hb⟩ }
  end }

lemma parts_top_subset (a : α) [decidable (a = ⊥)] : (⊤ : finpartition a).parts ⊆ {a} :=
begin
  intros b hb,
  change b ∈ finpartition.parts (dite _ _ _) at hb,
  split_ifs at hb,
  { simp only [copy_parts, empty_parts, not_mem_empty] at hb,
    exact hb.elim },
  { exact hb }
end

lemma parts_top_subsingleton (a : α) [decidable (a = ⊥)] :
  ((⊤ : finpartition a).parts : set α).subsingleton :=
set.subsingleton_of_subset_singleton $ λ b hb, mem_singleton.1 $ parts_top_subset _ hb

end order
end lattice

section distrib_lattice
variables [distrib_lattice α] [order_bot α]

section inf
variables [decidable_eq α] {a b c : α}

instance : has_inf (finpartition a) :=
⟨λ P Q, of_erase ((P.parts ×ˢ Q.parts).image $ λ bc, bc.1 ⊓ bc.2)
  begin
    rw sup_indep_iff_disjoint_erase,
    simp only [mem_image, and_imp, exists_prop, forall_exists_index, id.def, prod.exists,
      mem_product, finset.disjoint_sup_right, mem_erase, ne.def],
    rintro _ x₁ y₁ hx₁ hy₁ rfl _ h x₂ y₂ hx₂ hy₂ rfl,
    rcases eq_or_ne x₁ x₂ with rfl | xdiff,
    { refine disjoint.mono inf_le_right inf_le_right (Q.disjoint hy₁ hy₂ _),
      intro t,
      simpa [t] using h },
    exact disjoint.mono inf_le_left inf_le_left (P.disjoint hx₁ hx₂ xdiff),
  end
  begin
    rw [sup_image, comp.left_id, sup_product_left],
    transitivity P.parts.sup id ⊓ Q.parts.sup id,
    { simp_rw [finset.sup_inf_distrib_right, finset.sup_inf_distrib_left],
      refl },
    { rw [P.sup_parts, Q.sup_parts, inf_idem] }
  end⟩

@[simp] lemma parts_inf (P Q : finpartition a) :
  (P ⊓ Q).parts = ((P.parts ×ˢ Q.parts).image $ λ bc : α × α, bc.1 ⊓ bc.2).erase ⊥ := rfl

instance : semilattice_inf (finpartition a) :=
{ inf_le_left := λ P Q b hb, begin
    obtain ⟨c, hc, rfl⟩ := mem_image.1 (mem_of_mem_erase hb),
    rw mem_product at hc,
    exact ⟨c.1, hc.1, inf_le_left⟩,
  end,
  inf_le_right := λ P Q b hb, begin
    obtain ⟨c, hc, rfl⟩ := mem_image.1 (mem_of_mem_erase hb),
    rw mem_product at hc,
    exact ⟨c.2, hc.2, inf_le_right⟩,
  end,
  le_inf := λ P Q R hPQ hPR b hb, begin
    obtain ⟨c, hc, hbc⟩ := hPQ hb,
    obtain ⟨d, hd, hbd⟩ := hPR hb,
    have h := _root_.le_inf hbc hbd,
    refine ⟨c ⊓ d, mem_erase_of_ne_of_mem (ne_bot_of_le_ne_bot (P.ne_bot hb) h)
      (mem_image.2 ⟨(c, d), mem_product.2 ⟨hc, hd⟩, rfl⟩), h⟩,
  end,
  ..finpartition.partial_order, ..finpartition.has_inf }

end inf

lemma exists_le_of_le {a b : α} {P Q : finpartition a} (h : P ≤ Q) (hb : b ∈ Q.parts) :
  ∃ c ∈ P.parts, c ≤ b :=
begin
  by_contra' H,
  refine Q.ne_bot hb (disjoint_self.1 $ disjoint.mono_right (Q.le hb) _),
  rw [←P.sup_parts, finset.disjoint_sup_right],
  rintro c hc,
  obtain ⟨d, hd, hcd⟩ := h hc,
  refine (Q.disjoint hb hd _).mono_right hcd,
  rintro rfl,
  exact H _ hc hcd,
end

lemma card_mono {a : α} {P Q : finpartition a} (h : P ≤ Q) : Q.parts.card ≤ P.parts.card :=
begin
  classical,
  have : ∀ b ∈ Q.parts, ∃ c ∈ P.parts, c ≤ b := λ b, exists_le_of_le h,
  choose f hP hf using this,
  rw ←card_attach,
  refine card_le_card_of_inj_on (λ b, f _ b.2) (λ b _, hP _ b.2) (λ b hb c hc h, _),
  exact subtype.coe_injective (Q.disjoint.elim b.2 c.2 $ λ H, P.ne_bot (hP _ b.2) $
    disjoint_self.1 $ H.mono (hf _ b.2) $ h.le.trans $ hf _ c.2),
end

variables [decidable_eq α] {a b c : α}

section bind
variables {P : finpartition a} {Q : Π i ∈ P.parts, finpartition i}

/-- Given a finpartition `P` of `a` and finpartitions of each part of `P`, this yields the
finpartition of `a` obtained by juxtaposing all the subpartitions. -/
@[simps] def bind (P : finpartition a) (Q : Π i ∈ P.parts, finpartition i) : finpartition a :=
{ parts := P.parts.attach.bUnion (λ i, (Q i.1 i.2).parts),
  sup_indep := begin
    rw sup_indep_iff_pairwise_disjoint,
    rintro a ha b hb h,
    rw [finset.mem_coe, finset.mem_bUnion] at ha hb,
    obtain ⟨⟨A, hA⟩, -, ha⟩ := ha,
    obtain ⟨⟨B, hB⟩, -, hb⟩ := hb,
    obtain rfl | hAB := eq_or_ne A B,
    { exact (Q A hA).disjoint ha hb h },
    { exact (P.disjoint hA hB hAB).mono ((Q A hA).le ha) ((Q B hB).le hb) }
  end,
  sup_parts := begin
    simp_rw [sup_bUnion, ←P.sup_parts],
    rw [eq_comm, ←finset.sup_attach],
    exact sup_congr rfl (λ b hb, (Q b.1 b.2).sup_parts.symm),
  end,
  not_bot_mem := λ h, begin
    rw finset.mem_bUnion at h,
    obtain ⟨⟨A, hA⟩, -, h⟩ := h,
    exact (Q A hA).not_bot_mem h,
  end }

lemma card_bind (Q : Π i ∈ P.parts, finpartition i) :
  (P.bind Q).parts.card = ∑ A in P.parts.attach, (Q _ A.2).parts.card :=
begin
  apply card_bUnion,
  rintro ⟨b, hb⟩ - ⟨c, hc⟩ - hbc,
  rw finset.disjoint_left,
  rintro d hdb hdc,
  rw [ne.def, subtype.mk_eq_mk] at hbc,
  exact (Q b hb).ne_bot hdb (eq_bot_iff.2 $
    (le_inf ((Q b hb).le hdb) $ (Q c hc).le hdc).trans $ (P.disjoint hb hc hbc).le_bot),
end

end bind

/-- Adds `b` to a finpartition of `a` to make a finpartition of `a ⊔ b`. -/
@[simps] def extend (P : finpartition a) (hb : b ≠ ⊥) (hab : disjoint a b) (hc : a ⊔ b = c) :
  finpartition c :=
{ parts := insert b P.parts,
  sup_indep :=
  begin
    rw [sup_indep_iff_pairwise_disjoint, coe_insert],
    exact P.disjoint.insert (λ d hd hbd, hab.symm.mono_right $ P.le hd),
  end,
  sup_parts := by rwa [sup_insert, P.sup_parts, id, _root_.sup_comm],
  not_bot_mem := λ h, (mem_insert.1 h).elim hb.symm P.not_bot_mem }

lemma card_extend (P : finpartition a) (b c : α) {hb : b ≠ ⊥} {hab : disjoint a b}
  {hc : a ⊔ b = c} :
  (P.extend hb hab hc).parts.card = P.parts.card + 1 :=
card_insert_of_not_mem $ λ h, hb $ hab.symm.eq_bot_of_le $ P.le h

end distrib_lattice

section generalized_boolean_algebra
variables [generalized_boolean_algebra α] [decidable_eq α] {a b c : α} (P : finpartition a)

/-- Restricts a finpartition to avoid a given element. -/
@[simps] def avoid (b : α) : finpartition (a \ b) :=
of_erase
  (P.parts.image (\ b))
  (P.disjoint.image_finset_of_le $ λ a, sdiff_le).sup_indep
  (by rw [sup_image, comp.left_id, finset.sup_sdiff_right, ←id_def, P.sup_parts])

@[simp] lemma mem_avoid : c ∈ (P.avoid b).parts ↔ ∃ d ∈ P.parts, ¬ d ≤ b ∧ d \ b = c :=
begin
  simp only [avoid, of_erase_parts, mem_erase, ne.def, mem_image, exists_prop,
    ←exists_and_distrib_left, @and.left_comm (c ≠ ⊥)],
  refine exists_congr (λ d, and_congr_right' $ and_congr_left _),
  rintro rfl,
  rw sdiff_eq_bot_iff,
end

end generalized_boolean_algebra
end finpartition

/-! ### Finite partitions of finsets -/

namespace finpartition
variables [decidable_eq α] {s t : finset α} (P : finpartition s)

lemma nonempty_of_mem_parts {a : finset α} (ha : a ∈ P.parts) : a.nonempty :=
nonempty_iff_ne_empty.2 $ P.ne_bot ha

lemma exists_mem {a : α} (ha : a ∈ s) : ∃ t ∈ P.parts, a ∈ t :=
by { simp_rw ←P.sup_parts at ha, exact mem_sup.1 ha }

lemma bUnion_parts : P.parts.bUnion id = s := (sup_eq_bUnion _ _).symm.trans P.sup_parts

lemma sum_card_parts : ∑ i in P.parts, i.card = s.card :=
begin
  convert congr_arg finset.card P.bUnion_parts,
  rw card_bUnion P.sup_indep.pairwise_disjoint,
  refl,
end

/-- `⊥` is the partition in singletons, aka discrete partition. -/
instance (s : finset α) : has_bot (finpartition s) :=
⟨{ parts := s.map ⟨singleton, singleton_injective⟩,
  sup_indep := set.pairwise_disjoint.sup_indep begin
      rw finset.coe_map,
      exact finset.pairwise_disjoint_range_singleton.subset (set.image_subset_range _ _),
    end,
  sup_parts := by rw [sup_map, comp.left_id, embedding.coe_fn_mk, finset.sup_singleton'],
  not_bot_mem := by simp }⟩

@[simp] lemma parts_bot (s : finset α) :
  (⊥ : finpartition s).parts = s.map ⟨singleton, singleton_injective⟩ := rfl

lemma card_bot (s : finset α) : (⊥ : finpartition s).parts.card = s.card := finset.card_map _
lemma mem_bot_iff : t ∈ (⊥ : finpartition s).parts ↔ ∃ a ∈ s, {a} = t := mem_map

instance (s : finset α) : order_bot (finpartition s) :=
{ bot_le := λ P t ht, begin
    rw mem_bot_iff at ht,
    obtain ⟨a, ha, rfl⟩ := ht,
    obtain ⟨t, ht, hat⟩ := P.exists_mem ha,
    exact ⟨t, ht, singleton_subset_iff.2 hat⟩,
  end,
  ..finpartition.has_bot s }

lemma card_parts_le_card (P : finpartition s) : P.parts.card ≤ s.card :=
by { rw ←card_bot s, exact card_mono bot_le }

section atomise

/-- Cuts `s` along the finsets in `F`: Two elements of `s` will be in the same part if they are
in the same finsets of `F`. -/
def atomise (s : finset α) (F : finset (finset α)) : finpartition s :=
of_erase
  (F.powerset.image $ λ Q, s.filter (λ i, ∀ t ∈ F, t ∈ Q ↔ i ∈ t))
  (set.pairwise_disjoint.sup_indep $ λ x hx y hy h, disjoint_left.mpr $ λ z hz1 hz2, h begin
    rw [mem_coe, mem_image] at hx hy,
    obtain ⟨Q, hQ, rfl⟩ := hx,
    obtain ⟨R, hR, rfl⟩ := hy,
    suffices h : Q = R,
    { subst h },
    rw [id, mem_filter] at hz1 hz2,
    rw mem_powerset at hQ hR,
    ext i,
    refine ⟨λ hi, _, λ hi, _⟩,
    { rwa [hz2.2 _ (hQ hi), ←hz1.2 _ (hQ hi)] },
    { rwa [hz1.2 _ (hR hi), ←hz2.2 _ (hR hi)] }
  end)
  (begin
    refine (finset.sup_le $ λ t ht, _).antisymm (λ a ha, _),
    { rw mem_image at ht,
      obtain ⟨A, hA, rfl⟩ := ht,
      exact s.filter_subset _ },
    { rw [mem_sup],
      refine ⟨s.filter (λ i, ∀ t, t ∈ F → (t ∈ F.filter (λ u, a ∈ u) ↔ i ∈ t)),
        mem_image_of_mem _ (mem_powerset.2 $ filter_subset _ _), mem_filter.2 ⟨ha, λ t ht, _⟩⟩,
      rw mem_filter,
      exact and_iff_right ht }
  end)

variables {F : finset (finset α)}

lemma mem_atomise :
  t ∈ (atomise s F).parts ↔ t.nonempty ∧ ∃ (Q ⊆ F), s.filter (λ i, ∀ u ∈ F, u ∈ Q ↔ i ∈ u) = t :=
by simp only [atomise, of_erase, bot_eq_empty, mem_erase, mem_image, nonempty_iff_ne_empty,
  mem_singleton, and_comm, mem_powerset, exists_prop]

lemma atomise_empty (hs : s.nonempty) : (atomise s ∅).parts = {s} :=
begin
  simp only [atomise, powerset_empty, image_singleton, not_mem_empty, is_empty.forall_iff,
    implies_true_iff, filter_true],
  exact erase_eq_of_not_mem (not_mem_singleton.2 hs.ne_empty.symm),
end

lemma card_atomise_le : (atomise s F).parts.card ≤ 2^F.card :=
(card_le_of_subset $ erase_subset _ _).trans $ finset.card_image_le.trans (card_powerset _).le

lemma bUnion_filter_atomise (ht : t ∈ F) (hts : t ⊆ s) :
  ((atomise s F).parts.filter $ λ u, u ⊆ t ∧ u.nonempty).bUnion id = t :=
begin
  ext a,
  refine mem_bUnion.trans ⟨λ ⟨u, hu, ha⟩, (mem_filter.1 hu).2.1 ha, λ ha, _⟩,
  obtain ⟨u, hu, hau⟩ := (atomise s F).exists_mem (hts ha),
  refine ⟨u, mem_filter.2 ⟨hu, λ b hb, _, _, hau⟩, hau⟩,
  obtain ⟨Q, hQ, rfl⟩ := (mem_atomise.1 hu).2,
  rw mem_filter at hau hb,
  rwa [←hb.2 _ ht, hau.2 _ ht],
end

lemma card_filter_atomise_le_two_pow (ht : t ∈ F) :
  ((atomise s F).parts.filter $ λ u, u ⊆ t ∧ u.nonempty).card ≤ 2 ^ (F.card - 1) :=
begin
  suffices h : (atomise s F).parts.filter (λ u, u ⊆ t ∧ u.nonempty)
    ⊆ (F.erase t).powerset.image (λ P, s.filter $ λ i, ∀ x ∈ F, x ∈ insert t P ↔ i ∈ x),
  { refine (card_le_of_subset h).trans (card_image_le.trans _),
    rw [card_powerset, card_erase_of_mem ht] },
  rw subset_iff,
  simp only [mem_erase, mem_sdiff, mem_powerset, mem_image, exists_prop, mem_filter, and_assoc,
    finset.nonempty, exists_imp_distrib, and_imp, mem_atomise, forall_apply_eq_imp_iff₂],
  rintro P' i hi P PQ rfl hy₂ j hj,
  refine ⟨P.erase t, erase_subset_erase _ PQ, _⟩,
  simp only [insert_erase (((mem_filter.1 hi).2 _ ht).2 $ hy₂ hi), filter_congr_decidable],
end

end atomise
end finpartition