import data.list.perm
import data.sigma.on_fst

local attribute [simp] not_or_distrib and.assoc
local attribute [-simp] sigma.forall

namespace list

section αβ
variables {α : Type*} {β : α → Type*}

/-- Keys: the list of keys from a list of dependent key-value pairs -/
def keys : list (sigma β) → list α :=
map sigma.fst

section keys
variables {a : α} {s hd : sigma β} {l l₁ l₂ tl : list (sigma β)}

@[simp] theorem keys_nil : @keys α β [] = [] :=
rfl

@[simp] theorem keys_cons : (hd :: tl).keys = hd.1 :: tl.keys :=
rfl

@[simp] theorem keys_singleton : [s].keys = [s.1] :=
rfl

@[simp] theorem keys_append : (l₁ ++ l₂).keys = l₁.keys ++ l₂.keys :=
by simp [keys]

@[simp] theorem keys_iff_ne_key_of_mem :
  (∀ (s : sigma β), s ∈ l → a ≠ s.1) ↔ a ∉ l.keys :=
by induction l; simp *

theorem mem_of_ne_key_of_mem_cons (h : hd.1 ≠ s.1) : s ∈ hd :: tl → s ∈ tl :=
by cases s; cases hd; simp [ne.symm h]

theorem mem_keys_of_mem : s ∈ l → s.1 ∈ l.keys :=
mem_map_of_mem sigma.fst

