/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.eq_to_hom
import Mathlib.PostPort

universes u₁ v₁

namespace Mathlib

/-#
Disjoint unions of categories, functors, and natural transformations.
-/

namespace category_theory

/--
`sum C D` gives the direct sum of two categories.
-/
protected instance sum (C : Type u₁) [category C] (D : Type u₁) [category D] : category (C ⊕ D) :=
  category.mk

@[simp] theorem sum_comp_inl (C : Type u₁) [category C] (D : Type u₁) [category D] {P : C} {Q : C}
    {R : C} (f : sum.inl P ⟶ sum.inl Q) (g : sum.inl Q ⟶ sum.inl R) : f ≫ g = f ≫ g :=
  rfl

@[simp] theorem sum_comp_inr (C : Type u₁) [category C] (D : Type u₁) [category D] {P : D} {Q : D}
    {R : D} (f : sum.inr P ⟶ sum.inr Q) (g : sum.inr Q ⟶ sum.inr R) : f ≫ g = f ≫ g :=
  rfl

namespace sum

/-- `inl_` is the functor `X ↦ inl X`. -/
-- Unfortunate naming here, suggestions welcome.

def inl_ (C : Type u₁) [category C] (D : Type u₁) [category D] : C ⥤ C ⊕ D :=
  functor.mk (fun (X : C) => sum.inl X) fun (X Y : C) (f : X ⟶ Y) => f

/-- `inr_` is the functor `X ↦ inr X`. -/
def inr_ (C : Type u₁) [category C] (D : Type u₁) [category D] : D ⥤ C ⊕ D :=
  functor.mk (fun (X : D) => sum.inr X) fun (X Y : D) (f : X ⟶ Y) => f

/-- The functor exchanging two direct summand categories. -/
def swap (C : Type u₁) [category C] (D : Type u₁) [category D] : C ⊕ D ⥤ D ⊕ C :=
  functor.mk (fun (X : C ⊕ D) => sorry) fun (X Y : C ⊕ D) (f : X ⟶ Y) => sorry

@[simp] theorem swap_obj_inl (C : Type u₁) [category C] (D : Type u₁) [category D] (X : C) :
    functor.obj (swap C D) (sum.inl X) = sum.inr X :=
  rfl

@[simp] theorem swap_obj_inr (C : Type u₁) [category C] (D : Type u₁) [category D] (X : D) :
    functor.obj (swap C D) (sum.inr X) = sum.inl X :=
  rfl

@[simp] theorem swap_map_inl (C : Type u₁) [category C] (D : Type u₁) [category D] {X : C} {Y : C}
    {f : sum.inl X ⟶ sum.inl Y} : functor.map (swap C D) f = f :=
  rfl

@[simp] theorem swap_map_inr (C : Type u₁) [category C] (D : Type u₁) [category D] {X : D} {Y : D}
    {f : sum.inr X ⟶ sum.inr Y} : functor.map (swap C D) f = f :=
  rfl

namespace swap

/-- `swap` gives an equivalence between `C ⊕ D` and `D ⊕ C`. -/
def equivalence (C : Type u₁) [category C] (D : Type u₁) [category D] : C ⊕ D ≌ D ⊕ C :=
  equivalence.mk (swap C D) (swap D C)
    (nat_iso.of_components (fun (X : C ⊕ D) => eq_to_iso sorry) sorry)
    (nat_iso.of_components (fun (X : D ⊕ C) => eq_to_iso sorry) sorry)

protected instance is_equivalence (C : Type u₁) [category C] (D : Type u₁) [category D] :
    is_equivalence (swap C D) :=
  is_equivalence.of_equivalence (equivalence C D)

/-- The double swap on `C ⊕ D` is naturally isomorphic to the identity functor. -/
def symmetry (C : Type u₁) [category C] (D : Type u₁) [category D] : swap C D ⋙ swap D C ≅ 𝟭 :=
  iso.symm (equivalence.unit_iso (equivalence C D))

end swap

end sum

namespace functor

/-- The sum of two functors. -/
def sum {A : Type u₁} [category A] {B : Type u₁} [category B] {C : Type u₁} [category C]
    {D : Type u₁} [category D] (F : A ⥤ B) (G : C ⥤ D) : A ⊕ C ⥤ B ⊕ D :=
  mk (fun (X : A ⊕ C) => sorry) fun (X Y : A ⊕ C) (f : X ⟶ Y) => sorry

@[simp] theorem sum_obj_inl {A : Type u₁} [category A] {B : Type u₁} [category B] {C : Type u₁}
    [category C] {D : Type u₁} [category D] (F : A ⥤ B) (G : C ⥤ D) (a : A) :
    obj (sum F G) (sum.inl a) = sum.inl (obj F a) :=
  rfl

@[simp] theorem sum_obj_inr {A : Type u₁} [category A] {B : Type u₁} [category B] {C : Type u₁}
    [category C] {D : Type u₁} [category D] (F : A ⥤ B) (G : C ⥤ D) (c : C) :
    obj (sum F G) (sum.inr c) = sum.inr (obj G c) :=
  rfl

