/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Scott Morrison
-/
import category_theory.limits.shapes.equalizers
import category_theory.limits.shapes.finite_products
import category_theory.limits.preserves.shapes.products
import category_theory.limits.preserves.shapes.equalizers

/-!
# Constructing limits from products and equalizers.

If a category has all products, and all equalizers, then it has all limits.
Similarly, if it has all finite products, and all equalizers, then it has all finite limits.

If a functor preserves all products and equalizers, then it preserves all limits.
Similarly, if it preserves all finite products and equalizers, then it preserves all finite limits.

# TODO

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

open category_theory
open opposite

namespace category_theory.limits

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

variables {J : Type v} [small_category J]

-- We hide the "implementation details" inside a namespace
namespace has_limit_of_has_products_of_has_equalizers

variables {F : J ⥤ C}
          {c₁ : fan F.obj}
          {c₂ : fan (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.2)}
          (s t : c₁.X ⟶ c₂.X)
          (hs : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), s ≫ c₂.π.app f = c₁.π.app f.1.1 ≫ F.map f.2)
          (ht : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), t ≫ c₂.π.app f = c₁.π.app f.1.2)
          (i : fork s t)

include hs ht
/--
(Implementation) Given the appropriate product and equalizer cones, build the cone for `F` which is
limiting if the given cones are also.
-/
@[simps]
def build_limit : cone F :=
{ X := i.X,
  π :=
  { app := λ j, i.ι ≫ c₁.π.app _,
    naturality' := λ j₁ j₂ f, begin
      dsimp,
      rw [category.id_comp, category.assoc, ← hs ⟨⟨_, _⟩, f⟩, i.condition_assoc, ht],
    end} }

variable {i}
/--
(Implementation) Show the cone constructed in `build_limit` is limiting, provided the cones used in
its construction are.
-/
def build_is_limit (t₁ : is_limit c₁) (t₂ : is_limit c₂) (hi : is_limit i) :
  is_limit (build_limit s t hs ht i) :=
{ lift := λ q,
  begin
    refine hi.lift (fork.of_ι _ _),
    { refine t₁.lift (fan.mk _ (λ j, _)),
      apply q.π.app j },
    { apply t₂.hom_ext,
      simp [hs, ht] },
  end,
  uniq' := λ q m w, hi.hom_ext (i.equalizer_ext (t₁.hom_ext (by simpa using w))) }

end has_limit_of_has_products_of_has_equalizers

open has_limit_of_has_products_of_has_equalizers

/--
Given the existence of the appropriate (possibly finite) products and equalizers, we know a limit of
`F` exists.
(This assumes the existence of all equalizers, which is technically stronger than needed.)
-/
lemma has_limit_of_equalizer_and_product (F : J ⥤ C)
  [has_limit (discrete.functor F.obj)]
  [has_limit (discrete.functor (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.2))]
  [has_equalizers C] : has_limit F :=
has_limit.mk
{ cone := _,
  is_limit :=
    build_is_limit
      (pi.lift (λ f, limit.π _ _ ≫ F.map f.2))
      (pi.lift (λ f, limit.π _ f.1.2))
      (by simp)
      (by simp)
      (limit.is_limit _)
      (limit.is_limit _)
      (limit.is_limit _) }

/--
Any category with products and equalizers has all limits.

See https://stacks.math.columbia.edu/tag/002N.
-/
lemma limits_from_equalizers_and_products
  [has_products C] [has_equalizers C] : has_limits C :=
{ has_limits_of_shape := λ J 𝒥,
  { has_limit := λ F, by exactI has_limit_of_equalizer_and_product F } }

/--
Any category with finite products and equalizers has all finite limits.

See https://stacks.math.columbia.edu/tag/002O.
-/
lemma finite_limits_from_equalizers_and_finite_products
  [has_finite_products C] [has_equalizers C] : has_finite_limits C :=
⟨λ J _ _, { has_limit := λ F, by exactI has_limit_of_equalizer_and_product F }⟩

variables {D : Type u₂} [category.{v} D]
noncomputable theory

section

variables [has_limits_of_shape (discrete J) C]
          [has_limits_of_shape (discrete (Σ p : J × J, p.1 ⟶ p.2)) C]
          [has_equalizers C]
variables (G : C ⥤ D)
          [preserves_limits_of_shape walking_parallel_pair G]
          [preserves_limits_of_shape (discrete J) G]
          [preserves_limits_of_shape (discrete (Σ p : J × J, p.1 ⟶ p.2)) G]

/-- If a functor preserves equalizers and the appropriate products, it preserves limits. -/
def preserves_limit_of_preserves_equalizers_and_product :
  preserves_limits_of_shape J G :=
{ preserves_limit := λ K,
  begin
    let P := ∏ K.obj,
    let Q := ∏ (λ (f : (Σ (p : J × J), p.fst ⟶ p.snd)), K.obj f.1.2),
    let s : P ⟶ Q := pi.lift (λ f, limit.π _ _ ≫ K.map f.2),
    let t : P ⟶ Q := pi.lift (λ f, limit.π _ f.1.2),
    let I := equalizer s t,
    let i : I ⟶ P := equalizer.ι s t,
    apply preserves_limit_of_preserves_limit_cone
      (build_is_limit s t (by simp) (by simp)
        (limit.is_limit _)
        (limit.is_limit _)
        (limit.is_limit _)),
    refine is_limit.of_iso_limit (build_is_limit _ _ _ _ _ _ _) _,
    { exact fan.mk _ (λ j, G.map (pi.π _ j)) },
    { exact fan.mk (G.obj Q) (λ f, G.map (pi.π _ f)) },
    { apply G.map s },
    { apply G.map t },
    { intro f,
      dsimp,
      simp only [←G.map_comp, limit.lift_π, fan.mk_π_app] },
    { intro f,
      dsimp,
      simp only [←G.map_comp, limit.lift_π, fan.mk_π_app] },
    { apply fork.of_ι (G.map i) _,
      simp only [← G.map_comp, equalizer.condition] },
    { apply is_limit_of_has_product_of_preserves_limit },
    { apply is_limit_of_has_product_of_preserves_limit },
    { apply is_limit_fork_map_of_is_limit,
      apply equalizer_is_equalizer },
    refine cones.ext (iso.refl _) _,
    intro j,
    dsimp,
    simp, -- See note [dsimp, simp].
  end }
end

/-- If G preserves equalizers and finite products, it preserves finite limits. -/
def preserves_finite_limits_of_preserves_equalizers_and_finite_products
  [has_equalizers C] [has_finite_products C]
  (G : C ⥤ D) [preserves_limits_of_shape walking_parallel_pair G]
  [∀ J [fintype J], preserves_limits_of_shape (discrete J) G]
  (J : Type v) [small_category J] [fin_category J] :
preserves_limits_of_shape J G :=
preserves_limit_of_preserves_equalizers_and_product G

/-- If G preserves equalizers and products, it preserves all limits. -/
def preserves_limits_of_preserves_equalizers_and_products
  [has_equalizers C] [has_products C]
  (G : C ⥤ D) [preserves_limits_of_shape walking_parallel_pair G]
  [∀ J, preserves_limits_of_shape (discrete J) G] :
preserves_limits G :=
{ preserves_limits_of_shape := λ J 𝒥,
  by exactI preserves_limit_of_preserves_equalizers_and_product G }

/-!
We now dualize the above constructions, resorting to copy-paste.
-/

-- We hide the "implementation details" inside a namespace
namespace has_colimit_of_has_coproducts_of_has_coequalizers

variables {F : J ⥤ C}
          {c₁ : cofan (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.1)}
          {c₂ : cofan F.obj}
          (s t : c₁.X ⟶ c₂.X)
          (hs : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), c₁.ι.app f ≫ s = F.map f.2 ≫ c₂.ι.app f.1.2)
          (ht : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), c₁.ι.app f ≫ t = c₂.ι.app f.1.1)
          (i : cofork s t)

include hs ht
/--
(Implementation) Given the appropriate coproduct and coequalizer cocones,
build the cocone for `F` which is colimiting if the given cocones are also.
-/
@[simps]
def build_colimit : cocone F :=
{ X := i.X,
  ι :=
  { app := λ j, c₂.ι.app _ ≫ i.π,
    naturality' := λ j₁ j₂ f, begin
      dsimp,
      rw [category.comp_id, ←reassoc_of (hs ⟨⟨_, _⟩, f⟩), i.condition, ←category.assoc, ht],
    end} }