theorem exists_mem_of_mem_keys (h : a ∈ l.keys) : ∃ (b : β a), sigma.mk a b ∈ l :=
let ⟨⟨a', b'⟩, m, e⟩ := exists_of_mem_map h in
eq.rec_on e (exists.intro b' m)

theorem mem_keys : a ∈ l.keys ↔ ∃ (b : β a), sigma.mk a b ∈ l :=
⟨exists_mem_of_mem_keys, λ ⟨b, h⟩, mem_keys_of_mem h⟩

end keys

/-- No duplicate keys in a list of dependent key-value pairs. -/
def nodupkeys : list (sigma β) → Prop :=
pairwise (sigma.fst_rel (≠))

section nodupkeys
variables {s t hd : sigma β} {l l₁ l₂ tl : list (sigma β)}

@[simp] theorem nodupkeys_nil : @nodupkeys α β [] :=
pairwise.nil _

@[simp] theorem nodupkeys_cons :
  (hd :: tl).nodupkeys ↔ hd.1 ∉ tl.keys ∧ tl.nodupkeys :=
by simp [nodupkeys, sigma.fst_rel]

theorem nodupkeys_cons_of_nodupkeys (h : hd.1 ∉ tl.keys)
  (t : nodupkeys tl) : nodupkeys (hd :: tl) :=
nodupkeys_cons.mpr ⟨h, t⟩

theorem nodupkeys_singleton (s : sigma β) : nodupkeys [s] :=
nodupkeys_cons_of_nodupkeys (not_mem_nil s.1) nodupkeys_nil

theorem nodup_of_nodupkeys : l.nodupkeys → l.nodup :=
pairwise.imp $ λ ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ (h : a₁ ≠ a₂), by simp [h]

@[simp] theorem nodupkeys_iff : l.keys.nodup ↔ l.nodupkeys :=
pairwise_map sigma.fst

theorem perm_nodupkeys (p : l₁ ~ l₂) : l₁.nodupkeys ↔ l₂.nodupkeys :=
perm_pairwise (@sigma.fst_rel.symm α β (≠) (@ne.symm α)) p

@[simp] theorem nodupkeys_cons_of_not_mem_keys (h : hd.1 ∉ tl.keys) :
  (hd :: tl).nodupkeys ↔ tl.nodupkeys :=
begin
  induction tl,
  case list.nil { simp },
  case list.cons : hd₁ tl ih {
    simp at h,
    simp [perm_nodupkeys (perm.swap hd₁ hd tl), ne.symm h.1, ih h.2] }
end

variables {ls : list (list (sigma β))}

theorem nodupkeys_join : (join ls).nodupkeys ↔
  (∀ {l : list (sigma β)}, l ∈ ls → l.nodupkeys) ∧ pairwise disjoint (ls.map keys) :=
have ∀ (l₁ l₂ : list (sigma β)), (∀ (s ∈ l₁) (t ∈ l₂), sigma.fst_rel ne s t) ↔ disjoint l₁.keys l₂.keys :=
  λ l₁ l₂,
  have h₁ : (∀ (s : sigma β), s ∈ l₁ → s.1 ∉ l₂.keys) → disjoint l₁.keys l₂.keys :=
    λ f a mkas mkat, let ⟨b, mabs⟩ := exists_mem_of_mem_keys mkas in
    absurd mkat $ f ⟨a, b⟩ mabs,
  have h₂ : disjoint l₁.keys l₂.keys → ∀ (s : sigma β), s ∈ l₁ → s.1 ∉ l₂.keys :=
    λ dj s mss mkat, absurd mkat $ dj $ mem_keys_of_mem mss,
  ⟨by simpa using h₁, by simpa using h₂⟩,
pairwise_join.trans $ and_congr iff.rfl $ (pairwise.iff this).trans (pairwise_map _).symm

theorem nodup_enum_map_fst (l : list α) : (l.enum.map prod.fst).nodup :=
by simp [list.nodup_range]

theorem perm_keys_of_perm (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) (p : l₁ ~ l₂) :
  l₁.keys ~ l₂.keys :=
begin
  induction p,
  case list.perm.nil { refl },
  case list.perm.skip : hd tl₁ tl₂ p ih {
    simp at nd₁ nd₂,
    simp [perm.skip hd.1 (ih nd₁.2 nd₂.2)] },
  case list.perm.swap : s₁ s₂ l {
    simp [perm.swap s₁.1 s₂.1 (keys l)] },
  case list.perm.trans : l₁ l₂ l₃ p₁₂ p₂₃ ih₁₂ ih₂₃ nd₁ nd₃ {
    have nd₂ : l₂.nodupkeys := (perm_nodupkeys p₁₂).mp nd₁,
    exact perm.trans (ih₁₂ nd₁ nd₂) (ih₂₃ nd₂ nd₃) }
end

-- Is this useful?
theorem nodupkeys_functional (d : l.nodupkeys) (ms : s ∈ l) (mt : t ∈ l)
  (h : s.1 = t.1) : (eq.rec_on h s.2 : β t.1) = t.2 :=
begin
  induction d,
  case pairwise.nil { cases ms },
  case pairwise.cons : _ _ r _ ih {
    simp at ms mt,
    cases ms; cases mt,
    { subst ms, subst mt },
    { induction ms, exact absurd h (r _ mt) },
    { induction mt, exact absurd h (ne.symm (r _ ms)) },
    { exact ih ms mt } },
end

-- Is this useful?
theorem eq_of_nodupkeys_of_eq_fst (d : l.nodupkeys) (ms : s ∈ l) (mt : t ∈ l)
  (h : s.1 = t.1) : s = t :=
sigma.eq h $ nodupkeys_functional d ms mt h

end nodupkeys

section decidable_eq_α
variables [decidable_eq α]

/-- Key-based single-value lookup in a list of dependent key-value pairs. The
result is the first key-matching value found, if one exists. -/
def klookup (a : α) : list (sigma β) → option (β a)
| []         := none
| (hd :: tl) := if h : hd.1 = a then some (h.rec_on hd.2) else klookup tl

section klookup
variables {a : α} {s hd : sigma β} {l l₁ l₂ tl : list (sigma β)}

@[simp] theorem klookup_nil : @klookup _ β _ a [] = none :=
rfl

@[simp] theorem klookup_cons_eq (h : hd.1 = a) :
  klookup a (hd :: tl) = some (h.rec_on hd.2) :=
by simp [klookup, h]

@[simp] theorem klookup_cons_ne (h : hd.1 ≠ a) :
  klookup a (hd :: tl) = klookup a tl :=
by simp [klookup, h]

@[simp] theorem klookup_eq (a : α) : ∀ (l : list (sigma β)),
  klookup a l = none ∨ ∃ (b : β a), b ∈ l.klookup a
| []         := or.inl rfl
| (hd :: tl) :=
  if h₁ : hd.1 = a then
    or.inr ⟨h₁.rec_on hd.2, klookup_cons_eq h₁⟩
  else
    match klookup_eq tl with
    | or.inl h₂      := or.inl $ (klookup_cons_ne h₁).trans h₂
    | or.inr ⟨b, h₂⟩ := or.inr ⟨b, (klookup_cons_ne h₁).trans h₂⟩
    end

theorem klookup_is_some : (l.klookup a).is_some ↔ ∃ (b : β a), b ∈ l.klookup a :=
by simp [option.is_some_iff_exists]

theorem klookup_not_mem_keys : a ∉ l.keys ↔ klookup a l = none :=
by induction l with hd _ ih;
   [simp, {by_cases h : hd.1 = a; [simp [h], simp [h, ne.symm h, ih]]}]

@[simp] theorem mem_klookup_of_nodupkeys (nd : l.nodupkeys) : s.2 ∈ l.klookup s.1 ↔ s ∈ l :=
begin
  induction l generalizing s,
  case list.nil { simp },
  case list.cons : hd tl ih {
    simp at nd,
    by_cases h : hd.1 = s.1,
    { rw klookup_cons_eq h,
      cases s with a₁ b₁,
      cases hd with a₂ b₂,
      dsimp at h,
      induction h,
      split,
      { simp {contextual := tt} },
      { intro h,
        simp at h,
        cases h with h h,
        { simp [h] },
        { exact absurd (mem_keys_of_mem h) nd.1 } } },
    { rw [klookup_cons_ne h, mem_cons_iff],
      split,
      { exact or.inr ∘ (ih nd.2).mp },
      { intro p,
        cases p with p p,
        { induction p, exact false.elim (ne.irrefl h) },
        { exact (ih nd.2).mpr p } } } }
end

theorem perm_klookup (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) (p : l₁ ~ l₂) :
  l₁.klookup a = l₂.klookup a :=
begin
  induction p,
  case list.perm.nil { refl },
  case list.perm.skip : hd tl₁ tl₂ p ih nd₁ nd₂ {
    by_cases h : hd.1 = a,
    { simp [h] },
    { simp at nd₁ nd₂, simp [h, ih nd₁.2 nd₂.2] } },
  case list.perm.swap : s₁ s₂ l nd₂₁ nd₁₂ {
    simp at nd₂₁ nd₁₂,
    by_cases h₂ : s₂.1 = a,
    { induction h₂, simp [nd₁₂.1] },
    { by_cases h₁ : s₁.1 = a; simp [h₂, h₁] } },
  case list.perm.trans : l₁ l₂ l₃ p₁₂ p₂₃ ih₁₂ ih₂₃ nd₁ nd₃ {
    have nd₂ : l₂.nodupkeys := (perm_nodupkeys p₁₂).mp nd₁,
    exact eq.trans (ih₁₂ nd₁ nd₂) (ih₂₃ nd₂ nd₃) }
end

end klookup

/-- Key-based multiple-value lookup in a list of dependent key-value pairs.
The result is a list of all key-matching values. -/
def klookup_all (a : α) : list (sigma β) → list (β a)
| []         := []
| (hd :: tl) :=
  let tl' := klookup_all tl in
  if h : hd.1 = a then h.rec_on hd.2 :: tl' else tl'

section klookup_all
variables {a : α} {hd : sigma β} {l l₁ l₂ tl : list (sigma β)}

@[simp] theorem klookup_all_nil : @klookup_all _ β _ a [] = [] :=
rfl

@[simp] theorem klookup_all_cons_eq (h : hd.1 = a) :
  (hd :: tl).klookup_all a = h.rec_on hd.2 :: tl.klookup_all a :=
by simp [klookup_all, h]

@[simp] theorem klookup_all_cons_ne (h : hd.1 ≠ a) :
  (hd :: tl).klookup_all a = tl.klookup_all a :=
by simp [klookup_all, h]

theorem klookup_all_head [inhabited (β a)] :
  (l.klookup_all a).head = (l.klookup a).iget :=
by induction l with hd; [refl, {by_cases hd.1 = a; simp *}]

theorem perm_klookup_all (p : l₁ ~ l₂) : l₁.klookup_all a ~ l₂.klookup_all a :=
begin
  induction p,
  case list.perm.nil { refl },
  case list.perm.skip : hd tl₁ tl₂ p ih {
    by_cases h : hd.1 = a; simp [h, ih, perm.skip] },
  case list.perm.swap : s₁ s₂ l {
    by_cases h₁ : s₁.1 = a; by_cases h₂ : s₂.1 = a; simp [h₁, h₂, perm.swap] },
  case list.perm.trans : l₁ l₂ l₃ p₁₂ p₂₃ ih₁₂ ih₂₃ {
    exact perm.trans ih₁₂ ih₂₃ }
end

end klookup_all

/-- Key-based single-pair erasure in a list of dependent key-value pairs. The
result is the list minus the first key-matching pair, if one exists. -/
def kerase (a : α) : list (sigma β) → list (sigma β)
| []         := []
| (hd :: tl) := if hd.1 = a then tl else hd :: kerase tl

section kerase
variables {a a₁ a₂ : α} {s hd : sigma β} {l l₁ l₂ tl : list (sigma β)}

@[simp] theorem kerase_nil : @kerase _ β _ a [] = [] :=
rfl

@[simp] theorem kerase_cons_eq (h : hd.1 = a) :
  (hd :: tl).kerase a = tl :=
by simp [kerase, h]

@[simp] theorem kerase_cons_ne (h : hd.1 ≠ a) :
  (hd :: tl).kerase a = hd :: tl.kerase a :=
by simp [kerase, h]

theorem kerase_cons (a : α) (hd : sigma β) (tl : list (sigma β)) :
  hd.1 = a ∧ (hd :: tl).kerase a = tl ∨
  hd.1 ≠ a ∧ (hd :: tl).kerase a = hd :: tl.kerase a :=
by by_cases h : hd.1 = a; simp [h]

@[simp] theorem mem_kerase_nil : s ∈ @kerase _ β _ a [] ↔ false :=
by simp

@[simp] theorem kerase_of_not_mem_keys (h : a ∉ l.keys) : l.kerase a = l :=
by induction l with _ _ ih;
   [refl, {simp at h, simp [h.1, ne.symm h.1, ih h.2]}]

theorem exists_kerase_eq (h : a ∈ l.keys) :
  ∃ (b : β a) (l₁ l₂ : list (sigma β)),
    a ∉ l₁.keys ∧
    l = l₁ ++ ⟨a, b⟩ :: l₂ ∧
    l.kerase a = l₁ ++ l₂ :=
begin
  induction l,
  case list.nil { cases h },
  case list.cons : hd tl ih {
    by_cases e : hd.1 = a,
    { induction e,
      exact ⟨hd.2, [], tl, by simp, by cases hd; refl, by simp⟩ },
    { simp at h,
      cases h,
      case or.inl : h { exact absurd h (ne.symm e) },
      case or.inr : h {
        rcases ih h with ⟨b, tl₁, tl₂, h₁, h₂, h₃⟩,
        exact ⟨b, hd :: tl₁, tl₂, not_mem_cons_of_ne_of_not_mem (ne.symm e) h₁,
               by rw h₂; refl, by simp [e, h₃]⟩ } } }
end

theorem kerase_sublist (a : α) (l : list (sigma β)) : l.kerase a <+ l :=
if h : a ∈ l.keys then
  match l, l.kerase a, exists_kerase_eq h with
  | _, _, ⟨_, _, _, _, rfl, rfl⟩ := by simp
  end
else
  by simp [h]

theorem kerase_subset (a : α) (l : list (sigma β)) : l.kerase a ⊆ l :=
subset_of_sublist (kerase_sublist a l)

theorem kerase_sublist_kerase (a : α) : ∀ {l₁ l₂ : list (sigma β)},
  l₁ <+ l₂ → l₁.kerase a <+ l₂.kerase a
| _ _ sublist.slnil := sublist.slnil
| _ _ (sublist.cons  l₁ l₂ hd sl) :=
  if h : hd.1 = a then
    by rw [kerase_cons_eq h]; exact (kerase_sublist _ _).trans sl
  else
    by rw kerase_cons_ne h; exact (kerase_sublist_kerase sl).cons _ _ _
| _ _ (sublist.cons2 l₁ l₂ hd sl) :=
  if h : hd.1 = a then
    by repeat {rw kerase_cons_eq h}; exact sl
  else
    by repeat {rw kerase_cons_ne h}; exact (kerase_sublist_kerase sl).cons2 _ _ _

theorem mem_of_mem_kerase : s ∈ l.kerase a → s ∈ l :=
@kerase_subset _ _ _ _ _ _

@[simp] theorem mem_kerase_of_ne (h : s.1 ≠ a) : s ∈ l.kerase a ↔ s ∈ l :=
iff.intro mem_of_mem_kerase $ λ p,
  if q : a ∈ l.keys then
    match l, l.kerase a, exists_kerase_eq q, p with
    | _, _, ⟨_, _, _, _, rfl, rfl⟩, p :=
      by clear _match; cases s; simpa [h] using p
    end
  else
    by simp [q, p]

theorem kerase_subset_keys (a : α) (l : list (sigma β)) :
  (l.kerase a).keys ⊆ l.keys :=
subset_of_sublist (map_sublist_map _ (kerase_sublist a l))

theorem mem_keys_of_mem_keys_kerase : a₁ ∈ (l.kerase a₂).keys → a₁ ∈ l.keys :=
@kerase_subset_keys _ _ _ _ _ _

@[simp] theorem mem_keys_kerase_of_ne (h : a₂ ≠ a₁) :
  a₁ ∈ (l.kerase a₂).keys ↔ a₁ ∈ l.keys :=
iff.intro mem_keys_of_mem_keys_kerase $ λ p,
  if q : a₂ ∈ l.keys then
    match l, l.kerase a₂, exists_kerase_eq q, p with
    | _, _, ⟨_, _, _, _, rfl, rfl⟩, p := by simpa [ne.symm h] using p
    end
  else
    by simp [q, p]

@[simp] theorem nodupkeys_kerase (a : α) :
  l.nodupkeys → (l.kerase a).nodupkeys :=
begin
  induction l,
  case list.nil { simp },
  case list.cons : hd tl ih {
    intro nd,
    simp at nd,
    by_cases h : hd.1 = a,
    { simp [h, nd.2] },
    { rw [kerase_cons_ne h, nodupkeys_cons],
      exact ⟨mt (mem_keys_kerase_of_ne (ne.symm h)).mp nd.1, ih nd.2⟩ } }
end

@[simp] theorem not_mem_keys_kerase_self (nd : l.nodupkeys) :
  a ∉ (l.kerase a).keys :=
begin
  induction l,
  case list.nil { simp },
  case list.cons : hd tl ih {
    simp at nd,
    by_cases h : hd.1 = a,
    { induction h, simp [nd.1] },
    { simp [h, ne.symm h, ih nd.2] } }
end

theorem kerase_append_left : ∀ {l₁ l₂ : list (sigma β)},
  a ∈ l₁.keys → (l₁ ++ l₂).kerase a = l₁.kerase a ++ l₂
| []          _  h  := by cases h
| (hd :: tl₁) l₂ h₁ :=
  if h₂ : hd.1 = a then
    by simp [h₂]
  else
    by simp at h₁; cases h₁;
       [exact absurd h₁ (ne.symm h₂), simp [h₂, kerase_append_left h₁]]

theorem kerase_append_right : ∀ {l₁ l₂ : list (sigma β)},
  a ∉ l₁.keys → (l₁ ++ l₂).kerase a = l₁ ++ l₂.kerase a
| []         _  h := rfl
| (_ :: tl₁) l₂ h := by simp at h; simp [ne.symm h.1, kerase_append_right h.2]

theorem kerase_comm (a₁ a₂ : α) (l : list (sigma β)) :
  (l.kerase a₁).kerase a₂ = (l.kerase a₂).kerase a₁ :=
if h : a₂ = a₁ then
  by simp [h]
else if ha₁ : a₁ ∈ l.keys then
  if ha₂ : a₂ ∈ l.keys then
    match l, l.kerase a₁, exists_kerase_eq ha₁, ha₂ with
    | _, _, ⟨b₁, l₁, l₂, a₁_nin_l₁, rfl, rfl⟩, a₂_in_l₁_app_l₂ :=
      if h' : a₂ ∈ l₁.keys then
        by simp [kerase_append_left h',
                 kerase_append_right (mt (mem_keys_kerase_of_ne h).mp a₁_nin_l₁)]
      else
        by simp [kerase_append_right h', kerase_append_right a₁_nin_l₁,
                 @kerase_cons_ne _ _ _ a₂ ⟨a₁, b₁⟩ _ (ne.symm h)]
    end
  else
    by simp [ha₂, mt mem_keys_of_mem_keys_kerase ha₂]
else
  by simp [ha₁, mt mem_keys_of_mem_keys_kerase ha₁]

@[simp] theorem klookup_kerase (nd : l.nodupkeys) : (l.kerase a).klookup a = none :=
begin
  induction l,
  case list.nil { simp },
  case list.cons : hd tl ih {
    simp at nd,
    by_cases h₁ : hd.1 = a,
    { by_cases h₂ : a ∈ tl.keys,
      { induction h₁, exact absurd h₂ nd.1 },
      { simp [h₁, klookup_not_mem_keys.mp h₂] } },
    { simp [h₁, ih nd.2] } }
end

theorem ne_of_nodupkeys_of_mem_kerase :
  l.nodupkeys → s ∈ l.kerase a → a ≠ s.1 :=
begin
  induction l,
  case list.nil { simp },
  case list.cons : hd tl ih {
    intros nd h,
    simp at nd,
    rcases kerase_cons a hd tl with ⟨he, p⟩ | ⟨hn, p⟩,
    { induction he,
      simp [p] at h,
      exact ne.symm (ne_of_mem_of_not_mem (mem_keys_of_mem h) nd.1) },
    { simp [hn] at h,
      cases h with h h,
      { induction h, exact ne.symm hn },
      { exact ih nd.2 h } } }
end

theorem nodupkeys_kerase_eq_filter (a : α) (nd : l.nodupkeys) :
  l.kerase a = filter (λ s, s.1 ≠ a) l :=
begin
  induction nd,
  case pairwise.nil { refl },
  case pairwise.cons : s l n p ih {
    by_cases h : s.1 = a,
    { have : filter (λ (t : sigma β), t.1 ≠ a) l = l :=
        filter_eq_self.mpr (λ t th, h ▸ ne.symm (n t th)),
      simp [h, kerase, filter, this] },
    { simp [h, ih] } }
end

@[simp] theorem mem_kerase_of_nodupkeys (nd : l.nodupkeys) :
  s ∈ l.kerase a ↔ s.1 ≠ a ∧ s ∈ l :=
by rw nodupkeys_kerase_eq_filter a nd; simp [and_comm]

theorem perm_kerase (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) (p : l₁ ~ l₂) :
  l₁.kerase a ~ l₂.kerase a :=
begin
  induction p,
  case list.perm.nil { refl },
  case list.perm.skip : hd tl₁ tl₂ p ih {
    simp at nd₁ nd₂,
    by_cases h : hd.1 = a; simp [p, h, ih nd₁.2 nd₂.2, perm.skip] },
  case list.perm.swap : s₁ s₂ l nd₂₁ nd₁₂ {
    simp at nd₁₂,
    by_cases h₂ : s₂.1 = a,
    { induction h₂, simp [nd₁₂.1] },
    { by_cases h₁ : s₁.1 = a; simp [h₂, h₁, perm.swap] } },
  case list.perm.trans : l₁ l₂ l₃ p₁₂ p₂₃ ih₁₂ ih₂₃ nd₁ nd₃ {
    have nd₂ : l₂.nodupkeys := (perm_nodupkeys p₁₂).mp nd₁,
    exact perm.trans (ih₁₂ nd₁ nd₂) (ih₂₃ nd₂ nd₃) }
end

end kerase

/-- `cons` with `kerase` of the first `s`-key-matching pair -/
def kinsert (s : sigma β) (l : list (sigma β)) : list (sigma β) :=
s :: l.kerase s.1

section kinsert
variables {a : α} {s t hd : sigma β} {l l₁ l₂ tl : list (sigma β)}

@[simp] theorem kinsert_eq_cons_kerase : tl.kinsert hd = hd :: tl.kerase hd.1 :=
rfl

@[simp] theorem mem_kinsert : s ∈ kinsert t l ↔ s = t ∨ s ∈ l.kerase t.1 :=
by simp [kinsert]

@[simp] theorem mem_keys_kinsert : a ∈ (l.kinsert s).keys ↔ s.1 = a ∨ a ∈ l.keys :=
by by_cases h : s.1 = a; [simp [h], simp [h, ne.symm h]]

@[simp] theorem nodupkeys_kinsert (s : sigma β) (nd : l.nodupkeys) :
  (l.kinsert s).nodupkeys :=
(nodupkeys_cons_of_not_mem_keys (not_mem_keys_kerase_self nd)).mpr $
  nodupkeys_kerase _ nd

theorem perm_kinsert (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) (p : l₁ ~ l₂) :
  l₁.kinsert s ~ l₂.kinsert s :=
perm.skip s $ perm_kerase nd₁ nd₂ p

end kinsert

/-- Key-based single-pair replacement in a list of dependent key-value pairs.
The result is the list with the first key-matching pair, if it exists, replaced
by the given pair. -/
def kreplace (s : sigma β) : list (sigma β) → list (sigma β)
| []         := []
| (hd :: tl) := if h : hd.1 = s.1 then s :: tl else hd :: kreplace tl

section kreplace
variables {a : α} {s t hd : sigma β} {l l₁ l₂ tl : list (sigma β)}

@[simp] theorem kreplace_nil : kreplace s [] = [] :=
rfl

@[simp] theorem kreplace_cons_eq (h : hd.1 = s.1) :
  (hd :: tl).kreplace s = s :: tl :=
by simp [kreplace, h]

@[simp] theorem kreplace_cons_ne (h : hd.1 ≠ s.1) :
  (hd :: tl).kreplace s = hd :: tl.kreplace s :=
by simp [kreplace, h]

theorem kreplace_cons (s hd : sigma β) (tl : list (sigma β)) :
  hd.1 = s.1 ∧ (hd :: tl).kreplace s = s :: tl ∨
  hd.1 ≠ s.1 ∧ (hd :: tl).kreplace s = hd :: tl.kreplace s :=
by by_cases h : hd.1 = s.1; simp [h]

theorem mem_of_mem_kreplace_ne (h : t.1 ≠ s.1) : s ∈ l.kreplace t → s ∈ l :=
begin
  induction l generalizing s t,
  case list.nil { simp },
  case list.cons : hd tl ih {
    by_cases p : hd.1 = t.1,
    { rw kreplace_cons_eq p,
      exact mem_cons_of_mem hd ∘ mem_of_ne_key_of_mem_cons h },
    { rw [kreplace_cons_ne p, mem_cons_iff, mem_cons_iff],
      exact or.imp_right (ih h) } }
end

theorem mem_keys_of_mem_keys_kreplace_ne (h₁ : a ≠ s.1) (h₂ : a ∈ (l.kreplace s).keys) :
  a ∈ l.keys :=
let ⟨b, h₃⟩ := exists_mem_of_mem_keys h₂ in
@mem_keys_of_mem _ _ ⟨a, b⟩ _ (mem_of_mem_kreplace_ne (ne.symm h₁) h₃)

@[simp] theorem nodupkeys_kreplace (s : sigma β) :
  l.nodupkeys → (l.kreplace s).nodupkeys :=
begin
  induction l,
  case list.nil { simp },
  case list.cons : hd tl ih {
    intro nd,
    simp at nd,
    by_cases p : hd.1 = s.1,
    { rw p at nd, simp [p, nd.1, nd.2] },
    { simp [p, nd.1, ih nd.2, mt (mem_keys_of_mem_keys_kreplace_ne p)] } }
end

theorem perm_kreplace (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) (p : l₁ ~ l₂) :
  l₁.kreplace s ~ l₂.kreplace s :=
begin
  induction p,
  case list.perm.nil { refl },
  case list.perm.skip : hd tl₁ tl₂ p ih {
    simp at nd₁ nd₂,
    by_cases h : hd.1 = s.1; simp [p, h, ih nd₁.2 nd₂.2, perm.skip] },
  case list.perm.swap : s₁ s₂ l nd₂₁ nd₁₂ {
    simp at nd₂₁ nd₁₂,
    by_cases h₂ : s₂.1 = s.1,
    { rw kreplace_cons_eq h₂,
      by_cases h₁ : s₁.1 = s.1,
      { rw kreplace_cons_eq h₁,
        exact absurd (h₁.trans h₂.symm) nd₁₂.1 },
      { simp [h₁, h₂, perm.swap] } },
    { by_cases h₁ : s₁.1 = s.1; simp [h₁, h₂, perm.swap] } },
  case list.perm.trans : l₁ l₂ l₃ p₁₂ p₂₃ ih₁₂ ih₂₃ nd₁ nd₃ {
    have nd₂ : l₂.nodupkeys := (perm_nodupkeys p₁₂).mp nd₁,
    exact perm.trans (ih₁₂ nd₁ nd₂) (ih₂₃ nd₂ nd₃) }
end

end kreplace

/-- Left-biased key-based union of lists of dependent key-value pairs.
The result of `l₁.kunion l₂` is constructed from `l₁` with `l₂` appended such
that the first pair matching each key in `l₁` is erased from `l₂`. Note that
the result can still have duplicates if duplicates exist in either argument. -/
def kunion : list (sigma β) → list (sigma β) → list (sigma β)
| []         l := l
| (hd :: tl) l := hd :: kunion tl (kerase hd.1 l)

section kunion
variables {a : α} {s hd : sigma β} {l l₁ l₂ l₃ l₄ tl : list (sigma β)}

@[simp] theorem nil_kunion (l : list (sigma β)) : [].kunion l = l :=
rfl

@[simp] theorem kunion_nil : ∀ (l : list (sigma β)), l.kunion [] = l
| []        := rfl
| (_ :: tl) := by rw [kunion, kerase_nil, kunion_nil tl]

@[simp] theorem kunion_cons : (hd :: tl).kunion l = hd :: tl.kunion (l.kerase hd.1) :=
rfl

@[simp] theorem kerase_kunion : ∀ {l₁ : list (sigma β)} (l₂ : list (sigma β)),
  (l₁.kerase a).kunion (l₂.kerase a) = (l₁.kunion l₂).kerase a
| []        _ := rfl
| (hd :: _) l := by by_cases h : hd.1 = a;
                    simp [h, kerase_comm a hd.1 l, kerase_kunion]

@[simp] theorem map_kunion {γ : Type*} (f : sigma β → γ)
  (dk : disjoint l₁.keys l₂.keys) : (l₁.kunion l₂).map f = l₁.map f ++ l₂.map f :=
by induction l₁ with _ _ ih; [refl, {simp at dk, simp [dk.1, ih dk.2.symm]}]

theorem keys_kunion (dk : disjoint l₁.keys l₂.keys) :
  (l₁.kunion l₂).keys = l₁.keys ++ l₂.keys :=
by simp [keys, dk]

@[simp] theorem kinsert_kunion : (l₁.kinsert s).kunion l₂ = (l₁.kunion l₂).kinsert s :=
by simp

@[simp] theorem kunion_assoc : (l₁.kunion l₂).kunion l₃ = l₁.kunion (l₂.kunion l₃) :=
by induction l₁ generalizing l₂ l₃; simp *

theorem mem_of_mem_kunion : s ∈ l₁.kunion l₂ → s ∈ l₁ ∨ s ∈ l₂ :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp },
  case list.cons : hd tl ih {
    intro h,
    simp at h,
    cases h,
    case or.inl : h { simp [h] },
    case or.inr : h {
      cases ih h,
      case or.inl : h { simp [h] },
      case or.inr : h { simp [mem_of_mem_kerase h] } } }
