/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import category_theory.limits.filtered_colimit_commutes_finite_limit
import category_theory.limits.preserves.functor_category
import category_theory.limits.preserves.shapes.equalizers
import category_theory.limits.bicones
import category_theory.limits.comma
import category_theory.limits.preserves.finite
import category_theory.limits.shapes.finite_limits

/-!
# Representably flat functors

We define representably flat functors as functors such that the category of structured arrows
over `X` is cofiltered for each `X`. This concept is also known as flat functors as in [Elephant]
Remark C2.3.7, and this name is suggested by Mike Shulman in
https://golem.ph.utexas.edu/category/2011/06/flat_functors_and_morphisms_of.html to avoid
confusion with other notions of flatness.

This definition is equivalent to left exact functors (functors that preserves finite limits) when
`C` has all finite limits.

## Main results

* `flat_of_preserves_finite_limits`: If `F : C ⥤ D` preserves finite limits and `C` has all finite
  limits, then `F` is flat.
* `preserves_finite_limits_of_flat`: If `F : C ⥤ D` is flat, then it preserves all finite limits.
* `preserves_finite_limits_iff_flat`: If `C` has all finite limits,
  then `F` is flat iff `F` is left_exact.
* `Lan_preserves_finite_limits_of_flat`: If `F : C ⥤ D` is a flat functor between small categories,
  then the functor `Lan F.op` between presheaves of sets preserves all finite limits.
* `flat_iff_Lan_flat`: If `C`, `D` are small and `C` has all finite limits, then `F` is flat iff
  `Lan F.op : (Cᵒᵖ ⥤ Type*) ⥤ (Dᵒᵖ ⥤ Type*)` is flat.
* `preserves_finite_limits_iff_Lan_preserves_finite_limits`: If `C`, `D` are small and `C` has all
  finite limits, then `F` preserves finite limits iff `Lan F.op : (Cᵒᵖ ⥤ Type*) ⥤ (Dᵒᵖ ⥤ Type*)`
  does.

-/

universes w v₁ v₂ v₃ u₁ u₂ u₃

open category_theory
open category_theory.limits
open opposite

namespace category_theory

namespace structured_arrow_cone
open structured_arrow
variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₁} D]
variables {J : Type w} [small_category J]
variables {K : J ⥤ C} (F : C ⥤ D) (c : cone K)

/--
Given a cone `c : cone K` and a map `f : X ⟶ c.X`, we can construct a cone of structured
arrows over `X` with `f` as the cone point. This is the underlying diagram.
-/
@[simps]
def to_diagram : J ⥤ structured_arrow c.X K :=
{ obj := λ j, structured_arrow.mk (c.π.app j),
  map := λ j k g, structured_arrow.hom_mk g (by simpa) }

/-- Given a diagram of `structured_arrow X F`s, we may obtain a cone with cone point `X`. -/
@[simps]
def diagram_to_cone {X : D} (G : J ⥤ structured_arrow X F) : cone (G ⋙ proj X F ⋙ F) :=
{ X := X, π := { app := λ j, (G.obj j).hom } }

