/-
Copyright (c) 2018 Sean Leather. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sean Leather, Mario Carneiro
-/
import data.list.alist
import data.finset.sigma
import data.part
/-!
# Finite maps over `multiset`

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

universes u v w
open list
variables {α : Type u} {β : α → Type v}

/-! ### multisets of sigma types-/

namespace multiset

/-- Multiset of keys of an association multiset. -/
def keys (s : multiset (sigma β)) : multiset α :=
s.map sigma.fst

@[simp] theorem coe_keys {l : list (sigma β)} :
  keys (l : multiset (sigma β)) = (l.keys : multiset α) :=
rfl

/-- `nodupkeys s` means that `s` has no duplicate keys. -/
def nodupkeys (s : multiset (sigma β)) : Prop :=
quot.lift_on s list.nodupkeys (λ s t p, propext $ perm_nodupkeys p)

@[simp] theorem coe_nodupkeys {l : list (sigma β)} : @nodupkeys α β l ↔ l.nodupkeys := iff.rfl

lemma nodup_keys {m : multiset (Σ a, β a)} : m.keys.nodup ↔ m.nodupkeys :=
by { rcases m with ⟨l⟩, refl }

alias nodup_keys ↔ _ nodupkeys.nodup_keys

lemma nodupkeys.nodup {m : multiset (Σ a, β a)} (h : m.nodupkeys) : m.nodup :=
h.nodup_keys.of_map _

end multiset

/-! ### finmap -/

/-- `finmap β` is the type of finite maps over a multiset. It is effectively
  a quotient of `alist β` by permutation of the underlying list. -/
structure finmap (β : α → Type v) : Type (max u v) :=
(entries : multiset (sigma β))
(nodupkeys : entries.nodupkeys)

/-- The quotient map from `alist` to `finmap`. -/
def alist.to_finmap (s : alist β) : finmap β := ⟨s.entries, s.nodupkeys⟩

local notation (name := to_finmap) `⟦`:max a `⟧`:0 := alist.to_finmap a

theorem alist.to_finmap_eq {s₁ s₂ : alist β} :
  ⟦s₁⟧ = ⟦s₂⟧ ↔ s₁.entries ~ s₂.entries :=
by cases s₁; cases s₂; simp [alist.to_finmap]

@[simp] theorem alist.to_finmap_entries (s : alist β) : ⟦s⟧.entries = s.entries := rfl

/-- Given `l : list (sigma β)`, create a term of type `finmap β` by removing
entries with duplicate keys. -/
def list.to_finmap [decidable_eq α] (s : list (sigma β)) : finmap β := s.to_alist.to_finmap

namespace finmap
open alist

lemma nodup_entries (f : finmap β) : f.entries.nodup := f.nodupkeys.nodup

/-! ### lifting from alist -/

/-- Lift a permutation-respecting function on `alist` to `finmap`. -/
@[elab_as_eliminator] def lift_on
  {γ} (s : finmap β) (f : alist β → γ)
  (H : ∀ a b : alist β, a.entries ~ b.entries → f a = f b) : γ :=
