/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import data.set.basic
import tactic.monotonicity.basic

/-!
# Typeclass for types with a set-like extensionality property

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

The `has_mem` typeclass is used to let terms of a type have elements.
Many instances of `has_mem` have a set-like extensionality property:
things are equal iff they have the same elements.  The `set_like`
typeclass provides a unified interface to define a `has_mem` that is
extensional in this way.

The main use of `set_like` is for algebraic subobjects (such as
`submonoid` and `submodule`), whose non-proof data consists only of a
carrier set.  In such a situation, the projection to the carrier set
is injective.

In general, a type `A` is `set_like` with elements of type `B` if it
has an injective map to `set B`.  This module provides standard
boilerplate for every `set_like`: a `coe_sort`, a `coe` to set, a
`partial_order`, and various extensionality and simp lemmas.

A typical subobject should be declared as:
```
structure my_subobject (X : Type*) [object_typeclass X] :=
(carrier : set X)
(op_mem' : ∀ {x : X}, x ∈ carrier → sorry ∈ carrier)

namespace my_subobject

variables {X : Type*} [object_typeclass X] {x : X}

instance : set_like (my_subobject X) X :=
⟨my_subobject.carrier, λ p q h, by cases p; cases q; congr'⟩

@[simp] lemma mem_carrier {p : my_subobject X} : x ∈ p.carrier ↔ x ∈ (p : set X) := iff.rfl

@[ext] theorem ext {p q : my_subobject X} (h : ∀ x, x ∈ p ↔ x ∈ q) : p = q := set_like.ext h

/-- Copy of a `my_subobject` with a new `carrier` equal to the old one. Useful to fix definitional
equalities. See Note [range copy pattern]. -/
protected def copy (p : my_subobject X) (s : set X) (hs : s = ↑p) : my_subobject X :=
{ carrier := s,
  op_mem' := hs.symm ▸ p.op_mem' }

@[simp] lemma coe_copy (p : my_subobject X) (s : set X) (hs : s = ↑p) :
  (p.copy s hs : set X) = s := rfl

lemma copy_eq (p : my_subobject X) (s : set X) (hs : s = ↑p) : p.copy s hs = p :=
set_like.coe_injective hs

end my_subobject
```

An alternative to `set_like` could have been an extensional `has_mem` typeclass:
```
class has_ext_mem (α : out_param $ Type u) (β : Type v) extends has_mem α β :=
(ext_iff : ∀ {s t : β}, s = t ↔ ∀ (x : α), x ∈ s ↔ x ∈ t)
```
While this is equivalent, `set_like` conveniently uses a carrier set projection directly.

## Tags

subobjects
-/

/-- A class to indicate that there is a canonical injection between `A` and `set B`.

This has the effect of giving terms of `A` elements of type `B` (through a `has_mem`
instance) and a compatible coercion to `Type*` as a subtype.

Note: if `set_like.coe` is a projection, implementers should create a simp lemma such as
```
@[simp] lemma mem_carrier {p : my_subobject X} : x ∈ p.carrier ↔ x ∈ (p : set X) := iff.rfl
```
to normalize terms.

