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

import number_theory.cyclotomic.discriminant
import ring_theory.polynomial.eisenstein

/-!
# Ring of integers of `p ^ n`-th cyclotomic fields
We compute the ring of integers of a `p ^ n`-th cyclotomic extension of `ℚ`.

## Main results
* `is_cyclotomic_extension.rat.is_integral_closure_adjoing_singleton_of_prime_pow`: if `K` is a
  `p ^ k`-th cyclotomic extension of `ℚ`, then `(adjoin ℤ {ζ})` is the integral closure of
  `ℤ` in `K`.
* `is_cyclotomic_extension.rat.cyclotomic_ring_is_integral_closure_of_prime_pow`: the integral
  closure of `ℤ` inside `cyclotomic_field (p ^ k) ℚ` is `cyclotomic_ring (p ^ k) ℤ ℚ`.
-/

universes u

open algebra is_cyclotomic_extension polynomial

open_locale cyclotomic

namespace is_cyclotomic_extension.rat

variables {p : ℕ+} {k : ℕ} {K : Type u} [field K] [char_zero K] {ζ : K} [hp : fact (p : ℕ).prime]

include hp

/-- The discriminant of the power basis given by `ζ - 1`. -/
lemma discr_prime_pow_ne_two' [is_cyclotomic_extension {p ^ (k + 1)} ℚ K]
  (hζ : is_primitive_root ζ ↑(p ^ (k + 1))) (hk : p ^ (k + 1) ≠ 2) :
  discr ℚ (hζ.sub_one_power_basis ℚ).basis =
  (-1) ^ (((p ^ (k + 1) : ℕ).totient) / 2) * p ^ ((p : ℕ) ^ k * ((p - 1) * (k + 1) - 1)) :=
begin
  rw [← discr_prime_pow_ne_two hζ (cyclotomic.irreducible_rat (p ^ (k + 1)).pos) hk],
  exact hζ.discr_zeta_eq_discr_zeta_sub_one.symm
end

lemma discr_odd_prime' [is_cyclotomic_extension {p} ℚ K] (hζ : is_primitive_root ζ p)
  (hodd : p ≠ 2) :
  discr ℚ (hζ.sub_one_power_basis ℚ).basis = (-1) ^ (((p : ℕ) - 1) / 2) * p ^ ((p : ℕ) - 2) :=
begin
  rw [← discr_odd_prime hζ (cyclotomic.irreducible_rat hp.out.pos) hodd],
  exact hζ.discr_zeta_eq_discr_zeta_sub_one.symm
end

/-- The discriminant of the power basis given by `ζ - 1`. Beware that in the cases `p ^ k = 1` and
`p ^ k = 2` the formula uses `1 / 2 = 0` and `0 - 1 = 0`. It is useful only to have a uniform
result. See also `is_cyclotomic_extension.rat.discr_prime_pow_eq_unit_mul_pow'`. -/
lemma discr_prime_pow' [is_cyclotomic_extension {p ^ k} ℚ K]
  (hζ : is_primitive_root ζ ↑(p ^ k)) :
  discr ℚ (hζ.sub_one_power_basis ℚ).basis =
  (-1) ^ (((p ^ k : ℕ).totient) / 2) * p ^ ((p : ℕ) ^ (k - 1) * ((p - 1) * k - 1)) :=
begin
  rw [← discr_prime_pow hζ (cyclotomic.irreducible_rat (p ^ k).pos)],
  exact hζ.discr_zeta_eq_discr_zeta_sub_one.symm
end

/-- If `p` is a prime and `is_cyclotomic_extension {p ^ k} K L`, then there are `u : ℤˣ` and
`n : ℕ` such that the discriminant of the power basis given by `ζ - 1` is `u * p ^ n`. Often this is
enough and less cumbersome to use than `is_cyclotomic_extension.rat.discr_prime_pow'`. -/
lemma discr_prime_pow_eq_unit_mul_pow' [is_cyclotomic_extension {p ^ k} ℚ K]
  (hζ : is_primitive_root ζ ↑(p ^ k)) :
  ∃ (u : ℤˣ) (n : ℕ), discr ℚ (hζ.sub_one_power_basis ℚ).basis = u * p ^ n :=
begin
  rw [hζ.discr_zeta_eq_discr_zeta_sub_one.symm],
  exact discr_prime_pow_eq_unit_mul_pow hζ (cyclotomic.irreducible_rat (p ^ k).pos)
end

/-- If `K` is a `p ^ k`-th cyclotomic extension of `ℚ`, then `(adjoin ℤ {ζ})` is the
integral closure of `ℤ` in `K`. -/
lemma is_integral_closure_adjoing_singleton_of_prime_pow
  [hcycl : is_cyclotomic_extension {p ^ k} ℚ K] (hζ : is_primitive_root ζ ↑(p ^ k)) :
  is_integral_closure (adjoin ℤ ({ζ} : set K)) ℤ K :=
begin
  refine ⟨subtype.val_injective, λ x, ⟨λ h, ⟨⟨x, _⟩, rfl⟩, _⟩⟩,
  swap,
  { rintro ⟨y, rfl⟩,
    exact is_integral.algebra_map (le_integral_closure_iff_is_integral.1
      (adjoin_le_integral_closure (hζ.is_integral (p ^ k).pos)) _) },
  let B := hζ.sub_one_power_basis ℚ,
  have hint : is_integral ℤ B.gen :=  is_integral_sub (hζ.is_integral (p ^ k).pos)
    is_integral_one,
  have H := discr_mul_is_integral_mem_adjoin ℚ hint h,
  obtain ⟨u, n, hun⟩ := discr_prime_pow_eq_unit_mul_pow' hζ,
  rw [hun] at H,
  replace H := subalgebra.smul_mem _ H u.inv,
  rw [← smul_assoc, ← smul_mul_assoc, units.inv_eq_coe_inv, coe_coe, zsmul_eq_mul,
    ← int.cast_mul, units.inv_mul, int.cast_one, one_mul,
    show (p : ℚ) ^ n • x = ((p : ℕ) : ℤ) ^ n • x, by simp [smul_def]] at H,
  unfreezingI { cases k },
  { haveI : is_cyclotomic_extension {1} ℚ K := by simpa using hcycl,
    have : x ∈ (⊥ : subalgebra ℚ K),
    { rw [singleton_one ℚ K],
      exact mem_top },
    obtain ⟨y, rfl⟩ := mem_bot.1 this,
    replace h := (is_integral_algebra_map_iff (algebra_map ℚ K).injective).1 h,
    obtain ⟨z, hz⟩ := is_integrally_closed.is_integral_iff.1 h,
    rw [← hz, ← is_scalar_tower.algebra_map_apply],
    exact subalgebra.algebra_map_mem  _ _ },
  { have hmin : (minpoly ℤ B.gen).is_eisenstein_at (submodule.span ℤ {((p : ℕ) : ℤ)}),
    { have h₁ := minpoly.gcd_domain_eq_field_fractions ℚ hint,
      have h₂ := hζ.minpoly_sub_one_eq_cyclotomic_comp
        (cyclotomic.irreducible_rat (p ^ _).pos),
      rw [is_primitive_root.sub_one_power_basis_gen] at h₁,
      rw [h₁, ← map_cyclotomic_int, show int.cast_ring_hom ℚ = algebra_map ℤ ℚ, by refl,
        show ((X + 1)) = map (algebra_map ℤ ℚ) (X + 1), by simp, ← map_comp] at h₂,
      haveI : char_zero ℚ := ordered_semiring.to_char_zero,
      rw [is_primitive_root.sub_one_power_basis_gen, map_injective (algebra_map ℤ ℚ)
        ((algebra_map ℤ ℚ).injective_int) h₂],
      exact cyclotomic_prime_pow_comp_X_add_one_is_eisenstein_at _ _ },
    refine adjoin_le _ (mem_adjoin_of_smul_prime_pow_smul_of_minpoly_is_eiseinstein_at
      (nat.prime_iff_prime_int.1 hp.out) hint h H hmin),
    simp only [set.singleton_subset_iff, set_like.mem_coe],
    exact subalgebra.sub_mem _ (self_mem_adjoin_singleton ℤ _) (subalgebra.one_mem _) }
end

lemma is_integral_closure_adjoing_singleton_of_prime [hcycl : is_cyclotomic_extension {p} ℚ K]
  (hζ : is_primitive_root ζ ↑p) :
  is_integral_closure (adjoin ℤ ({ζ} : set K)) ℤ K :=
begin
  rw [← pow_one p] at hζ hcycl,
  exactI is_integral_closure_adjoing_singleton_of_prime_pow hζ,
end

local attribute [-instance] cyclotomic_field.algebra
local attribute [instance] algebra_rat_subsingleton

/-- The integral closure of `ℤ` inside `cyclotomic_field (p ^ k) ℚ` is
`cyclotomic_ring (p ^ k) ℤ ℚ`. -/
lemma cyclotomic_ring_is_integral_closure_of_prime_pow :
  is_integral_closure (cyclotomic_ring (p ^ k) ℤ ℚ) ℤ (cyclotomic_field (p ^ k) ℚ) :=
begin
  haveI : char_zero ℚ := ordered_semiring.to_char_zero,
  haveI : is_cyclotomic_extension {p ^ k} ℚ (cyclotomic_field (p ^ k) ℚ),
  { convert cyclotomic_field.is_cyclotomic_extension (p ^ k) _,
    { exact subsingleton.elim _ _ },
    { exact ne_zero.char_zero } },
  have hζ := zeta_spec (p ^ k) ℚ (cyclotomic_field (p ^ k) ℚ),
  refine ⟨is_fraction_ring.injective _ _, λ x, ⟨λ h, ⟨⟨x, _⟩, rfl⟩, _⟩⟩,
  { have := (is_integral_closure_adjoing_singleton_of_prime_pow hζ).is_integral_iff,
    obtain ⟨y, rfl⟩ := this.1 h,
    convert adjoin_mono _ y.2,
    { simp only [eq_iff_true_of_subsingleton] },
    { simp only [eq_iff_true_of_subsingleton] },
    { simp only [pnat.pow_coe, set.singleton_subset_iff, set.mem_set_of_eq],
      exact hζ.pow_eq_one } },
  { haveI : is_cyclotomic_extension {p ^ k} ℤ (cyclotomic_ring (p ^ k) ℤ ℚ),
    { convert cyclotomic_ring.is_cyclotomic_extension _ ℤ ℚ,
      { exact subsingleton.elim _ _ },
      { exact ne_zero.char_zero } },
    rintro ⟨y, rfl⟩,
    exact is_integral.algebra_map ((is_cyclotomic_extension.integral {p ^ k} ℤ _) _) }
end

lemma cyclotomic_ring_is_integral_closure_of_prime :
  is_integral_closure (cyclotomic_ring p ℤ ℚ) ℤ (cyclotomic_field p ℚ) :=
begin
  rw [← pow_one p],
  exact cyclotomic_ring_is_integral_closure_of_prime_pow
end

end is_cyclotomic_extension.rat


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

/-!
# Skeleton of a category

Define skeletal categories as categories in which any two isomorphic objects are equal.

Construct the skeleton of an arbitrary category by taking isomorphism classes, and show it is a
skeleton of the original category.

In addition, construct the skeleton of a thin category as a partial ordering, and (noncomputably)
show it is a skeleton of the original category. The advantage of this special case being handled
separately is that lemmas and definitions about orderings can be used directly, for example for the
subobject lattice. In addition, some of the commutative diagrams about the functors commute
definitionally on the nose which is convenient in practice.
-/

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

namespace category_theory

open category

variables (C : Type u₁) [category.{v₁} C]
variables (D : Type u₂) [category.{v₂} D]
variables {E : Type u₃} [category.{v₃} E]

/-- A category is skeletal if isomorphic objects are equal. -/
def skeletal : Prop := ∀ ⦃X Y : C⦄, is_isomorphic X Y → X = Y

/--
`is_skeleton_of C D F` says that `F : D ⥤ C` exhibits `D` as a skeletal full subcategory of `C`,
in particular `F` is a (strong) equivalence and `D` is skeletal.
-/
structure is_skeleton_of (F : D ⥤ C) :=
(skel : skeletal D)
(eqv : is_equivalence F)

local attribute [instance] is_isomorphic_setoid

variables {C D}
/-- If `C` is thin and skeletal, then any naturally isomorphic functors to `C` are equal. -/
lemma functor.eq_of_iso {F₁ F₂ : D ⥤ C} [∀ X Y : C, subsingleton (X ⟶ Y)] (hC : skeletal C)
  (hF : F₁ ≅ F₂) : F₁ = F₂ :=
functor.ext (λ X, hC ⟨hF.app X⟩) (λ _ _ _, subsingleton.elim _ _)

/--
If `C` is thin and skeletal, `D ⥤ C` is skeletal.
`category_theory.functor_thin` shows it is thin also.
-/
lemma functor_skeletal [∀ X Y : C, subsingleton (X ⟶ Y)] (hC : skeletal C) : skeletal (D ⥤ C) :=
λ F₁ F₂ h, h.elim (functor.eq_of_iso hC)
variables (C D)

/--
Construct the skeleton category as the induced category on the isomorphism classes, and derive
its category structure.
-/
@[derive category]
def skeleton : Type u₁ := induced_category C quotient.out

instance [inhabited C] : inhabited (skeleton C) := ⟨⟦default C⟧⟩

/-- The functor from the skeleton of `C` to `C`. -/
@[simps, derive [full, faithful]]
noncomputable def from_skeleton : skeleton C ⥤ C := induced_functor _

instance : ess_surj (from_skeleton C) :=
{ mem_ess_image := λ X, ⟨quotient.mk X, quotient.mk_out X⟩ }

noncomputable instance : is_equivalence (from_skeleton C) :=
equivalence.equivalence_of_fully_faithfully_ess_surj (from_skeleton C)

lemma skeleton_skeletal : skeletal (skeleton C) :=
begin
  rintro X Y ⟨h⟩,
  have : X.out ≈ Y.out := ⟨(from_skeleton C).map_iso h⟩,
  simpa using quotient.sound this,
end

/-- The `skeleton` of `C` given by choice is a skeleton of `C`. -/
noncomputable def skeleton_is_skeleton : is_skeleton_of C (skeleton C) (from_skeleton C) :=
{ skel := skeleton_skeletal C,
  eqv := from_skeleton.is_equivalence C }

section
variables {C D}

/--
Two categories which are categorically equivalent have skeletons with equivalent objects.
-/
noncomputable
def equivalence.skeleton_equiv (e : C ≌ D) : skeleton C ≃ skeleton D :=
let f := ((from_skeleton C).as_equivalence.trans e).trans (from_skeleton D).as_equivalence.symm in
{ to_fun := f.functor.obj,
  inv_fun := f.inverse.obj,
  left_inv := λ X, skeleton_skeletal C ⟨(f.unit_iso.app X).symm⟩,
  right_inv := λ Y, skeleton_skeletal D ⟨(f.counit_iso.app Y)⟩, }

end

/--
Construct the skeleton category by taking the quotient of objects. This construction gives a
preorder with nice definitional properties, but is only really appropriate for thin categories.
If your original category is not thin, you probably want to be using `skeleton` instead of this.
-/
def thin_skeleton : Type u₁ := quotient (is_isomorphic_setoid C)

instance inhabited_thin_skeleton [inhabited C] : inhabited (thin_skeleton C) :=
⟨quotient.mk (default _)⟩

instance thin_skeleton.preorder : preorder (thin_skeleton C) :=
{ le := quotient.lift₂ (λ X Y, nonempty (X ⟶ Y))
  begin
    rintros _ _ _ _ ⟨i₁⟩ ⟨i₂⟩,
    exact propext ⟨nonempty.map (λ f, i₁.inv ≫ f ≫ i₂.hom),
      nonempty.map (λ f, i₁.hom ≫ f ≫ i₂.inv)⟩,
  end,
  le_refl :=
  begin
    refine quotient.ind (λ a, _),
    exact ⟨𝟙 _⟩,
  end,
  le_trans := λ a b c, quotient.induction_on₃ a b c $ λ A B C, nonempty.map2 (≫) }

