import traversals.basic
import category_theory.currying

open category_theory
open category_theory.limits
open simplex_category
open sSet
open_locale simplicial

namespace traversal

namespace geom_real_rec

variables {n : ℕ}

def sSet_colimit {sh : Type*} [small_category sh] (diag : sh ⥤ sSet) :
  colimit_cocone (diag) :=
{ cocone := combine_cocones (diag) (λ n,
  { cocone := types.colimit_cocone _,
    is_colimit := types.colimit_cocone_is_colimit _ }),
  is_colimit := combined_is_colimit _ _, }

def sSet_pushout {X Y Z : sSet} (f : X ⟶ Y) (g : X ⟶ Z) := sSet_colimit (span f g)

def bundle : Π (θ : traversal n), Σ (g : sSet), Δ[n] ⟶ g
| ⟦⟧       := ⟨Δ[n], 𝟙 _⟩
| (e :: θ) :=
  let colim := sSet_pushout (to_sSet_hom (δ e.t)) (bundle θ).2 in
  ⟨colim.cocone.X, to_sSet_hom (δ e.s) ≫ pushout_cocone.inl colim.cocone⟩

end geom_real_rec

def geom_real_rec {n} (θ : traversal n) : sSet := (geom_real_rec.bundle θ).1

namespace geom_real_rec
variables {n : ℕ}

def geom_real_incl (θ : traversal n) : Δ[n] ⟶ geom_real_rec θ := (geom_real_rec.bundle θ).2

def bundle_colim (e : edge n) (θ : traversal n) :=
  sSet_pushout (to_sSet_hom (δ e.t)) (bundle θ).2

@[simp]
lemma geom_real_rec_nil : geom_real_rec (⟦⟧ : traversal n) = Δ[n] := rfl

@[simp]
lemma geom_real_incl_nil : geom_real_incl (⟦⟧ : traversal n) = 𝟙 Δ[n] := rfl

lemma geom_real_rec_cons (e : edge n) (θ : traversal n) :
  geom_real_rec (e :: θ) = (bundle_colim e θ).cocone.X := rfl

lemma geom_real_incl_cons (e : edge n) (θ : traversal n) :
  geom_real_incl (e :: θ) = to_sSet_hom (δ e.s)
    ≫ pushout_cocone.inl (bundle_colim e θ).cocone := rfl

