import .sterm .pterm

namespace list

theorem subset_union_left {α : Type*} [decidable_eq α]
  {l1 l2 : list α} : l1 ⊆ l1 ∪ l2 :=
by {intros a ha, apply list.mem_union_left, exact ha}

end list

namespace polya.field

inductive alt (γ) [const_space γ] : bool → Type
| sform : list (nterm γ) → sterm γ → alt tt
| pform : list (nterm γ) → pterm γ → alt ff

namespace alt
open nterm

variables {α : Type} [discrete_field α]
variables {γ : Type} [const_space γ]
variables [morph γ α] {ρ : dict α}

def of_const (a : γ) : Π {b}, alt γ b
| tt := sform [] (sterm.of_const a)
| ff := pform [] (pterm.of_const a)

def singleton (x : nterm γ) : Π {b}, alt γ b
| tt := sform ∅ (sterm.singleton x)
| ff := pform ∅ (pterm.singleton x)

def to_nterm : alt γ tt → nterm γ
| (sform _ S) := S.to_nterm

def to_sterm : alt γ tt → sterm γ
| (sform _ S) := S

def to_pterm : alt γ ff → pterm γ
| (pform _ P) := P

def hyps : Π {b}, alt γ b → list (nterm γ)
| ._ (sform ts _) := ts
| ._ (pform ts _) := ts

def eval (ρ : dict α) : Π {b}, alt γ b → α
| ._ (sform _ S) := sterm.eval ρ S
| ._ (pform _ P) := pterm.eval ρ P

def to_sform : Π {b}, alt γ b → alt γ tt
| ._ (sform ts S) := sform ts S
| ._ (pform ts P) := sform (ts ∪ P.reduce_hyps) (sterm.of_nterm P.reduce.to_nterm)

def to_pform : Π {b}, alt γ b → alt γ ff
| ._ (sform ts S) := pform ts (pterm.of_nterm S.to_nterm)
| ._ (pform ts P) := pform ts P

def hyps_to_sform {a} {x : alt γ a} :
  x.hyps ⊆ x.to_sform.hyps :=
begin
  cases x,
  { simp [to_sform] },
  { unfold to_sform, unfold hyps, exact list.subset_union_left }
end

def hyps_to_pform {a} {x : alt γ a} :
  x.hyps = x.to_pform.hyps :=
by cases x; simp [hyps, to_pform]

theorem eval_def {x : alt γ tt} :
  eval ρ x = nterm.eval ρ x.to_nterm :=
by {cases x, simp [eval, to_nterm, sterm.eval_to_nterm]}

theorem eval_of_const {b} {c : γ} :
  eval ρ (of_const c : alt γ b) = (c : α) :=
by cases b; simp [of_const, eval, pterm.eval_of_const, sterm.eval_of_const]

theorem eval_singleton {b} {x : nterm γ} :
  eval ρ (singleton x : alt γ b) = nterm.eval ρ x :=
begin
  cases b,
  { unfold singleton, unfold eval,
    rw ← pterm.eval_singleton },
  { unfold singleton, unfold eval,
    rw ← sterm.eval_singleton }
end

theorem eval_to_sform {b} {x : alt γ b} :
  nonzero ρ x.to_sform.hyps →
  eval ρ x.to_sform = eval ρ x :=
begin
  intro H, cases x,
  { refl },
  { unfold to_sform, unfold eval,
    rw [sterm.eval_of_nterm, ← pterm.eval_to_nterm],
    rw ← pterm.eval_reduce,
    intros t ht, apply H,
    unfold to_sform, unfold hyps,
    apply list.mem_union_right,
    exact ht }
end

theorem eval_to_pform {b} {x : alt γ b} :
  eval ρ x.to_pform = eval ρ x :=
begin
  cases x,
  { unfold to_pform, unfold eval,
    rw [pterm.eval_of_nterm, ← sterm.eval_to_nterm] },
  { refl }
end

theorem eval_to_sterm {x : alt γ tt} :
  sterm.eval ρ x.to_sterm = eval ρ x :=
begin
  cases x, unfold to_sterm, unfold eval
end

theorem eval_to_pterm {x : alt γ ff} :
  eval ρ x = pterm.eval ρ x.to_pterm :=
begin
  cases x, unfold to_pterm, unfold eval
end

--TODO:
--more cases to avoid switching form too often
--when applying operators

def add_sform (x y : alt γ tt) : alt γ tt :=
sform (x.hyps ∪ y.hyps) (x.to_sterm + y.to_sterm)

def mul_pform (x y : alt γ ff) : alt γ ff :=
pform (x.hyps ∪ y.hyps) (x.to_pterm * y.to_pterm)

def pow_pform (x : alt γ ff) (n : znum) : alt γ ff :=
if n = 0 then singleton (1 : γ)
else pform x.hyps (x.to_pterm ^ n)

instance : has_add (alt γ tt) := ⟨add_sform⟩
instance : has_mul (alt γ ff) := ⟨mul_pform⟩
instance : has_pow (alt γ ff) znum := ⟨pow_pform⟩

def add {a b} (x : alt γ a) (y : alt γ b) : alt γ tt :=
x.to_sform + y.to_sform

def mul {a b} (x : alt γ a) (y : alt γ b) : alt γ ff :=
x.to_pform * y.to_pform

def pow {a} (x : alt γ a) (n : znum) : alt γ ff :=
x.to_pform ^ n

theorem hyps_singleton {b} {x : nterm γ} :
  (singleton x : alt γ b).hyps = ∅ :=
by cases b; simp [singleton, hyps]

theorem hyps_add_sform {x y : alt γ tt} :
  (x + y).hyps = x.hyps ∪ y.hyps :=
by simp [has_add.add, add_sform, hyps]

theorem hyps_mul_pform {x y : alt γ ff} :
  (x * y).hyps = x.hyps ∪ y.hyps :=
by simp [has_mul.mul, mul_pform, hyps]

theorem hyps_pow_pform {x : alt γ ff} {n : znum} :
  (x ^ n).hyps = if n = 0 then ∅ else x.hyps :=
begin
  by_cases h0 : n = 0;
  by_cases h1 : n = 1;
  simp [has_pow.pow, pow_pform, h0, h1, hyps, hyps_singleton]
end

theorem hyps_add {a b} {x : alt γ a} {y : alt γ b} :
  hyps (add x y) = hyps x.to_sform ∪ hyps y.to_sform :=
by cases x; cases y; simp [add, to_sform, hyps_add_sform]

theorem hyps_mul {a b} {x : alt γ a} {y : alt γ b} :
  hyps (mul x y) = hyps x.to_pform ∪ hyps y.to_pform :=
by cases x; cases y; simp [mul, to_pform, hyps_mul_pform]

theorem hyps_pow {a} {x : alt γ a} {n : znum} :
  hyps (pow x n) = if n = 0 then ∅ else hyps x.to_pform :=
by simp [pow, hyps, hyps_pow_pform]

theorem eval_add_sform {x y : alt γ tt} :
  eval ρ (x + y) = eval ρ x + eval ρ y :=
begin
  suffices : eval ρ (add_sform x y) = eval ρ x + eval ρ y,
  by exact this,
  cases x, cases y,
  unfold add_sform, unfold to_sterm, unfold eval,
  apply sterm.eval_add
end

theorem eval_add {a b} {x : alt γ a} {y : alt γ b} :
  nonzero ρ (hyps (add x y)) →
  eval ρ (add x y) = eval ρ x + eval ρ y :=
begin
  intro H, rw [hyps_add, nonzero_union] at H,
  cases H with H1 H2,
  unfold add, rw [eval_add_sform, eval_to_sform, eval_to_sform],
  { exact H2 },
  { exact H1 }
end

theorem eval_mul_pform {x y : alt γ ff} :
  eval ρ (x * y) = eval ρ x * eval ρ y :=
begin
  suffices : eval ρ (mul_pform x y) = eval ρ x * eval ρ y,
  by exact this,
  cases x, cases y,
  unfold mul_pform, unfold to_pterm, unfold eval,
  apply pterm.eval_mul
end

theorem eval_mul {a b} {x : alt γ a} {y : alt γ b} :
  eval ρ (mul x y) = eval ρ x * eval ρ y :=
begin
  unfold mul, rw [eval_mul_pform, eval_to_pform, eval_to_pform]
end

theorem eval_pow_pform {x : alt γ ff} {n : znum} :
  eval ρ (x ^ n) = eval ρ x ^ (n : ℤ) :=
begin
  suffices : eval ρ (pow_pform x n) = eval ρ x ^ (n : ℤ),
  by exact this,
  cases x,
  unfold pow_pform, unfold to_pterm,
  by_cases hn : n = 0,
  { rw if_pos hn, unfold eval, simp [hn, eval_singleton] },
  { rw if_neg hn, unfold eval, apply pterm.eval_pow }
end

theorem eval_pow {a} {x : alt γ a} {n : znum} :
  eval ρ (pow x n) = eval ρ x ^ (n : ℤ) :=
begin
  unfold pow, rw [eval_pow_pform, eval_to_pform]
end

@[reducible]
def aux_of_nterm : nterm γ → bool
| (nterm.add _ _) := tt
| (nterm.mul _ _) := ff
| (nterm.pow _ _) := ff
| _ := tt

def of_nterm : Π (x : nterm γ), alt γ (aux_of_nterm x)
| (nterm.add x y) := add (of_nterm x) (of_nterm y)
| (nterm.mul x y) := mul (of_nterm x) (of_nterm y)
| (nterm.pow x n) := pow (of_nterm x) n
| (nterm.const a) := of_const a
| (nterm.atom i)  := singleton i

theorem eval_of_nterm {x : nterm γ} :
  nonzero ρ (of_nterm x).hyps →
  eval ρ (of_nterm x) = nterm.eval ρ x :=
begin
  induction x with i c x y ihx ihy x y ihx ihy x n ihx,
  { intro, unfold of_nterm, rw eval_singleton, refl },
  { intro, unfold of_nterm, rw eval_of_const, simp [nterm.eval] },
  { unfold of_nterm, intro H,
    rw [hyps_add,  nonzero_union] at H,
    rw [eval_add, ihx, ihy],
    { exact nterm.eval_add },
    { apply nonzero_subset (hyps_to_sform), exact H.right},
    { apply nonzero_subset (hyps_to_sform), exact H.left },
    { rw [hyps_add, nonzero_union], exact H }},
  { unfold of_nterm, intro H,
    rw [hyps_mul,  nonzero_union] at H,
    rw [eval_mul, ihx, ihy],
    { exact nterm.eval_mul },
    { rw hyps_to_pform, exact H.right },
    { rw hyps_to_pform, exact H.left }},
  { unfold of_nterm, intro H,
    by_cases hn : n = 0,
    { rw [eval_pow, hn, znum.cast_zero, fpow_zero],
      suffices : nterm.eval ρ (x ^ (0 : znum)) = 1,
      by exact this,
      rw [nterm.eval_pow, znum.cast_zero, fpow_zero] },
    { rw [hyps_pow, if_neg hn] at H,
      rw [eval_pow, ihx],
      { exact nterm.eval_pow },
      { rw hyps_to_pform, exact H }}}
end

end alt

namespace nterm

variables {α : Type} [discrete_field α]
variables {γ : Type} [const_space γ]
variables [morph γ α] {ρ : dict α}

def norm (x : nterm γ) : nterm γ :=
(alt.of_nterm x).to_sform.to_nterm

def norm_hyps (x : nterm γ) : list (nterm γ) :=
(alt.of_nterm x).to_sform.hyps

def correctness {x : nterm γ} :
  nonzero ρ (norm_hyps x) →
  nterm.eval ρ (norm x) = nterm.eval ρ x :=
begin
  intro H, unfold norm,
  rw [← alt.eval_def, ← alt.eval_of_nterm, alt.eval_to_sform],
  { intros t ht, apply H, exact ht },
  { intros t ht, apply H, apply alt.hyps_to_sform, exact ht }
end

--section soundness
--variables {x y : nterm γ} {i : num} {n : znum} {c : γ}
--
--theorem sound_atom : @norm γ _ i = i :=
--begin
--  sorry
--end
--
--theorem sound_const : @norm γ _ c = c :=
--begin
--  sorry
--end
--
--theorem sound_add :
--  norm (x + y) = (sterm.of_nterm x.norm
--    + sterm.of_nterm y.norm).to_nterm :=
--begin
--  sorry
--end
--
--theorem sound_mul :
--  norm (x * y) = (pterm.of_nterm x.norm
--    * pterm.of_nterm y.norm).reduce.to_nterm :=
--begin
--  sorry
--end
--
--theorem sound_pow :
--  norm (x ^ n) = (pterm.of_nterm x.norm ^ n).reduce.to_nterm :=
--begin
--  sorry
--end
--
--def naive_norm : nterm γ → nterm γ
--| (add x y) := (sterm.of_nterm (naive_norm x) + sterm.of_nterm (naive_norm y)).to_nterm
--| (mul x y) := (pterm.of_nterm (naive_norm x) * pterm.of_nterm (naive_norm y)).reduce.to_nterm
--| (pow x n) := (pterm.of_nterm (naive_norm x) ^ n).reduce.to_nterm
--| x := x
--
--theorem soundness {x : nterm γ} :
--  norm x = naive_norm x :=
--begin
--  sorry
--  --TODO: this theorem is not required,
--  --but it could be an interesting
--  --first step to prove soundness
--end
--
--end soundness

end nterm

end polya.field


/-! Specialization library.

-/

namespace Spe

open Except (ok error)

/-- Can check an `α`-value. -/
structure Check (ε α : Type u) : Type u where
  /-- Okay if legit, error otherwise. -/
  check : α → Except ε Unit

/-- Proposition corresponding to [`Check.check`] being `ok ()`. -/
@[simp]
def Check.isLegit
  (self : Check ε α)
  (val : α)
: Prop :=
  self.check val = ok ()

/-- [`Check.isLegit`] is decidable. -/
instance instDecIsLegit
  {self : Check ε α}
  {val : α}
: Decidable (self.isLegit val) :=
  match legit? : self.check val with
  | ok () => isTrue legit?
  | error _ => isFalse (
    by
      simp
      intro h
      rw [legit?] at h
      contradiction
  )

/-- [`Check`] coerces to function [`Check.isLegit`]. -/
instance instCoeFunCheck
: CoeFun (Check ε α) (fun _ => α → Prop) where
  coe self :=
    self.isLegit

/-- Wraps an `α`, the [`Check`] function, and a proof of legitimacy. -/
structure Legit (ε α : Type u) where
private mk ::
  val : α
  check : Check ε α
  legit : check val

