import data.equiv.basic
import tactic

universes u₀ v₀ u₁ v₁ v₂ w w₀ w₁

class liftable (α : Type u₀) (β : (Type v₀)) :=
  (lift {}   : α ≃ β)

-- instance {α} : liftable α (ulift α) :=
-- ⟨ equiv.ulift.symm ⟩

instance ulift.liftable.ulift {α : Type w} : liftable (ulift.{u₀} α) (ulift.{u₁} α) :=
⟨ equiv.trans equiv.ulift equiv.ulift.symm ⟩

class liftable1 (f : (Type u₀ → Type u₁)) (g : Type v₀ → Type v₁) :=
  (up   : Π {α β}, α ≃ β → f α → g β)
  (down : Π {α β}, α ≃ β → g β → f α)
  (up_down : ∀ {α β} (F : α ≃ β) (x : g β), up F (down F x) = x)
  (down_up : ∀ {α β} (F : α ≃ β) (x : f α), down F (up F x) = x)

attribute [simp] liftable1.up_down liftable1.down_up

namespace liftable

@[reducible]
def up' {f : Type v₀ → Type v₁} (g : Type (max u₀ v₀) → Type u₁) [liftable1 f g]
  {α} : f α → g (ulift.{u₀} α) :=
liftable1.up g equiv.ulift.symm

@[reducible]
def down' {f : Type u₀ → Type u₁} {g : Type (max u₀ v₀) → Type v₁} [liftable1 f g]
  {α} : g (ulift α) → f α :=
liftable1.down _ equiv.ulift.symm

@[reducible]
def shift' {f : Type (max w u₀) → Type u₁} {g : Type (max w v₀) → Type v₁} [liftable1 f g]
  {α : Type w} : g (ulift α) → f (ulift α) :=
liftable1.down _ $ equiv.trans equiv.ulift equiv.ulift.symm

end liftable

open ulift

protected lemma prod.map_map {α α' α'' β β' β''}
  (x : α × β) (f : α → α') (f' : α' → α'')
              (g : β → β') (g' : β' → β'') :
  prod.map f' g' (prod.map f g x) = prod.map (f' ∘ f) (g' ∘ g) x :=
by cases x; refl

protected lemma prod.id_map {α β}
  (x : α × β) :
  prod.map (λ x, x) (λ x, x) x = x :=
by cases x; refl

instance : liftable1 id id :=
{ up := λ _ _ F, F
, down := λ _ _ F, F.symm
, up_down := by intros; simp
, down_up := by intros; simp }

def state_t.liftable' {s : Type u₀} {s' : Type u₁} {m m'} [functor m'] [functor m] [is_lawful_functor m'] [is_lawful_functor m]
  [liftable1 m m']
  (F : s ≃ s') :
  liftable1 (state_t s m) (state_t s' m') :=
{ up   := λ _ _ G ⟨ f ⟩, ⟨ λ s, liftable1.up _ (equiv.prod_congr G F) (f $ F.symm s) ⟩
, down := λ _ _ G ⟨ g ⟩, ⟨ λ s, liftable1.down _ (equiv.prod_congr G F) $ g (F s) ⟩
, up_down := by { rintros α β G ⟨ f ⟩, simp! }
, down_up := by { rintros α β G ⟨ g ⟩, simp! [map_map,function.comp] } }

instance {s : Type u₀} {s' : Type u₁} {m m'} [functor m'] [functor m] [is_lawful_functor m'] [is_lawful_functor m]
  [liftable1 m m'] [liftable s s'] :
  liftable1 (state_t s m) (state_t s' m') :=
state_t.liftable' liftable.lift

def reader_t.liftable' {s : Type u₀} {s' : Type u₁} {m : Type u₀ → Type v₀} {m' : Type u₁ → Type v₁}
  [liftable1 m m']
  (F : s ≃ s') :
  liftable1 (reader_t s m) (reader_t s' m') :=
{ up   := λ _ _ G ⟨ f ⟩, ⟨ λ s, liftable1.up _ G (f $ F.symm s) ⟩
, down := λ _ _ G ⟨ g ⟩, ⟨ λ s, liftable1.down _ G $ g $ F s ⟩
, up_down := by { rintros α β G ⟨ f ⟩, simp! }
, down_up := by { rintros α β G ⟨ g ⟩, simp! [map_map,function.comp] } }

instance {s : Type u₀} {s' : Type u₁} {m : Type u₀ → Type v₀} {m' : Type u₁ → Type v₁}
  [liftable1 m m'] [liftable s s'] :
  liftable1 (reader_t s m) (reader_t s' m') :=
reader_t.liftable' liftable.lift

-- namespace liftable

-- variables {f : Type (max u₀ w) → Type u₁} {g : Type (max (max u₀ w) v₀) → Type v₁}
-- variables [liftable f g] [functor g]
-- variable {α : Type w}
-- open functor

-- def up' (x : f (ulift.{u₀} α)) : g (ulift.{max u₀ v₀} α) :=
-- map (ulift.up ∘ ulift.down ∘ ulift.down) $ up x

-- def down' (x : g (ulift.{max u₀ v₀} α)) : f (ulift.{u₀} α) :=
-- down $ map (ulift.up ∘ ulift.up ∘ ulift.down) x

-- variables [is_lawful_functor g]

-- lemma up_down' : ∀ (x : g (ulift.{max u₀ v₀} α)), up' (down' x : f (ulift.{u₀} α)) = x :=
-- by intros; simp [up',down',map_map,function.comp,ulift.up_down]

-- lemma down_up' : ∀ (x : f (ulift.{u₀} α)), down' (up' x : g (ulift.{max u₀ v₀} α)) = x :=
-- by intros; simp [up',down',map_map,function.comp,ulift.up_down]

-- end liftable

section trans
open liftable

-- def liftable.trans
--     {f : Type u₀ → Type u₁}
--     {g : Type v₀ → Type v₁}
--     {h : Type w₀ → Type w₁}
--     [functor h] [is_lawful_functor h]
--     (_ : liftable f g)
--     (_ : liftable g h) :
--   liftable f h :=
-- by refine
--      { up := λ α β G, (up' : g (ulift α) → h (ulift.{max v₀ w} α)) ∘ (up : f α → g (ulift α)),
--        down := λ α β G, (down : g (ulift α) → f α) ∘ (down' : h (ulift.{max v₀ w} α) → g (ulift α)) ,
--        .. };
--      intros; simp [function.comp,up_down',down_up']

end trans

instance : liftable1 option.{u₀} option.{v₁} :=
{ up := λ α β eq, @option.rec _ (λ _, option β) (@none β) (λ x, some $ eq x)
, down := λ α β eq, @option.rec _ (λ _, option α) (@none α) (λ x, some $ eq.symm x)
, up_down := by intros; cases x; simp
, down_up := by intros; cases x; simp }

namespace pliftable

@[reducible]
def up' {f : Type v₀ → Type v₁} (g : Type u₀ → Type u₁) [liftable1 f g] :
  f punit → g punit :=
liftable1.up g equiv.punit_equiv_punit

@[reducible]
def down' {f : Type u₀ → Type u₁} {g : Type v₀ → Type v₁} [liftable1 f g] :
  g punit → f punit :=
liftable1.down _ equiv.punit_equiv_punit

end pliftable


import Stuff.normalizing_properly.category

structure free_cat : Type :=
( toString : String )
deriving DecidableEq

namespace free_cat

inductive hom : (X Y : free_cat) → Type
| id (X : free_cat) : hom X X
| comp' (X Y Z : free_cat)
  (f : hom X Y) (g : String) : hom X Z

instance hom.DecidableEq : {X Y : free_cat} → DecidableEq (hom X Y)
| _, _, hom.id _, hom.id _ => isTrue rfl
| _, _, hom.comp' _ Y _ f₁ g₁, hom.comp' _ Y' _ f₂ g₂ =>
  if hY : Y = Y'
    then by
      subst hY
      exact if hg : g₁ = g₂
        then by
          subst hg
          exact @decidable_of_decidable_of_iff (f₁ = f₂) _ (hom.DecidableEq _ _)
            (by
              apply Iff.intro
              { intro h; rw [h] }
              { intro h; injection h; assumption })
        else isFalse (λ h => by injection h; contradiction)
    else isFalse (λ h => by injection h; contradiction)
| _, _, hom.id _, hom.comp' _ _ _ _ _ => isFalse (λ h => by injection h)
| _, _, hom.comp' _ _ _ _ _, hom.id _ => isFalse (λ h => by injection h)

def mh (X Y : free_cat) (s : String) : hom X Y :=
hom.comp' X X Y (hom.id X) s

def hom.comp : {X Y Z : free_cat} →
  hom X Y → hom Y Z → hom X Z
| _, _, _, f, hom.id _ => f
| _, _, _, f, hom.comp' _ _ _ g h =>
  hom.comp' _ _ _ (comp f g) h

private theorem id_comp : {X Y : free_cat} → (f : hom X Y) →
  (hom.id X).comp f = f
| _, _, hom.id _ => rfl
| _, _, hom.comp' _ _ _ f g => by
rw [hom.comp, id_comp f]

private theorem assoc : {W X Y Z : free_cat} → (f : hom W X) →
  (g : hom X Y) → (h : hom Y Z) →
  (f.comp g).comp h = f.comp (g.comp h)
| _, _, _, _, f, g, hom.id _ => rfl
| _, _, _, _, f, g, hom.comp' _ _ _ h i => by
rw [hom.comp, assoc f g h, hom.comp, hom.comp]

instance : category free_cat :=
{ hom := hom,
  id := hom.id,
  comp := hom.comp,
  id_comp := id_comp,
  comp_id := λ _ => rfl,
  assoc := assoc }

instance {X Y : free_cat} : DecidableEq (X ⟶ Y) :=
hom.DecidableEq

end free_cat


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Init.Meta

namespace Std
-- We put `Range` in `Init` because we want the notation `[i:j]`  without importing `Std`
-- We don't put `Range` in the top-level namespace to avoid collisions with user defined types
structure Range where
  start : Nat := 0
  stop  : Nat
  step  : Nat := 1

instance : Membership Nat Range where
  mem i r := r.start ≤ i ∧ i < r.stop

namespace Range
universe u v

@[inline] protected def forIn {β : Type u} {m : Type u → Type v} [Monad m] (range : Range) (init : β) (f : Nat → β → m (ForInStep β)) : m β :=
  -- pass `stop` and `step` separately so the `range` object can be eliminated through inlining
  let rec @[specialize] loop (fuel i stop step : Nat) (b : β) : m β := do
    if i ≥ stop then
      return b
    else match fuel with
     | 0   => pure b
     | fuel+1 => match (← f i b) with
        | ForInStep.done b  => pure b
        | ForInStep.yield b => loop fuel (i + step) stop step b
  loop range.stop range.start range.stop range.step init

instance : ForIn m Range Nat where
  forIn := Range.forIn

@[inline] protected def forIn' {β : Type u} {m : Type u → Type v} [Monad m] (range : Range) (init : β) (f : (i : Nat) → i ∈ range → β → m (ForInStep β)) : m β :=
  let rec @[specialize] loop (start stop step : Nat) (f : (i : Nat) → start ≤ i ∧ i < stop → β → m (ForInStep β)) (fuel i : Nat) (hl : start ≤ i) (b : β) : m β := do
    if hu : i < stop then
      match fuel with
      | 0   => pure b
      | fuel+1 => match (← f i ⟨hl, hu⟩ b) with
         | ForInStep.done b  => pure b
         | ForInStep.yield b => loop start stop step f fuel (i + step) (Nat.le_trans hl (Nat.le_add_right ..)) b
    else
      return b
  loop range.start range.stop range.step f range.stop range.start (Nat.le_refl ..) init

instance : ForIn' m Range Nat inferInstance where
  forIn' := Range.forIn'

@[inline] protected def forM {m : Type u → Type v} [Monad m] (range : Range) (f : Nat → m PUnit) : m PUnit :=
  let rec @[specialize] loop (fuel i stop step : Nat) : m PUnit := do
    if i ≥ stop then
      pure ⟨⟩
    else match fuel with
     | 0   => pure ⟨⟩
     | fuel+1 => f i; loop fuel (i + step) stop step
  loop range.stop range.start range.stop range.step

instance : ForM m Range Nat where
  forM := Range.forM

syntax:max "[" withoutPosition(":" term) "]" : term
syntax:max "[" withoutPosition(term ":" term) "]" : term
syntax:max "[" withoutPosition(":" term ":" term) "]" : term
syntax:max "[" withoutPosition(term ":" term ":" term) "]" : term

macro_rules
  | `([ : $stop]) => `({ stop := $stop : Range })
  | `([ $start : $stop ]) => `({ start := $start, stop := $stop : Range })
  | `([ $start : $stop : $step ]) => `({ start := $start, stop := $stop, step := $step : Range })
  | `([ : $stop : $step ]) => `({ stop := $stop, step := $step : Range })

end Range
end Std

theorem Membership.mem.upper {i : Nat} {r : Std.Range} (h : i ∈ r) : i < r.stop := by
  simp [Membership.mem] at h
  exact h.2

theorem Membership.mem.lower {i : Nat} {r : Std.Range} (h : i ∈ r) : r.start ≤ i := by
  simp [Membership.mem] at h
  exact h.1


import category_theory.adjunction.basic
import category_theory.limits.preserves.basic
import data.pfun

open category_theory category_theory.functor category_theory.limits

universe u

variables (𝒞 : Type) [category.{0} 𝒞]

inductive bicompletion_aux : bool → Type 1
| of_cat_obj : 𝒞 → bicompletion_aux ff
| limit_obj {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → bicompletion_aux ff)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → bicompletion_aux tt) : bicompletion_aux ff
| colimit_obj {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → bicompletion_aux ff)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → bicompletion_aux tt) : bicompletion_aux ff
| of_cat_hom : Π {X Y : 𝒞}, (X ⟶ Y) → bicompletion_aux tt -- of_cat_obj X ⟶ of_cat_obj Y
| limit_cone_comp {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → bicompletion_aux ff)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → bicompletion_aux tt)
  (X : 𝒟) (Y : bicompletion_aux ff) (f : bicompletion_aux tt) : -- F_obj X ⟶ Y
  bicompletion_aux tt -- limit_obj F_obj F_hom ⟶ Y
| is_limit {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → bicompletion_aux ff)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → bicompletion_aux tt)
  (cone_obj : bicompletion_aux ff)
  (cone : Π (X : 𝒟), bicompletion_aux tt) : -- cone_obj ⟶ F_obj X
  bicompletion_aux tt -- cone_obj → limit_obj F_obj F_hom
| colimit_cocone_comp {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → bicompletion_aux ff)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → bicompletion_aux tt)
  (X : 𝒟) (Y : bicompletion_aux ff) (f : bicompletion_aux tt) : -- Y ⟶ F_obj X
  bicompletion_aux tt -- Y ⟶ colimit_obj F_obj F_hom
| is_colimit {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → bicompletion_aux ff)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → bicompletion_aux tt)
  (cocone_obj : bicompletion_aux ff)
  (cocone : Π (X : 𝒟), bicompletion_aux tt) : -- F_obj X ⟶ cocone_obj
  bicompletion_aux tt -- colimit_obj F_obj F_hom ⟶ cocone_obj

namespace bicompletion_aux

variable {𝒞}

@[simp] def dom : Π (X : bicompletion_aux 𝒞 tt), bicompletion_aux 𝒞 ff
| (@of_cat_hom _ _ X Y f) := of_cat_obj X
| (@limit_cone_comp _ _ 𝒟 _ F_obj F_hom X _ _) := by exactI limit_obj F_obj @F_hom
| (@is_limit _ _ 𝒟 _ F_obj F_hom cone_obj cone) := cone_obj
| (@colimit_cocone_comp _ _ 𝒟 _ F_obj F_hom X Y f) := Y
| (@is_colimit _ _ 𝒟 _ F_obj F_hom cocone_obj cocone) := by exactI colimit_obj F_obj @F_hom

@[simp] def cod : Π (X : bicompletion_aux 𝒞 tt), bicompletion_aux 𝒞 ff
| (@of_cat_hom _ _ X Y f) := of_cat_obj Y
| (@colimit_cocone_comp _ _ 𝒟 _ F_obj F_hom X _ _) := by exactI colimit_obj F_obj @F_hom
| (@is_colimit _ _ 𝒟 _ F_obj F_hom cocone_obj cocone) := cocone_obj
| (@limit_cone_comp _ _ 𝒟 _ F_obj F_hom X Y f) := Y
| (@is_limit _ _ 𝒟 _ F_obj F_hom cone_obj cone) := by exactI limit_obj F_obj @F_hom

variable (𝒞)

def obj₁ : Type 1 := bicompletion_aux 𝒞 ff

variable {𝒞}
variables {𝒟 : Type} [category.{0} 𝒟]

def hom₁ (X Y : obj₁ 𝒞) : Type 1 :=
{ f : bicompletion_aux 𝒞 tt // f.dom = X ∧ f.cod = Y }

def of_cat_obj₁ (X : 𝒞) : obj₁ 𝒞 := of_cat_obj X

def limit_obj₁ (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y)) : obj₁ 𝒞 :=
limit_obj F_obj (λ X Y f, (F_hom f).1)

def colimit_obj₁ (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y)) : obj₁ 𝒞 :=
colimit_obj F_obj (λ X Y f, (F_hom f).1)

def of_cat_hom₁ {X Y : 𝒞} (f : X ⟶ Y) : hom₁ (of_cat_obj X) (of_cat_obj Y) :=
⟨of_cat_hom f, by simp⟩

def limit_cone_comp₁ (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y)) (X : 𝒟)
  {Y : obj₁ 𝒞} (f : hom₁ (F_obj X) Y) :
  hom₁ (limit_obj₁ F_obj @F_hom) Y :=
⟨limit_cone_comp F_obj (λ X Y f, (F_hom f).1) X Y f.1, by simp [limit_obj₁]⟩

def colimit_cocone_comp₁ (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y)) (X : 𝒟)
  {Y : obj₁ 𝒞} (f : hom₁ Y (F_obj X)) :
  hom₁ Y (colimit_obj₁ F_obj @F_hom) :=
⟨colimit_cocone_comp F_obj (λ X Y f, (F_hom f).1) X Y f.1, by simp [colimit_obj₁]⟩

def is_limit₁ (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y))
  (cone_obj : obj₁ 𝒞)
  (cone : Π (X : 𝒟), hom₁ cone_obj (F_obj X)) :
  hom₁ cone_obj (limit_obj₁ F_obj @F_hom) :=