/-- The functor from a category to its thin skeleton. -/
@[simps]
def to_thin_skeleton : C ⥤ thin_skeleton C :=
{ obj := quotient.mk,
  map := λ X Y f, hom_of_le (nonempty.intro f) }

/-!
The constructions here are intended to be used when the category `C` is thin, even though
some of the statements can be shown without this assumption.
-/
namespace thin_skeleton

/-- The thin skeleton is thin. -/
instance thin {X Y : thin_skeleton C} : subsingleton (X ⟶ Y) :=
⟨by { rintros ⟨⟨f₁⟩⟩ ⟨⟨f₂⟩⟩, refl }⟩

variables {C} {D}

/-- A functor `C ⥤ D` computably lowers to a functor `thin_skeleton C ⥤ thin_skeleton D`. -/
@[simps]
def map (F : C ⥤ D) : thin_skeleton C ⥤ thin_skeleton D :=
{ obj := quotient.map F.obj $ λ X₁ X₂ ⟨hX⟩, ⟨F.map_iso hX⟩,
  map := λ X Y, quotient.rec_on_subsingleton₂ X Y $
           λ x y k, hom_of_le ((le_of_hom k).elim (λ t, ⟨F.map t⟩)) }

lemma comp_to_thin_skeleton (F : C ⥤ D) : F ⋙ to_thin_skeleton D = to_thin_skeleton C ⋙ map F :=
rfl

/-- Given a natural transformation `F₁ ⟶ F₂`, induce a natural transformation `map F₁ ⟶ map F₂`.-/
def map_nat_trans {F₁ F₂ : C ⥤ D} (k : F₁ ⟶ F₂) : map F₁ ⟶ map F₂ :=
{ app := λ X, quotient.rec_on_subsingleton X (λ x, ⟨⟨⟨k.app x⟩⟩⟩) }

-- TODO: state the lemmas about what happens when you compose with `to_thin_skeleton`
/-- A functor `C ⥤ D ⥤ E` computably lowers to a functor
`thin_skeleton C ⥤ thin_skeleton D ⥤ thin_skeleton E` -/
@[simps]
def map₂ (F : C ⥤ D ⥤ E) :
  thin_skeleton C ⥤ thin_skeleton D ⥤ thin_skeleton E :=
{ obj := λ x,
  { obj := λ y, quotient.map₂ (λ X Y, (F.obj X).obj Y)
                (λ X₁ X₂ ⟨hX⟩ Y₁ Y₂ ⟨hY⟩, ⟨(F.obj X₁).map_iso hY ≪≫ (F.map_iso hX).app Y₂⟩) x y,
    map := λ y₁ y₂, quotient.rec_on_subsingleton x $
            λ X, quotient.rec_on_subsingleton₂ y₁ y₂ $
              λ Y₁ Y₂ hY, hom_of_le ((le_of_hom hY).elim (λ g, ⟨(F.obj X).map g⟩)) },
  map := λ x₁ x₂, quotient.rec_on_subsingleton₂ x₁ x₂ $
           λ X₁ X₂ f,
           { app := λ y, quotient.rec_on_subsingleton y
              (λ Y, hom_of_le ((le_of_hom f).elim (λ f', ⟨(F.map f').app Y⟩))) } }

variables (C)

section
variables [∀ X Y : C, subsingleton (X ⟶ Y)]

instance to_thin_skeleton_faithful : faithful (to_thin_skeleton C) := {}

/-- Use `quotient.out` to create a functor out of the thin skeleton. -/
@[simps]
noncomputable def from_thin_skeleton : thin_skeleton C ⥤ C :=
{ obj := quotient.out,
  map := λ x y, quotient.rec_on_subsingleton₂ x y $
    λ X Y f,
            (nonempty.some (quotient.mk_out X)).hom
          ≫ (le_of_hom f).some
          ≫ (nonempty.some (quotient.mk_out Y)).inv }

noncomputable instance from_thin_skeleton_equivalence : is_equivalence (from_thin_skeleton C) :=
{ inverse := to_thin_skeleton C,
  counit_iso := nat_iso.of_components (λ X, (nonempty.some (quotient.mk_out X))) (by tidy),
  unit_iso :=
    nat_iso.of_components
      (λ x, quotient.rec_on_subsingleton x
        (λ X, eq_to_iso (quotient.sound ⟨(nonempty.some (quotient.mk_out X)).symm⟩)))
      (by tidy) }

variables {C}

lemma equiv_of_both_ways {X Y : C} (f : X ⟶ Y) (g : Y ⟶ X) : X ≈ Y :=
⟨iso_of_both_ways f g⟩

instance thin_skeleton_partial_order : partial_order (thin_skeleton C) :=
{ le_antisymm := quotient.ind₂
  begin
    rintros _ _ ⟨f⟩ ⟨g⟩,
    apply quotient.sound (equiv_of_both_ways f g),
  end,
  ..category_theory.thin_skeleton.preorder C }

lemma skeletal : skeletal (thin_skeleton C) :=
λ X Y, quotient.induction_on₂ X Y $ λ x y h, h.elim $ λ i, (le_of_hom i.1).antisymm (le_of_hom i.2)

lemma map_comp_eq (F : E ⥤ D) (G : D ⥤ C) : map (F ⋙ G) = map F ⋙ map G :=
functor.eq_of_iso skeletal $
  nat_iso.of_components (λ X, quotient.rec_on_subsingleton X (λ x, iso.refl _)) (by tidy)

lemma map_id_eq : map (𝟭 C) = 𝟭 (thin_skeleton C) :=
functor.eq_of_iso skeletal $
  nat_iso.of_components (λ X, quotient.rec_on_subsingleton X (λ x, iso.refl _)) (by tidy)

lemma map_iso_eq {F₁ F₂ : D ⥤ C} (h : F₁ ≅ F₂) : map F₁ = map F₂ :=
functor.eq_of_iso skeletal { hom := map_nat_trans h.hom, inv := map_nat_trans h.inv }

/-- `from_thin_skeleton C` exhibits the thin skeleton as a skeleton. -/
noncomputable def thin_skeleton_is_skeleton : is_skeleton_of C (thin_skeleton C)
  (from_thin_skeleton C) :=
{ skel := skeletal,
  eqv := thin_skeleton.from_thin_skeleton_equivalence C }

noncomputable instance is_skeleton_of_inhabited :
  inhabited (is_skeleton_of C (thin_skeleton C) (from_thin_skeleton C)) :=
⟨thin_skeleton_is_skeleton⟩

end

variables {C}

/-- An adjunction between thin categories gives an adjunction between their thin skeletons. -/
def lower_adjunction
  (R : D ⥤ C) (L : C ⥤ D) (h : L ⊣ R) :
  thin_skeleton.map L ⊣ thin_skeleton.map R :=
adjunction.mk_of_unit_counit
{ unit :=
  { app := λ X,
    begin
      letI := is_isomorphic_setoid C,
      refine quotient.rec_on_subsingleton X (λ x, hom_of_le ⟨h.unit.app x⟩),
      -- TODO: make quotient.rec_on_subsingleton' so the letI isn't needed
    end },
  counit :=
  { app := λ X,
    begin
      letI := is_isomorphic_setoid D,
      refine quotient.rec_on_subsingleton X (λ x, hom_of_le ⟨h.counit.app x⟩),
    end } }

end thin_skeleton

open thin_skeleton

section
variables {C} {α : Type*} [partial_order α]

/--
When `e : C ≌ α` is a categorical equivalence from a thin category `C` to some partial order `α`,
the `thin_skeleton C` is order isomorphic to `α`.
-/
noncomputable
def equivalence.thin_skeleton_order_iso
  [∀ X Y : C, subsingleton (X ⟶ Y)] (e : C ≌ α) : thin_skeleton C ≃o α :=
((from_thin_skeleton C).as_equivalence.trans e).to_order_iso

end

end category_theory


import combinatorics.simple_graph.subgraph
import algebra.big_operators.order
import data.fintype.card
import .constructions
import tactic.ring_exp

open_locale big_operators

/-!
# Hat Games

This module defines the notion of a simple hat game played on an `α` `simple_graph`
with `β` colours, and proves bounds from the literature on this area.

## Main definitions