@[simp] theorem sum_map_inl {A : Type u₁} [category A] {B : Type u₁} [category B] {C : Type u₁}
    [category C] {D : Type u₁} [category D] (F : A ⥤ B) (G : C ⥤ D) {a : A} {a' : A}
    (f : sum.inl a ⟶ sum.inl a') : map (sum F G) f = map F f :=
  rfl

@[simp] theorem sum_map_inr {A : Type u₁} [category A] {B : Type u₁} [category B] {C : Type u₁}
    [category C] {D : Type u₁} [category D] (F : A ⥤ B) (G : C ⥤ D) {c : C} {c' : C}
    (f : sum.inr c ⟶ sum.inr c') : map (sum F G) f = map G f :=
  rfl

end functor

namespace nat_trans

/-- The sum of two natural transformations. -/
def sum {A : Type u₁} [category A] {B : Type u₁} [category B] {C : Type u₁} [category C]
    {D : Type u₁} [category D] {F : A ⥤ B} {G : A ⥤ B} {H : C ⥤ D} {I : C ⥤ D} (α : F ⟶ G)
    (β : H ⟶ I) : functor.sum F H ⟶ functor.sum G I :=
  mk fun (X : A ⊕ C) => sorry

@[simp] theorem sum_app_inl {A : Type u₁} [category A] {B : Type u₁} [category B] {C : Type u₁}
    [category C] {D : Type u₁} [category D] {F : A ⥤ B} {G : A ⥤ B} {H : C ⥤ D} {I : C ⥤ D}
    (α : F ⟶ G) (β : H ⟶ I) (a : A) : app (sum α β) (sum.inl a) = app α a :=
  rfl

@[simp] theorem sum_app_inr {A : Type u₁} [category A] {B : Type u₁} [category B] {C : Type u₁}
    [category C] {D : Type u₁} [category D] {F : A ⥤ B} {G : A ⥤ B} {H : C ⥤ D} {I : C ⥤ D}
    (α : F ⟶ G) (β : H ⟶ I) (c : C) : app (sum α β) (sum.inr c) = app β c :=
  rfl

end Mathlib


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

/-!
# Bundled hom instances for module and multiplicative actions

This file defines instances for module, mul_action and related structures on bundled `_hom` types.

These are analogous to the instances in `algebra.module.pi`, but for bundled instead of unbundled
functions.
-/

variables {R S A B : Type*}

namespace add_monoid_hom

section
variables [monoid R] [monoid S] [add_monoid A] [add_comm_monoid B]
variables [distrib_mul_action R B] [distrib_mul_action S B]

instance : distrib_mul_action R (A →+ B) :=
{ smul := λ r f,
  { to_fun := r • f,
    map_zero' := by simp,
    map_add' := λ x y, by simp [smul_add] },
  one_smul := λ f, by simp,
  mul_smul := λ r s f, by simp [mul_smul],
  smul_add := λ r f g, ext $ λ x, by simp [smul_add],
  smul_zero := λ r, ext $ λ x, by simp [smul_zero] }

@[simp] lemma coe_smul (r : R) (f : A →+ B) : ⇑(r • f) = r • f := rfl
lemma smul_apply (r : R) (f : A →+ B) (x : A) : (r • f) x = r • f x := rfl

instance [smul_comm_class R S B] : smul_comm_class R S (A →+ B) :=
⟨λ a b f, ext $ λ x, smul_comm _ _ _⟩

instance [has_scalar R S] [is_scalar_tower R S B] : is_scalar_tower R S (A →+ B) :=
⟨λ a b f, ext $ λ x, smul_assoc _ _ _⟩

instance [distrib_mul_action Rᵐᵒᵖ B] [is_central_scalar R B] : is_central_scalar R (A →+ B) :=
⟨λ a b, ext $ λ x, op_smul_eq_smul _ _⟩

end

instance [semiring R] [add_monoid A] [add_comm_monoid B] [module R B] :
  module R (A →+ B) :=
{ add_smul := λ r s x, ext $ λ y, by simp [add_smul],
  zero_smul := λ x, ext $ λ y, by simp [zero_smul],
  ..add_monoid_hom.distrib_mul_action }

end add_monoid_hom


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.fintype.card
import data.finset.prod

/-!
# fintype instance for the product of two fintypes.

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

-/

open function
open_locale nat

universes u v

variables {α β γ : Type*}

open finset function

namespace set
variables {s t : set α}

lemma to_finset_prod (s : set α) (t : set β) [fintype s] [fintype t] [fintype (s ×ˢ t)] :
  (s ×ˢ t).to_finset = s.to_finset ×ˢ t.to_finset :=
by { ext, simp }

lemma to_finset_off_diag {s : set α} [decidable_eq α] [fintype s] [fintype s.off_diag] :
  s.off_diag.to_finset = s.to_finset.off_diag :=
finset.ext $ by simp

end set

instance (α β : Type*) [fintype α] [fintype β] : fintype (α × β) :=
⟨univ ×ˢ univ, λ ⟨a, b⟩, by simp⟩

@[simp] lemma finset.univ_product_univ {α β : Type*} [fintype α] [fintype β] :
  (univ : finset α) ×ˢ (univ : finset β) = univ :=
rfl

@[simp] theorem fintype.card_prod (α β : Type*) [fintype α] [fintype β] :
  fintype.card (α × β) = fintype.card α * fintype.card β :=
card_product _ _

section
open_locale classical

@[simp] lemma infinite_prod :
  infinite (α × β) ↔ infinite α ∧ nonempty β ∨ nonempty α ∧ infinite β :=
begin
  refine ⟨λ H, _, λ H, H.elim (and_imp.2 $ @prod.infinite_of_left α β)
    (and_imp.2 $ @prod.infinite_of_right α β)⟩,
  rw and.comm, contrapose! H, introI H',
  rcases infinite.nonempty (α × β) with ⟨a, b⟩,
  haveI := fintype_of_not_infinite (H.1 ⟨b⟩), haveI := fintype_of_not_infinite (H.2 ⟨a⟩),
  exact H'.false
end

instance pi.infinite_of_left {ι : Sort*} {π : ι → Sort*} [∀ i, nontrivial $ π i]
  [infinite ι] : infinite (Π i : ι, π i) :=
begin
  choose m n hm using λ i, exists_pair_ne (π i),
  refine infinite.of_injective (λ i, m.update i (n i)) (λ x y h, not_not.1 $ λ hne, _),
  simp_rw [update_eq_iff, update_noteq hne] at h,
  exact (hm x h.1.symm).elim,
end

/-- If at least one `π i` is infinite and the rest nonempty, the pi type of all `π` is infinite. -/
lemma pi.infinite_of_exists_right {ι : Type*} {π : ι → Type*} (i : ι)
  [infinite $ π i] [∀ i, nonempty $ π i] :
  infinite (Π i : ι, π i) :=
let ⟨m⟩ := @pi.nonempty ι π _ in infinite.of_injective _ (update_injective m i)

/-- See `pi.infinite_of_exists_right` for the case that only one `π i` is infinite. -/
instance pi.infinite_of_right {ι : Sort*} {π : ι → Sort*} [∀ i, infinite $ π i] [nonempty ι] :
  infinite (Π i : ι, π i) :=
pi.infinite_of_exists_right (classical.arbitrary ι)

/-- Non-dependent version of `pi.infinite_of_left`. -/
instance function.infinite_of_left {ι π : Sort*} [nontrivial π]
  [infinite ι] : infinite (ι → π) :=
pi.infinite_of_left

/-- Non-dependent version of `pi.infinite_of_exists_right` and `pi.infinite_of_right`. -/
instance function.infinite_of_right {ι π : Sort*} [infinite π] [nonempty ι] :
  infinite (ι → π) :=
pi.infinite_of_right

end


/-
Copyright (c) 2018 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis, Chris Hughes
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.associated
import Mathlib.algebra.big_operators.basic
import Mathlib.data.nat.enat
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-- `multiplicity a b` returns the largest natural number `n` such that
  `a ^ n ∣ b`, as an `enat` or natural with infinity. If `∀ n, a ^ n ∣ b`,
  then it returns `⊤`-/
def multiplicity {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] (a : α) (b : α) : enat :=
  enat.find fun (n : ℕ) => ¬a ^ (n + 1) ∣ b

namespace multiplicity

/-- `multiplicity.finite a b` indicates that the multiplicity of `a` in `b` is finite. -/
def finite {α : Type u_1} [comm_monoid α] (a : α) (b : α) :=
  ∃ (n : ℕ), ¬a ^ (n + 1) ∣ b

theorem finite_iff_dom {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} {b : α} : finite a b ↔ roption.dom (multiplicity a b) :=
  iff.rfl

theorem finite_def {α : Type u_1} [comm_monoid α] {a : α} {b : α} : finite a b ↔ ∃ (n : ℕ), ¬a ^ (n + 1) ∣ b :=
  iff.rfl

theorem int.coe_nat_multiplicity (a : ℕ) (b : ℕ) : multiplicity ↑a ↑b = multiplicity a b := sorry

theorem not_finite_iff_forall {α : Type u_1} [comm_monoid α] {a : α} {b : α} : ¬finite a b ↔ ∀ (n : ℕ), a ^ n ∣ b := sorry

theorem not_unit_of_finite {α : Type u_1} [comm_monoid α] {a : α} {b : α} (h : finite a b) : ¬is_unit a := sorry

theorem finite_of_finite_mul_left {α : Type u_1} [comm_monoid α] {a : α} {b : α} {c : α} : finite a (b * c) → finite a c := sorry

theorem finite_of_finite_mul_right {α : Type u_1} [comm_monoid α] {a : α} {b : α} {c : α} : finite a (b * c) → finite a b :=
  eq.mpr (id (Eq._oldrec (Eq.refl (finite a (b * c) → finite a b)) (mul_comm b c))) finite_of_finite_mul_left

theorem pow_dvd_of_le_multiplicity {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} {b : α} {k : ℕ} : ↑k ≤ multiplicity a b → a ^ k ∣ b := sorry

theorem pow_multiplicity_dvd {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} {b : α} (h : finite a b) : a ^ roption.get (multiplicity a b) h ∣ b :=
  pow_dvd_of_le_multiplicity
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑(roption.get (multiplicity a b) h) ≤ multiplicity a b)) (enat.coe_get h)))
      (le_refl (multiplicity a b)))

theorem is_greatest {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} {b : α} {m : ℕ} (hm : multiplicity a b < ↑m) : ¬a ^ m ∣ b := sorry

theorem is_greatest' {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} {b : α} {m : ℕ} (h : finite a b) (hm : roption.get (multiplicity a b) h < m) : ¬a ^ m ∣ b :=
  is_greatest
    (eq.mp (Eq._oldrec (Eq.refl (↑(roption.get (multiplicity a b) h) < ↑m)) (enat.coe_get h))
      (eq.mp (Eq._oldrec (Eq.refl (roption.get (multiplicity a b) h < m)) (Eq.symm (propext enat.coe_lt_coe))) hm))

theorem unique {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} {b : α} {k : ℕ} (hk : a ^ k ∣ b) (hsucc : ¬a ^ (k + 1) ∣ b) : ↑k = multiplicity a b := sorry

theorem unique' {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} {b : α} {k : ℕ} (hk : a ^ k ∣ b) (hsucc : ¬a ^ (k + 1) ∣ b) : k = roption.get (multiplicity a b) (Exists.intro k hsucc) := sorry

theorem le_multiplicity_of_pow_dvd {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} {b : α} {k : ℕ} (hk : a ^ k ∣ b) : ↑k ≤ multiplicity a b :=
  le_of_not_gt fun (hk' : ↑k > multiplicity a b) => is_greatest hk' hk

theorem pow_dvd_iff_le_multiplicity {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} {b : α} {k : ℕ} : a ^ k ∣ b ↔ ↑k ≤ multiplicity a b :=
  { mp := le_multiplicity_of_pow_dvd, mpr := pow_dvd_of_le_multiplicity }

theorem multiplicity_lt_iff_neg_dvd {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} {b : α} {k : ℕ} : multiplicity a b < ↑k ↔ ¬a ^ k ∣ b :=
  eq.mpr (id (Eq._oldrec (Eq.refl (multiplicity a b < ↑k ↔ ¬a ^ k ∣ b)) (propext pow_dvd_iff_le_multiplicity)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (multiplicity a b < ↑k ↔ ¬↑k ≤ multiplicity a b)) (propext not_le)))
      (iff.refl (multiplicity a b < ↑k)))

theorem eq_some_iff {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} {b : α} {n : ℕ} : multiplicity a b = ↑n ↔ a ^ n ∣ b ∧ ¬a ^ (n + 1) ∣ b := sorry

theorem eq_top_iff {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} {b : α} : multiplicity a b = ⊤ ↔ ∀ (n : ℕ), a ^ n ∣ b := sorry

theorem one_right {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} (ha : ¬is_unit a) : multiplicity a 1 = 0 := sorry

@[simp] theorem get_one_right {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} (ha : finite a 1) : roption.get (multiplicity a 1) ha = 0 := sorry

@[simp] theorem multiplicity_unit {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} (b : α) (ha : is_unit a) : multiplicity a b = ⊤ :=
  iff.mpr eq_top_iff fun (_x : ℕ) => iff.mp is_unit_iff_forall_dvd (is_unit.pow _x ha) b

@[simp] theorem one_left {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] (b : α) : multiplicity 1 b = ⊤ := sorry

theorem multiplicity_eq_zero_of_not_dvd {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} {b : α} (ha : ¬a ∣ b) : multiplicity a b = 0 := sorry

theorem eq_top_iff_not_finite {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} {b : α} : multiplicity a b = ⊤ ↔ ¬finite a b :=
  roption.eq_none_iff'

theorem multiplicity_le_multiplicity_iff {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} {b : α} {c : α} {d : α} : multiplicity a b ≤ multiplicity c d ↔ ∀ (n : ℕ), a ^ n ∣ b → c ^ n ∣ d := sorry

theorem multiplicity_le_multiplicity_of_dvd {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} {b : α} {c : α} (hdvd : a ∣ b) : multiplicity b c ≤ multiplicity a c :=
  iff.mpr multiplicity_le_multiplicity_iff fun (n : ℕ) (h : b ^ n ∣ c) => dvd_trans (pow_dvd_pow_of_dvd hdvd n) h

theorem dvd_of_multiplicity_pos {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} {b : α} (h : 0 < multiplicity a b) : a ∣ b :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a ∣ b)) (Eq.symm (pow_one a))))
    (pow_dvd_of_le_multiplicity (iff.mp enat.pos_iff_one_le h))

theorem dvd_iff_multiplicity_pos {α : Type u_1} [comm_monoid α] [DecidableRel has_dvd.dvd] {a : α} {b : α} : 0 < multiplicity a b ↔ a ∣ b := sorry

theorem finite_nat_iff {a : ℕ} {b : ℕ} : finite a b ↔ a ≠ 1 ∧ 0 < b := sorry

