import main
import split_cycle

open_locale classical

variables {V X : Type}

def minus_voter (P : Prof V X) (i : V) : Prof {v : V // v ≠ i} X := λ v x y, P v.val x y
-- use strict preference.
def positive_involvement (F : VSCC) (P : Prof V X) : Prop := ∀ (x : X) (i : V), x ∈ F {v : V // v ≠ i} X (minus_voter P i) → (∀ y, y ≠ x → P i x y) → x ∈ F V X P

def negative_involvement (F : VSCC) (P : Prof V X) : Prop := ∀ (x : X) (i : V), x ∉ F {v : V // v ≠ i} X (minus_voter P i) → (∀ y, y ≠ x → P i y x) → x ∉ F V X P

lemma minus_voter_margin_eq [fintype V] (i : V) [fintype {v // v ≠ i}] (P : Prof V X) [profile_asymmetric P] (z x : X) (p : P i x z) : margin (minus_voter P i) z x = margin P z x + 1 :=
begin
  have asymm := _inst_3.asymmetric,
  unfold margin,
  have meq : ((finset.filter (λ (x_1 : {v // v ≠ i}), minus_voter P i x_1 z x) finset.univ).card) = ((finset.filter (λ (x_1 : V), P x_1 z x) finset.univ).card),
    {apply eq.symm,
    have f : (finset.filter (λ (x_1 : V), P x_1 z x) finset.univ) = (finset.map ⟨(λ (s : {v // v ≠ i}), s.val), begin
      obviously,
    end⟩ (finset.filter (λ (x_1 : {v // v ≠ i}), minus_voter P i x_1 z x) finset.univ)),
      {simp, ext1, obviously,
      rw ←ᾰ_1 at p,
      exact (asymm a z x ᾰ) p, }, -- require asymmetry
      rw f,
      simp,},
  rw meq,
  have o : ∀ a b c : ℤ, c = b + 1 → a - b = a - c + 1 := by omega,
  apply o (↑((finset.filter (λ (x_1 : V), P x_1 z x) finset.univ).card)) (↑((finset.filter (λ (x_1 : {v // v ≠ i}), minus_voter P i x_1 x z) finset.univ).card)) (↑((finset.filter (λ (x_1 : V), P x_1 x z) finset.univ).card)),
  norm_cast,
  rw finset.card_eq_succ,
  use i, use (finset.filter (λ (x_1 : V), x_1 ≠ i ∧ P x_1 x z) finset.univ),
  have nmem : i ∉ (finset.filter (λ (x_1 : V), x_1 ≠ i ∧ P x_1 x z) finset.univ),
    {obviously,},

  use nmem,
  split,
  ext1,
  simp only [true_and, finset.mem_univ, ne.def, finset.mem_insert, finset.mem_filter],

  split,
    {intro m,
    cases m,
    rw m,
    exact p,
    exact and.right m,},
    {intro m,
    by_cases a = i,
    use h,
    apply or.inr,
    exact ⟨h, m⟩,},

  refine finset.card_congr _ _ _ _,
    {intro a,
    intro a_spec,
    simp at a_spec,
    exact ⟨a, and.left a_spec⟩,},
    {intro a, intro ha, simp at ha, simp,
    unfold minus_voter, simp, exact and.right ha,},
    {intros a b ha hb, simp at ha, simp at hb,
    simp, },
    {intros b hb, simp at hb, simp,
    use b.val, simp, use b.property, unfold minus_voter at hb,
    exact hb,},
end

lemma minus_voter_margin_le [fintype V] (i : V) [fintype {v // v ≠ i}] (P : Prof V X) [profile_asymmetric P] (a b : X) : margin (minus_voter P i) a b ≤ margin P a b + 1 :=
begin
  by_cases P i b a,
    {have m := minus_voter_margin_eq i P a b h,
    exact le_of_eq m,},

  unfold margin,

  have meq : ((finset.filter (λ (x_1 : {v // v ≠ i}), minus_voter P i x_1 b a) finset.univ).card) = ((finset.filter (λ (x_1 : V), P x_1 b a) finset.univ).card),
    {refine finset.card_congr _ _ _ _,
      {intros a a_spec,
      exact a.val,},
      {intros a_1 ha, simp, simp at ha, unfold minus_voter at ha, exact ha, },
      {intros a_1 b_1 ha hb, simp, obviously,},
      {intros b_1 b_spec, simp at b_spec,
      let h2 := h,
      by_cases b_1 = i,
      exfalso, rw h at b_spec, exact h2 b_spec,
      use ⟨b_1, h⟩,
      split, simp, simp, unfold minus_voter, exact b_spec,},
    },

  rw meq,
  have o : ∀ a b c : ℤ, a ≤ c → a - b ≤ c - b + 1 := by omega,
  apply o (↑((finset.filter (λ (x_1 : {v // v ≠ i}), minus_voter P i x_1 a b) finset.univ).card)) (↑((finset.filter (λ (x_1 : V), P x_1 b a) finset.univ).card)) (↑((finset.filter (λ (x_1 : V), P x_1 a b) finset.univ).card)),

  norm_cast,
  refine finset.card_le_card_of_inj_on _ _ _,
  exact (λ v, v.val),
  intros a_1 a_spec,
  simp, simp at a_spec,
  unfold minus_voter at a_spec,
  exact a_spec,

  intros a1 a1_spec a2 a2_spec,
  obviously,
end

theorem positive_involvement_split_cycle [fintype V] (P : Prof V X) [profile_asymmetric P] : positive_involvement split_cycle P :=
begin
  unfold positive_involvement,
  intros x i w p,
  unfold split_cycle, unfold max_el_VSCC, unfold split_cycle_VCCR, simp,
  unfold split_cycle at w, unfold max_el_VSCC at w, unfold split_cycle_VCCR at w,
  unfold split_cycle_CCR at w, simp at w,
  intro y,
  unfold split_cycle_CCR,
  push_neg,
  use _inst_1,
  intro m,
  specialize w y,

  casesI w with _inst_3 w,

  have ynx := ne_of_margin_pos m,

  have mxy := minus_voter_margin_eq i P y x (p y ynx),

  have mp : margin_pos (minus_voter P i) y x,
    {unfold margin_pos, rw mxy,
    have o : ∀ a : ℤ, a > 0 → 0 < a + 1 := by omega,
    exact o (margin P y x) m,},

  specialize w mp,
  cases w with c w,
  cases w with x_mem w,
  cases w with y_mem w,

  use c, use x_mem, use y_mem,

  refine cycle_of_cycle_imp _ w,
  intros a b mab,
  have o : ∀ a b c d : ℤ, a ≤ b → a = c + 1 → b ≤ d + 1 → c ≤ d := by omega,

  apply (o (margin (minus_voter P i) y x) (margin (minus_voter P i) a b) (margin P y x) (margin P a b) mab mxy ),

  exact minus_voter_margin_le i P a b,
end

lemma minus_voter_margin_eq2 [fintype V] (i : V) [fintype {v // v ≠ i}] (P : Prof V X) [profile_asymmetric P] (z x : X) (p : P i z x) : margin (minus_voter P i) z x + 1 = margin P z x :=
begin
  have asymm := _inst_3.asymmetric,
  unfold margin,
  have meq : ((finset.filter (λ (x_1 : {v // v ≠ i}), minus_voter P i x_1 x z) finset.univ).card) = ((finset.filter (λ (x_1 : V), P x_1 x z) finset.univ).card),
    {apply eq.symm,
    have f : (finset.filter (λ (x_1 : V), P x_1 x z) finset.univ) = (finset.map ⟨(λ (s : {v // v ≠ i}), s.val), begin
      obviously,
    end⟩ (finset.filter (λ (x_1 : {v // v ≠ i}), minus_voter P i x_1 x z) finset.univ)),
      {simp, ext1, obviously,
      rw ←ᾰ_1 at p,
      exact (asymm a x z ᾰ) p, }, -- require asymmetry
      rw f,
      simp,},
  rw meq,
  have o : ∀ a b c : ℤ, c = a + 1 → a - b + 1 = c - b := by omega,
  apply o (↑((finset.filter (λ (x_1 : {v // v ≠ i}), minus_voter P i x_1 z x) finset.univ).card)) (↑((finset.filter (λ (x_1 : V), P x_1 x z) finset.univ).card)) (↑((finset.filter (λ (x_1 : V), P x_1 z x) finset.univ).card)),
  norm_cast,
  rw finset.card_eq_succ,
  use i, use (finset.filter (λ (x_1 : V), x_1 ≠ i ∧ P x_1 z x) finset.univ),
  have nmem : i ∉ (finset.filter (λ (x_1 : V), x_1 ≠ i ∧ P x_1 z x) finset.univ),
    {obviously,},

  use nmem,
  split,
  ext1,
  simp only [true_and, finset.mem_univ, ne.def, finset.mem_insert, finset.mem_filter],

  split,
    {intro m,
    cases m,
    rw m,
    exact p,
    exact and.right m,},
    {intro m,
    by_cases a = i,
    use h,
    apply or.inr,
    exact ⟨h, m⟩,},

  refine finset.card_congr _ _ _ _,
    {intro a,
    intro a_spec,
    simp at a_spec,
    exact ⟨a, and.left a_spec⟩,},
    {intro a, intro ha, simp at ha, simp,
    unfold minus_voter, simp, exact and.right ha,},
    {intros a b ha hb, simp at ha, simp at hb,
    simp, },
    {intros b hb, simp at hb, simp,
    use b.val, simp, use b.property, unfold minus_voter at hb,
    exact hb,},
end

lemma minus_voter_margin_le2 [fintype V] (i : V) [fintype {v // v ≠ i}] (P : Prof V X) [profile_asymmetric P] (a b : X) : margin P a b ≤ margin (minus_voter P i) a b + 1 :=
begin
  by_cases P i a b,
    {have m := minus_voter_margin_eq2 i P a b h,
    exact le_of_eq m.symm,},

  unfold margin,

  have meq : ((finset.filter (λ (x_1 : {v // v ≠ i}), minus_voter P i x_1 a b) finset.univ).card) = ((finset.filter (λ (x_1 : V), P x_1 a b) finset.univ).card),
    {refine finset.card_congr _ _ _ _,
      {intros a a_spec,
      exact a.val,},
      {intros a_1 ha, simp, simp at ha, unfold minus_voter at ha, exact ha, },
      {intros a_1 b_1 ha hb, simp, obviously,},
      {intros b_1 b_spec, simp at b_spec,
      let h2 := h,
      by_cases b_1 = i,
      exfalso, rw h at b_spec, exact h2 b_spec,
      use ⟨b_1, h⟩,
      split, simp, simp, unfold minus_voter, exact b_spec,},
    },

  rw meq,
  have o : ∀ a b c : ℤ, c ≤ b → a - b ≤ a - c + 1 := by omega,
  apply o (↑((finset.filter (λ (x_1 : V), P x_1 a b) finset.univ).card)) (↑((finset.filter (λ (x_1 : V), P x_1 b a) finset.univ).card)) (↑((finset.filter (λ (x_1 : {v // v ≠ i}), minus_voter P i x_1 b a) finset.univ).card)),

  norm_cast,
  refine finset.card_le_card_of_inj_on _ _ _,
  exact (λ v, v.val),
  intros a_1 a_spec,
  simp, simp at a_spec,
  unfold minus_voter at a_spec,
  exact a_spec,

  intros a1 a1_spec a2 a2_spec,
  obviously,
end

theorem negative_involvement_split_cycle [fintype V] (P : Prof V X) [profile_asymmetric P] : negative_involvement split_cycle P :=
begin
  intros x i w p,
  unfold split_cycle, unfold max_el_VSCC, unfold split_cycle_VCCR, simp,
  unfold split_cycle at w, unfold max_el_VSCC at w, unfold split_cycle_VCCR at w,
  unfold split_cycle_CCR at w, simp at w,
  cases w with y w,
  use y,
  introI _inst_3,
  specialize w (subtype.fintype (λ v, v ≠ i)),
  cases w with m w,

  have ynx := ne_of_margin_pos m,
  have mxy := minus_voter_margin_eq2 i P y x (p y ynx),

  have o : ∀ a b : ℤ, 0 < a → a + 1 = b → 0 < b := by omega,
  use o (margin (minus_voter P i) y x) (margin P y x) m mxy,
  push_neg,
  intros l x_mem y_mem,
  specialize w l, specialize w x_mem, specialize w y_mem,
  contrapose w,
  push_neg,
  push_neg at w,

  refine cycle_of_cycle_imp _ w,
  intros a b mab,

  have o : ∀ a b c d : ℤ, a ≤ b → c + 1 = a → b ≤ d + 1 → c ≤ d := by omega,

  apply (o (margin P y x) (margin P a b) (margin (minus_voter P i) y x) (margin (minus_voter P i) a b) mab mxy ),

  exact minus_voter_margin_le2 i P a b,
end


import ..bin_tree
import ..nonempty_list

open util.data.nonempty_list
open util.data.bin_tree'
open util.data.bin_tree'.bin_tree'

universes u v

variable {α : Type u}

-- https://ncatlab.org/nlab/show/Mac+Lane%27s+proof+of+the+coherence+theorem+for+monoidal+categories

-- TODO(tim): do we really need two definitions of the congruence closure or can we just delete this one?
inductive cong_clos' (R : bin_tree' α → bin_tree' α → Type u) : bin_tree' α → bin_tree' α → Type u
| lift : Π s t, R s t → cong_clos' s t
| refl : Π t, cong_clos' t t
| trans : Π r s t, cong_clos' r s → cong_clos' s t → cong_clos' r t
| cong : Π l₁ r₁ l₂ r₂, cong_clos' l₁ l₂ → cong_clos' r₁ r₂ → cong_clos' (branch l₁ r₁) (branch l₂ r₂)

namespace cong_clos'

variable {R : bin_tree' α → bin_tree' α → Type u}

def sym (R_sym : Π s t, R s t → R t s)
    : Π {s t}, cong_clos' R s t → cong_clos' R t s
| ._ ._ (lift _ _ p)       := lift _ _ (R_sym _ _ p)
| ._ ._ (refl ._ t)        := refl R t
| ._ ._ (trans _ _ _ p q)  := trans _ _ _ (sym q) (sym p)
| ._ ._ (cong _ _ _ _ l r) := cong _ _ _ _ (sym l) (sym r)

def transport {S : bin_tree' α → bin_tree' α → Type u} (f : Π s t, R s t → S s t)
    : Π {s t}, cong_clos' R s t → cong_clos' S s t
| ._ ._ (lift _ _ p)       := lift _ _ (f _ _ p)
| ._ ._ (refl ._ t)        := refl S t
| ._ ._ (trans _ _ _ p q)  := trans _ _ _ (transport p) (transport q)
| ._ ._ (cong _ _ _ _ l r) := cong _ _ _ _ (transport l) (transport r)

lemma respects_to_list (R_to_list : Π s t, R s t → s.to_list = t.to_list)
    : Π {s t}, cong_clos' R s t → s.to_list = t.to_list
| ._ ._ (lift _ _ p)           := R_to_list _ _ p
| ._ ._ (refl ._ _)            := eq.refl _
| ._ ._ (trans _ _ _ p q)      := eq.trans (respects_to_list p) (respects_to_list q)
| ._ ._ (cong l₁ r₁ l₂ r₂ l r) :=
    begin
      unfold bin_tree'.to_list,
      rewrite (respects_to_list l),
      rewrite (respects_to_list r)
    end

end cong_clos'

inductive cong_clos_step (R : bin_tree' α → bin_tree' α → Type u) : bin_tree' α → bin_tree' α → Type u
| lift  : Π s t, R s t → cong_clos_step s t
| left  : Π l₁ l₂ r, cong_clos_step l₁ l₂ → cong_clos_step (branch l₁ r) (branch l₂ r)
| right : Π l r₁ r₂, cong_clos_step r₁ r₂ → cong_clos_step (branch l r₁) (branch l r₂)

namespace cong_clos_step

variable {R : bin_tree' α → bin_tree' α → Type u}

-- the equation compiler somehow can't handle the next definitions ~> turn it off
-- TODO(tim): report bug
set_option eqn_compiler.lemmas false

def sym (R_sym : Π s t, R s t → R t s)
    : Π {s t}, cong_clos_step R s t → cong_clos_step R t s
| ._ ._ (lift _ _ p)    := lift _ _ (R_sym _ _ p)
| ._ ._ (left _ _ _ l)  := left _ _ _ (sym l)
| ._ ._ (right _ _ _ r) := right _ _ _ (sym r)

def transport {S : bin_tree' α → bin_tree' α → Type u} (f : Π s t, R s t → S s t)
    : Π {s t}, cong_clos_step R s t → cong_clos_step S s t
| ._ ._ (lift _ _ p)    := lift _ _ (f _ _ p)
| ._ ._ (left _ _ _ l)  := left _ _ _ (transport l)
| ._ ._ (right _ _ _ r) := right _ _ _ (transport r)

lemma respects_to_list (R_to_list : Π s t, R s t → s.to_list = t.to_list)
    : Π {s t}, cong_clos_step R s t → s.to_list = t.to_list
| ._ ._ (lift _ _ p)    := R_to_list _ _ p
| ._ ._ (left _ _ _ l)  := by unfold bin_tree'.to_list; rewrite (respects_to_list l)
| ._ ._ (right _ _ _ r) := by unfold bin_tree'.to_list; rewrite (respects_to_list r)

lemma respects_lopsided
    (R_to_list : Π s t, R s t → s.to_list = t.to_list)
    {s t} (p : cong_clos_step R s t)
    : s.lopsided = t.lopsided
  := by unfold lopsided; rewrite respects_to_list R_to_list p

set_option eqn_compiler.lemmas true

end cong_clos_step

-- smallest reflexive, transitive, congruent (but not necessarily symmetric) relation that includes R
inductive cong_clos (R : bin_tree' α → bin_tree' α → Type u) : bin_tree' α → bin_tree' α → Type u
| refl : Π t, cong_clos t t
| step : Π r s t, cong_clos_step R r s → cong_clos s t → cong_clos r t

namespace cong_clos

variable {R : bin_tree' α → bin_tree' α → Type u}

open cong_clos_step

def lift {s t : bin_tree' α} (p : R s t) : cong_clos R s t :=
  step _ _ _ (cong_clos_step.lift _ _ p) (refl R _)

def trans : Π {r s t : bin_tree' α}, cong_clos R r s → cong_clos R s t → cong_clos R r t
| ._ ._ _ (refl ._ t)       qs := qs
| ._ ._ _ (step _ _ _ p ps) qs := step _ _ _ p (trans ps qs)

lemma trans_refl_right : Π {s t : bin_tree' α} (p : cong_clos R s t), trans p (refl R t) = p
| ._ ._ (refl ._ t)       := by reflexivity
| ._ ._ (step _ _ _ p ps) := by unfold trans; rewrite (trans_refl_right ps)

def inject_left (r : bin_tree' α) : Π {l₁ l₂ : bin_tree' α}, cong_clos R l₁ l₂ → cong_clos R (branch l₁ r) (branch l₂ r)
| ._ ._ (refl ._ t)       := refl R _
| ._ ._ (step _ _ _ p ps) := step _ _ _ (left _ _ _ p) (inject_left ps)

def inject_right (l : bin_tree' α) : Π {r₁ r₂ : bin_tree' α}, cong_clos R r₁ r₂ → cong_clos R (branch l r₁) (branch l r₂)
| ._ ._ (refl ._ _)       := refl R _
| ._ ._ (step _ _ _ p ps) := step _ _ _ (right _ _ _ p) (inject_right ps)

def cong {l₁ l₂ r₁ r₂ : bin_tree' α} (l : cong_clos R l₁ l₂) (r : cong_clos R r₁ r₂) : cong_clos R (branch l₁ r₁) (branch l₂ r₂) :=
  trans (inject_left _ l) (inject_right _ r)

def convert : Π (s t : bin_tree' α), cong_clos' R s t → cong_clos R s t
| ._ ._ (cong_clos'.refl ._ _)        := refl R _
| ._ ._ (cong_clos'.lift _ _ p)       := lift p
| ._ ._ (cong_clos'.trans _ _ _ p q)  := trans (convert _ _ p) (convert _ _ q)
| ._ ._ (cong_clos'.cong _ _ _ _ l r) := cong (convert _ _ l) (convert _ _ r)

def sym_helper (R_sym : Π s t, R s t → R t s)
    : Π {s t u}, cong_clos R s t → cong_clos R s u → cong_clos R t u
| ._ ._ _ (refl ._ t)       qs := qs
| ._ ._ _ (step _ _ _ p ps) qs := sym_helper ps (step _ _ _ (cong_clos_step.sym R_sym p) qs)

def sym (R_sym : Π s t, R s t → R t s) {s t} (ps : cong_clos R s t) : cong_clos R t s :=
  sym_helper R_sym ps (refl R _)

def transport {S : bin_tree' α → bin_tree' α → Type u} (f : Π s t, R s t → S s t)
    : Π {s t}, cong_clos R s t → cong_clos S s t
| ._ ._ (refl ._ t)       := refl S t
| ._ ._ (step _ _ _ p ps) := step _ _ _ (cong_clos_step.transport f p) (transport ps)

lemma respects_to_list (R_to_list : Π s t, R s t → s.to_list = t.to_list)
    : Π {s t}, cong_clos R s t → s.to_list = t.to_list
| ._ ._ (refl ._ t)       := by reflexivity
| ._ ._ (step r s t p ps) :=
  begin
    transitivity,
      exact (cong_clos_step.respects_to_list R_to_list p),
      exact (respects_to_list ps)
  end

lemma respects_lopsided
    (R_to_list : Π s t, R s t → s.to_list = t.to_list)
    {s t} (p : cong_clos R s t)
    : s.lopsided = t.lopsided
  := by unfold lopsided; rewrite respects_to_list R_to_list p

end cong_clos


import tactic
import compile_fast

class NatLt (m n : ℕ) := (proof : m < n)
instance NatLt.one (n : ℕ) : NatLt 0 (n+1) := ⟨nat.succ_pos _⟩
instance NatLt.trans (m n : ℕ) [h : NatLt m n] : NatLt (m+1) (n+1) :=
⟨nat.succ_lt_succ h.proof⟩

-- instance i1 : NatLt 3 2 := infer_instance -- no
instance i2 : NatLt 1 3 := infer_instance

universes u v

class Atomic (α : Type u) .

class Rectangle (Gen : ℕ → Type* → Type*) :=
  (map {α β : Type*} (i : ℕ) : (α → β) → Gen i α → Gen i β)
  (repl {α : Type*}  (i : ℕ) : α → Gen i α)

open Rectangle

class Merge (α β : Type*) (γ : out_param Type*) :=
  (merge1 : α → γ)
  (merge2 : β → γ)

open Merge

class NestedMap (α β γ δ : Type*) :=
  (map : (β → γ) → α → δ)

section Instances
variables
{Gen : ℕ → Type u → Type v}
{View : ℕ → Type u → Type v}
[Rectangle Gen]
variables {α β γ : Type u}

instance Gen.Merge.one {ρ} [Atomic ρ] : Merge ρ ρ ρ := ⟨id, id⟩
instance Gen.Merge.succ {i : ℕ} [Merge α β γ] : Merge (Gen i α) (Gen i β) (Gen i γ) :=
⟨map i (merge1 β), map i (merge2 α)⟩
instance Gen.Merge.scalar_r {i : ℕ} {ρ} [Atomic ρ] [Merge α ρ α] : Merge (Gen i α) ρ (Gen i α) :=
⟨id, repl i ∘ merge2 α⟩
instance Gen.Merge.lt {i j : ℕ} [NatLt i j] [Merge α (Gen j β) γ]
: Merge (Gen i α) (Gen j β) (Gen i γ) :=
⟨map i (merge1 (Gen j β)), repl i ∘ merge2 α⟩
instance Gen.Merge.scalar_l {j : ℕ} {ρ} [Atomic ρ] [Merge ρ β β] : Merge ρ (Gen j β) (Gen j β) :=
⟨repl j ∘ merge1 β, id⟩
instance Gen.merge.gt {i j : ℕ} [NatLt j i] [Merge (Gen i α) β γ] : Merge (Gen i α) (Gen j β) (Gen j γ) :=
⟨repl j ∘ merge1 β, map j (merge2 (Gen i α))⟩

def merge {α β γ} [Merge α β γ] : α → β → (γ × γ) := λ a b, (merge1 β a, merge2 α b)

instance Gen.NestedMap.Eq {i : ℕ} {α β} : NestedMap (Gen i α) α β (Gen i β) := ⟨Rectangle.map i⟩
instance Gen.NestedMap.Lt {i j : ℕ} {α β γ δ} [NatLt i j] [NestedMap α β γ δ] : NestedMap (Gen i α) β γ (Gen i δ) :=
⟨λ f, Rectangle.map i (NestedMap.map f)⟩

end Instances

def Fun (i : ℕ) (α : Type*) := ℕ → α
def Fun.to_fun {i α} : Fun i α → ℕ → α := id
def map {α β : Type} (m : ℕ) : (α → β) → Fun m α → Fun m β := λ f v, f ∘ v
def repl {α : Type} (m : ℕ) : α → Fun m α := λ v _, v

instance : Rectangle Fun :=
  { map := λ _ _, map, repl := λ _, repl }

instance nat.Atomic : Atomic ℕ := ⟨⟩

example : Merge ℕ ℕ ℕ := infer_instance
example {i : ℕ} : Merge (Fun i ℕ) ℕ (Fun i ℕ) := infer_instance
example {i : ℕ} : Merge (Fun i ℕ) (Fun i ℕ) (Fun i ℕ) := infer_instance
example {i : ℕ} : Merge (Fun i ℕ) ℕ (Fun i ℕ) := infer_instance
example {i j : ℕ} [NatLt i j] : Merge ℕ (Fun j ℕ) (Fun j ℕ) := infer_instance
example {i j : ℕ} [NatLt i j] : Merge (Fun i ℕ) (Fun j ℕ) (Fun i (Fun j ℕ)) := infer_instance
example {i j k : ℕ} [NatLt i j] : Merge (Fun i (Fun j ℕ)) (Fun j (Fun k ℕ)) (Fun i (Fun j (Fun k ℕ))) := infer_instance

@[reducible] def i := 1
@[reducible] def j := 2
@[reducible] def k := 3
@[reducible] def l := 4
@[reducible] def V := ℕ

instance hmul_of_Merge {α β γ : Type}  [has_mul γ] [Merge α β γ] : has_hmul α β γ :=
⟨λ a b, merge1 β a * merge2 α b⟩

-- demo with functions:
instance Fun.mul {i : ℕ} {α : Type} [has_mul α] : has_mul (Fun i α) :=
⟨λ a b i, a.to_fun i * b.to_fun i⟩
example {i : ℕ} : has_hmul (Fun i ℕ) ℕ (Fun i ℕ) := infer_instance

def v1 : Fun i (Fun j V) := λ i j, i+j
def v2 : Fun j (Fun k V) := λ i j, i*j
def v3 : (Fun l V) := λ i, i

--set_option trace.class_instances true
--set_option class.instance_max_depth 20
--set_option pp.all true

section Streams

def Ind (i : ℕ) := E
inductive Stream (n : ℕ) (α : Type)
| view (v : View (Ind n) α) : Stream
| gen  (g : G (Ind n) α)    : Stream

instance {n} : functor (Stream n) :=
{ map := λ _ _ f g, match g with
  | Stream.view v := Stream.view { v with value := f ∘ v.value }
  | Stream.gen  g := Stream.gen  { g with value := f g.value }
  end }

instance : Rectangle Stream :=
{ map  := λ _ _ _, functor.map,
  repl := λ _ m v, Stream.view ⟨λ _, v⟩ }
instance : Atomic E := ⟨⟩

def foo1 : Merge (Stream i E) (Stream j E) (Stream i (Stream j E)) := infer_instance

variables {ι α β γ : Type}
(n : ℕ)

instance G.Ind.hmul {i : ℕ} [has_hmul α β γ] : has_hmul (G (Ind i) α) (G (Ind i) β) (G (Ind i) γ) := ⟨G.mul⟩

instance [inhabited α] : inhabited (Stream n α) := ⟨Stream.view ⟨λ _, default⟩⟩
instance [inhabited ι] [inhabited α] : inhabited (G ι α) := ⟨G.empty⟩

-- instance Stream.has_mul {α} {i} [has_mul α] : has_mul (StreamGen' i α) := ⟨StreamGen.mul⟩
instance Stream.has_mul {γ} {i} [inhabited γ] [has_mul γ] : has_mul (Stream i γ) := ⟨λ a b,
match a, b with
| Stream.view a, Stream.view b := arbitrary _ -- Stream.view $ a⋆b
| Stream.gen a, Stream.view b := Stream.gen $ a⋆b
| Stream.view a, Stream.gen b := Stream.gen $ a⋆b
| Stream.gen a, Stream.gen b := Stream.gen $ a⋆b
end⟩

variables (a : Stream i E) (b : Stream j E)

example : has_mul (Stream i (Stream j E)) := infer_instance
example : Stream i (Stream j E) := a ⋆ b

instance : has_coe (G E E) (Stream n E) := ⟨Stream.gen⟩
instance coe_stream [has_coe α β] : has_coe (G E α) (Stream n β) := ⟨Stream.gen ∘ functor.map has_coe.coe⟩

class of_stream (α β : Type) := (coe : α → β)
instance base.of_stream : of_stream α α := ⟨id⟩
def Stream.to_g {n} [inhabited α] : (Stream n α) → (G E α) := λ s, match s with
| Stream.view _ := arbitrary _
| Stream.gen a := a
end

instance [inhabited β] [of_stream α β] : of_stream (Stream n α) (G E β) := ⟨λ s, match s with
| Stream.view _ := arbitrary _
| Stream.gen a := of_stream.coe <$> a
end⟩

def Stream.of [of_stream α β] : α → β := of_stream.coe

infixr ` →ₛ `:24 := Stream

--def Stream.to_stream {n} [of_stream α β] : Stream n α → G E β := of_stream.coe

-- instance s_level.eval [of_stream γ β] [Ev α (G E β)] : Ev α (Stream i γ) :=
-- ⟨ λ l r, exec l (of_stream.coe r : G E β) ⟩
-- instance stream.level.eval' (n : ℕ) [Ev α (G E β)] : Ev α (Stream n β) :=
-- ⟨ λ l r, exec l $ r.to_g _ ⟩

class Sum (n : ℕ) (α : Type) (β : out_param Type) := (sum : α → β)
instance sum_eq (n : ℕ) [inhabited α] : Sum n (Stream n α) (G unit α) := ⟨G.contract ∘ Stream.to_g⟩
instance sum_lt (m n : ℕ) [NatLt n m] [Sum m α β] : Sum m (Stream n α) (Stream n β) := ⟨functor.map $ Sum.sum m⟩

abbreviation R := E

prefix ` Σ ` := Sum.sum

def mmul1'  := Σ i $ Σ j $ Σ k $ (A : i →ₛ j →ₛ E) ⋆ (B : j →ₛ k →ₛ E)
def mmul2'  := Σ i $ Σ j $ Σ k $ (A : i →ₛ k →ₛ E) ⋆ (B : j →ₛ k →ₛ E)
def ttv'    := Σ i $ Σ j $ Σ k $ (C : i →ₛ j →ₛ k →ₛ R) ⋆ (v : k →ₛ R)
def ttm'    := Σ i $ Σ j $ Σ k $ Σ l $ (C : i →ₛ j →ₛ l →ₛ R) ⋆ (A : k →ₛ l →ₛ R)
def mttkrp' := Σ i $ Σ j $ Σ k $ Σ l $ (C : i →ₛ j →ₛ k →ₛ R) ⋆ (A : j →ₛ l →ₛ R) ⋆ (B : k →ₛ l →ₛ R)
def inner3' := Σ i $ Σ j $ Σ k $ (C : i →ₛ j →ₛ k →ₛ R) ⋆ (D : i →ₛ j →ₛ k →ₛ R)

example : Sum i (Stream i E) (G unit E) := infer_instance
example : Sum j (Stream i (Stream j E)) (Stream i (G unit E)) := infer_instance

def inner : Stream i (Stream j (G unit E)) :=
  Sum.sum k $ (A : i →ₛ k →ₛ E) ⋆ (B : j →ₛ k →ₛ E)

def eg_mmul1 :=
  [me $ exec out mmul1'] ++
  [ta $ Prog.inline_code "taco_ijk_sum();"]

def eg_mmul2 :=
  [me $ exec out mmul2'] ++
  [ta $ Prog.inline_code "mmul2_compute();"]

def eg_ttv :=
  [me $ exec out $ G.contract $ View.to_gen "foo" 30 $ constView E $ ttv'] ++
  [ta $ exec out $ G.contract $ View.to_gen "foo" 30 $ constView E $ E.inline_code "ttv_compute();"]

def eg_ttm :=
  [me $ exec out ttm'] ++
  [ta $ Prog.inline_code "ttm_compute();"]

def eg_mttkrp :=
  [me $ exec out mttkrp'] ++
  [ta $ Prog.inline_code "mttkrp_compute();"]

def eg_inner3 :=
  [me $ exec out inner3'] ++
  [ta $ Prog.inline_code "inner3_compute();"]

def eg_inner3' :=
  [me $ exec out $ G.contract $ View.to_gen "foo" 200 $ constView E $ inner3'] ++
  [ta $ exec out $ G.contract $ View.to_gen "foo" 200 $ constView E $ E.inline_code "inner3_compute();"]

def compile_with_load (v : list Prog) := compile $ load ++ v

def tests :=
  /- 1 -/ eg_mmul1 ++
  /- 2 -/ eg_mmul2 ++
  /- 3 -/ eg_ttv ++
  /- 4 -/ eg_ttm ++
  /- 5 -/ eg_mttkrp ++
  /- 6 -/ eg_inner3'

def run_comparisons := compile_with_load tests

-- main comparison script:
-- #eval run_comparisons

end Streams


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import category_theory.sites.compatible_plus
import category_theory.sites.sheafification

/-!

In this file, we prove that sheafification is compatible with functors which
preserve the correct limits and colimits.

-/

namespace category_theory.grothendieck_topology

open category_theory
open category_theory.limits
open opposite

universes w₁ w₂ v u
variables {C : Type u} [category.{v} C] (J : grothendieck_topology C)
variables {D : Type w₁} [category.{max v u} D]
variables {E : Type w₂} [category.{max v u} E]
variables (F : D ⥤ E)

noncomputable theory

variables [∀ (α β : Type (max v u)) (fst snd : β → α),
  has_limits_of_shape (walking_multicospan fst snd) D]
variables [∀ (α β : Type (max v u)) (fst snd : β → α),
  has_limits_of_shape (walking_multicospan fst snd) E]
variables [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ D]
variables [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ E]
variables [∀ (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ F]
variables [∀ (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D), preserves_limit (W.index P).multicospan F]

variables (P : Cᵒᵖ ⥤ D)

/-- The isomorphism between the sheafification of `P` composed with `F` and
the sheafification of `P ⋙ F`.

Use the lemmas `whisker_right_to_sheafify_sheafify_comp_iso_hom`,
`to_sheafify_comp_sheafify_comp_iso_inv` and `sheafify_comp_iso_inv_eq_sheafify_lift` to reduce
the components of this isomorphisms to a state that can be handled using the universal property
of sheafification. -/
def sheafify_comp_iso : J.sheafify P ⋙ F ≅ J.sheafify (P ⋙ F) :=
J.plus_comp_iso _ _ ≪≫ (J.plus_functor _).map_iso (J.plus_comp_iso _ _)

/-- The isomorphism between the sheafification of `P` composed with `F` and
the sheafification of `P ⋙ F`, functorially in `F`. -/
def sheafification_whisker_left_iso (P : Cᵒᵖ ⥤ D)
  [∀ (F : D ⥤ E) (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ F]
  [∀ (F : D ⥤ E) (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D),
    preserves_limit (W.index P).multicospan F] :
  (whiskering_left _ _ E).obj (J.sheafify P) ≅
  (whiskering_left _ _ _).obj P ⋙ J.sheafification E :=
begin
  refine J.plus_functor_whisker_left_iso _ ≪≫ _ ≪≫ functor.associator _ _ _,
  refine iso_whisker_right _ _,
  refine J.plus_functor_whisker_left_iso _,
end

@[simp]
lemma sheafification_whisker_left_iso_hom_app (P : Cᵒᵖ ⥤ D) (F : D ⥤ E)
  [∀ (F : D ⥤ E) (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ F]
  [∀ (F : D ⥤ E) (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D),
    preserves_limit (W.index P).multicospan F] :
  (sheafification_whisker_left_iso J P).hom.app F = (J.sheafify_comp_iso F P).hom :=
begin
  dsimp [sheafification_whisker_left_iso, sheafify_comp_iso],
  rw category.comp_id,
end

@[simp]
lemma sheafification_whisker_left_iso_inv_app (P : Cᵒᵖ ⥤ D) (F : D ⥤ E)
  [∀ (F : D ⥤ E) (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ F]
  [∀ (F : D ⥤ E) (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D),
    preserves_limit (W.index P).multicospan F] :
  (sheafification_whisker_left_iso J P).inv.app F = (J.sheafify_comp_iso F P).inv :=
begin
  dsimp [sheafification_whisker_left_iso, sheafify_comp_iso],
  erw category.id_comp,
end

/-- The isomorphism between the sheafification of `P` composed with `F` and
the sheafification of `P ⋙ F`, functorially in `P`. -/
def sheafification_whisker_right_iso :
  J.sheafification D ⋙ (whiskering_right _ _ _).obj F ≅
  (whiskering_right _ _ _).obj F ⋙ J.sheafification E :=
begin
  refine functor.associator _ _ _ ≪≫ _,
  refine iso_whisker_left (J.plus_functor D) (J.plus_functor_whisker_right_iso _) ≪≫ _,
  refine _ ≪≫ functor.associator _ _ _,
  refine (functor.associator _ _ _).symm ≪≫ _,
  exact iso_whisker_right (J.plus_functor_whisker_right_iso _) (J.plus_functor E),
end

@[simp]
lemma sheafification_whisker_right_iso_hom_app :
  (J.sheafification_whisker_right_iso F).hom.app P = (J.sheafify_comp_iso F P).hom :=
begin
  dsimp [sheafification_whisker_right_iso, sheafify_comp_iso],
  simp only [category.id_comp, category.comp_id],
  erw category.id_comp,
end

@[simp]
lemma sheafification_whisker_right_iso_inv_app :
  (J.sheafification_whisker_right_iso F).inv.app P = (J.sheafify_comp_iso F P).inv :=
begin
  dsimp [sheafification_whisker_right_iso, sheafify_comp_iso],
  simp only [category.id_comp, category.comp_id],
  erw category.id_comp,
end

@[simp, reassoc]
lemma whisker_right_to_sheafify_sheafify_comp_iso_hom :
  whisker_right (J.to_sheafify _) _ ≫ (J.sheafify_comp_iso F P).hom = J.to_sheafify _ :=
begin
  dsimp [sheafify_comp_iso],
  erw [whisker_right_comp, category.assoc],
  slice_lhs 2 3 { rw plus_comp_iso_whisker_right },
  rw [category.assoc, ← J.plus_map_comp,
    whisker_right_to_plus_comp_plus_comp_iso_hom, ← category.assoc,
    whisker_right_to_plus_comp_plus_comp_iso_hom],
  refl,
end

@[simp, reassoc]
lemma to_sheafify_comp_sheafify_comp_iso_inv :
  J.to_sheafify _ ≫ (J.sheafify_comp_iso F P).inv = whisker_right (J.to_sheafify _) _ :=
by { rw iso.comp_inv_eq, simp }

section

-- We will sheafify `D`-valued presheaves in this section.
variables
  [concrete_category.{max v u} D]
  [preserves_limits (forget D)]
  [∀ (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ (forget D)]
  [reflects_isomorphisms (forget D)]

@[simp]
lemma sheafify_comp_iso_inv_eq_sheafify_lift : (J.sheafify_comp_iso F P).inv =
  J.sheafify_lift (whisker_right (J.to_sheafify _) _) ((J.sheafify_is_sheaf _).comp _) :=
begin
  apply J.sheafify_lift_unique,
  rw iso.comp_inv_eq,
  simp,
end

end

end category_theory.grothendieck_topology


import free_pfpng.setup

.

noncomputable theory

open_locale classical

open category_theory
open opposite

universe u

lemma Profinite.mono_free'_to_condensed_free_pfpng_aux
  (S B : Profinite.{u}) (b : B) (T : discrete_quotient S)
  (t : S.to_Condensed.val.obj (op B) →₀ ℤ) :
let e : S.to_Condensed.val.obj (op B) →
    S.condensed_free_pfpng.val.obj (op B) :=
    λ f, (S.to_condensed_free_pfpng.val.app (op B) f),
    ι : S.to_Condensed.val.obj (op B) → S :=
      λ f, (ulift.down f).1 b in
    ((limits.limit.π (S.fintype_diagram ⋙ forget Fintype ⋙
      AddCommGroup.free' ⋙ Ab.ulift) T)
      (S.condensed_free_pfpng_specialize B b (free'_lift e t))).down
  = t.map_domain (T.proj ∘ ι) :=
begin
  dsimp,
  revert t,
  rw ← function.funext_iff,
  dsimp,
  change ulift.down ∘ _ = _,
  apply finsupp.fun_ext,
  { intros, simp only [function.comp_app, map_add, ulift.add_down,
      eq_self_iff_true, forall_const] },
  { intros, simp only [function.comp_app, map_zero, ulift.zero_down,
      finsupp.map_domain_add] },
  { intros,
    simp only [function.comp_app, finsupp.map_domain_single,
      free'_lift_eq_finsupp_lift],
    dsimp [Profinite.condensed_free_pfpng_specialize],
    simp only [← comp_apply],
    erw limits.limit.lift_π,
    simp only [finsupp.sum_single_index, zero_smul, one_zsmul],
    ext i,
    dsimp [Profinite.condensed_free_pfpng_specialize_cone,
      finsupp.single, Profinite.free_pfpng_π, Profinite.to_free_pfpng],
    erw ProFiltPseuNormGrp₁.limit_π_coe_eq,
    simp only [← comp_apply, category.assoc],
    dsimp [Profinite.free_pfpng_level_iso,
      limits.is_limit.cone_point_unique_up_to_iso],
    simp only [← comp_apply, category.assoc],
    erw (limits.is_limit_of_preserves (ProFiltPseuNormGrp₁.level.obj 1)
      (limits.limit.is_limit (S.fintype_diagram ⋙ free_pfpng_functor))).fac,
    erw limits.limit.lift_π,
    refl },
end

lemma Profinite.specialization_eq_zero_of_eq_zero (S B : Profinite.{u}) (b : B)
  (t : S.to_Condensed.val.obj (op B) →₀ ℤ)
  (ht : free'_lift (S.to_condensed_free_pfpng.val.app (op B)) t = 0) :
  t.map_domain (λ f, (ulift.down f).1 b) = 0 :=
begin
  apply free_pfpng.discrete_quotient_separates_points' S,
  intros T,
  apply_fun (λ e, S.condensed_free_pfpng_specialize B b e) at ht,
  rw add_monoid_hom.map_zero at ht,
  apply_fun (λ e, limits.limit.π (S.fintype_diagram ⋙ forget Fintype ⋙
    AddCommGroup.free' ⋙ Ab.ulift) T e) at ht,
  rw add_monoid_hom.map_zero at ht,
  apply_fun ulift.down at ht,
  dsimp [AddCommGroup.free'],
  rw ← finsupp.map_domain_comp,
  have := S.mono_free'_to_condensed_free_pfpng_aux B b T t,
  dsimp at this, erw ← this, exact ht
end

lemma Profinite.adj'_hom_equiv_symm_eq_free'_lift (S B : Profinite.{u}) :
    (((AddCommGroup.adj'.whisker_right Profinite.{u}ᵒᵖ).hom_equiv
      S.to_Condensed.val S.condensed_free_pfpng.val).symm
      S.to_condensed_free_pfpng.val).app (op B) =
    free'_lift (S.to_condensed_free_pfpng.val.app (op B)) :=
begin
  ext u v, dsimp [free'_lift],
  simp only [adjunction.hom_equiv_counit, whiskering_right_obj_map,
    nat_trans.comp_app, whisker_right_app,
    adjunction.whisker_right_counit_app_app],
end

open_locale big_operators
lemma finsupp.map_domain_ne_zero_of_ne_zero_of_inj_on {α β γ : Type*} [add_comm_group β]
  (t : α →₀ β) (ht : t ≠ 0) (f : α → γ)
  (hinj : set.inj_on f t.support) :
  t.map_domain f ≠ 0 :=
begin
  contrapose! ht,
  have : ∀ (e : γ) (he : e ∈ (t.map_domain f).support), ∃ (q : α) (hq : q ∈ t.support), f q = e,
  { intros e he, by_contra c, push_neg at c,
    simp only [finsupp.mem_support_iff, ne.def] at he,
    apply he,
    erw finset.sum_apply',
    apply finset.sum_eq_zero,
    intros a ha,
    dsimp [finsupp.single], rw if_neg, apply c, exact ha },
  choose q hq hh using this,
  let ι : (t.map_domain f).support → t.support :=
    λ e, ⟨q e.1 e.2, hq e.1 e.2⟩,
  have hι : function.surjective ι,
  { rintros ⟨e,he⟩, use f e,
    { simp only [finsupp.mem_support_iff, ne.def],
      rw finsupp.map_domain_apply' _ _ (set.subset.refl _) hinj he,
      simpa using he },
    { ext, dsimp,
      apply hinj, apply hq, apply he, apply hh } },
  have : (t.map_domain f).support = ∅, by simpa using ht,
  suffices : t.support = ∅, by simpa using this,
  by_contra c, change _ ≠ _ at c,
  erw ← finset.nonempty_iff_ne_empty at c,
  obtain ⟨c,hc⟩ := c, obtain ⟨⟨c,hc⟩,ee⟩ := hι ⟨c,hc⟩,
  rw this at hc, simpa using hc,
end

lemma finsupp.lift_map_domain {γ α β : Type*} [add_comm_group β]
  (f : α → β) (ι : γ → α) :
  (finsupp.lift _ ℤ _ f) ∘ finsupp.map_domain ι = finsupp.lift _ ℤ _ (f ∘ ι) :=
begin
  apply finsupp.fun_ext,
  { intros x y,
    dsimp only [function.comp_apply],
    simp only [finsupp.map_domain_add],
    erw ((finsupp.lift β ℤ α) f).to_add_monoid_hom.map_add, refl },
  { intros x y,
    erw ((finsupp.lift β ℤ γ) (f ∘ ι)).to_add_monoid_hom.map_add, refl },
  { intros x, simp },
end

lemma finsupp.lift_map_domain_apply {γ α β : Type*} [add_comm_group β]
  (f : α → β) (ι : γ → α) (e : γ →₀ ℤ) :
  (finsupp.lift _ ℤ _ f).to_add_monoid_hom (e.map_domain ι) =
  finsupp.lift _ ℤ _ (f ∘ ι) e :=
begin
  rw ← finsupp.lift_map_domain, refl,
end

lemma finsupp.card_supp_map_domain_lt {α β γ : Type*} [add_comm_group γ]
  (f : α → β) (t : α →₀ γ) (u v : α)
  (huv : u ≠ v) (hu : u ∈ t.support) (hv : v ∈ t.support)
  (hf : f u = f v) : (t.map_domain f).support.card < t.support.card :=
begin
  classical,
  have key : (finsupp.map_domain f t).support ⊆ _ := finsupp.map_domain_support,
  have : (finsupp.map_domain f t).support.card ≤ (t.support.image f).card :=
    finset.card_le_of_subset key,
  refine lt_of_le_of_lt this _,
  have key' : (t.support.image f).card ≤ t.support.card := finset.card_image_le,
  apply lt_of_le_of_ne key',
  change ¬ _,
  rw finset.card_image_iff,
  dsimp [set.inj_on],
  push_neg, use [u, hu, v, hv, hf],
end

lemma Profinite.mono_free'_to_condensed_free_pfpng_induction_aux (n : ℕ) :
  ∀ (S B : Profinite.{u}) (t : S.to_Condensed.val.obj (op B) →₀ ℤ),
    t.support.card ≤ n →
    (free'_lift (S.to_condensed_free_pfpng.val.app (op B))) t = 0 →
  (∀ (b : ↥B), finsupp.map_domain (λ f : S.to_Condensed.val.obj (op B),
    (ulift.down f).1 b) t = 0) →
  (∃ (α : Type u) [_inst_1 : fintype α] (X : α → Profinite) (π : Π (a : α), X a ⟶ B)
    (surj : ∀ (b : ↥B), ∃ (a : α) (x : ↥(X a)), (π a) x = b),
    ∀ (a : α), finsupp.map_domain (S.to_Condensed.val.map (π a).op) t = 0) :=
begin
  /-
  TODO: This proof is very slow. It would be better to pull out a few
  of the `have` statements into separate lemmas to (hopefully)
  speed this up.
  -/
  induction n,
  case nat.zero
  { intros S B t ht, simp at ht, rw ht, intros h1 h2,
    use [punit, infer_instance, λ _, B, λ _, 𝟙 _],
    split, { intros b, use [punit.star, b], refl },
    { intros _, rw finsupp.map_domain_zero, } },
  case nat.succ : n hn
  { intros S B t ht1 ht2 H,
    by_cases ht1' : t.support.card = n+1, swap,
    { apply hn, exact nat.le_of_lt_succ (nat.lt_of_le_and_ne ht1 ht1'),
      assumption' },
    clear ht1,
    let F := t.support,
    let e : F → (B ⟶ S) := λ f, f.1.1,
    obtain ⟨Q,h1,h2,ee,-⟩ : ∃ (α : Type u) (hα1 : fintype α)
      (hα2 : linear_order α) (ee : α ≃ F), true,
    { refine ⟨ulift (fin (fintype.card F)), infer_instance,
        is_well_order.linear_order well_ordering_rel,
        equiv.ulift.trans (fintype.equiv_fin _).symm, trivial⟩, },
    resetI,
    let E₀ := { a : Q × Q | a.1 < a.2 },
    let X₀ : E₀ → Profinite.{u} := λ i, Profinite.equalizer (e (ee i.1.1)) (e (ee i.1.2)),
    let π₀ : Π (i : E₀), X₀ i ⟶ B := λ i, Profinite.equalizer.ι _ _,

    have surj₀ : ∀ (b : B), ∃ (e₀ : E₀) (x : X₀ e₀), π₀ _ x = b,
    { intro b, specialize H b,
      contrapose! H,
      have key : ∀ (i j : Q) (h : i < j), e (ee i) b ≠ e (ee j) b,
      { intros i j h, specialize H ⟨⟨i,j⟩, h⟩, intro c,
        specialize H, dsimp [X₀] at H, specialize H ⟨b, c⟩,
        apply H, refl },
      apply finsupp.map_domain_ne_zero_of_ne_zero_of_inj_on,
      { intro c, rw c at ht1', simpa using ht1' },
      { intros x hx y hy hxy, dsimp at hxy,
        let i : Q := ee.symm ⟨x,hx⟩,
        let j : Q := ee.symm ⟨y,hy⟩,
        rcases lt_trichotomy i j with (hhh|hhh|hhh),
        { specialize key i j hhh, contrapose hxy, convert key,
          { dsimp [i], rw ee.apply_symm_apply, refl },
          { dsimp [j], rw ee.apply_symm_apply, refl } },
        { apply_fun (λ q, (ee q).1) at hhh, dsimp [i,j] at hhh,
          simp_rw ee.apply_symm_apply at hhh, exact hhh },
        { specialize key j i hhh, contrapose hxy, convert key.symm,
          { dsimp [j], rw ee.apply_symm_apply, refl },
          { dsimp [i], rw ee.apply_symm_apply, refl } } } },

    let f₀ : Π (i : E₀), S.to_Condensed.val.obj (op B) → S.to_Condensed.val.obj (op (X₀ i)) :=
      λ i, S.to_Condensed.val.map (π₀ i).op,

    let t₀ : Π (i : E₀), S.to_Condensed.val.obj (op (X₀ i)) →₀ ℤ :=
      λ i, t.map_domain (f₀ i),

    have card₀ : ∀ (i : E₀), (t₀ i).support.card ≤ n,
    { intros i, suffices : (t₀ i).support.card < n + 1,
        by exact nat.lt_succ_iff.mp this,
      rw ← ht1',
      fapply finsupp.card_supp_map_domain_lt,
      refine (ee i.1.1).1,
      refine (ee i.1.2).1,
      { change ¬ _,
        erw ← subtype.ext_iff,
        apply ee.injective.ne,
        apply ne_of_lt,
        exact i.2 },
      refine (ee i.1.1).2,
      refine (ee i.1.2).2,
      { dsimp [f₀, π₀, Profinite.to_Condensed], ext1, dsimp,
        -- missing Profinite.equalizer.condition
        ext t, exact t.2 } },

    have lift₀ : ∀ (i : E₀), free'_lift (S.to_condensed_free_pfpng.val.app (op (X₀ i))) (t₀ i) = 0,
    { intros i, rw free'_lift_eq_finsupp_lift, dsimp only [t₀, f₀],
      apply_fun (λ q, S.condensed_free_pfpng.val.map (π₀ i).op q) at ht2,
      rw [add_monoid_hom.map_zero, free'_lift_eq_finsupp_lift] at ht2,
      convert ht2,
      rw finsupp.lift_map_domain_apply,
      dsimp [finsupp.lift],
      rw (S.condensed_free_pfpng.val.map (π₀ i).op).map_finsupp_sum,
      refl },

    have map₀ : ∀ (i : E₀) (b : ↥(X₀ i)),
        finsupp.map_domain
          (λ (f : S.to_Condensed.val.obj (op (X₀ i))), f.down.to_fun b) (t₀ i) = 0,
    { intros i b, dsimp [t₀], rw ← finsupp.map_domain_comp,
      exact H (π₀ i b) },

    have key := λ i, hn S (X₀ i) (t₀ i) (card₀ i) (lift₀ i) (map₀ i),

    choose A hA X₁ π₁ surj₁ key using key, resetI,

    let E := Σ (e : E₀), A e,
    let X : E → Profinite.{u} := λ i, X₁ i.1 i.2,
    let π : Π (e : E), X e ⟶ B := λ e, π₁ e.1 e.2 ≫ π₀ e.1,

    use [E, infer_instance, X, π], split,

    { intros b,
      obtain ⟨e₀,x,hx⟩ := surj₀ b,
      obtain ⟨i,q,hq⟩ := surj₁ e₀ x,
      use [⟨e₀,i⟩,q], dsimp [π], rw [hq, hx] },
    { intros a,
      dsimp [π], rw functor.map_comp,
      erw finsupp.map_domain_comp,
      apply key } },
end

instance Profinite.mono_free'_to_condensed_free_pfpng
  (S : Profinite.{u}) : mono S.free'_to_condensed_free_pfpng :=
begin
  apply presheaf_to_Condensed_Ab_map_mono_of_exists, intros B t ht,
  let e : S.to_Condensed.val.obj (op B) →
    S.condensed_free_pfpng.val.obj (op B) :=
    λ f, (S.to_condensed_free_pfpng.val.app (op B) f),
  dsimp at t ht,
  replace ht : free'_lift e t = 0, by rwa ← S.adj'_hom_equiv_symm_eq_free'_lift,
  let ι : Π b : B, S.to_Condensed.val.obj (op B) → S :=
    λ b f, (ulift.down f).1 b,
  have aux : ∀ b : B, t.map_domain (ι b) = 0 :=
    λ b, S.specialization_eq_zero_of_eq_zero B b t ht,
  dsimp,
  apply Profinite.mono_free'_to_condensed_free_pfpng_induction_aux,
  refl,
  assumption',
end


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

! This file was ported from Lean 3 source module category_theory.limits.constructions.finite_products_of_binary_products
! leanprover-community/mathlib commit 69c6a5a12d8a2b159f20933e60115a4f2de62b58
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Limits.Preserves.Shapes.BinaryProducts
import Mathbin.CategoryTheory.Limits.Preserves.Shapes.Products
import Mathbin.CategoryTheory.Limits.Shapes.BinaryProducts
import Mathbin.CategoryTheory.Limits.Shapes.FiniteProducts
import Mathbin.Logic.Equiv.Fin

/-!
# Constructing finite products from binary products and terminal.

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

If a category has binary products and a terminal object then it has finite products.
If a functor preserves binary products and the terminal object then it preserves finite products.

# TODO

Provide the dual results.
Show the analogous results for functors which reflect or create (co)limits.
-/

universe v v' u u'

noncomputable section

open CategoryTheory CategoryTheory.Category CategoryTheory.Limits

namespace CategoryTheory

variable {J : Type v} [SmallCategory J]

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

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

/- warning: category_theory.extend_fan -> CategoryTheory.extendFan is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u2}} [_inst_2 : CategoryTheory.Category.{u1, u2} C] {n : Nat} {f : (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) -> C} (c₁ : CategoryTheory.Limits.Fan.{0, u1, u2} (Fin n) C _inst_2 (fun (i : Fin n) => f (Fin.succ n i))), (CategoryTheory.Limits.BinaryFan.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (OfNat.mk.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (Zero.zero.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) (Fin.hasZeroOfNeZero (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne)) (NeZero.succ n)))))) (CategoryTheory.Limits.Cone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)) -> (CategoryTheory.Limits.Fan.{0, u1, u2} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) C _inst_2 f)
but is expected to have type
  forall {C : Type.{u2}} [_inst_2 : CategoryTheory.Category.{u1, u2} C] {n : Nat} {f : (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) -> C} (c₁ : CategoryTheory.Limits.Fan.{0, u1, u2} (Fin n) C _inst_2 (fun (i : Fin n) => f (Fin.succ n i))), (CategoryTheory.Limits.BinaryFan.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) 0 (Fin.instOfNatFin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) 0 (NeZero.succ n)))) (CategoryTheory.Limits.Cone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)) -> (CategoryTheory.Limits.Fan.{0, u1, u2} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) C _inst_2 f)
Case conversion may be inaccurate. Consider using '#align category_theory.extend_fan CategoryTheory.extendFanₓ'. -/
/--
Given `n+1` objects of `C`, a fan for the last `n` with point `c₁.X` and a binary fan on `c₁.X` and
`f 0`, we can build a fan for all `n+1`.

In `extend_fan_is_limit` we show that if the two given fans are limits, then this fan is also a
limit.
-/
@[simps (config := { rhsMd := semireducible })]
def extendFan {n : ℕ} {f : Fin (n + 1) → C} (c₁ : Fan fun i : Fin n => f i.succ)
    (c₂ : BinaryFan (f 0) c₁.pt) : Fan f :=
  Fan.mk c₂.pt
    (by
      refine' Fin.cases _ _
      · apply c₂.fst
      · intro i
        apply c₂.snd ≫ c₁.π.app ⟨i⟩)
#align category_theory.extend_fan CategoryTheory.extendFan

/- warning: category_theory.extend_fan_is_limit -> CategoryTheory.extendFanIsLimit is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u2}} [_inst_2 : CategoryTheory.Category.{u1, u2} C] {n : Nat} (f : (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) -> C) {c₁ : CategoryTheory.Limits.Fan.{0, u1, u2} (Fin n) C _inst_2 (fun (i : Fin n) => f (Fin.succ n i))} {c₂ : CategoryTheory.Limits.BinaryFan.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (OfNat.mk.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (Zero.zero.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) (Fin.hasZeroOfNeZero (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne)) (NeZero.succ n)))))) (CategoryTheory.Limits.Cone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)}, (CategoryTheory.Limits.IsLimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁) -> (CategoryTheory.Limits.IsLimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.discreteCategory.{0} CategoryTheory.Limits.WalkingPair) C _inst_2 (CategoryTheory.Limits.pair.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (OfNat.mk.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (Zero.zero.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) (Fin.hasZeroOfNeZero (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne)) (NeZero.succ n)))))) (CategoryTheory.Limits.Cone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)) c₂) -> (CategoryTheory.Limits.IsLimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))))) (CategoryTheory.discreteCategory.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))))) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) f) (CategoryTheory.extendFan.{u1, u2} C _inst_2 n f c₁ c₂))
but is expected to have type
  forall {C : Type.{u2}} [_inst_2 : CategoryTheory.Category.{u1, u2} C] {n : Nat} (f : (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) -> C) {c₁ : CategoryTheory.Limits.Fan.{0, u1, u2} (Fin n) C _inst_2 (fun (i : Fin n) => f (Fin.succ n i))} {c₂ : CategoryTheory.Limits.BinaryFan.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) 0 (Fin.instOfNatFin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) 0 (NeZero.succ n)))) (CategoryTheory.Limits.Cone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)}, (CategoryTheory.Limits.IsLimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁) -> (CategoryTheory.Limits.IsLimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.discreteCategory.{0} CategoryTheory.Limits.WalkingPair) C _inst_2 (CategoryTheory.Limits.pair.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) 0 (Fin.instOfNatFin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) 0 (NeZero.succ n)))) (CategoryTheory.Limits.Cone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)) c₂) -> (CategoryTheory.Limits.IsLimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))))) (CategoryTheory.discreteCategory.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))))) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) f) (CategoryTheory.extendFan.{u1, u2} C _inst_2 n f c₁ c₂))
Case conversion may be inaccurate. Consider using '#align category_theory.extend_fan_is_limit CategoryTheory.extendFanIsLimitₓ'. -/
/-- Show that if the two given fans in `extend_fan` are limits, then the constructed fan is also a
limit.
-/
def extendFanIsLimit {n : ℕ} (f : Fin (n + 1) → C) {c₁ : Fan fun i : Fin n => f i.succ}
    {c₂ : BinaryFan (f 0) c₁.pt} (t₁ : IsLimit c₁) (t₂ : IsLimit c₂) : IsLimit (extendFan c₁ c₂)
    where
  lift s := by
    apply (binary_fan.is_limit.lift' t₂ (s.π.app ⟨0⟩) _).1
    apply t₁.lift ⟨_, discrete.nat_trans fun ⟨i⟩ => s.π.app ⟨i.succ⟩⟩
  fac := fun s ⟨j⟩ => by
    apply Fin.inductionOn j
    · apply (binary_fan.is_limit.lift' t₂ _ _).2.1
    · rintro i -
      dsimp only [extend_fan_π_app]
      rw [Fin.cases_succ, ← assoc, (binary_fan.is_limit.lift' t₂ _ _).2.2, t₁.fac]
      rfl
  uniq s m w := by
    apply binary_fan.is_limit.hom_ext t₂
    · rw [(binary_fan.is_limit.lift' t₂ _ _).2.1]
      apply w ⟨0⟩
    · rw [(binary_fan.is_limit.lift' t₂ _ _).2.2]
      apply t₁.uniq ⟨_, _⟩
      rintro ⟨j⟩
      rw [assoc]
      dsimp only [discrete.nat_trans_app, extend_fan_is_limit._match_1]
      rw [← w ⟨j.succ⟩]
      dsimp only [extend_fan_π_app]
      rw [Fin.cases_succ]
#align category_theory.extend_fan_is_limit CategoryTheory.extendFanIsLimit

section

variable [HasBinaryProducts C] [HasTerminal C]

/-- If `C` has a terminal object and binary products, then it has a product for objects indexed by
`fin n`.
This is a helper lemma for `has_finite_products_of_has_binary_and_terminal`, which is more general
than this.
-/
private theorem has_product_fin : ∀ (n : ℕ) (f : Fin n → C), HasProduct f
  | 0 => fun f =>
    by
    letI : has_limits_of_shape (discrete (Fin 0)) C :=
      has_limits_of_shape_of_equivalence (Discrete.equivalence.{0} fin_zero_equiv'.symm)
    infer_instance
  | n + 1 => fun f => by
    haveI := has_product_fin n
    apply has_limit.mk ⟨_, extend_fan_is_limit f (limit.is_limit _) (limit.is_limit _)⟩
#align category_theory.has_product_fin category_theory.has_product_fin

#print CategoryTheory.hasFiniteProducts_of_has_binary_and_terminal /-
/-- If `C` has a terminal object and binary products, then it has finite products. -/
theorem hasFiniteProducts_of_has_binary_and_terminal : HasFiniteProducts C :=
  by
  refine' ⟨fun n => ⟨fun K => _⟩⟩
  letI := has_product_fin n fun n => K.obj ⟨n⟩
  let this : (discrete.functor fun n => K.obj ⟨n⟩) ≅ K := discrete.nat_iso fun ⟨i⟩ => iso.refl _
  apply has_limit_of_iso this
#align category_theory.has_finite_products_of_has_binary_and_terminal CategoryTheory.hasFiniteProducts_of_has_binary_and_terminal
-/

end

section Preserves

variable (F : C ⥤ D)

variable [PreservesLimitsOfShape (Discrete WalkingPair) F]

variable [PreservesLimitsOfShape (Discrete.{0} PEmpty) F]

variable [HasFiniteProducts.{v} C]

/- warning: category_theory.preserves_fin_of_preserves_binary_and_terminal -> CategoryTheory.preservesFinOfPreservesBinaryAndTerminalₓ is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u3}} [_inst_2 : CategoryTheory.Category.{u1, u3} C] {D : Type.{u4}} [_inst_3 : CategoryTheory.Category.{u2, u4} D] (F : CategoryTheory.Functor.{u1, u2, u3, u4} C _inst_2 D _inst_3) [_inst_4 : CategoryTheory.Limits.PreservesLimitsOfShape.{0, 0, u1, u2, u3, u4} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.discreteCategory.{0} CategoryTheory.Limits.WalkingPair) F] [_inst_5 : CategoryTheory.Limits.PreservesLimitsOfShape.{0, 0, u1, u2, u3, u4} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} PEmpty.{1}) (CategoryTheory.discreteCategory.{0} PEmpty.{1}) F] [_inst_6 : CategoryTheory.Limits.HasFiniteProducts.{u1, u3} C _inst_2] (n : Nat) (f : (Fin n) -> C), CategoryTheory.Limits.PreservesLimit.{0, 0, u1, u2, u3, u4} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) (CategoryTheory.Discrete.functor.{u1, 0, u3} C _inst_2 (Fin n) f) F
but is expected to have type
  forall {C : Type.{u1}} [_inst_2 : CategoryTheory.Category.{u3, u1} C] {D : Type.{u2}} [_inst_3 : CategoryTheory.Category.{u4, u2} D] (F : CategoryTheory.Functor.{u3, u4, u1, u2} C _inst_2 D _inst_3) [_inst_4 : CategoryTheory.Limits.PreservesLimitsOfShape.{0, 0, u3, u4, u1, u2} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.discreteCategory.{0} CategoryTheory.Limits.WalkingPair) F] [_inst_5 : CategoryTheory.Limits.PreservesLimitsOfShape.{0, 0, u3, u4, u1, u2} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} PEmpty.{1}) (CategoryTheory.discreteCategory.{0} PEmpty.{1}) F] [_inst_6 : CategoryTheory.Limits.HasFiniteProducts.{u3, u1} C _inst_2] (n : Nat) (f : (Fin n) -> C), CategoryTheory.Limits.PreservesLimit.{0, 0, u3, u4, u1, u2} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) (CategoryTheory.Discrete.functor.{u3, 0, u1} C _inst_2 (Fin n) f) F
Case conversion may be inaccurate. Consider using '#align category_theory.preserves_fin_of_preserves_binary_and_terminal CategoryTheory.preservesFinOfPreservesBinaryAndTerminalₓₓ'. -/
/-- If `F` preserves the terminal object and binary products, then it preserves products indexed by
`fin n` for any `n`.
-/
noncomputable def preservesFinOfPreservesBinaryAndTerminal :
    ∀ (n : ℕ) (f : Fin n → C), PreservesLimit (Discrete.functor f) F
  | 0 => fun f =>
    by
    letI : preserves_limits_of_shape (discrete (Fin 0)) F :=
      preservesLimitsOfShapeOfEquiv.{0, 0} (discrete.equivalence fin_zero_equiv'.symm) _
    infer_instance
  | n + 1 => by
    haveI := preserves_fin_of_preserves_binary_and_terminal n
    intro f
    refine'
      preserves_limit_of_preserves_limit_cone
        (extend_fan_is_limit f (limit.is_limit _) (limit.is_limit _)) _
    apply (is_limit_map_cone_fan_mk_equiv _ _ _).symm _
    let this :=
      extend_fan_is_limit (fun i => F.obj (f i)) (is_limit_of_has_product_of_preserves_limit F _)
        (is_limit_of_has_binary_product_of_preserves_limit F _ _)
    refine' is_limit.of_iso_limit this _
    apply cones.ext _ _
    apply iso.refl _
    rintro ⟨j⟩
    apply Fin.inductionOn j
    · apply (category.id_comp _).symm
    · rintro i -
      dsimp only [extend_fan_π_app, iso.refl_hom, fan.mk_π_app]
      rw [Fin.cases_succ, Fin.cases_succ]
      change F.map _ ≫ _ = 𝟙 _ ≫ _
      rw [id_comp, ← F.map_comp]
      rfl
#align category_theory.preserves_fin_of_preserves_binary_and_terminal CategoryTheory.preservesFinOfPreservesBinaryAndTerminalₓ

#print CategoryTheory.preservesShapeFinOfPreservesBinaryAndTerminal /-
/-- If `F` preserves the terminal object and binary products, then it preserves limits of shape
`discrete (fin n)`.
-/
def preservesShapeFinOfPreservesBinaryAndTerminal (n : ℕ) :
    PreservesLimitsOfShape (Discrete (Fin n)) F
    where PreservesLimit K :=
    by
    let this : (discrete.functor fun n => K.obj ⟨n⟩) ≅ K := discrete.nat_iso fun ⟨i⟩ => iso.refl _
    haveI := preserves_fin_of_preserves_binary_and_terminal F n fun n => K.obj ⟨n⟩
    apply preserves_limit_of_iso_diagram F this
#align category_theory.preserves_shape_fin_of_preserves_binary_and_terminal CategoryTheory.preservesShapeFinOfPreservesBinaryAndTerminal
-/

#print CategoryTheory.preservesFiniteProductsOfPreservesBinaryAndTerminal /-
/-- If `F` preserves the terminal object and binary products then it preserves finite products. -/
def preservesFiniteProductsOfPreservesBinaryAndTerminal (J : Type) [Fintype J] :
    PreservesLimitsOfShape (Discrete J) F := by
  classical
    let e := Fintype.equivFin J
    haveI := preserves_shape_fin_of_preserves_binary_and_terminal F (Fintype.card J)
    apply preservesLimitsOfShapeOfEquiv.{0, 0} (discrete.equivalence e).symm
#align category_theory.preserves_finite_products_of_preserves_binary_and_terminal CategoryTheory.preservesFiniteProductsOfPreservesBinaryAndTerminal
-/

end Preserves

/- warning: category_theory.extend_cofan -> CategoryTheory.extendCofan is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u2}} [_inst_2 : CategoryTheory.Category.{u1, u2} C] {n : Nat} {f : (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) -> C} (c₁ : CategoryTheory.Limits.Cofan.{0, u1, u2} (Fin n) C _inst_2 (fun (i : Fin n) => f (Fin.succ n i))), (CategoryTheory.Limits.BinaryCofan.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (OfNat.mk.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (Zero.zero.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) (Fin.hasZeroOfNeZero (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne)) (NeZero.succ n)))))) (CategoryTheory.Limits.Cocone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)) -> (CategoryTheory.Limits.Cofan.{0, u1, u2} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) C _inst_2 f)
but is expected to have type
  forall {C : Type.{u2}} [_inst_2 : CategoryTheory.Category.{u1, u2} C] {n : Nat} {f : (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) -> C} (c₁ : CategoryTheory.Limits.Cofan.{0, u1, u2} (Fin n) C _inst_2 (fun (i : Fin n) => f (Fin.succ n i))), (CategoryTheory.Limits.BinaryCofan.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) 0 (Fin.instOfNatFin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) 0 (NeZero.succ n)))) (CategoryTheory.Limits.Cocone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)) -> (CategoryTheory.Limits.Cofan.{0, u1, u2} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) C _inst_2 f)
Case conversion may be inaccurate. Consider using '#align category_theory.extend_cofan CategoryTheory.extendCofanₓ'. -/
/-- Given `n+1` objects of `C`, a cofan for the last `n` with point `c₁.X`
and a binary cofan on `c₁.X` and `f 0`, we can build a cofan for all `n+1`.

In `extend_cofan_is_colimit` we show that if the two given cofans are colimits,
then this cofan is also a colimit.
-/
@[simps (config := { rhsMd := semireducible })]
def extendCofan {n : ℕ} {f : Fin (n + 1) → C} (c₁ : Cofan fun i : Fin n => f i.succ)
    (c₂ : BinaryCofan (f 0) c₁.pt) : Cofan f :=
  Cofan.mk c₂.pt
    (by
      refine' Fin.cases _ _
      · apply c₂.inl
      · intro i
        apply c₁.ι.app ⟨i⟩ ≫ c₂.inr)
#align category_theory.extend_cofan CategoryTheory.extendCofan

/- warning: category_theory.extend_cofan_is_colimit -> CategoryTheory.extendCofanIsColimit is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u2}} [_inst_2 : CategoryTheory.Category.{u1, u2} C] {n : Nat} (f : (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) -> C) {c₁ : CategoryTheory.Limits.Cofan.{0, u1, u2} (Fin n) C _inst_2 (fun (i : Fin n) => f (Fin.succ n i))} {c₂ : CategoryTheory.Limits.BinaryCofan.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (OfNat.mk.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (Zero.zero.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) (Fin.hasZeroOfNeZero (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne)) (NeZero.succ n)))))) (CategoryTheory.Limits.Cocone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)}, (CategoryTheory.Limits.IsColimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁) -> (CategoryTheory.Limits.IsColimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.discreteCategory.{0} CategoryTheory.Limits.WalkingPair) C _inst_2 (CategoryTheory.Limits.pair.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (OfNat.mk.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) 0 (Zero.zero.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne))) (Fin.hasZeroOfNeZero (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (One.one.{0} Nat Nat.hasOne)) (NeZero.succ n)))))) (CategoryTheory.Limits.Cocone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)) c₂) -> (CategoryTheory.Limits.IsColimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))))) (CategoryTheory.discreteCategory.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))))) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) f) (CategoryTheory.extendCofan.{u1, u2} C _inst_2 n f c₁ c₂))
but is expected to have type
  forall {C : Type.{u2}} [_inst_2 : CategoryTheory.Category.{u1, u2} C] {n : Nat} (f : (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) -> C) {c₁ : CategoryTheory.Limits.Cofan.{0, u1, u2} (Fin n) C _inst_2 (fun (i : Fin n) => f (Fin.succ n i))} {c₂ : CategoryTheory.Limits.BinaryCofan.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) 0 (Fin.instOfNatFin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) 0 (NeZero.succ n)))) (CategoryTheory.Limits.Cocone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)}, (CategoryTheory.Limits.IsColimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁) -> (CategoryTheory.Limits.IsColimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.discreteCategory.{0} CategoryTheory.Limits.WalkingPair) C _inst_2 (CategoryTheory.Limits.pair.{u1, u2} C _inst_2 (f (OfNat.ofNat.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) 0 (Fin.instOfNatFin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) 0 (NeZero.succ n)))) (CategoryTheory.Limits.Cocone.pt.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin n) (fun (i : Fin n) => f (Fin.succ n i))) c₁)) c₂) -> (CategoryTheory.Limits.IsColimit.{0, u1, 0, u2} (CategoryTheory.Discrete.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))))) (CategoryTheory.discreteCategory.{0} (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))))) C _inst_2 (CategoryTheory.Discrete.functor.{u1, 0, u2} C _inst_2 (Fin (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) f) (CategoryTheory.extendCofan.{u1, u2} C _inst_2 n f c₁ c₂))
Case conversion may be inaccurate. Consider using '#align category_theory.extend_cofan_is_colimit CategoryTheory.extendCofanIsColimitₓ'. -/
/-- Show that if the two given cofans in `extend_cofan` are colimits,
then the constructed cofan is also a colimit.
-/
def extendCofanIsColimit {n : ℕ} (f : Fin (n + 1) → C) {c₁ : Cofan fun i : Fin n => f i.succ}
    {c₂ : BinaryCofan (f 0) c₁.pt} (t₁ : IsColimit c₁) (t₂ : IsColimit c₂) :
    IsColimit (extendCofan c₁ c₂)
    where
  desc s := by
    apply (binary_cofan.is_colimit.desc' t₂ (s.ι.app ⟨0⟩) _).1
    apply t₁.desc ⟨_, discrete.nat_trans fun i => s.ι.app ⟨i.as.succ⟩⟩
  fac s := by
    rintro ⟨j⟩
    apply Fin.inductionOn j
    · apply (binary_cofan.is_colimit.desc' t₂ _ _).2.1
    · rintro i -
      dsimp only [extend_cofan_ι_app]
      rw [Fin.cases_succ, assoc, (binary_cofan.is_colimit.desc' t₂ _ _).2.2, t₁.fac]
      rfl
  uniq s m w := by
    apply binary_cofan.is_colimit.hom_ext t₂
    · rw [(binary_cofan.is_colimit.desc' t₂ _ _).2.1]
      apply w ⟨0⟩
    · rw [(binary_cofan.is_colimit.desc' t₂ _ _).2.2]
      apply t₁.uniq ⟨_, _⟩
      rintro ⟨j⟩
      dsimp only [discrete.nat_trans_app]
      rw [← w ⟨j.succ⟩]
      dsimp only [extend_cofan_ι_app]
      rw [Fin.cases_succ, assoc]
#align category_theory.extend_cofan_is_colimit CategoryTheory.extendCofanIsColimit

section

variable [HasBinaryCoproducts C] [HasInitial C]

/--
If `C` has an initial object and binary coproducts, then it has a coproduct for objects indexed by
`fin n`.
This is a helper lemma for `has_cofinite_products_of_has_binary_and_terminal`, which is more general
than this.
-/
private theorem has_coproduct_fin : ∀ (n : ℕ) (f : Fin n → C), HasCoproduct f
  | 0 => fun f =>
    by
    letI : has_colimits_of_shape (discrete (Fin 0)) C :=
      has_colimits_of_shape_of_equivalence (Discrete.equivalence.{0} fin_zero_equiv'.symm)
    infer_instance
  | n + 1 => fun f => by
    haveI := has_coproduct_fin n
    apply
      has_colimit.mk ⟨_, extend_cofan_is_colimit f (colimit.is_colimit _) (colimit.is_colimit _)⟩
#align category_theory.has_coproduct_fin category_theory.has_coproduct_fin

#print CategoryTheory.hasFiniteCoproducts_of_has_binary_and_initial /-
/-- If `C` has an initial object and binary coproducts, then it has finite coproducts. -/
theorem hasFiniteCoproducts_of_has_binary_and_initial : HasFiniteCoproducts C :=
  by
  refine' ⟨fun n => ⟨fun K => _⟩⟩
  letI := has_coproduct_fin n fun n => K.obj ⟨n⟩
  let this : K ≅ discrete.functor fun n => K.obj ⟨n⟩ := discrete.nat_iso fun ⟨i⟩ => iso.refl _
  apply has_colimit_of_iso this
#align category_theory.has_finite_coproducts_of_has_binary_and_initial CategoryTheory.hasFiniteCoproducts_of_has_binary_and_initial
-/

end

section Preserves

variable (F : C ⥤ D)

variable [PreservesColimitsOfShape (Discrete WalkingPair) F]

variable [PreservesColimitsOfShape (Discrete.{0} PEmpty) F]

variable [HasFiniteCoproducts.{v} C]

/- warning: category_theory.preserves_fin_of_preserves_binary_and_initial -> CategoryTheory.preservesFinOfPreservesBinaryAndInitialₓ is a dubious translation:
lean 3 declaration is
  forall {C : Type.{u3}} [_inst_2 : CategoryTheory.Category.{u1, u3} C] {D : Type.{u4}} [_inst_3 : CategoryTheory.Category.{u2, u4} D] (F : CategoryTheory.Functor.{u1, u2, u3, u4} C _inst_2 D _inst_3) [_inst_4 : CategoryTheory.Limits.PreservesColimitsOfShape.{0, 0, u1, u2, u3, u4} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.discreteCategory.{0} CategoryTheory.Limits.WalkingPair) F] [_inst_5 : CategoryTheory.Limits.PreservesColimitsOfShape.{0, 0, u1, u2, u3, u4} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} PEmpty.{1}) (CategoryTheory.discreteCategory.{0} PEmpty.{1}) F] [_inst_6 : CategoryTheory.Limits.HasFiniteCoproducts.{u1, u3} C _inst_2] (n : Nat) (f : (Fin n) -> C), CategoryTheory.Limits.PreservesColimit.{0, 0, u1, u2, u3, u4} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) (CategoryTheory.Discrete.functor.{u1, 0, u3} C _inst_2 (Fin n) f) F
but is expected to have type
  forall {C : Type.{u1}} [_inst_2 : CategoryTheory.Category.{u3, u1} C] {D : Type.{u2}} [_inst_3 : CategoryTheory.Category.{u4, u2} D] (F : CategoryTheory.Functor.{u3, u4, u1, u2} C _inst_2 D _inst_3) [_inst_4 : CategoryTheory.Limits.PreservesColimitsOfShape.{0, 0, u3, u4, u1, u2} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} CategoryTheory.Limits.WalkingPair) (CategoryTheory.discreteCategory.{0} CategoryTheory.Limits.WalkingPair) F] [_inst_5 : CategoryTheory.Limits.PreservesColimitsOfShape.{0, 0, u3, u4, u1, u2} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} PEmpty.{1}) (CategoryTheory.discreteCategory.{0} PEmpty.{1}) F] [_inst_6 : CategoryTheory.Limits.HasFiniteCoproducts.{u3, u1} C _inst_2] (n : Nat) (f : (Fin n) -> C), CategoryTheory.Limits.PreservesColimit.{0, 0, u3, u4, u1, u2} C _inst_2 D _inst_3 (CategoryTheory.Discrete.{0} (Fin n)) (CategoryTheory.discreteCategory.{0} (Fin n)) (CategoryTheory.Discrete.functor.{u3, 0, u1} C _inst_2 (Fin n) f) F
Case conversion may be inaccurate. Consider using '#align category_theory.preserves_fin_of_preserves_binary_and_initial CategoryTheory.preservesFinOfPreservesBinaryAndInitialₓₓ'. -/
/-- If `F` preserves the initial object and binary coproducts, then it preserves products indexed by
`fin n` for any `n`.
-/
noncomputable def preservesFinOfPreservesBinaryAndInitial :
    ∀ (n : ℕ) (f : Fin n → C), PreservesColimit (Discrete.functor f) F
  | 0 => fun f =>
    by
    letI : preserves_colimits_of_shape (discrete (Fin 0)) F :=
      preservesColimitsOfShapeOfEquiv.{0, 0} (discrete.equivalence fin_zero_equiv'.symm) _
    infer_instance
  | n + 1 => by
    haveI := preserves_fin_of_preserves_binary_and_initial n
    intro f
    refine'
      preserves_colimit_of_preserves_colimit_cocone
        (extend_cofan_is_colimit f (colimit.is_colimit _) (colimit.is_colimit _)) _
    apply (is_colimit_map_cocone_cofan_mk_equiv _ _ _).symm _
    let this :=
      extend_cofan_is_colimit (fun i => F.obj (f i))
        (is_colimit_of_has_coproduct_of_preserves_colimit F _)
        (is_colimit_of_has_binary_coproduct_of_preserves_colimit F _ _)
    refine' is_colimit.of_iso_colimit this _
    apply cocones.ext _ _
    apply iso.refl _
    rintro ⟨j⟩
    apply Fin.inductionOn j
    · apply category.comp_id
    · rintro i -
      dsimp only [extend_cofan_ι_app, iso.refl_hom, cofan.mk_ι_app]
      rw [Fin.cases_succ, Fin.cases_succ]
      erw [comp_id, ← F.map_comp]
      rfl
#align category_theory.preserves_fin_of_preserves_binary_and_initial CategoryTheory.preservesFinOfPreservesBinaryAndInitialₓ

#print CategoryTheory.preservesShapeFinOfPreservesBinaryAndInitial /-
/-- If `F` preserves the initial object and binary coproducts, then it preserves colimits of shape
`discrete (fin n)`.
-/
def preservesShapeFinOfPreservesBinaryAndInitial (n : ℕ) :
    PreservesColimitsOfShape (Discrete (Fin n)) F
    where PreservesColimit K :=
    by
    let this : (discrete.functor fun n => K.obj ⟨n⟩) ≅ K := discrete.nat_iso fun ⟨i⟩ => iso.refl _
    haveI := preserves_fin_of_preserves_binary_and_initial F n fun n => K.obj ⟨n⟩
    apply preserves_colimit_of_iso_diagram F this
#align category_theory.preserves_shape_fin_of_preserves_binary_and_initial CategoryTheory.preservesShapeFinOfPreservesBinaryAndInitial
-/

#print CategoryTheory.preservesFiniteCoproductsOfPreservesBinaryAndInitial /-
/-- If `F` preserves the initial object and binary coproducts then it preserves finite products. -/
def preservesFiniteCoproductsOfPreservesBinaryAndInitial (J : Type) [Fintype J] :
    PreservesColimitsOfShape (Discrete J) F := by
  classical
    let e := Fintype.equivFin J
    haveI := preserves_shape_fin_of_preserves_binary_and_initial F (Fintype.card J)
    apply preservesColimitsOfShapeOfEquiv.{0, 0} (discrete.equivalence e).symm
#align category_theory.preserves_finite_coproducts_of_preserves_binary_and_initial CategoryTheory.preservesFiniteCoproductsOfPreservesBinaryAndInitial
-/

end Preserves

end CategoryTheory