⟨is_limit F_obj (λ X Y f, (F_hom f).1) cone_obj (λ X, (cone X).1), by simp [limit_obj₁]⟩

def is_colimit₁ (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y))
  (cocone_obj : obj₁ 𝒞)
  (cocone : Π (X : 𝒟), hom₁ (F_obj X) cocone_obj) :
  hom₁ (colimit_obj₁ F_obj @F_hom) cocone_obj  :=
⟨is_colimit F_obj (λ X Y f, (F_hom f).1) cocone_obj (λ X, (cocone X).1), by simp [colimit_obj₁]⟩

def id₁_aux (b : bool) (hb : b = ff) (X : bicompletion_aux 𝒞 b) :
  hom₁ (show bicompletion_aux 𝒞 ff, from eq.rec_on hb X)
       (show bicompletion_aux 𝒞 ff, from eq.rec_on hb X) :=
begin
  revert hb,
  refine bicompletion_aux.rec_on X _ _ _ _ _ _ _ _,
  { rintros X h,
    exact of_cat_hom₁ (𝟙 X) },
  { introsI 𝒟 _ F_obj F_hom ih₁ ih₂ _,
    exact ⟨is_limit F_obj @F_hom (limit_obj F_obj @F_hom)
      (λ D, limit_cone_comp F_obj @F_hom D (F_obj D) (ih₁ D rfl).1),
      by simp⟩ },
  { introsI 𝒟 _ F_obj F_hom ih₁ ih₂ _,
    exact ⟨is_colimit F_obj @F_hom (colimit_obj F_obj @F_hom)
      (λ D, colimit_cocone_comp F_obj @F_hom D (F_obj D) (ih₁ D rfl).1),
      by simp⟩ },
  all_goals { intros, contradiction }
end

def id₁ (X : obj₁ 𝒞) : hom₁ X X :=
id₁_aux ff rfl X

@[elab_as_eliminator] def hom_rec_on {motive : bicompletion_aux 𝒞 tt → Sort u}
  (f : bicompletion_aux 𝒞 tt)
  (of_cat_hom : Π {X Y : 𝒞} (f : X ⟶ Y), motive (of_cat_hom f))
  (limit_cone_comp : Π {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → bicompletion_aux 𝒞 ff)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → bicompletion_aux 𝒞 tt) (X : 𝒟) (Y : bicompletion_aux 𝒞 ff)
    (f : bicompletion_aux 𝒞 tt),
    (Π {X Y : 𝒟} (f : by exactI X ⟶ Y), motive (F_hom f)) →
    motive f → motive (by exactI limit_cone_comp F_obj @F_hom X Y f))
  (is_limit : Π {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → bicompletion_aux 𝒞 ff)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → bicompletion_aux 𝒞 tt) (cone_obj : bicompletion_aux 𝒞 ff)
    (cone : 𝒟 → bicompletion_aux 𝒞 tt),
    (Π {X Y : 𝒟} (f : by exactI X ⟶ Y), motive (F_hom f)) →
    (Π (X : 𝒟), motive (cone X)) → motive (by exactI is_limit F_obj @F_hom cone_obj cone))
  (colimit_cocone_comp : Π {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → bicompletion_aux 𝒞 ff)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → bicompletion_aux 𝒞 tt) (X : 𝒟) (Y : bicompletion_aux 𝒞 ff)
    (f : bicompletion_aux 𝒞 tt),
    (Π {X Y : 𝒟} (f : by exactI X ⟶ Y), motive (F_hom f)) →
    motive f → motive (by exactI colimit_cocone_comp F_obj @F_hom X Y f))
  (is_colimit : Π {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → bicompletion_aux 𝒞 ff)
   (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → bicompletion_aux 𝒞 tt) (cocone_obj : bicompletion_aux 𝒞 ff)
   (cocone : 𝒟 → bicompletion_aux 𝒞 tt),
     (Π {X Y : 𝒟} (f : by exactI X ⟶ Y), motive (F_hom f)) →
     (Π (X : 𝒟), motive (cocone X)) → motive (by exactI is_colimit F_obj @F_hom cocone_obj cocone)) :
  motive f :=
have ∀ b (f : bicompletion_aux 𝒞 b) (h : b = tt), motive (eq.rec_on h f) :=
  begin
    intros b f,
    refine bicompletion_aux.rec_on f _ _ _ _ _ _ _ _,
    { intros, simp at *, contradiction },
    { intros, simp at *, contradiction },
    { intros, simp at *, contradiction },
    { intros X Y f _,
      exact of_cat_hom f },
    { introsI 𝒟 _ F_obj F_hom X Y f ih₁ ih₂ ih₃ ih₄ _,
      exact limit_cone_comp F_obj @F_hom X Y f (λ X Y f, ih₂ f rfl) (ih₄ rfl) },
    { introsI 𝒟 _ F_obj F_hom cone_obj cone ih₁ ih₂ ih₃ ih₄ _,
      exact is_limit F_obj @F_hom cone_obj cone (λ X Y f, ih₂ f rfl) (λ X, ih₄ X rfl) },
    { introsI 𝒟 _ F_obj F_hom X Y f ih₁ ih₂ ih₃ ih₄ _,
      exact colimit_cocone_comp F_obj @F_hom X Y f (λ X Y f, ih₂ f rfl) (ih₄ rfl) },
    { introsI 𝒟 _ F_obj F_hom cone_obj cone ih₁ ih₂ ih₃ ih₄ _,
      exact is_colimit F_obj @F_hom cone_obj cone (λ X Y f, ih₂ f rfl) (λ X, ih₄ X rfl) },
  end,
this tt f rfl

structure part2 (α : Type 1) : Type 1 :=
(dom : Type)
(get : dom → α)

def part2.none {α : Type 1} : part2 α := ⟨empty, empty.elim⟩

instance : monad part2 :=
{ pure := λ α a, ⟨unit, λ _, a⟩,
  bind := λ α β a f, ⟨Σ (h : a.dom), (f (a.get h)).dom, λ h, (f (a.get h.1)).get h.2⟩ }