end

theorem mem_kunion_left (l₂ : list (sigma β)) (h : s ∈ l₁) : s ∈ l₁.kunion l₂ :=
by induction l₁ generalizing l₂; simp at h; cases h; simp *

theorem mem_kunion_right (h₁ : s.1 ∉ l₁.keys) (h₂ : s ∈ l₂) : s ∈ l₁.kunion l₂ :=
by induction l₁ generalizing l₂; simp at h₁; cases h₁; simp *

theorem mem_kunion_middle (dk : disjoint (l₁.kunion l₂).keys l₃.keys) (h : s ∈ l₁.kunion l₃) :
  s ∈ (l₁.kunion l₂).kunion l₃ :=
match mem_of_mem_kunion h with
| or.inl h := mem_kunion_left _ (mem_kunion_left _ h)
| or.inr h := mem_kunion_right (disjoint_right.mp dk (mem_keys_of_mem h)) h
end

theorem mem_kunion_of_disjoint_keys (dk : disjoint l₁.keys l₂.keys) (h : s ∈ l₁ ∨ s ∈ l₂) :
  s ∈ l₁.kunion l₂ :=
begin
  cases h with h h,
  { exact mem_kunion_left _ h },
  { by_cases p : s.1 ∈ l₁.keys,
    { exact absurd h (mt mem_keys_of_mem (dk p)) },
    { exact mem_kunion_right p h } }
end

@[simp] theorem mem_kunion_iff (dk : disjoint l₁.keys l₂.keys) : s ∈ l₁.kunion l₂ ↔ s ∈ l₁ ∨ s ∈ l₂ :=
⟨mem_of_mem_kunion, mem_kunion_of_disjoint_keys dk⟩

@[simp] theorem mem_keys_kunion : a ∈ (l₁.kunion l₂).keys ↔ a ∈ l₁.keys ∨ a ∈ l₂.keys :=
by induction l₁ with hd _ ih generalizing l₂;
   [simp, {by_cases h : hd.1 = a; [simp [h], simp [h, ne.symm h, ih]]}]

theorem nodupkeys_kunion (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) :
  (l₁.kunion l₂).nodupkeys :=
by induction l₁ generalizing l₂; simp at nd₁; simp *

theorem perm_kunion_left (l : list (sigma β)) (p : l₁ ~ l₂) : l₁.kunion l ~ l₂.kunion l :=
begin
  induction p generalizing l,
  case list.perm.nil { refl },
  case list.perm.skip : hd tl₁ tl₂ p ih {
    simp [ih (kerase hd.1 l), perm.skip] },
  case list.perm.swap : s₁ s₂ l {
    simp [kerase_comm, perm.swap] },
  case list.perm.trans : l₁ l₂ l₃ p₁₂ p₂₃ ih₁₂ ih₂₃ {
    exact perm.trans (ih₁₂ l) (ih₂₃ l) }
end

theorem perm_kunion_right : ∀ (l : list (sigma β)) {l₁ l₂ : list (sigma β)},
  l₁.nodupkeys → l₂.nodupkeys → l₁ ~ l₂ → l.kunion l₁ ~ l.kunion l₂
| []         _  _  _   _   p := p
| (hd :: tl) l₁ l₂ nd₁ nd₂ p :=
  by simp [perm.skip hd
    (perm_kunion_right tl (nodupkeys_kerase hd.1 nd₁)
                           (nodupkeys_kerase hd.1 nd₂)
                           (perm_kerase nd₁ nd₂ p))]

theorem perm_kunion (nd₂ : l₂.nodupkeys) (nd₄ : l₄.nodupkeys)
  (p₁₃ : l₁ ~ l₃) (p₂₄ : l₂ ~ l₄) : l₁.kunion l₂ ~ l₃.kunion l₄ :=
perm.trans (perm_kunion_left l₂ p₁₃) (perm_kunion_right l₃ nd₂ nd₄ p₂₄)

end kunion

end decidable_eq_α

end αβ

section α₁α₂α₃β₁β₂β₃
universes u v
variables {α₁ α₂ α₃ : Type u} {β₁ : α₁ → Type v} {β₂ : α₂ → Type v} {β₃ : α₃ → Type v}

section keys
variables {s : sigma β₁} {l : list (sigma β₁)} {f : sigma β₁ → sigma β₂}

theorem mem_keys_map_of_mem (f : sigma β₁ → sigma β₂) (ms : s ∈ l) :
  (f s).1 ∈ (l.map f).keys :=
mem_keys_of_mem (mem_map_of_mem f ms)

theorem mem_keys_map (ff : sigma.fst_functional f) (h : s.1 ∈ l.keys) :
  (f s).1 ∈ (l.map f).keys :=
let ⟨_, m, e⟩ := exists_of_mem_map h in ff e ▸ mem_keys_map_of_mem f m

theorem mem_keys_of_mem_keys_map (fi : sigma.fst_injective f) (h : (f s).1 ∈ (l.map f).keys) :
  s.1 ∈ l.keys :=
have h : (sigma.fst ∘ f) s ∈ map (sigma.fst ∘ f) l, by simpa [keys] using h,
let ⟨_, m, e⟩ := exists_of_mem_map h in fi e ▸ mem_keys_of_mem m

-- Is this useful?
theorem mem_keys_of_mem_map (fi : sigma.fst_injective f) (h : f s ∈ l.map f) : s.1 ∈ l.keys :=
let ⟨_, m, e⟩ := exists_of_mem_map h in
fi (sigma.eq_fst e) ▸ mem_keys_of_mem m

@[simp] theorem mem_keys_map_iff (ff : sigma.fst_functional f) (fi : sigma.fst_injective f) :
  (f s).1 ∈ (l.map f).keys ↔ s.1 ∈ l.keys :=
⟨mem_keys_of_mem_keys_map fi, mem_keys_map ff⟩

end keys

section nodupkeys
variables {s t : sigma β₁} {l : list (sigma β₁)} {f : sigma β₁ → sigma β₂}

-- Is this useful?
theorem nodupkeys_injective (fi : sigma.fst_injective f) (d : l.nodupkeys)
  (ms : s ∈ l) (mt : t ∈ l) (h : f s = f t) : s = t :=
eq_of_nodupkeys_of_eq_fst d ms mt $ fi $ sigma.eq_fst h

theorem nodupkeys_of_nodupkeys_map (ff : sigma.fst_functional f) :
  nodupkeys (map f l) → nodupkeys l :=
pairwise_of_pairwise_map f $ λ s t, mt (@ff s t)

theorem nodupkeys_map (fi : sigma.fst_injective f) :
  l.nodupkeys → (l.map f).nodupkeys :=
pairwise_map_of_pairwise f
  (λ s t (h : s ∈ l ∧ t ∈ l ∧ s.1 ≠ t.1), mt (@fi s t) h.2.2) ∘
  pairwise.and_mem.mp

theorem nodupkeys_map_iff (ff : sigma.fst_functional f) (fi : sigma.fst_injective f) :
  (l.map f).nodupkeys ↔ l.nodupkeys :=
⟨nodupkeys_of_nodupkeys_map ff, nodupkeys_map fi⟩

-- Is this useful?
theorem mem_map_of_mem_of_mem_keys_map (fi : sigma.fst_injective f) (d : l.nodupkeys)
  (ms : s ∈ l) (mfs : (f s).1 ∈ (l.map f).keys) : f s ∈ l.map f :=
begin
  simp [keys] at mfs,
  rcases mfs with ⟨a, b, mab, ef⟩,
  cases s with sa sb,
  have ea : a = sa := fi ef,
  subst ea,
  have eb : b = sb := nodupkeys_functional d mab ms rfl,
  subst eb,
  exact mem_map_of_mem f mab,
end

end nodupkeys

section map_disjoint
variables {l₁ l₂ : list (sigma β₁)} {f : sigma β₁ → sigma β₂}

theorem map_disjoint_keys_of_disjoint_keys (fi : sigma.fst_injective f)
  (dk : disjoint l₁.keys l₂.keys) : disjoint (l₁.map f).keys (l₂.map f).keys :=
λ a h₁ h₂,
have h₁ : a ∈ map (sigma.fst ∘ f) l₁, by simpa [keys] using h₁,
let ⟨s, m, e⟩ := exists_of_mem_map h₁ in
have e : (f s).1 = a := e,
dk (mem_keys_of_mem m) (mem_keys_of_mem_keys_map fi (e.symm ▸ h₂))

theorem disjoint_keys_of_map_disjoint_keys (ff : sigma.fst_functional f)
  (dk : disjoint (l₁.map f).keys (l₂.map f).keys) : disjoint l₁.keys l₂.keys :=
λ a h₁ h₂, let ⟨b₁, h₁⟩ := exists_mem_of_mem_keys h₁ in
dk (mem_keys_map_of_mem f h₁) (mem_keys_map ff h₂)

@[simp] theorem map_disjoint_keys (ff : sigma.fst_functional f) (fi : sigma.fst_injective f) :
  disjoint (l₁.map f).keys (l₂.map f).keys ↔ disjoint l₁.keys l₂.keys :=
⟨disjoint_keys_of_map_disjoint_keys ff, map_disjoint_keys_of_disjoint_keys fi⟩

end map_disjoint

section decidable_eq_α₁_α₂
variables [decidable_eq α₁] [decidable_eq α₂]

section map
variables {s : sigma β₁} {l : list (sigma β₁)} {f : sigma β₁ → sigma β₂}

@[simp] theorem map_kerase (ff : sigma.fst_functional f) (fi : sigma.fst_injective f) :
  (l.kerase s.1).map f = (l.map f).kerase (f s).1 :=
begin
  induction l,
  case list.nil { simp },
  case list.cons : hd tl ih {
    by_cases h : (f hd).1 = (f s).1,
    { simp [h, fi h] },
    { simp [h, mt (@ff _ _) h, ih] } }
end

@[simp] theorem map_kinsert (ff : sigma.fst_functional f) (fi : sigma.fst_injective f) :
  (l.kinsert s).map f = (l.map f).kinsert (f s) :=
by simp [ff, fi]

end map

end decidable_eq_α₁_α₂

end α₁α₂α₃β₁β₂β₃

section αβ₁β₂
universes u v
variables {α : Type u} {β₁ β₂ : α → Type v}

section nodupkeys
variables {l : list (sigma β₁)}

theorem nodupkeys_map_id_iff (f : ∀ a, β₁ a → β₂ a) :
  (l.map (sigma.map id f)).nodupkeys ↔ l.nodupkeys :=
nodupkeys_map_iff (sigma.map_id_fst_functional f) (sigma.map_id_fst_injective f)

end nodupkeys

end αβ₁β₂

end list


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.types
import Mathlib.category_theory.equivalence
import Mathlib.data.opposite
import Mathlib.PostPort

universes v₁ u₁ u₂ v₂ v

namespace Mathlib

namespace category_theory

/-- The hom types of the opposite of a category (or graph).

  As with the objects, we'll make this irreducible below.
  Use `f.op` and `f.unop` to convert between morphisms of C
  and morphisms of Cᵒᵖ.
-/
protected instance has_hom.opposite {C : Type u₁} [has_hom C] : has_hom (Cᵒᵖ) :=
  has_hom.mk fun (X Y : Cᵒᵖ) => opposite.unop Y ⟶ opposite.unop X

/--
The opposite of a morphism in `C`.
-/
/--
def has_hom.hom.op {C : Type u₁} [has_hom C] {X : C} {Y : C} (f : X ⟶ Y) : opposite.op Y ⟶ opposite.op X :=
  f

Given a morphism in `Cᵒᵖ`, we can take the "unopposite" back in `C`.
-/
def has_hom.hom.unop {C : Type u₁} [has_hom C] {X : Cᵒᵖ} {Y : Cᵒᵖ} (f : X ⟶ Y) : opposite.unop Y ⟶ opposite.unop X :=
  f

theorem has_hom.hom.op_inj {C : Type u₁} [has_hom C] {X : C} {Y : C} : function.injective has_hom.hom.op :=
  fun (_x _x_1 : X ⟶ Y) (H : has_hom.hom.op _x = has_hom.hom.op _x_1) => congr_arg has_hom.hom.unop H

theorem has_hom.hom.unop_inj {C : Type u₁} [has_hom C] {X : Cᵒᵖ} {Y : Cᵒᵖ} : function.injective has_hom.hom.unop :=
  fun (_x _x_1 : X ⟶ Y) (H : has_hom.hom.unop _x = has_hom.hom.unop _x_1) => congr_arg has_hom.hom.op H

@[simp] theorem has_hom.hom.unop_op {C : Type u₁} [has_hom C] {X : C} {Y : C} {f : X ⟶ Y} : has_hom.hom.unop (has_hom.hom.op f) = f :=
  rfl

@[simp] theorem has_hom.hom.op_unop {C : Type u₁} [has_hom C] {X : Cᵒᵖ} {Y : Cᵒᵖ} {f : X ⟶ Y} : has_hom.hom.op (has_hom.hom.unop f) = f :=
  rfl

/--
The opposite category.

See https://stacks.math.columbia.edu/tag/001M.
-/
protected instance category.opposite {C : Type u₁} [category C] : category (Cᵒᵖ) :=
  category.mk

@[simp] theorem op_comp {C : Type u₁} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} : has_hom.hom.op (f ≫ g) = has_hom.hom.op g ≫ has_hom.hom.op f :=
  rfl

@[simp] theorem op_id {C : Type u₁} [category C] {X : C} : has_hom.hom.op 𝟙 = 𝟙 :=
  rfl

@[simp] theorem unop_comp {C : Type u₁} [category C] {X : Cᵒᵖ} {Y : Cᵒᵖ} {Z : Cᵒᵖ} {f : X ⟶ Y} {g : Y ⟶ Z} : has_hom.hom.unop (f ≫ g) = has_hom.hom.unop g ≫ has_hom.hom.unop f :=
  rfl

