import for_mathlib.category_theory.lifting_properties.continuous_functor

noncomputable theory

universes w v u

open category_theory category_theory.category category_theory.limits

section

variables {α : Type w} [partial_order α] {a b : α}

lemma is_bot.unique (ha : is_bot a) (hb : is_bot b) :
  a = b :=
le_antisymm (ha _) (hb _)

lemma is_bot.of_le (ha : is_bot b) (a : α) (h : a ≤ b) : is_bot a :=
λ c, h.trans (ha c)

lemma is_top.unique (ha : is_top a) (hb : is_top b) :
  a = b :=
le_antisymm (hb _) (ha _)

variables (a b)

def order.are_succ : Prop := (a < b) ∧
  ∀ (c : α) (hc₁ : a ≤ c) (hc₂ : c < b), c = a

def order.is_succ : Prop :=
  ∃ (a : α), order.are_succ a b

def order.is_limit : Prop :=
  (¬is_bot a) ∧ (¬order.is_succ a)

variables {a b}

def order.are_succ.lt (h : order.are_succ a b) : a < b := h.1

def order.are_succ.le (h : order.are_succ a b) : a ≤ b := h.1.le

def order.are_succ.hom (h : order.are_succ a b) :
  a ⟶ b := hom_of_le h.1.le

lemma order.are_succ.of_le_iff {m : α} (a b : { x : α // x ≤ m}) :
  order.are_succ a b ↔ order.are_succ a.1 b.1 :=
begin
  split,
  { intro h,
    exact ⟨h.1, λ c hc₁ hc₂, subtype.ext_iff.1 (h.2 ⟨c, hc₂.le.trans b.2⟩ hc₁ hc₂)⟩, },
  { intro h,
    exact ⟨h.1, λ c hc₁ hc₂, by { ext, exact h.2 c.1 hc₁ hc₂}⟩, },
end

lemma order.is_succ.of_le_iff {m : α} (b : { x : α // x ≤ m}) :
  order.is_succ b ↔ order.is_succ b.1 :=
begin
  split,
  { rintro ⟨a, ha⟩,
    rw order.are_succ.of_le_iff at ha,
    exact ⟨_, ha⟩, },
  { rintro ⟨a, ha⟩,
    let a' : { x // x ≤ m} := ⟨a, ha.1.le.trans b.2⟩,
    exact ⟨_, (order.are_succ.of_le_iff a' b).2 ha⟩, },
end

@[simps, nolint unused_arguments]
def order.lt_inclusion_functor (m : α) :
  { a : α // a < m } ⥤ α :=
monotone.functor (subtype.mono_coe _)

@[simps]
def order.lt_cocone (m : α) {C : Type*} [category C] (F : α ⥤ C) :
  cocone (order.lt_inclusion_functor m ⋙ F) :=
{ X := F.obj m,
  ι :=
  { app := λ a, F.map (hom_of_le a.2.le),
    naturality' := λ a b f, begin
      dsimp,
      simp only [comp_id, ← F.map_comp],
      congr,
    end, }, }

@[simps]
def order.le_inclusion_functor_of_le (m₁ m₂ : α) (h : m₁ ≤ m₂) :
  { a : α // a ≤ m₁ } ⥤ { a : α // a ≤ m₂ } :=
begin
  let φ : { a : α // a ≤ m₁ } → { a : α // a ≤ m₂ } := λ a, ⟨a.1, a.2.trans h⟩,
  have hφ : monotone φ := λ a b hab, hab,
  exact monotone.functor hφ,
end

@[simps]
def order.order_iso_lt_le (m₁ m₂ : α) (h : m₁ ≤ m₂) (b : { x // x ≤ m₁}) :
  order_iso { y : { x // x ≤ m₁ } // y < b } { y : { x // x ≤ m₂ } // y < ⟨b.1, b.2.trans h⟩ } :=
{ to_fun := λ y, ⟨⟨y.1.1, y.1.2.trans h⟩, y.2⟩,
  inv_fun := λ y, ⟨⟨y.1, (show y.1.1 ≤ b.1, by exact y.2.le).trans (b.2 : b.1 ≤ m₁)⟩, y.2⟩,
  left_inv := λ y, by { ext, refl, },
  right_inv := λ y, by { ext, refl, },
  map_rel_iff' := λ x y, ⟨λ h, h, λ h, h⟩, }

@[simps]
def order_iso.to_equivalence {α : Type u } {β : Type v} [preorder α] [preorder β]
  (e : order_iso α β) : α ≌ β :=
{ functor := monotone.functor e.monotone,
  inverse := monotone.functor e.symm.monotone,
  unit_iso := eq_to_iso (category_theory.functor.ext (λ a, (e.left_inv a).symm)
    (λ a₁ a₂ f, subsingleton.elim _ _)),
  counit_iso := eq_to_iso (category_theory.functor.ext (λ b, (e.right_inv b))
    (λ b₁ b₂ f, subsingleton.elim _ _)),
  functor_unit_iso_comp' := λ X, subsingleton.elim _ _, }

@[simps]
def order.lt_inclusion_functor_iso_of_le (m₁ m₂ : α) (h : m₁ ≤ m₂) (b : { x // x ≤ m₁}) :
  order.lt_inclusion_functor b ⋙ order.le_inclusion_functor_of_le m₁ m₂ h ≅
    (order.order_iso_lt_le m₁ m₂ h b).to_equivalence.functor ⋙
      order.lt_inclusion_functor (⟨b, b.2.trans h⟩ : { x // x ≤ m₂ }) := iso.refl _

@[simps]
def order.lt_inclusion_functor_iso_of_le' (m₁ m₂ : α) (h : m₁ ≤ m₂) (b : { x // x ≤ m₁}) :
  (order.order_iso_lt_le m₁ m₂ h b).to_equivalence.inverse ⋙
    order.lt_inclusion_functor b ⋙ order.le_inclusion_functor_of_le m₁ m₂ h ≅
      order.lt_inclusion_functor (⟨b, b.2.trans h⟩ : { x // x ≤ m₂ }) :=
iso_whisker_left (order.order_iso_lt_le m₁ m₂ h b).to_equivalence.inverse
  (order.lt_inclusion_functor_iso_of_le m₁ m₂ h b) ≪≫ (functor.associator _ _ _).symm ≪≫
  iso_whisker_right (order.order_iso_lt_le m₁ m₂ h b).to_equivalence.counit_iso _ ≪≫
  functor.left_unitor _

lemma is_bot.subsingleton_le {m : α} (hm : is_bot m) :
  subsingleton {a // a ≤ m} :=
⟨λ x₁ x₂, begin
  have eq : ∀ (x : {x // x ≤ m}), x = ⟨m, hm m⟩ := λ x, le_antisymm x.2 (hm _),
  rw [eq x₁, eq x₂],
end⟩

end

section

variables {α : Type*} [linear_order α]

@[simp]
lemma is_bot.of_le_iff {m : α} (a : { x : α // x ≤ m}) :
  is_bot a ↔ is_bot a.1 :=
begin
  split,
  { intros h b,
    by_cases hb : b ≤ m,
    { exact h ⟨b, hb⟩, },
    { exact a.2.trans (not_le.1 hb).le, }, },
  { intros h b,
    exact h b.1, },
end

lemma order.is_limit.of_le_iff {m : α} (a : { x : α // x ≤ m}) :
  order.is_limit a ↔ order.is_limit a.1 :=
begin
  dsimp only [order.is_limit],
  rw [is_bot.of_le_iff, order.is_succ.of_le_iff],
end

lemma order.are_succ.lt_iff_le {a b : α} (h : order.are_succ a b) (c : α) : c < b ↔ c ≤ a :=
begin
  split,
  { intro hc,
    by_contra',
    simpa only [h.2 c this.le hc, lt_self_iff_false] using this, },
  { intro hc,
    exact lt_of_le_of_lt hc h.lt, },
end

lemma order.are_succ.pred_uniq {a a' b : α} (h₁ : order.are_succ a b) (h₂ : order.are_succ a' b) :
  a = a' :=
le_antisymm (by simpa only [← h₂.lt_iff_le] using h₁.lt)
  (by simpa only [← h₁.lt_iff_le] using h₂.lt)

section

variables {C : Type*} [category C] {m : α} (hm : is_top m)
  (F G : α ⥤ C) (φ : order.lt_inclusion_functor m ⋙ F ⟶ order.lt_inclusion_functor m ⋙ G)
  (φm : F.obj m ⟶ G.obj m)
  (comm : ∀ (a : { x // x < m }), F.map (hom_of_le (hm a.1)) ≫ φm =
    φ.app a ≫ G.map (hom_of_le (hm a.1)))

include comm

def is_top.mk_nat_trans : F ⟶ G :=
{ app := λ a, begin
    by_cases a < m,
    { exact φ.app ⟨a, h⟩, },
    { refine eq_to_hom _ ≫ φm ≫ eq_to_hom _,
      all_goals
      { rw le_antisymm (hm _) (not_lt.1 h), }, },
  end,
  naturality' := λ a₁ a₂ ψ, begin
    by_cases h₂ : a₂ < m,
    { have h₁ := lt_of_le_of_lt (le_of_hom ψ) h₂,
      rw [dif_pos h₁, dif_pos h₂],
      let b₁ : { x // x < m} := ⟨a₁, h₁⟩,
      let b₂ : { x // x < m} := ⟨a₂, h₂⟩,
      have ψ' : b₁ ≤ b₂ := le_of_hom ψ,
      convert φ.naturality (hom_of_le ψ'), },
    { have h₂' := le_antisymm (not_lt.1 h₂) (hm a₂),
      subst h₂',
      rw dif_neg (lt_irrefl m),
      by_cases h₁ : a₁ < m,
      { simp only [dif_pos h₁, eq_to_hom_refl, id_comp, comp_id],
        convert comm ⟨a₁ ,h₁⟩, },
      { have h₁' := le_antisymm (not_lt.1 h₁) (hm a₁),
        subst h₁',
        simp only [dif_neg (lt_irrefl m), subsingleton.elim ψ (𝟙 _),
          category_theory.functor.map_id, comp_id, id_comp], }, },
  end, }

lemma is_top.mk_nat_trans_eq (a : α) (ha : a < m) :
  (is_top.mk_nat_trans hm F G φ φm comm).app a = φ.app ⟨a, ha⟩ :=
begin
  dsimp only [is_top.mk_nat_trans],
  rw dif_pos ha,
end

@[simp]
lemma is_top.mk_nat_trans_eq' :
  (is_top.mk_nat_trans hm F G φ φm comm).app m = φm :=
begin
  dsimp only [is_top.mk_nat_trans],
  simp only [dif_neg (lt_irrefl m), eq_to_hom_refl, comp_id, id_comp],
end

end

section

variables {C : Type*} [category C] {m₁ m₂ : α} (hm₁₂ : order.are_succ m₁ m₂)
  (hm₂ : is_top m₂)
  (F G : α ⥤ C) (φ : order.lt_inclusion_functor m₂ ⋙ F ⟶ order.lt_inclusion_functor m₂ ⋙ G)
  (φm : F.obj m₂ ⟶ G.obj m₂)
  (comm : F.map hm₁₂.hom ≫ φm = φ.app ⟨m₁, hm₁₂.lt⟩ ≫ G.map hm₁₂.hom)

include comm

def order.are_succ.mk_nat_trans : F ⟶ G :=
hm₂.mk_nat_trans F G φ φm (λ a, begin
  have r : a.1 ≤ m₁ := (hm₁₂.lt_iff_le _).1 a.2,
  have r' : a ≤ ⟨m₁, hm₁₂.lt⟩ := r,
  simp only [subsingleton.elim (hom_of_le (r.trans hm₁₂.le)) (hom_of_le r ≫ hom_of_le hm₁₂.le),
    functor.map_comp, assoc],
  erw comm,
  apply φ.naturality_assoc (hom_of_le r'),
end)

lemma order.are_succ.mk_nat_trans_eq (a : α) (ha : a < m₂) :
  (order.are_succ.mk_nat_trans hm₁₂ hm₂ F G φ φm comm).app a = φ.app ⟨a, ha⟩ :=
begin
  dsimp only [order.are_succ.mk_nat_trans],
  apply is_top.mk_nat_trans_eq,
end

@[simp]
lemma order.are_succ.mk_nat_trans_eq' :
  (order.are_succ.mk_nat_trans hm₁₂ hm₂ F G φ φm comm).app m₂ = φm :=
begin
  dsimp only [order.are_succ.mk_nat_trans],
  apply is_top.mk_nat_trans_eq',
end

end

end

lemma is_well_order.three_cases {α : Type*} [linear_order α] [is_well_order α (<)]
  (a : α) : is_bot a ∨ order.is_succ a ∨ order.is_limit a :=
begin
  by_cases h₁ : is_bot a,
  { exact or.inl h₁, },
  { by_cases h₂ : order.is_succ a,
    { exact or.inr (or.inl h₂), },
    { exact or.inr (or.inr ⟨h₁, h₂⟩), }, },
end

lemma is_well_order.two_cases {α : Type*} [linear_order α] [is_well_order α (<)]
  (a : α) (ha : ¬is_bot a) : order.is_succ a ∨ order.is_limit a :=
begin
  by_cases order.is_succ a,
  { exact or.inl h, },
  { exact or.inr ⟨ha, h⟩, },
end

instance is_well_order_subtype {α : Type*} [linear_order α] [is_well_order α (<)]
  (P : α → Prop) : is_well_order { a : α // P a } (<) :=
begin
  haveI : is_trichotomous { a : α // P a } (<) := ⟨λ a b, begin
    rcases @is_trichotomous.trichotomous α (<) _ a.1 b.1 with h₁ | (h₂ | h₃),
    { exact or.inl h₁, },
    { exact or.inr (or.inl (by { ext, exact h₂, })), },
    { exact or.inr (or.inr h₃), },
  end⟩,
  haveI : is_trans { a : α // P a } (<) := ⟨λ a b c hab hbc, hab.trans hbc⟩,
  haveI : is_well_founded { a : α // P a } (<) := ⟨⟨begin
    rintro ⟨a, ha⟩,
    apply @well_founded.induction α (<) is_well_founded.wf (λ (a : α),
      ∀ (ha : P a), acc (<) (⟨a, ha⟩ : { b : α // P b})),
    refine λ b H hb, acc.intro _ _,
    rintro ⟨a, ha⟩ hab,
    exact H a hab ha,
  end⟩⟩,
  constructor,
end

namespace category_theory

namespace functor

variables {C : Type u} [category.{v} C] {α : Type*}
  {Φ : C ⥤ C} (τ : 𝟭 C ⟶ Φ)

structure transfinite_iteration [partial_order α] (m : α) :=
(F : { a : α // a ≤ m } ⥤ C)
(hF : ∀ (b : { a : α // a ≤ m }) (hb : order.is_limit b),
  is_colimit (order.lt_cocone b F))
(iso : Π (a b : { a : α // a ≤ m }) (hab : order.are_succ a b),
  under.mk (F.map hab.hom) ≅ under.mk (τ.app (F.obj a)))

namespace transfinite_iteration

variables {τ} {α}

section

variables [partial_order α] {m : α}

@[ext]
structure hom (I₁ I₂ : transfinite_iteration τ m) :=
(f : I₁.F ⟶ I₂.F)
(commτ : Π (a b : { a : α // a ≤ m}) (hab : order.are_succ a b),
  (I₁.iso a b hab).hom.right ≫ Φ.map (f.app a) =
    f.app b ≫ (I₂.iso a b hab).hom.right)

@[simps]
def hom.id (I : transfinite_iteration τ m) :
  hom I I :=
{ f := 𝟙 _,
  commτ := by tidy, }

@[simps]
def hom.comp {I₁ I₂ I₃ : transfinite_iteration τ m} (f : hom I₁ I₂) (g : hom I₂ I₃) :
  hom I₁ I₃ :=
{ f := f.f ≫ g.f,
  commτ := λ a b hab, by simp only [nat_trans.comp_app, map_comp, assoc,
      reassoc_of (f.commτ a b hab), g.commτ a b hab], }

instance : category (transfinite_iteration τ m) :=
{ hom := hom,
  id := hom.id,
  comp := λ I₁ I₂ I₃, hom.comp, }

variables (τ m)

@[simps]
def eval (a : { b : α // b ≤ m}) : transfinite_iteration τ m ⥤ C :=
{ obj := λ I, I.F.obj a,
  map := λ I₁ I₂ f, f.f.app a, }

end

section

variables [linear_order α] {m : α}

def restriction (m₁ m₂ : α) (h : m₁ ≤ m₂) :
  transfinite_iteration τ m₂ ⥤ transfinite_iteration τ m₁ :=
{ obj := λ I,
  { F := order.le_inclusion_functor_of_le _ _ h ⋙ I.F,
    hF := begin
      rintro ⟨b, hb⟩ hb',
      have hc := I.hF ⟨b, hb.trans h⟩ (by simpa only [order.is_limit.of_le_iff] using hb'),
      apply limits.is_colimit.of_whisker_equivalence
        (order.order_iso_lt_le m₁ m₂ h ⟨b, hb⟩).to_equivalence.symm,
      let e := order.lt_inclusion_functor_iso_of_le' m₁ m₂ h ⟨b, hb⟩,
      let e' := iso_whisker_right e I.F,
      let e'' : (order.order_iso_lt_le m₁ m₂ h ⟨b, hb⟩).to_equivalence.inverse ⋙
        order.lt_inclusion_functor ⟨b, hb⟩ ⋙ order.le_inclusion_functor_of_le m₁ m₂ h ⋙
        I.F ≅ _ := e',
      equiv_rw (limits.is_colimit.precompose_hom_equiv e''.symm _).symm,
      refine is_colimit.of_iso_colimit hc (cocones.ext (iso.refl _) (λ a, _)),
      dsimp,
      simpa only [comp_id, ← I.F.map_comp],
    end,
    iso := λ a b hab, I.iso ⟨a.1, a.2.trans h⟩ ⟨b.1, b.2.trans h⟩
      (by simpa only [order.are_succ.of_le_iff] using hab), },
  map := λ I₁ I₂ f,
  { f := whisker_left (order.le_inclusion_functor_of_le _ _ h) f.f,
    commτ := λ a b hab, f.commτ ⟨a.1, a.2.trans h⟩ ⟨b.1, b.2.trans h⟩
      (by simpa only [order.are_succ.of_le_iff] using hab), }, }

end

variables (τ) [linear_order α] [is_well_order α (<)] (m : α) (a₀ : { b : α // b ≤ m})
  (ha₀ : is_bot a₀)

include ha₀

lemma faithful_eval_zero : faithful (eval τ m a₀) :=
⟨λ I₁ I₂ f g h, begin
  ext b,
  apply @well_founded.induction { b : α // b ≤ m } (<) is_well_founded.wf
    (λ b, f.f.app b = g.f.app b),
  intros b H,
  rcases is_well_order.three_cases b with h₁ | (h₂ | h₃),
  { have eq := is_bot.unique ha₀ h₁,
    subst eq,
    exact h, },
  { obtain ⟨a, hab⟩ := h₂,
    simp only [← cancel_mono ((under.forget _).map (I₂.iso a b hab).hom),
      under.forget_map, ← f.commτ a b hab, H a hab.lt, g.commτ a b hab], },
  { apply (I₁.hF b h₃).hom_ext,
    intro a,
    simp only [order.lt_cocone_ι_app, nat_trans.naturality],
    congr' 1,
    exact H a a.2, },
end⟩

variable {m}

lemma eval_injective (I₁ I₂ : transfinite_iteration τ m) (m₁ m₂ : { x // x ≤ m})
  (f₁ : (restriction m₁.1 m m₁.2).obj I₁ ⟶ (restriction m₁.1 m m₁.2).obj I₂)
  (f₂ : (restriction m₂.1 m m₂.2).obj I₁ ⟶ (restriction m₂.1 m m₂.2).obj I₂)
  (eq : f₁.f.app ⟨a₀.1, ha₀ _⟩ = f₂.f.app ⟨a₀.1, ha₀ _⟩)
  (a : { x // x ≤ m}) (ha₁ : a ≤ m₁) (ha₂ : a ≤ m₂) :
  f₁.f.app ⟨a.1, ha₁⟩ = f₂.f.app ⟨a.1, ha₂⟩ :=
begin
  suffices : (restriction a.1 m₁.1 ha₁).map f₁ = (restriction a.1 m₂.1 ha₂).map f₂,
  { exact congr_app (congr_arg transfinite_iteration.hom.f this) ⟨a.1, le_refl _⟩, },
  haveI := faithful_eval_zero τ a.1 ⟨a₀, ha₀ _⟩
    (by simpa only [is_bot.of_le_iff] using ha₀),
  exact (eval τ a.1 ⟨a₀, ha₀ _⟩).map_injective eq,
end

variable (m)

lemma full_eval_zero : full (eval τ m a₀) :=
nonempty.some begin
  rcases a₀ with ⟨a₀, ha₁⟩,
  rw is_bot.of_le_iff at ha₀,
  dsimp at ha₀,
  apply @well_founded.induction α (<) is_well_founded.wf (λ (m' : α), nonempty
    (full (eval τ m' ⟨a₀, ha₀ _⟩))),
  clear ha₁ m,
  intros m H,
  refine ⟨full_of_surjective _ (λ I₁ I₂ f, _)⟩,
  dsimp at f,
  by_cases hm : is_bot m,
  { haveI : subsingleton { x // x ≤ m},
    { have hm : ∀ (a : { x // x ≤ m}), a = ⟨a₀, ha₀ _⟩ :=
        λ a, le_antisymm (a.2.trans (hm _)) (ha₀ _),
      exact ⟨λ x y, by rw [hm x, hm y]⟩, },
    refine
    ⟨{ f :=
      { app := λ a, eq_to_hom (by congr) ≫ f ≫ eq_to_hom (by congr),
        naturality' := λ a₁ a₂ φ, begin
          have h₁₂ := subsingleton.elim a₁ a₂,
          subst h₁₂,
          simp only [subsingleton.elim φ (𝟙 _), map_id, id_comp, comp_id],
        end, },
      commτ := λ a b hab, begin
        exfalso,
        rw subsingleton.elim a b at hab,
        simpa only [lt_self_iff_false] using hab.1,
      end, }, _⟩,
    dsimp,
    simp only [comp_id, id_comp], },
  { let X := { x // x < m},
    let R₁ := λ (a : X), (restriction a.1 m a.2.le).obj I₁,
    let R₂ := λ (a : X), (restriction a.1 m a.2.le).obj I₂,
    have h : ∀ (a : X), ∃ (Φ : R₁ a ⟶ R₂ a),
      (eval τ a.1 ⟨a₀, ha₀ _⟩).map Φ = f,
    { intros a,
      haveI := (H a.1 a.2).some,
      apply (eval τ a.1 ⟨a₀, ha₀ _⟩).map_surjective, },
    let Ψ := λ (a : X), (h a).some,
    have hΨ : ∀ (a : X), (Ψ a).f.app ⟨a₀, ha₀ _⟩ = f := λ a, (h a).some_spec,
    have hΨ' : ∀ (a₁ a₂ : X) (ha₁₂ : a₁ ≤ a₂) (b : α) (hb : b ≤ a₁.1),
      (Ψ a₁).f.app ⟨b, hb⟩ = (Ψ a₂).f.app ⟨b, hb.trans ha₁₂⟩,
    { intros a₁ a₂ ha₁₂ b hb,
      exact eval_injective τ ⟨a₀, ha₀ _⟩ (by simpa only [is_bot.of_le_iff] using ha₀)
        I₁ I₂ ⟨a₁.1, a₁.2.le⟩ ⟨a₂.1, a₂.2.le⟩ (Ψ a₁) (Ψ a₂) (by erw [hΨ a₁, hΨ a₂])
        ⟨b, hb.trans a₁.2.le⟩ hb (hb.trans ha₁₂), },
    let m' : { x // x ≤ m} := ⟨m, le_refl m⟩,
    have hm' : is_top m' := λ a, a.2,
    let φ' : order.lt_inclusion_functor m' ⋙ I₁.F ⟶ order.lt_inclusion_functor m' ⋙ I₂.F :=
    { app := by { rintro ⟨⟨a, ha⟩, ha'⟩, exact (Ψ ⟨a, ha'⟩).f.app ⟨a, le_refl _⟩, },
      naturality' := begin
        rintro ⟨⟨a₁, ha₁⟩, ha₁'⟩ ⟨⟨a₂, ha₂⟩, ha₂'⟩ g,
        dsimp,
        rw hΨ' ⟨a₁, ha₁'⟩ ⟨a₂, ha₂'⟩ (le_of_hom g),
        let a₁' : {x // x ≤ a₂} := ⟨a₁, le_of_hom g⟩,
        let a₂' : {x // x ≤ a₂} := ⟨a₂, le_refl _⟩,
        let g' : a₁' ⟶ a₂' := hom_of_le (le_of_hom g),
        exact (Ψ ⟨a₂, ha₂'⟩).f.naturality g',
      end },
    cases is_well_order.two_cases _ hm with hm'' hm'',
    { obtain ⟨m₁, hm₁⟩ := hm'',
      have hm₁' := (order.are_succ.of_le_iff ⟨m₁, hm₁.le⟩ m').2 hm₁,
      let m₁' : { x // x < m'} := ⟨⟨m₁, hm₁.le⟩, hm₁.lt⟩,
      let φm : I₁.F.obj m' ⟶ I₂.F.obj m' := (under.forget _).map (I₁.iso _ _ hm₁').hom ≫
        Φ.map (φ'.app m₁') ≫ (under.forget _).map (I₂.iso _ _ hm₁').inv,
      refine ⟨{ f := hm₁'.mk_nat_trans hm' _ _ φ' φm _, commτ := _, }, _⟩,
      { have eq := τ.naturality (φ'.app m₁'),
        have eq₁ := under.w (I₁.iso _ _ hm₁').hom,
        have eq₂ := under.w (I₂.iso _ _ hm₁').hom,
        have eq₃ := ((under.forget _).map_iso (I₂.iso _ _ hm₁')).hom_inv_id,
        dsimp [φm] at ⊢ eq eq₁ eq₂ eq₃,
        rw [← eq₁, ← eq₂, assoc] at eq,
        slice_lhs 1 3 { rw ← eq, },
        simp only [assoc, eq₃, comp_id], },
      { rintro ⟨a, ha⟩ ⟨b, hb⟩ hab,
        by_cases hb' : b < m,
        { have ha' : a < m := lt_of_le_of_lt hab.le hb',
          rw [hm₁'.mk_nat_trans_eq hm' _ _ _ _ _ ⟨b, hb⟩ hb',
            hm₁'.mk_nat_trans_eq hm' _ _ _ _ _ ⟨a, ha⟩ ha'],
          dsimp [φ'],
          rw [hΨ' ⟨a, ha'⟩ ⟨b, hb'⟩ hab.le a (le_refl _)],
          exact (Ψ ⟨b, hb'⟩).commτ ⟨a, hab.le⟩ ⟨b, le_refl _⟩
            (by simpa only [order.are_succ.of_le_iff] using hab), },
        { have hb'' : m = b := le_antisymm (not_lt.1 hb') hb,
          subst hb'',
          have ha' : m₁ = a := order.are_succ.pred_uniq hm₁ ((order.are_succ.of_le_iff _ _).1 hab),
          subst ha',
          rw [hm₁'.mk_nat_trans_eq' hm', hm₁'.mk_nat_trans_eq hm' _ _ _ _ _ ⟨m₁, ha⟩ hm₁.lt],
          dsimp [φm],
          have eq := ((under.forget _).map_iso (I₂.iso ⟨m₁, ha⟩ ⟨m, hb⟩ hab)).inv_hom_id,
          dsimp at eq,
          simp only [assoc, eq, comp_id], }, },
      { dsimp,
        let a₀' : { x // x ≤ m} := ⟨a₀, ha₀ _⟩,
        have ha₀' : a₀' < m',
        { rw hm₁'.lt_iff_le,
          apply ha₀, },
        rw hm₁'.mk_nat_trans_eq hm' _ _ _ _ _ a₀' ha₀',
        dsimp [φ'],
        rw hΨ, }, },
    { let φm : I₁.F.obj m' ⟶ I₂.F.obj m' := (I₁.hF m'
        ((order.is_limit.of_le_iff m').2 hm'')).desc (cocone.mk (I₂.F.obj m')
          { app := begin
              rintro ⟨⟨a, ha⟩, ha'⟩,
              exact (Ψ ⟨a, ha'⟩).f.app ⟨a, le_refl _⟩ ≫ I₂.F.map (hom_of_le ha),
            end,
            naturality' := begin
              rintro ⟨⟨a, ha⟩, ha'⟩ ⟨⟨b, hb⟩, hb'⟩ hab,
              dsimp,
              rw [comp_id, hΨ' ⟨a, ha'⟩ ⟨b, hb'⟩ (le_of_hom hab) a (le_refl _)],
              let a' : { x // x ≤ b} := ⟨a, le_of_hom hab⟩,
              let b' : { x // x ≤ b} := ⟨b, le_refl _⟩,
              let hab' : a' ⟶ b' := hom_of_le a'.2,
              let a'' : {x // x ≤ m} := ⟨a, ha⟩,
              let b'' : {x // x ≤ m} := ⟨b, hb⟩,
              let g : b'' ⟶ m' := hom_of_le hb,
              let hab'' : a'' ⟶ b'' := hab,
              have eq' := subsingleton.elim (hom_of_le ha : a'' ⟶ m') (hab'' ≫ hom_of_le hb),
              rw [eq', I₂.F.map_comp],
              have eq := (Ψ ⟨b, hb'⟩).f.naturality hab' =≫ I₂.F.map g,
              simp only [assoc] at eq,
              convert eq,
            end }),
      refine ⟨{ f := hm'.mk_nat_trans _ _ φ' φm _, commτ := _, }, _⟩,
      { rintro ⟨⟨a, ha⟩, ha'⟩,
        apply (I₁.hF m' ((order.is_limit.of_le_iff m').2 hm'')).fac, },
      { rintro ⟨a, ha⟩ ⟨b, hb⟩ hab,
        have hb' : b < m,
        { by_contra',
          have hb'' := le_antisymm this hb,
          subst hb'',
          simp only [order.are_succ.of_le_iff] at hab,
          exact hm''.2 ⟨_, hab⟩, },
        have ha' : a < m := lt_of_lt_of_le hab.lt hb,
        rw [hm'.mk_nat_trans_eq _ _ _ _ _ ⟨a, ha⟩ ha',
          hm'.mk_nat_trans_eq _ _ _ _ _ ⟨b, hb⟩ hb'],
        dsimp [φ'],
        rw hΨ' ⟨a, ha'⟩ ⟨b, hb'⟩ hab.le a (le_refl _),
        exact (Ψ ⟨b, hb'⟩).commτ ⟨a, _⟩ ⟨b, _⟩
          (by simpa only [order.are_succ.of_le_iff] using hab), },
      { dsimp,
        let a₀' : { x // x ≤ m} := ⟨a₀, ha₀ _⟩,
        have ha₀' : a₀' < m',
        { by_contra',
          apply hm''.1,
          rw ← le_antisymm a₀'.2 this,
          exact ha₀, },
        rw hm'.mk_nat_trans_eq _ _ _ _ _ a₀' ha₀',
        apply hΨ, }, }, },
end

end transfinite_iteration

section

def to_sections_lt_inclusion_functor [partial_order α] (F : αᵒᵖ ⥤ Type v) (a : α) (x : F.obj (opposite.op a)) :
  ((order.lt_inclusion_functor a).op ⋙ F).sections :=
⟨λ b, F.map (hom_of_le b.unop.2.le).op x, begin
  rintro b c f,
  dsimp,
  simpa only [← functor_to_types.map_comp_apply F],
end⟩

variables [linear_order α] [is_well_order α (<)]
  (F : αᵒᵖ ⥤ Type v)
  (hF₁ : ∀ (a b : α) (hab : order.are_succ a b), function.surjective (F.map (hom_of_le hab.le).op))
  (hF₂ : ∀ (a : α) (ha : order.is_limit a), function.surjective (F.to_sections_lt_inclusion_functor a))

namespace surjective_of_is_well_order_of_surjective

structure X :=
(β : set α)
(hβ : ∀ (x y : α) (hxy : x ≤ y) (hy : y ∈ β), x ∈ β)
(s : Π (b : β), F.obj (opposite.op b.1))
(hs : ∀ (b c : β) (h : b ≤ c), s b = F.map (hom_of_le h : b.1 ⟶ c.1).op (s c))

instance : partial_order (X F) :=
{ le := λ σ₁ σ₂, (σ₁.β ⊆ σ₂.β) ∧
    ∀ (b : α) (hb₁ : b ∈ σ₁.β) (hb₂ : b ∈ σ₂.β), σ₁.s ⟨b, hb₁⟩ = σ₂.s ⟨b, hb₂⟩,
  le_refl := by tauto,
  le_trans := λ σ₁ σ₂ σ₃ h₁₂ h₂₃,
    ⟨h₁₂.1.trans h₂₃.1, λ b hb₁ hb₃, (h₁₂.2 b hb₁ (h₁₂.1 hb₁)).trans (h₂₃.2 b (h₁₂.1 hb₁) hb₃)⟩,
  le_antisymm := λ σ₁ σ₂ h₁₂ h₂₁, begin
    rcases σ₁ with ⟨β, hβ, s, hs⟩,
    rcases σ₂ with ⟨β', hβ', s', hs'⟩,
    have eqβ : β = β',
    { ext,
      exact ⟨λ h, h₁₂.1 h, λ h, h₂₁.1 h⟩, },
    subst eqβ,
    simp only [eq_self_iff_true, heq_iff_eq, true_and],
    ext ⟨b, hb⟩,
    exact h₁₂.2 b hb hb,
  end, }

@[simps]
def X.of_is_bot (a₀ : α) (ha₀ : is_bot a₀) (x : F.obj (opposite.op a₀)) :
  X F :=
{ β := { a₀ },
  hβ := λ x y hxy hy, begin
    simp only [set.mem_singleton_iff] at hy ⊢,
    exact le_antisymm (hxy.trans (by rw hy)) (ha₀ _),
  end,
  s := begin
    rintro ⟨b, hb⟩,
    simp only [set.mem_singleton_iff] at hb,
    subst hb,
    exact x,
  end,
  hs := begin
    rintro ⟨b, hb⟩ ⟨c, hc⟩ hbc,
    simp only [set.mem_singleton_iff] at hb hc,
    substs hb hc,
    dsimp,
    erw [subsingleton.elim (hom_of_le hbc) (𝟙 _), op_id, F.map_id, types_id_apply],
  end, }

@[simp]
lemma X.of_is_bot_s₀ (a₀ : α) (ha₀ : is_bot a₀) (x : F.obj (opposite.op a₀)) :
  (X.of_is_bot F a₀ ha₀ x).s ⟨a₀, rfl⟩ = x := rfl

def X_set (a₀ : α) (ha₀ : is_bot a₀) (x₀ : F.obj (opposite.op a₀)) :=
  { σ : X F | X.of_is_bot F a₀ ha₀ x₀ ≤ σ }

variable {F}

lemma X_set_chain_condition {a₀ : α} {ha₀ : is_bot a₀} {x₀ : F.obj (opposite.op a₀)}
  (C : set (X F)) (hC₁ : C ⊆ X_set F a₀ ha₀ x₀) (hC₂ : is_chain (≤) C) :
  ∃ (m : X F) (hm : m ∈ X_set F a₀ ha₀ x₀), ∀ (z : X F) (hz : z ∈ C), z ≤ m :=
begin
  by_cases hC₀ : nonempty C,
  { let β : set α := λ b, ∃ (c : C), b ∈ c.1.β,
    let γ : β → C := λ b, b.2.some,
    have hγ : ∀ (b : β), b.1 ∈ (γ b).1.β := λ b, b.2.some_spec,
    let s : Π (b : β), F.obj (opposite.op b.val) := λ b, (γ b).1.s ⟨b.1, hγ b⟩,
    have hC₂' : ∀ (z₁ z₂ : C) (b : α) (hb₁ : b ∈ z₁.1.β) (hb₂ : b ∈ z₂.1.β),
      z₁.1.s ⟨b, hb₁⟩ = z₂.1.s ⟨b, hb₂⟩,
    { intros z₁ z₂ b hb₁ hb₂,
      by_cases hz₁₂ : z₁.1 = z₂.1,
      { have hz₁₂' : z₁ = z₂ := by { ext, exact hz₁₂, },
        subst hz₁₂', },
      { cases hC₂ z₁.2 z₂.2 hz₁₂,
        { apply h.2, },
        { symmetry, apply h.2, }, }, },
    have hs : ∀ (z : C) (b : α) (hb : b ∈ z.1.β), s ⟨b, ⟨z, hb⟩⟩ = z.1.s ⟨b, hb⟩,
    { intros s b hb,
      apply hC₂', },
    refine
    ⟨{ β := β,
      hβ := λ b₁ b₂ h₁₂ h₂, begin
        obtain ⟨c, hc⟩ := h₂,
        exact ⟨c, c.1.hβ b₁ _ h₁₂ hc⟩,
      end,
      s := s,
      hs := begin
        rintro ⟨b, hb⟩ ⟨c, hc⟩ hbc,
        let g := γ ⟨c, hc⟩,
        erw [hs g c (hγ _), hs g b (g.1.hβ _ _ hbc (hγ _))],
        exact g.1.hs ⟨b, _⟩ ⟨c, _⟩ hbc,
      end, }, _, _⟩,
    { split,
      { dsimp,
        simp only [set.singleton_subset_iff],
        exact ⟨_, (hC₁ hC₀.some.2).1 rfl⟩, },
      { intros b hb₁ hb₂,
        apply (hC₁ (γ ⟨b, hb₂⟩).2).2, }, },
    { intros z hz,
      split,
      { intros a ha,
        exact ⟨⟨z, hz⟩, ha⟩, },
      { intros b hb₁ hb₂,
        exact (hs ⟨z, hz⟩ b hb₁).symm, }, }, },
  { refine ⟨X.of_is_bot F a₀ ha₀ x₀, le_refl _, _⟩,
    intros z hz,
    exfalso,
    exact hC₀ ⟨⟨z, hz⟩⟩, },
end

section

variables (x : X F) {m : α} (hx : x.β = {a | a < m}) (t : F.obj (opposite.op m))
  (ht : ∀ (b : α) (hb : b < m),
    x.s ⟨b, by simpa only [hx] using hb⟩ = (F.map (hom_of_le hb.le).op) t)

include ht

@[simps]
def X.extension : X F :=
{ β := {a | a ≤ m},
  hβ := λ x y hxy hy, hxy.trans hy,
  s := begin
    rintro ⟨b, hb⟩,
    by_cases b < m,
    { exact x.s ⟨b, by simpa only [hx] using h⟩, },
    { have hb' := le_antisymm (not_lt.1 h) hb,
      subst hb',
      exact t, },
  end,
  hs := begin
    rintro ⟨b, hb⟩ ⟨c, hc⟩ (hbc : b ≤ c),
    dsimp,
    by_cases hc' : c < m,
    { have hb' : b < m := lt_of_le_of_lt hbc hc',
      rw [dif_pos hb', dif_pos hc'],
      exact x.hs ⟨b, by simpa only [hx] using hb'⟩ ⟨c, by simpa only [hx] using hc'⟩ hbc, },
    { replace hc' : m = c := le_antisymm (not_lt.1 hc') hc,
      subst hc',
      by_cases hb' : b < m,
      { dsimp,
        simp only [dif_pos hb', lt_self_iff_false, not_false_iff, dif_neg],
        apply ht, },
      { replace hb' : m = b := le_antisymm (not_lt.1 hb') hb,
        subst hb',
        dsimp,
        simp only [lt_self_iff_false, not_false_iff, dif_neg,
          subsingleton.elim (hom_of_le hbc) (𝟙 _), op_id, F.map_id, types_id_apply], }, },
  end, }

lemma X.le_extension : x < X.extension x hx t ht :=
begin
  have hx' : x ≠ X.extension x hx t ht,
  { intro h,
    rw ← lt_self_iff_false m,
    change m ∈ { x | x < m},
    rw [← hx, h],
    apply le_refl, },
  suffices : x ≤ X.extension x hx t ht,
  { cases this.lt_or_eq,
    { exact h, },
    { exfalso,
      refine hx' h, }, },
  split,
  { dsimp,
    simp only [hx, set.set_of_subset_set_of],
    intros a ha,
    exact ha.le, },
  { intros b hb₁ hb₂,
    have hb₁' : b < m := by simpa only [hx] using hb₁,
    dsimp,
    rw dif_pos hb₁', },
end

end

end surjective_of_is_well_order_of_surjective

include hF₁ hF₂

open surjective_of_is_well_order_of_surjective

lemma surjective_of_is_well_order_of_surjective' (a₀ : α) (ha₀ : is_bot a₀):
  function.surjective (λ (s : F.sections), s.1 (opposite.op a₀)) :=
λ x₀, begin
  obtain ⟨m, hm₀ : X.of_is_bot F a₀ ha₀ x₀ ≤ m, hm⟩ :=
    zorn_partial_order₀ (X_set F a₀ ha₀ x₀) (by apply X_set_chain_condition),
  suffices : m.β = ⊤,
  { have hm' : ∀ (b : α), b ∈ m.β := λ b, by simp only [this, set.top_eq_univ],
    refine ⟨⟨λ b, m.s ⟨b.unop, hm' _⟩, _⟩, _⟩,
    { intros b c f,
      have eq := m.hs ⟨c.unop, hm' _⟩ ⟨b.unop, hm' _⟩ (le_of_hom f.unop),
      convert eq.symm, },
    { dsimp,
      simp only [← hm₀.2 a₀ (by simp) (hm' _), X.of_is_bot_s], }, },
  replace hm : ∀ (z : X F) (hz : m ≤ z), z = m := λ z hz, hm z (hm₀.trans hz) hz,
  by_contra' hm',
  replace hm' : (m.βᶜ : set α).nonempty,
  { simp only [set.nonempty_iff_ne_empty],
    intro h,
    apply hm',
    rw [← compl_compl m.β, h, set.compl_empty, set.top_eq_univ], },
  let b := @well_founded.min α (<) is_well_founded.wf _ hm',
  have hb : m.β = { x | x < b},
  { have hb' : b ∈ m.βᶜ := well_founded.min_mem _ _ _,
    ext a,
    split,
    { intro ha,
      dsimp,
      by_contra',
      exact hb' (m.hβ _ _ this ha), },
    { intro ha,
      dsimp at ha,
      by_contra ha',
      have ha'' : ¬ (a < b):= well_founded.not_lt_min _ _ _ ha',
      exact ha'' ha, }, },
  rcases is_well_order.three_cases b with h₁ | (h₂ | h₃),
  { rw is_bot.unique h₁ ha₀ at hb,
    have ha₀' : a₀ ∉ m.β,
    { simp only [hb, set.mem_set_of_eq, lt_self_iff_false, not_false_iff], },
    apply ha₀',
    apply hm₀.1,
    simp only [X.of_is_bot_β, set.mem_singleton], },
  { obtain ⟨a, hab⟩ := h₂,
    have ha' : a ∈ m.β := by simpa only [hb] using hab.lt,
    obtain ⟨t, ht⟩ := hF₁ _ _ hab (m.s ⟨a, ha'⟩),
    let M := X.extension m hb t (λ c hc, begin
      rw hab.lt_iff_le at hc,
      rw m.hs ⟨c, m.hβ _ _ hc ha'⟩ ⟨a, ha'⟩ hc,
      have eq := congr_arg (F.map (hom_of_le hc).op) ht,
      simp only [← functor_to_types.map_comp_apply] at eq,
      convert eq.symm,
    end),
    have hM : m < M := X.le_extension _ _ _ _,
    simpa only [hm M hM.le, lt_self_iff_false] using hM, },
  { obtain ⟨t, ht⟩ := hF₂ _ h₃ ⟨λ c, m.s ⟨c.unop.1, by simpa only [hb] using c.unop.2⟩,
      (λ c d hcd, (m.hs ⟨d.unop.1, _⟩ ⟨c.unop.1, _⟩ _).symm)⟩,
    let M := X.extension m hb t (λ c hc,
      congr_fun (congr_arg subtype.val ht.symm) (opposite.op ⟨c, hc⟩)),
    have hM : m < M := X.le_extension _ _ _ _,
    simpa only [hm M hM.le, lt_self_iff_false] using hM, },
end

lemma surjective_of_is_well_order_of_surjective [order_bot α] :
  function.surjective (λ (s : F.sections), s.1 (opposite.op ⊥)) :=
surjective_of_is_well_order_of_surjective' F hF₁ hF₂ ⊥ (order_bot.bot_le)

end

section

variables {m : α} [linear_order α] (F : { x // x < m } ⥤ C) (X : C)
  (φ : F ⟶ (functor.const _).obj X)

namespace order_extension_from_lt_to_le

include F X

def obj (a : { x // x ≤ m}) : C :=
begin
  by_cases a.1 < m,
  { exact F.obj ⟨a.1, h⟩, },
  { exact X, },
end

def obj_iso_of_lt (a : { x // x ≤ m}) (ha : a.1 < m) :
  obj F X a ≅ F.obj ⟨a.1, ha⟩ :=
eq_to_iso begin
  dsimp [obj],
  classical,
  erw [dif_pos ha],
end

def obj_iso_of_not_lt (a : { x // x ≤ m}) (ha : ¬ a.1 < m) :
  obj F X a ≅ X :=
eq_to_iso begin
  dsimp [obj],
  erw [dif_neg ha],
end

end order_extension_from_lt_to_le

open order_extension_from_lt_to_le

include φ

def order_extension_from_lt_to_le : { x // x ≤ m } ⥤ C :=
{ obj := order_extension_from_lt_to_le.obj F X,
  map := λ a b f, begin
    classical,
    by_cases ha : a.1 < m,
    { by_cases hb : b.1 < m,
      { exact (obj_iso_of_lt F X a ha).hom ≫ F.map (hom_of_le (by exact le_of_hom f)) ≫
          (obj_iso_of_lt F X b hb).inv, },
      { exact (obj_iso_of_lt F X a ha).hom ≫ φ.app ⟨a, ha⟩ ≫ (obj_iso_of_not_lt F X b hb).inv, }, },
    { exact (obj_iso_of_not_lt F X a ha).hom ≫ (obj_iso_of_not_lt F X b
        (by { simp only [not_lt] at ⊢ ha, exact ha.trans (le_of_hom f), })).inv, },
  end,
  map_id' := λ a, begin
    by_cases ha : a.1 < m,
    { simp only [dif_pos ha],
      have h := le_refl (⟨a.1, ha⟩ : { x // x < m}),
      rw [subsingleton.elim (hom_of_le h) (𝟙 _), functor.map_id, id_comp, iso.hom_inv_id], },
    { simp only [dif_neg ha, iso.hom_inv_id], },
  end,
  map_comp' := λ a b c f g, begin
    by_cases ha : a.1 < m,
    { by_cases hb : b.1 < m,
      { by_cases hc : c.1 < m,
        { simp only [dif_pos ha, dif_pos hb, dif_pos hc, assoc, iso.inv_hom_id_assoc,
            iso.cancel_iso_hom_left, ← F.map_comp_assoc],
          congr, },
        { simp only [dif_pos ha, dif_pos hb, dif_neg hc, assoc, iso.inv_hom_id_assoc,
            iso.cancel_iso_hom_left],
          let f' : (⟨a, ha⟩ : { x // x < m}) ⟶ ⟨b, hb⟩ := f,
          have eq := φ.naturality f',
          dsimp at eq,
          rw comp_id at eq,
          simp only [← eq, assoc],
          congr, }, },
      { have hc : ¬c.1 < m := λ h, hb (lt_of_le_of_lt (le_of_hom g) h),
        simp only [dif_pos ha, dif_neg hb, dif_neg hc, assoc, iso.inv_hom_id_assoc], } },
    { have hb : ¬b.1 < m := λ h, ha (lt_of_le_of_lt (le_of_hom f) h),
      have hc : ¬c.1 < m := λ h, hb (lt_of_le_of_lt (le_of_hom g) h),
      simp only [dif_neg ha, dif_neg hb, dif_neg hc, assoc, iso.inv_hom_id_assoc], },
  end, }

end

@[simps]
def nat_trans_to_functor_const [preorder α] (F : α ⥤ C) (m : α) (hm : is_top m) :
  F ⟶ (functor.const _).obj (F.obj m) :=
{ app := λ a, F.map (hom_of_le (hm a)),
  naturality' := λ a b hab, begin
    dsimp,
    simpa only [comp_id, ← F.map_comp],
  end, }

namespace transfinite_iteration

variables (τ) [linear_order α] [is_well_order α (<)] {m : α} (a₀ : { b : α // b ≤ m})
  (ha₀ : is_bot a₀)

def mk_of_is_bot (hm : is_bot m) (X : C) : transfinite_iteration τ m :=
{ F := (functor.const _).obj X,
  hF := λ b hb, begin
    exfalso,
    exact hb.1 (by simpa only [is_bot.of_le_iff] using (hm.of_le _ b.2)),
  end,
  iso := begin
    rintro ⟨a, ha⟩ ⟨b, hb⟩ hab,
    exfalso,
    rw order.are_succ.of_le_iff at hab,
    dsimp at hab,
    have ha' := is_bot.unique (hm.of_le _ ha) hm,
    have hb' := is_bot.unique (hm.of_le _ hb) hm,
    substs ha' hb',
    simpa only [lt_self_iff_false] using hab.lt,
  end, }

def mk_of_are_succ {a b : α} (hab : order.are_succ a b) (I : transfinite_iteration τ a) :
  transfinite_iteration τ b :=
begin
  let a' : { x // x < b} := ⟨a, hab.lt⟩,
  have ha' : is_top a' := λ c, (hab.lt_iff_le c.1).1 c.2,
  let i : { x // x < b } → { x // x ≤ a } := λ x, ⟨x.1, ha' _⟩,
  have hi : _root_.monotone i := λ x y hxy, hxy,
  exact
  { F := order_extension_from_lt_to_le (monotone.functor hi ⋙ I.F)
      (Φ.obj (I.F.obj ⟨a, le_refl a⟩))
      (functor.nat_trans_to_functor_const _ a' ha' ≫ (functor.const _).map (τ.app _)),
    hF := sorry,
    iso := sorry, }
end

variable (m)

include ha₀

lemma ess_surj_eval_zero : ess_surj (eval τ m a₀) :=
begin
  rcases a₀ with ⟨a₀, ha₁⟩,
  rw is_bot.of_le_iff at ha₀,
  apply @well_founded.induction α (<) is_well_founded.wf
    (λ b, ess_surj (eval τ b ⟨a₀, ha₀ _⟩)) m,
  intros b H,
  rcases is_well_order.three_cases b with h₁ | (h₂ | h₃),
  { have hb := is_bot.unique h₁ ha₀,
    subst hb,
    exact ⟨λ X₀, ⟨mk_of_is_bot τ ha₀ X₀, ⟨iso.refl _⟩⟩⟩, },
  { obtain ⟨a, hab⟩ := h₂,
    haveI := H a hab.lt,
    exact ⟨λ X₀, ⟨mk_of_are_succ τ hab ((eval τ a ⟨a₀, ha₀ _⟩).obj_preimage X₀),
      ⟨order_extension_from_lt_to_le.obj_iso_of_lt _ _ _ (lt_of_le_of_lt (ha₀ _) hab.lt) ≪≫
      ((eval τ a ⟨a₀, ha₀ _⟩).obj_obj_preimage_iso _)⟩⟩⟩, },
  { sorry, },
end

end transfinite_iteration

end functor

end category_theory


/-
Copyright (c) 2020 Kenji Nakagawa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenji Nakagawa, Anne Baanen, Filippo A. E. Nuccio
-/
import ring_theory.discrete_valuation_ring
import ring_theory.fractional_ideal
import ring_theory.ideal.over

/-!
# Dedekind domains

This file defines the notion of a Dedekind domain (or Dedekind ring),
giving three equivalent definitions (TODO: and shows that they are equivalent).

## Main definitions

 - `is_dedekind_domain` defines a Dedekind domain as a commutative ring that is not a field,
   Noetherian, integrally closed in its field of fractions and has Krull dimension exactly one.
   `is_dedekind_domain_iff` shows that this does not depend on the choice of field of fractions.
 - `is_dedekind_domain_dvr` alternatively defines a Dedekind domain as an integral domain that
   is not a field, Noetherian, and the localization at every nonzero prime ideal is a DVR.
 - `is_dedekind_domain_inv` alternatively defines a Dedekind domain as an integral domain that
   is not a field, and every nonzero fractional ideal is invertible.
 - `is_dedekind_domain_inv_iff` shows that this does note depend on the choice of field of
   fractions.

## Implementation notes

The definitions that involve a field of fractions choose a canonical field of fractions,
but are independent of that choice. The `..._iff` lemmas express this independence.

## References

* [D. Marcus, *Number Fields*][marcus1977number]
* [J.W.S. Cassels, A. Frölich, *Algebraic Number Theory*][cassels1967algebraic]

## Tags

dedekind domain, dedekind ring
-/

variables (R A K : Type*) [comm_ring R] [integral_domain A] [field K]

/-- A ring `R` has Krull dimension at most one if all nonzero prime ideals are maximal. -/
def ring.dimension_le_one : Prop :=
∀ p ≠ (⊥ : ideal R), p.is_prime → p.is_maximal

open ideal ring

namespace ring

lemma dimension_le_one.principal_ideal_ring
  [is_principal_ideal_ring A] : dimension_le_one A :=
λ p nonzero prime, by { haveI := prime, exact is_prime.to_maximal_ideal nonzero }

lemma dimension_le_one.integral_closure [nontrivial R] [algebra R A]
  (h : dimension_le_one R) : dimension_le_one (integral_closure R A) :=
begin
  intros p ne_bot prime,
  haveI := prime,
  refine integral_closure.is_maximal_of_is_maximal_comap p
    (h _ (integral_closure.comap_ne_bot ne_bot) _),
  apply is_prime.comap
end
end ring

/--
A Dedekind domain is an integral domain that is Noetherian, integrally closed, and
has Krull dimension exactly one (`not_is_field` and `dimension_le_one`).

The integral closure condition is independent of the choice of field of fractions:
use `is_dedekind_domain_iff` to prove `is_dedekind_domain` for a given `fraction_map`.

This is the default implementation, but there are equivalent definitions,
`is_dedekind_domain_dvr` and `is_dedekind_domain_inv`.
TODO: Prove that these are actually equivalent definitions.
-/
class is_dedekind_domain : Prop :=
(not_is_field : ¬ is_field A)
(is_noetherian_ring : is_noetherian_ring A)
(dimension_le_one : dimension_le_one A)
(is_integrally_closed : integral_closure A (fraction_ring A) = ⊥)

/-- An integral domain is a Dedekind domain iff and only if it is not a field, is
Noetherian, has dimension ≤ 1, and is integrally closed in a given fraction field.
In particular, this definition does not depend on the choice of this fraction field. -/
lemma is_dedekind_domain_iff (f : fraction_map A K) :
  is_dedekind_domain A ↔
    (¬ is_field A) ∧ is_noetherian_ring A ∧ dimension_le_one A ∧
    integral_closure A f.codomain = ⊥ :=
⟨λ ⟨hf, hr, hd, hi⟩, ⟨hf, hr, hd,
  by rw [←integral_closure_map_alg_equiv (fraction_ring.alg_equiv_of_quotient f),
         hi, algebra.map_bot]⟩,
 λ ⟨hf, hr, hd, hi⟩, ⟨hf, hr, hd,
  by rw [←integral_closure_map_alg_equiv (fraction_ring.alg_equiv_of_quotient f).symm,
         hi, algebra.map_bot]⟩⟩

/--
A Dedekind domain is an integral domain that is not a field, is Noetherian, and the
localization at every nonzero prime is a discrete valuation ring.

This is equivalent to `is_dedekind_domain`.
TODO: prove the equivalence.
-/
structure is_dedekind_domain_dvr : Prop :=
(not_is_field : ¬ is_field A)
(is_noetherian_ring : is_noetherian_ring A)
(is_dvr_at_nonzero_prime : ∀ P ≠ (⊥ : ideal A), P.is_prime →
  discrete_valuation_ring (localization.at_prime P))

section inverse

open_locale classical

variables {R₁ : Type*} [integral_domain R₁] {g : fraction_map R₁ K}
variables {I J : fractional_ideal g}

noncomputable instance : has_inv (fractional_ideal g) := ⟨λ I, 1 / I⟩

lemma inv_eq : I⁻¹ = 1 / I := rfl

lemma inv_zero' : (0 : fractional_ideal g)⁻¹ = 0 := fractional_ideal.div_zero

lemma inv_nonzero {J : fractional_ideal g} (h : J ≠ 0) :
J⁻¹ = ⟨(1 : fractional_ideal g) / J, fractional_ideal.fractional_div_of_nonzero h⟩ :=
fractional_ideal.div_nonzero _

lemma coe_inv_of_nonzero {J : fractional_ideal g} (h : J ≠ 0) :
  (↑J⁻¹ : submodule R₁ g.codomain) = g.coe_submodule 1 / J :=
by { rwa inv_nonzero _, refl, assumption}

/-- `I⁻¹` is the inverse of `I` if `I` has an inverse. -/
theorem right_inverse_eq (I J : fractional_ideal g) (h : I * J = 1) :
  J = I⁻¹ :=
begin
  have hI : I ≠ 0 := fractional_ideal.ne_zero_of_mul_eq_one I J h,
  suffices h' : I * (1 / I) = 1,
  { exact (congr_arg units.inv $
      @units.ext _ _ (units.mk_of_mul_eq_one _ _ h) (units.mk_of_mul_eq_one _ _ h') rfl) },
  apply le_antisymm,
  { apply fractional_ideal.mul_le.mpr _,
    intros x hx y hy,
    rw mul_comm,
    exact (fractional_ideal.mem_div_iff_of_nonzero hI).mp hy x hx },
  rw ← h,
  apply fractional_ideal.mul_left_mono I,
  apply (fractional_ideal.le_div_iff_of_nonzero hI).mpr _,
  intros y hy x hx,
  rw mul_comm,
  exact fractional_ideal.mul_mem_mul hx hy
end

theorem mul_inv_cancel_iff {I : fractional_ideal g} :
  I * I⁻¹ = 1 ↔ ∃ J, I * J = 1 :=
⟨λ h, ⟨I⁻¹, h⟩, λ ⟨J, hJ⟩, by rwa [← @right_inverse_eq _ _ _ _ _ I J hJ]⟩

variables {K' : Type*} [field K'] {g' : fraction_map R₁ K'}

@[simp] lemma map_inv (I : fractional_ideal g) (h : g.codomain ≃ₐ[R₁] g'.codomain) :
  (I⁻¹).map (h : g.codomain →ₐ[R₁] g'.codomain) = (I.map h)⁻¹ :=
by rw [inv_eq, fractional_ideal.map_div, fractional_ideal.map_one, inv_eq]

open_locale classical

open submodule submodule.is_principal

@[simp] lemma span_singleton_inv (x : g.codomain) :
  (fractional_ideal.span_singleton x)⁻¹ = fractional_ideal.span_singleton (x⁻¹) :=
fractional_ideal.one_div_span_singleton x

lemma mul_generator_self_inv (I : fractional_ideal g)
  [submodule.is_principal (I : submodule R₁ g.codomain)] (h : I ≠ 0) :
  I * fractional_ideal.span_singleton (generator (I : submodule R₁ g.codomain))⁻¹ = 1 :=
begin
  -- Rewrite only the `I` that appears alone.
  conv_lhs { congr, rw fractional_ideal.eq_span_singleton_of_principal I },
  rw [fractional_ideal.span_singleton_mul_span_singleton, mul_inv_cancel,
    fractional_ideal.span_singleton_one],
  intro generator_I_eq_zero,
  apply h,
  rw [fractional_ideal.eq_span_singleton_of_principal I, generator_I_eq_zero,
    fractional_ideal.span_singleton_zero]
end

lemma invertible_of_principal (I : fractional_ideal g)
  [submodule.is_principal (I : submodule R₁ g.codomain)] (h : I ≠ 0) :
  I * I⁻¹ = 1 :=
(fractional_ideal.mul_div_self_cancel_iff).mpr
  ⟨fractional_ideal.span_singleton (generator (I : submodule R₁ g.codomain))⁻¹,
    @mul_generator_self_inv _ _ _ _ _ I _ h⟩

lemma invertible_iff_generator_nonzero (I : fractional_ideal g)
  [submodule.is_principal (I : submodule R₁ g.codomain)] :
  I * I⁻¹ = 1 ↔ generator (I : submodule R₁ g.codomain) ≠ 0 :=
begin
  split,
  { intros hI hg,
    apply fractional_ideal.ne_zero_of_mul_eq_one _ _ hI,
    rw [fractional_ideal.eq_span_singleton_of_principal I, hg,
        fractional_ideal.span_singleton_zero] },
  { intro hg,
    apply invertible_of_principal,
    rw [fractional_ideal.eq_span_singleton_of_principal I],
    intro hI,
    have := fractional_ideal.mem_span_singleton_self (generator (I : submodule R₁ g.codomain)),
    rw [hI, fractional_ideal.mem_zero_iff] at this,
    contradiction }
end

lemma is_principal_inv (I : fractional_ideal g)
  [submodule.is_principal (I : submodule R₁ g.codomain)] (h : I ≠ 0) :
  submodule.is_principal (I⁻¹).1 :=
begin
  rw [fractional_ideal.val_eq_coe, fractional_ideal.is_principal_iff],
  use (generator (I : submodule R₁ g.codomain))⁻¹,
  have hI : I  * fractional_ideal.span_singleton ((generator (I : submodule R₁ g.codomain))⁻¹)  = 1,
  apply @mul_generator_self_inv _ _ _ _ _ I _ h,
  apply (@right_inverse_eq _ _ _ _ _ I (fractional_ideal.span_singleton
    ( (generator (I : submodule R₁ g.codomain))⁻¹)) hI).symm,
end

/--
A Dedekind domain is an integral domain that is not a field such that every fractional ideal
has an inverse.

This is equivalent to `is_dedekind_domain`.
TODO: prove the equivalence.
-/
structure is_dedekind_domain_inv : Prop :=
(not_is_field : ¬ is_field A)
(mul_inv_cancel : ∀ I ≠ (⊥ : fractional_ideal (fraction_ring.of A)), I * (1 / I) = 1)

open ring.fractional_ideal

lemma is_dedekind_domain_inv_iff (f : fraction_map A K) :
  is_dedekind_domain_inv A ↔
    (¬ is_field A) ∧ (∀ I ≠ (⊥ : fractional_ideal f), I * I⁻¹ = 1) :=
begin
  set h : (fraction_ring.of A).codomain ≃ₐ[A] f.codomain := fraction_ring.alg_equiv_of_quotient f,
  split; rintros ⟨hf, hi⟩; use hf; intros I hI,
  { have := hi (map ↑h.symm I) (map_ne_zero _ hI),
    convert congr_arg (map (h : (fraction_ring.of A).codomain →ₐ[A] f.codomain)) this;
      simp only [map_symm_map, map_one, fractional_ideal.map_mul, fractional_ideal.map_div,
                 inv_eq] },
  { have := hi (map ↑h I) (map_ne_zero _ hI),
    convert congr_arg (map (h.symm : f.codomain →ₐ[A] (fraction_ring.of A).codomain)) this;
      simp only [map_map_symm, map_one, fractional_ideal.map_mul, fractional_ideal.map_div,
                 inv_eq] },
end

end inverse


import defs data.list.perm
open nnf

namespace list
universes u v w
variables {α : Type u}

theorem length_sub_lt_of_nodup_subperm [decidable_eq α] {l₁ l₂ : list α} {a : α}
(h₁ : l₁ <+~ l₂) (h₂ : a ∈ l₂) (h₃ : a ∉ l₁) (h₄ : nodup l₁):
length l₂ - length (a :: l₁) < length l₂ - length l₁
:=
begin
  rw nat.sub_lt_sub_left_iff,
  { simp [zero_lt_one] },
  { apply subperm.length_le,
    apply cons_subperm_of_mem; assumption }
end

end list

structure psig : Type :=
(d : nnf)
(b : list nnf)

instance : decidable_eq psig := by tactic.mk_dec_eq_instance

def sig : Type := option psig

instance : decidable_eq sig := by tactic.mk_dec_eq_instance

def dsig : Π (s : sig) (h : s ≠ none), nnf
| none h := by contradiction
| (some ⟨d, b⟩) h := d

def bsig : Π (s : sig) (h : s ≠ none), list nnf
| none h := by contradiction
| (some ⟨d, b⟩) h := b

instance (Γ) : decidable_eq (no_literals Γ) := by tactic.mk_dec_eq_instance

instance (Γ) : decidable_eq (saturated Γ) := by tactic.mk_dec_eq_instance

instance (Γ) : decidable_eq (box_only Γ) := by tactic.mk_dec_eq_instance

structure sseqt : Type :=
(goal : list nnf)
(s : sig) -- sig := option psig
(a : list psig) -- psig is the signature, which is of the form (d, b)
(h b m: list nnf)
(ndh : list.nodup h) -- nodup says there is no duplicate elements
(ndb : list.nodup b)
(sph : h <+~ closure goal) -- <+~ denotes sublist permutation
(spb : b <+~ closure goal)
(sbm : m ⊆ closure goal)
(ha : ∀ φ ∈ h, (⟨φ, b⟩ : psig) ∈ a)
(hb : box_only b)
-- dsig takes a signature (d, b) and a proof h, and returns d
(ps₁ : Π (h : s ≠ none), dsig s h ∈ m)
-- bsig takes a signature (d, b) and a proof h, and returns b
(ps₂ : Π (h : s ≠ none), bsig s h ⊆ m)

instance : decidable_eq sseqt := by tactic.mk_dec_eq_instance

class val_constructible (Γ : sseqt) :=
(satu : saturated Γ.m)
(no_box_main : ∀ {φ}, box φ ∉ Γ.m)
(no_contra_main : ∀ {n}, var n ∈ Γ.m → neg n ∉ Γ.m)

class modal_applicable (Γ : sseqt) extends val_constructible Γ :=
(φ : nnf)
(ex : dia φ ∈ Γ.m)

class model_constructible (Γ : sseqt) extends val_constructible Γ :=
(no_dia : ∀ {φ}, nnf.dia φ ∉ Γ.m)

def and_child {φ ψ} (Γ : sseqt) (h : nnf.and φ ψ ∈ Γ.m) : sseqt :=
{ goal := Γ.goal,
  s := none,
  m := φ :: ψ :: Γ.m.erase (and φ ψ),
  sbm := begin
          intros x hx, cases hx,
          {rw hx, apply (mem_closure_and _ (Γ.sbm h)).1},
          {cases hx,
           {rw hx, apply (mem_closure_and _ (Γ.sbm h)).2},
           {apply Γ.sbm, apply list.erase_subset, exact hx}}
         end,
  ps₁ := by intro; contradiction,
  ps₂ := by intro; contradiction,
  .. Γ}

inductive and_instance_seqt (Γ : sseqt) : sseqt → Type
| cons : Π {φ ψ} (h : nnf.and φ ψ ∈ Γ.m),
         and_instance_seqt $ and_child Γ h

def or_child_left {φ ψ} (Γ : sseqt) (h : nnf.or φ ψ ∈ Γ.m) : sseqt :=
{ goal := Γ.goal,
  s := none,
  m := φ :: Γ.m.erase (or φ ψ),
  sbm := begin
          intros x hx, cases hx,
          {rw hx, apply (mem_closure_or _ (Γ.sbm h)).1},
          {apply Γ.sbm, apply list.erase_subset, exact hx}
         end,
  ps₁ := by intro; contradiction,
  ps₂ := by intro; contradiction,
  .. Γ}

def or_child_right {φ ψ} (Γ : sseqt) (h : nnf.or φ ψ ∈ Γ.m) : sseqt :=
{ goal := Γ.goal,
  s := none,
  m := ψ :: Γ.m.erase (or φ ψ),
  sbm := begin
           intros x hx, cases hx,
           {rw hx, apply (mem_closure_or _ (Γ.sbm h)).2},
           {apply Γ.sbm, apply list.erase_subset, exact hx}
         end,
  ps₁ := by intro; contradiction,
  ps₂ := by intro; contradiction,
  .. Γ}

inductive or_instance_seqt (Γ : sseqt) : sseqt → sseqt → Type
| cons : Π {φ ψ} (h : nnf.or φ ψ ∈ Γ.m),
         or_instance_seqt (or_child_left Γ h) (or_child_right Γ h)

def box_child_new {φ} (Γ : sseqt) (h₁ : nnf.box φ ∈ Γ.m) (h₂ : nnf.box φ ∉ Γ.b) : sseqt :=
{ goal := Γ.goal,
  s := none,
  h := [],
  b := box φ :: Γ.b,
  m := φ :: Γ.m.erase (box φ),
  ndh := by simp,
  ndb := begin rw list.nodup_cons, split, exact h₂, exact Γ.ndb end,
  sph := begin apply list.nil_subperm end,
  spb := begin
           apply list.cons_subperm_of_mem Γ.ndb h₂,
           apply Γ.sbm h₁, apply Γ.spb
         end,
  sbm := begin
           intros x hx, cases hx,
           {rw hx, apply mem_closure_box _ (Γ.sbm h₁)},
           {apply Γ.sbm, apply list.erase_subset, exact hx}
         end,
  ha := λ φ h, absurd h $ list.not_mem_nil _,
  hb := cons_box_only Γ.hb,
  ps₁ := by intro; contradiction,
  ps₂ := by intro; contradiction,
  .. Γ}

inductive box_new_instance_seqt (Γ : sseqt) : sseqt → Type
| cons : Π {φ} (h₁ : nnf.box φ ∈ Γ.m) (h₂ : nnf.box φ ∉ Γ.b),
         box_new_instance_seqt $ box_child_new Γ h₁ h₂

def box_child {φ} (Γ : sseqt) (h₁ : nnf.box φ ∈ Γ.m) : sseqt :=
{ goal := Γ.goal,
  s := none,
  a := Γ.a,
  h := Γ.h,
  b := Γ.b,
  m := φ :: Γ.m.erase (box φ),
  ndh := Γ.ndh,
  ndb := Γ.ndb,
  sph := Γ.sph,
  spb := Γ.spb,
  sbm := begin
           intros x hx, cases hx,
           {rw hx, apply mem_closure_box _ (Γ.sbm h₁)},
           {apply Γ.sbm, apply list.erase_subset, exact hx}
         end,
  ha := Γ.ha,
  hb := Γ.hb,
  ps₁ := by intro; contradiction,
  ps₂ := by intro; contradiction}

inductive box_dup_instance_seqt (Γ : sseqt) : sseqt → Type
| cons : Π {φ} (h₁ : nnf.box φ ∈ Γ.m) (h₂ : nnf.box φ ∈ Γ.b),
         box_dup_instance_seqt $ box_child Γ h₁

theorem hintikka_vc {Γ} (h : val_constructible Γ) : hintikka Γ.m :=
{hno_contra := h.no_contra_main,
 hand_left := begin intros φ ψ h₁, exfalso, apply h.satu.no_and, exact h₁ end,
 hand_right := begin intros φ ψ h₁, exfalso, apply h.satu.no_and, exact h₁ end,
 hor := begin intros φ ψ h₁, exfalso, apply h.satu.no_or, exact h₁ end,
 hbox := begin intros φ h₁, exfalso, apply h.no_box_main, exact h₁ end}

theorem hintikka_ma {Γ} (h : modal_applicable Γ) : hintikka Γ.m :=
hintikka_vc h.to_val_constructible

theorem hintikka_mc {Γ} (h : model_constructible Γ) : hintikka Γ.m :=
hintikka_vc h.to_val_constructible

structure info : Type :=
(id : sseqt)
(htk : list nnf)
(hhtk : hintikka htk)
(mhtk : id.m ⊆ htk)

instance : decidable_eq info := by tactic.mk_dec_eq_instance

inductive tmodel
| cons : info → list tmodel → list psig → tmodel

instance : decidable_eq tmodel := by tactic.mk_dec_eq_instance


import data.cpi.species data.upair

namespace cpi

variables {ℍ : Type} {ω : context}

/-- The kind of a production, either a species or concretion-/
@[derive decidable_eq, nolint has_inhabited_instance]
inductive kind
| species
| concretion

/-- A transition from a species to some production of a given kind. -/
@[derive decidable_eq, nolint has_inhabited_instance]
inductive label (ℍ : Type) : context → kind → Type
/- From a species to a concretion. Sends $b$ values on channel $a$ and evolves
   into whatever species the concretion applies, substituting $y$ variables
   with the values received. -/
| apply {} {Γ} (a : name Γ) : label Γ kind.concretion

/- Evolution from one species to another species without any other interaction,
   at a specific rate. -/
| spontaneous {Γ} (rate : ℍ) : label Γ kind.species

/- Evolution from one species to another, with a rate determined by an affinity
   network. This is converted into a spontaneous interaction when the names
   refer to a global affinity network. -/
| of_affinity {} {Γ} (k : upair (name Γ)) : label Γ kind.species

notation `#`:max a:max := label.apply a
notation `τ@'`:max k:max  := label.spontaneous k
notation `τ⟨ `:max a `, ` b ` ⟩`:max := label.of_affinity (upair.mk a b)
notation `τ⟨ `:max p ` ⟩`:max := label.of_affinity p

/-- Convert a label to a string. Can use `repr` normally. -/
protected def label.to_string [has_repr ℍ] : ∀ {k}, label ℍ ω k → string
| ._ (# a) := "#" ++ repr a
| ._ (τ@' k) := "τ@" ++ repr k
| ._ (τ⟨ p ⟩) := "τ⟨ " ++ repr p ++ " ⟩"

instance label.has_repr [has_repr ℍ] {k} : has_repr (label ℍ ω k) := ⟨ label.to_string ⟩

/-- Rename all names within a label. -/
def label.rename {Γ Δ} (ρ : name Γ → name Δ) : ∀ {k}, label ℍ Γ k → label ℍ Δ k
| ._ #a := # (ρ a)
| ._ τ@'k := τ@'k
| ._ τ⟨ ab ⟩ := τ⟨ upair.map ρ ab ⟩

lemma label.rename.inj {Γ Δ} {ρ : name Γ → name Δ} (inj : function.injective ρ)
  : ∀ {k}, function.injective (@label.rename ℍ Γ Δ ρ k)
  | ._ #a #b eq := by { cases inj (label.apply.inj eq), from rfl }
  | ._ τ@'k τ@'j rfl := rfl
  | ._ τ⟨ a ⟩ τ⟨ b ⟩ eq := begin
      cases upair.map.inj inj (label.of_affinity.inj eq),
      from rfl
    end
  | ._ τ@'k τ⟨ _ ⟩ eq := by contradiction
  | ._ τ⟨ _ ⟩ τ@'k eq := by contradiction

lemma label.rename_compose {Γ Δ η} (ρ : name Γ → name Δ) (σ : name Δ → name η)
  : ∀ {k} (l : label ℍ Γ k)
  , label.rename σ (label.rename ρ l) = label.rename (σ ∘ ρ) l
| ._ #a := rfl
| ._ τ@'k := rfl
| ._ τ⟨ ab ⟩ := by simp only [label.rename, upair.map_compose]

lemma label.rename_id {Γ} : ∀ {k} (l : label ℍ Γ k), label.rename id l = l
| ._ #a := rfl
| ._ τ@'k := rfl
| ._ τ⟨ p ⟩ := congr_arg _ (upair.map_identity p)

end cpi

#lint-


import LMT

variable {I} [Nonempty I] {E} [Nonempty E] [Nonempty (A I E)]

example {a1 a2 a3 : A I E} :
        (v3) ≠ ((((a3).write i1 (v3)).write i3 (v3)).read i1) → False := by
  arr


import phase2.litter_completion

open set sum
open_locale pointwise

universe u

namespace con_nf

namespace struct_approx
variables [params.{u}] {α : Λ} [position_data.{}] [phase_2_assumptions α]
  {β : Iic α} [freedom_of_action_hypothesis β]

def near_litter_hypothesis (N : near_litter) (A : extended_index β) (H : hypothesis ⟨inr N, A⟩) :
  hypothesis ⟨inr N.1.to_near_litter, A⟩ := {
  atom_image := λ a B h, H.atom_image a B (begin
    by_cases h' : litter_set N.fst = N.snd,
    suffices : N.fst.to_near_litter = N,
    { rwa this at h, },
    { ext : 1,
      refl,
      exact h', },
    exact relation.trans_gen.tail h (constrains.near_litter N h' A),
  end),
  near_litter_image := λ N' B h, H.near_litter_image N' B (begin
    by_cases h' : litter_set N.fst = N.snd,
    suffices : N.fst.to_near_litter = N,
    { rwa this at h, },
    { ext : 1,
      refl,
      exact h', },
    exact relation.trans_gen.tail h (constrains.near_litter N h' A),
  end),
}

def near_litter_completion_map (π : struct_approx β) (hπ : π.free)
  (N : near_litter) (A : extended_index β) (H : hypothesis ⟨inr N, A⟩) : set atom :=
(near_litter_approx.largest_sublitter (π A)
  (litter_completion π hπ N.1 A (near_litter_hypothesis N A H)) ∪
  π A • (N ∩ (π A).atom_perm.domain)) ∆
  ⋃ (a : atom) (ha : a ∈ (litter_set N.1 ∆ N) \ (π A).atom_perm.domain),
    {H.atom_image a A (relation.trans_gen.single (constrains.symm_diff N a ha.1 A))}

-- TODO: Move this lemma
lemma near_litter_approx.near_litter_domain_small (π : near_litter_approx) (N : near_litter) :
  small ((N : set atom) ∩ π.atom_perm.domain) :=
begin
  rw [← symm_diff_symm_diff_cancel_left (litter_set N.fst) N, inter_symm_diff_distrib_right],
  exact small.symm_diff (π.domain_small N.fst) (small.mono (inter_subset_left _ _) N.2.prop),
end

/-
lemma largest_sublitter_symm_diff_small (π : near_litter_approx) (N : near_litter) :
  small ((π.largest_sublitter N.fst : set atom) ∆ N) :=
begin
  refine is_near_litter.near _ _,
  exact N.fst,
  exact (near_litter.is_near_litter (π.largest_sublitter N.fst).to_near_litter _).mpr rfl,
  rw near_litter.is_near_litter,
end

lemma largest_sublitter_diff_small (π : near_litter_approx) (N : near_litter) :
  small ((π.largest_sublitter N.fst : set atom) \ N) :=
small.mono (subset_union_left _ _) (largest_sublitter_symm_diff_small π N)
-/

lemma near_litter_completion_map_is_near_litter (π : struct_approx β)
  (hπ : π.free) (N : near_litter) (A : extended_index β) (H : hypothesis ⟨inr N, A⟩) :
  is_near_litter (π.litter_completion hπ N.fst A (near_litter_hypothesis N A H))
    (π.near_litter_completion_map hπ N A H) :=
begin
  rw [near_litter_completion_map, is_near_litter, is_near, near_litter_approx.coe_largest_sublitter,
    ← symm_diff_assoc, symm_diff_comm, ← small.symm_diff_iff _],
  { rw [set.symm_diff_def, ← diff_diff, sdiff_sdiff_right_self, inf_eq_inter,
      union_diff_distrib, sdiff_sdiff_self, bot_eq_empty, empty_union],
    exact small.union (small.mono (diff_subset _ _) ((π A).domain_small _))
      (small.mono (diff_subset _ _) ((near_litter_approx.near_litter_domain_small _ _).image)), },
  { exact small.bUnion (small.mono (diff_subset _ _) N.2.prop) (λ _ _, small_singleton _), },
end

noncomputable def near_litter_completion (π : struct_approx β) (hπ : π.free)
  (N : near_litter) (A : extended_index β) (H : hypothesis ⟨inr N, A⟩) : near_litter :=
⟨litter_completion π hπ N.1 A (near_litter_hypothesis N A H),
  near_litter_completion_map π hπ N A H,
  near_litter_completion_map_is_near_litter π hπ N A H⟩

@[simp] lemma near_litter_completion_fst_eq (π : struct_approx β) (hπ : π.free)
  (N : near_litter) (A : extended_index β) (H : hypothesis ⟨inr N, A⟩) :
  (π.near_litter_completion hπ N A H).1 =
  litter_completion π hπ N.1 A (near_litter_hypothesis N A H) := rfl

end struct_approx

end con_nf


import .presheaves

open category_theory opposite

noncomputable theory

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

inductive prod_coprod : Type
| of_cat' : C → prod_coprod
| prod : prod_coprod → prod_coprod → prod_coprod
| coprod : prod_coprod → prod_coprod → prod_coprod

variable {C}

namespace prod_coprod

inductive syntax : Π (X Y : prod_coprod C), Type
| of_cat {X Y : C} : (X ⟶ Y) → syntax (of_cat' X) (of_cat' Y)
| prod_mk {X Y Z : prod_coprod C} : syntax X Y → syntax X Z → syntax X (Y.prod Z)
| fst {X Y : prod_coprod C} : syntax (X.prod Y) X
| snd {X Y : prod_coprod C} : syntax (X.prod Y) Y
| coprod_mk {X Y Z : prod_coprod C} : syntax X Z → syntax Y Z → syntax (X.coprod Y) Z
| inl {X Y : prod_coprod C} : syntax X (X.coprod Y)
| inr {X Y : prod_coprod C} : syntax Y (X.coprod Y)
| id (X : prod_coprod C) : syntax X X
| comp {X Y Z : prod_coprod C} : syntax X Y → syntax Y Z → syntax X Z

namespace syntax

inductive rel : Π {X Y : prod_coprod C}, syntax X Y → syntax X Y → Prop
| refl {X Y : prod_coprod C} (f : syntax X Y) : rel f f
| symm {X Y : prod_coprod C} {f g : syntax X Y} : rel f g → rel g f
| trans {X Y : prod_coprod C} {f g h : syntax X Y} : rel f g → rel g h → rel f h
| comp_congr {X Y Z : prod_coprod C} {f₁ f₂ : syntax X Y} {g₁ g₂ : syntax Y Z} :
  rel f₁ f₂ → rel g₁ g₂ → rel (f₁.comp g₁) (f₂.comp g₂)
| prod_mk_congr {X Y Z : prod_coprod C} {f₁ f₂ : syntax X Y} {g₁ g₂ : syntax X Z} :
  rel f₁ f₂ → rel g₁ g₂ → rel (f₁.prod_mk g₁) (f₂.prod_mk g₂)
| coprod_mk_congr {X Y Z : prod_coprod C} {f₁ f₂ : syntax X Z} {g₁ g₂ : syntax Y Z} :
  rel f₁ f₂ → rel g₁ g₂ → rel (f₁.coprod_mk g₁) (f₂.coprod_mk g₂)
| id_comp {X Y : prod_coprod C} (f : syntax X Y) : rel ((syntax.id X).comp f) f
| comp_id {X Y : prod_coprod C} (f : syntax X Y) : rel (f.comp (syntax.id Y)) f
| assoc {W X Y Z : prod_coprod C} (f : syntax W X) (g : syntax X Y) (h : syntax Y Z) :
  rel ((f.comp g).comp h) (f.comp (g.comp h))
| of_cat_id {X : C} : rel (syntax.of_cat (𝟙 X)) (syntax.id (of_cat' X))
| of_cat_comp {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  rel (syntax.of_cat (f ≫ g)) (syntax.comp (syntax.of_cat f) (syntax.of_cat g))
| mk_fst_comp {X Y Z : prod_coprod C} (f : syntax X Y) (g : syntax X Z) :
  rel (syntax.comp (syntax.prod_mk f g) syntax.fst) f
| mk_snd_comp {X Y Z : prod_coprod C} (f : syntax X Y) (g : syntax X Z) :
  rel (syntax.comp (syntax.prod_mk f g) syntax.snd) g
| prod_eta {X Y Z : prod_coprod C} (f : syntax X (Y.prod Z)) :
  rel (syntax.prod_mk (f.comp syntax.fst) (f.comp syntax.snd)) f
| inl_comp_mk {X Y Z : prod_coprod C} (f : syntax X Z) (g : syntax Y Z) :
  rel (syntax.comp syntax.inl (syntax.coprod_mk f g)) f
| inr_comp_mk {X Y Z : prod_coprod C} (f : syntax X Z) (g : syntax Y Z) :
  rel (syntax.comp syntax.inr (syntax.coprod_mk f g)) g
| coprod_eta {X Y Z : prod_coprod C} (f : syntax (X.coprod Y) Z) :
  rel (syntax.coprod_mk (syntax.inl.comp f) (syntax.inr.comp f)) f

attribute [refl] rel.refl
attribute [symm] rel.symm
attribute [trans] rel.trans

infixl ` ♥ `: 50 := rel

lemma rel_prod {X Y Z : prod_coprod C} {f g : syntax X (Y.prod Z)}
  (h₁ : rel (f.comp syntax.fst) (g.comp syntax.fst))
  (h₂ : rel (f.comp syntax.snd) (g.comp syntax.snd)) :
  rel f g :=
calc f ♥ syntax.prod_mk (f.comp syntax.fst) (f.comp syntax.snd) : rel.symm (rel.prod_eta f)
   ... ♥ syntax.prod_mk (g.comp syntax.fst) (g.comp syntax.snd) : rel.prod_mk_congr h₁ h₂
   ... ♥ g : rel.prod_eta g

lemma rel_coprod {X Y Z : prod_coprod C} {f g : syntax (X.coprod Y) Z}
  (h₁ : rel (syntax.inl.comp f) (syntax.inl.comp g))
  (h₂ : rel (syntax.inr.comp f) (syntax.inr.comp g)) :
  rel f g :=
calc f ♥ syntax.coprod_mk (syntax.inl.comp f) (syntax.inr.comp f) : rel.symm (rel.coprod_eta f)
   ... ♥ syntax.coprod_mk (syntax.inl.comp g) (syntax.inr.comp g) : rel.coprod_mk_congr h₁ h₂
   ... ♥ g : rel.coprod_eta g

instance rel_setoid (X Y : prod_coprod C) : setoid (syntax X Y) :=
{ r := rel,
  iseqv := ⟨rel.refl, λ _ _, rel.symm, λ _ _ _, rel.trans⟩ }

end syntax

section syntax

open syntax

def hom (X Y : prod_coprod C) : Type := quotient (syntax.rel_setoid X Y)

instance : category_struct (prod_coprod C) :=
{ hom := hom,
  id := λ X, quotient.mk' (syntax.id X),
  comp := λ X Y Z f g, quotient.lift_on₂ f g (λ f g, quotient.mk' (syntax.comp f g))
    (λ f₁ g₁ f₂ g₂ hf hg, quotient.sound (rel.comp_congr hf hg)) }

instance : category (prod_coprod C) :=
{ id_comp' := λ X Y f, quotient.induction_on f (λ f, quotient.sound (rel.id_comp f)),
  comp_id' := λ X Y f, quotient.induction_on f (λ f, quotient.sound (rel.comp_id f)),
  assoc' := λ W X Y Z f g h, quotient.induction_on₃ f g h
    (λ f g h, quotient.sound (rel.assoc f g h)) }

def of_syntax {X Y : prod_coprod C} : syntax X Y → (X ⟶ Y) := quotient.mk

def of_cat : C ⥤ prod_coprod C :=
{ obj := λ X, of_cat' X,
  map := λ X Y f, of_syntax (syntax.of_cat f),
  map_id' := λ X, quotient.sound rel.of_cat_id,
  map_comp' := λ X Y Z f g, quotient.sound (rel.of_cat_comp f g) }

@[simp] lemma of_cat_obj (X : C) : of_cat.obj X = of_cat' X := rfl

def prod_mk {X Y Z : prod_coprod C} (f : X ⟶ Y) (g : X ⟶ Z) : X ⟶ (Y.prod Z) :=
quotient.lift_on₂ f g (λ f g, of_syntax (prod_mk f g)) begin
  intros,
  dsimp,
  refine quotient.sound _,
  refine rel.prod_mk_congr _ _; assumption
end

def fst {X Y : prod_coprod C} : (X.prod Y) ⟶ X :=
of_syntax fst

def snd {X Y : prod_coprod C} : (X.prod Y) ⟶ Y :=
of_syntax snd

@[simp] lemma prod_mk_fst_comp {X Y Z : prod_coprod C} (f : X ⟶ Y) (g : X ⟶ Z) :
  prod_mk f g ≫ fst = f :=
quotient.induction_on₂ f g (λ f g, quotient.sound (syntax.rel.mk_fst_comp _ _))

@[simp] lemma prod_mk_snd_comp {X Y Z : prod_coprod C} (f : X ⟶ Y) (g : X ⟶ Z) :
  prod_mk f g ≫ snd = g :=
quotient.induction_on₂ f g (λ f g, quotient.sound (syntax.rel.mk_snd_comp _ _))

lemma prod_mk_eta {X Y Z : prod_coprod C} (f : X ⟶ Y.prod Z) :
  prod_mk (f ≫ fst) (f ≫ snd) = f :=
quotient.induction_on f (λ f, quotient.sound (syntax.rel.prod_eta _))

@[ext] lemma prod_hom_ext {X Y Z : prod_coprod C} {f g : X ⟶ Y.prod Z}
  (h₁ : f ≫ fst = g ≫ fst) (h₂ : f ≫ snd = g ≫ snd) : f = g :=
begin
  conv_lhs { rw ← prod_mk_eta f },
  rw [h₁, h₂, prod_mk_eta]
end

def coprod_mk {X Y Z : prod_coprod C} (f : X ⟶ Z) (g : Y ⟶ Z) : (X.coprod Y) ⟶ Z :=
quotient.lift_on₂ f g (λ f g, of_syntax (coprod_mk f g)) begin
  intros,
  dsimp,
  refine quotient.sound _,
  refine rel.coprod_mk_congr _ _; assumption
end

def inl {X Y : prod_coprod C} : X ⟶ (X.coprod Y) :=
of_syntax inl

def inr {X Y : prod_coprod C} : Y ⟶ (X.coprod Y) :=
of_syntax inr

@[elab_as_eliminator] lemma hom_induction
  {motive : Π (X Y : prod_coprod C), (X ⟶ Y) → Prop}
  {X Y : prod_coprod C} (f : X ⟶ Y)
  (h₁ : Π {X Y : C} (f : X ⟶ Y), motive _ _ (of_cat.map f))
  (h₂ : Π {X Y Z : prod_coprod C} (f : X ⟶ Y) (g : X ⟶ Z),
     motive X Y f → motive X Z g → motive _ _ (prod_mk f g))
  (h₃ : Π {X Y : prod_coprod C}, motive (X.prod Y) X fst)
  (h₄ : Π {X Y : prod_coprod C}, motive (X.prod Y) Y snd)
  (h₅ : Π {X Y Z : prod_coprod C} (f : X ⟶ Z) (g : Y ⟶ Z),
     motive X Z f → motive Y Z g → motive _ _ (coprod_mk f g))
  (h₆ : Π {X Y : prod_coprod C}, motive X (X.coprod Y) inl)
  (h₇ : Π {X Y : prod_coprod C}, motive Y (X.coprod Y) inr)
  (h₈ : Π (X : prod_coprod C), motive X X (𝟙 X))
  (h₉ : Π {X Y Z : prod_coprod C} (f : X ⟶ Y) (g : Y ⟶ Z),
     motive X Y f → motive Y Z g → motive X Z (f ≫ g)) :
  motive X Y f :=
quotient.induction_on f
  begin
    intro f,
    apply syntax.rec_on f; try { assumption },
    { intros _ _ _ f g,
      exact h₂ (of_syntax f) (of_syntax g) },
    { intros _ _ _ f g,
      exact h₅ (of_syntax f) (of_syntax g) },
    { intros _ _ _ f g,
      exact h₉ (of_syntax f) (of_syntax g) }
  end

@[simp] lemma inl_comp_coprod_mk {X Y Z : prod_coprod C} (f : X ⟶ Z) (g : Y ⟶ Z) :
  inl ≫ coprod_mk f g = f :=
quotient.induction_on₂ f g (λ f g, quotient.sound (syntax.rel.inl_comp_mk _ _))

@[simp] lemma inr_comp_coprod_mk {X Y Z : prod_coprod C} (f : X ⟶ Z) (g : Y ⟶ Z) :
  inr ≫ coprod_mk f g = g :=
quotient.induction_on₂ f g (λ f g, quotient.sound (syntax.rel.inr_comp_mk _ _))

lemma coprod_mk_eta {X Y Z : prod_coprod C} (f : X.coprod Y ⟶ Z) :
  coprod_mk (inl ≫ f) (inr ≫ f) = f :=
quotient.induction_on f (λ f, quotient.sound (syntax.rel.coprod_eta _))

@[ext] lemma coprod_hom_ext {X Y Z : prod_coprod C} {f g : X.coprod Y ⟶ Z}
  (h₁ : inl ≫ f = inl ≫ g ) (h₂ : inr ≫ f = inr ≫ g) : f = g :=
begin
  conv_lhs { rw ← coprod_mk_eta f },
  rw [h₁, h₂, coprod_mk_eta]
end

-- def wf_rel (x y : (prod_coprod C × prod_coprod C) ⊕
--   (prod_coprod C × prod_coprod C × prod_coprod C)) :Prop :=
-- sum.lex (measure sizeof) (measure sizeof) x y

-- @[simp] def sizeof2 : prod_coprod C → ℕ
-- | (of_cat' X) := 0
-- | (prod X Y) := sizeof2 X + sizeof2 Y + 0
-- | (coprod X Y) := sizeof2 X + sizeof2 Y + 1

-- def hwf_rel_wf : has_well_founded ((prod_coprod C × prod_coprod C) ⊕
--   (prod_coprod C × prod_coprod C × prod_coprod C)) :=
-- ⟨_, measure_wf (λ x, sum.cases_on x
--     (λ x, sizeof x.1 + sizeof x.2)
--     (λ x, sizeof x.1 + sizeof x.2.1 + sizeof x.2.2))⟩

-- @[simp] lemma hwf_rel_wf_simp :@has_well_founded.r _ (@hwf_rel_wf C _) =
--   measure (λ x, sum.cases_on x
--     (λ x, sizeof x.1 + sizeof x.2)
--     (λ x, sizeof x.1 + sizeof x.2.1 + sizeof x.2.2)) := rfl

-- meta def wf_dec_tac : tactic unit :=
-- `[try { simp },
--   well_founded_tactics.default_dec_tac]

/-- Defining two maps by mutual induction. Morally we are defining the following.
  First - `norm_type (X Y : prod_coprod C) : Type`
    The type of normal form of maps `X ⟶ Y`.
  Second - `norm_type_not_proj (X Y Z : prod_coprod C) : Type`
    The type of normal forms of maps `(X.prod Y) ⟶ Z` that cannot be written
    `fst ≫ f` or `snd ≫ f` for any `f`
-/

-- @[simp] def norm_type :
--   ((prod_coprod C × prod_coprod C) ⊕
--   (prod_coprod C × prod_coprod C × prod_coprod C)) → Type
-- | (sum.inl (coprod X Y, Z)) := norm_type (sum.inl (X, Z)) × norm_type (sum.inl (Y, Z))
-- | (sum.inl (prod X Y, Z)) :=
--   norm_type (sum.inl (X, Z)) ⊕ norm_type (sum.inl (Y, Z))
--   ⊕ norm_type (sum.inr (X, Y, Z))
-- | (sum.inl (of_cat' X, of_cat' Y)) := X ⟶ Y
-- | (sum.inl (of_cat' X, prod Y Z)) :=
--   norm_type (sum.inl (of_cat' X, Y)) × norm_type (sum.inl (of_cat' X, Z))
-- | (sum.inl (of_cat' X, coprod Y Z)) :=
--   norm_type (sum.inl (of_cat' X, Y)) ⊕ norm_type (sum.inl (of_cat' X, Z))
-- | (sum.inr (W, X, coprod Y Z)) :=
--   norm_type (sum.inr (W, X, Y)) ⊕  -- (f : prod W X ⟶ Y) ≫ inl
--   norm_type (sum.inr (W, X, Z))  -- (f : prod W X ⟶ Z) ≫ inr
-- | (sum.inr (W, X, prod Y Z)) :=
--   (norm_type (sum.inr (W, X, Y)) × norm_type (sum.inr (W, X, Z))) ⊕ -- prod_mk _ _
--   (norm_type (sum.inl (W, Y)) × norm_type (sum.inl (X, Z))) ⊕
--   (norm_type (sum.inl (W, Z)) × norm_type (sum.inl (X, Y)))
-- | (sum.inr (X, Y, of_cat' Z)) := empty
-- using_well_founded {
--   dec_tac := wf_dec_tac,
--  rel_tac := λ _ _, `[exact hwf_rel_wf] }

inductive norm_hom :
  ((prod_coprod C × prod_coprod C) ⊕
  (prod_coprod C × prod_coprod C × prod_coprod C)) → Type
| coprod_mk {X Y Z : prod_coprod C} :
  norm_hom (sum.inl (X, Z)) → norm_hom (sum.inl (Y, Z)) →
  norm_hom (sum.inl (coprod X Y, Z))
| fst_comp {X Y Z : prod_coprod C} : norm_hom (sum.inl (X, Z)) →
  norm_hom (sum.inl (prod X Y, Z))
| snd_comp {X Y Z : prod_coprod C} : norm_hom (sum.inl (Y, Z)) →
  norm_hom (sum.inl (prod X Y, Z))
| of_not_proj {X Y Z : prod_coprod C} : norm_hom (sum.inr (X, Y, Z)) →
  norm_hom (sum.inl (prod X Y, Z))
| of_cat {X Y : C} : (X ⟶ Y) → norm_hom (sum.inl (of_cat' X, of_cat' Y))
| comp_inl_of_cat {X : C} {Y Z : prod_coprod C} : norm_hom (sum.inl (of_cat' X, Y)) →
  norm_hom (sum.inl (of_cat' X, coprod Y Z))
| comp_inr_of_cat {X : C} {Y Z : prod_coprod C} : norm_hom (sum.inl (of_cat' X, Z)) →
  norm_hom (sum.inl (of_cat' X, coprod Y Z))
| prod_mk_of_cat {X : C} {Y Z : prod_coprod C} : norm_hom (sum.inl (of_cat' X, Y)) →
  norm_hom (sum.inl (of_cat' X, Z)) → norm_hom (sum.inl (of_cat' X, prod Y Z))
| comp_inl_not_proj {W X Y Z : prod_coprod C} : norm_hom (sum.inr (W, X, Y)) →
  norm_hom (sum.inr (W, X, coprod Y Z))
| comp_inr_not_proj {W X Y Z : prod_coprod C} : norm_hom (sum.inr (W, X, Z)) →
  norm_hom (sum.inr (W, X, coprod Y Z))
| prod_mk_not_proj {W X Y Z : prod_coprod C} : norm_hom (sum.inr (W, X, Y)) →
  norm_hom (sum.inr (W, X, Z)) → norm_hom (sum.inr (W, X, prod Y Z))
| prod_mk_not_proj_fst_comp {W X Y Z : prod_coprod C} : norm_hom (sum.inr (W, X, Y)) →
  norm_hom (sum.inl (W, Z)) → norm_hom (sum.inr (W, X, prod Y Z))
| prod_mk_not_proj_snd_comp {W X Y Z : prod_coprod C} : norm_hom (sum.inr (W, X, Y)) →
  norm_hom (sum.inl (X, Z)) → norm_hom (sum.inr (W, X, prod Y Z))
| prod_mk_fst_comp_not_proj {W X Y Z : prod_coprod C} : norm_hom (sum.inl (W, Y)) →
  norm_hom (sum.inr (W, X, Z)) → norm_hom (sum.inr (W, X, prod Y Z))
| prod_mk_snd_comp_not_proj {W X Y Z : prod_coprod C} : norm_hom (sum.inl (X, Y)) →
  norm_hom (sum.inr (W, X, Z)) → norm_hom (sum.inr (W, X, prod Y Z))
| prod_mk_fst_comp_snd_comp {W X Y Z : prod_coprod C} :
  norm_hom (sum.inl (W, Y)) → norm_hom (sum.inl (X, Z)) →
  norm_hom (sum.inr (W, X, prod Y Z))
| prod_mk_snd_comp_fst_comp {W X Y Z : prod_coprod C} :
  norm_hom (sum.inl (X, Y)) → norm_hom (sum.inl (W, Z)) →
  norm_hom (sum.inr (W, X, prod Y Z))

variables {W X Y Z : prod_coprod C}

open norm_hom

def norm_hom.comp_inl : Π {X Y Z : prod_coprod C}, norm_hom (sum.inl (X, Y)) →
  norm_hom (sum.inl (X, coprod Y Z))
| (of_cat' X) _ _ f := norm_hom.comp_inl_of_cat f
| (coprod W X) Y Z (norm_hom.coprod_mk f g) := norm_hom.coprod_mk (norm_hom.comp_inl f) (norm_hom.comp_inl g)
| (prod W X) Y Z (norm_hom.fst_comp f) := norm_hom.fst_comp (norm_hom.comp_inl f)
| (prod W X) Y Z (norm_hom.snd_comp f) := norm_hom.snd_comp (norm_hom.comp_inl f)
| (prod W X) Y Z (norm_hom.of_not_proj f) := norm_hom.of_not_proj (norm_hom.comp_inl_not_proj f)

def norm_hom.comp_inr : Π {X Y Z : prod_coprod C}, norm_hom (sum.inl (X, Z)) →
  norm_hom (sum.inl (X, coprod Y Z))
| (of_cat' X) _ _ f := norm_hom.comp_inr_of_cat f
| (coprod W X) Y Z (norm_hom.coprod_mk f g) := norm_hom.coprod_mk (norm_hom.comp_inr f) (norm_hom.comp_inr g)
| (prod W X) Y Z (norm_hom.fst_comp f) := norm_hom.fst_comp (norm_hom.comp_inr f)
| (prod W X) Y Z (norm_hom.snd_comp f) := norm_hom.snd_comp (norm_hom.comp_inr f)
| (prod W X) Y Z (norm_hom.of_not_proj f) := norm_hom.of_not_proj (norm_hom.comp_inr_not_proj f)

def norm_hom.id : Π (X : prod_coprod C), norm_hom (sum.inl (X, X))
| (of_cat' X) := norm_hom.of_cat (𝟙 X)
| (prod X Y) := norm_hom.of_not_proj
  (norm_hom.prod_mk_fst_comp_snd_comp (norm_hom.id X) (norm_hom.id Y))
| (coprod X Y) :=
  norm_hom.coprod_mk
    (norm_hom.comp_inl (norm_hom.id _))
    (norm_hom.comp_inr (norm_hom.id _))

def norm_hom.inl {X Y : prod_coprod C} : norm_hom (sum.inl (X, coprod X Y)) :=
norm_hom.comp_inl (norm_hom.id _)

def norm_hom.inr {X Y : prod_coprod C} : norm_hom (sum.inl (Y, coprod X Y)) :=
norm_hom.comp_inr (norm_hom.id _)

def norm_hom.fst {X Y : prod_coprod C} : norm_hom (sum.inl (prod X Y, X)) :=
norm_hom.fst_comp (norm_hom.id _)

def norm_hom.snd {X Y : prod_coprod C} : norm_hom (sum.inl (prod X Y, Y)) :=
norm_hom.snd_comp (norm_hom.id _)

def norm_hom.prod_mk : Π {X Y Z : prod_coprod C} (f : norm_hom (sum.inl (X, Y)))
  (g : norm_hom (sum.inl (X, Z))), norm_hom (sum.inl (X, prod Y Z))
| (of_cat' X) Y Z f g := norm_hom.prod_mk_of_cat f g
| (prod W X) Y Z (norm_hom.fst_comp f) (norm_hom.fst_comp g) :=
  norm_hom.fst_comp (norm_hom.prod_mk f g)
| (prod W X) Y Z (norm_hom.snd_comp f) (norm_hom.snd_comp g) :=
  norm_hom.snd_comp (norm_hom.prod_mk f g)
| (prod W X) Y Z (norm_hom.fst_comp f) (norm_hom.snd_comp g) :=
  norm_hom.of_not_proj (norm_hom.prod_mk_fst_comp_snd_comp f g)
| (prod W X) Y Z (norm_hom.snd_comp f) (norm_hom.fst_comp g) :=
  norm_hom.of_not_proj (norm_hom.prod_mk_snd_comp_fst_comp f g)
| (prod W X) Y Z (norm_hom.of_not_proj f) (norm_hom.fst_comp g) :=
  norm_hom.of_not_proj (norm_hom.prod_mk_not_proj_fst_comp f g)
| (prod W X) Y Z (norm_hom.of_not_proj f) (norm_hom.snd_comp g) :=
  norm_hom.of_not_proj (norm_hom.prod_mk_not_proj_snd_comp f g)
| (prod W X) Y Z (norm_hom.fst_comp f) (norm_hom.of_not_proj g)  :=
  norm_hom.of_not_proj (norm_hom.prod_mk_fst_comp_not_proj f g)
| (prod W X) Y Z (norm_hom.snd_comp f) (norm_hom.of_not_proj g)  :=
  norm_hom.of_not_proj (norm_hom.prod_mk_snd_comp_not_proj f g)
| (prod W X) Y Z (norm_hom.of_not_proj f) (norm_hom.of_not_proj g)  :=
  norm_hom.of_not_proj (norm_hom.prod_mk_not_proj f g)
| (coprod W X) Y Z (norm_hom.coprod_mk f g) (norm_hom.coprod_mk h i) :=
  norm_hom.coprod_mk (norm_hom.prod_mk f h) (norm_hom.prod_mk g i)
--set_option timeout 400000

inductive norm_hom2 : Π (X Y : prod_coprod C), Type
| of_cat {X Y : C} (f : X ⟶ Y) : norm_hom2 (of_cat' X) (of_cat' Y)
| coprod_mk {X Y Z : prod_coprod C} (f : norm_hom2 X Z) (g : norm_hom2 Y Z) :
  norm_hom2 (X.coprod Y) Z
| comp_inl {X Y Z : prod_coprod C} (f : norm_hom2 X Y) :
  norm_hom2 X (coprod Y Z)
| comp_inr {X Y Z : prod_coprod C} (f : norm_hom2 X Z) :
  norm_hom2 X (coprod Y Z)
| prod_mk {X Y Z : prod_coprod C} (f : norm_hom2 X Y) (g : norm_hom2 X Z) :
  norm_hom2 X (prod Y Z)
| fst_comp {X Y Z : prod_coprod C} (f : norm_hom2 X Z) :
  norm_hom2 (prod X Y) Z
| snd_comp {X Y Z : prod_coprod C} (f : norm_hom2 Y Z) :
  norm_hom2 (prod X Y) Z

@[simp] def norm_hom.to_norm_hom2 : Π {X Y : prod_coprod C} (f : norm_hom (sum.inl (X, Y))),
  norm_hom2 X Y
| _ _ (norm_hom.of_cat f) := norm_hom2.of_cat f
| _ _ (norm_hom.coprod_mk f g) := norm_hom2.coprod_mk (norm_hom.to_norm_hom2 f) (norm_hom.to_norm_hom2 g)
| _ _ (norm_hom.fst_comp f) := norm_hom2.fst_comp (norm_hom.to_norm_hom2 f)
| _ _ (norm_hom.snd_comp f) := norm_hom2.snd_comp (norm_hom.to_norm_hom2 f)
| _ _ (norm_hom.comp_inl_of_cat f) := norm_hom2.comp_inl (norm_hom.to_norm_hom2 f)
| _ _ (norm_hom.comp_inr_of_cat f) := norm_hom2.comp_inr (norm_hom.to_norm_hom2 f)
| _ _ (norm_hom.prod_mk_of_cat f g) := norm_hom2.prod_mk (norm_hom.to_norm_hom2 f) (norm_hom.to_norm_hom2 g)
| _ _ (norm_hom.of_not_proj (norm_hom.comp_inl_not_proj f)) :=
  norm_hom2.comp_inl (norm_hom.to_norm_hom2 (norm_hom.of_not_proj f))
| _ _ (norm_hom.of_not_proj (norm_hom.comp_inr_not_proj f)) :=
  norm_hom2.comp_inr (norm_hom.to_norm_hom2 (norm_hom.of_not_proj f))
| _ _ (norm_hom.of_not_proj (norm_hom.prod_mk_not_proj f g)) :=
  norm_hom2.prod_mk (norm_hom.to_norm_hom2 f.of_not_proj) (norm_hom.to_norm_hom2 g.of_not_proj)
| _ _ (norm_hom.of_not_proj (norm_hom.prod_mk_not_proj_fst_comp f g)) :=
  norm_hom2.prod_mk (norm_hom.to_norm_hom2 f.of_not_proj) (norm_hom.to_norm_hom2 g.fst_comp)
| _ _ (norm_hom.of_not_proj (norm_hom.prod_mk_not_proj_snd_comp f g)) :=
  norm_hom2.prod_mk (norm_hom.to_norm_hom2 f.of_not_proj) (norm_hom.to_norm_hom2 g.snd_comp)
| _ _ (norm_hom.of_not_proj (norm_hom.prod_mk_fst_comp_not_proj f g)) :=
  norm_hom2.prod_mk (norm_hom.to_norm_hom2 f.fst_comp) (norm_hom.to_norm_hom2 g.of_not_proj)
| _ _ (norm_hom.of_not_proj (norm_hom.prod_mk_snd_comp_not_proj f g)) :=
  norm_hom2.prod_mk (norm_hom.to_norm_hom2 f.snd_comp) (norm_hom.to_norm_hom2 g.of_not_proj)
| _ _ (norm_hom.of_not_proj (norm_hom.prod_mk_fst_comp_snd_comp f g)) :=
  norm_hom2.prod_mk (norm_hom.to_norm_hom2 f.fst_comp) (norm_hom.to_norm_hom2 g.snd_comp)
| _ _ (norm_hom.of_not_proj (norm_hom.prod_mk_snd_comp_fst_comp f g)) :=
  norm_hom2.prod_mk (norm_hom.to_norm_hom2 f.snd_comp) (norm_hom.to_norm_hom2 g.fst_comp)

@[simp] def norm_hom2.comp : Π {X Y Z : prod_coprod C} (f : norm_hom2 X Y)
  (g : norm_hom2 Y Z), norm_hom2 X Z
| _ _ _ (norm_hom2.coprod_mk f g) h :=
  norm_hom2.coprod_mk (norm_hom2.comp f h) (norm_hom2.comp g h)
| _ _ _ (norm_hom2.fst_comp f) g :=
  norm_hom2.fst_comp (norm_hom2.comp f g)
| _ _ _ (norm_hom2.snd_comp f) g :=
  norm_hom2.snd_comp (norm_hom2.comp f g)
-- | _ _ _ f (norm_hom2.prod_mk g h) :=
--   norm_hom2.prod_mk (norm_hom2.comp f g) (norm_hom2.comp f h)
-- | _ _ _ f (norm_hom2.comp_inl g) :=
--   norm_hom2.comp_inl (norm_hom2.comp f g)
-- | _ _ _ f (norm_hom2.comp_inr g) :=
--   norm_hom2.comp_inr (norm_hom2.comp f g)
| _ _ _ (norm_hom2.of_cat f) (norm_hom2.of_cat g) :=
  norm_hom2.of_cat (f ≫ g)
| _ _ _ (norm_hom2.comp_inl f) (norm_hom2.coprod_mk g h) :=
  norm_hom2.comp f g
| _ _ _ (norm_hom2.comp_inr f) (norm_hom2.coprod_mk g h) :=
  norm_hom2.comp f h
| _ _ _  (norm_hom2.prod_mk f g) (norm_hom2.fst_comp h) :=
  norm_hom2.comp f h
| _ _ _  (norm_hom2.prod_mk f g) (norm_hom2.snd_comp h) :=
  norm_hom2.comp g h
--repeated cases
| _ _ _ (norm_hom2.of_cat f) (norm_hom2.comp_inl g) :=
  norm_hom2.comp_inl (norm_hom2.comp (norm_hom2.of_cat f) g)
| _ _ _ (norm_hom2.of_cat f) (norm_hom2.comp_inr g) :=
  norm_hom2.comp_inr (norm_hom2.comp (norm_hom2.of_cat f) g)
| _ _ _ (norm_hom2.of_cat f) (norm_hom2.prod_mk g h) :=
  norm_hom2.prod_mk (norm_hom2.comp (norm_hom2.of_cat f) g)
    (norm_hom2.comp (norm_hom2.of_cat f) h)
| _ _ _ f'@(norm_hom2.comp_inl f) (norm_hom2.comp_inl g) :=
  norm_hom2.comp_inl (norm_hom2.comp f' g)
| _ _ _ f'@(norm_hom2.comp_inr f) (norm_hom2.comp_inl g) :=
  norm_hom2.comp_inl (norm_hom2.comp f' g)
| _ _ _ f'@(norm_hom2.comp_inr f) (norm_hom2.comp_inr g) :=
  norm_hom2.comp_inr (norm_hom2.comp f' g)
| _ _ _ f'@(norm_hom2.comp_inl f) (norm_hom2.comp_inr g) :=
  norm_hom2.comp_inr (norm_hom2.comp f' g)
| _ _ _ f'@(norm_hom2.comp_inl f) (norm_hom2.prod_mk g h) :=
  norm_hom2.prod_mk (norm_hom2.comp f' g) (norm_hom2.comp f' h)
| _ _ _ f'@(norm_hom2.comp_inr f) (norm_hom2.prod_mk g h) :=
  norm_hom2.prod_mk (norm_hom2.comp f' g) (norm_hom2.comp f' h)
| _ _ _ f@(norm_hom2.prod_mk _ _) (norm_hom2.comp_inl g) :=
  norm_hom2.comp_inl (norm_hom2.comp f g)
| _ _ _ f@(norm_hom2.prod_mk _ _) (norm_hom2.comp_inr g) :=
  norm_hom2.comp_inr (norm_hom2.comp f g)
| _ _ _ f@(norm_hom2.prod_mk _ _) (norm_hom2.prod_mk g h) :=
  norm_hom2.prod_mk (norm_hom2.comp f g) (norm_hom2.comp f h)

@[simp] def norm_hom2.to_norm_hom : Π {X Y : prod_coprod C} (f : norm_hom2 X Y),
  norm_hom (sum.inl (X, Y))
| _ _ (norm_hom2.of_cat f) := norm_hom.of_cat f
| _ _ (norm_hom2.comp_inl f) := norm_hom.comp_inl (norm_hom2.to_norm_hom f)
| _ _ (norm_hom2.comp_inr f) := norm_hom.comp_inr (norm_hom2.to_norm_hom f)
| _ _ (norm_hom2.fst_comp f) := norm_hom.fst_comp (norm_hom2.to_norm_hom f)
| _ _ (norm_hom2.snd_comp f) := norm_hom.snd_comp (norm_hom2.to_norm_hom f)
| _ _ (norm_hom2.prod_mk f g) := norm_hom.prod_mk (norm_hom2.to_norm_hom f) (norm_hom2.to_norm_hom g)
| _ _ (norm_hom2.coprod_mk f g) := norm_hom.coprod_mk (norm_hom2.to_norm_hom f) (norm_hom2.to_norm_hom g)

@[simp] def norm_hom2.to_hom : Π {X Y : prod_coprod C} (f : norm_hom2 X Y), (X ⟶ Y)
| _ _ (norm_hom2.of_cat f) := of_cat.map f
| _ _ (norm_hom2.comp_inl f) := norm_hom2.to_hom f ≫ inl
| _ _ (norm_hom2.comp_inr f) := norm_hom2.to_hom f ≫ inr
| _ _ (norm_hom2.fst_comp f) := fst ≫ norm_hom2.to_hom f
| _ _ (norm_hom2.snd_comp f) := snd ≫ norm_hom2.to_hom f
| _ _ (norm_hom2.prod_mk f g) := prod_mk (norm_hom2.to_hom f) (norm_hom2.to_hom g)
| _ _ (norm_hom2.coprod_mk f g) := coprod_mk (norm_hom2.to_hom f) (norm_hom2.to_hom g)

@[simp] def norm_hom.comp {X Y Z : prod_coprod C} (f : norm_hom (sum.inl (X, Y)))
  (g : norm_hom (sum.inl (Y, Z))) : norm_hom (sum.inl (X, Z)) :=
(f.to_norm_hom2.comp g.to_norm_hom2).to_norm_hom

lemma comp_id {X Y Z : prod_coprod C}
  (f : norm_hom (sum.inl (X, Y))) :
  f.comp (norm_hom.id _) = f :=
begin

end
-- | (coprod W X) Y Z (norm_hom.coprod_mk f g) := norm_hom.coprod_mk (norm_hom.comp_inl f) (norm_hom.comp_inl g)
-- | (prod W X) Y Z (norm_hom.fst_comp f) := norm_hom.fst_comp (norm_hom.comp_inl f)
-- | (prod W X) Y Z (norm_hom.snd_comp f) := norm_hom.snd_comp (norm_hom.comp_inl f)
-- | (prod W X) Y Z (norm_hom.of_not_proj f) := norm_hom.of_not_proj (norm_hom.comp_inl_not_proj f)

@[simp] def norm_syntax : Π {X Y : prod_coprod C} (f : syntax X Y),
  norm_hom (sum.inl (X, Y))
| _ _ (syntax.of_cat f) := norm_hom.of_cat f
| _ _ (syntax.id _) := norm_hom.id _
| _ _ (syntax.comp f g) := (norm_syntax f).comp (norm_syntax g)
| _ _ syntax.fst := norm_hom.fst
| _ _ syntax.snd := norm_hom.snd
| _ _ (syntax.prod_mk f g) := norm_hom.prod_mk (norm_syntax f) (norm_syntax g)
| _ _ syntax.inl := norm_hom.inl
| _ _ syntax.inr := norm_hom.inr
| _ _ (syntax.coprod_mk f g) := norm_hom.coprod_mk (norm_syntax f) (norm_syntax g)

lemma norm_syntax_rel : Π {X Y : prod_coprod C} {f g : syntax X Y}, rel f g → norm_syntax f = norm_syntax g :=
begin
  intros X Y f g h,
  induction h; simp [*, norm_hom.to_norm_hom2, norm_hom.id] at *,

end
#exit
@[simp] lemma to_hom_comp_inl : Π {X Y Z : prod_coprod C} (f : norm_hom (sum.inl (X, Y))),
  (@norm_hom.comp_inl _ _ _ _ Z f).to_norm_hom2.to_hom = f.to_norm_hom2.to_hom ≫ inl
| (of_cat' X) _ _ f := by simp [norm_hom.comp_inl]
| (coprod W X) Y Z (norm_hom.coprod_mk f g) :=
  by ext; simp [norm_hom.comp_inl, to_hom_comp_inl f, to_hom_comp_inl g,
    ← category.assoc]
| (prod W X) Y Z (norm_hom.fst_comp f) := by simp [norm_hom.comp_inl, to_hom_comp_inl f]
| (prod W X) Y Z (norm_hom.snd_comp f) := by simp [norm_hom.comp_inl, to_hom_comp_inl f]
| (prod W X) Y Z (norm_hom.of_not_proj f) :=
  by simp [norm_hom.comp_inl, to_hom_comp_inl f.of_not_proj]

@[simp] lemma to_hom_comp_inr : Π {X Y Z : prod_coprod C} (f : norm_hom (sum.inl (X, Z))),
  (@norm_hom.comp_inr _ _ X Y Z f).to_norm_hom2.to_hom = f.to_norm_hom2.to_hom ≫ inr
| (of_cat' X) _ _ f := by simp [norm_hom.comp_inr]
| (coprod W X) Y Z (norm_hom.coprod_mk f g) :=
  by ext; simp [norm_hom.comp_inr, to_hom_comp_inr f, to_hom_comp_inr g,
    ← category.assoc]
| (prod W X) Y Z (norm_hom.fst_comp f) := by simp [norm_hom.comp_inr, to_hom_comp_inr f]
| (prod W X) Y Z (norm_hom.snd_comp f) := by simp [norm_hom.comp_inr, to_hom_comp_inr f]
| (prod W X) Y Z (norm_hom.of_not_proj f) :=
  by simp [norm_hom.comp_inr, to_hom_comp_inr f.of_not_proj]

@[simp] lemma to_hom_prod_mk : Π {X Y Z : prod_coprod C} (f : norm_hom (sum.inl (X, Y)))
  (g : norm_hom (sum.inl (X, Z))),
  (f.prod_mk g).to_norm_hom2.to_hom = prod_mk f.to_norm_hom2.to_hom g.to_norm_hom2.to_hom
| (of_cat' X) Y Z f g := by simp [norm_hom.prod_mk]
| (prod W X) Y Z (norm_hom.fst_comp f) (norm_hom.fst_comp g) :=
  by ext; simp [norm_hom.prod_mk, to_hom_prod_mk f, to_hom_prod_mk g]
| (prod W X) Y Z (norm_hom.snd_comp f) (norm_hom.snd_comp g) :=
  by ext; simp [norm_hom.prod_mk, to_hom_prod_mk f, to_hom_prod_mk g]
| (prod W X) Y Z (norm_hom.fst_comp f) (norm_hom.snd_comp g) :=
  by ext; simp [norm_hom.prod_mk, to_hom_prod_mk f, to_hom_prod_mk g]
| (prod W X) Y Z (norm_hom.snd_comp f) (norm_hom.fst_comp g) :=
  by ext; simp [norm_hom.prod_mk, to_hom_prod_mk f, to_hom_prod_mk g]
| (prod W X) Y Z (norm_hom.of_not_proj f) (norm_hom.fst_comp g) :=
  by ext; simp [norm_hom.prod_mk, to_hom_prod_mk f.of_not_proj, to_hom_prod_mk g]
| (prod W X) Y Z (norm_hom.of_not_proj f) (norm_hom.snd_comp g) :=
  by ext; simp [norm_hom.prod_mk, to_hom_prod_mk f.of_not_proj, to_hom_prod_mk g]
| (prod W X) Y Z (norm_hom.fst_comp f) (norm_hom.of_not_proj g)  :=
  by ext; simp [norm_hom.prod_mk, to_hom_prod_mk f, to_hom_prod_mk g.of_not_proj]
| (prod W X) Y Z (norm_hom.snd_comp f) (norm_hom.of_not_proj g)  :=
  by ext; simp [norm_hom.prod_mk, to_hom_prod_mk f, to_hom_prod_mk g.of_not_proj]
| (prod W X) Y Z (norm_hom.of_not_proj f) (norm_hom.of_not_proj g)  :=
  by ext; simp [norm_hom.prod_mk, to_hom_prod_mk f.of_not_proj, to_hom_prod_mk g.of_not_proj]
| (coprod W X) Y Z (norm_hom.coprod_mk f g) (norm_hom.coprod_mk h i) :=
  by ext; simp [norm_hom.prod_mk, to_hom_prod_mk f, to_hom_prod_mk g]

@[simp] lemma to_hom_comp : Π {X Y Z : prod_coprod C} (f : norm_hom2 X Y) (g : norm_hom2 Y Z),
  (f.comp g).to_hom = f.to_hom ≫ g.to_hom
| _ _ _ (norm_hom2.coprod_mk f g) h :=
  by ext; simp [to_hom_comp f, to_hom_comp g, ← category.assoc]
| _ _ _ (norm_hom2.fst_comp f) g :=
  by simp [to_hom_comp f]
| _ _ _ (norm_hom2.snd_comp f) g :=
  by simp [to_hom_comp f]
-- | _ _ _ f (norm_hom2.prod_mk g h) :=
-- | _ _ _ f (norm_hom2.comp_inl g) := g)
-- | _ _ _ f (norm_hom2.comp_inr g) :=
| _ _ _ (norm_hom2.of_cat f) (norm_hom2.of_cat g) :=
  by simp
| _ _ _ (norm_hom2.comp_inl f) (norm_hom2.coprod_mk g h) :=
  by simp [to_hom_comp f]
| _ _ _ (norm_hom2.comp_inr f) (norm_hom2.coprod_mk g h) :=
  by simp [to_hom_comp f]
| _ _ _  (norm_hom2.prod_mk f g) (norm_hom2.fst_comp h) :=
  by simp [to_hom_comp _ h, ← category.assoc]
| _ _ _  (norm_hom2.prod_mk f g) (norm_hom2.snd_comp h) :=
  by simp [to_hom_comp _ h, ← category.assoc]
--repeated cases
| _ _ _ (norm_hom2.of_cat f) (norm_hom2.comp_inl g) :=
  by simp [to_hom_comp _ g]
| _ _ _ (norm_hom2.of_cat f) (norm_hom2.comp_inr g) :=
  by simp [to_hom_comp _ g]
| _ _ _ (norm_hom2.of_cat f) (norm_hom2.prod_mk g h) :=
  by ext; simp [to_hom_comp _ g, to_hom_comp _ h]
| _ _ _ (norm_hom2.comp_inl f) (norm_hom2.comp_inl g) :=
  by simp [to_hom_comp _ g]
| _ _ _ (norm_hom2.comp_inr f) (norm_hom2.comp_inl g) :=
  by simp [to_hom_comp _ g]
| _ _ _ f'@(norm_hom2.comp_inr f) (norm_hom2.comp_inr g) :=
  by simp [to_hom_comp _ g]
| _ _ _ f'@(norm_hom2.comp_inl f) (norm_hom2.comp_inr g) :=
  by simp [to_hom_comp _ g]
| _ _ _ f'@(norm_hom2.comp_inl f) (norm_hom2.prod_mk g h) :=
  by ext; simp [to_hom_comp _ g, to_hom_comp _ h]
| _ _ _ f'@(norm_hom2.comp_inr f) (norm_hom2.prod_mk g h) :=
  by ext; simp [to_hom_comp _ g, to_hom_comp _ h]
| _ _ _ f@(norm_hom2.prod_mk _ _) (norm_hom2.comp_inl g) :=
  by simp [to_hom_comp _ g]
| _ _ _ f@(norm_hom2.prod_mk _ _) (norm_hom2.comp_inr g) :=
  by simp [to_hom_comp _ g]
| _ _ _ f@(norm_hom2.prod_mk _ _) (norm_hom2.prod_mk g h) :=
  by ext; simp [to_hom_comp _ g, to_hom_comp _ h]

#exit
lemma to_presheaf_syntax_comp {X Y Z : prod_coprod C} (f : syntax X Y) (g : syntax Y Z) :
  to_presheaf_syntax (f.comp g) = to_presheaf_syntax f ≫ to_presheaf_syntax g := rfl

lemma to_presheaf_syntax_rel {X Y : prod_coprod C} (f g : syntax X Y) (h : rel f g) :
  to_presheaf_syntax f = to_presheaf_syntax g :=
begin
  induction h; try { simp * }; try { ext }; try { refl }; tidy,
end

def to_presheaf : prod_coprod C ⥤ (Cᵒᵖ ⥤ Type) :=
{ obj := to_presheaf_obj,
  map := λ X Y f, quotient.lift_on f (to_presheaf_syntax) to_presheaf_syntax_rel,
  map_id' := λ _, rfl,
  map_comp' := λ _ _ _ f g, quotient.induction_on₂ f g begin intros, simp,
    erw quotient.lift_on_mk,
    simp [to_presheaf_syntax_comp] end }

@[simp] lemma to_presheaf_obj_of_cat (X : C) : to_presheaf.obj (of_cat' X) = yoneda.obj X := rfl

@[simp] lemma to_presheaf_obj_prod (X Y : prod_coprod C) : to_presheaf.obj (prod X Y) =
  Pprod (to_presheaf_obj X) (to_presheaf_obj Y) := rfl

@[simp] lemma to_presheaf_obj_coprod (X Y : prod_coprod C) : to_presheaf.obj (coprod X Y) =
  Pcoprod (to_presheaf_obj X) (to_presheaf_obj Y) := rfl

@[simp] lemma to_presheaf_of_cat {X Y : C} (f : X ⟶ Y) :
  to_presheaf.map (of_cat.map f) = yoneda.map f := rfl

@[simp] lemma to_presheaf_prod_mk {X Y Z : prod_coprod C}
  (f : X ⟶ Y) (g : X ⟶ Z) :
  to_presheaf.map (prod_mk f g) = Pprod_lift (to_presheaf.map f) (to_presheaf.map g) :=
begin
  refine quotient.induction_on₂ f g _,
  intros, refl
end

@[simp] lemma to_presheaf_coprod_mk {X Y Z : prod_coprod C}
  (f : X ⟶ Z) (g : Y ⟶ Z) :
  to_presheaf.map (coprod_mk f g) = Pcoprod_lift (to_presheaf.map f) (to_presheaf.map g) :=
begin
  refine quotient.induction_on₂ f g _,
  intros, refl
end

@[simp] lemma to_presheaf_fst {X Y : prod_coprod C} :
  to_presheaf.map (fst : X.prod Y ⟶ X) = Pprod_fst := rfl

@[simp] lemma to_presheaf_snd {X Y : prod_coprod C} :
  to_presheaf.map (snd : X.prod Y ⟶ Y) = Pprod_snd := rfl

@[simp] lemma to_presheaf_inl {X Y : prod_coprod C} :
  to_presheaf.map (inl : X ⟶ X.coprod Y) = Pcoprod_inl := rfl

@[simp] lemma to_presheaf_inr {X Y : prod_coprod C} :
  to_presheaf.map (inr : Y ⟶ X.coprod Y) = Pcoprod_inr := rfl

end syntax

def transformation_syntax : Π {X : C} {Y : prod_coprod C}, (to_presheaf.obj Y).obj (opposite.op X) →
  syntax (of_cat' X) Y
| X (of_cat' Y) := λ f, syntax.of_cat f
| X (prod Y Z) := λ f, syntax.prod_mk (transformation_syntax f.1) (transformation_syntax f.2)
| X (coprod Y Z) := λ f, f.elim
  (λ f, (transformation_syntax f).comp syntax.inl)
  (λ f, (transformation_syntax f).comp syntax.inr)

@[simp] def transformation : Π {X : C} {Y : prod_coprod C},
  (to_presheaf.obj Y).obj (opposite.op X) →
  ((of_cat' X) ⟶ Y)
| X (of_cat' Y) := λ f, of_cat.map f
| X (prod Y Z) := λ f, prod_mk (transformation f.1) (transformation f.2)
| X (coprod Y Z) := λ f, f.elim
  (λ f, (transformation f) ≫ inl)
  (λ f, (transformation f) ≫ inr)

lemma transformation_eq_of_syntax_transformation_syntax {X : C} {Y : prod_coprod C}
  (x : (to_presheaf.obj Y).obj (opposite.op X)) :
  transformation x = of_syntax (transformation_syntax x) :=
by induction Y; simp [transformation, transformation_syntax, *]; tidy

lemma transformation_left_naturality : Π {X Y : prod_coprod C}
  (f : X ⟶ Y) ⦃Z : C⦄ (z : (to_presheaf.obj X).obj (op Z)),
  transformation ((to_presheaf.map f).app (op Z) z) =
  transformation z ≫ f :=
begin
  intros X Y f Z z, revert Z z,
  refine hom_induction f _ _ _ _ _ _ _ _ _; intros; try { ext };
  try { dsimp at * }; try { simp * at * },
  cases z; simp *
end

def transformation_inverse {X : C} {Y : prod_coprod C}
  (f : (of_cat' X) ⟶ Y) :
  (to_presheaf.obj Y).obj (opposite.op X) :=
yoneda_equiv (to_presheaf.map f)

lemma transformation_transformation_inverse {X : C} {Y : prod_coprod C}
  (f : (of_cat' X) ⟶ Y) : transformation (transformation_inverse f) = f :=
begin
  simp [yoneda_equiv, transformation_inverse, transformation_left_naturality],
  exact category.id_comp _,
end

lemma transformation_inverse_transformation {X : C} {Y : prod_coprod C}
  (f : (to_presheaf.obj Y).obj (opposite.op X)) :
  transformation_inverse (transformation f) = f :=
begin
  simp [yoneda_equiv, transformation_inverse, transformation_left_naturality],
  induction Y,
  { simp [transformation], exact category.id_comp _ },
  { simp [transformation, *] },
  { cases f;
    simp [transformation, *] }
end

instance of_cat_full : full (@of_cat C _) :=
{ preimage := λ X Y f, ((to_presheaf.map f).app (op X) (𝟙 X)),
  witness' := λ X Y f, begin
    have := transformation_left_naturality f (𝟙 X),
    simp at this,
    erw [category.id_comp] at this,
    simpa using this
  end }

instance of_cat_faithful : faithful (@of_cat C _) :=
{ map_injective' := λ X Y f g h, begin
    have := congr_arg transformation_inverse h,
    simp [transformation_inverse] at this,
    erw [category.id_comp] at this,
    erw [category.id_comp] at this,
    assumption
end }

def normalize {X : C} {Y : prod_coprod C}
  (f : (of_cat' X) ⟶ Y) : syntax (of_cat' X) Y :=
transformation_syntax (transformation_inverse f)

lemma of_syntax_normalize {X : C} {Y : prod_coprod C}
  (f : (of_cat' X) ⟶ Y) : of_syntax (normalize f) = f :=
by rw [normalize, ← transformation_eq_of_syntax_transformation_syntax,
  transformation_transformation_inverse]

end prod_coprod