variable {i}
/--
(Implementation) Show the cocone constructed in `build_colimit` is colimiting,
provided the cocones used in its construction are.
-/
def build_is_colimit (t₁ : is_colimit c₁) (t₂ : is_colimit c₂) (hi : is_colimit i) :
  is_colimit (build_colimit s t hs ht i) :=
{ desc := λ q,
  begin
    refine hi.desc (cofork.of_π _ _),
    { refine t₂.desc (cofan.mk _ (λ j, _)),
      apply q.ι.app j },
    { apply t₁.hom_ext,
      simp [reassoc_of hs, reassoc_of ht] },
  end,
  uniq' := λ q m w, hi.hom_ext (i.coequalizer_ext (t₂.hom_ext (by simpa using w))) }

end has_colimit_of_has_coproducts_of_has_coequalizers

open has_colimit_of_has_coproducts_of_has_coequalizers

/--
Given the existence of the appropriate (possibly finite) coproducts and coequalizers,
we know a colimit of `F` exists.
(This assumes the existence of all coequalizers, which is technically stronger than needed.)
-/
lemma has_colimit_of_coequalizer_and_coproduct (F : J ⥤ C)
  [has_colimit (discrete.functor F.obj)]
  [has_colimit (discrete.functor (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.1))]
  [has_coequalizers C] : has_colimit F :=
has_colimit.mk
{ cocone := _,
  is_colimit :=
    build_is_colimit
      (sigma.desc (λ f, F.map f.2 ≫ colimit.ι (discrete.functor F.obj) f.1.2))
      (sigma.desc (λ f, colimit.ι (discrete.functor F.obj) f.1.1))
      (by simp)
      (by simp)
      (colimit.is_colimit _)
      (colimit.is_colimit _)
      (colimit.is_colimit _) }

/--
Any category with coproducts and coequalizers has all colimits.

See https://stacks.math.columbia.edu/tag/002P.
-/
lemma colimits_from_coequalizers_and_coproducts
  [has_products C] [has_equalizers C] : has_limits C :=
{ has_limits_of_shape := λ J 𝒥,
  { has_limit := λ F, by exactI has_limit_of_equalizer_and_product F } }

/--
Any category with finite coproducts and coequalizers has all finite colimits.

See https://stacks.math.columbia.edu/tag/002Q.
-/
lemma finite_colimits_from_coequalizers_and_finite_coproducts
  [has_finite_coproducts C] [has_coequalizers C] : has_finite_colimits C :=
⟨λ J _ _, { has_colimit := λ F, by exactI has_colimit_of_coequalizer_and_coproduct F }⟩

noncomputable theory

section

variables [has_colimits_of_shape (discrete J) C]
          [has_colimits_of_shape (discrete (Σ p : J × J, p.1 ⟶ p.2)) C]
          [has_coequalizers C]
variables (G : C ⥤ D)
          [preserves_colimits_of_shape walking_parallel_pair G]
          [preserves_colimits_of_shape (discrete J) G]
          [preserves_colimits_of_shape (discrete (Σ p : J × J, p.1 ⟶ p.2)) G]

/-- If a functor preserves coequalizers and the appropriate coproducts, it preserves colimits. -/
def preserves_colimit_of_preserves_coequalizers_and_coproduct :
  preserves_colimits_of_shape J G :=
{ preserves_colimit := λ K,
  begin
    let P := ∐ K.obj,
    let Q := ∐ (λ (f : (Σ (p : J × J), p.fst ⟶ p.snd)), K.obj f.1.1),
    let s : Q ⟶ P := sigma.desc (λ f, K.map f.2 ≫ colimit.ι (discrete.functor K.obj) _),
    let t : Q ⟶ P := sigma.desc (λ f, colimit.ι (discrete.functor K.obj) f.1.1),
    let I := coequalizer s t,
    let i : P ⟶ I := coequalizer.π s t,
    apply preserves_colimit_of_preserves_colimit_cocone
      (build_is_colimit s t (by simp) (by simp)
        (colimit.is_colimit _)
        (colimit.is_colimit _)
        (colimit.is_colimit _)),
    refine is_colimit.of_iso_colimit (build_is_colimit _ _ _ _ _ _ _) _,
    { exact cofan.mk (G.obj Q) (λ j, G.map (sigma.ι _ j)) },
    { exact cofan.mk _ (λ f, G.map (sigma.ι _ f)) },
    { apply G.map s },
    { apply G.map t },
    { intro f,
      dsimp,
      simp only [←G.map_comp, colimit.ι_desc, cofan.mk_ι_app] },
    { intro f,
      dsimp,
      simp only [←G.map_comp, colimit.ι_desc, cofan.mk_ι_app] },
    { apply cofork.of_π (G.map i) _,
      simp only [← G.map_comp, coequalizer.condition] },
    { apply is_colimit_of_has_coproduct_of_preserves_colimit },
    { apply is_colimit_of_has_coproduct_of_preserves_colimit },
    { apply is_colimit_cofork_map_of_is_colimit,
      apply coequalizer_is_coequalizer },
    refine cocones.ext (iso.refl _) _,
    intro j,
    dsimp,
    simp, -- See note [dsimp, simp].
  end }
end

/-- If G preserves coequalizers and finite coproducts, it preserves finite colimits. -/
def preserves_finite_colimits_of_preserves_coequalizers_and_finite_coproducts
  [has_coequalizers C] [has_finite_coproducts C]
  (G : C ⥤ D) [preserves_colimits_of_shape walking_parallel_pair G]
  [∀ J [fintype J], preserves_colimits_of_shape (discrete J) G]
  (J : Type v) [small_category J] [fin_category J] :
preserves_colimits_of_shape J G :=
preserves_colimit_of_preserves_coequalizers_and_coproduct G

/-- If G preserves coequalizers and coproducts, it preserves all colimits. -/
def preserves_colimits_of_preserves_coequalizers_and_coproducts
  [has_coequalizers C] [has_coproducts C]
  (G : C ⥤ D) [preserves_colimits_of_shape walking_parallel_pair G]
  [∀ J, preserves_colimits_of_shape (discrete J) G] :
preserves_colimits G :=
{ preserves_colimits_of_shape := λ J 𝒥,
  by exactI preserves_colimit_of_preserves_coequalizers_and_coproduct G }

end category_theory.limits


-- set_option trace.Elab.info true

theorem test (p q : Prop) (hp : p) (hq : q) : p ∧ q ∧ p := by
  apply And.intro
  case right =>
    apply And.intro
    case left => exact hq
    case right => exact hp
  case left => exact hp


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

import algebraic_topology.dold_kan.gamma_comp_n
import algebraic_topology.dold_kan.n_reflects_iso

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

In order to construct the unit isomorphism of the Dold-Kan equivalence,
we first construct natural transformations
`Γ₂N₁.nat_trans : N₁ ⋙ Γ₂ ⟶ to_karoubi (simplicial_object C)` and
`Γ₂N₂.nat_trans : N₂ ⋙ Γ₂ ⟶ 𝟭 (simplicial_object C)`.
It is then shown that `Γ₂N₂.nat_trans` is an isomorphism by using
that it becomes an isomorphism after the application of the functor
`N₂ : karoubi (simplicial_object C) ⥤ karoubi (chain_complex C ℕ)`
which reflects isomorphisms.

-/

noncomputable theory

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

namespace algebraic_topology

namespace dold_kan

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

lemma P_infty_comp_map_mono_eq_zero (X : simplicial_object C) {n : ℕ}
  {Δ' : simplex_category} (i : Δ' ⟶ [n]) [hi : mono i] (h₁ : Δ'.len ≠ n) (h₂ : ¬is_δ₀ i) :
  P_infty.f n ≫ X.map i.op = 0 :=
begin
  unfreezingI { induction Δ' using simplex_category.rec with m, },
  obtain ⟨k, hk⟩ := nat.exists_eq_add_of_lt (len_lt_of_mono i
    (λ h, by { rw ← h at h₁,  exact h₁ rfl, })),
  simp only [len_mk] at hk,
  cases k,
  { change n = m + 1 at hk,
    unfreezingI { subst hk, obtain ⟨j, rfl⟩ := eq_δ_of_mono i, },
    rw is_δ₀.iff at h₂,
    have h₃ : 1 ≤ (j : ℕ),
    { by_contra,
      exact h₂ (by simpa only [fin.ext_iff, not_le, nat.lt_one_iff] using h), },
    exact (higher_faces_vanish.of_P (m+1) m).comp_δ_eq_zero j h₂ (by linarith), },
  { simp only [nat.succ_eq_add_one, ← add_assoc] at hk,
    clear h₂ hi,
    subst hk,
    obtain ⟨j₁, i, rfl⟩ := eq_comp_δ_of_not_surjective i (λ h, begin
      have h' := len_le_of_epi (simplex_category.epi_iff_surjective.2 h),
      dsimp at h',
      linarith,
    end),
    obtain ⟨j₂, i, rfl⟩ := eq_comp_δ_of_not_surjective i (λ h, begin
      have h' := len_le_of_epi (simplex_category.epi_iff_surjective.2 h),
      dsimp at h',
      linarith,
    end),
    by_cases hj₁ : j₁ = 0,
    { unfreezingI { subst hj₁, },
      rw [assoc, ← simplex_category.δ_comp_δ'' (fin.zero_le _)],
      simp only [op_comp, X.map_comp, assoc, P_infty_f],
      erw [(higher_faces_vanish.of_P _ _).comp_δ_eq_zero_assoc _ j₂.succ_ne_zero, zero_comp],
      rw fin.coe_succ,
      linarith, },
    { simp only [op_comp, X.map_comp, assoc, P_infty_f],
      erw [(higher_faces_vanish.of_P _ _).comp_δ_eq_zero_assoc _ hj₁, zero_comp],
      by_contra,
      exact hj₁ (by { simp only [fin.ext_iff, fin.coe_zero], linarith, }), }, },
end

@[reassoc]
lemma Γ₀_obj_termwise_map_mono_comp_P_infty (X : simplicial_object C) {Δ Δ' : simplex_category}
  (i : Δ ⟶ Δ') [mono i] :
  Γ₀.obj.termwise.map_mono (alternating_face_map_complex.obj X) i ≫ P_infty.f (Δ.len) =
    P_infty.f (Δ'.len) ≫ X.map i.op :=
begin
  unfreezingI
  { induction Δ using simplex_category.rec with n,
    induction Δ' using simplex_category.rec with n', },
  dsimp,
  /- We start with the case `i` is an identity -/
  by_cases n = n',
  { unfreezingI { subst h, },
    simp only [simplex_category.eq_id_of_mono i, Γ₀.obj.termwise.map_mono_id, op_id, X.map_id],
    dsimp,
    simp only [id_comp, comp_id], },
  by_cases hi : is_δ₀ i,
  /- The case `i = δ 0` -/
  { have h' : n' = n + 1 := hi.left,
    unfreezingI { subst h', },
    simp only [Γ₀.obj.termwise.map_mono_δ₀' _ i hi],
    dsimp,
    rw [← P_infty.comm' _ n rfl, alternating_face_map_complex.obj_d_eq],
    simp only [eq_self_iff_true, id_comp, if_true, preadditive.comp_sum],
    rw finset.sum_eq_single (0 : fin (n+2)), rotate,
    { intros b hb hb',
      rw preadditive.comp_zsmul,
      erw [P_infty_comp_map_mono_eq_zero X (simplex_category.δ b) h
        (by { rw is_δ₀.iff, exact hb', }), zsmul_zero], },
    { simp only [finset.mem_univ, not_true, is_empty.forall_iff], },
    { simpa only [hi.eq_δ₀, fin.coe_zero, pow_zero, one_zsmul], }, },
  /- The case `i ≠ δ 0` -/
  { rw [Γ₀.obj.termwise.map_mono_eq_zero _ i _ hi, zero_comp], swap,
    { by_contradiction h',
      exact h (congr_arg simplex_category.len h'.symm), },
    rw P_infty_comp_map_mono_eq_zero,
    { exact h, },
    { by_contradiction h',
      exact hi h', }, },
end

variable [has_finite_coproducts C]

namespace Γ₂N₁

/-- The natural transformation `N₁ ⋙ Γ₂ ⟶ to_karoubi (simplicial_object C)`. -/
@[simps]
def nat_trans : (N₁ : simplicial_object C ⥤ _) ⋙ Γ₂ ⟶ to_karoubi _ :=
{ app := λ X,
  { f :=
    { app := λ Δ, (Γ₀.splitting K[X]).desc Δ (λ A, P_infty.f A.1.unop.len ≫ X.map (A.e.op)),
      naturality' := λ Δ Δ' θ, begin
        apply (Γ₀.splitting K[X]).hom_ext',
        intro A,
        change _ ≫ (Γ₀.obj K[X]).map θ  ≫ _ = _,
        simp only [splitting.ι_desc_assoc, assoc,
          Γ₀.obj.map_on_summand'_assoc, splitting.ι_desc],
        erw Γ₀_obj_termwise_map_mono_comp_P_infty_assoc X (image.ι (θ.unop ≫ A.e)),
        dsimp only [to_karoubi],
        simp only [← X.map_comp],
        congr' 2,
        simp only [eq_to_hom_refl, id_comp, comp_id, ← op_comp],
        exact quiver.hom.unop_inj (A.fac_pull θ),
      end, },
    comm := begin
      apply (Γ₀.splitting K[X]).hom_ext,
      intro n,
      dsimp [N₁],
      simp only [← splitting.ι_summand_id, splitting.ι_desc,
        comp_id, splitting.ι_desc_assoc, assoc, P_infty_f_idem_assoc],
    end, },
  naturality' := λ X Y f, begin
    ext1,
    apply (Γ₀.splitting K[X]).hom_ext,
    intro n,
    dsimp [N₁, to_karoubi],
    simpa only [←splitting.ι_summand_id, splitting.ι_desc, splitting.ι_desc_assoc,
      assoc, P_infty_f_idem_assoc, karoubi.comp_f, nat_trans.comp_app, Γ₂_map_f_app,
      homological_complex.comp_f, alternating_face_map_complex.map_f,
      P_infty_f_naturality_assoc, nat_trans.naturality],
  end, }

end Γ₂N₁

/-- The compatibility isomorphism relating `N₂ ⋙ Γ₂` and `N₁ ⋙ Γ₂`. -/
@[simps]
def compatibility_Γ₂N₁_Γ₂N₂ : to_karoubi (simplicial_object C) ⋙ N₂ ⋙ Γ₂ ≅ N₁ ⋙ Γ₂ :=
eq_to_iso (functor.congr_obj (functor_extension₁_comp_whiskering_left_to_karoubi _ _) (N₁ ⋙ Γ₂))

namespace Γ₂N₂

/-- The natural transformation `N₂ ⋙ Γ₂ ⟶ 𝟭 (simplicial_object C)`. -/
def nat_trans : (N₂ : karoubi (simplicial_object C) ⥤ _) ⋙ Γ₂ ⟶ 𝟭 _ :=
((whiskering_left _ _ _).obj _).preimage (compatibility_Γ₂N₁_Γ₂N₂.hom ≫ Γ₂N₁.nat_trans)

lemma nat_trans_app_f_app (P : karoubi (simplicial_object C)) :
  Γ₂N₂.nat_trans.app P = (N₂ ⋙ Γ₂).map P.decomp_id_i ≫
    (compatibility_Γ₂N₁_Γ₂N₂.hom ≫ Γ₂N₁.nat_trans).app P.X ≫ P.decomp_id_p :=
whiskering_left_obj_preimage_app ((compatibility_Γ₂N₁_Γ₂N₂.hom ≫ Γ₂N₁.nat_trans)) P

end Γ₂N₂

lemma compatibility_Γ₂N₁_Γ₂N₂_nat_trans (X : simplicial_object C) :
  Γ₂N₁.nat_trans.app X = (compatibility_Γ₂N₁_Γ₂N₂.app X).inv ≫
    Γ₂N₂.nat_trans.app ((to_karoubi _).obj X) :=
begin
  rw [← cancel_epi (compatibility_Γ₂N₁_Γ₂N₂.app X).hom, iso.hom_inv_id_assoc],
  exact congr_app (((whiskering_left _ _ _).obj _).image_preimage
    (compatibility_Γ₂N₁_Γ₂N₂.hom ≫ Γ₂N₁.nat_trans : _ ⟶ to_karoubi _ ⋙ 𝟭 _ )).symm X,
end

lemma identity_N₂_objectwise (P : karoubi (simplicial_object C)) :
  N₂Γ₂.inv.app (N₂.obj P) ≫ N₂.map (Γ₂N₂.nat_trans.app P) = 𝟙 (N₂.obj P) :=
begin
  ext n,
  have eq₁ : (N₂Γ₂.inv.app (N₂.obj P)).f.f n = P_infty.f n ≫ P.p.app (op [n]) ≫
    (Γ₀.splitting (N₂.obj P).X).ι_summand (splitting.index_set.id (op [n])),
  { simp only [N₂Γ₂_inv_app_f_f, N₂_obj_p_f, assoc], },
  have eq₂ : (Γ₀.splitting (N₂.obj P).X).ι_summand (splitting.index_set.id (op [n])) ≫
    (N₂.map (Γ₂N₂.nat_trans.app P)).f.f n = P_infty.f n ≫ P.p.app (op [n]),
  { dsimp [N₂],
    simp only [Γ₂N₂.nat_trans_app_f_app, P_infty_on_Γ₀_splitting_summand_eq_self_assoc,
      functor.comp_map, compatibility_Γ₂N₁_Γ₂N₂_hom, nat_trans.comp_app,
      eq_to_hom_app, assoc, karoubi.comp_f, karoubi.eq_to_hom_f, eq_to_hom_refl, comp_id,
      karoubi.decomp_id_p_f, karoubi.comp_p_assoc, Γ₂_map_f_app,
      N₂_map_f_f, karoubi.decomp_id_i_f, Γ₂N₁.nat_trans_app_f_app],
    erw [splitting.ι_desc_assoc, assoc, assoc, splitting.ι_desc_assoc],
    dsimp [splitting.index_set.id, splitting.index_set.e],
    simp only [assoc, nat_trans.naturality, P_infty_f_naturality_assoc,
      app_idem_assoc, P_infty_f_idem_assoc],
    erw [P.X.map_id, comp_id], },
  simp only [karoubi.comp_f, homological_complex.comp_f, karoubi.id_eq, N₂_obj_p_f, assoc,
    eq₁, eq₂, P_infty_f_naturality_assoc, app_idem, P_infty_f_idem_assoc],
end

lemma identity_N₂ :
  ((𝟙 (N₂ : karoubi (simplicial_object C) ⥤ _ ) ◫ N₂Γ₂.inv) ≫
    (Γ₂N₂.nat_trans ◫ 𝟙 N₂) : N₂ ⟶ N₂) = 𝟙 N₂ :=
by { ext P : 2, dsimp, rw [Γ₂.map_id, N₂.map_id, comp_id, id_comp, identity_N₂_objectwise P], }

instance : is_iso (Γ₂N₂.nat_trans : (N₂ : karoubi (simplicial_object C) ⥤ _ ) ⋙ _ ⟶ _) :=
begin
  haveI : ∀ (P : karoubi (simplicial_object C)), is_iso (Γ₂N₂.nat_trans.app P),
  { intro P,
    haveI : is_iso (N₂.map (Γ₂N₂.nat_trans.app P)),
    { have h := identity_N₂_objectwise P,
      erw hom_comp_eq_id at h,
      rw h,
      apply_instance, },
    exact is_iso_of_reflects_iso _ N₂, },
  apply nat_iso.is_iso_of_is_iso_app,
end

instance : is_iso (Γ₂N₁.nat_trans : (N₁ : simplicial_object C ⥤ _ ) ⋙ _ ⟶ _) :=
begin
  haveI : ∀ (X : simplicial_object C), is_iso (Γ₂N₁.nat_trans.app X),
  { intro X,
    rw compatibility_Γ₂N₁_Γ₂N₂_nat_trans,
    apply_instance, },
  apply nat_iso.is_iso_of_is_iso_app,
end

/-- The unit isomorphism of the Dold-Kan equivalence. -/
@[simp]
def Γ₂N₂ : 𝟭 _ ≅ (N₂ : karoubi (simplicial_object C) ⥤ _) ⋙ Γ₂ :=
(as_iso Γ₂N₂.nat_trans).symm

/-- The natural isomorphism `to_karoubi (simplicial_object C) ≅ N₁ ⋙ Γ₂`. -/
@[simps]
def Γ₂N₁ : to_karoubi _  ≅ (N₁ : simplicial_object C ⥤ _) ⋙ Γ₂ :=
(as_iso Γ₂N₁.nat_trans).symm

end dold_kan

end algebraic_topology


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import algebra.field.defs
import algebra.ring.opposite
import data.int.cast.lemmas

/-!
# Field structure on the multiplicative/additive opposite

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

variables (α : Type*)

namespace mul_opposite

@[to_additive] instance [has_rat_cast α] : has_rat_cast αᵐᵒᵖ := ⟨λ n, op n⟩

variables {α}

@[simp, norm_cast, to_additive]
lemma op_rat_cast [has_rat_cast α] (q : ℚ) : op (q : α) = q := rfl

@[simp, norm_cast, to_additive]
lemma unop_rat_cast [has_rat_cast α] (q : ℚ) : unop (q : αᵐᵒᵖ) = q := rfl

variables (α)

instance [division_semiring α] : division_semiring αᵐᵒᵖ :=
{ .. mul_opposite.group_with_zero α, .. mul_opposite.semiring α }

instance [division_ring α] : division_ring αᵐᵒᵖ :=
{ rat_cast := λ q, op q,
  rat_cast_mk := λ a b hb h, by { rw [rat.cast_def, op_div, op_nat_cast, op_int_cast],
    exact int.commute_cast _ _ },
  ..mul_opposite.division_semiring α, ..mul_opposite.ring α }

instance [semifield α] : semifield αᵐᵒᵖ :=
{ .. mul_opposite.division_semiring α, .. mul_opposite.comm_semiring α }

instance [field α] : field αᵐᵒᵖ :=
{ .. mul_opposite.division_ring α, .. mul_opposite.comm_ring α }

end mul_opposite

namespace add_opposite

instance [division_semiring α] : division_semiring αᵃᵒᵖ :=
{ ..add_opposite.group_with_zero α, ..add_opposite.semiring α }

instance [division_ring α] : division_ring αᵃᵒᵖ :=
{ rat_cast_mk := λ a b hb h, by rw ←div_eq_mul_inv; exact congr_arg op (rat.cast_def _),
  ..add_opposite.ring α, ..add_opposite.group_with_zero α, ..add_opposite.has_rat_cast α }

instance [semifield α] : semifield αᵃᵒᵖ :=
{ ..add_opposite.division_semiring α, ..add_opposite.comm_semiring α }

instance [field α] : field αᵃᵒᵖ :=
{ ..add_opposite.division_ring α, ..add_opposite.comm_ring α }

end add_opposite


import unitb.code.syntax
import unitb.code.rules

import util.predicate

universe variables u v

open nat predicate

section

parameters (σ : Type) (lbl : Type)

@[reducible]
private def pred := σ → Prop

parameters {σ}

lemma assert_of_first {p q : pred} {c : code lbl p q}
: assert_of (first c) = p :=
begin
  induction c
  ; try { refl },
  case code.seq  p' q' r' c₀ c₁
  { unfold first,
    destruct first c₀,
    case none
    { intro h,
      simp [h],
      destruct first c₁,
      case none
      { intro h',
        simp [h'], unfold assert_of,
        simp [h'] at ih_2, unfold assert_of at ih_2,
        simp [h] at ih_1, unfold assert_of at ih_1,
        subst r', subst q' },
      case some
      { intros x h', simp [h'],
        unfold assert_of assert_of',
        rw h at ih_1, rw h' at ih_2,
        unfold assert_of at ih_1 ih_2,
        subst p', rw ih_2, } },
    case some
    { intros x h,
      simp [h],
      unfold assert_of assert_of',
      rw h at ih_1, unfold assert_of at ih_1,
      rw ih_1 }, }
end

lemma first_eq_none_imp_eq {p q : pred} {c : code lbl p q}
: first c = none → p = q :=
begin
  induction c
  ; unfold first
  ; try { contradiction },
  case code.skip
  { simp },
  case code.seq p' q' r' c₀ c₁
  { destruct first c₀,
    case none
    { intro h', simp [h'],
      intro h'', rw [ih_1 h',ih_2 h''], },
    case some
    { intros pc h,
      simp [h], contradiction }, },
end

local attribute [instance] classical.prop_decidable

lemma assert_of_next {p q : pred} {c : code lbl p q} (pc : option (current c)) (s : σ)
: assert_of (next s pc) = next_assert pc s :=
begin
  cases pc with pc,
  { refl },
  unfold next next_assert,
  induction pc
  ; try { refl }
  ; unfold next' next_assert',
  case current.seq_left
  { rw ← ih_1,
    cases next' s a,
    case none
    { destruct first c₁,
      case none
      { intros h₀,
        simp [h₀],
        unfold assert_of,
        cases c₁ ; try { refl }
        ; unfold first at h₀
        ; try { contradiction },
        { simp at h₀,
          simp [first_eq_none_imp_eq h₀.left,first_eq_none_imp_eq  h₀.right] }, },
      case some
      { intros pc h₀,
        simp,
        rw [h₀,fmap_some],
        unfold assert_of assert_of',
        change assert_of (some pc) = _,
        rw [← h₀,assert_of_first] } },
    case some
    { simp, refl } },
  case current.seq_right
  { rw ← ih_1,
    cases next' s a ; refl },
  case current.ite_cond
  { cases classical.em (t s) with h h,
    { rw [if_pos h,if_pos h],
      destruct first c₀,
      { intros h, simp [h], have h := first_eq_none_imp_eq h,
        unfold assert_of, subst pa },
      { intros pc h, simp [h],
        unfold assert_of assert_of',
        change assert_of (some pc) = _,
        rw [← h,assert_of_first], }, },
    { rw [if_neg h,if_neg h],
      destruct first c₁,
      { intros h, simp [h],
        have h := first_eq_none_imp_eq h,
        unfold assert_of, subst pb },
      { intros pc h, simp [h],
        unfold assert_of assert_of',
        change assert_of (some pc) = _,
        rw [← h,assert_of_first], }, }, },
  case current.ite_left
  { rw ← ih_1, clear ih_1,
    cases next' s a with pc ; simp,
    { refl },
    { unfold assert_of assert_of', }, },
  case current.ite_right
  { rw ← ih_1, clear ih_1,
    cases next' s a with pc ; simp,
    { refl },
    { unfold assert_of assert_of', }, },
  case current.while_cond
  { cases classical.em (w s) with h h ;
    destruct first c_1,
    { intro h',
      rw [if_pos h,if_pos h,h'],
      have h'' := first_eq_none_imp_eq h', subst inv,
      refl, },
    { intros pc h',
      rw [if_pos h,if_pos h,h'],
      simp,
      change assert_of (some pc) = _,
      rw [← h',assert_of_first], },
    { intros h',
      rw [if_neg h,if_neg h], refl },
    { intros pc h',
      rw [if_neg h,if_neg h], refl }, },
  case current.while_body
  { rw ← ih_1, clear ih_1,
    destruct next' s a,
    { intros h',
      simp [h'], refl },
    { intros pc h',
      simp [h'], refl }, },
end

end

section local_correctness

local attribute [instance] classical.prop_decidable

parameters (σ : Type)

parameters (F : nondet.program σ)

@[reducible]
private def lbl := F.lbl

@[reducible]
private def pred := σ → Prop

parameters {σ}

variables {p q : pred}
variable (c : code lbl p q)

structure state_correctness (pc : option $ current c) : Prop :=
  (enabled : ∀ l, selects pc l → assert_of pc ⟹ F.guard (some l))
  (correct : ∀ l, selects pc l →
       ∀ s s', assert_of pc s → F.step_of (some l) s s' → next_assert pc s s')
  (cond_true : ∀ (H : is_control pc),
       ∀ s, assert_of pc s → condition pc H s → next_assert pc s s)
  (cond_false : ∀ (H : is_control pc),
       ∀ s, assert_of pc s → ¬ condition pc H s → next_assert pc s s)

lemma selects_action_imp_eq {l l' : lbl} {p q : pred} {ds : set lbl}
  (pc : option (current $ code.action p q ds l))
  (H : selects pc l')
: l' = l :=
begin
  cases pc with pc,
  { cases H },
  { cases pc, apply H, },
end

lemma selects_and_selects_imp_eq {l l' : lbl} {p q : pred}
  {c : code lbl p q}
  {pc : option (current c)}
  (H  : selects pc l)
  (H' : selects pc l')
: l' = l :=
sorry

lemma assert_of_action {l : lbl} {p q : pred} {ds : set lbl}
  (pc : current $ code.action p q ds l)
: assert_of (some pc) = p :=
begin
  cases pc with pc, refl,
end

lemma next_assert_action {l : lbl} {p q : pred} {ds : set lbl}
  (pc : current $ code.action p q ds l)
  (s : σ)
: next_assert (some pc) s = q :=
begin
  cases pc with pc, refl,
end

section

variables H : correct F c
include H

lemma enabled_of_correct
: ∀ (pc : current c) l, selects (some pc) l → assert_of (some pc) ⟹ F.guard (some l) :=
begin
  induction H,
  { intros pc l Hpc, cases pc, },
  { intros pc l' Hpc, cases pc with pc,
    have Heq_l := selects_action_imp_eq _ Hpc, subst l',
    unfold assert_of assert_of', apply a },
  { intros pc l',
    cases pc with pc pc
    ; unfold selects assert_of selects' assert_of'
    ; intros Hpc,
    { apply ih_1 _ _ Hpc },
    { apply ih_2 _ _ Hpc }, },
  { intros pc l',
    cases pc with pc pc
    ; unfold selects assert_of selects' assert_of'
    ; intros Hpc,
    { cases Hpc },
    { apply ih_1 _ _ Hpc },
    { apply ih_2 _ _ Hpc }, },
  { intros pc l',
    cases pc with pc pc
    ; unfold selects assert_of selects' assert_of'
    ; intros Hpc,
    { cases Hpc },
    { apply ih_1 _ _ Hpc }, },
end

lemma correct_of_correct
: ∀ (pc : current c) l, selects (some pc) l →
       ∀ s s', assert_of (some pc) s → F.step_of (some l) s s' → next_assert (some pc) s s' :=
begin
  induction H,
  { intros pc l Hpc, cases pc, },
  { intros pc l' Hpc, cases pc with pc,
    have Heq_l := selects_action_imp_eq _ Hpc, subst l',
    unfold assert_of assert_of', apply a_1 },
  { intros pc l',
    cases pc with pc pc
    ; unfold selects assert_of selects' assert_of'
    ; intros Hpc,
    { apply ih_1 _ _ Hpc },
    { apply ih_2 _ _ Hpc }, },
  { intros pc l',
    cases pc with pc pc
    ; unfold selects assert_of selects' assert_of'
    ; intros Hpc,
    { cases Hpc },
    { apply ih_1 _ _ Hpc },
    { apply ih_2 _ _ Hpc }, },
  { intros pc l',
    cases pc with pc pc
    ; dunfold selects assert_of selects' assert_of'
    ; intros Hpc,
    { cases Hpc },
    { apply ih_1 _ _ Hpc }, },
end

lemma cond_true_of_correct
: ∀ (pc : current c) (H : is_control $ some pc),
       ∀ s, assert_of (some pc) s → condition (some pc) H s → next_assert (some pc) s s :=
begin
  induction H,
  case correct.skip p'
  { intros pc l Hpc, cases pc, },
  case correct.action p' q' l ds Hgrd Htrip
  { intros pc l' s, cases pc with pc, cases l' },
  case correct.seq p' q' r' c₀ c₁ Hc₀ Hc₁
  { intros pc l',
    cases pc with pc pc
    ; dunfold selects assert_of selects' assert_of'
    ; intros Hpc,
    { apply ih_1 _ _ Hpc },
    { apply ih_2 _ _ Hpc }, },
  case correct.ite p' t pa pb q' ds c₀ c₁ Hc₀ Hc₁ Hpa Hpb
  { intros pc,
    cases pc with pc pc
    ; dunfold condition assert_of condition' assert_of' next_assert next_assert'
             is_control is_control'
    ; intros Hpc s Hp Hc,
    case current.ite_cond
    { rw if_pos Hc, apply Hpa _ ⟨Hp,Hc⟩, },
    case current.ite_left
    { apply ih_1 _ _ _ Hp Hc, },
    case current.ite_right
    { apply ih_2 _ _ _ Hp Hc, }, },
  case correct.while t p' inv q' ds b c Htp Hntq Hcvr
  { intros pc,
    cases pc with pc pc
    ; dunfold condition assert_of condition' assert_of' next_assert next_assert'
              is_control is_control'
    ; intros Hpc s Hp Hc,
    { rw if_pos Hc, apply Htp _ ⟨Hp,Hc⟩, },
    { apply ih_1 _ _ _ Hp Hc, }, },
end

lemma cond_false_of_correct
: ∀ (pc : current c) (H : is_control (some pc)),
       ∀ s, assert_of (some pc) s → ¬ condition (some pc) H s → next_assert (some pc) s s :=
begin
  induction H,
  case correct.skip p'
  { intros pc l Hpc, cases pc, },
  case correct.action p' q' l ds Hgrd Htrip
  { intros pc l' s, cases pc with pc, cases l' },
  case correct.seq p' q' r' c₀ c₁ Hc₀ Hc₁
  { intros pc l',
    cases pc with pc pc
    ; dunfold selects assert_of selects' assert_of'
    ; intros Hpc,
    { apply ih_1 _ _ Hpc },
    { apply ih_2 _ _ Hpc }, },
  case correct.ite p' t pa pb q' ds c₀ c₁ Hc₀ Hc₁ Hpa Hpb
  { intros pc,
    cases pc with pc pc
    ; dunfold condition assert_of condition' assert_of' next_assert next_assert'
             is_control is_control'
    ; intros Hpc s Hp Hc,
    case current.ite_cond
    { rw if_neg Hc, apply Hpb _ ⟨Hp,Hc⟩, },
    case current.ite_left
    { apply ih_1 _ _ _ Hp Hc, },
    case current.ite_right
    { apply ih_2 _ _ _ Hp Hc, }, },
  case correct.while t p' inv q' ds b c Htp Hntq Hcvr
  { intros pc,
    cases pc with pc pc
    ; dunfold condition assert_of condition' assert_of' next_assert next_assert'
             is_control is_control'
    ; intros Hpc s Hp Hc,
    { rw if_neg Hc, apply Hntq _ ⟨Hp,Hc⟩, },
    { apply ih_1 _ _ _ Hp Hc, }, },
end

lemma state_correctness_none
: state_correctness c none :=
begin
  apply state_correctness.mk,
  { intros l Hl, cases Hl },
  { intros l Hl, cases Hl },
  { intros H', unfold is_control at H', cases H', },
  { intros H', unfold is_control at H', cases H', },
end

lemma syntactic_imp_state_correctness (pc : option $ current c)
: state_correctness c pc :=
begin
  cases pc with pc,
  { apply state_correctness_none _ H },
  apply state_correctness.mk,
  { apply enabled_of_correct _ H },
  { apply correct_of_correct _ H },
  { apply cond_true_of_correct _ H },
  { apply cond_false_of_correct _ H },
end

omit H
parameters {F}
variable {c}

lemma not_selects_and_is_control
  {pc : option $ current c} {l : lbl}
  (h₀ : selects pc l)
  (h₁ : is_control pc )
: false :=
begin
  cases pc with pc,
  { unfold is_control at h₁, cases h₁ },
  unfold is_control at h₁,
  unfold selects at h₀,
  induction pc
  ; try { cases h₁ }
  ; try { cases h₀ }
  ; apply ih_1 h₁ h₀
end

lemma next_counter_action {p q : pred} {ds} {l : lbl} {p' q'} {c' : code lbl p' q'}
  (s : σ)
  (H : subtree (code.action p q ds l) c')
: next s (some $ counter H) = exit' H :=
begin
  unfold next,
  induction H,
  { simp, refl },
  all_goals { simp [counter,next',ih_1] },
end

lemma not_within_skip {p' q'} {c' : code lbl p' q'}
  {H : subtree (code.skip p) c'}
  {pc : option $ current c'}
  (H' : within H pc)
: exits H pc :=
begin
  unfold exits,
  cases pc with pc,
  { apply H' },
  unfold within at H',
  rw or_comm at H',
  cases H' with H' H',
  { apply H' },
  induction H,
  { rw exit'_rfl,
    cases pc },
  { rw within'_seq_left at H',
    cases H' with pc' H', cases H' with H₀ H₁,
    rw [exit'_seq_left,ih_1 _ H₀,fmap_some,some_or_else,H₁] },
  { rw within'_seq_right at H',
    cases H' with pc' H', cases H' with H₀ H₁,
    rw [exit'_seq_right,ih_1 _ H₀,fmap_some,H₁] },
  { rw within'_ite_left at H',
    cases H' with pc' H', cases H' with H₀ H₁,
    rw [exit'_ite_left,ih_1 _ H₀,fmap_some,H₁] },
  { rw within'_ite_right at H',
    cases H' with pc' H', cases H' with H₀ H₁,
    rw [exit'_ite_right,ih_1 _ H₀,fmap_some,H₁] },
  { rw within'_while at H',
    cases H' with pc' H', cases H' with H₀ H₁,
    rw [exit'_while,ih_1 _ H₀,fmap_some,some_or_else,H₁] },
end

lemma counter_action_of_within {p q : pred} {ds} {l : lbl} {p' q'} {c' : code lbl p' q'}
  {H : subtree (code.action p q ds l) c'}
  {pc : option $ current c'}
  (Hpc : within H pc)
  (Hnex : ¬ exits H pc)
: some (counter H) = pc :=
begin
  cases pc with pc ; unfold within at Hpc,
  { cases Hnex Hpc, },
  rw [or_comm,or_iff_not_imp] at Hpc,
  have H₃ := Hpc Hnex,  clear Hpc Hnex,
  apply congr_arg,
  induction H,
  case subtree.rfl
   { cases pc, refl },
  case subtree.seq_left
   { unfold counter,
     rw [within'_seq_left] at H₃,
     cases H₃ with pc₀ H₃, cases H₃ with H₃ H₄,
     cases H₄, clear H₄,
     apply congr_arg,
     apply ih_1 _ H₃ },
  case subtree.seq_right
   { unfold counter,
     rw [within'_seq_right] at H₃,
     cases H₃ with pc₀ H₃, cases H₃ with H₃ H₄,
     cases H₄, clear H₄,
     apply congr_arg,
     apply ih_1 _ H₃ },
  case subtree.ite_left
   { unfold counter,
     rw [within'_ite_left] at H₃,
     cases H₃ with pc₀ H₃, cases H₃ with H₃ H₄,
     cases H₄, clear H₄,
     apply congr_arg,
     apply ih_1 _ H₃ },
  case subtree.ite_right
   { unfold counter,
     rw [within'_ite_right] at H₃,
     cases H₃ with pc₀ H₃, cases H₃ with H₃ H₄,
     cases H₄, clear H₄,
     apply congr_arg,
     apply ih_1 _ H₃ },
  case subtree.while
   { unfold counter,
     rw [within'_while] at H₃,
     cases H₃ with pc₀ H₃, cases H₃ with H₃ H₄,
     cases H₄, clear H₄,
     apply congr_arg,
     apply ih_1 _ H₃ },
end

end

end local_correctness


import tactic

namespace chapter3

  open string
  open nat
  open option
  open function

  --define natural trees
  inductive natree
  | node : natree
  | ref : string → natree
  | app : natree → natree → natree
  open natree

  --introduce notation
  notation `𝕋` := natree
  notation `△` := natree.node
  infixl `⬝`:60 := natree.app

  variables {w x y z : 𝕋}

  --equational axioms (should these just be defined as a relation, seperate from equality?)
  @[simp] axiom kernel : △⬝△⬝y⬝z = y
  @[simp] axiom stem : △⬝(△⬝x)⬝y⬝z = y⬝z⬝(x⬝z)
  @[simp] axiom fork : △⬝(△⬝w⬝x)⬝y⬝z = z⬝w⬝x

  /-
  congruence "axioms"
  cong_node comes for free from rfl,
  cong_app comes for free from congurence of function application with equality (congr_arg2) and the fact that inductive type constructors are injective (app.inj)
  -/
  def cong_node : △ = △ := rfl
  def cong_app : w = y ∧ x = z ↔ w ⬝ x = y ⬝ z := --this is only really a "congruence" in one direction
  begin                                           --also the left direction is actually *false* which means the axioms above introduce inconsistency
    split,
      intro h,
      cases h,
      exact congr_arg2 app h_left h_right,
    intro h,
    exact app.inj h,
  end

  def uhoh : false :=
  begin
    sorry --implement
  end

  --define primitive combinators
  def K := △⬝△
  @[simp] theorem r_K : K⬝y⬝z = y := by simp [K]

  def I := △⬝(△⬝△)⬝(△⬝△)
  @[simp] theorem r_I : I⬝x = x := by simp [I]

  def D := △⬝(△⬝△)⬝(△⬝△⬝△)
  @[simp] theorem r_D : D⬝x⬝y⬝z = y⬝z⬝(x⬝z) := by simp [D]

  @[simp] def d (x : 𝕋) := △⬝(△⬝x)
  theorem d_eq_r_D : d x = D⬝x := by simp [D]

  --derivation of S combinator
  theorem S_exists : ∀ S : 𝕋, S⬝x⬝y⬝z = x⬝z⬝(y⬝z) → S = d (K⬝D) ⬝ (d K ⬝ (K⬝D)) :=
  begin
    intros S h₁,
    have h₂ : S⬝x⬝y⬝z = D⬝y⬝x⬝z,
    calc S⬝x⬝y⬝z = x⬝z⬝(y⬝z) : h₁
             ... = D⬝y⬝x⬝z   : by rw ←r_D
    ,
    have h₃ := h₂,
    rw ←cong_app at h₃, cases h₃ with h₃ r,                    --how can we remove r?
    have h₄ : S⬝x⬝y = D⬝(K⬝x)⬝D⬝y,
    calc S⬝x⬝y = D⬝y⬝x        : h₃
           ... = D⬝y⬝(K⬝x⬝y)  : by conv {to_lhs, rw ←@r_K x y} --why is the "conv to_lhs" necessary?
           ... = D⬝(K⬝x)⬝D⬝y  : by rw ←r_D
    ,
    have h₅ := h₄,
    rw ←cong_app at h₅, cases h₅ with h₅ r,
    have h₆ : S⬝x = D⬝(K⬝D)⬝(D⬝K⬝(K⬝D))⬝x,
    calc S⬝x = D⬝(K⬝x)⬝D             : h₅
         ... = (K⬝D⬝x)⬝(K⬝x)⬝(K⬝D⬝x) : by conv {to_lhs, rw ←@r_K D x}
         ... = D⬝K⬝(K⬝D)⬝x⬝(K⬝D⬝x)   : by rw ←r_D
         ... = D⬝(K⬝D)⬝(D⬝K⬝(K⬝D))⬝x : by rw ←r_D
    ,
    have h₇ := h₆,
    rw ←cong_app at h₇, cases h₇ with h₇ r,
    calc   S = D⬝(K⬝D)⬝(D⬝K⬝(K⬝D)) : h₇
         ... = d (K⬝D)⬝(d K⬝(K⬝D)) : by repeat {rw ←d_eq_r_D}
    ,
  end

  def S := d (K⬝D) ⬝ (d K ⬝ (K⬝D))
  @[simp] theorem r_S : S⬝x⬝y⬝z = x⬝z⬝(y⬝z) := by simp [S]

  --define associated functions
  namespace natree

    def iterate : 𝕋 → 𝕋 → ℕ → 𝕋
    | t₁ t₂ 0 := t₂
    | t₁ t₂ (n+1) := t₁ ⬝ iterate t₁ t₂ n

    def from_nat : ℕ → 𝕋
    | n := iterate △ △ n

    def reduce : 𝕋 → option 𝕋
    | (△⬝△⬝y⬝z) := some y
    | (△⬝(△⬝x)⬝y⬝z) := some ((y⬝z)⬝x⬝z)
    | (△⬝(△⬝w⬝x)⬝y⬝z) := some (z⬝w⬝x)
    | _ := none

    def depth : 𝕋 → ℕ
    | (t₁ ⬝ t₂) := max t₁.depth t₂.depth + 1
    | _ := 0

    lemma depth_well_founded (h : z = x ⬝ y) : x.depth < z.depth ∧ y.depth < z.depth :=
    begin
      split;
      conv
      begin
        to_rhs,
        rw [h, depth],
      end;
      apply lt_of_le_of_lt,
        exact le_max_left x.depth y.depth,
        apply lt_add_one,
      exact le_max_right x.depth y.depth,
      apply lt_add_one,
    end

    def step : 𝕋 → option 𝕋
    | t :=
      match reduce t with
      | some t' := some t'
      | none :=
        begin
          cases h₁ : t with _ t₁ t₂,
          exact none, exact none, --no reduction in "node" and "ref" cases
          have h₂ := depth_well_founded h₁, cases h₂, --establish safe recursion hypotheses
          exact (
            match step t₁ with
            | some t₁' := some (t₁' ⬝ t₂)
            | none :=
              match step t₂ with
              | some t₂' := some (t₁ ⬝ t₂')
              | none := none
              end
            end
          ),
        end
      end
    --use "depth" function in well-founded recursion checking
    using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf depth⟩]}

    def normalize : ℕ → 𝕋 → 𝕋
    | 0 t := t
    | (n+1) t :=
      match step t with
      | some t' := normalize n t'
      | none := t
      end

  end natree

end chapter3


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.functor.hom
import category_theory.functor.currying
import category_theory.products.basic

/-!
# The Yoneda embedding

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

The Yoneda embedding as a functor `yoneda : C ⥤ (Cᵒᵖ ⥤ Type v₁)`,
along with an instance that it is `fully_faithful`.

Also the Yoneda lemma, `yoneda_lemma : (yoneda_pairing C) ≅ (yoneda_evaluation C)`.

## References
* [Stacks: Opposite Categories and the Yoneda Lemma](https://stacks.math.columbia.edu/tag/001L)
-/

namespace category_theory
open opposite

universes v₁ u₁ u₂-- morphism levels before object levels. See note [category_theory universes].

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

/--
The Yoneda embedding, as a functor from `C` into presheaves on `C`.

See <https://stacks.math.columbia.edu/tag/001O>.
-/
@[simps]
def yoneda : C ⥤ (Cᵒᵖ ⥤ Type v₁) :=
{ obj := λ X,
  { obj := λ Y, unop Y ⟶ X,
    map := λ Y Y' f g, f.unop ≫ g,
    map_comp' := λ _ _ _ f g, begin ext, dsimp, erw [category.assoc] end,
    map_id' := λ Y, begin ext, dsimp, erw [category.id_comp] end },
  map := λ X X' f, { app := λ Y g, g ≫ f } }

/--
The co-Yoneda embedding, as a functor from `Cᵒᵖ` into co-presheaves on `C`.
-/
@[simps] def coyoneda : Cᵒᵖ ⥤ (C ⥤ Type v₁) :=
{ obj := λ X,
  { obj := λ Y, unop X ⟶ Y,
    map := λ Y Y' f g, g ≫ f },
  map := λ X X' f, { app := λ Y g, f.unop ≫ g } }

namespace yoneda

lemma obj_map_id {X Y : C} (f : op X ⟶ op Y) :
  (yoneda.obj X).map f (𝟙 X) = (yoneda.map f.unop).app (op Y) (𝟙 Y) :=
by { dsimp, simp }

@[simp] lemma naturality {X Y : C} (α : yoneda.obj X ⟶ yoneda.obj Y)
  {Z Z' : C} (f : Z ⟶ Z') (h : Z' ⟶ X) : f ≫ α.app (op Z') h = α.app (op Z) (f ≫ h) :=
(functor_to_types.naturality _ _ α f.op h).symm

/--
The Yoneda embedding is full.

See <https://stacks.math.columbia.edu/tag/001P>.
-/
instance yoneda_full : full (yoneda : C ⥤ Cᵒᵖ ⥤ Type v₁) :=
{ preimage := λ X Y f, f.app (op X) (𝟙 X) }

/--
The Yoneda embedding is faithful.

See <https://stacks.math.columbia.edu/tag/001P>.
-/
instance yoneda_faithful : faithful (yoneda : C ⥤ Cᵒᵖ ⥤ Type v₁) :=
{ map_injective' := λ X Y f g p, by convert (congr_fun (congr_app p (op X)) (𝟙 X)); dsimp; simp }

/-- Extensionality via Yoneda. The typical usage would be
```
-- Goal is `X ≅ Y`
apply yoneda.ext,
-- Goals are now functions `(Z ⟶ X) → (Z ⟶ Y)`, `(Z ⟶ Y) → (Z ⟶ X)`, and the fact that these
functions are inverses and natural in `Z`.
```
-/
def ext (X Y : C)
  (p : Π {Z : C}, (Z ⟶ X) → (Z ⟶ Y)) (q : Π {Z : C}, (Z ⟶ Y) → (Z ⟶ X))
  (h₁ : Π {Z : C} (f : Z ⟶ X), q (p f) = f) (h₂ : Π {Z : C} (f : Z ⟶ Y), p (q f) = f)
  (n : Π {Z Z' : C} (f : Z' ⟶ Z) (g : Z ⟶ X), p (f ≫ g) = f ≫ p g) : X ≅ Y :=
yoneda.preimage_iso (nat_iso.of_components (λ Z, { hom := p, inv := q, }) (by tidy))

/--
If `yoneda.map f` is an isomorphism, so was `f`.
-/
lemma is_iso {X Y : C} (f : X ⟶ Y) [is_iso (yoneda.map f)] : is_iso f :=
is_iso_of_fully_faithful yoneda f

end yoneda

namespace coyoneda

@[simp] lemma naturality {X Y : Cᵒᵖ} (α : coyoneda.obj X ⟶ coyoneda.obj Y)
  {Z Z' : C} (f : Z' ⟶ Z) (h : unop X ⟶ Z') : (α.app Z' h) ≫ f = α.app Z (h ≫ f) :=
(functor_to_types.naturality _ _ α f h).symm

instance coyoneda_full : full (coyoneda : Cᵒᵖ ⥤ C ⥤ Type v₁) :=
{ preimage := λ X Y f, (f.app _ (𝟙 X.unop)).op }

instance coyoneda_faithful : faithful (coyoneda : Cᵒᵖ ⥤ C ⥤ Type v₁) :=
{ map_injective' := λ X Y f g p,
  begin
    have t := congr_fun (congr_app p X.unop) (𝟙 _),
    simpa using congr_arg quiver.hom.op t,
  end }

/--
If `coyoneda.map f` is an isomorphism, so was `f`.
-/
lemma is_iso {X Y : Cᵒᵖ} (f : X ⟶ Y) [is_iso (coyoneda.map f)] : is_iso f :=
is_iso_of_fully_faithful coyoneda f

/-- The identity functor on `Type` is isomorphic to the coyoneda functor coming from `punit`. -/
def punit_iso : coyoneda.obj (opposite.op punit) ≅ 𝟭 (Type v₁) :=
nat_iso.of_components
  (λ X, { hom := λ f, f ⟨⟩, inv := λ x _, x })
  (by tidy)

/-- Taking the `unop` of morphisms is a natural isomorphism. -/
@[simps] def obj_op_op (X : C) : coyoneda.obj (op (op X)) ≅ yoneda.obj X :=
nat_iso.of_components (λ Y, (op_equiv _ _).to_iso) (λ X Y f, rfl)

end coyoneda

namespace functor

/--
A functor `F : Cᵒᵖ ⥤ Type v₁` is representable if there is object `X` so `F ≅ yoneda.obj X`.

See <https://stacks.math.columbia.edu/tag/001Q>.
-/
class representable (F : Cᵒᵖ ⥤ Type v₁) : Prop :=
(has_representation : ∃ X (f : yoneda.obj X ⟶ F), is_iso f)

instance {X : C} : representable (yoneda.obj X) :=
{ has_representation := ⟨X, 𝟙 _, infer_instance⟩ }

/--
A functor `F : C ⥤ Type v₁` is corepresentable if there is object `X` so `F ≅ coyoneda.obj X`.

See <https://stacks.math.columbia.edu/tag/001Q>.
-/
class corepresentable (F : C ⥤ Type v₁) : Prop :=
(has_corepresentation : ∃ X (f : coyoneda.obj X ⟶ F), is_iso f)

instance {X : Cᵒᵖ} : corepresentable (coyoneda.obj X) :=
{ has_corepresentation := ⟨X, 𝟙 _, infer_instance⟩ }

-- instance : corepresentable (𝟭 (Type v₁)) :=
-- corepresentable_of_nat_iso (op punit) coyoneda.punit_iso

section representable
variables (F : Cᵒᵖ ⥤ Type v₁)
variable [F.representable]

/-- The representing object for the representable functor `F`. -/
noncomputable def repr_X : C :=
(representable.has_representation : ∃ X (f : _ ⟶ F), _).some

/-- The (forward direction of the) isomorphism witnessing `F` is representable. -/
noncomputable def repr_f : yoneda.obj F.repr_X ⟶ F :=
representable.has_representation.some_spec.some

/--
The representing element for the representable functor `F`, sometimes called the universal
element of the functor.
-/
noncomputable def repr_x : F.obj (op F.repr_X) :=
F.repr_f.app (op F.repr_X) (𝟙 F.repr_X)

instance : is_iso F.repr_f :=
representable.has_representation.some_spec.some_spec

/--
An isomorphism between `F` and a functor of the form `C(-, F.repr_X)`.  Note the components
`F.repr_w.app X` definitionally have type `(X.unop ⟶ F.repr_X) ≅ F.obj X`.
-/
noncomputable def repr_w : yoneda.obj F.repr_X ≅ F := as_iso F.repr_f

@[simp] lemma repr_w_hom : F.repr_w.hom = F.repr_f := rfl

lemma repr_w_app_hom (X : Cᵒᵖ) (f : unop X ⟶ F.repr_X) :
  (F.repr_w.app X).hom f = F.map f.op F.repr_x :=
begin
  change F.repr_f.app X f = (F.repr_f.app (op F.repr_X) ≫ F.map f.op) (𝟙 F.repr_X),
  rw ←F.repr_f.naturality,
  dsimp,
  simp
end

end representable

section corepresentable

variables (F : C ⥤ Type v₁)
variable [F.corepresentable]

/-- The representing object for the corepresentable functor `F`. -/
noncomputable def corepr_X : C :=
(corepresentable.has_corepresentation : ∃ X (f : _ ⟶ F), _).some.unop

/-- The (forward direction of the) isomorphism witnessing `F` is corepresentable. -/
noncomputable def corepr_f : coyoneda.obj (op F.corepr_X) ⟶ F :=
corepresentable.has_corepresentation.some_spec.some

/--
The representing element for the corepresentable functor `F`, sometimes called the universal
element of the functor.
-/
noncomputable def corepr_x : F.obj F.corepr_X :=
F.corepr_f.app F.corepr_X (𝟙 F.corepr_X)

instance : is_iso F.corepr_f :=
corepresentable.has_corepresentation.some_spec.some_spec

/--
An isomorphism between `F` and a functor of the form `C(F.corepr X, -)`. Note the components
`F.corepr_w.app X` definitionally have type `F.corepr_X ⟶ X ≅ F.obj X`.
-/
noncomputable def corepr_w : coyoneda.obj (op F.corepr_X) ≅ F := as_iso F.corepr_f

lemma corepr_w_app_hom (X : C) (f : F.corepr_X ⟶ X) :
  (F.corepr_w.app X).hom f = F.map f F.corepr_x :=
begin
  change F.corepr_f.app X f = (F.corepr_f.app F.corepr_X ≫ F.map f) (𝟙 F.corepr_X),
  rw ←F.corepr_f.naturality,
  dsimp,
  simp
end

end corepresentable

end functor

lemma representable_of_nat_iso (F : Cᵒᵖ ⥤ Type v₁) {G} (i : F ≅ G) [F.representable] :
  G.representable :=
{ has_representation := ⟨F.repr_X, F.repr_f ≫ i.hom, infer_instance⟩ }

lemma corepresentable_of_nat_iso (F : C ⥤ Type v₁) {G} (i : F ≅ G) [F.corepresentable] :
  G.corepresentable :=
{ has_corepresentation := ⟨op F.corepr_X, F.corepr_f ≫ i.hom, infer_instance⟩ }

instance : functor.corepresentable (𝟭 (Type v₁)) :=
corepresentable_of_nat_iso (coyoneda.obj (op punit)) coyoneda.punit_iso

open opposite

variables (C)

-- We need to help typeclass inference with some awkward universe levels here.
instance prod_category_instance_1 : category ((Cᵒᵖ ⥤ Type v₁) × Cᵒᵖ) :=
category_theory.prod.{(max u₁ v₁) v₁} (Cᵒᵖ ⥤ Type v₁) Cᵒᵖ

instance prod_category_instance_2 : category (Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁)) :=
category_theory.prod.{v₁ (max u₁ v₁)} Cᵒᵖ (Cᵒᵖ ⥤ Type v₁)

open yoneda

/--
The "Yoneda evaluation" functor, which sends `X : Cᵒᵖ` and `F : Cᵒᵖ ⥤ Type`
to `F.obj X`, functorially in both `X` and `F`.
-/
def yoneda_evaluation : Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁) ⥤ Type (max u₁ v₁) :=
evaluation_uncurried Cᵒᵖ (Type v₁) ⋙ ulift_functor.{u₁}

@[simp] lemma yoneda_evaluation_map_down
  (P Q : Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁)) (α : P ⟶ Q) (x : (yoneda_evaluation C).obj P) :
  ((yoneda_evaluation C).map α x).down = α.2.app Q.1 (P.2.map α.1 x.down) := rfl

/--
The "Yoneda pairing" functor, which sends `X : Cᵒᵖ` and `F : Cᵒᵖ ⥤ Type`
to `yoneda.op.obj X ⟶ F`, functorially in both `X` and `F`.
-/
def yoneda_pairing : Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁) ⥤ Type (max u₁ v₁) :=
functor.prod yoneda.op (𝟭 (Cᵒᵖ ⥤ Type v₁)) ⋙ functor.hom (Cᵒᵖ ⥤ Type v₁)

@[simp] lemma yoneda_pairing_map
  (P Q : Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁)) (α : P ⟶ Q) (β : (yoneda_pairing C).obj P) :
  (yoneda_pairing C).map α β = yoneda.map α.1.unop ≫ β ≫ α.2 := rfl

/--
The Yoneda lemma asserts that that the Yoneda pairing
`(X : Cᵒᵖ, F : Cᵒᵖ ⥤ Type) ↦ (yoneda.obj (unop X) ⟶ F)`
is naturally isomorphic to the evaluation `(X, F) ↦ F.obj X`.

See <https://stacks.math.columbia.edu/tag/001P>.
-/
def yoneda_lemma : yoneda_pairing C ≅ yoneda_evaluation C :=
{ hom :=
  { app := λ F x, ulift.up ((x.app F.1) (𝟙 (unop F.1))),
    naturality' :=
    begin
      intros X Y f, ext, dsimp,
      erw [category.id_comp, ←functor_to_types.naturality],
      simp only [category.comp_id, yoneda_obj_map],
    end },
  inv :=
  { app := λ F x,
    { app := λ X a, (F.2.map a.op) x.down,
      naturality' :=
      begin
        intros X Y f, ext, dsimp,
        rw [functor_to_types.map_comp_apply]
      end },
    naturality' :=
    begin
      intros X Y f, ext, dsimp,
      rw [←functor_to_types.naturality, functor_to_types.map_comp_apply]
    end },
  hom_inv_id' :=
  begin
    ext, dsimp,
    erw [←functor_to_types.naturality,
         obj_map_id],
    simp only [yoneda_map_app, quiver.hom.unop_op],
    erw [category.id_comp],
  end,
  inv_hom_id' :=
  begin
    ext, dsimp,
    rw [functor_to_types.map_id_apply]
  end }.

variables {C}

/--
The isomorphism between `yoneda.obj X ⟶ F` and `F.obj (op X)`
(we need to insert a `ulift` to get the universes right!)
given by the Yoneda lemma.
-/
@[simps] def yoneda_sections (X : C) (F : Cᵒᵖ ⥤ Type v₁) :
  (yoneda.obj X ⟶ F) ≅ ulift.{u₁} (F.obj (op X)) :=
(yoneda_lemma C).app (op X, F)

/--
We have a type-level equivalence between natural transformations from the yoneda embedding
and elements of `F.obj X`, without any universe switching.
-/
def yoneda_equiv {X : C} {F : Cᵒᵖ ⥤ Type v₁} : (yoneda.obj X ⟶ F) ≃ F.obj (op X) :=
(yoneda_sections X F).to_equiv.trans equiv.ulift

@[simp]
lemma yoneda_equiv_apply {X : C} {F : Cᵒᵖ ⥤ Type v₁} (f : yoneda.obj X ⟶ F) :
  yoneda_equiv f = f.app (op X) (𝟙 X) :=
rfl

@[simp]
lemma yoneda_equiv_symm_app_apply {X : C} {F : Cᵒᵖ ⥤ Type v₁} (x : F.obj (op X))
  (Y : Cᵒᵖ) (f : Y.unop ⟶ X) :
  (yoneda_equiv.symm x).app Y f = F.map f.op x :=
rfl

lemma yoneda_equiv_naturality {X Y : C} {F : Cᵒᵖ ⥤ Type v₁} (f : yoneda.obj X ⟶ F) (g : Y ⟶ X) :
  F.map g.op (yoneda_equiv f) = yoneda_equiv (yoneda.map g ≫ f) :=
begin
  change (f.app (op X) ≫ F.map g.op) (𝟙 X) = f.app (op Y) (𝟙 Y ≫ g),
  rw ←f.naturality,
  dsimp,
  simp,
end

/--
When `C` is a small category, we can restate the isomorphism from `yoneda_sections`
without having to change universes.
-/
def yoneda_sections_small {C : Type u₁} [small_category C] (X : C)
  (F : Cᵒᵖ ⥤ Type u₁) :
  (yoneda.obj X ⟶ F) ≅ F.obj (op X) :=
yoneda_sections X F ≪≫ ulift_trivial _

@[simp]
lemma yoneda_sections_small_hom {C : Type u₁} [small_category C] (X : C)
  (F : Cᵒᵖ ⥤ Type u₁) (f : yoneda.obj X ⟶ F) :
  (yoneda_sections_small X F).hom f = f.app _ (𝟙 _) :=
rfl

@[simp]
lemma yoneda_sections_small_inv_app_apply {C : Type u₁} [small_category C] (X : C)
  (F : Cᵒᵖ ⥤ Type u₁) (t : F.obj (op X)) (Y : Cᵒᵖ) (f : Y.unop ⟶ X) :
  ((yoneda_sections_small X F).inv t).app Y f = F.map f.op t :=
rfl

local attribute [ext] functor.ext

/-- The curried version of yoneda lemma when `C` is small. -/
def curried_yoneda_lemma {C : Type u₁} [small_category C] :
  (yoneda.op ⋙ coyoneda : Cᵒᵖ ⥤ (Cᵒᵖ ⥤ Type u₁) ⥤ Type u₁) ≅ evaluation Cᵒᵖ (Type u₁) :=
eq_to_iso (by tidy) ≪≫ curry.map_iso (yoneda_lemma C ≪≫
  iso_whisker_left (evaluation_uncurried Cᵒᵖ (Type u₁)) ulift_functor_trivial) ≪≫
    eq_to_iso (by tidy)

/-- The curried version of yoneda lemma when `C` is small. -/
def curried_yoneda_lemma' {C : Type u₁} [small_category C] :
  yoneda ⋙ (whiskering_left Cᵒᵖ (Cᵒᵖ ⥤ Type u₁)ᵒᵖ (Type u₁)).obj yoneda.op ≅ 𝟭 (Cᵒᵖ ⥤ Type u₁) :=
eq_to_iso (by tidy) ≪≫ curry.map_iso (iso_whisker_left (prod.swap _ _)
  (yoneda_lemma C ≪≫ iso_whisker_left
    (evaluation_uncurried Cᵒᵖ (Type u₁)) ulift_functor_trivial : _)) ≪≫ eq_to_iso (by tidy)

end category_theory


/-
Copyright (c) 2023 Wojciech Nawrocki. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Wojciech Nawrocki
-/

import ProofChecker.Model.PropForm
import ProofChecker.Model.PropVars

import ProofChecker.Data.HashMap.Lemmas
import ProofChecker.Data.ICnf

/-! Clause database together with some (provably correct) methods. For example, we can conclude
that if a clause follows from the current database by unit propagation, then it is implied by the
database's interpretation as a propositional formula. -/

/-- A stateful clause database, i.e. a dynamically modifiable CNF, for use in poly-time proof
checkers such as for LRAT. It uses in-place data structures, so should be used linearly.

(Persistent structures do not seem immediately helpful as linear formats do not backtrack.)

In `ClauseDb α`, `α` is the type of clause indices. -/
structure ClauseDb (α : Type) [BEq α] [Hashable α] where
  /-- Each clause is stored together with a flag indicating whether it has been deleted.
  Deleted clauses are logically not in the database. -/
  clauses : HashMap α (IClause × Bool) := {}

namespace HashMap

variable [BEq α] [Hashable α]

def mapOne (m : HashMap α β) (idx : α) (f : β → β) : HashMap α β :=
  match m.find? idx with
  | some b => m.insert idx (f b)
  | none => m

end HashMap

inductive UnitPropResult (α : Type) where
  | contradiction
  /-- The hint did not become unit. -/
  | hintNotUnit (hint : α)
  /-- The hint points at a nonexistent clause. -/
  | hintNonexistent (hint : α)
  | extended (τ : PartPropAssignment)

namespace UnitPropResult

def isContradiction (r : UnitPropResult α) : Bool :=
  r matches contradiction

end UnitPropResult

namespace ClauseDb

variable {α : Type} [BEq α] [Hashable α]

instance [ToString α] : ToString (ClauseDb α) where
  toString db := toString db.clauses.toList

def empty : ClauseDb α := { clauses := .empty }

def fold (db : ClauseDb α) (f : β → α → IClause → β) (init : β) : β :=
  db.clauses.fold (init := init) fun acc idx (C, deleted) =>
    if deleted then acc else f acc idx C

def foldM [Monad m] (db : ClauseDb α) (f : β → α → IClause → m β) (init : β) : m β :=
  db.clauses.foldM (init := init) fun acc idx (C, deleted) =>
    if deleted then pure acc else f acc idx C

def addClause (db : ClauseDb α) (idx : α) (C : IClause) : ClauseDb α :=
  { db with clauses := db.clauses.insert idx (C, false) }

def delClause (db : ClauseDb α) (idx : α) : ClauseDb α :=
  { db with clauses := db.clauses.mapOne idx fun (C, _) => (C, true) }

def getClause (db : ClauseDb α) (idx : α) : Option IClause :=
  db.clauses.find? idx |>.bind (fun (C, deleted) => if deleted then none else C)

def contains (db : ClauseDb α) (idx : α) : Bool :=
  db.getClause idx |>.isSome

/-- NOTE: This implementation is not efficient as it doesn't use early return. -/
def all (db : ClauseDb α) (p : α → IClause → Bool) : Bool :=
  db.fold (fun acc idx C => acc && p idx C) true

/-- NOTE: This implementation is not efficient as it doesn't use early return. -/
def any (db : ClauseDb α) (p : α → IClause → Bool) : Bool :=
  !db.all (fun idx C => !p idx C)

/-- Initialize a clause database from a CNF array. -/
def ofICnf (cnf : ICnf) : ClauseDb Nat :=
  let (db, _) := cnf.foldl (init := (empty, 1)) fun (db, idx) C =>
    (db.addClause idx C, idx + 1)
  db

@[deprecated]
def unitPropWithHints (db : ClauseDb α) (τ : PartPropAssignment) (hints : Array α)
    : UnitPropResult α := Id.run do
  let mut τ := τ
  for hint in hints do
    let some C := db.getClause hint
      | return .hintNonexistent hint
    match C.reduce τ with
    | some #[u] => τ := τ.insert u.var u.polarity
    | some #[] => return .contradiction
    | _ => return .hintNotUnit hint
  return .extended τ

/-! Theorems about `ClauseDb` -/

variable [LawfulBEq α] [HashMap.LawfulHashable α]

/-! `getClause` -/

theorem getClause_eq_some (db : ClauseDb α) (idx : α) (C : IClause) :
    db.getClause idx = some C ↔ db.clauses.find? idx = some (C, false) := by
  simp [getClause]

@[simp]
theorem getClause_empty (idx : α) : (empty : ClauseDb α).getClause idx = none := by
  simp [getClause, empty]

theorem getClause_addClause (db : ClauseDb α) (idx : α) (C : IClause) :
    (db.addClause idx C).getClause idx = some C := by
  dsimp [getClause, addClause]
  rw [HashMap.find?_insert _ _ (LawfulBEq.rfl)]
  simp

theorem getClause_addClause_of_ne (db : ClauseDb α) (idx idx' : α) (C : IClause) :
    idx ≠ idx' → (db.addClause idx C).getClause idx' = db.getClause idx' := by
  intro h
  dsimp [addClause, getClause]
  rw [HashMap.find?_insert_of_ne _ _ (bne_iff_ne idx idx' |>.mpr h)]

theorem getClause_delClause (db : ClauseDb α) (idx : α) :
    (db.delClause idx).getClause idx = none := by
  dsimp [getClause, delClause, HashMap.mapOne]
  split
  next =>
    rw [HashMap.find?_insert _ _ (LawfulBEq.rfl)]
    simp
  next h =>
    simp [h]

theorem getClause_delClause_of_ne (db : ClauseDb α) (idx idx' : α) :
    idx ≠ idx' → (db.delClause idx).getClause idx' = db.getClause idx' := by
  intro h
  dsimp [getClause, delClause, HashMap.mapOne]
  split
  next =>
    rw [HashMap.find?_insert_of_ne _ _ (bne_iff_ne _ _ |>.mpr h)]
  next => rfl

/-! `contains` -/

theorem contains_iff_getClause_eq_some (db : ClauseDb α) (idx : α) :
    db.contains idx ↔ ∃ C, db.getClause idx = some C := by
  simp [contains, Option.isSome_iff_exists, db.clauses.contains_iff]

@[simp]
theorem not_contains_empty (idx : α) : (empty : ClauseDb α).contains idx = false := by
  have := contains_iff_getClause_eq_some empty idx
  simp_all

theorem contains_addClause (db : ClauseDb α) (idx idx' : α) (C : IClause) :
    (db.addClause idx C).contains idx' ↔ (db.contains idx' ∨ idx = idx') := by
  simp only [contains_iff_getClause_eq_some]
  refine ⟨?mp, fun h => h.elim ?mpr₁ ?mpr₂⟩
  case mp =>
    intro ⟨C, hGet⟩
    by_cases hEq : idx = idx' <;>
      aesop (add norm getClause_addClause_of_ne)
  case mpr₁ =>
    intro ⟨C, hGet⟩
    by_cases hEq : idx = idx' <;>
      aesop (add norm getClause_addClause, norm getClause_addClause_of_ne)
  case mpr₂ =>
    aesop (add norm getClause_addClause)

theorem contains_delClause (db : ClauseDb α) (idx idx' : α) :
    (db.delClause idx).contains idx' ↔ (db.contains idx' ∧ idx ≠ idx') := by
  simp only [contains_iff_getClause_eq_some]
  refine ⟨?mp, ?mpr⟩
  case mp =>
    intro ⟨C, hGet⟩
    have hEq : idx ≠ idx' := fun h => by
      rw [h, getClause_delClause] at hGet
      cases hGet
    rw [getClause_delClause_of_ne _ _ _ hEq] at hGet
    simp [hGet, hEq]
  case mpr =>
    intro ⟨⟨C, hGet⟩, hEq⟩
    exact ⟨C, hGet ▸ getClause_delClause_of_ne _ _ _ hEq⟩

/-! `fold` -/

theorem fold_of_getClause_eq_some_of_comm (db : ClauseDb α) (idx : α) (C : IClause)
    (f : β → α → IClause → β) (init : β) :
    db.getClause idx = some C →
    (∀ b a₁ C₁ a₂ C₂, f (f b a₁ C₁) a₂ C₂ = f (f b a₂ C₂) a₁ C₁) →
    ∃ b, db.fold f init = f b idx C := by
  intro h hComm
  rw [getClause_eq_some] at h
  have ⟨b, hb⟩ := db.clauses.fold_of_mapsTo_of_comm (init := init)
    (f := fun acc idx (C, deleted) => if deleted then acc else f acc idx C)
    h (by aesop)
  use b
  simp [fold, hb]

/-! `all` -/

theorem all_true (db : ClauseDb α) (p : α → IClause → Bool) :
    db.all p → ∀ idx C, db.getClause idx = some C → p idx C := by
  dsimp [all]
  intro hAll idx C hGet
  have ⟨b, hEq⟩ :=
    fold_of_getClause_eq_some_of_comm db idx C (fun acc idx C => acc && p idx C) true
      hGet ?comm
  case comm =>
    intros
    simp only [Bool.and_assoc]
    rw [Bool.and_comm (p _ _)]
  simp_all

theorem all_of_all_true (db : ClauseDb α) (p : α → IClause → Bool) :
    (∀ idx C, db.getClause idx = some C → p idx C) → db.all p := by
  dsimp [all, fold, getClause]
  intro
  apply db.clauses.foldRecOn (C := fun b => b = true) (hInit := rfl)
  simp_all

/-! `any` -/

theorem any_true (db : ClauseDb α) (p : α → IClause → Bool) :
    db.any p → ∃ idx C, db.getClause idx = some C ∧ p idx C = true := by
  have := db.all_of_all_true (fun idx C => !p idx C)
  dsimp [any]
  exact not_imp_not.mp fun _ => by simp_all

/-! `toPropTermSub` -/

open Classical PropTerm

/-- Interpret the conjunction of a subset of the clauses as a Boolean function. -/
noncomputable def toPropTermSub (db : ClauseDb α) (idxs : Set α) : PropTerm Var :=
  db.fold (init := ⊤) fun acc idx C => if idx ∈ idxs then acc ⊓ C.toPropTerm else acc

theorem toPropTermSub_of_getClause_eq_some (db : ClauseDb α) :
    idx ∈ idxs → db.getClause idx = some C → db.toPropTermSub idxs ≤ C.toPropTerm := by
  intro hMem hGet
  have ⟨φ, hφ⟩ := db.fold_of_getClause_eq_some_of_comm idx C
    (init := ⊤) (f := fun acc idx C => if idx ∈ idxs then acc ⊓ C.toPropTerm else acc)
    hGet ?comm
  case comm =>
    intros
    dsimp
    split_ifs <;> ac_rfl
  apply PropTerm.entails_ext.mpr
  rw [toPropTermSub, hφ]
  simp [hMem]

theorem satisfies_toPropTermSub (db : ClauseDb α) (idxs : Set α) (σ : PropAssignment Var) :
    σ ⊨ db.toPropTermSub idxs ↔ ∀ idx ∈ idxs, ∀ C, db.getClause idx = some C → σ ⊨ C.toPropTerm :=
  ⟨mp, mpr⟩
where
  mp := fun h idx hMem C hGet =>
    entails_ext.mp (toPropTermSub_of_getClause_eq_some db hMem hGet) _ h

  mpr := fun h => by
    dsimp [toPropTermSub]
    apply HashMap.foldRecOn (hInit := satisfies_tr)
    intro φ idx (C, deleted) hφ hFind
    dsimp
    split_ifs <;> try assumption
    next hDel hMem =>
      rw [satisfies_conj]
      refine ⟨by assumption, ?_⟩
      apply h idx hMem
      simp [getClause, hFind, hDel]

@[simp]
theorem toPropTermSub_empty (idxs : Set α) : (empty : ClauseDb α).toPropTermSub idxs = ⊤ := by
  ext τ
  simp [satisfies_toPropTermSub]

@[simp]
theorem toPropTermSub_emptySet (db : ClauseDb α) : db.toPropTermSub ∅ = ⊤ := by
  ext τ
  aesop (add norm satisfies_toPropTermSub)

theorem toPropTermSub_subset (db : ClauseDb α) :
    idxs ⊆ idxs' → db.toPropTermSub idxs' ≤ db.toPropTermSub idxs := by
  intro hSub
  apply entails_ext.mpr
  aesop (add norm satisfies_toPropTermSub)

theorem toPropTermSub_subset_eq (db : ClauseDb α) :
    idxs ⊆ idxs' → (∀ idx ∈ idxs', db.contains idx → idx ∈ idxs) →
    db.toPropTermSub idxs' = db.toPropTermSub idxs := by
  intro hSub h
  apply le_antisymm (toPropTermSub_subset db hSub)
  apply entails_ext.mpr
  simp only [satisfies_toPropTermSub]
  intro τ hτ _ hMem' _ hGet'
  exact hτ _ (h _ hMem' (contains_iff_getClause_eq_some _ _ |>.mpr ⟨_, hGet'⟩)) _ hGet'

theorem toPropTermSub_addClause (db : ClauseDb α) (idxs : Set α) (idx : α) (C : IClause) :
    db.toPropTermSub idxs ⊓ C.toPropTerm ≤ (db.addClause idx C).toPropTermSub idxs := by
  apply entails_ext.mpr
  simp only [satisfies_conj, satisfies_toPropTermSub]
  intro τ h idx' C' hMem' hGet'
  by_cases hEq : idx = idx' <;>
    aesop (add norm getClause_addClause, norm getClause_addClause_of_ne)

theorem toPropTermSub_addClause_of_not_contains (db : ClauseDb α) (C : IClause) :
    ¬db.contains idx → (db.addClause idx C).toPropTermSub idxs ≤ db.toPropTermSub idxs := by
  intro hContains
  apply entails_ext.mpr
  simp only [satisfies_toPropTermSub]
  intro _ _ idx'
  by_cases hEq : idx = idx' <;>
    aesop (add norm contains_iff_getClause_eq_some, norm getClause_addClause_of_ne)

theorem toPropTermSub_addClause_eq (db : ClauseDb α) (C : IClause) :
    idx ∈ idxs → ¬db.contains idx →
    (db.addClause idx C).toPropTermSub idxs = db.toPropTermSub idxs ⊓ C.toPropTerm := by
  intro hMem hContains
  refine le_antisymm ?_ (toPropTermSub_addClause db idxs idx C)
  apply le_inf (toPropTermSub_addClause_of_not_contains db C hContains)
  apply toPropTermSub_of_getClause_eq_some _ hMem
  apply getClause_addClause

theorem toPropTermSub_addClause_of_not_mem (db : ClauseDb α) (C : IClause) :
    idx ∉ idxs → (db.addClause idx C).toPropTermSub idxs = db.toPropTermSub idxs := by
  intro hMem
  ext τ
  simp only [satisfies_toPropTermSub]
  constructor <;> {
    intro h idx' hMem'
    have : idx ≠ idx' := fun h =>
      hMem <| h ▸ hMem'
    aesop (add norm getClause_addClause_of_ne)
  }

theorem toPropTermSub_delClause (db : ClauseDb α) (idxs : Set α) (idx : α) :
    db.toPropTermSub idxs ≤ (db.delClause idx).toPropTermSub idxs := by
  apply PropTerm.entails_ext.mpr
  simp only [satisfies_toPropTermSub]
  intro _ _ idx'
  by_cases hEq : idx = idx' <;>
    aesop (add norm getClause_delClause_of_ne, norm getClause_delClause)

theorem toPropTermSub_delClause_of_getClause_eq_some (db : ClauseDb α) :
    db.getClause idx = some C →
    (db.delClause idx).toPropTermSub idxs ⊓ C.toPropTerm ≤ db.toPropTermSub idxs := by
  intro hGet
  apply entails_ext.mpr
  simp only [satisfies_conj, satisfies_toPropTermSub]
  intro _ _ idx'
  by_cases hEq : idx = idx' <;>
    aesop (add norm getClause_delClause_of_ne)

theorem toPropTermSub_delClause_eq (db : ClauseDb α) :
    idx ∈ idxs → db.getClause idx = some C →
    (db.delClause idx).toPropTermSub idxs ⊓ C.toPropTerm = db.toPropTermSub idxs := by
  intro hMem hGet
  apply le_antisymm (toPropTermSub_delClause_of_getClause_eq_some db hGet)
  apply le_inf (toPropTermSub_delClause db idxs idx)
  apply toPropTermSub_of_getClause_eq_some _ hMem hGet

theorem toPropTermSub_delClause_of_not_mem (db : ClauseDb α) :
    idx ∉ idxs → (db.delClause idx).toPropTermSub idxs = db.toPropTermSub idxs := by
  intro hMem
  ext τ
  simp only [satisfies_toPropTermSub]
  constructor <;> {
    intro h idx' hMem'
    have : idx ≠ idx' := fun h =>
      hMem <| h ▸ hMem'
    aesop (add norm getClause_delClause_of_ne)
  }

/-! `toPropTerm` -/

/-- Interpret the conjuction of all the clauses as a Boolean function. -/
noncomputable def toPropTerm (db : ClauseDb α) : PropTerm Var :=
  db.toPropTermSub Set.univ

theorem toPropTerm_of_getClause_eq_some (db : ClauseDb α) :
    db.getClause idx = some C → db.toPropTerm ≤ C.toPropTerm :=
  toPropTermSub_of_getClause_eq_some db (Set.mem_univ idx)

open PropTerm in
theorem satisfies_toPropTerm (db : ClauseDb α) (σ : PropAssignment Var) :
    σ ⊨ db.toPropTerm ↔ ∀ idx C, db.getClause idx = some C → σ ⊨ C.toPropTerm :=
  have ⟨mp, mpr⟩ := satisfies_toPropTermSub db Set.univ σ
  ⟨fun h idx C hGet => mp h idx (Set.mem_univ idx) C hGet,
   fun h => mpr (fun idx _ C hGet => h idx C hGet)⟩

theorem toPropTerm_subset (db : ClauseDb α) (idxs : Set α) :
    db.toPropTerm ≤ db.toPropTermSub idxs :=
  toPropTermSub_subset db (Set.subset_univ idxs)

@[simp]
theorem toPropTerm_empty : (empty : ClauseDb α).toPropTerm = ⊤ :=
  toPropTermSub_empty Set.univ

theorem toPropTerm_addClause (db : ClauseDb α) (idx : α) (C : IClause) :
    db.toPropTerm ⊓ C.toPropTerm ≤ (db.addClause idx C).toPropTerm :=
  toPropTermSub_addClause db Set.univ idx C

theorem toPropTerm_addClause_eq (db : ClauseDb α) (idx : α) (C : IClause) :
    ¬db.contains idx →
    (db.addClause idx C).toPropTerm = db.toPropTerm ⊓ C.toPropTerm :=
  toPropTermSub_addClause_eq db C (Set.mem_univ idx)

theorem toPropTerm_delClause (db : ClauseDb α) (idx : α) :
    db.toPropTerm ≤ (db.delClause idx).toPropTerm :=
  toPropTermSub_delClause db Set.univ idx

theorem toPropTerm_delClause_eq (db : ClauseDb α) (idx : α) (C : IClause) :
    db.getClause idx = some C →
    (db.delClause idx).toPropTerm ⊓ C.toPropTerm = db.toPropTerm :=
  toPropTermSub_delClause_eq db (Set.mem_univ idx)

/-! `ofICnf` -/

theorem ofICnf_characterization (cnf : ICnf) :
    ¬(ofICnf cnf).contains 0 ∧
    (∀ i : Fin cnf.size, (ofICnf cnf).getClause (i + 1) = some cnf[i]) ∧
    (∀ i > cnf.size, ¬(ofICnf cnf).contains i) := by
  have ⟨h₁, h₂, h₃, _⟩ := cnf.foldl_induction
    (motive := fun (sz : Nat) (p : ClauseDb Nat × Nat) =>
      ¬p.1.contains 0 ∧
      (∀ i : Fin cnf.size, i < sz → p.1.getClause (i + 1) = some cnf[i]) ∧
      (∀ i > sz, ¬p.1.contains i) ∧
      p.2 = sz + 1)
    (init := (empty, 1))
    (f := fun (db, idx) C => (db.addClause idx C, idx + 1))
    (h0 := by simp [not_contains_empty])
    (hf := by
      intro sz (db, idx) ⟨ih₁, ih₂, ih₃, ih₄⟩
      dsimp at ih₄ ⊢
      simp only [ih₄, contains_iff_getClause_eq_some, and_true] at *
      refine ⟨?step₁, ?step₂, ?step₃⟩
      case step₁ =>
        have : sz.val + 1 ≠ 0 := Nat.succ_ne_zero _
        simp [getClause_addClause_of_ne _ _ _ _ this, ih₁]
      case step₂ =>
        intro i hLt
        by_cases hEq : sz.val = i.val
        . simp [hEq, getClause_addClause]
        . have : sz.val + 1 ≠ i.val + 1 := by simp [hEq]
          rw [getClause_addClause_of_ne _ _ _ _ this]
          apply ih₂
          exact Nat.lt_of_le_of_ne (Nat.le_of_lt_succ hLt) (Ne.symm hEq)
      case step₃ =>
        intro i hGe
        have : sz.val + 1 ≠ i := Nat.ne_of_lt hGe
        rw [getClause_addClause_of_ne _ _ _ _ this]
        apply ih₃
        linarith)
  dsimp [ofICnf]
  exact ⟨h₁, fun i => h₂ i i.isLt, h₃⟩

theorem ofICnf_ext (cnf : ICnf) (C : IClause) :
    C ∈ cnf.data ↔ ∃ idx, (ofICnf cnf).getClause idx = some C := by
  have ⟨h₁, h₂, h₃⟩ := ofICnf_characterization cnf
  apply Iff.intro
  case mp =>
    intro h
    have ⟨i, h⟩ := Array.get_of_mem_data h
    use (i + 1)
    rw [← h]
    apply h₂
  case mpr =>
    intro ⟨idx, h⟩
    have hContains := contains_iff_getClause_eq_some _ _ |>.mpr ⟨C, h⟩
    have hPos : 0 < idx := by
      apply Nat.pos_of_ne_zero
      intro
      simp_all
    have hLt : idx - 1 < cnf.size := by
      suffices idx ≤ cnf.size by
        apply Nat.sub_lt_left_of_lt_add
        . apply Nat.succ_le_of_lt hPos
        . rw [add_comm]
          apply Nat.lt_succ_of_le this
      by_contra
      simp_all
    have hPred : idx - 1 + 1 = idx := Nat.succ_pred_eq_of_pos hPos
    have := h₂ ⟨idx - 1, hLt⟩
    simp only [hPred, h] at this
    cases this
    apply Array.get_mem_data

@[simp]
theorem toPropTerm_ofICnf (cnf : ICnf) : (ofICnf cnf).toPropTerm = cnf.toPropTerm := by
  ext τ
  simp only [ICnf.satisfies_iff, satisfies_toPropTerm, ofICnf_ext]
  aesop

/-! `unitPropWithHints` -/

inductive UnitPropResultDep {α : Type} [BEq α] [Hashable α]
    (db : ClauseDb α) (σ : PartPropAssignment) (hints : Array α) where
  /-- A contradiction was derived. The contradiction is implied by the subset of the database
  used in hints as well as the initial assignment. -/
  | contradiction (h : db.toPropTermSub (· ∈ hints.data) ⊓ σ.toPropTerm ≤ ⊥)
  /-- The partial assignment was extended. The final assignment `σ'` is implied by the subset of
  the database used in hints as well as the initial assignment. -/
  | extended (σ' : PartPropAssignment)
             (h : db.toPropTermSub (· ∈ hints.data) ⊓ σ.toPropTerm ≤ σ'.toPropTerm)
  /-- The hint `C` at index `idx` did not become unit under `σ`. -/
  | hintNotUnit (idx : α) (C : IClause) (σ : PartPropAssignment)
  /-- The hint index `idx` points at a nonexistent clause. -/
 | hintNonexistent (idx : α)

/-- Check whether the given clause is a unit and return the unit literal if so. Otherwise fail.
Note that repeating a literal as in (l ∨ l ∨ l) is allowed and counts as a unit. -/
def checkIsUnit (C₀ : IClause) : Option { l : ILit // l.toPropTerm = C₀.toPropTerm } := do
  let ⟨l?, _, hL?⟩ ← loopM_with_invariant (n := C₀.size)
    (invariant := fun i (acc : Option ILit) =>
      (acc = none → i = 0) ∧
      ∀ l, acc = some l →
        l ∈ C₀.data ∧
        ∀ j : Fin C₀.size, j < i → C₀[j] = l)
    (start_state := ⟨none, by simp⟩)
    (step := fun i ⟨acc, ih₁, _⟩ => do
      let lᵢ := C₀[i]
      have hL : lᵢ ∈ C₀.data := C₀.get_mem_data i
      if hI : i.val = 0 then
        return ⟨some lᵢ, by simp, by simp_all⟩
      else
        match acc with
        | some l =>
          if h : lᵢ = l then
            return ⟨some lᵢ, by simp, by
              intro _ h
              injection h with h; cases h
              refine ⟨hL, fun j hJ => ?_⟩
              cases Nat.lt_or_eq_of_le (Nat.le_of_lt_succ hJ) <;>
                simp_all⟩
          else
            none
        | none => False.elim <| hI <| ih₁ rfl)
  match l?, hL? with
  | some l, hL =>
    return ⟨l, by
      ext
      have ⟨_, h₂⟩ := hL _ rfl
      have : ∀ l' ∈ C₀.data, l' = l := fun _ hL' =>
        have ⟨i, hI⟩ := Array.get_of_mem_data hL'
        hI ▸ h₂ i i.isLt
      aesop (add norm IClause.satisfies_iff)⟩
  | none,   _  => none

/-- Propagate units starting from the given assignment. The clauses in `hints` are expected
to become unit in the order provided. Return the extended assignment, or `none` if a contradiction
was found. See `unitPropWithHintsDep` for a certified version. -/
def unitPropWithHintsDep (db : ClauseDb α) (σ₀ : PartPropAssignment) (hints : Array α)
    : UnitPropResultDep db σ₀ hints := Id.run do
  let mut σ : {σ : PartPropAssignment //
      db.toPropTermSub (· ∈ hints.data) ⊓ σ₀.toPropTerm ≤ σ.toPropTerm } :=
    ⟨σ₀, inf_le_right⟩
  for h : i in [0:hints.size] do
    let hint := hints[i]'(Membership.mem.upper h)
    have hMem : hint ∈ hints.data := Array.getElem_mem_data hints _

    match hGet : db.getClause hint with
    | none => return .hintNonexistent hint
    | some C =>
      have hDbσ₀ :
          db.toPropTermSub (· ∈ hints.data) ⊓ σ₀.toPropTerm ≤ C.toPropTerm ⊓ σ.val.toPropTerm :=
        le_inf (inf_le_of_left_le (toPropTermSub_of_getClause_eq_some db hMem hGet)) σ.property
      match hRed : C.reduce σ.val with
      | some #[] =>
        have : db.toPropTermSub (· ∈ hints.data) ⊓ σ₀.toPropTerm ≤ ⊥ := by
          have : C.toPropTerm ⊓ σ.val.toPropTerm ≤ ⊥ :=
            IClause.reduce_eq_some _ _ _ hRed
          exact le_trans hDbσ₀ this
        return .contradiction this
      | some C' =>
        let some ⟨u, hU⟩ := checkIsUnit C'
          | return .hintNotUnit hint C σ.val
        have : db.toPropTermSub (· ∈ hints.data) ⊓ σ₀.toPropTerm ≤
            PartPropAssignment.toPropTerm (σ.val.insert u.var u.polarity) := by
          have hU : db.toPropTermSub (· ∈ hints.data) ⊓ σ₀.toPropTerm ≤ u.toPropTerm := by
            have h := IClause.reduce_eq_some _ _ _ hRed
            conv at h => rhs; rw [← hU]; simp [IClause.toPropTerm]
            exact le_trans hDbσ₀ h
          refine PropTerm.entails_ext.mpr fun τ hτ => ?_
          have hU : τ ⊨ u.toPropTerm :=
            PropTerm.entails_ext.mp hU τ hτ
          have hσ : τ ⊨ σ.val.toPropTerm :=
            PropTerm.entails_ext.mp σ.property τ hτ
          rw [PartPropAssignment.satisfies_iff] at hσ ⊢
          intro x p hFind
          by_cases hEq : x = u.var
          next =>
            rw [hEq, HashMap.find?_insert _ _ LawfulBEq.rfl] at hFind
            rw [ILit.satisfies_iff] at hU
            simp_all
          next =>
            rw [HashMap.find?_insert_of_ne _ _ (bne_iff_ne _ _ |>.mpr (Ne.symm hEq))] at hFind
            exact hσ _ _ hFind
        σ := ⟨σ.val.insert u.var u.polarity, this⟩
      | _ => return .hintNotUnit hint C σ.val
  return .extended σ.val σ.property

end ClauseDb