* `hat_guessing_function` is a structure that represents a guessing function on `α`. The key part
  is `f`, the function itself, but we also have that the function is invariant under
  non-local changes (that is, it can only "see" vertices it's connected to) and that it
  actually guesses hats at all times, as required for a strategy to be winning.

## Implementation notes

* `hat_guessing_function G β` requires `[decidable_eq α]` to do an `ite`; there's likely a way to
  remove it by making it a function `∀ a : α, G.neighbour_set α → β`, which also makes
  `f_local` trivial, but this involves a lot of coercions, which are not fun.

-/

open simple_graph

local notation `|` x `|` := finset.card x
local notation `‖` x `‖` := fintype.card x

/--
A hat-guessing function is a function that takes in a vertex, and an arrangement of hats, and
tries to guess its own vertex. It must fit two conditions: first, it can only depend on the values
of vertices that are adjacent to it, and it must also guess correctly on at least one vertex.
-/
@[nolint has_inhabited_instance] -- this whole file is dedicated to whether G, β instances exist!
structure hat_guessing_function {α : Type*} (G : simple_graph α) [decidable_eq α] (β : Type*) :=
(f : α → (α → β) → β)
(f_local': ∀ a b : α, ¬G.adj a b → ∀ arr : (α → β), ∀ k : β,
  f a arr = f a (λ x, if x = b then k else arr x))
(f_guesses': ∀ arr : (α → β), ∃ a : α, f a arr = arr a)

namespace hat_guessing_function

variables {α β γ : Type*} {G : simple_graph α} [decidable_eq α] (hg : hat_guessing_function G β)

instance : has_coe_to_fun (hat_guessing_function G β):= ⟨_, f⟩

theorem f_local : ∀ {a b : α}, ¬G.adj a b → ∀ arr : (α → β), ∀ k : β,
hg a arr = hg a (λ x, if x = b then k else arr x) := hg.f_local'

theorem f_guesses : ∀ arr : (α → β), ∃ a : α, hg a arr = arr a := hg.f_guesses'

@[simp] lemma f_eq_coe : hg.f = hg := rfl

@[simp] lemma coe_mk (h₁ h₂) : ⇑(⟨hg, h₁, h₂⟩ : hat_guessing_function G β) = hg := rfl

def elim' (h : is_empty α) {C} : C := (is_empty.exists_iff.mp $ hg.f_guesses is_empty_elim).elim

def elim [h : is_empty α] {C} : C := elim' hg h

section basic

/--
If you have a guesser `α → β`, and a function with a right-inverse `f : β → γ`, then
you can create a guesser `α → γ`.
-/
def guesser_of_rinverse {f : β → γ} {g : γ → β} (hf : function.right_inverse g f) :
hat_guessing_function G γ :=
{ f := λ a arr, f $ hg a $ g ∘ arr,
  f_local' := λ _ _ nadj _ _, begin
    rw hg.f_local nadj,
    congr,
    ext,
    split_ifs with h; simp [h]
  end,
  f_guesses' := λ arr, let ⟨a, ha⟩ := hg.f_guesses (g ∘ arr) in ⟨a, by rw [ha, hf]⟩ }

/--
We replace the right-inverse requirement with a surjection. With axiom of choice, being surjective
is equivalent to having a right-inverse; however, this means that this definition is non-computable.
-/
noncomputable def guesser_of_surjection {f : β → γ} (hf : function.surjective f) :
hat_guessing_function G γ := hg.guesser_of_rinverse $ function.right_inverse_surj_inv hf

/--
If there's an isomorphism between two types, then guessing on either of them is equivalent.
-/
def guesser_of_equiv (h : β ≃ γ) := hg.guesser_of_rinverse h.right_inv

/-- On an nonempty graph, you can trivially guess 1 colour. -/
def inhabited_guesser [nonempty α] : hat_guessing_function G unit :=
{ f := λ _ _, unit.star,
  f_local' := λ _ _ _ _ _, rfl,
  f_guesses' := by simp }

/--
On a graph with an edge, you can guess 2 colours. The strategy is to take the two vertices, and
one vertex guesses that they are the same colour, whilst the other vertex guesses they aren't.
-/
def edge_guesser {v w : α} (h : G.adj v w) : hat_guessing_function G bool :=
{ f := λ x arr, if v = x then arr w else (if w = x then !(arr v) else ff),
  f_local' := by intros; split_ifs; subst_vars; tauto,
  f_guesses' := λ arr, begin
    obtain hwv | hwv := eq_or_ne (arr v) (arr w),
    { exact ⟨v, by simp [hwv]⟩ },
    { use w,
      suffices : !arr v = arr w, by simpa [G.ne_of_adj h],
      cases (arr v); cases (arr w); trivial }
  end }

/--
Subgraphs are now implemented in mathlib! You can transfer a β-guessing strategy from a subgraph.
-/
def of_subgraph {H : subgraph G} [decidable_pred (∈ H.verts)] [inhabited β]
  (hg : hat_guessing_function H.coe β) : hat_guessing_function G β :=
{ f := λ v arr, if hv : v ∈ H.verts then hg ⟨v, hv⟩ (λ v, arr v)
                else default β, -- we need this to pick an "independent" choice of β.
  f_local' := λ a b nadj arr x, begin
    split_ifs with ha,
    { by_cases hb : b ∈ H.verts,
      { change ¬G.adj (⟨a, ha⟩ : H.verts) (⟨b, hb⟩ : H.verts) at nadj,
        convert hg.f_local (mt (subgraph.adj_sub H) nadj) (λ v, arr v) x,
        exact funext (λ ⟨x, ha⟩, by simp) },
      congr,
      funext x,
      suffices : b ≠ x, by simp [this.symm],
      rintro rfl,
      exact hb x.prop },
    refl
  end,
  f_guesses' := λ arr, let ⟨a, ha⟩ := hg.f_guesses (λ v, arr v) in ⟨a, by simpa using ha⟩ }

/--
An alternative version of `of_subgraph` using `spanning_coe`.
-/
def of_subgraph' {H : subgraph G} (hg : hat_guessing_function H.spanning_coe β) :
  hat_guessing_function G β :=
{ f := hg,
  f_local' := λ a b nadj, hg.f_local $ mt (λ h, H.adj_sub h) nadj,
  f_guesses' := hg.f_guesses }

end basic

section finite

open finset

variables [fintype β] [fintype γ]

/--
If two β, γ have equal cardinality, and we have an `hat_guessing_function G β`, then there exists
a `hat_guessing_function G γ`; however, we cannot computably extract it. (This is choice-related;
how do we pick which guessing function?)
-/
-- TODO: Make a `trunc` version; however, I don't know the API.
lemma exists_equal_cards_guess (h : ‖β‖ = ‖γ‖) : nonempty (hat_guessing_function G γ) :=
⟨guesser_of_equiv hg (fintype.equiv_of_card_eq h)⟩

/--
The non-computable equivalent to the above statement.
-/
noncomputable def equal_cards_guess (h : ‖β‖ = ‖γ‖) : hat_guessing_function G γ :=
(hg.exists_equal_cards_guess h).some

/-- Auxillary lemmata for `max_guess_lt_card_verts`. -/
lemma size_univ_larger (k : ℕ) : k * (k + 1) ^ (k - 1) < (k + 1) ^ k :=
begin
  cases k,
  { norm_num },
  ring_exp,
  simp [mul_two, pos_iff_ne_zero, pow_ne_zero]
end

lemma cancel_pow {k n : ℕ} : k * (n + 1) ≤ (n + 1) ^ n → k ≤ (n + 1) ^ (n - 1) :=
begin
  cases n,
  { norm_num },
  simp [pow_succ']
end

/--
For `k` vertices on a graph, you can never guess `k+1` colours. We prove this using
simple properties of cardinality, and is essentially a reduction of the case on a
complete graph to all other possible graphs.
-/
theorem best_guess_le_card_verts [fintype α] : hat_guessing_function G (option α) → false := begin
  intro hg,
  let guessed_at := λ a, univ.filter (λ arr, hg a arr = arr a),

  have univ_large : |(univ : finset (α → option α))| = (‖α‖ + 1) ^ ‖α‖, by simp [card_univ],
  -- the approach we take here is to show that individual vertices can guess "relatively few"
  -- configurations, but `univ` (the total number of configurations) is larger than that
  suffices small_guesses : ∀ a : α, |guessed_at a| ≤ (‖α‖ + 1) ^ (‖α‖ - 1),
  { let all_guessed := univ.filter (λ arr, ∃ a : α, hg a arr = arr a),

    have all_are_guessed : univ = all_guessed,
      ext arr,
      simpa using hg.f_guesses arr,

    -- `univ.bUnion guessed_at` is our key object. this is the union over all vertices of what is
    -- guessed at that specific vertex, and for a winning hg-function, this needs to be all of them.
    have bUnion_guessed_at_eq_guessed : all_guessed = univ.bUnion guessed_at,
      apply subset.antisymm,
      { intros arr arr_guessed,
        simpa using hg.f_guesses arr },
      { rintros _ -, rw ←all_are_guessed, apply mem_univ },

    -- we get a contradiction based on this; if there was a HG function, every config would work,
    -- but each individual vertex can only guess so many, and indeed not enough;
    -- then there's no hope of us ever guessing all of the vertices

    have bUnion_small : |univ.bUnion guessed_at| ≤ ‖α‖ * (‖α‖ + 1) ^ (‖α‖ - 1) :=
    calc |univ.bUnion guessed_at| ≤ ∑ a, |guessed_at a| : card_bUnion_le
         ... ≤ ∑ a, (λ _, (‖α‖ + 1) ^ (‖α‖ - 1)) a : sum_le_sum (λ x _, small_guesses x)
         ... ≤ ‖α‖ * (‖α‖ + 1) ^ (‖α‖ - 1) : by simp [card_univ],

    rw [all_are_guessed, bUnion_guessed_at_eq_guessed] at univ_large,
    rw univ_large at bUnion_small,
    have := size_univ_larger (‖α‖), -- unsure why parser wants brackets
    linarith },

  -- now we need to show that all vertices guess a smaller proportion than you'd expect. the main
  -- idea is that a vertex can't see itself (at least), so any pair of configurations that
  -- are different only on themselves can't be distinguished by the hat guessing function.
  -- we model this phenomenon with `similar_arrs`, which is the equivalence class of
  -- vertices under this relation.
  intro a,
  let modify_arr := λ arr : α → option α, λ k, (λ x : α, if x = a then k else arr x),
  let similar_arrs := λ arr, finset.map (⟨modify_arr arr, _⟩) (univ), swap,
    -- `finset.map` requires an embedding, which gives _very_ nice cardinality results
    -- (clearly useful for us!) but we must prove that `modify_arr arr` is injective
    { intros x y fx_eq_fy,
      rw function.funext_iff at fx_eq_fy,
      specialize fx_eq_fy a,
      simp_rw modify_arr at fx_eq_fy,  -- you _can't_ combine both these lines for some reason
      simp only [if_true, eq_self_iff_true] at fx_eq_fy,
      assumption },

  have at_most_similar : |guessed_at a| * (‖α‖ + 1) ≤ |(guessed_at a).bUnion similar_arrs|,
    { rw card_bUnion, simp [card_univ],
    -- `card_bUnion` requires disjointness for equality, which is proved below
    intros arr1 arr1guessed arr2 arr2guessed arr1_ne_arr2,
    rw disjoint_iff_ne,
    intros arr3 arr3_sim_arr1 arr4 arr4_sim_arr2,
    -- our approach is to show that if arr1 ≠ arr2, then they have to be different in a
    -- non-`a` variable, therefore meaning that disjointness holds
    simp only [similar_arrs, if_true, eq_self_iff_true, function.embedding.coe_fn_mk,
               mem_map, mem_fin_range, exists_true_left] at arr3_sim_arr1 arr4_sim_arr2,
    obtain ⟨k, -, arr3_sim_arr1⟩ := arr3_sim_arr1,
    obtain ⟨m, -, arr4_sim_arr2⟩ := arr4_sim_arr2,
    simp_rw [modify_arr] at arr3_sim_arr1 arr4_sim_arr2,

    -- If two colourings are the same except at non-connected vertices, and they guess,
    -- then they must be equal. (TODO: May be worth extracting this, it's a useful proof!)
    contrapose! arr1_ne_arr2 with arr3_eq_arr4, funext x,
    have hg_local := hg.f_local (G.loopless a),
    substs arr3_eq_arr4 arr4_sim_arr2,
    rename arr3_sim_arr1 → arr1_sim_arr2,
    rw [function.funext_iff] at arr1_sim_arr2,
    funext x,

    obtain rfl | h := eq_or_ne x a, -- `split-ifs` would be nice, but throws away too much information
    { simp only [true_and, mem_filter, mem_univ] at arr1guessed arr2guessed,
      rw [←arr1guessed, ←arr2guessed, hg_local arr1 k, hg_local arr2 m],
      simp_rw λ t, arr1_sim_arr2 t },
    specialize arr1_sim_arr2 x,
    simp only [h, if_false] at arr1_sim_arr2,
    exact arr1_sim_arr2 },

  have less_than_card_univ : |(guessed_at a).bUnion similar_arrs| ≤ (‖α‖ + 1) ^ ‖α‖,
    by simpa only [←univ_large, card_univ] using card_le_univ _,

  exact cancel_pow (at_most_similar.trans less_than_card_univ)
end

end finite

section complete

open finset

/--
Finite complete graphs on `α` have guessing strategies that guess `α` colours. This is a
natural extension of the 2-player result to any finite commutative group.
-/
def complete_guess [fintype α] [add_comm_group α] : hat_guessing_function (complete_graph α) α :=
{ f := λ k arr, k - ∑ x in univ \ {k}, arr x,
  f_local' := λ a b hab arr _, by simp [sub_right_inj, sum_ite_of_false, not_not.mp hab],
  f_guesses' := λ arr, ⟨∑ x in univ, arr x,
  by rw [←@sum_singleton _ _ (finset.sum _ _) arr, sub_eq_iff_eq_add', sum_sdiff (subset_univ _)]⟩ }

end complete

section lexicographic

/-!
This section follows the proof in Gadoleau & Georgiou 2015 (https://arxiv.org/pdf/1311.2022.pdf)
that the lexicographic product of a graph and a complete graph can create graphs with better
hat-guessing strategies.
-/

/-
The next few lines essentially verify what is assumed in the paper. Locality proofs are often
ignored in the papers as these functions are "clearly" defined to be local; the approach I took
doesn't have this flexibility, sadly.
-/

open finset

variables [fintype γ] [decidable_eq γ]

/-- The β part of the lex guessing function. -/
def guess_β [add_comm_group β] (va : α × γ) (arr : α × γ → β × γ)
  := (hg va.1 (λ x, ∑ m : γ, (arr ⟨x, m⟩).1)) - ∑ m in univ \ {va.2}, (arr ⟨va.1, m⟩).1

/-- The γ part of the lex guessing function. -/
def guess_γ {α} [add_comm_group γ] (va : α × γ) (arr : α × γ → β × γ) :=
  - (∑ m in univ \ {va.2}, (arr ⟨va.1, m⟩).2) - va.2

lemma guess_β_local [add_comm_group β] {a b : α × γ}
  (nadj : ¬(G · γ).adj a b) {arr : α × γ → β × γ} {k : β × γ} :
  hg.guess_β a arr = hg.guess_β a (λ x, if x = b then k else arr x) :=
begin
  rw guess_β,
  rw lex_adj at nadj,
  obtain ⟨v, a⟩ := a,
  congr' 1,
  -- we focus on converting the first part of the expression into the right form
  convert hg.f_local (by tauto) (λ (x : α), ∑ (m : γ), (arr (x, m)).fst) _,
  funext,
  split_ifs with h,
  { subst h }, -- degenerate case of the first part
  -- the rest comes from the lexicographic relations; we use `all_goals` as the sums are the same
  all_goals { rw sum_apply_ite_of_false, tidy }
end

lemma guess_γ_local [add_comm_group γ] {a b : α × γ}
  (h : ¬(G · γ).adj a b) {arr : α × γ → β × γ} {k : β × γ} :
  guess_γ a arr = guess_γ a (λ x, ite (x = b) k (arr x)) :=
by { rw guess_γ, congr' 2, rw sum_apply_ite_of_false, tidy }

/-- Lemma 1 in the Gadouleau paper, generalised to guessing types.  -/
def blow_up [add_comm_group β] [add_comm_group γ] : hat_guessing_function (G · γ) (β × γ) :=
{ f := λ va arr, (hg.guess_β va arr, guess_γ va arr),
  f_local' := λ a b nadj _ k, by rw [hg.guess_β_local nadj, guess_γ_local nadj],
  f_guesses' := λ arr, begin
    obtain ⟨x, hx⟩ := hg.f_guesses (λ x, ∑ m : γ, (arr ⟨x, m⟩).1),
    use ⟨x, -∑ m, (arr ⟨x, m⟩).2⟩,
    ext,
      { have : ∑ m in _, (arr (x, m)).fst = _ := sum_singleton,
        rw [guess_β, hx, sub_eq_iff_eq_add', ←this, sum_sdiff],
        simp },
      have : ∑ m in _, (arr (x, m)).snd = _ := sum_singleton,
      rw [guess_γ, neg_sub_neg, ←this, sub_eq_iff_eq_add', sum_sdiff],
      simp
  end }

end lexicographic

end hat_guessing_function


import algebra.ring ring_theory.ideal.basic
import tactic.ring
import commutative_algebra.nilpotent algebra.geom_sum

open commutative_algebra

variables (A : Type*) [comm_ring A]

def is_local := (1 : A) ≠ 0 ∧ ∀ (a : A), (is_unit a) ∨ (is_unit (1 - a))

def is_jacobson (a : A) :=  ∀ (x : A), is_unit (1 + a * x)

def jacobson_radical : ideal A := {
  carrier := λ (a : A), ∀ (x : A), is_unit (1 + a * x),
  zero_mem' := λ x, by { rw[zero_mul, add_zero], exact is_unit_one },
  add_mem' := λ a b ha hb x,
  begin
   rcases is_unit_iff_exists_inv.mp (ha x) with ⟨u,hu⟩,
   rcases is_unit_iff_exists_inv.mp (hb (x * u)) with ⟨v,hv⟩,
   apply is_unit_iff_exists_inv.mpr, use (u * v),
   exact calc
    (1 + (a + b) * x) * (u * v) =
     ((1 + a * x) * u) * v + (b * (x * u)) * v : by ring
    ... = (1 + b * (x * u)) * v : by { rw [hu], ring }
    ... = 1 : hv
  end,
  smul_mem' := λ a b hb x, by {
   have : a • b * x = a * b * x := rfl,
   rw [this, mul_comm a b, mul_assoc],
   exact hb (a * x)
  }
}

theorem nilradical_le_jacobson : (nilradical A) ≤ (jacobson_radical A) :=
λ a ⟨⟨n,h⟩⟩ x,
begin
  apply is_unit_iff_exists_inv.mpr,
  let u := geom_sum (- (a * x)) n, use u,
  have h' : u * _ = _ := geom_sum_mul_neg (- (a * x)) n,
  rw[sub_neg_eq_add, mul_comm, mul_comm a, neg_mul_eq_neg_mul,
     mul_pow, h, mul_zero, sub_zero, mul_comm x] at h',
  exact h'
end


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Johannes Hölzl, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.set.countable
import Mathlib.set_theory.schroeder_bernstein
import Mathlib.data.fintype.card
import Mathlib.PostPort

universes u u_1 u_2 v w u_3

namespace Mathlib

/-!
# Cardinal Numbers

We define cardinal numbers as a quotient of types under the equivalence relation of equinumerity.
We define the order on cardinal numbers, define omega, and do basic cardinal arithmetic:
  addition, multiplication, power, cardinal successor, minimum, supremum,
    infinitary sums and products

The fact that the cardinality of `α × α` coincides with that of `α` when `α` is infinite is not
proved in this file, as it relies on facts on well-orders. Instead, it is in
`cardinal_ordinal.lean` (together with many other facts on cardinals, for instance the
cardinality of `list α`).

## Implementation notes

* There is a type of cardinal numbers in every universe level: `cardinal.{u} : Type (u + 1)`
  is the quotient of types in `Type u`.
  There is a lift operation lifting cardinal numbers to a higher level.
* Cardinal arithmetic specifically for infinite cardinals (like `κ * κ = κ`) is in the file
  `set_theory/ordinal.lean`, because concepts from that file are used in the proof.

## References

* <https://en.wikipedia.org/wiki/Cardinal_number>

## Tags

cardinal number, cardinal arithmetic, cardinal exponentiation, omega
-/

/-- The equivalence relation on types given by equivalence (bijective correspondence) of types.
  Quotienting by this equivalence relation gives the cardinal numbers.
-/
protected instance cardinal.is_equivalent : setoid (Type u) :=
  setoid.mk (fun (α β : Type u) => Nonempty (α ≃ β)) sorry

/-- `cardinal.{u}` is the type of cardinal numbers in `Type u`,
  defined as the quotient of `Type u` by existence of an equivalence
  (a bijection with explicit inverse). -/
def cardinal := quotient sorry

namespace cardinal

/-- The cardinal number of a type -/
def mk : Type u → cardinal := quotient.mk

protected theorem eq {α : Type u} {β : Type u} : mk α = mk β ↔ Nonempty (α ≃ β) := quotient.eq

@[simp] theorem mk_def (α : Type u) : quotient.mk α = mk α := rfl

@[simp] theorem mk_out (c : cardinal) : mk (quotient.out c) = c := quotient.out_eq c

/-- We define the order on cardinal numbers by `mk α ≤ mk β` if and only if
  there exists an embedding (injective function) from α to β. -/
protected instance has_le : HasLessEq cardinal :=
  { LessEq :=
      fun (q₁ q₂ : cardinal) =>
        quotient.lift_on₂ q₁ q₂ (fun (α β : Type u) => Nonempty (α ↪ β)) sorry }

theorem mk_le_of_injective {α : Type u} {β : Type u} {f : α → β} (hf : function.injective f) :
    mk α ≤ mk β :=
  Nonempty.intro (function.embedding.mk f hf)

theorem mk_le_of_surjective {α : Type u} {β : Type u} {f : α → β} (hf : function.surjective f) :
    mk β ≤ mk α :=
  Nonempty.intro (function.embedding.of_surjective f hf)

theorem le_mk_iff_exists_set {c : cardinal} {α : Type u} : c ≤ mk α ↔ ∃ (p : set α), mk ↥p = c :=
  sorry

theorem out_embedding {c : cardinal} {c' : cardinal} :
    c ≤ c' ↔ Nonempty (quotient.out c ↪ quotient.out c') :=
  sorry

protected instance linear_order : linear_order cardinal :=
  linear_order.mk LessEq (partial_order.lt._default LessEq) sorry sorry sorry sorry
    (classical.dec_rel LessEq) Mathlib.decidable_eq_of_decidable_le
    Mathlib.decidable_lt_of_decidable_le

protected instance distrib_lattice : distrib_lattice cardinal :=
  Mathlib.distrib_lattice_of_linear_order

protected instance has_zero : HasZero cardinal := { zero := quotient.mk pempty }

protected instance inhabited : Inhabited cardinal := { default := 0 }

theorem ne_zero_iff_nonempty {α : Type u} : mk α ≠ 0 ↔ Nonempty α := sorry

protected instance has_one : HasOne cardinal := { one := quotient.mk PUnit }

protected instance nontrivial : nontrivial cardinal :=
  nontrivial.mk
    (Exists.intro 1 (Exists.intro 0 (iff.mpr ne_zero_iff_nonempty (Nonempty.intro PUnit.unit))))

theorem le_one_iff_subsingleton {α : Type u} : mk α ≤ 1 ↔ subsingleton α := sorry

theorem one_lt_iff_nontrivial {α : Type u} : 1 < mk α ↔ nontrivial α := sorry

protected instance has_add : Add cardinal :=
  { add :=
      fun (q₁ q₂ : cardinal) => quotient.lift_on₂ q₁ q₂ (fun (α β : Type u) => mk (α ⊕ β)) sorry }

@[simp] theorem add_def (α : Type (max u_1 u_2)) (β : Type (max u_1 u_2)) :
    mk α + mk β = mk (α ⊕ β) :=
  rfl

protected instance has_mul : Mul cardinal :=
  { mul :=
      fun (q₁ q₂ : cardinal) => quotient.lift_on₂ q₁ q₂ (fun (α β : Type u) => mk (α × β)) sorry }

@[simp] theorem mul_def (α : Type u) (β : Type u) : mk α * mk β = mk (α × β) := rfl

protected theorem eq_zero_or_eq_zero_of_mul_eq_zero {a : cardinal} {b : cardinal} :
    a * b = 0 → a = 0 ∨ b = 0 :=
  sorry

protected instance comm_semiring : comm_semiring cardinal :=
  comm_semiring.mk Add.add sorry 0 zero_add sorry add_comm Mul.mul sorry 1 one_mul sorry zero_mul
    sorry left_distrib sorry mul_comm

/-- The cardinal exponential. `mk α ^ mk β` is the cardinal of `β → α`. -/
protected def power (a : cardinal) (b : cardinal) : cardinal :=
  quotient.lift_on₂ a b (fun (α β : Type u) => mk (β → α)) sorry

protected instance has_pow : has_pow cardinal cardinal := has_pow.mk cardinal.power

@[simp] theorem power_def (α : Type u_1) (β : Type u_1) : mk α ^ mk β = mk (β → α) := rfl

@[simp] theorem power_zero {a : cardinal} : a ^ 0 = 1 :=
  quotient.induction_on a
    fun (α : Type u_1) => quotient.sound (Nonempty.intro (equiv.pempty_arrow_equiv_punit α))

@[simp] theorem power_one {a : cardinal} : a ^ 1 = a :=
  quotient.induction_on a
    fun (α : Type u_1) => quotient.sound (Nonempty.intro (equiv.punit_arrow_equiv α))

@[simp] theorem one_power {a : cardinal} : 1 ^ a = 1 :=
  quotient.induction_on a
    fun (α : Type u_1) => quotient.sound (Nonempty.intro (equiv.arrow_punit_equiv_punit α))

@[simp] theorem prop_eq_two : mk (ulift Prop) = bit0 1 :=
  quot.sound
    (Nonempty.intro
      (equiv.trans equiv.ulift
        (equiv.trans equiv.Prop_equiv_bool equiv.bool_equiv_punit_sum_punit)))

@[simp] theorem zero_power {a : cardinal} : a ≠ 0 → 0 ^ a = 0 := sorry

theorem power_ne_zero {a : cardinal} (b : cardinal) : a ≠ 0 → a ^ b ≠ 0 := sorry

theorem mul_power {a : cardinal} {b : cardinal} {c : cardinal} : (a * b) ^ c = a ^ c * b ^ c :=
  quotient.induction_on₃ a b c
    fun (α β γ : Type u_1) =>
      quotient.sound (Nonempty.intro (equiv.arrow_prod_equiv_prod_arrow α β γ))

theorem power_add {a : cardinal} {b : cardinal} {c : cardinal} : a ^ (b + c) = a ^ b * a ^ c :=
  quotient.induction_on₃ a b c
    fun (α β γ : Type u_1) =>
      quotient.sound (Nonempty.intro (equiv.sum_arrow_equiv_prod_arrow β γ α))

theorem power_mul {a : cardinal} {b : cardinal} {c : cardinal} : (a ^ b) ^ c = a ^ (b * c) :=
  eq.mpr (id (Eq._oldrec (Eq.refl ((a ^ b) ^ c = a ^ (b * c))) (mul_comm b c)))
    (quotient.induction_on₃ a b c
      fun (α β γ : Type u_1) =>
        quotient.sound (Nonempty.intro (equiv.arrow_arrow_equiv_prod_arrow γ β α)))

@[simp] theorem pow_cast_right (κ : cardinal) (n : ℕ) : κ ^ ↑n = κ ^ n := sorry

protected theorem zero_le (a : cardinal) : 0 ≤ a := sorry

protected theorem add_le_add {a : cardinal} {b : cardinal} {c : cardinal} {d : cardinal} :
    a ≤ b → c ≤ d → a + c ≤ b + d :=
  sorry

protected theorem add_le_add_left (a : cardinal) {b : cardinal} {c : cardinal} :
    b ≤ c → a + b ≤ a + c :=
  cardinal.add_le_add (le_refl a)

protected theorem le_iff_exists_add {a : cardinal} {b : cardinal} :
    a ≤ b ↔ ∃ (c : cardinal), b = a + c :=
  sorry

protected instance order_bot : order_bot cardinal :=
  order_bot.mk 0 linear_order.le linear_order.lt linear_order.le_refl linear_order.le_trans
    linear_order.le_antisymm cardinal.zero_le

protected instance canonically_ordered_comm_semiring : canonically_ordered_comm_semiring cardinal :=
  canonically_ordered_comm_semiring.mk comm_semiring.add comm_semiring.add_assoc comm_semiring.zero
    comm_semiring.zero_add comm_semiring.add_zero comm_semiring.add_comm order_bot.le order_bot.lt
    order_bot.le_refl order_bot.le_trans order_bot.le_antisymm sorry sorry order_bot.bot
    order_bot.bot_le cardinal.le_iff_exists_add comm_semiring.mul comm_semiring.mul_assoc
    comm_semiring.one comm_semiring.one_mul comm_semiring.mul_one comm_semiring.zero_mul
    comm_semiring.mul_zero comm_semiring.left_distrib comm_semiring.right_distrib
    comm_semiring.mul_comm cardinal.eq_zero_or_eq_zero_of_mul_eq_zero

@[simp] theorem zero_lt_one : 0 < 1 := lt_of_le_of_ne (zero_le 1) zero_ne_one

theorem zero_power_le (c : cardinal) : 0 ^ c ≤ 1 := sorry

theorem power_le_power_left {a : cardinal} {b : cardinal} {c : cardinal} :
    a ≠ 0 → b ≤ c → a ^ b ≤ a ^ c :=
  sorry

theorem power_le_max_power_one {a : cardinal} {b : cardinal} {c : cardinal} (h : b ≤ c) :
    a ^ b ≤ max (a ^ c) 1 :=
  sorry

theorem power_le_power_right {a : cardinal} {b : cardinal} {c : cardinal} : a ≤ b → a ^ c ≤ b ^ c :=
  sorry

theorem cantor (a : cardinal) : a < bit0 1 ^ a := sorry

protected instance no_top_order : no_top_order cardinal :=
  no_top_order.mk fun (a : cardinal) => Exists.intro (bit0 1 ^ a) (cantor a)

/-- The minimum cardinal in a family of cardinals (the existence
  of which is provided by `injective_min`). -/
def min {ι : Type u_1} (I : Nonempty ι) (f : ι → cardinal) : cardinal := f (classical.some sorry)

theorem min_eq {ι : Type u_1} (I : Nonempty ι) (f : ι → cardinal) : ∃ (i : ι), min I f = f i :=
  Exists.intro (classical.some (min._proof_1 I f)) rfl

theorem min_le {ι : Type u_1} {I : Nonempty ι} (f : ι → cardinal) (i : ι) : min I f ≤ f i := sorry

theorem le_min {ι : Type u_1} {I : Nonempty ι} {f : ι → cardinal} {a : cardinal} :
    a ≤ min I f ↔ ∀ (i : ι), a ≤ f i :=
  sorry

protected theorem wf : well_founded Less := sorry

protected instance has_wf : has_well_founded cardinal := has_well_founded.mk Less cardinal.wf

protected instance wo : is_well_order cardinal Less := is_well_order.mk cardinal.wf

/-- The successor cardinal - the smallest cardinal greater than
  `c`. This is not the same as `c + 1` except in the case of finite `c`. -/
def succ (c : cardinal) : cardinal := min sorry subtype.val

theorem lt_succ_self (c : cardinal) : c < succ c := sorry

theorem succ_le {a : cardinal} {b : cardinal} : succ a ≤ b ↔ a < b :=
  { mp := lt_of_lt_of_le (lt_succ_self a),
    mpr := fun (h : a < b) => min_le subtype.val { val := b, property := h } }

theorem lt_succ {a : cardinal} {b : cardinal} : a < succ b ↔ a ≤ b :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a < succ b ↔ a ≤ b)) (Eq.symm (propext not_le))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (¬succ b ≤ a ↔ a ≤ b)) (propext succ_le)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (¬b < a ↔ a ≤ b)) (propext not_lt))) (iff.refl (a ≤ b))))

theorem add_one_le_succ (c : cardinal) : c + 1 ≤ succ c := sorry

theorem succ_ne_zero (c : cardinal) : succ c ≠ 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (succ c ≠ 0)) (Eq.symm (propext pos_iff_ne_zero))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (0 < succ c)) (propext lt_succ))) (zero_le c))