If you declare an unbundled subclass of `set_like`, for example:
```
class mul_mem_class (S : Type*) (M : Type*) [has_mul M] [set_like S M] where
  ...
```
Then you should *not* repeat the `out_param` declaration, `set_like` will supply the value instead.
This ensures in Lean 4 your subclass will not have issues with synthesis of the `[has_mul M]`
parameter starting before the value of `M` is known.
-/
@[protect_proj]
class set_like (A : Type*) (B : out_param $ Type*) :=
(coe : A → set B)
(coe_injective' : function.injective coe)

namespace set_like

variables {A : Type*} {B : Type*} [i : set_like A B]

include i

instance : has_coe_t A (set B) := ⟨set_like.coe⟩

@[priority 100]
instance : has_mem B A := ⟨λ x p, x ∈ (p : set B)⟩

-- `dangerous_instance` does not know that `B` is used only as an `out_param`
@[nolint dangerous_instance, priority 100]
instance : has_coe_to_sort A Type* := ⟨λ p, {x : B // x ∈ p}⟩

variables (p q : A)

@[simp, norm_cast] theorem coe_sort_coe : ((p : set B) : Type*) = p := rfl

variables {p q}

protected theorem «exists» {q : p → Prop} :
  (∃ x, q x) ↔ (∃ x ∈ p, q ⟨x, ‹_›⟩) := set_coe.exists

protected theorem «forall» {q : p → Prop} :
  (∀ x, q x) ↔ (∀ x ∈ p, q ⟨x, ‹_›⟩) := set_coe.forall

theorem coe_injective : function.injective (coe : A → set B) :=
λ x y h, set_like.coe_injective' h

@[simp, norm_cast]

theorem ext' (h : (p : set B) = q) : p = q := coe_injective h

theorem ext'_iff : p = q ↔ (p : set B) = q := coe_set_eq.symm

/-- Note: implementers of `set_like` must copy this lemma in order to tag it with `@[ext]`. -/
theorem ext (h : ∀ x, x ∈ p ↔ x ∈ q) : p = q := coe_injective $ set.ext h

theorem ext_iff : p = q ↔ (∀ x, x ∈ p ↔ x ∈ q) := coe_injective.eq_iff.symm.trans set.ext_iff

@[simp] theorem mem_coe {x : B} : x ∈ (p : set B) ↔ x ∈ p := iff.rfl

@[simp, norm_cast] lemma coe_eq_coe {x y : p} : (x : B) = y ↔ x = y := subtype.ext_iff_val.symm

@[simp, norm_cast] lemma coe_mk (x : B) (hx : x ∈ p) : ((⟨x, hx⟩ : p) : B) = x := rfl
@[simp] lemma coe_mem (x : p) : (x : B) ∈ p := x.2

@[simp] protected lemma eta (x : p) (hx : (x : B) ∈ p) : (⟨x, hx⟩ : p) = x := subtype.eta x hx

-- `dangerous_instance` does not know that `B` is used only as an `out_param`
@[nolint dangerous_instance, priority 100]
instance : partial_order A :=
{ le := λ H K, ∀ ⦃x⦄, x ∈ H → x ∈ K,
  .. partial_order.lift (coe : A → set B) coe_injective }

lemma le_def {S T : A} : S ≤ T ↔ ∀ ⦃x : B⦄, x ∈ S → x ∈ T := iff.rfl

@[simp, norm_cast]
lemma coe_subset_coe {S T : A} : (S : set B) ⊆ T ↔ S ≤ T := iff.rfl

@[mono] lemma coe_mono : monotone (coe : A → set B) := λ a b, coe_subset_coe.mpr

@[simp, norm_cast]
lemma coe_ssubset_coe {S T : A} : (S : set B) ⊂ T ↔ S < T := iff.rfl

@[mono] lemma coe_strict_mono : strict_mono (coe : A → set B) := λ a b, coe_ssubset_coe.mpr

lemma not_le_iff_exists : ¬(p ≤ q) ↔ ∃ x ∈ p, x ∉ q := set.not_subset

lemma exists_of_lt : p < q → ∃ x ∈ q, x ∉ p := set.exists_of_ssubset

lemma lt_iff_le_and_exists : p < q ↔ p ≤ q ∧ ∃ x ∈ q, x ∉ p :=
by rw [lt_iff_le_not_le, not_le_iff_exists]

end set_like


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import tactic.lint
import tactic.ext

/-!
# Sigma types

This file proves basic results about sigma types.

A sigma type is a dependent pair type. Like `α × β` but where the type of the second component
depends on the first component. This can be seen as a generalization of the sum type `α ⊕ β`:
* `α ⊕ β` is made of stuff which is either of type `α` or `β`.
* Given `α : ι → Type*`, `sigma α` is made of stuff which is of type `α i` for some `i : ι`. One
  effectively recovers a type isomorphic to `α ⊕ β` by taking a `ι` with exactly two elements. See
  `equiv.sum_equiv_sigma_bool`.

`Σ x, A x` is notation for `sigma A` (note the difference with the big operator `∑`).
`Σ x y z ..., A x y z ...` is notation for `Σ x, Σ y, Σ z, ..., A x y z ...`. Here we have
`α : Type*`, `β : α → Type*`, `γ : Π a : α, β a → Type*`, ...,
`A : Π (a : α) (b : β a) (c : γ a b) ..., Type*`  with `x : α` `y : β x`, `z : γ x y`, ...

## Notes

The definition of `sigma` takes values in `Type*`. This effectively forbids `Prop`- valued sigma
types. To that effect, we have `psigma`, which takes value in `Sort*` and carries a more complicated
universe signature in consequence.
-/

section sigma
variables {α α₁ α₂ : Type*} {β : α → Type*} {β₁ : α₁ → Type*} {β₂ : α₂ → Type*}

namespace sigma

instance [inhabited α] [inhabited (β default)] : inhabited (sigma β) :=
⟨⟨default, default⟩⟩

instance [h₁ : decidable_eq α] [h₂ : ∀a, decidable_eq (β a)] : decidable_eq (sigma β)
| ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ := match a₁, b₁, a₂, b₂, h₁ a₁ a₂ with
  | _, b₁, _, b₂, is_true (eq.refl a) :=
    match b₁, b₂, h₂ a b₁ b₂ with
    | _, _, is_true (eq.refl b) := is_true rfl
    | b₁, b₂, is_false n := is_false (assume h, sigma.no_confusion h (λe₁ e₂, n $ eq_of_heq e₂))
    end
  | a₁, _, a₂, _, is_false n := is_false (assume h, sigma.no_confusion h (λe₁ e₂, n e₁))
  end

@[simp, nolint simp_nf] -- sometimes the built-in injectivity support does not work
theorem mk.inj_iff {a₁ a₂ : α} {b₁ : β a₁} {b₂ : β a₂} :
  sigma.mk a₁ b₁ = ⟨a₂, b₂⟩ ↔ (a₁ = a₂ ∧ b₁ == b₂) :=
by simp

@[simp] theorem eta : ∀ x : Σ a, β a, sigma.mk x.1 x.2 = x
| ⟨i, x⟩ := rfl

@[ext]
lemma ext {x₀ x₁ : sigma β} (h₀ : x₀.1 = x₁.1) (h₁ : x₀.2 == x₁.2) : x₀ = x₁ :=
by { cases x₀, cases x₁, cases h₀, cases h₁, refl }

lemma ext_iff {x₀ x₁ : sigma β} : x₀ = x₁ ↔ x₀.1 = x₁.1 ∧ x₀.2 == x₁.2 :=
by { cases x₀, cases x₁, exact sigma.mk.inj_iff }

/-- A specialized ext lemma for equality of sigma types over an indexed subtype. -/
@[ext]
lemma subtype_ext {β : Type*} {p : α → β → Prop} :
  ∀ {x₀ x₁ : Σ a, subtype (p a)}, x₀.fst = x₁.fst → (x₀.snd : β) = x₁.snd → x₀ = x₁
| ⟨a₀, b₀, hb₀⟩ ⟨a₁, b₁, hb₁⟩ rfl rfl := rfl

lemma subtype_ext_iff {β : Type*} {p : α → β → Prop} {x₀ x₁ : Σ a, subtype (p a)} :
  x₀ = x₁ ↔ x₀.fst = x₁.fst ∧ (x₀.snd : β) = x₁.snd :=
⟨λ h, h ▸ ⟨rfl, rfl⟩, λ ⟨h₁, h₂⟩, subtype_ext h₁ h₂⟩

@[simp] theorem «forall» {p : (Σ a, β a) → Prop} :
  (∀ x, p x) ↔ (∀ a b, p ⟨a, b⟩) :=
⟨assume h a b, h ⟨a, b⟩, assume h ⟨a, b⟩, h a b⟩

@[simp] theorem «exists» {p : (Σ a, β a) → Prop} :
  (∃ x, p x) ↔ (∃ a b, p ⟨a, b⟩) :=
⟨assume ⟨⟨a, b⟩, h⟩, ⟨a, b, h⟩, assume ⟨a, b, h⟩, ⟨⟨a, b⟩, h⟩⟩

/-- Map the left and right components of a sigma -/
def map (f₁ : α₁ → α₂) (f₂ : Πa, β₁ a → β₂ (f₁ a)) (x : sigma β₁) : sigma β₂ :=
⟨f₁ x.1, f₂ x.1 x.2⟩

end sigma

lemma sigma_mk_injective {i : α} : function.injective (@sigma.mk α β i)
| _ _ rfl := rfl

lemma function.injective.sigma_map {f₁ : α₁ → α₂} {f₂ : Πa, β₁ a → β₂ (f₁ a)}
  (h₁ : function.injective f₁) (h₂ : ∀ a, function.injective (f₂ a)) :
  function.injective (sigma.map f₁ f₂)
| ⟨i, x⟩ ⟨j, y⟩ h :=
begin
  have : i = j, from h₁ (sigma.mk.inj_iff.mp h).1,
  subst j,
  have : x = y, from h₂ i (eq_of_heq (sigma.mk.inj_iff.mp h).2),
  subst y
end

lemma function.surjective.sigma_map {f₁ : α₁ → α₂} {f₂ : Πa, β₁ a → β₂ (f₁ a)}
  (h₁ : function.surjective f₁) (h₂ : ∀ a, function.surjective (f₂ a)) :
  function.surjective (sigma.map f₁ f₂) :=
begin
  intros y,
  cases y with j y,
  cases h₁ j with i hi,
  subst j,
  cases h₂ i y with x hx,
  subst y,
  exact ⟨⟨i, x⟩, rfl⟩
end

/-- Interpret a function on `Σ x : α, β x` as a dependent function with two arguments.

This also exists as an `equiv` as `equiv.Pi_curry γ`. -/
def sigma.curry {γ : Π a, β a → Type*} (f : Π x : sigma β, γ x.1 x.2) (x : α) (y : β x) : γ x y :=
f ⟨x,y⟩

/-- Interpret a dependent function with two arguments as a function on `Σ x : α, β x`.

This also exists as an `equiv` as `(equiv.Pi_curry γ).symm`. -/
def sigma.uncurry {γ : Π a, β a → Type*} (f : Π x (y : β x), γ x y) (x : sigma β) : γ x.1 x.2 :=
f x.1 x.2

@[simp]
lemma sigma.uncurry_curry {γ : Π a, β a → Type*} (f : Π x : sigma β, γ x.1 x.2) :
  sigma.uncurry (sigma.curry f) = f :=
funext $ λ ⟨i, j⟩, rfl

@[simp]
lemma sigma.curry_uncurry {γ : Π a, β a → Type*} (f : Π x (y : β x), γ x y) :
  sigma.curry (sigma.uncurry f) = f :=
rfl

/-- Convert a product type to a Σ-type. -/
@[simp]
def prod.to_sigma {α β} : α × β → Σ _ : α, β
| ⟨x,y⟩ := ⟨x,y⟩

@[simp]
lemma prod.fst_to_sigma {α β} (x : α × β) : (prod.to_sigma x).fst = x.fst :=
by cases x; refl

@[simp]
lemma prod.snd_to_sigma {α β} (x : α × β) : (prod.to_sigma x).snd = x.snd :=
by cases x; refl

end sigma

section psigma
variables {α : Sort*} {β : α → Sort*}

namespace psigma

/-- Nondependent eliminator for `psigma`. -/
def elim {γ} (f : ∀ a, β a → γ) (a : psigma β) : γ :=
psigma.cases_on a f

@[simp] theorem elim_val {γ} (f : ∀ a, β a → γ) (a b) : psigma.elim f ⟨a, b⟩ = f a b := rfl

instance [inhabited α] [inhabited (β default)] : inhabited (psigma β) :=
⟨⟨default, default⟩⟩

instance [h₁ : decidable_eq α] [h₂ : ∀a, decidable_eq (β a)] : decidable_eq (psigma β)
| ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ := match a₁, b₁, a₂, b₂, h₁ a₁ a₂ with
  | _, b₁, _, b₂, is_true (eq.refl a) :=
    match b₁, b₂, h₂ a b₁ b₂ with
    | _, _, is_true (eq.refl b) := is_true rfl
    | b₁, b₂, is_false n := is_false (assume h, psigma.no_confusion h (λe₁ e₂, n $ eq_of_heq e₂))
    end
  | a₁, _, a₂, _, is_false n := is_false (assume h, psigma.no_confusion h (λe₁ e₂, n e₁))
  end

theorem mk.inj_iff {a₁ a₂ : α} {b₁ : β a₁} {b₂ : β a₂} :
  @psigma.mk α β a₁ b₁ = @psigma.mk α β a₂ b₂ ↔ (a₁ = a₂ ∧ b₁ == b₂) :=
iff.intro psigma.mk.inj $
  assume ⟨h₁, h₂⟩, match a₁, a₂, b₁, b₂, h₁, h₂ with _, _, _, _, eq.refl a, heq.refl b := rfl end

@[ext]
lemma ext {x₀ x₁ : psigma β} (h₀ : x₀.1 = x₁.1) (h₁ : x₀.2 == x₁.2) : x₀ = x₁ :=
by { cases x₀, cases x₁, cases h₀, cases h₁, refl }

lemma ext_iff {x₀ x₁ : psigma β} : x₀ = x₁ ↔ x₀.1 = x₁.1 ∧ x₀.2 == x₁.2 :=
by { cases x₀, cases x₁, exact psigma.mk.inj_iff }

/-- A specialized ext lemma for equality of psigma types over an indexed subtype. -/
@[ext]
lemma subtype_ext {β : Sort*} {p : α → β → Prop} :
  ∀ {x₀ x₁ : Σ' a, subtype (p a)}, x₀.fst = x₁.fst → (x₀.snd : β) = x₁.snd → x₀ = x₁
| ⟨a₀, b₀, hb₀⟩ ⟨a₁, b₁, hb₁⟩ rfl rfl := rfl

lemma subtype_ext_iff {β : Sort*} {p : α → β → Prop} {x₀ x₁ : Σ' a, subtype (p a)} :
  x₀ = x₁ ↔ x₀.fst = x₁.fst ∧ (x₀.snd : β) = x₁.snd :=
⟨λ h, h ▸ ⟨rfl, rfl⟩, λ ⟨h₁, h₂⟩, subtype_ext h₁ h₂⟩

variables {α₁ : Sort*} {α₂ : Sort*} {β₁ : α₁ → Sort*} {β₂ : α₂ → Sort*}

/-- Map the left and right components of a sigma -/
def map (f₁ : α₁ → α₂) (f₂ : Πa, β₁ a → β₂ (f₁ a)) : psigma β₁ → psigma β₂
| ⟨a, b⟩ := ⟨f₁ a, f₂ a b⟩

end psigma

end psigma


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import logic.small.basic
import category_theory.category.ulift
import category_theory.skeletal

/-!
# Essentially small categories.

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

A category given by `(C : Type u) [category.{v} C]` is `w`-essentially small
if there exists a `small_model C : Type w` equipped with `[small_category (small_model C)]`.

A category is `w`-locally small if every hom type is `w`-small.

The main theorem here is that a category is `w`-essentially small iff
the type `skeleton C` is `w`-small, and `C` is `w`-locally small.
-/

universes w v v' u u'

open category_theory

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

namespace category_theory

/-- A category is `essentially_small.{w}` if there exists
an equivalence to some `S : Type w` with `[small_category S]`. -/
class essentially_small (C : Type u) [category.{v} C] : Prop :=
(equiv_small_category : ∃ (S : Type w) (_ : small_category S), by exactI nonempty (C ≌ S))

/-- Constructor for `essentially_small C` from an explicit small category witness. -/

/--
An arbitrarily chosen small model for an essentially small category.
-/
@[nolint has_nonempty_instance]
def small_model (C : Type u) [category.{v} C] [essentially_small.{w} C] : Type w :=
classical.some (@essentially_small.equiv_small_category C _ _)

noncomputable
instance small_category_small_model
  (C : Type u) [category.{v} C] [essentially_small.{w} C] : small_category (small_model C) :=
classical.some (classical.some_spec (@essentially_small.equiv_small_category C _ _))

/--
The (noncomputable) categorical equivalence between
an essentially small category and its small model.
-/
noncomputable
def equiv_small_model (C : Type u) [category.{v} C] [essentially_small.{w} C] : C ≌ small_model C :=
nonempty.some (classical.some_spec (classical.some_spec
  (@essentially_small.equiv_small_category C _ _)))

lemma essentially_small_congr {C : Type u} [category.{v} C] {D : Type u'} [category.{v'} D]
  (e : C ≌ D) : essentially_small.{w} C ↔ essentially_small.{w} D :=
begin
  fsplit,
  { rintro ⟨S, 𝒮, ⟨f⟩⟩,
    resetI,
    exact essentially_small.mk' (e.symm.trans f), },
  { rintro ⟨S, 𝒮, ⟨f⟩⟩,
    resetI,
    exact essentially_small.mk' (e.trans f), },
end

lemma discrete.essentially_small_of_small {α : Type u} [small.{w} α] :
  essentially_small.{w} (discrete α) :=
⟨⟨discrete (shrink α), ⟨infer_instance, ⟨discrete.equivalence (equiv_shrink _)⟩⟩⟩⟩

lemma essentially_small_self : essentially_small.{max w v u} C :=
essentially_small.mk' (as_small.equiv : C ≌ as_small.{w} C)

/--
A category is `w`-locally small if every hom set is `w`-small.

See `shrink_homs C` for a category instance where every hom set has been replaced by a small model.
-/
class locally_small (C : Type u) [category.{v} C] : Prop :=
(hom_small : ∀ X Y : C, small.{w} (X ⟶ Y) . tactic.apply_instance)

instance (C : Type u) [category.{v} C] [locally_small.{w} C] (X Y : C) :
  small (X ⟶ Y) :=
locally_small.hom_small X Y

lemma locally_small_congr {C : Type u} [category.{v} C] {D : Type u'} [category.{v'} D]
  (e : C ≌ D) : locally_small.{w} C ↔ locally_small.{w} D :=
begin
  fsplit,
  { rintro ⟨L⟩,
    fsplit,
    intros X Y,
    specialize L (e.inverse.obj X) (e.inverse.obj Y),
    refine (small_congr _).mpr L,
    exact equiv_of_fully_faithful e.inverse, },
  { rintro ⟨L⟩,
    fsplit,
    intros X Y,
    specialize L (e.functor.obj X) (e.functor.obj Y),
    refine (small_congr _).mpr L,
    exact equiv_of_fully_faithful e.functor, },
end

@[priority 100]
instance locally_small_self (C : Type u) [category.{v} C] : locally_small.{v} C := {}

@[priority 100]
instance locally_small_of_essentially_small
  (C : Type u) [category.{v} C] [essentially_small.{w} C] : locally_small.{w} C :=
(locally_small_congr (equiv_small_model C)).mpr (category_theory.locally_small_self _)

/--
We define a type alias `shrink_homs C` for `C`. When we have `locally_small.{w} C`,
we'll put a `category.{w}` instance on `shrink_homs C`.
-/
@[nolint has_nonempty_instance]
def shrink_homs (C : Type u) := C

namespace shrink_homs

section
variables {C' : Type*} -- a fresh variable with no category instance attached

/-- Help the typechecker by explicitly translating from `C` to `shrink_homs C`. -/
def to_shrink_homs {C' : Type*} (X : C') : shrink_homs C' := X
/-- Help the typechecker by explicitly translating from `shrink_homs C` to `C`. -/
def from_shrink_homs {C' : Type*} (X : shrink_homs C') : C' := X

@[simp] lemma to_from (X : C') : from_shrink_homs (to_shrink_homs X) = X := rfl
@[simp] lemma from_to (X : shrink_homs C') : to_shrink_homs (from_shrink_homs X) = X := rfl

end

variables (C) [locally_small.{w} C]

@[simps]
noncomputable
instance : category.{w} (shrink_homs C) :=
{ hom := λ X Y, shrink (from_shrink_homs X ⟶ from_shrink_homs Y),
  id := λ X, equiv_shrink _ (𝟙 (from_shrink_homs X)),
  comp := λ X Y Z f g,
    equiv_shrink _ (((equiv_shrink _).symm f) ≫ ((equiv_shrink _).symm g)), }.

/-- Implementation of `shrink_homs.equivalence`. -/
@[simps]
noncomputable
def functor : C ⥤ shrink_homs C :=
{ obj := λ X, to_shrink_homs X,
  map := λ X Y f, equiv_shrink (X ⟶ Y) f, }

/-- Implementation of `shrink_homs.equivalence`. -/
@[simps]
noncomputable
def inverse : shrink_homs C ⥤ C :=
{ obj := λ X, from_shrink_homs X,
  map := λ X Y f, (equiv_shrink (from_shrink_homs X ⟶ from_shrink_homs Y)).symm f, }

/--
The categorical equivalence between `C` and `shrink_homs C`, when `C` is locally small.
-/
@[simps]
noncomputable
def equivalence : C ≌ shrink_homs C :=
equivalence.mk (functor C) (inverse C)
  (nat_iso.of_components (λ X, iso.refl X) (by tidy))
  (nat_iso.of_components (λ X, iso.refl X) (by tidy))

end shrink_homs

/--
A category is essentially small if and only if
the underlying type of its skeleton (i.e. the "set" of isomorphism classes) is small,
and it is locally small.
-/
theorem essentially_small_iff (C : Type u) [category.{v} C] :
  essentially_small.{w} C ↔ small.{w} (skeleton C) ∧ locally_small.{w} C :=
begin
  -- This theorem is the only bit of real work in this file.
  fsplit,
  { intro h,
    fsplit,
    { rcases h with ⟨S, 𝒮, ⟨e⟩⟩,
      resetI,
      refine ⟨⟨skeleton S, ⟨_⟩⟩⟩,
      exact e.skeleton_equiv, },
    { resetI, apply_instance, }, },
  { rintro ⟨⟨S, ⟨e⟩⟩, L⟩,
    resetI,
    let e' := (shrink_homs.equivalence C).skeleton_equiv.symm,
    refine ⟨⟨S, _, ⟨_⟩⟩⟩,
    apply induced_category.category (e'.trans e).symm,
    refine (shrink_homs.equivalence C).trans
      ((skeleton_equivalence _).symm.trans
      ((induced_functor (e'.trans e).symm).as_equivalence.symm)), },
end

/--
Any thin category is locally small.
-/
@[priority 100]
instance locally_small_of_thin {C : Type u} [category.{v} C] [quiver.is_thin C] :
  locally_small.{w} C := {}

/--
A thin category is essentially small if and only if the underlying type of its skeleton is small.
-/
theorem essentially_small_iff_of_thin
  {C : Type u} [category.{v} C] [quiver.is_thin C] :
  essentially_small.{w} C ↔ small.{w} (skeleton C) :=
by simp [essentially_small_iff, category_theory.locally_small_of_thin]

end category_theory


import analysis.inner_product_space.pi_L2

variables {ι : Type*} [fintype ι]
variables {𝕜 : Type*} [is_R_or_C 𝕜] {E : Type*} [inner_product_space 𝕜 E]
variables {E' : Type*} [inner_product_space 𝕜 E']

variables {m n : ℕ}

local notation `⟪`x`, `y`⟫` := @inner 𝕜 (euclidean_space 𝕜 (fin m)) _ x y

open_locale matrix

lemma inner_matrix_row_row (A : matrix (fin n) (fin m) 𝕜) (i j : (fin n)) :
  ⟪A i, A j⟫ = (A ⬝ Aᴴ) j i := by {simp only [inner, matrix.mul_apply, star_ring_end_apply,
    matrix.conj_transpose_apply,mul_comm]}


/-
Copyright (c) 2018 Mario Carneiro, Kevin Buzzard. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Kevin Buzzard

! This file was ported from Lean 3 source module ring_theory.ideal.idempotent_fg
! leanprover-community/mathlib commit 290a7ba01fbcab1b64757bdaa270d28f4dcede35
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Ring.Idempotents
import Mathbin.RingTheory.Finiteness

/-!
## Lemmas on idempotent finitely generated ideals

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

namespace Ideal

/- warning: ideal.is_idempotent_elem_iff_of_fg -> Ideal.isIdempotentElem_iff_of_fg is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} [_inst_1 : CommRing.{u1} R] (I : Ideal.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))), (Ideal.Fg.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1)) I) -> (Iff (IsIdempotentElem.{u1} (Ideal.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))) (Ideal.hasMul.{u1} R (CommRing.toCommSemiring.{u1} R _inst_1)) I) (Exists.{succ u1} R (fun (e : R) => And (IsIdempotentElem.{u1} R (Distrib.toHasMul.{u1} R (Ring.toDistrib.{u1} R (CommRing.toRing.{u1} R _inst_1))) e) (Eq.{succ u1} (Ideal.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))) I (Submodule.span.{u1, u1} R R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1)) (NonUnitalNonAssocSemiring.toAddCommMonoid.{u1} R (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} R (Semiring.toNonAssocSemiring.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))))) (Semiring.toModule.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))) (Singleton.singleton.{u1, u1} R (Set.{u1} R) (Set.hasSingleton.{u1} R) e))))))
but is expected to have type
  forall {R : Type.{u1}} [_inst_1 : CommRing.{u1} R] (I : Ideal.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))), (Ideal.Fg.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1)) I) -> (Iff (IsIdempotentElem.{u1} (Ideal.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))) (Ideal.instMulIdealToSemiring.{u1} R (CommRing.toCommSemiring.{u1} R _inst_1)) I) (Exists.{succ u1} R (fun (e : R) => And (IsIdempotentElem.{u1} R (NonUnitalNonAssocRing.toMul.{u1} R (NonAssocRing.toNonUnitalNonAssocRing.{u1} R (Ring.toNonAssocRing.{u1} R (CommRing.toRing.{u1} R _inst_1)))) e) (Eq.{succ u1} (Ideal.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))) I (Submodule.span.{u1, u1} R R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1)) (NonUnitalNonAssocSemiring.toAddCommMonoid.{u1} R (NonUnitalNonAssocRing.toNonUnitalNonAssocSemiring.{u1} R (NonAssocRing.toNonUnitalNonAssocRing.{u1} R (Ring.toNonAssocRing.{u1} R (CommRing.toRing.{u1} R _inst_1))))) (_private.Mathlib.RingTheory.Ideal.Operations.0.Ideal.instModuleToSemiringToAddCommMonoidToNonUnitalNonAssocSemiringToNonUnitalNonAssocRingToNonUnitalRingToNonUnitalCommRing.{u1, u1} R R (CommRing.toCommSemiring.{u1} R _inst_1) _inst_1 (Algebra.id.{u1} R (CommRing.toCommSemiring.{u1} R _inst_1))) (Singleton.singleton.{u1, u1} R (Set.{u1} R) (Set.instSingletonSet.{u1} R) e))))))