theorem ne_zero_of_finite {α : Type u_1} [comm_monoid_with_zero α] {a : α} {b : α} (h : finite a b) : b ≠ 0 := sorry

@[simp] protected theorem zero {α : Type u_1} [comm_monoid_with_zero α] [DecidableRel has_dvd.dvd] (a : α) : multiplicity a 0 = ⊤ := sorry

@[simp] theorem multiplicity_zero_eq_zero_of_ne_zero {α : Type u_1} [comm_monoid_with_zero α] [DecidableRel has_dvd.dvd] (a : α) (ha : a ≠ 0) : multiplicity 0 a = 0 :=
  multiplicity_eq_zero_of_not_dvd (eq.mpr (id (Eq._oldrec (Eq.refl (¬0 ∣ a)) (propext zero_dvd_iff))) ha)

theorem min_le_multiplicity_add {α : Type u_1} [comm_semiring α] [DecidableRel has_dvd.dvd] {p : α} {a : α} {b : α} : min (multiplicity p a) (multiplicity p b) ≤ multiplicity p (a + b) := sorry

@[simp] protected theorem neg {α : Type u_1} [comm_ring α] [DecidableRel has_dvd.dvd] (a : α) (b : α) : multiplicity a (-b) = multiplicity a b := sorry

theorem multiplicity_add_of_gt {α : Type u_1} [comm_ring α] [DecidableRel has_dvd.dvd] {p : α} {a : α} {b : α} (h : multiplicity p b < multiplicity p a) : multiplicity p (a + b) = multiplicity p b := sorry

theorem multiplicity_sub_of_gt {α : Type u_1} [comm_ring α] [DecidableRel has_dvd.dvd] {p : α} {a : α} {b : α} (h : multiplicity p b < multiplicity p a) : multiplicity p (a - b) = multiplicity p b := sorry

theorem multiplicity_add_eq_min {α : Type u_1} [comm_ring α] [DecidableRel has_dvd.dvd] {p : α} {a : α} {b : α} (h : multiplicity p a ≠ multiplicity p b) : multiplicity p (a + b) = min (multiplicity p a) (multiplicity p b) := sorry

theorem finite_mul_aux {α : Type u_1} [comm_cancel_monoid_with_zero α] {p : α} (hp : prime p) {n : ℕ} {m : ℕ} {a : α} {b : α} : ¬p ^ (n + 1) ∣ a → ¬p ^ (m + 1) ∣ b → ¬p ^ (n + m + 1) ∣ a * b := sorry

theorem finite_mul {α : Type u_1} [comm_cancel_monoid_with_zero α] {p : α} {a : α} {b : α} (hp : prime p) : finite p a → finite p b → finite p (a * b) := sorry

theorem finite_mul_iff {α : Type u_1} [comm_cancel_monoid_with_zero α] {p : α} {a : α} {b : α} (hp : prime p) : finite p (a * b) ↔ finite p a ∧ finite p b :=
  { mp := fun (h : finite p (a * b)) => { left := finite_of_finite_mul_right h, right := finite_of_finite_mul_left h },
    mpr := fun (h : finite p a ∧ finite p b) => finite_mul hp (and.left h) (and.right h) }

theorem finite_pow {α : Type u_1} [comm_cancel_monoid_with_zero α] {p : α} {a : α} (hp : prime p) {k : ℕ} (ha : finite p a) : finite p (a ^ k) := sorry

@[simp] theorem multiplicity_self {α : Type u_1} [comm_cancel_monoid_with_zero α] [DecidableRel has_dvd.dvd] {a : α} (ha : ¬is_unit a) (ha0 : a ≠ 0) : multiplicity a a = 1 := sorry

@[simp] theorem get_multiplicity_self {α : Type u_1} [comm_cancel_monoid_with_zero α] [DecidableRel has_dvd.dvd] {a : α} (ha : finite a a) : roption.get (multiplicity a a) ha = 1 := sorry

protected theorem mul' {α : Type u_1} [comm_cancel_monoid_with_zero α] [DecidableRel has_dvd.dvd] {p : α} {a : α} {b : α} (hp : prime p) (h : roption.dom (multiplicity p (a * b))) : roption.get (multiplicity p (a * b)) h =
  roption.get (multiplicity p a) (and.left (iff.mp (finite_mul_iff hp) h)) +
    roption.get (multiplicity p b) (and.right (iff.mp (finite_mul_iff hp) h)) := sorry

protected theorem mul {α : Type u_1} [comm_cancel_monoid_with_zero α] [DecidableRel has_dvd.dvd] {p : α} {a : α} {b : α} (hp : prime p) : multiplicity p (a * b) = multiplicity p a + multiplicity p b := sorry

theorem finset.prod {α : Type u_1} [comm_cancel_monoid_with_zero α] [DecidableRel has_dvd.dvd] {β : Type u_2} {p : α} (hp : prime p) (s : finset β) (f : β → α) : multiplicity p (finset.prod s fun (x : β) => f x) = finset.sum s fun (x : β) => multiplicity p (f x) := sorry

protected theorem pow' {α : Type u_1} [comm_cancel_monoid_with_zero α] [DecidableRel has_dvd.dvd] {p : α} {a : α} (hp : prime p) (ha : finite p a) {k : ℕ} : roption.get (multiplicity p (a ^ k)) (finite_pow hp ha) = k * roption.get (multiplicity p a) ha := sorry

theorem pow {α : Type u_1} [comm_cancel_monoid_with_zero α] [DecidableRel has_dvd.dvd] {p : α} {a : α} (hp : prime p) {k : ℕ} : multiplicity p (a ^ k) = k •ℕ multiplicity p a := sorry

theorem multiplicity_pow_self {α : Type u_1} [comm_cancel_monoid_with_zero α] [DecidableRel has_dvd.dvd] {p : α} (h0 : p ≠ 0) (hu : ¬is_unit p) (n : ℕ) : multiplicity p (p ^ n) = ↑n := sorry

theorem multiplicity_pow_self_of_prime {α : Type u_1} [comm_cancel_monoid_with_zero α] [DecidableRel has_dvd.dvd] {p : α} (hp : prime p) (n : ℕ) : multiplicity p (p ^ n) = ↑n :=
  multiplicity_pow_self (prime.ne_zero hp) (prime.not_unit hp) n

end multiplicity

theorem multiplicity_eq_zero_of_coprime {p : ℕ} {a : ℕ} {b : ℕ} (hp : p ≠ 1) (hle : multiplicity p a ≤ multiplicity p b) (hab : nat.coprime a b) : multiplicity p a = 0 := sorry


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tim Baumann, Stephen Morgan, Scott Morrison, Floris van Doorn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.natural_transformation
import Mathlib.PostPort

universes u₁ u₂ v₁ v₂ v₃ u₃

namespace Mathlib

namespace category_theory

/--
`functor.category C D` gives the category structure on functors and natural transformations
between categories `C` and `D`.

Notice that if `C` and `D` are both small categories at the same universe level,
this is another small category at that level.
However if `C` and `D` are both large categories at the same universe level,
this is a small category at the next higher level.
-/
protected instance functor.category (C : Type u₁) [category C] (D : Type u₂) [category D] :
    category (C ⥤ D) :=
  category.mk

namespace nat_trans

@[simp] theorem vcomp_eq_comp {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D}
    {G : C ⥤ D} {H : C ⥤ D} (α : F ⟶ G) (β : G ⟶ H) : vcomp α β = α ≫ β :=
  rfl

theorem vcomp_app' {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D}
    {H : C ⥤ D} (α : F ⟶ G) (β : G ⟶ H) (X : C) : app (α ≫ β) X = app α X ≫ app β X :=
  rfl

theorem congr_app {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D}
    {α : F ⟶ G} {β : F ⟶ G} (h : α = β) (X : C) : app α X = app β X :=
  eq.mpr (id (Eq._oldrec (Eq.refl (app α X = app β X)) h)) (Eq.refl (app β X))

@[simp] theorem id_app {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) (X : C) :
    app 𝟙 X = 𝟙 :=
  rfl

@[simp] theorem comp_app {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D}
    {G : C ⥤ D} {H : C ⥤ D} (α : F ⟶ G) (β : G ⟶ H) (X : C) : app (α ≫ β) X = app α X ≫ app β X :=
  rfl

theorem app_naturality {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃}
    [category E] {F : C ⥤ D ⥤ E} {G : C ⥤ D ⥤ E} (T : F ⟶ G) (X : C) {Y : D} {Z : D} (f : Y ⟶ Z) :
    functor.map (functor.obj F X) f ≫ app (app T X) Z =
        app (app T X) Y ≫ functor.map (functor.obj G X) f :=
  naturality (app T X) f

theorem naturality_app {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃}
    [category E] {F : C ⥤ D ⥤ E} {G : C ⥤ D ⥤ E} (T : F ⟶ G) (Z : D) {X : C} {Y : C} (f : X ⟶ Y) :
    app (functor.map F f) Z ≫ app (app T Y) Z = app (app T X) Z ≫ app (functor.map G f) Z :=
  congr_fun (congr_arg app (naturality T f)) Z

/-- A natural transformation is a monomorphism if each component is. -/
theorem mono_app_of_mono {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D}
    {G : C ⥤ D} (α : F ⟶ G) [∀ (X : C), mono (app α X)] : mono α :=
  sorry

/-- A natural transformation is an epimorphism if each component is. -/
theorem epi_app_of_epi {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D}
    (α : F ⟶ G) [∀ (X : C), epi (app α X)] : epi α :=
  sorry

/-- `hcomp α β` is the horizontal composition of natural transformations. -/
def hcomp {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E]
    {F : C ⥤ D} {G : C ⥤ D} {H : D ⥤ E} {I : D ⥤ E} (α : F ⟶ G) (β : H ⟶ I) : F ⋙ H ⟶ G ⋙ I :=
  mk fun (X : C) => app β (functor.obj F X) ≫ functor.map I (app α X)

infixl:80 " ◫ " => Mathlib.category_theory.nat_trans.hcomp