@[simp] theorem unop_id {C : Type u₁} [category C] {X : Cᵒᵖ} : has_hom.hom.unop 𝟙 = 𝟙 :=
  rfl

@[simp] theorem unop_id_op {C : Type u₁} [category C] {X : C} : has_hom.hom.unop 𝟙 = 𝟙 :=
  rfl

@[simp] theorem op_id_unop {C : Type u₁} [category C] {X : Cᵒᵖ} : has_hom.hom.op 𝟙 = 𝟙 :=
  rfl

/-- The functor from the double-opposite of a category to the underlying category. -/
def op_op (C : Type u₁) [category C] : Cᵒᵖᵒᵖ ⥤ C :=
  functor.mk (fun (X : Cᵒᵖᵒᵖ) => opposite.unop (opposite.unop X))
    fun (X Y : Cᵒᵖᵒᵖ) (f : X ⟶ Y) => has_hom.hom.unop (has_hom.hom.unop f)

/-- The functor from a category to its double-opposite.  -/
def unop_unop (C : Type u₁) [category C] : C ⥤ (Cᵒᵖᵒᵖ) :=
  functor.mk (fun (X : C) => opposite.op (opposite.op X)) fun (X Y : C) (f : X ⟶ Y) => has_hom.hom.op (has_hom.hom.op f)

/-- The double opposite category is equivalent to the original. -/
@[simp] theorem op_op_equivalence_inverse (C : Type u₁) [category C] : equivalence.inverse (op_op_equivalence C) = unop_unop C :=
  Eq.refl (equivalence.inverse (op_op_equivalence C))

/--
If `f.op` is an isomorphism `f` must be too.
(This cannot be an instance as it would immediately loop!)
-/
def is_iso_of_op {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [is_iso (has_hom.hom.op f)] : is_iso f :=
  is_iso.mk (has_hom.hom.unop (inv (has_hom.hom.op f)))

namespace functor

/--
The opposite of a functor, i.e. considering a functor `F : C ⥤ D` as a functor `Cᵒᵖ ⥤ Dᵒᵖ`.
In informal mathematics no distinction is made between these.
-/
@[simp] theorem op_obj {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) (X : Cᵒᵖ) : obj (functor.op F) X = opposite.op (obj F (opposite.unop X)) :=
  Eq.refl (obj (functor.op F) X)

/--
Given a functor `F : Cᵒᵖ ⥤ Dᵒᵖ` we can take the "unopposite" functor `F : C ⥤ D`.
In informal mathematics no distinction is made between these.
-/
protected def unop {C : Type u₁} [category C] {D : Type u₂} [category D] (F : Cᵒᵖ ⥤ (Dᵒᵖ)) : C ⥤ D :=
  mk (fun (X : C) => opposite.unop (obj F (opposite.op X)))
    fun (X Y : C) (f : X ⟶ Y) => has_hom.hom.unop (map F (has_hom.hom.op f))

/-- The isomorphism between `F.op.unop` and `F`. -/
def op_unop_iso {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) : functor.unop (functor.op F) ≅ F :=
  nat_iso.of_components (fun (X : C) => iso.refl (obj (functor.unop (functor.op F)) X)) sorry

/-- The isomorphism between `F.unop.op` and `F`. -/
def unop_op_iso {C : Type u₁} [category C] {D : Type u₂} [category D] (F : Cᵒᵖ ⥤ (Dᵒᵖ)) : functor.op (functor.unop F) ≅ F :=
  nat_iso.of_components (fun (X : Cᵒᵖ) => iso.refl (obj (functor.op (functor.unop F)) X)) sorry

/--
Taking the opposite of a functor is functorial.
-/
@[simp] theorem op_hom_obj (C : Type u₁) [category C] (D : Type u₂) [category D] (F : C ⥤ Dᵒᵖ) : obj (op_hom C D) F = functor.op (opposite.unop F) :=
  Eq.refl (obj (op_hom C D) F)

/--
Take the "unopposite" of a functor is functorial.
-/
@[simp] theorem op_inv_obj (C : Type u₁) [category C] (D : Type u₂) [category D] (F : Cᵒᵖ ⥤ (Dᵒᵖ)) : obj (op_inv C D) F = opposite.op (functor.unop F) :=
  Eq.refl (obj (op_inv C D) F)

-- TODO show these form an equivalence

/--
Another variant of the opposite of functor, turning a functor `C ⥤ Dᵒᵖ` into a functor `Cᵒᵖ ⥤ D`.
In informal mathematics no distinction is made.
-/
@[simp] theorem left_op_map {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ (Dᵒᵖ)) (X : Cᵒᵖ) (Y : Cᵒᵖ) (f : X ⟶ Y) : map (functor.left_op F) f = has_hom.hom.unop (map F (has_hom.hom.unop f)) :=
  Eq.refl (map (functor.left_op F) f)

/--
Another variant of the opposite of functor, turning a functor `Cᵒᵖ ⥤ D` into a functor `C ⥤ Dᵒᵖ`.
In informal mathematics no distinction is made.
-/
@[simp] theorem right_op_obj {C : Type u₁} [category C] {D : Type u₂} [category D] (F : Cᵒᵖ ⥤ D) (X : C) : obj (functor.right_op F) X = opposite.op (obj F (opposite.op X)) :=
  Eq.refl (obj (functor.right_op F) X)

-- TODO show these form an equivalence

protected instance op.category_theory.full {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} [full F] : full (functor.op F) :=
  full.mk
    fun (X Y : Cᵒᵖ) (f : obj (functor.op F) X ⟶ obj (functor.op F) Y) => has_hom.hom.op (preimage F (has_hom.hom.unop f))

protected instance op.category_theory.faithful {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} [faithful F] : faithful (functor.op F) :=
  faithful.mk

/-- If F is faithful then the right_op of F is also faithful. -/
protected instance right_op_faithful {C : Type u₁} [category C] {D : Type u₂} [category D] {F : Cᵒᵖ ⥤ D} [faithful F] : faithful (functor.right_op F) :=
  faithful.mk

/-- If F is faithful then the left_op of F is also faithful. -/
protected instance left_op_faithful {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ (Dᵒᵖ)} [faithful F] : faithful (functor.left_op F) :=
  faithful.mk

end functor

namespace nat_trans

/-- The opposite of a natural transformation. -/
@[simp] theorem op_app {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ⟶ G) (X : Cᵒᵖ) : app (nat_trans.op α) X = has_hom.hom.op (app α (opposite.unop X)) :=
  Eq.refl (app (nat_trans.op α) X)

@[simp] theorem op_id {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) : nat_trans.op 𝟙 = 𝟙 :=
  rfl

/-- The "unopposite" of a natural transformation. -/
@[simp] theorem unop_app {C : Type u₁} [category C] {D : Type u₂} [category D] {F : Cᵒᵖ ⥤ (Dᵒᵖ)} {G : Cᵒᵖ ⥤ (Dᵒᵖ)} (α : F ⟶ G) (X : C) : app (nat_trans.unop α) X = has_hom.hom.unop (app α (opposite.op X)) :=
  Eq.refl (app (nat_trans.unop α) X)

@[simp] theorem unop_id {C : Type u₁} [category C] {D : Type u₂} [category D] (F : Cᵒᵖ ⥤ (Dᵒᵖ)) : nat_trans.unop 𝟙 = 𝟙 :=
  rfl

/--
Given a natural transformation `α : F.op ⟶ G.op`,
we can take the "unopposite" of each component obtaining a natural transformation `G ⟶ F`.
-/
protected def remove_op {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : functor.op F ⟶ functor.op G) : G ⟶ F :=
  mk fun (X : C) => has_hom.hom.unop (app α (opposite.op X))

@[simp] theorem remove_op_id {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) : nat_trans.remove_op 𝟙 = 𝟙 :=
  rfl

/--
Given a natural transformation `α : F ⟶ G`, for `F G : C ⥤ Dᵒᵖ`,
taking `unop` of each component gives a natural transformation `G.left_op ⟶ F.left_op`.
-/
protected def left_op {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ (Dᵒᵖ)} {G : C ⥤ (Dᵒᵖ)} (α : F ⟶ G) : functor.left_op G ⟶ functor.left_op F :=
  mk fun (X : Cᵒᵖ) => has_hom.hom.unop (app α (opposite.unop X))

@[simp] theorem left_op_app {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ (Dᵒᵖ)} {G : C ⥤ (Dᵒᵖ)} (α : F ⟶ G) (X : Cᵒᵖ) : app (nat_trans.left_op α) X = has_hom.hom.unop (app α (opposite.unop X)) :=
  rfl

/--
Given a natural transformation `α : F.left_op ⟶ G.left_op`, for `F G : C ⥤ Dᵒᵖ`,
taking `op` of each component gives a natural transformation `G ⟶ F`.
-/
protected def remove_left_op {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ (Dᵒᵖ)} {G : C ⥤ (Dᵒᵖ)} (α : functor.left_op F ⟶ functor.left_op G) : G ⟶ F :=
  mk fun (X : C) => has_hom.hom.op (app α (opposite.op X))

@[simp] theorem remove_left_op_app {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ (Dᵒᵖ)} {G : C ⥤ (Dᵒᵖ)} (α : functor.left_op F ⟶ functor.left_op G) (X : C) : app (nat_trans.remove_left_op α) X = has_hom.hom.op (app α (opposite.op X)) :=
  rfl

end nat_trans

namespace iso

/--
The opposite isomorphism.
-/
protected def op {C : Type u₁} [category C] {X : C} {Y : C} (α : X ≅ Y) : opposite.op Y ≅ opposite.op X :=
  mk (has_hom.hom.op (hom α)) (has_hom.hom.op (inv α))

@[simp] theorem op_hom {C : Type u₁} [category C] {X : C} {Y : C} {α : X ≅ Y} : hom (iso.op α) = has_hom.hom.op (hom α) :=
  rfl

@[simp] theorem op_inv {C : Type u₁} [category C] {X : C} {Y : C} {α : X ≅ Y} : inv (iso.op α) = has_hom.hom.op (inv α) :=
  rfl

end iso

namespace nat_iso

/-- The natural isomorphism between opposite functors `G.op ≅ F.op` induced by a natural
isomorphism between the original functors `F ≅ G`. -/
protected def op {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ≅ G) : functor.op G ≅ functor.op F :=
  iso.mk (nat_trans.op (iso.hom α)) (nat_trans.op (iso.inv α))

@[simp] theorem op_hom {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ≅ G) : iso.hom (nat_iso.op α) = nat_trans.op (iso.hom α) :=
  rfl

@[simp] theorem op_inv {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : F ≅ G) : iso.inv (nat_iso.op α) = nat_trans.op (iso.inv α) :=
  rfl

/-- The natural isomorphism between functors `G ≅ F` induced by a natural isomorphism
between the opposite functors `F.op ≅ G.op`. -/
protected def remove_op {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : functor.op F ≅ functor.op G) : G ≅ F :=
  iso.mk (nat_trans.remove_op (iso.hom α)) (nat_trans.remove_op (iso.inv α))

@[simp] theorem remove_op_hom {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : functor.op F ≅ functor.op G) : iso.hom (nat_iso.remove_op α) = nat_trans.remove_op (iso.hom α) :=
  rfl

@[simp] theorem remove_op_inv {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D} (α : functor.op F ≅ functor.op G) : iso.inv (nat_iso.remove_op α) = nat_trans.remove_op (iso.inv α) :=
  rfl

/-- The natural isomorphism between functors `G.unop ≅ F.unop` induced by a natural isomorphism
between the original functors `F ≅ G`. -/
protected def unop {C : Type u₁} [category C] {D : Type u₂} [category D] {F : Cᵒᵖ ⥤ (Dᵒᵖ)} {G : Cᵒᵖ ⥤ (Dᵒᵖ)} (α : F ≅ G) : functor.unop G ≅ functor.unop F :=
  iso.mk (nat_trans.unop (iso.hom α)) (nat_trans.unop (iso.inv α))

@[simp] theorem unop_hom {C : Type u₁} [category C] {D : Type u₂} [category D] {F : Cᵒᵖ ⥤ (Dᵒᵖ)} {G : Cᵒᵖ ⥤ (Dᵒᵖ)} (α : F ≅ G) : iso.hom (nat_iso.unop α) = nat_trans.unop (iso.hom α) :=
  rfl

@[simp] theorem unop_inv {C : Type u₁} [category C] {D : Type u₂} [category D] {F : Cᵒᵖ ⥤ (Dᵒᵖ)} {G : Cᵒᵖ ⥤ (Dᵒᵖ)} (α : F ≅ G) : iso.inv (nat_iso.unop α) = nat_trans.unop (iso.inv α) :=
  rfl

end nat_iso

namespace equivalence

/--
An equivalence between categories gives an equivalence between the opposite categories.
-/
@[simp] theorem op_inverse {C : Type u₁} [category C] {D : Type u₂} [category D] (e : C ≌ D) : inverse (op e) = functor.op (inverse e) :=
  Eq.refl (inverse (op e))

/--
An equivalence between opposite categories gives an equivalence between the original categories.
-/
@[simp] theorem unop_unit_iso {C : Type u₁} [category C] {D : Type u₂} [category D] (e : Cᵒᵖ ≌ (Dᵒᵖ)) : unit_iso (unop e) = iso.symm (nat_iso.unop (unit_iso e)) :=
  Eq.refl (unit_iso (unop e))

end equivalence

/-- The equivalence between arrows of the form `A ⟶ B` and `B.unop ⟶ A.unop`. Useful for building
adjunctions.
Note that this (definitionally) gives variants
```
def op_equiv' (A : C) (B : Cᵒᵖ) : (opposite.op A ⟶ B) ≃ (B.unop ⟶ A) :=
op_equiv _ _

def op_equiv'' (A : Cᵒᵖ) (B : C) : (A ⟶ opposite.op B) ≃ (B ⟶ A.unop) :=
op_equiv _ _

def op_equiv''' (A B : C) : (opposite.op A ⟶ opposite.op B) ≃ (B ⟶ A) :=
op_equiv _ _
```
-/
def op_equiv {C : Type u₁} [category C] (A : Cᵒᵖ) (B : Cᵒᵖ) : (A ⟶ B) ≃ (opposite.unop B ⟶ opposite.unop A) :=
  equiv.mk (fun (f : A ⟶ B) => has_hom.hom.unop f) (fun (g : opposite.unop B ⟶ opposite.unop A) => has_hom.hom.op g) sorry
    sorry

-- These two are made by hand rather than by simps because simps generates

-- `(op_equiv _ _).to_fun f = ...` rather than the coercion version.

@[simp] theorem op_equiv_apply {C : Type u₁} [category C] (A : Cᵒᵖ) (B : Cᵒᵖ) (f : A ⟶ B) : coe_fn (op_equiv A B) f = has_hom.hom.unop f :=
  rfl

@[simp] theorem op_equiv_symm_apply {C : Type u₁} [category C] (A : Cᵒᵖ) (B : Cᵒᵖ) (f : opposite.unop B ⟶ opposite.unop A) : coe_fn (equiv.symm (op_equiv A B)) f = has_hom.hom.op f :=
  rfl

/-- Construct a morphism in the opposite of a preorder category from an inequality. -/
def op_hom_of_le {α : Type v} [preorder α] {U : αᵒᵖ} {V : αᵒᵖ} (h : opposite.unop V ≤ opposite.unop U) : U ⟶ V :=
  has_hom.hom.op (hom_of_le h)

theorem le_of_op_hom {α : Type v} [preorder α] {U : αᵒᵖ} {V : αᵒᵖ} (h : U ⟶ V) : opposite.unop V ≤ opposite.unop U :=
  le_of_hom (has_hom.hom.unop h)


def small (ps : Array (Nat × Nat)) : Array (Nat × Nat) :=
  (ps.filter fun (p : Prod _ _) =>
    match p with
    | (x, y) => x == 0)
  ++
  ps

#eval small #[(1, 2), (0, 3), (2, 4)]

variable {α β : Type} [Inhabited α] [Inhabited β]

def P (xys : Array (α × β)) (f : α → β) : Prop := True

example (xys : Array (α × β))
        (pred? : α → Bool)
        (H : Subtype $ P (xys.filter fun (x, _) => pred? x))
        : Unit := ()


/-
# References

1. Enderton, Herbert B. A Mathematical Introduction to Logic. 2nd ed. San Diego:
   Harcourt/Academic Press, 2001.
-/

import Bookshelf.Tuple

/--
The following describes a so-called "generic" tuple. Like in `Bookshelf.Tuple`,
an `n`-tuple is defined recursively like so:

  `⟨x₁, ..., xₙ⟩ = ⟨⟨x₁, ..., xₙ₋₁⟩, xₙ⟩`

Unlike `Bookshelf.Tuple`, a "generic" tuple bends the syntax above further. For
example, both tuples above are equivalent to:

  `⟨⟨x₁, ..., xₘ⟩, xₘ₊₁, ..., xₙ⟩`

for some `1 ≤ m ≤ n`. This distinction is purely syntactic, but necessary to
prove certain theorems found in [1] (e.g. `lemma_0a`).

In general, prefer `Bookshelf.Tuple`.
-/
inductive XTuple : (α : Type u) → (size : Nat × Nat) → Type u where
  | nil : XTuple α (0, 0)
  | snoc : XTuple α (p, q) → Tuple α r → XTuple α (p + q, r)

syntax (priority := high) "x[" term,* "]" : term

macro_rules
  | `(x[]) => `(XTuple.nil)
  | `(x[$x]) => `(XTuple.snoc x[] t[$x])
  | `(x[x[$xs:term,*], $ys:term,*]) => `(XTuple.snoc x[$xs,*] t[$ys,*])
  | `(x[$x, $xs:term,*]) => `(XTuple.snoc x[] t[$x, $xs,*])

namespace XTuple

open scoped Tuple

/- -------------------------------------
 - Normalization
 - -------------------------------------/

/--
Converts an `XTuple` into "normal form".
-/
def norm : XTuple α (m, n) → Tuple α (m + n)
  |         x[] => t[]
  | snoc  is ts => Tuple.concat is.norm ts

/--
Normalization of an empty `XTuple` yields an empty `Tuple`.
-/
theorem norm_nil_eq_nil : @norm α 0 0 nil = Tuple.nil :=
  rfl

/--
Normalization of a pseudo-empty `XTuple` yields an empty `Tuple`.
-/
theorem norm_snoc_nil_nil_eq_nil : @norm α 0 0 (snoc x[] t[]) = t[] := by
  unfold norm norm
  rfl

/--
Normalization elimates `snoc` when the `snd` component is `nil`.
-/
theorem norm_snoc_nil_elim {t : XTuple α (p, q)}
  : norm (snoc t t[]) = norm t :=
  XTuple.casesOn t
    (motive := fun _ t => norm (snoc t t[]) = norm t)
    (by simp; unfold norm norm; rfl)
    (fun tf tl => by
      simp
      conv => lhs; unfold norm)

/--
Normalization eliminates `snoc` when the `fst` component is `nil`.
-/
theorem norm_nil_snoc_elim {ts : Tuple α n} : norm (snoc x[] ts) = cast (by simp) ts := by
  unfold norm norm
  rw [Tuple.nil_concat_self_eq_self]

/--
Normalization distributes across `Tuple.snoc` calls.
-/
theorem norm_snoc_snoc_norm
  : norm (snoc as (Tuple.snoc bs b)) = Tuple.snoc (norm (snoc as bs)) b := by
  unfold norm
  rw [←Tuple.concat_snoc_snoc_concat]

/--
Normalizing an `XTuple` is equivalent to concatenating the normalized `fst`
component with the `snd`.
-/
theorem norm_snoc_eq_concat {t₁ : XTuple α (p, q)} {t₂ : Tuple α n}
  : norm (snoc t₁ t₂) = Tuple.concat t₁.norm t₂ := by
  conv => lhs; unfold norm

/- -------------------------------------
 - Equality
 - -------------------------------------/

/--
Implements Boolean equality for `XTuple α n` provided `α` has decidable
equality.
-/
instance BEq [DecidableEq α] : BEq (XTuple α n) where
  beq t₁ t₂ := t₁.norm == t₂.norm

/- -------------------------------------
 - Basic API
 - -------------------------------------/

/--
Returns the number of entries in the `XTuple`.
-/
def size (_ : XTuple α n) := n

/--
Returns the number of entries in the "shallowest" portion of the `XTuple`. For
example, the length of `x[x[1, 2], 3, 4]` is `3`, despite its size being `4`.
-/
def length : XTuple α n → Nat
  |         x[] => 0
  | snoc x[] ts => ts.size
  | snoc   _ ts => 1 + ts.size

/--
Returns the first component of our `XTuple`. For example, the first component of
tuple `x[x[1, 2], 3, 4]` is `t[1, 2]`.
-/
def fst : XTuple α (m, n) → Tuple α m
  | x[] => t[]
  | snoc ts _ => ts.norm

/--
Given `XTuple α (m, n)`, the `fst` component is equal to an initial segment of
size `k` of the tuple in normal form.
-/
theorem self_fst_eq_norm_take (t : XTuple α (m, n)) : t.fst = t.norm.take m :=
  match t with
  | x[] => by unfold fst; rw [Tuple.self_take_zero_eq_nil]; simp
  | snoc tf tl => by
    unfold fst
    conv => rhs; unfold norm
    rw [Tuple.eq_take_concat]
    simp

/--
If the normal form of an `XTuple` is equal to a `Tuple`, the `fst` component
must be a prefix of the `Tuple`.
-/
theorem norm_eq_fst_eq_take {t₁ : XTuple α (m, n)} {t₂ : Tuple α (m + n)}
  : (t₁.norm = t₂) → (t₁.fst = t₂.take m) :=
  fun h => by rw [self_fst_eq_norm_take, h]

/--
Returns the first component of our `XTuple`. For example, the first component of
tuple `x[x[1, 2], 3, 4]` is `t[3, 4]`.
-/
def snd : XTuple α (m, n) → Tuple α n
  | x[] => t[]
  | snoc _ ts => ts

/- -------------------------------------
 - Lemma 0A
 - -------------------------------------/

section

variable {k m n : Nat}
variable (p : 1 ≤ m)
variable (q : n + (m - 1) = m + k)

namespace Lemma_0a

lemma n_eq_succ_k : n = k + 1 :=
  let ⟨m', h⟩ := Nat.exists_eq_succ_of_ne_zero $ show m ≠ 0 by
    intro h
    have ff : 1 ≤ 0 := h ▸ p
    ring_nf at ff
    exact ff.elim
  calc
    n = n + (m - 1) - (m - 1) := by rw [Nat.add_sub_cancel]
    _ = m' + 1 + k - (m' + 1 - 1) := by rw [q, h]
    _ = m' + 1 + k - m' := by simp
    _ = 1 + k + m' - m' := by rw [Nat.add_assoc, Nat.add_comm]
    _ = 1 + k := by simp
    _ = k + 1 := by rw [Nat.add_comm]