/-- [`Legit`] coerces to [`Legit.val`]. -/
instance instCoeLegit : Coe (Legit ε α) α where
  coe self :=
    self.val

section
  variable
    {ε α : Type u}

  /-- Tries to build a legitimate `α`. -/
  def Legit.mk?
    (check : Check ε α)
    (val : α)
  : Except ε <| Legit ε α :=
    match legit : check.check val with
    | ok () => ok ⟨val, check, legit⟩
    | error e => error e

  /-- Alias for [`Legit.mk?`] -/
  abbrev Check.validate? :=
    @Legit.mk?

  /-- Builds the [`Check`] corresponding to being a member of a list of values. -/
  def Check.ofList
    [DecidableEq α]
    (set : List α)
    (err : (a : α) → a ∉ set → ε)
  : Check ε α where
    check val :=
      if mem? : val ∈ set
      then ok ()
      else error <| err val mem?

  /-- Proof that legit value cannot be `val` if `val` is not legit. -/
  theorem Legit.absurd
    (self : Legit ε α)
    (val : α)
    (illegit : ¬(self.check val) := by dsimp)
  : self.val ≠ val :=
    by
      intro h
      rw [←h] at illegit
      apply illegit self.legit
end

namespace Demo

  inductive Test
  | Var1
  | Var2
  | Var3
  deriving BEq, DecidableEq, Hashable, Repr

  instance instToStringTest : ToString Test where
    toString
    | .Var1 => "Var1"
    | .Var2 => "Var2"
    | .Var3 => "Var3"

  def list12 : List Test :=
    [Test.Var1, Test.Var2]

  def errMsg (l : List Test) (a : Test) (_ : a ∉ l) : String :=
    s! "value `{a}` is not a member of [{pretty}]"
  where
    pretty :=
      "" |> l.foldl
        fun (s : String) (val : Test) => -- fold
          if s.isEmpty then toString val
          else s ++ ", " ++ (toString val)

  def not3 : Check String Test :=
    Check.ofList list12 (errMsg list12)

  #eval (
    match not3.validate? Test.Var1 with
    | .ok legit => "ok " ++ toString legit.val
    | .error msg => "error: " ++ msg
  )
  #eval (
    match not3.validate? Test.Var2 with
    | .ok legit => "ok " ++ toString legit.val
    | .error msg => "error: " ++ msg
  )
  #eval (
    match not3.validate? Test.Var3 with
    | .ok legit => "ok " ++ toString legit.val
    | .error msg => "error: " ++ msg
  )

end Demo


-- WIP Trying to proove addBoth.sub, addBoth.sup
-- Is it really necessary to import BEq and have beq_eq_eq?

-- Tested with:
-- leanprover/lean4:nightly unchanged - Lean (version 4.0.0-nightly-2023-01-28, commit e37f209c1a2a, Release)

import Std.Data.AssocList
import Std.Data.List.Lemmas
import Std.Classes.BEq

namespace MWE8

theorem cond_eq_ite (c : Bool) (a b : α) : cond c a b = if c then a else b := by cases c <;> rfl

theorem cond_decide {α} (p : Prop) [Decidable p] (t e : α) : cond (decide p) t e = if p then t else e := by
  by_cases p <;> simp [*]

-- https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/Problems.20simplifying.20.20conditions.20with.20hypotheses/near/324212540
@[simp] theorem beq_eq_eq [DecidableEq α] (x y : α) :
  (x == y) = decide (x = y) := rfl

abbrev Strings := List String

instance : Repr (Std.AssocList String Strings) where reprPrec s n := s.toList.repr n

def addDecl (s: Std.AssocList String Strings) (d: String) : Std.AssocList String Strings :=
match s.contains d with
| true => s
| false => .cons d [] s

theorem addDecl.added (s: Std.AssocList String Strings) (d: String): (addDecl s d).contains d
:= by
  simp [addDecl]
  split <;> simp
  next x heq => simp_all

theorem addDecl.cons (s: Std.AssocList String Strings) (d: String): (addDecl s d).isEmpty = false
:= by
  simp [addDecl]
  split <;> simp [List.isEmpty]
  . case h_1 x heq =>
    split <;> simp_all

theorem addDecl.after (s: Std.AssocList String Strings) (x y: String): s.contains x → (addDecl s y).contains x
:= by
  intro h
  simp [Std.AssocList.contains, addDecl] at h ⊢
  apply Exists.elim h
  split <;> simp_all
  done

def addSubSup: String → String → Std.AssocList String Strings → Std.AssocList String Strings
| sub, sup, .nil            => .cons sub [sup] .nil
| sub, sup, .cons a as tail => bif a = sub then .cons sub (as.insert sup) tail else .cons a as (addSubSup sub sup tail)

theorem addSubSup.sub (sub sup: String) (ss: Std.AssocList String Strings): (addSubSup sub sup ss).contains sub
:= by
  induction ss <;> simp_all
  . case cons key value tail tail_ih =>
    simp [addSubSup, cond_eq_ite]
    by_cases key = sub
    . case pos h =>
      simp [h]
    . case neg h =>
      simp [h]
      apply tail_ih

def addBoth (sub sup: String) (ss: Std.AssocList String Strings) : Std.AssocList String Strings :=
  let ss' := addDecl ss sup
  addSubSup sub sup ss'

theorem addBoth.sub_eq (sub sup: String) (ss: Std.AssocList String Strings)
: (addBoth sub sup ss).contains sub
:= by
  induction ss <;> simp_all
  . case nil =>
    simp [addBoth, addDecl, addSubSup, cond_eq_ite]
    split <;> simp_all
  . case cons key value tail tail_ih =>
    simp [addBoth, addDecl]
    by_cases key = sup <;> simp [*]
    . case pos =>
      simp [addSubSup, cond_eq_ite]
      by_cases sup = sub <;> simp [*]
      . case neg h =>
        simp [addBoth, addDecl] at tail_ih
        split at tail_ih
        . case h_1 =>
          by_cases key = sub <;> simp [*]
        . case h_2 x heq =>
          by_cases key = sub <;> simp_all
          simp [addSubSup, cond_eq_ite, h] at tail_ih
          apply tail_ih
    . case neg h =>
      split <;> simp_all
      . case h_1 x heq =>
        -- Given the tactic state:
        -- subsupkey: String
        -- value: Strings
        -- tail: Std.AssocList String Strings
        -- x: Bool
        -- tail_ih: ∃ x, x ∈ Std.AssocList.toList (addBoth sub sup tail) ∧ x.fst = sub
        -- h: ¬key = sup
        -- heq: ∃ x, x ∈ Std.AssocList.toList tail ∧ x.fst = sup

        -- How to prove?
        -- ⊢ ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons key value tail)) ∧ x.fst = sub
        sorry

      . case h_2 x heq =>
        -- Given the tactic state:
        -- subsupkey: String
        -- value: Strings
        -- tail: Std.AssocList String Strings
        -- x: Bool
        -- tail_ih: ∃ x, x ∈ Std.AssocList.toList (addBoth sub sup tail) ∧ x.fst = sub
        -- h: ¬key = sup
        -- heq: (List.any (Std.AssocList.toList tail) fun x => decide (x.fst = sup)) = false

        -- How to prove?
        -- ⊢ ∃ x,
        --   x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons sup [] (Std.AssocList.cons key value tail))) ∧
        --     x.fst = sub
        sorry

theorem addBoth.sub_beq (sub sup: String) (ss: Std.AssocList String Strings)
: (addBoth sub sup ss).contains sub
:= by
  induction ss <;> simp_all
  . case nil =>
    simp [addBoth, addDecl, addSubSup, cond_eq_ite]
    split <;> simp_all
  . case cons key value tail tail_ih =>
    simp [addBoth, addDecl]
    by_cases key == sup <;> simp_all
    . case pos =>
      simp [addSubSup, cond_eq_ite]
      by_cases sup == sub <;> simp [*]
      . case pos =>
        simp_all
      . case neg h =>
        simp [addBoth, addDecl] at tail_ih
        split at tail_ih
        . case h_1 =>
          by_cases key == sub <;> simp_all
        . case h_2 x heq =>
          by_cases key == sub <;> simp_all
          simp [addSubSup, cond_eq_ite, h] at tail_ih
          apply tail_ih
    . case neg h =>
      split <;> simp_all
      . case h_1 x heq =>
        -- Given the tactic state: (same as addBoth.sub_eq: path cons/neg/h_1)
        -- subsupkey: String
        -- value: Strings
        -- tail: Std.AssocList String Strings
        -- x: Bool
        -- tail_ih: ∃ x, x ∈ Std.AssocList.toList (addBoth sub sup tail) ∧ x.fst = sub
        -- h: ¬key = sup
        -- heq: ∃ x, x ∈ Std.AssocList.toList tail ∧ x.fst = sup

        -- How to prove?
        -- ⊢ ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons key value tail)) ∧ x.fst = sub
        sorry

      . case h_2 x heq =>
        -- Given the tactic state: (same as addBoth.sub_eq: path cons/neg/h_2)
        -- subsupkey: String
        -- value: Strings
        -- tail: Std.AssocList String Strings
        -- x: Bool
        -- tail_ih: ∃ x, x ∈ Std.AssocList.toList (addBoth sub sup tail) ∧ x.fst = sub
        -- h: ¬key = sup
        -- heq: (List.any (Std.AssocList.toList tail) fun x => decide (x.fst = sup)) = false

        -- How to prove?
        -- ⊢ ∃ x,
        --   x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons sup [] (Std.AssocList.cons key value tail))) ∧
        --     x.fst = sub
        sorry

theorem addBoth.sup_eq (sub sup: String) (ss: Std.AssocList String Strings)
: (addBoth sub sup ss).contains sup
:= by
  simp [addBoth]
  simp [addDecl]
  induction ss <;> simp [*]
  . case nil =>
    simp [addSubSup, cond_eq_ite]
    by_cases sup = sub <;> simp [*]
  . case cons key value tail tail_ih =>
    simp [addDecl, cond_eq_ite]
    by_cases key = sup <;> simp [*]
    . case pos h1 =>
      simp [addSubSup, cond_eq_ite] at tail_ih ⊢
      by_cases sup = sub <;> simp [*]
    . case neg h1 =>
      let ⟨ x, hx, he ⟩ := tail_ih
      split <;> simp_all
      . case h_1 y heq =>
        -- Given the tactic state:
        -- subsupkey: String
        -- value: Strings
        -- tail: Std.AssocList String Strings
        -- x: String × Strings
        -- y: Bool
        -- tail_ih: ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup tail) ∧ x.fst = sup
        -- h1: ¬key = sup
        -- hx: x ∈ Std.AssocList.toList (addSubSup sub sup tail)
        -- he: x.fst = sup
        -- heq: ∃ x, x ∈ Std.AssocList.toList tail ∧ x.fst = sup

        -- How to prove?
        -- ⊢ ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons key value tail)) ∧ x.fst = sup
        sorry

      . case h_2 y heq =>
        -- Given the tactic state:
        -- subsupkey: String
        -- value: Strings
        -- tail: Std.AssocList String Strings
        -- x: String × Strings
        -- y: Bool
        -- tail_ih: ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons sup [] tail)) ∧ x.fst = sup
        -- h1: ¬key = sup
        -- hx: x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons sup [] tail))
        -- he: x.fst = sup
        -- heq: (List.any (Std.AssocList.toList tail) fun x => decide (x.fst = sup)) = false

        -- How to prove?
        -- ⊢ ∃ x,
        --   x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons sup [] (Std.AssocList.cons key value tail))) ∧
        --     x.fst = sup
        sorry

theorem addBoth.sup_beq (sub sup: String) (ss: Std.AssocList String Strings)
: (addBoth sub sup ss).contains sup
:= by
  simp [addBoth]
  simp [addDecl]
  induction ss <;> simp_all
  . case nil =>
    simp [addSubSup, cond_eq_ite]
    by_cases sup == sub <;> simp_all
  . case cons key value tail tail_ih =>
    simp [addDecl, cond_eq_ite]
    by_cases key == sup <;> simp_all
    . case pos h1 =>
      simp [addSubSup, cond_eq_ite]
      by_cases sup == sub <;> simp_all
    . case neg h1 =>
      let ⟨ x, hx, he ⟩ := tail_ih
      split <;> simp_all
      . case h_1 y heq =>
        -- Given the tactic state (same as addBoth.sup_eq: path cons/neg/h1)
        -- subsupkey: String
        -- value: Strings
        -- tail: Std.AssocList String Strings
        -- x: String × Strings
        -- y: Bool
        -- tail_ih: ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup tail) ∧ x.fst = sup
        -- h1: ¬key = sup
        -- hx: x ∈ Std.AssocList.toList (addSubSup sub sup tail)
        -- he: x.fst = sup
        -- heq: ∃ x, x ∈ Std.AssocList.toList tail ∧ x.fst = sup

        -- How to prove?
        -- ⊢ ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons key value tail)) ∧ x.fst = sup
        sorry

      . case h_2 y heq =>
        -- Given the tactic state: (same as addBoth.sup_eq: path cons/neg/h2)
        -- subsupkey: String
        -- value: Strings
        -- tail: Std.AssocList String Strings
        -- x: String × Strings
        -- y: Bool
        -- tail_ih: ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons sup [] tail)) ∧ x.fst = sup
        -- h1: ¬key = sup
        -- hx: x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons sup [] tail))
        -- he: x.fst = sup
        -- heq: (List.any (Std.AssocList.toList tail) fun x => decide (x.fst = sup)) = false

        -- How to prove?
        -- ⊢ ∃ x,
        --   x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons sup [] (Std.AssocList.cons key value tail))) ∧
        --     x.fst = sup
        sorry

end MWE8


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Adam Topaz
-/
import category_theory.limits.preserves.basic
import category_theory.limits.types
import category_theory.limits.shapes.wide_pullbacks
import category_theory.limits.shapes.multiequalizer
import category_theory.concrete_category.elementwise

/-!
# Facts about (co)limits of functors into concrete categories
-/

universes w v u

open category_theory

namespace category_theory.limits

local attribute [instance] concrete_category.has_coe_to_fun concrete_category.has_coe_to_sort

section limits

variables {C : Type u} [category.{v} C] [concrete_category.{(max w v)} C]
  {J : Type w} [small_category J] (F : J ⥤ C) [preserves_limit F (forget C)]

lemma concrete.to_product_injective_of_is_limit {D : cone F} (hD : is_limit D) :
  function.injective (λ (x : D.X) (j : J), D.π.app j x) :=