Case conversion may be inaccurate. Consider using '#align ideal.is_idempotent_elem_iff_of_fg Ideal.isIdempotentElem_iff_of_fgₓ'. -/
/-- A finitely generated idempotent ideal is generated by an idempotent element -/
theorem isIdempotentElem_iff_of_fg {R : Type _} [CommRing R] (I : Ideal R) (h : I.Fg) :
    IsIdempotentElem I ↔ ∃ e : R, IsIdempotentElem e ∧ I = R ∙ e :=
  by
  constructor
  · intro e
    obtain ⟨r, hr, hr'⟩ :=
      Submodule.exists_mem_and_smul_eq_self_of_fg_of_le_smul I I h
        (by
          rw [smul_eq_mul]
          exact e.ge)
    simp_rw [smul_eq_mul] at hr'
    refine' ⟨r, hr' r hr, antisymm _ ((Submodule.span_singleton_le_iff_mem _ _).mpr hr)⟩
    intro x hx
    rw [← hr' x hx]
    exact ideal.mem_span_singleton'.mpr ⟨_, mul_comm _ _⟩
  · rintro ⟨e, he, rfl⟩
    simp [IsIdempotentElem, Ideal.span_singleton_mul_span_singleton, he.eq]
#align ideal.is_idempotent_elem_iff_of_fg Ideal.isIdempotentElem_iff_of_fg

/- warning: ideal.is_idempotent_elem_iff_eq_bot_or_top -> Ideal.isIdempotentElem_iff_eq_bot_or_top is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} [_inst_1 : CommRing.{u1} R] [_inst_2 : IsDomain.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))] (I : Ideal.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))), (Ideal.Fg.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1)) I) -> (Iff (IsIdempotentElem.{u1} (Ideal.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))) (Ideal.hasMul.{u1} R (CommRing.toCommSemiring.{u1} R _inst_1)) I) (Or (Eq.{succ u1} (Ideal.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))) I (Bot.bot.{u1} (Ideal.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))) (Submodule.hasBot.{u1, u1} R R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1)) (NonUnitalNonAssocSemiring.toAddCommMonoid.{u1} R (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} R (Semiring.toNonAssocSemiring.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))))) (Semiring.toModule.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1)))))) (Eq.{succ u1} (Ideal.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))) I (Top.top.{u1} (Ideal.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))) (Submodule.hasTop.{u1, u1} R R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1)) (NonUnitalNonAssocSemiring.toAddCommMonoid.{u1} R (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} R (Semiring.toNonAssocSemiring.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))))) (Semiring.toModule.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))))))))
but is expected to have type
  forall {R : Type.{u1}} [_inst_1 : CommRing.{u1} R] [_inst_2 : IsDomain.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))] (I : Ideal.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))), (Ideal.Fg.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1)) I) -> (Iff (IsIdempotentElem.{u1} (Ideal.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))) (Ideal.instMulIdealToSemiring.{u1} R (CommRing.toCommSemiring.{u1} R _inst_1)) I) (Or (Eq.{succ u1} (Ideal.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))) I (Bot.bot.{u1} (Ideal.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))) (Submodule.instBotSubmodule.{u1, u1} R R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1)) (NonUnitalNonAssocSemiring.toAddCommMonoid.{u1} R (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} R (Semiring.toNonAssocSemiring.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))))) (Semiring.toModule.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1)))))) (Eq.{succ u1} (Ideal.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))) I (Top.top.{u1} (Ideal.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))) (Submodule.instTopSubmodule.{u1, u1} R R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1)) (NonUnitalNonAssocSemiring.toAddCommMonoid.{u1} R (NonAssocSemiring.toNonUnitalNonAssocSemiring.{u1} R (Semiring.toNonAssocSemiring.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))))) (Semiring.toModule.{u1} R (Ring.toSemiring.{u1} R (CommRing.toRing.{u1} R _inst_1))))))))