@[simp] theorem hcomp_app {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃}
    [category E] {F : C ⥤ D} {G : C ⥤ D} {H : D ⥤ E} {I : D ⥤ E} (α : F ⟶ G) (β : H ⟶ I) (X : C) :
    app (α ◫ β) X = app β (functor.obj F X) ≫ functor.map I (app α X) :=
  rfl

@[simp] theorem hcomp_id_app {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃}
    [category E] {F : C ⥤ D} {G : C ⥤ D} {H : D ⥤ E} (α : F ⟶ G) (X : C) :
    app (α ◫ 𝟙) X = functor.map H (app α X) :=
  sorry

theorem id_hcomp_app {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃}
    [category E] {F : C ⥤ D} {G : C ⥤ D} {H : E ⥤ C} (α : F ⟶ G) (X : E) :
    app (𝟙 ◫ α) X = app α (functor.obj H X) :=
  sorry

-- Note that we don't yet prove a `hcomp_assoc` lemma here: even stating it is painful, because we

-- need to use associativity of functor composition. (It's true without the explicit associator,

-- because functor composition is definitionally associative, but relying on the definitional equality

-- causes bad problems with elaboration later.)

theorem exchange {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E]
    {F : C ⥤ D} {G : C ⥤ D} {H : C ⥤ D} {I : D ⥤ E} {J : D ⥤ E} {K : D ⥤ E} (α : F ⟶ G) (β : G ⟶ H)
    (γ : I ⟶ J) (δ : J ⟶ K) : (α ≫ β) ◫ (γ ≫ δ) = α ◫ γ ≫ β ◫ δ :=
  sorry

end nat_trans

namespace functor

/-- Flip the arguments of a bifunctor. See also `currying.lean`. -/
protected def flip {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E]
    (F : C ⥤ D ⥤ E) : D ⥤ C ⥤ E :=
  mk
    (fun (k : D) =>
      mk (fun (j : C) => obj (obj F j) k) fun (j j' : C) (f : j ⟶ j') => nat_trans.app (map F f) k)
    fun (c c' : D) (f : c ⟶ c') => nat_trans.mk fun (j : C) => map (obj F j) f

@[simp] theorem flip_obj_obj {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃}
    [category E] (F : C ⥤ D ⥤ E) (c : C) (d : D) :
    obj (obj (functor.flip F) d) c = obj (obj F c) d :=
  rfl

@[simp] theorem flip_obj_map {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃}
    [category E] (F : C ⥤ D ⥤ E) {c : C} {c' : C} (f : c ⟶ c') (d : D) :
    map (obj (functor.flip F) d) f = nat_trans.app (map F f) d :=
  rfl

@[simp] theorem flip_map_app {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃}
    [category E] (F : C ⥤ D ⥤ E) {d : D} {d' : D} (f : d ⟶ d') (c : C) :
    nat_trans.app (map (functor.flip F) f) c = map (obj F c) f :=
  rfl

end Mathlib


theorem byCases_Bool_bind [Monad m] (x : m Bool) (f g : Bool → m β) (isTrue : f true = g true) (isFalse : f false = g false) : (x >>= f) = (x >>= g) := by
  have : f = g := by
    funext b; cases b <;> assumption
  rw [this]

theorem eq_findM [Monad m] [LawfulMonad m] (p : α → m Bool) (xs : List α) :
    (do for x in xs do
          let b ← p x
          if b then
            return some x
        return none)
    =
    xs.findM? p := by
  induction xs with simp [List.findM?]
  | cons x xs ih =>
    rw [← ih]; simp
    apply byCases_Bool_bind <;> simp

theorem eq_findSomeM_findM [Monad m] [LawfulMonad m] (p : α → m Bool) (xss : List (List α)) :
    (do for xs in xss do
           for x in xs do
             let b ← p x
             if b then
               return some x
        return none)
    =
    xss.findSomeM? (fun xs => xs.findM? p) := by
  induction xss with simp [List.findSomeM?]
  | cons xs xss ih =>
    rw [← ih, ← eq_findM]
    induction xs with simp
    | cons x xs ih =>
      apply byCases_Bool_bind <;> simp [ih]

theorem eq_findSomeM_findM' [Monad m] [LawfulMonad m] (p : α → m Bool) (xss : List (List α)) :
    (do for xs in xss do
           for x in xs do
             let b ← p x
             if b then
               return some x
        return none)
    =
    xss.findSomeM? (fun xs => xs.findM? p) := by
  induction xss <;> simp [List.findSomeM?]
  rename List α => xs
  rename _ = _  => ih
  rw [← ih, ← eq_findM]
  induction xs <;> simp
  rename _ = _ => ih
  apply byCases_Bool_bind <;> simp [ih]

theorem z_add (x : Nat) : 0 + x = x := by
  induction x
  rfl
  rename _ = _ => ih
  show Nat.succ (0 + _) = _
  rw [ih]


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.algebra.tower
import Mathlib.algebra.invertible
import Mathlib.linear_algebra.basis
import Mathlib.ring_theory.adjoin
import Mathlib.PostPort

universes u v w u₁ u_1 u_2 u_3 u_4 v₁ w₁

namespace Mathlib

/-!
# Towers of algebras

We set up the basic theory of algebra towers.
An algebra tower A/S/R is expressed by having instances of `algebra A S`,
`algebra R S`, `algebra R A` and `is_scalar_tower R S A`, the later asserting the
compatibility condition `(r • s) • a = r • (s • a)`.

In `field_theory/tower.lean` we use this to prove the tower law for finite extensions,
that if `R` and `S` are both fields, then `[A:R] = [A:S] [S:A]`.

In this file we prepare the main lemma:
if `{bi | i ∈ I}` is an `R`-basis of `S` and `{cj | j ∈ J}` is a `S`-basis
of `A`, then `{bi cj | i ∈ I, j ∈ J}` is an `R`-basis of `A`. This statement does not require the
base rings to be a field, so we also generalize the lemma to rings in this file.
-/

namespace is_scalar_tower

protected instance polynomial (R : Type u) {S : Type v} {A : Type w} [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A] : is_scalar_tower R S (polynomial A) :=
  of_algebra_map_eq fun (x : R) => congr_arg (⇑polynomial.C) (algebra_map_apply R S A x)

theorem aeval_apply (R : Type u) (S : Type v) (A : Type w) [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A] (x : A) (p : polynomial R) : coe_fn (polynomial.aeval x) p = coe_fn (polynomial.aeval x) (polynomial.map (algebra_map R S) p) := sorry

/-- Suppose that `R -> S -> A` is a tower of algebras.
If an element `r : R` is invertible in `S`, then it is invertible in `A`. -/
def invertible.algebra_tower (R : Type u) (S : Type v) (A : Type w) [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A] (r : R) [invertible (coe_fn (algebra_map R S) r)] : invertible (coe_fn (algebra_map R A) r) :=
  invertible.copy (invertible.map (↑(algebra_map S A)) (coe_fn (algebra_map R S) r)) (coe_fn (algebra_map R A) r) sorry

/-- A natural number that is invertible when coerced to `R` is also invertible
when coerced to any `R`-algebra. -/
def invertible_algebra_coe_nat (R : Type u) (A : Type w) [comm_semiring R] [semiring A] [algebra R A] (n : ℕ) [inv : invertible ↑n] : invertible ↑n :=
  invertible.algebra_tower ℕ R A n

theorem algebra_map_aeval (R : Type u) (A : Type w) (B : Type u₁) [comm_semiring R] [comm_semiring A] [comm_semiring B] [algebra R A] [algebra A B] [algebra R B] [is_scalar_tower R A B] (x : A) (p : polynomial R) : coe_fn (algebra_map A B) (coe_fn (polynomial.aeval x) p) = coe_fn (polynomial.aeval (coe_fn (algebra_map A B) x)) p := sorry

theorem aeval_eq_zero_of_aeval_algebra_map_eq_zero (R : Type u) (A : Type w) (B : Type u₁) [comm_semiring R] [comm_semiring A] [comm_semiring B] [algebra R A] [algebra A B] [algebra R B] [is_scalar_tower R A B] {x : A} {p : polynomial R} (h : function.injective ⇑(algebra_map A B)) (hp : coe_fn (polynomial.aeval (coe_fn (algebra_map A B) x)) p = 0) : coe_fn (polynomial.aeval x) p = 0 := sorry

theorem aeval_eq_zero_of_aeval_algebra_map_eq_zero_field {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_semiring R] [field A] [comm_semiring B] [nontrivial B] [algebra R A] [algebra R B] [algebra A B] [is_scalar_tower R A B] {x : A} {p : polynomial R} (h : coe_fn (polynomial.aeval (coe_fn (algebra_map A B) x)) p = 0) : coe_fn (polynomial.aeval x) p = 0 :=
  aeval_eq_zero_of_aeval_algebra_map_eq_zero R A B (ring_hom.injective (algebra_map A B)) h

end is_scalar_tower

namespace algebra

theorem adjoin_algebra_map' {R : Type u} {S : Type v} {A : Type w} [comm_ring R] [comm_ring S] [comm_ring A] [algebra R S] [algebra S A] (s : set S) : adjoin R (⇑(algebra_map S (comap R S A)) '' s) = subalgebra.map (adjoin R s) (to_comap R S A) := sorry

theorem adjoin_algebra_map (R : Type u) (S : Type v) (A : Type w) [comm_ring R] [comm_ring S] [comm_ring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A] (s : set S) : adjoin R (⇑(algebra_map S A) '' s) = subalgebra.map (adjoin R s) (is_scalar_tower.to_alg_hom R S A) := sorry

theorem adjoin_res (C : Type u_1) (D : Type u_2) (E : Type u_3) [comm_semiring C] [comm_semiring D] [comm_semiring E] [algebra C D] [algebra C E] [algebra D E] [is_scalar_tower C D E] (S : set E) : subalgebra.res C (adjoin D S) =
  subalgebra.under (subalgebra.map ⊤ (is_scalar_tower.to_alg_hom C D E))
    (adjoin (↥(subalgebra.map ⊤ (is_scalar_tower.to_alg_hom C D E))) S) := sorry