lemma n_pred_eq_k : n - 1 = k := by
  have h : k + 1 - 1 = k + 1 - 1 := rfl
  conv at h => lhs; rw [←n_eq_succ_k p q]
  simp at h
  exact h

lemma n_geq_one : 1 ≤ n := by
  rw [n_eq_succ_k p q]
  simp

lemma min_comm_succ_eq : min (m + k) (k + 1) = k + 1 :=
  Nat.recOn k
    (by simp; exact p)
    (fun k' ih => calc
      min (m + (k' + 1)) (k' + 1 + 1)
          = min (m + k' + 1) (k' + 1 + 1) := by conv => rw [Nat.add_assoc]
        _ = min (m + k') (k' + 1) + 1 := Nat.min_succ_succ (m + k') (k' + 1)
        _ = k' + 1 + 1 := by rw [ih])

lemma n_eq_min_comm_succ : n = min (m + k) (k + 1) := by
  rw [min_comm_succ_eq p]
  exact n_eq_succ_k p q

lemma n_pred_m_eq_m_k : n + (m - 1) = m + k := by
  rw [←Nat.add_sub_assoc p, Nat.add_comm, Nat.add_sub_assoc (n_geq_one p q)]
  conv => lhs; rw [n_pred_eq_k p q]

def cast_norm : XTuple α (n, m - 1) → Tuple α (m + k)
  | xs => cast (by rw [q]) xs.norm

def cast_fst : XTuple α (n, m - 1) → Tuple α (k + 1)
  | xs => cast (by rw [n_eq_succ_k p q]) xs.fst

def cast_take (ys : Tuple α (m + k)) :=
  cast (by rw [min_comm_succ_eq p]) (ys.take (k + 1))

end Lemma_0a

open Lemma_0a

/--[1]
Assume that ⟨x₁, ..., xₘ⟩ = ⟨y₁, ..., yₘ, ..., yₘ₊ₖ⟩. Then x₁ = ⟨y₁, ..., yₖ₊₁⟩.
-/
theorem lemma_0a (xs : XTuple α (n, m - 1)) (ys : Tuple α (m + k))
  : (cast_norm q xs = ys) → (cast_fst p q xs = cast_take p ys) := by
  intro h
  suffices HEq
    (cast (_ : Tuple α n = Tuple α (k + 1)) (fst xs))
    (cast (_ : Tuple α (min (m + k) (k + 1)) = Tuple α (k + 1)) (Tuple.take ys (k + 1)))
    from eq_of_heq this
  congr
  · exact n_eq_min_comm_succ p q
  · rfl
  · exact n_eq_min_comm_succ p q
  · exact HEq.rfl
  · exact Eq.recOn
      (motive := fun _ h => HEq
        (_ : n + (n - 1) = n + k)
        (cast h (show n + (n - 1) = n + k by rw [n_pred_eq_k p q])))
      (show (n + (n - 1) = n + k) = (min (m + k) (k + 1) + (n - 1) = n + k) by
        rw [n_eq_min_comm_succ p q])
      HEq.rfl
  · exact n_geq_one p q
  · exact n_pred_eq_k p q
  · exact Eq.symm (n_eq_min_comm_succ p q)
  · exact n_pred_eq_k p q
  · rw [self_fst_eq_norm_take]
    unfold cast_norm at h
    simp at h
    rw [←h, ←n_eq_succ_k p q]
    have h₂ := Eq.recOn
      (motive := fun x h => HEq
        (Tuple.take xs.norm n)
        (Tuple.take (cast (show Tuple α (n + (m - 1)) = Tuple α x by rw [h]) xs.norm) n))
      (show n + (m - 1) = m + k by rw [n_pred_m_eq_m_k p q])
      HEq.rfl
    exact Eq.recOn
      (motive := fun x h => HEq
        (cast h (Tuple.take xs.norm n))
        (Tuple.take (cast (_ : Tuple α (n + (m - 1)) = Tuple α (m + k)) xs.norm) n))
      (show Tuple α (min (n + (m - 1)) n) = Tuple α n by simp)
      h₂

end

end XTuple


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad, Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.functor.multivariate
import Mathlib.data.pfunctor.multivariate.basic
import Mathlib.data.pfunctor.multivariate.M
import Mathlib.data.qpf.multivariate.basic
import Mathlib.PostPort

universes u u_1

namespace Mathlib

/-!
# The final co-algebra of a multivariate qpf is again a qpf.

For a `(n+1)`-ary QPF `F (α₀,..,αₙ)`, we take the least fixed point of `F` with
regards to its last argument `αₙ`. The result is a `n`-ary functor: `fix F (α₀,..,αₙ₋₁)`.
Making `fix F` into a functor allows us to take the fixed point, compose with other functors
and take a fixed point again.

## Main definitions

 * `cofix.mk`     - constructor
 * `cofix.dest    - destructor
 * `cofix.corec`  - corecursor: useful for formulating infinite, productive computations
 * `cofix.bisim`  - bisimulation: proof technique to show the equality of possibly infinite values
                    of `cofix F α`

## Implementation notes

For `F` a QPF`, we define `cofix F α` in terms of the M-type of the polynomial functor `P` of `F`.
We define the relation `Mcongr` and take its quotient as the definition of `cofix F α`.

`Mcongr` is taken as the weakest bisimulation on M-type.  See
[avigad-carneiro-hudon2019] for more details.

## Reference

 * [Jeremy Avigad, Mario M. Carneiro and Simon Hudon, *Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]
-/

namespace mvqpf

/-- `corecF` is used as a basis for defining the corecursor of `cofix F α`. `corecF`
uses corecursion to construct the M-type generated by `q.P` and uses function on `F`
as a corecursive step -/
def corecF {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n}
    {β : Type u} (g : β → F (α ::: β)) : β → mvpfunctor.M (P F) α :=
  mvpfunctor.M.corec (P F) fun (x : β) => repr (g x)

theorem corecF_eq {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n}
    {β : Type u} (g : β → F (α ::: β)) (x : β) :
    mvpfunctor.M.dest (P F) (corecF g x) = mvfunctor.map (typevec.id ::: corecF g) (repr (g x)) :=
  sorry

/-- Characterization of desirable equivalence relations on M-types -/
def is_precongr {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n}
    (r : mvpfunctor.M (P F) α → mvpfunctor.M (P F) α → Prop) :=
  ∀ {x y : mvpfunctor.M (P F) α},
    r x y →
      abs (mvfunctor.map (typevec.id ::: Quot.mk r) (mvpfunctor.M.dest (P F) x)) =
        abs (mvfunctor.map (typevec.id ::: Quot.mk r) (mvpfunctor.M.dest (P F) y))

/-- Equivalence relation on M-types representing a value of type `cofix F` -/
def Mcongr {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n}
    (x : mvpfunctor.M (P F) α) (y : mvpfunctor.M (P F) α) :=
  ∃ (r : mvpfunctor.M (P F) α → mvpfunctor.M (P F) α → Prop), is_precongr r ∧ r x y

/-- Greatest fixed point of functor F. The result is a functor with one fewer parameters
than the input. For `F a b c` a ternary functor, fix F is a binary functor such that

```lean
cofix F a b = F a b (cofix F a b)
```
-/
def cofix {n : ℕ} (F : typevec (n + 1) → Type u) [mvfunctor F] [q : mvqpf F] (α : typevec n) :=
  Quot Mcongr

protected instance cofix.inhabited {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F]
    [q : mvqpf F] {α : typevec n} [Inhabited (mvpfunctor.A (P F))]
    [(i : fin2 n) → Inhabited (α i)] : Inhabited (cofix F α) :=
  { default := Quot.mk Mcongr Inhabited.default }

/-- maps every element of the W type to a canonical representative -/
def Mrepr {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} :
    mvpfunctor.M (P F) α → mvpfunctor.M (P F) α :=
  corecF (abs ∘ mvpfunctor.M.dest (P F))

/-- the map function for the functor `cofix F` -/
def cofix.map {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n}
    {β : typevec n} (g : typevec.arrow α β) : cofix F α → cofix F β :=
  Quot.lift (fun (x : mvpfunctor.M (P F) α) => Quot.mk Mcongr (mvfunctor.map g x)) sorry

protected instance cofix.mvfunctor {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F]
    [q : mvqpf F] : mvfunctor (cofix F) :=
  mvfunctor.mk cofix.map

/-- Corecursor for `cofix F` -/
def cofix.corec {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n}
    {β : Type u} (g : β → F (α ::: β)) : β → cofix F α :=
  fun (x : β) => Quot.mk Mcongr (corecF g x)

/-- Destructor for `cofix F` -/
def cofix.dest {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} :
    cofix F α → F (α ::: cofix F α) :=
  Quot.lift
    (fun (x : mvpfunctor.M (P F) α) =>
      mvfunctor.map (typevec.id ::: Quot.mk Mcongr) (abs (mvpfunctor.M.dest (P F) x)))
    sorry

/-- Abstraction function for `cofix F α` -/
def cofix.abs {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} :
    mvpfunctor.M (P F) α → cofix F α :=
  Quot.mk Mcongr

/-- Representation function for `cofix F α` -/
def cofix.repr {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} :
    cofix F α → mvpfunctor.M (P F) α :=
  mvpfunctor.M.corec (P F) (repr ∘ cofix.dest)

/-- Corecursor for `cofix F` -/
def cofix.corec'₁ {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n}
    {β : Type u} (g : {X : Type u} → (β → X) → F (α ::: X)) (x : β) : cofix F α :=
  cofix.corec (fun (x : β) => g id) x

/-- More flexible corecursor for `cofix F`. Allows the return of a fully formed
value instead of making a recursive call -/
def cofix.corec' {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n}
    {β : Type u} (g : β → F (α ::: (cofix F α ⊕ β))) (x : β) : cofix F α :=
  let f : typevec.arrow (α ::: cofix F α) (α ::: (cofix F α ⊕ β)) := typevec.id ::: sum.inl;
  cofix.corec (sum.elim (mvfunctor.map f ∘ cofix.dest) g) (sum.inr x)

/-- Corecursor for `cofix F`. The shape allows recursive calls to
look like recursive calls. -/
def cofix.corec₁ {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n}
    {β : Type u} (g : {X : Type u} → (cofix F α → X) → (β → X) → β → F (α ::: X)) (x : β) :
    cofix F α :=
  cofix.corec' (fun (x : β) => g sum.inl sum.inr x) x

theorem cofix.dest_corec {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F]
    {α : typevec n} {β : Type u} (g : β → F (α ::: β)) (x : β) :
    cofix.dest (cofix.corec g x) = mvfunctor.map (typevec.id ::: cofix.corec g) (g x) :=
  sorry

/-- constructor for `cofix F` -/
def cofix.mk {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n} :
    F (α ::: cofix F α) → cofix F α :=
  cofix.corec
    fun (x : F (α ::: cofix F α)) =>
      mvfunctor.map (typevec.id ::: fun (i : cofix F α) => cofix.dest i) x

/-!
## Bisimulation principles for `cofix F`

The following theorems are bisimulation principles. The general idea
is to use a bisimulation relation to prove the equality between
specific values of type `cofix F α`.

A bisimulation relation `R` for values `x y : cofix F α`:

 * holds for `x y`: `R x y`
 * for any values `x y` that satisfy `R`, their root has the same shape
   and their children can be paired in such a way that they satisfy `R`.

-/

/-- Bisimulation principle using `map` and `quot.mk` to match and relate children of two trees. -/
theorem cofix.bisim_rel {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F]
    {α : typevec n} (r : cofix F α → cofix F α → Prop)
    (h :
      ∀ (x y : cofix F α),
        r x y →
          mvfunctor.map (typevec.id ::: Quot.mk r) (cofix.dest x) =
            mvfunctor.map (typevec.id ::: Quot.mk r) (cofix.dest y))
    (x : cofix F α) (y : cofix F α) : r x y → x = y :=
  sorry

/-- Bisimulation principle using `liftr` to match and relate children of two trees. -/
theorem cofix.bisim {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F]
    {α : typevec n} (r : cofix F α → cofix F α → Prop)
    (h :
      ∀ (x y : cofix F α),
        r x y → mvfunctor.liftr (typevec.rel_last α r) (cofix.dest x) (cofix.dest y))
    (x : cofix F α) (y : cofix F α) : r x y → x = y :=
  sorry

/-- Bisimulation principle using `liftr'` to match and relate children of two trees. -/
theorem cofix.bisim₂ {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F]
    {α : typevec n} (r : cofix F α → cofix F α → Prop)
    (h :
      ∀ (x y : cofix F α),
        r x y → mvfunctor.liftr' (typevec.rel_last' α r) (cofix.dest x) (cofix.dest y))
    (x : cofix F α) (y : cofix F α) : r x y → x = y :=
  sorry

/-- Bisimulation principle the values `⟨a,f⟩` of the polynomial functor representing
`cofix F α` as well as an invariant `Q : β → Prop` and a state `β` generating the
left-hand side and right-hand side of the equality through functions `u v : β → cofix F α` -/
theorem cofix.bisim' {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F]
    {α : typevec n} {β : Type u_1} (Q : β → Prop) (u : β → cofix F α) (v : β → cofix F α)
    (h :
      ∀ (x : β),
        Q x →
          ∃ (a : mvpfunctor.A (P F)),
            ∃ (f' : typevec.arrow (mvpfunctor.B (mvpfunctor.drop (P F)) a) α),
              ∃ (f₀ : pfunctor.B (mvpfunctor.last (P F)) a → cofix F α),
                ∃ (f₁ : pfunctor.B (mvpfunctor.last (P F)) a → cofix F α),
                  cofix.dest (u x) = abs (sigma.mk a (mvpfunctor.append_contents (P F) f' f₀)) ∧
                    cofix.dest (v x) = abs (sigma.mk a (mvpfunctor.append_contents (P F) f' f₁)) ∧
                      ∀ (i : pfunctor.B (mvpfunctor.last (P F)) a),
                        ∃ (x' : β), Q x' ∧ f₀ i = u x' ∧ f₁ i = v x')
    (x : β) : Q x → u x = v x :=
  sorry

theorem cofix.mk_dest {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F]
    {α : typevec n} (x : cofix F α) : cofix.mk (cofix.dest x) = x :=
  sorry

theorem cofix.dest_mk {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F]
    {α : typevec n} (x : F (α ::: cofix F α)) : cofix.dest (cofix.mk x) = x :=
  sorry

theorem cofix.ext {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] {α : typevec n}
    (x : cofix F α) (y : cofix F α) (h : cofix.dest x = cofix.dest y) : x = y :=
  eq.mpr (id (Eq._oldrec (Eq.refl (x = y)) (Eq.symm (cofix.mk_dest x))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (cofix.mk (cofix.dest x) = y)) h))
      (eq.mpr (id (Eq._oldrec (Eq.refl (cofix.mk (cofix.dest y) = y)) (cofix.mk_dest y)))
        (Eq.refl y)))

theorem cofix.ext_mk {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F]
    {α : typevec n} (x : F (α ::: cofix F α)) (y : F (α ::: cofix F α))
    (h : cofix.mk x = cofix.mk y) : x = y :=
  eq.mpr (id (Eq._oldrec (Eq.refl (x = y)) (Eq.symm (cofix.dest_mk x))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (cofix.dest (cofix.mk x) = y)) h))
      (eq.mpr (id (Eq._oldrec (Eq.refl (cofix.dest (cofix.mk y) = y)) (cofix.dest_mk y)))
        (Eq.refl y)))

/-!
`liftr_map`, `liftr_map_last` and `liftr_map_last'` are useful for reasoning about
the induction step in bisimulation proofs.
-/

theorem liftr_map {n : ℕ} {α : typevec n} {β : typevec n} {F' : typevec n → Type u} [mvfunctor F']
    [is_lawful_mvfunctor F'] (R : typevec.arrow (typevec.prod β β) (typevec.repeat n Prop))
    (x : F' α) (f : typevec.arrow α β) (g : typevec.arrow α β)
    (h : typevec.arrow α (typevec.subtype_ R))
    (hh :
      typevec.comp (typevec.subtype_val R) h =
        typevec.comp (typevec.prod.map f g) typevec.prod.diag) :
    mvfunctor.liftr' R (mvfunctor.map f x) (mvfunctor.map g x) :=
  sorry

theorem liftr_map_last {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [is_lawful_mvfunctor F]
    {α : typevec n} {ι : Type u} {ι' : Type u} (R : ι' → ι' → Prop) (x : F (α ::: ι)) (f : ι → ι')
    (g : ι → ι') (hh : ∀ (x : ι), R (f x) (g x)) :
    mvfunctor.liftr' (typevec.rel_last' α R) (mvfunctor.map (typevec.id ::: f) x)
        (mvfunctor.map (typevec.id ::: g) x) :=
  sorry

theorem liftr_map_last' {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [is_lawful_mvfunctor F]
    {α : typevec n} {ι : Type u} (R : ι → ι → Prop) (x : F (α ::: ι)) (f : ι → ι)
    (hh : ∀ (x : ι), R (f x) x) :
    mvfunctor.liftr' (typevec.rel_last' α R) (mvfunctor.map (typevec.id ::: f) x) x :=
  sorry

theorem cofix.abs_repr {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F]
    {α : typevec n} (x : cofix F α) : Quot.mk Mcongr (cofix.repr x) = x :=
  sorry

/-- tactic for proof by bisimulation -/
theorem corec_roll {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F]
    {α : typevec n} {X : Type u} {Y : Type u} {x₀ : X} (f : X → Y) (g : Y → F (α ::: X)) :
    cofix.corec (g ∘ f) x₀ = cofix.corec (mvfunctor.map (typevec.id ::: f) ∘ g) (f x₀) :=
  sorry

theorem cofix.dest_corec' {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F]
    {α : typevec n} {β : Type u} (g : β → F (α ::: (cofix F α ⊕ β))) (x : β) :
    cofix.dest (cofix.corec' g x) =
        mvfunctor.map (typevec.id ::: sum.elim id (cofix.corec' g)) (g x) :=
  sorry

theorem cofix.dest_corec₁ {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F]
    {α : typevec n} {β : Type u} (g : {X : Type u} → (cofix F α → X) → (β → X) → β → F (α ::: X))
    (x : β)
    (h :
      ∀ (X Y : Type u) (f : cofix F α → X) (f' : β → X) (k : X → Y),
        g (k ∘ f) (k ∘ f') x = mvfunctor.map (typevec.id ::: k) (g f f' x)) :
    cofix.dest (cofix.corec₁ g x) = g id (cofix.corec₁ g) x :=
  sorry

protected instance mvqpf_cofix {n : ℕ} {F : typevec (n + 1) → Type u} [mvfunctor F] [q : mvqpf F] :
    mvqpf (cofix F) :=
  mk (mvpfunctor.Mp (P F)) (fun (α : typevec n) => Quot.mk Mcongr)
    (fun (α : typevec n) => cofix.repr) sorry sorry

end Mathlib


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

universes u_1 u_3 u_5 u_6 l w

namespace Mathlib

/-!
# The Grothendieck construction

Given a functor `F : C ⥤ Cat`, the objects of `grothendieck F`
consist of dependent pairs `(b, f)`, where `b : C` and `f : F.obj c`,
and a morphism `(b, f) ⟶ (b', f')` is a pair `β : b ⟶ b'` in `C`, and
`φ : (F.map β).obj f ⟶ f'`

Categories such as `PresheafedSpace` are in fact examples of this construction,
and it may be interesting to try to generalize some of the development there.

## Implementation notes

Really we should treat `Cat` as a 2-category, and allow `F` to be a 2-functor.

There is also a closely related construction starting with `G : Cᵒᵖ ⥤ Cat`,
where morphisms consists again of `β : b ⟶ b'` and `φ : f ⟶ (F.map (op β)).obj f'`.

## References

See also `category_theory.functor.elements` for the category of elements of functor `F : C ⥤ Type`.

* https://stacks.math.columbia.edu/tag/02XV
* https://ncatlab.org/nlab/show/Grothendieck+construction

-/

namespace category_theory

/--
The Grothendieck construction (often written as `∫ F` in mathematics) for a functor `F : C ⥤ Cat`
gives a category whose
* objects `X` consist of `X.base : C` and `X.fiber : F.obj base`
* morphisms `f : X ⟶ Y` consist of
  `base : X.base ⟶ Y.base` and
  `f.fiber : (F.map base).obj X.fiber ⟶ Y.fiber`
-/
structure grothendieck {C : Type u_1} [category C] (F : C ⥤ Cat) where
  base : C
  fiber : ↥(functor.obj F base)

namespace grothendieck

/--
A morphism in the Grothendieck category `F : C ⥤ Cat` consists of
`base : X.base ⟶ Y.base` and `f.fiber : (F.map base).obj X.fiber ⟶ Y.fiber`.
-/
structure hom {C : Type u_1} [category C] {F : C ⥤ Cat} (X : grothendieck F) (Y : grothendieck F)
    where
  base : base X ⟶ base Y
  fiber : functor.obj (functor.map F base) (fiber X) ⟶ fiber Y

theorem ext {C : Type u_1} [category C] {F : C ⥤ Cat} {X : grothendieck F} {Y : grothendieck F}
    (f : hom X Y) (g : hom X Y) (w_base : hom.base f = hom.base g)
    (w_fiber :
      eq_to_hom
            (eq.mpr
              (id
                (Eq._oldrec
                  (Eq.refl
                    (functor.obj (functor.map F (hom.base g)) (fiber X) =
                      functor.obj (functor.map F (hom.base f)) (fiber X)))
                  w_base))
              (Eq.refl (functor.obj (functor.map F (hom.base g)) (fiber X)))) ≫
          hom.fiber f =
        hom.fiber g) :
    f = g :=
  sorry

/--
The identity morphism in the Grothendieck category.
-/
@[simp] theorem id_fiber {C : Type u_1} [category C] {F : C ⥤ Cat} (X : grothendieck F) :
    hom.fiber (id X) = eq_to_hom (id._proof_1 X) :=
  Eq.refl (hom.fiber (id X))

protected instance hom.inhabited {C : Type u_1} [category C] {F : C ⥤ Cat} (X : grothendieck F) :
    Inhabited (hom X X) :=
  { default := id X }

/--
Composition of morphisms in the Grothendieck category.
-/
@[simp] theorem comp_fiber {C : Type u_1} [category C] {F : C ⥤ Cat} {X : grothendieck F}
    {Y : grothendieck F} {Z : grothendieck F} (f : hom X Y) (g : hom Y Z) :
    hom.fiber (comp f g) =
        eq_to_hom (comp._proof_1 f g) ≫
          functor.map (functor.map F (hom.base g)) (hom.fiber f) ≫ hom.fiber g :=
  Eq.refl (hom.fiber (comp f g))

protected instance category_theory.category {C : Type u_1} [category C] {F : C ⥤ Cat} :
    category (grothendieck F) :=
  category.mk

@[simp] theorem id_fiber' {C : Type u_1} [category C] {F : C ⥤ Cat} (X : grothendieck F) :
    hom.fiber 𝟙 =
        eq_to_hom
          (eq.mpr
            (id
              (Eq._oldrec (Eq.refl (functor.obj (functor.map F (hom.base 𝟙)) (fiber X) = fiber X))
                (functor.map_id F (base X))))
            (eq.mpr
              (id
                (Eq._oldrec (Eq.refl (functor.obj 𝟙 (fiber X) = fiber X))
                  (functor.id_obj (fiber X))))
              (Eq.refl (fiber X)))) :=
  id_fiber X

theorem congr {C : Type u_1} [category C] {F : C ⥤ Cat} {X : grothendieck F} {Y : grothendieck F}
    {f : X ⟶ Y} {g : X ⟶ Y} (h : f = g) :
    hom.fiber f =
        eq_to_hom (Eq._oldrec (Eq.refl (functor.obj (functor.map F (hom.base f)) (fiber X))) h) ≫
          hom.fiber g :=
  sorry

/-- The forgetful functor from `grothendieck F` to the source category. -/
def forget {C : Type u_1} [category C] (F : C ⥤ Cat) : grothendieck F ⥤ C :=
  functor.mk (fun (X : grothendieck F) => base X)
    fun (X Y : grothendieck F) (f : X ⟶ Y) => hom.base f

/--
The Grothendieck construction applied to a functor to `Type`
(thought of as a functor to `Cat` by realising a type as a discrete category)
is the same as the 'category of elements' construction.
-/
def grothendieck_Type_to_Cat {C : Type u_1} [category C] (G : C ⥤ Type w) :
    grothendieck (G ⋙ Type_to_Cat) ≌ functor.elements G :=
  sorry

end Mathlib


import category_theory.comma
import category_theory.adjunction.basic
import category_theory.limits.shapes
import category_theory.limits.shapes.images
import category_theory.limits.shapes.regular_mono
import category_theory.epi_mono
import category_theory.limits.over
import category.images
import over

/-!
# Locally cartesian closed categories
We say `C` is locally cartesian closed if it has all finite limits, and each
`C/B` is cartesian closed.

Given `f : A ⟶ B` in `C/B`, the iterated slice `(C/B)/f` is isomorphic to
`C/A`, and so `f* : C/B ⥤ (C/B)/f` is 'the same thing' as pulling back
morphisms along `f`. In particular, `C` is locally cartesian closed iff
it has finite limits and `f* : C/B ⥤ C/A` has a right adjoint (for each
`f : A ⟶ B`).

From here, we can show that if `C` is locally cartesian closed and has
reflexive coequalizers, then every morphism factors into a regular epic
and monic.
-/

noncomputable theory
namespace category_theory
open category limits

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

local attribute [instance] has_finite_products_of_has_finite_limits
local attribute [instance] has_finite_wide_pullbacks_of_has_finite_limits

class is_locally_cartesian_closed [has_finite_limits.{v} C] :=
(overs_cc : Π (B : C), cartesian_closed (over B))

attribute [instance] is_locally_cartesian_closed.overs_cc

universe u₂

variable {C}
lemma equiv_reflects_mono {D : Type u₂} [category.{v} D] {X Y : C} (f : X ⟶ Y) (e : C ≌ D)
  (hef : mono (e.functor.map f)) : mono f :=
faithful_reflects_mono e.functor hef

lemma equiv_reflects_epi {D : Type u₂} [category.{v} D] {X Y : C} (f : X ⟶ Y) (e : C ≌ D)
  (hef : epi (e.functor.map f)) : epi f :=
faithful_reflects_epi e.functor hef

section

lemma equiv_preserves_mono {D : Type u₂} [category.{v} D] {X Y : C} (f : X ⟶ Y) [mono f] (e : C ≌ D) :
  mono (e.functor.map f) :=
begin
  apply equiv_reflects_mono ((e.functor).map f) e.symm,
  erw equivalence.inv_fun_map,
  apply mono_comp _ _,
  apply @is_iso.mono_of_iso _ _ _ _ _ (nat_iso.is_iso_app_of_is_iso _ _),
  apply_instance,
  apply mono_comp _ _,
  apply_instance,
  apply @is_iso.mono_of_iso _ _ _ _ _ (nat_iso.is_iso_app_of_is_iso _ _),
  apply is_iso.of_iso,
end

lemma equiv_preserves_epi {D : Type u₂} [category.{v} D] {X Y : C} (f : X ⟶ Y) [epi f] (e : C ≌ D) :
  epi (e.functor.map f) :=
begin
  apply equiv_reflects_epi ((e.functor).map f) e.symm,
  erw equivalence.inv_fun_map,
  apply epi_comp _ _,
  apply @is_iso.epi_of_iso _ _ _ _ _ (nat_iso.is_iso_app_of_is_iso _ _),
  apply_instance,
  apply epi_comp _ _,
  apply_instance,
  apply @is_iso.epi_of_iso _ _ _ _ _ (nat_iso.is_iso_app_of_is_iso _ _),
  apply is_iso.of_iso,
end
end

lemma over_epi {B : C} {f g : over B} (k : f ⟶ g) [epi k.left] : epi k :=
⟨λ h l m a, by { ext, rw [← cancel_epi k.left, ← over.comp_left, a], refl }⟩

lemma over_epi' [has_binary_products.{v} C] {B : C} {f g : over B} (k : f ⟶ g) [ke : epi k] : epi k.left :=
left_adjoint_preserves_epi (forget_adj_star _) ke

variables [has_finite_limits.{v} C] [is_locally_cartesian_closed.{v} C]

def dependent_product {A B : C} (f : A ⟶ B) : over A ⥤ over B :=
(over.iterated_slice_equiv (over.mk f)).inverse ⋙ Pi_functor (over.mk f)

def ladj' {A B : C} (f : A ⟶ B) : pullback_along f ⊣ dependent_product f :=
adjunction.comp _ _ (star_adj_pi_of_exponentiable (over.mk f)) (equivalence.to_adjunction _)

def ladj {A B : C} (f : A ⟶ B) : real_pullback f ⊣ dependent_product f :=
adjunction.of_nat_iso_left (ladj' f) (iso_pb f)

instance other_thing {A B : C} (f : A ⟶ B) : is_left_adjoint (real_pullback f) :=
⟨dependent_product f, ladj _⟩

/--
 P ⟶ D
 ↓   ↓
 A → B
If g : D ⟶ B is epi then the pullback of g along f is epi
-/

instance pullback_preserves_epi {A B D : C}
  (f : A ⟶ B) (g : D ⟶ B) [hg : epi g] :
  epi (pullback.snd : pullback g f ⟶ A) :=
begin
  let g'' : over.mk g ⟶ over.mk (𝟙 B) := over.hom_mk g,
  haveI : epi g''.left := hg,
  haveI := left_adjoint_preserves_epi (ladj f) (over_epi g''),
  have : ((real_pullback f).map g'').left ≫ pullback.snd = pullback.snd := pullback.lift_snd _ pullback.snd _,
  rw ← this,
  have : epi ((real_pullback f).map g'').left := over_epi' _,
  haveI : split_epi (pullback.snd : pullback (𝟙 B) f ⟶ A) := ⟨pullback.lift f (𝟙 A) (by simp), pullback.lift_snd _ _ _⟩,
  apply epi_comp,
end

lemma pullback_preserves_epi'' {A B D : C}
  (f : A ⟶ B) {g : D ⟶ B} [hg : epi g] {c : pullback_cone g f} (t : is_limit c) :
epi (pullback_cone.snd c) :=
begin
  have y := is_limit.unique_up_to_iso t (limit.is_limit _),
  have z : pullback_cone.snd c = y.hom.hom ≫ pullback_cone.snd (limit.cone (cospan g f)),
    rw y.hom.w,
  rw z, apply epi_comp _ _,
    apply @is_iso.epi_of_iso _ _ _ _ _ _, refine ⟨_, _, _⟩, apply y.inv.hom,
    show ((y.hom ≫ y.inv).hom = 𝟙 c.X), rw y.hom_inv_id, refl,
    show ((y.inv ≫ y.hom).hom = 𝟙 _), rw y.inv_hom_id, refl,
  exact category_theory.pullback_preserves_epi f g
end

lemma prod_map_epi {A B : C} (D : C) {q : A ⟶ B} [hq : epi q] : epi (limits.prod.map q (𝟙 D)) :=
pullback_preserves_epi'' _ (pullback_prod _ _)

lemma prod_map_epi' {A B : C} (D : C) {q : A ⟶ B} [hq : epi q] : epi (limits.prod.map (𝟙 D) q) :=
pullback_preserves_epi'' _ (pullback_prod' q D)

instance prod_maps_epi {X Y Z W : C} (f : X ⟶ Y) (g : W ⟶ Z) [epi f] [epi g] : epi (limits.prod.map f g) :=
begin
  have: limits.prod.map f g = limits.prod.map (𝟙 _) g ≫ limits.prod.map f (𝟙 _),
  { apply prod.hom_ext,
    { rw [limits.prod.map_fst, assoc, limits.prod.map_fst, limits.prod.map_fst_assoc, id_comp] },
    { rw [limits.prod.map_snd, assoc, limits.prod.map_snd, comp_id, limits.prod.map_snd] } },
  rw this,
  apply epi_comp _ _,
  apply prod_map_epi',
  apply prod_map_epi
end

section pullback_preserves_colimits

variables {J : Type v} [small_category J] [has_colimits_of_shape J C]
variables {Y Z : C} (f : Y ⟶ Z)

local attribute [-instance] adjunction.has_colimit_comp_equivalence

@[simps]
def pullback_diagram (K : J ⥤ C) (c : cocone K) (r : c.X ⟶ Z) : J ⥤ C :=
{ obj := λ j, pullback (c.ι.app j ≫ r : K.obj j ⟶ Z) f,
  map := λ j₁ j₂ k,
  begin
    apply pullback.lift (pullback.fst ≫ K.map k) pullback.snd _,
    simp [reassoc_of (c.w k), pullback.condition],
  end }.

@[simps]
def pullback_cocone (K : J ⥤ C) (c : cocone K) (r : c.X ⟶ Z) : cocone (pullback_diagram f K c r) :=
{ X := pullback r f,
  ι :=
  { app := λ j,
    begin
      apply pullback.lift _ pullback.snd _,
      apply pullback.fst ≫ c.ι.app j,
      rw [assoc, pullback.condition],
    end } }

@[simps]
def long_diagram (K : J ⥤ C) (c : cocone K) (r : c.X ⟶ Z) : J ⥤ over Z :=
{ obj := λ j, over.mk (c.ι.app j ≫ r),
  map := λ j₁ j₂ k, over.hom_mk (K.map k) (by { dsimp, rw reassoc_of (c.w k) }) }

@[simps]
def long_cone {K : J ⥤ C} (c : cocone K) (r : c.X ⟶ Z) : cocone (long_diagram K c r) :=
{ X := over.mk r,
  ι := { app := λ j, over.hom_mk (c.ι.app j) } }.

def diagram_iso {K : J ⥤ C} (c : cocone K) (r : c.X ⟶ Z) : (long_diagram K c r ⋙ over.forget _) ≅ K :=
nat_iso.of_components (λ k, iso.refl _) (by tidy)

def forget_long_cocone_iso {K : J ⥤ C} (c : cocone K) (r : c.X ⟶ Z) :
  (over.forget _).map_cocone (long_cone c r) ≅ (cocones.precompose (diagram_iso c r).hom).obj c :=
cocones.ext (iso.refl _) (begin intro j, dsimp [diagram_iso], simp end)

def long_colimit {K : J ⥤ C} (c : cocone K) (r : c.X ⟶ Z) (t : is_colimit c) : is_colimit (long_cone c r) :=
begin
  suffices : is_colimit ((over.forget _).map_cocone (long_cone c r)),
    apply reflects_colimit.reflects this,
  apply limits.is_colimit.of_iso_colimit _ (forget_long_cocone_iso _ _).symm,
  apply is_colimit.of_left_adjoint (cocones.precompose_equivalence (diagram_iso _ r)).functor t,
end

def pullback_diagram_iso {K : J ⥤ C} (c : cocone K) (r : c.X ⟶ Z) :
  ((long_diagram K c r ⋙ real_pullback f) ⋙ over.forget _) ≅ pullback_diagram f K c r :=
nat_iso.of_components (λ j, iso.refl _) (by tidy)

def pullback_preserves {K : J ⥤ C} (c : cocone K) (t : is_colimit c) (r : c.X ⟶ Z) : is_colimit (pullback_cocone f K c r) :=
begin
  haveI : preserves_colimits (real_pullback f) := adjunction.left_adjoint_preserves_colimits (ladj f),
  let e := cocones.precompose_equivalence (pullback_diagram_iso f c r),
  let c' := is_colimit.of_left_adjoint e.inverse (preserves_colimit.preserves (preserves_colimit.preserves (long_colimit c r t))),
  apply is_colimit.of_iso_colimit c',
  apply cocones.ext _ _,
  apply iso.refl _,
  intro j,
  dsimp [pullback_diagram_iso],
  simpa
end

@[simps]
def pullback_along_id : pullback (𝟙 Z) f ≅ Y :=
{ hom := pullback.snd,
  inv := pullback.lift f (𝟙 _) (by simp),
  hom_inv_id' :=
  begin
    apply pullback.hom_ext,
    rw [assoc, pullback.lift_fst, ← pullback.condition], simp,
    simp,
  end }

end pullback_preserves_colimits

variables [has_coequalizers.{v} C]
section factorise

def coequalizer_strong_epi_fac {A B : C} (f : A ⟶ B) : strong_epi_mono_factorisation f :=
{ I := coequalizer (pullback.fst : pullback f f ⟶ A) pullback.snd,
  m := coequalizer.desc f pullback.condition,
  e := coequalizer.π pullback.fst pullback.snd,
  m_mono := ⟨λ D g h gmhm,
  begin
    let q := coequalizer.π pullback.fst pullback.snd,
    let E := pullback (limits.prod.map q q) (limits.prod.lift g h),
    let n : E ⟶ D := pullback.snd,
    let k : E ⟶ A := pullback.fst ≫ limits.prod.fst,
    let l : E ⟶ A := pullback.fst ≫ limits.prod.snd,
    have kqng: k ≫ q = n ≫ g,
      have: _ = (n ≫ _) ≫ _ := pullback.condition =≫ limits.prod.fst,
      simpa using this,
    have lqnh: l ≫ q = n ≫ h,
      have: _ = (n ≫ _) ≫ _ := pullback.condition =≫ limits.prod.snd,
      simpa using this,
    have kflf: k ≫ f = l ≫ f,
      rw [← coequalizer.π_desc f pullback.condition, ← assoc, kqng, assoc, gmhm, ← assoc, ← lqnh, assoc],
    have aqbq : _ ≫ q = _ ≫ q := coequalizer.condition _ _,
    have: n ≫ g = n ≫ h,
      rw [← kqng, ← pullback.lift_fst k l kflf, assoc, aqbq, pullback.lift_snd_assoc _ _ _, lqnh],
    rwa ← cancel_epi n,
  end⟩ }

instance coequalizer_fac : has_strong_epi_mono_factorisations.{v} C :=
has_strong_epi_mono_factorisations.mk $ λ A B f, coequalizer_strong_epi_fac f.

def regular_epi_of_comp_iso {X Y Z : C} (f : X ⟶ Y) [r : regular_epi f] (g : Y ⟶ Z) [is_iso g] :
  regular_epi (f ≫ g) :=
{ W := r.W,
  left := r.left,
  right := r.right,
  w := begin rw [reassoc_of r.w], end,
  is_colimit := cofork.is_colimit.mk _
  (λ s, inv g ≫ r.is_colimit.desc _)
  (λ s, begin change (_ ≫ g) ≫ inv g ≫ _ = _, erw [assoc, (as_iso g).hom_inv_id_assoc, r.is_colimit.fac _ walking_parallel_pair.one], end)
  (λ s m w, begin erw (as_iso g).eq_inv_comp, apply r.is_colimit.uniq, intro j, rw ← w j, cases j; simp end) }

/-- The strong epi-mono factorisation is actually a regular epi-mono factorisation. -/
instance {A B : C} (f : A ⟶ B) : regular_epi (factor_thru_image f) :=
begin
  have := is_image.e_iso_ext_hom (strong_epi_mono_factorisation.to_mono_is_image (coequalizer_strong_epi_fac f)) (image.is_image f),
  change _ = factor_thru_image f at this,
  rw ← this,
  change regular_epi (coequalizer.π _ _ ≫ _),
  refine regular_epi_of_comp_iso _ _,
end

end factorise

-- This is slow and horrible :(
instance pullback_regular_epi {X Y Z : C} (f : Y ⟶ Z) (g : X ⟶ Z) [gr : regular_epi g] [has_coequalizers.{v} C] :
  regular_epi (pullback.snd : pullback g f ⟶ Y) :=
{ W := pullback ((gr.left ≫ g) ≫ 𝟙 _) f,
  left :=
  begin
    apply pullback.lift (pullback.fst ≫ gr.left) pullback.snd _,
    rw [← pullback.condition, comp_id, assoc],
  end,
  right :=
  begin
    apply pullback.lift (pullback.fst ≫ gr.right) pullback.snd _,
    rw [← pullback.condition, comp_id, assoc, gr.w],
  end,
  w := by simp,
  is_colimit :=
  begin
    have := pullback_preserves f _ gr.is_colimit (𝟙 Z),
    apply is_colimit.of_iso_colimit (is_colimit.of_left_adjoint (cocones.precompose_equivalence _).inverse this),
    swap,
    { apply nat_iso.of_components _ _,
      { rintro ⟨j⟩,
        { apply iso.refl _ },
        { refine ⟨pullback.lift pullback.fst pullback.snd _, pullback.lift pullback.fst pullback.snd _, _, _⟩,
          { rw ← pullback.condition,
            dsimp,
            conv_rhs {congr, skip, erw comp_id} },
          { dsimp,
            conv_lhs {congr, skip, erw comp_id},
            rw pullback.condition },
          { apply pullback.hom_ext; simp only [assoc, id_comp, pullback.lift_fst, pullback.lift_snd] },
          { apply pullback.hom_ext; simp only [assoc, id_comp, pullback.lift_fst, pullback.lift_snd] } } },
    { rintro k₁ k₂ i,
      cases i,
      { dsimp, rw [id_comp],
        apply pullback.hom_ext; simp },
      { dsimp,
        rw [id_comp],
        apply pullback.hom_ext; simp },
      { cases k₁,
        { dsimp, rw [id_comp], simp only [functor.map_id, comp_id], apply pullback.hom_ext,
          { simp only [pullback.lift_fst], dsimp, simp },
          { simp only [pullback.lift_snd], erw [id_comp] } },
        { dsimp, simp only [functor.map_id, comp_id, id_comp], conv_rhs {apply_congr comp_id},
          apply pullback.hom_ext,
          { simp only [assoc, pullback.lift_fst], apply comp_id },
          { simp only [assoc, pullback.lift_snd] } } } } },
    dsimp [cocones.precompose_equivalence, cocones.precompose],
    apply cocones.ext _ _,
    apply pullback_along_id,
    dsimp,
    rintro ⟨j⟩,
    dsimp, simp,
    dsimp, simp,
    apply_instance,
  end }.

def pullback_image {X Y Z : C} (f : Y ⟶ Z) (g : X ⟶ Z) [has_coequalizers.{v} C] :
  pullback (image.ι g) f ≅ image (pullback.snd : pullback g f ⟶ _) :=
begin
  let red : pullback g f ⟶ pullback (image.ι g) f, -- := pullback.lift (pullback.fst ≫ factor_thru_image g) pullback.snd _,
    apply pullback.lift (pullback.fst ≫ factor_thru_image g) pullback.snd _,
    simp [pullback.condition],
  let green : pullback (factor_thru_image g) (pullback.fst : pullback (image.ι g) f ⟶ _) ⟶ pullback (image.ι g) f,
    apply pullback.snd,
  have : regular_epi green := by apply_instance,
  let red_to_green : pullback (factor_thru_image g) (pullback.fst : pullback (image.ι g) f ⟶ _) ⟶ pullback g f,
    apply pullback.lift pullback.fst (pullback.snd ≫ pullback.snd) _,
    rw [assoc, ←pullback.condition, ←pullback.condition_assoc, image.fac g],
  let green_to_red : pullback g f ⟶ pullback (factor_thru_image g) (pullback.fst : pullback (image.ι g) f ⟶ _),
    apply pullback.lift pullback.fst red _,
    rw [pullback.lift_fst],
  have : split_epi green_to_red,
    refine { section_ := red_to_green, id' := _ },
    apply pullback.hom_ext,
    { simp },
    { apply pullback.hom_ext; simp [pullback.condition] },
  haveI := this,
  have : regular_epi green := by apply_instance,
  haveI : strong_epi (green_to_red ≫ green) := strong_epi_comp _ _,
  apply unique_factorise _ _ (green_to_red ≫ green) pullback.snd _,
  simp,
end

variable [has_coequalizers.{v} C]

lemma pullback_image_fac {X Y Z : C} (f : Y ⟶ Z) (g : X ⟶ Z) [has_coequalizers.{v} C] :
  (pullback_image f g).hom ≫ image.ι (pullback.snd : pullback g f ⟶ Y) = (pullback.snd : pullback (image.ι g) f ⟶ Y) :=
is_image.lift_fac _ _

lemma pullback_image_inv_fac {X Y Z : C} (f : Y ⟶ Z) (g : X ⟶ Z) [has_coequalizers.{v} C] :
  (pullback_image f g).inv ≫ (pullback.snd : pullback (image.ι g) f ⟶ Y) = image.ι (pullback.snd : pullback g f ⟶ Y) :=
image.lift_fac _

def regular_epi_of_regular_epi {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) [epi f] [r : regular_epi (f ≫ g)] : regular_epi g :=
{ W := r.W,
  left := r.left ≫ f,
  right := r.right ≫ f,
  w := by rw [assoc, assoc, r.w],
  is_colimit := cofork.is_colimit.mk _
  (λ s, begin apply (cofork.is_colimit.desc' r.is_colimit (f ≫ s.π) _).1, rw [← assoc, s.condition, assoc], end)
  (begin intro s, erw [← cancel_epi f, ← assoc, (cofork.is_colimit.desc' r.is_colimit (f ≫ s.π) _).2], end)
  (begin
    intros s m w,
    apply cofork.is_colimit.hom_ext r.is_colimit,
    erw [assoc, w walking_parallel_pair.one, (cofork.is_colimit.desc' r.is_colimit (f ≫ s.π) _).2]
  end) }

def regular_epi_of_is_pullback {W X Y Z : C} (f : W ⟶ X) (g : W ⟶ Y) (h : X ⟶ Z) (k : Y ⟶ Z)
  (comm : f ≫ h = g ≫ k) (l : is_limit (pullback_cone.mk _ _ comm)) [regular_epi h] :
  regular_epi g :=
begin
  have e : regular_epi (pullback.snd : pullback h k ⟶ Y) := category_theory.pullback_regular_epi k h,
  have : (pullback.snd : pullback h k ⟶ Y) = l.lift _ ≫ g := (l.fac _ walking_cospan.right).symm,
  rw this at e,
  have : split_epi (l.lift (limit.cone (cospan h k))),
    refine ⟨limit.lift _ (pullback_cone.mk f g comm), _⟩,
    dsimp,
    apply l.hom_ext,
    apply (pullback_cone.mk f g comm).equalizer_ext,
    erw [assoc, l.fac (limit.cone (cospan h k)) walking_cospan.left, limit.lift_π, id_comp],
    erw [assoc, l.fac (limit.cone (cospan h k)) walking_cospan.right, limit.lift_π, id_comp],
  haveI := this,
  apply regular_epi_of_regular_epi (l.lift (limit.cone (cospan h k))) g,
end

def regular_epi_of_is_pullback_alt {W X Y Z : C} (f : W ⟶ X) (g : W ⟶ Y) (h : X ⟶ Z) (k : Y ⟶ Z)
  (comm : f ≫ h = g ≫ k) (l : is_limit (pullback_cone.mk _ _ comm)) [regular_epi k] :
  regular_epi f := regular_epi_of_is_pullback g f k h comm.symm (pullback_flip l)

def regular_epi_of_strong_epi {X Y : C} (f : X ⟶ Y) [strong_epi f] : regular_epi f :=
begin
  haveI : regular_epi (factor_thru_image f) := by apply_instance,
  have : strong_epi (factor_thru_image f ≫ image.ι f),
    rwa image.fac f,
  haveI := this,
  haveI : strong_epi (image.ι f) := strong_epi_of_strong_epi (factor_thru_image f) _,
  haveI : is_iso (image.ι f) := is_iso_of_mono_of_strong_epi _,
  rw ← image.fac f,
  apply regular_epi_of_comp_iso,
end

instance regular_epi_comp {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) [regular_epi f] [regular_epi g] : regular_epi (f ≫ g) :=
by { haveI := strong_epi_comp f g; exact regular_epi_of_strong_epi (f ≫ g) }

instance regular_prod_map {X Y Z W : C} (f : X ⟶ Y) (g : W ⟶ Z) [regular_epi f] [regular_epi g] :
  regular_epi (limits.prod.map f g) :=
begin
  have : regular_epi (limits.prod.map f (𝟙 W)) := regular_epi_of_is_pullback _ _ _ _ _ (pullback_prod f W),
  haveI : regular_epi (limits.prod.map (𝟙 Y) g) := regular_epi_of_is_pullback _ _ _ _ _ (pullback_prod' g Y),
  have : limits.prod.map f (𝟙 W) ≫ limits.prod.map (𝟙 Y) g = limits.prod.map f g,
    apply prod.hom_ext; simp only [limits.prod.map_fst, limits.prod.map_snd, assoc, comp_id, limits.prod.map_snd_assoc, id_comp],
  rw ← this,
  apply_instance,
end

def image_prod_map {X Y Z W : C} (f : X ⟶ Y) (g : Z ⟶ W) : image (limits.prod.map f g) ≅ image f ⨯ image g :=
begin
  symmetry,
  apply unique_factorise _ _ (limits.prod.map (factor_thru_image f) (factor_thru_image g)) (limits.prod.map (image.ι f) (image.ι g)) _,
  apply prod.hom_ext; simp,
end

lemma image_prod_map_comp {X Y Z W : C} (f : X ⟶ Y) (g : Z ⟶ W) : (image_prod_map f g).hom ≫ limits.prod.map (image.ι f) (image.ι g) = image.ι _ :=
image.lift_fac _

lemma image_prod_map_inv_comp {X Y Z W : C} (f : X ⟶ Y) (g : Z ⟶ W) : (image_prod_map f g).inv ≫ image.ι _ = limits.prod.map (image.ι f) (image.ι g) :=
is_image.lift_fac _ _

end category_theory


import topology.maps
import category_theory.base
import category_theory.functor_category
import topology.category.Top.basic

open category_theory

universe u

namespace homotopy_theory.topological_spaces

namespace Top

local notation `Top` := Top.{u}

protected def mk_ob (α : Type u) [t : topological_space α] : Top := ⟨α, t⟩
protected def mk_hom {X Y : Top} (f : X → Y) (hf : continuous f . tactic.interactive.continuity') : X ⟶ Y :=
continuous_map.mk f hf
@[ext] protected def hom_eq {X Y : Top} {f g : X ⟶ Y} (h : ∀ x, f x = g x) : f = g :=
continuous_map.ext h
protected lemma hom_eq2 {X Y : Top} {f g : X ⟶ Y} : f = g ↔ f.to_fun = g.to_fun :=
by { cases f, cases g, split; cc }
protected def hom_congr {X Y : Top} {f g : X ⟶ Y} : f = g → ∀ x, f x = g x :=
by intros e x; rw e

section terminal

protected def point : Top := @Top.mk_ob punit ⊥
notation `*` := Top.point

protected def point_induced (A : Top) : A ⟶ * :=
Top.mk_hom (λ _, punit.star) (by continuity)

end terminal

protected def const {A X : Top} (x : X) : A ⟶ X :=
Top.mk_hom (λ a, x) (by continuity)

section product

-- TODO: Generalize all the following definitions using a `has_product` class

protected def prod (X Y : Top) : Top :=
Top.mk_ob (X.α × Y.α)

protected def pr₁ {X Y : Top} : Top.prod X Y ⟶ X :=
Top.mk_hom (λ p, p.1) (by continuity!)

protected def pr₂ {X Y : Top} : Top.prod X Y ⟶ Y :=
Top.mk_hom (λ p, p.2) (by continuity!)

-- TODO: The (by continuity) argument ought to be supplied
-- automatically by auto_param, but for some reason elaboration goes
-- wrong without it
protected def prod_maps {X X' Y Y' : Top} (f : X ⟶ X') (g : Y ⟶ Y') :
  Top.prod X Y ⟶ Top.prod X' Y' :=
Top.mk_hom (λ p, (f p.1, g p.2)) (by continuity!)

protected def prod_pt {X Y : Top} (y : Y) : X ⟶ Top.prod X Y :=
Top.mk_hom (λ x, (x, y)) (by continuity)

protected def product_by (Y : Top) : Top ↝ Top :=
{ obj := λ X, Top.prod X Y,
  map := λ X X' f, Top.prod_maps f (𝟙 Y) }

notation `-×`:35 Y:34 := Top.product_by Y

protected def product_by_trans {Y Y' : Top} (g : Y ⟶ Y') : -×Y ⟶ -×Y' :=
{ app := λ X, Top.prod_maps (𝟙 X) g }

protected def prod_pt_trans {Y : Top} (y : Y) : functor.id _ ⟶ -×Y :=
{ app := λ X, Top.prod_pt y }

protected def pr₁_trans {Y : Top} : -×Y ⟶ functor.id _ :=
{ app := λ X, Top.pr₁ }

end product

section subtype

/-- The hom sets of Top used to be defined using `subtype`;
this provides the equivalence to the old definition. -/
protected def hom_equiv_subtype (X Y : Top) :
  (X ⟶ Y) ≃ {f : X → Y // continuous f} :=
{ to_fun := λ p, ⟨p.1, p.2⟩,
  inv_fun := λ p, ⟨p.1, p.2⟩,
  left_inv := λ p, by cases p; refl,
  right_inv := λ p, by cases p; refl }

end subtype

end «Top»

end homotopy_theory.topological_spaces