/-- The indexed sum of cardinals is the cardinality of the
  indexed disjoint union, i.e. sigma type. -/
def sum {ι : Type u_1} (f : ι → cardinal) : cardinal := mk (sigma fun (i : ι) => quotient.out (f i))

theorem le_sum {ι : Type u_1} (f : ι → cardinal) (i : ι) : f i ≤ sum f := sorry

@[simp] theorem sum_mk {ι : Type u_1} (f : ι → Type u_2) :
    (sum fun (i : ι) => mk (f i)) = mk (sigma fun (i : ι) => f i) :=
  quot.sound
    (Nonempty.intro
      (equiv.sigma_congr_right
        fun (i : ι) => Classical.choice (quotient.exact (quot.out_eq (mk (f i))))))

theorem sum_const (ι : Type u) (a : cardinal) : (sum fun (_x : ι) => a) = mk ι * a := sorry

theorem sum_le_sum {ι : Type u_1} (f : ι → cardinal) (g : ι → cardinal) (H : ∀ (i : ι), f i ≤ g i) :
    sum f ≤ sum g :=
  sorry

/-- The indexed supremum of cardinals is the smallest cardinal above
  everything in the family. -/
def sup {ι : Type u_1} (f : ι → cardinal) : cardinal :=
  min sorry fun (a : Subtype fun (c : cardinal) => ∀ (i : ι), f i ≤ c) => subtype.val a

theorem le_sup {ι : Type u_1} (f : ι → cardinal) (i : ι) : f i ≤ sup f := sorry

theorem sup_le {ι : Type u_1} {f : ι → cardinal} {a : cardinal} : sup f ≤ a ↔ ∀ (i : ι), f i ≤ a :=
  { mp := fun (h : sup f ≤ a) (i : ι) => le_trans (le_sup f i) h,
    mpr :=
      fun (h : ∀ (i : ι), f i ≤ a) => id (id (min_le subtype.val { val := a, property := h })) }

theorem sup_le_sup {ι : Type u_1} (f : ι → cardinal) (g : ι → cardinal) (H : ∀ (i : ι), f i ≤ g i) :
    sup f ≤ sup g :=
  iff.mpr sup_le fun (i : ι) => le_trans (H i) (le_sup g i)

theorem sup_le_sum {ι : Type u_1} (f : ι → cardinal) : sup f ≤ sum f :=
  iff.mpr sup_le (le_sum fun (i : ι) => f i)

theorem sum_le_sup {ι : Type u} (f : ι → cardinal) : sum f ≤ mk ι * sup f :=
  eq.mpr (id (Eq._oldrec (Eq.refl (sum f ≤ mk ι * sup f)) (Eq.symm (sum_const ι (sup f)))))
    (sum_le_sum f (fun (_x : ι) => sup f) (le_sup fun (i : ι) => f i))

theorem sup_eq_zero {ι : Type u_1} {f : ι → cardinal} (h : ι → False) : sup f = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (sup f = 0)) (Eq.symm (propext nonpos_iff_eq_zero))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (sup f ≤ 0)) (propext sup_le)))
      fun (x : ι) => False._oldrec (h x))

/-- The indexed product of cardinals is the cardinality of the Pi type
  (dependent product). -/
def prod {ι : Type u} (f : ι → cardinal) : cardinal := mk ((i : ι) → quotient.out (f i))

@[simp] theorem prod_mk {ι : Type u_1} (f : ι → Type u_2) :
    (prod fun (i : ι) => mk (f i)) = mk ((i : ι) → f i) :=
  quot.sound
    (Nonempty.intro
      (equiv.Pi_congr_right fun (i : ι) => Classical.choice (quotient.exact (mk_out (mk (f i))))))

theorem prod_const (ι : Type u) (a : cardinal) : (prod fun (_x : ι) => a) = a ^ mk ι := sorry

theorem prod_le_prod {ι : Type u_1} (f : ι → cardinal) (g : ι → cardinal)
    (H : ∀ (i : ι), f i ≤ g i) : prod f ≤ prod g :=
  sorry

theorem prod_ne_zero {ι : Type u_1} (f : ι → cardinal) : prod f ≠ 0 ↔ ∀ (i : ι), f i ≠ 0 := sorry

theorem prod_eq_zero {ι : Type u_1} (f : ι → cardinal) : prod f = 0 ↔ ∃ (i : ι), f i = 0 := sorry

/-- The universe lift operation on cardinals. You can specify the universes explicitly with
  `lift.{u v} : cardinal.{u} → cardinal.{max u v}` -/
def lift (c : cardinal) : cardinal :=
  quotient.lift_on c (fun (α : Type u) => quotient.mk (ulift α)) sorry

theorem lift_mk (α : Type u) : lift (mk α) = mk (ulift α) := rfl

theorem lift_umax : lift = lift := sorry

theorem lift_id' (a : cardinal) : lift a = a :=
  quot.induction_on a fun (α : Type (max u_1 u_2)) => quot.sound (Nonempty.intro equiv.ulift)

@[simp] theorem lift_id (a : cardinal) : lift a = a := lift_id'

@[simp] theorem lift_lift (a : cardinal) : lift (lift a) = lift a :=
  quot.induction_on a
    fun (α : Type u) =>
      quotient.sound
        (Nonempty.intro
          (equiv.trans equiv.ulift (equiv.trans equiv.ulift (equiv.symm equiv.ulift))))

theorem lift_mk_le {α : Type u} {β : Type v} : lift (mk α) ≤ lift (mk β) ↔ Nonempty (α ↪ β) := sorry

theorem lift_mk_eq {α : Type u} {β : Type v} : lift (mk α) = lift (mk β) ↔ Nonempty (α ≃ β) := sorry

@[simp] theorem lift_le {a : cardinal} {b : cardinal} : lift a ≤ lift b ↔ a ≤ b := sorry

@[simp] theorem lift_inj {a : cardinal} {b : cardinal} : lift a = lift b ↔ a = b := sorry

@[simp] theorem lift_lt {a : cardinal} {b : cardinal} : lift a < lift b ↔ a < b := sorry

@[simp] theorem lift_zero : lift 0 = 0 :=
  quotient.sound (Nonempty.intro (equiv.trans equiv.ulift equiv.pempty_equiv_pempty))

@[simp] theorem lift_one : lift 1 = 1 :=
  quotient.sound (Nonempty.intro (equiv.trans equiv.ulift equiv.punit_equiv_punit))

@[simp] theorem lift_add (a : cardinal) (b : cardinal) : lift (a + b) = lift a + lift b :=
  quotient.induction_on₂ a b
    fun (α β : Type u_1) =>
      quotient.sound
        (Nonempty.intro
          (equiv.trans equiv.ulift (equiv.symm (equiv.sum_congr equiv.ulift equiv.ulift))))

@[simp] theorem lift_mul (a : cardinal) (b : cardinal) : lift (a * b) = lift a * lift b :=
  quotient.induction_on₂ a b
    fun (α β : Type u_1) =>
      quotient.sound
        (Nonempty.intro
          (equiv.trans equiv.ulift (equiv.symm (equiv.prod_congr equiv.ulift equiv.ulift))))