theorem adjoin_res_eq_adjoin_res (C : Type u_1) (D : Type u_2) (E : Type u_3) (F : Type u_4) [comm_semiring C] [comm_semiring D] [comm_semiring E] [comm_semiring F] [algebra C D] [algebra C E] [algebra C F] [algebra D F] [algebra E F] [is_scalar_tower C D F] [is_scalar_tower C E F] {S : set D} {T : set E} (hS : adjoin C S = ⊤) (hT : adjoin C T = ⊤) : subalgebra.res C (adjoin E (⇑(algebra_map D F) '' S)) = subalgebra.res C (adjoin D (⇑(algebra_map E F) '' T)) := sorry

end algebra

namespace subalgebra

@[simp] theorem aeval_coe (R : Type u) {A : Type w} [comm_semiring R] [comm_semiring A] [algebra R A] {S : subalgebra R A} {x : ↥S} {p : polynomial R} : coe_fn (polynomial.aeval ↑x) p = ↑(coe_fn (polynomial.aeval x) p) :=
  Eq.symm (is_scalar_tower.algebra_map_aeval R (↥S) A x p)

end subalgebra

theorem algebra.fg_trans' {R : Type u_1} {S : Type u_2} {A : Type u_3} [comm_ring R] [comm_ring S] [comm_ring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A] (hRS : subalgebra.fg ⊤) (hSA : subalgebra.fg ⊤) : subalgebra.fg ⊤ := sorry