Case conversion may be inaccurate. Consider using '#align ideal.is_idempotent_elem_iff_eq_bot_or_top Ideal.isIdempotentElem_iff_eq_bot_or_topₓ'. -/
theorem isIdempotentElem_iff_eq_bot_or_top {R : Type _} [CommRing R] [IsDomain R] (I : Ideal R)
    (h : I.Fg) : IsIdempotentElem I ↔ I = ⊥ ∨ I = ⊤ :=
  by
  constructor
  · intro H
    obtain ⟨e, he, rfl⟩ := (I.is_idempotent_elem_iff_of_fg h).mp H
    simp only [Ideal.submodule_span_eq, Ideal.span_singleton_eq_bot]
    apply or_of_or_of_imp_of_imp (is_idempotent_elem.iff_eq_zero_or_one.mp he) id
    rintro rfl
    simp
  · rintro (rfl | rfl) <;> simp [IsIdempotentElem]
#align ideal.is_idempotent_elem_iff_eq_bot_or_top Ideal.isIdempotentElem_iff_eq_bot_or_top

end Ideal


import category_theory.limits.shapes.pullbacks
import category_theory.limits.limits
import category_theory.types
import category_theory.limits.types
import category_theory.monad.algebra
import category_theory.category.Cat
import tactic.equiv_rw
import category.pullbacks
import data.sigma

namespace category_theory

open category_theory category_theory.category category_theory.limits

universes v u
noncomputable theory
section
variables (A : Type u) [category.{v} A]

structure internal_category_struct :=
(C₀ C₁ C₂ : A) -- object of objects, object of morphisms, object of composable pairs (i.e (f,g) where f ∘ g makes sense)
(trg src : C₁ ⟶ C₀) -- get codomain and domain of morphisms
(ident : C₀ ⟶ C₁) -- get identity morphism on object
(first_hom comp second_hom : C₂ ⟶ C₁) -- decompose composite
(comp_comm : first_hom ≫ src = second_hom ≫ trg)
(comp_pb : is_limit (pullback_cone.mk _ _ comp_comm))
(ident_trg : ident ≫ trg = 𝟙 C₀)
(ident_src : ident ≫ src = 𝟙 C₀)
(comp_trg : comp ≫ trg = first_hom ≫ trg)
(comp_src : comp ≫ src = second_hom ≫ src)
end

open internal_category_struct

attribute [simp, reassoc] internal_category_struct.ident_src internal_category_struct.ident_trg
attribute [simp, reassoc] internal_category_struct.comp_comm internal_category_struct.comp_trg internal_category_struct.comp_src

section
variables {C : Type u} [category.{v} C] {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z)
@[simp] lemma mk_fst {W : C} (fst : W ⟶ X) (snd : W ⟶ Y) (eq : fst ≫ f = snd ≫ g) :
  (pullback_cone.mk fst snd eq).fst = fst := rfl
@[simp] lemma mk_snd {W : C} (fst : W ⟶ X) (snd : W ⟶ Y) (eq : fst ≫ f = snd ≫ g) :
  (pullback_cone.mk fst snd eq).snd = snd := rfl
end

section
variables {A : Type u} [category.{v} A] (c : internal_category_struct A)
-- given f,g with the source of f = target of g (ie f ∘ g or g ≫ f makes sense), form the composable pair (f,g)

def make_pair {Q : A} (f g : Q ⟶ c.C₁)
  (composable : f ≫ c.src = g ≫ c.trg) :