@[simp] theorem lift_power (a : cardinal) (b : cardinal) : lift (a ^ b) = lift a ^ lift b :=
  quotient.induction_on₂ a b
    fun (α β : Type u_1) =>
      quotient.sound
        (Nonempty.intro
          (equiv.trans equiv.ulift (equiv.symm (equiv.arrow_congr equiv.ulift equiv.ulift))))

@[simp] theorem lift_two_power (a : cardinal) : lift (bit0 1 ^ a) = bit0 1 ^ lift a := sorry

@[simp] theorem lift_min {ι : Type u_1} {I : Nonempty ι} (f : ι → cardinal) :
    lift (min I f) = min I (lift ∘ f) :=
  sorry

theorem lift_down {a : cardinal} {b : cardinal} : b ≤ lift a → ∃ (a' : cardinal), lift a' = b :=
  sorry

theorem le_lift_iff {a : cardinal} {b : cardinal} :
    b ≤ lift a ↔ ∃ (a' : cardinal), lift a' = b ∧ a' ≤ a :=
  sorry

theorem lt_lift_iff {a : cardinal} {b : cardinal} :
    b < lift a ↔ ∃ (a' : cardinal), lift a' = b ∧ a' < a :=
  sorry

@[simp] theorem lift_succ (a : cardinal) : lift (succ a) = succ (lift a) := sorry

@[simp] theorem lift_max {a : cardinal} {b : cardinal} : lift a = lift b ↔ lift a = lift b := sorry

theorem mk_prod {α : Type u} {β : Type v} : mk (α × β) = lift (mk α) * lift (mk β) :=
  quotient.sound
    (Nonempty.intro (equiv.prod_congr (equiv.symm equiv.ulift) (equiv.symm equiv.ulift)))

theorem sum_const_eq_lift_mul (ι : Type u) (a : cardinal) :
    (sum fun (_x : ι) => a) = lift (mk ι) * lift a :=
  sorry

/-- `ω` is the smallest infinite cardinal, also known as ℵ₀. -/
def omega : cardinal := lift (mk ℕ)

theorem mk_nat : mk ℕ = omega := Eq.symm (lift_id (mk ℕ))

theorem omega_ne_zero : omega ≠ 0 := iff.mpr ne_zero_iff_nonempty (Nonempty.intro (ulift.up 0))

theorem omega_pos : 0 < omega := iff.mpr pos_iff_ne_zero omega_ne_zero

@[simp] theorem lift_omega : lift omega = omega := lift_lift (mk ℕ)

/- properties about the cast from nat -/

@[simp] theorem mk_fin (n : ℕ) : mk (fin n) = ↑n := sorry

@[simp] theorem lift_nat_cast (n : ℕ) : lift ↑n = ↑n := sorry

theorem lift_eq_nat_iff {a : cardinal} {n : ℕ} : lift a = ↑n ↔ a = ↑n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (lift a = ↑n ↔ a = ↑n)) (Eq.symm (lift_nat_cast n))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (lift a = lift ↑n ↔ a = ↑n)) (propext lift_inj)))
      (iff.refl (a = ↑n)))

theorem nat_eq_lift_eq_iff {n : ℕ} {a : cardinal} : ↑n = lift a ↔ ↑n = a :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑n = lift a ↔ ↑n = a)) (Eq.symm (lift_nat_cast n))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (lift ↑n = lift a ↔ ↑n = a)) (propext lift_inj)))
      (iff.refl (↑n = a)))

theorem lift_mk_fin (n : ℕ) : lift (mk (fin n)) = ↑n := sorry

theorem fintype_card (α : Type u) [fintype α] : mk α = ↑(fintype.card α) := sorry

theorem card_le_of_finset {α : Type u_1} (s : finset α) : ↑(finset.card s) ≤ mk α := sorry

@[simp] theorem nat_cast_pow {m : ℕ} {n : ℕ} : ↑(m ^ n) = ↑m ^ ↑n := sorry

@[simp] theorem nat_cast_le {m : ℕ} {n : ℕ} : ↑m ≤ ↑n ↔ m ≤ n := sorry

@[simp] theorem nat_cast_lt {m : ℕ} {n : ℕ} : ↑m < ↑n ↔ m < n := sorry

@[simp] theorem nat_cast_inj {m : ℕ} {n : ℕ} : ↑m = ↑n ↔ m = n := sorry

@[simp] theorem nat_succ (n : ℕ) : ↑(Nat.succ n) = succ ↑n :=
  le_antisymm (add_one_le_succ (nat.cast n))
    (iff.mpr succ_le (iff.mpr nat_cast_lt (nat.lt_succ_self n)))

@[simp] theorem succ_zero : succ 0 = 1 := sorry

theorem card_le_of {α : Type u} {n : ℕ} (H : ∀ (s : finset α), finset.card s ≤ n) : mk α ≤ ↑n :=
  sorry

theorem cantor' (a : cardinal) {b : cardinal} (hb : 1 < b) : a < b ^ a := sorry

theorem one_le_iff_pos {c : cardinal} : 1 ≤ c ↔ 0 < c :=
  eq.mpr (id (Eq._oldrec (Eq.refl (1 ≤ c ↔ 0 < c)) (Eq.symm succ_zero)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (succ 0 ≤ c ↔ 0 < c)) (propext succ_le))) (iff.refl (0 < c)))

theorem one_le_iff_ne_zero {c : cardinal} : 1 ≤ c ↔ c ≠ 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (1 ≤ c ↔ c ≠ 0)) (propext one_le_iff_pos)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (0 < c ↔ c ≠ 0)) (propext pos_iff_ne_zero)))
      (iff.refl (c ≠ 0)))

theorem nat_lt_omega (n : ℕ) : ↑n < omega := sorry

@[simp] theorem one_lt_omega : 1 < omega := sorry

theorem lt_omega {c : cardinal} : c < omega ↔ ∃ (n : ℕ), c = ↑n := sorry

theorem omega_le {c : cardinal} : omega ≤ c ↔ ∀ (n : ℕ), ↑n ≤ c := sorry

theorem lt_omega_iff_fintype {α : Type u} : mk α < omega ↔ Nonempty (fintype α) := sorry

theorem lt_omega_iff_finite {α : Type u_1} {S : set α} : mk ↥S < omega ↔ set.finite S :=
  lt_omega_iff_fintype

protected instance can_lift_cardinal_nat : can_lift cardinal ℕ :=
  can_lift.mk coe (fun (x : cardinal) => x < omega) sorry

theorem add_lt_omega {a : cardinal} {b : cardinal} (ha : a < omega) (hb : b < omega) :
    a + b < omega :=
  sorry

theorem add_lt_omega_iff {a : cardinal} {b : cardinal} : a + b < omega ↔ a < omega ∧ b < omega :=
  sorry

theorem mul_lt_omega {a : cardinal} {b : cardinal} (ha : a < omega) (hb : b < omega) :
    a * b < omega :=
  sorry

theorem mul_lt_omega_iff {a : cardinal} {b : cardinal} :
    a * b < omega ↔ a = 0 ∨ b = 0 ∨ a < omega ∧ b < omega :=
  sorry

theorem mul_lt_omega_iff_of_ne_zero {a : cardinal} {b : cardinal} (ha : a ≠ 0) (hb : b ≠ 0) :
    a * b < omega ↔ a < omega ∧ b < omega :=
  sorry

theorem power_lt_omega {a : cardinal} {b : cardinal} (ha : a < omega) (hb : b < omega) :
    a ^ b < omega :=
  sorry

theorem eq_one_iff_subsingleton_and_nonempty {α : Type u_1} :
    mk α = 1 ↔ subsingleton α ∧ Nonempty α :=
  sorry

theorem infinite_iff {α : Type u} : infinite α ↔ omega ≤ mk α := sorry

theorem countable_iff {α : Type u} (s : set α) : set.countable s ↔ mk ↥s ≤ omega := sorry

theorem denumerable_iff {α : Type u} : Nonempty (denumerable α) ↔ mk α = omega := sorry

theorem mk_int : mk ℤ = omega := iff.mp denumerable_iff (Nonempty.intro denumerable.int)

theorem mk_pnat : mk ℕ+ = omega := iff.mp denumerable_iff (Nonempty.intro denumerable.pnat)

theorem two_le_iff {α : Type u} : bit0 1 ≤ mk α ↔ ∃ (x : α), ∃ (y : α), x ≠ y := sorry

theorem two_le_iff' {α : Type u} (x : α) : bit0 1 ≤ mk α ↔ ∃ (y : α), x ≠ y := sorry

/-- König's theorem -/
theorem sum_lt_prod {ι : Type u_1} (f : ι → cardinal) (g : ι → cardinal)
    (H : ∀ (i : ι), f i < g i) : sum f < prod g :=
  sorry

@[simp] theorem mk_empty : mk empty = 0 := fintype_card empty

@[simp] theorem mk_pempty : mk pempty = 0 := fintype_card pempty

@[simp] theorem mk_plift_of_false {p : Prop} (h : ¬p) : mk (plift p) = 0 :=
  quotient.sound (Nonempty.intro (equiv.trans equiv.plift (equiv.equiv_pempty h)))

theorem mk_unit : mk Unit = 1 := Eq.trans (fintype_card Unit) nat.cast_one

@[simp] theorem mk_punit : mk PUnit = 1 := Eq.trans (fintype_card PUnit) nat.cast_one

@[simp] theorem mk_singleton {α : Type u} (x : α) : mk ↥(singleton x) = 1 :=
  quotient.sound (Nonempty.intro (equiv.set.singleton x))

@[simp] theorem mk_plift_of_true {p : Prop} (h : p) : mk (plift p) = 1 :=
  quotient.sound (Nonempty.intro (equiv.trans equiv.plift (equiv.prop_equiv_punit h)))

@[simp] theorem mk_bool : mk Bool = bit0 1 :=
  quotient.sound (Nonempty.intro equiv.bool_equiv_punit_sum_punit)

@[simp] theorem mk_Prop : mk Prop = bit0 1 :=
  Eq.trans (quotient.sound (Nonempty.intro equiv.Prop_equiv_bool)) mk_bool

@[simp] theorem mk_set {α : Type u} : mk (set α) = bit0 1 ^ mk α := sorry

@[simp] theorem mk_option {α : Type u} : mk (Option α) = mk α + 1 :=
  quotient.sound (Nonempty.intro (equiv.option_equiv_sum_punit α))

theorem mk_list_eq_sum_pow (α : Type u) : mk (List α) = sum fun (n : ℕ) => mk α ^ ↑n := sorry

theorem mk_quot_le {α : Type u} {r : α → α → Prop} : mk (Quot r) ≤ mk α :=
  mk_le_of_surjective quot.exists_rep

theorem mk_quotient_le {α : Type u} {s : setoid α} : mk (quotient s) ≤ mk α := mk_quot_le

theorem mk_subtype_le {α : Type u} (p : α → Prop) : mk (Subtype p) ≤ mk α :=
  Nonempty.intro (function.embedding.subtype p)

theorem mk_subtype_le_of_subset {α : Type u} {p : α → Prop} {q : α → Prop}
    (h : ∀ {x : α}, p x → q x) : mk (Subtype p) ≤ mk (Subtype q) :=
  Nonempty.intro (function.embedding.subtype_map (function.embedding.refl α) h)

@[simp] theorem mk_emptyc (α : Type u) : mk ↥∅ = 0 :=
  quotient.sound (Nonempty.intro (equiv.set.pempty α))

theorem mk_emptyc_iff {α : Type u} {s : set α} : mk ↥s = 0 ↔ s = ∅ := sorry

theorem mk_univ {α : Type u} : mk ↥set.univ = mk α :=
  quotient.sound (Nonempty.intro (equiv.set.univ α))

theorem mk_image_le {α : Type u} {β : Type u} {f : α → β} {s : set α} : mk ↥(f '' s) ≤ mk ↥s :=
  mk_le_of_surjective set.surjective_onto_image

theorem mk_image_le_lift {α : Type u} {β : Type v} {f : α → β} {s : set α} :
    lift (mk ↥(f '' s)) ≤ lift (mk ↥s) :=
  iff.mpr lift_mk_le
    (Nonempty.intro
      (function.embedding.of_surjective (set.image_factorization f s) set.surjective_onto_image))

theorem mk_range_le {α : Type u} {β : Type u} {f : α → β} : mk ↥(set.range f) ≤ mk α :=
  mk_le_of_surjective set.surjective_onto_range

theorem mk_range_eq {α : Type u} {β : Type u} (f : α → β) (h : function.injective f) :
    mk ↥(set.range f) = mk α :=
  quotient.sound (Nonempty.intro (equiv.symm (equiv.set.range f h)))

theorem mk_range_eq_of_injective {α : Type u} {β : Type v} {f : α → β} (hf : function.injective f) :
    lift (mk ↥(set.range f)) = lift (mk α) :=
  sorry

theorem mk_range_eq_lift {α : Type u} {β : Type v} {f : α → β} (hf : function.injective f) :
    lift (mk ↥(set.range f)) = lift (mk α) :=
  iff.mpr lift_mk_eq (Nonempty.intro (equiv.symm (equiv.set.range f hf)))

theorem mk_image_eq {α : Type u} {β : Type u} {f : α → β} {s : set α} (hf : function.injective f) :
    mk ↥(f '' s) = mk ↥s :=
  quotient.sound (Nonempty.intro (equiv.symm (equiv.set.image f s hf)))

theorem mk_Union_le_sum_mk {α : Type u} {ι : Type u} {f : ι → set α} :
    mk ↥(set.Union fun (i : ι) => f i) ≤ sum fun (i : ι) => mk ↥(f i) :=
  trans_rel_left LessEq (mk_le_of_surjective (set.sigma_to_Union_surjective f))
    (Eq.symm (sum_mk fun (i : ι) => ↥(f i)))

theorem mk_Union_eq_sum_mk {α : Type u} {ι : Type u} {f : ι → set α}
    (h : ∀ (i j : ι), i ≠ j → disjoint (f i) (f j)) :
    mk ↥(set.Union fun (i : ι) => f i) = sum fun (i : ι) => mk ↥(f i) :=
  Eq.trans (quot.sound (Nonempty.intro (set.Union_eq_sigma_of_disjoint h)))
    (Eq.symm (sum_mk fun (i : ι) => ↥(f i)))

theorem mk_Union_le {α : Type u} {ι : Type u} (f : ι → set α) :
    mk ↥(set.Union fun (i : ι) => f i) ≤ mk ι * sup fun (i : ι) => mk ↥(f i) :=
  le_trans mk_Union_le_sum_mk (sum_le_sup fun (i : ι) => mk ↥(f i))

theorem mk_sUnion_le {α : Type u} (A : set (set α)) :
    mk ↥(⋃₀A) ≤ mk ↥A * sup fun (s : ↥A) => mk ↥s :=
  eq.mpr
    (id (Eq._oldrec (Eq.refl (mk ↥(⋃₀A) ≤ mk ↥A * sup fun (s : ↥A) => mk ↥s)) set.sUnion_eq_Union))
    (mk_Union_le fun (i : ↥A) => ↑i)

theorem mk_bUnion_le {ι : Type u} {α : Type u} (A : ι → set α) (s : set ι) :
    mk ↥(set.Union fun (x : ι) => set.Union fun (H : x ∈ s) => A x) ≤
        mk ↥s * sup fun (x : ↥s) => mk ↥(A (subtype.val x)) :=
  sorry

@[simp] theorem finset_card {α : Type u} {s : finset α} : ↑(finset.card s) = mk ↥↑s := sorry

theorem finset_card_lt_omega {α : Type u} (s : finset α) : mk ↥↑s < omega :=
  eq.mpr (id (Eq._oldrec (Eq.refl (mk ↥↑s < omega)) (propext lt_omega_iff_fintype)))
    (Nonempty.intro (finset.subtype.fintype s))

theorem mk_union_add_mk_inter {α : Type u} {S : set α} {T : set α} :
    mk ↥(S ∪ T) + mk ↥(S ∩ T) = mk ↥S + mk ↥T :=
  quot.sound (Nonempty.intro (equiv.set.union_sum_inter S T))