begin
  let E := (forget C).map_cone D,
  let hE : is_limit E := is_limit_of_preserves _ hD,
  let G := types.limit_cone.{w v} (F ⋙ forget C),
  let hG := types.limit_cone_is_limit.{w v} (F ⋙ forget C),
  let T : E.X ≅ G.X := hE.cone_point_unique_up_to_iso hG,
  change function.injective (T.hom ≫ (λ x j, G.π.app j x)),
  have h : function.injective T.hom,
  { intros a b h,
    suffices : T.inv (T.hom a) = T.inv (T.hom b), by simpa,
    rw h },
  suffices : function.injective (λ (x : G.X) j, G.π.app j x),
    by exact this.comp h,
  apply subtype.ext,
end

lemma concrete.is_limit_ext {D : cone F} (hD : is_limit D) (x y : D.X) :
  (∀ j, D.π.app j x = D.π.app j y) → x = y :=
λ h, concrete.to_product_injective_of_is_limit _ hD (funext h)

lemma concrete.limit_ext [has_limit F] (x y : limit F) :
  (∀ j, limit.π F j x = limit.π F j y) → x = y :=
concrete.is_limit_ext F (limit.is_limit _) _ _

section wide_pullback

open wide_pullback
open wide_pullback_shape

lemma concrete.wide_pullback_ext {B : C} {ι : Type w} {X : ι → C} (f : Π j : ι, X j ⟶ B)
  [has_wide_pullback B X f] [preserves_limit (wide_cospan B X f) (forget C)]
  (x y : wide_pullback B X f) (h₀ : base f x = base f y)
  (h : ∀ j, π f j x = π f j y) : x = y :=
begin
  apply concrete.limit_ext,
  rintro (_|j),
  { exact h₀ },
  { apply h }
end

lemma concrete.wide_pullback_ext' {B : C} {ι : Type w} [nonempty ι]
  {X : ι → C} (f : Π j : ι, X j ⟶ B) [has_wide_pullback.{w} B X f]
  [preserves_limit (wide_cospan B X f) (forget C)]
  (x y : wide_pullback B X f) (h : ∀ j, π f j x = π f j y) : x = y :=
begin
  apply concrete.wide_pullback_ext _ _ _ _ h,
  inhabit ι,
  simp only [← π_arrow f (arbitrary _), comp_apply, h],
end

end wide_pullback

section multiequalizer

lemma concrete.multiequalizer_ext {I : multicospan_index.{w} C} [has_multiequalizer I]
  [preserves_limit I.multicospan (forget C)] (x y : multiequalizer I)
  (h : ∀ (t : I.L), multiequalizer.ι I t x = multiequalizer.ι I t y) : x = y :=
begin
  apply concrete.limit_ext,
  rintros (a|b),
  { apply h },
  { rw [← limit.w I.multicospan (walking_multicospan.hom.fst b),
      comp_apply, comp_apply, h] }
end