Q ⟶ c.C₂ :=
(pullback_cone.is_limit.lift' c.comp_pb _ _ composable).1

@[simp, reassoc]
lemma compose_l {Q : A} (f g : Q ⟶ c.C₁)
  (cmp : f ≫ c.src = g ≫ c.trg) :
make_pair c f g cmp ≫ c.first_hom = f :=
(pullback_cone.is_limit.lift' c.comp_pb _ _ cmp).2.1

@[simp, reassoc]
lemma compose_r {Q : A} (f g : Q ⟶ c.C₁)
  (cmp : f ≫ c.src = g ≫ c.trg) :
make_pair c f g cmp ≫ c.second_hom = g :=
(pullback_cone.is_limit.lift' c.comp_pb _ _ cmp).2.2

@[reassoc] lemma compose_natural {Q R : A} (f g : R ⟶ c.C₁) (h : Q ⟶ R) (composable : f ≫ c.src = g ≫ c.trg) :
  h ≫ make_pair c f g composable = make_pair c (h ≫ f) (h ≫ g) (by simp [*]) :=
begin
  apply pullback_cone.is_limit.hom_ext c.comp_pb;
  simp,
end
end

section
variables {A : Type u} [category.{v} A] [has_finite_limits A] (c : internal_category_struct A)
/--
object of composable triples (f,g,h) where f ∘ (g ∘ h) makes sense
(as should (f ∘ g) ∘ h)
constructed as the pullback of (f,g₁) and (g₂,h) where g₁ = g₂
-/
def internal_category_struct.C₃ : A :=
pullback c.second_hom c.first_hom

open limits.pullback

/-- The first pair `(f, g₁)` of the triple `(f, g₁ = g₂, h)` -/
abbreviation internal_category_struct.left_pair : c.C₃ ⟶ c.C₂ := fst
/-- The second pair `(g₂, h)` of the triple `(f, g₁ = g₂, h)` -/
abbreviation internal_category_struct.right_pair : c.C₃ ⟶ c.C₂ := snd

/-- The first homomorphism `f` of the triple `(f, g, h)` -/
abbreviation internal_category_struct.trip_first_hom : c.C₃ ⟶ c.C₁ := c.left_pair ≫ c.first_hom
/-- The first homomorphism `h` of the triple `(f, g, h)` -/
abbreviation internal_category_struct.trip_third_hom : c.C₃ ⟶ c.C₁ := c.right_pair ≫ c.second_hom

/-- Prove `g₁ = g₂` in the triple `(f, g₁ = g₂, h)` -/
@[reassoc] lemma trip_snd_eq : c.left_pair ≫ c.second_hom = c.right_pair ≫ c.first_hom := condition

/-- Map `(f, g, h)` to `(f ∘ g, h)` -/
abbreviation internal_category_struct.comp_left_pair : c.C₃ ⟶ c.C₂ :=
make_pair c (c.left_pair ≫ c.comp) c.trip_third_hom $
by rw [assoc, c.comp_src, trip_snd_eq_assoc, assoc, c.comp_comm]

/-- Map `(f, g, h)` to `(f, g ∘ h)` -/
abbreviation internal_category_struct.comp_right_pair : c.C₃ ⟶ c.C₂ :=
make_pair c c.trip_first_hom (c.right_pair ≫ c.comp) $
by rw [assoc, assoc, c.comp_trg, c.comp_comm, trip_snd_eq_assoc]

end
-- def element {X : Type u} : (⊤_ (Type u) ⟶ X) ≃ X :=
-- { to_fun := λ f, f _,

-- }
-- -- { to_fun := λ f, f ⟨λ t, t.elim, λ t, t.elim⟩,
-- --   inv_fun := λ x _, x,
-- --   left_inv := λ f,
-- --   begin
-- --     ext1 ⟨_, _⟩,
-- --     dsimp,
-- --     congr,
-- --     ext ⟨⟩,
-- --   end,
-- --   right_inv := λ x, rfl }

-- @[simp] lemma element_natural {X Y : Type u} (f : ⊤_ _ ⟶ X) (g : X ⟶ Y) : element (f ≫ g) = g (element f) :=
-- rfl

-- @[simp] lemma element_unelement {X : Type u} (x : X) : element (element.symm x) = x :=
-- rfl

-- def category_struct_of_internal_category_struct_type (c : internal_category_struct.{u} (Type u)) :
--   category_struct c.C₀ :=
-- { hom := λ X Y, {h : c.C₁ // c.src h = Y ∧ c.trg h = X},
--   id := λ X, ⟨c.ident X, congr_fun c.ident_src X, congr_fun c.ident_trg X⟩,
--   comp := λ X Y Z f g,
--   begin
--     refine ⟨_, _, _⟩,
--     { refine element (make_pair c (element.symm ↑f) (element.symm ↑g) _ ≫ c.comp),
--       rw ← element.apply_eq_iff_eq,
--       dsimp, rw [f.prop.1, g.prop.2] },
--     { change (make_pair _ _ _ _ ≫ c.comp ≫ c.src) _ = Z,
--       rw [c.comp_src, compose_r_assoc],
--       exact g.prop.1 },
--     { change (make_pair _ _ _ _ ≫ c.comp ≫ c.trg) _ = X,
--       rw [c.comp_trg, compose_l_assoc],
--       exact f.prop.2 },
--   end }

-- structure internal_category (A : Type u) [category.{v} A] [has_finite_limits.{v} A] extends internal_category_struct.{v} A :=
-- (assoc : internal_category_struct.comp_left_pair _ ≫ comp = internal_category_struct.comp_right_pair _ ≫ comp)
-- (id_comp : make_pair _ (𝟙 _) (src ≫ ident) (by simp) ≫ comp = 𝟙 C₁)
-- (comp_id : make_pair _ (trg ≫ ident) (𝟙 _) (by simp) ≫ comp = 𝟙 C₁)

-- @[simps]
-- def internal_category_struct_type_of_category_struct (C : Type u) [category_struct.{u} C] : internal_category_struct.{u} (Type u) :=
-- { C₀ := C,
--   C₁ := Σ (X Y : C), X ⟶ Y,
--   C₂ := Σ (X Y Z : C), (X ⟶ Y) × (Y ⟶ Z),
--   src := λ f, f.1,
--   trg := λ f, f.2.1,
--   ident := λ x, ⟨x, x, 𝟙 _⟩,
--   first_hom := λ x, ⟨x.2.1, x.2.2.1, x.2.2.2.2⟩,
--   comp := λ x, ⟨x.1, x.2.2.1, x.2.2.2.1 ≫ x.2.2.2.2⟩,
--   second_hom := λ x, ⟨x.1, x.2.1, x.2.2.2.1⟩,
--   comp_comm := rfl,
--   comp_pb :=
--   begin
--     refine construct_type_pb _ _,
--     rintros ⟨Y, X, f⟩ ⟨Z, Y, g⟩ _,
--     dsimp at a, subst a,
--     refine ⟨⟨Z, Y, X, g, f⟩, rfl, rfl, _⟩,
--     rintro ⟨Z', Y', X', g', f'⟩ h₁ h₂,
--     dsimp at h₁ h₂,
--     cases h₁,
--     cases h₂,
--     refl,
--   end,
--   ident_trg := rfl,
--   ident_src := rfl,
--   comp_trg := rfl,
--   comp_src := rfl }

-- section

-- def tag (α : Type*) (n : ℕ) (t : α) := t

-- def alt_pb (C : Type u) [category_struct.{u} C] := Σ (W X Y Z : C), (W ⟶ X) × (X ⟶ Y) × (Y ⟶ Z)
-- def alt_π₁ (C : Type u) [category_struct.{u} C] :
--   alt_pb C ⟶ (internal_category_struct_type_of_category_struct C).C₂ :=
-- begin
--   intro x,
--   refine ⟨x.2.1, x.2.2.1, x.2.2.2.1, x.2.2.2.2.2.1, x.2.2.2.2.2.2⟩,
-- end
-- def alt_π₂ (C : Type u) [category_struct.{u} C] :
--   alt_pb C ⟶ (internal_category_struct_type_of_category_struct C).C₂ :=
-- begin
--   intro x,
--   refine ⟨x.1, x.2.1, x.2.2.1, x.2.2.2.2.1, x.2.2.2.2.2.1⟩,
-- end

-- lemma alt_comm (C : Type u) [category_struct.{u} C] :
--   alt_π₁ C ≫ (internal_category_struct_type_of_category_struct C).second_hom = alt_π₂ C ≫ (internal_category_struct_type_of_category_struct C).first_hom :=
-- rfl

-- def is_pb (C : Type u) [category_struct.{u} C] :
--   is_limit (pullback_cone.mk _ _ (alt_comm C)) :=
-- begin
--   apply construct_type_pb _,
--   rintros ⟨X, Y, Z, f, g⟩ ⟨W, X, Y, h, f⟩ _,
--   dsimp [internal_category_struct_type_of_category_struct] at a,
--   injection a with a₁ a₂,
--   subst a₁,
--   rw heq_iff_eq at a₂,
--   injection a₂ with a₃ a₄,
--   subst a₃,
--   rw heq_iff_eq at a₄,
--   subst a₄,
--   refine ⟨⟨_, _, _, _, h, f, g⟩, _, _, _⟩,
--   refl,
--   refl,
--   rintro ⟨_, _, _, _, _, _, _⟩ k l,
--   cases k,
--   cases l,
--   refl,
-- end

-- end

-- local attribute [instance] has_finite_limits_of_has_limits

-- def to_C₃ (C : Type u) [category_struct.{u} C] : alt_pb C ≅ (internal_category_struct_type_of_category_struct C).C₃ :=
-- limits.is_limit.cone_point_unique_up_to_iso (is_pb C) (limit.is_limit _)

-- @[simps]
-- def internal_category_type_of_category (C : Type u) [category.{u} C] : internal_category.{u} (Type u) :=
-- { id_comp :=
--   begin
--     ext1 ⟨X, Y, f⟩,
--     change (⟨_, _, _⟩ : Σ (X Y : C), X ⟶ Y) = _,
--     congr' 2,
--     apply id_comp,
--   end,
--   comp_id :=
--   begin
--     ext1 ⟨X, Y, f⟩,
--     change (⟨X, Y, f ≫ 𝟙 _⟩ : Σ (X Y : C), X ⟶ Y) = (⟨X, Y, f⟩ : Σ (X Y : C), X ⟶ Y),
--     congr' 2,
--     apply comp_id,
--   end,
--   assoc :=
--   begin
--     haveI := is_iso.of_iso (to_C₃ C),
--     rw [← cancel_epi (to_C₃ C).hom, compose_natural_assoc, compose_natural_assoc],
--     change make_pair _ (pullback.lift _ _ _ ≫ pullback.fst ≫ _) (pullback.lift _ _ _ ≫ pullback.snd ≫ _) _ ≫ _ =
--            make_pair _ (pullback.lift _ _ _ ≫ pullback.fst ≫ _) (pullback.lift _ _ _ ≫ pullback.snd ≫ _) _ ≫ _,
--     simp_rw [pullback.lift_fst_assoc, pullback.lift_snd_assoc],
--     ext1 ⟨W, X, Y, Z, f, g, h⟩,
--     change (⟨W, Z, f ≫ g ≫ h⟩ : Σ (X Y : C), X ⟶ Y) = (⟨W, Z, (f ≫ g) ≫ h⟩ : Σ (X Y : C), X ⟶ Y),
--     simp,
--   end,
--   ..internal_category_struct_type_of_category_struct C }

-- instance category_of_internal_category_type (c : internal_category.{u} (Type u)) :
--   small_category c.C₀ :=
-- { comp_id' :=
--   begin
--     rintros X Y ⟨f, rfl, rfl⟩,
--     ext1,
--     change element (make_pair _ (element.symm f) _ _ ≫ c.comp) = f,
--     equiv_rw (@element c.C₁).symm at f,
--     rw equiv.apply_eq_iff_eq,
--     change make_pair c.to_internal_category_struct f (element.symm (element ((f ≫ c.src) ≫ c.ident))) _ ≫ c.comp = _,
--     simp_rw [equiv.symm_apply_apply, assoc],
--     have := f ≫= c.id_comp,
--     simp_rw [compose_natural_assoc, comp_id] at this,
--     exact this,
--   end,
--   id_comp' :=
--   begin
--     rintros X Y ⟨f, rfl, rfl⟩,
--     ext1,
--     change element (make_pair _ _ (element.symm f) _ ≫ c.comp) = f,
--     equiv_rw (@element c.C₁).symm at f,
--     rw equiv.apply_eq_iff_eq,
--     change make_pair c.to_internal_category_struct (element.symm (element ((f ≫ c.trg) ≫ c.ident))) f _ ≫ c.comp = _,
--     simp_rw [equiv.symm_apply_apply, assoc],
--     have := f ≫= c.comp_id,
--     simp_rw [compose_natural_assoc, comp_id] at this,
--     exact this,
--   end,
--   assoc' :=
--   begin
--     rintros W X Y Z ⟨f, rfl, rfl⟩ ⟨g, rfl, fg⟩ ⟨h, rfl, gh⟩,
--     ext1,
--     equiv_rw (@element c.C₁).symm at f,
--     equiv_rw (@element c.C₁).symm at g,
--     equiv_rw (@element c.C₁).symm at h,
--     change element (make_pair _ _ _ _ ≫ c.comp) = element (make_pair _ _ _ _ ≫ c.comp),
--     rw equiv.apply_eq_iff_eq,
--     change make_pair _ (element.symm (element (make_pair _ (element.symm (element f)) (element.symm (element g)) _ ≫ c.comp))) (element.symm (element h)) _ ≫ c.comp =
--            make_pair _ (element.symm (element f)) (element.symm (element (make_pair _ (element.symm (element g)) (element.symm (element h)) _ ≫ c.comp))) _ ≫ c.comp,
--     simp_rw [equiv.symm_apply_apply],
--     change make_pair _ (make_pair _ f g _ ≫ c.comp) h _ ≫ c.comp = make_pair _ f (make_pair _ g h _ ≫ c.comp) _ ≫ c.comp,
--     have := pullback.lift (make_pair _ f g _) (make_pair _ g h _) _ ≫= c.assoc,
--       rotate,
--       { rw [equiv.symm_symm, ← element_natural _ c.trg, ← element_natural _ c.src, equiv.apply_eq_iff_eq] at fg,
--         rw fg },
--       { rw [equiv.symm_symm, ← element_natural _ c.trg, ← element_natural _ c.src, equiv.apply_eq_iff_eq] at gh,
--         rw gh },
--       { rw [compose_l, compose_r] },
--     rw [← assoc, ← assoc] at this,
--     convert this;
--     apply pullback_cone.is_limit.hom_ext c.comp_pb;
--     simp,
--   end,
--   ..category_struct_of_internal_category_struct_type c.to_internal_category_struct}

-- structure internal_functor {A : Type u} [category.{v} A] [has_finite_limits A] (c d : internal_category A) :=
-- (obj : c.C₀ ⟶ d.C₀)
-- (map : c.C₁ ⟶ d.C₁)
-- (map_src : map ≫ d.src = c.src ≫ obj)
-- (map_trg : map ≫ d.trg = c.trg ≫ obj)
-- (ident_map : c.ident ≫ map = obj ≫ d.ident)
-- (comp_map : make_pair _ (first_hom _ ≫ map) (second_hom _ ≫ map) (by simp [map_src, map_trg]) ≫ d.comp = c.comp ≫ map)

-- attribute [simp, reassoc] internal_functor.map_src internal_functor.map_trg internal_functor.ident_map internal_functor.comp_map
-- variables {A : Type u} [category.{v} A] [has_finite_limits A]

-- def internal_id (c : internal_category A) : internal_functor c c :=
-- { obj := 𝟙 _,
--   map := 𝟙 _,
--   map_src := by simp,
--   map_trg := by simp,
--   ident_map := by simp,
--   comp_map :=
--   begin
--     simp only [comp_id],
--     convert id_comp _,
--     apply pullback_cone.is_limit.hom_ext c.comp_pb;
--     simp,
--   end }

-- def internal_comp {c d e : internal_category A} (F : internal_functor c d) (G : internal_functor d e) :
--   internal_functor c e :=
-- { obj := F.obj ≫ G.obj,
--   map := F.map ≫ G.map,
--   map_src := by simp,
--   map_trg := by simp,
--   ident_map := by simp,
--   comp_map :=
--   begin
--     rw [← F.comp_map_assoc, ← G.comp_map, compose_natural_assoc],
--     simp,
--   end }

-- @[ext] def internal_functor_ext {c d : internal_category A} (F G : internal_functor c d) (h₁ : F.obj = G.obj) (h₂ : F.map = G.map) : F = G :=
-- begin
--   cases F, cases G,
--   congr; assumption
-- end
-- @[simps]
-- def make_functor (c d : internal_category.{u} (Type u)) (F : internal_functor c d) :
--   c.C₀ ⥤ d.C₀ :=
-- { obj := F.obj,
--   map := λ X Y f,
--   begin
--     refine ⟨F.map f.1, _, _⟩,
--     { change (F.map ≫ d.src) _ = _,
--       rw F.map_src,
--       dsimp,
--       rw f.prop.1 },
--     { change (F.map ≫ d.trg) _ = _,
--       rw F.map_trg,
--       dsimp,
--       rw f.prop.2 },
--   end,
--   map_id' := λ X,
--   begin
--     ext1,
--     change (c.ident ≫ F.map) X = (F.obj ≫ d.ident) X,
--     rw F.ident_map,
--   end,
--   map_comp' :=
--   begin
--     rintros _ _ Z ⟨f, rfl, rfl⟩ ⟨g, rfl, fg⟩,
--     ext1,
--     change F.map (element (make_pair _ (element.symm f) (element.symm g) _ ≫ c.comp)) = element (make_pair _ (element.symm (F.map f)) (element.symm (F.map g)) _ ≫ d.comp),
--     equiv_rw (@element c.C₁).symm at f,
--     equiv_rw (@element c.C₁).symm at g,
--     have : g ≫ c.trg = f ≫ c.src,
--       rw ← element.apply_eq_iff_eq,
--       simpa using fg,
--     simp_rw [← element_natural _ F.map, equiv.symm_apply_apply],
--     rw [element.apply_eq_iff_eq, assoc, ← F.comp_map, compose_natural_assoc],
--     simp,
--   end }

-- def internalise_functor (C D : Type u) [small_category C] [small_category D] (F : C ⥤ D) :
--   internal_functor (internal_category_type_of_category C) (internal_category_type_of_category D) :=
-- { obj := F.obj,
--   map := λ XYf, ⟨F.obj XYf.1, F.obj XYf.2.1, F.map XYf.2.2⟩,
--   map_src := rfl,
--   map_trg := rfl,
--   ident_map :=
--   begin
--     ext1 X,
--     dsimp,
--     simp only [functor.map_id],
--     refl,
--   end,
--   comp_map :=
--   begin
--     ext1 ⟨X, Y, Z, f, g⟩,
--     dsimp [internal_category_struct_type_of_category_struct],
--     change (⟨F.obj X, ⟨F.obj Z, F.map f ≫ F.map g⟩⟩ : Σ (X Y : D), X ⟶ Y) = (⟨F.obj X, ⟨F.obj Z, F.map (f ≫ g)⟩⟩ : Σ (X Y : D), X ⟶ Y),
--     simp,
--   end }

-- instance cat_of_int_cat : category (internal_category.{v} A) :=
-- { hom := internal_functor,
--   id := internal_id,
--   comp := λ X Y Z, internal_comp,
--   id_comp' := λ X Y f,
--   begin
--     apply internal_functor_ext;
--     apply id_comp,
--   end,
--   comp_id' := λ X Y f,
--   begin
--     apply internal_functor_ext;
--     apply comp_id,
--   end,
--   assoc' := λ c₁ c₂ c₃ c₄ f g h,
--   begin
--     apply internal_functor_ext;
--     apply assoc,
--   end }

-- @[simps]
-- def internal_equiv : internal_category (Type u) ⥤ Cat :=
-- { obj := λ c, Cat.of c.C₀,
--   map := make_functor,
--   map_id' := λ c,
--   begin
--     refine functor.ext (λ X, rfl) _,
--     intros,
--     apply subtype.ext,
--     dsimp [make_functor],
--     simpa only [id_comp, comp_id],
--   end,
--   map_comp' := λ c d e f g,
--   begin
--     refine functor.ext (λ X, rfl) _,
--     intros,
--     apply subtype.ext,
--     dsimp,
--     simpa,
--   end }

-- @[simps]
-- def internal_inv : Cat.{u} ⥤ internal_category (Type u) :=
-- { obj := λ c, internal_category_type_of_category c.α,
--   map := λ c d f, internalise_functor _ _ f }

-- -- -- set_option pp.all true
-- -- def internal_equivalence : internal_category.{u} (Type u) ≌ Cat.{u u} :=
-- -- { functor :=
-- --   { obj := λ c, Cat.of c.C₀,
-- --     map := make_functor,
-- --     map_id' := λ c,
-- --     begin
-- --       refine functor.ext (λ X, rfl) _,
-- --       intros,
-- --       apply subtype.ext,
-- --       dsimp [make_functor],
-- --       simpa only [id_comp, comp_id],
-- --     end,
-- --     map_comp' := λ c d e f g,
-- --     begin
-- --       refine functor.ext (λ X, rfl) _,
-- --       intros,
-- --       apply subtype.ext,
-- --       dsimp,
-- --       simpa,
-- --     end },
-- --   inverse :=
-- --   { obj := λ c, internal_category_type_of_category c.α,
-- --     map := λ c d f, internalise_functor _ _ f },
-- --   unit_iso :=
-- --   begin
-- --     -- apply nat_iso.of_components _ _,
-- --     -- intro X,
-- --     -- dsimp,
-- --     -- change X ≅ _,
-- --     -- dsimp [Cat.of, bundled.of, Cat.str, category_theory.category_of_internal_category_type, internal_category_type_of_category],
-- --     -- refine ⟨_, _, _, _⟩,
-- --     -- refine ⟨𝟙 _, λ x, ⟨X.src x, X.trg x, sorry⟩, rfl, rfl, _, _⟩,
-- --     -- ext1,
-- --     -- dsimp [internal_category_struct_type_of_category_struct],
-- --     -- change (⟨(X.ident ≫ X.src) x, (X.ident ≫ X.trg) x, _⟩ : Σ (X₁ Y₁ : X.to_internal_category_struct.C₀), X₁ ⟶ Y₁) = _,
-- --     sorry,
-- --   end,
-- --   counit_iso :=
-- --   begin
-- --     apply nat_iso.of_components _ _,
-- --     intro X,
-- --     apply eq_to_iso,
-- --     cases X,
-- --     dsimp [Cat.of, bundled.of],
-- --     congr,

-- --   end
-- -- }

end category_theory


import .form ..list

namespace nat

def update (m n) (v : nat → nat) : nat → nat
| x := if x = m then n else v x

lemma update_eq (m n v) : update m n v m = n :=
begin simp only [update, if_pos rfl] end

lemma update_eq_of_ne {m n v k} :
  m ≠ k → update m n v k = v k :=
begin
  intro h1, simp only [update],
  rw if_neg h1.symm
end

namespace preterm

def sub_terms : preterm → option (preterm × preterm)
| (& i)      := none
| (i ** n)   := none
| (t +* s) := t.sub_terms <|> s.sub_terms
| (t -* s) := t.sub_terms <|> s.sub_terms <|> some (t,s)

def sub_subst (t s : preterm) (k : nat) : preterm → preterm
| t@(& m)    := t
| t@(m ** n) := t
| (x +* y) := x.sub_subst +* y.sub_subst
| (x -* y) :=
  if x = t ∧ y = s then (1 ** k)
  else x.sub_subst -* y.sub_subst

lemma val_sub_subst {k x y v} :
  ∀ {t : preterm}, t.fresh_idx ≤ k →
  (sub_subst x y k t).val
  (update k (x.val v - y.val v) v) = t.val v
| (& m)    h1 := rfl
| (m ** n) h1 :=
  begin
    simp_omega [sub_subst], apply congr_arg,
    apply update_eq_of_ne (ne_of_gt _),
    apply lt_iff_add_one_le.elim_right h1,
 end
| (t +* s) h1 :=
  begin
    simp_omega [sub_subst], apply fun_mono_2;
    apply val_sub_subst (le_trans _ h1),
    apply le_max_left, apply le_max_right
  end
| (t -* s) h1 :=
  begin
    simp_omega [sub_subst],
    by_cases h2 : t = x ∧ s = y,
    { rw if_pos h2, simp_omega,
      rw [update_eq, h2.left, h2.right, one_mul] },
    { rw if_neg h2, simp_omega [sub_subst],
      apply fun_mono_2;
      apply val_sub_subst (le_trans _ h1),
      apply le_max_left, apply le_max_right, }
  end

end preterm

namespace form

def sub_terms : form → option (preterm × preterm)
| (t =* s) := t.sub_terms <|> s.sub_terms
| (t ≤* s) := t.sub_terms <|> s.sub_terms
| (¬* p)   := p.sub_terms
| (p ∨* q) := p.sub_terms <|> q.sub_terms
| (p ∧* q) := p.sub_terms <|> q.sub_terms

@[omega] def sub_subst (x y : preterm) (k : nat) : form → form
| (t =* s) := preterm.sub_subst x y k t =* preterm.sub_subst x y k s
| (t ≤* s) := preterm.sub_subst x y k t ≤* preterm.sub_subst x y k s
| (¬* p)   := ¬* p.sub_subst
| (p ∨* q) := p.sub_subst ∨* q.sub_subst
| (p ∧* q) := p.sub_subst ∧* q.sub_subst

end form

def is_diff (t s k) : form :=
((t =* (s +* (1 ** k))) ∨* (t ≤* s ∧* ((1 ** k) =* &0)))

lemma holds_is_diff {t s : preterm} {k} {v : nat → nat} :
  v k = t.val v - s.val v → (is_diff t s k).holds v :=
begin
  intro h1, simp_omega [is_diff, if_pos (eq.refl 1)],
  by_cases h2 : t.val v ≤ s.val v,
  { right, refine ⟨h2,_⟩,
    rw [h1, one_mul, nat.sub_eq_zero_iff_le], exact h2 },
  { left, rw [h1, one_mul, add_comm, nat.sub_add_cancel _],
    rw not_le at h2, apply le_of_lt h2 }
end

def sub_elim_core (t s k) (p : form) : form :=
(form.sub_subst t s k p) ∧* (is_diff t s k)

def sub_fresh_idx (t s : preterm) (p : form) : nat :=
max p.fresh_idx (max t.fresh_idx s.fresh_idx)

def sub_elim (t s) (p : form) : form :=
-- sub_elim_core t s p.fresh_idx p
sub_elim_core t s (sub_fresh_idx t s p) p

lemma sub_subst_equiv {k} {x y : preterm} {v} :
  ∀ p : form, p.fresh_idx ≤ k → ((form.sub_subst x y k p).holds
    (update k (x.val v - y.val v) v) ↔ (p.holds v))
| (t =* s) h1 :=
  begin
    simp_omega, apply pred_mono_2;
    apply preterm.val_sub_subst (le_trans _ h1),
    apply le_max_left, apply le_max_right
  end
| (t ≤* s) h1 :=
  begin
    simp_omega, apply pred_mono_2;
    apply preterm.val_sub_subst (le_trans _ h1),
    apply le_max_left, apply le_max_right
  end
| (¬* p) h1 :=
  by { apply not_iff_not_of_iff, apply sub_subst_equiv p h1 }
| (p ∨* q) h1 :=
  begin
    simp_omega, apply pred_mono_2; apply propext;
    apply sub_subst_equiv _ (le_trans _ h1),
    apply le_max_left, apply le_max_right
  end
| (p ∧* q) h1 :=
  begin
    simp_omega, apply pred_mono_2; apply propext;
    apply sub_subst_equiv _ (le_trans _ h1),
    apply le_max_left, apply le_max_right
  end

lemma sat_sub_elim {t s} {p : form} :
  p.sat → (sub_elim t s p).sat :=
begin
  intro h1, simp only [sub_elim, sub_elim_core],
  cases h1 with v h1,
  refine ⟨update (sub_fresh_idx t s p) (t.val v - s.val v) v, _⟩,
  constructor,
  { apply (sub_subst_equiv p _).elim_right h1,
    apply le_max_left },
  { apply holds_is_diff, rw update_eq,
    apply sub_eq_sub_of_eq_of_eq;
    apply preterm.val_constant; intros x h2;
    rw update_eq_of_ne; apply ne_of_gt;
    apply lt_of_lt_of_le h2;
    apply le_trans _ (le_max_right _ _),
    apply le_max_left, apply le_max_right }
end

lemma unsat_of_unsat_sub_elim (t s p) :
  (sub_elim t s p).unsat → p.unsat :=
not_of_imp_of_not sat_sub_elim

end nat


/-
Copyright (c) 2021 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen, Paul Lezeau

! This file was ported from Lean 3 source module number_theory.kummer_dedekind
! leanprover-community/mathlib commit f7fc89d5d5ff1db2d1242c7bb0e9062ce47ef47c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.AlgebraTower
import Mathbin.RingTheory.DedekindDomain.Ideal
import Mathbin.RingTheory.IsAdjoinRoot

/-!
# Kummer-Dedekind theorem

This file proves the monogenic version of the Kummer-Dedekind theorem on the splitting of prime
ideals in an extension of the ring of integers. This states that if `I` is a prime ideal of
Dedekind domain `R` and `S = R[α]` for some `α` that is integral over `R` with minimal polynomial
`f`, then the prime factorisations of `I * S` and `f mod I` have the same shape, i.e. they have the
same number of prime factors, and each prime factors of `I * S` can be paired with a prime factor
of `f mod I` in a way that ensures multiplicities match (in fact, this pairing can be made explicit
with a formula).

## Main definitions

 * `normalized_factors_map_equiv_normalized_factors_min_poly_mk` : The bijection in the
    Kummer-Dedekind theorem. This is the pairing between the prime factors of `I * S` and the prime
    factors of `f mod I`.

## Main results

 * `normalized_factors_ideal_map_eq_normalized_factors_min_poly_mk_map` : The Kummer-Dedekind
    theorem.
 * `ideal.irreducible_map_of_irreducible_minpoly` : `I.map (algebra_map R S)` is irreducible if
    `(map I^.quotient.mk (minpoly R pb.gen))` is irreducible, where `pb` is a power basis of `S`
    over `R`.

## TODO

 * Prove the Kummer-Dedekind theorem in full generality.

 * Prove the converse of `ideal.irreducible_map_of_irreducible_minpoly`.

 * Prove that `normalized_factors_map_equiv_normalized_factors_min_poly_mk` can be expressed as
    `normalized_factors_map_equiv_normalized_factors_min_poly_mk g = ⟨I, G(α)⟩` for `g` a prime
    factor of `f mod I` and `G` a lift of `g` to `R[X]`.

## References

 * [J. Neukirch, *Algebraic Number Theory*][Neukirch1992]

## Tags

kummer, dedekind, kummer dedekind, dedekind-kummer, dedekind kummer
-/

variable (R : Type _) {S : Type _} [CommRing R] [CommRing S] [Algebra R S]

open Ideal Polynomial DoubleQuot UniqueFactorizationMonoid Algebra RingHom

-- mathport name: «expr < >»
local notation:max R "<" x ">" => adjoin R ({x} : Set S)

/-- Let `S / R` be a ring extension and `x : S`, then the conductor of `R<x>` is the
    biggest ideal of `S` contained in `R<x>`. -/
def conductor (x : S) : Ideal S
    where
  carrier := { a | ∀ b : S, a * b ∈ R<x> }
  zero_mem' b := by simpa only [MulZeroClass.zero_mul] using Subalgebra.zero_mem _
  add_mem' a b ha hb c := by simpa only [add_mul] using Subalgebra.add_mem _ (ha c) (hb c)
  smul_mem' c a ha b := by simpa only [smul_eq_mul, mul_left_comm, mul_assoc] using ha (c * b)
#align conductor conductor

variable {R} {x : S}

theorem conductor_eq_of_eq {y : S} (h : (R<x> : Set S) = R<y>) : conductor R x = conductor R y :=
  Ideal.ext fun a => forall_congr' fun b => Set.ext_iff.mp h _
#align conductor_eq_of_eq conductor_eq_of_eq

theorem conductor_subset_adjoin : (conductor R x : Set S) ⊆ R<x> := fun y hy => by
  simpa only [mul_one] using hy 1
#align conductor_subset_adjoin conductor_subset_adjoin

theorem mem_conductor_iff {y : S} : y ∈ conductor R x ↔ ∀ b : S, y * b ∈ R<x> :=
  ⟨fun h => h, fun h => h⟩
#align mem_conductor_iff mem_conductor_iff

theorem conductor_eq_top_of_adjoin_eq_top (h : R<x> = ⊤) : conductor R x = ⊤ := by
  simp only [Ideal.eq_top_iff_one, mem_conductor_iff, h, mem_top, forall_const]
#align conductor_eq_top_of_adjoin_eq_top conductor_eq_top_of_adjoin_eq_top

theorem conductor_eq_top_of_powerBasis (pb : PowerBasis R S) : conductor R pb.gen = ⊤ :=
  conductor_eq_top_of_adjoin_eq_top pb.adjoin_gen_eq_top
#align conductor_eq_top_of_power_basis conductor_eq_top_of_powerBasis

variable {I : Ideal R}

/-- This technical lemma tell us that if `C` is the conductor of `R<x>` and `I` is an ideal of `R`
  then `p * (I * S) ⊆ I * R<x>` for any `p` in `C ∩ R` -/
theorem prod_mem_ideal_map_of_mem_conductor {p : R} {z : S}
    (hp : p ∈ Ideal.comap (algebraMap R S) (conductor R x)) (hz' : z ∈ I.map (algebraMap R S)) :
    algebraMap R S p * z ∈ algebraMap R<x> S '' ↑(I.map (algebraMap R R<x>)) :=
  by
  rw [Ideal.map, Ideal.span, Finsupp.mem_span_image_iff_total] at hz'
  obtain ⟨l, H, H'⟩ := hz'
  rw [Finsupp.total_apply] at H'
  rw [← H', mul_comm, Finsupp.sum_mul]
  have lem :
    ∀ {a : R},
      a ∈ I →
        l a • algebraMap R S a * algebraMap R S p ∈
          algebraMap R<x> S '' I.map (algebraMap R R<x>) :=
    by
    intro a ha
    rw [Algebra.id.smul_eq_mul, mul_assoc, mul_comm, mul_assoc, Set.mem_image]
    refine'
      Exists.intro
        (algebraMap R R<x> a * ⟨l a * algebraMap R S p, show l a * algebraMap R S p ∈ R<x> from _⟩)
        _
    · rw [mul_comm]
      exact mem_conductor_iff.mp (ideal.mem_comap.mp hp) _
    refine' ⟨_, by simpa only [RingHom.map_mul, mul_comm (algebraMap R S p) (l a)] ⟩
    rw [mul_comm]
    apply Ideal.mul_mem_left (I.map (algebraMap R R<x>)) _ (Ideal.mem_map_of_mem _ ha)
  refine'
    Finset.sum_induction _ (fun u => u ∈ algebraMap R<x> S '' I.map (algebraMap R R<x>))
      (fun a b => _) _ _
  rintro ⟨z, hz, rfl⟩ ⟨y, hy, rfl⟩
  rw [← RingHom.map_add]
  exact ⟨z + y, Ideal.add_mem _ (set_like.mem_coe.mp hz) hy, rfl⟩
  · refine' ⟨0, set_like.mem_coe.mpr <| Ideal.zero_mem _, RingHom.map_zero _⟩
  · intro y hy
    exact lem ((Finsupp.mem_supported _ l).mp H hy)
#align prod_mem_ideal_map_of_mem_conductor prod_mem_ideal_map_of_mem_conductor

/-- A technical result telling us that `(I * S) ∩ R<x> = I * R<x>` for any ideal `I` of `R`. -/
theorem comap_map_eq_map_adjoin_of_coprime_conductor
    (hx : (conductor R x).comap (algebraMap R S) ⊔ I = ⊤)
    (h_alg : Function.Injective (algebraMap R<x> S)) :
    (I.map (algebraMap R S)).comap (algebraMap R<x> S) = I.map (algebraMap R R<x>) :=
  by
  apply le_antisymm
  · -- This is adapted from [Neukirch1992]. Let `C = (conductor R x)`. The idea of the proof
    -- is that since `I` and `C ∩ R` are coprime, we have
    -- `(I * S) ∩ R<x> ⊆ (I + C) * ((I * S) ∩ R<x>) ⊆ I * R<x> + I * C * S ⊆ I * R<x>`.
    intro y hy
    obtain ⟨z, hz⟩ := y
    obtain ⟨p, hp, q, hq, hpq⟩ := submodule.mem_sup.mp ((Ideal.eq_top_iff_one _).mp hx)
    have temp : algebraMap R S p * z + algebraMap R S q * z = z := by
      simp only [← add_mul, ← RingHom.map_add (algebraMap R S), hpq, map_one, one_mul]
    suffices
      z ∈ algebraMap R<x> S '' I.map (algebraMap R R<x>) ↔
        (⟨z, hz⟩ : R<x>) ∈ I.map (algebraMap R R<x>)
      by
      rw [← this, ← temp]
      obtain ⟨a, ha⟩ :=
        (Set.mem_image _ _ _).mp
          (prod_mem_ideal_map_of_mem_conductor hp
            (show z ∈ I.map (algebraMap R S) by rwa [Ideal.mem_comap] at hy))
      use a + algebraMap R R<x> q * ⟨z, hz⟩
      refine'
        ⟨Ideal.add_mem (I.map (algebraMap R R<x>)) ha.left _, by
          simpa only [ha.right, map_add, AlgHom.map_mul, add_right_inj] ⟩
      rw [mul_comm]
      exact Ideal.mul_mem_left (I.map (algebraMap R R<x>)) _ (Ideal.mem_map_of_mem _ hq)
    refine'
      ⟨fun h => _, fun h => (Set.mem_image _ _ _).mpr (Exists.intro ⟨z, hz⟩ ⟨by simp [h], rfl⟩)⟩
    · obtain ⟨x₁, hx₁, hx₂⟩ := (Set.mem_image _ _ _).mp h
      have : x₁ = ⟨z, hz⟩ := by
        apply h_alg
        simpa [hx₂]
      rwa [← this]
  · -- The converse inclusion is trivial
    have : algebraMap R S = (algebraMap _ S).comp (algebraMap R R<x>) :=
      by
      ext
      rfl
    rw [this, ← Ideal.map_map]
    apply Ideal.le_comap_map
#align comap_map_eq_map_adjoin_of_coprime_conductor comap_map_eq_map_adjoin_of_coprime_conductor

/-- The canonical morphism of rings from `R<x> ⧸ (I*R<x>)` to `S ⧸ (I*S)` is an isomorphism
    when `I` and `(conductor R x) ∩ R` are coprime. -/
noncomputable def quotAdjoinEquivQuotMap (hx : (conductor R x).comap (algebraMap R S) ⊔ I = ⊤)
    (h_alg : Function.Injective (algebraMap R<x> S)) :
    R<x> ⧸ I.map (algebraMap R R<x>) ≃+* S ⧸ I.map (algebraMap R S) :=
  RingEquiv.ofBijective
    (Ideal.Quotient.lift (I.map (algebraMap R R<x>))
      ((I.map (algebraMap R S)).Quotient.mk.comp (algebraMap R<x> S)) fun r hr =>
      by
      have : algebraMap R S = (algebraMap R<x> S).comp (algebraMap R R<x>) :=
        by
        ext
        rfl
      rw [RingHom.comp_apply, Ideal.Quotient.eq_zero_iff_mem, this, ← Ideal.map_map]
      exact Ideal.mem_map_of_mem _ hr)
    (by
      constructor
      · --the kernel of the map is clearly `(I * S) ∩ R<x>`. To get injectivity, we need to show that
        --this is contained in `I * R<x>`, which is the content of the previous lemma.
        refine' RingHom.lift_injective_of_ker_le_ideal _ _ fun u hu => _
        rwa [RingHom.mem_ker, RingHom.comp_apply, Ideal.Quotient.eq_zero_iff_mem, ← Ideal.mem_comap,
          comap_map_eq_map_adjoin_of_coprime_conductor hx h_alg] at hu
      · -- Surjectivity follows from the surjectivity of the canonical map `R<x> → S ⧸ (I * S)`,
        -- which in turn follows from the fact that `I * S + (conductor R x) = S`.
        refine' Ideal.Quotient.lift_surjective_of_surjective _ _ fun y => _
        obtain ⟨z, hz⟩ := Ideal.Quotient.mk_surjective y
        have : z ∈ conductor R x ⊔ I.map (algebraMap R S) :=
          by
          suffices conductor R x ⊔ I.map (algebraMap R S) = ⊤ by simp only [this]
          rw [Ideal.eq_top_iff_one] at hx⊢
          replace hx := Ideal.mem_map_of_mem (algebraMap R S) hx
          rw [Ideal.map_sup, RingHom.map_one] at hx
          exact
            (sup_le_sup
                (show ((conductor R x).comap (algebraMap R S)).map (algebraMap R S) ≤ conductor R x
                  from Ideal.map_comap_le)
                (le_refl (I.map (algebraMap R S))))
              hx
        rw [← Ideal.mem_quotient_iff_mem_sup, hz, Ideal.mem_map_iff_of_surjective] at this
        obtain ⟨u, hu, hu'⟩ := this
        use ⟨u, conductor_subset_adjoin hu⟩
        simpa only [← hu']
        · exact Ideal.Quotient.mk_surjective)
#align quot_adjoin_equiv_quot_map quotAdjoinEquivQuotMap

@[simp]
theorem quotAdjoinEquivQuotMap_apply_mk (hx : (conductor R x).comap (algebraMap R S) ⊔ I = ⊤)
    (h_alg : Function.Injective (algebraMap R<x> S)) (a : R<x>) :
    quotAdjoinEquivQuotMap hx h_alg ((I.map (algebraMap R R<x>)).Quotient.mk a) =
      (I.map (algebraMap R S)).Quotient.mk ↑a :=
  rfl
#align quot_adjoin_equiv_quot_map_apply_mk quotAdjoinEquivQuotMap_apply_mk

namespace KummerDedekind

open BigOperators Polynomial Classical

variable [IsDomain R] [IsIntegrallyClosed R]

variable [IsDomain S] [IsDedekindDomain S]

variable [NoZeroSMulDivisors R S]

attribute [local instance] Ideal.Quotient.field

/-- The first half of the **Kummer-Dedekind Theorem** in the monogenic case, stating that the prime
    factors of `I*S` are in bijection with those of the minimal polynomial of the generator of `S`
    over `R`, taken `mod I`.-/
noncomputable def normalizedFactorsMapEquivNormalizedFactorsMinPolyMk (hI : IsMaximal I)
    (hI' : I ≠ ⊥) (hx : (conductor R x).comap (algebraMap R S) ⊔ I = ⊤) (hx' : IsIntegral R x) :
    { J : Ideal S | J ∈ normalizedFactors (I.map (algebraMap R S)) } ≃
      { d : (R ⧸ I)[X] | d ∈ normalizedFactors (map I.Quotient.mk (minpoly R x)) } :=
  (normalizedFactorsEquivOfQuotEquiv
        ((quotAdjoinEquivQuotMap hx
                (by
                  apply NoZeroSMulDivisors.algebraMap_injective (Algebra.adjoin R {x}) S
                  exact Subalgebra.noZeroSMulDivisors_top (Algebra.adjoin R {x}))).symm.trans
          (((Algebra.adjoin.powerBasis' hx').quotientEquivQuotientMinpolyMap I).toRingEquiv.trans
            (quotEquivOfEq
              (show
                Ideal.span {(minpoly R (Algebra.adjoin.powerBasis' hx').gen).map I.Quotient.mk} =
                  Ideal.span {(minpoly R x).map I.Quotient.mk}
                by rw [Algebra.adjoin.powerBasis'_minpoly_gen hx']))))
        (--show that `I * S` ≠ ⊥
        show I.map (algebraMap R S) ≠ ⊥ by
          rwa [Ne.def, map_eq_bot_iff_of_injective (NoZeroSMulDivisors.algebraMap_injective R S), ←
            Ne.def])
        (--show that the ideal spanned by `(minpoly R pb.gen) mod I` is non-zero
        by
          by_contra
          exact
            (show map I.Quotient.mk (minpoly R x) ≠ 0 from
                Polynomial.map_monic_ne_zero (minpoly.monic hx'))
              (span_singleton_eq_bot.mp h))).trans
    (normalizedFactorsEquivSpanNormalizedFactors
        (show map I.Quotient.mk (minpoly R x) ≠ 0 from
          Polynomial.map_monic_ne_zero (minpoly.monic hx'))).symm
#align kummer_dedekind.normalized_factors_map_equiv_normalized_factors_min_poly_mk KummerDedekind.normalizedFactorsMapEquivNormalizedFactorsMinPolyMk

/-- The second half of the **Kummer-Dedekind Theorem** in the monogenic case, stating that the
    bijection `factors_equiv'` defined in the first half preserves multiplicities. -/
theorem multiplicity_factors_map_eq_multiplicity (hI : IsMaximal I) (hI' : I ≠ ⊥)
    (hx : (conductor R x).comap (algebraMap R S) ⊔ I = ⊤) (hx' : IsIntegral R x) {J : Ideal S}
    (hJ : J ∈ normalizedFactors (I.map (algebraMap R S))) :
    multiplicity J (I.map (algebraMap R S)) =
      multiplicity (↑(normalizedFactorsMapEquivNormalizedFactorsMinPolyMk hI hI' hx hx' ⟨J, hJ⟩))
        (map I.Quotient.mk (minpoly R x)) :=
  by
  rw [normalized_factors_map_equiv_normalized_factors_min_poly_mk, Equiv.coe_trans,
    Function.comp_apply,
    multiplicity_normalizedFactorsEquivSpanNormalizedFactors_symm_eq_multiplicity,
    normalizedFactorsEquivOfQuotEquiv_multiplicity_eq_multiplicity]
#align kummer_dedekind.multiplicity_factors_map_eq_multiplicity KummerDedekind.multiplicity_factors_map_eq_multiplicity

/-- The **Kummer-Dedekind Theorem**. -/
theorem normalizedFactors_ideal_map_eq_normalizedFactors_min_poly_mk_map (hI : IsMaximal I)
    (hI' : I ≠ ⊥) (hx : (conductor R x).comap (algebraMap R S) ⊔ I = ⊤) (hx' : IsIntegral R x) :
    normalizedFactors (I.map (algebraMap R S)) =
      Multiset.map
        (fun f =>
          ((normalizedFactorsMapEquivNormalizedFactorsMinPolyMk hI hI' hx hx').symm f : Ideal S))
        (normalizedFactors (Polynomial.map I.Quotient.mk (minpoly R x))).attach :=
  by
  ext J
  -- WLOG, assume J is a normalized factor
  by_cases hJ : J ∈ normalized_factors (I.map (algebraMap R S))
  swap
  · rw [multiset.count_eq_zero.mpr hJ, eq_comm, Multiset.count_eq_zero, Multiset.mem_map]
    simp only [Multiset.mem_attach, true_and_iff, not_exists]
    rintro J' rfl
    exact
      hJ ((normalized_factors_map_equiv_normalized_factors_min_poly_mk hI hI' hx hx').symm J').Prop
  -- Then we just have to compare the multiplicities, which we already proved are equal.
  have := multiplicity_factors_map_eq_multiplicity hI hI' hx hx' hJ
  rw [multiplicity_eq_count_normalized_factors, multiplicity_eq_count_normalized_factors,
    UniqueFactorizationMonoid.normalize_normalized_factor _ hJ,
    UniqueFactorizationMonoid.normalize_normalized_factor, PartENat.natCast_inj] at this
  refine' this.trans _
  -- Get rid of the `map` by applying the equiv to both sides.
  generalize hJ' :
    (normalized_factors_map_equiv_normalized_factors_min_poly_mk hI hI' hx hx') ⟨J, hJ⟩ = J'
  have :
    ((normalized_factors_map_equiv_normalized_factors_min_poly_mk hI hI' hx hx').symm J' :
        Ideal S) =
      J :=
    by rw [← hJ', Equiv.symm_apply_apply _ _, Subtype.coe_mk]
  subst this
  -- Get rid of the `attach` by applying the subtype `coe` to both sides.
  rw [Multiset.count_map_eq_count' fun f =>
      ((normalized_factors_map_equiv_normalized_factors_min_poly_mk hI hI' hx hx').symm f :
        Ideal S),
    Multiset.attach_count_eq_count_coe]
  · exact subtype.coe_injective.comp (Equiv.injective _)
  · exact (normalized_factors_map_equiv_normalized_factors_min_poly_mk hI hI' hx hx' _).Prop
  ·
    exact
      irreducible_of_normalized_factor _
        (normalized_factors_map_equiv_normalized_factors_min_poly_mk hI hI' hx hx' _).Prop
  · exact Polynomial.map_monic_ne_zero (minpoly.monic hx')
  · exact irreducible_of_normalized_factor _ hJ
  ·
    rwa [← bot_eq_zero, Ne.def,
      map_eq_bot_iff_of_injective (NoZeroSMulDivisors.algebraMap_injective R S)]
#align kummer_dedekind.normalized_factors_ideal_map_eq_normalized_factors_min_poly_mk_map KummerDedekind.normalizedFactors_ideal_map_eq_normalizedFactors_min_poly_mk_map

theorem Ideal.irreducible_map_of_irreducible_minpoly (hI : IsMaximal I) (hI' : I ≠ ⊥)
    (hx : (conductor R x).comap (algebraMap R S) ⊔ I = ⊤) (hx' : IsIntegral R x)
    (hf : Irreducible (map I.Quotient.mk (minpoly R x))) : Irreducible (I.map (algebraMap R S)) :=
  by
  have mem_norm_factors :
    normalize (map I.Quotient.mk (minpoly R x)) ∈
      normalized_factors (map I.Quotient.mk (minpoly R x)) :=
    by simp [normalized_factors_irreducible hf]
  suffices ∃ y, normalized_factors (I.map (algebraMap R S)) = {y}
    by
    obtain ⟨y, hy⟩ := this
    have h :=
      normalized_factors_prod
        (show I.map (algebraMap R S) ≠ 0 by
          rwa [← bot_eq_zero, Ne.def,
            map_eq_bot_iff_of_injective (NoZeroSMulDivisors.algebraMap_injective R S)])
    rw [associated_iff_eq, hy, Multiset.prod_singleton] at h
    rw [← h]
    exact
      irreducible_of_normalized_factor y
        (show y ∈ normalized_factors (I.map (algebraMap R S)) by simp [hy])
  rw [normalized_factors_ideal_map_eq_normalized_factors_min_poly_mk_map hI hI' hx hx']
  use
    ((normalized_factors_map_equiv_normalized_factors_min_poly_mk hI hI' hx hx').symm
        ⟨normalize (map I.Quotient.mk (minpoly R x)), mem_norm_factors⟩ :
      Ideal S)
  rw [Multiset.map_eq_singleton]
  use ⟨normalize (map I.Quotient.mk (minpoly R x)), mem_norm_factors⟩
  refine' ⟨_, rfl⟩
  apply Multiset.map_injective Subtype.coe_injective
  rw [Multiset.attach_map_val, Multiset.map_singleton, Subtype.coe_mk]
  exact normalized_factors_irreducible hf
#align kummer_dedekind.ideal.irreducible_map_of_irreducible_minpoly KummerDedekind.Ideal.irreducible_map_of_irreducible_minpoly

end KummerDedekind