begin
  refine (quotient.lift_on s.1 (λ l, (⟨_, λ nd, f ⟨l, nd⟩⟩ : part γ))
    (λ l₁ l₂ p, part.ext' (perm_nodupkeys p) _) : part γ).get _,
  { exact λ h₁ h₂, H _ _ (by exact p) },
  { have := s.nodupkeys, rcases s.entries with ⟨l⟩, exact id }
end

@[simp] theorem lift_on_to_finmap {γ} (s : alist β) (f : alist β → γ) (H) :
  lift_on ⟦s⟧ f H = f s := by cases s; refl

/-- Lift a permutation-respecting function on 2 `alist`s to 2 `finmap`s. -/
@[elab_as_eliminator] def lift_on₂
  {γ} (s₁ s₂ : finmap β) (f : alist β → alist β → γ)
  (H : ∀ a₁ b₁ a₂ b₂ : alist β, a₁.entries ~ a₂.entries → b₁.entries ~ b₂.entries →
    f a₁ b₁ = f a₂ b₂) : γ :=
lift_on s₁
  (λ l₁, lift_on s₂ (f l₁) (λ b₁ b₂ p, H _ _ _ _ (perm.refl _) p))
  (λ a₁ a₂ p, have H' : f a₁ = f a₂ := funext (λ _, H _ _ _ _ p (perm.refl _)), by simp only [H'])

@[simp] theorem lift_on₂_to_finmap {γ} (s₁ s₂ : alist β) (f : alist β → alist β → γ) (H) :
  lift_on₂ ⟦s₁⟧ ⟦s₂⟧ f H = f s₁ s₂ :=
by cases s₁; cases s₂; refl

/-! ### induction -/

@[elab_as_eliminator] theorem induction_on
  {C : finmap β → Prop} (s : finmap β) (H : ∀ (a : alist β), C ⟦a⟧) : C s :=
by rcases s with ⟨⟨a⟩, h⟩; exact H ⟨a, h⟩

@[elab_as_eliminator] theorem induction_on₂ {C : finmap β → finmap β → Prop}
  (s₁ s₂ : finmap β) (H : ∀ (a₁ a₂ : alist β), C ⟦a₁⟧ ⟦a₂⟧) : C s₁ s₂ :=
induction_on s₁ $ λ l₁, induction_on s₂ $ λ l₂, H l₁ l₂

@[elab_as_eliminator] theorem induction_on₃ {C : finmap β →  finmap β → finmap β → Prop}
  (s₁ s₂ s₃ : finmap β) (H : ∀ (a₁ a₂ a₃ : alist β), C ⟦a₁⟧ ⟦a₂⟧ ⟦a₃⟧) : C s₁ s₂ s₃ :=
induction_on₂ s₁ s₂ $ λ l₁ l₂, induction_on s₃ $ λ l₃, H l₁ l₂ l₃

/-! ### extensionality -/

@[ext] theorem ext : ∀ {s t : finmap β}, s.entries = t.entries → s = t
| ⟨l₁, h₁⟩ ⟨l₂, h₂⟩ H := by congr'

@[simp] theorem ext_iff {s t : finmap β} : s.entries = t.entries ↔ s = t :=
⟨ext, congr_arg _⟩

/-! ### mem -/

/-- The predicate `a ∈ s` means that `s` has a value associated to the key `a`. -/
instance : has_mem α (finmap β) := ⟨λ a s, a ∈ s.entries.keys⟩

theorem mem_def {a : α} {s : finmap β} :
  a ∈ s ↔ a ∈ s.entries.keys := iff.rfl

@[simp] theorem mem_to_finmap {a : α} {s : alist β} :
  a ∈ ⟦s⟧ ↔ a ∈ s := iff.rfl

/-! ### keys -/

/-- The set of keys of a finite map. -/
def keys (s : finmap β) : finset α :=
⟨s.entries.keys, s.nodupkeys.nodup_keys⟩

@[simp] theorem keys_val (s : alist β) : (keys ⟦s⟧).val = s.keys := rfl

@[simp] theorem keys_ext {s₁ s₂ : alist β} :
  keys ⟦s₁⟧ = keys ⟦s₂⟧ ↔ s₁.keys ~ s₂.keys :=
by simp [keys, alist.keys]

theorem mem_keys {a : α} {s : finmap β} : a ∈ s.keys ↔ a ∈ s :=
induction_on s $ λ s, alist.mem_keys

/-! ### empty -/

/-- The empty map. -/
instance : has_emptyc (finmap β) := ⟨⟨0, nodupkeys_nil⟩⟩

instance : inhabited (finmap β) := ⟨∅⟩

@[simp] theorem empty_to_finmap : (⟦∅⟧ : finmap β) = ∅ := rfl

@[simp] theorem to_finmap_nil [decidable_eq α] : ([].to_finmap : finmap β) = ∅ := rfl

theorem not_mem_empty {a : α} : a ∉ (∅ : finmap β) :=
multiset.not_mem_zero a

@[simp] theorem keys_empty : (∅ : finmap β).keys = ∅ := rfl

/-! ### singleton -/

/-- The singleton map. -/
def singleton (a : α) (b : β a) : finmap β := ⟦alist.singleton a b⟧

@[simp] theorem keys_singleton (a : α) (b : β a) :
  (singleton a b).keys = {a} := rfl

@[simp] lemma mem_singleton (x y : α) (b : β y) : x ∈ singleton y b ↔ x = y :=
by simp only [singleton]; erw [mem_cons_eq, mem_nil_iff, or_false]

section

variables [decidable_eq α]

instance has_decidable_eq [∀ a, decidable_eq (β a)] : decidable_eq (finmap β)
| s₁ s₂ := decidable_of_iff _ ext_iff

/-! ### lookup -/

/-- Look up the value associated to a key in a map. -/
def lookup (a : α) (s : finmap β) : option (β a) :=
lift_on s (lookup a) (λ s t, perm_lookup)

@[simp] theorem lookup_to_finmap (a : α) (s : alist β) :
  lookup a ⟦s⟧ = s.lookup a := rfl

@[simp] theorem lookup_list_to_finmap (a : α) (s : list (sigma β)) :
  lookup a s.to_finmap = s.lookup a :=
by rw [list.to_finmap, lookup_to_finmap, lookup_to_alist]

@[simp] theorem lookup_empty (a) : lookup a (∅ : finmap β) = none :=
rfl

theorem lookup_is_some {a : α} {s : finmap β} :
  (s.lookup a).is_some ↔ a ∈ s :=
induction_on s $ λ s, alist.lookup_is_some

theorem lookup_eq_none {a} {s : finmap β} : lookup a s = none ↔ a ∉ s :=
induction_on s $ λ s, alist.lookup_eq_none

lemma mem_lookup_iff {f : finmap β} {a : α} {b : β a} :
  b ∈ f.lookup a ↔ sigma.mk a b ∈ f.entries :=
by { rcases f with ⟨⟨l⟩, hl⟩, exact list.mem_lookup_iff hl }

/-- A version of `finmap.mem_lookup_iff` with LHS in the simp-normal form. -/
lemma lookup_eq_some_iff {f : finmap β} {a : α} {b : β a} :
  f.lookup a = some b ↔ sigma.mk a b ∈ f.entries :=
mem_lookup_iff

@[simp] lemma sigma_keys_lookup (f : finmap β) :
  f.keys.sigma (λ i, (f.lookup i).to_finset) = ⟨f.entries, f.nodup_entries⟩ :=
begin
  ext x,
  have : x ∈ f.entries → x.fst ∈ f.keys, from multiset.mem_map_of_mem _,
  simpa [lookup_eq_some_iff]
end

@[simp] lemma lookup_singleton_eq {a : α} {b : β a} : (singleton a b).lookup a = some b :=
by rw [singleton, lookup_to_finmap, alist.singleton, alist.lookup, lookup_cons_eq]

instance (a : α) (s : finmap β) : decidable (a ∈ s) :=
decidable_of_iff _ lookup_is_some

lemma mem_iff {a : α} {s : finmap β} : a ∈ s ↔ ∃ b, s.lookup a = some b :=
induction_on s $ λ s,
iff.trans list.mem_keys $ exists_congr $ λ b,
(list.mem_lookup_iff s.nodupkeys).symm

lemma mem_of_lookup_eq_some {a : α} {b : β a} {s : finmap β} (h : s.lookup a = some b) : a ∈ s :=
mem_iff.mpr ⟨_, h⟩

theorem ext_lookup {s₁ s₂ : finmap β} : (∀ x, s₁.lookup x = s₂.lookup x) → s₁ = s₂ :=
induction_on₂ s₁ s₂ $ λ s₁ s₂ h,
begin
  simp only [alist.lookup, lookup_to_finmap] at h,
  rw [alist.to_finmap_eq],
  apply lookup_ext s₁.nodupkeys s₂.nodupkeys,
  intros x y,
  rw h,
end

/-- An equivalence between `finmap β` and pairs `(keys : finset α, lookup : Π a, option (β a))` such
that `(lookup a).is_some ↔ a ∈ keys`. -/
@[simps apply_coe_fst apply_coe_snd]
def keys_lookup_equiv :
  finmap β ≃ {f : finset α × (Π a, option (β a)) // ∀ i, (f.2 i).is_some ↔ i ∈ f.1} :=
{ to_fun := λ f, ⟨(f.keys, λ i, f.lookup i), λ i, lookup_is_some⟩,
  inv_fun := λ f, ⟨(f.1.1.sigma $ λ i, (f.1.2 i).to_finset).val,
    begin
      refine multiset.nodup_keys.1 ((finset.nodup _).map_on _),
      simp only [finset.mem_val, finset.mem_sigma, option.mem_to_finset, option.mem_def],
      rintro ⟨i, x⟩ ⟨hi, hx⟩ ⟨j, y⟩ ⟨hj, hy⟩ (rfl : i = j),
      obtain rfl : x = y, from option.some.inj (hx.symm.trans hy),
      refl
    end⟩,
  left_inv := λ f, ext $ by simp,
  right_inv := λ ⟨⟨s, f⟩, hf⟩,
    begin
      ext : 2; dsimp [keys],
      { ext1 i,
        have : i ∈ s → (∃ x, f i = some x),
          from λ hi, ⟨option.get _, option.get_mem $ (hf i).2 hi⟩,
        simpa [multiset.keys] },
      { ext i x : 2,
        simp only [option.mem_def, lookup_eq_some_iff, finset.mem_val, finset.mem_sigma,
          option.mem_to_finset, and_iff_right_iff_imp, ← hf],
        exact λ h, option.is_some_iff_exists.2 ⟨_, h⟩ }
    end }

@[simp] lemma keys_lookup_equiv_symm_apply_keys :
  ∀ f : {f : finset α × (Π a, option (β a)) // ∀ i, (f.2 i).is_some ↔ i ∈ f.1},
    (keys_lookup_equiv.symm f).keys = (f : finset α × Π a, option (β a)).1 :=
keys_lookup_equiv.surjective.forall.2 $ λ f,
  by simp only [equiv.symm_apply_apply, keys_lookup_equiv_apply_coe_fst]

@[simp] lemma keys_lookup_equiv_symm_apply_lookup :
  ∀ (f : {f : finset α × (Π a, option (β a)) // ∀ i, (f.2 i).is_some ↔ i ∈ f.1}) a,
    (keys_lookup_equiv.symm f).lookup a = (f : finset α × Π a, option (β a)).2 a :=
keys_lookup_equiv.surjective.forall.2 $ λ f a,
  by simp only [equiv.symm_apply_apply, keys_lookup_equiv_apply_coe_snd]

/-! ### replace -/

/-- Replace a key with a given value in a finite map.
  If the key is not present it does nothing. -/
def replace (a : α) (b : β a) (s : finmap β) : finmap β :=
lift_on s (λ t, ⟦replace a b t⟧) $
λ s₁ s₂ p, to_finmap_eq.2 $ perm_replace p

@[simp] theorem replace_to_finmap (a : α) (b : β a) (s : alist β) :
  replace a b ⟦s⟧ = ⟦s.replace a b⟧ := by simp [replace]

@[simp] theorem keys_replace (a : α) (b : β a) (s : finmap β) :
  (replace a b s).keys = s.keys :=
induction_on s $ λ s, by simp

@[simp] theorem mem_replace {a a' : α} {b : β a} {s : finmap β} :
  a' ∈ replace a b s ↔ a' ∈ s :=
induction_on s $ λ s, by simp

end

/-! ### foldl -/

/-- Fold a commutative function over the key-value pairs in the map -/
def foldl {δ : Type w} (f : δ → Π a, β a → δ)
  (H : ∀ d a₁ b₁ a₂ b₂, f (f d a₁ b₁) a₂ b₂ = f (f d a₂ b₂) a₁ b₁)
  (d : δ) (m : finmap β) : δ :=
m.entries.foldl (λ d s, f d s.1 s.2) (λ d s t, H _ _ _ _ _) d

/-- `any f s` returns `tt` iff there exists a value `v` in `s` such that `f v = tt`. -/
def any (f : Π x, β x → bool) (s : finmap β) : bool :=
s.foldl (λ x y z, x || f y z) (by { intros, simp_rw [bool.bor_assoc, bool.bor_comm] }) ff

/-- `all f s` returns `tt` iff `f v = tt` for all values `v` in `s`. -/
def all (f : Π x, β x → bool) (s : finmap β) : bool :=
s.foldl (λ x y z, x && f y z) (by { intros, simp_rw [bool.band_assoc, bool.band_comm] }) tt

/-! ### erase -/

section

variables [decidable_eq α]

/-- Erase a key from the map. If the key is not present it does nothing. -/
def erase (a : α) (s : finmap β) : finmap β :=
lift_on s (λ t, ⟦erase a t⟧) $
λ s₁ s₂ p, to_finmap_eq.2 $ perm_erase p

@[simp] theorem erase_to_finmap (a : α) (s : alist β) :
  erase a ⟦s⟧ = ⟦s.erase a⟧ := by simp [erase]

@[simp]

@[simp] theorem keys_erase (a : α) (s : finmap β) :
  (erase a s).keys = s.keys.erase a :=
induction_on s $ λ s, by simp

@[simp] theorem mem_erase {a a' : α} {s : finmap β} : a' ∈ erase a s ↔ a' ≠ a ∧ a' ∈ s :=
induction_on s $ λ s, by simp

theorem not_mem_erase_self {a : α} {s : finmap β} : ¬ a ∈ erase a s :=
by rw [mem_erase, not_and_distrib, not_not]; left; refl

@[simp] theorem lookup_erase (a) (s : finmap β) : lookup a (erase a s) = none :=
induction_on s $ lookup_erase a

@[simp] theorem lookup_erase_ne {a a'} {s : finmap β} (h : a ≠ a') :
  lookup a (erase a' s) = lookup a s :=
induction_on s $ λ s, lookup_erase_ne h

theorem erase_erase {a a' : α} {s : finmap β} : erase a (erase a' s) = erase a' (erase a s) :=
induction_on s $ λ s, ext (by simp only [erase_erase, erase_to_finmap])

/-! ### sdiff -/

/-- `sdiff s s'` consists of all key-value pairs from `s` and `s'` where the keys are in `s` or
`s'` but not both. -/
def sdiff (s s' : finmap β) : finmap β :=
s'.foldl (λ s x _, s.erase x) (λ a₀ a₁ _ a₂ _, erase_erase) s

instance : has_sdiff (finmap β) := ⟨sdiff⟩

/-! ### insert -/

/-- Insert a key-value pair into a finite map, replacing any existing pair with
  the same key. -/
def insert (a : α) (b : β a) (s : finmap β) : finmap β :=
lift_on s (λ t, ⟦insert a b t⟧) $
λ s₁ s₂ p, to_finmap_eq.2 $ perm_insert p

@[simp] theorem insert_to_finmap (a : α) (b : β a) (s : alist β) :
  insert a b ⟦s⟧ = ⟦s.insert a b⟧ := by simp [insert]

theorem insert_entries_of_neg {a : α} {b : β a} {s : finmap β} : a ∉ s →
  (insert a b s).entries = ⟨a, b⟩ ::ₘ s.entries :=
induction_on s $ λ s h,
by simp [insert_entries_of_neg (mt mem_to_finmap.1 h)]

@[simp] theorem mem_insert {a a' : α} {b' : β a'} {s : finmap β} :
  a ∈ insert a' b' s ↔ a = a' ∨ a ∈ s :=
induction_on s mem_insert

@[simp] theorem lookup_insert {a} {b : β a} (s : finmap β) :
  lookup a (insert a b s) = some b :=
induction_on s $ λ s,
by simp only [insert_to_finmap, lookup_to_finmap, lookup_insert]

@[simp] theorem lookup_insert_of_ne {a a'} {b : β a} (s : finmap β) (h : a' ≠ a) :
  lookup a' (insert a b s) = lookup a' s :=
induction_on s $ λ s,
by simp only [insert_to_finmap, lookup_to_finmap, lookup_insert_ne h]

@[simp] theorem insert_insert {a} {b b' : β a} (s : finmap β) :
  (s.insert a b).insert a b' = s.insert a b' :=
induction_on s $ λ s,
by simp only [insert_to_finmap, insert_insert]

theorem insert_insert_of_ne {a a'} {b : β a} {b' : β a'} (s : finmap β) (h : a ≠ a') :
  (s.insert a b).insert a' b' = (s.insert a' b').insert a b :=
induction_on s $ λ s,
by simp only [insert_to_finmap, alist.to_finmap_eq, insert_insert_of_ne _ h]

theorem to_finmap_cons (a : α) (b : β a) (xs : list (sigma β)) :
  list.to_finmap (⟨a,b⟩ :: xs) = insert a b xs.to_finmap := rfl

theorem mem_list_to_finmap (a : α) (xs : list (sigma β)) :
  a ∈ xs.to_finmap ↔ (∃ b : β a, sigma.mk a b ∈ xs) :=
by { induction xs with x xs; [skip, cases x];
     simp only [to_finmap_cons, *, not_mem_empty, exists_or_distrib, not_mem_nil, to_finmap_nil,
                exists_false, mem_cons_iff, mem_insert, exists_and_distrib_left];
     apply or_congr _ iff.rfl,
     conv { to_lhs, rw ← and_true (a = x_fst) },
     apply and_congr_right, rintro ⟨⟩, simp only [exists_eq, heq_iff_eq] }

@[simp] theorem insert_singleton_eq {a : α} {b b' : β a} :
  insert a b (singleton a b') = singleton a b :=
by simp only [singleton, finmap.insert_to_finmap, alist.insert_singleton_eq]

/-! ### extract -/

/-- Erase a key from the map, and return the corresponding value, if found. -/
def extract (a : α) (s : finmap β) : option (β a) × finmap β :=
lift_on s (λ t, prod.map id to_finmap (extract a t)) $
λ s₁ s₂ p, by simp [perm_lookup p, to_finmap_eq, perm_erase p]

@[simp] theorem extract_eq_lookup_erase (a : α) (s : finmap β) :
  extract a s = (lookup a s, erase a s) :=
induction_on s $ λ s, by simp [extract]

/-! ### union -/

/-- `s₁ ∪ s₂` is the key-based union of two finite maps. It is left-biased: if
there exists an `a ∈ s₁`, `lookup a (s₁ ∪ s₂) = lookup a s₁`. -/
def union (s₁ s₂ : finmap β) : finmap β :=
lift_on₂ s₁ s₂ (λ s₁ s₂, ⟦s₁ ∪ s₂⟧) $
λ s₁ s₂ s₃ s₄ p₁₃ p₂₄, to_finmap_eq.mpr $ perm_union p₁₃ p₂₄

instance : has_union (finmap β) := ⟨union⟩

@[simp] theorem mem_union {a} {s₁ s₂ : finmap β} :
  a ∈ s₁ ∪ s₂ ↔ a ∈ s₁ ∨ a ∈ s₂ :=
induction_on₂ s₁ s₂ $ λ _ _, mem_union

@[simp] theorem union_to_finmap (s₁ s₂ : alist β) : ⟦s₁⟧ ∪ ⟦s₂⟧ = ⟦s₁ ∪ s₂⟧ :=
by simp [(∪), union]

theorem keys_union {s₁ s₂ : finmap β} : (s₁ ∪ s₂).keys = s₁.keys ∪ s₂.keys :=
induction_on₂ s₁ s₂ $ λ s₁ s₂, finset.ext $ by simp [keys]

@[simp] theorem lookup_union_left {a} {s₁ s₂ : finmap β} :
  a ∈ s₁ → lookup a (s₁ ∪ s₂) = lookup a s₁ :=
induction_on₂ s₁ s₂ $ λ s₁ s₂, lookup_union_left

@[simp] theorem lookup_union_right {a} {s₁ s₂ : finmap β} :
  a ∉ s₁ → lookup a (s₁ ∪ s₂) = lookup a s₂ :=
induction_on₂ s₁ s₂ $ λ s₁ s₂, lookup_union_right

theorem lookup_union_left_of_not_in {a} {s₁ s₂ : finmap β} (h : a ∉ s₂) :
  lookup a (s₁ ∪ s₂) = lookup a s₁ :=
begin
  by_cases h' : a ∈ s₁,
  { rw lookup_union_left h' },
  { rw [lookup_union_right h', lookup_eq_none.mpr h, lookup_eq_none.mpr h'] }
end

@[simp] theorem mem_lookup_union {a} {b : β a} {s₁ s₂ : finmap β} :
  b ∈ lookup a (s₁ ∪ s₂) ↔ b ∈ lookup a s₁ ∨ a ∉ s₁ ∧ b ∈ lookup a s₂ :=
induction_on₂ s₁ s₂ $ λ s₁ s₂, mem_lookup_union

theorem mem_lookup_union_middle {a} {b : β a} {s₁ s₂ s₃ : finmap β} :
  b ∈ lookup a (s₁ ∪ s₃) → a ∉ s₂ → b ∈ lookup a (s₁ ∪ s₂ ∪ s₃) :=
induction_on₃ s₁ s₂ s₃ $ λ s₁ s₂ s₃, mem_lookup_union_middle

theorem insert_union {a} {b : β a} {s₁ s₂ : finmap β} :
  insert a b (s₁ ∪ s₂) = insert a b s₁ ∪ s₂ :=
induction_on₂ s₁ s₂ $ λ a₁ a₂, by simp [insert_union]

theorem union_assoc {s₁ s₂ s₃ : finmap β} : (s₁ ∪ s₂) ∪ s₃ = s₁ ∪ (s₂ ∪ s₃) :=
induction_on₃ s₁ s₂ s₃ $ λ s₁ s₂ s₃,
by simp only [alist.to_finmap_eq, union_to_finmap, alist.union_assoc]

@[simp] theorem empty_union {s₁ : finmap β} : ∅ ∪ s₁ = s₁ :=
induction_on s₁ $ λ s₁, by rw ← empty_to_finmap;
  simp [- empty_to_finmap, alist.to_finmap_eq, union_to_finmap, alist.union_assoc]

@[simp] theorem union_empty {s₁ : finmap β} : s₁ ∪ ∅ = s₁ :=
induction_on s₁ $ λ s₁, by rw ← empty_to_finmap;
  simp [- empty_to_finmap, alist.to_finmap_eq, union_to_finmap, alist.union_assoc]

theorem erase_union_singleton (a : α) (b : β a) (s : finmap β) (h : s.lookup a = some b) :
  s.erase a ∪ singleton a b = s :=
ext_lookup
(λ x, by { by_cases h' : x = a,
      { subst a, rw [lookup_union_right not_mem_erase_self, lookup_singleton_eq, h], },
      { have : x ∉ singleton a b, { rwa mem_singleton },
        rw [lookup_union_left_of_not_in this, lookup_erase_ne h'] } } )

end

/-! ### disjoint -/

/-- `disjoint s₁ s₂` holds if `s₁` and `s₂` have no keys in common. -/
def disjoint (s₁ s₂ : finmap β) : Prop :=
∀ x ∈ s₁, ¬ x ∈ s₂

lemma disjoint_empty (x : finmap β) : disjoint ∅ x .

@[symm]
lemma disjoint.symm (x y : finmap β) (h : disjoint x y) : disjoint y x :=
λ p hy hx, h p hx hy

lemma disjoint.symm_iff (x y : finmap β) : disjoint x y ↔ disjoint y x :=
⟨disjoint.symm x y, disjoint.symm y x⟩

section

variables [decidable_eq α]

instance : decidable_rel (@disjoint α β) :=
λ x y, by dsimp only [disjoint]; apply_instance

lemma disjoint_union_left (x y z : finmap β) : disjoint (x ∪ y) z ↔ disjoint x z ∧ disjoint y z :=
by simp [disjoint, finmap.mem_union, or_imp_distrib, forall_and_distrib]

lemma disjoint_union_right (x y z : finmap β) : disjoint x (y ∪ z) ↔ disjoint x y ∧ disjoint x z :=
by rw [disjoint.symm_iff, disjoint_union_left, disjoint.symm_iff _ x, disjoint.symm_iff _ x]

theorem union_comm_of_disjoint {s₁ s₂ : finmap β} : disjoint s₁ s₂ → s₁ ∪ s₂ = s₂ ∪ s₁ :=
induction_on₂ s₁ s₂ $ λ s₁ s₂,
by { intros h, simp only [alist.to_finmap_eq, union_to_finmap, alist.union_comm_of_disjoint h] }

theorem union_cancel {s₁ s₂ s₃ : finmap β} (h : disjoint s₁ s₃) (h' : disjoint s₂ s₃) :
  s₁ ∪ s₃ = s₂ ∪ s₃ ↔ s₁ = s₂ :=
⟨λ h'', begin
          apply ext_lookup, intro x,
          have : (s₁ ∪ s₃).lookup x = (s₂ ∪ s₃).lookup x, from h'' ▸ rfl,
          by_cases hs₁ : x ∈ s₁,
          { rwa [lookup_union_left hs₁, lookup_union_left_of_not_in (h _ hs₁)] at this, },
          { by_cases hs₂ : x ∈ s₂,
            { rwa [lookup_union_left_of_not_in (h' _ hs₂), lookup_union_left hs₂] at this, },
            { rw [lookup_eq_none.mpr hs₁, lookup_eq_none.mpr hs₂] } }
        end,
 λ h, h ▸ rfl⟩

end

end finmap


/- Author: E.W.Ayers.
   This section roughly follows Chapter 3, §1, §2 of Sheaves in Geology and Logic by Saunders Maclane and Ieke M.
 -/

import sieve
import category.pullbacks

universes u v w
namespace category_theory

open category_theory limits order lattice

/-- A set of sieves for every object in the category: a candidate to be a Grothendieck topology. -/
def sieve_set (C : Type u) [category.{v} C] := Π (X : C), set (sieve X)

def sieve_set.trivial (C : Type u) [category.{v} C] : sieve_set C := λ X, {⊤}

lemma mem_trivial (C : Type u) [category.{v} C] {X : C} (S : sieve X) :
  S ∈ sieve_set.trivial C X ↔ S = ⊤ :=
set.mem_singleton_iff

/-- A sieve on `X` is dense if for any arrow `f : Y ⟶ X`, there is a `g : Z ⟶ Y` with `g ≫ f ∈ S`. -/
def sieve_set.dense (C : Type u) [category.{v} C] : sieve_set C :=
λ X, {S | ∀ {Y : C} (f : Y ⟶ X), ∃ Z (g : Z ⟶ Y), over.mk (g ≫ f) ∈ S.arrows }

/-- The atomic sieve_set just contains all of the non-empty sieves. -/
def sieve_set.atomic (C : Type u) [category.{v} C] : sieve_set C :=
λ X, {S | ∃ {Y} (f : Y ⟶ X), over.mk f ∈ S.arrows}

open sieve category

/--
Definition of a Grothendieck Topology: a set of sieves `J X` on each object `X` satisfying three axioms:
1. For every object `X`, the maximal sieve is in `J X`.
2. If `S ∈ J X` then its pullback along any `h : Y ⟶ X` is in `J Y`.
3. If `S ∈ J X` and `R` is a sieve on `X`, then provided that the pullback of `R` along any arrow
   `f : Y ⟶ X` in `S` is in `J Y`, we have that `R` itself is in `J X`.
-/
class grothendieck {C : Type u} [category.{v} C] (J : sieve_set C) : Prop :=
(max : ∀ X, ⊤ ∈ J X)
(stab : ∀ {X Y} (S ∈ J X) (h : Y ⟶ X), sieve.pullback S h ∈ J Y)
(trans : ∀ ⦃X⦄ (S : sieve X) (hS : S ∈ J X) (R : sieve X), (∀ {Y} (f : Y ⟶ X), over.mk f ∈ S.arrows → R.pullback f ∈ J Y) → R ∈ J X)

/-- A site is a category equipped with a grothendieck topology. -/
structure Site :=
(C : Type u)
[𝒞 : category.{v} C]
(J : sieve_set C)
[g : grothendieck J]

namespace grothendieck
variables {C : Type u} [category.{v} C]
variables {X Y : C} {S R : sieve X}
variables {J : sieve_set C} [grothendieck J]

def superset_covering (Hss : S ≤ R) (sjx : S ∈ J X) : R ∈ J X :=
begin
  apply grothendieck.trans _ sjx,
  intros Y h hh,
  dsimp,
  have : S.pullback h ≤ R.pullback h,
    apply pullback_le_map Hss,
  have : S.pullback h = ⊤,
    rw ← id_mem_iff_eq_top,
    simpa,
  have : R.pullback h = ⊤,
    apply top_unique,
    rwa ← this,
  rw this,
  apply grothendieck.max,
end

def covers (J : sieve_set C) (S : sieve X) (f : Y ⟶ X) : Prop := S.pullback f ∈ J Y

lemma arrow_max (f : Y ⟶ X) (S : sieve X) [grothendieck J] (hf : over.mk f ∈ S.arrows) : covers J S f :=
begin
  rw [covers, (pullback_eq_top_iff_mem f).1 hf],
  apply grothendieck.max,
end
lemma arrow_stab (f : Y ⟶ X) (S : sieve X) (h : covers J S f) {Z : C} (g : Z ⟶ Y) : covers J S (g ≫ f) :=
begin
  rw [covers, pullback_comp],
  apply grothendieck.stab,
  apply h,
end
lemma arrow_trans (f : Y ⟶ X) (S R : sieve X) (h : covers J S f) : (∀ {Z : C} (g : Z ⟶ X), over.mk g ∈ S.arrows → covers J R g) → covers J R f :=
begin
  intro k,
  apply grothendieck.trans (S.pullback f) h,
  intros Z g hg,
  rw ← pullback_comp,
  apply k (g ≫ f) hg,
end

lemma intersection_covering (rj : R ∈ J X) (sj : S ∈ J X) : R ⊓ S ∈ J X :=
begin
  apply grothendieck.trans R rj,
  intros Y f Hf,
  have : S.pullback f ≤ (R ⊓ S).pullback f,
    intros Z g hg,
    refine ⟨downward_closed _ Hf _, hg⟩,
  apply superset_covering this,
  apply grothendieck.stab _ sj,
  apply_instance,
end

lemma arrow_intersect (f : Y ⟶ X) (S R : sieve X) (hS : covers J S f) (hR : covers J R f) : covers J (S ⊓ R) f :=
begin
  rw [covers, pullback_inter],
  apply intersection_covering;
  assumption
end

open sieve_set

instance trivial.grothendieck : grothendieck (sieve_set.trivial C) :=
{ max := λ X, set.mem_singleton _,
  stab := λ X Y S HS h,
  begin
    rw mem_trivial at *,
    rw [HS, pullback_top],
  end,
  trans := λ X S HS R HR,
  begin
    rw [mem_trivial, ← id_mem_iff_eq_top, pullback_eq_top_iff_mem],
    simp only [mem_trivial] at HR,
    apply HR,
    rwa [id_mem_iff_eq_top, ← mem_trivial],
  end }

instance dense.grothendieck : grothendieck (dense C) :=
{ max := λ X Y f, ⟨Y, 𝟙 Y, ⟨⟩⟩,
  stab :=
    begin
      intros X Y S H h Z f,
      rcases H (f ≫ h) with ⟨W, g, H⟩,
      refine ⟨W, g, _⟩,
      simpa,
    end,
  trans :=
    begin
      intros X S H₁ R H₂ Y f,
      rcases H₁ f with ⟨Z,g,H₃⟩,
      rcases H₂ _ H₃ (𝟙 Z) with ⟨W,h,H₄⟩,
      refine ⟨W, (h ≫ 𝟙 Z ≫ g), _⟩,
      simpa using H₄,
    end }

/--
A category satisfies the right Ore condition if any span can be completed to a
commutative square.
NB. Any category with pullbacks obviously satisfies the right Ore condition.
-/
def right_ore_condition (C : Type u) [category.{v} C] : Prop :=
∀ {X Y Z : C} (yx : Y ⟶ X) (zx : Z ⟶ X), ∃ W (wy : W ⟶ Y) (wz : W ⟶ Z), wy ≫ yx = wz ≫ zx

/--
The atomic sieveset is a grothendieck topology when it
satisfies the 'square' property. Which says that every span `Y ⟶ X ⟵ Z` forms a commuting
diagram.
-/
instance atomic.grothendieck
  (hro : right_ore_condition C)
  : grothendieck (atomic C) :=
{ max := λ X, ⟨_, 𝟙 _, ⟨⟩⟩,
  stab :=
  begin
    rintros X Y S ⟨Z, f, hf⟩ h,
    rcases hro h f with ⟨W, g, k, comm⟩,
    refine ⟨_, g, _⟩,
    simp [mem_pullback, comm, hf],
  end,
  trans :=
  begin
    rintros X S ⟨Y, f, hf⟩ R h,
    rcases h f hf with ⟨Z, g, hg⟩,
    exact ⟨_, _, hg⟩,
  end }

open opposite

def matching_family (P : Cᵒᵖ ⥤ Type v) (S : sieve X) :=
S.as_functor ⟶ P

def amalgamation {P : Cᵒᵖ ⥤ Type v} {S : sieve X} (γ : matching_family P S) :=
{α : yoneda.obj X ⟶ P // sieve.functor_inclusion S ≫ α = γ}

@[derive subsingleton]
def sheaf_condition (J : sieve_set C) [grothendieck J] (P : Cᵒᵖ ⥤ Type v) : Type (max u v) :=
Π (X : C) (S : sieve X) (γ : matching_family P S), S ∈ J X → unique (amalgamation γ)

def matching_family' (P : Cᵒᵖ ⥤ Type v) {c : C} (S : sieve c) :=
{x : Π {d : C} (f : d ⟶ c), over.mk f ∈ S.arrows → P.obj (opposite.op d) // ∀ {d e : C} (f : d ⟶ c) (g : e ⟶ d) (h : over.mk f ∈ S.arrows), x (g ≫ f) (sieve.downward_closed _ h _) = P.map g.op (x f h)}

def amalgamation' {P : Cᵒᵖ ⥤ Type v} {c : C} {S : sieve c} (γ : matching_family' P S) :=
{y : P.obj (opposite.op c) // ∀ {d : C} (f : d ⟶ c) (hf : over.mk f ∈ S.arrows), P.map f.op y = γ.1 f hf}

@[derive subsingleton]
def sheaf_condition' (J : sieve_set C) [grothendieck J] (P : Cᵒᵖ ⥤ Type v) : Type (max u v) :=
Π (c : C) (S : sieve c) (γ : matching_family' P S), S ∈ J c → unique (amalgamation' γ)

def matching_family'_equiv_matching_family (P : Cᵒᵖ ⥤ Type v) : matching_family' P S ≃ matching_family P S :=
{ to_fun := λ x, ⟨λ _ t, x.1 _ t.2, λ c c' f, funext $ λ t, x.2 _ _ t.2⟩,
  inv_fun := λ x, ⟨λ d f hf, x.app _ ⟨f, hf⟩, λ d d' f g h, congr_fun (x.2 g.op) ⟨f, h⟩⟩,
  left_inv := λ _, subtype.ext $ funext $ λ _, funext $ λ _, funext $ λ _, rfl,
  right_inv := λ _, by { ext _ ⟨_, _⟩, refl } }

def amalgamation'_equiv_amalgamation (P : Cᵒᵖ ⥤ Type v) (x : matching_family' P S) :
  amalgamation (matching_family'_equiv_matching_family P x) ≃ (amalgamation' x) :=
{ to_fun := λ γ,
  { val := γ.1.app _ (𝟙 X),
    property := λ d f hf,
    begin
      have := congr_fun (γ.1.naturality f.op) (𝟙 _),
      dsimp at this,
      erw ← this,
      rw comp_id,
      have q := congr_arg (λ t, nat_trans.app t (opposite.op d)) γ.2,
      dsimp at q,
      have := congr_fun q ⟨f, hf⟩,
      exact this,
    end },
  inv_fun := λ γ,
  { val :=
    { app := λ c f, P.map f.op γ.1,
      naturality' := λ c c' f, funext $ λ g,
      begin
        dsimp at g,
        dsimp,
        rw P.map_comp,
        refl,
      end },
    property :=
    begin
      ext c ⟨f, hf⟩,
      apply γ.2,
    end },
  left_inv :=
  begin
    rintro ⟨γ₁, γ₂⟩,
    ext d f,
    dsimp,
    dsimp at f,
    have := congr_fun (γ₁.naturality f.op) (𝟙 X),
    dsimp at this,
    rw [← this, comp_id],
  end,
  right_inv :=
  begin
    rintro ⟨γ₁, γ₂⟩,
    ext1,
    dsimp,
    rw P.map_id,
    refl,
  end }

def sheaf'_equiv_sheaf (J : sieve_set C) [grothendieck J] (P : Cᵒᵖ ⥤ Type v) :
  sheaf_condition J P ≅ sheaf_condition' J P :=
{ hom :=
  begin
    intros h c S γ hS,
    apply equiv.unique (amalgamation'_equiv_amalgamation _ _).symm,
    apply h _ _ _ hS,
  end,
  inv :=
  begin
    intros h c S γ hS,
    haveI := h _ _ ((matching_family'_equiv_matching_family P).symm γ) hS,
    have := equiv.unique (amalgamation'_equiv_amalgamation P ((matching_family'_equiv_matching_family P).symm γ)),
    simpa using this,
  end }

end grothendieck

end category_theory


import data.list
import tactic

universes u v w

theorem list.tfae_prf {a b : Prop} {l : list Prop} (h : list.tfae l) (ha : a ∈ l) (hb : b ∈ l) (ha_prf : a) : b :=
(h a ha b hb).mp ha_prf

lemma and_iff_right_of_left_if_right {p q : Prop} (h : p → q) : q ∧ p ↔ p :=
⟨λ h₂, h₂.right, λ h₂, ⟨h h₂, h₂⟩⟩

lemma choice_2_arg {α : Sort u} {β : Sort v} {γ : α → β → Sort w}
{r : Π (x : α) (y : β), γ x y → Prop} (h : ∀ (x : α) (y : β), ∃ (z : γ x y), r x y z) :
∃ (f : Π (x : α) (y : β), γ x y), ∀ (x : α) (y : β), r x y (f x y) :=
begin
  let γ' : (pprod α β) → Sort w := (λ z, γ z.fst z.snd),
  let r' := λ (x : pprod α β) (z : γ' x), r x.fst x.snd z,
  have h' : ∀ (x : pprod α β), ∃ z : γ' x, r' x z := (λ x, h x.fst x.snd),
  rcases classical.axiom_of_choice h' with ⟨f, hf⟩,
  let f := (λ x y, f ⟨x, y⟩),
  existsi f, intros x y, exact hf ⟨x, y⟩,
end

lemma subst_right_of_and {α : Sort u} {p : Prop} {a b c : α} (h : p → b = c) : p ∧ a = b ↔ p ∧ a = c :=
⟨ assume h₂, ⟨h₂.left, (h h₂.left) ▸ h₂.right⟩,
  assume h₂, ⟨h₂.left, (h h₂.left).symm ▸ h₂.right⟩ ⟩

lemma exists_unique_eq {α : Sort u} {β : Sort v} (f : α → β) : ∀ x : α, ∃! y : β, (λ (a : α) (b : β), b = f a) x y :=
λ x, ⟨f x, rfl, λ y, assume hy, hy⟩

lemma rel_congr_left {α : Sort u} {r : α → α → Prop} (symm : symmetric r) (trans : transitive r)
  {x y : α} (xy : r x y) {z : α} : r x z ↔ r y z :=
⟨λ xz, trans (symm xy) xz, λ yz, trans xy yz⟩

lemma iff_of_not_of_not {p : Prop} (np : ¬ p) {q : Prop} (nq : ¬ q) : p ↔ q :=
⟨λ hp, false.elim (np hp), λ hq, false.elim (nq hq)⟩

lemma ite_prop {α : Sort u} {p : α → Prop} {x y : α} (px : p x) (py : p y) {q : Prop} [h : decidable q] :
p (if q then x else y) :=
begin
  by_cases q,
    rw if_pos h, exact px,
  rw if_neg h, exact py,
end


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

! This file was ported from Lean 3 source module category_theory.extensive
! leanprover-community/mathlib commit ac3ae212f394f508df43e37aa093722fa9b65d31
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Limits.Shapes.CommSq
import Mathbin.CategoryTheory.Limits.Shapes.StrictInitial
import Mathbin.CategoryTheory.Limits.Shapes.Types
import Mathbin.Topology.Category.Top.Limits
import Mathbin.CategoryTheory.Limits.FunctorCategory

/-!

# Extensive categories

## Main definitions
- `category_theory.is_van_kampen_colimit`: A (colimit) cocone over a diagram `F : J ⥤ C` is van
  Kampen if for every cocone `c'` over the pullback of the diagram `F' : J ⥤ C'`,
  `c'` is colimiting iff `c'` is the pullback of `c`.
- `category_theory.finitary_extensive`: A category is (finitary) extensive if it has finite
  coproducts, and binary coproducts are van Kampen.

## Main Results
- `category_theory.has_strict_initial_objects_of_finitary_extensive`: The initial object
  in extensive categories is strict.
- `category_theory.finitary_extensive.mono_inr_of_is_colimit`: Coproduct injections are monic in
  extensive categories.
- `category_theory.binary_cofan.is_pullback_initial_to_of_is_van_kampen`: In extensive categories,
  sums are disjoint, i.e. the pullback of `X ⟶ X ⨿ Y` and `Y ⟶ X ⨿ Y` is the initial object.
- `category_theory.types.finitary_extensive`: The category of types is extensive.

## TODO

Show that the following are finitary extensive:
- the categories of sheaves over a site
- `Scheme`
- `AffineScheme` (`CommRingᵒᵖ`)

## References
- https://ncatlab.org/nlab/show/extensive+category
- [Carboni et al, Introduction to extensive and distributive categories][CARBONI1993145]

-/

open CategoryTheory.Limits

namespace CategoryTheory

universe v' u' v u

variable {J : Type v'} [Category.{u'} J] {C : Type u} [Category.{v} C]

/-- A natural transformation is equifibered if every commutative square of the following form is
a pullback.
```
F(X) → F(Y)
 ↓      ↓
G(X) → G(Y)
```
-/
def NatTrans.Equifibered {F G : J ⥤ C} (α : F ⟶ G) : Prop :=
  ∀ ⦃i j : J⦄ (f : i ⟶ j), IsPullback (F.map f) (α.app i) (α.app j) (G.map f)
#align category_theory.nat_trans.equifibered CategoryTheory.NatTrans.Equifibered

theorem NatTrans.equifibered_of_isIso {F G : J ⥤ C} (α : F ⟶ G) [IsIso α] : α.Equifibered :=
  fun _ _ f => IsPullback.of_vert_isIso ⟨NatTrans.naturality _ f⟩
#align category_theory.nat_trans.equifibered_of_is_iso CategoryTheory.NatTrans.equifibered_of_isIso

theorem NatTrans.Equifibered.comp {F G H : J ⥤ C} {α : F ⟶ G} {β : G ⟶ H} (hα : α.Equifibered)
    (hβ : β.Equifibered) : (α ≫ β).Equifibered := fun i j f => (hα f).paste_vert (hβ f)
#align category_theory.nat_trans.equifibered.comp CategoryTheory.NatTrans.Equifibered.comp

/-- A (colimit) cocone over a diagram `F : J ⥤ C` is universal if it is stable under pullbacks. -/
def IsUniversalColimit {F : J ⥤ C} (c : Cocone F) : Prop :=
  ∀ ⦃F' : J ⥤ C⦄ (c' : Cocone F') (α : F' ⟶ F) (f : c'.pt ⟶ c.pt)
    (h : α ≫ c.ι = c'.ι ≫ (Functor.const J).map f) (hα : α.Equifibered),
    (∀ j : J, IsPullback (c'.ι.app j) (α.app j) f (c.ι.app j)) → Nonempty (IsColimit c')
#align category_theory.is_universal_colimit CategoryTheory.IsUniversalColimit

/-- A (colimit) cocone over a diagram `F : J ⥤ C` is van Kampen if for every cocone `c'` over the
pullback of the diagram `F' : J ⥤ C'`, `c'` is colimiting iff `c'` is the pullback of `c`.

TODO: Show that this is iff the functor `C ⥤ Catᵒᵖ` sending `x` to `C/x` preserves it.
TODO: Show that this is iff the inclusion functor `C ⥤ Span(C)` preserves it.
-/
def IsVanKampenColimit {F : J ⥤ C} (c : Cocone F) : Prop :=
  ∀ ⦃F' : J ⥤ C⦄ (c' : Cocone F') (α : F' ⟶ F) (f : c'.pt ⟶ c.pt)
    (h : α ≫ c.ι = c'.ι ≫ (Functor.const J).map f) (hα : α.Equifibered),
    Nonempty (IsColimit c') ↔ ∀ j : J, IsPullback (c'.ι.app j) (α.app j) f (c.ι.app j)
#align category_theory.is_van_kampen_colimit CategoryTheory.IsVanKampenColimit

theorem IsVanKampenColimit.is_universal {F : J ⥤ C} {c : Cocone F} (H : IsVanKampenColimit c) :
    IsUniversalColimit c := fun _ c' α f h hα => (H c' α f h hα).mpr
#align category_theory.is_van_kampen_colimit.is_universal CategoryTheory.IsVanKampenColimit.is_universal

/-- A van Kampen colimit is a colimit. -/
noncomputable def IsVanKampenColimit.isColimit {F : J ⥤ C} {c : Cocone F}
    (h : IsVanKampenColimit c) : IsColimit c :=
  by
  refine'
    ((h c (𝟙 F) (𝟙 c.X : _) (by rw [Functor.map_id, category.comp_id, category.id_comp])
            (nat_trans.equifibered_of_is_iso _)).mpr
        fun j => _).some
  haveI : is_iso (𝟙 c.X) := inferInstance
  exact is_pullback.of_vert_is_iso ⟨by erw [nat_trans.id_app, category.comp_id, category.id_comp]⟩
#align category_theory.is_van_kampen_colimit.is_colimit CategoryTheory.IsVanKampenColimit.isColimit

theorem IsInitial.isVanKampenColimit [HasStrictInitialObjects C] {X : C} (h : IsInitial X) :
    IsVanKampenColimit (asEmptyCocone X) :=
  by
  intro F' c' α f hf hα
  have : F' = functor.empty C := by apply functor.hext <;> rintro ⟨⟨⟩⟩
  subst this
  haveI := h.is_iso_to f
  refine'
    ⟨by rintro _ ⟨⟨⟩⟩, fun _ =>
      ⟨is_colimit.of_iso_colimit h (cocones.ext (as_iso f).symm <| by rintro ⟨⟨⟩⟩)⟩⟩
#align category_theory.is_initial.is_van_kampen_colimit CategoryTheory.IsInitial.isVanKampenColimit

section Extensive

variable {X Y : C}

/-- A category is (finitary) extensive if it has finite coproducts,
and binary coproducts are van Kampen.

TODO: Show that this is iff all finite coproducts are van Kampen. -/
class FinitaryExtensive (C : Type u) [Category.{v} C] : Prop where
  [HasFiniteCoproducts : HasFiniteCoproducts C]
  van_kampen' : ∀ {X Y : C} (c : BinaryCofan X Y), IsColimit c → IsVanKampenColimit c
#align category_theory.finitary_extensive CategoryTheory.FinitaryExtensive

attribute [instance] finitary_extensive.has_finite_coproducts

theorem FinitaryExtensive.van_kampen [FinitaryExtensive C] {F : Discrete WalkingPair ⥤ C}
    (c : Cocone F) (hc : IsColimit c) : IsVanKampenColimit c :=
  by
  let X := F.obj ⟨walking_pair.left⟩
  let Y := F.obj ⟨walking_pair.right⟩
  have : F = pair X Y := by
    apply functor.hext
    · rintro ⟨⟨⟩⟩ <;> rfl
    · rintro ⟨⟨⟩⟩ ⟨j⟩ ⟨⟨rfl : _ = j⟩⟩ <;> simpa
  clear_value X Y
  subst this
  exact finitary_extensive.van_kampen' c hc
#align category_theory.finitary_extensive.van_kampen CategoryTheory.FinitaryExtensive.van_kampen

theorem map_pair_equifibered {F F' : Discrete WalkingPair ⥤ C} (α : F ⟶ F') : α.Equifibered :=
  by
  rintro ⟨⟨⟩⟩ ⟨j⟩ ⟨⟨rfl : _ = j⟩⟩
  all_goals
    dsimp; simp only [discrete.functor_map_id]
    exact is_pullback.of_horiz_is_iso ⟨by simp only [category.comp_id, category.id_comp]⟩
#align category_theory.map_pair_equifibered CategoryTheory.map_pair_equifibered

theorem BinaryCofan.is_van_kampen_iff (c : BinaryCofan X Y) :
    IsVanKampenColimit c ↔
      ∀ {X' Y' : C} (c' : BinaryCofan X' Y') (αX : X' ⟶ X) (αY : Y' ⟶ Y) (f : c'.pt ⟶ c.pt)
        (hαX : αX ≫ c.inl = c'.inl ≫ f) (hαY : αY ≫ c.inr = c'.inr ≫ f),
        Nonempty (IsColimit c') ↔ IsPullback c'.inl αX f c.inl ∧ IsPullback c'.inr αY f c.inr :=
  by
  constructor
  · introv H hαX hαY
    rw [H c' (map_pair αX αY) f (by ext ⟨⟨⟩⟩ <;> dsimp <;> assumption) (map_pair_equifibered _)]
    constructor
    · intro H
      exact ⟨H _, H _⟩
    · rintro H ⟨⟨⟩⟩
      exacts[H.1, H.2]
  · introv H F' hα h
    let X' := F'.obj ⟨walking_pair.left⟩
    let Y' := F'.obj ⟨walking_pair.right⟩
    have : F' = pair X' Y' := by
      apply functor.hext
      · rintro ⟨⟨⟩⟩ <;> rfl
      · rintro ⟨⟨⟩⟩ ⟨j⟩ ⟨⟨rfl : _ = j⟩⟩ <;> simpa
    clear_value X' Y'
    subst this
    change binary_cofan X' Y' at c'
    rw [H c' _ _ _ (nat_trans.congr_app hα ⟨walking_pair.left⟩)
        (nat_trans.congr_app hα ⟨walking_pair.right⟩)]
    constructor
    · rintro H ⟨⟨⟩⟩
      exacts[H.1, H.2]
    · intro H
      exact ⟨H _, H _⟩
#align category_theory.binary_cofan.is_van_kampen_iff CategoryTheory.BinaryCofan.is_van_kampen_iff

theorem BinaryCofan.is_van_kampen_mk {X Y : C} (c : BinaryCofan X Y)
    (cofans : ∀ X Y : C, BinaryCofan X Y) (colimits : ∀ X Y, IsColimit (cofans X Y))
    (cones : ∀ {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z), PullbackCone f g)
    (limits : ∀ {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z), IsLimit (cones f g))
    (h₁ :
      ∀ {X' Y' : C} (αX : X' ⟶ X) (αY : Y' ⟶ Y) (f : (cofans X' Y').pt ⟶ c.pt)
        (hαX : αX ≫ c.inl = (cofans X' Y').inl ≫ f) (hαY : αY ≫ c.inr = (cofans X' Y').inr ≫ f),
        IsPullback (cofans X' Y').inl αX f c.inl ∧ IsPullback (cofans X' Y').inr αY f c.inr)
    (h₂ :
      ∀ {Z : C} (f : Z ⟶ c.pt),
        IsColimit (BinaryCofan.mk (cones f c.inl).fst (cones f c.inr).fst)) :
    IsVanKampenColimit c := by
  rw [binary_cofan.is_van_kampen_iff]
  introv hX hY
  constructor
  · rintro ⟨h⟩
    let e := h.cocone_point_unique_up_to_iso (colimits _ _)
    obtain ⟨hl, hr⟩ := h₁ αX αY (e.inv ≫ f) (by simp [hX]) (by simp [hY])
    constructor
    · rw [← category.id_comp αX, ← iso.hom_inv_id_assoc e f]
      have : c'.inl ≫ e.hom = 𝟙 X' ≫ (cofans X' Y').inl :=
        by
        dsimp
        simp
      haveI : is_iso (𝟙 X') := inferInstance
      exact (is_pullback.of_vert_is_iso ⟨this⟩).paste_vert hl
    · rw [← category.id_comp αY, ← iso.hom_inv_id_assoc e f]
      have : c'.inr ≫ e.hom = 𝟙 Y' ≫ (cofans X' Y').inr :=
        by
        dsimp
        simp
      haveI : is_iso (𝟙 Y') := inferInstance
      exact (is_pullback.of_vert_is_iso ⟨this⟩).paste_vert hr
  · rintro ⟨H₁, H₂⟩
    refine' ⟨is_colimit.of_iso_colimit _ <| (iso_binary_cofan_mk _).symm⟩
    let e₁ : X' ≅ _ := H₁.is_limit.cone_point_unique_up_to_iso (limits _ _)
    let e₂ : Y' ≅ _ := H₂.is_limit.cone_point_unique_up_to_iso (limits _ _)
    have he₁ : c'.inl = e₁.hom ≫ (cones f c.inl).fst := by simp
    have he₂ : c'.inr = e₂.hom ≫ (cones f c.inr).fst := by simp
    rw [he₁, he₂]
    apply binary_cofan.is_colimit_comp_right_iso (binary_cofan.mk _ _)
    apply binary_cofan.is_colimit_comp_left_iso (binary_cofan.mk _ _)
    exact h₂ f
#align category_theory.binary_cofan.is_van_kampen_mk CategoryTheory.BinaryCofan.is_van_kampen_mk

theorem BinaryCofan.mono_inr_of_is_van_kampen [HasInitial C] {X Y : C} {c : BinaryCofan X Y}
    (h : IsVanKampenColimit c) : Mono c.inr :=
  by
  refine' pullback_cone.mono_of_is_limit_mk_id_id _ (is_pullback.is_limit _)
  refine'
    (h (binary_cofan.mk (initial.to Y) (𝟙 Y)) (map_pair (initial.to X) (𝟙 Y)) c.inr _
          (map_pair_equifibered _)).mp
      ⟨_⟩ ⟨walking_pair.right⟩
  · ext ⟨⟨⟩⟩ <;> dsimp <;> simp
  ·
    exact
      ((binary_cofan.is_colimit_iff_is_iso_inr initial_is_initial _).mpr
          (by
            dsimp
            infer_instance)).some
#align category_theory.binary_cofan.mono_inr_of_is_van_kampen CategoryTheory.BinaryCofan.mono_inr_of_is_van_kampen

theorem FinitaryExtensive.mono_inr_of_isColimit [FinitaryExtensive C] {c : BinaryCofan X Y}
    (hc : IsColimit c) : Mono c.inr :=
  BinaryCofan.mono_inr_of_is_van_kampen (FinitaryExtensive.van_kampen c hc)
#align category_theory.finitary_extensive.mono_inr_of_is_colimit CategoryTheory.FinitaryExtensive.mono_inr_of_isColimit

theorem FinitaryExtensive.mono_inl_of_isColimit [FinitaryExtensive C] {c : BinaryCofan X Y}
    (hc : IsColimit c) : Mono c.inl :=
  FinitaryExtensive.mono_inr_of_isColimit (BinaryCofan.isColimitFlip hc)
#align category_theory.finitary_extensive.mono_inl_of_is_colimit CategoryTheory.FinitaryExtensive.mono_inl_of_isColimit

instance [FinitaryExtensive C] (X Y : C) : Mono (coprod.inl : X ⟶ X ⨿ Y) :=
  (FinitaryExtensive.mono_inl_of_isColimit (coprodIsCoprod X Y) : _)

instance [FinitaryExtensive C] (X Y : C) : Mono (coprod.inr : Y ⟶ X ⨿ Y) :=
  (FinitaryExtensive.mono_inr_of_isColimit (coprodIsCoprod X Y) : _)

theorem BinaryCofan.isPullback_initial_to_of_is_van_kampen [HasInitial C] {c : BinaryCofan X Y}
    (h : IsVanKampenColimit c) : IsPullback (initial.to _) (initial.to _) c.inl c.inr :=
  by
  refine'
    ((h (binary_cofan.mk (initial.to Y) (𝟙 Y)) (map_pair (initial.to X) (𝟙 Y)) c.inr _
            (map_pair_equifibered _)).mp
        ⟨_⟩ ⟨walking_pair.left⟩).flip
  · ext ⟨⟨⟩⟩ <;> dsimp <;> simp
  ·
    exact
      ((binary_cofan.is_colimit_iff_is_iso_inr initial_is_initial _).mpr
          (by
            dsimp
            infer_instance)).some
#align category_theory.binary_cofan.is_pullback_initial_to_of_is_van_kampen CategoryTheory.BinaryCofan.isPullback_initial_to_of_is_van_kampen

theorem FinitaryExtensive.isPullback_initial_to_binaryCofan [FinitaryExtensive C]
    {c : BinaryCofan X Y} (hc : IsColimit c) :
    IsPullback (initial.to _) (initial.to _) c.inl c.inr :=
  BinaryCofan.isPullback_initial_to_of_is_van_kampen (FinitaryExtensive.van_kampen c hc)
#align category_theory.finitary_extensive.is_pullback_initial_to_binary_cofan CategoryTheory.FinitaryExtensive.isPullback_initial_to_binaryCofan

theorem has_strict_initial_of_is_universal [HasInitial C]
    (H : IsUniversalColimit (BinaryCofan.mk (𝟙 (⊥_ C)) (𝟙 (⊥_ C)))) : HasStrictInitialObjects C :=
  hasStrictInitialObjects_of_initial_is_strict
    (by
      intro A f
      suffices is_colimit (binary_cofan.mk (𝟙 A) (𝟙 A))
        by
        obtain ⟨l, h₁, h₂⟩ := limits.binary_cofan.is_colimit.desc' this (f ≫ initial.to A) (𝟙 A)
        rcases(category.id_comp _).symm.trans h₂ with rfl
        exact ⟨⟨_, ((category.id_comp _).symm.trans h₁).symm, initial_is_initial.hom_ext _ _⟩⟩
      refine'
        (H (binary_cofan.mk (𝟙 _) (𝟙 _)) (map_pair f f) f (by ext ⟨⟨⟩⟩ <;> dsimp <;> simp)
            (map_pair_equifibered _) _).some
      rintro ⟨⟨⟩⟩ <;> dsimp <;>
        exact is_pullback.of_horiz_is_iso ⟨(category.id_comp _).trans (category.comp_id _).symm⟩)
#align category_theory.has_strict_initial_of_is_universal CategoryTheory.has_strict_initial_of_is_universal

instance (priority := 100) hasStrictInitialObjects_of_finitaryExtensive [FinitaryExtensive C] :
    HasStrictInitialObjects C :=
  has_strict_initial_of_is_universal
    (FinitaryExtensive.van_kampen _
        ((BinaryCofan.isColimit_iff_isIso_inr initialIsInitial _).mpr
            (by
              dsimp
              infer_instance)).some).is_universal
#align category_theory.has_strict_initial_objects_of_finitary_extensive CategoryTheory.hasStrictInitialObjects_of_finitaryExtensive

theorem finitaryExtensive_iff_of_isTerminal (C : Type u) [Category.{v} C] [HasFiniteCoproducts C]
    (T : C) (HT : IsTerminal T) (c₀ : BinaryCofan T T) (hc₀ : IsColimit c₀) :
    FinitaryExtensive C ↔ IsVanKampenColimit c₀ :=
  by
  refine' ⟨fun H => H.2 c₀ hc₀, fun H => _⟩
  constructor
  simp_rw [binary_cofan.is_van_kampen_iff] at H⊢
  intro X Y c hc X' Y' c' αX αY f hX hY
  obtain ⟨d, hd, hd'⟩ :=
    limits.binary_cofan.is_colimit.desc' hc (HT.from _ ≫ c₀.inl) (HT.from _ ≫ c₀.inr)
  rw [H c' (αX ≫ HT.from _) (αY ≫ HT.from _) (f ≫ d) (by rw [← reassoc_of hX, hd, category.assoc])
      (by rw [← reassoc_of hY, hd', category.assoc])]
  obtain ⟨hl, hr⟩ := (H c (HT.from _) (HT.from _) d hd.symm hd'.symm).mp ⟨hc⟩
  rw [hl.paste_vert_iff hX.symm, hr.paste_vert_iff hY.symm]
#align category_theory.finitary_extensive_iff_of_is_terminal CategoryTheory.finitaryExtensive_iff_of_isTerminal

instance types.finitaryExtensive : FinitaryExtensive (Type u) :=
  by
  rw [finitary_extensive_iff_of_is_terminal (Type u) PUnit types.is_terminal_punit _
      (types.binary_coproduct_colimit _ _)]
  apply
    binary_cofan.is_van_kampen_mk _ _ (fun X Y => types.binary_coproduct_colimit X Y) _
      fun X Y Z f g => (limits.types.pullback_limit_cone f g).2
  · intros
    constructor
    · refine' ⟨⟨hαX.symm⟩, ⟨pullback_cone.is_limit_aux' _ _⟩⟩
      intro s
      have : ∀ x, ∃! y, s.fst x = Sum.inl y := by
        intro x
        cases h : s.fst x
        · simp_rw [sum.inl_injective.eq_iff]
          exact exists_unique_eq'
        · apply_fun f  at h
          cases ((congr_fun s.condition x).symm.trans h).trans (congr_fun hαY val : _).symm
      delta ExistsUnique at this
      choose l hl hl'
      exact
        ⟨l, (funext hl).symm, types.is_terminal_punit.hom_ext _ _, fun l' h₁ h₂ =>
          funext fun x => hl' x (l' x) (congr_fun h₁ x).symm⟩
    · refine' ⟨⟨hαY.symm⟩, ⟨pullback_cone.is_limit_aux' _ _⟩⟩
      intro s
      dsimp
      have : ∀ x, ∃! y, s.fst x = Sum.inr y := by
        intro x
        cases h : s.fst x
        · apply_fun f  at h
          cases ((congr_fun s.condition x).symm.trans h).trans (congr_fun hαX val : _).symm
        · simp_rw [sum.inr_injective.eq_iff]
          exact exists_unique_eq'
      delta ExistsUnique at this
      choose l hl hl'
      exact
        ⟨l, (funext hl).symm, types.is_terminal_punit.hom_ext _ _, fun l' h₁ h₂ =>
          funext fun x => hl' x (l' x) (congr_fun h₁ x).symm⟩
  · intro Z f
    dsimp [limits.types.binary_coproduct_cocone]
    delta types.pullback_obj
    have : ∀ x, f x = Sum.inl PUnit.unit ∨ f x = Sum.inr PUnit.unit :=
      by
      intro x
      rcases f x with (⟨⟨⟩⟩ | ⟨⟨⟩⟩)
      exacts[Or.inl rfl, Or.inr rfl]
    let eX : { p : Z × PUnit // f p.fst = Sum.inl p.snd } ≃ { x : Z // f x = Sum.inl PUnit.unit } :=
      ⟨fun p => ⟨p.1.1, by convert p.2⟩, fun x => ⟨⟨_, _⟩, x.2⟩, fun _ => by ext <;> rfl, fun _ =>
        by ext <;> rfl⟩
    let eY : { p : Z × PUnit // f p.fst = Sum.inr p.snd } ≃ { x : Z // f x = Sum.inr PUnit.unit } :=
      ⟨fun p => ⟨p.1.1, p.2.trans (congr_arg Sum.inr <| Subsingleton.elim _ _)⟩, fun x =>
        ⟨⟨_, _⟩, x.2⟩, fun _ => by ext <;> rfl, fun _ => by ext <;> rfl⟩
    fapply binary_cofan.is_colimit_mk
    ·
      exact fun s x =>
        dite _ (fun h => s.inl <| eX.symm ⟨x, h⟩) fun h =>
          s.inr <| eY.symm ⟨x, (this x).resolve_left h⟩
    · intro s
      ext ⟨⟨x, ⟨⟩⟩, _⟩
      dsimp
      split_ifs <;> rfl
    · intro s
      ext ⟨⟨x, ⟨⟩⟩, hx⟩
      dsimp
      split_ifs
      · cases h.symm.trans hx
      · rfl
    · intro s m e₁ e₂
      ext x
      split_ifs
      · rw [← e₁]
        rfl
      · rw [← e₂]
        rfl
#align category_theory.types.finitary_extensive CategoryTheory.types.finitaryExtensive

section TopCat

/-- (Implementation) An auxiliary lemma for the proof that `Top` is finitary extensive. -/
def finitaryExtensiveTopAux (Z : TopCat.{u}) (f : Z ⟶ TopCat.of (Sum PUnit.{u + 1} PUnit.{u + 1})) :
    IsColimit
      (BinaryCofan.mk
        (TopCat.pullbackFst f (TopCat.binaryCofan (TopCat.of PUnit) (TopCat.of PUnit)).inl)
        (TopCat.pullbackFst f (TopCat.binaryCofan (TopCat.of PUnit) (TopCat.of PUnit)).inr)) :=
  by
  have : ∀ x, f x = Sum.inl PUnit.unit ∨ f x = Sum.inr PUnit.unit :=
    by
    intro x
    rcases f x with (⟨⟨⟩⟩ | ⟨⟨⟩⟩)
    exacts[Or.inl rfl, Or.inr rfl]
  let eX : { p : Z × PUnit // f p.fst = Sum.inl p.snd } ≃ { x : Z // f x = Sum.inl PUnit.unit } :=
    ⟨fun p => ⟨p.1.1, p.2.trans (congr_arg Sum.inl <| Subsingleton.elim _ _)⟩, fun x =>
      ⟨⟨_, _⟩, x.2⟩, fun _ => by ext <;> rfl, fun _ => by ext <;> rfl⟩
  let eY : { p : Z × PUnit // f p.fst = Sum.inr p.snd } ≃ { x : Z // f x = Sum.inr PUnit.unit } :=
    ⟨fun p => ⟨p.1.1, p.2.trans (congr_arg Sum.inr <| Subsingleton.elim _ _)⟩, fun x =>
      ⟨⟨_, _⟩, x.2⟩, fun _ => by ext <;> rfl, fun _ => by ext <;> rfl⟩
  fapply binary_cofan.is_colimit_mk
  · refine' fun s =>
      ⟨fun x =>
        dite _ (fun h => s.inl <| eX.symm ⟨x, h⟩) fun h =>
          s.inr <| eY.symm ⟨x, (this x).resolve_left h⟩,
        _⟩
    rw [continuous_iff_continuousAt]
    intro x
    by_cases f x = Sum.inl PUnit.unit
    · revert h x
      apply (IsOpen.continuousOn_iff _).mp
      · rw [continuousOn_iff_continuous_restrict]
        convert_to Continuous fun x : { x | f x = Sum.inl PUnit.unit } =>
            s.inl ⟨(x, PUnit.unit), x.2⟩
        · ext ⟨x, hx⟩
          exact dif_pos hx
        continuity
      · convert f.2.1 _ openEmbedding_inl.open_range
        ext x
        exact
          ⟨fun h => ⟨_, h.symm⟩, fun ⟨e, h⟩ =>
            h.symm.trans (congr_arg Sum.inl <| Subsingleton.elim _ _)⟩
    · revert h x
      apply (IsOpen.continuousOn_iff _).mp
      · rw [continuousOn_iff_continuous_restrict]
        convert_to Continuous fun x : { x | f x ≠ Sum.inl PUnit.unit } =>
            s.inr ⟨(x, PUnit.unit), (this _).resolve_left x.2⟩
        · ext ⟨x, hx⟩
          exact dif_neg hx
        continuity
      · convert f.2.1 _ openEmbedding_inr.open_range
        ext x
        change f x ≠ Sum.inl PUnit.unit ↔ f x ∈ Set.range Sum.inr
        trans f x = Sum.inr PUnit.unit
        ·
          rcases f x with (⟨⟨⟩⟩ | ⟨⟨⟩⟩) <;>
            simp only [iff_self_iff, eq_self_iff_true, not_true, Ne.def, not_false_iff]
        ·
          exact
            ⟨fun h => ⟨_, h.symm⟩, fun ⟨e, h⟩ =>
              h.symm.trans (congr_arg Sum.inr <| Subsingleton.elim _ _)⟩
  · intro s
    ext ⟨⟨x, ⟨⟩⟩, _⟩
    change dite _ _ _ = _
    split_ifs <;> rfl
  · intro s
    ext ⟨⟨x, ⟨⟩⟩, hx⟩
    change dite _ _ _ = _
    split_ifs
    · cases h.symm.trans hx
    · rfl
  · intro s m e₁ e₂
    ext x
    change m x = dite _ _ _
    split_ifs
    · rw [← e₁]
      rfl
    · rw [← e₂]
      rfl
#align category_theory.finitary_extensive_Top_aux CategoryTheory.finitaryExtensiveTopAux

instance : FinitaryExtensive TopCat.{u} :=
  by
  rw [finitary_extensive_iff_of_is_terminal TopCat.{u} _ TopCat.isTerminalPunit _
      (TopCat.binaryCofanIsColimit _ _)]
  apply
    binary_cofan.is_van_kampen_mk _ _ (fun X Y => TopCat.binaryCofanIsColimit X Y) _
      fun X Y Z f g => TopCat.pullbackConeIsLimit f g
  · intros
    constructor
    · refine' ⟨⟨hαX.symm⟩, ⟨pullback_cone.is_limit_aux' _ _⟩⟩
      intro s
      have : ∀ x, ∃! y, s.fst x = Sum.inl y := by
        intro x
        cases h : s.fst x
        · simp_rw [sum.inl_injective.eq_iff]
          exact exists_unique_eq'
        · apply_fun f  at h
          cases
            ((concrete_category.congr_hom s.condition x).symm.trans h).trans
              (concrete_category.congr_hom hαY val : _).symm
      delta ExistsUnique at this
      choose l hl hl'
      refine'
        ⟨⟨l, _⟩, ContinuousMap.ext fun a => (hl a).symm, Top.is_terminal_punit.hom_ext _ _,
          fun l' h₁ h₂ =>
          ContinuousMap.ext fun x => hl' x (l' x) (concrete_category.congr_hom h₁ x).symm⟩
      apply embedding_inl.to_inducing.continuous_iff.mpr
      convert s.fst.2 using 1
      exact (funext hl).symm
    · refine' ⟨⟨hαY.symm⟩, ⟨pullback_cone.is_limit_aux' _ _⟩⟩
      intro s
      dsimp
      have : ∀ x, ∃! y, s.fst x = Sum.inr y := by
        intro x
        cases h : s.fst x
        · apply_fun f  at h
          cases
            ((concrete_category.congr_hom s.condition x).symm.trans h).trans
              (concrete_category.congr_hom hαX val : _).symm
        · simp_rw [sum.inr_injective.eq_iff]
          exact exists_unique_eq'
      delta ExistsUnique at this
      choose l hl hl'
      refine'
        ⟨⟨l, _⟩, ContinuousMap.ext fun a => (hl a).symm, Top.is_terminal_punit.hom_ext _ _,
          fun l' h₁ h₂ =>
          ContinuousMap.ext fun x => hl' x (l' x) (concrete_category.congr_hom h₁ x).symm⟩
      apply embedding_inr.to_inducing.continuous_iff.mpr
      convert s.fst.2 using 1
      exact (funext hl).symm
  · intro Z f
    exact finitary_extensive_Top_aux Z f

end TopCat

section Functor

universe v'' u''

variable {D : Type u''} [Category.{v''} D]

theorem NatTrans.Equifibered.whiskerRight {F G : J ⥤ C} {α : F ⟶ G} (hα : α.Equifibered) (H : C ⥤ D)
    [PreservesLimitsOfShape WalkingCospan H] : (whiskerRight α H).Equifibered := fun i j f =>
  (hα f).map H
#align category_theory.nat_trans.equifibered.whisker_right CategoryTheory.NatTrans.Equifibered.whiskerRight

theorem IsVanKampenColimit.of_iso {F : J ⥤ C} {c c' : Cocone F} (H : IsVanKampenColimit c)
    (e : c ≅ c') : IsVanKampenColimit c' :=
  by
  intro F' c'' α f h hα
  have : c'.ι ≫ (Functor.Const J).map e.inv.hom = c.ι :=
    by
    ext j
    exact e.inv.2 j
  rw [H c'' α (f ≫ e.inv.1) (by rw [functor.map_comp, ← reassoc_of h, this]) hα]
  apply forall_congr'
  intro j
  conv_lhs => rw [← category.comp_id (α.app j)]
  haveI : is_iso e.inv.hom := functor.map_is_iso (cocones.forget _) e.inv
  exact (is_pullback.of_vert_is_iso ⟨by simp⟩).paste_vert_iff (nat_trans.congr_app h j).symm
#align category_theory.is_van_kampen_colimit.of_iso CategoryTheory.IsVanKampenColimit.of_iso

theorem IsVanKampenColimit.of_map {D : Type _} [Category D] (G : C ⥤ D) {F : J ⥤ C} {c : Cocone F}
    [PreservesLimitsOfShape WalkingCospan G] [ReflectsLimitsOfShape WalkingCospan G]
    [PreservesColimitsOfShape J G] [ReflectsColimitsOfShape J G]
    (H : IsVanKampenColimit (G.mapCocone c)) : IsVanKampenColimit c :=
  by
  intro F' c' α f h hα
  refine'
    (Iff.trans _
          (H (G.map_cocone c') (whisker_right α G) (G.map f)
            (by
              ext j
              simpa using G.congr_map (nat_trans.congr_app h j))
            (hα.whisker_right G))).trans
      (forall_congr' fun j => _)
  · exact ⟨fun h => ⟨is_colimit_of_preserves G h.some⟩, fun h => ⟨is_colimit_of_reflects G h.some⟩⟩
  · exact is_pullback.map_iff G (nat_trans.congr_app h.symm j)
#align category_theory.is_van_kampen_colimit.of_map CategoryTheory.IsVanKampenColimit.of_map

theorem isVanKampenColimit_of_evaluation [HasPullbacks D] [HasColimitsOfShape J D] (F : J ⥤ C ⥤ D)
    (c : Cocone F) (hc : ∀ x : C, IsVanKampenColimit (((evaluation C D).obj x).mapCocone c)) :
    IsVanKampenColimit c := by
  intro F' c' α f e hα
  have := fun x =>
    hc x (((evaluation C D).obj x).mapCocone c') (whisker_right α _)
      (((evaluation C D).obj x).map f)
      (by
        ext y
        dsimp
        exact nat_trans.congr_app (nat_trans.congr_app e y) x)
      (hα.whisker_right _)
  constructor
  · rintro ⟨hc'⟩ j
    refine' ⟨⟨(nat_trans.congr_app e j).symm⟩, ⟨evaluation_jointly_reflects_limits _ _⟩⟩
    refine' fun x => (is_limit_map_cone_pullback_cone_equiv _ _).symm _
    exact ((this x).mp ⟨preserves_colimit.preserves hc'⟩ _).IsLimit
  ·
    exact fun H =>
      ⟨evaluation_jointly_reflects_colimits _ fun x =>
          ((this x).mpr fun j => (H j).map ((evaluation C D).obj x)).some⟩
#align category_theory.is_van_kampen_colimit_of_evaluation CategoryTheory.isVanKampenColimit_of_evaluation

instance [HasPullbacks C] [FinitaryExtensive C] : FinitaryExtensive (D ⥤ C) :=
  haveI : has_finite_coproducts (D ⥤ C) := ⟨fun n => limits.functor_category_has_colimits_of_shape⟩
  ⟨fun X Y c hc =>
    is_van_kampen_colimit_of_evaluation _ c fun x =>
      finitary_extensive.van_kampen _ <| preserves_colimit.preserves hc⟩

theorem finitaryExtensive_of_preserves_and_reflects (F : C ⥤ D) [FinitaryExtensive D]
    [HasFiniteCoproducts C] [PreservesLimitsOfShape WalkingCospan F]
    [ReflectsLimitsOfShape WalkingCospan F] [PreservesColimitsOfShape (Discrete WalkingPair) F]
    [ReflectsColimitsOfShape (Discrete WalkingPair) F] : FinitaryExtensive C :=
  ⟨fun X Y c hc => (FinitaryExtensive.van_kampen _ (isColimitOfPreserves F hc)).of_map F⟩
#align category_theory.finitary_extensive_of_preserves_and_reflects CategoryTheory.finitaryExtensive_of_preserves_and_reflects

theorem finitaryExtensive_of_preserves_and_reflects_isomorphism (F : C ⥤ D) [FinitaryExtensive D]
    [HasFiniteCoproducts C] [HasPullbacks C] [PreservesLimitsOfShape WalkingCospan F]
    [PreservesColimitsOfShape (Discrete WalkingPair) F] [ReflectsIsomorphisms F] :
    FinitaryExtensive C :=
  by
  haveI : reflects_limits_of_shape walking_cospan F :=
    reflects_limits_of_shape_of_reflects_isomorphisms
  haveI : reflects_colimits_of_shape (discrete walking_pair) F :=
    reflects_colimits_of_shape_of_reflects_isomorphisms
  exact finitary_extensive_of_preserves_and_reflects F
#align category_theory.finitary_extensive_of_preserves_and_reflects_isomorphism CategoryTheory.finitaryExtensive_of_preserves_and_reflects_isomorphism

end Functor

end Extensive

end CategoryTheory


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Scott Morrison

! This file was ported from Lean 3 source module category_theory.epi_mono
! leanprover-community/mathlib commit e97cf15cd1aec9bd5c193b2ffac5a6dc9118912b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Opposites
import Mathbin.CategoryTheory.Groupoid

/-!
# Facts about epimorphisms and monomorphisms.

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

The definitions of `epi` and `mono` are in `category_theory.category`,
since they are used by some lemmas for `iso`, which is used everywhere.
-/

universe v₁ v₂ u₁ u₂

namespace CategoryTheory

variable {C : Type u₁} [Category.{v₁} C]

#print CategoryTheory.unop_mono_of_epi /-
instance unop_mono_of_epi {A B : Cᵒᵖ} (f : A ⟶ B) [Epi f] : Mono f.unop :=
  ⟨fun Z g h eq => Quiver.Hom.op_inj ((cancel_epi f).1 (Quiver.Hom.unop_inj Eq))⟩
#align category_theory.unop_mono_of_epi CategoryTheory.unop_mono_of_epi
-/

#print CategoryTheory.unop_epi_of_mono /-
instance unop_epi_of_mono {A B : Cᵒᵖ} (f : A ⟶ B) [Mono f] : Epi f.unop :=
  ⟨fun Z g h eq => Quiver.Hom.op_inj ((cancel_mono f).1 (Quiver.Hom.unop_inj Eq))⟩
#align category_theory.unop_epi_of_mono CategoryTheory.unop_epi_of_mono
-/

#print CategoryTheory.op_mono_of_epi /-
instance op_mono_of_epi {A B : C} (f : A ⟶ B) [Epi f] : Mono f.op :=
  ⟨fun Z g h eq => Quiver.Hom.unop_inj ((cancel_epi f).1 (Quiver.Hom.op_inj Eq))⟩
#align category_theory.op_mono_of_epi CategoryTheory.op_mono_of_epi
-/

#print CategoryTheory.op_epi_of_mono /-
instance op_epi_of_mono {A B : C} (f : A ⟶ B) [Mono f] : Epi f.op :=
  ⟨fun Z g h eq => Quiver.Hom.unop_inj ((cancel_mono f).1 (Quiver.Hom.op_inj Eq))⟩
#align category_theory.op_epi_of_mono CategoryTheory.op_epi_of_mono
-/

#print CategoryTheory.SplitMono /-
/-- A split monomorphism is a morphism `f : X ⟶ Y` with a given retraction `retraction f : Y ⟶ X`
such that `f ≫ retraction f = 𝟙 X`.

Every split monomorphism is a monomorphism.
-/
@[ext, nolint has_nonempty_instance]
structure SplitMono {X Y : C} (f : X ⟶ Y) where
  retraction : Y ⟶ X
  id' : f ≫ retraction = 𝟙 X := by obviously
#align category_theory.split_mono CategoryTheory.SplitMono
-/

restate_axiom split_mono.id'

attribute [simp, reassoc.1] split_mono.id

#print CategoryTheory.IsSplitMono /-
/-- `is_split_mono f` is the assertion that `f` admits a retraction -/
class IsSplitMono {X Y : C} (f : X ⟶ Y) : Prop where
  exists_splitMono : Nonempty (SplitMono f)
#align category_theory.is_split_mono CategoryTheory.IsSplitMono
-/

#print CategoryTheory.IsSplitMono.mk' /-
/-- A constructor for `is_split_mono f` taking a `split_mono f` as an argument -/
theorem IsSplitMono.mk' {X Y : C} {f : X ⟶ Y} (sm : SplitMono f) : IsSplitMono f :=
  ⟨Nonempty.intro sm⟩
#align category_theory.is_split_mono.mk' CategoryTheory.IsSplitMono.mk'
-/

#print CategoryTheory.SplitEpi /-
/-- A split epimorphism is a morphism `f : X ⟶ Y` with a given section `section_ f : Y ⟶ X`
such that `section_ f ≫ f = 𝟙 Y`.
(Note that `section` is a reserved keyword, so we append an underscore.)

Every split epimorphism is an epimorphism.
-/
@[ext, nolint has_nonempty_instance]
structure SplitEpi {X Y : C} (f : X ⟶ Y) where
  section_ : Y ⟶ X
  id' : section_ ≫ f = 𝟙 Y := by obviously
#align category_theory.split_epi CategoryTheory.SplitEpi
-/

restate_axiom split_epi.id'

attribute [simp, reassoc.1] split_epi.id

#print CategoryTheory.IsSplitEpi /-
/-- `is_split_epi f` is the assertion that `f` admits a section -/
class IsSplitEpi {X Y : C} (f : X ⟶ Y) : Prop where
  exists_splitEpi : Nonempty (SplitEpi f)
#align category_theory.is_split_epi CategoryTheory.IsSplitEpi
-/

#print CategoryTheory.IsSplitEpi.mk' /-
/-- A constructor for `is_split_epi f` taking a `split_epi f` as an argument -/
theorem IsSplitEpi.mk' {X Y : C} {f : X ⟶ Y} (se : SplitEpi f) : IsSplitEpi f :=
  ⟨Nonempty.intro se⟩
#align category_theory.is_split_epi.mk' CategoryTheory.IsSplitEpi.mk'
-/

#print CategoryTheory.retraction /-
/-- The chosen retraction of a split monomorphism. -/
noncomputable def retraction {X Y : C} (f : X ⟶ Y) [hf : IsSplitMono f] : Y ⟶ X :=
  hf.exists_splitMono.some.retraction
#align category_theory.retraction CategoryTheory.retraction
-/

#print CategoryTheory.IsSplitMono.id /-
@[simp, reassoc.1]
theorem IsSplitMono.id {X Y : C} (f : X ⟶ Y) [hf : IsSplitMono f] : f ≫ retraction f = 𝟙 X :=
  hf.exists_splitMono.some.id
#align category_theory.is_split_mono.id CategoryTheory.IsSplitMono.id
-/

#print CategoryTheory.SplitMono.splitEpi /-
/-- The retraction of a split monomorphism has an obvious section. -/
def SplitMono.splitEpi {X Y : C} {f : X ⟶ Y} (sm : SplitMono f) : SplitEpi sm.retraction
    where section_ := f
#align category_theory.split_mono.split_epi CategoryTheory.SplitMono.splitEpi
-/

#print CategoryTheory.retraction_isSplitEpi /-
/-- The retraction of a split monomorphism is itself a split epimorphism. -/
instance retraction_isSplitEpi {X Y : C} (f : X ⟶ Y) [hf : IsSplitMono f] :
    IsSplitEpi (retraction f) :=
  IsSplitEpi.mk' (SplitMono.splitEpi _)
#align category_theory.retraction_is_split_epi CategoryTheory.retraction_isSplitEpi
-/

#print CategoryTheory.isIso_of_epi_of_isSplitMono /-
/-- A split mono which is epi is an iso. -/
theorem isIso_of_epi_of_isSplitMono {X Y : C} (f : X ⟶ Y) [IsSplitMono f] [Epi f] : IsIso f :=
  ⟨⟨retraction f, ⟨by simp, by simp [← cancel_epi f]⟩⟩⟩
#align category_theory.is_iso_of_epi_of_is_split_mono CategoryTheory.isIso_of_epi_of_isSplitMono
-/

#print CategoryTheory.section_ /-
/-- The chosen section of a split epimorphism.
(Note that `section` is a reserved keyword, so we append an underscore.)
-/
noncomputable def section_ {X Y : C} (f : X ⟶ Y) [hf : IsSplitEpi f] : Y ⟶ X :=
  hf.exists_splitEpi.some.section_
#align category_theory.section_ CategoryTheory.section_
-/

#print CategoryTheory.IsSplitEpi.id /-
@[simp, reassoc.1]
theorem IsSplitEpi.id {X Y : C} (f : X ⟶ Y) [hf : IsSplitEpi f] : section_ f ≫ f = 𝟙 Y :=
  hf.exists_splitEpi.some.id
#align category_theory.is_split_epi.id CategoryTheory.IsSplitEpi.id
-/

#print CategoryTheory.SplitEpi.splitMono /-
/-- The section of a split epimorphism has an obvious retraction. -/
def SplitEpi.splitMono {X Y : C} {f : X ⟶ Y} (se : SplitEpi f) : SplitMono se.section_
    where retraction := f
#align category_theory.split_epi.split_mono CategoryTheory.SplitEpi.splitMono
-/

#print CategoryTheory.section_isSplitMono /-
/-- The section of a split epimorphism is itself a split monomorphism. -/
instance section_isSplitMono {X Y : C} (f : X ⟶ Y) [hf : IsSplitEpi f] : IsSplitMono (section_ f) :=
  IsSplitMono.mk' (SplitEpi.splitMono _)
#align category_theory.section_is_split_mono CategoryTheory.section_isSplitMono
-/

#print CategoryTheory.isIso_of_mono_of_isSplitEpi /-
/-- A split epi which is mono is an iso. -/
theorem isIso_of_mono_of_isSplitEpi {X Y : C} (f : X ⟶ Y) [Mono f] [IsSplitEpi f] : IsIso f :=
  ⟨⟨section_ f, ⟨by simp [← cancel_mono f], by simp⟩⟩⟩
#align category_theory.is_iso_of_mono_of_is_split_epi CategoryTheory.isIso_of_mono_of_isSplitEpi
-/

#print CategoryTheory.IsSplitMono.of_iso /-
/-- Every iso is a split mono. -/
instance (priority := 100) IsSplitMono.of_iso {X Y : C} (f : X ⟶ Y) [IsIso f] : IsSplitMono f :=
  IsSplitMono.mk' { retraction := inv f }
#align category_theory.is_split_mono.of_iso CategoryTheory.IsSplitMono.of_iso
-/

#print CategoryTheory.IsSplitEpi.of_iso /-
/-- Every iso is a split epi. -/
instance (priority := 100) IsSplitEpi.of_iso {X Y : C} (f : X ⟶ Y) [IsIso f] : IsSplitEpi f :=
  IsSplitEpi.mk' { section_ := inv f }
#align category_theory.is_split_epi.of_iso CategoryTheory.IsSplitEpi.of_iso
-/

#print CategoryTheory.SplitMono.mono /-
theorem SplitMono.mono {X Y : C} {f : X ⟶ Y} (sm : SplitMono f) : Mono f :=
  { right_cancellation := fun Z g h w => by replace w := w =≫ sm.retraction; simpa using w }
#align category_theory.split_mono.mono CategoryTheory.SplitMono.mono
-/

#print CategoryTheory.IsSplitMono.mono /-
/-- Every split mono is a mono. -/
instance (priority := 100) IsSplitMono.mono {X Y : C} (f : X ⟶ Y) [hf : IsSplitMono f] : Mono f :=
  hf.exists_splitMono.some.Mono
#align category_theory.is_split_mono.mono CategoryTheory.IsSplitMono.mono
-/

#print CategoryTheory.SplitEpi.epi /-
theorem SplitEpi.epi {X Y : C} {f : X ⟶ Y} (se : SplitEpi f) : Epi f :=
  { left_cancellation := fun Z g h w => by replace w := se.section_ ≫= w; simpa using w }
#align category_theory.split_epi.epi CategoryTheory.SplitEpi.epi
-/

#print CategoryTheory.IsSplitEpi.epi /-
/-- Every split epi is an epi. -/
instance (priority := 100) IsSplitEpi.epi {X Y : C} (f : X ⟶ Y) [hf : IsSplitEpi f] : Epi f :=
  hf.exists_splitEpi.some.Epi
#align category_theory.is_split_epi.epi CategoryTheory.IsSplitEpi.epi
-/

#print CategoryTheory.IsIso.of_mono_retraction' /-
/-- Every split mono whose retraction is mono is an iso. -/
theorem IsIso.of_mono_retraction' {X Y : C} {f : X ⟶ Y} (hf : SplitMono f) [Mono <| hf.retraction] :
    IsIso f :=
  ⟨⟨hf.retraction, ⟨by simp, (cancel_mono_id <| hf.retraction).mp (by simp)⟩⟩⟩
#align category_theory.is_iso.of_mono_retraction' CategoryTheory.IsIso.of_mono_retraction'
-/

#print CategoryTheory.IsIso.of_mono_retraction /-
/-- Every split mono whose retraction is mono is an iso. -/
theorem IsIso.of_mono_retraction {X Y : C} (f : X ⟶ Y) [hf : IsSplitMono f]
    [hf' : Mono <| retraction f] : IsIso f :=
  @IsIso.of_mono_retraction' _ _ _ _ _ hf.exists_splitMono.some hf'
#align category_theory.is_iso.of_mono_retraction CategoryTheory.IsIso.of_mono_retraction
-/

#print CategoryTheory.IsIso.of_epi_section' /-
/-- Every split epi whose section is epi is an iso. -/
theorem IsIso.of_epi_section' {X Y : C} {f : X ⟶ Y} (hf : SplitEpi f) [Epi <| hf.section_] :
    IsIso f :=
  ⟨⟨hf.section_, ⟨(cancel_epi_id <| hf.section_).mp (by simp), by simp⟩⟩⟩
#align category_theory.is_iso.of_epi_section' CategoryTheory.IsIso.of_epi_section'
-/

#print CategoryTheory.IsIso.of_epi_section /-
/-- Every split epi whose section is epi is an iso. -/
theorem IsIso.of_epi_section {X Y : C} (f : X ⟶ Y) [hf : IsSplitEpi f] [hf' : Epi <| section_ f] :
    IsIso f :=
  @IsIso.of_epi_section' _ _ _ _ _ hf.exists_splitEpi.some hf'
#align category_theory.is_iso.of_epi_section CategoryTheory.IsIso.of_epi_section
-/

#print CategoryTheory.Groupoid.ofTruncSplitMono /-
-- FIXME this has unnecessarily become noncomputable!
/-- A category where every morphism has a `trunc` retraction is computably a groupoid. -/
noncomputable def Groupoid.ofTruncSplitMono
    (all_split_mono : ∀ {X Y : C} (f : X ⟶ Y), Trunc (IsSplitMono f)) : Groupoid.{v₁} C :=
  by
  apply groupoid.of_is_iso
  intro X Y f
  trunc_cases all_split_mono f
  trunc_cases all_split_mono (retraction f)
  apply is_iso.of_mono_retraction
#align category_theory.groupoid.of_trunc_split_mono CategoryTheory.Groupoid.ofTruncSplitMono
-/

section

variable (C)

#print CategoryTheory.SplitMonoCategory /-
/-- A split mono category is a category in which every monomorphism is split. -/
class SplitMonoCategory where
  isSplitMono_of_mono : ∀ {X Y : C} (f : X ⟶ Y) [Mono f], IsSplitMono f
#align category_theory.split_mono_category CategoryTheory.SplitMonoCategory
-/

#print CategoryTheory.SplitEpiCategory /-
/-- A split epi category is a category in which every epimorphism is split. -/
class SplitEpiCategory where
  isSplitEpi_of_epi : ∀ {X Y : C} (f : X ⟶ Y) [Epi f], IsSplitEpi f
#align category_theory.split_epi_category CategoryTheory.SplitEpiCategory
-/

end

#print CategoryTheory.isSplitMono_of_mono /-
/-- In a category in which every monomorphism is split, every monomorphism splits. This is not an
    instance because it would create an instance loop. -/
theorem isSplitMono_of_mono [SplitMonoCategory C] {X Y : C} (f : X ⟶ Y) [Mono f] : IsSplitMono f :=
  SplitMonoCategory.isSplitMono_of_mono _
#align category_theory.is_split_mono_of_mono CategoryTheory.isSplitMono_of_mono
-/

#print CategoryTheory.isSplitEpi_of_epi /-
/-- In a category in which every epimorphism is split, every epimorphism splits. This is not an
    instance because it would create an instance loop. -/
theorem isSplitEpi_of_epi [SplitEpiCategory C] {X Y : C} (f : X ⟶ Y) [Epi f] : IsSplitEpi f :=
  SplitEpiCategory.isSplitEpi_of_epi _
#align category_theory.is_split_epi_of_epi CategoryTheory.isSplitEpi_of_epi
-/

section

variable {D : Type u₂} [Category.{v₂} D]

/- warning: category_theory.split_mono.map -> CategoryTheory.SplitMono.map is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u3}} [_inst_1 : CategoryTheory.Category.{u1, u3} C] {D : Type.{u4}} [_inst_2 : CategoryTheory.Category.{u2, u4} D] {X : C} {Y : C} {f : Quiver.Hom.{succ u1, u3} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) X Y}, (CategoryTheory.SplitMono.{u1, u3} C _inst_1 X Y f) -> (forall (F : CategoryTheory.Functor.{u1, u2, u3, u4} C _inst_1 D _inst_2), CategoryTheory.SplitMono.{u2, u4} D _inst_2 (CategoryTheory.Functor.obj.{u1, u2, u3, u4} C _inst_1 D _inst_2 F X) (CategoryTheory.Functor.obj.{u1, u2, u3, u4} C _inst_1 D _inst_2 F Y) (CategoryTheory.Functor.map.{u1, u2, u3, u4} C _inst_1 D _inst_2 F X Y f))
but is expected to have type
  forall {C : Type.{u3}} [_inst_1 : CategoryTheory.Category.{u1, u3} C] {D : Type.{u4}} [_inst_2 : CategoryTheory.Category.{u2, u4} D] {X : C} {Y : C} {f : Quiver.Hom.{succ u1, u3} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) X Y}, (CategoryTheory.SplitMono.{u1, u3} C _inst_1 X Y f) -> (forall (F : CategoryTheory.Functor.{u1, u2, u3, u4} C _inst_1 D _inst_2), CategoryTheory.SplitMono.{u2, u4} D _inst_2 (Prefunctor.obj.{succ u1, succ u2, u3, u4} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) D (CategoryTheory.CategoryStruct.toQuiver.{u2, u4} D (CategoryTheory.Category.toCategoryStruct.{u2, u4} D _inst_2)) (CategoryTheory.Functor.toPrefunctor.{u1, u2, u3, u4} C _inst_1 D _inst_2 F) X) (Prefunctor.obj.{succ u1, succ u2, u3, u4} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) D (CategoryTheory.CategoryStruct.toQuiver.{u2, u4} D (CategoryTheory.Category.toCategoryStruct.{u2, u4} D _inst_2)) (CategoryTheory.Functor.toPrefunctor.{u1, u2, u3, u4} C _inst_1 D _inst_2 F) Y) (Prefunctor.map.{succ u1, succ u2, u3, u4} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) D (CategoryTheory.CategoryStruct.toQuiver.{u2, u4} D (CategoryTheory.Category.toCategoryStruct.{u2, u4} D _inst_2)) (CategoryTheory.Functor.toPrefunctor.{u1, u2, u3, u4} C _inst_1 D _inst_2 F) X Y f))
Case conversion may be inaccurate. Consider using '#align category_theory.split_mono.map CategoryTheory.SplitMono.mapₓ'. -/
/-- Split monomorphisms are also absolute monomorphisms. -/
@[simps]
def SplitMono.map {X Y : C} {f : X ⟶ Y} (sm : SplitMono f) (F : C ⥤ D) : SplitMono (F.map f)
    where
  retraction := F.map sm.retraction
  id' := by rw [← functor.map_comp, split_mono.id, Functor.map_id]
#align category_theory.split_mono.map CategoryTheory.SplitMono.map

/- warning: category_theory.split_epi.map -> CategoryTheory.SplitEpi.map is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u3}} [_inst_1 : CategoryTheory.Category.{u1, u3} C] {D : Type.{u4}} [_inst_2 : CategoryTheory.Category.{u2, u4} D] {X : C} {Y : C} {f : Quiver.Hom.{succ u1, u3} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) X Y}, (CategoryTheory.SplitEpi.{u1, u3} C _inst_1 X Y f) -> (forall (F : CategoryTheory.Functor.{u1, u2, u3, u4} C _inst_1 D _inst_2), CategoryTheory.SplitEpi.{u2, u4} D _inst_2 (CategoryTheory.Functor.obj.{u1, u2, u3, u4} C _inst_1 D _inst_2 F X) (CategoryTheory.Functor.obj.{u1, u2, u3, u4} C _inst_1 D _inst_2 F Y) (CategoryTheory.Functor.map.{u1, u2, u3, u4} C _inst_1 D _inst_2 F X Y f))
but is expected to have type
  forall {C : Type.{u3}} [_inst_1 : CategoryTheory.Category.{u1, u3} C] {D : Type.{u4}} [_inst_2 : CategoryTheory.Category.{u2, u4} D] {X : C} {Y : C} {f : Quiver.Hom.{succ u1, u3} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) X Y}, (CategoryTheory.SplitEpi.{u1, u3} C _inst_1 X Y f) -> (forall (F : CategoryTheory.Functor.{u1, u2, u3, u4} C _inst_1 D _inst_2), CategoryTheory.SplitEpi.{u2, u4} D _inst_2 (Prefunctor.obj.{succ u1, succ u2, u3, u4} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) D (CategoryTheory.CategoryStruct.toQuiver.{u2, u4} D (CategoryTheory.Category.toCategoryStruct.{u2, u4} D _inst_2)) (CategoryTheory.Functor.toPrefunctor.{u1, u2, u3, u4} C _inst_1 D _inst_2 F) X) (Prefunctor.obj.{succ u1, succ u2, u3, u4} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) D (CategoryTheory.CategoryStruct.toQuiver.{u2, u4} D (CategoryTheory.Category.toCategoryStruct.{u2, u4} D _inst_2)) (CategoryTheory.Functor.toPrefunctor.{u1, u2, u3, u4} C _inst_1 D _inst_2 F) Y) (Prefunctor.map.{succ u1, succ u2, u3, u4} C (CategoryTheory.CategoryStruct.toQuiver.{u1, u3} C (CategoryTheory.Category.toCategoryStruct.{u1, u3} C _inst_1)) D (CategoryTheory.CategoryStruct.toQuiver.{u2, u4} D (CategoryTheory.Category.toCategoryStruct.{u2, u4} D _inst_2)) (CategoryTheory.Functor.toPrefunctor.{u1, u2, u3, u4} C _inst_1 D _inst_2 F) X Y f))
Case conversion may be inaccurate. Consider using '#align category_theory.split_epi.map CategoryTheory.SplitEpi.mapₓ'. -/
/-- Split epimorphisms are also absolute epimorphisms. -/
@[simps]
def SplitEpi.map {X Y : C} {f : X ⟶ Y} (se : SplitEpi f) (F : C ⥤ D) : SplitEpi (F.map f)
    where
  section_ := F.map se.section_
  id' := by rw [← functor.map_comp, split_epi.id, Functor.map_id]
#align category_theory.split_epi.map CategoryTheory.SplitEpi.map

instance {X Y : C} (f : X ⟶ Y) [hf : IsSplitMono f] (F : C ⥤ D) : IsSplitMono (F.map f) :=
  IsSplitMono.mk' (hf.exists_splitMono.some.map F)

instance {X Y : C} (f : X ⟶ Y) [hf : IsSplitEpi f] (F : C ⥤ D) : IsSplitEpi (F.map f) :=
  IsSplitEpi.mk' (hf.exists_splitEpi.some.map F)

end

end CategoryTheory


/-
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
-/

import ring_theory.algebra_tower
import ring_theory.dedekind_domain.ideal
import ring_theory.is_adjoin_root

/-!
# 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
-/

variables (R : Type*) {S : Type*} [comm_ring R] [comm_ring S] [algebra R S]

open ideal polynomial double_quot unique_factorization_monoid algebra ring_hom

local notation R`<`:std.prec.max_plus 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 :=
{ carrier := {a | ∀ (b : S), a * b ∈ R<x> },
  zero_mem' := λ b, by simpa only [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) }

variables {R} {x : S}

lemma conductor_eq_of_eq {y : S} (h : (R<x> : set S) = R<y>):
  conductor R x = conductor R y :=
ideal.ext $ λ a, forall_congr $ λ b, set.ext_iff.mp h _

lemma conductor_subset_adjoin : (conductor R x : set S) ⊆ R<x> :=
λ y hy, by simpa only [mul_one] using hy 1

lemma mem_conductor_iff {y : S} : y ∈ conductor R x ↔ ∀ (b : S), y * b ∈ R<x> :=
⟨λ h, h, λ h, h⟩

lemma 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]

lemma conductor_eq_top_of_power_basis (pb : power_basis R S) : conductor R pb.gen = ⊤ :=
conductor_eq_top_of_adjoin_eq_top pb.adjoin_gen_eq_top

variables {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` -/
lemma prod_mem_ideal_map_of_mem_conductor {p : R} {z : S}
  (hp : p ∈ ideal.comap (algebra_map R S) (conductor R x)) (hz' : z ∈ (I.map (algebra_map R S))) :
  (algebra_map R S p) * z ∈
    algebra_map R<x> S '' ↑(I.map (algebra_map R R<x>)) :=
begin
  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 • (algebra_map R S a) * (algebra_map R S p)) ∈
    (algebra_map R<x> S) '' (I.map (algebra_map R R<x>)),
  { intros a ha,
    rw [algebra.id.smul_eq_mul, mul_assoc, mul_comm, mul_assoc, set.mem_image],
    refine exists.intro (algebra_map R R<x> a * ⟨l a * algebra_map R S p,
      show l a * algebra_map R S p ∈ R<x>, from _ ⟩) _,
    { rw mul_comm,
      exact mem_conductor_iff.mp (ideal.mem_comap.mp hp) _ },
    refine ⟨_, by simpa only [ring_hom.map_mul, mul_comm (algebra_map R S p) (l a)]⟩,
    rw mul_comm,
    apply ideal.mul_mem_left (I.map (algebra_map R R<x>)) _
      (ideal.mem_map_of_mem _ ha) },
  refine finset.sum_induction _ (λ u, u ∈ (algebra_map R<x> S) ''
    (I.map (algebra_map R R<x>)))
    (λ a b, _) _ _,
  rintro ⟨z, hz, rfl⟩ ⟨y, hy, rfl⟩,
  rw [← ring_hom.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 _, ring_hom.map_zero _⟩ },
  { intros y hy,
    exact lem ((finsupp.mem_supported _ l).mp H hy) },
end

/-- A technical result telling us that `(I * S) ∩ R<x> = I * R<x>` for any ideal `I` of `R`. -/
lemma comap_map_eq_map_adjoin_of_coprime_conductor
  (hx : (conductor R x).comap (algebra_map R S) ⊔ I = ⊤)
  (h_alg : function.injective (algebra_map R<x> S)):
  (I.map (algebra_map R S)).comap (algebra_map R<x> S) = I.map (algebra_map R R<x>) :=
begin
  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>`.
    intros 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 : (algebra_map R S p)*z + (algebra_map R S q)*z = z,
    { simp only [←add_mul, ←ring_hom.map_add (algebra_map R S), hpq, map_one, one_mul] },
    suffices : z ∈ algebra_map R<x> S '' (I.map (algebra_map R R<x>)) ↔ (⟨z, hz⟩ : R<x>) ∈
      I.map (algebra_map R R<x>),
    { rw [← this, ← temp],
      obtain ⟨a, ha⟩ := (set.mem_image _ _ _).mp (prod_mem_ideal_map_of_mem_conductor hp
        (show z ∈ I.map (algebra_map R S), by rwa ideal.mem_comap at hy )),
      use a + (algebra_map R R<x> q) * ⟨z, hz⟩,
      refine ⟨ ideal.add_mem (I.map (algebra_map R R<x>)) ha.left _,
        by simpa only [ha.right, map_add, alg_hom.map_mul, add_right_inj] ⟩,
      rw mul_comm,
        exact ideal.mul_mem_left (I.map (algebra_map R R<x>)) _ (ideal.mem_map_of_mem _ hq) },
    refine ⟨ λ h, _, λ 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⟩,
      { apply h_alg,
        simpa [hx₂], },
      rwa ← this }  },

  { -- The converse inclusion is trivial
    have : algebra_map R S = (algebra_map _ S).comp (algebra_map R R<x>) := by { ext, refl },
    rw [this, ← ideal.map_map],
    apply ideal.le_comap_map }
end

/-- 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 quot_adjoin_equiv_quot_map (hx : (conductor R x).comap (algebra_map R S) ⊔ I = ⊤)
  (h_alg : function.injective (algebra_map R<x> S)) :
  R<x> ⧸ (I.map (algebra_map R R<x>)) ≃+* S ⧸ (I.map (algebra_map R S)) :=
ring_equiv.of_bijective (ideal.quotient.lift (I.map (algebra_map R R<x>))
  (((I.map (algebra_map R S))^.quotient.mk).comp (algebra_map R<x> S )) (λ r hr,
    begin
      have : algebra_map R S = (algebra_map R<x> S).comp
        (algebra_map R R<x>) := by { ext, refl },
      rw [ring_hom.comp_apply, ideal.quotient.eq_zero_iff_mem, this, ← ideal.map_map],
      exact ideal.mem_map_of_mem _ hr
    end))
begin
  split,
  { --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 ring_hom.lift_injective_of_ker_le_ideal _ _ (λ u hu, _),
    rwa [ring_hom.mem_ker, ring_hom.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 _ _ (λ y, _),
    obtain ⟨z, hz⟩ := ideal.quotient.mk_surjective y,
    have : z ∈ conductor R x ⊔ (I.map (algebra_map R S)),
    { suffices : conductor R x ⊔ (I.map (algebra_map R S)) = ⊤,
      { simp only [this] },
      rw ideal.eq_top_iff_one at hx ⊢,
      replace hx := ideal.mem_map_of_mem (algebra_map R S) hx,
      rw [ideal.map_sup, ring_hom.map_one] at hx,
      exact (sup_le_sup (show  ((conductor R x).comap (algebra_map R S)).map (algebra_map R S) ≤
        conductor R x, from ideal.map_comap_le) (le_refl (I.map (algebra_map 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 } }
end

@[simp]
lemma quot_adjoin_equiv_quot_map_apply_mk (hx : (conductor R x).comap (algebra_map R S) ⊔ I = ⊤)
  (h_alg : function.injective (algebra_map R<x> S)) (a : R<x>) :
   quot_adjoin_equiv_quot_map hx h_alg ((I.map (algebra_map R R<x>))^.quotient.mk a)
   = (I.map (algebra_map R S))^.quotient.mk ↑a :=
rfl

namespace kummer_dedekind

open_locale big_operators polynomial classical

variables [is_domain R] [is_integrally_closed R]
variables [is_domain S] [is_dedekind_domain S]
variable [no_zero_smul_divisors R S]

local attribute [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 normalized_factors_map_equiv_normalized_factors_min_poly_mk (hI : is_maximal I)
  (hI' : I ≠ ⊥) (hx : (conductor R x).comap (algebra_map R S) ⊔ I = ⊤)
  (hx' : is_integral R x) :
  {J : ideal S | J ∈ normalized_factors (I.map (algebra_map R S) )} ≃
    {d : (R ⧸ I)[X] | d ∈ normalized_factors (map I^.quotient.mk (minpoly R x))} :=
(normalized_factors_equiv_of_quot_equiv
  ((quot_adjoin_equiv_quot_map hx
    (by { apply no_zero_smul_divisors.algebra_map_injective (algebra.adjoin R {x}) S,
          exact subalgebra.no_zero_smul_divisors_top (algebra.adjoin R {x}) })).symm.trans
  (((algebra.adjoin.power_basis' hx').quotient_equiv_quotient_minpoly_map I).to_ring_equiv.trans
    (quot_equiv_of_eq (show (ideal.span ({(minpoly R (algebra.adjoin.power_basis' hx').gen).map
    I^.quotient.mk})) = (ideal.span ({(minpoly R x).map I^.quotient.mk})),
      by rw algebra.adjoin.power_basis'_minpoly_gen hx'))))
  --show that `I * S` ≠ ⊥
  (show I.map (algebra_map R S) ≠ ⊥,
    by rwa [ne.def, map_eq_bot_iff_of_injective (no_zero_smul_divisors.algebra_map_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
  (normalized_factors_equiv_span_normalized_factors
    (show (map I^.quotient.mk (minpoly R x)) ≠ 0, from
      polynomial.map_monic_ne_zero (minpoly.monic hx'))).symm

/-- 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 : is_maximal I) (hI' : I ≠ ⊥)
  (hx : (conductor R x).comap (algebra_map R S) ⊔ I = ⊤) (hx' : is_integral R x)
  {J : ideal S} (hJ : J ∈ normalized_factors (I.map (algebra_map R S))) :
  multiplicity J (I.map (algebra_map R S)) =
    multiplicity ↑(normalized_factors_map_equiv_normalized_factors_min_poly_mk 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_app,
       multiplicity_normalized_factors_equiv_span_normalized_factors_symm_eq_multiplicity,
       normalized_factors_equiv_of_quot_equiv_multiplicity_eq_multiplicity]

/-- The **Kummer-Dedekind Theorem**. -/
theorem normalized_factors_ideal_map_eq_normalized_factors_min_poly_mk_map (hI : is_maximal I)
  (hI' : I ≠ ⊥) (hx : (conductor R x).comap (algebra_map R S) ⊔ I = ⊤)
  (hx' : is_integral R x) :
  normalized_factors (I.map (algebra_map R S)) =
    multiset.map
      (λ f, ((normalized_factors_map_equiv_normalized_factors_min_poly_mk hI hI' hx hx').symm f :
        ideal S))
      (normalized_factors (polynomial.map I^.quotient.mk (minpoly R x))).attach :=
begin
  ext J,
  -- WLOG, assume J is a normalized factor
  by_cases hJ : J ∈ normalized_factors (I.map (algebra_map 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, not_exists],
    rintros 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,
      unique_factorization_monoid.normalize_normalized_factor _ hJ,
      unique_factorization_monoid.normalize_normalized_factor,
      part_enat.coe_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,
  { 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' (λ 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
    (no_zero_smul_divisors.algebra_map_injective R S)] },
end

theorem ideal.irreducible_map_of_irreducible_minpoly (hI : is_maximal I) (hI' : I ≠ ⊥)
  (hx : (conductor R x).comap (algebra_map R S) ⊔ I = ⊤)
  (hx' : is_integral R x) (hf : irreducible (map I^.quotient.mk (minpoly R x))) :
  irreducible (I.map (algebra_map R S)) :=
begin
  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 (algebra_map R S)) = {y},
  { obtain ⟨y, hy⟩ := this,
    have h := normalized_factors_prod (show I.map (algebra_map R S) ≠ 0, by rwa [← bot_eq_zero,
      ne.def, map_eq_bot_iff_of_injective (no_zero_smul_divisors.algebra_map_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 (algebra_map 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_coe, multiset.map_singleton, subtype.coe_mk],
  exact normalized_factors_irreducible hf
end

end kummer_dedekind