def comp₁
  (f : bicompletion_aux 𝒞 tt) :
  Π (g : bicompletion_aux 𝒞 tt),
  part2 {h : bicompletion_aux 𝒞 tt // h.dom = f.dom ∧ h.cod = g.cod} :=
hom_rec_on f
  begin --f : of_cat_obj X ⟶ of_cat_obj Y
    intros X Y f g,
    refine hom_rec_on g _ _ _ _ _,
    { intros Y' Z g,
      exact ⟨plift (Y = Y'), λ h, by cases h with h; subst h;
        exact ⟨(of_cat_hom (f ≫ g)), by simp⟩⟩ },
    { intros, exact part2.none },
    { introsI 𝒟 _ F_obj F_hom cone_obj cone ih₁ ih₂,
      exact ⟨∀ X, (ih₂ X).dom, λ hd,
        ⟨is_limit F_obj @F_hom (of_cat_obj X) (λ X, (ih₂ X).get (hd X)), by simp⟩⟩ },
    { introsI 𝒟 _ F_obj F_hom A B f ih₁ ih₂,
      exact ih₂ >>= λ ih₂, return
        ⟨colimit_cocone_comp F_obj @F_hom A (of_cat_obj X) ih₂, by simp⟩ },
    { intros, exact part2.none }
  end
  begin
    introsI 𝒟 _ F_obj F_hom X Y f ih₁ ih₂ g,
    exact ih₂ g >>= λ ih₂, return ⟨limit_cone_comp F_obj @F_hom X g.cod ih₂, by simp⟩
  end
  begin
    introsI 𝒟 _ F_obj F_hom cone_obj cone ih₁ ih₂ g,
    refine hom_rec_on g _ _ _ _ _,
    { intros, exact part2.none },
    { introsI ℰ _ G_obj G_hom A B i ih₃ ih₄,
      exact ih₄ >>= λ ih₄, ⟨plift (B = i.cod), λ h, by cases h with h; subst h; exact ih₄⟩ },
    { introsI ℰ _ G_obj G_hom cone_obj' cone' ih₃ ih₄,
      dsimp [cod, dom] at *,
      exact ⟨{ X : Σ X, (ih₄ X).dom // (cone' X.1).cod = limit_obj G_obj @G_hom},
        λ X, ⟨(ih₄ X.1.1).get X.1.2,
          by simp [((ih₄ X.1.1).get X.1.2).prop.1, ((ih₄ X.1.1).get X.1.2).prop.2, X.prop]⟩⟩ },
    { introsI ℰ _ G_obj G_hom cocone_obj cocone ih₃ ih₄,
      dsimp [cod, dom] at *, },
    { intros, exact part2.none }

  end
  _
  _

def comp₁ : Π
  (f : bicompletion_aux 𝒞 tt)
  (g : bicompletion_aux 𝒞 tt),
  part (bicompletion_aux 𝒞 tt)
| (@of_cat_hom _ _ A B f) (@of_cat_hom _ _ B' C g) :=
  ⟨B = B', λ h, by subst h; exact (of_cat_hom₁ (f ≫ g)).1⟩
| (@limit_cone_comp _ _ 𝒟 _ F_obj F_hom A B f) g :=
  do ih ← comp₁ f g, return (by exactI limit_cone_comp F_obj @F_hom A g.cod ih)
| f (@colimit_cocone_comp _ _ 𝒟 _ F_obj F_hom A B g) :=
  do ih ← comp₁ f g, return (by exactI colimit_cocone_comp F_obj @F_hom A g.cod ih)
| (@is_colimit _ _ 𝒟 _ F_obj F_hom cocone_obj cocone) g :=
  let f : Π (A : 𝒟), part (bicompletion_aux 𝒞 tt) := λ A, comp₁ (cocone A) g in
  ⟨∀ A : 𝒟, (f A).dom, λ h, by exactI @is_colimit _ _ 𝒟 _ F_obj @F_hom cocone_obj
    (λ A, (f A).get (h A))⟩
| f (@is_limit _ _ 𝒟 _ F_obj F_hom cone_obj cone) :=
  let f : Π (A : 𝒟), part (bicompletion_aux 𝒞 tt) := λ A, comp₁ f (cone A) in
  ⟨∀ A : 𝒟, (f A).dom, λ h, by exactI @is_colimit _ _ 𝒟 _ F_obj @F_hom cone_obj
    (λ A, (f A).get (h A))⟩
using_well_founded { dec_tac := `[admit] }

inductive valid_obj₁ : Π (X : obj₁ 𝒞), Prop
| of_cat_obj (X : 𝒞) : valid_obj₁ (of_cat_obj X)
| limit_obj {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y))
  (h : Π X : 𝒟, valid_obj₁ (F_obj X)) :
  valid_obj₁ (limit_obj₁ F_obj @F_hom)
| colimit_obj {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y))
  (h : Π X : 𝒟, valid_obj₁ (F_obj X)) :
  valid_obj₁ (colimit_obj₁ F_obj @F_hom)

def valid_obj₁_limit_obj
  {𝒟 : Type} [category.{0} 𝒟] {F_obj : 𝒟 → obj₁ 𝒞}
  {F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → bicompletion_aux 𝒞 tt}
  (h : valid_obj₁ (limit_obj F_obj @F_hom)) :
  Π (X : 𝒟), valid_obj₁ (F_obj X) :=
begin
  generalize hX : limit_obj F_obj @F_hom = X,
  rw hX at h,
  induction h,
  { simp * at * },
  { simp [limit_obj₁] at hX,
    rcases hX with ⟨hX₁, hX₂, hX₂, hX₄⟩,
    subst hX₁,
    simp at *,
    subst hX₂,
    assumption },
  { simp [*, colimit_obj₁] at * }
end

def valid_obj₁_colimit_obj
  {𝒟 : Type} [category.{0} 𝒟] {F_obj : 𝒟 → obj₁ 𝒞}
  {F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → bicompletion_aux 𝒞 tt}
  (h : valid_obj₁ (colimit_obj F_obj @F_hom)) :
  Π (X : 𝒟), valid_obj₁ (F_obj X) :=
begin
  generalize hX : colimit_obj F_obj @F_hom = X,
  rw hX at h,
  induction h,
  { simp * at * },
  { simp [*, limit_obj₁] at * },
  { simp [colimit_obj₁] at hX,
    rcases hX with ⟨hX₁, hX₂, hX₂, hX₄⟩,
    subst hX₁,
    simp at *,
    subst hX₂,
    assumption }
end

inductive valid_hom₁ : Π {X Y : obj₁ 𝒞}, hom₁ X Y → Type 1
| of_cat_hom {X Y : 𝒞} (f : X ⟶ Y) : valid_hom₁ (of_cat_hom₁ f)
| limit_cone_comp {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y))
  (X : 𝒟) {Y : obj₁ 𝒞} (f : hom₁ (F_obj X) Y)
  (F_hom_valid : Π {X Y : 𝒟} (f : X ⟶ Y), valid_hom₁ (F_hom f))
  (f_valid : valid_hom₁ f) :
  valid_hom₁ (limit_cone_comp₁ F_obj @F_hom X f)
| colimit_cocone_comp {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y))
  (X : 𝒟) {Y : obj₁ 𝒞} (f : hom₁ Y (F_obj X))
  (F_hom_valid : Π {X Y : 𝒟} (f : X ⟶ Y), valid_hom₁ (F_hom f))
  (f_valid : valid_hom₁ f) :
  valid_hom₁ (colimit_cocone_comp₁ F_obj @F_hom X f)
| is_limit {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y))
  (cone_obj : obj₁ 𝒞)
  (cone : Π (X : 𝒟), hom₁ cone_obj (F_obj X))
  (F_hom_valid : Π {X Y : 𝒟} (f : X ⟶ Y), valid_hom₁ (F_hom f))
  (cone_valid : Π (X : 𝒟), valid_hom₁ (cone X)) :
  valid_hom₁ (is_limit₁ F_obj @F_hom cone_obj cone)
| is_colimit {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y))
  (cocone_obj : obj₁ 𝒞)
  (cocone : Π (X : 𝒟), hom₁ (F_obj X) cocone_obj)
  (F_hom_valid : Π {X Y : 𝒟} (f : X ⟶ Y), valid_hom₁ (F_hom f))
  (cocone_valid : Π (X : 𝒟), valid_hom₁ (cocone X)) :
  valid_hom₁ (is_colimit₁ F_obj @F_hom cocone_obj cocone)

variable (𝒞)

def obj₂ : Type 1 := { X : obj₁ 𝒞 // valid_obj₁ X }

variable {𝒞}

def hom₂ (X Y : obj₂ 𝒞) : Type 1 := Σ (f : hom₁ X.1 Y.1), valid_hom₁ f

open valid_hom₁

lemma valid_hom₁_limit_cone_comp {𝒟 : Type} [category.{0} 𝒟] (F_obj : 𝒟 → obj₁ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₁ (F_obj X) (F_obj Y))
  (X : 𝒟) {Y : obj₁ 𝒞} (f : hom₁ (F_obj X) Y)
  (F_hom_valid : Π {X Y : 𝒟} (f : X ⟶ Y), valid_hom₁ (F_hom f))
  (f_valid : valid_hom₁ f)
  (h : valid_hom₁ (limit_cone_comp₁ F_obj @F_hom X f)) :
  h == valid_hom₁.limit_cone_comp F_obj @F_hom X f @F_hom_valid f_valid :=
@valid_hom₁.rec_on _ _ (λ A B g hg, g == limit_cone_comp₁ F_obj @F_hom X f →
  hg == valid_hom₁.limit_cone_comp F_obj @F_hom X f @F_hom_valid f_valid)
  _ _ _ _
  begin
    intros,
    simp [of_cat_hom₁] at *,

  end _ _ _ _ (heq.refl _)

lemma hom₂_ext_aux {X Y : obj₁ 𝒞} (f : hom₁ X Y) (h₁ : valid_hom₁ f) :
  ∀ (h₂ : valid_hom₁ f), h₁ = h₂ :=
begin
  induction h₁,
  { intro h₂, cases h₂, refl },
  { intro h₂,
    refine valid_hom₁.rec_on h₂ _ _ _ _ _,
    { intros X Y f, }
     }

end

def of_cat_obj₂ (X : 𝒞) : obj₂ 𝒞 :=
⟨of_cat_obj X, valid_obj₁.of_cat_obj _⟩

lemma of_cat_obj₂_injective : function.injective (@of_cat_obj₂ 𝒞 _) :=
begin
  intros X Y hXY,
  simp [of_cat_obj₂] at hXY,
  injection hXY,
end

def limit_obj₂ (F_obj : 𝒟 → obj₂ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₂ (F_obj X) (F_obj Y)) : obj₂ 𝒞 :=
⟨limit_obj₁ (λ X, (F_obj X).1) (λ X Y f, (F_hom f).1), valid_obj₁.limit_obj _ _ (λ X, (F_obj X).2)⟩

lemma limit_obj₂_injective {𝒟₁ 𝒟₂ : Type} [i₁ : category 𝒟₁] [i₂ : category 𝒟₂]
  {F_obj₁ : 𝒟₁ → obj₂ 𝒞} {F_obj₂ : 𝒟₂ → obj₂ 𝒞}
  {F_hom₁ : Π {X Y : 𝒟₁}, (X ⟶ Y) → hom₂ (F_obj₁ X) (F_obj₁ Y)}
  {F_hom₂ : Π {X Y : 𝒟₂}, (X ⟶ Y) → hom₂ (F_obj₂ X) (F_obj₂ Y)}
  (h : limit_obj₂ F_obj₁ @F_hom₁ = limit_obj₂ F_obj₂ @F_hom₂) :
  𝒟₁ = 𝒟₂ ∧ i₁ == i₂ ∧ F_obj₁ == F_obj₂ ∧ @F_hom₁ == @F_hom₂ :=
begin
  simp [limit_obj₂, limit_obj₁] at h,
  injection h with h₁ h₂ h₃ h₄,
  unfreezingI { subst h₁ },
  rw heq_iff_eq at h₂,
  unfreezingI { subst h₂ },
  simp [heq_iff_eq, function.funext_iff, subtype.coe_injective.eq_iff] at h₃,
  rw [← function.funext_iff] at h₃,
  dsimp at h₃,
  subst h₃,
  simp [heq_iff_eq, function.funext_iff, subtype.coe_injective.eq_iff] at h₄,
end

def colimit_obj₂ (F_obj : 𝒟 → obj₂ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₂ (F_obj X) (F_obj Y)) : obj₂ 𝒞 :=
⟨colimit_obj₁ (λ X, (F_obj X).1) (λ X Y f, (F_hom f).1), valid_obj₁.colimit_obj _ _ (λ X, (F_obj X).2)⟩

def of_cat_hom₂ {X Y : 𝒞} (f : X ⟶ Y) : hom₂ (of_cat_obj₂ X) (of_cat_obj₂ Y) :=
⟨of_cat_hom₁ f, valid_hom₁.of_cat_hom _⟩

def limit_cone_comp₂ (F_obj : 𝒟 → obj₂ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₂ (F_obj X) (F_obj Y)) (X : 𝒟)
  {Y : obj₂ 𝒞} (f : hom₂ (F_obj X) Y) :
  hom₂ (limit_obj₂ F_obj @F_hom) Y :=
⟨limit_cone_comp₁ (λ X, (F_obj X).1) (λ X Y f, (F_hom f).1) X f.1,
  valid_hom₁.limit_cone_comp _ _ _ _ (λ X Y f, (F_hom f).2) f.2⟩

def colimit_cocone_comp₂ (F_obj : 𝒟 → obj₂ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₂ (F_obj X) (F_obj Y)) (X : 𝒟)
  {Y : obj₂ 𝒞} (f : hom₂ Y (F_obj X)):
  hom₂ Y (colimit_obj₂ F_obj @F_hom) :=
⟨colimit_cocone_comp₁ (λ X, (F_obj X).1) (λ X Y f, (F_hom f).1) X f.1,
  valid_hom₁.colimit_cocone_comp _ _ _ _ (λ X Y f, (F_hom f).2) f.2⟩

def is_limit₂ (F_obj : 𝒟 → obj₂ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
  (cone_obj : obj₂ 𝒞)
  (cone : Π (X : 𝒟), hom₂ cone_obj (F_obj X)) :
  hom₂ cone_obj (limit_obj₂ F_obj @F_hom) :=
⟨is_limit₁ (λ X, (F_obj X).1) (λ X Y f, (F_hom f).1) cone_obj.1 (λ X, (cone X).1),
  valid_hom₁.is_limit _ _ _ _ (λ X Y f, (F_hom f).2) (λ X, (cone X).2)⟩

def is_colimit₂ (F_obj : 𝒟 → obj₂ 𝒞)
  (F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
  (cocone_obj : obj₂ 𝒞)
  (cocone : Π (X : 𝒟), hom₂ (F_obj X) cocone_obj) :
  hom₂ (colimit_obj₂ F_obj @F_hom) cocone_obj  :=
⟨is_colimit₁ (λ X, (F_obj X).1) (λ X Y f, (F_hom f).1) cocone_obj.1 (λ X, (cocone X).1),
  valid_hom₁.is_colimit _ _ _ _ (λ X Y f, (F_hom f).2) (λ X, (cocone X).2)⟩

@[elab_as_eliminator] protected def hom₂.rec_on
  {motive : Π {X Y : obj₂ 𝒞} (f : hom₂ X Y), Sort*} {X Y : obj₂ 𝒞} (f : hom₂ X Y)
  (of_cat_hom : Π {X Y : 𝒞} (f : X ⟶ Y), motive (of_cat_hom₂ f))
  (limit_cone_comp : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    (ih_F_hom : Π {X Y : 𝒟} (f : by exactI X ⟶ Y), motive (F_hom f))
    (X : 𝒟) {Y : obj₂ 𝒞} (f : hom₂ (F_obj X) Y)
    (ih_f : motive f),
      motive (by exactI limit_cone_comp₂ F_obj @F_hom X f))
  (colimit_cocone_comp : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    (ih_F_hom : Π {X Y : 𝒟} (f : by exactI X ⟶ Y), motive (F_hom f))
    (X : 𝒟) {Y : obj₂ 𝒞} (f : hom₂ Y (F_obj X))
    (ih_f : motive f),
      motive (by exactI colimit_cocone_comp₂ F_obj @F_hom X f))
  (is_limit : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    (ih_F_hom : Π {X Y : 𝒟} (f : by exactI X ⟶ Y), motive (F_hom f))
    (cone_obj : obj₂ 𝒞) (cone : Π (X : 𝒟), hom₂ cone_obj (F_obj X))
    (ih_cone : Π (X : 𝒟), motive (cone X)),
      motive (by exactI is_limit₂ F_obj @F_hom cone_obj cone))
  (is_colimit : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    (ih_F_hom : Π {X Y : 𝒟} (f : by exactI X ⟶ Y), motive (F_hom f))
    (cocone_obj : obj₂ 𝒞) (cocone : Π (X : 𝒟), hom₂ (F_obj X) cocone_obj)
    (ih_cone : Π (X : 𝒟), motive (cocone X)),
      motive (by exactI is_colimit₂ F_obj @F_hom cocone_obj cocone)) :
  motive f :=
begin
  cases X with X hX, cases Y with Y hY,
  cases f with f hf,
  dsimp at f, dsimp at hf,
  revert hX hY,
  refine valid_hom₁.rec_on hf _ _ _ _ _,
  { intros A B g hX hY,
    exact of_cat_hom g },
  { introsI 𝒟 _ F_obj F_hom X Y f F_hom_valid f_valid ih₁ ih₂ hX hY,
    exact @limit_cone_comp _ _ (λ A, ⟨F_obj A, valid_obj₁_limit_obj hX A⟩)
      (λ X Y f, ⟨F_hom f, F_hom_valid f⟩)
      (λ X Y f, ih₁ f _ _) X ⟨Y, hY⟩ ⟨f, f_valid⟩ (ih₂ _ _) },
  { introsI 𝒟 _ F_obj F_hom X Y f F_hom_valid f_valid ih₁ ih₂ hY hX,
    exact @colimit_cocone_comp _ _ (λ A, ⟨F_obj A, valid_obj₁_colimit_obj hX A⟩)
      (λ X Y f, ⟨F_hom f, F_hom_valid f⟩)
      (λ X Y f, ih₁ f _ _) X ⟨Y, hY⟩ ⟨f, f_valid⟩ (ih₂ _ _) },
  { introsI 𝒟 _ F_obj F_hom cone_obj cone F_hom_valid cone_valid ih₁ ih₂ hX hY,
    exact @is_limit 𝒟 _ (λ A, ⟨F_obj A, valid_obj₁_limit_obj hY A⟩)
      (λ X Y f, ⟨F_hom f, F_hom_valid f⟩)
      (λ X Y f, ih₁ f _ _) ⟨cone_obj, hX⟩
      (λ X, ⟨cone X, cone_valid X⟩)
      (λ X, ih₂ X _ _) },
  { introsI 𝒟 _ F_obj F_hom cocone_obj cocone F_hom_valid cocone_valid ih₁ ih₂ hX hY,
    exact @is_colimit 𝒟 _ (λ A, ⟨F_obj A, valid_obj₁_colimit_obj hX A⟩)
      (λ X Y f, ⟨F_hom f, F_hom_valid f⟩)
      (λ X Y f, ih₁ f _ _) ⟨cocone_obj, hY⟩
      (λ X, ⟨cocone X, cocone_valid X⟩)
      (λ X, ih₂ X _ _) }
end

def hom₂_of_cat_obj_rec_on
  {motive : Π {X : 𝒞} {Y : obj₂ 𝒞} (f : hom₂ (of_cat_obj₂ X) Y), Sort*}
  {X : 𝒞} {Y : obj₂ 𝒞} (f : hom₂ (of_cat_obj₂ X) Y)
  (of_cat_hom : Π {Y : 𝒞} (f : X ⟶ Y), motive (of_cat_hom₂ f))
  (colimit_cocone_comp : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    (X : 𝒟) {Y : 𝒞} (f : hom₂ (of_cat_obj₂ Y) (F_obj X))
    (ih_f : motive f),
      motive (by exactI colimit_cocone_comp₂ F_obj @F_hom X f))
  (is_limit : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    (cone_obj : 𝒞) (cone : Π (X : 𝒟), hom₂ (of_cat_obj₂ cone_obj) (F_obj X))
    (ih_cone : Π (X : 𝒟), motive (cone X)),
      motive (by exactI is_limit₂ F_obj @F_hom (of_cat_obj₂ cone_obj) cone)) :
  motive f :=
@hom₂.rec_on 𝒞 _ (λ A B f, ∀ (h : A = of_cat_obj₂ X),
  motive (show hom₂ (of_cat_obj₂ X) B, from eq.rec_on h f))
  (of_cat_obj₂ X) Y f
  (λ A B g h, begin
      have := of_cat_obj₂_injective h,
      subst this,
      dsimp,
      exact of_cat_hom g
    end)
  begin
    intros,
    simp [limit_obj₂, of_cat_obj₂, limit_obj₁] at h,
    contradiction
  end
  begin
    introsI 𝒟 _ F_obj F_hom ih₁ A B g ih₂ h,
    subst h,
    exact colimit_cocone_comp _ _ _ _ (ih₂ rfl)
  end
  begin
    introsI 𝒟 _ F_obj F_hom ih₁ cone_obj cone ih₂ h,
    subst h,
    exact is_limit _ _ _ _ (λ A, ih₂ A rfl),
  end
  begin
    intros,
    simp [colimit_obj₂, of_cat_obj₂] at h,
    contradiction
  end
  rfl

def hom₂_limit_obj_rec_on
  {motive : Π {𝒟 : Type} [category 𝒟] {F_obj : 𝒟 → obj₂ 𝒞}
    {F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y)} {Y : obj₂ 𝒞},
    hom₂ (by exactI limit_obj₂ F_obj @F_hom) Y → Sort*}
  {𝒟 : Type} [category 𝒟] {F_obj : 𝒟 → obj₂ 𝒞}
  {F_hom : Π {X Y : 𝒟}, (X ⟶ Y) → hom₂ (F_obj X) (F_obj Y)} {Y : obj₂ 𝒞}
  (f : hom₂ (limit_obj₂ F_obj @F_hom) Y)
  (limit_cone_comp : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    (X : 𝒟) {Y : obj₂ 𝒞} (f : hom₂ (F_obj X) Y),
      by exactI motive (limit_cone_comp₂ F_obj @F_hom X f))
  (colimit_cocone_comp : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    (X : 𝒟)
    {ℰ : Type} [category ℰ] (G_obj : ℰ → obj₂ 𝒞)
    (G_hom : Π {X Y : ℰ}, (by exactI X ⟶ Y) → hom₂ (G_obj X) (G_obj Y))
    (f : hom₂ (by exactI limit_obj₂ G_obj @G_hom) (F_obj X))
    (ih_f : by exactI motive f),
      by exactI motive (colimit_cocone_comp₂ F_obj @F_hom X f))
  (is_limit : Π {𝒟 : Type} [category 𝒟] (F_obj : 𝒟 → obj₂ 𝒞)
    (F_hom : Π {X Y : 𝒟}, (by exactI X ⟶ Y) → hom₂ (F_obj X) (F_obj Y))
    {ℰ : Type} [category ℰ] (G_obj : ℰ → obj₂ 𝒞)
    (G_hom : Π {X Y : ℰ}, (by exactI X ⟶ Y) → hom₂ (G_obj X) (G_obj Y))
    (cone : Π (X : 𝒟), hom₂ (by exactI limit_obj₂ G_obj @G_hom) (F_obj X))
    (ih_cone : Π (X : 𝒟), by exactI motive (cone X)),
      by exactI motive (is_limit₂ F_obj @F_hom (limit_obj₂ G_obj @G_hom) cone)) :
  motive f :=
@hom₂.rec_on 𝒞 _ (λ A B f, ∀ (h : A = limit_obj₂ F_obj @F_hom),
  motive (show hom₂ (limit_obj₂ F_obj @F_hom) B, from eq.rec_on h f))
  (limit_obj₂ F_obj @F_hom) Y f
  begin
    intros,
    simp [limit_obj₂, of_cat_obj₂, limit_obj₁] at h,
    contradiction
  end
  begin
    intros ℰ _ G_obj G_hom ih₁ A B g ih₂ h,
    simp [limit_obj₂, of_cat_obj₂, limit_obj₁] at h,
    injection h with h₁ h₂ h₃ h₄,
    unfreezingI { subst h₁ },
    rw [heq_iff_eq] at h₂,
    unfreezingI { subst h₂ },
    dsimp at h₄,
    dsimp,

  end
  begin
    introsI 𝒟 _ F_obj F_hom ih₁ A B g ih₂ h,
    subst h,
    exact colimit_cocone_comp _ _ _ _ (ih₂ rfl)
  end
  begin
    introsI 𝒟 _ F_obj F_hom ih₁ cone_obj cone ih₂ h,
    subst h,
    exact is_limit _ _ _ _ (λ A, ih₂ A rfl),
  end
  begin
    intros,
    simp [colimit_obj₂, of_cat_obj₂] at h,
    contradiction
  end
  rfl

def comp₂ {X Y : obj₂ 𝒞} (f : hom₂ X Y) : Π {Z : obj₂ 𝒞}, hom₂ Y Z → hom₂ X Z :=
hom₂.rec_on f
  begin
    intros X Y f Z g,
    refine hom₂_of_cat_obj_rec_on g _ _ _,
    { intros B g,
      exact of_cat_hom₂ (f ≫ g) },
    { introsI 𝒟 _ F_obj F_hom ih₁ B g ih₂,
      simp [limit_obj₂, of_cat_obj₂, limit_obj₁, *] at *,
      refine colimit_cocone_comp₂ F_obj _ _ ih₂ },
    { introsI 𝒟 _ F_obj F_hom ih₁ cone ih₂,
      refine is_limit₂ _ _ _ (λ X, ih₂ _) }
  end
  begin
    introsI 𝒟 _ F_obj F_hom ih₁ A B f ih₂ Z g,
    refine limit_cone_comp₂ _ _ _ (ih₂ g),
  end
  begin
    introsI 𝒟 _ F_obj F_hom ih₁ A B f ih₂ Z g,
    refine ih₂ _,
    admit
  end
  begin
    introsI 𝒟 _ F_obj F_hom ih₁ cone_obj cone ih₂ Z g,

    admit,
  end
  begin
    introsI 𝒟 _ F_obj F_hom ih₁ cocone_obj cocone ih₂ Z g,
    exact is_colimit₂ _ _ _ (λ A, ih₂ _ g)
  end

end bicompletion_aux


import data.cpi.species.basic

-- Dubious instances to force setoids to be equivalent.
instance {α : Type*} [r : setoid α] : is_refl α has_equiv.equiv
  := { refl := λ a, r.iseqv.1 a }
instance {α : Type*} [r : setoid α] : is_trans α has_equiv.equiv
  := { trans := λ a b c ab bc, r.iseqv.2.2 ab bc }
instance {α : Type*} [r : setoid α] : is_symm α has_equiv.equiv
  := { symm := λ a b ab, r.iseqv.2.1 ab }

namespace cpi
namespace species

variables {ℍ : Type} {ω Γ : context} [setoid (species ℍ ω Γ)]

/-- A species is prime if it is non-nil, and for any decomposition into two
    parallel species, one of those must be nil.  -/
def prime (A : species ℍ ω Γ) : Prop
  := ¬ A ≈ nil ∧ ∀ B C, A ≈ (B |ₛ C) → B ≈ nil ∨ C ≈ nil

lemma prime.equivalent_imp {A B : species ℍ ω Γ} : A ≈ B → prime A → prime B
| ab ⟨ neq, prime ⟩ := ⟨ λ nil, neq (trans ab nil), λ A B eq, prime A B (trans ab eq) ⟩

/-- Primality commutes with structrural congruence. -/
lemma prime.equivalent {A B : species ℍ ω Γ} : A ≈ B → prime A = prime B
| eq := propext ⟨ prime.equivalent_imp eq, prime.equivalent_imp (symm eq) ⟩

/-- The set of all species which are prime. -/
@[nolint has_inhabited_instance]
def prime_species (ℍ : Type) (ω Γ : context) [setoid (species ℍ ω Γ)] :Type
  := { A : species ℍ ω Γ // prime A }

instance prime_species.setoid: setoid (prime_species ℍ ω Γ) :=
  { r := λ A B, A.val ≈ B.val,
    iseqv := ⟨ λ a, by from refl a.val,
              λ _ _ ab, by from symm ab,
              λ _ _ _ ab bc, by from trans ab bc ⟩ }

/-- A quotient of all structurally congruent species which are prime. -/
@[nolint has_inhabited_instance]
def prime_species' (ℍ : Type) (ω Γ : context) [r : setoid (species ℍ ω Γ)] :=
  quotient (@prime_species.setoid ℍ ω Γ r)

/-- Unwrap a quotient of prime species, yielding a quotient of species. -/
def prime_species.unwrap : prime_species' ℍ ω Γ → species' ℍ ω Γ
| A := quot.lift_on A (λ B, ⟦ B.val ⟧) (λ _ _ eq, quot.sound eq)

instance prime_species'.has_repr [has_repr (species' ℍ ω Γ)] : has_repr (prime_species' ℍ ω Γ)
  := ⟨ λ x, repr (prime_species.unwrap x) ⟩

lemma prime_species.unwrap.inj :
  ∀ (A B : prime_species' ℍ ω Γ), prime_species.unwrap A = prime_species.unwrap B
  → A = B
| A B eq := begin
  rcases quotient.exists_rep A with ⟨ A, eq ⟩, subst eq,
  rcases quotient.exists_rep B with ⟨ B, eq ⟩, subst eq,
  from quot.sound (quotient.exact eq),
end

end species
end cpi

#lint-


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Scott Morrison
-/
import category_theory.subobject.factor_thru
import category_theory.subobject.well_powered

/-!
# The lattice of subobjects

We provide the `semilattice_inf` with `order_top (subobject X)` instance when `[has_pullback C]`,
and the `semilattice_sup (subobject X)` instance when `[has_images C] [has_binary_coproducts C]`.
-/

universes v₁ v₂ u₁ u₂

noncomputable theory

open category_theory category_theory.category category_theory.limits

variables {C : Type u₁} [category.{v₁} C] {X Y Z : C}
variables {D : Type u₂} [category.{v₂} D]

namespace category_theory

namespace mono_over

section has_top

instance {X : C} : has_top (mono_over X) :=
{ top := mk' (𝟙 _) }

instance {X : C} : inhabited (mono_over X) := ⟨⊤⟩

/-- The morphism to the top object in `mono_over X`. -/
def le_top (f : mono_over X) : f ⟶ ⊤ :=
hom_mk f.arrow (comp_id _)

@[simp] lemma top_left (X : C) : ((⊤ : mono_over X) : C) = X := rfl
@[simp] lemma top_arrow (X : C) : (⊤ : mono_over X).arrow = 𝟙 X := rfl

/-- `map f` sends `⊤ : mono_over X` to `⟨X, f⟩ : mono_over Y`. -/
def map_top (f : X ⟶ Y) [mono f] : (map f).obj ⊤ ≅ mk' f :=
iso_of_both_ways (hom_mk (𝟙 _) rfl) (hom_mk (𝟙 _) (by simp [id_comp f]))

section
variable [has_pullbacks C]

/-- The pullback of the top object in `mono_over Y`
is (isomorphic to) the top object in `mono_over X`. -/
def pullback_top (f : X ⟶ Y) : (pullback f).obj ⊤ ≅ ⊤ :=
iso_of_both_ways (le_top _) (hom_mk (pullback.lift f (𝟙 _) (by tidy)) (pullback.lift_snd _ _ _))

/-- There is a morphism from `⊤ : mono_over A` to the pullback of a monomorphism along itself;
as the category is thin this is an isomorphism. -/
def top_le_pullback_self {A B : C} (f : A ⟶ B) [mono f] :
  (⊤ : mono_over A) ⟶ (pullback f).obj (mk' f) :=
hom_mk _ (pullback.lift_snd _ _ rfl)

/-- The pullback of a monomorphism along itself is isomorphic to the top object. -/
def pullback_self {A B : C} (f : A ⟶ B) [mono f] :
  (pullback f).obj (mk' f) ≅ ⊤ :=
iso_of_both_ways (le_top _) (top_le_pullback_self _)

end

end has_top

section has_bot

variables [has_initial C] [initial_mono_class C]

instance {X : C} : has_bot (mono_over X) :=
{ bot := mk' (initial.to X) }

@[simp] lemma bot_left (X : C) : ((⊥ : mono_over X) : C) = ⊥_ C := rfl
@[simp] lemma bot_arrow {X : C} : (⊥ : mono_over X).arrow = initial.to X := rfl

/-- The (unique) morphism from `⊥ : mono_over X` to any other `f : mono_over X`. -/
def bot_le {X : C} (f : mono_over X) : ⊥ ⟶ f :=
hom_mk (initial.to _) (by simp)

/-- `map f` sends `⊥ : mono_over X` to `⊥ : mono_over Y`. -/
def map_bot (f : X ⟶ Y) [mono f] : (map f).obj ⊥ ≅ ⊥ :=
iso_of_both_ways (hom_mk (initial.to _) (by simp)) (hom_mk (𝟙 _) (by simp))

end has_bot

section zero_order_bot

variables [has_zero_object C]
open_locale zero_object

/-- The object underlying `⊥ : subobject B` is (up to isomorphism) the zero object. -/
def bot_coe_iso_zero {B : C} : ((⊥ : mono_over B) : C) ≅ 0 :=
initial_is_initial.unique_up_to_iso has_zero_object.zero_is_initial

@[simp] lemma bot_arrow_eq_zero [has_zero_morphisms C] {B : C} : (⊥ : mono_over B).arrow = 0 :=
zero_of_source_iso_zero _ bot_coe_iso_zero

end zero_order_bot

section inf
variables [has_pullbacks C]

/--
When `[has_pullbacks C]`, `mono_over A` has "intersections", functorial in both arguments.

As `mono_over A` is only a preorder, this doesn't satisfy the axioms of `semilattice_inf`,
but we reuse all the names from `semilattice_inf` because they will be used to construct
`semilattice_inf (subobject A)` shortly.
-/
@[simps]
def inf {A : C} : mono_over A ⥤ mono_over A ⥤ mono_over A :=
{ obj := λ f, pullback f.arrow ⋙ map f.arrow,
  map := λ f₁ f₂ k,
  { app := λ g,
    begin
      apply hom_mk _ _,
      apply pullback.lift pullback.fst (pullback.snd ≫ k.left) _,
      rw [pullback.condition, assoc, w k],
      dsimp,
      rw [pullback.lift_snd_assoc, assoc, w k],
    end } }.

/-- A morphism from the "infimum" of two objects in `mono_over A` to the first object. -/
def inf_le_left {A : C} (f g : mono_over A) :
  (inf.obj f).obj g ⟶ f :=
hom_mk _ rfl

/-- A morphism from the "infimum" of two objects in `mono_over A` to the second object. -/
def inf_le_right {A : C} (f g : mono_over A) :
  (inf.obj f).obj g ⟶ g :=
hom_mk _ pullback.condition

/-- A morphism version of the `le_inf` axiom. -/
def le_inf {A : C} (f g h : mono_over A) :
  (h ⟶ f) → (h ⟶ g) → (h ⟶ (inf.obj f).obj g) :=
begin
  intros k₁ k₂,
  refine hom_mk (pullback.lift k₂.left k₁.left _) _,
  rw [w k₁, w k₂],
  erw [pullback.lift_snd_assoc, w k₁],
end

end inf

section sup
variables [has_images C] [has_binary_coproducts C]

/-- When `[has_images C] [has_binary_coproducts C]`, `mono_over A` has a `sup` construction,
which is functorial in both arguments,
and which on `subobject A` will induce a `semilattice_sup`. -/
def sup  {A : C} : mono_over A ⥤ mono_over A ⥤ mono_over A :=
curry_obj ((forget A).prod (forget A) ⋙ uncurry.obj over.coprod ⋙ image)

/-- A morphism version of `le_sup_left`. -/
def le_sup_left {A : C} (f g : mono_over A) :
  f ⟶ (sup.obj f).obj g :=
begin
  refine hom_mk (coprod.inl ≫ factor_thru_image _) _,
  erw [category.assoc, image.fac, coprod.inl_desc],
  refl,
end

/-- A morphism version of `le_sup_right`. -/
def le_sup_right {A : C} (f g : mono_over A) :
  g ⟶ (sup.obj f).obj g :=
begin
  refine hom_mk (coprod.inr ≫ factor_thru_image _) _,
  erw [category.assoc, image.fac, coprod.inr_desc],
  refl,
end

/-- A morphism version of `sup_le`. -/
def sup_le {A : C} (f g h : mono_over A) :
  (f ⟶ h) → (g ⟶ h) → ((sup.obj f).obj g ⟶ h) :=
begin
  intros k₁ k₂,
  refine hom_mk _ _,
  apply image.lift ⟨_, h.arrow, coprod.desc k₁.left k₂.left, _⟩,
  { dsimp,
    ext1,
    { simp [w k₁] },
    { simp [w k₂] } },
  { apply image.lift_fac }
end

end sup

end mono_over

namespace subobject

section order_top

instance order_top {X : C} : order_top (subobject X) :=
{ top := quotient.mk' ⊤,
  le_top :=
  begin
    refine quotient.ind' (λ f, _),
    exact ⟨mono_over.le_top f⟩,
  end }

instance {X : C} : inhabited (subobject X) := ⟨⊤⟩

lemma top_eq_id (B : C) : (⊤ : subobject B) = subobject.mk (𝟙 B) := rfl

lemma underlying_iso_top_hom {B : C} :
  (underlying_iso (𝟙 B)).hom = (⊤ : subobject B).arrow :=
by { convert underlying_iso_hom_comp_eq_mk (𝟙 B), simp only [comp_id], }

instance top_arrow_is_iso {B : C} : is_iso ((⊤ : subobject B).arrow) :=
by { rw ←underlying_iso_top_hom, apply_instance, }

@[simp, reassoc]
lemma underlying_iso_inv_top_arrow {B : C} :
  (underlying_iso _).inv ≫ (⊤ : subobject B).arrow = 𝟙 B :=
underlying_iso_arrow _

@[simp]
lemma map_top (f : X ⟶ Y) [mono f] : (map f).obj ⊤ = subobject.mk f :=
quotient.sound' ⟨mono_over.map_top f⟩

lemma top_factors {A B : C} (f : A ⟶ B) : (⊤ : subobject B).factors f :=
⟨f, comp_id _⟩

lemma is_iso_iff_mk_eq_top {X Y : C} (f : X ⟶ Y) [mono f] : is_iso f ↔ mk f = ⊤ :=
⟨λ _, by exactI mk_eq_mk_of_comm _ _ (as_iso f) (category.comp_id _), λ h,
  by { rw [←of_mk_le_mk_comp h.le, category.comp_id], exact is_iso.of_iso (iso_of_mk_eq_mk _ _ h) }⟩

lemma is_iso_arrow_iff_eq_top {Y : C} (P : subobject Y) : is_iso P.arrow ↔ P = ⊤ :=
by rw [is_iso_iff_mk_eq_top, mk_arrow]

instance is_iso_top_arrow {Y : C} : is_iso (⊤ : subobject Y).arrow :=
by rw is_iso_arrow_iff_eq_top

lemma mk_eq_top_of_is_iso {X Y : C} (f : X ⟶ Y) [is_iso f] : mk f = ⊤ :=
(is_iso_iff_mk_eq_top f).mp infer_instance

lemma eq_top_of_is_iso_arrow {Y : C} (P : subobject Y) [is_iso P.arrow] : P = ⊤ :=
(is_iso_arrow_iff_eq_top P).mp infer_instance

section
variables [has_pullbacks C]

lemma pullback_top (f : X ⟶ Y) : (pullback f).obj ⊤ = ⊤ :=
quotient.sound' ⟨mono_over.pullback_top f⟩

lemma pullback_self {A B : C} (f : A ⟶ B) [mono f] :
  (pullback f).obj (mk f) = ⊤ :=
quotient.sound' ⟨mono_over.pullback_self f⟩

end

end order_top

section order_bot
variables [has_initial C] [initial_mono_class C]

instance order_bot {X : C} : order_bot (subobject X) :=
{ bot := quotient.mk' ⊥,
  bot_le :=
  begin
    refine quotient.ind' (λ f, _),
    exact ⟨mono_over.bot_le f⟩,
  end }

lemma bot_eq_initial_to {B : C} : (⊥ : subobject B) = subobject.mk (initial.to B) := rfl

/-- The object underlying `⊥ : subobject B` is (up to isomorphism) the initial object. -/
def bot_coe_iso_initial {B : C} : ((⊥ : subobject B) : C) ≅ ⊥_ C := underlying_iso _

lemma map_bot (f : X ⟶ Y) [mono f] : (map f).obj ⊥ = ⊥ :=
quotient.sound' ⟨mono_over.map_bot f⟩

end order_bot

section zero_order_bot

variables [has_zero_object C]
open_locale zero_object

/-- The object underlying `⊥ : subobject B` is (up to isomorphism) the zero object. -/
def bot_coe_iso_zero {B : C} : ((⊥ : subobject B) : C) ≅ 0 :=
bot_coe_iso_initial ≪≫ initial_is_initial.unique_up_to_iso has_zero_object.zero_is_initial

variables [has_zero_morphisms C]

lemma bot_eq_zero {B : C} : (⊥ : subobject B) = subobject.mk (0 : 0 ⟶ B) :=
mk_eq_mk_of_comm _ _ (initial_is_initial.unique_up_to_iso has_zero_object.zero_is_initial) (by simp)

@[simp] lemma bot_arrow {B : C} : (⊥ : subobject B).arrow = 0 :=
zero_of_source_iso_zero _ bot_coe_iso_zero

lemma bot_factors_iff_zero {A B : C} (f : A ⟶ B) : (⊥ : subobject B).factors f ↔ f = 0 :=
⟨by { rintro ⟨h, rfl⟩, simp }, by { rintro rfl, exact ⟨0, by simp⟩, }⟩

lemma mk_eq_bot_iff_zero {f : X ⟶ Y} [mono f] : subobject.mk f = ⊥ ↔ f = 0 :=
⟨λ h, by simpa [h, bot_factors_iff_zero] using mk_factors_self f,
  λ h, mk_eq_mk_of_comm _ _ ((iso_zero_of_mono_eq_zero h).trans has_zero_object.zero_iso_initial)
    (by simp [h])⟩

end zero_order_bot

section functor
variable (C)

/-- Sending `X : C` to `subobject X` is a contravariant functor `Cᵒᵖ ⥤ Type`. -/
@[simps]
def functor [has_pullbacks C] : Cᵒᵖ ⥤ Type (max u₁ v₁) :=
{ obj := λ X, subobject X.unop,
  map := λ X Y f, (pullback f.unop).obj,
  map_id' := λ X, funext pullback_id,
  map_comp' := λ X Y Z f g, funext (pullback_comp _ _) }

end functor

section semilattice_inf_top
variables [has_pullbacks C]

/-- The functorial infimum on `mono_over A` descends to an infimum on `subobject A`. -/
def inf {A : C} : subobject A ⥤ subobject A ⥤ subobject A :=
thin_skeleton.map₂ mono_over.inf

lemma inf_le_left  {A : C} (f g : subobject A) :
  (inf.obj f).obj g ≤ f :=
quotient.induction_on₂' f g (λ a b, ⟨mono_over.inf_le_left _ _⟩)

lemma inf_le_right {A : C} (f g : subobject A) :
  (inf.obj f).obj g ≤ g :=
quotient.induction_on₂' f g (λ a b, ⟨mono_over.inf_le_right _ _⟩)

lemma le_inf {A : C} (h f g : subobject A) :
  h ≤ f → h ≤ g → h ≤ (inf.obj f).obj g :=
quotient.induction_on₃' h f g
begin
  rintros f g h ⟨k⟩ ⟨l⟩,
  exact ⟨mono_over.le_inf _ _ _ k l⟩,
end

instance {B : C} : semilattice_inf (subobject B) :=
{ inf := λ m n, (inf.obj m).obj n,
  inf_le_left := inf_le_left,
  inf_le_right := inf_le_right,
  le_inf := le_inf,
  ..subobject.partial_order _ }

lemma factors_left_of_inf_factors {A B : C} {X Y : subobject B} {f : A ⟶ B}
  (h : (X ⊓ Y).factors f) : X.factors f :=
factors_of_le _ (inf_le_left _ _) h

lemma factors_right_of_inf_factors {A B : C} {X Y : subobject B} {f : A ⟶ B}
  (h : (X ⊓ Y).factors f) : Y.factors f :=
factors_of_le _ (inf_le_right _ _) h

@[simp]
lemma inf_factors {A B : C} {X Y : subobject B} (f : A ⟶ B) :
  (X ⊓ Y).factors f ↔ X.factors f ∧ Y.factors f :=
⟨λ h, ⟨factors_left_of_inf_factors h, factors_right_of_inf_factors h⟩,
  begin
    revert X Y,
    refine quotient.ind₂' _,
    rintro X Y ⟨⟨g₁, rfl⟩, ⟨g₂, hg₂⟩⟩,
    exact ⟨_, pullback.lift_snd_assoc _ _ hg₂ _⟩,
  end⟩

lemma inf_arrow_factors_left {B : C} (X Y : subobject B) : X.factors (X ⊓ Y).arrow :=
(factors_iff _ _).mpr ⟨of_le (X ⊓ Y) X (inf_le_left X Y), by simp⟩

@[simp]
lemma finset_inf_factors {I : Type*} {A B : C} {s : finset I} {P : I → subobject B}
  (f : A ⟶ B) :
  (s.inf P).factors f ↔ ∀ i ∈ s, (P i).factors f :=
begin
  classical,
  apply finset.induction_on s,
  { simp [top_factors] },
  { intros i s nm ih, simp [ih] },
end

-- `i` is explicit here because often we'd like to defer a proof of `m`
lemma finset_inf_arrow_factors {I : Type*} {B : C} (s : finset I) (P : I → subobject B)
  (i : I) (m : i ∈ s) : (P i).factors (s.inf P).arrow :=
begin
  revert i m,
  classical,
  apply finset.induction_on s,
  { rintro _ ⟨⟩, },
  { intros i s nm ih j m,
    rw [finset.inf_insert],
    simp only [finset.mem_insert] at m, rcases m with (rfl|m),
    { rw ←factor_thru_arrow _ _ (inf_arrow_factors_left _ _),
      exact factors_comp_arrow _, },
    { rw ←factor_thru_arrow _ _ (inf_arrow_factors_right _ _),
      apply factors_of_factors_right,
      exact ih _ m, } },
end

lemma inf_eq_map_pullback' {A : C} (f₁ : mono_over A) (f₂ : subobject A) :
  (subobject.inf.obj (quotient.mk' f₁)).obj f₂ =
    (subobject.map f₁.arrow).obj ((subobject.pullback f₁.arrow).obj f₂) :=
begin
  apply quotient.induction_on' f₂,
  intro f₂,
  refl,
end

lemma inf_eq_map_pullback {A : C} (f₁ : mono_over A) (f₂ : subobject A) :
  (quotient.mk' f₁ ⊓ f₂ : subobject A) = (map f₁.arrow).obj ((pullback f₁.arrow).obj f₂) :=
inf_eq_map_pullback' f₁ f₂

lemma prod_eq_inf {A : C} {f₁ f₂ : subobject A} [has_binary_product f₁ f₂] :
  (f₁ ⨯ f₂) = f₁ ⊓ f₂ :=
le_antisymm
  (_root_.le_inf (limits.prod.fst).le (limits.prod.snd).le)
  ((prod.lift (_root_.inf_le_left.hom) (_root_.inf_le_right.hom))).le

lemma inf_def {B : C} (m m' : subobject B) :
  m ⊓ m' = (inf.obj m).obj m' := rfl

/-- `⊓` commutes with pullback. -/
lemma inf_pullback {X Y : C} (g : X ⟶ Y) (f₁ f₂) :
  (pullback g).obj (f₁ ⊓ f₂) = (pullback g).obj f₁ ⊓ (pullback g).obj f₂ :=
begin
  revert f₁,
  apply quotient.ind',
  intro f₁,
  erw [inf_def, inf_def, inf_eq_map_pullback', inf_eq_map_pullback', ← pullback_comp,
       ← map_pullback pullback.condition (pullback_is_pullback f₁.arrow g),
       ← pullback_comp, pullback.condition],
  refl,
end

/-- `⊓` commutes with map. -/
lemma inf_map {X Y : C} (g : Y ⟶ X) [mono g] (f₁ f₂) :
  (map g).obj (f₁ ⊓ f₂) = (map g).obj f₁ ⊓ (map g).obj f₂ :=
begin
  revert f₁,
  apply quotient.ind',
  intro f₁,
  erw [inf_def, inf_def, inf_eq_map_pullback',
       inf_eq_map_pullback', ← map_comp],
  dsimp,
  rw [pullback_comp, pullback_map_self],
end

end semilattice_inf_top

section semilattice_sup
variables [has_images C] [has_binary_coproducts C]

/-- The functorial supremum on `mono_over A` descends to an supremum on `subobject A`. -/
def sup {A : C} : subobject A ⥤ subobject A ⥤ subobject A :=
thin_skeleton.map₂ mono_over.sup

instance {B : C} : semilattice_sup (subobject B) :=
{ sup := λ m n, (sup.obj m).obj n,
  le_sup_left := λ m n, quotient.induction_on₂' m n (λ a b, ⟨mono_over.le_sup_left _ _⟩),
  le_sup_right := λ m n, quotient.induction_on₂' m n (λ a b, ⟨mono_over.le_sup_right _ _⟩),
  sup_le := λ m n k, quotient.induction_on₃' m n k (λ a b c ⟨i⟩ ⟨j⟩, ⟨mono_over.sup_le _ _ _ i j⟩),
  ..subobject.partial_order B }

lemma sup_factors_of_factors_left {A B : C} {X Y : subobject B} {f : A ⟶ B} (P : X.factors f) :
  (X ⊔ Y).factors f :=
factors_of_le f le_sup_left P

lemma sup_factors_of_factors_right {A B : C} {X Y : subobject B} {f : A ⟶ B} (P : Y.factors f) :
  (X ⊔ Y).factors f :=
factors_of_le f le_sup_right P

variables [has_initial C] [initial_mono_class C]

lemma finset_sup_factors {I : Type*} {A B : C} {s : finset I} {P : I → subobject B}
  {f : A ⟶ B} (h : ∃ i ∈ s, (P i).factors f) :
  (s.sup P).factors f :=
begin
  classical,
  revert h,
  apply finset.induction_on s,
  { rintro ⟨_, ⟨⟨⟩, _⟩⟩, },
  { rintros i s nm ih ⟨j, ⟨m, h⟩⟩,
    simp only [finset.sup_insert],
    simp at m, rcases m with (rfl|m),
    { exact sup_factors_of_factors_left h, },
    { exact sup_factors_of_factors_right (ih ⟨j, ⟨m, h⟩⟩), }, },
end

end semilattice_sup

section lattice

instance [has_initial C] [initial_mono_class C] {B : C} : bounded_order (subobject B) :=
{ ..subobject.order_top,
  ..subobject.order_bot }

variables [has_pullbacks C] [has_images C] [has_binary_coproducts C]

instance {B : C} : lattice (subobject B) :=
{ ..subobject.semilattice_inf,
  ..subobject.semilattice_sup }

end lattice

section Inf

variables [well_powered C]

/--
The "wide cospan" diagram, with a small indexing type, constructed from a set of subobjects.
(This is just the diagram of all the subobjects pasted together, but using `well_powered C`
to make the diagram small.)
-/
def wide_cospan {A : C} (s : set (subobject A)) :
  wide_pullback_shape (equiv_shrink _ '' s) ⥤ C :=
wide_pullback_shape.wide_cospan A
  (λ j : equiv_shrink _ '' s, (((equiv_shrink (subobject A)).symm j) : C))
  (λ j, ((equiv_shrink (subobject A)).symm j).arrow)

@[simp] lemma wide_cospan_map_term {A : C} (s : set (subobject A)) (j) :
  (wide_cospan s).map (wide_pullback_shape.hom.term j) =
    ((equiv_shrink (subobject A)).symm j).arrow :=
rfl

/-- Auxiliary construction of a cone for `le_Inf`. -/
def le_Inf_cone {A : C} (s : set (subobject A)) (f : subobject A) (k : Π (g ∈ s), f ≤ g) :
  cone (wide_cospan s) :=
wide_pullback_shape.mk_cone f.arrow
  (λ j, underlying.map (hom_of_le (k _ (by { rcases j with ⟨-, ⟨g, ⟨m, rfl⟩⟩⟩, simpa using m, }))))
  (by tidy)

@[simp] lemma le_Inf_cone_π_app_none
  {A : C} (s : set (subobject A)) (f : subobject A) (k : Π (g ∈ s), f ≤ g) :
  (le_Inf_cone s f k).π.app none = f.arrow :=
rfl

variables [has_wide_pullbacks.{v₁} C]

/--
The limit of `wide_cospan s`. (This will be the supremum of the set of subobjects.)
-/
def wide_pullback {A : C} (s : set (subobject A)) : C :=
limits.limit (wide_cospan s)

/--
The inclusion map from `wide_pullback s` to `A`
-/
def wide_pullback_ι {A : C} (s : set (subobject A)) :
  wide_pullback s ⟶ A :=
limits.limit.π (wide_cospan s) none

instance wide_pullback_ι_mono {A : C} (s : set (subobject A)) :
  mono (wide_pullback_ι s) :=
⟨λ W u v h, limit.hom_ext (λ j, begin
  cases j,
  { exact h, },
  { apply (cancel_mono ((equiv_shrink (subobject A)).symm j).arrow).1,
    rw [assoc, assoc],
    erw limit.w (wide_cospan s) (wide_pullback_shape.hom.term j),
    exact h, },
end)⟩

/--
When `[well_powered C]` and `[has_wide_pullbacks C]`, `subobject A` has arbitrary infimums.
-/
def Inf {A : C} (s : set (subobject A)) : subobject A :=
subobject.mk (wide_pullback_ι s)

lemma Inf_le {A : C} (s : set (subobject A)) (f ∈ s) :
  Inf s ≤ f :=
begin
  fapply le_of_comm,
  { refine (underlying_iso _).hom ≫
      (limits.limit.π
        (wide_cospan s)
        (some ⟨equiv_shrink _ f, set.mem_image_of_mem (equiv_shrink (subobject A)) H⟩)) ≫ _,
    apply eq_to_hom,
    apply (congr_arg (λ X : subobject A, (X : C))),
    exact (equiv.symm_apply_apply _ _), },
  { dsimp [Inf],
    simp only [category.comp_id, category.assoc, ←underlying_iso_hom_comp_eq_mk,
      subobject.arrow_congr, congr_arg_mpr_hom_left, iso.cancel_iso_hom_left],
    convert limit.w (wide_cospan s) (wide_pullback_shape.hom.term _), },
end.

lemma le_Inf {A : C} (s : set (subobject A)) (f : subobject A) (k : Π (g ∈ s), f ≤ g) :
  f ≤ Inf s :=
begin
  fapply le_of_comm,
  { exact limits.limit.lift _ (le_Inf_cone s f k) ≫ (underlying_iso _).inv, },
  { dsimp [Inf, wide_pullback_ι],
    simp, },
end

instance {B : C} : complete_semilattice_Inf (subobject B) :=
{ Inf := Inf,
  Inf_le := Inf_le,
  le_Inf := le_Inf,
  ..subobject.partial_order B }

end Inf

section Sup

variables [well_powered C] [has_coproducts.{v₁} C]

/--
The univesal morphism out of the coproduct of a set of subobjects,
after using `[well_powered C]` to reindex by a small type.
-/
def small_coproduct_desc {A : C} (s : set (subobject A)) : _ ⟶ A :=
limits.sigma.desc (λ j : equiv_shrink _ '' s, ((equiv_shrink (subobject A)).symm j).arrow)

variables [has_images C]

/-- When `[well_powered C] [has_images C] [has_coproducts C]`,
`subobject A` has arbitrary supremums. -/
def Sup {A : C} (s : set (subobject A)) : subobject A :=
subobject.mk (image.ι (small_coproduct_desc s))

lemma le_Sup {A : C} (s : set (subobject A)) (f ∈ s)  :
  f ≤ Sup s :=
begin
  fapply le_of_comm,
  { dsimp [Sup],
    refine _ ≫ factor_thru_image _ ≫ (underlying_iso _).inv,
    refine _ ≫ sigma.ι _ ⟨equiv_shrink _ f, (by simpa [set.mem_image] using H)⟩,
    exact eq_to_hom (congr_arg (λ X : subobject A, (X : C)) (equiv.symm_apply_apply _ _).symm), },
  { dsimp [Sup, small_coproduct_desc],
    simp, dsimp, simp, },
end

lemma symm_apply_mem_iff_mem_image {α β : Type*} (e : α ≃ β) (s : set α) (x : β) :
  e.symm x ∈ s ↔ x ∈ e '' s :=
⟨λ h, ⟨e.symm x, h, by simp⟩, by { rintro ⟨a, m, rfl⟩, simpa using m, }⟩

lemma Sup_le {A : C} (s : set (subobject A)) (f : subobject A) (k : Π (g ∈ s), g ≤ f) :
  Sup s ≤ f :=
begin
  fapply le_of_comm,
  { dsimp [Sup],
    refine (underlying_iso _).hom ≫ image.lift ⟨_, f.arrow, _, _⟩,
    { refine sigma.desc _,
      rintro ⟨g, m⟩,
      refine underlying.map (hom_of_le (k _ _)),
      simpa [symm_apply_mem_iff_mem_image] using m, },
    { ext j, rcases j with ⟨j, m⟩, dsimp [small_coproduct_desc], simp, dsimp, simp, }, },
  { dsimp [Sup],
    simp, },
end

instance {B : C} : complete_semilattice_Sup (subobject B) :=
{ Sup := Sup,
  le_Sup := le_Sup,
  Sup_le := Sup_le,
  ..subobject.partial_order B }

end Sup

section complete_lattice
variables [well_powered C] [has_wide_pullbacks.{v₁} C] [has_images C] [has_coproducts.{v₁} C]
  [initial_mono_class C]

local attribute [instance] has_smallest_coproducts_of_has_coproducts

instance {B : C} : complete_lattice (subobject B) :=
{ ..subobject.semilattice_inf,
  ..subobject.semilattice_sup,
  ..subobject.bounded_order,
  ..subobject.complete_semilattice_Inf,
  ..subobject.complete_semilattice_Sup, }

end complete_lattice

section zero_object
variables [has_zero_morphisms C] [has_zero_object C]
open_locale zero_object

/-- A nonzero object has nontrivial subobject lattice. -/
lemma nontrivial_of_not_is_zero {X : C} (h : ¬ is_zero X) : nontrivial (subobject X) :=
⟨⟨mk (0 : 0 ⟶ X), mk (𝟙 X), λ w, h (is_zero.of_iso (is_zero_zero C) (iso_of_mk_eq_mk _ _ w).symm)⟩⟩

end zero_object

section subobject_subobject

/-- The subobject lattice of a subobject `Y` is order isomorphic to the interval `set.Iic Y`. -/
def subobject_order_iso {X : C} (Y : subobject X) : subobject (Y : C) ≃o set.Iic Y :=
{ to_fun := λ Z, ⟨subobject.mk (Z.arrow ≫ Y.arrow),
    set.mem_Iic.mpr (le_of_comm ((underlying_iso _).hom ≫ Z.arrow) (by simp))⟩,
  inv_fun := λ Z, subobject.mk (of_le _ _ Z.2),
  left_inv := λ Z, mk_eq_of_comm _ (underlying_iso _) (by { ext, simp, }),
  right_inv := λ Z, subtype.ext (mk_eq_of_comm _ (underlying_iso _)
    (by { dsimp, simp [←iso.eq_inv_comp], })),
  map_rel_iff' := λ W Z,
    ⟨λ h, le_of_comm
      ((underlying_iso _).inv ≫ of_le _ _ (subtype.mk_le_mk.mp h) ≫ (underlying_iso _).hom)
      (by { ext, simp, }),
     λ h, subtype.mk_le_mk.mpr
       (le_of_comm ((underlying_iso _).hom ≫ of_le _ _ h ≫ (underlying_iso _).inv) (by simp))⟩, }

end subobject_subobject

end subobject

end category_theory


import category_theory.sites.limits

import for_mathlib.abelian_sheaves.functor_category
import for_mathlib.sheaf
import category_theory.sites.left_exact

namespace category_theory
namespace Sheaf

noncomputable theory

universes w v u
variables {C : Type (max v u)} [category.{v} C] {J : grothendieck_topology C}
variables {A : Type w} [category.{max v u} A]

section has_zero_morphisms

variables [limits.has_zero_morphisms A]

instance : limits.has_zero_morphisms (Sheaf J A) :=
{ has_zero := λ X Y, ⟨⟨0⟩⟩,
  comp_zero' := λ X Y f Z, Sheaf.hom.ext _ _ $ limits.comp_zero,
  zero_comp' := λ X Y Z f, Sheaf.hom.ext _ _ $ limits.zero_comp }

end has_zero_morphisms

section parallel_pair

def parallel_pair_iso {F G : Sheaf J A} (η γ : F ⟶ G) :
  limits.parallel_pair η γ ⋙ Sheaf_to_presheaf J A ≅ limits.parallel_pair η.val γ.val :=
nat_iso.of_components
(λ x,
match x with
| limits.walking_parallel_pair.zero := eq_to_iso rfl
| limits.walking_parallel_pair.one := eq_to_iso rfl
end) begin
  rintro (x|x) (y|y) (f|f|f),
  any_goals { refl },
  any_goals { ext, dsimp [parallel_pair_iso._match_1], simp },
end

end parallel_pair

section kernels

variables [limits.has_zero_morphisms A]
-- TODO: Add some instances that derive the following from `[has_kernels A]`.
variables [limits.has_limits_of_shape.{_ (max v u)} limits.walking_parallel_pair A]

def kernel_sheaf {F G : Sheaf J A} (η : F ⟶ G) : Sheaf J A :=
{ val := limits.kernel.{(max v u)} ((Sheaf_to_presheaf J A).map η),
  cond := begin
    haveI : limits.has_limit (limits.parallel_pair η 0 ⋙ Sheaf_to_presheaf J A) := begin
      apply limits.has_limit_of_iso (parallel_pair_iso _ _).symm,
      apply_instance,
    end,
    let e : limits.limit (limits.parallel_pair η 0 ⋙ Sheaf_to_presheaf J A) ≅
      limits.kernel η.val := limits.has_limit.iso_of_nat_iso (parallel_pair_iso _ _),
    apply presheaf.is_sheaf_of_iso J e.symm,
    apply is_sheaf_of_is_limit,
    apply limits.limit.is_limit,
  end }

def kernel_ι {F G : Sheaf J A} (η : F ⟶ G) : kernel_sheaf η ⟶ F :=
⟨limits.kernel.ι _⟩

def kernel_fork {F G : Sheaf J A} (η : F ⟶ G) : limits.fork η 0 :=
limits.fork.of_ι (kernel_ι η) $
by { simp only [limits.comp_zero], ext1, apply limits.kernel.condition }

def is_limit_kernel_fork {F G : Sheaf J A} (η : F ⟶ G) : limits.is_limit (kernel_fork η) :=
limits.is_limit_aux _ (λ S, ⟨limits.kernel.lift _ S.ι.val $ congr_arg Sheaf.hom.val S.condition⟩)
(by { intros S, ext1, apply limits.kernel.lift_ι, })
begin
  intros S m hm,
  ext : 2,
  simp only [limits.kernel.lift_ι],
  exact congr_arg Sheaf.hom.val hm,
end

-- Sanity check
example : limits.has_kernels (Sheaf J A) := by apply_instance

def kernel_iso_kernel_sheaf {F G : Sheaf J A} (η : F ⟶ G) :
  limits.kernel η ≅ kernel_sheaf η :=
(limits.limit.is_limit _).cone_point_unique_up_to_iso (is_limit_kernel_fork _)

@[simp, reassoc]
lemma kernel_iso_kernel_sheaf_hom_ι {F G : Sheaf J A} (η : F ⟶ G) :
  (kernel_iso_kernel_sheaf η).hom ≫ kernel_ι η = limits.kernel.ι _ :=
((limits.limit.is_limit _).unique_up_to_iso (is_limit_kernel_fork η)).hom.w
  limits.walking_parallel_pair.zero

@[simp, reassoc]
lemma kernel_iso_kernel_sheaf_hom_ι_val {F G : Sheaf J A} (η : F ⟶ G) :
  (kernel_iso_kernel_sheaf η).hom.val ≫ (kernel_ι η).val = (limits.kernel.ι η).val :=
begin
  change ((kernel_iso_kernel_sheaf η).hom ≫ (kernel_ι η)).val = (limits.kernel.ι η).val,
  simp,
end

@[simp, reassoc]
lemma kernel_iso_kernel_sheaf_inv_ι {F G : Sheaf J A} (η : F ⟶ G) :
  (kernel_iso_kernel_sheaf η).inv ≫ limits.kernel.ι _ = kernel_ι η :=
by simp only [← kernel_iso_kernel_sheaf_hom_ι, iso.inv_hom_id_assoc]

@[simp, reassoc]
lemma kernel_iso_kernel_sheaf_inv_ι_val {F G : Sheaf J A} (η : F ⟶ G) :
  (kernel_iso_kernel_sheaf η).inv.val ≫ (limits.kernel.ι η).val = (kernel_ι η).val :=
begin
  change ((kernel_iso_kernel_sheaf η).inv ≫ (limits.kernel.ι η)).val = (kernel_ι η).val,
  simp,
end

end kernels

section cokernels

variables [limits.has_zero_morphisms A]
-- TODO: Add some instances that derive the following from `[has_cokernels A]`.
variables [limits.has_colimits_of_shape.{_ (max v u)} limits.walking_parallel_pair A]

-- We will need to sheafify....
variables [concrete_category.{max v u} A]
variables [∀ (P : Cᵒᵖ ⥤ A) (X : C) (S : J.cover X), limits.has_multiequalizer (S.index P)]
variables [limits.preserves_limits (forget A)]
variables [∀ (X : C), limits.has_colimits_of_shape (J.cover X)ᵒᵖ A]
variables [∀ (X : C), limits.preserves_colimits_of_shape (J.cover X)ᵒᵖ (forget A)]
variables [reflects_isomorphisms (forget A)]

def cokernel_sheaf {F G : Sheaf J A} (η : F ⟶ G) : Sheaf J A :=
{ val := J.sheafify (limits.cokernel ((Sheaf_to_presheaf J A).map η)), -- ;-)
  cond := grothendieck_topology.plus.is_sheaf_plus_plus _ _ }

def cokernel_π {F G : Sheaf J A} (η : F ⟶ G) : G ⟶ cokernel_sheaf η :=
⟨show (Sheaf_to_presheaf J A).obj G ⟶ J.sheafify (limits.cokernel ((Sheaf_to_presheaf J A).map η)),
from limits.cokernel.π ((Sheaf_to_presheaf J A).map η) ≫
  J.to_sheafify (limits.cokernel ((Sheaf_to_presheaf J A).map η))⟩

def cokernel_cofork {F G : Sheaf J A} (η : F ⟶ G) : limits.cofork η 0 :=
limits.cofork.of_π (cokernel_π η) begin
  ext1,
  rw [limits.zero_comp],
  dsimp only [cokernel_π],
  show η.val ≫ _ = 0,
  erw [← category.assoc, limits.cokernel.condition, limits.zero_comp],
end

def is_colimit_cokernel_cofork {F G : Sheaf J A} (η : F ⟶ G) :
  limits.is_colimit (cokernel_cofork η) :=
limits.is_colimit_aux _ (λ S,
  ⟨J.sheafify_lift
    (limits.cokernel.desc ((Sheaf_to_presheaf J A).map η) S.π.val $
      congr_arg Sheaf.hom.val S.condition)
    (S.X.2)⟩)
begin
  intros S, ext1,
  change (_ ≫ _) ≫ _ = _,
  rw [category.assoc, J.to_sheafify_sheafify_lift, limits.cokernel.π_desc],
end begin
  intros S m hm, ext1,
  apply J.sheafify_lift_unique,
  rw Sheaf.hom.ext_iff at hm,
  change (_ ≫ _) ≫ _ = _ at hm,
  rw category.assoc at hm,
  ext1,
  rw [hm, limits.cokernel.π_desc],
end

-- Sanity check
example : limits.has_cokernels (Sheaf J A) := by apply_instance

def cokernel_iso_cokernel_sheaf {F G : Sheaf J A} (η : F ⟶ G) :
  limits.cokernel η ≅ cokernel_sheaf η :=
(limits.colimit.is_colimit _).cocone_point_unique_up_to_iso (is_colimit_cokernel_cofork _)

@[simp]
lemma cokernel_iso_cokernel_sheaf_hom_π {F G : Sheaf J A} (η : F ⟶ G) :
  limits.cokernel.π η ≫ (cokernel_iso_cokernel_sheaf η).hom = cokernel_π _ :=
((limits.colimit.is_colimit _).unique_up_to_iso (is_colimit_cokernel_cofork η)).hom.w
  limits.walking_parallel_pair.one

@[simp]
lemma cokernel_iso_cokernel_sheaf_inv_π {F G : Sheaf J A} (η : F ⟶ G) :
  cokernel_π η ≫ (cokernel_iso_cokernel_sheaf η).inv = limits.cokernel.π η :=
by simp only [← cokernel_iso_cokernel_sheaf_hom_π,
  category.assoc, iso.hom_inv_id, category.comp_id]

end cokernels

section kernels_and_cokernels

variables [limits.has_zero_morphisms A]
-- TODO: use has kernels and cokernels, when possible... see above
variables [limits.has_colimits_of_shape.{_ (max v u)} limits.walking_parallel_pair A]
variables [limits.has_limits_of_shape.{_ (max v u)} limits.walking_parallel_pair A]

-- We will need to sheafify....
variables [concrete_category.{max v u} A]
variables [∀ (P : Cᵒᵖ ⥤ A) (X : C) (S : J.cover X), limits.has_multiequalizer (S.index P)]
variables [limits.preserves_limits (forget A)]
variables [∀ (X : C), limits.has_colimits_of_shape (J.cover X)ᵒᵖ A]
variables [∀ (X : C), limits.preserves_colimits_of_shape (J.cover X)ᵒᵖ (forget A)]
variables [reflects_isomorphisms (forget A)]

def coim_to_im'_aux {F G : Sheaf J A} (η : F ⟶ G) :
  abelian.coimage ((Sheaf_to_presheaf J A).map η) ⟶
    (Sheaf_to_presheaf J A).obj (kernel_sheaf (cokernel_π η)) :=
(abelian.coimage_image_comparison _ ≫ limits.kernel.lift _ (limits.kernel.ι _) begin
  dsimp [cokernel_π],
  rw [← category.assoc, limits.kernel.condition],
  simp only [limits.zero_comp],
end)

def coim_to_im' {F G : Sheaf J A} (η : F ⟶ G) :
  cokernel_sheaf (kernel_ι η) ⟶ kernel_sheaf (cokernel_π η) :=
⟨J.sheafify_lift (coim_to_im'_aux η) (kernel_sheaf _).2⟩

def kernel_sheaf_cokernel_π_iso {F G : Sheaf J A} (η : F ⟶ G) :
  kernel_sheaf (limits.cokernel.π η) ≅ kernel_sheaf (cokernel_π η) :=
{ hom := ⟨limits.kernel.map _ _ (𝟙 _)
    ((Sheaf_to_presheaf J A).map (cokernel_iso_cokernel_sheaf η).hom) begin
      rw ← functor.map_comp,
      dsimp [cokernel_iso_cokernel_sheaf, limits.is_colimit.cocone_point_unique_up_to_iso,
        cokernel_cofork],
      show Sheaf.hom.val (limits.cokernel.π η ≫ _) = _,
      simp only [limits.coequalizer.π_desc, category.id_comp],
    end⟩,
  inv := ⟨limits.kernel.map _ _ (𝟙 _)
    ((Sheaf_to_presheaf J A).map (cokernel_iso_cokernel_sheaf η).inv) begin
      rw ← functor.map_comp,
      dsimp [cokernel_iso_cokernel_sheaf, limits.is_colimit.cocone_point_unique_up_to_iso,
        cokernel_π, is_colimit_cokernel_cofork, limits.is_colimit_aux],
      erw [category.id_comp, category.assoc, J.to_sheafify_sheafify_lift,
        limits.cokernel.π_desc],
    end⟩,
  hom_inv_id' := begin
    ext : 2,
    delta limits.kernel.map,
    dsimp,
    erw [category.assoc, limits.kernel.lift_ι, ← category.assoc, limits.kernel.lift_ι,
      category.comp_id, category.comp_id, category.id_comp],
  end,
  inv_hom_id' := begin
    ext : 2,
    delta limits.kernel.map,
    dsimp,
    erw [category.assoc, limits.kernel.lift_ι, ← category.assoc, limits.kernel.lift_ι,
      category.comp_id, category.comp_id, category.id_comp],
  end }

def cokernel_sheaf_kernel_ι_iso {F G : Sheaf J A} (η : F ⟶ G) :
  cokernel_sheaf (limits.kernel.ι η) ≅ cokernel_sheaf (kernel_ι η) :=
{ hom := ⟨J.sheafify_lift
    (limits.cokernel.map _ _ ((Sheaf_to_presheaf J A).map (kernel_iso_kernel_sheaf η).hom) (𝟙 _)
      (by rw [category.comp_id, ← functor.map_comp, kernel_iso_kernel_sheaf_hom_ι])
      ≫ J.to_sheafify _) (cokernel_sheaf _).2⟩,
  inv := ⟨J.sheafify_lift
    (limits.cokernel.map _ _ ((Sheaf_to_presheaf J A).map (kernel_iso_kernel_sheaf η).inv) (𝟙 _)
      (by rw [category.comp_id, ← functor.map_comp, kernel_iso_kernel_sheaf_inv_ι])
      ≫ J.to_sheafify _)
    (cokernel_sheaf _).2⟩,
  hom_inv_id' := begin
    ext1,
    apply J.sheafify_hom_ext _ _ (cokernel_sheaf _).2,
    erw [← category.assoc, J.to_sheafify_sheafify_lift, category.assoc,
      J.to_sheafify_sheafify_lift, ← category.assoc],
    conv_rhs { erw category.comp_id },
    convert category.id_comp _,
    ext1,
    delta limits.cokernel.map,
    erw [← category.assoc, limits.coequalizer.π_desc, category.id_comp,
      limits.coequalizer.π_desc, category.id_comp, category.comp_id],
  end,
  inv_hom_id' := begin
    ext1,
    apply J.sheafify_hom_ext _ _ (cokernel_sheaf _).2,
    erw [← category.assoc, J.to_sheafify_sheafify_lift, category.assoc,
      J.to_sheafify_sheafify_lift, ← category.assoc],
    conv_rhs { erw category.comp_id },
    convert category.id_comp _,
    ext1,
    delta limits.cokernel.map,
    erw [← category.assoc, limits.coequalizer.π_desc, category.id_comp,
      limits.coequalizer.π_desc, category.id_comp, category.comp_id],
  end }

lemma eq_coim_to_im' {F G : Sheaf J A} (η : F ⟶ G) :
  (cokernel_sheaf_kernel_ι_iso η).inv ≫
  (cokernel_iso_cokernel_sheaf _).inv ≫
  abelian.coimage_image_comparison η  ≫
  (kernel_iso_kernel_sheaf _).hom ≫
  (kernel_sheaf_cokernel_π_iso η).hom
  = coim_to_im' η :=
begin
  dsimp [abelian.coimage_image_comparison, cokernel_sheaf_kernel_ι_iso,
    coim_to_im', coim_to_im'_aux, kernel_sheaf_cokernel_π_iso,
    limits.is_colimit.cocone_point_unique_up_to_iso,
    limits.is_limit.cone_point_unique_up_to_iso],
  delta limits.kernel.map limits.cokernel.map,
  ext1,
  apply J.sheafify_lift_unique,
  ext : 2,
  conv_rhs {
    erw [← category.assoc, limits.cokernel.π_desc,
      category.assoc, limits.kernel.lift_ι, limits.kernel.lift_ι] },
  dsimp,
  simp only [category.assoc, category.comp_id, category.id_comp,
    J.to_sheafify_sheafify_lift_assoc, kernel_iso_kernel_sheaf_hom_ι_val,
      limits.kernel.lift_ι, limits.cokernel.π_desc_assoc],
  dsimp [cokernel_iso_cokernel_sheaf, limits.is_colimit.cocone_point_unique_up_to_iso,
    is_colimit_cokernel_cofork, limits.is_colimit_aux],
  rw J.to_sheafify_sheafify_lift_assoc,
  simp only [limits.cokernel.π_desc_assoc, ← category.assoc, ← Sheaf.hom.comp_val,
    limits.cokernel.π_desc],
  simp only [category_theory.category_comp_val, category.assoc],
  erw kernel_iso_kernel_sheaf_hom_ι_val,
  rw [← Sheaf.hom.comp_val, limits.kernel.lift_ι],
end

lemma coim_to_im_eq {F G : Sheaf J A} (η : F ⟶ G) :
  abelian.coimage_image_comparison η =
  (cokernel_iso_cokernel_sheaf _).hom ≫
  (cokernel_sheaf_kernel_ι_iso η).hom ≫
  coim_to_im' η ≫
  (kernel_sheaf_cokernel_π_iso η).inv ≫
  (kernel_iso_kernel_sheaf _).inv
  :=
begin
  rw ← eq_coim_to_im',
  simp only [category.assoc, iso.hom_inv_id, iso.inv_hom_id,
    iso.hom_inv_id_assoc, iso.inv_hom_id_assoc, category.comp_id],
end

end kernels_and_cokernels

section preadditive

variable [preadditive A]

instance : preadditive (Sheaf J A) :=
{ hom_group := λ P Q,
  { add := λ f g, ⟨f.val + g.val⟩,
    add_assoc := by { intros, ext1, apply add_assoc },
    zero := ⟨0⟩,
    zero_add := by { intros, ext1, apply zero_add },
    add_zero := by { intros, ext1, apply add_zero },
    nsmul := λ n f, ⟨n • f.val⟩,
    nsmul_zero' := by { intros, ext1, simpa },
    nsmul_succ' := by { intros, ext1, simpa },
    neg := λ f, ⟨-f.val⟩,
    sub := λ f g, ⟨f.val - g.val⟩,
    sub_eq_add_neg := by { intros, ext1, apply sub_eq_add_neg },
    zsmul := λ n f, ⟨n • f.val⟩,
    zsmul_zero' := by { intros, ext1, simpa },
    zsmul_succ' := by { intros, ext1, simpa },
    zsmul_neg' := by { intros, ext1, simpa },
    add_left_neg := by { intros, ext1, apply add_left_neg },
    add_comm := by { intros, ext1, apply add_comm } },
  add_comp' := λ P Q R f g h, by { ext1, apply preadditive.add_comp },
  comp_add' := λ P Q R f g h, by { ext1, apply preadditive.comp_add } }

end preadditive

section additive

variable [additive_category A]

instance : additive_category (Sheaf J A) :=
{ has_biproducts_of_shape := begin
    introsI J _ _,
    constructor,
    intros F,
    apply limits.has_biproduct.of_has_product
  end,
  ..(by apply_instance : preadditive (Sheaf J A)) }

end additive

section abelian

variables [abelian A]
-- We need sheafification
variables [concrete_category.{max v u} A]
variables [∀ (P : Cᵒᵖ ⥤ A) (X : C) (S : J.cover X), limits.has_multiequalizer (S.index P)]
variables [limits.preserves_limits (forget A)]
--variables [limits.has_finite_limits A]
variables [∀ (X : C), limits.has_colimits_of_shape (J.cover X)ᵒᵖ A]
variables [∀ (X : C), limits.preserves_colimits_of_shape (J.cover X)ᵒᵖ (forget A)]
variables [reflects_isomorphisms (forget A)]

open grothendieck_topology

def parallel_pair_sheafification {F G : Sheaf J A} (η : F ⟶ G) : limits.parallel_pair
  (limits.cokernel.π η.val) 0 ⋙ J.sheafification A ≅
  limits.parallel_pair (cokernel_π η).val 0 :=
nat_iso.of_components
(λ x,
match x with
| limits.walking_parallel_pair.zero := by { dsimp, refine (J.iso_sheafify G.2).symm }
| limits.walking_parallel_pair.one := by { dsimp, exact eq_to_iso rfl }
end)
begin
  -- This proof is SLOW :-(
  rintros (a|a) (b|b) (f|f|f),
  { dsimp [parallel_pair_sheafification._match_1],
    simp only [iso.eq_inv_comp, functor.map_id],
    dsimp [grothendieck_topology.iso_sheafify],
    rw [← category.assoc, is_iso.comp_inv_eq, category.id_comp],
    change J.to_sheafify _ ≫ (sheafification J A).map _ = _,
    erw [functor.map_id, category.comp_id] },
  { dsimp [parallel_pair_sheafification._match_1],
    rw [category.comp_id, iso.eq_inv_comp],
    dsimp [grothendieck_topology.iso_sheafify, cokernel_π],
    change (to_sheafification J A).app _ ≫ (sheafification J A).map _ = _,
    rw ← (to_sheafification J A).naturality,
    refl },
  { dsimp [parallel_pair_sheafification._match_1],
    simp only [limits.comp_zero, category.comp_id],
    change (sheafification J A).map _ = _,
    apply J.sheafify_hom_ext,
    { exact plus.is_sheaf_plus_plus J (limits.cokernel η.val) },
    erw ← (to_sheafification J A).naturality,
    simp },
  { dsimp [parallel_pair_sheafification._match_1],
    simp only [limits.comp_zero, category.id_comp, category.comp_id],
    change (sheafification J A).map _ = _,
    simp only [functor.map_id],
    erw (sheafification J A).map_id, refl },
end .

def kernel_cokernel_π_iso {F G : Sheaf J A} (η : F ⟶ G) :
  J.sheafify (limits.kernel (limits.cokernel.π ((Sheaf_to_presheaf J A).map η))) ≅
  limits.kernel ((Sheaf_to_presheaf J A).map (cokernel_π η)) :=
begin
  let e := (limits.is_limit_of_preserves (sheafification J A)
      (limits.limit.is_limit
      (limits.parallel_pair (limits.cokernel.π
      ((Sheaf_to_presheaf J A).map η)) 0))).cone_point_unique_up_to_iso (limits.limit.is_limit _),
  refine e ≪≫ _,
  change limits.limit _ ≅ _,
  refine limits.has_limit.iso_of_nat_iso _,
  apply parallel_pair_sheafification,
end

/-
{ hom := J.sheafify_lift (limits.kernel.map _ _ (𝟙 _) (J.to_sheafify _) (by admit)) (by admit),
  inv := begin
    let e : J.sheafify ((Sheaf_to_presheaf J A).obj G) ⟶
      J.sheafify (limits.cokernel ((Sheaf_to_presheaf J A).map η)) :=
        (sheafification J A).map (limits.cokernel.π _),
    let ee : limits.kernel ((Sheaf_to_presheaf J A).map (cokernel_π η)) ⟶ limits.kernel e,
    { refine limits.kernel.map _ _ (J.to_sheafify _) (𝟙 _) _,
      rw category.comp_id,
      dsimp only [e],
      rw ← grothendieck_topology.to_sheafification_app,
      rw ← (to_sheafification J A).naturality,
      refl },
    refine ee ≫ _,
    dsimp only [e],
    change limits.kernel ((Sheaf_to_presheaf J A).map ((presheaf_to_Sheaf J A).map _)) ⟶ _,
    refine (Sheaf_to_presheaf J A).map (kernel_iso_kernel_sheaf _).inv ≫ _,
    change _ ⟶ (Sheaf_to_presheaf J A).obj ((presheaf_to_Sheaf J A).obj _),
    refine (Sheaf_to_presheaf J A).map _,
    haveI : is_left_adjoint (presheaf_to_Sheaf J A) := by admit,
    -- Now we need to use the fact that finite limits commute with sheafification,
    -- i.e. that sheafification is left exact.
    admit
  end,
  hom_inv_id' := by admit,
  inv_hom_id' := by admit }
-/

lemma coim_to_im'_eq {F G : Sheaf J A} (η : F ⟶ G) :
  (Sheaf_to_presheaf J A).map (coim_to_im' η) =
  (sheafification J A).map (abelian.coimage_image_comparison _) ≫ (kernel_cokernel_π_iso η).hom :=
begin
  dsimp only [kernel_cokernel_π_iso, limits.is_limit.cone_point_unique_up_to_iso,
    functor.map_iso, iso.trans_hom],
  simp only [category.assoc],
  dsimp only [id, limits.is_limit.unique_up_to_iso, limits.cones.forget,
    limits.is_limit.lift_cone_morphism, functor.map_cone],
  apply limits.equalizer.hom_ext,
  simp only [category.assoc],
  --delta limits.equalizer.ι,
  erw limits.has_limit.iso_of_nat_iso_hom_π,
  dsimp only [parallel_pair_sheafification, nat_iso.of_components, id, iso_sheafify,
    as_iso, iso.symm],
  simp only [← category.assoc],
  rw is_iso.eq_comp_inv,
  simp only [category.assoc],
  erw limits.limit.lift_π,
  dsimp [limits.cones.functoriality, sheafify_map],
  simp_rw [← plus_functor_map, ← functor.comp_map, ← functor.map_comp],
  dsimp [coim_to_im', abelian.coimage_image_comparison, coim_to_im'_aux],
  apply J.sheafify_hom_ext,
  { exact plus.is_sheaf_plus_plus J G.val, },
  simp_rw ← category.assoc,
  erw J.to_sheafify_sheafify_lift,
  change _ = (to_sheafification J A).app _ ≫ (sheafification J A).map _,
  erw ← (to_sheafification J A).naturality,
  simp only [category.assoc, limits.kernel.lift_ι],
  dsimp,
  erw category.assoc,
end

instance is_iso_coim_to_im {F G : Sheaf J A} (η : F ⟶ G) :
  is_iso (abelian.coimage_image_comparison η) :=
begin
  rw coim_to_im_eq,
  suffices : is_iso (coim_to_im' η),
  { resetI, apply is_iso.comp_is_iso },
  suffices : is_iso ((Sheaf_to_presheaf J A).map (coim_to_im' η)),
  { resetI, apply is_iso_of_fully_faithful (Sheaf_to_presheaf J A) },
  rw coim_to_im'_eq,
  apply is_iso.comp_is_iso,
end

instance abelian : abelian (Sheaf J A) :=
abelian.of_coimage_image_comparison_is_iso

end abelian

end Sheaf
end category_theory


import data.cpi.concretion.basic

namespace cpi
namespace concretion

variables {ℍ : Type} {ω : context} [∀ Γ, setoid (species ℍ ω Γ)]

/-- Structural congruence between concretions. -/
inductive equiv : ∀ {Γ} {b y}, concretion ℍ ω Γ b y → concretion ℍ ω Γ b y → Prop
| refl  {Γ} {b y} {F : concretion ℍ ω Γ b y} : equiv F F
| trans {Γ} {b y} {F G H : concretion ℍ ω Γ b y} : equiv F G → equiv G H → equiv F H
| symm  {Γ} {b y} {F G : concretion ℍ ω Γ b y} : equiv F G → equiv G F

| ξ_parallel₁
    {Γ} {b y} {F F' : concretion ℍ ω Γ b y} {A : species ℍ ω Γ}
  : equiv F F' → equiv (F |₁ A) (F' |₁ A)
| ξ_parallel₂
    {Γ} {b y} {F F' : concretion ℍ ω Γ b y} {A : species ℍ ω Γ}
  : equiv F F' → equiv (A |₂ F) (A |₂ F')
| ξ_restriction
    {Γ} {b y} (M : affinity ℍ) {F F' : concretion ℍ ω (context.extend M.arity Γ) b y}
  : equiv F F' → equiv (ν'(M) F) (ν'(M) F')

-- Parallel is a commutative monoid
| parallel_nil
    {Γ} {b y} {F : concretion ℍ ω Γ b y}
  : equiv (F |₁ species.nil) F
| parallel_symm
    {Γ} {b y} {F : concretion ℍ ω Γ b y} {A : species ℍ ω Γ}
  : equiv (F |₁ A) (A |₂ F)
| parallel_assoc₁
    {Γ} {b y} {F : concretion ℍ ω Γ b y} {A B : species ℍ ω Γ}
  : equiv ((F |₁ A) |₁ B) (F |₁ (A |ₛ B))
| parallel_assoc₂
    {Γ} {b y} {F : concretion ℍ ω Γ b y} {A B : species ℍ ω Γ}
  : equiv ((A |₂ F) |₁ B) (A |₂ (F |₁ B))

-- Projections for species into parallel/apply
| ξ_parallel
    {Γ} {b y} {F : concretion ℍ ω Γ b y} {A B : species ℍ ω Γ}
  : A ≈ B → equiv (F |₁ A) (F |₁ B)
| ξ_apply
    {Γ} {b y} {bs : vector (name Γ) b} {A B : species ℍ ω (context.extend y Γ)}
  : A ≈ B → equiv (#(bs; y) A) (#(bs; y) B)

-- Standard ν rules
| ν_parallel₁
    {Γ} {b y} (M : affinity ℍ)
    {A : species ℍ ω Γ} {F : concretion ℍ ω (context.extend M.arity Γ) b y}
  : equiv (ν'(M)(species.rename name.extend A |₂ F)) (A |₂ ν'(M) F)
| ν_parallel₂
    {Γ} {b y} (M : affinity ℍ)
    {A : species ℍ ω (context.extend M.arity Γ)} {F : concretion ℍ ω Γ b y}
  : equiv (ν'(M)(concretion.rename name.extend F |₁ A)) (F |₁ (ν(M) A))
| ν_drop
    {Γ} {b y} (M : affinity ℍ) {F : concretion ℍ ω Γ b y}
  : equiv (ν'(M) rename name.extend F) F
| ν_swap
    {Γ} {b y} (M N : affinity ℍ)
    {F : concretion ℍ ω (context.extend N.arity (context.extend M.arity Γ)) b y}
  : equiv (ν'(M)ν'(N) F) (ν'(N)ν'(M) rename name.swap F)

| apply_parallel
    {Γ} {b y} {bs : vector (name Γ) b}
    {A : species ℍ ω Γ} {B : species ℍ ω (context.extend y Γ)}
  : equiv (#(bs; y) (species.rename name.extend A |ₛ B)) (A |₂ #(bs; y) B)

instance {Γ} {b y} : is_equiv (concretion ℍ ω Γ b y) equiv :=
  { refl := @equiv.refl ℍ _ _ Γ b y, symm := @equiv.symm ℍ _ _ Γ b y, trans := @equiv.trans ℍ _ _ Γ b y }
instance {Γ} {b y} : is_refl (concretion ℍ ω Γ b y) equiv := ⟨ λ _, equiv.refl ⟩

namespace equiv
  /-- The setoid of species under structural congruence. Can be brought into
      scope with the "congruence" locale. -/
  def setoid {Γ} {b y} : setoid (concretion ℍ ω Γ b y) :=
    ⟨ equiv, ⟨ @refl ℍ _ _ Γ b y, @symm ℍ _ _ Γ b y, @trans ℍ _ _ Γ b y ⟩ ⟩

  localized "attribute [instance] cpi.concretion.equiv.setoid" in congruence

  protected lemma ξ_parallel'
      {Γ} {b y} {F : concretion ℍ ω Γ b y} {A A' : species ℍ ω Γ} (eq : A ≈ A')
    : (A |₂ F) ≈ (A' |₂ F) :=
      calc  (A |₂ F)
          ≈ (F |₁ A) : symm parallel_symm
      ... ≈ (F |₁ A') : ξ_parallel eq
      ... ≈ (A' |₂ F) : parallel_symm

  protected lemma parallel_assoc₃
      {Γ} {b y : ℕ} {A B : species ℍ ω Γ} {F : concretion ℍ ω Γ b y}
    : ((A |ₛ B) |₂ F) ≈ (A |₂ B |₂ F) :=
    calc  ((A |ₛ B) |₂ F)
        ≈ (F |₁ (A |ₛ B)) : symm parallel_symm
    ... ≈ ((F |₁ A) |₁ B) : symm parallel_assoc₁
    ... ≈ ((A |₂ F) |₁ B) : ξ_parallel₁ parallel_symm
    ... ≈ (A |₂ F |₁ B) : parallel_assoc₂
    ... ≈ (A |₂ B |₂ F) : ξ_parallel₂ parallel_symm

end equiv
end concretion

end cpi

#lint-