/-- The cardinality of a union is at most the sum of the cardinalities
of the two sets. -/
theorem mk_union_le {α : Type u} (S : set α) (T : set α) : mk ↥(S ∪ T) ≤ mk ↥S + mk ↥T :=
  mk_union_add_mk_inter ▸ self_le_add_right (mk ↥(S ∪ T)) (mk ↥(S ∩ T))

theorem mk_union_of_disjoint {α : Type u} {S : set α} {T : set α} (H : disjoint S T) :
    mk ↥(S ∪ T) = mk ↥S + mk ↥T :=
  quot.sound (Nonempty.intro (equiv.set.union H))

theorem mk_sum_compl {α : Type u_1} (s : set α) : mk ↥s + mk ↥(sᶜ) = mk α :=
  quotient.sound (Nonempty.intro (equiv.set.sum_compl s))

theorem mk_le_mk_of_subset {α : Type u_1} {s : set α} {t : set α} (h : s ⊆ t) : mk ↥s ≤ mk ↥t :=
  Nonempty.intro (set.embedding_of_subset s t h)

theorem mk_subtype_mono {α : Type u} {p : α → Prop} {q : α → Prop} (h : ∀ (x : α), p x → q x) :
    mk (Subtype fun (x : α) => p x) ≤ mk (Subtype fun (x : α) => q x) :=
  Nonempty.intro (set.embedding_of_subset (fun (x : α) => p x) (fun (x : α) => q x) h)

theorem mk_set_le {α : Type u} (s : set α) : mk ↥s ≤ mk α := mk_subtype_le s

theorem mk_image_eq_lift {α : Type u} {β : Type v} (f : α → β) (s : set α)
    (h : function.injective f) : lift (mk ↥(f '' s)) = lift (mk ↥s) :=
  iff.mpr lift_mk_eq (Nonempty.intro (equiv.symm (equiv.set.image f s h)))

theorem mk_image_eq_of_inj_on_lift {α : Type u} {β : Type v} (f : α → β) (s : set α)
    (h : set.inj_on f s) : lift (mk ↥(f '' s)) = lift (mk ↥s) :=
  iff.mpr lift_mk_eq (Nonempty.intro (equiv.symm (equiv.set.image_of_inj_on f s h)))

theorem mk_image_eq_of_inj_on {α : Type u} {β : Type u} (f : α → β) (s : set α)
    (h : set.inj_on f s) : mk ↥(f '' s) = mk ↥s :=
  quotient.sound (Nonempty.intro (equiv.symm (equiv.set.image_of_inj_on f s h)))

theorem mk_subtype_of_equiv {α : Type u} {β : Type u} (p : β → Prop) (e : α ≃ β) :
    mk (Subtype fun (a : α) => p (coe_fn e a)) = mk (Subtype fun (b : β) => p b) :=
  quotient.sound (Nonempty.intro (equiv.subtype_equiv_of_subtype e))

theorem mk_sep {α : Type u} (s : set α) (t : α → Prop) :
    mk ↥(has_sep.sep (fun (x : α) => t x) s) = mk ↥(set_of fun (x : ↥s) => t (subtype.val x)) :=
  quotient.sound (Nonempty.intro (equiv.set.sep s t))