/-- An auxiliary equivalence to be used in `multiequalizer_equiv` below.-/
def concrete.multiequalizer_equiv_aux (I : multicospan_index C) :
  (I.multicospan ⋙ (forget C)).sections ≃
  { x : Π (i : I.L), I.left i // ∀ (i : I.R), I.fst i (x _) = I.snd i (x _) } :=
{ to_fun := λ x, ⟨λ i, x.1 (walking_multicospan.left _), λ i, begin
    have a := x.2 (walking_multicospan.hom.fst i),
    have b := x.2 (walking_multicospan.hom.snd i),
    rw ← b at a,
    exact a,
  end⟩,
  inv_fun := λ x,
  { val := λ j,
    match j with
    | walking_multicospan.left a := x.1 _
    | walking_multicospan.right b := I.fst b (x.1 _)
    end,
    property := begin
      rintros (a|b) (a'|b') (f|f|f),
      { change (I.multicospan.map (𝟙 _)) _ = _, simp },
      { refl },
      { dsimp, erw ← x.2 b', refl },
      { change (I.multicospan.map (𝟙 _)) _ = _, simp },
    end },
  left_inv := begin
    intros x, ext (a|b),
    { refl },
    { change _ = x.val _,
      rw ← x.2 (walking_multicospan.hom.fst b),
      refl }
  end,
  right_inv := by { intros x, ext i, refl } }

/-- The equivalence between the noncomputable multiequalizer and
and the concrete multiequalizer. -/
noncomputable
def concrete.multiequalizer_equiv (I : multicospan_index.{w} C) [has_multiequalizer I]
  [preserves_limit I.multicospan (forget C)] : (multiequalizer I : C) ≃
    { x : Π (i : I.L), I.left i // ∀ (i : I.R), I.fst i (x _) = I.snd i (x _) } :=
let h1 := (limit.is_limit I.multicospan),
    h2 := (is_limit_of_preserves (forget C) h1),
    E := h2.cone_point_unique_up_to_iso (types.limit_cone_is_limit _) in
equiv.trans E.to_equiv (concrete.multiequalizer_equiv_aux I)

@[simp]
lemma concrete.multiequalizer_equiv_apply (I : multicospan_index.{w} C) [has_multiequalizer I]
  [preserves_limit I.multicospan (forget C)] (x : multiequalizer I) (i : I.L) :
  ((concrete.multiequalizer_equiv I) x : Π (i : I.L), I.left i) i = multiequalizer.ι I i x := rfl

end multiequalizer

-- TODO: Add analogous lemmas about products and equalizers.

end limits

section colimits

-- We don't mark this as an `@[ext]` lemma as we don't always want to work elementwise.
lemma cokernel_funext {C : Type*} [category C] [has_zero_morphisms C] [concrete_category C]
  {M N K : C} {f : M ⟶ N} [has_cokernel f] {g h : cokernel f ⟶ K}
  (w : ∀ (n : N), g (cokernel.π f n) = h (cokernel.π f n)) : g = h :=
begin
  apply coequalizer.hom_ext,
  apply concrete_category.hom_ext _ _,
  simpa using w,
end

variables {C : Type u} [category.{v} C] [concrete_category.{v} C]
  {J : Type v} [small_category J] (F : J ⥤ C) [preserves_colimit F (forget C)]

lemma concrete.from_union_surjective_of_is_colimit {D : cocone F} (hD : is_colimit D) :
  let ff : (Σ (j : J), F.obj j) → D.X := λ a, D.ι.app a.1 a.2 in function.surjective ff :=
begin
  intro ff,
  let E := (forget C).map_cocone D,
  let hE : is_colimit E := is_colimit_of_preserves _ hD,
  let G := types.colimit_cocone.{v v} (F ⋙ forget C),
  let hG := types.colimit_cocone_is_colimit.{v v} (F ⋙ forget C),
  let T : E ≅ G := hE.unique_up_to_iso hG,
  let TX : E.X ≅ G.X := (cocones.forget _).map_iso T,
  suffices : function.surjective (TX.hom ∘ ff),
  { intro a,
    obtain ⟨b, hb⟩ := this (TX.hom a),
    refine ⟨b, _⟩,
    apply_fun TX.inv at hb,
    change (TX.hom ≫ TX.inv) (ff b) = (TX.hom ≫ TX.inv) _ at hb,
    simpa only [TX.hom_inv_id] using hb },
  have : TX.hom ∘ ff = λ a, G.ι.app a.1 a.2,
  { ext a,
    change (E.ι.app a.1 ≫ hE.desc G) a.2 = _,
    rw hE.fac },
  rw this,
  rintro ⟨⟨j,a⟩⟩,
  exact ⟨⟨j,a⟩,rfl⟩,
end

lemma concrete.is_colimit_exists_rep {D : cocone F} (hD : is_colimit D) (x : D.X) :
  ∃ (j : J) (y : F.obj j), D.ι.app j y = x :=
begin
  obtain ⟨a, rfl⟩ := concrete.from_union_surjective_of_is_colimit F hD x,
  exact ⟨a.1, a.2, rfl⟩,
end

lemma concrete.colimit_exists_rep [has_colimit F] (x : colimit F) :
  ∃ (j : J) (y : F.obj j), colimit.ι F j y = x :=
concrete.is_colimit_exists_rep F (colimit.is_colimit _) x

lemma concrete.is_colimit_rep_eq_of_exists {D : cocone F} {i j : J} (hD : is_colimit D)
  (x : F.obj i) (y : F.obj j) (h : ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f x = F.map g y) :
  D.ι.app i x = D.ι.app j y :=
begin
  let E := (forget C).map_cocone D,
  let hE : is_colimit E := is_colimit_of_preserves _ hD,
  let G := types.colimit_cocone.{v v} (F ⋙ forget C),
  let hG := types.colimit_cocone_is_colimit.{v v} (F ⋙ forget C),
  let T : E ≅ G := hE.unique_up_to_iso hG,
  let TX : E.X ≅ G.X := (cocones.forget _).map_iso T,
  apply_fun TX.hom,
  swap, { suffices : function.bijective TX.hom, by exact this.1,
    rw ← is_iso_iff_bijective, apply is_iso.of_iso },
  change (E.ι.app i ≫ TX.hom) x = (E.ι.app j ≫ TX.hom) y,
  erw [T.hom.w, T.hom.w],
  obtain ⟨k, f, g, h⟩ := h,
  have : G.ι.app i x = (G.ι.app k (F.map f x) : G.X) := quot.sound ⟨f,rfl⟩,
  rw [this, h],
  symmetry,
  exact quot.sound ⟨g,rfl⟩,
end

lemma concrete.colimit_rep_eq_of_exists [has_colimit F] {i j : J}
  (x : F.obj i) (y : F.obj j) (h : ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f x = F.map g y) :
  colimit.ι F i x = colimit.ι F j y :=
concrete.is_colimit_rep_eq_of_exists F (colimit.is_colimit _) x y h

section filtered_colimits

variable [is_filtered J]

lemma concrete.is_colimit_exists_of_rep_eq {D : cocone F} {i j : J} (hD : is_colimit D)
  (x : F.obj i) (y : F.obj j) (h : D.ι.app _ x = D.ι.app _ y) :
  ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f x = F.map g y :=
begin
  let E := (forget C).map_cocone D,
  let hE : is_colimit E := is_colimit_of_preserves _ hD,
  let G := types.colimit_cocone.{v v} (F ⋙ forget C),
  let hG := types.colimit_cocone_is_colimit.{v v} (F ⋙ forget C),
  let T : E ≅ G := hE.unique_up_to_iso hG,
  let TX : E.X ≅ G.X := (cocones.forget _).map_iso T,
  apply_fun TX.hom at h,
  change (E.ι.app i ≫ TX.hom) x = (E.ι.app j ≫ TX.hom) y at h,
  erw [T.hom.w, T.hom.w] at h,
  replace h := quot.exact _ h,
  suffices : ∀ (a b : Σ j, F.obj j)
    (h : eqv_gen (limits.types.quot.rel.{v v} (F ⋙ forget C)) a b),
    ∃ k (f : a.1 ⟶ k) (g : b.1 ⟶ k), F.map f a.2 = F.map g b.2,
  { exact this ⟨i,x⟩ ⟨j,y⟩ h },
  intros a b h,
  induction h,
  case eqv_gen.rel : x y hh
  { obtain ⟨e,he⟩ := hh,
    use [y.1, e, 𝟙 _],
    simpa using he.symm },
  case eqv_gen.refl : x { use [x.1, 𝟙 _, 𝟙 _, rfl] },
  case eqv_gen.symm : x y _ hh
  { obtain ⟨k, f, g, hh⟩ := hh,
    use [k, g, f, hh.symm] },
  case eqv_gen.trans : x y z _ _ hh1 hh2
  { obtain ⟨k1, f1, g1, h1⟩ := hh1,
    obtain ⟨k2, f2, g2, h2⟩ := hh2,
    let k0 : J := is_filtered.max k1 k2,
    let e1 : k1 ⟶ k0 := is_filtered.left_to_max _ _,
    let e2 : k2 ⟶ k0 := is_filtered.right_to_max _ _,
    let k : J := is_filtered.coeq (g1 ≫ e1) (f2 ≫ e2),
    let e : k0 ⟶ k := is_filtered.coeq_hom _ _,
    use [k, f1 ≫ e1 ≫ e, g2 ≫ e2 ≫ e],
    simp only [F.map_comp, comp_apply, h1, ← h2],
    simp only [← comp_apply, ← F.map_comp],
    rw is_filtered.coeq_condition },
end

theorem concrete.is_colimit_rep_eq_iff_exists {D : cocone F} {i j : J}
  (hD : is_colimit D) (x : F.obj i) (y : F.obj j) :
  D.ι.app i x = D.ι.app j y ↔ ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f x = F.map g y :=
⟨concrete.is_colimit_exists_of_rep_eq _ hD _ _, concrete.is_colimit_rep_eq_of_exists _ hD _ _⟩

lemma concrete.colimit_exists_of_rep_eq [has_colimit F] {i j : J}
  (x : F.obj i) (y : F.obj j) (h : colimit.ι F _ x = colimit.ι F _ y) :
  ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f x = F.map g y :=
concrete.is_colimit_exists_of_rep_eq F (colimit.is_colimit _) x y h

theorem concrete.colimit_rep_eq_iff_exists [has_colimit F] {i j : J}
  (x : F.obj i) (y : F.obj j) :
  colimit.ι F i x = colimit.ι F j y ↔ ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f x = F.map g y :=
⟨concrete.colimit_exists_of_rep_eq _ _ _, concrete.colimit_rep_eq_of_exists _ _ _⟩

end filtered_colimits

section wide_pushout

open wide_pushout
open wide_pushout_shape

lemma concrete.wide_pushout_exists_rep {B : C} {α : Type*} {X : α → C} (f : Π j : α, B ⟶ X j)
  [has_wide_pushout.{v} B X f] [preserves_colimit (wide_span B X f) (forget C)]
  (x : wide_pushout B X f) : (∃ y : B, head f y = x) ∨ (∃ (i : α) (y : X i), ι f i y = x) :=
begin
  obtain ⟨_ | j, y, rfl⟩ := concrete.colimit_exists_rep _ x,
  { use y },
  { right,
    use [j,y] }
end

lemma concrete.wide_pushout_exists_rep' {B : C} {α : Type*} [nonempty α] {X : α → C}
  (f : Π j : α, B ⟶ X j) [has_wide_pushout.{v} B X f]
  [preserves_colimit (wide_span B X f) (forget C)] (x : wide_pushout B X f) :
  ∃ (i : α) (y : X i), ι f i y = x :=
begin
  rcases concrete.wide_pushout_exists_rep f x with ⟨y, rfl⟩ | ⟨i, y, rfl⟩,
  { inhabit α,
    use [arbitrary _, f _ y],
    simp only [← arrow_ι _ (arbitrary α), comp_apply] },
  { use [i,y] }
end

end wide_pushout

-- TODO: Add analogous lemmas about coproducts and coequalizers.

end colimits

end category_theory.limits


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import data.list.chain
import category_theory.punit
import category_theory.is_connected
import category_theory.sigma.basic
import category_theory.full_subcategory

/-!
# Connected components of a category

Defines a type `connected_components J` indexing the connected components of a category, and the
full subcategories giving each connected component: `component j : Type u₁`.
We show that each `component j` is in fact connected.

We show every category can be expressed as a disjoint union of its connected components, in
particular `decomposed J` is the category (definitionally) given by the sigma-type of the connected
components of `J`, and it is shown that this is equivalent to `J`.
-/

universes v₁ v₂ v₃ u₁ u₂

noncomputable theory

open category_theory.category

namespace category_theory

attribute [instance, priority 100] is_connected.is_nonempty

variables {J : Type u₁} [category.{v₁} J]
variables {C : Type u₂} [category.{u₁} C]

/-- This type indexes the connected components of the category `J`. -/
def connected_components (J : Type u₁) [category.{v₁} J] : Type u₁ := quotient (zigzag.setoid J)

instance [inhabited J] : inhabited (connected_components J) := ⟨quotient.mk' (default J)⟩

/-- Given an index for a connected component, produce the actual component as a full subcategory. -/
@[derive category]
def component (j : connected_components J) : Type u₁ := {k : J // quotient.mk' k = j}

/-- The inclusion functor from a connected component to the whole category. -/
@[derive [full, faithful], simps {rhs_md := semireducible}]
def component.ι (j) : component j ⥤ J :=
full_subcategory_inclusion _

/-- Each connected component of the category is nonempty. -/
instance (j : connected_components J) : nonempty (component j) :=
begin
  apply quotient.induction_on' j,
  intro k,
  refine ⟨⟨k, rfl⟩⟩,
end

instance (j : connected_components J) : inhabited (component j) := classical.inhabited_of_nonempty'

/-- Each connected component of the category is connected. -/
instance (j : connected_components J) : is_connected (component j) :=
begin
  -- Show it's connected by constructing a zigzag (in `component j`) between any two objects
  apply is_connected_of_zigzag,
  rintro ⟨j₁, hj₁⟩ ⟨j₂, rfl⟩,
  -- We know that the underlying objects j₁ j₂ have some zigzag between them in `J`
  have h₁₂ : zigzag j₁ j₂ := quotient.exact' hj₁,
  -- Get an explicit zigzag as a list
  rcases list.exists_chain_of_relation_refl_trans_gen h₁₂ with ⟨l, hl₁, hl₂⟩,
  -- Everything which has a zigzag to j₂ can be lifted to the same component as `j₂`.
  let f : Π x, zigzag x j₂ → component (quotient.mk' j₂) := λ x h, ⟨x, quotient.sound' h⟩,
  -- Everything in our chosen zigzag from `j₁` to `j₂` has a zigzag to `j₂`.
  have hf : ∀ (a : J), a ∈ l → zigzag a j₂,
  { intros i hi,
    apply list.chain.induction (λ t, zigzag t j₂) _ hl₁ hl₂ _ _ _ (or.inr hi),
    { intros j k,
      apply relation.refl_trans_gen.head },
    { apply relation.refl_trans_gen.refl } },
  -- Now lift the zigzag from `j₁` to `j₂` in `J` to the same thing in `component j`.
  refine ⟨l.pmap f hf, _, _⟩,
  { refine @@list.chain_pmap_of_chain _ _ _ f (λ x y _ _ h, _) hl₁ h₁₂ _,
    exact zag_of_zag_obj (component.ι _) h },
  { erw list.last_pmap _ f (j₁ :: l) (by simpa [h₁₂] using hf) (list.cons_ne_nil _ _),
    exact subtype.ext hl₂ },
end

/--
The disjoint union of `J`s connected components, written explicitly as a sigma-type with the
category structure.
This category is equivalent to `J`.
-/
abbreviation decomposed (J : Type u₁) [category.{v₁} J] :=
Σ (j : connected_components J), component j

/--
The inclusion of each component into the decomposed category. This is just `sigma.incl` but having
this abbreviation helps guide typeclass search to get the right category instance on `decomposed J`.
-/
-- This name may cause clashes further down the road, and so might need to be changed.
abbreviation inclusion (j : connected_components J) : component j ⥤ decomposed J :=
sigma.incl _

/-- The forward direction of the equivalence between the decomposed category and the original. -/
@[simps {rhs_md := semireducible}]
def decomposed_to (J : Type u₁) [category.{v₁} J] : decomposed J ⥤ J :=
sigma.desc component.ι

@[simp]
lemma inclusion_comp_decomposed_to (j : connected_components J) :
  inclusion j ⋙ decomposed_to J = component.ι j :=
rfl

instance : full (decomposed_to J) :=
{ preimage :=
  begin
    rintro ⟨j', X, hX⟩ ⟨k', Y, hY⟩ f,
    dsimp at f,
    have : j' = k',
      rw [← hX, ← hY, quotient.eq'],
      exact relation.refl_trans_gen.single (or.inl ⟨f⟩),
    subst this,
    refine sigma.sigma_hom.mk f,
  end,
  witness' :=
  begin
    rintro ⟨j', X, hX⟩ ⟨_, Y, rfl⟩ f,
    have : quotient.mk' Y = j',
    { rw [← hX, quotient.eq'],
      exact relation.refl_trans_gen.single (or.inr ⟨f⟩) },
    subst this,
    refl,
  end }

instance : faithful (decomposed_to J) :=
{ map_injective' :=
  begin
    rintro ⟨_, j, rfl⟩ ⟨_, k, hY⟩ ⟨_, _, _, f⟩ ⟨_, _, _, g⟩ e,
    change f = g at e,
    subst e,
  end }

instance : ess_surj (decomposed_to J) :=
{ mem_ess_image := λ j, ⟨⟨_, j, rfl⟩, ⟨iso.refl _⟩⟩ }

instance : is_equivalence (decomposed_to J) :=
equivalence.equivalence_of_fully_faithfully_ess_surj _

/-- This gives that any category is equivalent to a disjoint union of connected categories. -/
@[simps functor {rhs_md := semireducible}]
def decomposed_equiv : decomposed J ≌ J :=
(decomposed_to J).as_equivalence

end category_theory


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

import for_mathlib.dold_kan.functor_gamma
import category_theory.idempotents.homological_complex

/-! The counit isomorphism of the Dold-Kan equivalence

The purpose of this file is to construct natural isomorphisms
`N₁Γ₀ : Γ₀ ⋙ N₁ ≅ to_karoubi (chain_complex C ℕ)`
and `N₂Γ₂ : Γ₂ ⋙ N₂ ≅ 𝟭 (karoubi (chain_complex C ℕ))`.

-/

noncomputable theory

open category_theory category_theory.category category_theory.limits category_theory.idempotents
  opposite simplicial_object
open_locale simplicial

namespace algebraic_topology

namespace dold_kan

variables {C : Type*} [category C] [preadditive C] [has_finite_coproducts C]

/-- The isomorphism  `(Γ₀.splitting K).nondeg_complex ≅ K` for all `K : chain_complex C ℕ`. -/
@[simps]
def Γ₀_nondeg_complex_iso (K : chain_complex C ℕ) : (Γ₀.splitting K).nondeg_complex ≅ K :=
homological_complex.hom.iso_of_components (λ n, iso.refl _)
begin
  rintros _ n (rfl : n+1=_),
  dsimp,
  simp only [id_comp, comp_id, alternating_face_map_complex.obj_d_eq,
    preadditive.sum_comp, preadditive.comp_sum],
  rw fintype.sum_eq_single (0 : fin (n+2)),
  { simp only [fin.coe_zero, pow_zero, one_zsmul],
    erw [Γ₀.obj.map_mono_on_summand_id_assoc, Γ₀.obj.termwise.map_mono_δ₀,
      splitting.ι_π_summand_eq_id, comp_id], },
  { intros i hi,
    dsimp,
    simp only [preadditive.zsmul_comp, preadditive.comp_zsmul, assoc],
    erw [Γ₀.obj.map_mono_on_summand_id_assoc, Γ₀.obj.termwise.map_mono_eq_zero,
      zero_comp, zsmul_zero],
    { intro h,
      replace h := congr_arg simplex_category.len h,
      change n+1 = n at h,
      linarith, },
    { simpa only [is_δ₀.iff] using hi, }, },
end

/-- The natural isomorphism `(Γ₀.splitting K).nondeg_complex ≅ K` for `K : chain_complex C ℕ`. -/
def Γ₀'_comp_nondeg_complex_functor :
  Γ₀' ⋙ split.nondeg_complex_functor ≅ 𝟭 (chain_complex C ℕ) :=
nat_iso.of_components Γ₀_nondeg_complex_iso
  (λ X Y f, by { ext n, dsimp, simp only [comp_id, id_comp], })

/-- The natural isomorphism `Γ₀ ⋙ N₁ ≅ to_karoubi (chain_complex C ℕ)`. -/
def N₁Γ₀ : Γ₀ ⋙ N₁ ≅ to_karoubi (chain_complex C ℕ) :=
calc Γ₀ ⋙ N₁ ≅ Γ₀' ⋙ split.forget C ⋙ N₁ : functor.associator _ _ _
... ≅ Γ₀' ⋙ split.nondeg_complex_functor ⋙ to_karoubi _ :
  iso_whisker_left Γ₀' split.to_karoubi_nondeg_complex_functor_iso_N₁.symm
... ≅ (Γ₀' ⋙ split.nondeg_complex_functor) ⋙ to_karoubi _ : (functor.associator _ _ _).symm
... ≅ 𝟭 _ ⋙ to_karoubi (chain_complex C ℕ) : iso_whisker_right Γ₀'_comp_nondeg_complex_functor _
... ≅ to_karoubi (chain_complex C ℕ) : functor.left_unitor _

lemma N₁Γ₀_app (K : chain_complex C ℕ) :
  N₁Γ₀.app K = (Γ₀.splitting K).to_karoubi_nondeg_complex_iso_N₁.symm
    ≪≫ (to_karoubi _).map_iso (Γ₀_nondeg_complex_iso K) :=
begin
  ext1,
  dsimp [N₁Γ₀],
  erw [id_comp, comp_id, comp_id],
  refl,
end

lemma N₁Γ₀_hom_app (K : chain_complex C ℕ) :
  N₁Γ₀.hom.app K = (Γ₀.splitting K).to_karoubi_nondeg_complex_iso_N₁.inv
    ≫ (to_karoubi _).map (Γ₀_nondeg_complex_iso K).hom :=
by { change (N₁Γ₀.app K).hom = _, simpa only [N₁Γ₀_app], }

lemma N₁Γ₀_inv_app (K : chain_complex C ℕ) :
  N₁Γ₀.inv.app K = (to_karoubi _).map (Γ₀_nondeg_complex_iso K).inv ≫
   (Γ₀.splitting K).to_karoubi_nondeg_complex_iso_N₁.hom :=
by { change (N₁Γ₀.app K).inv = _, simpa only [N₁Γ₀_app], }

@[simp]
lemma N₁Γ₀_hom_app_f_f (K : chain_complex C ℕ) (n : ℕ) :
  (N₁Γ₀.hom.app K).f.f n = (Γ₀.splitting K).to_karoubi_nondeg_complex_iso_N₁.inv.f.f n :=
by { rw N₁Γ₀_hom_app, apply comp_id, }

@[simp]
lemma N₁Γ₀_inv_app_f_f (K : chain_complex C ℕ) (n : ℕ) :
  (N₁Γ₀.inv.app K).f.f n = (Γ₀.splitting K).to_karoubi_nondeg_complex_iso_N₁.hom.f.f n :=
by { rw N₁Γ₀_inv_app, apply id_comp, }

lemma N₂Γ₂_to_karoubi : to_karoubi (chain_complex C ℕ) ⋙ Γ₂ ⋙ N₂ = Γ₀ ⋙ N₁ :=
begin
  have h := functor.congr_obj (functor_extension₂_comp_whiskering_left_to_karoubi
    (chain_complex C ℕ) (simplicial_object C)) Γ₀,
  have h' := functor.congr_obj (functor_extension₁_comp_whiskering_left_to_karoubi
    (simplicial_object C) (chain_complex C ℕ)) N₁,
  dsimp [N₂, Γ₂, functor_extension₁] at h h' ⊢,
  rw [← functor.assoc, h, functor.assoc, h'],
end

/-- Compatibility isomorphism between `to_karoubi _ ⋙ Γ₂ ⋙ N₂` and `Γ₀ ⋙ N₁` which
are functors `chain_complex C ℕ ⥤ karoubi (chain_complex C ℕ)`. -/
@[simps]
def N₂Γ₂_to_karoubi_iso : to_karoubi (chain_complex C ℕ) ⋙ Γ₂ ⋙ N₂ ≅ Γ₀ ⋙ N₁ :=
eq_to_iso (N₂Γ₂_to_karoubi)

/-- The counit isomorphism of the Dold-Kan equivalence for additive categories. -/
def N₂Γ₂ : Γ₂ ⋙ N₂ ≅ 𝟭 (karoubi (chain_complex C ℕ)) :=
((whiskering_left _ _ _).obj (to_karoubi (chain_complex C ℕ))).preimage_iso
  (N₂Γ₂_to_karoubi_iso ≪≫ N₁Γ₀)

lemma N₂Γ₂_compatible_with_N₁Γ₀ (K : chain_complex C ℕ) :
  N₂Γ₂.hom.app ((to_karoubi _).obj K) = N₂Γ₂_to_karoubi_iso.hom.app K ≫ N₁Γ₀.hom.app K :=
congr_app (((whiskering_left _ _ (karoubi (chain_complex C ℕ ))).obj
  (to_karoubi (chain_complex C ℕ))).image_preimage
  (N₂Γ₂_to_karoubi_iso.hom ≫ N₁Γ₀.hom : _ ⟶ to_karoubi _ ⋙ 𝟭 _)) K

@[simp]
lemma N₂Γ₂_inv_app_f_f (X : karoubi (chain_complex C ℕ)) (n : ℕ) :
  (N₂Γ₂.inv.app X).f.f n =
    X.p.f n ≫ (Γ₀.splitting X.X).ι_summand (splitting.index_set.id (op [n])) :=
begin
  dsimp only [N₂Γ₂, functor.preimage_iso, iso.trans],
  simp only [whiskering_left_obj_preimage_app, N₂Γ₂_to_karoubi_iso_inv, functor.id_map,
    nat_trans.comp_app, eq_to_hom_app, functor.comp_map, assoc, karoubi.comp_f,
    karoubi.eq_to_hom_f, eq_to_hom_refl, comp_id, karoubi.comp_p_assoc, N₂_map_f_f,
    homological_complex.comp_f, N₁Γ₀_inv_app_f_f, P_infty_on_Γ₀_splitting_summand_eq_self_assoc,
    splitting.to_karoubi_nondeg_complex_iso_N₁_hom_f_f, Γ₂_map_f_app, karoubi.decomp_id_p_f],
  dsimp [to_karoubi],
  rw [splitting.ι_desc],
  dsimp [splitting.index_set.id],
  rw karoubi.homological_complex.p_idem_assoc,
end

end dold_kan

end algebraic_topology


import for_mathlib.snake_lemma

namespace category_theory

local notation x `⟶[`D`]` y := D.map (snake_diagram.hom x y)

namespace snake_lemma

open category_theory.limits

universes v u
variables {A : Type u} [category.{v} A] [abelian A]
  {F G : snake_diagram ⥤ A} (η : F ⟶ G)

namespace δ_natural_setup

@[reassoc]
lemma aux1 (hF : is_snake_input F) (hG : is_snake_input G) :
  η.app (0, 2) ≫ hG.to_kernel = hF.to_kernel ≫
  kernel.lift _ (kernel.ι _ ≫ η.app _) begin
    simp only [category.assoc, ← η.naturality, kernel.condition_assoc, zero_comp],
  end :=
begin
  apply equalizer.hom_ext,
  dsimp [is_snake_input.to_kernel],
  simp,
end

@[reassoc]
lemma aux2 (hF : is_snake_input F) (hG : is_snake_input G) :
  kernel.lift ((1, 2) ⟶[G] (2, 2)) (kernel.ι ((1, 2) ⟶[F] (2, 2)) ≫
    η.app (1, 2)) begin
      simp only [category.assoc, ← η.naturality, kernel.condition_assoc, zero_comp],
    end ≫ inv hG.cokernel_to_top_right_kernel_to_right_kernel =
  inv hF.cokernel_to_top_right_kernel_to_right_kernel ≫
    cokernel.desc _ (kernel.lift _ (kernel.ι _ ≫ η.app _) begin
      simp only [category.assoc, ← η.naturality, kernel.condition_assoc, zero_comp],
    end ≫ cokernel.π _) begin
      dsimp [is_snake_input.to_top_right_kernel],
      simp only [← category.assoc], let t := _, change t ≫ _ = _,
      have ht : t = η.app _ ≫ kernel.lift ((1,1) ⟶[G] (2,2)) ((1,0) ⟶[G] (1,1)) _,
      { apply equalizer.hom_ext, simp, },
      rw [ht, category.assoc, cokernel.condition, comp_zero],
    end :=
begin
  simp only [is_iso.eq_inv_comp, is_iso.comp_inv_eq, category.assoc],
  dsimp only [is_snake_input.cokernel_to_top_right_kernel_to_right_kernel],
  apply equalizer.hom_ext,
  simp only [le_refl, and_true, category.assoc, nat_trans.naturality,
    kernel.condition_assoc, zero_comp, true_and,
    cokernel.condition, comp_zero, equalizer_as_kernel, kernel.lift_ι],
  apply coequalizer.hom_ext,
  simp only [category.assoc, nat_trans.naturality, cokernel.π_desc_assoc,
    kernel.lift_ι_assoc, kernel.lift_ι],
end

@[reassoc]
lemma aux3 (hF : is_snake_input F) (hG : is_snake_input G) :
  kernel.lift hG.bottom_left_cokernel_to (kernel.ι hF.bottom_left_cokernel_to ≫
    cokernel.desc ((1, 0) ⟶[F] (2, 1)) (η.app (2, 1) ≫
    cokernel.π ((1, 0) ⟶[G] (2, 1))) begin
      simp only [category.assoc, η.naturality_assoc, cokernel.condition, comp_zero],
    end) begin
      dsimp [is_snake_input.bottom_left_cokernel_to],
      simp only [category.assoc], let t := _, change _ ≫ t = _,
      have ht : t = cokernel.desc ((1,0) ⟶[F] (2,1)) ((2,1) ⟶[F] (2,2)) _ ≫ η.app _,
      { apply coequalizer.hom_ext, simp, },
      rw [ht, kernel.condition_assoc, zero_comp],
    end ≫
    inv hG.left_cokernel_to_kernel_bottom_left_cokernel_to =
  inv hF.left_cokernel_to_kernel_bottom_left_cokernel_to ≫
  cokernel.desc _ (η.app _ ≫ cokernel.π _) begin
    simp only [category.assoc, η.naturality_assoc, cokernel.condition, comp_zero],
  end :=
begin
  rw [is_iso.comp_inv_eq, category.assoc (inv _), is_iso.eq_inv_comp],
  dsimp [is_snake_input.left_cokernel_to_kernel_bottom_left_cokernel_to],
  apply coequalizer.hom_ext, apply equalizer.hom_ext,
  simp only [nat_trans.naturality_assoc, category.assoc, cokernel.π_desc_assoc,
    cokernel.π_desc, kernel.lift_ι, kernel.lift_ι_assoc],
end

end δ_natural_setup

open δ_natural_setup

theorem δ_natural (hF : is_snake_input F) (hG : is_snake_input G) :
  η.app (0,2) ≫ hG.δ = hF.δ ≫ η.app (3,0) :=
begin
  dsimp only [is_snake_input.δ],
  simp only [category.assoc],
  rw aux1_assoc η hF hG,
  rw aux2_assoc η hF hG,
  simp_rw cancel_epi,
  apply coequalizer.hom_ext,
  dsimp only [is_snake_input.δ_aux],
  simp only [cokernel.π_desc_assoc, category.assoc],
  simp only [← category.assoc], let t := _, change (t ≫ _) ≫ _ = _,
  let s := _, change _ = ((s ≫ _) ≫ _) ≫ _,
  have ht : t = s ≫ kernel.lift _ (kernel.ι _ ≫
    cokernel.desc _ (η.app _ ≫ cokernel.π _) begin
      simp only [category.assoc, η.naturality_assoc, cokernel.condition, comp_zero],
    end) _,
  rotate 2,
  { dsimp only [is_snake_input.bottom_left_cokernel_to], simp only [category.assoc],
    let t := _, change _ ≫ t = _,
    have ht : t = cokernel.desc ((1,0) ⟶[F] (2,1)) ((2,1) ⟶[F] (2,2)) _ ≫ η.app _,
    { apply coequalizer.hom_ext,
      simp only [cokernel.π_desc_assoc, category.assoc, cokernel.π_desc, nat_trans.naturality], },
    rw [ht, kernel.condition_assoc, zero_comp] },
  { dsimp only [t, s],
    apply equalizer.hom_ext,
    simp only [category.assoc, nat_trans.naturality_assoc, cokernel.π_desc, kernel.lift_ι, kernel.lift_ι_assoc] },
  rw ht, dsimp only [s], clear ht t s,
  simp only [category.assoc], congr' 1,
  rw aux3_assoc η hF hG, congr' 1,
  dsimp only [is_snake_input.cokernel_to],
  apply coequalizer.hom_ext,
  simp only [cokernel.π_desc_assoc, category.assoc, cokernel.π_desc, nat_trans.naturality],
end

end snake_lemma

end category_theory


example (A B C D E F G H I J K L : Prop)
(f1 : A → B) (f2 : B → E) (f3 : E → D) (f4 : D → A) (f5 : E → F)
(f6 : F → C) (f7 : B → C) (f8 : F → G) (f9 : G → J) (f10 : I → J)
(f11 : J → I) (f12 : I → H) (f13 : E → H) (f14 : H → K) (f15 : I → L)
 : A → L :=
begin
cc,
end


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

! This file was ported from Lean 3 source module combinatorics.set_family.kleitman
! leanprover-community/mathlib commit 50832daea47b195a48b5b33b1c8b2162c48c3afc
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Combinatorics.SetFamily.HarrisKleitman
import Mathbin.Combinatorics.SetFamily.Intersecting

/-!
# Kleitman's bound on the size of intersecting families

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

An intersecting family on `n` elements has size at most `2ⁿ⁻¹`, so we could naïvely think that two
intersecting families could cover all `2ⁿ` sets. But actually that's not case because for example
none of them can contain the empty set. Intersecting families are in some sense correlated.
Kleitman's bound stipulates that `k` intersecting families cover at most `2ⁿ - 2ⁿ⁻ᵏ` sets.

## Main declarations

* `finset.card_bUnion_le_of_intersecting`: Kleitman's theorem.

## References

* [D. J. Kleitman, *Families of non-disjoint subsets*][kleitman1966]
-/

open Finset

open Fintype (card)

variable {ι α : Type _} [Fintype α] [DecidableEq α] [Nonempty α]

/- warning: finset.card_bUnion_le_of_intersecting -> Finset.card_bunionᵢ_le_of_intersecting is a dubious translation:
lean 3 declaration is
  forall {ι : Type.{u1}} {α : Type.{u2}} [_inst_1 : Fintype.{u2} α] [_inst_2 : DecidableEq.{succ u2} α] [_inst_3 : Nonempty.{succ u2} α] (s : Finset.{u1} ι) (f : ι -> (Finset.{u2} (Finset.{u2} α))), (forall (i : ι), (Membership.Mem.{u1, u1} ι (Finset.{u1} ι) (Finset.hasMem.{u1} ι) i s) -> (Set.Intersecting.{u2} (Finset.{u2} α) (Lattice.toSemilatticeInf.{u2} (Finset.{u2} α) (Finset.lattice.{u2} α (fun (a : α) (b : α) => _inst_2 a b))) (Finset.orderBot.{u2} α) ((fun (a : Type.{u2}) (b : Type.{u2}) [self : HasLiftT.{succ u2, succ u2} a b] => self.0) (Finset.{u2} (Finset.{u2} α)) (Set.{u2} (Finset.{u2} α)) (HasLiftT.mk.{succ u2, succ u2} (Finset.{u2} (Finset.{u2} α)) (Set.{u2} (Finset.{u2} α)) (CoeTCₓ.coe.{succ u2, succ u2} (Finset.{u2} (Finset.{u2} α)) (Set.{u2} (Finset.{u2} α)) (Finset.Set.hasCoeT.{u2} (Finset.{u2} α)))) (f i)))) -> (LE.le.{0} Nat Nat.hasLe (Finset.card.{u2} (Finset.{u2} α) (Finset.bunionᵢ.{u1, u2} ι (Finset.{u2} α) (fun (a : Finset.{u2} α) (b : Finset.{u2} α) => Finset.decidableEq.{u2} α (fun (a : α) (b : α) => _inst_2 a b) a b) s f)) (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat Nat.hasSub) (HPow.hPow.{0, 0, 0} Nat Nat Nat (instHPow.{0, 0} Nat Nat (Monoid.Pow.{0} Nat Nat.monoid)) (OfNat.ofNat.{0} Nat 2 (OfNat.mk.{0} Nat 2 (bit0.{0} Nat Nat.hasAdd (One.one.{0} Nat Nat.hasOne)))) (Fintype.card.{u2} α _inst_1)) (HPow.hPow.{0, 0, 0} Nat Nat Nat (instHPow.{0, 0} Nat Nat (Monoid.Pow.{0} Nat Nat.monoid)) (OfNat.ofNat.{0} Nat 2 (OfNat.mk.{0} Nat 2 (bit0.{0} Nat Nat.hasAdd (One.one.{0} Nat Nat.hasOne)))) (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat Nat.hasSub) (Fintype.card.{u2} α _inst_1) (Finset.card.{u1} ι s)))))
but is expected to have type
  forall {ι : Type.{u2}} {α : Type.{u1}} [_inst_1 : Fintype.{u1} α] [_inst_2 : DecidableEq.{succ u1} α] [_inst_3 : Nonempty.{succ u1} α] (s : Finset.{u2} ι) (f : ι -> (Finset.{u1} (Finset.{u1} α))), (forall (i : ι), (Membership.mem.{u2, u2} ι (Finset.{u2} ι) (Finset.instMembershipFinset.{u2} ι) i s) -> (Set.Intersecting.{u1} (Finset.{u1} α) (Lattice.toSemilatticeInf.{u1} (Finset.{u1} α) (Finset.instLatticeFinset.{u1} α (fun (a : α) (b : α) => _inst_2 a b))) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} α) (Finset.toSet.{u1} (Finset.{u1} α) (f i)))) -> (LE.le.{0} Nat instLENat (Finset.card.{u1} (Finset.{u1} α) (Finset.bunionᵢ.{u2, u1} ι (Finset.{u1} α) (fun (a : Finset.{u1} α) (b : Finset.{u1} α) => Finset.decidableEq.{u1} α (fun (a : α) (b : α) => _inst_2 a b) a b) s f)) (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat instSubNat) (HPow.hPow.{0, 0, 0} Nat Nat Nat (instHPow.{0, 0} Nat Nat instPowNat) (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2)) (Fintype.card.{u1} α _inst_1)) (HPow.hPow.{0, 0, 0} Nat Nat Nat (instHPow.{0, 0} Nat Nat instPowNat) (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2)) (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat instSubNat) (Fintype.card.{u1} α _inst_1) (Finset.card.{u2} ι s)))))