theorem linear_independent_smul {R : Type u} {S : Type v} {A : Type w} [comm_ring R] [ring S] [add_comm_group A] [algebra R S] [module S A] [module R A] [is_scalar_tower R S A] {ι : Type v₁} {b : ι → S} {ι' : Type w₁} {c : ι' → A} (hb : linear_independent R b) (hc : linear_independent S c) : linear_independent R fun (p : ι × ι') => b (prod.fst p) • c (prod.snd p) := sorry

theorem is_basis.smul {R : Type u} {S : Type v} {A : Type w} [comm_ring R] [ring S] [add_comm_group A] [algebra R S] [module S A] [module R A] [is_scalar_tower R S A] {ι : Type v₁} {b : ι → S} {ι' : Type w₁} {c : ι' → A} (hb : is_basis R b) (hc : is_basis S c) : is_basis R fun (p : ι × ι') => b (prod.fst p) • c (prod.snd p) := sorry

theorem is_basis.smul_repr {R : Type u} {S : Type v} {A : Type w} [comm_ring R] [ring S] [add_comm_group A] [algebra R S] [module S A] [module R A] [is_scalar_tower R S A] {ι : Type u_1} {ι' : Type u_2} {b : ι → S} {c : ι' → A} (hb : is_basis R b) (hc : is_basis S c) (x : A) (ij : ι × ι') : coe_fn (coe_fn (is_basis.repr (is_basis.smul hb hc)) x) ij =
  coe_fn (coe_fn (is_basis.repr hb) (coe_fn (coe_fn (is_basis.repr hc) x) (prod.snd ij))) (prod.fst ij) := sorry

theorem is_basis.smul_repr_mk {R : Type u} {S : Type v} {A : Type w} [comm_ring R] [ring S] [add_comm_group A] [algebra R S] [module S A] [module R A] [is_scalar_tower R S A] {ι : Type u_1} {ι' : Type u_2} {b : ι → S} {c : ι' → A} (hb : is_basis R b) (hc : is_basis S c) (x : A) (i : ι) (j : ι') : coe_fn (coe_fn (is_basis.repr (is_basis.smul hb hc)) x) (i, j) =
  coe_fn (coe_fn (is_basis.repr hb) (coe_fn (coe_fn (is_basis.repr hc) x) j)) i := sorry

theorem exists_subalgebra_of_fg (A : Type w) (B : Type u₁) (C : Type u_1) [comm_ring A] [comm_ring B] [comm_ring C] [algebra A B] [algebra B C] [algebra A C] [is_scalar_tower A B C] (hAC : subalgebra.fg ⊤) (hBC : submodule.fg ⊤) : ∃ (B₀ : subalgebra A B), subalgebra.fg B₀ ∧ submodule.fg ⊤ := sorry

/-- Artin--Tate lemma: if A ⊆ B ⊆ C is a chain of subrings of commutative rings, and
A is noetherian, and C is algebra-finite over A, and C is module-finite over B,
then B is algebra-finite over A.

References: Atiyah--Macdonald Proposition 7.8; Stacks 00IS; Altman--Kleiman 16.17. -/
theorem fg_of_fg_of_fg (A : Type w) (B : Type u₁) (C : Type u_1) [comm_ring A] [comm_ring B] [comm_ring C] [algebra A B] [algebra B C] [algebra A C] [is_scalar_tower A B C] [is_noetherian_ring A] (hAC : subalgebra.fg ⊤) (hBC : submodule.fg ⊤) (hBCi : function.injective ⇑(algebra_map B C)) : subalgebra.fg ⊤ := sorry

/-- Restrict the domain of an `alg_hom`. -/
def alg_hom.restrict_domain {A : Type w} (B : Type u₁) {C : Type u_1} {D : Type u_2} [comm_semiring A] [comm_semiring C] [comm_semiring D] [algebra A C] [algebra A D] (f : alg_hom A C D) [comm_semiring B] [algebra A B] [algebra B C] [is_scalar_tower A B C] : alg_hom A B D :=
  alg_hom.comp f (is_scalar_tower.to_alg_hom A B C)

/-- Extend the scalars of an `alg_hom`. -/
def alg_hom.extend_scalars {A : Type w} (B : Type u₁) {C : Type u_1} {D : Type u_2} [comm_semiring A] [comm_semiring C] [comm_semiring D] [algebra A C] [algebra A D] (f : alg_hom A C D) [comm_semiring B] [algebra A B] [algebra B C] [is_scalar_tower A B C] : alg_hom B C D :=
  alg_hom.mk (alg_hom.to_fun f) sorry sorry sorry sorry sorry

/-- `alg_hom`s from the top of a tower are equivalent to a pair of `alg_hom`s. -/
def alg_hom_equiv_sigma {A : Type w} {B : Type u₁} {C : Type u_1} {D : Type u_2} [comm_semiring A] [comm_semiring C] [comm_semiring D] [algebra A C] [algebra A D] [comm_semiring B] [algebra A B] [algebra B C] [is_scalar_tower A B C] : alg_hom A C D ≃ sigma fun (f : alg_hom A B D) => alg_hom B C D :=
  equiv.mk (fun (f : alg_hom A C D) => sigma.mk (alg_hom.restrict_domain B f) (alg_hom.extend_scalars B f))
    (fun (fg : sigma fun (f : alg_hom A B D) => alg_hom B C D) => is_scalar_tower.restrict_base A (sigma.snd fg)) sorry
    sorry


/-
Copyright (c) 2014-15 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Floris van Doorn

Partially ported from Coq HoTT
Theorems about sigma-types (dependent sums)
-/
import .prod

universes u v w
hott_theory

namespace hott

open hott.eq sigma hott.equiv hott.is_equiv function hott.is_trunc sum unit

@[reducible, hott]
def dpair {α β} := @sigma.mk α β

namespace sigma
  variables {A : Type _} {A' : Type _} {B : A → Type _} {B' : A' → Type _} {C : Πa, B a → Type _}
            {D : Πa b, C a b → Type _}
            {a a' a'' : A} {b b₁ b₂ : B a} {b' : B a'} {b'' : B a''} {u v w : Σa, B a}

  @[hott] def destruct := @sigma.cases_on

  /- Paths in a sigma-type -/

  @[hott] protected def eta : Π (u : Σa, B a), (⟨u.1 , u.2⟩: sigma _) = u
  | ⟨u₁, u₂⟩ := idp

  @[hott] def eta2 : Π (u : Σa b, C a b), (⟨u.1, u.2.1, u.2.2⟩: Σ _ _, _) = u
  | ⟨u₁, u₂, u₃⟩ := idp

  @[hott] def eta3 : Π (u : Σa b c, D a b c), (⟨u.1, u.2.1, u.2.2.1, u.2.2.2⟩: Σ _ _ _, _) = u
  | ⟨u₁, u₂, u₃, u₄⟩ := idp

  @[hott] def dpair_eq_dpair (p : a = a') (q : b =[p] b') : (⟨a, b⟩: Σ _, _) = ⟨a', b'⟩ :=
  apd011 sigma.mk p q

  @[hott] def sigma_eq (p : u.1 = v.1) (q : u.2 =[p] v.2) : u = v :=
  by induction u; induction v; exact (dpair_eq_dpair p q)

  @[hott] def sigma_eq_right (q : b₁ = b₂) : (⟨a, b₁⟩: Σ _, _) = ⟨a, b₂⟩ :=
  ap (dpair a) q

  @[hott] def eq_fst (p : u = v) : u.1 = v.1 :=
  ap fst p

  postfix `..1`:(max+1) := eq_fst

  @[hott] def eq_snd (p : u = v) : u.2 =[p..1] v.2 :=
  by induction p; exact idpo

  postfix `..2`:(max+1) := eq_snd

  @[hott] def dpair_sigma_eq (p : u.1 = v.1) (q : u.2 =[p] v.2)
    : (⟨(sigma_eq p q)..1, (sigma_eq p q)..2⟩: Σ p, u.2 =[p] v.2) = ⟨p, q⟩ :=
  by induction u; induction v;dsimp at *;induction q;refl

  @[hott] def sigma_eq_fst (p : u.1 = v.1) (q : u.2 =[p] v.2) : (sigma_eq p q)..1 = p :=
  (dpair_sigma_eq p q)..1

  @[hott] def sigma_eq_snd (p : u.1 = v.1) (q : u.2 =[p] v.2)
    : (sigma_eq p q)..2 =[sigma_eq_fst p q; λ p, u.2 =[p] v.2] q :=
  (dpair_sigma_eq p q)..2

  @[hott] def sigma_eq_eta (p : u = v) : sigma_eq (p..1) (p..2) = p :=
  by induction p; induction u; reflexivity

  @[hott] def eq2_fst {p q : u = v} (r : p = q) : p..1 = q..1 :=
  ap eq_fst r

  @[hott] def eq2_snd {p q : u = v} (r : p = q) : p..2 =[eq2_fst r; λ x, u.2 =[x] v.2] q..2 :=
  by apply pathover_ap; apply (apd eq_snd r)

  @[hott] def tr_fst_sigma_eq {B' : A → Type _} (p : u.1 = v.1) (q : u.2 =[p] v.2)
    : transport (λx : sigma _, B' x.1) (sigma_eq p q) = transport B' p :=
  by induction u; induction v; dsimp at *;induction q; reflexivity

  @[hott] protected def ap_fst (p : u = v) : ap (λx : sigma B, x.1) p = p..1 := idp

  /- the uncurried version of sigma_eq. We will prove that this is an equivalence -/

  @[hott] def sigma_eq_unc : Π (pq : Σ(p : u.1 = v.1), u.2 =[p] v.2), u = v
  | ⟨pq₁, pq₂⟩ := sigma_eq pq₁ pq₂

  @[hott] def dpair_sigma_eq_unc : Π (pq : Σ(p : u.1 = v.1), u.2 =[p] v.2),
    (⟨(sigma_eq_unc pq)..1, (sigma_eq_unc pq)..2⟩: Σ p, u.2 =[p] v.2) = pq
  | ⟨pq₁, pq₂⟩ := dpair_sigma_eq pq₁ pq₂

  @[hott] def sigma_eq_fst_unc (pq : Σ(p : u.1 = v.1), u.2 =[p] v.2)
    : (sigma_eq_unc pq)..1 = pq.1 :=
  (dpair_sigma_eq_unc pq)..1

  @[hott] def sigma_eq_snd_unc (pq : Σ(p : u.1 = v.1), u.2 =[p] v.2) :
    (sigma_eq_unc pq)..2 =[sigma_eq_fst_unc pq; λ p, u.2 =[p] v.2] pq.2 :=
  (dpair_sigma_eq_unc pq)..2

  @[hott] def sigma_eq_eta_unc (p : u = v) : sigma_eq_unc ⟨p..1, p..2⟩ = p :=
  sigma_eq_eta p

  @[hott] def tr_sigma_eq_fst_unc {B' : A → Type _}
    (pq : Σ(p : u.1 = v.1), u.2 =[p] v.2)
      : transport (λx:sigma _, B' x.1) (@sigma_eq_unc A B u v pq) = transport B' pq.1 :=
  by apply destruct pq; apply tr_fst_sigma_eq

  @[hott, instance] def is_equiv_sigma_eq (u v : Σa, B a)
      : is_equiv (@sigma_eq_unc A B u v) :=
  adjointify sigma_eq_unc
             (λp, ⟨p..1, p..2⟩)
             sigma_eq_eta_unc
             dpair_sigma_eq_unc

  @[hott] def sigma_eq_equiv (u v : Σa, B a)
    : (u = v) ≃ (Σ(p : u.1 = v.1),  u.2 =[p] v.2) :=
  (equiv.mk sigma_eq_unc (by apply_instance))⁻¹ᵉ

  @[hott] def dpair_eq_dpair_con (p1 : a  = a' ) (q1 : b  =[p1] b' )
                                (p2 : a' = a'') (q2 : b' =[p2] b'') :
    dpair_eq_dpair (p1 ⬝ p2) (q1 ⬝o q2) = dpair_eq_dpair p1 q1 ⬝ dpair_eq_dpair  p2 q2 :=
  by induction q1; induction q2; reflexivity

  @[hott] def sigma_eq_con (p1 : u.1 = v.1) (q1 : u.2 =[p1] v.2)
                          (p2 : v.1 = w.1) (q2 : v.2 =[p2] w.2) :
    sigma_eq (p1 ⬝ p2) (q1 ⬝o q2) = sigma_eq p1 q1 ⬝ sigma_eq p2 q2 :=
  by induction u; induction v; induction w; apply dpair_eq_dpair_con

  @[hott] def dpair_eq_dpair_con_idp (p : a = a') (q : b =[p] b') :
    dpair_eq_dpair p q = dpair_eq_dpair p (pathover_tr _ _) ⬝
    dpair_eq_dpair idp (pathover_idp_of_eq _ (tr_eq_of_pathover q)) :=
  by induction q; reflexivity

  /- eq_fst commutes with the groupoid structure. -/

  @[hott] def eq_fst_idp (u : Σa, B a)           : (idpath u) ..1 = refl (u.1)      := idp
  @[hott] def eq_fst_con (p : u = v) (q : v = w) : (p ⬝ q)  ..1 = (p..1) ⬝ (q..1) := ap_con _ _ _
  @[hott] def eq_fst_inv (p : u = v)             : p⁻¹      ..1 = (p..1)⁻¹        := ap_inv _ _

  /- Applying dpair to one argument is the same as dpair_eq_dpair with reflexivity in the first place. -/

  @[hott] def ap_dpair (q : b₁ = b₂) :
    ap (sigma.mk a) q = dpair_eq_dpair idp (pathover_idp_of_eq _ q) :=
  by induction q; reflexivity

  /- Dependent transport is the same as transport along a sigma_eq. -/

  @[hott] def transportD_eq_transport (p : a = a') (c : C a b) :
      p ▸D c = transport (λu : sigma _, C (u.1) (u.2)) (dpair_eq_dpair p (pathover_tr _ _)) c :=
  by induction p; reflexivity

  @[hott] def sigma_eq_eq_sigma_eq {p1 q1 : a = a'} {p2 : b =[p1] b'} {q2 : b =[q1] b'}
      (r : p1 = q1) (s : p2 =[r; λ p, b =[p] b'] q2) : @sigma_eq _ _ ⟨a,b⟩ ⟨a',b'⟩ p1 p2 = sigma_eq q1 q2 :=
  by induction s; reflexivity

  /- A path between paths in a total space is commonly shown component wise. -/
  @[hott] def sigma_eq2 {p q : u = v} (r : p..1 = q..1) (s : p..2 =[r; λ p, u.2 =[p] v.2] q..2)
    : p = q :=
  begin
    induction p, induction u with u1 u2,
    transitivity sigma_eq q..1 q..2,
      apply sigma_eq_eq_sigma_eq r s,
      apply sigma_eq_eta,
  end

  @[hott] def sigma_eq2_unc {p q : u = v} (rs : Σ(r : p..1 = q..1), p..2 =[r; λ p, u.2 =[p] v.2] q..2) : p = q :=
  by apply destruct rs; apply sigma_eq2

  @[hott] def ap_dpair_eq_dpair (f : Πa, B a → A') (p : a = a') (q : b =[p] b')
    : @ap _ A' (@sigma.rec _ _ (λ _, A') f) _ _ (dpair_eq_dpair p q) = apd011 f p q :=
  by induction q; reflexivity

  /- Transport -/

  /- The concrete description of transport in sigmas (and also pis) is rather trickier than in the other types.  In particular, these cannot be described just in terms of transport in simpler types; they require also the dependent transport [transportD].

  In particular, this indicates why `transport` alone cannot be fully defined by induction on the structure of types, although Id-elim/transportD can be (cf. Observational Type _ Theory).  A more thorough set of lemmas, along the lines of the present ones but dealing with Id-elim rather than just transport, might be nice to have eventually? -/

  @[hott] def sigma_transport (p : a = a') (bc : Σ(b : B a), C a b)
    : p ▸ bc = ⟨p ▸ bc.1, p ▸D bc.2⟩ :=
  by induction p; induction bc; reflexivity

  /- The special case when the second variable doesn't depend on the first is simpler. -/
  @[hott] def sigma_transport_nondep {B : Type _} {C : A → B → Type _} (p : a = a')
    (bc : Σ(b : B), C a b) : p ▸ bc = ⟨bc.1, transport (λ a, C a bc.1) p bc.2⟩ :=
  by induction p; induction bc; reflexivity

  /- Or if the second variable contains a first component that doesn't depend on the first. -/

  @[hott] def sigma_transport2_nondep {C : A → Type _} {D : Π a:A, B a → C a → Type _} (p : a = a')
      (bcd : Σ(b : B a) (c : C a), D a b c) : p ▸ bcd = ⟨p ▸ bcd.1, p ▸ bcd.2.1, p ▸D2 bcd.2.2⟩ :=
  begin
    induction p, induction bcd with b cd, induction cd, reflexivity
  end

  /- Pathovers -/

  @[hott] def etao (p : a = a') (bc : Σ(b : B a), C a b)
    : bc =[p; λ a, Σ b, C a b] ⟨p ▸ bc.1, p ▸D bc.2⟩ :=
  by induction p; induction bc; apply idpo

  -- TODO: interchange sigma_pathover and sigma_pathover'
  @[hott] def sigma_pathover (p : a = a') (u : Σ(b : B a), C a b) (v : Σ(b : B a'), C a' b)
    (r : u.1 =[p] v.1) (s : u.2 =[apd011 C p r; id] v.2) : u =[p; λ a, Σ b, C a b] v :=
  begin
    induction u, induction v, dsimp at *, induction r,
    dsimp [apd011] at s, apply idp_rec_on s, apply idpo
  end

  @[hott] def sigma_pathover' (p : a = a') (u : Σ(b : B a), C a b) (v : Σ(b : B a'), C a' b)
    (r : u.1 =[p] v.1) (s : @pathover (sigma _) ⟨a,u.1⟩ (λ x, C x.1 x.2) u.2 ⟨a',v.1⟩ (sigma_eq p r) v.2) :
    u =[p; λ a, Σ b, C a b] v :=
  begin
    induction u, induction v, dsimp at *, induction r,
    apply idp_rec_on s, apply idpo
  end

  @[hott] def sigma_pathover_nondep {B : Type _} {C : A → B → Type _} (p : a = a')
    (u : Σ(b : B), C a b) (v : Σ(b : B), C a' b)
    (r : u.1 = v.1) (s : @pathover (prod _ _) (a,u.1) (λx, C x.1 x.2) u.2 (a',v.1) (prod.prod_eq p r) v.2) :
    u =[p; λ a, Σ b, C a b] v :=
  begin
    induction p, induction u, induction v, dsimp at *, induction r,
    apply idp_rec_on s, apply idpo
  end

  @[hott] def pathover_fst {A : Type _} {B : A → Type _} {C : Πa, B a → Type _}
    {a a' : A} {p : a = a'} {x : Σb, C a b} {x' : Σb', C a' b'}
    (q : x =[p; λ a, Σb, C a b] x') : x.1 =[p] x'.1 :=
  begin induction q, constructor end

  @[hott] def sigma_pathover_equiv_of_is_prop {A : Type _} {B : A → Type _} (C : Πa, B a → Type _)
    {a a' : A} (p : a = a') (x : Σb, C a b) (x' : Σb', C a' b')
    [Πa b, is_prop (C a b)] : x =[p; λa, Σb, C a b] x' ≃ x.1 =[p] x'.1 :=
  begin
    fapply equiv.MK,
    { exact pathover_fst },
    { intro q, induction x with b c, induction x' with b' c', dsimp at q, induction q,
      apply pathover_idp_of_eq, exact sigma_eq idp (is_prop.elimo _ _ _) },
    { intro q, induction x with b c, induction x' with b' c', dsimp at q, induction q,
      have: c = c', by apply is_prop.elim, induction this,
      dsimp, rwr is_prop_elimo_self, },
    { intro q, induction q, induction x with b c,
      dsimp [pathover_fst], rwr is_prop_elimo_self }
  end

  /-
    TODO:
    * define the projections from the type u =[p] v
    * show that the uncurried version of sigma_pathover is an equivalence
  -/
  /- Squares in a sigma type are characterized in cubical.squareover (to avoid circular imports) -/

  /- Functorial action -/
  variables (f : A → A') (g : Πa, B a → B' (f a))

  @[hott] def sigma_functor (u : Σa, B a) : Σa', B' a' :=
  ⟨f u.1, g u.1 u.2⟩

  @[hott] def total {B' : A → Type _} (g : Πa, B a → B' a) : (Σa, B a) → (Σa, B' a) :=
  sigma_functor id g

  /- Equivalences -/
  @[hott] def is_equiv_sigma_functor [H1 : is_equiv f] [H2 : Π a, is_equiv (g a)]
      : is_equiv (sigma_functor f g) :=
  adjointify (sigma_functor f g)
             (sigma_functor f⁻¹ᶠ (λ(a' : A') (b' : B' a'),
               ((g (f⁻¹ᶠ a'))⁻¹ᶠ (transport B' (right_inv f a')⁻¹ b'))))
  begin abstract {
    intro u', induction u' with a' b', fapply sigma_eq,
    {apply right_inv f},
    {dsimp [sigma_functor], rwr right_inv (g (f⁻¹ᶠ a')), apply tr_pathover}
  } end
  begin abstract {
    intro u, induction u with a b, fapply sigma_eq,
    {apply left_inv f},
    {apply pathover_of_tr_eq, dsimp only [sigma_functor],
      rwr [adj f, ← fn_tr_eq_tr_fn (left_inv f a) (λ a, (g a)⁻¹ᶠ),
        tr_compose B', tr_inv_tr], dsimp, rwr left_inv }
  } end

  @[hott] def sigma_equiv_sigma_of_is_equiv
    [H1 : is_equiv f] [H2 : Π a, is_equiv (g a)] : (Σa, B a) ≃ (Σa', B' a') :=
  equiv.mk (sigma_functor f g) (is_equiv_sigma_functor _ _)

  @[hott] def sigma_equiv_sigma (Hf : A ≃ A') (Hg : Π a, B a ≃ B' (Hf a)) :
      (Σa, B a) ≃ (Σa', B' a') :=
  sigma_equiv_sigma_of_is_equiv Hf (λ a, Hg a)

  @[hott] def sigma_equiv_sigma_right {B' : A → Type _} (Hg : Π a, B a ≃ B' a)
    : (Σa, B a) ≃ Σa, B' a :=
  sigma_equiv_sigma equiv.rfl Hg

  variable (B)
  @[hott] def sigma_equiv_sigma_left (Hf : A ≃ A') :
    (Σa, B a) ≃ (Σa', B (Hf⁻¹ᶠ a')) :=
  sigma_equiv_sigma Hf (λ a, equiv_ap B (right_inv Hf⁻¹ᶠ a)⁻¹ᵖ)

  @[hott] def sigma_equiv_sigma_left' (Hf : A' ≃ A) : (Σa, B (Hf a)) ≃ (Σa', B a') :=
  sigma_equiv_sigma Hf (λa, erfl)
  variable {B}

  @[hott] def ap_sigma_functor_eq_dpair (p : a = a') (q : b =[p] b') :
    ap (sigma_functor f g) (@sigma_eq _ _ ⟨a,b⟩ ⟨a',b'⟩ p q) =
      sigma_eq (ap f p) (by exact pathover.rec_on q idpo) :=
  by induction q; reflexivity

  @[hott] def sigma_ua {A B : Type _} (C : A ≃ B → Type _) :
    (Σ(p : A = B), C (equiv_of_eq p)) ≃ Σ(e : A ≃ B), C e :=
  sigma_equiv_sigma_left' C (eq_equiv_equiv _ _)

  -- @[hott] def ap_sigma_functor_eq (p : u.1 = v.1) (q : u.2 =[p] v.2)
  --   : ap (sigma_functor f g) (sigma_eq p q) =
  --     sigma_eq (ap f p)
  --      ((tr_compose B' f p (g u.1 u.2))⁻¹ ⬝ (fn_tr_eq_tr_fn p g u.2)⁻¹ ⬝ ap (g v.1) q) :=
  -- by induction u; induction v; apply ap_sigma_functor_eq_dpair

  /- definition 3.11.9(i): Summing up a contractible family of types does nothing. -/

  @[hott, instance] def is_equiv_fst (B : A → Type _) [H : Π a, is_contr (B a)]
      : is_equiv (@fst A B) :=
  adjointify fst
             (λa, ⟨a, center _⟩)
             (λa, idp)
             (λu, sigma_eq idp (pathover_idp_of_eq _ (center_eq _)))

  @[hott] def sigma_equiv_of_is_contr_right (B : A → Type _) [H : Π a, is_contr (B a)]
    : (Σa, B a) ≃ A :=
  equiv.mk fst (by apply_instance)

  /- definition 3.11.9(ii): Dually, summing up over a contractible type does nothing. -/

  @[hott] def sigma_equiv_of_is_contr_left (B : A → Type _) [H : is_contr A]
    : (Σa, B a) ≃ B (center A) :=
  equiv.MK
    (λu, (center_eq u.1)⁻¹ ▸ u.2)
    (λb, ⟨center _, b⟩)
    begin abstract { intro b, change _ = idpath (center A) ▸ b,
      apply ap (λx, x ▸ b), apply prop_eq_of_is_contr, } end
    begin abstract { exact λu, sigma_eq (center_eq _) (tr_pathover _ _) } end

  /- Associativity -/

  --this proof is harder than in Coq because we don't have eta definitionally for sigma
  @[hott] def sigma_assoc_equiv (C : (Σa, B a) → Type _)
    : (Σa b, C ⟨a, b⟩) ≃ (Σu, C u) :=
  equiv.mk _ (adjointify
    (λav, ⟨⟨av.1, av.2.1⟩, av.2.2⟩)
    (λuc, ⟨uc.1.1, uc.1.2, by rwr sigma.eta; exact uc.2⟩)
    begin abstract { intro uc, induction uc with u c, induction u, reflexivity } end
    begin abstract { intro av, induction av with a v, induction v, reflexivity } end)

  open prod
  @[hott] def assoc_equiv_prod (C : (A × A') → Type _) : (Σa a', C (a,a')) ≃ (Σu, C u) :=
  equiv.mk _ (adjointify
    (λav, ⟨(av.1, av.2.1), av.2.2⟩)
    (λuc, ⟨(uc.1).1, (uc.1).2, by rwr prod.eta; exact uc.2⟩)
    (λ ⟨⟨a,b⟩,c⟩, idp) (λ ⟨a,⟨b,c⟩⟩, idp))

  /- Symmetry -/

  @[hott] def comm_equiv_unc (C : A × A' → Type _) : (Σa a', C (a, a')) ≃ (Σa' a, C (a, a')) :=
  calc
    (Σa a', C (a, a')) ≃ Σu, C u          : assoc_equiv_prod _
                   ... ≃ Σv, C (flip v)   : sigma_equiv_sigma (prod.prod_comm_equiv _ _)
                                              (λ ⟨a,a'⟩, equiv.rfl)
                   ... ≃ Σa' a, C (a, a') : by symmetry; exact assoc_equiv_prod (C ∘ prod.flip)

  @[hott] def sigma_comm_equiv (C : A → A' → Type _)
    : (Σa a', C a a') ≃ (Σa' a, C a a') :=
  comm_equiv_unc (λu, C (fst u) (snd u))

  @[hott] def equiv_prod (A B : Type _) : (Σ(a : A), B) ≃ A × B :=
  equiv.mk _ (adjointify
    (λs, (s.1, s.2))
    (λp, ⟨fst p, snd p⟩)
    (λ⟨a,b⟩, idp) (λ⟨a,b⟩, idp))

  @[hott] def comm_equiv_nondep (A B : Type _) : (Σ(a : A), B) ≃ Σ(b : B), A :=
  calc
    (Σ(a : A), B) ≃ A × B       : by apply equiv_prod
              ... ≃ B × A       : by apply prod.prod_comm_equiv
              ... ≃ Σ(b : B), A : by symmetry; apply equiv_prod

  @[hott] def sigma_assoc_comm_equiv {A : Type _} (B C : A → Type _)
    : (Σ(v : Σa, B a), C v.1) ≃ (Σ(u : Σa, C a), B u.1) :=
  calc    (Σ(v : Σa, B a), C v.1)
        ≃ (Σa (b : B a), C a)     : by symmetry; apply sigma_assoc_equiv (C ∘ fst)
    ... ≃ (Σa (c : C a), B a)     : by apply sigma_equiv_sigma_right; intro a; apply comm_equiv_nondep
    ... ≃ (Σ(u : Σa, C a), B u.1) : by apply sigma_assoc_equiv (B ∘ fst)

  /- Interaction with other type constructors -/

  @[hott] def sigma_empty_left (B : empty → Type _) : (Σx, B x) ≃ empty :=
  begin
    fapply equiv.MK,
    { intro v, induction v, cases v_fst},
    { intro x, cases x},
    { intro x, cases x},
    { intro v, induction v, cases v_fst},
  end

  @[hott] def sigma_empty_right (A : Type _) : (Σ(a : A), empty) ≃ empty :=
  begin
    fapply equiv.MK,
    { intro v, induction v, cases v_snd},
    { intro x, cases x},
    { intro x, cases x},
    { intro v, induction v, cases v_snd},
  end

  @[hott] def sigma_unit_left (B : unit → Type _) : (Σx, B x) ≃ B star :=
  sigma_equiv_of_is_contr_left _

  @[hott] def sigma_unit_right (A : Type _) : (Σ(a : A), unit) ≃ A :=
  sigma_equiv_of_is_contr_right _

  @[hott] def sigma_sum_left (B : A ⊎ A' → Type _)
    : (Σp, B p) ≃ (Σa, B (inl a)) ⊎ (Σa, B (inr a)) :=
  begin
    fapply equiv.MK,
    { intro v,
      induction v with p b,
      induction p,
      { apply inl, constructor, assumption },
      { apply inr, constructor, assumption }},
    { intro p, induction p with v v; induction v; constructor; assumption},
    { intro p, induction p with v v; induction v; reflexivity},
    { intro v, induction v with p b, induction p; reflexivity},
  end

  @[hott] def sigma_sum_right (B C : A → Type _)
    : (Σa, B a ⊎ C a) ≃ (Σa, B a) ⊎ (Σa, C a) :=
  begin
    fapply equiv.MK,
    { intro v,
      induction v with a p,
      induction p,
      { apply inl, constructor, assumption},
      { apply inr, constructor, assumption}},
    { intro p,
      induction p with v v,
      { induction v, constructor, apply inl, assumption },
      { induction v, constructor, apply inr, assumption }},
    { intro p, induction p with v v; induction v; reflexivity},
    { intro v, induction v with a p, induction p; reflexivity},
  end

  @[hott] def sigma_sigma_eq_right {A : Type _} (a : A) (P : Π(b : A), a = b → Type _)
    : (Σ(b : A) (p : a = b), P b p) ≃ P a idp :=
  calc
    (Σ(b : A) (p : a = b), P b p) ≃ (Σ(v : Σ(b : A), a = b), P v.1 v.2) : by apply sigma_assoc_equiv (λ u, P u.fst u.snd)
      ... ≃ P a idp : by apply sigma_equiv_of_is_contr_left (λ v : Σ b, a=b, P v.fst v.snd)

  @[hott] def sigma_sigma_eq_left {A : Type _} (a : A) (P : Π(b : A), b = a → Type _)
    : (Σ(b : A) (p : b = a), P b p) ≃ P a idp :=
  calc
    (Σ(b : A) (p : b = a), P b p) ≃ (Σ(v : Σ(b : A), b = a), P v.1 v.2) : by apply sigma_assoc_equiv (λ u : Σ b, b=a, P u.fst u.snd)
      ... ≃ P a idp : by apply sigma_equiv_of_is_contr_left (λ v : Σ b, b=a, P v.fst v.snd)

  /- ** Universal mapping properties -/
  /- *** The positive universal property. -/

  section
  @[hott, instance] def is_equiv_sigma_rec (C : (Σa, B a) → Type _)
    : is_equiv (sigma.rec : (Πa b, C ⟨a, b⟩) → Πab, C ab) :=
  adjointify _ (λ g a b, g ⟨a, b⟩)
               (λ g, eq_of_homotopy (λ⟨a,b⟩, idp))
               (λ f, refl f)

  @[hott] def equiv_sigma_rec (C : (Σa, B a) → Type _)
    : (Π(a : A) (b: B a), C ⟨a, b⟩) ≃ (Πxy, C xy) :=
  equiv.mk sigma.rec (by apply_instance)

  /- *** The negative universal property. -/

  @[hott] protected def coind_unc (fg : Σ(f : Πa, B a), Πa, C a (f a)) (a : A)
    : Σ(b : B a), C a b :=
  ⟨fg.1 a, fg.2 a⟩

  @[hott] protected def coind (f : Π a, B a) (g : Π a, C a (f a)) (a : A) : Σ(b : B a), C a b :=
  sigma.coind_unc ⟨f, g⟩ a

  --is the instance below dangerous?
  --in Coq this can be done without function extensionality
  @[hott, instance] def is_equiv_coind (C : Πa, B a → Type _)
    : is_equiv (@sigma.coind_unc _ _ C) :=
  adjointify _ (λ h, ⟨λa, (h a).1, λa, (h a).2⟩)
               (λ h, eq_of_homotopy (λu, sigma.eta _))
               (λ⟨f,g⟩, idp)

  variable (C)
  @[hott] def sigma_pi_equiv_pi_sigma : (Σ(f : Πa, B a), Πa, C a (f a)) ≃ (Πa, Σb, C a b) :=
  equiv.mk sigma.coind_unc (by apply_instance)
  variable {C}
  end

  /- Subtypes (sigma types whose second components are props) -/

  @[hott] def subtype {A : Type _} (P : A → Type _) [H : Πa, is_prop (P a)] :=
  Σ(a : A), P a
  notation [parsing_only] `{` binder `|` r:(scoped:1 P, subtype P) `}` := r

  /- To prove equality in a subtype, we only need equality of the first component. -/
  @[hott] def subtype_eq [H : Πa, is_prop (B a)] {u v : {a | B a}} :
    u.1 = v.1 → u = v :=
  sigma_eq_unc ∘ inv fst

  @[hott] def is_equiv_subtype_eq [H : Πa, is_prop (B a)] (u v : {a | B a})
      : is_equiv (subtype_eq : u.1 = v.1 → u = v) :=
  is_equiv_compose _ _
  local attribute [instance] is_equiv_subtype_eq

  @[hott] def equiv_subtype [H : Πa, is_prop (B a)] (u v : {a | B a}) :
    (u.1 = v.1) ≃ (u = v) :=
  equiv.mk subtype_eq (by apply_instance)

  @[hott] def subtype_eq_equiv [H : Πa, is_prop (B a)] (u v : {a | B a}) :
    (u = v) ≃ (u.1 = v.1) :=
  (equiv_subtype u v)⁻¹ᵉ

  @[hott] def subtype_eq_inv {A : Type _} {B : A → Type _} [H : Πa, is_prop (B a)] (u v : Σa, B a)
    : u = v → u.1 = v.1 :=
  subtype_eq⁻¹ᶠ

  @[hott] def is_equiv_subtype_eq_inv {A : Type _} {B : A → Type _} [H : Πa, is_prop (B a)]
    (u v : Σa, B a) : is_equiv (subtype_eq_inv u v) :=
  by delta subtype_eq_inv; apply_instance

  /- truncatedness -/
  @[hott] def is_trunc_sigma (B : A → Type _) (n : trunc_index)
      [HA : is_trunc n A] [HB : Πa, is_trunc n (B a)] : is_trunc n (Σa, B a) :=
  begin
  unfreezeI, revert A B HA HB,
  induction n with n IH; resetI,
  { intros A B HA HB, apply is_trunc_equiv_closed_rev -2 (sigma_equiv_of_is_contr_left B) (HB _) },
  { intros A B HA HB, apply is_trunc_succ_intro, intros u v,
    apply is_trunc_equiv_closed_rev _ (sigma_eq_equiv _ _) (IH _);
    apply_instance }
  end

  @[hott] theorem is_trunc_subtype (B : A → Prop) (n : trunc_index)
      [HA : is_trunc (n.+1) A] : is_trunc (n.+1) (Σa, B a) :=
  @is_trunc_sigma _ (λ a, B a) (n.+1) _ (λa, is_trunc_succ_of_is_prop _ _)

  /- if the total space is a mere proposition, you can equate two points in the base type by
     finding points in their fibers -/
  @[hott] def eq_base_of_is_prop_sigma {A : Type _} (B : A → Type _) (H : is_prop (Σa, B a)) {a a' : A}
    (b : B a) (b' : B a') : a = a' :=
  (@is_prop.elim (Σa, B a) _ ⟨a, b⟩ ⟨a', b'⟩)..1

end sigma

attribute [instance] sigma.is_trunc_sigma
attribute [instance] sigma.is_trunc_subtype

namespace sigma

  /- pointed sigma type -/
  open pointed

  @[hott, instance] def pointed_sigma {A : Type _} (P : A → Type _) [G : pointed A]
      [H : pointed (P pt)] : pointed (Σx, P x) :=
  pointed.mk ⟨pt,pt⟩

  @[hott] def psigma {A : Type*} (P : A → Type*) : Type* :=
  pointed.mk' (Σa, P a)

  notation `Σ*` binders `, ` r:(scoped P, psigma P) := r

  @[hott] def pfst {A : Type*} {B : A → Type*} : (Σ*(x : A), B x) →* A :=
  pmap.mk fst idp

  @[hott] def psnd {A : Type*} {B : A → Type*} (v : (Σ*(x : A), B x)) : B (pfst.to_fun v) :=
  snd v

  @[hott] def ptsigma {n : ℕ₋₂} {A : n-Type*} (P : A → (n-Type*)) : n-Type* :=
  ptrunctype.mk' n (Σa, P a)

end sigma

end hott