theorem mk_preimage_of_injective_lift {α : Type u} {β : Type v} (f : α → β) (s : set β)
    (h : function.injective f) : lift (mk ↥(f ⁻¹' s)) ≤ lift (mk ↥s) :=
  sorry

theorem mk_preimage_of_subset_range_lift {α : Type u} {β : Type v} (f : α → β) (s : set β)
    (h : s ⊆ set.range f) : lift (mk ↥s) ≤ lift (mk ↥(f ⁻¹' s)) :=
  sorry

theorem mk_preimage_of_injective_of_subset_range_lift {α : Type u} {β : Type v} (f : α → β)
    (s : set β) (h : function.injective f) (h2 : s ⊆ set.range f) :
    lift (mk ↥(f ⁻¹' s)) = lift (mk ↥s) :=
  le_antisymm (mk_preimage_of_injective_lift f s h) (mk_preimage_of_subset_range_lift f s h2)

theorem mk_preimage_of_injective {α : Type u} {β : Type u} (f : α → β) (s : set β)
    (h : function.injective f) : mk ↥(f ⁻¹' s) ≤ mk ↥s :=
  sorry

theorem mk_preimage_of_subset_range {α : Type u} {β : Type u} (f : α → β) (s : set β)
    (h : s ⊆ set.range f) : mk ↥s ≤ mk ↥(f ⁻¹' s) :=
  sorry

theorem mk_preimage_of_injective_of_subset_range {α : Type u} {β : Type u} (f : α → β) (s : set β)
    (h : function.injective f) (h2 : s ⊆ set.range f) : mk ↥(f ⁻¹' s) = mk ↥s :=
  sorry

theorem mk_subset_ge_of_subset_image_lift {α : Type u} {β : Type v} (f : α → β) {s : set α}
    {t : set β} (h : t ⊆ f '' s) :
    lift (mk ↥t) ≤ lift (mk ↥(has_sep.sep (fun (x : α) => f x ∈ t) s)) :=
  sorry

theorem mk_subset_ge_of_subset_image {α : Type u} {β : Type u} (f : α → β) {s : set α} {t : set β}
    (h : t ⊆ f '' s) : mk ↥t ≤ mk ↥(has_sep.sep (fun (x : α) => f x ∈ t) s) :=
  sorry

theorem le_mk_iff_exists_subset {c : cardinal} {α : Type u} {s : set α} :
    c ≤ mk ↥s ↔ ∃ (p : set α), p ⊆ s ∧ mk ↥p = c :=
  sorry

/-- The function α^{<β}, defined to be sup_{γ < β} α^γ.
  We index over {s : set β.out // mk s < β } instead of {γ // γ < β}, because the latter lives in a
  higher universe -/
def powerlt (α : cardinal) (β : cardinal) : cardinal :=
  sup fun (s : Subtype fun (s : set (quotient.out β)) => mk ↥s < β) => α ^ mk ↥s

infixl:80 " ^< " => Mathlib.cardinal.powerlt

theorem powerlt_aux {c : cardinal} {c' : cardinal} (h : c < c') :
    ∃ (s : Subtype fun (s : set (quotient.out c')) => mk ↥s < c'), mk ↥s = c :=
  sorry

theorem le_powerlt {c₁ : cardinal} {c₂ : cardinal} {c₃ : cardinal} (h : c₂ < c₃) :
    c₁ ^ c₂ ≤ c₁ ^< c₃ :=
  sorry

theorem powerlt_le {c₁ : cardinal} {c₂ : cardinal} {c₃ : cardinal} :
    c₁ ^< c₂ ≤ c₃ ↔ ∀ (c₄ : cardinal), c₄ < c₂ → c₁ ^ c₄ ≤ c₃ :=
  sorry

theorem powerlt_le_powerlt_left {a : cardinal} {b : cardinal} {c : cardinal} (h : b ≤ c) :
    a ^< b ≤ a ^< c :=
  sorry

theorem powerlt_succ {c₁ : cardinal} {c₂ : cardinal} (h : c₁ ≠ 0) : c₁ ^< succ c₂ = c₁ ^ c₂ := sorry

theorem powerlt_max {c₁ : cardinal} {c₂ : cardinal} {c₃ : cardinal} :
    c₁ ^< max c₂ c₃ = max (c₁ ^< c₂) (c₁ ^< c₃) :=
  sorry

theorem zero_powerlt {a : cardinal} (h : a ≠ 0) : 0 ^< a = 1 := sorry

theorem powerlt_zero {a : cardinal} : a ^< 0 = 0 := sorry

end Mathlib


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

/-!
# Essential image of a functor

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

The essential image `ess_image` of a functor consists of the objects in the target category which
are isomorphic to an object in the image of the object function.
This, for instance, allows us to talk about objects belonging to a subcategory expressed as a
functor rather than a subtype, preserving the principle of equivalence. For example this lets us
define exponential ideals.

The essential image can also be seen as a subcategory of the target category, and witnesses that
a functor decomposes into a essentially surjective functor and a fully faithful functor.
(TODO: show that this decomposition forms an orthogonal factorisation system).
-/
universes v₁ v₂ u₁ u₂

noncomputable theory

namespace category_theory

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

namespace functor

/--
The essential image of a functor `F` consists of those objects in the target category which are
isomorphic to an object in the image of the function `F.obj`. In other words, this is the closure
under isomorphism of the function `F.obj`.
This is the "non-evil" way of describing the image of a functor.
-/
def ess_image (F : C ⥤ D) : set D := λ Y, ∃ (X : C), nonempty (F.obj X ≅ Y)

/-- Get the witnessing object that `Y` is in the subcategory given by `F`. -/
def ess_image.witness {Y : D} (h : Y ∈ F.ess_image) : C := h.some

/-- Extract the isomorphism between `F.obj h.witness` and `Y` itself. -/
def ess_image.get_iso {Y : D} (h : Y ∈ F.ess_image) : F.obj h.witness ≅ Y :=
classical.choice h.some_spec

/-- Being in the essential image is a "hygenic" property: it is preserved under isomorphism. -/
lemma ess_image.of_iso {Y Y' : D} (h : Y ≅ Y') (hY : Y ∈ ess_image F) :
  Y' ∈ ess_image F :=
hY.imp (λ B, nonempty.map (≪≫ h))

/--
If `Y` is in the essential image of `F` then it is in the essential image of `F'` as long as
`F ≅ F'`.
-/
lemma ess_image.of_nat_iso {F' : C ⥤ D} (h : F ≅ F') {Y : D} (hY : Y ∈ ess_image F) :
  Y ∈ ess_image F' :=
hY.imp (λ X, nonempty.map (λ t, h.symm.app X ≪≫ t))

/-- Isomorphic functors have equal essential images. -/
lemma ess_image_eq_of_nat_iso {F' : C ⥤ D} (h : F ≅ F') :
  ess_image F = ess_image F' :=
funext (λ _, propext ⟨ess_image.of_nat_iso h, ess_image.of_nat_iso h.symm⟩)

/-- An object in the image is in the essential image. -/
lemma obj_mem_ess_image (F : D ⥤ C) (Y : D) : F.obj Y ∈ ess_image F := ⟨Y, ⟨iso.refl _⟩⟩

/-- The essential image of a functor, interpreted of a full subcategory of the target category. -/
@[derive category, nolint has_nonempty_instance]
def ess_image_subcategory (F : C ⥤ D) := full_subcategory F.ess_image

/-- The essential image as a subcategory has a fully faithful inclusion into the target category. -/
@[derive [full, faithful], simps]
def ess_image_inclusion (F : C ⥤ D) : F.ess_image_subcategory ⥤ D :=
full_subcategory_inclusion _

/--
Given a functor `F : C ⥤ D`, we have an (essentially surjective) functor from `C` to the essential
image of `F`.
-/
@[simps]
def to_ess_image (F : C ⥤ D) : C ⥤ F.ess_image_subcategory :=
full_subcategory.lift _ F (obj_mem_ess_image _)

/--
The functor `F` factorises through its essential image, where the first functor is essentially
surjective and the second is fully faithful.
-/
@[simps]
def to_ess_image_comp_essential_image_inclusion (F : C ⥤ D) :
  F.to_ess_image ⋙ F.ess_image_inclusion ≅ F :=
full_subcategory.lift_comp_inclusion _ _ _

end functor

/--
A functor `F : C ⥤ D` is essentially surjective if every object of `D` is in the essential image
of `F`. In other words, for every `Y : D`, there is some `X : C` with `F.obj X ≅ Y`.

See <https://stacks.math.columbia.edu/tag/001C>.
-/
class ess_surj (F : C ⥤ D) : Prop :=
(mem_ess_image [] (Y : D) : Y ∈ F.ess_image)

instance : ess_surj F.to_ess_image :=
{ mem_ess_image := λ ⟨Y, hY⟩, ⟨_, ⟨⟨_, _, hY.get_iso.hom_inv_id, hY.get_iso.inv_hom_id⟩⟩⟩ }

variables (F) [ess_surj F]

/-- Given an essentially surjective functor, we can find a preimage for every object `Y` in the
    codomain. Applying the functor to this preimage will yield an object isomorphic to `Y`, see
    `obj_obj_preimage_iso`. -/
def functor.obj_preimage (Y : D) : C := (ess_surj.mem_ess_image F Y).witness
/-- Applying an essentially surjective functor to a preimage of `Y` yields an object that is
    isomorphic to `Y`. -/
def functor.obj_obj_preimage_iso (Y : D) : F.obj (F.obj_preimage Y) ≅ Y :=
(ess_surj.mem_ess_image F Y).get_iso

/-- The induced functor of a faithful functor is faithful -/
instance faithful.to_ess_image (F : C ⥤ D) [faithful F] : faithful F.to_ess_image :=
faithful.of_comp_iso F.to_ess_image_comp_essential_image_inclusion

/-- The induced functor of a full functor is full -/
instance full.to_ess_image (F : C ⥤ D) [full F] : full F.to_ess_image :=
begin
  haveI := full.of_iso F.to_ess_image_comp_essential_image_inclusion.symm,
  exactI full.of_comp_faithful F.to_ess_image F.ess_image_inclusion
end

end category_theory


import data.nat.lattice
import data.nat.prime
import data.nat.prime_fin
import data.finset.basic
import tactic

open finset nat set
noncomputable

-- A098550 The Yellowstone permutation

def s : ℕ → ℕ
| 0       := 0
| 1       := 1
| 2       := 2
| 3       := 3
| (n + 4) := Inf { k : ℕ | 0 < k ∧ ∀ m < n + 4, s m ≠ k ∧ nat.coprime k (s (n + 3)) ∧
                   1 < nat.gcd k (s (n + 2)) }

@[simp]
lemma s0 : s 0 = 0 := by rw s
@[simp]
lemma s1 : s 1 = 1 := by rw s
@[simp]
lemma s2 : s 2 = 2 := by rw s
@[simp]
lemma s3 : s 3 = 3 := by rw s

-- Proof by ericr
lemma s_four : s 4 = 4 :=
begin
  rw s,
  have key : _ := _,
  rw nat.Inf_def ⟨4, key⟩,
  swap,
  { norm_num,
    intros m hm,
    interval_cases m; simp, },
  apply le_antisymm,
  { apply nat.find_min',
    exact key, },
  { rw le_find_iff,
    intros m hm,
    interval_cases m;
    simp [show ∃ x : ℕ, x < 4, by exact ⟨3, by simp⟩],
    exact ⟨2, by simp⟩, },
end

lemma s_nonempty {n : ℕ} : set.nonempty
{ k : ℕ | 0 < k ∧ ∀ m < n + 4, s m ≠ k ∧ nat.coprime k (s (n + 3)) ∧ 1 < nat.gcd k (s (n + 2)) } :=
begin
  induction n with k hk,
  { use 4, norm_num, intros m hm, interval_cases m; simp, },
  { -- construct prime larger than every value before
    have big_prime : ∃ p, nat.prime p ∧ ∀ m < k.succ + 4, s m < p,
    {  -- set of previous values
      let prev_values : finset ℕ := (finset.image s (finset.range (k.succ + 4))),
      let ub : ℕ := prev_values.sup id,
      -- use infinitude of primes
      rcases infinite.exists_nat_lt infinite_set_of_prime ub with ⟨p, ⟨hp, hp'⟩⟩,
      use p,
      split,
      { rw mem_set_of_eq at hp, exact hp, },
      { intros m hm,
        apply lt_of_le_of_lt _ hp',
        dsimp [ub],
        rw ← id.def (s m),
        apply le_sup,
        rw finset.mem_image,
        use m,
        simp [hm], }, },
    -- use s (k.succ + 2) * big_prime
    sorry, }
end

/-

Kept here for historical reasons + I want to laugh at myself forever at this

-- Maybe I should quit Lean...
lemma s_four : s 4 = 4 :=
begin
  rw s,
  apply le_antisymm,
  { apply nat.Inf_le,
    simp_rw [mem_set_of_eq, s, coprime],
    norm_num,
    intros m hm,
    rcases m with _|_|_|_|_,
    { simp, },
    { simp, },
    { simp, },
    { simp, },
    { exfalso,
      simp_rw [succ_lt_succ_iff] at hm, linarith, }, },
  { simp_rw [s, coprime],
    rw Inf_def,
    swap,
    { use 4,
      rw mem_set_of_eq,
      norm_num,
      intros m hm,
      rcases m with _|_|_|_|_,
      { simp, },
      { simp, },
      { simp, },
      { simp, },
      { exfalso,
        simp_rw [succ_lt_succ_iff] at hm, linarith, }, },
    rw nat.le_find_iff,
    norm_num,
    intros m hm,
    rcases m with _|_|_|_|_,
    { simp, },
    { simp, use 2, simp [s], },
    { simp, use 2, simp [s], },
    { simp, use 2, simp [s], },
    { simp_rw [succ_lt_succ_iff] at hm, linarith, }, },
end

-/


/-
Copyright (c) 2021 Filippo A. E. Nuccio. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Filippo A. E. Nuccio, Eric Wieser
-/

import data.matrix.basic
import data.matrix.block
import linear_algebra.matrix.determinant
import linear_algebra.matrix.nonsingular_inverse
import linear_algebra.tensor_product
import ring_theory.tensor_product

/-!
# Kronecker product of matrices

This defines the [Kronecker product](https://en.wikipedia.org/wiki/Kronecker_product).

## Main definitions

* `matrix.kronecker_map`: A generalization of the Kronecker product: given a map `f : α → β → γ`
  and matrices `A` and `B` with coefficients in `α` and `β`, respectively, it is defined as the
  matrix with coefficients in `γ` such that
  `kronecker_map f A B (i₁, i₂) (j₁, j₂) = f (A i₁ j₁) (B i₁ j₂)`.
* `matrix.kronecker_map_bilinear`: when `f` is bilinear, so is `kronecker_map f`.

## Specializations

* `matrix.kronecker`: An alias of `kronecker_map (*)`. Prefer using the notation.
* `matrix.kronecker_bilinear`: `matrix.kronecker` is bilinear

* `matrix.kronecker_tmul`: An alias of `kronecker_map (⊗ₜ)`. Prefer using the notation.
* `matrix.kronecker_tmul_bilinear`: `matrix.tmul_kronecker` is bilinear

## Notations

These require `open_locale kronecker`:

* `A ⊗ₖ B` for `kronecker_map (*) A B`. Lemmas about this notation use the token `kronecker`.
* `A ⊗ₖₜ B` and `A ⊗ₖₜ[R] B` for `kronecker_map (⊗ₜ) A B`.  Lemmas about this notation use the token
  `kronecker_tmul`.

-/

namespace matrix

open_locale matrix

variables {R α α' β β' γ γ' : Type*}
variables {l m n p : Type*} {q r : Type*} {l' m' n' p' : Type*}

section kronecker_map

/-- Produce a matrix with `f` applied to every pair of elements from `A` and `B`. -/
def kronecker_map (f : α → β → γ) (A : matrix l m α) (B : matrix n p β) :
  matrix (l × n) (m × p) γ :=
of $ λ (i : l × n) (j : m × p), f (A i.1 j.1) (B i.2 j.2)

-- TODO: set as an equation lemma for `kronecker_map`, see mathlib4#3024
@[simp]
lemma kronecker_map_apply (f : α → β → γ) (A : matrix l m α) (B : matrix n p β) (i j) :
  kronecker_map f A B i j = f (A i.1 j.1) (B i.2 j.2) := rfl

lemma kronecker_map_transpose (f : α → β → γ)
  (A : matrix l m α) (B : matrix n p β) :
  kronecker_map f Aᵀ Bᵀ = (kronecker_map f A B)ᵀ :=
ext $ λ i j, rfl

lemma kronecker_map_map_left (f : α' → β → γ) (g : α → α')
  (A : matrix l m α) (B : matrix n p β) :
  kronecker_map f (A.map g) B = kronecker_map (λ a b, f (g a) b) A B :=
ext $ λ i j, rfl

lemma kronecker_map_map_right (f : α → β' → γ) (g : β → β')
  (A : matrix l m α) (B : matrix n p β) :
  kronecker_map f A (B.map g) = kronecker_map (λ a b, f a (g b)) A B :=
ext $ λ i j, rfl

lemma kronecker_map_map (f : α → β → γ) (g : γ → γ')
  (A : matrix l m α) (B : matrix n p β) :
  (kronecker_map f A B).map g = kronecker_map (λ a b, g (f a b)) A B :=
ext $ λ i j, rfl

@[simp] lemma kronecker_map_zero_left [has_zero α] [has_zero γ]
  (f : α → β → γ) (hf : ∀ b, f 0 b = 0) (B : matrix n p β) :
  kronecker_map f (0 : matrix l m α) B = 0:=
ext $ λ i j,hf _

@[simp] lemma kronecker_map_zero_right [has_zero β] [has_zero γ]
  (f : α → β → γ) (hf : ∀ a, f a 0 = 0) (A : matrix l m α) :
  kronecker_map f A (0 : matrix n p β) = 0 :=
ext $ λ i j, hf _

lemma kronecker_map_add_left [has_add α] [has_add γ] (f : α → β → γ)
  (hf : ∀ a₁ a₂ b, f (a₁ + a₂) b = f a₁ b + f a₂ b)
  (A₁ A₂ : matrix l m α) (B : matrix n p β) :
  kronecker_map f (A₁ + A₂) B = kronecker_map f A₁ B + kronecker_map f A₂ B :=
ext $ λ i j, hf _ _ _

lemma kronecker_map_add_right [has_add β] [has_add γ] (f : α → β → γ)
  (hf : ∀ a b₁ b₂, f a (b₁ + b₂) = f a b₁ + f a b₂)
  (A : matrix l m α) (B₁ B₂ : matrix n p β) :
  kronecker_map f A (B₁ + B₂) = kronecker_map f A B₁ + kronecker_map f A B₂ :=
ext $ λ i j, hf _ _ _

lemma kronecker_map_smul_left [has_smul R α] [has_smul R γ] (f : α → β → γ)
  (r : R) (hf : ∀ a b, f (r • a) b = r • f a b) (A : matrix l m α) (B : matrix n p β) :
  kronecker_map f (r • A) B = r • kronecker_map f A B :=
ext $ λ i j, hf _ _

lemma kronecker_map_smul_right [has_smul R β] [has_smul R γ] (f : α → β → γ)
  (r : R) (hf : ∀ a b, f a (r • b) = r • f a b) (A : matrix l m α) (B : matrix n p β) :
  kronecker_map f A (r • B) = r • kronecker_map f A B :=
ext $ λ i j, hf _ _

lemma kronecker_map_diagonal_diagonal [has_zero α] [has_zero β] [has_zero γ]
  [decidable_eq m] [decidable_eq n]
  (f : α → β → γ) (hf₁ : ∀ b, f 0 b = 0) (hf₂ : ∀ a, f a 0 = 0) (a : m → α) (b : n → β):
  kronecker_map f (diagonal a) (diagonal b) = diagonal (λ mn, f (a mn.1) (b mn.2)) :=
begin
  ext ⟨i₁, i₂⟩ ⟨j₁, j₂⟩,
  simp [diagonal, apply_ite f, ite_and, ite_apply, apply_ite (f (a i₁)), hf₁, hf₂],
end

lemma kronecker_map_diagonal_right [has_zero β] [has_zero γ] [decidable_eq n]
  (f : α → β → γ) (hf : ∀ a, f a 0 = 0) (A : matrix l m α) (b : n → β):
  kronecker_map f A (diagonal b) = block_diagonal (λ i, A.map (λ a, f a (b i))) :=
begin
  ext ⟨i₁, i₂⟩ ⟨j₁, j₂⟩,
  simp [diagonal, block_diagonal, apply_ite (f (A i₁ j₁)), hf],
end

lemma kronecker_map_diagonal_left [has_zero α] [has_zero γ] [decidable_eq l]
  (f : α → β → γ) (hf : ∀ b, f 0 b = 0) (a : l → α) (B : matrix m n β) :
  kronecker_map f (diagonal a) B =
    matrix.reindex (equiv.prod_comm _ _) (equiv.prod_comm _ _)
      (block_diagonal (λ i, B.map (λ b, f (a i) b))) :=
begin
  ext ⟨i₁, i₂⟩ ⟨j₁, j₂⟩,
  simp [diagonal, block_diagonal, apply_ite f, ite_apply, hf],
end

@[simp] lemma kronecker_map_one_one [has_zero α] [has_zero β] [has_zero γ]
  [has_one α] [has_one β] [has_one γ] [decidable_eq m] [decidable_eq n]
  (f : α → β → γ) (hf₁ : ∀ b, f 0 b = 0) (hf₂ : ∀ a, f a 0 = 0) (hf₃ : f 1 1 = 1) :
  kronecker_map f (1 : matrix m m α) (1 : matrix n n β) = 1 :=
(kronecker_map_diagonal_diagonal _ hf₁ hf₂ _ _).trans $ by simp only [hf₃, diagonal_one]

lemma kronecker_map_reindex (f : α → β → γ) (el : l ≃ l') (em : m ≃ m') (en : n ≃ n')
  (ep : p ≃ p') (M : matrix l m α) (N : matrix n p β) :
  kronecker_map f (reindex el em M) (reindex en ep N) =
    reindex (el.prod_congr en) (em.prod_congr ep) (kronecker_map f M N) :=
by { ext ⟨i, i'⟩ ⟨j, j'⟩, refl }

lemma kronecker_map_reindex_left (f : α → β → γ) (el : l ≃ l') (em : m ≃ m') (M : matrix l m α)
  (N : matrix n n' β) : kronecker_map f (matrix.reindex el em M) N =
  reindex (el.prod_congr (equiv.refl _)) (em.prod_congr (equiv.refl _)) (kronecker_map f M N) :=
kronecker_map_reindex _ _ _ (equiv.refl _) (equiv.refl _) _ _

lemma kronecker_map_reindex_right (f : α → β → γ) (em : m ≃ m') (en : n ≃ n') (M : matrix l l' α)
  (N : matrix m n β) : kronecker_map f M (reindex em en N) =
  reindex ((equiv.refl _).prod_congr em) ((equiv.refl _).prod_congr en) (kronecker_map f M N) :=
kronecker_map_reindex _ (equiv.refl _) (equiv.refl _) _ _ _ _

lemma kronecker_map_assoc {δ ξ ω ω' : Type*} (f : α → β → γ) (g : γ → δ → ω) (f' : α → ξ → ω')
  (g' : β → δ → ξ) (A : matrix l m α) (B : matrix n p β) (D : matrix q r δ) (φ : ω ≃ ω')
  (hφ : ∀ a b d, φ (g (f a b) d) = f' a (g' b d)) :
  (reindex (equiv.prod_assoc l n q) (equiv.prod_assoc m p r)).trans (equiv.map_matrix φ)
    (kronecker_map g (kronecker_map f A B) D) = kronecker_map f' A (kronecker_map g' B D) :=
ext $ λ i j, hφ _ _ _

lemma kronecker_map_assoc₁ {δ ξ ω : Type*} (f : α → β → γ) (g : γ → δ → ω) (f' : α → ξ → ω)
  (g' : β → δ → ξ) (A : matrix l m α) (B : matrix n p β) (D : matrix q r δ)
  (h : ∀ a b d, (g (f a b) d) = f' a (g' b d)) :
  reindex (equiv.prod_assoc l n q) (equiv.prod_assoc m p r)
    (kronecker_map g (kronecker_map f A B) D) = kronecker_map f' A (kronecker_map g' B D) :=
ext $ λ i j, h _ _ _

/-- When `f` is bilinear then `matrix.kronecker_map f` is also bilinear. -/
@[simps]
def kronecker_map_bilinear [comm_semiring R]
  [add_comm_monoid α] [add_comm_monoid β] [add_comm_monoid γ]
  [module R α] [module R β] [module R γ]
  (f : α →ₗ[R] β →ₗ[R] γ) :
  matrix l m α →ₗ[R] matrix n p β →ₗ[R] matrix (l × n) (m × p) γ :=
linear_map.mk₂ R
  (kronecker_map (λ r s, f r s))
  (kronecker_map_add_left _ $ f.map_add₂)
  (λ r, kronecker_map_smul_left _ _ $ f.map_smul₂ _)
  (kronecker_map_add_right _ $ λ a, (f a).map_add)
  (λ r, kronecker_map_smul_right _ _ $ λ a, (f a).map_smul r)

/-- `matrix.kronecker_map_bilinear` commutes with `⬝` if `f` commutes with `*`.

This is primarily used with `R = ℕ` to prove `matrix.mul_kronecker_mul`. -/
lemma kronecker_map_bilinear_mul_mul [comm_semiring R]
  [fintype m] [fintype m'] [non_unital_non_assoc_semiring α]
  [non_unital_non_assoc_semiring β] [non_unital_non_assoc_semiring γ]
  [module R α] [module R β] [module R γ]
  (f : α →ₗ[R] β →ₗ[R] γ) (h_comm : ∀ a b a' b', f (a * b) (a' * b') = f a a' * f b b')
  (A : matrix l m α) (B : matrix m n α) (A' : matrix l' m' β) (B' : matrix m' n' β) :
  kronecker_map_bilinear f (A ⬝ B) (A' ⬝ B') =
    (kronecker_map_bilinear f A A') ⬝ (kronecker_map_bilinear f B B') :=
begin
  ext ⟨i, i'⟩ ⟨j, j'⟩,
  simp only [kronecker_map_bilinear_apply_apply, mul_apply, ← finset.univ_product_univ,
    finset.sum_product, kronecker_map_apply],
  simp_rw [f.map_sum, linear_map.sum_apply, linear_map.map_sum, h_comm],
end

/-- `trace` distributes over `matrix.kronecker_map_bilinear`.

This is primarily used with `R = ℕ` to prove `matrix.trace_kronecker`. -/
lemma trace_kronecker_map_bilinear [comm_semiring R]
  [fintype m] [fintype n] [add_comm_monoid α] [add_comm_monoid β] [add_comm_monoid γ]
  [module R α] [module R β] [module R γ]
  (f : α →ₗ[R] β →ₗ[R] γ) (A : matrix m m α) (B : matrix n n β) :
  trace (kronecker_map_bilinear f A B) = f (trace A) (trace B) :=
by simp_rw [matrix.trace, matrix.diag, kronecker_map_bilinear_apply_apply,
  linear_map.map_sum₂, map_sum, ←finset.univ_product_univ, finset.sum_product, kronecker_map_apply]

/-- `determinant` of `matrix.kronecker_map_bilinear`.

This is primarily used with `R = ℕ` to prove `matrix.det_kronecker`. -/
lemma det_kronecker_map_bilinear [comm_semiring R]
  [fintype m] [fintype n] [decidable_eq m] [decidable_eq n] [comm_ring α]
  [comm_ring β] [comm_ring γ]
  [module R α] [module R β] [module R γ]
  (f : α →ₗ[R] β →ₗ[R] γ) (h_comm : ∀ a b a' b', f (a * b) (a' * b') = f a a' * f b b')
  (A : matrix m m α) (B : matrix n n β) :
  det (kronecker_map_bilinear f A B) =
    det (A.map (λ a, f a 1)) ^ fintype.card n * det (B.map (λ b, f 1 b)) ^ fintype.card m :=
calc det (kronecker_map_bilinear f A B)
      = det (kronecker_map_bilinear f A 1 ⬝ kronecker_map_bilinear f 1 B)
    : by rw [←kronecker_map_bilinear_mul_mul f h_comm, matrix.mul_one, matrix.one_mul]
... = det (block_diagonal (λ _, A.map (λ a, f a 1)))
    * det (block_diagonal (λ _, B.map (λ b, f 1 b)))
    : begin
        rw [det_mul, ←diagonal_one, ←diagonal_one,
          kronecker_map_bilinear_apply_apply, kronecker_map_diagonal_right _ (λ _, _),
          kronecker_map_bilinear_apply_apply, kronecker_map_diagonal_left  _ (λ _, _),
          det_reindex_self],
        { exact linear_map.map_zero₂ _ _ },
        { exact map_zero _ },
      end
... = _ : by simp_rw [det_block_diagonal, finset.prod_const, finset.card_univ]

end kronecker_map

/-! ### Specialization to `matrix.kronecker_map (*)` -/

section kronecker

open_locale matrix

/-- The Kronecker product. This is just a shorthand for `kronecker_map (*)`. Prefer the notation
`⊗ₖ` rather than this definition. -/
@[simp] def kronecker [has_mul α] : matrix l m α → matrix n p α → matrix (l × n) (m × p) α :=
kronecker_map (*)

localized "infix (name := matrix.kronecker_map.mul)
  ` ⊗ₖ `:100 := matrix.kronecker_map (*)" in kronecker

@[simp]
lemma kronecker_apply [has_mul α] (A : matrix l m α) (B : matrix n p α) (i₁ i₂ j₁ j₂) :
  (A ⊗ₖ B) (i₁, i₂) (j₁, j₂) = A i₁ j₁ * B i₂ j₂ := rfl

/-- `matrix.kronecker` as a bilinear map. -/
def kronecker_bilinear [comm_semiring R] [semiring α] [algebra R α] :
  matrix l m α →ₗ[R] matrix n p α →ₗ[R] matrix (l × n) (m × p) α :=
kronecker_map_bilinear (algebra.lmul R α)

/-! What follows is a copy, in order, of every `matrix.kronecker_map` lemma above that has
hypotheses which can be filled by properties of `*`. -/

@[simp] lemma zero_kronecker [mul_zero_class α] (B : matrix n p α) : (0 : matrix l m α) ⊗ₖ B = 0 :=
kronecker_map_zero_left _ zero_mul B

@[simp] lemma kronecker_zero [mul_zero_class α] (A : matrix l m α) : A ⊗ₖ (0 : matrix n p α) = 0 :=
kronecker_map_zero_right _ mul_zero A

lemma add_kronecker [distrib α] (A₁ A₂ : matrix l m α) (B : matrix n p α) :
  (A₁ + A₂) ⊗ₖ B = A₁ ⊗ₖ B + A₂ ⊗ₖ B :=
kronecker_map_add_left _ add_mul _ _ _

lemma kronecker_add [distrib α] (A : matrix l m α) (B₁ B₂ : matrix n p α) :
  A ⊗ₖ (B₁ + B₂) = A ⊗ₖ B₁ + A ⊗ₖ B₂ :=
kronecker_map_add_right _ mul_add _ _ _

lemma smul_kronecker [monoid R] [monoid α] [mul_action R α] [is_scalar_tower R α α]
  (r : R) (A : matrix l m α) (B : matrix n p α) :
  (r • A) ⊗ₖ B = r • (A ⊗ₖ B) :=
kronecker_map_smul_left _ _ (λ _ _, smul_mul_assoc _ _ _) _ _

lemma kronecker_smul [monoid R] [monoid α] [mul_action R α] [smul_comm_class R α α]
  (r : R) (A : matrix l m α) (B : matrix n p α) :
  A ⊗ₖ (r • B) = r • (A ⊗ₖ B) :=
kronecker_map_smul_right _ _ (λ _ _, mul_smul_comm _ _ _) _ _

lemma diagonal_kronecker_diagonal [mul_zero_class α]
  [decidable_eq m] [decidable_eq n]
  (a : m → α) (b : n → α):
  (diagonal a) ⊗ₖ (diagonal b) = diagonal (λ mn, (a mn.1) * (b mn.2)) :=
kronecker_map_diagonal_diagonal _ zero_mul mul_zero _ _

lemma kronecker_diagonal [mul_zero_class α] [decidable_eq n] (A : matrix l m α) (b : n → α):
  A ⊗ₖ diagonal b = block_diagonal (λ i, mul_opposite.op (b i) • A) :=
kronecker_map_diagonal_right _ mul_zero _ _

lemma diagonal_kronecker [mul_zero_class α] [decidable_eq l](a : l → α) (B : matrix m n α) :
  diagonal a ⊗ₖ B =
    matrix.reindex (equiv.prod_comm _ _) (equiv.prod_comm _ _) (block_diagonal (λ i, a i • B)) :=
kronecker_map_diagonal_left _ zero_mul _ _

@[simp] lemma one_kronecker_one [mul_zero_one_class α] [decidable_eq m] [decidable_eq n] :
  (1 : matrix m m α) ⊗ₖ (1 : matrix n n α) = 1 :=
kronecker_map_one_one _ zero_mul mul_zero (one_mul _)

lemma kronecker_one [mul_zero_one_class α] [decidable_eq n] (A : matrix l m α) :
  A ⊗ₖ (1 : matrix n n α) = block_diagonal (λ i, A) :=
(kronecker_diagonal _ _).trans $ congr_arg _ $ funext $ λ _, matrix.ext $ λ _ _, mul_one _

lemma one_kronecker [mul_zero_one_class α] [decidable_eq l] (B : matrix m n α) :
  (1 : matrix l l α) ⊗ₖ B =
    matrix.reindex (equiv.prod_comm _ _) (equiv.prod_comm _ _) (block_diagonal (λ i, B)) :=
(diagonal_kronecker _ _).trans $
  congr_arg _ $ congr_arg _ $ funext $ λ _, matrix.ext $ λ _ _, one_mul _

lemma mul_kronecker_mul [fintype m] [fintype m'] [comm_semiring α]
  (A : matrix l m α) (B : matrix m n α) (A' : matrix l' m' α) (B' : matrix m' n' α) :
  (A ⬝ B) ⊗ₖ (A' ⬝ B') = (A ⊗ₖ A') ⬝ (B ⊗ₖ B') :=
kronecker_map_bilinear_mul_mul (algebra.lmul ℕ α).to_linear_map mul_mul_mul_comm A B A' B'

@[simp] lemma kronecker_assoc [semigroup α] (A : matrix l m α) (B : matrix n p α)
  (C : matrix q r α) : reindex (equiv.prod_assoc l n q) (equiv.prod_assoc m p r) ((A ⊗ₖ B) ⊗ₖ C) =
  A ⊗ₖ (B ⊗ₖ C) :=
kronecker_map_assoc₁ _ _ _ _ A B C mul_assoc

lemma trace_kronecker [fintype m] [fintype n] [semiring α]
  (A : matrix m m α) (B : matrix n n α) :
  trace (A ⊗ₖ B) = trace A * trace B :=
trace_kronecker_map_bilinear (algebra.lmul ℕ α).to_linear_map _ _

lemma det_kronecker [fintype m] [fintype n] [decidable_eq m] [decidable_eq n] [comm_ring R]
  (A : matrix m m R) (B : matrix n n R) :
  det (A ⊗ₖ B) = det A ^ fintype.card n * det B ^ fintype.card m :=
begin
  refine
    (det_kronecker_map_bilinear (algebra.lmul ℕ R).to_linear_map mul_mul_mul_comm _ _).trans _,
  congr' 3,
  { ext i j, exact mul_one _},
  { ext i j, exact one_mul _},
end

lemma inv_kronecker [fintype m] [fintype n] [decidable_eq m] [decidable_eq n] [comm_ring R]
  (A : matrix m m R) (B : matrix n n R) :
  (A ⊗ₖ B)⁻¹ = A⁻¹ ⊗ₖ B⁻¹ :=
begin
  -- handle the special cases where either matrix is not invertible
  by_cases hA : is_unit A.det, swap,
  { casesI is_empty_or_nonempty n,
    { exact subsingleton.elim _ _ },
    have hAB : ¬is_unit (A ⊗ₖ B).det,
    { refine mt (λ hAB, _) hA,
      rw det_kronecker at hAB,
      exact (is_unit_pow_iff fintype.card_ne_zero).mp (is_unit_of_mul_is_unit_left hAB) },
    rw [nonsing_inv_apply_not_is_unit _ hA, zero_kronecker, nonsing_inv_apply_not_is_unit _ hAB] },
  by_cases hB : is_unit B.det, swap,
  { casesI is_empty_or_nonempty m,
    { exact subsingleton.elim _ _ },
    have hAB : ¬is_unit (A ⊗ₖ B).det,
    { refine mt (λ hAB, _) hB,
      rw det_kronecker at hAB,
      exact (is_unit_pow_iff fintype.card_ne_zero).mp (is_unit_of_mul_is_unit_right hAB) },
    rw [nonsing_inv_apply_not_is_unit _ hB, kronecker_zero,
      nonsing_inv_apply_not_is_unit _ hAB] },
  -- otherwise follows trivially from `mul_kronecker_mul`
  { apply inv_eq_right_inv,
    rw [←mul_kronecker_mul, ←one_kronecker_one, mul_nonsing_inv _ hA, mul_nonsing_inv _ hB] },
end

end kronecker

/-! ### Specialization to `matrix.kronecker_map (⊗ₜ)` -/

section kronecker_tmul

variables (R)
open tensor_product
open_locale matrix tensor_product

section module

variables [comm_semiring R] [add_comm_monoid α] [add_comm_monoid β] [add_comm_monoid γ]
variables [module R α] [module R β] [module R γ]

/-- The Kronecker tensor product. This is just a shorthand for `kronecker_map (⊗ₜ)`.
Prefer the notation `⊗ₖₜ` rather than this definition. -/
@[simp] def kronecker_tmul :
  matrix l m α → matrix n p β → matrix (l × n) (m × p) (α ⊗[R] β) :=
kronecker_map (⊗ₜ)

localized "infix (name := matrix.kronecker_map.tmul)
  ` ⊗ₖₜ `:100 := matrix.kronecker_map (⊗ₜ)" in kronecker
localized "notation (name := matrix.kronecker_map.tmul')
  x ` ⊗ₖₜ[`:100 R `] `:0 y:100 := matrix.kronecker_map (tensor_product.tmul R) x y" in kronecker

@[simp]
lemma kronecker_tmul_apply (A : matrix l m α) (B : matrix n p β) (i₁ i₂ j₁ j₂) :
  (A ⊗ₖₜ B) (i₁, i₂) (j₁, j₂) = A i₁ j₁ ⊗ₜ[R] B i₂ j₂ := rfl

/-- `matrix.kronecker` as a bilinear map. -/
def kronecker_tmul_bilinear :
  matrix l m α →ₗ[R] matrix n p β →ₗ[R] matrix (l × n) (m × p) (α ⊗[R] β) :=
kronecker_map_bilinear (tensor_product.mk R α β)

/-! What follows is a copy, in order, of every `matrix.kronecker_map` lemma above that has
hypotheses which can be filled by properties of `⊗ₜ`. -/

@[simp] lemma zero_kronecker_tmul (B : matrix n p β) : (0 : matrix l m α) ⊗ₖₜ[R] B = 0 :=
kronecker_map_zero_left _ (zero_tmul α) B

@[simp] lemma kronecker_tmul_zero (A : matrix l m α) : A ⊗ₖₜ[R] (0 : matrix n p β) = 0 :=
kronecker_map_zero_right _ (tmul_zero β) A

lemma add_kronecker_tmul (A₁ A₂ : matrix l m α) (B : matrix n p α) :
  (A₁ + A₂) ⊗ₖₜ[R] B = A₁ ⊗ₖₜ B + A₂ ⊗ₖₜ B :=
kronecker_map_add_left _ add_tmul _ _ _

lemma kronecker_tmul_add (A : matrix l m α) (B₁ B₂ : matrix n p α) :
  A ⊗ₖₜ[R] (B₁ + B₂) = A ⊗ₖₜ B₁ + A ⊗ₖₜ B₂ :=
kronecker_map_add_right _ tmul_add _ _ _

lemma smul_kronecker_tmul
  (r : R) (A : matrix l m α) (B : matrix n p α) :
  (r • A) ⊗ₖₜ[R] B = r • (A ⊗ₖₜ B) :=
kronecker_map_smul_left _ _ (λ _ _, smul_tmul' _ _ _) _ _

lemma kronecker_tmul_smul
  (r : R) (A : matrix l m α) (B : matrix n p α) :
  A ⊗ₖₜ[R] (r • B) = r • (A ⊗ₖₜ B) :=
kronecker_map_smul_right _ _ (λ _ _, tmul_smul _ _ _) _ _

lemma diagonal_kronecker_tmul_diagonal
  [decidable_eq m] [decidable_eq n]
  (a : m → α) (b : n → α):
  (diagonal a) ⊗ₖₜ[R] (diagonal b) = diagonal (λ mn, a mn.1 ⊗ₜ b mn.2) :=
kronecker_map_diagonal_diagonal _ (zero_tmul _) (tmul_zero _) _ _

lemma kronecker_tmul_diagonal [decidable_eq n] (A : matrix l m α) (b : n → α):
  A ⊗ₖₜ[R] (diagonal b) = block_diagonal (λ i, A.map (λ a, a ⊗ₜ[R] b i)) :=
kronecker_map_diagonal_right _ (tmul_zero _) _ _

lemma diagonal_kronecker_tmul [decidable_eq l](a : l → α) (B : matrix m n α) :
  diagonal a ⊗ₖₜ[R] B =
    matrix.reindex (equiv.prod_comm _ _) (equiv.prod_comm _ _)
      (block_diagonal (λ i, B.map (λ b, a i ⊗ₜ[R] b))) :=
kronecker_map_diagonal_left _ (zero_tmul _) _ _

@[simp] lemma kronecker_tmul_assoc (A : matrix l m α) (B : matrix n p β) (C : matrix q r γ) :
  reindex (equiv.prod_assoc l n q) (equiv.prod_assoc m p r)
    (((A ⊗ₖₜ[R] B) ⊗ₖₜ[R] C).map (tensor_product.assoc _ _ _ _)) = A ⊗ₖₜ[R] (B ⊗ₖₜ[R] C) :=
ext $ λ i j, assoc_tmul _ _ _

end module

section algebra
open_locale kronecker
open algebra.tensor_product

section semiring
variables [comm_semiring R] [semiring α] [semiring β] [algebra R α] [algebra R β]

@[simp] lemma one_kronecker_tmul_one [decidable_eq m] [decidable_eq n] :
  (1 : matrix m m α) ⊗ₖₜ[R] (1 : matrix n n α) = 1 :=
kronecker_map_one_one _ (zero_tmul _) (tmul_zero _) rfl

lemma mul_kronecker_tmul_mul [fintype m] [fintype m']
  (A : matrix l m α) (B : matrix m n α) (A' : matrix l' m' β) (B' : matrix m' n' β) :
  (A ⬝ B) ⊗ₖₜ[R] (A' ⬝ B') = (A ⊗ₖₜ A') ⬝ (B ⊗ₖₜ B') :=
kronecker_map_bilinear_mul_mul (tensor_product.mk R α β) tmul_mul_tmul A B A' B'

end semiring

section comm_ring
variables [comm_ring R] [comm_ring α] [comm_ring β] [algebra R α] [algebra R β]

lemma det_kronecker_tmul [fintype m] [fintype n] [decidable_eq m] [decidable_eq n]
  (A : matrix m m α) (B : matrix n n β) :
  det (A ⊗ₖₜ[R] B) = (det A ^ fintype.card n) ⊗ₜ[R] (det B ^ fintype.card m) :=
begin
  refine
    (det_kronecker_map_bilinear (tensor_product.mk R α β) tmul_mul_tmul _ _).trans _,
  simp only [mk_apply, ←include_left_apply, ←include_right_apply] {eta := ff},
  simp only [←alg_hom.map_matrix_apply, ←alg_hom.map_det],
  simp only [include_left_apply, include_right_apply, tmul_pow, tmul_mul_tmul,
    one_pow, _root_.mul_one, _root_.one_mul],
end

end comm_ring

end algebra

-- insert lemmas specific to `kronecker_tmul` below this line

end kronecker_tmul

end matrix