Case conversion may be inaccurate. Consider using '#align finset.card_bUnion_le_of_intersecting Finset.card_bunionᵢ_le_of_intersectingₓ'. -/
/-- **Kleitman's theorem**. An intersecting family on `n` elements contains at most `2ⁿ⁻¹` sets, and
each further intersecting family takes at most half of the sets that are in no previous family. -/
theorem Finset.card_bunionᵢ_le_of_intersecting (s : Finset ι) (f : ι → Finset (Finset α))
    (hf : ∀ i ∈ s, (f i : Set (Finset α)).Intersecting) :
    (s.bunionᵢ f).card ≤ 2 ^ card α - 2 ^ (card α - s.card) :=
  by
  obtain hs | hs := le_total (card α) s.card
  · rw [tsub_eq_zero_of_le hs, pow_zero]
    refine'
      (card_le_of_subset <|
            bUnion_subset.2 fun i hi a ha =>
              mem_compl.2 <| not_mem_singleton.2 <| (hf _ hi).ne_bot ha).trans_eq
        _
    rw [card_compl, Fintype.card_finset, card_singleton]
  induction' s using Finset.cons_induction with i s hi ih generalizing f
  · simp
  classical
    set f' : ι → Finset (Finset α) := fun j =>
      if hj : j ∈ cons i s hi then (hf j hj).exists_card_eq.some else ∅ with hf'
    have hf₁ :
      ∀ j,
        j ∈ cons i s hi →
          f j ⊆ f' j ∧ 2 * (f' j).card = 2 ^ card α ∧ (f' j : Set (Finset α)).Intersecting :=
      by
      rintro j hj
      simp_rw [hf', dif_pos hj, ← Fintype.card_finset]
      exact Classical.choose_spec (hf j hj).exists_card_eq
    have hf₂ : ∀ j, j ∈ cons i s hi → IsUpperSet (f' j : Set (Finset α)) :=
      by
      refine' fun j hj => (hf₁ _ hj).2.2.isUpperSet' ((hf₁ _ hj).2.2.is_max_iff_card_eq.2 _)
      rw [Fintype.card_finset]
      exact (hf₁ _ hj).2.1
    refine' (card_le_of_subset <| bUnion_mono fun j hj => (hf₁ _ hj).1).trans _
    nth_rw 1 [cons_eq_insert i]
    rw [bUnion_insert]
    refine' (card_mono <| @le_sup_sdiff _ _ _ <| f' i).trans ((card_union_le _ _).trans _)
    rw [union_sdiff_left, sdiff_eq_inter_compl]
    refine' le_of_mul_le_mul_left _ (pow_pos zero_lt_two <| card α + 1)
    rw [pow_succ', mul_add, mul_assoc, mul_comm _ 2, mul_assoc]
    refine'
      (add_le_add
              ((mul_le_mul_left <| pow_pos (zero_lt_two' ℕ) _).2
                (hf₁ _ <| mem_cons_self _ _).2.2.card_le) <|
            (mul_le_mul_left <| zero_lt_two' ℕ).2 <| IsUpperSet.card_inter_le_finset _ _).trans
        _
    · rw [coe_bUnion]
      exact isUpperSet_unionᵢ₂ fun i hi => hf₂ _ <| subset_cons _ hi
    · rw [coe_compl]
      exact (hf₂ _ <| mem_cons_self _ _).compl
    rw [mul_tsub, card_compl, Fintype.card_finset, mul_left_comm, mul_tsub,
      (hf₁ _ <| mem_cons_self _ _).2.1, two_mul, add_tsub_cancel_left, ← mul_tsub, ← mul_two,
      mul_assoc, ← add_mul, mul_comm]
    refine' mul_le_mul_left' _ _
    refine'
      (add_le_add_left
            (ih ((card_le_of_subset <| subset_cons _).trans hs) _ fun i hi =>
              (hf₁ _ <| subset_cons _ hi).2.2)
            _).trans
        _
    rw [mul_tsub, two_mul, ← pow_succ, ←
      add_tsub_assoc_of_le (pow_le_pow' (one_le_two : (1 : ℕ) ≤ 2) tsub_le_self),
      tsub_add_eq_add_tsub hs, card_cons, add_tsub_add_eq_tsub_right]
#align finset.card_bUnion_le_of_intersecting Finset.card_bunionᵢ_le_of_intersecting


/-
# Example: Aviation Resource Management

The previous examples have been typical problems from computing science. This
example is drawn from industry, and is a simplified version of a problem that
occurs globally on a daily basis. It concerns resource allocation in the aviation
industry. Specifically, scheduling aircraft for take off at an airport.

The number of passengers undertaking air travel is continually increasing, with a
corresponding increase in the number of aircraft movements. However, the resources
available to facilitate these flights are not growing at the same rate. In
particular, airports and their runways, taxiways and gates are becoming ever more
congested. If we cannot grow the resources to match the increase in passenger
numbers and flights, it is necessary to improve the efficiency with which the
available resources are used.

[Air Traffic Flow Management (ATFM)](https://www.icao.int/airnavigation/IMP/Documents/9971%20Collaborative%20Flight%20and%20Flow%20Informaiton.pdf)
is the discipline that assesses future air traffic movements, and schedules that
traffic to make best use of available resources. The application of a set of rules
that schedules aircraft across resources over a period of time is known as a
Traffic Management Initiative (TMI). There are different kinds of TMIs, one being
a Ground Delay Program (GDP): hold aircraft on the ground at their departure point
such that after take off they are able to proceed to their destination without
being placed in a holding pattern prior to arrival. An aircraft holding in the air
is using significant amounts of fuel, increasing costs for the operator and
increasing environmental impact due to greater emissions.

A GDP assesses the aircraft bound for an airport based on flight schedules, allocates
landing times, and then back calculates to determine the best take off time for an
aircraft to ensure when it reaches its destination it will not be in conflict with
other aircraft attempting to land.

## The Problem Statement

The particular TMI we will look at is a departure program; that is, scheduling
aircraft departing an airport. Such a program may be conducted to ensure an
ordered sequence of departures. For example, during the mining boom in Western
Australia, many aircraft would depart the capital, Perth, for remote mining
sites. We have many aircraft departing one airport, and heading to a variety of
destinations with low traffic volumes. In a free for all situation, the aircraft
will leave their gates according to their schedule, resulting in congestion on
taxiways as aircraft queue for take off. Individual flights have no motivation to
wait for a suitable slot, since others will simply leave their gate to fill the
gap. Congestion is not the only problem; aircraft sitting on the taxiway burn fuel
hence there is increased cost for the aircraft operator, and greater environmental
impact from the increased emissions.

A departure program allocates a take off time to each aircraft so the operator is
informed beforehand when they are allowed to take off. This provides the aircraft
operator with more certainty since they know exactly when the flight will depart
and hence can better predict arrival time for planning of subsequent flight legs.
A number of constraints must be satisfied by the departure program:
- Specified flights wish to depart an airport.
  - The flights that plan to depart during the period of the TMI.
- Each flight may only take off from certain runways.
  - Larger aircraft may not be able to take off from shorter runways.
- Each flight has a preferred take off time.
  - The time the aircraft operator would ideally like their flight to depart.
- Each flight must take off in a nominated time window.
  - Aircraft operators have schedules to meet; the allocated take off time must not be too
  far from the scheduled time.
- Only certain runways are available.
  - The configuration of resources dictates which of the runways at an airport are available
  for use.
- Each runway has a maximum rate at which departures can occur.
  - The rates may differ for different runways. Rate is impacted by factors such as the forecast
  weather and airport noise restrictions.
- The program occurs over a fixed interval.
  - A program need only run at times when there is likely to be competition for resources.

Given these constraints, the problem then is to:
- Allocate a runway and target take off time to as many flights as possible such that the
constraints are satisfied. Flights should be allocated a time as close as possible to their
preferred time.

## The Specification
-/

import LeanSpec.lib.Temporal
import LeanSpec.lib.Util

open Std Std.Map Temporal

namespace TMI

/-
First some basic types that identify airports, flights and runways. There are rules
around how these identifiers are formed, but for this specification it is sufficient
that different identifiers can be distinguished.

### Designator of an Airport
-/
abbrev AirportDesig := String

/-
### Identifier of a Flight
-/
abbrev FlightId := String

/-
### Designator of a Runway
-/
abbrev RunwayDesig := String

/-
### Flight Departure

The `FlightDeparture` type captures information concerning a flight that is pertinent to the
determination of departure slot allocation for a TMI. In a wider context, there is far more
information relevant to a flight, but here we abstract only the necessary details.
-/
structure FlightDeparture where
  -- The runways the flight is able to use.
  canUse    : List RunwayDesig
  -- The operator's preferred take off time for the flight.
  preferred : DTG
  -- The period of time during which the flight can reasonably take off.
  window    : Interval
  -- The flight must be able to use at least one runway.
  inv₁      : canUse ≠ ∅
  -- The preferred take off time must occur within the window.
  inv₂      : preferred ∈ window

/-
Notes:
- Field `canUse` is the runways (with respect to the departure TMI airport) the
flight is able to use. A flight, based on the type of aircraft used, may only be
able to use certain runways; an A380, for example, would not be able to take off
or land on short runways.
- It is not possible to allocate every flight its preferred take off time, but
operators have schedules to adhere to, and subsequent legs the aircraft must
conduct, so an acceptable take off window is specified. The flight must not be
allocated a time outside the window.
- To present an alternative approach to invariants, in this specification each
constraint is captured in a distinct subscripted `inv` field.

Traditionally, structures (records) are used to model data consisting of multiple disparate elements.
Dependent types introduce the capability to directly encode constraints that relate the
elements of a type. The consequence is that instances of the type that structurally look
like elements of the type are excluded because they fail to satisfy the constraints.

In the case of `FlightDeparture`, the empty list is of type `List RunwayDesig`, but field
`canUse` will never be the empty list as `inv₁` would not be satisfied. The consequence of
the invariant is a flight cannot be considered if it does not nominate at least one runway
from which it can take off.

### Runway Rate

The runway rate determines how frequently an aircraft can take off from a runway.
This is modelled as a duration, being the minimum period of time between successive
take offs.
-/
abbrev Rate := Duration

/-
Each relevant runway is mapped to the rate it can accommodate.
-/
abbrev RunwayRates := RunwayDesig ⟹ Rate

/-
Note: `A ⟹ B` is the type of finite maps from `A` to `B` (defined in [Util](lib/Util.md)).

### TMI Configuration

A TMI configuration is all the information necessary to calculate a departure TMI,
consisting of information relevant to the airport, and the flights that wish to
depart from the airport during the TMI.
-/
structure TMIConfig where
  -- The designator of the airport at which the TMI is run.
  airport : AirportDesig
  -- The period of time over which the TMI runs.
  period  : Interval
  -- The flights that desire to take off within the period of the TMI.
  flights : FlightId ⟹ FlightDeparture
  -- The rates of the runways that participate in the TMI.
  rates   : RunwayRates
  -- The take off window of a proposed flight must fall within the TMI period.
  inv₁    : ∀ f ∈ flights.range, f.window ∩ period ≠ ∅
  -- A flight must be able to take off from one of the participating runways.
  inv₂    : ∀ f ∈ flights.range, f.canUse ∩ rates.domain ≠ ∅

/-
### Slot

A slot is a point in time at which a runway is available to an aircraft for take off.
-/
structure Slot where
  -- The runway designator.
  rwy  : RunwayDesig
  -- The target take off time.
  ttot : DTG

/-
### Flight Allocation

The result of running a departure TMI (GDP) is a map from flights to their slots
(allocated runways and take off times) such that the problem constraints are satisfied.
-/
structure FlightAllocation (cfg : TMIConfig) where
  -- The allocation of flight departures to slots.
  gdp  : FlightId ⟹ Slot
  -- Any flight in the GDP must be drawn from the TMI configuration.
  inv₁ : gdp.domain ⊆ cfg.flights.domain
  -- The runway allocated to a flight must be a participant in the TMI.
  inv₂ : ∀ slot ∈ gdp.range, slot.rwy ∈ cfg.rates.domain
  -- The runway allocated to a flight must be one of the runways it can use.
  inv₃ : ∀ fsl ∈ gdp, ∀ fdep ∈ cfg.flights,
           fsl.1 = fdep.1 → fsl.2.rwy ∈ fdep.2.canUse
  -- The target time allocated to a flight must fall within its window.
  inv₄ : ∀ fsl ∈ gdp, ∀ fdep ∈ cfg.flights,
           fsl.1 = fdep.1 → fsl.2.ttot ∈ fdep.2.window
  -- The target time allocated to a flight must fall within the TMI period.
  inv₅ : ∀ slot ∈ gdp.range, slot.ttot ∈ cfg.period
  -- Two flights allocated the same runway must depart at least the minimum duration apart.
  inv₆ : ∀ fsl₁ ∈ gdp, ∀ fsl₂ ∈ gdp, ∀ fr ∈ cfg.rates,
           fsl₁.1 ≠ fsl₂.1 ∧ fsl₁.2.rwy = fsl₂.2.rwy ∧ fr.1 = fsl₁.2.rwy →
             fsl₁.2.ttot - fsl₂.2.ttot ≥ fr.2

/-
As noted earlier, structures can contain constraints to which the instances must adhere.
Dependent types allow us to take this a step further. `FlightAllocation` is dependent on
(parameterised by) `TMIConfig`. As a result, the constraints of the type are not just
restricted to the fields of the type being defined, they can also specify relationships
between the argument type and the type being defined. In the case of `FlightAllocation`, every
constraint is concerned with the relationship to `TMIConfig`.

Field `gdp` of `FlightAllocation` is the only _data_ field; all others are invariants. The effect
of this definition is that for a given `cfg : TMIConfig`, the elements of type
`FlightAllocation cfg` are all, and only, those allocations of flights to slots that satisfy
the problem constraints.

### Cost

To complete the specification, we need the concept of a cost of a departure TMI.
There are many possible allocations that meet the constraints. The cost function
decides which one to select.

In an operational situation, the best cost function is far from clear, and would
likely require some investigation and prototyping. In this specification,
we adopt a fairly simple cost function for demonstration purposes. The cost function
needs to take account of both those flights that are allocated slots in the GDP, and
those that are omitted:
- the cost of an included flight increases the further the allocated time is from the preferred time;
- the cost of an excluded flight is generally greater than the cost of an included flight.

The deviation assigned to a flight that was allocated a slot in the TMI is
the duration between its preferred time and its allocated time. Duration is
expressed in seconds, so the greater the duration, the greater the cost.
-/
def allocatedDeviation (flight : FlightDeparture) (slot : Slot) : Duration :=
  flight.preferred - slot.ttot

/-
If an omitted flight's window only partly overlaps the TMI period, there is still the
possibility it may be able to take off in its operational window, but outside the
TMI period. If an omitted flight's window is wholly within the TMI period, the
aircraft operator has a scheduling problem to solve. Consequently, for an omitted flight:

- if its window is fully within the TMI period, the cost is the duration of the window;
- if the window is partly outside the TMI period, the cost is half the duration of the window.
-/
def omittedDeviation (period window : Interval) : Duration :=
  let d := window.durationOf
  if window ⊆ period then d else d/2

/-
The deviations for all flights that requested a take off during the period of the TMI.
-/
def deviations (cfg : TMIConfig) (alloc : FlightAllocation cfg) : List Duration :=
  let deviation (fdep : FlightId × FlightDeparture) : Duration :=
        match alloc.gdp.find? fdep.1 with
        | none      => omittedDeviation cfg.period fdep.2.window
        | some slot => allocatedDeviation fdep.2 slot
  cfg.flights.toList.map deviation

/-
The `cost` of a TMI is the sum of the costs of the flights that requested a take off
during the TMI.
-/
def cost (cfg : TMIConfig) (alloc : FlightAllocation cfg) : Duration :=
  (deviations cfg alloc).add 0

/-
### Departure TMI

Combining the components above, the departure TMI can be specified as:
- the optimal allocation, that is, of all allocations that satisfy the configuration, the (not
necessarily unique) allocation whose cost is no greater than any other.
-/
def DepartureTMI (cfg : TMIConfig) :=
  { opt : FlightAllocation cfg // ∀ alloc : FlightAllocation cfg, cost cfg opt ≤ cost cfg alloc }

/-
## Further Discussion

We finish with some further discussion on aspects of the specification.

### More Concise Specification

There is a great deal of repetition in the specification of the invariants of type
`FlightAllocation`, which generally occur in the quantified variables and pre-conditions.
We can reduce that repetition by merging invariants as follows:
-/
structure FlightAllocation₁ (cfg : TMIConfig) where
  -- The allocation of flights to slots.
  gdp  : FlightId ⟹ Slot
  -- Any flight in the GDP must be drawn from the TMI configuration.
  inv₁ : gdp.domain ⊆ cfg.flights.domain
  -- The runway allocated to a flight must be a participant in the TMI.
  -- The target time allocated to a flight must fall within the TMI period.
  -- The runway allocated to a flight must be one of the runways it can use.
  -- The target time allocated to a flight must fall within its window.
  inv₂ : ∀ fsl ∈ gdp,
           fsl.2.rwy ∈ cfg.rates.domain ∧
           fsl.2.ttot ∈ cfg.period ∧
           ∀ fdep ∈ cfg.flights, fsl.1 = fdep.1 →
             fsl.2.rwy ∈ fdep.2.canUse ∧
             fsl.2.ttot ∈ fdep.2.window
  -- Two flights allocated the same runway must depart at least the minimum duration apart.
  inv₃ : ∀ fsl₁ ∈ gdp, ∀ fsl₂ ∈ gdp, ∀ fr ∈ cfg.rates,
           fsl₁.1 ≠ fsl₂.1 ∧ fsl₁.2.rwy = fsl₂.2.rwy ∧ fr.1 = fsl₁.2.rwy →
             fsl₁.2.ttot - fsl₂.2.ttot ≥ fr.2

/-
There are now three rather than six invariants, and it is more concise. The separate approach
was taken to provide a clearer map from the specification to the informal description of the
constraints. In addition, keeping them separate makes it easier to focus on individual
constraints.

### Non-Dependent Approach

`FlightAllocation` is a dependent type that only admits an element if it satisfies the invariants.
The initial approach was more traditional with `FlightAllocation` defined as a simple map:
-/
abbrev FlightAllocation₂ := FlightId ⟹ Slot

/-
This type admits anything that is structurally a map from `FlightId` to `Slot`,
hence includes things like:
- identifiers that do not relate to a flight;
- slots referring to runways that do not exist.

It is then necessary to define a property `Satisfies`, external to the type definition,
that specifies when a flight allocation satisfies a TMI configuration (that is, the
`FlightAllocation` is a valid solution to the `TMIConfig`).
-/
def Satisfies (cfg : TMIConfig) (alloc : FlightAllocation₂) :=
  alloc.domain ⊆ cfg.flights.domain ∧
  (∀ slot ∈ alloc.range, slot.rwy ∈ cfg.rates.domain) ∧
  (∀ fsl ∈ alloc, ∀ fdep ∈ cfg.flights,
    fsl.1 = fdep.1 → fsl.2.rwy ∈ fdep.2.canUse) ∧
  (∀ fsl ∈ alloc, ∀ fdep ∈ cfg.flights,
    fsl.1 = fdep.1 → fsl.2.ttot ∈ fdep.2.window) ∧
  (∀ slot ∈ alloc.range, slot.ttot ∈ cfg.period) ∧
  (∀ fsl₁ ∈ alloc, ∀ fsl₂ ∈ alloc, ∀ fr ∈ cfg.rates,
    fsl₁.1 ≠ fsl₂.1 ∧ fsl₁.2.rwy = fsl₂.2.rwy ∧ fr.1 = fsl₁.2.rwy →
      fsl₁.2.ttot - fsl₂.2.ttot ≥ fr.2)

/-
Note that, other than some minor syntactic differences, the constraints expressed by
`Satisfies` are exactly the invariants of type `FlightAllocation`.

The dependent approach allows the constraints to be located with the data they refer to,
rather than elsewhere in the specification, which aids comprehension. Further, the dependent
approach allows the types to be more tightly defined, and as a result the specification of
functions over those types tends to be simpler.

## Exercises

- Small changes to specifications can have major effects. What would happen if the
specification was changed such that the cost function only considered flights that
are included in the TMI? That is, change `deviations` to:
-/
def deviations₁ (cfg : TMIConfig) (alloc : FlightAllocation cfg) : List Duration :=
  let deviation (fdep : FlightId × FlightDeparture) : Duration :=
        match  alloc.gdp.find? fdep.1 with
        | none      => 0
        | some slot => allocatedDeviation fdep.2 slot
  cfg.flights.toList.map deviation
/-
- There has been a requirements change. A flight must not take off prior to its
preferred time, though it can after its preferred time. Change the specification to
satisfy the new requirement.

- It is always instructive to consider boundary cases. Say a TMI was run with a configuration
in which no flights are specified. That is, `flights : FlightId ⟹ FlightDeparture` is the empty map.
Is a solution that meets the specification still possible?

- Another boundary case is when no runways rates are specified. That is, `rates : RunwayRates` is
the empty map. Is a solution that meets the specification still possible? Is there any relationship
between this and the `flights` item?

- What is the impact on the specification if the constraint `inv₁ : canUse ≠ ∅` on type
`FlightDeparture` is removed?

- An alternative approach to evaluation of cost is to maximise the number of
passengers that are able to depart during the TMI. Modify the specification to
implement this approach to cost. Hint: you will have to change `FlightDeparture`.
(If you are a freight carrier you are out of luck.)
-/
end TMI


import for_mathlib.algebra.homology.derived_category

noncomputable theory

open category_theory category_theory.category category_theory.pretriangulated
  category_theory.limits

namespace homological_complex

/- to be moved to algebra.homology.homology (and expanded) -/

variables {C ι : Type*} {c : complex_shape ι} [category C] [has_zero_morphisms C]

abbreviation cycles (K : homological_complex C c) (i : ι) [K.has_homology i] : C :=
((short_complex_functor C c i).obj K).cycles

abbreviation cycles_i (K : homological_complex C c) (i : ι) [K.has_homology i] :
  K.cycles i ⟶ K.X i :=
((short_complex_functor C c i).obj K).cycles_i

@[simp, reassoc]
lemma cycles_i_d (K : homological_complex C c) (i j : ι) [K.has_homology i] :
  K.cycles_i i ≫ K.d i j = 0 :=
begin
  by_cases c.rel i j,
  { have hj := c.next_eq' h,
    subst hj,
    apply short_complex.cycles_i_g, },
  { rw [K.shape _ _ h, comp_zero] },
end

def lift_cycles (K : homological_complex C c) {A : C} {n₀ : ι} [K.has_homology n₀]
  (z : A ⟶ K.X n₀) (n₁ : ι) (hn₁ : c.rel n₀ n₁) (hz : z ≫ K.d n₀ n₁ = 0) :
    A ⟶ K.cycles n₀ :=
short_complex.lift_cycles _ z begin
  have hn₁ := c.next_eq' hn₁,
  subst hn₁,
  exact hz,
end

@[simp, reassoc]
lemma lift_cycles_i (K : homological_complex C c) {A : C} {n₀ : ι} [K.has_homology n₀]
  (z : A ⟶ K.X n₀) (n₁ : ι) (hn₁ : c.rel n₀ n₁) (hz : z ≫ K.d n₀ n₁ = 0) :
  K.lift_cycles z n₁ hn₁ hz ≫ K.cycles_i n₀ = z :=
short_complex.lift_cycles_i _ _ _

lemma eq_lift_cycles_i (K : homological_complex C c) {A : C} {n₀ : ι} [K.has_homology n₀]
  (z : A ⟶ K.cycles n₀) (n₁ : ι) (hn₁ : c.rel n₀ n₁) :
  ∃ (z' : A ⟶ K.X n₀) (hz' : z' ≫ K.d n₀ n₁ = 0),
    z = K.lift_cycles z' n₁ hn₁ hz' :=
⟨z ≫ K.cycles_i n₀, by simp, by simp [← cancel_mono (K.cycles_i n₀)]⟩

abbreviation cycles_map {K L : homological_complex C c} (φ : K ⟶ L) (i : ι)
  [K.has_homology i] [L.has_homology i] :
  K.cycles i ⟶ L.cycles i :=
short_complex.cycles_map ((short_complex_functor C c i).map φ)

@[simp, reassoc]
lemma lift_cycles_comp_cycles_map {K L : homological_complex C c} {A : C} {n₀ : ι}
  [K.has_homology n₀] [L.has_homology n₀] (z : A ⟶ K.X n₀) (n₁ : ι)
  (hn₁ : c.rel n₀ n₁) (hz : z ≫ K.d n₀ n₁ = 0) (φ : K ⟶ L) :
  K.lift_cycles z n₁ hn₁ hz ≫ cycles_map φ n₀ =
    L.lift_cycles (z ≫ φ.f n₀) n₁ hn₁
    (by rw [assoc, φ.comm, reassoc_of hz, zero_comp]) :=
short_complex.lift_cycles_comp_cycles_map _ _ _ _

abbreviation homology_π (K : homological_complex C c) (i : ι) [K.has_homology i] :
  K.cycles i ⟶ K.homology i :=
((short_complex_functor C c i).obj K).homology_π

@[simp, reassoc]
lemma homology_π_naturality {K L : homological_complex C c} (φ : K ⟶ L) (i : ι)
  [K.has_homology i] [L.has_homology i] :
  K.homology_π i ≫ homology_map φ i = cycles_map φ i ≫ L.homology_π i :=
short_complex.homology_π_naturality _

variables (C c)

@[simps]
def _root_.cycles_functor (i : ι) [category_with_homology C] :
  homological_complex C c ⥤ C :=
  short_complex_functor C c i ⋙ short_complex.cycles_functor C

end homological_complex

variables {C : Type*} [category C] [abelian C]

namespace derived_category

@[reassoc]
lemma homology_functor_factors_hom_naturality {K L : cochain_complex C ℤ} (φ : K ⟶ L) (n : ℤ) :
  (homology_functor C n).map (Q.map φ) ≫ (homology_functor_factors C n).hom.app L =
    (homology_functor_factors C n).hom.app K ≫ homology_map φ n :=
(homology_functor_factors C n).hom.naturality φ

@[reassoc]
lemma homology_functor_factors_inv_naturality {K L : cochain_complex C ℤ} (φ : K ⟶ L) (n : ℤ) :
  homology_map φ n ≫ (homology_functor_factors C n).inv.app L =
    (homology_functor_factors C n).inv.app K ≫ (homology_functor C n).map (Q.map φ) :=
(homology_functor_factors C n).inv.naturality φ

end derived_category

namespace cochain_complex

variable (C)
def shift_cycles_functor_iso [abelian C] (n k m : ℤ) (h : k + n = m) :
  category_theory.shift_functor _ n ⋙ cycles_functor C (complex_shape.up ℤ) k ≅
    cycles_functor C _ m :=
(functor.associator _ _ _).symm ≪≫
  iso_whisker_right (shift_short_complex_functor_iso C _ _ _ h) _

variable {C}

lemma shift_cycles_functor_iso_hom_app [abelian C] (n k m : ℤ) (h : k + n = m)
  (K : cochain_complex C ℤ) :
    (shift_cycles_functor_iso C n k m h).hom.app K =
    short_complex.cycles_map ((shift_short_complex_functor_iso C n k m h).hom.app K) :=
id_comp _

lemma shift_cycles_functor_iso_hom_app_comp_cycles_i [abelian C] (n k m : ℤ) (h : k + n = m)
  (K : cochain_complex C ℤ) :
  (shift_cycles_functor_iso C n k m h).hom.app K ≫ K.cycles_i m =
  K⟦n⟧.cycles_i k ≫ (K.shift_functor_obj_X_iso n k m h.symm).hom :=
begin
  have eq := (short_complex.cycles_i_nat_trans C).naturality
    ((shift_short_complex_functor_iso C _ _ _ h).hom.app K),
  dsimp at eq,
  rw [shift_cycles_functor_iso_hom_app, eq],
  dsimp [shift_short_complex_functor_iso],
  simpa only [shift_eval_hom_app_eq],
end

lemma unshift_cocycle (K : cochain_complex C ℤ) (r : ℤ) {A : C} {n₀ : ℤ}
  (z : A ⟶ K⟦r⟧.X n₀) (n₁ : ℤ) (hn₁ : n₁ = n₀ + 1)
  (hz : z ≫ K⟦r⟧.d n₀ n₁ = 0) (n₀' : ℤ) (hn₀' : n₀' = n₀ + r) (n₁' : ℤ) :
  (z ≫ (K.shift_functor_obj_X_iso r n₀ n₀' hn₀').hom) ≫ K.d n₀' n₁' = 0 :=
begin
  by_cases hn₁' : n₁' = n₁ + r,
  { substs hn₀' hn₁',
    dsimp [homological_complex.X_iso_of_eq, iso.refl] at ⊢ hz,
    rw [linear.comp_smul] at hz,
    erw [assoc, id_comp, ← cancel_epi (preadditive.mul_iso ((-1 : units ℤ)^r) (iso.refl A)).hom,
      comp_zero, preadditive.mul_iso_hom, iso.refl_hom, preadditive.zsmul_comp, id_comp, hz], },
  { rw [K.shape, comp_zero],
    change _ ≠ _,
    exact λ h, hn₁' (by linarith), },
end

@[reassoc]
lemma shift_lift_cycles (K : cochain_complex C ℤ) (r : ℤ) {A : C} {n₀ : ℤ}
  (z : A ⟶ K⟦r⟧.X n₀) (n₁ : ℤ) (hn₁ : (complex_shape.up ℤ).rel n₀ n₁)
    (hz : z ≫ K⟦r⟧.d n₀ n₁ = 0) (n₀' : ℤ) (hn₀' : n₀' = n₀ + r) :
    homological_complex.lift_cycles (K⟦r⟧) z n₁ hn₁ hz =
      K.lift_cycles (z ≫ (K.shift_functor_obj_X_iso r n₀ n₀' hn₀').hom) (n₀'+1) rfl
      (K.unshift_cocycle r z n₁ hn₁.symm hz n₀' hn₀' _) ≫
      (shift_cycles_functor_iso C r n₀ n₀' hn₀'.symm).inv.app K :=
begin
  simp only [← cancel_mono ((shift_cycles_functor_iso C r n₀ n₀' hn₀'.symm).hom.app K), assoc,
    iso.inv_hom_id_app, ← cancel_mono (homological_complex.cycles_i K n₀')],
  dsimp,
  simpa only [id_comp, homological_complex.lift_cycles_i,
    shift_cycles_functor_iso_hom_app_comp_cycles_i _ _ _  hn₀'.symm K,
    homological_complex.lift_cycles_i_assoc],
end

@[reassoc]
lemma shift_homology_π (K : cochain_complex C ℤ) (r n₀ n₀': ℤ) (hn₀' : n₀' = n₀ + r) :
  homological_complex.homology_π
    ((category_theory.shift_functor (cochain_complex C ℤ) r).obj K) n₀ =
    (shift_cycles_functor_iso C r n₀ n₀' hn₀'.symm).hom.app K ≫
      homological_complex.homology_π K n₀' ≫
      (shift_homology_functor_iso C r n₀ n₀' hn₀'.symm).inv.app K :=
begin
  simp only [← cancel_mono ((shift_homology_functor_iso C r n₀ n₀' hn₀'.symm).hom.app K),
    assoc, iso.inv_hom_id_app, shift_cycles_functor_iso_hom_app],
  erw comp_id,
  simpa only [shift_homology_functor_iso_hom_app]
    using short_complex.homology_π_naturality
      ((shift_short_complex_functor_iso C r n₀ n₀' hn₀'.symm).hom.app K),
end

@[reassoc]
lemma shift_lift_cycles_comp_homology_π (K : cochain_complex C ℤ) (r : ℤ) {A : C} {n₀ : ℤ}
  (z : A ⟶ K⟦r⟧.X n₀) (n₁ : ℤ) (hn₁ : (complex_shape.up ℤ).rel n₀ n₁)
    (hz : z ≫ K⟦r⟧.d n₀ n₁ = 0) (n₀' : ℤ) (hn₀' : n₀' = n₀ + r) :
  homological_complex.lift_cycles (K⟦r⟧) z n₁ hn₁ hz ≫ K⟦r⟧.homology_π n₀ =
  K.lift_cycles (z ≫ (K.shift_functor_obj_X_iso r n₀ n₀' hn₀').hom) (n₀'+1) rfl
    (K.unshift_cocycle r z n₁ hn₁.symm hz n₀' hn₀' _) ≫
    K.homology_π n₀' ≫ (shift_homology_functor_iso C r n₀ n₀' hn₀'.symm).inv.app K :=
by simp only [shift_lift_cycles K r z n₁ hn₁ hz n₀' hn₀', assoc,
  shift_homology_π K r n₀ n₀' hn₀', iso.inv_hom_id_app_assoc]

namespace homology_sequence

variables {C} {S : short_complex (cochain_complex C ℤ)} (ex : S.short_exact)

include ex

lemma ex₂ (n : ℤ) :
  (short_complex.mk (homology_map S.f n) (homology_map S.g n)
    (by rw [← homology_map_comp, S.zero, _root_.homology_map_zero])).exact :=
begin
  refine (short_complex.exact_iff_of_iso _).1
    (derived_category.homology_sequence.ex₂ (derived_category.triangle_of_ses_dist ex) n),
  exact short_complex.mk_iso
    ((derived_category.homology_functor_factors C n).app _)
    ((derived_category.homology_functor_factors C n).app _)
    ((derived_category.homology_functor_factors C n).app _)
    (derived_category.homology_functor_factors_hom_naturality S.f n).symm
    (derived_category.homology_functor_factors_hom_naturality S.g n).symm,
end

def δ (n₀ n₁ : ℤ) (h : n₁ = n₀+1) :
  S.X₃.homology n₀ ⟶ S.X₁.homology n₁ :=
(derived_category.homology_functor_factors C n₀).inv.app S.X₃ ≫
  derived_category.homology_sequence.δ (derived_category.triangle_of_ses_dist ex) n₀ n₁ h ≫
  (derived_category.homology_functor_factors C n₁).hom.app S.X₁

@[simp, reassoc]
lemma δ_comp (n₀ n₁ : ℤ) (h : n₁ = n₀+1) :
  δ ex _ _ h ≫ homology_map S.f n₁  = 0 :=
begin
  dsimp only [δ],
  simp only [assoc, ← derived_category.homology_functor_factors_hom_naturality],
  erw [derived_category.homology_sequence.δ_comp_assoc, zero_comp, comp_zero],
end

@[simp, reassoc]
lemma comp_δ (n₀ n₁ : ℤ) (h : n₁ = n₀+1) :
  homology_map S.g n₀ ≫ δ ex _ _ h = 0 :=
begin
  dsimp only [δ],
  rw derived_category.homology_functor_factors_inv_naturality_assoc,
  erw derived_category.homology_sequence.comp_δ_assoc (derived_category.triangle_of_ses_dist ex),
  rw [zero_comp, comp_zero],
end

lemma ex₃ (n₀ n₁ : ℤ) (h : n₁ = n₀+1) :
  (short_complex.mk (homology_map S.g n₀) (δ ex _ _ h) (by simp)).exact :=
begin
  refine (short_complex.exact_iff_of_iso _).1
    (derived_category.homology_sequence.ex₃ (derived_category.triangle_of_ses_dist ex) n₀ n₁ h),
  exact short_complex.mk_iso
    ((derived_category.homology_functor_factors C n₀).app _)
    ((derived_category.homology_functor_factors C n₀).app _)
    ((derived_category.homology_functor_factors C n₁).app _)
    (derived_category.homology_functor_factors_hom_naturality S.g n₀).symm
    (by { dsimp [δ], simp only [iso.hom_inv_id_app_assoc]}),
end

lemma ex₁ (n₀ n₁ : ℤ) (h : n₁ = n₀+1) :
  (short_complex.mk (δ ex _ _ h) (homology_map S.f n₁)  (by simp)).exact :=
begin
  refine (short_complex.exact_iff_of_iso _).1
    (derived_category.homology_sequence.ex₁ (derived_category.triangle_of_ses_dist ex) n₀ n₁ h),
  exact short_complex.mk_iso
    ((derived_category.homology_functor_factors C n₀).app _)
    ((derived_category.homology_functor_factors C n₁).app _)
    ((derived_category.homology_functor_factors C n₁).app _)
    (by { dsimp [δ], simp only [iso.hom_inv_id_app_assoc], })
    (derived_category.homology_functor_factors_hom_naturality S.f n₁).symm,
end

end homology_sequence

variables {C} {S : short_complex (cochain_complex C ℤ)} (ex : S.short_exact)

lemma from_mapping_cone_of_ses_comp_δ (n₀ n₁ : ℤ) (h : n₁ = n₀ + 1) :
  homology_map (cochain_complex.from_mapping_cone_of_ses ex) n₀ ≫
    homology_sequence.δ ex n₀ n₁ h =
  homology_map (mapping_cone.δ S.f) n₀ ≫
    (shift_homology_functor_iso C 1 n₀ n₁ h.symm).hom.app S.X₁ :=
begin
  dsimp only [homology_sequence.δ, derived_category.homology_sequence.δ,
    derived_category.triangle_of_ses, triangle.mk, derived_category.triangle_of_ses_δ,
    derived_category.mapping_cone_triangle, derived_category.mapping_cone_δ],
  simp only [assoc, derived_category.homology_functor_factors_inv_naturality_assoc,
    functor.map_comp, functor.map_inv, is_iso.hom_inv_id_assoc,
    derived_category.shift_homology_functor_iso_hom_app_Q_obj,
    iso.inv_hom_id_app, comp_id],
  simp only [← functor.map_comp_assoc, iso.hom_inv_id_app, functor.map_comp],
  erw [category_theory.functor.map_id, comp_id,
    ← derived_category.homology_functor_factors_inv_naturality_assoc,
    iso.inv_hom_id_app_assoc],
end

namespace mapping_cone

open hom_complex

@[simp, reassoc]
lemma cycles_i_fst_d {K L : cochain_complex C ℤ} (φ : K ⟶ L) (n₀ n₁ n₂ : ℤ) (h : n₁ = n₀ + 1) :
  (mapping_cone φ).cycles_i n₀ ≫ (fst φ : cochain (mapping_cone φ) K 1).v n₀ n₁ h ≫
    K.d n₁ n₂ = 0 :=
begin
  by_cases hn₂ : n₁ + 1 = n₂,
  { have eq := (mapping_cone φ).cycles_i_d n₀ n₁,
    simpa only [assoc, d_fst _ _ _ _ h, zero_comp, preadditive.comp_neg, neg_eq_zero]
      using eq =≫ (fst φ : cochain (mapping_cone φ) K 1).v n₁ n₂ hn₂.symm, },
  { simp only [K.shape _ _ hn₂, comp_zero], },
end

lemma homology_map_δ_on_a_cocycle {K L : cochain_complex C ℤ} (φ : K ⟶ L) {A : C} {n₀ : ℤ}
  (z : A ⟶ (mapping_cone φ).cycles n₀) (n₁ : ℤ) (h : n₁ = n₀ + 1) :
  z ≫ (mapping_cone φ).homology_π n₀ ≫ homology_map (mapping_cone.δ φ) n₀ ≫
    (shift_homology_functor_iso C 1 n₀ n₁ h.symm).hom.app K =
    K.lift_cycles (-z ≫ (mapping_cone φ).cycles_i n₀ ≫
      (mapping_cone.fst φ : cochain (mapping_cone φ) K 1).v n₀ n₁ h) (n₁+1) rfl (by simp) ≫
      K.homology_π n₁ :=
begin
  obtain ⟨z, hz, rfl⟩ := (mapping_cone φ).eq_lift_cycles_i z n₁ h.symm,
  obtain ⟨x, y, eq⟩ := to_decomposition z n₁ h,
  simp only [homological_complex.homology_π_naturality_assoc,
    homological_complex.lift_cycles_i_assoc,
    homological_complex.lift_cycles_comp_cycles_map_assoc,
    shift_lift_cycles_comp_homology_π_assoc _ 1 _ n₁ h.symm _ n₁ h,
    iso.inv_hom_id_app, δ, assoc, cocycle.hom_of_f, cocycle.right_shift_coe, δ_as_cocycle_coe,
    cochain.right_shift_v _ _ _ (zero_add 1).symm n₀ n₀ (add_zero n₀).symm (n₁) h,
    preadditive.neg_comp, preadditive.comp_neg, shift_functor_obj_X_iso, cochain.neg_v,
    iso.inv_hom_id],
  dsimp,
  simp only [comp_id],
end

end mapping_cone

namespace homology_sequence

open hom_complex

lemma comp_δ_eq {n₀ n₁ : ℤ} {A : C} (x₃ : A ⟶ S.X₃.X n₀)
  (x₂ : A ⟶ S.X₂.X n₀) (x₁ : A ⟶ S.X₁.X n₁) (h : n₁ = n₀+1)
    (hx₃ : x₃ ≫ S.X₃.d n₀ n₁ = 0) (hx₂ : x₂ ≫ S.g.f n₀ = x₃)
    (hx₁ : x₁ ≫ S.f.f n₁ = x₂ ≫ S.X₂.d n₀ n₁) :
  S.X₃.lift_cycles x₃ n₁ h.symm hx₃ ≫ S.X₃.homology_π n₀ ≫ (δ ex n₀ n₁ h) =
    S.X₁.lift_cycles x₁ (n₁+1) rfl begin
      haveI : mono (S.f.f (n₁+1)) :=
        (short_complex.short_exact.map_of_exact ex (homological_complex.eval _ _ (n₁+1))).mono_f,
      simp only [← cancel_mono (S.f.f (n₁+1)), assoc, ← S.f.comm, reassoc_of hx₁,
        homological_complex.d_comp_d, comp_zero, zero_comp],
    end ≫ S.X₁.homology_π n₁ :=
begin
  haveI : mono (S.f.f (n₁+1)) :=
    (short_complex.short_exact.map_of_exact ex (homological_complex.eval _ _ (n₁+1))).mono_f,
  have hx₁' : x₁ ≫ S.X₁.d n₁ (n₁ + 1) = 0,
  { simp only [← cancel_mono (S.f.f (n₁+1)), assoc, ← S.f.comm, reassoc_of hx₁,
      homological_complex.d_comp_d, comp_zero, zero_comp], },
  let z : A ⟶ (mapping_cone S.f).cycles n₀ :=
    (mapping_cone S.f).lift_cycles
      (-x₁ ≫ (mapping_cone.inl S.f).v n₁ n₀ (by linarith)
        + x₂ ≫ (mapping_cone.inr S.f).f n₀) n₁ h.symm
      (by simp only [mapping_cone.to_ext_iff _ _ _ rfl,
        assoc, preadditive.add_comp, zero_comp, preadditive.comp_neg,
        preadditive.neg_comp, neg_neg, mapping_cone.inl_fst_assoc, comp_id,
        mapping_cone.d_fst _ _ _ _ h, hx₁', zero_add, mapping_cone.inr_fst_assoc,
        comp_zero, neg_zero, mapping_cone.d_snd _ _ _ h, preadditive.comp_add,
        mapping_cone.inr_snd_assoc, mapping_cone.inl_snd_assoc, hx₁, add_zero, neg_add_self,
        eq_self_iff_true, and_self]),
  have hz₁ : x₁ = -z ≫ homological_complex.cycles_i (mapping_cone S.f) n₀ ≫
    (mapping_cone.fst S.f : cochain (mapping_cone S.f) S.X₁ 1).v n₀ n₁ h,
  { simp only [add_zero, neg_neg, preadditive.add_comp, preadditive.neg_comp, assoc,
      comp_zero, homological_complex.lift_cycles_i_assoc, mapping_cone.inl_fst,
      comp_id, mapping_cone.inr_fst], },
  have hz₂ : z ≫ homological_complex.cycles_map (from_mapping_cone_of_ses ex) n₀ =
    homological_complex.lift_cycles S.X₃ x₃ n₁ h.symm hx₃,
  { rw ← cancel_mono (S.X₃.cycles_i n₀),
    simp only [zero_add, neg_zero, assoc, preadditive.add_comp, preadditive.neg_comp,
      comp_zero, inl_from_mapping_cone_of_ses, inr_from_mapping_cone_of_ses,
      homological_complex.lift_cycles_comp_cycles_map, homological_complex.lift_cycles_i, hx₂], },
  simp only [hz₁, reassoc_of hz₂, ← mapping_cone.homology_map_δ_on_a_cocycle S.f z n₁ h,
    ← from_mapping_cone_of_ses_comp_δ ex n₀ n₁ h,
    homological_complex.homology_π_naturality_assoc],
end

/- Actually, we probably need a more general homology sequence for any complex_shape, which
could be done using the snake lemma, and then `comp_δ_eq` would be used to prove
a comparison lemma between the two connecting maps... -/

end homology_sequence

end cochain_complex