/--
Given a cone `c : cone K` and a map `f : X ⟶ F.obj c.X`, we can construct a cone of structured
arrows over `X` with `f` as the cone point.
-/
@[simps]
def to_cone {X : D} (f : X ⟶ F.obj c.X) :
  cone (to_diagram (F.map_cone c) ⋙ map f ⋙ pre _ K F) :=
{ X := mk f, π := { app := λ j, hom_mk (c.π.app j) rfl,
                    naturality' := λ j k g, by { ext, dsimp, simp } } }

end structured_arrow_cone

section representably_flat
variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]
variables {E : Type u₃} [category.{v₃} E]

/--
A functor `F : C ⥤ D` is representably-flat functor if the comma category `(X/F)`
is cofiltered for each `X : C`.
-/
class representably_flat (F : C ⥤ D) : Prop :=
(cofiltered : ∀ (X : D), is_cofiltered (structured_arrow X F))

attribute [instance] representably_flat.cofiltered

local attribute [instance] is_cofiltered.nonempty

instance representably_flat.id : representably_flat (𝟭 C) :=
begin
  constructor,
  intro X,
  haveI : nonempty (structured_arrow X (𝟭 C)) := ⟨structured_arrow.mk (𝟙 _)⟩,
  suffices : is_cofiltered_or_empty (structured_arrow X (𝟭 C)),
  { resetI, constructor },
  constructor,
  { intros Y Z,
    use structured_arrow.mk (𝟙 _),
    use structured_arrow.hom_mk Y.hom (by erw [functor.id_map, category.id_comp]),
    use structured_arrow.hom_mk Z.hom (by erw [functor.id_map, category.id_comp]) },
  { intros Y Z f g,
    use structured_arrow.mk (𝟙 _),
    use structured_arrow.hom_mk Y.hom (by erw [functor.id_map, category.id_comp]),
    ext,
    transitivity Z.hom; simp }
end

instance representably_flat.comp (F : C ⥤ D) (G : D ⥤ E)
  [representably_flat F] [representably_flat G] : representably_flat (F ⋙ G) :=
begin
  constructor,
  intro X,
  haveI : nonempty (structured_arrow X (F ⋙ G)),
  { have f₁ : structured_arrow X G := nonempty.some infer_instance,
    have f₂ : structured_arrow f₁.right F := nonempty.some infer_instance,
    exact ⟨structured_arrow.mk (f₁.hom ≫ G.map f₂.hom)⟩ },
  suffices : is_cofiltered_or_empty (structured_arrow X (F ⋙ G)),
  { resetI, constructor },
  constructor,
  { intros Y Z,
    let W := @is_cofiltered.min (structured_arrow X G) _ _
      (structured_arrow.mk Y.hom) (structured_arrow.mk Z.hom),
    let Y' : W ⟶ _ := is_cofiltered.min_to_left _ _,
    let Z' : W ⟶ _ := is_cofiltered.min_to_right _ _,

    let W' := @is_cofiltered.min (structured_arrow W.right F) _ _
      (structured_arrow.mk Y'.right) (structured_arrow.mk Z'.right),
    let Y'' : W' ⟶ _ := is_cofiltered.min_to_left _ _,
    let Z'' : W' ⟶ _ := is_cofiltered.min_to_right _ _,

    use structured_arrow.mk (W.hom ≫ G.map W'.hom),
    use structured_arrow.hom_mk Y''.right (by simp [← G.map_comp]),
    use structured_arrow.hom_mk Z''.right (by simp [← G.map_comp]) },
  { intros Y Z f g,
    let W := @is_cofiltered.eq (structured_arrow X G) _ _
        (structured_arrow.mk Y.hom) (structured_arrow.mk Z.hom)
        (structured_arrow.hom_mk (F.map f.right) (structured_arrow.w f))
        (structured_arrow.hom_mk (F.map g.right) (structured_arrow.w g)),
    let h : W ⟶ _ := is_cofiltered.eq_hom _ _,
    let h_cond : h ≫ _ = h ≫ _ := is_cofiltered.eq_condition _ _,

    let W' := @is_cofiltered.eq (structured_arrow W.right F) _ _
        (structured_arrow.mk h.right) (structured_arrow.mk (h.right ≫ F.map f.right))
        (structured_arrow.hom_mk f.right rfl)
        (structured_arrow.hom_mk g.right (congr_arg comma_morphism.right h_cond).symm),
    let h' : W' ⟶ _ := is_cofiltered.eq_hom _ _,
    let h'_cond : h' ≫ _ = h' ≫ _ := is_cofiltered.eq_condition _ _,

    use structured_arrow.mk (W.hom ≫ G.map W'.hom),
    use structured_arrow.hom_mk h'.right (by simp [← G.map_comp]),
    ext,
    exact (congr_arg comma_morphism.right h'_cond : _) }
end

end representably_flat

section has_limit
variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₁} D]

local attribute [instance] has_finite_limits_of_has_finite_limits_of_size

@[priority 100]
instance cofiltered_of_has_finite_limits [has_finite_limits C] : is_cofiltered C :=
{ cocone_objs := λ A B, ⟨limits.prod A B, limits.prod.fst, limits.prod.snd, trivial⟩,
  cocone_maps :=  λ A B f g, ⟨equalizer f g, equalizer.ι f g, equalizer.condition f g⟩,
  nonempty := ⟨⊤_ C⟩ }

lemma flat_of_preserves_finite_limits [has_finite_limits C] (F : C ⥤ D)
  [preserves_finite_limits F] : representably_flat F := ⟨λ X,
begin
  haveI : has_finite_limits (structured_arrow X F) :=
  begin
    apply has_finite_limits_of_has_finite_limits_of_size.{v₁} (structured_arrow X F),
    intros J sJ fJ, resetI, constructor
  end,
  apply_instance
end⟩

namespace preserves_finite_limits_of_flat
open structured_arrow
open structured_arrow_cone
variables {J : Type v₁} [small_category J] [fin_category J] {K : J ⥤ C}
variables (F : C ⥤ D) [representably_flat F] {c : cone K} (hc : is_limit c) (s : cone (K ⋙ F))
include hc

/--
(Implementation).
Given a limit cone `c : cone K` and a cone `s : cone (K ⋙ F)` with `F` representably flat,
`s` can factor through `F.map_cone c`.
-/
noncomputable def lift : s.X ⟶ F.obj c.X :=
let s' := is_cofiltered.cone (to_diagram s ⋙ structured_arrow.pre _ K F) in
s'.X.hom ≫ (F.map $ hc.lift $
  (cones.postcompose ({ app := λ X, 𝟙 _, naturality' := by simp }
      : (to_diagram s ⋙ pre s.X K F) ⋙ proj s.X F ⟶ K)).obj $
  (structured_arrow.proj s.X F).map_cone s')

lemma fac (x : J) : lift F hc s ≫ (F.map_cone c).π.app x = s.π.app x :=
by simpa [lift, ←functor.map_comp]

local attribute [simp] eq_to_hom_map

lemma uniq {K : J ⥤ C} {c : cone K} (hc : is_limit c)
  (s : cone (K ⋙ F)) (f₁ f₂ : s.X ⟶ F.obj c.X)
  (h₁ : ∀ (j : J), f₁ ≫ (F.map_cone c).π.app j = s.π.app j)
  (h₂ : ∀ (j : J), f₂ ≫ (F.map_cone c).π.app j = s.π.app j) : f₁ = f₂ :=
begin
  -- We can make two cones over the diagram of `s` via `f₁` and `f₂`.
  let α₁ : to_diagram (F.map_cone c) ⋙ map f₁ ⟶ to_diagram s :=
  { app := λ X, eq_to_hom (by simp [←h₁]), naturality' := λ _ _ _, by { ext, simp } },
  let α₂ : to_diagram (F.map_cone c) ⋙ map f₂ ⟶ to_diagram s :=
  { app := λ X, eq_to_hom (by simp [←h₂]), naturality' := λ _ _ _, by { ext, simp } },
  let c₁ : cone (to_diagram s ⋙ pre s.X K F) :=
    (cones.postcompose (whisker_right α₁ (pre s.X K F) : _)).obj (to_cone F c f₁),
  let c₂ : cone (to_diagram s ⋙ pre s.X K F) :=
    (cones.postcompose (whisker_right α₂ (pre s.X K F) : _)).obj (to_cone F c f₂),

  -- The two cones can then be combined and we may obtain a cone over the two cones since
  -- `structured_arrow s.X F` is cofiltered.
  let c₀ := is_cofiltered.cone (bicone_mk _ c₁ c₂),
  let g₁ : c₀.X ⟶ c₁.X := c₀.π.app (bicone.left),
  let g₂ : c₀.X ⟶ c₂.X := c₀.π.app (bicone.right),

  -- Then `g₁.right` and `g₂.right` are two maps from the same cone into the `c`.
  have : ∀ (j : J), g₁.right ≫ c.π.app j = g₂.right ≫ c.π.app j,
  { intro j,
    injection c₀.π.naturality (bicone_hom.left  j) with _ e₁,
    injection c₀.π.naturality (bicone_hom.right j) with _ e₂,
    simpa using e₁.symm.trans e₂ },
  have : c.extend g₁.right = c.extend g₂.right,
  { unfold cone.extend, congr' 1, ext x, apply this },

  -- And thus they are equal as `c` is the limit.
  have : g₁.right = g₂.right,
  calc g₁.right = hc.lift (c.extend g₁.right) : by { apply hc.uniq (c.extend _), tidy }
            ... = hc.lift (c.extend g₂.right) : by { congr, exact this }
            ... = g₂.right                    : by { symmetry, apply hc.uniq (c.extend _), tidy },

  -- Finally, since `fᵢ` factors through `F(gᵢ)`, the result follows.
  calc f₁ = 𝟙 _ ≫ f₁                  : by simp
      ... = c₀.X.hom ≫ F.map g₁.right : g₁.w
      ... = c₀.X.hom ≫ F.map g₂.right : by rw this
      ... = 𝟙 _ ≫ f₂                  : g₂.w.symm
      ... = f₂                         : by simp
end

end preserves_finite_limits_of_flat

/-- Representably flat functors preserve finite limits. -/
noncomputable
def preserves_finite_limits_of_flat (F : C ⥤ D) [representably_flat F] :
  preserves_finite_limits F :=
begin
  apply preserves_finite_limits_of_preserves_finite_limits_of_size,
  intros J _ _, constructor,
  intros K, constructor,
  intros c hc,
  exactI { lift := preserves_finite_limits_of_flat.lift F hc,
    fac' := preserves_finite_limits_of_flat.fac F hc,
    uniq' := λ s m h, by
    { apply preserves_finite_limits_of_flat.uniq F hc,
      exact h,
      exact preserves_finite_limits_of_flat.fac F hc s } }
end

/--
If `C` is finitely cocomplete, then `F : C ⥤ D` is representably flat iff it preserves
finite limits.
-/
noncomputable
def preserves_finite_limits_iff_flat [has_finite_limits C] (F : C ⥤ D) :
  representably_flat F ≃ preserves_finite_limits F :=
{ to_fun := λ _, by exactI preserves_finite_limits_of_flat F,
  inv_fun := λ _, by exactI flat_of_preserves_finite_limits F,
  left_inv := λ _, proof_irrel _ _,
  right_inv := λ x, by { cases x, unfold preserves_finite_limits_of_flat,
    dunfold preserves_finite_limits_of_preserves_finite_limits_of_size, congr } }

end has_limit

section small_category
variables {C D : Type u₁} [small_category C] [small_category D] (E : Type u₂) [category.{u₁} E]

/--
(Implementation)
The evaluation of `Lan F` at `X` is the colimit over the costructured arrows over `X`.
-/
noncomputable
def Lan_evaluation_iso_colim (F : C ⥤ D) (X : D)
  [∀ (X : D), has_colimits_of_shape (costructured_arrow F X) E] :
  Lan F ⋙ (evaluation D E).obj X ≅
  ((whiskering_left _ _ E).obj (costructured_arrow.proj F X)) ⋙ colim :=
nat_iso.of_components (λ G, colim.map_iso (iso.refl _))
begin
  intros G H i,
  ext,
  simp only [functor.comp_map, colimit.ι_desc_assoc, functor.map_iso_refl, evaluation_obj_map,
    whiskering_left_obj_map, category.comp_id, Lan_map_app, category.assoc],
  erw [colimit.ι_pre_assoc (Lan.diagram F H X) (costructured_arrow.map j.hom),
    category.id_comp, category.comp_id, colimit.ι_map],
  rcases j with ⟨j_left, ⟨⟨⟩⟩, j_hom⟩,
  congr,
  rw [costructured_arrow.map_mk, category.id_comp, costructured_arrow.mk]
end

variables [concrete_category.{u₁} E] [has_limits E] [has_colimits E]
variables [reflects_limits (forget E)] [preserves_filtered_colimits (forget E)]
variables [preserves_limits (forget E)]

/--
If `F : C ⥤ D` is a representably flat functor between small categories, then the functor
`Lan F.op` that takes presheaves over `C` to presheaves over `D` preserves finite limits.
-/
noncomputable
instance Lan_preserves_finite_limits_of_flat (F : C ⥤ D) [representably_flat F] :
  preserves_finite_limits (Lan F.op : _ ⥤ (Dᵒᵖ ⥤ E)) :=
begin
  apply preserves_finite_limits_of_preserves_finite_limits_of_size.{u₁},
  intros J _ _, resetI,
  apply preserves_limits_of_shape_of_evaluation (Lan F.op : (Cᵒᵖ ⥤ E) ⥤ (Dᵒᵖ ⥤ E)) J,
  intro K,
  haveI : is_filtered (costructured_arrow F.op K) :=
    is_filtered.of_equivalence (structured_arrow_op_equivalence F (unop K)),
  exact preserves_limits_of_shape_of_nat_iso (Lan_evaluation_iso_colim _ _ _).symm,
end

instance Lan_flat_of_flat (F : C ⥤ D) [representably_flat F] :
  representably_flat (Lan F.op : _ ⥤ (Dᵒᵖ ⥤ E)) := flat_of_preserves_finite_limits _

variable [has_finite_limits C]

noncomputable
instance Lan_preserves_finite_limits_of_preserves_finite_limits (F : C ⥤ D)
  [preserves_finite_limits F] : preserves_finite_limits (Lan F.op : _ ⥤ (Dᵒᵖ ⥤ E)) :=
begin
  haveI := flat_of_preserves_finite_limits F,
  apply_instance
end

lemma flat_iff_Lan_flat (F : C ⥤ D) :
  representably_flat F ↔ representably_flat (Lan F.op : _ ⥤ (Dᵒᵖ ⥤ Type u₁)) :=
⟨λ H, by exactI infer_instance, λ H,
begin
  resetI,
  haveI := preserves_finite_limits_of_flat (Lan F.op : _ ⥤ (Dᵒᵖ ⥤ Type u₁)),
  haveI : preserves_finite_limits F :=
    begin
      apply preserves_finite_limits_of_preserves_finite_limits_of_size.{u₁},
      intros, resetI, apply preserves_limit_of_Lan_presesrves_limit
    end,
  apply flat_of_preserves_finite_limits
end⟩

/--
If `C` is finitely complete, then `F : C ⥤ D` preserves finite limits iff
`Lan F.op : (Cᵒᵖ ⥤ Type*) ⥤ (Dᵒᵖ ⥤ Type*)` preserves finite limits.
-/
noncomputable
def preserves_finite_limits_iff_Lan_preserves_finite_limits (F : C ⥤ D) :
  preserves_finite_limits F ≃ preserves_finite_limits (Lan F.op : _ ⥤ (Dᵒᵖ ⥤ Type u₁)) :=
{ to_fun := λ _, by exactI infer_instance,
  inv_fun := λ _,
  begin
    apply preserves_finite_limits_of_preserves_finite_limits_of_size.{u₁},
    intros, resetI, apply preserves_limit_of_Lan_presesrves_limit
  end,
  left_inv := λ x,
  begin
    cases x, unfold preserves_finite_limits_of_flat,
    dunfold preserves_finite_limits_of_preserves_finite_limits_of_size, congr
  end,
  right_inv := λ x,
  begin
    cases x,
    unfold preserves_finite_limits_of_flat,
    congr,
    unfold category_theory.Lan_preserves_finite_limits_of_preserves_finite_limits
      category_theory.Lan_preserves_finite_limits_of_flat,
    dunfold preserves_finite_limits_of_preserves_finite_limits_of_size, congr
  end }

end small_category
end category_theory


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monad.basic
import Mathlib.category_theory.monad.kleisli
import Mathlib.category_theory.category.Kleisli
import Mathlib.category_theory.types
import Mathlib.PostPort

universes u

namespace Mathlib

/-!

# Convert from `monad` (i.e. Lean's `Type`-based monads) to `category_theory.monad`

This allows us to use these monads in category theory.

-/

namespace category_theory

protected instance of_type_functor.monad (m : Type u → Type u) [Monad m] [is_lawful_monad m] :
    monad (of_type_functor m) :=
  monad.mk (nat_trans.mk pure) (nat_trans.mk mjoin)

/--
The `Kleisli` category of a `control.monad` is equivalent to the `kleisli` category of its
category-theoretic version, provided the monad is lawful.
-/
@[simp] theorem eq_unit_iso (m : Type u → Type u) [Monad m] [is_lawful_monad m] :
    equivalence.unit_iso (eq m) =
        nat_iso.of_components (fun (X : Kleisli m) => iso.refl X) (eq._proof_7 m) :=
  Eq.refl (equivalence.unit_iso (eq m))

end Mathlib


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Patrick Massot, Sébastien Gouëzel, Zhouhang Zhou, Reid Barton
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.dense_embedding
import Mathlib.PostPort

universes u_5 u_6 l u_1 u_2 u_3 u_4 u v

namespace Mathlib

/-- Homeomorphism between `α` and `β`, also called topological isomorphism -/
structure homeomorph (α : Type u_5) (β : Type u_6) [topological_space α] [topological_space β]
extends α ≃ β
where
  continuous_to_fun : autoParam (continuous (equiv.to_fun _to_equiv))
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.interactive.continuity'")
    (Lean.Name.mkStr
      (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic") "interactive")
      "continuity'")
    [])
  continuous_inv_fun : autoParam (continuous (equiv.inv_fun _to_equiv))
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.interactive.continuity'")
    (Lean.Name.mkStr
      (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic") "interactive")
      "continuity'")
    [])

infixl:25 " ≃ₜ " => Mathlib.homeomorph

namespace homeomorph

protected instance has_coe_to_fun {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] : has_coe_to_fun (α ≃ₜ β) :=
  has_coe_to_fun.mk (fun (_x : α ≃ₜ β) => α → β) fun (e : α ≃ₜ β) => ⇑(to_equiv e)

@[simp] theorem homeomorph_mk_coe {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (a : α ≃ β) (b : autoParam (continuous (equiv.to_fun a))
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.interactive.continuity'")
    (Lean.Name.mkStr
      (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic") "interactive")
      "continuity'")
    [])) (c : autoParam (continuous (equiv.inv_fun a))
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.interactive.continuity'")
    (Lean.Name.mkStr
      (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic") "interactive")
      "continuity'")
    [])) : ⇑(mk a) = ⇑a :=
  rfl

theorem coe_eq_to_equiv {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) (a : α) : coe_fn h a = coe_fn (to_equiv h) a :=
  rfl

theorem to_equiv_injective {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] : function.injective to_equiv := sorry

theorem ext {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] {h : α ≃ₜ β} {h' : α ≃ₜ β} (H : ∀ (x : α), coe_fn h x = coe_fn h' x) : h = h' :=
  to_equiv_injective (equiv.ext H)

/-- Identity map as a homeomorphism. -/
protected def refl (α : Type u_1) [topological_space α] : α ≃ₜ α :=
  mk (equiv.mk (equiv.to_fun (equiv.refl α)) (equiv.inv_fun (equiv.refl α)) sorry sorry)

/-- Composition of two homeomorphisms. -/
protected def trans {α : Type u_1} {β : Type u_2} {γ : Type u_3} [topological_space α] [topological_space β] [topological_space γ] (h₁ : α ≃ₜ β) (h₂ : β ≃ₜ γ) : α ≃ₜ γ :=
  mk
    (equiv.mk (equiv.to_fun (equiv.trans (to_equiv h₁) (to_equiv h₂)))
      (equiv.inv_fun (equiv.trans (to_equiv h₁) (to_equiv h₂))) sorry sorry)

/-- Inverse of a homeomorphism. -/
protected def symm {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) : β ≃ₜ α :=
  mk (equiv.mk (equiv.to_fun (equiv.symm (to_equiv h))) (equiv.inv_fun (equiv.symm (to_equiv h))) sorry sorry)

@[simp] theorem homeomorph_mk_coe_symm {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (a : α ≃ β) (b : autoParam (continuous (equiv.to_fun a))
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.interactive.continuity'")
    (Lean.Name.mkStr
      (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic") "interactive")
      "continuity'")
    [])) (c : autoParam (continuous (equiv.inv_fun a))
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.interactive.continuity'")
    (Lean.Name.mkStr
      (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic") "interactive")
      "continuity'")
    [])) : ⇑(homeomorph.symm (mk a)) = ⇑(equiv.symm a) :=
  rfl

protected theorem continuous {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) : continuous ⇑h :=
  continuous_to_fun h

@[simp] theorem apply_symm_apply {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) (x : β) : coe_fn h (coe_fn (homeomorph.symm h) x) = x :=
  equiv.apply_symm_apply (to_equiv h) x

@[simp] theorem symm_apply_apply {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) (x : α) : coe_fn (homeomorph.symm h) (coe_fn h x) = x :=
  equiv.symm_apply_apply (to_equiv h) x

protected theorem bijective {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) : function.bijective ⇑h :=
  equiv.bijective (to_equiv h)

protected theorem injective {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) : function.injective ⇑h :=
  equiv.injective (to_equiv h)

protected theorem surjective {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) : function.surjective ⇑h :=
  equiv.surjective (to_equiv h)

/-- Change the homeomorphism `f` to make the inverse function definitionally equal to `g`. -/
def change_inv {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (f : α ≃ₜ β) (g : β → α) (hg : function.right_inverse g ⇑f) : α ≃ₜ β :=
  (fun (this : g = ⇑(homeomorph.symm f)) => mk (equiv.mk (⇑f) g sorry sorry)) sorry

@[simp] theorem symm_comp_self {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) : ⇑(homeomorph.symm h) ∘ ⇑h = id :=
  funext (symm_apply_apply h)

@[simp] theorem self_comp_symm {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) : ⇑h ∘ ⇑(homeomorph.symm h) = id :=
  funext (apply_symm_apply h)

@[simp] theorem range_coe {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) : set.range ⇑h = set.univ :=
  function.surjective.range_eq (homeomorph.surjective h)

theorem image_symm {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) : set.image ⇑(homeomorph.symm h) = set.preimage ⇑h :=
  funext (equiv.image_eq_preimage (to_equiv (homeomorph.symm h)))

theorem preimage_symm {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) : set.preimage ⇑(homeomorph.symm h) = set.image ⇑h :=
  Eq.symm (funext (equiv.image_eq_preimage (to_equiv h)))

@[simp] theorem image_preimage {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) (s : set β) : ⇑h '' (⇑h ⁻¹' s) = s :=
  equiv.image_preimage (to_equiv h) s

@[simp] theorem preimage_image {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) (s : set α) : ⇑h ⁻¹' (⇑h '' s) = s :=
  equiv.preimage_image (to_equiv h) s

protected theorem inducing {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) : inducing ⇑h := sorry

theorem induced_eq {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) : topological_space.induced (⇑h) _inst_2 = _inst_1 :=
  Eq.symm (inducing.induced (homeomorph.inducing h))

protected theorem quotient_map {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) : quotient_map ⇑h := sorry

theorem coinduced_eq {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) : topological_space.coinduced (⇑h) _inst_1 = _inst_2 :=
  Eq.symm (and.right (homeomorph.quotient_map h))

protected theorem embedding {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) : embedding ⇑h :=
  embedding.mk (homeomorph.inducing h) (equiv.injective (to_equiv h))

theorem compact_image {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] {s : set α} (h : α ≃ₜ β) : is_compact (⇑h '' s) ↔ is_compact s :=
  iff.symm (embedding.compact_iff_compact_image (homeomorph.embedding h))

theorem compact_preimage {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] {s : set β} (h : α ≃ₜ β) : is_compact (⇑h ⁻¹' s) ↔ is_compact s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_compact (⇑h ⁻¹' s) ↔ is_compact s)) (Eq.symm (image_symm h))))
    (compact_image (homeomorph.symm h))

protected theorem dense_embedding {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) : dense_embedding ⇑h :=
  dense_embedding.mk
    (dense_inducing.mk (inducing.mk (Eq.symm (induced_eq h))) (function.surjective.dense_range (homeomorph.surjective h)))
    (homeomorph.injective h)

@[simp] theorem is_open_preimage {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) {s : set β} : is_open (⇑h ⁻¹' s) ↔ is_open s :=
  quotient_map.is_open_preimage (homeomorph.quotient_map h)

@[simp] theorem is_open_image {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) {s : set α} : is_open (⇑h '' s) ↔ is_open s := sorry

@[simp] theorem is_closed_preimage {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) {s : set β} : is_closed (⇑h ⁻¹' s) ↔ is_closed s := sorry

@[simp] theorem is_closed_image {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) {s : set α} : is_closed (⇑h '' s) ↔ is_closed s := sorry

theorem preimage_closure {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) (s : set β) : ⇑h ⁻¹' closure s = closure (⇑h ⁻¹' s) := sorry

theorem image_closure {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) (s : set α) : ⇑h '' closure s = closure (⇑h '' s) := sorry

protected theorem is_open_map {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) : is_open_map ⇑h :=
  fun (s : set α) => iff.mpr (is_open_image h)

protected theorem is_closed_map {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) : is_closed_map ⇑h :=
  fun (s : set α) => iff.mpr (is_closed_image h)

protected theorem closed_embedding {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) : closed_embedding ⇑h :=
  closed_embedding_of_embedding_closed (homeomorph.embedding h) (homeomorph.is_closed_map h)

@[simp] theorem map_nhds_eq {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) (x : α) : filter.map (⇑h) (nhds x) = nhds (coe_fn h x) := sorry

@[simp] theorem comap_nhds_eq {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) (y : β) : filter.comap (⇑h) (nhds y) = nhds (coe_fn (homeomorph.symm h) y) := sorry

theorem nhds_eq_comap {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (h : α ≃ₜ β) (x : α) : nhds x = filter.comap (⇑h) (nhds (coe_fn h x)) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (nhds x = filter.comap (⇑h) (nhds (coe_fn h x)))) (comap_nhds_eq h (coe_fn h x))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (nhds x = nhds (coe_fn (homeomorph.symm h) (coe_fn h x)))) (symm_apply_apply h x)))
      (Eq.refl (nhds x)))

/-- If an bijective map `e : α ≃ β` is continuous and open, then it is a homeomorphism. -/
def homeomorph_of_continuous_open {α : Type u_1} {β : Type u_2} [topological_space α] [topological_space β] (e : α ≃ β) (h₁ : continuous ⇑e) (h₂ : is_open_map ⇑e) : α ≃ₜ β :=
  mk (equiv.mk (equiv.to_fun e) (equiv.inv_fun e) (equiv.left_inv e) (equiv.right_inv e))

@[simp] theorem comp_continuous_on_iff {α : Type u_1} {β : Type u_2} {γ : Type u_3} [topological_space α] [topological_space β] [topological_space γ] (h : α ≃ₜ β) (f : γ → α) (s : set γ) : continuous_on (⇑h ∘ f) s ↔ continuous_on f s :=
  iff.symm (inducing.continuous_on_iff (homeomorph.inducing h))

@[simp] theorem comp_continuous_iff {α : Type u_1} {β : Type u_2} {γ : Type u_3} [topological_space α] [topological_space β] [topological_space γ] (h : α ≃ₜ β) {f : γ → α} : continuous (⇑h ∘ f) ↔ continuous f :=
  iff.symm (inducing.continuous_iff (homeomorph.inducing h))

@[simp] theorem comp_continuous_iff' {α : Type u_1} {β : Type u_2} {γ : Type u_3} [topological_space α] [topological_space β] [topological_space γ] (h : α ≃ₜ β) {f : β → γ} : continuous (f ∘ ⇑h) ↔ continuous f :=
  iff.symm (quotient_map.continuous_iff (homeomorph.quotient_map h))

/-- If two sets are equal, then they are homeomorphic. -/
def set_congr {α : Type u_1} [topological_space α] {s : set α} {t : set α} (h : s = t) : ↥s ≃ₜ ↥t :=
  mk (equiv.mk (equiv.to_fun (equiv.set_congr h)) (equiv.inv_fun (equiv.set_congr h)) sorry sorry)

/-- Sum of two homeomorphisms. -/
def sum_congr {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} [topological_space α] [topological_space β] [topological_space γ] [topological_space δ] (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) : α ⊕ γ ≃ₜ β ⊕ δ :=
  mk
    (equiv.mk (equiv.to_fun (equiv.sum_congr (to_equiv h₁) (to_equiv h₂)))
      (equiv.inv_fun (equiv.sum_congr (to_equiv h₁) (to_equiv h₂))) sorry sorry)

/-- Product of two homeomorphisms. -/
def prod_congr {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} [topological_space α] [topological_space β] [topological_space γ] [topological_space δ] (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) : α × γ ≃ₜ β × δ :=
  mk
    (equiv.mk (equiv.to_fun (equiv.prod_congr (to_equiv h₁) (to_equiv h₂)))
      (equiv.inv_fun (equiv.prod_congr (to_equiv h₁) (to_equiv h₂))) sorry sorry)

/-- `α × β` is homeomorphic to `β × α`. -/
def prod_comm (α : Type u_1) (β : Type u_2) [topological_space α] [topological_space β] : α × β ≃ₜ β × α :=
  mk (equiv.mk (equiv.to_fun (equiv.prod_comm α β)) (equiv.inv_fun (equiv.prod_comm α β)) sorry sorry)

/-- `(α × β) × γ` is homeomorphic to `α × (β × γ)`. -/
def prod_assoc (α : Type u_1) (β : Type u_2) (γ : Type u_3) [topological_space α] [topological_space β] [topological_space γ] : (α × β) × γ ≃ₜ α × β × γ :=
  mk (equiv.mk (equiv.to_fun (equiv.prod_assoc α β γ)) (equiv.inv_fun (equiv.prod_assoc α β γ)) sorry sorry)

/-- `ulift α` is homeomorphic to `α`. -/
def ulift {α : Type u} [topological_space α] : ulift α ≃ₜ α :=
  mk (equiv.mk (equiv.to_fun equiv.ulift) (equiv.inv_fun equiv.ulift) sorry sorry)

/-- `(α ⊕ β) × γ` is homeomorphic to `α × γ ⊕ β × γ`. -/
def sum_prod_distrib {α : Type u_1} {β : Type u_2} {γ : Type u_3} [topological_space α] [topological_space β] [topological_space γ] : (α ⊕ β) × γ ≃ₜ α × γ ⊕ β × γ :=
  homeomorph.symm (homeomorph_of_continuous_open (equiv.symm (equiv.sum_prod_distrib α β γ)) sorry sorry)

/-- `α × (β ⊕ γ)` is homeomorphic to `α × β ⊕ α × γ`. -/
def prod_sum_distrib {α : Type u_1} {β : Type u_2} {γ : Type u_3} [topological_space α] [topological_space β] [topological_space γ] : α × (β ⊕ γ) ≃ₜ α × β ⊕ α × γ :=
  homeomorph.trans (prod_comm α (β ⊕ γ)) (homeomorph.trans sum_prod_distrib (sum_congr (prod_comm β α) (prod_comm γ α)))

/-- `(Σ i, σ i) × β` is homeomorphic to `Σ i, (σ i × β)`. -/
def sigma_prod_distrib {β : Type u_2} [topological_space β] {ι : Type u_5} {σ : ι → Type u_6} [(i : ι) → topological_space (σ i)] : (sigma fun (i : ι) => σ i) × β ≃ₜ sigma fun (i : ι) => σ i × β :=
  homeomorph.symm (homeomorph_of_continuous_open (equiv.symm (equiv.sigma_prod_distrib σ β)) sorry sorry)


import category_theory.instances.topological_spaces
import category_theory.limits.pullbacks
import category_theory.const
import topology.continuity

open category_theory.instances
open category_theory.limits
open category_theory.functor
open category_theory
open sum

universe u
noncomputable theory

variables {X Y Z : Top.{u}}
variables (f : X ⟶ Y) (g : X ⟶ Z)

-- in the following diagram P is the pushout we wish to construct
-- X  ⟶  Y
-- ↓      ↓
-- Z  ⟶  P

-- this relation identifies any x and y that are the image of the same
-- point in X
def r (x : sum Y.α Z.α) (y : sum Y.α Z.α) : Prop :=
x = y ∨
∃ a : X.α, inl (f.val a) = x ∧ inr (g.val a) = y

def P : Top := { α := quot (r f g), str := by apply_instance}

-- inclusion maps from Y and Z into the pushout P
def i_Y : Y ⟶ P f g := { val := quot.mk (r f g) ∘ inl,
    property := continuous.comp continuous_inl continuous_quot_mk }
def i_Z : Z ⟶ P f g := { val := quot.mk (r f g) ∘ inr,
    property := continuous.comp continuous_inr continuous_quot_mk }

lemma natural : f ≫ (i_Y f g) = g ≫ (i_Z f g) :=
subtype.eq
begin
  rw [concrete_category_comp, i_Y, i_Z],
  dsimp,
  ext,
  rw [function.comp.assoc],
  apply quot.sound,
  exact or.inr ⟨ x, ⟨ rfl, rfl ⟩ ⟩,
end

def Top.nat_trans_app (A : walking_span) : (span f g).obj A ⟶ ((const walking_span).obj (P f g)).obj A :=
    match A with
| walking_span.zero  := f ≫ (i_Y f g)
| walking_span.left  := i_Y f g
| walking_span.right := i_Z f g
end

def Top.nat_trans : span f g ⟹ (const walking_span).obj (P f g) := { app := Top.nat_trans_app f g,
naturality' := sorry }

def topcat : category Top := by apply_instance

-- cosquare := λ f g, something of type cocone (span f g)
-- span f g is a functor from walking_span.{v} to Top
-- cocone (F : J ⥤ Top) is a structure taking an object X : Top and
-- a natural transformation ι taking F to (const J).obj X
-- natural transformations have an app field and a naturality' field
instance toppush : @has_pushouts Top topcat := { cosquare := sorry,
is_pushout := sorry }


import o_minimal.definable

open o_minimal

variables {R : Type*} (S : struc R)

/-- A *definable presheaf* structure on a type X
consists of the data of, for every definable set S ⊆ Rⁿ,
a predicate `definable` on functions S → X, satisfying the axiom:
for every definable map φ : T → S, precomposition by φ
preserves definable functions into X. -/
-- TODO: Refactor to be prior to def_set/def_fun?
class definable_presheaf (X : Type*) :=
(definable : Π {n : ℕ} {s : set (finvec n R)} (ds : def_set S s),
  (s → X) → Prop)
(definable_precomp : Π {n m : ℕ} {s : set (finvec n R)} {ds : def_set S s}
  {t : set (finvec m R)} {dt : def_set S t} (φ : t → s)
  (dφ : @def_fun R S _ _ (is_definable.subtype dt) _ _ (is_definable.subtype ds) φ)
--(dφ : S.definable {z | ∃ (hz : finvec.left z ∈ t), (φ ⟨finvec.left z, hz⟩).val = finvec.right z})
  (f : s → X), definable ds f → definable dt (f ∘ φ))

-- TODO: sheaf conditions

instance Prop.definable_presheaf : definable_presheaf S Prop :=
{ definable := λ n s ds a, @def_set R S _ _ (is_definable.subtype ds) a,
  definable_precomp := λ n m s ds t dt φ dφ a da,
  @def_fun.preimage R S _ _ (is_definable.subtype dt) _ _ (is_definable.subtype ds) φ dφ a da }

-- for now don't make this an instance, because of diamond problem with ×
def definable_presheaf_of_is_definable {X : Type*} [has_coordinates R X] [is_definable S X] :
  definable_presheaf S X :=
{ definable := λ n s ds f, by haveI := is_definable.subtype ds; exact def_fun S f,
  definable_precomp := λ n m s ds t dt φ dφ a da,
  by haveI := is_definable.subtype ds; haveI := is_definable.subtype dt; exact da.comp dφ }

structure defin {X : Type*} [definable_presheaf S X] {Y : Type*} [definable_presheaf S Y]
  (F : X → Y) : Prop :=
(preserves_definable : ∀ {n : ℕ} {s : set (finvec n R)} (ds : def_set S s) {f : s → X},
  definable_presheaf.definable ds f → definable_presheaf.definable ds (F ∘ f))

section yoneda
local attribute [instance] definable_presheaf_of_is_definable
-- A definable map between representables is definable in the new sense
-- if and only if it was definable in the old one.
-- A definable set in a representable is definable in the new sense
-- if and only if it was definable in the old one.

variables {X : Type*} [has_coordinates R X] [is_definable S X]
variables {Y : Type*} [has_coordinates R Y] [is_definable S Y]

lemma def_fun_iff_defin {f : X → Y} : def_fun S f ↔ defin S f :=
sorry

lemma def_set_iff_defin {s : set X} : def_set S s ↔ defin S s :=
sorry

end yoneda

instance prod.definable_presheaf {X Y : Type*} [definable_presheaf S X] [definable_presheaf S Y] :
  definable_presheaf S (X × Y) :=
{ definable := λ n s ds a,
    definable_presheaf.definable ds (λ x, (a x).fst) ∧
    definable_presheaf.definable ds (λ x, (a x).snd),
  definable_precomp := λ n m s ds t dt φ dφ a da,
    ⟨definable_presheaf.definable_precomp φ dφ (λ x, (a x).fst) da.1,
     definable_presheaf.definable_precomp φ dφ (λ x, (a x).snd) da.2⟩ }

instance Pi.definable_presheaf {X Y : Type*} [definable_presheaf S X] [definable_presheaf S Y] :
  definable_presheaf S (X → Y) :=
{ definable := λ n s ds a,
    by haveI : is_definable S s := is_definable.subtype ds;
       haveI : definable_presheaf S s := definable_presheaf_of_is_definable S;
       exact defin S (λ (p : s × X), a p.1 p.2),
  definable_precomp := sorry }

-- TODO: prove exponential law for `defin`
-- prove (un)currying preserves `defin`

-- TODO: prove definability of ∧ : Prop → Prop → Prop, etc.
-- this amounts to definable sets forming a boolean algebra!

instance subtype.definable_presheaf {X : Type*} [definable_presheaf S X] (A : set X) :
  definable_presheaf S A :=
{ definable := λ n s ds a, definable_presheaf.definable ds (subtype.val ∘ a),
  definable_precomp := sorry }

class compat_definable_coordinates (X : Type*) [has_coordinates R X] [definable_presheaf S X]
-- * definable, like in `is_definable`
-- * `definable_presheaf` structure equals the one from `definable_presheaf_of_is_definable`


import category_theory.category
import category_theory.colimits
import category_theory.colimit_lemmas
import category_theory.replete
import category_theory.pasting_pushouts

universes v u

open category_theory
open category_theory.category
local notation f ` ∘ `:80 g:80 := g ≫ f

namespace homotopy_theory.cofibrations

class has_cofibrations (C : Type u) [category C] :=
(is_cof : Π ⦃a b : C⦄, (a ⟶ b) → Prop)

def is_cof {C : Type u} [category C] [has_cofibrations C] ⦃a b : C⦄ (f : a ⟶ b) : Prop :=
has_cofibrations.is_cof f

/-

We gather here axioms pertaining to cofibrations common to many
notions of "categories with cofibrations".

* The cofibrations form a subcategory which includes all isomorphisms.

* Pushouts of cofibrations exist and are again cofibrations.

An isomorphism is a pushout of an identity map, so it actually
suffices to require that identities are cofibrations.

TODO: In ABC cofibration categories, some of the axioms only apply to
cofibrations with cofibrant domain. Is this sufficient for our
purposes? Useful?

-/

class precofibration_category (C : Type u) [category.{v} C]
  extends has_cofibrations C, wide_subcategory.{v} C is_cof :=
(pushout_by_cof : Π ⦃a b a' : C⦄ (f : a ⟶ b) (g : a ⟶ a'), is_cof f → pushout f g)
(pushout_is_cof : ∀ ⦃a b a' b' : C⦄ {f : a ⟶ b} {g : a ⟶ a'} {f' : a' ⟶ b'} {g' : b ⟶ b'},
  Is_pushout f g g' f' → is_cof f → is_cof f')

open precofibration_category

variables {C : Type u} [category.{v} C] [precofibration_category C]
lemma cof_id (a : C) : is_cof (𝟙 a) := mem_id a
lemma cof_comp {a b c : C} {f : a ⟶ b} {g : b ⟶ c} :
  is_cof f → is_cof g → is_cof (g ∘ f) := mem_comp

instance precofibration_category.replete
  (C : Type u) [category.{v} C] [p : precofibration_category.{v} C] :
  replete_wide_subcategory.{v} C is_cof :=
{ mem_iso := assume a b i,
    pushout_is_cof
      (by convert Is_pushout_of_isomorphic' (Is_pushout.refl (𝟙 a)) i; simp; refl)
      (cof_id a) }

lemma cof_iso {a b : C} (i : a ≅ b) : is_cof i.hom := mem_iso i

-- The coproduct of cofibrations is a cofibration.
-- TODO: Should we try to express this using Is_coproduct?
-- TODO: Make `coproduct` a class and use it in notation
lemma cof_coprod [has_initial_object.{v} C] [has_coproducts.{v} C]
  {a₀ b₀ a₁ b₁ : C} {j₀ : a₀ ⟶ b₀} {j₁ : a₁ ⟶ b₁} (h₀ : is_cof j₀) (h₁ : is_cof j₁) :
  is_cof (coprod_of_maps j₀ j₁) :=
begin
  convert cof_comp
    (pushout_is_cof (Is_pushout_i₀ j₀) h₀)
    (pushout_is_cof (Is_pushout_i₁ j₁) h₁),
  apply coprod.uniqueness; { rw ←assoc, simp }
end

-- Basically the same as above, but in the slice category a/C and for
-- arbitrary (rather than chosen) pushouts.
lemma cof_pushout {a b₀ b₁ c b₀' b₁' c' : C} {f₀ : a ⟶ b₀} {f₁ : a ⟶ b₁}
  {g₀ : b₀ ⟶ c} {g₁ : b₁ ⟶ c} {g₀' : b₀' ⟶ c'} {g₁' : b₁' ⟶ c'}
  {h₀ : b₀ ⟶ b₀'} {h₁ : b₁ ⟶ b₁'} (hh₀ : is_cof h₀) (hh₁ : is_cof h₁)
  (po : Is_pushout f₀ f₁ g₀ g₁) (po' : Is_pushout (h₀ ∘ f₀) (h₁ ∘ f₁) g₀' g₁') (e) :
  is_cof (po.induced (g₀' ∘ h₀) (g₁' ∘ h₁) e) :=
let po₀ := pushout_by_cof h₀ g₀ hh₀,
    po₁ := Is_pushout_of_Is_pushout_of_Is_pushout_vert po po₀.is_pushout,
    k₁ := po₁.induced g₀' (g₁' ∘ h₁) (by simpa using e) in
have k₁ ∘ po₀.map₀ = g₀', by simp,
let po₂ := Is_pushout_of_Is_pushout_of_Is_pushout' po₁ (by convert po') (by simp) in
have k₁ ∘ po₀.map₁ = po.induced (g₀' ∘ h₀) (g₁' ∘ h₁) e, begin
  apply po.uniqueness,
  { rw [←assoc, ←po₀.is_pushout.commutes], simp },
  { rw [←assoc, po₂.commutes], simp }
end,
by rw ←this;
   exact cof_comp (pushout_is_cof po₀.is_pushout hh₀) (pushout_is_cof po₂.transpose hh₁)

-- Suppose C has an initial object ∅. Then an object A of C is
-- cofibrant if the unique map ∅ → A is a cofibration.
variables [has_initial_object.{v} C]

def cofibrant (a : C) : Prop := is_cof (! a)

-- TODO: Apply this in many places
lemma cofibrant_of_cof {a b : C} {j : a ⟶ b} (ha : cofibrant a) (hj : is_cof j) :
  cofibrant b :=
begin
  change is_cof _,
  convert cof_comp ha hj,
  apply initial.uniqueness
end

lemma cofibrant_coprod [has_initial_object.{v} C] [has_coproducts.{v} C]
  {a₀ a₁ : C} (h₀ : cofibrant a₀) (h₁ : cofibrant a₁) : cofibrant (a₀ ⊔ a₁) :=
begin
  change is_cof (! _),
  convert cof_comp (cof_iso (coprod_initial_left ∅)) (cof_coprod h₀ h₁),
  apply initial.uniqueness
end

lemma cof_i₀ [has_initial_object.{v} C] [has_coproducts.{v} C]
  {a₀ a₁ : C} (h : cofibrant a₁) : is_cof (i₀ : a₀ ⟶ a₀ ⊔ a₁) :=
by convert cof_comp (cof_iso (coprod_initial_right a₀)) (cof_coprod (cof_id a₀) h);
   simp

lemma cof_i₁ [has_initial_object.{v} C] [has_coproducts.{v} C]
  {a₀ a₁ : C} (h : cofibrant a₀) : is_cof (i₁ : a₁ ⟶ a₀ ⊔ a₁) :=
by convert cof_comp (cof_iso (coprod_initial_left a₁)) (cof_coprod h (cof_id a₁));
   simp

variables (C)
class all_objects_cofibrant [has_initial_object.{v} C] :=
(cofibrant : ∀ (a : C), cofibrant a)

end homotopy_theory.cofibrations


import Do.For  -- import `runCatch`
import Lean
import Aesop

/-!
# Formalization of Extended `do` Translation

An intrinsically typed representation of the paper's syntax of `do` statements as well
of their translation functions and an equivalence proof thereof to a simple denotational semantics. -/

/-!
## Contexts

We represent contexts as lists of types and assignments of them as heterogeneous lists over these types.
As is common with lists, contexts grow to the left in our presentation.
The following encoding of heterogeneous lists avoids the universe bump of the usual inductive definition
(<https://lists.chalmers.se/pipermail/agda/2010/001826.html>). -/
def HList : List (Type u) → Type u
  | []      => PUnit
  | α :: αs => α × HList αs

@[matchPattern] abbrev HList.nil : HList [] := ⟨⟩
@[matchPattern] abbrev HList.cons (a : α) (as : HList αs) : HList (α :: αs) := (a, as)

/-! We overload the common list notations `::` and `[e, ...]` for `HList`. -/

infixr:67 " :: " => HList.cons

syntax (name := hlistCons) "[" term,* "]" : term
macro_rules (kind := hlistCons)
  | `([])          => `(HList.nil)
  | `([$x])        => `(HList.cons $x [])
  | `([$x, $xs,*]) => `(HList.cons $x [$xs,*])

/-!
Lean's very general, heterogeneous definition of `++` causes some issues with our overloading above in terms
such as `a ++ [b]`, so we restrict it to the `List` interpretation in the following, which is sufficient for our purposes.
-/

local macro_rules
  | `($a ++ $b) => `(List.append $a $b)

abbrev Assg Γ := HList Γ

/-! Updating a heterogeneous list at a given, guaranteed in-bounds index. -/

def HList.set : {αs : List (Type u)} → HList αs → (i : Fin αs.length) → αs.get i → HList αs
  | _ :: _, _ :: as, ⟨0,          _⟩, b => b :: as
  | _ :: _, a :: as, ⟨Nat.succ n, h⟩, b => a :: set as ⟨n, Nat.le_of_succ_le_succ h⟩ b
  | [],     [],      _,               _ => []

/-!
We write `∅` for empty contexts and assignments and `Γ ⊢ α` for the type of values of type `α` under the context `Γ`
- that is, the function type from an assignment to `α`.
-/
instance : EmptyCollection (Assg ∅) where
  emptyCollection := []

instance : CoeSort (List (Type u)) (Type u) := ⟨Assg⟩

notation:30 Γ " ⊢ " α => Assg Γ → α

def Assg.drop : Assg (α :: Γ) → Assg Γ
  | _ :: as => as

/-! In one special case, we will need to manipulate contexts from the right, i.e. the outermost scope. -/

def Assg.extendBot (x : α) : {Γ : _} → Assg Γ → Assg (Γ ++ [α])
  | [],     []      => [x]
  | _ :: _, a :: as => a :: extendBot x as

def Assg.dropBot : {Γ : _} → Assg (Γ ++ [α]) → Assg Γ
  | [],     _       => []
  | _ :: _, a :: as => a :: dropBot as

/-!
## Intrinsically Typed Representation of `do` Statements

where

* m: base monad
* ω: `return` type, `m ω` is the type of the entire `do` block
* Γ: `do`-local immutable context
* Δ: `do`-local mutable context
* b: `break` allowed
* c: `continue` allowed
* α: local result type, `m α` is the type of the statement

The constructor signatures are best understood by comparing them with the corresponding typing rules in the paper.
Note that the choice of de Bruijn indices changes/simplifies some parts, such as obviating freshness checks (`x ∉ Δ`).
-/

inductive Stmt (m : Type → Type u) (ω : Type) : (Γ Δ : List Type) → (b c : Bool) → (α : Type) → Type _ where
  | expr (e : Γ ⊢ Δ ⊢ m α) : Stmt m ω Γ Δ b c α
  | bind (s : Stmt m ω Γ Δ b c α) (s' : Stmt m ω (α :: Γ) Δ b c β) : Stmt m ω Γ Δ b c β  -- let _ ← s; s'
  | letmut (e : Γ ⊢ Δ ⊢ α) (s : Stmt m ω Γ (α :: Δ) b c β) : Stmt m ω Γ Δ b c β  -- let mut _ := e; s
  | assg (x : Fin Δ.length) (e : Γ ⊢ Δ ⊢ Δ.get x) : Stmt m ω Γ Δ b c Unit  -- x := e
  | ite (e : Γ ⊢ Δ ⊢ Bool) (s₁ s₂ : Stmt m ω Γ Δ b c α) : Stmt m ω Γ Δ b c α  -- if e then s₁ else s₂
  | ret (e : Γ ⊢ Δ ⊢ ω) : Stmt m ω Γ Δ b c α   -- return e
  | sfor (e : Γ ⊢ Δ ⊢ List α) (s : Stmt m ω (α :: Γ) Δ true true Unit) : Stmt m ω Γ Δ b c Unit  -- for _ in e do s
  | sbreak : Stmt m ω Γ Δ true c α  -- break
  | scont : Stmt m ω Γ Δ b true α  -- continue

/-! Neutral statements are a restriction of the above type. -/

inductive Neut (ω α : Type) : (b c : Bool) → Type _ where
  | val (a : α) : Neut ω α b c
  | ret (o : ω) : Neut ω α b c
  | rbreak : Neut ω α true c
  | rcont : Neut ω α b true

/-! We elide `Neut.val` where unambiguous. -/

instance : Coe α (Neut ω α b c) := ⟨Neut.val⟩
instance : Coe (Id α) (Neut ω α b c) := ⟨Neut.val⟩

/-!
We write `e[ρ][σ]` for the substitution of both contexts in `e`, a simple application in this encoding.
`σ[x ↦ v]` updates `σ` at `v` (a de Bruijn index). -/

macro:max (priority := high) e:term:max noWs "[" ρ:term "]" "[" σ:term "]" : term => `($e $ρ $σ)
macro:max (priority := high) σ:term:max noWs "[" x:term " ↦ " v:term "]" : term => `(HList.set $σ $x $v)

/-!
## Dynamic Evaluation Function

A direct encoding of the paper's operational semantics as a denotational function,
generalized over an arbitrary monad.
Note that the immutable context `ρ` is accumulated (`v :: ρ`) and passed explicitly instead of immutable
bindings being substituted immediately as that is a better match for the above definition of `Stmt`.
Iteration over the values of the given list in the `for` case introduces a nested, mutually recursive helper
function, with termination of the mutual bundle following from a size argument over the statement primarily
and the length of the list in the `for` case secondarily.
-/

@[simp] def Stmt.eval [Monad m] (ρ : Assg Γ) : Stmt m ω Γ Δ b c α → Assg Δ → m (Neut ω α b c × Assg Δ)
  | expr e, σ => e[ρ][σ] >>= fun v => pure ⟨v, σ⟩
  | bind s s', σ =>
    -- defining this part as a separate definition helps Lean with the termination proof
    let rec @[simp] cont val
      | ⟨Neut.val v, σ'⟩ => val v σ'
      -- the `Neut` type family forces us to repeat these cases as the LHS/RHS indices are not identical
      | ⟨Neut.ret o, σ'⟩ => pure ⟨Neut.ret o, σ'⟩
      | ⟨Neut.rbreak, σ'⟩ => pure ⟨Neut.rbreak, σ'⟩
      | ⟨Neut.rcont, σ'⟩ => pure ⟨Neut.rcont, σ'⟩
    s.eval ρ σ >>= cont (fun v σ' => s'.eval (v :: ρ) σ')
  | letmut e s, σ =>
    s.eval ρ (e[ρ][σ], σ) >>= fun ⟨r, σ'⟩ => pure ⟨r, σ'.drop⟩
  -- `x` is a valid de Bruijn index into `σ` by definition of `assg`
  | assg x e, σ => pure ⟨(), σ[x ↦ e[ρ][σ]]⟩
  | ite e s₁ s₂, σ => if e[ρ][σ] then s₁.eval ρ σ else s₂.eval ρ σ
  | ret e, σ => pure ⟨Neut.ret e[ρ][σ], σ⟩
  | sfor e s, σ =>
    let rec @[simp] go σ
      | [] => pure ⟨(), σ⟩
      | a::as =>
        s.eval (a :: ρ) σ >>= fun
        | ⟨(), σ'⟩ => go σ' as
        | ⟨Neut.rcont, σ'⟩ => go σ' as
        | ⟨Neut.rbreak, σ'⟩ => pure ⟨(), σ'⟩
        | ⟨Neut.ret o, σ'⟩ => pure ⟨Neut.ret o, σ'⟩
    go σ e[ρ][σ]
  | sbreak, σ => pure ⟨Neut.rbreak, σ⟩
  | scont, σ => pure ⟨Neut.rcont, σ⟩
termination_by
  eval s _ => (sizeOf s, 0)
  eval.go as => (sizeOf s, as.length)

/-! At the top-level statement, the contexts are empty, no loop control flow statements are allowed, and the return and result type are identical. -/

abbrev Do m α := Stmt m α ∅ ∅ false false α

def Do.eval [Monad m] (s : Do m α) : m α :=  -- corresponds to the reduction rule `do s ⇒ v` in the paper
  Stmt.eval ∅ s ∅ >>= fun
    | ⟨Neut.val a, _⟩ => pure a
    | ⟨Neut.ret o, _⟩ => pure o

notation "⟦" s "⟧" => Do.eval s

/-!
## Translation Functions

We adjust the immutable context where necessary.
The mutable context does not have to be adjusted. -/

@[simp] def Stmt.mapAssg (f : Assg Γ' → Assg Γ) : Stmt m ω Γ Δ b c β → Stmt m ω Γ' Δ b c β
  | expr e => expr (e ∘ f)
  | bind s₁ s₂ => bind (s₁.mapAssg f) (s₂.mapAssg (fun (a :: as) => (a :: f as)))
  | letmut e s => letmut (e ∘ f) (s.mapAssg f)
  | assg x e => assg x (e ∘ f)
  | ite e s₁ s₂ => ite (e ∘ f) (s₁.mapAssg f) (s₂.mapAssg f)
  | ret e => ret (e ∘ f)
  | sfor e s => sfor (e ∘ f) (s.mapAssg (fun (a :: as) => (a :: f as)))
  | sbreak => sbreak
  | scont => scont

/-! Let us write `f ∘ₑ e` for the composition of `f : α → β` with `e : Γ ⊢ Δ ⊢ α`, which we will use to rewrite embedded terms. -/

infixr:90 " ∘ₑ "  => fun f e => fun ρ σ => f e[ρ][σ]

/-!
The formalization of `S` creates some technical hurdles. Because it operates on the outer-most mutable binding,
we have to operate on that context from the right, from which we lose some helpful definitional equalities and
have to rewrite types using nested proofs instead.

The helper function `shadowSnd` is particularly interesting because it shows how the shadowing in
translation rules (S2) and (S9) is expressed in our de Bruijn encoding: The context `α :: β :: α :: Γ`
corresponds, in this order, to the `y` that has just been bound to the value of `get`, then `x` from the
respective rule, followed by the `y` of the outer scope. We encode the shadowing of `y` by dropping the
third element from the context as well as the assignment. We are in fact forced to do so because the corresponding
branches of `S` would not otherwise typecheck. The only mistake we could still make is to drop the wrong `α` value
from the assignment, which (speaking from experience) would eventually be caught by the correctness proof.
-/
@[simp] def S [Monad m] : Stmt m ω Γ (Δ ++ [α]) b c β → Stmt (StateT α m) ω (α :: Γ) Δ b c β
/-(S1)-/ | Stmt.expr e => Stmt.expr (StateT.lift ∘ₑ unmut e)
/-(S2)-/ | Stmt.bind s₁ s₂ => Stmt.bind (S s₁) (Stmt.bind (Stmt.expr (fun _ _ => get)) (Stmt.mapAssg shadowSnd (S s₂)))
/-(S3)-/ | Stmt.letmut e s => Stmt.letmut (unmut e) (S s)
         | Stmt.assg x e =>
           if h : x < Δ.length then
/-(S4)-/     Stmt.assg ⟨x, h⟩ (fun (y :: ρ) σ => List.get_append_left .. ▸ e ρ (Assg.extendBot y σ))
           else
/-(S5)-/     Stmt.expr (set (σ := α) ∘ₑ cast (List.get_last h) ∘ₑ unmut e)
/-(S6)-/ | Stmt.ite e s₁ s₂ => Stmt.ite (unmut e) (S s₁) (S s₂)
         -- unreachable case; could be eliminated by a more precise specification of `ω`, but the benefit would be minimal
         | Stmt.ret e => Stmt.ret (unmut e)
/-(S7)-/ | Stmt.sbreak => Stmt.sbreak
/-(S8)-/ | Stmt.scont => Stmt.scont
/-(S9)-/ | Stmt.sfor e s => Stmt.sfor (unmut e) (Stmt.bind (Stmt.expr (fun _ _ => get)) (Stmt.mapAssg shadowSnd (S s)))
where
  @[simp] unmut {β} (e : Γ ⊢ Δ ++ [α] ⊢ β) : α :: Γ ⊢ Δ ⊢ β
    | y :: ρ, σ => e ρ (Assg.extendBot y σ)
  @[simp] shadowSnd {β} : Assg (α :: β :: α :: Γ) → Assg (α :: β :: Γ)
    | a' :: b :: _ :: ρ => a' :: b :: ρ

@[simp] def R [Monad m] : Stmt m ω Γ Δ b c α → Stmt (ExceptT ω m) Empty Γ Δ b c α
/-(R1)-/ | Stmt.ret e => Stmt.expr (throw ∘ₑ e)
/-(R2)-/ | Stmt.expr e => Stmt.expr (ExceptT.lift ∘ₑ e)
/-(R3)-/ | Stmt.bind s s' => Stmt.bind (R s) (R s')
/-(R4)-/ | Stmt.letmut e s => Stmt.letmut e (R s)
/-(R5)-/ | Stmt.assg x e => Stmt.assg x e
/-(R6)-/ | Stmt.ite e s₁ s₂ => Stmt.ite e (R s₁) (R s₂)
/-(R7)-/ | Stmt.sbreak => Stmt.sbreak
/-(R8)-/ | Stmt.scont => Stmt.scont
/-(R9)-/ | Stmt.sfor e s => Stmt.sfor e (R s)

@[simp] def L [Monad m] : Stmt m ω Γ Δ b c α → Stmt (ExceptT Unit m) ω Γ Δ b c α
/-(L1)-/ | Stmt.sbreak => Stmt.sbreak
/-(L2)-/ | Stmt.scont => Stmt.scont
/-(L3)-/ | Stmt.expr e => Stmt.expr (ExceptT.lift ∘ₑ e)
/-(L4)-/ | Stmt.bind s s' => Stmt.bind (L s) (L s')
/-(L5)-/ | Stmt.letmut e s => Stmt.letmut e (L s)
/-(L6)-/ | Stmt.assg x e => Stmt.assg x e
/-(L7)-/ | Stmt.ite e s₁ s₂ => Stmt.ite e (L s₁) (L s₂)
         | Stmt.ret e => Stmt.ret e
/-(L8)-/ | Stmt.sfor e s => Stmt.sfor e (L s)

@[simp] def B [Monad m] : Stmt m ω Γ Δ b c α → Stmt (ExceptT Unit m) ω Γ Δ false c α
/-(B1)-/ | Stmt.sbreak => Stmt.expr (fun _ _ => throw ())
/-(B2)-/ | Stmt.scont => Stmt.scont
/-(B3)-/ | Stmt.expr e => Stmt.expr (ExceptT.lift ∘ₑ e)
/-(B4)-/ | Stmt.bind s s' => Stmt.bind (B s) (B s')
/-(B5)-/ | Stmt.letmut e s => Stmt.letmut e (B s)
/-(B6)-/ | Stmt.assg x e => Stmt.assg x e
/-(B7)-/ | Stmt.ite e s₁ s₂ => Stmt.ite e (B s₁) (B s₂)
         | Stmt.ret e => Stmt.ret e
/-(B8)-/ | Stmt.sfor e s => Stmt.sfor e (L s)

-- (elided in the paper)
@[simp] def C [Monad m] : Stmt m ω Γ Δ false c α → Stmt (ExceptT Unit m) ω Γ Δ false false α
  | Stmt.scont => Stmt.expr (fun _ _ => throw ())
  | Stmt.expr e => Stmt.expr (ExceptT.lift ∘ₑ e)
  | Stmt.bind s s' => Stmt.bind (C s) (C s')
  | Stmt.letmut e s => Stmt.letmut e (C s)
  | Stmt.assg x e => Stmt.assg x e
  | Stmt.ite e s₁ s₂ => Stmt.ite e (C s₁) (C s₂)
  | Stmt.ret e => Stmt.ret e
  | Stmt.sfor e s => Stmt.sfor e (L s)

/-!
The remaining function to be translated is `D`, which is straightforward as well except for its termination proof,
as it recurses on the results of `S` (D3) and `C ∘ B` (D5). Because of rules (S2, S9) that introduce new bindings,
`S` may in fact increase the size of the input, and the same is true for `C` and `B` for the `sizeOf` function
automatically generated by Lean. Thus we introduce a new measure `numExts` that counts the number of special statements
on top of basic `do` notation and prove that all three functions do not increase the size according to that measure.
Because the rules (D3) and (D5) each eliminate such a special statement, it follows that `D` terminates because either
the number of special statements decreases in each case, or it remains the same and the total number of statements decreases.
-/

@[simp] def Stmt.numExts : Stmt m ω Γ Δ b c α → Nat
  | expr _ => 0
  | bind s₁ s₂ => s₁.numExts + s₂.numExts
  | letmut _ s => s.numExts + 1
  | assg _ _ => 1
  | ite _ s₁ s₂ => s₁.numExts + s₂.numExts
  | ret _ => 1
  | sfor _ s => s.numExts + 1
  | sbreak => 1
  | scont => 1

@[simp] theorem Stmt.numExts_mapAssg (f : Assg Γ' → Assg Γ) (s : Stmt m ω Γ Δ b c β) : numExts (mapAssg f s) = numExts s := by
  induction s generalizing Γ' <;> simp [*]

theorem Stmt.numExts_S [Monad m] (s : Stmt m ω Γ (Δ ++ [α]) b c β) : numExts (S s) ≤ numExts s := by
  -- `induction` does not work with non-variable indices, so we first generalize `Δ ++ [α]` into an explicit equation
  revert s
  suffices {Δ': _ } → (s : Stmt m ω Γ Δ' b c β) → (h : Δ' = (Δ ++ [α])) → numExts (S (h ▸ s : Stmt m ω Γ (Δ ++ [α]) b c β)) ≤ numExts s
    from fun s => this s rfl
  intro Δ' s h
  induction s generalizing Δ with
    subst h
  | bind _ _ ih₁ ih₂ => simp [Nat.add_le_add, ih₁ rfl, ih₂ rfl]
  | letmut _ _ ih => simp [Nat.add_le_add, ih (List.cons_append ..).symm]
  | assg => aesop
  | ite _ _ _ ih₁ ih₂ => simp [Nat.add_le_add, ih₁ rfl, ih₂ rfl]
  | sfor _ _ ih => simp [Nat.add_le_add, ih rfl]
  | _ => simp

theorem Stmt.numExts_L_L [Monad m] (s : Stmt m ω Γ Δ b c β) : numExts (L (L s)) ≤ numExts s := by
  induction s <;> simp [Nat.add_le_add, *]

theorem Stmt.numExts_C_B [Monad m] (s : Stmt m ω Γ Δ b c β) : numExts (C (B s)) ≤ numExts s := by
  induction s <;> simp [Nat.add_le_add, numExts_L_L, *]

-- Auxiliary tactic for showing that `D` terminates
macro "D_tac" : tactic =>
  `({simp_wf
     solve
      | apply Prod.Lex.left; assumption
      | apply Prod.Lex.right' <;> simp_arith })

@[simp] def D [Monad m] : Stmt m Empty Γ ∅ false false α → (Γ ⊢ m α)
  | Stmt.expr e => (e[·][∅])
  | Stmt.bind s s' => (fun ρ => D s ρ >>= fun x => D s' (x :: ρ))
  | Stmt.letmut e s =>
    have := Nat.lt_succ_of_le <| Stmt.numExts_S (Δ := []) s  -- for termination
    fun ρ =>
      let x := e[ρ][∅]
      StateT.run' (D (S s) (x :: ρ)) x
  | Stmt.ite e s₁ s₂ => (fun ρ => if e[ρ][∅] then D s₁ ρ else D s₂ ρ)
  | Stmt.sfor e s =>
    have := Nat.lt_succ_of_le <| Stmt.numExts_C_B (Δ := []) s  -- for termination
    fun ρ =>
      runCatch (forM e[ρ][∅] (fun x => runCatch (D (C (B s)) (x :: ρ))))
  | Stmt.ret e => (nomatch e[·][∅])
termination_by _ s => (s.numExts, sizeOf s)
decreasing_by D_tac

/-! Finally we compose `D` and `R` into the translation rule for a top-level statement (1'). -/

def Do.trans [Monad m] (s : Do m α) : m α := runCatch (D (R s) ∅)

/-!
## Equivalence Proof

Using the monadic dynamic semantics, we can modularly prove for each individual translation function that
evaluating its output is equivalent to directly evaluating the input, modulo some lifting and adjustment
of resulting values. After induction on the statement, the proofs are mostly concerned with case splitting,
application of congruence theorems, and simplification. We can mostly offload these tasks onto
[Aesop](https://github.com/JLimperg/aesop).

-/
attribute [local simp] map_eq_pure_bind ExceptT.run_bind
attribute [aesop safe apply] bind_congr

theorem eval_R [Monad m] [LawfulMonad m] (s : Stmt m ω Γ Δ b c α) : (R s).eval ρ σ = (ExceptT.lift (s.eval ρ σ) >>= fun x => match (generalizing := false) x with
    | (Neut.ret o, _) => throw o
    | (Neut.val a, σ) => pure (Neut.val a, σ)
    | (Neut.rcont, σ) => pure (Neut.rcont, σ)
    | (Neut.rbreak, σ) => pure (Neut.rbreak, σ) : ExceptT ω m (Neut Empty α b c × Assg Δ)) := by
  apply ExceptT.ext
  induction s with
  | sfor e =>
    simp only [Stmt.eval, R]
    induction e ρ σ generalizing σ <;> aesop (add norm unfold Stmt.eval.go)
  | _ => aesop (add unsafe cases Neut) (erase Aesop.BuiltinRules.destructProducts)

@[simp] theorem eval_mapAssg [Monad m] [LawfulMonad m] (f : Assg Γ' → Assg Γ) : ∀ (s : Stmt m ω Γ Δ b c β), Stmt.eval ρ (Stmt.mapAssg f s) σ = Stmt.eval (f ρ) s σ := by
  intro s
  induction s generalizing Γ' with
  | sfor e s ih =>
    simp only [Stmt.eval, Stmt.mapAssg, Function.comp]
    induction e (f ρ) σ generalizing σ <;> aesop (add norm unfold Stmt.eval.go)
  | _ => aesop (add unsafe cases Neut)

/-!
We need one last helper function on context bottoms to be able to state the invariant of `S`, and then
prove various lemmas about their interactions. -/

def Assg.bot : {Γ : _} → Assg (Γ ++ [α]) → α
  | [],     [a]     => a
  | _ :: _, _ :: as => bot as

@[simp] theorem Assg.dropBot_extendBot (a : α) (σ : Assg Γ) : Assg.dropBot (Assg.extendBot a σ) = σ := by
  induction Γ <;> cases σ <;> simp [dropBot, extendBot, *]
@[simp] theorem Assg.bot_extendBot (a : α) (σ : Assg Γ) : Assg.bot (Assg.extendBot a σ) = a := by
  induction Γ <;> cases σ <;> simp [bot, extendBot, *]
@[simp] theorem Assg.extendBot_bot_dropBot (σ : Assg (Γ ++ [α])) : Assg.extendBot (Assg.bot σ) (Assg.dropBot σ) = σ := by
  induction Γ <;> cases σ <;> simp [dropBot, bot, extendBot, *] <;> rfl

@[simp] theorem Assg.dropBot_set_extendBot_init (a : α) (σ : Assg Γ) (h : i.1 < Γ.length) {b} : Assg.dropBot ((Assg.extendBot a σ).set i b) = σ.set ⟨i.1, h⟩ (List.get_append_left .. ▸ b) := by
  induction Γ with
  | nil => contradiction
  | cons  _ _ ih =>
    cases σ
    have ⟨i, h'⟩ := i
    cases i <;> simp [HList.set, dropBot]
    rw [ih]

@[simp] theorem Assg.bot_set_extendBot_init (a : α) (σ : Assg Γ) (h : i.1 < Γ.length) {b} : Assg.bot ((Assg.extendBot a σ).set i b) = a := by
  induction Γ with
  | nil => contradiction
  | cons  _ _ ih =>
    cases σ
    have ⟨i, h'⟩ := i
    cases i <;> simp [HList.set, dropBot, bot]
    rw [ih]; apply Nat.lt_of_succ_lt_succ h

@[simp] theorem Assg.dropBot_set_extendBot_bottom (a : α) (σ : Assg Γ) (h : ¬ i.1 < Γ.length) {b} : Assg.dropBot ((Assg.extendBot a σ).set i b) = σ := by
  induction Γ with
  | nil => rfl
  | cons  _ _ ih =>
    cases σ
    have ⟨i, h'⟩ := i
    cases i
    · apply False.elim (h (Nat.zero_lt_succ _))
    · simp [HList.set, dropBot]
      rw [ih]
      intro h''
      apply False.elim (h (Nat.succ_lt_succ h''))

@[simp] theorem Assg.bot_set_extendBot_bottom (a : α) (σ : Assg Γ) (h : ¬ i.1 < Γ.length) {b} : Assg.bot ((Assg.extendBot a σ).set i b) = cast (List.get_last h) b := by
  induction Γ with
  | nil =>
    have ⟨i, h'⟩ := i
    cases i
    · simp [HList.set, extendBot, bot]; rfl
    · apply False.elim (Nat.not_lt_zero _ (Nat.lt_of_succ_lt_succ h'))
  | cons  _ _ ih =>
    cases σ
    have ⟨i, h'⟩ := i
    cases i
    · apply False.elim (h (Nat.zero_lt_succ _))
    · simp [bot]
      rw [ih]
      intro h''
      apply False.elim (h (Nat.succ_lt_succ h''))

theorem eval_S [Monad m] [LawfulMonad m] : ∀ (s : Stmt m ω Γ (Δ ++ [α]) b c β), StateT.run ((S s).eval (a :: ρ) σ) a = s.eval ρ (Assg.extendBot a σ) >>= fun
    | r :: σ => pure ((r :: Assg.dropBot σ), Assg.bot σ) := by
  suffices {Δ': _ } → (s : Stmt m ω Γ Δ' b c β) → (h : Δ' = (Δ ++ [α])) → StateT.run ((S (h ▸ s)).eval (a :: ρ) σ) a = s.eval ρ (h ▸ Assg.extendBot a σ) >>= fun
    | r :: σ => pure ((r :: Assg.dropBot (h ▸ σ)), Assg.bot (h ▸ σ))
    from fun s => this s rfl
  intro Δ' s h
  induction s generalizing Δ a with
    subst h
  | bind s₁ s₂ ih₁ ih₂ =>
    have ih₁ := @ih₁ (h := rfl)
    have ih₂ := @ih₂ (h := rfl)
    aesop (add safe cases Neut)
  | letmut e s ih =>
    have ih := @ih (Δ := _ :: Δ) (h := rfl)
    aesop
  | sfor e s ih =>
    have ih := @ih (h := rfl)
    simp only [S, Stmt.eval, S.unmut]
    -- surgical generalization
    generalize h : a = a'
    conv =>
      pattern HList.cons a' _
      rw [← h]
    clear h
    induction e ρ _ generalizing σ a' <;> aesop (add safe cases Neut)
  | _ => aesop

theorem HList.eq_nil (as : HList ∅) : as = ∅ := rfl

attribute [local simp] ExceptT.run_bind

theorem eval_L [Monad m] [LawfulMonad m] (s : Stmt m ω Γ Δ b c α) : (L s).eval ρ σ = ExceptT.lift (s.eval ρ σ) := by
  apply ExceptT.ext
  induction s with
  | sfor e =>
    simp only [Stmt.eval, L]
    induction e ρ σ generalizing σ <;> aesop
  | _ => aesop (add safe cases Neut)

theorem eval_B [Monad m] [LawfulMonad m] (s : Stmt m ω Γ Δ b c α) : (B s).eval ρ σ = (ExceptT.lift (s.eval ρ σ) >>= fun x => match (generalizing := false) x with
    | (Neut.ret o, σ) => pure (Neut.ret o, σ)
    | (Neut.val a, σ) => pure (Neut.val a, σ)
    | (Neut.rcont, σ) => pure (Neut.rcont, σ)
    | (Neut.rbreak, _) => throw () : ExceptT Unit m (Neut ω α false c × Assg Δ)) := by
  apply ExceptT.ext
  induction s with
  | sfor e =>
    simp only [Stmt.eval, B]
    induction e ρ σ generalizing σ <;> aesop (add norm simp eval_L)
  | _ => aesop (erase Aesop.BuiltinRules.destructProducts)

@[simp] def throwOnContinue [Monad m] : (Neut ω α false c × Assg Δ) → ExceptT Unit m (Neut ω α false false × Assg Δ)
  | (Neut.ret o, σ) => pure (Neut.ret o, σ)
  | (Neut.val a, σ) => pure (Neut.val a, σ)
  | (Neut.rcont, _) => throw ()

theorem eval_C [Monad m] [LawfulMonad m] (s : Stmt m ω Γ Δ false c α) : (C s).eval ρ σ = ExceptT.lift (s.eval ρ σ) >>= throwOnContinue := by
  revert s
  suffices {b: _ } → (s' : Stmt m ω Γ Δ b c α) → (h : b = false) → let s : Stmt m ω Γ Δ false c α := h ▸ s'; (C s).eval ρ σ = ExceptT.lift (s.eval ρ σ) >>= throwOnContinue
    from fun s => this s rfl
  intro b' s h
  induction s with
    (first | subst h | trivial)
  | sfor e =>
    simp only [Stmt.eval, C]
    induction e ρ σ generalizing σ <;> aesop (add norm simp eval_L, unsafe apply ExceptT.ext)
  | _ => aesop (add unsafe apply ExceptT.ext)

theorem D_eq [Monad m] [LawfulMonad m] : (s : Stmt m Empty Γ ∅ false false α) →
    D s ρ = s.eval ρ ∅ >>= fun (Neut.val a, _) => pure a
  | Stmt.expr e => by simp
  | Stmt.bind s₁ s₂ => by
    have ih₁ := @D_eq (s := s₁)
    have ih₂ := @D_eq (s := s₂)
    aesop
  | Stmt.letmut e s => by
    have := Nat.lt_succ_of_le <| Stmt.numExts_S (Δ := []) s  -- for termination
    have ih := (D_eq (ρ := ·) (S s))
    aesop (add safe cases Neut, norm simp eval_S)
  | Stmt.ite e s₁ s₂ => by simp; split <;> simp [D_eq s₁, D_eq s₂]
  | Stmt.ret e => nomatch e ρ ∅
  | Stmt.sfor e s => by
    have := Nat.lt_succ_of_le <| Stmt.numExts_C_B (Δ := []) s  -- for termination
    have ih := (D_eq (ρ := ·) (C (B s)))
    simp
    induction e ρ ∅ <;> aesop (add safe cases Neut, norm unfold runCatch, norm simp [eval_C, eval_B])
termination_by _ s => (s.numExts, sizeOf s)
decreasing_by D_tac

/-! The equivalence proof cited in the paper follows from the invariants of `D` and `R`. -/

theorem Do.trans_eq_eval [Monad m] [LawfulMonad m] : ∀ s : Do m α, Do.trans s = ⟦s⟧ := by
  aesop (add norm simp [D_eq, eval_R], norm unfold [runCatch, Do.trans, Do.eval])

/-!
## Partial Evaluation

We define a new term notation `simp [...] in e` that rewrites the term e using the given
simplification theorems.
-/

open Lean in
open Lean.Parser.Tactic in
open Lean.Meta in
open Lean.Elab in
elab "simp" "[" simps:simpLemma,* "]" "in" e:term : term => do
  -- construct goal `⊢ e = ?x` with fresh metavariable `?x`, simplify, solve by reflexivity,
  -- and return assigned value of `?x`
  let e ← Term.elabTermAndSynthesize e none
  let x ← mkFreshExprMVar (← inferType e)
  let goal ← mkFreshExprMVar (← mkEq e x)
  -- disable ζ-reduction to preserve `let`s
  Term.runTactic goal.mvarId! (← `(tactic| (simp (config := { zeta := false }) [$simps:simpLemma,*]; rfl)))
  instantiateMVars x

-- further clean up generated programs
attribute [local simp] Assg.extendBot cast
attribute [-simp] StateT.run'_eq

/-!
We can now use this new notation to completely erase the translation functions
from an invocation on the example `ex2` from `For.lean` (manually translated to `Stmt`).
-/
/-
let mut y := init;
for x in xs do' {
  y ← f y x
};
return y
-/

def ex2' [Monad m] (f : β → α → m β) (init : β) (xs : List α) : m β :=
  simp [Do.trans] in Do.trans (
      Stmt.letmut (fun _ _ => init) <|
      Stmt.bind (
        Stmt.sfor (fun _ _ => xs) <|
        -- `y ← f y x` unfolded to `let z ← f y x; y := z` (A4)
        Stmt.bind
          (Stmt.expr (fun ([x]) ([y]) => f y x))
          (Stmt.assg ⟨0, by simp⟩ (fun ([z, x]) _ => z))) <|
      Stmt.ret (fun _ ([y]) => y))

/-!
Compare the output of the two versions - the structure is identical except for unused
monadic layers in the formal translation, which would be harder to avoid in this typed
approach. -/
#print ex2
#print ex2'

/-! We can evaluate the generated program like any other Lean program, and prove that both versions are equivalent. -/
#eval ex2' (m := Id) (fun a b => pure (a + b)) 0 [1, 2]

example [Monad m] [LawfulMonad m] (f : β → α → m β) :
    ex2' f init xs = ex2 f init xs := by
  rw [ex2, ex2']; unfold runCatch; induction xs generalizing init <;> simp_all! [StateT.run'_eq]

/-!
For one more example, consider `ex3` from `For.lean`.
-/
/-
for xs in xss do' {
  for x in xs do' {
    let b ← p x;
    if b then {
      return some x
    }
  }
};
pure none
-/

def ex3' [Monad m] (p : α → m Bool) (xss : List (List α)) : m (Option α) :=
  simp [Do.trans] in Do.trans (
      Stmt.bind
        (Stmt.sfor (fun _ _ => xss) <|
          Stmt.sfor (fun ([xs]) _ => xs) <|
            Stmt.bind
              (Stmt.expr (fun ([x, xs]) _ => p x))
              (Stmt.ite (fun ([b, x, xs]) _ => b)
                (Stmt.ret (fun ([b, x, xs]) _ => some x))
                (Stmt.expr (fun _ _ => pure ()))))
        (Stmt.expr (fun _ _ => pure none)))

#print ex3
#print ex3'
#eval ex3' (m := Id) (fun n => n % 2 == 0) [[1, 3], [2, 4]]

example [Monad m] [LawfulMonad m] (p : α → m Bool) (xss : List (List α)) :
    ex3' p xss = ex3 p xss := by
  rw [ex3, ex3']
  unfold runCatch
  induction xss with
  | nil => simp!
  | cons xs xss ih =>
    simp
    induction xs <;> aesop (add safe apply byCases_Bool_bind)

/-!
While it would be possible to override our `do'` notation such that its named syntax
is first translated to nameless `Stmt` constructors and then applied to `simp [Do.trans] in`,
for demonstration purposes we decided to encode these examples manually. In practice, the
macro implementation remains more desirable as mentioned in the paper.
-/


import GroundZero.Types.Unit
import GroundZero.Types.Sigma
import GroundZero.Types.Product
import GroundZero.Types.Coproduct

open GroundZero.Types.Unit
open GroundZero.Types.Id (map)
open GroundZero.Types (Coproduct idp fib)
open GroundZero.Types.Equiv (biinv)

namespace GroundZero
universe u v w k r

namespace Structures

hott def isLoop {A : Type u} {a : A} (p : a = a) := ¬(p = idp a)

hott def prop (A : Type u) := Π (a b : A), a = b

hott def propset := Σ (A : Type u), prop A
notation "Ω" => propset

hott def hset (A : Type u) := Π (a b : A) (p q : a = b), p = q
hott def Ens := Σ A, hset A

hott def groupoid (A : Type u) :=
Π (a b : A) (p q : a = b) (A B : p = q), A = B

hott def dec (A : Type u) := A + ¬A

hott def contr (A : Type u) := Σ (a : A), Π b, a = b

instance contr.dotted {A : Type u} (H : contr A) : Types.Id.dotted A := ⟨H.1⟩

inductive hlevel
| minusTwo
| succ : hlevel → hlevel

notation "ℕ₋₂" => hlevel
notation "−2" => hlevel.minusTwo
notation "−1" => hlevel.succ hlevel.minusTwo

namespace hlevel
  inductive le : hlevel → hlevel → Type
  | refl (a : hlevel)   : le a a
  | step (a b : hlevel) : le a b → le a (succ b)

  infix:50 " ≤ " => le

  hott def le.minusTwo : Π (n : hlevel), −2 ≤ n
  | −2     => le.refl −2
  | succ n => le.step _ _ (minusTwo n)

  noncomputable hott def le.succ (a b : hlevel) (ρ : a ≤ b) : succ a ≤ succ b :=
  begin induction ρ; apply le.refl; apply le.step; assumption end

  hott def add : hlevel → hlevel → hlevel
  | −2,            −2 => −2
  | −1,            −2 => −2
  | succ (succ n), −2 => n
  | n, succ (succ −2) => n
  | n, succ m         => succ (add n m)

  instance : HAdd hlevel hlevel hlevel := ⟨hlevel.add⟩

  hott def ofNat : ℕ → ℕ₋₂
  | Nat.zero   => succ (succ −2)
  | Nat.succ n => hlevel.succ (ofNat n)

  instance (n : ℕ) : OfNat ℕ₋₂ n := ⟨ofNat n⟩
end hlevel

def isNType : hlevel → Type u → Type u
| −2            => contr
| hlevel.succ n => λ A, Π (x y : A), isNType n (x = y)

notation "is-" n "-type" => isNType n

def nType (n : hlevel) : Type (u + 1) :=
Σ (A : Type u), is-n-type A

notation n "-Type" => nType n

hott def hlevel.cumulative {A : Type u} : Π (n : hlevel), is-n-type A → is-(hlevel.succ n)-type A
| −2,            H => λ x y, ⟨(H.2 x)⁻¹ ⬝ H.2 y, λ p, begin induction p; apply Types.Id.invComp end⟩
| hlevel.succ n, H => λ x y, cumulative n (H x y)

noncomputable hott def hlevel.strongCumulative (n m : hlevel) (ρ : n ≤ m) :
  Π {A : Type u}, (is-n-type A) → (is-m-type A) :=
begin
  induction ρ; intros; assumption;
  case step m ρ ih => {
    intros A G; apply @hlevel.cumulative;
    apply ih; assumption
  }
end

hott def contrImplProp {A : Type u} (h : contr A) : prop A :=
λ a b, (h.2 a)⁻¹ ⬝ (h.2 b)

def emptyIsProp : prop 𝟎 :=
begin intros x y; induction x end

def unitIsProp : prop 𝟏 :=
begin intros x y; induction x; induction y; reflexivity end

hott def contrEquivUnit {A : Type u} (h : contr A) : A ≃ 𝟏 :=
begin
  existsi (λ _, ★); apply Types.Qinv.toBiinv;
  existsi (λ _, h.1) <;> apply Prod.mk <;> intro x;
  induction x; reflexivity; apply h.2
end

hott def zeroMorphismContr {A : Type u} : contr (A → 𝟏) :=
⟨λ _, ★, λ f, HITs.Interval.funext (λ x, unitIsProp ★ (f x))⟩

hott def zeroMorphismEqv {A : Type u} : (A → 𝟏) ≃ 𝟏 :=
contrEquivUnit zeroMorphismContr

hott def familyOverUnit (C : 𝟏 → Type u) : (Π x, C x) ≃ (C ★) :=
begin
  fapply Sigma.mk; { intro φ; apply φ }; apply Types.Qinv.toBiinv;
  fapply Sigma.mk; { intros c x; induction x; exact c };
  fapply Prod.mk; { intro x; reflexivity };
  { intro ψ; apply HITs.Interval.funext; intro x; induction x; reflexivity }
end

hott def cozeroMorphismEqv {A : Type u} : (𝟏 → A) ≃ A :=
familyOverUnit (λ _, A)

hott def terminalArrow {A : Type u} : A ≃ (𝟏 → A) :=
⟨λ x _, x, Types.Qinv.toBiinv _ ⟨λ φ, φ ★, (λ φ, HITs.Interval.funext (λ ★, idp _), idp)⟩⟩

hott def contrTypeEquiv {A : Type u} {B : Type v}
  (p : contr A) (q : contr B) : A ≃ B := calc
      A ≃ 𝟏 : contrEquivUnit.{_, 0} p
    ... ≃ B : Types.Equiv.symm (contrEquivUnit q)

hott def prodUnitEquiv (A : Type u) : 𝟏 × A ≃ A :=
begin existsi Prod.snd; apply Prod.mk <;> existsi Prod.mk ★ <;> { intro; reflexivity } end

hott def unitProdEquiv (A : Type u) : A × 𝟏 ≃ A :=
begin existsi Prod.fst; apply Prod.mk <;> existsi (Prod.mk · ★) <;> { intro x; reflexivity } end

def boolToUniverse : 𝟐 → Type
| true  => 𝟏
| false => 𝟎

hott def ffNeqTt : false ≠ true :=
λ p, Types.Equiv.transport boolToUniverse p⁻¹ ★

hott def functionSpace : ¬(Π (A B : Type), prop (A → B)) :=
λ H, ffNeqTt (Types.Equiv.Homotopy.Id (H 𝟐 𝟐 id not) false)

hott def autoContr {A : Type u} (x : A) (H : prop (A → A)) : prop A :=
begin
  apply contrImplProp; existsi x;
  apply Types.Equiv.Homotopy.Id; apply H
end

section
  open Types.Equiv Types.Id

  hott def propIsSet {A : Type u} (r : prop A) : hset A :=
  begin
    intros x y p q; have g := r x; apply Types.Id.trans;
    symmetry; apply rewriteComp;
    exact (apd g p)⁻¹ ⬝ transportComposition p (g x);
    induction q; apply invComp
  end

  hott def setImplGroupoid {A : Type u} (r : hset A) : groupoid A :=
  begin
    intros a b p q η μ; have g := r _ _ p; apply Types.Id.trans;
    symmetry; apply rewriteComp; transitivity; symmetry; exact apd g η;
    apply transportComposition; induction μ; apply invComp
  end

  hott def emptyIsSet : hset 𝟎 := propIsSet emptyIsProp
  hott def unitIsSet  : hset 𝟏 := propIsSet unitIsProp

  hott def contrIsProp {A : Type u} : prop (contr A) :=
  begin
    intro ⟨x, u⟩ ⟨y, v⟩; have p := u y;
    induction p; apply map;
    apply HITs.Interval.funext; intro a;
    apply propIsSet (contrImplProp ⟨x, u⟩)
  end

  -- TODO: apply “repeat” tactic
  hott def propIsProp {A : Type u} : prop (prop A) :=
  begin
    intros f g;
    apply HITs.Interval.funext; intro;
    apply HITs.Interval.funext; intro;
    apply propIsSet; assumption
  end

  hott def setIsProp {A : Type u} : prop (hset A) :=
  begin
    intros f g;
    apply HITs.Interval.funext; intro;
    apply HITs.Interval.funext; intro;
    apply HITs.Interval.funext; intro;
    apply HITs.Interval.funext; intro;
    apply setImplGroupoid; assumption
  end

  hott def ntypeIsProp : Π (n : hlevel) {A : Type u}, prop (is-n-type A)
  | −2            => contrIsProp
  | hlevel.succ n => λ p q, HITs.Interval.funext (λ x, HITs.Interval.funext (λ y, ntypeIsProp n _ _))

  hott def functionToContr {A : Type u} : prop (A → contr A) :=
  begin intros f g; apply HITs.Interval.funext; intro x; apply contrIsProp end
end

hott def retract (B : Type u) (A : Type v) :=
Σ (r : A → B) (s : B → A), r ∘ s ~ id

hott def retract.section {B : Type u} {A : Type v} (w : retract B A) : B → A := w.2.1

hott def contrRetract {A : Type u} {B : Type v} : retract B A → contr A → contr B :=
λ ⟨r, s, ε⟩ ⟨a₀, p⟩, ⟨r a₀, λ b, map r (p (s b)) ⬝ (ε b)⟩

hott def retract.path {A : Type u} {B : Type v} :
  Π (H : retract B A) {a b : B},
  retract (a = b) (H.section a = H.section b) :=
λ ⟨r, s, ε⟩ a b, ⟨λ q, (ε a)⁻¹ ⬝ (@map A B _ _ r q) ⬝ (ε b), map s,
begin
  intro p; transitivity; symmetry; apply Types.Id.assoc;
  symmetry; apply Types.Equiv.invRewriteComp;
  transitivity; apply map (· ⬝ p); apply Types.Id.invInv;
  transitivity; apply map (ε a ⬝ ·); symmetry; apply Types.Equiv.idmap;
  transitivity; apply Types.Equiv.homotopySquare ε p;
  apply map (· ⬝ ε b); apply Types.Equiv.mapOverComp
end⟩

hott def equivRespectsRetraction : Π {n : ℕ₋₂} {A : Type u} {B : Type v},
  retract B A → is-n-type A → is-n-type B
| −2            => contrRetract
| hlevel.succ n => λ G H a b, equivRespectsRetraction (retract.path G) (H _ _)

hott def equivInducesRetraction {A : Type u} {B : Type v} : A ≃ B → retract B A :=
λ ⟨f, (_, ⟨g, ε⟩)⟩, ⟨f, g, ε⟩

hott def ntypeRespectsEquiv (n : ℕ₋₂) {A : Type u} {B : Type v} :
  A ≃ B → is-n-type A → is-n-type B :=
equivRespectsRetraction ∘ equivInducesRetraction

hott def ntypeRespectsSigma : Π (n : ℕ₋₂) {A : Type u} {B : A → Type v},
  is-n-type A → (Π x, is-n-type (B x)) → is-n-type (Σ x, B x)
| −2            => λ ⟨a₀, p⟩ B, ⟨⟨a₀, (B a₀).1⟩, λ ⟨a, b⟩, Types.Sigma.prod (p a) (contrImplProp (B a) _ _)⟩
| hlevel.succ n => λ A B p q, ntypeRespectsEquiv n (Types.Equiv.symm Types.Sigma.sigmaPath)
                                (ntypeRespectsSigma n (A p.1 q.1) (λ x, B q.1 _ _))

inductive propSquash (A : Type u) : Prop
| elem : A → propSquash A

inductive Lift (A : Prop) : Type
| elem : A → Lift A

def Squash := Lift ∘ propSquash

def Squash.elem {A : Type u} : A → Squash A :=
Lift.elem ∘ propSquash.elem

def Squash.uniq {A : Type u} : Π (a b : Squash A), a = b :=
λ (Lift.elem _) (Lift.elem _), idp _

def Squash.prop {A : Type u} {B : Prop} (f : A → B) : Squash A → B :=
λ (Lift.elem (propSquash.elem x)), f x

def Squash.Lift {A : Type u} {B : Type v}
  (f : A → B) : Squash A → Squash B :=
Lift.elem ∘ Squash.prop (propSquash.elem ∘ f)

def K (A : Type u) := Π (a : A) (p : a = a), p = idp a

hott def KIffSet (A : Type u) : K A ↔ hset A :=
begin
  fapply Prod.mk;
  { intros H x y p q; induction q; apply H };
  { intros H a p; apply H }
end

hott def lemProp {A : Type u} (h : A → prop A) : prop A :=
λ a, h a a

hott def lemContr {A : Type u} (h : A → contr A) : prop A :=
λ a, contrImplProp (h a) a

def isContrFiber {A : Type u} {B : Type v} (f : A → B) :=
Π (y : B), contr (fib f y)

hott def propEquivLemma {A : Type u} {B : Type v}
  (F : prop A) (G : prop B) (f : A → B) (g : B → A) : A ≃ B :=
⟨f, (⟨g, λ _, F _ _⟩, ⟨g, λ _, G _ _⟩)⟩

hott def minusTwoEqvContr {A : Type u} : (is-(−2)-type A) ≃ contr A :=
by reflexivity

hott def minusOneEqvProp {A : Type u} : (is-(−1)-type A) ≃ prop A :=
begin
  apply propEquivLemma; apply ntypeIsProp; apply propIsProp;
  { intros H a b; exact (H a b).1 };
  { intros H a b; existsi H a b; apply propIsSet H }
end

hott def equivFunext {A : Type u} {η μ : A → Type v}
  (H : Π x, η x ≃ μ x) : (Π x, η x) ≃ (Π x, μ x) :=
begin
  existsi (λ (f : Π x, η x) (x : A), (H x).forward (f x)); apply Prod.mk;
  { existsi (λ (f : Π x, μ x) (x : A), (H x).left (f x));
    intro f; apply HITs.Interval.funext;
    intro x; apply (H x).leftForward };
  { existsi (λ (f : Π x, μ x) (x : A), (H x).right (f x));
    intro f; apply HITs.Interval.funext;
    intro x; apply (H x).forwardRight }
end

hott def zeroEqvSet {A : Type u} : (is-0-type A) ≃ hset A := calc
  (is-0-type A) ≃ (Π (x y : A), is-(−1)-type (x = y)) : by reflexivity
            ... ≃ (Π (x y : A), prop (x = y)) :
                  begin apply equivFunext; intro x;
                        apply equivFunext; intro y;
                        apply minusOneEqvProp end
            ... ≃ hset A : by reflexivity

hott def oneEqvGroupoid {A : Type u} : (is-1-type A) ≃ groupoid A := calc
  (is-1-type A) ≃ (Π (x y : A), is-0-type (x = y)) : by reflexivity
            ... ≃ (Π (x y : A), hset (x = y)) :
                   begin apply equivFunext; intro x;
                         apply equivFunext; intro y;
                         apply zeroEqvSet end
            ... ≃ groupoid A : by reflexivity

hott def propIsNType {A : Type u} (H : prop A) : Π n, is-(hlevel.succ n)-type A
| −2            => minusOneEqvProp.left H
| hlevel.succ n => hlevel.cumulative (hlevel.succ n) (propIsNType H n)

hott def hsetRespectsEquiv {A : Type u} {B : Type v} :
  A ≃ B → hset A → hset B :=
begin
  intros e H; apply zeroEqvSet.forward;
  apply ntypeRespectsEquiv 0 e;
  apply zeroEqvSet.left;
  assumption
end

hott def hsetRespectsSigma {A : Type u} {B : A → Type v}
  (H : hset A) (G : Π x, hset (B x)) : hset (Σ x, B x) :=
begin
  apply zeroEqvSet.forward; apply ntypeRespectsSigma 0;
  { apply zeroEqvSet.left; intros x y; apply H };
  { intro x; apply zeroEqvSet.left; apply G }
end

hott def propRespectsEquiv {A : Type u} {B : Type v} :
  A ≃ B → prop A → prop B :=
begin
  intros e H; apply minusOneEqvProp.forward;
  apply ntypeRespectsEquiv −1 e;
  apply minusOneEqvProp.left;
  assumption
end

hott def contrRespectsEquiv {A : Type u} {B : Type v} :
  A ≃ B → contr A → contr B :=
ntypeRespectsEquiv −2

hott def productProp {A : Type u} {B : Type v}
  (h : prop A) (g : prop B) : prop (A × B) :=
begin
  intro ⟨x₁, y₁⟩ ⟨x₂, y₂⟩;
  have p := h x₁ x₂; have q := g y₁ y₂;
  induction p; induction q; reflexivity
end

hott def prodHset {A : Type u} {B : Type v}
  (p : hset A) (q : hset B) : hset (A × B) :=
begin
  apply hsetRespectsEquiv;
  apply Types.Sigma.const;
  apply hsetRespectsSigma;
  apply p; intro x; apply q
end

hott def piProp {A : Type u} {B : A → Type v}
  (H : Π x, prop (B x)) : prop (Π x, B x) :=
λ f g, HITs.Interval.funext (λ x, H x (f x) (g x))

hott def sigProp {A : Type u} {B : A → Type v}
  (H : prop A) (G : Π x, prop (B x)) : prop (Σ x, B x) :=
begin intros w₁ w₂; fapply Types.Sigma.prod; apply H; apply G end

hott def implProp {A : Type u} {B : Type v} (H : prop B) : prop (A → B) :=
piProp (λ _, H)

hott def notIsProp {A : Type u} : prop (¬ A) :=
implProp emptyIsProp

hott def reflMereRel {A : Type u} (R : A → A → Type v) (h : Π x y, prop (R x y))
  (ρ : Π x, R x x) (f : Π x y, R x y → x = y) : hset A :=
begin
  apply (KIffSet _).left; intros a p;
  apply Types.Id.transCancelLeft (f a a (ρ a));
  transitivity; symmetry; apply Types.Equiv.transportComposition;
  transitivity; apply Types.Equiv.liftedHapply (R a); apply Types.Equiv.apd (f a) p;
  transitivity; apply map (f a a) (h _ _ _ (ρ a)); symmetry; apply Types.Id.reflRight
end

hott def doubleNegEq {A : Type u} (h : Π (x y : A), ¬¬(x = y) → x = y) : hset A :=
begin
  fapply reflMereRel;
  { intros x y; exact ¬¬(x = y) };
  { intros x y; apply implProp; apply emptyIsProp };
  { intro x; intros f; apply f; reflexivity };
  { exact h }
end

hott def lemToDoubleNeg {A : Type u} : dec A → (¬¬A → A)
| Sum.inl x => λ _, x
| Sum.inr t => λ g, Proto.Empty.elim (g t)

hott def Hedberg {A : Type u} : (Π (x y : A), dec (x = y)) → hset A :=
begin intro H; apply doubleNegEq; intros x y; apply lemToDoubleNeg; apply H x y end

hott def boolEqTotal (x : 𝟐) : (x = false) + (x = true) :=
begin induction x using Bool.casesOn; left; reflexivity; right; reflexivity end

hott lemma boolDecEq (x y : 𝟐) : dec (x = y) :=
begin
  induction x using Bool.casesOn <;>
  induction y using Bool.casesOn;
  { left; reflexivity };
  { right; apply ffNeqTt };
  { right; intro p; apply ffNeqTt; exact p⁻¹ };
  { left; reflexivity }
end

hott corollary boolIsSet : hset 𝟐 :=
Hedberg boolDecEq

section
  open GroundZero.Types
  hott def zeroPath {A B : 0-Type} (p : A.fst = B.fst) : A = B :=
  begin fapply Sigma.prod; exact p; apply ntypeIsProp end

  hott def zeroPathRefl (A : 0-Type) : @zeroPath A A Id.refl = Id.refl :=
  begin
    transitivity; apply Id.map (Sigma.prod (idp _)); change _ = Id.refl;
    apply propIsSet (ntypeIsProp 0); apply Sigma.prodRefl
  end
end

hott def Identity.ens {A : Type u} (H : hset A) : hset (Proto.Identity A) :=
begin apply hsetRespectsEquiv; apply Types.Equiv.identityEqv; assumption end

hott def zeroEquiv (A B : 0-Type) := A.1 ≃ B.1
infix:25 " ≃₀ " => zeroEquiv

end Structures

-- http://www.cs.bham.ac.uk/~mhe/truncation-and-extensionality/tiny-library.html
-- http://www.cs.bham.ac.uk/~mhe/truncation-and-extensionality/hsetfunext.html
def singl {A : Type u} (a : A) :=
Σ b, a = b

namespace singl
  def trivialLoop {A : Type u} (a : A) : singl a :=
  ⟨a, by reflexivity⟩

  hott def pathFromTrivialLoop {A : Type u} {a b : A}
    (r : a = b) : trivialLoop a = ⟨b, r⟩ :=
  begin induction r; reflexivity end

  hott def contr {A : Type u} (a : A) : Structures.contr (singl a) :=
  ⟨trivialLoop a, λ t, pathFromTrivialLoop t.2⟩

  hott def prop {A : Type u} (a : A) : Structures.prop (singl a) :=
  Structures.contrImplProp (contr a)
end singl

namespace Theorems
  open GroundZero.Structures GroundZero.Types.Equiv GroundZero.Types

  hott theorem naive {A : Type u} {B : A → Type v} {f g : Π x, B x} : f ~ g → f = g :=
  HITs.Interval.funext

  hott theorem weak {A : Type u} {B : A → Type v} (H : Π x, contr (B x)) : contr (Π x, B x) :=
  begin existsi (λ x, (H x).1); intro f; apply naive; intro x; apply (H x).2 end

  section
    variable {A : Type u} {B : A → Type v}

    hott theorem isContrSigmaHomotopy (f : Π x, B x) : contr (Σ g, f ~ g) :=
    let r (k : Π x, Σ y, f x = y) :=
    @Sigma.mk _ (λ g, f ~ g) (λ x, (k x).1) (λ x, (k x).2);
    let s (g : Π x, B x) (h : f ~ g) x :=
    Sigma.mk (g x) (h x);
    begin
      existsi Sigma.mk f (Homotopy.id f); intro ⟨g, H⟩;
      change r (λ x, Sigma.mk (f x) (idp _)) = r (s g H);
      apply Id.map r; apply contrImplProp;
      apply weak; intro x; apply singl.contr
    end

    variable (f : Π x, B x) {π : Π g (h : f ~ g), Type w} (r : π f (Homotopy.id f))
    hott def homotopyInd (g : Π x, B x) (h : f ~ g) : π g h :=
    @transport (Σ g, f ~ g) (λ (p : Σ g, f ~ g), π p.fst p.snd)
      ⟨f, Homotopy.id f⟩ ⟨g, h⟩
      (contrImplProp (isContrSigmaHomotopy f) _ _) r

    hott lemma homotopyIndId : homotopyInd f r f (Homotopy.id f) = r :=
    begin
      transitivity; apply Id.map
        (λ p, @transport (Σ g, f ~ g) (λ p, π p.fst p.snd)
           ⟨f, Homotopy.id f⟩ ⟨f, Homotopy.id f⟩ p r);
      change _ = idp _; apply propIsSet; apply contrImplProp;
      apply isContrSigmaHomotopy; reflexivity
    end
  end

  hott def funext {A : Type u} {B : A → Type v}
    {f g : Π x, B x} : (f ~ g) → (f = g) :=
  @homotopyInd _ _ f (λ g x, f = g) (idp _) g

  hott lemma funextHapply {A : Type u} {B : A → Type v}
    {f g : Π x, B x} : funext ∘ @HITs.Interval.happly A B f g ~ id :=
  begin
    intro p; induction p; change funext (Homotopy.id _) = idp _;
    dsimp [funext]; apply homotopyIndId f
  end

  hott lemma happlyFunext {A : Type u} {B : A → Type v}
    (f g : Π x, B x) : HITs.Interval.happly ∘ @funext A B f g ~ id :=
  begin
    intro H; fapply @homotopyInd _ _ f (λ g G, HITs.Interval.happly (funext G) = G) _ g H;
    change _ = HITs.Interval.happly (idp _); apply Id.map HITs.Interval.happly;
    change homotopyInd _ _ _ _ = _; apply homotopyIndId
  end

  hott theorem full {A : Type u} {B : A → Type v} {f g : Π x, B x} : (f = g) ≃ (f ~ g) :=
  begin
    existsi HITs.Interval.happly; apply Qinv.toBiinv; existsi funext;
    apply Prod.mk; apply happlyFunext; apply funextHapply
  end

  hott corollary funextId {A : Type u} {B : A → Type v}
    {f : Π x, B x} : funext (Homotopy.id f) = idp f :=
  homotopyIndId _ _

  open GroundZero.Types.Equiv (transport)
  hott lemma mapHomotopy {A : Type u} {B : Type v} {a b : A} (f g : A → B) (p : a = b) (q : f ~ g) :
    Id.map g p = @transport (A → B) (λ h, h a = h b) f g (funext q) (Id.map f p) :=
  begin
    induction p; symmetry; transitivity; apply Types.Equiv.transportOverHmtpy;
    transitivity; apply Id.map (· ⬝ Id.map (λ (h : A → B), h a) (funext q));
    apply Id.reflRight; transitivity; symmetry; apply mapFunctoriality (λ (h : A → B), h a);
    transitivity; apply Id.map; apply Id.invComp; reflexivity
  end
end Theorems

namespace Structures
  hott def piRespectsNType :
    Π (n : ℕ₋₂) {A : Type u} {B : A → Type v},
      (Π x, is-n-type (B x)) → is-n-type (Π x, B x)
  | −2            => λ H, ⟨λ x, (H x).1, λ φ, Theorems.funext (λ x, (H x).2 (φ x))⟩
  | hlevel.succ n => λ H f g, ntypeRespectsEquiv n (Types.Equiv.symm Theorems.full)
                                (piRespectsNType n (λ x, H x _ _))

  hott def piHset {A : Type u} {B : A → Type v}
    (H : Π x, hset (B x)) : hset (Π x, B x) :=
  begin
    apply zeroEqvSet.forward; apply piRespectsNType 0;
    intro x; apply zeroEqvSet.left; apply H
  end
end Structures

hott def iter (A B : Type) : ℕ → Type
| Nat.zero   => B
| Nat.succ n => Coproduct (iter A B n) A

hott def pt := iter 𝟏

hott def vect (A : Type u) : ℕ → Type u
| Nat.zero   => 𝟏
| Nat.succ n => A × vect A n

hott def vect.const {A : Type u} (a : A) : Π n, vect A n
| Nat.zero   => ★
| Nat.succ n => (a, const a n)

hott def vect.map {A : Type u} {B : Type v} (f : A → B) :
  Π {n : ℕ}, vect A n → vect B n
| Nat.zero   => λ _, ★
| Nat.succ n => λ v, (f v.1, map f v.2)

section
  open GroundZero.Types.Equiv (transportOverProduct transport subst)
  open GroundZero.Types

  hott def vect.subst {A B : Type u} (p : A = B) (f : B → A) {n : ℕ} (v : vect A n) :
    vect.map f (transport (vect · n) p v) = vect.map (f ∘ transport id p) v :=
  begin induction p; reflexivity end
end

hott def vect.idfunc {A : Type u} : Π {n : ℕ} (f : A → A)
  (H : f ~ id) (v : vect A n), vect.map f v = v
| Nat.zero,   f, H, v => idp v
| Nat.succ n, f, H, v => Types.Product.prod (H v.1) (idfunc f H v.2)

hott def vect.id {A : Type u} {n : ℕ} (v : vect A n) : vect.map id v = v :=
begin apply vect.idfunc; reflexivity end

hott def vect.comp {A : Type u} {B : Type v} {γ : Type w} :
  Π {n : ℕ} (f : A → B) (g : B → γ) (v : vect A n), vect.map g (vect.map f v) = vect.map (g ∘ f) v
| Nat.zero,   f, g, v => idp _
| Nat.succ n, f, g, v => Types.Product.prod (idp _) (comp f g v.2)

hott def vect.constMap {A : Type u} {B : Type v} (a : A) (f : A → B) :
  Π {n : ℕ}, vect.map f (vect.const a n) = vect.const (f a) n
| Nat.zero   => idp _
| Nat.succ n => Types.Product.prod (idp _) (constMap a f)

hott def Finite := iter 𝟏 𝟎
@[match_pattern] def Finite.zero {n : ℕ} : Finite (n + 1) := Sum.inr ★
@[match_pattern] def Finite.succ {n : ℕ} : Finite n → Finite (n + 1) := Sum.inl

def LEMinf := Π (A : Type u), A + ¬A
notation "LEM∞" => LEMinf

open Structures (prop propset)
hott def hrel (A : Type u) := A → A → propset.{v}

section
  variable {A : Type u} (R : hrel A)

  def isrefl  := Π a, (R a a).1
  def issymm  := Π a b, (R a b).1 → (R b a).1
  def istrans := Π a b c, (R a b).1 → (R b c).1 → (R a c).1

  def iseqrel := isrefl R × issymm R × istrans R
end

hott def eqrel (A : Type u) := Σ φ, @iseqrel A φ

-- TODO: repeat
hott def iseqrel.prop {A : Type u} {R : hrel A} : prop (iseqrel R) :=
begin
  apply Structures.productProp;
  { intros f g; apply Theorems.funext;
    intro x; apply (R x x).2 };
  apply Structures.productProp;
  { intros f g;
    apply Theorems.funext; intro;
    apply Theorems.funext; intro;
    apply Theorems.funext; intro;
    apply (R _ _).2 };
  { intros f g;
     apply Theorems.funext; intro;
    apply Theorems.funext; intro;
    apply Theorems.funext; intro;
    apply Theorems.funext; intro;
    apply Theorems.funext; intro;
    apply (R _ _).2 }
end

section
  variable {A : Type u} (R : eqrel.{u, v} A)

  hott def eqrel.rel : hrel A := R.1
  hott def eqrel.iseqv : iseqrel R.rel := R.2

  hott def eqrel.apply (a b : A) : Type v :=
  (R.rel a b).1

  hott def eqrel.prop (a b : A) : prop (R.apply a b) :=
  (R.rel a b).2

  -- Accessors
  hott def eqrel.refl (a : A) : R.apply a a :=
  R.2.1 a

  hott def eqrel.symm {a b : A} : R.apply a b → R.apply b a :=
  R.2.2.1 a b

  hott def eqrel.trans {a b c : A} :
    R.apply a b → R.apply b c → R.apply a c :=
  R.2.2.2 a b c
end

hott def eqrel.eq {A : Type u} {x y : eqrel A} (p : x.rel = y.rel) : x = y :=
begin apply Types.Sigma.prod p; apply iseqrel.prop end

hott def iffOverPi {A : Type u} {B : A → Type v} {B' : A → Type w}
  (φ : Π x, B x ↔ B' x) : (Π x, B x) ↔ (Π x, B' x) :=
begin apply Prod.mk; { intros f x; apply (φ x).left; apply f }; { intros g x; apply (φ x).right; apply g } end

hott def hcommSquare (P : Type k) (A : Type u) (B : Type v) (C : Type w) :=
Σ (f : A → C) (g : B → C) (h : P → A) (k : P → B), f ∘ h = g ∘ k

hott def pullback {A : Type u} {B : Type v}
  (C : Type w) (f : A → C) (g : B → C) :=
Σ (p : A × B), f p.1 = g p.2

namespace hcommSquare
  variable {P : Type k} {A : Type u} {B : Type v} {C : Type w}

  def top   (η : hcommSquare P A B C) : P → A := η.2.2.1
  def bot   (η : hcommSquare P A B C) : B → C := η.2.1
  def left  (η : hcommSquare P A B C) : P → B := η.2.2.2.1
  def right (η : hcommSquare P A B C) : A → C := η.1

  def naturality (η : hcommSquare P A B C) : η.right ∘ η.top = η.bot ∘ η.left := η.2.2.2.2

  hott def induced (η : hcommSquare P A B C) (X : Type r) :
    (X → P) → @pullback (X → A) (X → B) (X → C) (λ f, right η ∘ f) (λ g, bot η ∘ g) :=
  λ φ, ⟨(top η ∘ φ, left η ∘ φ), @map (P → C) (X → C) (right η ∘ top η) (bot η ∘ left η) (· ∘ φ) η.naturality⟩

  hott def isPullback (η : hcommSquare P A B C) :=
  Π (X : Type (max u v w k)), biinv (induced η X)
end hcommSquare

hott def pullbackSquare (P : Type k) (A : Type u) (B : Type v) (C : Type w) :=
Σ (η : hcommSquare P A B C), η.isPullback

namespace Types.Equiv
  open GroundZero.Structures
  universe u' v'

  -- 1-1 correspondence
  def Corr (A : Type u) (B : Type v) :=
  Σ (R : A → B → Type w), (Π a, contr (Σ b, R a b)) × (Π b, contr (Σ a, R a b))

  open GroundZero.Types
  variable {A : Type u} {A' : Type v} {B : Type u'} {B' : Type v'}

  hott def prodBiinv {f : A → A'} {g : B → B'}
    (e₁ : biinv f) (e₂ : biinv g) : biinv (Product.bimap f g) :=
  (⟨Product.bimap e₁.1.1 e₂.1.1, λ w, Product.prod (e₁.1.2 w.1) (e₂.1.2 w.2)⟩,
   ⟨Product.bimap e₁.2.1 e₂.2.1, λ w, Product.prod (e₁.2.2 w.1) (e₂.2.2 w.2)⟩)

  hott def prodEquiv (e₁ : A ≃ A') (e₂ : B ≃ B') : (A × B) ≃ (A' × B') :=
  ⟨Product.bimap e₁.1 e₂.1, prodBiinv e₁.2 e₂.2⟩
end Types.Equiv

end GroundZero