def j_rec_bundle : Π (θ : traversal n),
  {j : geom_real_rec θ ⟶ Δ[n] // geom_real_incl θ ≫ j = 𝟙 Δ[n]}
| ⟦⟧       := ⟨𝟙 Δ[n], rfl⟩
| (e :: θ) :=
begin
  let j_θ := j_rec_bundle θ,
  refine ⟨(bundle_colim e θ).is_colimit.desc (pushout_cocone.mk (to_sSet_hom (σ e.1)) j_θ.1 _), _⟩,
  change _ = geom_real_incl θ ≫ j_θ.val, rw j_θ.2,
  swap,
  rw [geom_real_incl_cons, category.assoc],
  rw [(bundle_colim e θ).is_colimit.fac _ walking_span.left, pushout_cocone.mk_ι_app_left],
  all_goals
  { dsimp [to_sSet_hom],
    rw [←standard_simplex.map_comp, ←standard_simplex.map_id],
    apply congr_arg,
    cases e with i b, cases b;
    try { exact δ_comp_σ_self };
    try { exact δ_comp_σ_succ }},
end

def j_rec (θ : traversal n) : geom_real_rec θ ⟶ Δ[n] := (j_rec_bundle θ).1

def j_prop (θ : traversal n) : geom_real_incl θ ≫ j_rec θ = 𝟙 Δ[n] := (j_rec_bundle θ).2

def k_rec_bundle : Π (θ θ' : traversal n),
  {k : geom_real_rec θ ⟶ 𝕋₁ // geom_real_incl θ ≫ k = simplex_as_hom (θ', θ)}
| ⟦⟧       θ' := ⟨simplex_as_hom (θ',⟦⟧), rfl⟩
| (e :: θ) θ' :=
begin
  let k_θ := k_rec_bundle θ (θ' ++ ⟦e⟧),
  refine ⟨(bundle_colim e θ).is_colimit.desc (pushout_cocone.mk _ k_θ.1 _), _⟩,
  { apply simplex_as_hom,
    --Special position
    exact (apply_map (σ e.1) θ' ++ ⟦(eˢ, e.2)⟧, (eᵗ, e.2) :: apply_map (σ e.1) θ)},
  change _ = geom_real_incl θ ≫ k_θ.val, rw k_θ.2,
  swap,
  rw [geom_real_incl_cons, category.assoc],
  rw [(bundle_colim e θ).is_colimit.fac _ walking_span.left, pushout_cocone.mk_ι_app_left],
  all_goals
  { rw [hom_comp_simplex_as_hom],
    rw simplex_as_hom_eq_iff,
    cases e with i b, cases b; simp;
    rw [𝕋₀_map_apply, 𝕋₀_map_apply, has_hom.hom.unop_op];
    simp[edge.s, edge.t, apply_map];
    rw [←apply_comp, ←apply_comp];
    try { rw δ_comp_σ_self }; try { rw δ_comp_σ_succ };
    rw [apply_id, apply_id];
    simp },
end

def k_rec' (θ θ' : traversal n) := (k_rec_bundle θ θ').1

def k_prop' (θ θ' : traversal n) :
  geom_real_incl θ ≫ k_rec' θ θ' = simplex_as_hom (θ', θ) := (k_rec_bundle θ θ').2

def k_rec (θ : traversal n) : geom_real_rec θ ⟶ 𝕋₁ := (k_rec_bundle θ ⟦⟧).1

def k_prop (θ : traversal n) :
  geom_real_incl θ ≫ k_rec θ = simplex_as_hom (⟦⟧, θ) := (k_rec_bundle θ ⟦⟧).2

lemma j_comp_θ_eq_k_comp_cod : Π (θ θ' : traversal n),
  j_rec θ ≫ (θ' ++ θ).as_hom = (k_rec_bundle θ θ').1 ≫ cod
| ⟦⟧       θ' :=
  begin
    change simplex_as_hom _ = simplex_as_hom _ ≫ cod,
    rw [simplex_as_hom_comp_hom], refl,
  end
| (e :: θ) θ' :=
begin
  apply pushout_cocone.is_colimit.hom_ext (bundle_colim e θ).is_colimit,
  { change to_sSet_hom (σ e.fst) ≫ simplex_as_hom _ = simplex_as_hom _ ≫ cod,
    rw [simplex_as_hom_comp_hom, hom_comp_simplex_as_hom],
    rw simplex_as_hom_eq_iff,
    dsimp [𝕋₀, apply_map, cod], cases e with i b, cases b; simp,
    all_goals { simp [apply_map], change _ = _ ++ _, rw list.append_assoc, refl,}},
  { change j_rec θ ≫ (θ' ++ (⟦e⟧ ++ θ)).as_hom = (k_rec_bundle θ (θ' ++ ⟦e⟧)).1 ≫ cod,
    rw ←list.append_assoc,
    apply j_comp_θ_eq_k_comp_cod }
end

def pullback_cone_rec' (θ θ' : traversal n) : pullback_cone ((θ' ++ θ).as_hom) cod :=
  pullback_cone.mk (j_rec θ) (k_rec_bundle θ θ').1 (j_comp_θ_eq_k_comp_cod θ θ')

def pullback_cone_rec (θ : traversal n) : pullback_cone (θ.as_hom) cod :=
  pullback_cone.mk (j_rec θ) (k_rec θ) (j_comp_θ_eq_k_comp_cod θ ⟦⟧)

def append_eq_append_split {n} {a b c d : traversal n} :
  a ++ b = c ++ d → {a' // c = a ++ a' ∧ b = a' ++ d} ⊕ {c' // a = c ++ c' ∧ d = c' ++ b} :=
begin
  induction c generalizing a,
  case nil { rw list.nil_append, rintro rfl, right, exact ⟨a, rfl, rfl⟩ },
  case cons : c cs ih {
    intro h, cases a,
    { left, use c :: cs, simpa using h },
    { simp at h, cases h, cases h_left, simp,
      exact ih h_right }}
end

section beta

variables {m : simplex_category} {α : m ⟶ [n]} {e : edge n} {θ₁ θ₂ : traversal m.len} (H : apply_map_to_edge α e = θ₁ ++ θ₂)

def β_conditions (i) (H : apply_map_to_edge α e = θ₁ ++ θ₂) :
  α.to_preorder_hom i < e.1 ∨ α.to_preorder_hom i > e.1 ∨ (i, e.2) ∈ θ₁ ∨ (i, e.2) ∈ θ₂ :=
begin
  cases lt_trichotomy (α.to_preorder_hom i) e.fst, left, exact h,
  cases h, swap, right, left, exact h,
  right, right,
  replace h : (α.to_preorder_hom (i, e.2).1, (i, e.2).2) = e, rw h, cases e, refl,
  rw [←edge_in_apply_map_to_edge_iff, H] at h, simp at h, exact h,
end

def β_fun (H : apply_map_to_edge α e = θ₁ ++ θ₂) : fin (m.len + 1) → fin ([n + 1].len + 1) := λ i,
  if h₁ : α.to_preorder_hom i < e.1 then (α.to_preorder_hom i).cast_succ
  else if h₂ : α.to_preorder_hom i > e.1 then (α.to_preorder_hom i).succ
  else if h₃ : (i, e.2) ∈ θ₁ then eˢ
  else eᵗ

lemma β_eq_es_iff (i) : β_fun H i = (eˢ) ↔ (i, e.2) ∈ θ₁ :=
begin
  simp[β_fun],
  split;
  intro h',
  { by_contra, split_ifs at h',
    rw [←fin.cast_succ_lt_cast_succ_iff, h'] at h_1,
    cases e with j b, cases b,
    exact lt_asymm (fin.cast_succ_lt_succ j) h_1,
    exact lt_irrefl _ h_1,
    rw [←fin.succ_lt_succ_iff, h'] at h_2,
    cases e with j b, cases b,
    exact lt_irrefl _ h_2,
    exact lt_asymm (fin.cast_succ_lt_succ j) h_2,
    cases e with j b, cases b,
    exact ne_of_lt (fin.cast_succ_lt_succ j) h',
    exact ne_of_gt (fin.cast_succ_lt_succ j) h' },
  { have hi : (i, e.2) ∈ apply_map_to_edge α e, rw H, exact list.mem_append_left θ₂ h',
    rw edge_in_apply_map_to_edge_iff at hi,
    cases e with j b, cases b;
    simp at hi h'; simp[hi, h'] }
end

lemma β_eq_et_iff (i) : β_fun H i = (eᵗ) ↔ (i, e.2) ∈ θ₂ :=
begin
  simp[β_fun],
  have hf: e.s = e.t ↔ false,
  { split; intro hf, cases e with j b, cases b,
    exact ne_of_lt (fin.cast_succ_lt_succ j) hf.symm,
    exact ne_of_lt (fin.cast_succ_lt_succ j) hf,
    exfalso, exact hf },
  split; intro h',
  { by_contra, split_ifs at h',
    rw [←fin.cast_succ_lt_cast_succ_iff, h'] at h_1,
    cases e with j b, cases b,
    exact lt_irrefl _ h_1,
    exact lt_asymm (fin.cast_succ_lt_succ j) h_1,
    rw [←fin.succ_lt_succ_iff, h'] at h_2,
    cases e with j b, cases b,
    exact lt_asymm (fin.cast_succ_lt_succ j) h_2,
    exact lt_irrefl _ h_2,
    cases e with j b, cases b,
    exact ne_of_gt (fin.cast_succ_lt_succ j) h',
    exact ne_of_lt (fin.cast_succ_lt_succ j) h',
    cases β_conditions i H, exact h_1 h_4,
    cases h_4, exact h_2 h_4,
    cases h_4, exact h_3 h_4,
    exact h h_4 },
  { have hi : (α.to_preorder_hom (i, e.2).1, (i, e.2).2) = e,
    { rw [←edge_in_apply_map_to_edge_iff, H], exact list.mem_append_right θ₁ h',  },
    cases e; simp at hi ⊢ h', simp [hi],
    have H' : sorted (θ₁ ++ θ₂), rw ←H, apply apply_map_to_edge_sorted,
    rw ←append_sorted_iff at H',
    intro hi', exfalso, have h'' := (H'.2.2 _ hi' _ h'),
    exact edge.lt_asymm _ _ h'' h'', }
end

lemma β_monotone : monotone (β_fun H) := λ i j hij,
begin
  simp [β_fun], split_ifs; try { apply le_refl },
  { exact α.to_preorder_hom.monotone hij },
  { apply le_of_lt, rw ←fin.le_cast_succ_iff, exact α.to_preorder_hom.monotone hij },
  { rw ←fin.cast_succ_lt_cast_succ_iff at h, cases e with j b, cases b,
    exact le_trans (le_of_lt h) (le_of_lt (fin.cast_succ_lt_succ _)),
    exact le_of_lt h },
  { rw ←fin.cast_succ_lt_cast_succ_iff at h, cases e with j b, cases b,
    exact le_of_lt h,
    exact le_trans (le_of_lt h) (le_of_lt (fin.cast_succ_lt_succ _)) },
  { refine absurd (α.to_preorder_hom.monotone hij) (not_le.mpr _),
    exact lt_of_lt_of_le h_2 (not_lt.mp h) },
  { simp, exact α.to_preorder_hom.monotone hij },
  { refine absurd (α.to_preorder_hom.monotone hij) (not_le.mpr _),
    exact lt_of_le_of_lt (not_lt.mp h_3) h_1 },
  { refine absurd (α.to_preorder_hom.monotone hij) (not_le.mpr _),
    exact lt_of_le_of_lt (not_lt.mp h_3) h_1 },
  all_goals { have hi := le_antisymm (not_lt.mp h) (not_lt.mp h_1) },
  { refine absurd (α.to_preorder_hom.monotone hij) (not_le.mpr _),
    rwa hi at h_3 },
  { cases e with k b, cases b; simp [edge.s, edge.t],
    exact le_of_lt h_4,
    apply le_of_lt, rw[←fin.le_cast_succ_iff], simp, exact le_of_lt h_4 },
  swap 3, swap 3,
  { refine absurd (α.to_preorder_hom.monotone hij) (not_le.mpr _),
    rwa hi at h_3 },
  { cases e with k b, cases b; simp [edge.s, edge.t],
    apply le_of_lt, rw[←fin.le_cast_succ_iff], simp, exact le_of_lt h_4,
    exact le_of_lt h_4 },
  all_goals
  { cases e with k b, cases b; dsimp[edge.s, edge.t];
    try { exact le_of_lt (fin.cast_succ_lt_succ k) },
    exfalso, have hj := le_antisymm (not_lt.mp h_4) (not_lt.mp h_3),
    have H' : sorted (θ₁ ++ θ₂), rw ←H, apply apply_map_to_edge_sorted,
    rw ←append_sorted_iff at H', },
  { have hj' : (α.to_preorder_hom (j, ∔).1, (j, ∔).2) = (k, ∔), simp, exact hj,
    rw [←edge_in_apply_map_to_edge_iff, H] at hj',
    simp [h_5] at hj' h_2,
    refine absurd hij (not_le.mpr _),
    exact H'.2.2 _ h_2 _ hj', },
  { have hi' : (α.to_preorder_hom (i, ∸).1, (i, ∸).2) = (k, ∸), simp, exact hi.symm,
    rw [←edge_in_apply_map_to_edge_iff, H] at hi',
    simp [h_2] at hi' h_5,
    refine absurd hij (not_le.mpr _),
    exact H'.2.2 _ h_5 _ hi', },
end

def β (H : apply_map_to_edge α e = θ₁ ++ θ₂) : m ⟶ [n+1] := hom.mk
{ to_fun    := β_fun H,
  monotone' := β_monotone H, }

lemma β_comp_σ : β H ≫ σ e.1 = α :=
begin
  ext1, ext1 i, simp [β, β_fun], split_ifs;
  simp [σ, fin.pred_above]; split_ifs; try { refl };
  try { push_neg at * },
  { exfalso, exact lt_asymm h h_1 },
  { exfalso, rw ←fin.le_cast_succ_iff at h_2, simp at h_2, exact h h_2 },
  { push_neg at h h_1, rw le_antisymm h_1 h, cases e with j b, cases b;
    simp[edge.s, edge.t] at h_3 ⊢,
    exfalso, exact h_3 },
  { push_neg at h h_1 h_3, rw le_antisymm h_1 h, cases e with j b, cases b;
    simp[edge.s, edge.t] at h_3 ⊢,
    exact absurd (fin.cast_succ_lt_succ j) (not_lt.mpr h_3) },
  { push_neg at h h_1, rw le_antisymm h_1 h, cases e with j b, cases b;
    simp[edge.s, edge.t] at h_3 ⊢,
    exfalso, exact h_3 },
  { push_neg at h h_1 h_3, rw le_antisymm h_1 h, cases e with j b, cases b;
    simp[edge.s, edge.t] at h_3 ⊢,
    exact absurd (fin.cast_succ_lt_succ j) (not_lt.mpr h_3) },
end

end beta

def geom_real_rec_lift' : Π (θ θ' : traversal n) {m} (α : m ⟶ [n]) (θ₁ θ₂ : traversal m.len) (hθ : θ₁ ++ θ₂ = apply_map α θ),
  (geom_real_rec θ).obj (opposite.op m)
| ⟦⟧       θ' m α θ₁ θ₂ hθ := α
| (e :: θ) θ' m α θ₁ θ₂ hθ :=
  begin
    cases append_eq_append_split hθ with a' c',
    { rcases a' with ⟨θ₂', hθ₂', hθ₂⟩,
      let p : pushout_cocone _ _ := (bundle_colim e θ).cocone,
      apply p.inl.app (opposite.op m),
      exact β hθ₂',
    },
    { cases c' with c' hc',
      let p : pushout_cocone _ _ := (bundle_colim e θ).cocone,
      exact p.inr.app (opposite.op m) (geom_real_rec_lift' θ (θ' ++ ⟦e⟧) α c' θ₂ hc'.2.symm) },
  end

lemma geom_real_rec_fac_j' : Π (θ θ' : traversal n) {m} (α : m ⟶ [n]) (θ₁ θ₂ : traversal m.len) (hθ : θ₁ ++ θ₂ = apply_map α θ),
  (j_rec θ).app (opposite.op m) (geom_real_rec_lift' θ θ' α θ₁ θ₂ hθ) = α
| ⟦⟧       θ' m α θ₁ θ₂ hθ := rfl
| (e :: θ) θ' m α θ₁ θ₂ hθ :=
  begin
    simp [geom_real_rec_lift'],
    cases append_eq_append_split hθ with a' c',
    { rcases a' with ⟨θ₂', H, hθ₂⟩,
      cases e with i b, simp,
      exact β_comp_σ H },
    { cases c' with c' hc',
      exact geom_real_rec_fac_j' θ (θ' ++ ⟦e⟧) α c' θ₂ _ }
  end

lemma geom_real_rec_fac_k' : Π (θ θ' : traversal n) {m} (α : m ⟶ [n]) (θ₁ θ₂ : traversal m.len) (hθ : θ₁ ++ θ₂ = apply_map α θ),
  (k_rec_bundle θ θ').1.app (opposite.op m) (geom_real_rec_lift' θ θ' α θ₁ θ₂ hθ) = ((apply_map α θ') ++ θ₁, θ₂)
| ⟦⟧       θ' m α θ₁ θ₂ hθ :=
  begin
    simp [apply_map] at hθ, cases hθ.1, cases hθ.2,
    simp[geom_real_rec_lift'], refl
  end
| (e :: θ) θ' m α θ₁ θ₂ hθ :=
  begin
    simp [geom_real_rec_lift'],
    cases append_eq_append_split hθ with a' c',
    { rcases a' with ⟨θ₂', H, hθ₂⟩,
      change (simplex_as_hom _).app (opposite.op m) (β H) = _,
      simp [simplex_as_hom],
      change apply_map _ _  = _ ∧ apply_map _ _  = _ ,
      rw [apply_map_append],
      simp [apply_map],
      rw [←apply_comp, ←apply_comp, β_comp_σ H],
      cases hθ₂,
      change _ ∧ _ = θ₂' ++ _,
      rw [list.append_left_inj],
      rw [list.append_right_inj],
      have h₁ : sorted (θ₁ ++ θ₂'), rw ←H, apply apply_map_to_edge_sorted,
      have h₂ := h₁, rw ←append_sorted_iff at h₂,
      split;
      refine eq_of_sorted_of_same_elem _ _ (apply_map_to_edge_sorted _ _) (by simp[h₂.1, h₂.2]) _;
      intro e'; rw edge_in_apply_map_to_edge_iff; simp; split; simp [β];
      try {rw β_eq_es_iff H}; try {rw β_eq_et_iff H}; intro h,
      { intro h', rw ←h' at h, simpa using h },
      { have he' : e' ∈ apply_map_to_edge α e, rw H, exact list.mem_append_left θ₂' h,
        rw edge_in_apply_map_to_edge_iff at he', cases e, cases e', simp at he' ⊢,
        cases he'.2, simp, exact h },
      { intro h', rw ←h' at h, simpa using h },
      { have he' : e' ∈ apply_map_to_edge α e, rw H, exact list.mem_append_right θ₁ h,
        rw edge_in_apply_map_to_edge_iff at he', cases e, cases e', simp at he' ⊢,
        cases he'.2, simp, exact h }},
    { cases c' with c' hc', simp,
      dsimp [k_rec, k_rec_bundle],
      change (k_rec_bundle θ (θ' ++ ⟦e⟧)).1.app (opposite.op m) (geom_real_rec_lift' θ (θ' ++ ⟦e⟧) α c' θ₂ _) = _,
      cases hc'.1,
      specialize geom_real_rec_fac_k' θ (θ' ++ ⟦e⟧) α c' θ₂ hc'.2.symm,
      rw [geom_real_rec_fac_k', apply_map_append], simp [apply_map], refl, }
  end

def geom_real_rec_lift (θ : traversal n) {m} : Π (α : m ⟶ [n]) (θ₁ θ₂ : traversal m.len) (hθ : θ₁ ++ θ₂ = apply_map α θ),
  (geom_real_rec θ).obj (opposite.op m) := geom_real_rec_lift' θ ⟦⟧

lemma geom_real_rec_fac_j (θ : traversal n) {m} : Π (α : m ⟶ [n]) (θ₁ θ₂ : traversal m.len) (hθ : θ₁ ++ θ₂ = apply_map α θ),
  (j_rec θ).app (opposite.op m) (geom_real_rec_lift θ α θ₁ θ₂ hθ) = α := geom_real_rec_fac_j' θ ⟦⟧

lemma geom_real_rec_fac_k (θ : traversal n) {m} : Π (α : m ⟶ [n]) (θ₁ θ₂ : traversal m.len) (hθ : θ₁ ++ θ₂ = apply_map α θ),
  (k_rec θ).app (opposite.op m) (geom_real_rec_lift θ α θ₁ θ₂ hθ) = (θ₁, θ₂) := geom_real_rec_fac_k' θ ⟦⟧

lemma geom_real_rec_unique : Π (θ : traversal n) {m} (α : m ⟶ [n]) (θ₁ θ₂ : traversal m.len) (hθ : θ₁ ++ θ₂ = apply_map α θ)
  (x : (geom_real_rec θ).obj (opposite.op m)),
  (j_rec θ).app (opposite.op m) x = α →
  (k_rec θ).app (opposite.op m) x = (θ₁, θ₂) →
  x = geom_real_rec_lift θ α θ₁ θ₂ hθ
| ⟦⟧ m α θ₁ θ₂ hθ x hx₁ hx₂ := by dsimp [geom_real_rec_lift]; rw ←hx₁; refl
| (e :: θ) m α ⟦⟧         θ₂ hθ x hx₁ hx₂ := sorry
| (e :: θ) m α (e₁ :: θ₁) θ₂ hθ x hx₁ hx₂ := sorry

theorem geom_real_is_pullback_θ_cod (θ : traversal n) : is_limit (pullback_cone_rec θ) :=
begin
  apply evaluation_jointly_reflects_limits,
  intro m, exact
  { lift := λ c,
    begin
      let c_fst : c.X ⟶ Δ[n].obj m := c.π.app walking_cospan.left,
      let c_snd : c.X ⟶ 𝕋₁.obj m   := c.π.app walking_cospan.right,
      have hθ : c_fst ≫ (as_hom θ).app m = c_snd ≫ cod.app m,
      { change c_fst ≫ (cospan θ.as_hom cod ⋙ (evaluation simplex_categoryᵒᵖ Type).obj m).map walking_cospan.hom.inl
          = c_snd ≫ (cospan θ.as_hom cod ⋙ (evaluation simplex_categoryᵒᵖ Type).obj m).map walking_cospan.hom.inr,
        rw [←c.π.naturality, ←c.π.naturality], refl },
      exact λ x, geom_real_rec_lift θ (c_fst x) _ _ (congr_fun hθ x).symm,
    end,
    fac' := λ c,
    begin
      intro j, cases j;
      let c_fst : c.X ⟶ Δ[n].obj m := c.π.app walking_cospan.left;
      let c_snd : c.X ⟶ pointed_traversal m.unop.len := c.π.app walking_cospan.right,

      { let p := pullback_cone_rec θ,
        let const_c := (category_theory.functor.const walking_cospan).obj c.X,
        let const_c_inl := const_c.map walking_cospan.hom.inl,
        let const_p := (category_theory.functor.const walking_cospan).obj p.X,
        let const_p_inl := const_p.map walking_cospan.hom.inl,
        let eval_cospan := cospan θ.as_hom cod ⋙ (evaluation simplex_categoryᵒᵖ Type).obj m,
        change _ = const_c_inl ≫ c.π.app none,
        have H : const_c_inl ≫ c.π.app none = _, apply c.π.naturality',
        refine trans _ H.symm, clear H,
        suffices H : ((pullback_cone_rec θ).π.app none).app m
          = ((pullback_cone_rec θ).π.app walking_cospan.left).app m
          ≫ eval_cospan.map walking_cospan.hom.inl,
        { simp, rw H, ext1 x,
          let α : m.unop ⟶ [n] := c_fst x,
          simp, apply congr_arg,
          exact geom_real_rec_fac_j θ α _ _ _ },
        change (const_p_inl ≫ (pullback_cone_rec θ).π.app none).app m = _,
        rw p.π.naturality', refl },
      ext1 x, let α : m.unop ⟶ [n] := c_fst x,
      cases j, simp,
      { exact geom_real_rec_fac_j θ α _ _ _ },
      { change (k_rec θ).app (opposite.op m.unop) (geom_real_rec_lift θ α (c_snd x).1 (c_snd x).2 _) = c_snd x,
        rw [geom_real_rec_fac_k θ α (c_snd x).1 (c_snd x).2 _], simp }
    end,
    uniq' := λ c,
    begin
      intros lift' hlift',
      change c.X ⟶ (geom_real_rec θ).obj (opposite.op m.unop) at lift',
      ext1 x, simp,
      apply geom_real_rec_unique θ,
      specialize hlift' walking_cospan.left, simp at hlift',
      rw ←hlift', refl,
      specialize hlift' walking_cospan.right, simp at hlift',
      rw ←hlift',
      simp, refl,
    end }
end

end geom_real_rec

end traversal


import Monads.Applicative

namespace Monads
  /- The monad is a close relativ to the applicative, however unlike
     an applicative functor it is in fact able to change the structure
     of the context the value is wrapped in since it allows users to
     pass a function that produces a new structure: (α → m β) -/
  class Monad (m : Type u → Type v) extends Applicative m where
    -- return is a keyword so don't use it
    /- Basically equivalent to pure from applicative. -/
    ret : α → m α
    bind : m α → (α → m β) → m β
    /- Drop the action on the left and only return the right one. If
       left contains e.g. a sideffect it will still be executed. -/
    and_then {α β : Type u} : m α → m β → m β := λ a1 a2 => bind a1 (Function.const α a2)

  export Monad (ret)

  infixl:65 " >>= " => Monads.Monad.bind
  infixl:60 " >> " => Monads.Monad.and_then

  /- Establishes some well behavedeness for ret and bind as well as a relation
     to apply and pure from applicative. -/
  class LawfulMonad (m : Type u → Type v) [mon: Monad m] extends LawfulApplicative m : Prop where
    /- Binding a pure value to a function should be the same as applying the function
       to the value directly -/
    ret_left_id : ∀ (a : α) (h : α → m β), ret a >>= h = h a
    /- Binding a monadic value to ret should be a no op -/
    ret_right_id : ∀ (a : m α), a >>= ret = a
    /- A modified associativity law for bind -/
    bind_assoc : ∀ (a : m α) (g : α → m β) (h : β → m γ), (a >>= g) >>= h = a >>= (λ x => g x >>= h)
    /- Pure and return should behave equivalently -/
    pure_behaved : ∀ (a : α), pure a = mon.ret a
    /- Apply and bind are related in this way as shown below -/
    apply_behaved : ∀ {α β : Type u} (mf : m (α → β)) (ma : m α), mf <*> ma = mf >>= (λ f => ma >>= (λ a => ret $ f a))
    /- and_then and seq_right are the same.-/
    and_then_behaved: ∀ (a1 : m α) (a2 : m β), a1 *> a2 = a1 >> a2

  namespace LawfulMonad
    variable {m : Type u → Type v} [monad : Monad m] [LawfulMonad m]
    -- Constructing a lawful applicative from a lawful monad
    -- pure is just return so don't define it explicitly
    def bind_apply {α β : Type u} :  m (α → β) → m α → m β
    | mf, ma => mf >>= (λ f => ma >>= (λ a => ret $ f a))

    -- law 1
    example : ∀ x : m α, bind_apply (ret id) x = x := by
      intro x
      simp only [bind_apply]
      rw [ret_left_id]
      simp only [id]
      rw [ret_right_id]

    -- law 2
    example : ∀ (x : α) (g : α → β), bind_apply (ret g) (ret x) = monad.ret (g x) := by
      intro x g
      simp only [bind_apply]
      rw [ret_left_id]
      rw [ret_left_id]

    -- law 3
    example : ∀ {α β : Type u} (x : α) (g : m (α → β)), bind_apply g (ret x) = bind_apply (ret (· $ x)) g := by
      intro α β x g
      simp only [bind_apply]
      simp only [ret_left_id]

    -- law 4 (a very automated proof since its just a definition massacre)
    example : ∀ {α β γ: Type u} (x : m (β → γ)) (y : m (α → β)) (z : m α), bind_apply (bind_apply (bind_apply (ret (@Function.comp α β γ)) x) y) z = bind_apply x (bind_apply y z) := by
      intro α β γ x y z
      simp only [bind_apply]
      simp only [ret_left_id, bind_assoc]
  end LawfulMonad
end Monads


/-
Copyright (c) 2022 Siddhartha Gadgil. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Siddhartha Gadgil, Mario Carneiro
-/
import Mathlib.Lean.Meta
import Lean.Elab.Tactic.Location

/-!
# `trans` tactic

This implements the `trans` tactic, which can apply transitivity theorems with an optional middle
variable argument.
-/

namespace Mathlib.Tactic
open Lean Meta Elab

initialize registerTraceClass `Tactic.trans

/-- Environment extension storing transitivity lemmas -/
initialize transExt :
    SimpleScopedEnvExtension (Name × Array (DiscrTree.Key true)) (DiscrTree Name true) ←
  registerSimpleScopedEnvExtension {
    addEntry := fun dt (n, ks) ↦ dt.insertCore ks n
    initial := {}
  }

initialize registerBuiltinAttribute {
  name := `trans
  descr := "transitive relation"
  add := fun decl _ kind ↦ MetaM.run' do
    let declTy := (← getConstInfo decl).type
    let (xs, _, targetTy) ← withReducible <| forallMetaTelescopeReducing declTy
    let fail := throwError
      "@[trans] attribute only applies to lemmas proving
      x ∼ y → y ∼ z → x ∼ z, got {indentExpr declTy} with target {indentExpr targetTy}"
    let .app (.app rel _) _ := targetTy | fail
    let some yzHyp := xs.back? | fail
    let some xyHyp := xs.pop.back? | fail
    let .app (.app _ _) _ ← inferType yzHyp | fail
    let .app (.app _ _) _ ← inferType xyHyp | fail
    let key ← withReducible <| DiscrTree.mkPath rel
    transExt.add (decl, key) kind
}

/-- Composition using the `Trans` class in the homogeneous case. -/
def _root_.Trans.simple {a b c : α} [Trans r r r] : r a b → r b c → r a c := trans

/-- Composition using the `Trans` class in the general case. -/
def _root_.Trans.het {a : α} {b : β} {c : γ}
  {r : α → β → Sort u} {s : β → γ → Sort v} {t : outParam (α → γ → Sort w)}
  [Trans r s t] : r a b → s b c → t a c := trans

open Lean.Elab.Tactic

/-- solving `e ← mkAppM' f #[x]` -/
def getExplicitFuncArg? (e : Expr) : MetaM (Option <| Expr × Expr) := do
  match e with
  | Expr.app f a => do
    if ← isDefEq (← mkAppM' f #[a]) e then
      return some (f, a)
    else
      getExplicitFuncArg? f
  | _ => return none

/-- solving `tgt ← mkAppM' rel #[x, z]` given `tgt = f z` -/
def getExplicitRelArg? (tgt f z : Expr) : MetaM (Option <| Expr × Expr) := do
  match f  with
  | Expr.app rel x => do
    let check: Bool ← do
      try
        let folded ← mkAppM' rel #[x, z]
        isDefEq folded tgt
      catch _ =>
        pure false
    if check then
      return some (rel, x)
    else
      getExplicitRelArg? tgt rel z
  | _ => return none

/-- refining `tgt ← mkAppM' rel #[x, z]` dropping more arguments if possible -/
def getExplicitRelArgCore (tgt rel x z : Expr) : MetaM (Expr × Expr) := do
  match rel with
  | Expr.app rel' _ => do
    let check: Bool ← do
      try
        let folded ← mkAppM' rel' #[x, z]
        isDefEq folded tgt
      catch _ =>
        pure false
    if !check then
      return (rel, x)
    else
      getExplicitRelArgCore tgt rel' x z
  | _ => return (rel ,x)

/--
`trans` applies to a goal whose target has the form `t ~ u` where `~` is a transitive relation,
that is, a relation which has a transitivity lemma tagged with the attribute [trans].

* `trans s` replaces the goal with the two subgoals `t ~ s` and `s ~ u`.
* If `s` is omitted, then a metavariable is used instead.
-/
elab "trans" t?:(ppSpace (colGt term))? : tactic => withMainContext do
  let tgt ← getMainTarget
  let (rel, x, z) ←
    match tgt with
    | Expr.app f z =>
      match (← getExplicitRelArg? tgt f z) with
      | some (rel, x) =>
        let (rel, x) ← getExplicitRelArgCore tgt rel x z
        pure (rel, x, z)
      | none => throwError "transitivity lemmas only apply to
        binary relations, not {indentExpr tgt}"
    | _ => throwError "transitivity lemmas only apply to binary relations, not {indentExpr tgt}"
  trace[Tactic.trans]"goal decomposed"
  trace[Tactic.trans]"rel: {indentExpr rel}"
  trace[Tactic.trans]"x: {indentExpr x}"
  trace[Tactic.trans]"z: {indentExpr z}"
  -- first trying the homogeneous case
  try
    let ty ← inferType x
    let t'? ← t?.mapM (elabTermWithHoles · ty (← getMainTag))
    let s ← saveState
    trace[Tactic.trans]"trying homogeneous case"
    for lem in (← (transExt.getState (← getEnv)).getUnify rel).push ``Trans.simple do
      trace[Tactic.trans]"trying lemma {lem}"
      try
        liftMetaTactic fun g ↦ do
          let lemTy ← inferType (← mkConstWithLevelParams lem)
          let arity ← withReducible <| forallTelescopeReducing lemTy fun es _ ↦ pure es.size
          let y ← (t'?.map (pure ·.1)).getD (mkFreshExprMVar ty)
          let g₁ ← mkFreshExprMVar (some <| ← mkAppM' rel #[x, y]) .synthetic
          let g₂ ← mkFreshExprMVar (some <| ← mkAppM' rel #[y, z]) .synthetic
          g.assign (← mkAppOptM lem (mkArray (arity - 2) none ++ #[some g₁, some g₂]))
          pure <| [g₁.mvarId!, g₂.mvarId!] ++ if let some (_, gs') := t'? then gs' else [y.mvarId!]
        return
      catch _ => s.restore
    pure ()
  catch _ =>
  trace[Tactic.trans]"trying heterogeneous case"
  let t'? ← t?.mapM (elabTermWithHoles · none (← getMainTag))
  let s ← saveState
  for lem in (← (transExt.getState (← getEnv)).getUnify rel).push
      ``HEq.trans |>.push ``HEq.trans  do
    try
      liftMetaTactic fun g ↦ do
        trace[Tactic.trans]"trying lemma {lem}"
        let lemTy ← inferType (← mkConstWithLevelParams lem)
        let arity ← withReducible <| forallTelescopeReducing lemTy fun es _ ↦ pure es.size
        trace[Tactic.trans]"arity: {arity}"
        trace[Tactic.trans]"lemma-type: {lemTy}"
        let y ← (t'?.map (pure ·.1)).getD (mkFreshExprMVar none)
        trace[Tactic.trans]"obtained y: {y}"
        trace[Tactic.trans]"rel: {indentExpr rel}"
        trace[Tactic.trans]"x:{indentExpr x}"
        trace[Tactic.trans]"z:  {indentExpr z}"
        let g₂ ← mkFreshExprMVar (some <| ← mkAppM' rel #[y, z]) .synthetic
        trace[Tactic.trans]"obtained g₂: {g₂}"
        let g₁ ← mkFreshExprMVar (some <| ← mkAppM' rel #[x, y]) .synthetic
        trace[Tactic.trans]"obtained g₁: {g₁}"
        g.assign (← mkAppOptM lem (mkArray (arity - 2) none ++ #[some g₁, some g₂]))
        pure <| [g₁.mvarId!, g₂.mvarId!] ++ if let some (_, gs') := t'? then gs' else [y.mvarId!]
      return
    catch e =>
      trace[Tactic.trans]"failed: {e.toMessageData}"
      s.restore

  throwError m!"no applicable transitivity lemma found for {indentExpr tgt}
"


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

universes u₁ v₁ w₀ w₁ w₂

namespace Mathlib

/-!
# Categories of indexed families of objects.

We define the pointwise category structure on indexed families of objects in a category
(and also the dependent generalization).

-/

namespace category_theory

/--
`pi C` gives the cartesian product of an indexed family of categories.
-/
protected instance pi {I : Type w₀} (C : I → Type u₁) [(i : I) → category (C i)] : category ((i : I) → C i) :=
  category.mk

/--
This provides some assistance to typeclass search in a common situation,
which otherwise fails. (Without this `category_theory.pi.has_limit_of_has_limit_comp_eval` fails.)
-/
instance pi' {I : Type v₁} (C : I → Type u₁) [(i : I) → category (C i)] : category ((i : I) → C i) :=
  category_theory.pi C

namespace pi

@[simp] theorem id_apply {I : Type w₀} (C : I → Type u₁) [(i : I) → category (C i)] (X : (i : I) → C i) (i : I) : 𝟙 = 𝟙 :=
  rfl

@[simp] theorem comp_apply {I : Type w₀} (C : I → Type u₁) [(i : I) → category (C i)] {X : (i : I) → C i} {Y : (i : I) → C i} {Z : (i : I) → C i} (f : X ⟶ Y) (g : Y ⟶ Z) (i : I) : category_struct.comp f g i = f i ≫ g i :=
  rfl

/--
The evaluation functor at `i : I`, sending an `I`-indexed family of objects to the object over `i`.
-/
@[simp] theorem eval_map {I : Type w₀} (C : I → Type u₁) [(i : I) → category (C i)] (i : I) (f : (i : I) → C i) (g : (i : I) → C i) (α : f ⟶ g) : functor.map (eval C i) α = α i :=
  Eq.refl (functor.map (eval C i) α)

/--
Pull back an `I`-indexed family of objects to an `J`-indexed family, along a function `J → I`.
-/
@[simp] theorem comap_map {I : Type w₀} (C : I → Type u₁) [(i : I) → category (C i)] {J : Type w₁} (h : J → I) (f : (i : I) → C i) (g : (i : I) → C i) (α : f ⟶ g) (i : J) : functor.map (comap C h) α i = α (h i) :=
  Eq.refl (functor.map (comap C h) α i)

/--
The natural isomorphism between
pulling back a grading along the identity function,
and the identity functor. -/
def comap_id (I : Type w₀) (C : I → Type u₁) [(i : I) → category (C i)] : comap C id ≅ 𝟭 :=
  iso.mk (nat_trans.mk fun (X : (i : I) → C i) => 𝟙) (nat_trans.mk fun (X : (i : I) → C i) => 𝟙)

/--
The natural isomorphism comparing between
pulling back along two successive functions, and
pulling back along their composition
-/
def comap_comp {I : Type w₀} (C : I → Type u₁) [(i : I) → category (C i)] {J : Type w₁} {K : Type w₂} (f : K → J) (g : J → I) : comap C g ⋙ comap (C ∘ g) f ≅ comap C (g ∘ f) :=
  iso.mk (nat_trans.mk fun (X : (i : I) → C i) (b : K) => 𝟙) (nat_trans.mk fun (X : (i : I) → C i) (b : K) => 𝟙)

/-- The natural isomorphism between pulling back then evaluating, and just evaluating. -/
def comap_eval_iso_eval {I : Type w₀} (C : I → Type u₁) [(i : I) → category (C i)] {J : Type w₁} (h : J → I) (j : J) : comap C h ⋙ eval (C ∘ h) j ≅ eval C (h j) :=
  nat_iso.of_components (fun (f : (i : I) → C i) => iso.refl (functor.obj (comap C h ⋙ eval (C ∘ h) j) f)) sorry

protected instance sum_elim_category {I : Type w₀} (C : I → Type u₁) [(i : I) → category (C i)] {J : Type w₀} {D : J → Type u₁} [(j : J) → category (D j)] (s : I ⊕ J) : category (sum.elim C D s) :=
  sorry

/--
The bifunctor combining an `I`-indexed family of objects with a `J`-indexed family of objects
to obtain an `I ⊕ J`-indexed family of objects.
-/
@[simp] theorem sum_obj_obj {I : Type w₀} (C : I → Type u₁) [(i : I) → category (C i)] {J : Type w₀} {D : J → Type u₁} [(j : J) → category (D j)] (f : (i : I) → C i) (g : (j : J) → D j) (s : I ⊕ J) : functor.obj (functor.obj (sum C) f) g s = sum.rec f g s :=
  Eq.refl (functor.obj (functor.obj (sum C) f) g s)

end pi

namespace functor

/--
Assemble an `I`-indexed family of functors into a functor between the pi types.
-/
def pi {I : Type w₀} {C : I → Type u₁} [(i : I) → category (C i)] {D : I → Type u₁} [(i : I) → category (D i)] (F : (i : I) → C i ⥤ D i) : ((i : I) → C i) ⥤ ((i : I) → D i) :=
  mk (fun (f : (i : I) → C i) (i : I) => obj (F i) (f i)) fun (f g : (i : I) → C i) (α : f ⟶ g) (i : I) => map (F i) (α i)

-- One could add some natural isomorphisms showing

-- how `functor.pi` commutes with `pi.eval` and `pi.comap`.

end functor

namespace nat_trans

/--
Assemble an `I`-indexed family of natural transformations into a single natural transformation.
-/
def pi {I : Type w₀} {C : I → Type u₁} [(i : I) → category (C i)] {D : I → Type u₁} [(i : I) → category (D i)] {F : (i : I) → C i ⥤ D i} {G : (i : I) → C i ⥤ D i} (α : (i : I) → F i ⟶ G i) : functor.pi F ⟶ functor.pi G :=
  mk fun (f : (i : I) → C i) (i : I) => app (α i) (f i)


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.isomorphism_classes
import Mathlib.category_theory.thin
import Mathlib.PostPort

universes v₁ u₁ v₂ u₂ l u₃ v₃

namespace Mathlib

/-!
# Skeleton of a category

Define skeletal categories as categories in which any two isomorphic objects are equal.

Construct the skeleton of a thin category as a partial ordering, and (noncomputably) show it is
a skeleton of the original category. The advantage of this special case being handled separately
is that lemmas and definitions about orderings can be used directly, for example for the subobject
lattice (TODO). In addition, some of the commutative diagrams about the functors commute
definitionally on the nose which is convenient in practice.

(TODO): Construct the skeleton of a general category using choice, and show it is a skeleton.
-/

namespace category_theory

/-- A category is skeletal if isomorphic objects are equal. -/
def skeletal (C : Type u₁) [category C] :=
  ∀ {X Y : C}, is_isomorphic X Y → X = Y

/--
`is_skeleton_of C D F` says that `F : D ⥤ C` exhibits `D` as a skeletal full subcategory of `C`,
in particular `F` is a (strong) equivalence and `D` is skeletal.
-/
structure is_skeleton_of (C : Type u₁) [category C] (D : Type u₂) [category D] (F : D ⥤ C)
where
  skel : skeletal D
  eqv : is_equivalence F

/-- If `C` is thin and skeletal, then any naturally isomorphic functors to `C` are equal. -/
theorem functor.eq_of_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {F₁ : D ⥤ C} {F₂ : D ⥤ C} [∀ (X Y : C), subsingleton (X ⟶ Y)] (hC : skeletal C) (hF : F₁ ≅ F₂) : F₁ = F₂ := sorry

/--
If `C` is thin and skeletal, `D ⥤ C` is skeletal.
`category_theory.functor_thin` shows it is thin also.
-/
theorem functor_skeletal {C : Type u₁} [category C] {D : Type u₂} [category D] [∀ (X Y : C), subsingleton (X ⟶ Y)] (hC : skeletal C) : skeletal (D ⥤ C) :=
  fun (F₁ F₂ : D ⥤ C) (h : is_isomorphic F₁ F₂) => nonempty.elim h (functor.eq_of_iso hC)

/--
Construct the skeleton category by taking the quotient of objects. This construction gives a
preorder with nice definitional properties, but is only really appropriate for thin categories.
-/
def thin_skeleton (C : Type u₁) [category C] :=
  quotient (is_isomorphic_setoid C)

protected instance inhabited_thin_skeleton (C : Type u₁) [category C] [Inhabited C] : Inhabited (thin_skeleton C) :=
  { default := quotient.mk Inhabited.default }

protected instance thin_skeleton.preorder (C : Type u₁) [category C] : preorder (thin_skeleton C) :=
  preorder.mk (quotient.lift₂ (fun (X Y : C) => Nonempty (X ⟶ Y)) sorry)
    (fun (a b : thin_skeleton C) =>
      quotient.lift₂ (fun (X Y : C) => Nonempty (X ⟶ Y)) sorry a b ∧
        ¬quotient.lift₂ (fun (X Y : C) => Nonempty (X ⟶ Y)) sorry b a)
    sorry sorry

/-- The functor from a category to its thin skeleton. -/
@[simp] theorem to_thin_skeleton_obj (C : Type u₁) [category C] (a : C) : functor.obj (to_thin_skeleton C) a = quotient.mk a :=
  Eq.refl (functor.obj (to_thin_skeleton C) a)

/-!
The constructions here are intended to be used when the category `C` is thin, even though
some of the statements can be shown without this assumption.
-/

namespace thin_skeleton

/-- The thin skeleton is thin. -/
protected instance thin (C : Type u₁) [category C] {X : thin_skeleton C} {Y : thin_skeleton C} : subsingleton (X ⟶ Y) :=
  subsingleton.intro
    fun (a b : X ⟶ Y) =>
      ulift.cases_on a
        fun (a : plift (X ≤ Y)) =>
          plift.cases_on a
            fun (f₁ : X ≤ Y) =>
              ulift.cases_on b
                fun (b : plift (X ≤ Y)) => plift.cases_on b fun (f₂ : X ≤ Y) => Eq.refl (ulift.up (plift.up f₁))

/-- A functor `C ⥤ D` computably lowers to a functor `thin_skeleton C ⥤ thin_skeleton D`. -/
def map {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) : thin_skeleton C ⥤ thin_skeleton D :=
  functor.mk (quotient.map (functor.obj F) sorry)
    fun (X Y : thin_skeleton C) =>
      quotient.rec_on_subsingleton₂ X Y fun (x y : C) (k : quotient.mk x ⟶ quotient.mk y) => hom_of_le sorry

theorem comp_to_thin_skeleton {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) : F ⋙ to_thin_skeleton D = to_thin_skeleton C ⋙ map F :=
  rfl

/-- Given a natural transformation `F₁ ⟶ F₂`, induce a natural transformation `map F₁ ⟶ map F₂`.-/
def map_nat_trans {C : Type u₁} [category C] {D : Type u₂} [category D] {F₁ : C ⥤ D} {F₂ : C ⥤ D} (k : F₁ ⟶ F₂) : map F₁ ⟶ map F₂ :=
  nat_trans.mk fun (X : thin_skeleton C) => quotient.rec_on_subsingleton X fun (x : C) => ulift.up (plift.up sorry)

-- TODO: state the lemmas about what happens when you compose with `to_thin_skeleton`

/-- A functor `C ⥤ D ⥤ E` computably lowers to a functor
`thin_skeleton C ⥤ thin_skeleton D ⥤ thin_skeleton E` -/
@[simp] theorem map₂_obj_obj {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] (F : C ⥤ D ⥤ E) (x : thin_skeleton C) (y : thin_skeleton D) : functor.obj (functor.obj (map₂ F) x) y =
  quotient.map₂ (fun (X : C) (Y : D) => functor.obj (functor.obj F X) Y) (map₂._proof_1 F) x y :=
  Eq.refl (functor.obj (functor.obj (map₂ F) x) y)

protected instance to_thin_skeleton_faithful (C : Type u₁) [category C] [∀ (X Y : C), subsingleton (X ⟶ Y)] : faithful (to_thin_skeleton C) :=
  faithful.mk

/-- Use `quotient.out` to create a functor out of the thin skeleton. -/
@[simp] theorem from_thin_skeleton_map (C : Type u₁) [category C] [∀ (X Y : C), subsingleton (X ⟶ Y)] (x : thin_skeleton C) (y : thin_skeleton C) : ∀ (ᾰ : x ⟶ y),
  functor.map (from_thin_skeleton C) ᾰ =
    quotient.rec_on_subsingleton₂ x y
      (fun (X Y : C) (f : quotient.mk X ⟶ quotient.mk Y) =>
        iso.hom (nonempty.some (from_thin_skeleton._proof_2 C X)) ≫
          nonempty.some (from_thin_skeleton._proof_3 C X Y f) ≫
            iso.inv (nonempty.some (from_thin_skeleton._proof_4 C Y)))
      ᾰ :=
  fun (ᾰ : x ⟶ y) => Eq.refl (functor.map (from_thin_skeleton C) ᾰ)

protected instance from_thin_skeleton_equivalence (C : Type u₁) [category C] [∀ (X Y : C), subsingleton (X ⟶ Y)] : is_equivalence (from_thin_skeleton C) :=
  is_equivalence.mk' (to_thin_skeleton C)
    (nat_iso.of_components (fun (x : thin_skeleton C) => quotient.rec_on_subsingleton x fun (X : C) => eq_to_iso sorry)
      sorry)
    (nat_iso.of_components (fun (X : C) => nonempty.some sorry) sorry)

theorem equiv_of_both_ways {C : Type u₁} [category C] [∀ (X Y : C), subsingleton (X ⟶ Y)] {X : C} {Y : C} (f : X ⟶ Y) (g : Y ⟶ X) : X ≈ Y :=
  Nonempty.intro (iso_of_both_ways f g)

protected instance thin_skeleton_partial_order {C : Type u₁} [category C] [∀ (X Y : C), subsingleton (X ⟶ Y)] : partial_order (thin_skeleton C) :=
  partial_order.mk preorder.le preorder.lt sorry sorry sorry

theorem skeletal {C : Type u₁} [category C] [∀ (X Y : C), subsingleton (X ⟶ Y)] : skeletal (thin_skeleton C) := sorry

theorem map_comp_eq {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] [∀ (X Y : C), subsingleton (X ⟶ Y)] (F : E ⥤ D) (G : D ⥤ C) : map (F ⋙ G) = map F ⋙ map G := sorry

theorem map_id_eq {C : Type u₁} [category C] [∀ (X Y : C), subsingleton (X ⟶ Y)] : map 𝟭 = 𝟭 := sorry

theorem map_iso_eq {C : Type u₁} [category C] {D : Type u₂} [category D] [∀ (X Y : C), subsingleton (X ⟶ Y)] {F₁ : D ⥤ C} {F₂ : D ⥤ C} (h : F₁ ≅ F₂) : map F₁ = map F₂ :=
  functor.eq_of_iso skeletal (iso.mk (map_nat_trans (iso.hom h)) (map_nat_trans (iso.inv h)))

/-- `from_thin_skeleton C` exhibits the thin skeleton as a skeleton. -/
def thin_skeleton_is_skeleton {C : Type u₁} [category C] [∀ (X Y : C), subsingleton (X ⟶ Y)] : is_skeleton_of C (thin_skeleton C) (from_thin_skeleton C) :=
  is_skeleton_of.mk sorry (thin_skeleton.from_thin_skeleton_equivalence C)

protected instance is_skeleton_of_inhabited {C : Type u₁} [category C] [∀ (X Y : C), subsingleton (X ⟶ Y)] : Inhabited (is_skeleton_of C (thin_skeleton C) (from_thin_skeleton C)) :=
  { default := thin_skeleton_is_skeleton }


import category_theory.abelian.left_derived

import .derived_functor

universes w v u

noncomputable theory

namespace category_theory.abelian.functor

open category_theory category_theory.functor category_theory.limits
open category_theory.functor.left_derived

variables {C : Type u} {D : Type u} [category.{w} C] [category.{w} D] [enough_projectives C]
variables (F : C ⥤ D) {A₁ A₂ A₃ X : C} {f : A₁ ⟶ A₂} {g : A₂ ⟶ A₃}
variables [abelian C] [abelian D] [additive F] [preserves_finite_colimits F]

section les

def δ₀ (A : short_exact_sequence C) := δ F 0 A ≫ (left_derived_zero_iso_self F).hom.app A.1

lemma seven_term_exact_seq (A : short_exact_sequence C) :
  exact_seq D [
    (F.left_derived 1).map A.f, (F.left_derived 1).map A.g,
    δ₀ F A,
    F.map A.f, F.map A.g, (0 : F.obj A.3 ⟶ F.obj A.3)] :=
begin
  refine exact_seq.cons _ _ (exact_of_short_exact _ _ _) _ (exact_seq.cons _ _ _ _ _),
  { refine preadditive.exact_of_iso_of_exact' ((F.left_derived 1).map A.g) (δ F 0 A) _ _
      (iso.refl _) (iso.refl _) ((left_derived_zero_iso_self F).app A.1) (by simp) _ _,
    { dsimp [δ₀], rw [category.id_comp] },
    { exact (exact_iff_exact_seq _ _).2 ((six_term_exact_seq F 0 A).extract 1 2) } },
  refine exact_seq.cons _ _ _ _ _,
  { refine preadditive.exact_of_iso_of_exact' (δ F 0 A) ((F.left_derived 0).map A.f) _ _
      (iso.refl _) ((left_derived_zero_iso_self F).app A.1) ((left_derived_zero_iso_self F).app A.2)
      _ (by simp) _,
    { dsimp [δ₀], rw [category.id_comp] },
    { exact (exact_iff_exact_seq _ _).2 ((six_term_exact_seq F 0 A).extract 2 2) } },
    apply exact_seq.cons,
    { exact preserves_exact_of_preserves_finite_colimits_of_epi _ A.exact' },
    { rw [← exact_iff_exact_seq],
      exact ((abelian.tfae_epi (F.obj A.3) (F.map A.g)).out 0 2).1 infer_instance, }
end

end les

end category_theory.abelian.functor


import Lean.Elab.Command
import Lib.Logic.Classical

macro "obtain " p:term " from " d:term : tactic =>
  `(tactic| match $d:term with | $p:term => ?_)

-- macro "left" : tactic =>
--   `(tactic| apply Or.inl)

-- macro "right" : tactic =>
--   `(tactic| apply Or.inr)

-- macro "refl" : tactic =>
--   `(tactic| apply rfl)

-- macro "exfalso" : tactic =>
--   `(tactic| apply False.elim)

macro "byContradiction" h: ident : tactic =>
  `(tactic| apply Classical.byContradiction; intro h)

theorem swapHyp {p q : Prop} (h : p) (h' : ¬ p) : q := by
  cases h' h

macro "swapHyp" h:term "as" h':ident : tactic =>
  `(tactic| apply Classical.byContradiction; intro $h' <;>
            first
            | apply $h ; clear $h
            | apply swapHyp $h <;> clear $h
              )

-- open Lean Parser.Tactic Elab Command Elab.Tactic Meta
-- macro "fail" : tactic => pure $ throwError "foo"

namespace Option

@[simp]
theorem map_none {f : α → β} :
  Option.map f none = none := rfl

@[simp]
theorem map_some {f : α → β} {x} :
  Option.map f (some x) = some (f x) := rfl

attribute [simp] map_id

end Option

inductive EqvGen (R : α → α → Prop) : α → α → Prop :=
| rfl {x} : EqvGen R x x
| step {x y z} : R x y → EqvGen R y z → EqvGen R x z
| symm_step {x y z} : R y x → EqvGen R y z → EqvGen R x z

namespace EqvGen

variable {R : α → α → Prop}

theorem once (h : R x y) : EqvGen R x y := EqvGen.step h EqvGen.rfl
theorem once_symm (h : R y x) : EqvGen R x y := EqvGen.symm_step h EqvGen.rfl

theorem trans : EqvGen R x y → EqvGen R y z → EqvGen R x z := by
  intros h₀ h₁
  induction h₀ with
  | rfl => exact h₁
  | step hR hGen IH => exact step hR (IH h₁)
  | symm_step hR hGen IH => exact symm_step hR (IH h₁)

theorem symm_step_r : EqvGen R x y → R z y → EqvGen R x z := by
  intros h₀ h₁
  have h₁ := once_symm h₁
  apply trans <;> assumption
theorem step_r : EqvGen R x y → R y z → EqvGen R x z := by
  intros h₀ h₁
  have h₁ := once h₁
  apply trans <;> assumption

theorem symm : EqvGen R x y → EqvGen R y x := by
  intros h
  induction h with
  | rfl => exact rfl
  | step hR hGen IH => exact trans IH (symm_step hR rfl)
  | symm_step hR hGen IH => exact trans IH (step hR rfl)

end EqvGen

namespace Quot
variable {r : α → α → Prop}
variable {r' : α' → α' → Prop}

def liftOn₂ (x : Quot r) (y : Quot r') (f : α → α' → β)
  (h : ∀ (a b : α) (a' : α'),
    r a b → f a a' = f b a')
  (h' : ∀ (a : α) (a' b' : α'),
    r' a' b' → f a a' = f a b') : β :=
Quot.liftOn x
  (λ x => Quot.liftOn y (f x) $
    by intros; apply h'; assumption) $
  by intros
     induction y using Quot.inductionOn
     simp [Quot.liftOn]
     apply h; assumption

@[simp]
def liftOn₂_beta {x : α} {y : α'} (f : α → α' → β)
  (h : ∀ (a b : α) (a' : α'),
    r a b → f a a' = f b a')
  (h' : ∀ (a : α) (a' b' : α'),
    r' a' b' → f a a' = f a b') :
liftOn₂ (Quot.mk _ x) (Quot.mk _ y) f h h' = f x y :=
by simp [liftOn₂]

noncomputable def out (x : Quot r) : α :=
Classical.choose (exists_rep x)

theorem eq' : Quot.mk r x = Quot.mk r y ↔ EqvGen r x y := by
  constructor
  focus
    intros h
    have Hlift : ∀ (a b : α), r a b → EqvGen r x a = EqvGen r x b := by
      intros a b Hab
      apply propext
      constructor <;> intro h
      focus apply EqvGen.step_r <;> assumption
      focus apply EqvGen.symm_step_r <;> assumption
    rw [← Quot.liftBeta (r := r) (EqvGen r x) Hlift, ← h,
          Quot.liftBeta (r := r) _ Hlift]
    exact EqvGen.rfl
  focus
    intros h
    induction h with
    | rfl => refl
    | step Hr Hgen IH =>
      rw [← IH]
      apply Quot.sound; assumption
    | symm_step Hr Hgen IH =>
      apply Eq.symm
      rw [← IH]
      apply Quot.sound; assumption

theorem eq : Quot.mk r x = Quot.mk r y ↔ EqvGen r x y := by
  constructor
  focus
    intros h
    rewrite [← liftOn₂_beta (r:=r) (r':=r) (EqvGen r), h, liftOn₂_beta]
    focus
      exact EqvGen.rfl
    focus
      intros x y z Hxy
      apply propext
      constructor <;> intro h
      focus apply EqvGen.symm_step <;> assumption
      focus apply EqvGen.step <;> assumption
    focus
      intros x y z Hxy
      apply propext
      constructor <;> intro h
      focus apply EqvGen.step_r <;> assumption
      focus apply EqvGen.symm_step_r <;> assumption
  focus
    intros h
    induction h with
    | rfl => refl
    | step Hr Hgen IH =>
      rw [← IH]
      apply Quot.sound; assumption
    | symm_step Hr Hgen IH =>
      apply Eq.symm
      rw [← IH]
      apply Quot.sound; assumption

end Quot

class WellOrdered (α : Type) where
  R : α → α → Prop
  wf : WellFounded R
  total x y : R x y ∨ x = y ∨ R y x

instance [WellOrdered α] : LT α := ⟨ WellOrdered.R ⟩
instance [WellOrdered α] : LE α where
  le x y := x = y ∨ x < y

namespace WellOrdered

variable [Hwo : WellOrdered α]

theorem le_of_lt {x y : α} : x < y → x ≤ y := Or.inr

theorem lt_irrefl (x : α) : ¬ x < x := by
have := WellOrdered.wf.apply x
induction this with | intro x h ih =>
intro h'
apply ih _ h' h'

theorem le_refl (x : α) : x ≤ x := by
  left; refl

theorem lt_antisymm {x y : α} :
  x < y → y < x → False := by
revert y
have := WellOrdered.wf.apply x
induction this with | intro x h ih =>
intros y Hxy Hyx
cases ih _ Hyx Hyx Hxy

theorem le_antisymm {x y : α} :
  x ≤ y → y ≤ x → x = y := by
intros Hxy Hyx; match x, Hxy, Hyx with
| x, Or.inl rfl, _ => intros; refl
| x, Or.inr Hx_lt, Or.inl rfl => refl
| x, Or.inr Hx_lt, Or.inr Hy_lt =>
  cases lt_antisymm Hx_lt Hy_lt

section
open Classical

theorem bottom_exists [inst : Nonempty α] :
  ∃ x : α, ∀ y : α, ¬ y < x := by
cases inst with | intro x =>
have h := Hwo.wf.apply x
induction h with | intro y h ih => exact
if h : ∃ z, z < y then by
  cases h with | intro z hz =>
  apply ih _ hz
else by
  rewrite [not_exists] at h
  exists y; assumption

noncomputable def bottom (α) [WellOrdered α]
  [inst : Nonempty α] : α :=
choose bottom_exists

theorem lt_iff_not_lt [h : WellOrdered α] (x y : α) :
  x < y ↔ ¬ y ≤ x := by
constructor
focus
  intros h₀ h₁
  match y, h₁ with
  | y, Or.inr h₁ =>
    apply lt_antisymm h₀ h₁
  | _, Or.inl rfl =>
    apply lt_irrefl _ h₀
focus
  intros h₀
  have := WellOrdered.total x y
  match y, this with
  | y, Or.inl h₀ => assumption
  | _, Or.inr (Or.inl rfl) =>
    exfalso
    apply h₀; clear h₀
    apply le_refl
  | y, Or.inr (Or.inr h₁) =>
    exfalso
    apply h₀; clear h₀
    right; assumption

theorem not_lt_bottom
  [inst : Nonempty α] :
  ¬ x < bottom α :=
choose_spec bottom_exists x

theorem bottom_le
  [inst : Nonempty α] :
  bottom α ≤ x := by
have H := not_lt_bottom (α := α) (x := x)
simp [lt_iff_not_lt] at H
assumption

end

theorem lt_trans {x y z : α} :
  x < y → y < z → x < z := by
rewrite [lt_iff_not_lt x z]
intros hxy hyz hxz
cases hxz with
| inl hxz =>
  subst hxz
  apply lt_antisymm hxy hyz
| inr hxz =>
  have := WellOrdered.wf.apply x
  induction this generalizing y z with | intro x h ih =>
  apply @ih _ hxz x y <;> assumption

theorem le_trans {x y z : α} :
  x ≤ y → y ≤ z → x ≤ z := by
intros hxy hyz
cases hxy with
| inl hxy =>
  cases hyz with
  | inl hyz => subst hxy hyz; left; refl
  | inr hyz => subst hxy; right; assumption
| inr hxy =>
  cases hyz with
  | inl hyz => subst hyz; right; assumption
  | inr hyz =>
    right; apply lt_trans
      <;> assumption

section Classical
open Classical

-- noncomputable
-- def max (x y : α) : α :=
-- if x < y
--   then y
--   else x

theorem max_le_iff (x y z : α) :
  max x y ≤ z ↔ x ≤ z ∧ y ≤ z := by
byCases Hyz : y < x
focus
  have := le_of_lt Hyz
  simp [max, *]
  constructor
  focus
    intros h
    constructor <;> try assumption
    apply le_trans <;> assumption
  focus
    intro h; cases h; assumption
focus
  simp [max, *]
  simp [lt_iff_not_lt] at Hyz
  constructor
  focus
    intros h
    constructor <;> try assumption
    apply le_trans <;> assumption
  focus
    intros h; cases h; assumption

end Classical
end WellOrdered

def WellOrder := Sigma WellOrdered

noncomputable
instance : CoeSort WellOrder (Type) := ⟨ Sigma.fst ⟩

instance (α : WellOrder) : WellOrdered α := α.snd

structure WellOrderHom (α β : WellOrder) where
  hom : α.1 → β.1
  hom_preserve x y : α.2.R x y → β.2.R (hom x) (hom y)

namespace WellOrderHom

instance : CoeFun (WellOrderHom a b) (λ _ => a → b) where
  coe f := f.hom

theorem ext {f g : WellOrderHom a b}
  (h : ∀ x, f x = g x) :
  f = g := by
have d : f.hom = g.hom := funext h
cases f with
| mk f hf =>
cases g with | mk g hg =>
  simp at d; revert hf hg;
  rewrite [d]; intros; exact rfl

theorem ext_iff {f g : WellOrderHom a b}
  (h : f = g) :
  ∀ x, f x = g x := by
subst h; intros; refl

def id : WellOrderHom α α where
  hom := _root_.id
  hom_preserve x y hxy := hxy

def comp (f : WellOrderHom β γ) (g : WellOrderHom α β) : WellOrderHom α γ where
  hom := f.hom ∘ g.hom
  hom_preserve x y hxy := f.hom_preserve _ _ (g.hom_preserve _ _ hxy)

variable {X Y Z W : WellOrder}
variable (f : WellOrderHom X Y)
variable (g : WellOrderHom Y Z)
variable (h : WellOrderHom Z W)

@[simp]
theorem id_comp : id.comp f = f := by apply ext; intro x; exact rfl
@[simp]
theorem comp_id : f.comp id = f := by apply ext; intro x; exact rfl
@[simp]
theorem comp_assoc : (h.comp g).comp f = h.comp (g.comp f) :=
by apply ext; intro x; exact rfl

end WellOrderHom

class IsMono {X Y} (f : WellOrderHom X Y) where
  mono : ∀ W (g₁ g₂ : WellOrderHom W X), f.comp g₁ = f.comp g₂ → g₁ = g₂

namespace IsMono
variable {X Y Z : WellOrder}
variable (f : WellOrderHom X Y)
variable (g : WellOrderHom Y Z)
variable (gZY : WellOrderHom Z Y)
variable (gZX : WellOrderHom Z X)
open WellOrderHom

instance : IsMono (@WellOrderHom.id X) where
  mono W g₁ g₂ := by simp; apply _root_.id

instance [IsMono f] [IsMono g] : IsMono (g.comp f) where
  mono W g₁ g₂ := by
    simp; intro h
    have h := mono _ _ _ h
    apply mono _ _ _ h

end IsMono

class IsIso {X Y} (f : WellOrderHom X Y) where
  inv : WellOrderHom Y X
  to_inv : f.comp inv = WellOrderHom.id
  inv_to : inv.comp f = WellOrderHom.id

export IsIso (inv)

namespace IsIso
attribute [simp] to_inv inv_to

open WellOrderHom
variable {X Y Z : WellOrder}
variable (f : WellOrderHom X Y)
variable (g : WellOrderHom Y Z)
variable (gZY : WellOrderHom Z Y)
variable (gZX : WellOrderHom Z X)

@[simp]
theorem to_inv_reassoc [IsIso f] :
  f.comp ((inv f).comp gZY) = gZY :=
by rw [← WellOrderHom.comp_assoc, to_inv, id_comp]

@[simp]
theorem inv_to_reassoc [IsIso f] :
  (inv f).comp (f.comp gZX) = gZX :=
by rw [← WellOrderHom.comp_assoc, inv_to, id_comp]

instance [IsIso f] : IsIso (inv f) where
  inv := f
  to_inv := inv_to
  inv_to := to_inv

instance : IsIso (@WellOrderHom.id X) where
  inv := id
  to_inv := by simp
  inv_to := by simp

instance [IsIso f] [IsIso g] : IsIso (g.comp f) where
  inv := (inv f).comp (inv g)
  to_inv := by simp
  inv_to := by simp

instance (priority := low) [IsIso f] : IsMono f where
  mono W g₁ g₂ Heq := by
    rw [← inv_to_reassoc f g₁, Heq, inv_to_reassoc]

end IsIso

section HasArrow
-- set_option checkBinderAnnotations false

inductive HasArrow X Y (cl : WellOrderHom X Y → Type u) : Prop :=
| intro (f : WellOrderHom X Y) : cl f → HasArrow X Y cl

end HasArrow

def WellOrderMono (α β : WellOrder) := HasArrow α β IsMono
@[matchPattern]
def WellOrderMono.intro (f : WellOrderHom x y) [IsMono f] :
  WellOrderMono x y :=
HasArrow.intro f inferInstance

def WellOrderIso (α β : WellOrder) := HasArrow α β IsIso
@[matchPattern]
def WellOrderIso.intro (f : WellOrderHom x y) [IsIso f] :
  WellOrderIso x y :=
HasArrow.intro f inferInstance

-- namespace WellOrderIso

-- variable {X Y : WellOrder}

-- def flip (f : WellOrderIso X Y) : WellOrderIso Y X where
--   to := f.inv
--   inv := f.to
--   to_inv := f.inv_to
--   inv_to := f.to_inv

-- def toMono (f : WellOrderIso X Y) : WellOrderMono X Y where
--   to := f.to
--   mono Z g₀ g₁ h := _

-- end WellOrderIso

-- inductive Erased (α : Type u) : Prop :=
-- | intro (x : α) : Erased α

-- theorem Erased_impl {α β} (f : α → β) : Erased α → Erased β
-- | ⟨ x ⟩ => ⟨ f x ⟩

def WOEqv (α β : WellOrder) : Prop :=
WellOrderIso α β

def Ordinal := Quot WOEqv

namespace Ordinal

protected def mk (α : Type) [WellOrdered α] : Ordinal :=
Quot.mk _ { fst := α, snd := inferInstance }

def zero : Ordinal :=
Quot.mk _
{ fst := Empty,
  snd :=
  { R := by {intro x; cases x},
    wf := by { constructor; intro x; cases x },
    total := by {intro x; cases x} } }

inductive Option.R (r : α → α → Prop) : Option α → Option α → Prop where
| top x : R r (some x) none
| lifted x y : r x y → R r (some x) (some y)

theorem Option.R_acc {r : α → α → Prop}
        x (h : Acc r x) : Acc (Option.R r) (some x) := by
  induction h with
  | intro y h' ih =>
    constructor; intros z Hr; cases Hr
    apply ih; assumption

theorem Option.R_wf {r : α → α → Prop}
        (h : WellFounded r) : WellFounded (Option.R r) := by
  constructor; intro x
  match x with
  | none =>
    constructor; intro y h'; cases h'
    apply Option.R_acc
    apply h.apply
  | some x =>
    apply Option.R_acc
    apply h.apply

instance [WellOrdered α] : WellOrdered (Option α) where
  R := Option.R (WellOrdered.R)
  wf := Option.R_wf (WellOrdered.wf)
  total := λ x y =>
    match x, y with
    | none, none => by
      apply Or.inr; apply Or.inl
      constructor
    | none, some _ => by
      apply Or.inr; apply Or.inr
      constructor
    | some _, none => by
      apply Or.inl
      constructor
    | some x, some y =>
      match WellOrdered.total x y with
      | Or.inl h =>
        Or.inl $ Option.R.lifted _ _ h
      | Or.inr (Or.inl h) =>
        Or.inr $ Or.inl $ congrArg _ h
      | Or.inr (Or.inr h) =>
        Or.inr $ Or.inr $ Option.R.lifted _ _ h

def impl.S : WellOrder → WellOrder
| ⟨α, Hα⟩ =>
  let _ : WellOrdered α := Hα
  { fst := Option α,
    snd := inferInstance }

def S_hom (h : WellOrderHom a b) :
    WellOrderHom (impl.S a) (impl.S b) where
  hom := Option.map h
  hom_preserve := by
    intros x y h; cases x <;>
      cases y <;>
      cases h <;>
      constructor <;>
      apply h.hom_preserve <;>
      assumption

@[simp]
theorem id_hom :
  (@WellOrderHom.id a).hom = id := rfl

@[simp]
theorem S_hom_hom (h : WellOrderHom a b) :
  (S_hom h).hom = Option.map h.hom := rfl

@[simp]
theorem comp_hom (f : WellOrderHom b c) (g : WellOrderHom a b) :
  (f.comp g).hom = f.hom ∘ g.hom := rfl

@[simp]
theorem comp_S_hom
  (f : WellOrderHom b c) (g : WellOrderHom a b) :
  (S_hom f).comp (S_hom g) = S_hom (f.comp g) :=
WellOrderHom.ext $ by
  intro x
  cases x <;> simp [WellOrderHom.comp, S_hom]

@[simp]
theorem S_hom_id {α} :
  S_hom (@WellOrderHom.id α) = WellOrderHom.id :=
WellOrderHom.ext $ by
  intro x
  rw [S_hom_hom, id_hom, id_hom]
  simp

instance [@IsIso x y f] : IsIso (S_hom f) where
  inv := S_hom (inv f)
  to_inv := by simp
  inv_to := by simp

def S_iso : WellOrderIso a b → WellOrderIso (impl.S a) (impl.S b)
| ⟨f, h⟩ =>
  have h' := h
  ⟨S_hom f, inferInstance⟩
  -- to := S_hom h.to
  -- inv := S_hom h.inv
  -- to_inv := by simp [h.to_inv]
  -- inv_to := by simp [h.inv_to]

def S : Ordinal → Ordinal :=
Quot.lift (Quot.mk _ ∘ impl.S) λ a b Heqv => by
  simp
  apply Quot.sound
  exact S_iso Heqv

def Le (x y : Ordinal) : Prop :=
Quot.liftOn₂ x y
  (λ x y => WellOrderMono x y)
  (by intros a b x f
      cases f with
      | intro f hf =>
      simp; apply propext
      constructor <;> intros g
      { cases g with
        | intro g hg =>
          have hf := hf
          have hg := hg
          exact ⟨g.comp (inv f), inferInstance⟩ }
      { cases g with
        | intro g hg =>
          have hf := hf
          have hg := hg
          exact ⟨g.comp f, inferInstance⟩ } )
  (by intros x a b f
      cases f with | intro f hf =>
      simp; apply propext
      constructor <;> intros g
      { cases g with
        | intro g hg =>
          have hf := hf
          have hg := hg
          exact ⟨f.comp g, inferInstance⟩ }
      { cases g with
        | intro g hg =>
          have hf := hf
          have hg := hg
          exact ⟨(inv f).comp g, inferInstance⟩ }
       )

def Lt (x y : Ordinal) : Prop :=
Le x y ∧ ¬ Le y x

-- structure StrictInclusion (a b : WellOrder) : Type where
--   inclusion : WellOrderHom a b
--   [incl_mono : IsMono inclusion]
--   strict : ¬ WellOrderMono b a

-- attribute [instance] StrictInclusion.incl_mono

instance : LE Ordinal := ⟨ Le ⟩
instance : LT Ordinal := ⟨ Lt ⟩

theorem le_refl (x : Ordinal) : x ≤ x := by
  cases x using Quot.ind
  simp [LE.le,Le]
  exists @WellOrderHom.id _
  exact inferInstance

infix:25 " ⟶ " => WellOrderHom

instance : WellOrdered Unit where
  R _ _ := False
  wf := ⟨ λ a => ⟨ _, by intros _ h; cases h ⟩ ⟩
  total := by intros; right; left; refl

def Unit : WellOrder := ⟨_root_.Unit,inferInstance⟩

def const {β : WellOrder} (x : β) : Unit ⟶ β where
  hom := λ i => x
  hom_preserve := by intros _ _ h; cases h

section inverse
open Classical
noncomputable
def inverse [Nonempty α] (f : α → β) (x : β) : α :=
epsilon λ y => f y = x

end inverse

section schroeder_bernstein
open Classical

def injective (f : α → β) : Prop :=
∀ x y, f x = f y → x = y

def surjective (f : α → β) : Prop :=
∀ y, ∃ x, f x = y

def bijective (f : α → β) : Prop :=
injective f ∧ surjective f

variable [Nonempty α] [Nonempty β]
variable (f : α → β) (hf : injective f)
variable (g : β → α) (hg : injective g)

theorem left_inv_of_injective :
  inverse f ∘ f = id := by
apply funext; intro x
simp [Function.comp, inverse]
apply hf
apply Classical.epsilon_spec (p := λ y => f y = f x)
exists x; refl

theorem right_inv_of_surjective (hf' : surjective f) :
  f ∘ inverse f = id := by
apply funext; intro x
specialize (hf' x)
apply Classical.epsilon_spec (p := λ y => f y = x)
assumption

theorem injective_of_left_inv
        (h : g ∘ f = id) :
  injective f := by
intros x y Hxy
have Hxy : (g ∘ f) x = (g ∘ f) y := congrArg g Hxy
rewrite [h] at Hxy; assumption

theorem injective_of_right_inv
        (h : g ∘ f = id) :
  surjective g := by
intros x
exists (f x)
show (g ∘ f) x = x
rewrite [h]; refl
-- def lonely (b : β) := ∀ a, f a ≠ b

-- def iterate (n : Nat) (b : β) : β :=
-- match n with
-- | 0 => b
-- | Nat.succ n => iterate n (f (g b))

-- -- #exit
-- def descendent (b₀ b₁ : β) : Prop :=
-- ∃ n, iterate f g n b₀ = b₁
-- -- #exit
-- theorem schroeder_bernstein :
--   ∃ h : α → β, bijective h := by
-- let p x y := lonely f y ∧ descendent f g y (f x)
-- let h x :=
--   if ∃ y, p x y
--     then inverse g x
--     else f x
-- exists h; constructor
-- focus
--   intro x y; simp
-- -- focus
-- --   intros x y
-- --   -- simp at Hxy
-- --   simp
-- -- --   have : (∃ z, p x z) ↔ (∃ z, p y z) := by
-- -- --     constructor <;> intros h
-- -- --     focus
-- -- --       cases h with
-- -- --       | intro z hz => unfold p at *
-- -- --   admit
--   byCases hx : (∃ z, p x z) <;>
--     byCases hy : (∃ z, p y z) <;>
--     simp [*] <;> intro h3
--   focus
--     clear h
--     cases hx with | intro x' hx' =>
--     cases hy with | intro y' hy' =>
--       cases hy'; cases hx'
--       clear p
-- admit
-- abort
-- -- match propDecidable (∃ z, p x z), propDecidable (∃ z, p y z), Hxy with
-- -- | isTrue ⟨x', hx, hx'⟩, isTrue ⟨y', hy, hy'⟩, Hxy => _
-- -- | isTrue _, isFalse _, Hxy => _
-- -- | isFalse _, isTrue _, Hxy => _
-- -- | isFalse _, isFalse _, Hxy => _
-- -- -- { admit }
-- --      simp [h] at Hxy }
-- -- exists (inverse g ∘ f)

end schroeder_bernstein

theorem comp_const (f : WellOrderHom a b) x :
  f.comp (const x) = const (f x) := rfl

theorem injective_of_monomorphism
        (f : WellOrderHom a b) [IsMono f] :
  injective f.hom := by
intros x y Hxy
have := @IsMono.mono _ _ f _ _ (const x) (const y)
simp [comp_const, Hxy] at this
have := WellOrderHom.ext_iff this ()
assumption

-- Need Schroeder-Bernstein Theorem
theorem le_antisymm (x y : Ordinal)
        (Hxy : x ≤ y)
        (Hyx : y ≤ x) : x = y := by
  cases x using Quot.ind
  cases y using Quot.ind
  simp [LE.le,Le] at *
  apply Quot.sound
  cases Hxy with | intro f hf =>
  cases Hyx with | intro g hg => _
  admit

theorem le_trans (x y z : Ordinal)
        (Hxy : x ≤ y)
        (Hyz : y ≤ z) : x ≤ z := by
  cases x using Quot.ind
  cases y using Quot.ind
  cases z using Quot.ind
  simp [LE.le,Le] at *
  cases Hxy with | intro f hf =>
  cases Hyz with | intro g hg =>
  have hf := hf
  have hg := hg
  exists g.comp f
  exact inferInstance

theorem lt_total (x y : Ordinal) :
  x < y ∨ x = y ∨ y < x := by
byCases hxy : (x ≤ y) <;>
  byCases hyx : (y ≤ x)
focus
  right; left
  apply le_antisymm <;> assumption
focus
  left; constructor <;> assumption
focus
  right; right
  constructor <;> assumption
focus
  admit
-- Todo:
-- Le is a total order
-- Limits
-- zero is a limit? (no)
-- zero, Succ, Limit are distinct
-- recursor / induction principle

namespace WellOrdered

variable  [WellOrdered α]

theorem le_iff_forall_le (x y : α) :
  x ≤ y ↔ ∀ z, y ≤ z → x ≤ z := by
constructor <;> intros h
focus
  intros z h'
  apply WellOrdered.le_trans <;> assumption
focus
  apply h
  apply WellOrdered.le_refl

theorem le_iff_forall_ge (x y : α) :
  x ≤ y ↔ ∀ z, z ≤ x → z ≤ y := by
constructor <;> intros h
focus
  intros z h'
  apply WellOrdered.le_trans <;> assumption
focus
  apply h
  apply WellOrdered.le_refl

theorem le_total (x y : α) :
  x ≤ y ∨ y ≤ x := sorry

section Classical
open Classical

theorem le_max_l {x y : α} :
  x ≤ max x y := by
rw [le_iff_forall_le]; intros z
rw [WellOrdered.max_le_iff]
intros h; cases h; assumption

theorem le_max_r {x y : α} :
  y ≤ max x y := by
rw [le_iff_forall_le]; intros z
rw [WellOrdered.max_le_iff]
intros h; cases h; assumption

instance : @Reflexive α LE.le where
  refl := WellOrdered.le_refl

theorem max_eq_of_le {x y : α} :
  x ≤ y → max x y = y := by
intros h
apply WellOrdered.le_antisymm
focus
  rw [WellOrdered.max_le_iff]
  auto
focus
  apply WellOrdered.le_max_r

theorem max_eq_of_ge {x y : α} :
  y ≤ x → max x y = x := by
intros h
apply WellOrdered.le_antisymm
focus
  rw [WellOrdered.max_le_iff]
  auto
focus
  apply WellOrdered.le_max_l

end Classical
end WellOrdered

noncomputable
instance : CoeSort WellOrder Type := ⟨ Sigma.fst ⟩

structure Seq where
  index : Type
  [wo : WellOrdered index]
  ords : index → WellOrder
  increasing (i j : index) : i ≤ j → ords i ⟶ ords j
  [mono (i j : index) h : IsMono (increasing i j h)]
  strict (i j : index) :
    i < j → ¬ WellOrderMono (ords i) (ords j)
  increasing_refl (i : index) h :
    increasing i i h =
    WellOrderHom.id
  increasing_trans (i j k : index) (h : i ≤ j) (h' : j ≤ k) :
    (increasing _ _ h').comp (increasing _ _ h) =
    increasing _ _ (WellOrdered.le_trans h h')
  bottom : index
  next : index → index
  infinite i : i < next i
  nothing_below_bottom x : ¬ x < bottom
  consecutive i j : j < next i → j < i ∨ j = i

attribute [instance] Seq.wo Seq.mono

-- theorem Seq.increasing' (i j : s.index) :
--   i ≤ j → ords i ⟶ ords j

theorem Seq.bottom_le (s : Seq) x : s.bottom ≤ x := by
  have := s.nothing_below_bottom x
  simp [WellOrdered.lt_iff_not_lt] at this
  assumption

def Lim.Eqv (s : Seq) :
  (Σ i : s.index, s.ords i) → (Σ i, s.ords i) → Prop
| ⟨i, x⟩, ⟨j, y⟩ =>
  (∃ h : i < j, s.increasing _ _ (WellOrdered.le_of_lt h) x = y) ∨
  (∃ h : i = j, cast (by rw [h]) x = y) ∨
  (∃ h : i > j, s.increasing _ _ (WellOrdered.le_of_lt h) y = x)

def Lim (s : Seq) :=
Quot (Lim.Eqv s)

namespace Lim

variable (s : Seq)

theorem Eqv.intro i j (h : i ≤ j)
        x y
        (h' : s.increasing i j h x = y) :
  Eqv s ⟨i, x⟩ ⟨j, y⟩ := by
cases h with
| inl h =>
  subst h; right; left
  exists @rfl _ i
  simp [cast]
  simp [Seq.increasing_refl, WellOrderHom.id] at h'
  assumption
| inr h =>
  left; exists h
  assumption

theorem cast_cast {a b} (h : a = b) (h' : b = a) x :
  cast h (cast h' x) = x := by
cases h; cases h'; refl

theorem Eqv.symm x y :
  Eqv s x y →
  Eqv s y x := by
intros h; cases h with
| inl h => right; right; assumption
| inr h =>
  cases h with
  | inl h =>
    right; left
    cases h with | intro h h' =>
    exists h.symm
    rewrite [← h', cast_cast]
    refl
  | inr h => left; assumption

section
open Classical

theorem Eqv.intro' i j Hi Hj
        x y
        (h' : s.increasing i (max i j) Hi x =
              s.increasing j (max i j) Hj y) :
  Eqv s ⟨i, x⟩ ⟨j, y⟩ := by
cases WellOrdered.le_total i j with
| inl h =>
  have h₂ := WellOrdered.max_eq_of_le h
  revert Hi Hj h'
  rewrite [h₂]; intros Hi Hj
  rewrite [s.increasing_refl j]; intros h'
  apply Eqv.intro; assumption
| inr h =>
  have h₂ := WellOrdered.max_eq_of_ge h
  revert Hi Hj h'
  rewrite [h₂]; intros Hi Hj
  rewrite [s.increasing_refl i]; intros h'
  apply Lim.Eqv.symm
  apply Eqv.intro
  apply Eq.symm; assumption

end

theorem EqvGen_Eqv x y :
  EqvGen (Eqv s) x y ↔ Eqv s x y := by
constructor <;> intros h
focus
  induction h with
  | @rfl a =>
    cases a
    right; left
    exists @rfl _ _; simp [cast]
  | @step x y z a _ b =>
    cases x
    cases y
    cases z

  | symm_step a => skip

end Lim

namespace Lim

variable (s : Seq)
open Classical

theorem mk_eq_mk_max_l i j x :
  Quot.mk (Lim.Eqv s) ⟨i, x⟩ =
  Quot.mk _ ⟨max i j, s.increasing i (max i j)
    WellOrdered.le_max_l x⟩ := by
rw [Quot.eq]
apply EqvGen.once;
  apply Eqv.intro
{ refl }

theorem mk_eq_mk_max_r i j x :
  Quot.mk (Lim.Eqv s) ⟨i, x⟩ =
  Quot.mk _ ⟨max j i, s.increasing i (max j i)
    WellOrdered.le_max_r x⟩ := by
rw [Quot.eq]
apply EqvGen.once;
  apply Eqv.intro
{ refl }

-- theorem mk_eq_mk_max_r i j x :
--   Quot.mk (Lim.Eqv s) ⟨i, x⟩ =
--   Quot.mk _ ⟨max j i, s.increasing i (max j i)

protected inductive R : Lim s → Lim s → Prop :=
| intro i (x y : s.ords i) :
  x < y → Lim.R (Quot.mk _ ⟨i, x⟩) (Quot.mk _ ⟨i, y⟩)

-- protected def SigmaT := PSigma (λ i => s.ords i)
-- protected def toSigma : Lim s → Lim.SigmaT s
-- | ⟨a,b,h⟩ => ⟨a,b⟩
-- protected def SigmaT.R : Lim.SigmaT s → Lim.SigmaT s → Prop :=
-- PSigma.Lex LT.lt (λ _ => LT.lt)

-- protected theorem SigmaT.R_Subrelation :
--   Subrelation (Lim.R s) (InvImage (SigmaT.R s) (Lim.toSigma s)) := by
--   intros x y h
--   cases h with
--   | same i j k =>
--     simp [InvImage, Lim.toSigma]
--     apply PSigma.Lex.right; assumption
--   | lt x y =>
--     cases x; cases y
--     constructor; assumption

protected theorem R_wf :
  WellFounded (Lim.R s) := by
-- Subrelation.wf _ (InvImage.wf _ _)
constructor; intro a
cases a using Quot.ind with | mk a =>
cases a with | mk a b =>
have Hacc := WellOrdered.wf.apply b
-- let f b := Quot.mk (Eqv s) { fst := a, snd := b }
-- have Hacc := InvImage.accessible f Hacc
-- apply Acc
induction Hacc with | intro b h ih =>
-- clear h
constructor; intros y
generalize Hx : (Quot.mk (Eqv s) { fst := a, snd := b }) = x
intros Hr
cases Hr with | intro i x =>
rw [Quot.eq] at Hx
-- cases Hr
-- apply ih
skip

-- let lex : WellFounded (Lim.SigmaT.R s) :=
  -- (PSigma.lex WellOrdered.wf (λ i => WellOrdered.wf))
-- Subrelation.wf
  -- (SigmaT.R_Subrelation s)
  -- (InvImage.wf (Lim.toSigma s) lex)

protected theorem R_total x y :
  Lim.R s x y ∨ x = y ∨ Lim.R s y x :=
match x, y with
| ⟨x,x',hx⟩, ⟨y,y',hy⟩ =>
  match x, y, WellOrdered.total x y with
  | _, _, Or.inl h => by left; constructor; assumption
  | _, _, Or.inr (Or.inr h) => by right; right; constructor; assumption
  | a, _, Or.inr (Or.inl rfl) =>
    match WellOrdered.total x' y' with
    | Or.inl h => by left; constructor; assumption
    | Or.inr (Or.inl h) => by subst h; right; left; refl
    | Or.inr (Or.inr h) => by right; right; constructor; assumption

instance : WellOrdered (Lim s) where
  R := Lim.R s
  wf := Lim.R_wf s
  total := Lim.R_total s

theorem exists_in_inclusion (h : StrictInclusion a b) :
  ∃ x : b, True := by
apply Classical.byContradiction; intro h₀
rewrite [Classical.not_exists] at h₀
apply h.strict
let f (x : b) : a := False.elim (h₀ x trivial)
refine' ⟨⟨f, _⟩,_⟩
focus
  intros x; cases h₀ x trivial
focus
  constructor
  intros W g₁ g₂ _
  apply WellOrderHom.ext; intro a
  cases h₀ (g₁ a) trivial

section
open Classical
-- #print prefix

theorem exists_in_inclusion' (h : StrictInclusion a b) :
  ∃ x : b, ∀ y, ¬ h.inclusion y = x := by
byCases Ha : Nonempty a
focus
  apply Classical.byContradiction; intro h₀
  simp at h₀
  apply h.strict
  -- revert Ha; intro Ha
  have : injective h.inclusion.hom := injective_of_monomorphism _
  let f : b → a := inverse h.inclusion.hom
  have hf : ∀ i, f (h.inclusion i) = i :=
    congrFun (left_inv_of_injective _ this)
  refine' ⟨⟨f, _⟩,_⟩
  focus
    intros x y Hxy
    have Hx := h₀ x
    have Hy := h₀ y
    have : ∀ α [WellOrdered α] (a b : α),
             WellOrdered.R a b ↔ a < b := λ _ _ _ _ => Iff.rfl
    cases Hx with | intro x' Hx =>
    cases Hy with | intro y' Hy =>
    rewrite [← Hx, ← Hy, hf, hf]
    rewrite [this, WellOrdered.lt_iff_not_lt] at *
    rewrite [← Hx, ← Hy] at Hxy
    intros Hxy'; apply Hxy; clear Hxy x y Hx Hy this
    cases Hxy' with
    | inl h => subst h; left; refl
    | inr h =>
      right; apply WellOrderHom.hom_preserve
      assumption
  focus
    constructor
    intros W g₁ g₂ Hg
    apply WellOrderHom.ext; intros x
    have Hg := WellOrderHom.ext_iff Hg x
    simp [WellOrderHom.hom, WellOrderHom.comp] at Hg
    have := right_inv_of_surjective
      (WellOrderHom.hom h.inclusion) h₀
    have := congrFun this; simp at this
    have Hg := congrArg h.inclusion.hom Hg
    rewrite [this, this] at Hg; assumption
focus
  have := exists_in_inclusion h
  cases this with | intro x =>
  exists x; intros y _
  apply Ha; clear Ha
  constructor; assumption

end
--   intros x; cases h₀ x trivial
-- focus
--   constructor
--   intros W g₁ g₂ _
--   apply WellOrderHom.ext; intro a
--   cases h₀ (g₁ a) trivial

-- if h₀ : Nonempty a then by
--   cases h₀ with | intro x =>
--   exists h.inclusion x
--   -- exact intro
--   trivial
-- else by
--   -- cases h with | ⟨h₀, h₁⟩ =>
--   apply Classical.byContradiction
--   rewrite [not_exists]; intros h₁
--   apply h.strict
--   constructor

noncomputable
def witness (x : StrictInclusion a b) : b :=
Classical.choose (exists_in_inclusion' x)

protected noncomputable def default : Lim s where
  idx := s.next s.bottom
  val := witness (s.increasing _ _ (s.infinite _))
  min_idx j x h  := by
    let f := s.increasing _ _ (s.infinite s.bottom)
    cases s.consecutive _ _ h with
    | inl h =>
      cases s.nothing_below_bottom _ h
    | inr h =>
      subst j
      intros h₀
      apply
        Classical.choose_spec
          (exists_in_inclusion' f) _ h₀

noncomputable
instance : Inhabited (Lim s) where
  default := Lim.default s

end Lim

def lim (s : Seq) : Ordinal :=
Quot.mk _
{ fst := Lim s,
  snd := inferInstance }

theorem WO_is_equiv : EqvGen WOEqv x y → WOEqv x y := by
  intro h
  induction h with
  | rfl => exact ⟨WellOrderHom.id, inferInstance⟩
  | step h₀ _ ih =>
    cases h₀ with | intro f h₀ =>
    cases ih with | intro g ih =>
    exists g.comp f
    have h₀ := h₀; have ih := ih
    exact inferInstance
  | symm_step h₀ _ ih =>
    cases h₀ with | intro f h₀ =>
    cases ih with | intro g ih =>
    have h₀ := h₀; have ih := ih
    exists g.comp (inv f)
    exact inferInstance

theorem zero_ne_succ (x : Ordinal) : zero ≠ S x := by
  intros h
  cases x using Quot.ind with | mk x =>
  cases x with | mk a b =>
  simp [S] at h
  have h := WO_is_equiv $ Quot.eq.1 h
  simp [impl.S] at h
  cases h with | intro a b =>
  have b := b
  have f := (inv a).hom none
  cases f

theorem succ_ne_self (x : Ordinal) : x ≠ S x := by
  intros h
  cases x using Quot.ind with | mk x =>
  cases x with | mk a Ha =>
  revert Ha h; intros Ha h
  let Ha' : WellOrdered (Option a) := inferInstance
  let Ha'' : LT (Option a) := instLT
  simp [S] at h
  have h := WO_is_equiv $ Quot.eq.1 h
  cases h with | intro f hf =>
  have hf := hf
  have f := inv f
  have hf := f.hom_preserve
  simp [WellOrdered.R] at hf
  suffices H : ∀ x : Option a, some (f x) < x → False by
    apply H none
    simp only [LT.lt]
    constructor
  intros x
  have Hacc : Acc LT.lt x := WellOrdered.wf.apply _
  induction Hacc with | intro x _ ih =>
  intros h'
  apply ih _ h'
  constructor
  apply f.hom_preserve (some (f x)) x h'

open Classical

theorem zero_ne_lim (s : Seq) : zero ≠ lim s := by
  intros h
  -- rewrite [Quot.eq] at h
  have h := WO_is_equiv $ Quot.eq.1 h
  cases h with | intro f hf =>
  revert hf; intros hf
  have f := inv f
  have hf := f.hom_preserve
  cases f Inhabited.default
-- TODO:
-- succ ≠ lim
-- 0 ≠ lim
-- recursor
-- Lemma no Ordinal between x and S x?
-- #check Le
-- set_option trace.simp_rewrite true

-- #check getLocal
-- #check Lean.Expr.fvar

-- set_option trace.Ma
-- set_option trace.Elab.definition true

theorem S_consecutive y :
  y ≤ x ∧ y < S x ∨ x < y ∧ S x ≤ y := by
match lt_total x y with
| Or.inl Hlt =>
  right
  refine' ⟨Hlt, _⟩
  cases Hlt with | intro Hle Hnot_ge =>
  cases x using Quot.ind with | mk x =>
  cases y using Quot.ind with | mk y =>
  simp [Le] at Hle Hnot_ge
  have :
         (¬ Nonempty (y → x)) ∨
         (∃ f : y → x, ¬ Nonempty (y ⟶ x)) ∨
         (∃ f : y ⟶ x, IsMono f → False) := by
    apply byContradiction; intros h₀
    apply Hnot_ge; clear Hnot_ge
    simp at h₀
    match h₀ with
    | ⟨⟨f⟩, h₁, h₂⟩ =>
      cases h₁ f with | intro g =>
      cases h₂ g with | intro z => -- weird pretty printing: not
                                  -- printing the type means that
                                  -- we're not giving the ∀ variable a
                                  -- name
      -- cases z
      -- clear h₁
      constructor; assumption
  match this with
  | Or.inl h₀ =>
    cases Hle with | intro f Hf =>
    revert Hf; intros Hf
    have : StrictInclusion x y := ⟨f, Hnot_ge⟩
    let w := Lim.witness this
    simp [LE.le, S, Le]
    have : x → False := by
      intros a
      let f (b : y) := a
      apply h₀; constructor; assumption
    let g (_ : impl.S x) := w
    -- have : IsMono g := by
      -- intros
    let g' : impl.S x ⟶ y := by
      refine' ⟨g, _⟩
      intros a b Hab
      cases Hab with
      | top h => cases this h
      | lifted h => cases this h
    have hg : IsMono g' := by
      constructor; intros W g₁ g₂ Hg
      apply WellOrderHom.ext; intros x
      cases g₁ x with
      | some x => cases this x
      | none =>
        cases g₂ x with
        | some x => cases this x
        | none => refl
    constructor; assumption
  | Or.inr (Or.inl ⟨f, h₀⟩) =>
    clear this
    swapHyp h₀ as h₁
    constructor
    exists f
    skip
  | Or.inr (Or.inr h₀) => skip

| Or.inr (Or.inl Heq) => _
| Or.inr (Or.inr Hgt) => _

theorem lt_lim (s : Seq) x :
  lim s ≤ x ↔ ∀ i, Ordinal.mk (s.ords i) ≤ x := by
constructor
focus
  intros h i
  cases x using Quot.ind with | mk x =>
  simp [lim, LE.le, Le] at h
  cases h with | intro a b =>
  skip
focus
  intros h
  admit

theorem lim_not_consecutive (s : Seq) x :
  x < lim s → ∃ y, x < y ∧ y < lim s := by
admit

theorem S_ne_lim (s : Seq) : S x ≠ lim s := by
admit


import for_mathlib.category_theory.localization.products
import for_mathlib.category_theory.localization.adjunction
import for_mathlib.category_theory.finite_products

noncomputable theory

universes v v' u u'

namespace category_theory

namespace limits

def is_limit_postcompose {J C : Type*} [category J] [category C] {F₁ F₂ : J ⥤ C}
  (e : F₁ ≅ F₂) {c : cone F₁} (hc : is_limit c) : is_limit ((cones.postcompose e.hom).obj c) :=
{ lift := λ s, hc.lift ((cones.postcompose e.inv).obj s),
  fac' := λ s j, begin
    simp only [cones.postcompose_obj_π, nat_trans.comp_app, is_limit.fac_assoc, category.assoc, iso.inv_hom_id_app,
  category.comp_id],
  end,
  uniq' := λ s m w, hc.hom_ext (λ j, begin
    simp only [cones.postcompose_obj_π, nat_trans.comp_app] at w,
    simp only [← cancel_mono (e.hom.app j), w, category.assoc, is_limit.fac,
      cones.postcompose_obj_π, nat_trans.comp_app, iso.inv_hom_id_app, category.comp_id],
  end), }

end limits

open limits category

variables {C : Type u} {D : Type u'} [category.{v} C] [category.{v'} D]
  (L : C ⥤ D) (W : morphism_property C) [L.is_localization W]

namespace morphism_property

lemma isomorphisms.is_inverted_by (F : C ⥤ D) :
  (morphism_property.isomorphisms C).is_inverted_by F := λ X Y f hf,
begin
  rw morphism_property.isomorphisms.iff at hf,
  haveI := hf,
  apply_instance,
end

def stable_under_limits_of_shape (W : morphism_property C) (J : Type*) [category J] : Prop :=
∀ (X₁ X₂ : J ⥤ C) (c₁ : cone X₁) (c₂ : cone X₂) (h₁ : is_limit c₁) (h₂ : is_limit c₂)
  (f : X₁ ⟶ X₂) (hf : Π (j : J), W (nat_trans.app f j)), W (h₂.lift (cone.mk _ (c₁.π ≫ f)))

abbreviation stable_under_products_of_shape (W : morphism_property C) (J : Type*) : Prop :=
W.stable_under_limits_of_shape (discrete J)

@[simps]
def stable_under_products_of_shape.iso_aux {J D : Type*} [category D]
  (X : discrete J ⥤ D) (c : cone X) (hc : is_limit c)
  [has_product (λ j, X.obj (discrete.mk j))] :
  c.X ≅ ∏ (λ j, X.obj (discrete.mk j)) :=
{ hom := pi.lift (λ j, c.π.app (discrete.mk j)),
  inv := hc.lift (cone.mk (∏ (λ j, X.obj (discrete.mk j)))
    { app := by { rintro ⟨j⟩, exact pi.π _ j, },
    naturality' := begin
      rintro ⟨j₁⟩ ⟨j₂⟩ f,
      have h := discrete.eq_of_hom f,
      dsimp at h,
      subst h,
      simp only [subsingleton.elim f (𝟙 _), discrete.functor_map_id, id_comp, comp_id],
    end, }),
  hom_inv_id' := hc.hom_ext begin
    rintro ⟨j⟩,
    simp only [id_comp, assoc, is_limit.fac, limit.lift_π, fan.mk_π_app],
  end,
  inv_hom_id' := begin
    ext j,
    discrete_cases,
    simp only [id_comp, assoc, limit.lift_π, fan.mk_π_app, is_limit.fac],
  end, }

lemma stable_under_products_of_shape.mk (W : morphism_property C) (J : Type*)
  (hW₀ : W.respects_iso) [has_products_of_shape J C]
  (hW : ∀ (X₁ X₂ : J → C) (f : Π j, X₁ j ⟶ X₂ j) (hf : Π (j : J), W (f j)),
    W (pi.map f)) : W.stable_under_products_of_shape J :=
λ X₁ X₂ c₁ c₂ hc₁ hc₂ f hf, begin
  let Y₁ := λ j, X₁.obj (discrete.mk j),
  let Y₂ := λ j, X₂.obj (discrete.mk j),
  let φ : Π j, Y₁ j ⟶ Y₂ j := λ j, f.app (discrete.mk j),
  have hf' := hW Y₁ Y₂ φ (λ j, (hf (discrete.mk j))),
  refine (hW₀.arrow_mk_iso_iff _).mpr hf',
  refine arrow.iso_mk (stable_under_products_of_shape.iso_aux X₁ c₁ hc₁)
    (stable_under_products_of_shape.iso_aux X₂ c₂ hc₂) _,
  ext j,
  discrete_cases,
  dsimp,
  simp only [limit.lift_map, limit.lift_π, cones.postcompose_obj_π, nat_trans.comp_app,
    fan.mk_π_app, discrete.nat_trans_app, assoc, is_limit.fac],
end

class stable_under_finite_products (W : morphism_property C) : Prop :=
(condition [] : ∀ (J : Type) [finite J], stable_under_products_of_shape W J)

abbreviation stable_under_binary_products (W : morphism_property C) :=
  W.stable_under_products_of_shape walking_pair

namespace stable_under_products_of_shape

variable {W}

lemma lim_map {J : Type*} (h : W.stable_under_products_of_shape J) {X Y : discrete J ⥤ C}
  (f : X ⟶ Y) [has_products_of_shape J C]
  (hf : ∀ j, W (f.app (discrete.mk j))) : W (lim.map f) :=
h X Y _ _ (limit.is_limit X) (limit.is_limit Y) f
  (by { rintro ⟨j⟩, exact hf j, })

end stable_under_products_of_shape

end morphism_property

namespace localization

include L W

@[protected]
lemma has_products_of_shape (J : Type) [finite J] [W.contains_identities]
  [has_products_of_shape J C] (hW : W.stable_under_products_of_shape J) :
  has_products_of_shape J D :=
begin
  let G : C ⥤ _ := functor.const (discrete J),
  let F : ((discrete J) ⥤ C) ⥤ C := lim,
  let adj : G ⊣ F := const_lim_adj,
  let L' := (whiskering_right (discrete J) C D).obj L,
  let G' : D ⥤ _ := functor.const (discrete J),
  let W' := morphism_property.functor_category W (discrete J),
  have hF : W'.is_inverted_by (F ⋙ L),
  { intros X Y f hf,
    dsimp,
    exact localization.inverts L W (F.map f) (hW.lim_map f (λ j, hf (discrete.mk j))), },
  let F' := localization.lift (F ⋙ L) hF L',
  haveI : lifting L W (G ⋙ L') G' := ⟨L.comp_const (discrete J)⟩,
  exact has_limits_of_shape_of_adj (adj.localization L W L' W' G' F'),
end

@[protected]
lemma has_finite_products [W.contains_identities]
  [has_finite_products C] [W.stable_under_finite_products] :
  has_finite_products D :=
⟨λ n, by { exact localization.has_products_of_shape L W (fin n)
  (morphism_property.stable_under_finite_products.condition W (fin n)), }⟩

@[protected]
def preserves_products_of_shape (J : Type) [finite J] [W.contains_identities]
  [has_products_of_shape J C] (hW : W.stable_under_products_of_shape J) :
  preserves_limits_of_shape (discrete J) L :=
begin
  let G : C ⥤ _ := functor.const (discrete J),
  let F : ((discrete J) ⥤ C) ⥤ C := lim,
  let adj : G ⊣ F := const_lim_adj,
  let L' := (whiskering_right (discrete J) C D).obj L,
  let G' : D ⥤ _ := functor.const (discrete J),
  let W' := morphism_property.functor_category W (discrete J),
  have hF : W'.is_inverted_by (F ⋙ L),
  { intros X Y f hf,
    dsimp,
    exact localization.inverts L W (F.map f) (hW.lim_map f (λ j, hf (discrete.mk j))), },
  let F' := localization.lift (F ⋙ L) hF L',
  letI : lifting L W (G ⋙ L') G' := ⟨L.comp_const (discrete J)⟩,
  let adj' := adj.localization L W L' W' G' F',
  have h : ∀ (X : discrete J ⥤ C), adj.unit.app (F.obj X) ≫ F.map (adj.counit.app X) = 𝟙 (F.obj X),
  { intro X,
    exact adj.right_triangle_components, },
  haveI : ∀ (X : discrete J ⥤ C), is_iso ((limit_comparison_of_adj adj adj' L).app X),
  { intro X,
    dsimp only [limit_comparison_of_adj],
    simp only [adjunction.adjoint_nat_trans_equiv_app, adjunction.localization_unit_app, assoc,
      whiskering_right_obj_map, ← F'.map_comp, iso.inv_hom_id_app_assoc],
    erw [← nat_trans.naturality, ← assoc, ← L.map_comp],
    rw adj.right_triangle_components,
    apply_instance, },
  haveI : is_iso (limit_comparison_of_adj adj adj' L) := nat_iso.is_iso_of_is_iso_app _,
  exact preserves_limits_of_shape_of_adj adj adj' L,
end

instance localization_has_finite_products [W.contains_identities] [has_finite_products C]
  [W.stable_under_finite_products] : has_finite_products W.localization :=
  localization.has_finite_products W.Q W

instance [W.contains_identities] [has_finite_products C]
  [W.stable_under_finite_products] (J : Type) [finite J] :
  preserves_limits_of_shape (discrete J) W.Q :=
localization.preserves_products_of_shape W.Q W J
  (morphism_property.stable_under_finite_products.condition W J)

end localization

end category_theory


import rowround
import columnround

import category_theory.category.basic
import category_theory.core

open params
open operations
open quarterround
open rowround
open columnround
open utils

open category_theory

namespace doubleround

variables [category (bitvec word_len)]

/-!
  # Doubleround

  The `doubleround` function and the relation with its inverse.
-/

/-- doubleround(x) = rowround(columnround(x)) -/
@[simp] def doubleround (M : matrixType) : matrixType := rowround $ columnround M

/--  doubleround_inv(x) = columnround_inv(rowround_inv(x)) -/
@[simp] def doubleround_inv (M : matrixType) : matrixType := columnround_inv $ rowround_inv M

/- Just some notation for inverses. -/
local notation `doubleround⁻¹` := doubleround_inv

/-- The `doubleround` function is invertible. -/
lemma doubleround_is_inv (I : doubleround ≅ doubleround⁻¹) : I.hom ≫ I.inv = 𝟙 doubleround :=
  by rw [iso.hom_inv_id]

/--
A special case of `doubleround` where inputs and outputs are sorted according to the salsa20 spec:
doubleround'(x) = rowround'(columnround'(x)) -/
@[simp] def doubleround_salsa20 (M : matrixType) : matrixType := rowround_salsa20 $ columnround_salsa20 M

/--
A special case of `doubleround_inv` where inputs and outputs are sorted according to the salsa20 spec:
doubleround_inv'(x) = columnround_inv'(rowround_inv'(x)) -/
@[simp] def doubleround_salsa20_inv (M : matrixType) : matrixType := columnround_salsa20_inv $ rowround_salsa20_inv M

/- Just some notation for inverses. -/
local notation `doubleround_salsa20⁻¹` := doubleround_salsa20_inv

/-- The `doubleround` function is invertible. -/
lemma doubleround_salsa20_is_inv (I : doubleround_salsa20 ≅ doubleround_salsa20⁻¹) :
  I.hom ≫ I.inv = 𝟙 doubleround_salsa20 := by rw [iso.hom_inv_id]

end doubleround


import sli.sli model_checking.mc_bridge

namespace rmd_bridge
universe u
/-!
  **S** the type of a specification (the model that is interpreted by the STR)
    - if it is a string, then we have an inject function String → STR C A that will parse the string and instantiate the STR
    - if it is an program AST, the we have an inject function AST → STR C A that will instantiate the STR with the program AST
    - more generaly it can be any object type S for which we have an inject function S → STR C A
-/
variables (S C A E R V α : Type)

open sli
open sli.toTR
open model_checking

/-!
  # Debug semantics
-/

mutual inductive TraceEntry , DebugAction
with TraceEntry: Type
| root (c: C) (a: DebugAction)
| child (c: C) (a: DebugAction) (parent : TraceEntry)
with DebugAction : Type
| init
| step : A → DebugAction
| select : C → DebugAction
| jump : TraceEntry → DebugAction
| run_to_breakpoint : DebugAction

structure DebugConfig :=
  (current : option (TraceEntry C A))
  (history : set (TraceEntry C A))
  (options : option(DebugAction C A × set C))

/-!
  **BE** breakpoint expression type, which can be mapped to the semantics and the emptiness checking algorithm needed
  **Cp** configuration product, a configuration type, which in general is different from C.
    In practice it is the tuple (C, C₂), where C₂ is the configuration type needed by the breakpoint semantics
-/
def Finder (BE: Type)
:=
  STR C A → set C → BE → R → list C

def ote2c {C A : Type} : option (TraceEntry C A) → option C
| none := none
| (some (TraceEntry.root c _)) :=  c
| (some (TraceEntry.child c _ _)) := c

def rmdInitial
(o : STR C A) : set (DebugConfig C A) :=
  { { current := none, history := ∅, options := some (DebugAction.init, o.initial) } }

open DebugAction
def rmdActions
(o : STR C A) : DebugConfig C A → set (DebugAction C A)
| ⟨ current, history, options ⟩ :=
  let
    oa := { x : DebugAction C A | ∀ c, (options = none) → (ote2c current) = some c → ∀ a ∈ (o.actions c), x = step a },
    sa := { x : DebugAction C A | match options with | some (_, configs) := ∀ c ∈ configs, x = select c | none := false end },
    ja := { x : DebugAction C A | ∀ te ∈ history,                               x = jump te    },
    rtb := { x : DebugAction C A | match current with | some te := x = run_to_breakpoint | none := false end }
	in oa ∪ sa ∪ ja ∪ rtb

def same_configuration [decidable_eq C]: TraceEntry C A → C → bool
| (TraceEntry.root  c₁ _  ) c₂ := c₁ = c₂
| (TraceEntry.child c₁ _ _) c₂ := c₁ = c₂

/-!
  Attention:
- to the order of configurations in the counter example (start .. end) vs (end .. start).
  Here we suppose **(start .. end)**
- does the counter exemple contain the start configuration ?
  The same_configuration check removes the consecutive duplicates
-/
def trace2history {C A : Type} [decidable_eq C] : TraceEntry C A → DebugAction C A → list C → set (TraceEntry  C A) → TraceEntry C A × set (TraceEntry  C A)
| te da [] history := (te, history)
| te da (head::tail) history :=
  let
    te' := if (same_configuration C A te head) then te else (TraceEntry.child head da te),
    h := history ∪ { te' }
  in
   trace2history te' da tail h

def te2c {C A : Type} : TraceEntry C A → C
|  (TraceEntry.root c _) :=  c
|  (TraceEntry.child c _ _):= c

def rmdExecute {BE: Type}
  [decidable_eq C]
  (o : STR C A)
  (finder : Finder C A R BE) (breakpoint : BE) (reduction : R)
  :
  DebugAction C A → DebugConfig  C A → set (DebugConfig C A)
| (init) _                                                            :=  ∅ -- cannot get here
| (step a)            ⟨ (some (TraceEntry.root c da)), history, _ ⟩   := { ⟨ (TraceEntry.root c da), history, some (step a, o.execute a c) ⟩ }
| (step a)            ⟨ (some (TraceEntry.child c da p)), history, _⟩ := { ⟨ (TraceEntry.child c da p), history, some (step a, o.execute a c) ⟩ }
| (step a)            ⟨ _, _, _ ⟩                                     := ∅ -- cannot get here due to debugActions which produce steps only of current=some c
| (select c)          ⟨ none, history, some (da, _)⟩                  := (let te := (TraceEntry.root c da) in  { ⟨ te , { te } ∪ history, none ⟩ })
| (select c)          ⟨ some te, history, some(da, _)⟩                := (let te₁ := (TraceEntry.child c da te) in  { ⟨ te₁, { te₁ } ∪ history, none ⟩ })
| (select c)          ⟨ _, _, _ ⟩                                     := ∅ --cannot get here
| (jump te)           ⟨ _, history, _⟩                                := { ⟨ some te, history, none ⟩ }
| (run_to_breakpoint) ⟨ some te, history, opts ⟩                      :=
                                                                          let
                                                                            trace := finder o { (te2c te) } breakpoint reduction,
                                                                            patch := trace2history te run_to_breakpoint trace ∅
                                                                          in
                                                                            match patch with
                                                                            | (te, ch) := { ⟨ some te, history ∪ ch, none ⟩ }
                                                                            end
| (run_to_breakpoint) ⟨ _, _, _ ⟩                                     := ∅ --cannot get here

def ReducedMultiverseDebuggerBridge {BE: Type}
  [decidable_eq C]
  (o : STR C A)
  (finder : Finder C A R BE)
  (breakpoint : BE)
  (reduction : R)
  : STR (DebugConfig C A) (DebugAction C A) :=
{
  initial :=          rmdInitial C A o,
  actions := λ dc,    rmdActions C A o dc,
  execute := λ da dc, rmdExecute C A R o finder breakpoint reduction da dc
}

/-!
  # Replace the initial states of a STR, to make it start somewhere else
-/
def ReplaceInitial (o : STR C A) (initial : set C) : STR C A :=
{
  initial := initial,
  actions := o.actions,
  execute := o.execute,
}

def ReducedMultiverseDebugger {BE: Type}
  [decidable_eq C]
  (finder : Finder C A R BE)
  (inject: S → STR C A)
  (specification: S)
  (breakpoint : BE)
  (reduction : R)
: STR (DebugConfig C A) (DebugAction C A) :=
    ReducedMultiverseDebuggerBridge C A R (inject specification)
      finder breakpoint reduction

end rmd_bridge


/- Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johannes Hölzl

Introduce CommRing -- the category of commutative rings.

Currently only the basic setup.
-/

import category_theory.examples.monoids
import category_theory.embedding
import algebra.ring

universes u v

open category_theory

namespace category_theory.examples

/-- The category of rings. -/
@[reducible] def Ring : Type (u+1) := bundled ring

instance (x : Ring) : ring x := x.str

instance concrete_is_ring_hom : concrete_category @is_ring_hom :=
⟨by introsI α ia; apply_instance,
  by introsI α β γ ia ib ic f g hf hg; apply_instance⟩

instance Ring_hom_is_ring_hom {R S : Ring} (f : R ⟶ S) : is_ring_hom (f : R → S) := f.2

/-- The category of commutative rings. -/
@[reducible] def CommRing : Type (u+1) := bundled comm_ring

instance (x : CommRing) : comm_ring x := x.str

@[reducible] def is_comm_ring_hom {α β} [comm_ring α] [comm_ring β] (f : α → β) : Prop :=
is_ring_hom f

instance concrete_is_comm_ring_hom : concrete_category @is_comm_ring_hom :=
⟨by introsI α ia; apply_instance,
  by introsI α β γ ia ib ic f g hf hg; apply_instance⟩

instance CommRing_hom_is_comm_ring_hom {R S : CommRing} (f : R ⟶ S) : is_comm_ring_hom (f : R → S) := f.2

namespace CommRing
/-- The forgetful functor from commutative rings to (multiplicative) commutative monoids. -/
def forget_to_CommMon : CommRing ⥤ CommMon :=
concrete_functor
  (by intros _ c; exact { ..c })
  (by introsI _ _ _ _ f i;  exact { ..i })

instance : faithful (forget_to_CommMon) :=
begin
  tidy,
  apply (congr_fun h_1), -- TODO solve_by_elim should try this?
end

example : faithful (forget_to_CommMon ⋙ CommMon.forget_to_Mon) := by apply_instance
end CommRing

end category_theory.examples


import Mathlib.Tactic.FailIfNoProgress

section success

example : 1 = 1 := by fail_if_no_progress rfl
example (h : 1 = 1) : True := by
  fail_if_no_progress simp at h
  trivial

end success

section failure

example (x : Bool) (h : x = true) : x = true := by
  fail_if_success
    fail_if_no_progress simp
  exact h

example (x : Bool) (h : x = true) : True := by
  fail_if_success
    fail_if_no_progress simp at h
  trivial

end failure