/-
Copyright (c) 2017 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn

More results about pointed types.

Contains
- squares of pointed maps,
- equalities between pointed homotopies and
- squares between pointed homotopies
- pointed maps into and out of (ppmap A B), the pointed type of pointed maps from A to B
-/

import ..eq2 .pointed .unit .bool .equiv ..algebra.bundled
--algebra.homotopy_group
universes u v w
hott_theory

namespace hott
open hott.trunc /-hott.nat-/ is_trunc hott.equiv hott.is_equiv hott.bool hott.sigma
--open hott.unit trunc nat group sigma function bool

namespace pointed
  variables {A : Type*} {B : Type*} {C : Type*} {P : A → Type _}
    {p₀ : P pt} {k k' l m n : ppi P p₀}

  @[hott] def punit_pmap_phomotopy {A : Type*} (f : unit* →* A) :
    f ~* pconst unit* A :=
  phomotopy_of_is_contr_dom _ _

  @[hott] def punit_ppi (P : unit* → Type) (p₀ : P ⋆) : ppi P p₀ :=
  begin
    fapply ppi.mk, intro u, induction u, exact p₀,
    refl
  end

  @[hott] def punit_ppi_phomotopy {P : unit* → Type} {p₀ : P ⋆} (f : ppi P p₀) :
    f ~* punit_ppi P p₀ :=
  phomotopy_of_is_contr_dom _ _

  @[hott] def is_contr_punit_ppi (P : unit* → Type) (p₀ : P ⋆) : is_contr (ppi P p₀) :=
  is_contr.mk (punit_ppi P p₀) (λf, eq_of_phomotopy (punit_ppi_phomotopy f)⁻¹*)

  @[hott] def is_contr_punit_pmap (A : Type*) : is_contr (unit* →* A) :=
  is_contr_punit_ppi _ _

  -- @[hott] def phomotopy_eq_equiv (h₁ h₂ : k ~* l) :
  --   (h₁ = h₂) ≃ Σ(p : to_homotopy h₁ ~ to_homotopy h₂),
  --     whisker_right (respect_pt l) (p pt) ⬝ to_homotopy_pt h₂ = to_homotopy_pt h₁ :=
  -- begin
  --   refine ppi_eq_equiv _ _ ⬝e phomotopy.sigma_char _ _ ⬝e sigma_equiv_sigma_right _,
  --   intro p,
  -- end

  /- Short term TODO: generalize to dependent maps (use ppi_eq_equiv?)
     Long term TODO: use homotopies between pointed homotopies, not equalities
  -/

  @[hott] def phomotopy_eq_equiv {A B : Type*} {f g : A →* B} (h k : f ~* g) :
    (h = k) ≃ Σ(p : to_homotopy h ~ to_homotopy k),
      whisker_right (respect_pt g) (p pt) ⬝ to_homotopy_pt k = to_homotopy_pt h :=
      sorry
  -- calc
  --   h = k ≃ phomotopy.sigma_char f g h = phomotopy.sigma_char f g k
  --     : eq_equiv_fn_eq (phomotopy.sigma_char f g) h k
  --     ... ≃ Σ(p : to_homotopy h = to_homotopy k),
  --             to_homotopy_pt h =[p; λ(q : to_homotopy h = to_homotopy k), q pt ⬝ respect_pt g = respect_pt f] to_homotopy_pt k
  --     : sigma_eq_equiv _ _
  --     ... ≃ Σ(p : to_homotopy h = to_homotopy k),
  --             to_homotopy_pt h = ap (λq, q pt ⬝ respect_pt g) p ⬝ to_homotopy_pt k
  --     : sigma_equiv_sigma_right (λp, eq_pathover_equiv_Fl p (to_homotopy_pt h) (to_homotopy_pt k))
  --     ... ≃ Σ(p : to_homotopy h = to_homotopy k),
  --             ap (λq, q pt ⬝ respect_pt g) p ⬝ to_homotopy_pt k = to_homotopy_pt h
  --     : sigma_equiv_sigma_right (λp, eq_equiv_eq_symm _ _)
  --     ... ≃ Σ(p : to_homotopy h = to_homotopy k),
  --     whisker_right (respect_pt g) (apd10 p pt) ⬝ to_homotopy_pt k = to_homotopy_pt h
  --     : sigma_equiv_sigma_right (λp, equiv_eq_closed_left _ (whisker_right _ )(whisker_right_ap _ _)⁻¹))
  --     ... ≃ Σ(p : to_homotopy h ~ to_homotopy k),
  --     whisker_right (respect_pt g) (p pt) ⬝ to_homotopy_pt k = to_homotopy_pt h
  --     : sigma_equiv_sigma_left' eq_equiv_homotopy

  @[hott] def phomotopy_eq {A B : Type*} {f g : A →* B} {h k : f ~* g} (p : to_homotopy h ~ to_homotopy k)
    (q : whisker_right (respect_pt g) (p pt) ⬝ to_homotopy_pt k = to_homotopy_pt h) : h = k :=
  to_inv (phomotopy_eq_equiv h k) ⟨p, q⟩

  @[hott] def phomotopy_eq' {A B : Type*} {f g : A →* B} {h k : f ~* g} (p : to_homotopy h ~ to_homotopy k)
    (q : square (to_homotopy_pt h) (to_homotopy_pt k) (whisker_right (respect_pt g) (p pt)) idp) : h = k :=
  phomotopy_eq p (eq_of_square q)⁻¹

  @[hott, hsimp] def trans_refl (p : k ~* l) : p ⬝* phomotopy.rfl = p :=
  begin
    induction A with A a₀,
    induction k with k k₀, induction l with l l₀, induction p with p p₀', dsimp at *,
    induction l₀, dsimp at p₀', induction p₀', refl
  end

  @[hott] def eq_of_phomotopy_trans {X Y : Type*} {f g h : X →* Y} (p : f ~* g) (q : g ~* h) :
    eq_of_phomotopy (p ⬝* q) = eq_of_phomotopy p ⬝ eq_of_phomotopy q :=
  begin
    hinduction p using phomotopy_rec_idp, hinduction q using phomotopy_rec_idp,
    exact ap eq_of_phomotopy (trans_refl _) ⬝ whisker_left _ (eq_of_phomotopy_refl _)⁻¹ᵖ
  end

  @[hott] def refl_trans (p : k ~* l) : phomotopy.rfl ⬝* p = p :=
  begin
    hinduction p using phomotopy_rec_idp,
    apply trans_refl
  end

  @[hott] def trans_assoc (p : k ~* l) (q : l ~* m) (r : m ~* n) : p ⬝* q ⬝* r = p ⬝* (q ⬝* r) :=
  begin
    hinduction r using phomotopy_rec_idp,
    hinduction q using phomotopy_rec_idp,
    hinduction p using phomotopy_rec_idp,
    induction k with k k₀, induction k₀,
    refl
  end

  @[hott] def refl_symm : phomotopy.rfl⁻¹* = phomotopy.refl k :=
  begin
    induction k with k k₀, induction k₀,
    refl
  end

  @[hott] def symm_symm (p : k ~* l) : p⁻¹*⁻¹* = p :=
  begin
    hinduction p using phomotopy_rec_idp, induction k with k k₀, induction k₀, refl
  end

  @[hott] def trans_right_inv (p : k ~* l) : p ⬝* p⁻¹* = phomotopy.rfl :=
  begin
    hinduction p using phomotopy_rec_idp, exact refl_trans _ ⬝ refl_symm
  end

  @[hott] def trans_left_inv (p : k ~* l) : p⁻¹* ⬝* p = phomotopy.rfl :=
  begin
    hinduction p using phomotopy_rec_idp, exact trans_refl _ ⬝ refl_symm
  end

  @[hott] def trans2 {p p' : k ~* l} {q q' : l ~* m} (r : p = p') (s : q = q') : p ⬝* q = p' ⬝* q' :=
  ap011 phomotopy.trans r s

  @[hott] def pcompose3 {A B C : Type*} {g g' : B →* C} {f f' : A →* B}
  {p p' : g ~* g'} {q q' : f ~* f'} (r : p = p') (s : q = q') : p ◾* q = p' ◾* q' :=
  ap011 pcompose2 r s

  @[hott] def symm2 {p p' : k ~* l} (r : p = p') : p⁻¹* = p'⁻¹* :=
  ap phomotopy.symm r

  infixl ` ◾** `:80 := pointed.trans2
  infixl ` ◽* `:81 := pointed.pcompose3
  postfix `⁻²**`:(max+1) := pointed.symm2

  @[hott] def trans_symm (p : k ~* l) (q : l ~* m) : (p ⬝* q)⁻¹* = q⁻¹* ⬝* p⁻¹* :=
  begin
    hinduction p using phomotopy_rec_idp, hinduction q using phomotopy_rec_idp,
    exact (trans_refl _)⁻²** ⬝ (trans_refl _)⁻¹ ⬝ idp ◾** refl_symm⁻¹
  end

  @[hott] def phwhisker_left (p : k ~* l) {q q' : l ~* m} (s : q = q') : p ⬝* q = p ⬝* q' :=
  idp ◾** s

  @[hott] def phwhisker_right {p p' : k ~* l} (q : l ~* m) (r : p = p') : p ⬝* q = p' ⬝* q :=
  r ◾** idp

  @[hott, hsimp] def pwhisker_left_refl {A B C : Type*} (g : B →* C) (f : A →* B) :
    pwhisker_left g (phomotopy.refl f) = phomotopy.refl (g ∘* f) :=
  begin
    induction A with A a₀, induction B with B b₀, induction C with C c₀,
    induction f with f f₀, induction g with g g₀,
    dsimp at *, induction g₀, induction f₀, refl
  end

  @[hott, hsimp] def pwhisker_right_refl {A B C : Type*} (f : A →* B) (g : B →* C) :
    pwhisker_right f (phomotopy.refl g) = phomotopy.refl (g ∘* f) :=
  begin
    induction A with A a₀, induction B with B b₀, induction C with C c₀,
    induction f with f f₀, induction g with g g₀,
    dsimp at *, induction g₀, induction f₀, refl
  end

  @[hott] def pcompose2_refl {A B C : Type*} (g : B →* C) (f : A →* B) :
    phomotopy.refl g ◾* phomotopy.refl f = phomotopy.rfl :=
  pwhisker_right_refl _ _ ◾** pwhisker_left_refl _ _ ⬝ refl_trans _

  @[hott] def pcompose2_refl_left {A B C : Type*} (g : B →* C) {f f' : A →* B} (p : f ~* f') :
    phomotopy.rfl ◾* p = pwhisker_left g p :=
  pwhisker_right_refl _ _ ◾** idp ⬝ refl_trans _

  @[hott] def pcompose2_refl_right {A B C : Type*} {g g' : B →* C} (f : A →* B) (p : g ~* g') :
    p ◾* phomotopy.rfl = pwhisker_right f p :=
  idp ◾** pwhisker_left_refl _ _ ⬝ trans_refl _

  @[hott] def pwhisker_left_trans {A B C : Type*} (g : B →* C) {f₁ f₂ f₃ : A →* B}
    (p : f₁ ~* f₂) (q : f₂ ~* f₃) :
    pwhisker_left g (p ⬝* q) = pwhisker_left g p ⬝* pwhisker_left g q :=
  begin
    hinduction p using phomotopy_rec_idp,
    hinduction q using phomotopy_rec_idp,
    refine _ ⬝ (pwhisker_left_refl _ _)⁻¹ ◾** (pwhisker_left_refl _ _)⁻¹,
    refine ap (pwhisker_left g) (trans_refl _) ⬝ pwhisker_left_refl _ _ ⬝ (trans_refl _)⁻¹
  end

  @[hott] def pwhisker_right_trans {A B C : Type*} (f : A →* B) {g₁ g₂ g₃ : B →* C}
    (p : g₁ ~* g₂) (q : g₂ ~* g₃) :
    pwhisker_right f (p ⬝* q) = pwhisker_right f p ⬝* pwhisker_right f q :=
  begin
    hinduction p using phomotopy_rec_idp,
    hinduction q using phomotopy_rec_idp,
    refine _ ⬝ (pwhisker_right_refl _ _)⁻¹ ◾** (pwhisker_right_refl _ _)⁻¹,
    refine ap (pwhisker_right f) (trans_refl _) ⬝ pwhisker_right_refl _ _ ⬝ (trans_refl _)⁻¹
  end

  @[hott] def pwhisker_left_symm {A B C : Type*} (g : B →* C) {f₁ f₂ : A →* B} (p : f₁ ~* f₂) :
    pwhisker_left g p⁻¹* = (pwhisker_left g p)⁻¹* :=
  begin
    hinduction p using phomotopy_rec_idp,
    refine _ ⬝ ap phomotopy.symm (pwhisker_left_refl _ _)⁻¹ᵖ,
    refine ap (pwhisker_left g) refl_symm ⬝ pwhisker_left_refl _ _ ⬝ refl_symm⁻¹
  end

  @[hott] def pwhisker_right_symm {A B C : Type*} (f : A →* B) {g₁ g₂ : B →* C} (p : g₁ ~* g₂) :
    pwhisker_right f p⁻¹* = (pwhisker_right f p)⁻¹* :=
  begin
    hinduction p using phomotopy_rec_idp,
    refine _ ⬝ ap phomotopy.symm (pwhisker_right_refl _ _)⁻¹ᵖ,
    refine ap (pwhisker_right f) refl_symm ⬝ pwhisker_right_refl _ _ ⬝ refl_symm⁻¹
  end

  @[hott] def trans_eq_of_eq_symm_trans {p : k ~* l} {q : l ~* m} {r : k ~* m} (s : q = p⁻¹* ⬝* r) :
    p ⬝* q = r :=
  idp ◾** s ⬝ (trans_assoc _ _ _)⁻¹ ⬝ trans_right_inv p ◾** idp ⬝ refl_trans _

  @[hott] def eq_symm_trans_of_trans_eq {p : k ~* l} {q : l ~* m} {r : k ~* m} (s : p ⬝* q = r) :
    q = p⁻¹* ⬝* r :=
  (refl_trans _)⁻¹ ⬝ (trans_left_inv _)⁻¹ ◾** idp ⬝ trans_assoc _ _ _ ⬝ idp ◾** s

  @[hott] def trans_eq_of_eq_trans_symm {p : k ~* l} {q : l ~* m} {r : k ~* m} (s : p = r ⬝* q⁻¹*) :
    p ⬝* q = r :=
  s ◾** idp ⬝ trans_assoc _ _ _ ⬝ idp ◾** trans_left_inv q ⬝ trans_refl _

  @[hott] def eq_trans_symm_of_trans_eq {p : k ~* l} {q : l ~* m} {r : k ~* m} (s : p ⬝* q = r) :
    p = r ⬝* q⁻¹* :=
  (trans_refl _)⁻¹ ⬝ idp ◾** (trans_right_inv _)⁻¹ ⬝ (trans_assoc _ _ _)⁻¹ ⬝ s ◾** idp

  @[hott] def eq_trans_of_symm_trans_eq {p : k ~* l} {q : l ~* m} {r : k ~* m} (s : p⁻¹* ⬝* r = q) :
    r = p ⬝* q :=
  (refl_trans _)⁻¹ ⬝ (trans_right_inv _)⁻¹ ◾** idp ⬝ trans_assoc _ _ _ ⬝ idp ◾** s

  @[hott] def symm_trans_eq_of_eq_trans {p : k ~* l} {q : l ~* m} {r : k ~* m} (s : r = p ⬝* q) :
    p⁻¹* ⬝* r = q :=
  idp ◾** s ⬝ (trans_assoc _ _ _)⁻¹ ⬝ trans_left_inv p ◾** idp ⬝ refl_trans _

  @[hott] def eq_trans_of_trans_symm_eq {p : k ~* l} {q : l ~* m} {r : k ~* m} (s : r ⬝* q⁻¹* = p) :
    r = p ⬝* q :=
  (trans_refl _)⁻¹ ⬝ idp ◾** (trans_left_inv _)⁻¹ ⬝ (trans_assoc _ _ _)⁻¹ ⬝ s ◾** idp

  @[hott] def trans_symm_eq_of_eq_trans {p : k ~* l} {q : l ~* m} {r : k ~* m} (s : r = p ⬝* q) :
    r ⬝* q⁻¹* = p :=
  s ◾** idp ⬝ trans_assoc _ _ _ ⬝ idp ◾** trans_right_inv q ⬝ trans_refl _

  section phsquare
  /-
    Squares of pointed homotopies
  -/

  variables {f f' f₀₀ f₂₀ f₄₀ f₀₂ f₂₂ f₄₂ f₀₄ f₂₄ f₄₄ : ppi P p₀}
            {p₁₀ : f₀₀ ~* f₂₀} {p₃₀ : f₂₀ ~* f₄₀}
            {p₀₁ : f₀₀ ~* f₀₂} {p₂₁ : f₂₀ ~* f₂₂} {p₄₁ : f₄₀ ~* f₄₂}
            {p₁₂ : f₀₂ ~* f₂₂} {p₃₂ : f₂₂ ~* f₄₂}
            {p₀₃ : f₀₂ ~* f₀₄} {p₂₃ : f₂₂ ~* f₂₄} {p₄₃ : f₄₂ ~* f₄₄}
            {p₁₄ : f₀₄ ~* f₂₄} {p₃₄ : f₂₄ ~* f₄₄}

  @[hott, reducible] def phsquare (p₁₀ : f₀₀ ~* f₂₀) (p₁₂ : f₀₂ ~* f₂₂)
                                  (p₀₁ : f₀₀ ~* f₀₂) (p₂₁ : f₂₀ ~* f₂₂) : Type _ :=
  p₁₀ ⬝* p₂₁ = p₀₁ ⬝* p₁₂

  @[hott] def phsquare_of_eq (p : p₁₀ ⬝* p₂₁ = p₀₁ ⬝* p₁₂) : phsquare p₁₀ p₁₂ p₀₁ p₂₁ := p
  @[hott] def eq_of_phsquare (p : phsquare p₁₀ p₁₂ p₀₁ p₂₁) : p₁₀ ⬝* p₂₁ = p₀₁ ⬝* p₁₂ := p

  -- @[hott] def phsquare.mk (p : Πx, square (p₁₀ x) (p₁₂ x) (p₀₁ x) (p₂₁ x))
  --   (q : cube (square_of_eq (to_homotopy_pt p₁₀)) (square_of_eq (to_homotopy_pt p₁₂))
  --             (square_of_eq (to_homotopy_pt p₀₁)) (square_of_eq (to_homotopy_pt p₂₁))
  --             (p pt) ids) : phsquare p₁₀ p₁₂ p₀₁ p₂₁ :=
  -- begin
  --   fapply phomotopy_eq,
  --   { intro x, apply eq_of_square (p x) },
  --   { generalize p pt, intro r, exact sorry }
  -- end

  @[hott] def phhconcat (p : phsquare p₁₀ p₁₂ p₀₁ p₂₁) (q : phsquare p₃₀ p₃₂ p₂₁ p₄₁) :
    phsquare (p₁₀ ⬝* p₃₀) (p₁₂ ⬝* p₃₂) p₀₁ p₄₁ :=
  trans_assoc _ _ _ ⬝ idp ◾** q ⬝ (trans_assoc _ _ _)⁻¹ ⬝ p ◾** idp ⬝ trans_assoc _ _ _

  @[hott] def phvconcat (p : phsquare p₁₀ p₁₂ p₀₁ p₂₁) (q : phsquare p₁₂ p₁₄ p₀₃ p₂₃) :
    phsquare p₁₀ p₁₄ (p₀₁ ⬝* p₀₃) (p₂₁ ⬝* p₂₃) :=
  (phhconcat p⁻¹ q⁻¹)⁻¹

  @[hott] def phhdeg_square {p₁ p₂ : f ~* f'} (q : p₁ = p₂) : phsquare phomotopy.rfl phomotopy.rfl p₁ p₂ :=
  refl_trans _ ⬝ q⁻¹ ⬝ (trans_refl _)⁻¹
  @[hott] def phvdeg_square {p₁ p₂ : f ~* f'} (q : p₁ = p₂) : phsquare p₁ p₂ phomotopy.rfl phomotopy.rfl :=
  trans_refl _ ⬝ q ⬝ (refl_trans _)⁻¹

  variables (p₀₁ p₁₀)
  @[hott] def phhrefl : phsquare phomotopy.rfl phomotopy.rfl p₀₁ p₀₁ := phhdeg_square idp
  @[hott] def phvrefl : phsquare p₁₀ p₁₀ phomotopy.rfl phomotopy.rfl := phvdeg_square idp
  variables {p₀₁ p₁₀}
  @[hott] def phhrfl : phsquare phomotopy.rfl phomotopy.rfl p₀₁ p₀₁ := phhrefl p₀₁
  @[hott] def phvrfl : phsquare p₁₀ p₁₀ phomotopy.rfl phomotopy.rfl := phvrefl p₁₀

  /-
    The names are very baroque. The following stands for
    "pointed homotopy path-horizontal composition" (i.e. composition on the left with a path)
    The names are obtained by using the ones for squares, and putting "ph" in front of it.
    In practice, use the notation ⬝ph** defined below, which might be easier to remember
  -/
  @[hott] def phphconcat {p₀₁'} (p : p₀₁' = p₀₁) (q : phsquare p₁₀ p₁₂ p₀₁ p₂₁) :
    phsquare p₁₀ p₁₂ p₀₁' p₂₁ :=
  by induction p; exact q

  @[hott] def phhpconcat {p₂₁'} (q : phsquare p₁₀ p₁₂ p₀₁ p₂₁) (p : p₂₁ = p₂₁') :
    phsquare p₁₀ p₁₂ p₀₁ p₂₁' :=
  by induction p; exact q

  @[hott] def phpvconcat {p₁₀'} (p : p₁₀' = p₁₀) (q : phsquare p₁₀ p₁₂ p₀₁ p₂₁) :
    phsquare p₁₀' p₁₂ p₀₁ p₂₁ :=
  by induction p; exact q

  @[hott] def phvpconcat {p₁₂'} (q : phsquare p₁₀ p₁₂ p₀₁ p₂₁) (p : p₁₂ = p₁₂') :
    phsquare p₁₀ p₁₂' p₀₁ p₂₁ :=
  by induction p; exact q

  @[hott] def phhinverse (p : phsquare p₁₀ p₁₂ p₀₁ p₂₁) : phsquare p₁₀⁻¹* p₁₂⁻¹* p₂₁ p₀₁ :=
  begin
    refine (eq_symm_trans_of_trans_eq _)⁻¹,
    refine (trans_assoc _ _ _)⁻¹ ⬝ _,
    refine (eq_trans_symm_of_trans_eq _)⁻¹,
    exact (eq_of_phsquare p)⁻¹
  end

  @[hott] def phvinverse (p : phsquare p₁₀ p₁₂ p₀₁ p₂₁) : phsquare p₁₂ p₁₀ p₀₁⁻¹* p₂₁⁻¹* :=
  (phhinverse p⁻¹)⁻¹

  infix ` ⬝h** `:78 := phhconcat
  infix ` ⬝v** `:78 := phvconcat
  infixr ` ⬝ph** `:77 := phphconcat
  infixl ` ⬝hp** `:77 := phhpconcat
  infixr ` ⬝pv** `:77 := phpvconcat
  infixl ` ⬝vp** `:77 := phvpconcat
  postfix `⁻¹ʰ**`:(max+1) := phhinverse
  postfix `⁻¹ᵛ**`:(max+1) := phvinverse

  @[hott] def phwhisker_rt (p : f ~* f₂₀) (q : phsquare p₁₀ p₁₂ p₀₁ p₂₁) :
    phsquare (p₁₀ ⬝* p⁻¹*) p₁₂ p₀₁ (p ⬝* p₂₁) :=
  trans_assoc _ _ _ ⬝ idp ◾** ((trans_assoc _ _ _)⁻¹ ⬝ trans_left_inv _ ◾** idp ⬝ refl_trans _) ⬝ q

  @[hott] def phwhisker_br (p : f₂₂ ~* f) (q : phsquare p₁₀ p₁₂ p₀₁ p₂₁) :
    phsquare p₁₀ (p₁₂ ⬝* p) p₀₁ (p₂₁ ⬝* p) :=
  (trans_assoc _ _ _)⁻¹ ⬝ q ◾** idp ⬝ trans_assoc _ _ _

  @[hott] def phmove_top_of_left' {p₀₁ : f ~* f₀₂} (p : f₀₀ ~* f)
    (q : phsquare p₁₀ p₁₂ (p ⬝* p₀₁) p₂₁) : phsquare (p⁻¹* ⬝* p₁₀) p₁₂ p₀₁ p₂₁ :=
  trans_assoc _ _ _ ⬝ (eq_symm_trans_of_trans_eq (q ⬝ (trans_assoc _ _ _))⁻¹)⁻¹

  @[hott] def phmove_bot_of_left {p₀₁ : f₀₀ ~* f} (p : f ~* f₀₂)
    (q : phsquare p₁₀ p₁₂ (p₀₁ ⬝* p) p₂₁) : phsquare p₁₀ (p ⬝* p₁₂) p₀₁ p₂₁ :=
  q ⬝ trans_assoc _ _ _

  @[hott] def passoc_phomotopy_right {A B C D : Type*} (h : C →* D) (g : B →* C) {f f' : A →* B}
    (p : f ~* f') : phsquare (passoc h g f) (passoc h g f')
      (pwhisker_left (h ∘* g) p) (pwhisker_left h (pwhisker_left g p)) :=
  begin
    hinduction p using phomotopy_rec_idp,
    refine idp ◾** (ap (pwhisker_left h) (pwhisker_left_refl _ _) ⬝ pwhisker_left_refl _ _) ⬝ _ ⬝
          (pwhisker_left_refl _ _)⁻¹ ◾** idp,
    exact trans_refl _ ⬝ (refl_trans _)⁻¹
  end

  @[hott] theorem passoc_phomotopy_middle {A B C D : Type*} (h : C →* D) {g g' : B →* C} (f : A →* B)
    (p : g ~* g') : phsquare (passoc h g f) (passoc h g' f)
      (pwhisker_right f (pwhisker_left h p)) (pwhisker_left h (pwhisker_right f p)) :=
  begin
    hinduction p using phomotopy_rec_idp,
    rwr [pwhisker_right_refl, pwhisker_left_refl],
    rwr [pwhisker_right_refl, pwhisker_left_refl],
    exact phvrfl
  end

  @[hott] def pwhisker_right_pwhisker_left {A B C : Type*} {g g' : B →* C} {f f' : A →* B}
    (p : g ~* g') (q : f ~* f') :
    phsquare (pwhisker_right f p) (pwhisker_right f' p) (pwhisker_left g q) (pwhisker_left g' q) :=
  begin
    hinduction p using phomotopy_rec_idp,
    hinduction q using phomotopy_rec_idp,
    exact pwhisker_right_refl _ _ ◾** pwhisker_left_refl _ _ ⬝
          (pwhisker_left_refl _ _)⁻¹ ◾** (pwhisker_right_refl _ _)⁻¹
  end

  end phsquare

  section nondep_phsquare

  variables {f f' f₀₀ f₂₀ f₀₂ f₂₂ : A →* B}
            {p₁₀ : f₀₀ ~* f₂₀} {p₀₁ : f₀₀ ~* f₀₂} {p₂₁ : f₂₀ ~* f₂₂} {p₁₂ : f₀₂ ~* f₂₂}

  @[hott] def pwhisker_left_phsquare (f : B →* C) (p : phsquare p₁₀ p₁₂ p₀₁ p₂₁) :
    phsquare (pwhisker_left f p₁₀) (pwhisker_left f p₁₂)
             (pwhisker_left f p₀₁) (pwhisker_left f p₂₁) :=
  (pwhisker_left_trans _ _ _)⁻¹ ⬝ ap (pwhisker_left f) p ⬝ pwhisker_left_trans _ _ _

  @[hott] def pwhisker_right_phsquare (f : C →* A) (p : phsquare p₁₀ p₁₂ p₀₁ p₂₁) :
    phsquare (pwhisker_right f p₁₀) (pwhisker_right f p₁₂)
             (pwhisker_right f p₀₁) (pwhisker_right f p₂₁) :=
  (pwhisker_right_trans _ _ _)⁻¹ ⬝ ap (pwhisker_right f) p ⬝ pwhisker_right_trans _ _ _

  end nondep_phsquare

  @[hott] def phomotopy_of_eq_con (p : k = l) (q : l = m) :
    phomotopy_of_eq (p ⬝ q) = phomotopy_of_eq p ⬝* phomotopy_of_eq q :=
  begin induction q, induction p, symmetry, apply trans_refl end

  @[hott] def pcompose_left_eq_of_phomotopy {A B C : Type*} (g : B →* C) {f f' : A →* B}
    (H : f ~* f') : ap (λf, g ∘* f) (eq_of_phomotopy H) = eq_of_phomotopy (pwhisker_left g H) :=
  begin
    hinduction H using phomotopy_rec_idp,
    refine ap02 _ (eq_of_phomotopy_refl _) ⬝ (eq_of_phomotopy_refl _)⁻¹ ⬝ ap eq_of_phomotopy _,
    exact (pwhisker_left_refl _ _)⁻¹
  end

  @[hott] def pcompose_right_eq_of_phomotopy {A B C : Type*} {g g' : B →* C} (f : A →* B)
    (H : g ~* g') : ap (λg, g ∘* f) (eq_of_phomotopy H) = eq_of_phomotopy (pwhisker_right f H) :=
  begin
    hinduction H using phomotopy_rec_idp,
    refine ap02 _ (eq_of_phomotopy_refl _) ⬝ (eq_of_phomotopy_refl _)⁻¹ ⬝ ap eq_of_phomotopy _,
    exact (pwhisker_right_refl _ _)⁻¹
  end

  @[hott] def phomotopy_of_eq_pcompose_left {A B C : Type*} (g : B →* C) {f f' : A →* B}
    (p : f = f') : phomotopy_of_eq (ap (λf, g ∘* f) p) = pwhisker_left g (phomotopy_of_eq p) :=
  begin
    induction p, exact (pwhisker_left_refl _ _)⁻¹
  end

  @[hott] def phomotopy_of_eq_pcompose_right {A B C : Type*} {g g' : B →* C} (f : A →* B)
    (p : g = g') : phomotopy_of_eq (ap (λg, g ∘* f) p) = pwhisker_right f (phomotopy_of_eq p) :=
  begin
    induction p, exact (pwhisker_right_refl _ _)⁻¹
  end

  @[hott] def phomotopy_mk_ppmap {A B C : Type*} {f g : A →* ppmap B C} (p : Πa, f a ~* g a)
    (q : p pt ⬝* phomotopy_of_eq (respect_pt g) = phomotopy_of_eq (respect_pt f))
    : f ~* g :=
  begin
    apply phomotopy.mk (λa, eq_of_phomotopy (p a)),
    apply eq_of_fn_eq_fn (pmap_eq_equiv _ _),
    refine phomotopy_of_eq_con _ _ ⬝ _,
    refine phomotopy_of_eq_of_phomotopy _ ◾** idp ⬝ q,
  end

  /- properties of ppmap, the pointed type of pointed maps -/
  @[hott] def pcompose_pconst (f : B →* C) : f ∘* pconst A B ~* pconst A C :=
  phomotopy.mk (λa, respect_pt f) (idp_con _)⁻¹

  @[hott] def pconst_pcompose (f : A →* B) : pconst B C ∘* f ~* pconst A C :=
  phomotopy.mk (λa, rfl) (ap_constant _ _)⁻¹

  @[hott] def ppcompose_left (g : B →* C) : ppmap A B →* ppmap A C :=
  pmap.mk (pcompose g) (eq_of_phomotopy (pcompose_pconst g))

  @[hott] def ppcompose_right (f : A →* B) : ppmap B C →* ppmap A C :=
  pmap.mk (λg, g ∘* f) (eq_of_phomotopy (pconst_pcompose f))

  /- TODO: give construction using pequiv.MK, which computes better (see comment for a start of the proof), rename to ppmap_pequiv_ppmap_right -/
  @[hott] def pequiv_ppcompose_left (g : B ≃* C) : ppmap A B ≃* ppmap A C :=
  pequiv.MK' (ppcompose_left g.to_pmap) (ppcompose_left g⁻¹ᵉ*.to_pmap).to_fun
    begin intro f, apply eq_of_phomotopy, apply pinv_pcompose_cancel_left end
    begin intro f, apply eq_of_phomotopy, apply pcompose_pinv_cancel_left end
  -- pequiv.MK (ppcompose_left g) (ppcompose_left g⁻¹ᵉ*)
  --   abstract begin
  --     apply phomotopy_mk_ppmap (pinv_pcompose_cancel_left g), esimp,
  --     refine trans_refl _ ⬝ _,
  --     refine _ ⬝ (phomotopy_of_eq_con _ _ ⬝ (phomotopy_of_eq_pcompose_left _ _ ⬝
  --       ap (pwhisker_left _) (phomotopy_of_eq_of_phomotopy _)) ◾** (phomotopy_of_eq_of_phomotopy _))⁻¹,

  --   end end
  --   abstract begin
  --     exact sorry
  --   end end

  @[hott] def pequiv_ppcompose_right (f : A ≃* B) : ppmap B C ≃* ppmap A C :=
  begin
    fapply pequiv.MK',
    { exact ppcompose_right f.to_pmap },
    { exact (ppcompose_right f⁻¹ᵉ*.to_pmap).to_fun },
    { intro g, apply eq_of_phomotopy, apply pcompose_pinv_cancel_right },
    { intro g, apply eq_of_phomotopy, apply pinv_pcompose_cancel_right },
  end

  @[hott] def loop_ppmap_commute (A B : Type*) : Ω(ppmap A B) ≃* (ppmap A (Ω B)) :=
    pequiv_of_equiv
      (calc Ω(ppmap A B)
        ≃ (pconst A B ~* pconst A B)                       : pmap_eq_equiv _ _
    ... ≃ Σ(p : pconst A B ~ pconst A B), p pt ⬝ rfl = rfl : phomotopy.sigma_char _ _
    ... ≃ (A →* Ω B)                                       : pmap.sigma_char⁻¹ᵉ)
      (by refl)

  @[hott] def papply {A : Type*} (B : Type*) (a : A) : ppmap A B →* B :=
  pmap.mk (λ(f : A →* B), f a) idp

  @[hott] def papply_pcompose {A : Type*} (B : Type*) (a : A) : ppmap A B →* B :=
  pmap.mk (λ(f : A →* B), f a) idp

  @[hott] def ppmap_pbool_pequiv (B : Type*) : ppmap bool* B ≃* B :=
  begin
    fapply pequiv.MK',
    { exact papply B tt },
    { exact pbool_pmap },
    { intro f, fapply eq_of_phomotopy, fapply phomotopy.mk,
      { intro b, cases b, exact (respect_pt _)⁻¹ᵖ, refl },
      { exact con.left_inv _ }},
    { intro b, refl },
  end

  @[hott] def papn_pt (n : ℕ) (A B : Type*) : ppmap A B →* ppmap (Ω[n] A) (Ω[n] B) :=
  pmap.mk (λf, apn n f) (eq_of_phomotopy (apn_pconst _ _ _))

  @[hott] def papn_fun {n : ℕ} {A : Type*} (B : Type*) (p : Ω[n] A) :
    ppmap A B →* Ω[n] B :=
  papply _ p ∘* papn_pt n A B

  @[hott] def pconst_pcompose_pconst (A B C : Type*) :
    pconst_pcompose (pconst A B) = pcompose_pconst (pconst B C) :=
  idp

  @[hott] def pconst_pcompose_phomotopy_pconst {A B C : Type*} {f : A →* B} (p : f ~* pconst A B) :
    pconst_pcompose f = pwhisker_left (pconst B C) p ⬝* pcompose_pconst (pconst B C) :=
  begin
    have H : Π(p : pconst A B ~* f),
      pconst_pcompose f = pwhisker_left (pconst B C) p⁻¹* ⬝* pcompose_pconst (pconst B C),
    { intro p, hinduction p using phomotopy_rec_idp, refl },
    refine H p⁻¹* ⬝ ap (pwhisker_left _) (symm_symm _) ◾** idp,
  end

  @[hott] def passoc_pconst_right {A B C D : Type*} (h : C →* D) (g : B →* C) :
    passoc h g (pconst A B) ⬝* (pwhisker_left h (pcompose_pconst g) ⬝* pcompose_pconst h) =
    pcompose_pconst (h ∘* g) :=
  begin
    fapply phomotopy_eq,
    { intro a, apply idp_con },
    { induction h with h h₀, induction g with g g₀, induction D with D d₀, induction C with C c₀,
      dsimp at *, induction g₀, induction h₀, refl }
  end

  @[hott] def passoc_pconst_middle {A A' B B' : Type*} (g : B →* B') (f : A' →* A) :
    passoc g (pconst A B) f ⬝* (pwhisker_left g (pconst_pcompose f) ⬝* pcompose_pconst g) =
    pwhisker_right f (pcompose_pconst g) ⬝* pconst_pcompose f :=
  begin
    fapply phomotopy_eq,
    { intro a, exact idp_con _ ⬝ idp_con _ },
    { induction g with g g₀, induction f with f f₀, induction B' with D d₀, induction A with C c₀,
      dsimp at *, induction g₀, induction f₀, refl }
  end

  @[hott] def passoc_pconst_left {A B C D : Type*} (g : B →* C) (f : A →* B) :
    phsquare (passoc (pconst C D) g f) (pconst_pcompose f)
             (pwhisker_right f (pconst_pcompose g)) (pconst_pcompose (g ∘* f)) :=
  begin
    fapply phomotopy_eq,
    { intro a, dsimp [passoc, phomotopy.trans, phomotopy.mk], exact idp_con _ },
    { induction g with g g₀, induction f with f f₀, induction C with C c₀, induction B with B b₀,
      dsimp at *, induction g₀, induction f₀, refl }
  end

  @[hott] def ppcompose_left_pcompose {A B C D : Type*} (h : C →* D) (g : B →* C) :
    @ppcompose_left A _ _ (h ∘* g) ~* ppcompose_left h ∘* ppcompose_left g :=
  begin
    fapply phomotopy_mk_ppmap,
    { exact passoc h g },
    { dsimp [ppcompose_left],
      refine idp ◾** (phomotopy_of_eq_con _ _ ⬝
        (ap phomotopy_of_eq (pcompose_left_eq_of_phomotopy _ _) ⬝ phomotopy_of_eq_of_phomotopy _) ◾**
        phomotopy_of_eq_of_phomotopy _) ⬝ _,
      refine _ ⬝ (phomotopy_of_eq_of_phomotopy _)⁻¹ᵖ,
      exact passoc_pconst_right h g }
  end

  @[hott] def ppcompose_right_pcompose {A B C D : Type*} (g : B →* C) (f : A →* B) :
    @ppcompose_right _ _ D (g ∘* f) ~* ppcompose_right f ∘* ppcompose_right g :=
  begin
    symmetry,
    fapply phomotopy_mk_ppmap,
    { intro h, exact passoc h g f },
    { dsimp [ppcompose_right],
      refine idp ◾** phomotopy_of_eq_of_phomotopy _ ⬝ _ ⬝ (phomotopy_of_eq_con _ _ ⬝
        (ap phomotopy_of_eq (pcompose_right_eq_of_phomotopy _ _) ⬝ (phomotopy_of_eq_of_phomotopy _)) ◾** (phomotopy_of_eq_of_phomotopy _))⁻¹,
      exact passoc_pconst_left g f }
  end

  @[hott] def ppcompose_left_ppcompose_right {A A' B B' : Type*} (g : B →* B') (f : A' →* A) :
    psquare (ppcompose_left g) (ppcompose_left g) (ppcompose_right f) (ppcompose_right f) :=
  begin
    fapply phomotopy_mk_ppmap,
    { intro h, exact passoc g h f },
    { dsimp [ppcompose_left, ppcompose_right], refine idp ◾** (phomotopy_of_eq_con _ _ ⬝
        (ap phomotopy_of_eq (pcompose_left_eq_of_phomotopy _ _) ⬝ (phomotopy_of_eq_of_phomotopy _)) ◾**
        (phomotopy_of_eq_of_phomotopy _)) ⬝ _ ⬝ (phomotopy_of_eq_con _ _ ⬝
        (ap phomotopy_of_eq (pcompose_right_eq_of_phomotopy _ _) ⬝ (phomotopy_of_eq_of_phomotopy _)) ◾**
        (phomotopy_of_eq_of_phomotopy _))⁻¹,
      apply passoc_pconst_middle }
  end

  @[hott] def pcompose_pconst_phomotopy {A B C : Type*} {f f' : B →* C} (p : f ~* f') :
    pwhisker_right (pconst A B) p ⬝* pcompose_pconst f' = pcompose_pconst f :=
  begin
    fapply phomotopy_eq,
    { intro a, exact to_homotopy_pt p },
    { hinduction p using phomotopy_rec_idp, induction C with C c₀, induction f with f f₀,
      dsimp at *, induction f₀, refl }
  end

  @[hott] def pid_pconst (A B : Type*) : pcompose_pconst (pid B) = pid_pcompose (pconst A B) :=
  by refl

  @[hott] def pid_pconst_pcompose {A B C : Type*} (f : A →* B) :
    phsquare (pid_pcompose (pconst B C ∘* f))
             (pcompose_pconst (pid C))
             (pwhisker_left (pid C) (pconst_pcompose f))
             (pconst_pcompose f) :=
  begin
    fapply phomotopy_eq,
    { refl },
    { induction f with f f₀, induction B with B b₀, dsimp at *, induction f₀, refl }
  end

  @[hott] def ppcompose_left_pconst (A B C : Type*) :
    @ppcompose_left A _ _ (pconst B C) ~* pconst (ppmap A B) (ppmap A C) :=
  begin
    fapply phomotopy_mk_ppmap,
    { exact pconst_pcompose },
    { dsimp [ppcompose_left],
      exact idp ◾** phomotopy_of_eq_idp _ ⬝ (phomotopy_of_eq_of_phomotopy _)⁻¹ }
  end

  @[hott] def ppcompose_left_phomotopy {A B C : Type*} {g g' : B →* C} (p : g ~* g') :
    @ppcompose_left A _ _ g ~* ppcompose_left g' :=
  begin
    hinduction p using phomotopy_rec_idp,
    refl
  end

  @[hott] def ppcompose_left_phomotopy_refl {A B C : Type*} (g : B →* C) :
    ppcompose_left_phomotopy (phomotopy.refl g) = phomotopy.refl (@ppcompose_left A _ _ g) :=
  by dsimp [ppcompose_left_phomotopy]; exact phomotopy_rec_idp_refl _

    /- a more explicit proof of ppcompose_left_phomotopy, which might be useful if we need to prove properties about it
    -/
    -- fapply phomotopy_mk_ppmap,
    -- { intro f, exact pwhisker_right f p },
    -- { refine ap (λx, _ ⬝* x) (phomotopy_of_eq_of_phomotopy _) ⬝ _ ⬝ (phomotopy_of_eq_of_phomotopy _)⁻¹,
    --   exact pcompose_pconst_phomotopy p }

  @[hott] def ppcompose_right_phomotopy {A B C : Type*} {f f' : A →* B} (p : f ~* f') :
    @ppcompose_right _ _ C f ~* ppcompose_right f' :=
  begin
    hinduction p using phomotopy_rec_idp,
    refl
  end

  @[hott] def pppcompose (A B C : Type*) : ppmap B C →* ppmap (ppmap A B) (ppmap A C) :=
  pmap.mk ppcompose_left (eq_of_phomotopy (ppcompose_left_pconst _ _ _))

  section psquare

  variables {A' : Type*} {A₀₀ : Type*} {A₂₀ : Type*} {A₄₀ : Type*}
            {A₀₂ : Type*} {A₂₂ : Type*} {A₄₂ : Type*}
            {A₀₄ : Type*} {A₂₄ : Type*} {A₄₄ : Type*}
            {f₁₀ f₁₀' : A₀₀ →* A₂₀} {f₃₀ : A₂₀ →* A₄₀}
            {f₀₁ f₀₁' : A₀₀ →* A₀₂} {f₂₁ f₂₁' : A₂₀ →* A₂₂} {f₄₁ : A₄₀ →* A₄₂}
            {f₁₂ f₁₂' : A₀₂ →* A₂₂} {f₃₂ : A₂₂ →* A₄₂}
            {f₀₃ : A₀₂ →* A₀₄} {f₂₃ : A₂₂ →* A₂₄} {f₄₃ : A₄₂ →* A₄₄}
            {f₁₄ : A₀₄ →* A₂₄} {f₃₄ : A₂₄ →* A₄₄}

  -- @[hott] def ptrunc_functor_psquare (n : ℕ₋₂) (p : psquare f₁₀ f₁₂ f₀₁ f₂₁) :
  --   psquare (ptrunc_functor n f₁₀) (ptrunc_functor n f₁₂)
  --           (ptrunc_functor n f₀₁) (ptrunc_functor n f₂₁) :=
  -- (ptrunc_functor_pcompose _ _ _)⁻¹* ⬝* ptrunc_functor_phomotopy n p ⬝*
  -- ptrunc_functor_pcompose _ _ _

  -- @[hott] def homotopy_group_functor_psquare (n : ℕ) (p : psquare f₁₀ f₁₂ f₀₁ f₂₁) :
  --       psquare (π→[n] f₁₀) (π→[n] f₁₂) (π→[n] f₀₁) (π→[n] f₂₁) :=
  -- (homotopy_group_functor_compose _ _ _)⁻¹* ⬝* homotopy_group_functor_phomotopy n p ⬝*
  -- homotopy_group_functor_compose _ _ _

  -- @[hott] def homotopy_group_homomorphism_psquare (n : ℕ) [H : is_succ n]
  --   (p : psquare f₁₀ f₁₂ f₀₁ f₂₁) : hsquare (π→g[n] f₁₀) (π→g[n] f₁₂) (π→g[n] f₀₁) (π→g[n] f₂₁) :=
  -- begin
  --   induction H with n, exact to_homotopy (ptrunc_functor_psquare 0 (apn_psquare (succ n) p))
  -- end

  @[hott] def ppcompose_left_psquare {A : Type*} (p : psquare f₁₀ f₁₂ f₀₁ f₂₁) :
    psquare (@ppcompose_left A _ _ f₁₀) (ppcompose_left f₁₂)
            (ppcompose_left f₀₁) (ppcompose_left f₂₁) :=
  (ppcompose_left_pcompose _ _)⁻¹* ⬝* ppcompose_left_phomotopy p ⬝* ppcompose_left_pcompose _ _

  @[hott] def ppcompose_right_psquare {A : Type*} (p : psquare f₁₀ f₁₂ f₀₁ f₂₁) :
    psquare (@ppcompose_right _ _ A f₁₂) (ppcompose_right f₁₀)
            (ppcompose_right f₂₁) (ppcompose_right f₀₁) :=
  (ppcompose_right_pcompose _ _)⁻¹* ⬝* ppcompose_right_phomotopy p⁻¹* ⬝*
  ppcompose_right_pcompose _ _

  @[hott] def trans_phomotopy_hconcat {f₀₁' f₀₁''}
    (q₂ : f₀₁'' ~* f₀₁') (q₁ : f₀₁' ~* f₀₁) (p : psquare f₁₀ f₁₂ f₀₁ f₂₁) :
    (q₂ ⬝* q₁) ⬝ph* p = q₂ ⬝ph* q₁ ⬝ph* p :=
  idp ◾** (ap (pwhisker_left f₁₂) (trans_symm _ _) ⬝ pwhisker_left_trans _ _ _) ⬝ (trans_assoc _ _ _)⁻¹

  @[hott] def symm_phomotopy_hconcat {f₀₁'} (q : f₀₁ ~* f₀₁')
    (p : psquare f₁₀ f₁₂ f₀₁ f₂₁) : q⁻¹* ⬝ph* p = p ⬝* pwhisker_left f₁₂ q :=
  idp ◾** ap (pwhisker_left f₁₂) (symm_symm _)

  @[hott] def refl_phomotopy_hconcat (p : psquare f₁₀ f₁₂ f₀₁ f₂₁) : phomotopy.rfl ⬝ph* p = p :=
  idp ◾** (ap (pwhisker_left _) refl_symm ⬝ pwhisker_left_refl _ _) ⬝ trans_refl _

  local attribute [reducible] phomotopy.rfl
  @[hott] theorem pwhisker_left_phomotopy_hconcat {f₀₁'} (r : f₀₁' ~* f₀₁)
    (p : psquare f₁₀ f₁₂ f₀₁ f₂₁) (q : psquare f₁₂ f₁₄ f₀₃ f₂₃) :
    pwhisker_left f₀₃ r ⬝ph* (p ⬝v* q) = (r ⬝ph* p) ⬝v* q :=
  begin
    hinduction r using phomotopy_rec_idp,
    rwr [pwhisker_left_refl, refl_phomotopy_hconcat, refl_phomotopy_hconcat]
  end

  @[hott] theorem pvcompose_pwhisker_left {f₀₁'} (r : f₀₁ ~* f₀₁')
    (p : psquare f₁₀ f₁₂ f₀₁ f₂₁) (q : psquare f₁₂ f₁₄ f₀₃ f₂₃) :
    (p ⬝v* q) ⬝* (pwhisker_left f₁₄ (pwhisker_left f₀₃ r)) = (p ⬝* pwhisker_left f₁₂ r) ⬝v* q :=
  begin
    hinduction r using phomotopy_rec_idp, hsimp
  end
  -- by hinduction r using phomotopy_rec_idp; rwr [+pwhisker_left_refl, + trans_refl]

  @[hott] def phconcat2 {p p' : psquare f₁₀ f₁₂ f₀₁ f₂₁} {q q' : psquare f₃₀ f₃₂ f₂₁ f₄₁}
    (r : p = p') (s : q = q') : p ⬝h* q = p' ⬝h* q' :=
  ap011 phconcat r s

  @[hott] def pvconcat2 {p p' : psquare f₁₀ f₁₂ f₀₁ f₂₁} {q q' : psquare f₁₂ f₁₄ f₀₃ f₂₃}
    (r : p = p') (s : q = q') : p ⬝v* q = p' ⬝v* q' :=
  ap011 pvconcat r s

  @[hott] def phinverse2 {f₁₀ : A₀₀ ≃* A₂₀} {f₁₂ : A₀₂ ≃* A₂₂}
    {p p' : psquare f₁₀.to_pmap f₁₂.to_pmap f₀₁ f₂₁} (r : p = p') : p⁻¹ʰ* = p'⁻¹ʰ* :=
  ap phinverse r

  @[hott] def pvinverse2 {f₀₁ : A₀₀ ≃* A₀₂} {f₂₁ : A₂₀ ≃* A₂₂}
    {p p' : psquare f₁₀ f₁₂ f₀₁.to_pmap f₂₁.to_pmap} (r : p = p') : p⁻¹ᵛ* = p'⁻¹ᵛ* :=
  ap pvinverse r

  @[hott] def phomotopy_hconcat2 {q q' : f₀₁' ~* f₀₁} {p p' : psquare f₁₀ f₁₂ f₀₁ f₂₁}
    (r : q = q') (s : p = p') : q ⬝ph* p = q' ⬝ph* p' :=
  ap011 phomotopy_hconcat r s

  @[hott] def hconcat_phomotopy2 {p p' : psquare f₁₀ f₁₂ f₀₁ f₂₁} {q q' : f₂₁' ~* f₂₁}
    (r : p = p') (s : q = q') : p ⬝hp* q = p' ⬝hp* q' :=
  ap011 hconcat_phomotopy r s

  @[hott] def phomotopy_vconcat2 {q q' : f₁₀' ~* f₁₀} {p p' : psquare f₁₀ f₁₂ f₀₁ f₂₁}
    (r : q = q') (s : p = p') : q ⬝pv* p = q' ⬝pv* p' :=
  ap011 phomotopy_vconcat r s

  @[hott] def vconcat_phomotopy2 {p p' : psquare f₁₀ f₁₂ f₀₁ f₂₁} {q q' : f₁₂' ~* f₁₂}
    (r : p = p') (s : q = q') : p ⬝vp* q = p' ⬝vp* q' :=
  ap011 vconcat_phomotopy r s

  -- for consistency, should there be a second star here?
  infix ` ◾h* `:79 := phconcat2
  infix ` ◾v* `:79 := pvconcat2
  infixl ` ◾hp* `:79 := hconcat_phomotopy2
  infixr ` ◾ph* `:79 := phomotopy_hconcat2
  infixl ` ◾vp* `:79 := vconcat_phomotopy2
  infixr ` ◾pv* `:79 := phomotopy_vconcat2
  postfix `⁻²ʰ*`:(max+1) := phinverse2
  postfix `⁻²ᵛ*`:(max+1) := pvinverse2

  end psquare

  variables {X : Type*} {X' : Type*} {Y : Type*} {Y' : Type*} {Z : Type*}
  @[hott] def pap1 (X Y : Type*) : ppmap X Y →* ppmap (Ω X) (Ω Y) :=
  pmap.mk ap1 (eq_of_phomotopy (ap1_pconst _ _))

  @[hott] def ap1_gen_const {A B : Type _} {a₁ a₂ : A} (b : B) (p : a₁ = a₂) :
    ap1_gen (const A b) idp idp p = idp :=
  ap1_gen_idp_left (const A b) p ⬝ ap_constant p b

  @[hott] def ap1_gen_compose_const_left
    {A B C : Type _} (c : C) (f : A → B) {a₁ a₂ : A} (p : a₁ = a₂) :
    ap1_gen_compose (const B c) f idp idp idp idp p ⬝
    ap1_gen_const c (ap1_gen f idp idp p) =
    ap1_gen_const c p :=
  begin induction p, refl end

  local attribute [reducible] ap1_gen
  @[hott] def ap1_gen_compose_const_right
    {A B C : Type _} (g : B → C) (b : B) {a₁ a₂ : A} (p : a₁ = a₂) :
    ap1_gen_compose g (const A b) idp idp idp idp p ⬝
    begin
      change ap1_gen g idp idp (ap1_gen (const A b) idp idp p) = ap1_gen g idp idp idp,
      apply ap (ap1_gen g idp idp), exact (ap1_gen_const b p) end =
    ap1_gen_const (g b) p :=
  begin induction p, refl end

  @[hott] def ap1_pcompose_pconst_left {A B C : Type*} (f : A →* B) :
    phsquare (ap1_pcompose (pconst B C) f)
             (ap1_pconst A C)
             (ap1_phomotopy (pconst_pcompose f))
             (pwhisker_right (Ω→ f) (ap1_pconst B C) ⬝* pconst_pcompose (Ω→ f)) :=
  begin
    induction A with A a₀, induction B with B b₀, induction C with C c₀, induction f with f f₀,
    dsimp at *, induction f₀,
    refine idp ◾** trans_refl _ ⬝ _ ⬝ (refl_trans _)⁻¹ᵖ ⬝ (ap1_phomotopy_refl _)⁻¹ ◾** idp,
    fapply phomotopy_eq,
    { exact ap1_gen_compose_const_left c₀ f },
    { refl }
  end

  @[hott] def ap1_pcompose_pconst_right {A B C : Type*} (g : B →* C) :
    phsquare (ap1_pcompose g (pconst A B))
             (ap1_pconst A C)
             (ap1_phomotopy (pcompose_pconst g))
             (pwhisker_left (Ω→ g) (ap1_pconst A B) ⬝* pcompose_pconst (Ω→ g)) :=
  begin
    induction A with A a₀, induction B with B b₀, induction C with C c₀, induction g with g g₀,
    dsimp at *, induction g₀,
    refine idp ◾** trans_refl _ ⬝ _ ⬝ (refl_trans _)⁻¹ᵖ ⬝ (ap1_phomotopy_refl _)⁻¹ ◾** idp,
    fapply phomotopy_eq,
    { exact ap1_gen_compose_const_right g b₀ },
    { refl }
  end

  @[hott] def pap1_natural_left (f : X' →* X) :
    psquare (pap1 X Y) (pap1 X' Y) (ppcompose_right f) (ppcompose_right (Ω→ f)) :=
  begin
    fapply phomotopy_mk_ppmap,
    { intro g, exact (ap1_pcompose _ _)⁻¹* },
    { dsimp [ppcompose_right],
      refine idp ◾** (ap phomotopy_of_eq (ap1_eq_of_phomotopy _  ◾ idp ⬝
        (eq_of_phomotopy_trans _ _)⁻¹ᵖ) ⬝ (phomotopy_of_eq_of_phomotopy _))  ⬝ _,
      refine _ ⬝ (ap phomotopy_of_eq ((pcompose_right_eq_of_phomotopy _ _) ◾ idp ⬝
        (eq_of_phomotopy_trans _ _)⁻¹ᵖ) ⬝ (phomotopy_of_eq_of_phomotopy _))⁻¹ᵖ,
      apply symm_trans_eq_of_eq_trans, exact (ap1_pcompose_pconst_left f)⁻¹ᵖ }
  end

  @[hott] def pap1_natural_right (f : Y →* Y') :
    psquare (pap1 X Y) (pap1 X Y') (ppcompose_left f) (ppcompose_left (Ω→ f)) :=
  begin
    fapply phomotopy_mk_ppmap,
    { intro g, exact (ap1_pcompose _ _)⁻¹* },
    { dsimp [ppcompose_left, pap1],
      refine idp ◾** (ap phomotopy_of_eq (ap1_eq_of_phomotopy _  ◾ idp ⬝
        (eq_of_phomotopy_trans _ _)⁻¹ᵖ) ⬝ (phomotopy_of_eq_of_phomotopy _))  ⬝ _,
      refine _ ⬝ (ap phomotopy_of_eq ((pcompose_left_eq_of_phomotopy _ _) ◾ idp ⬝
        (eq_of_phomotopy_trans _ _)⁻¹ᵖ) ⬝ (phomotopy_of_eq_of_phomotopy _))⁻¹ᵖ,
      apply symm_trans_eq_of_eq_trans, exact (ap1_pcompose_pconst_right f)⁻¹ᵖ }
  end

  @[hott] def pequiv.sigma_char {A B : Type*} : (A ≃* B) ≃
    Σ(f : A →* B), (Σ(g : B →* A), f ∘* g ~* pid B) × (Σ(h : B →* A), h ∘* f ~* pid A) :=
  begin
    fapply equiv.MK,
    { intro f, exact ⟨f.to_pmap, (⟨pequiv.to_pinv1 f, pequiv.pright_inv f⟩,
                          ⟨pequiv.to_pinv2 f, pequiv.pleft_inv f⟩)⟩, },
    { intro f, exact pequiv.mk' f.1 f.2.1.1 f.2.2.1 f.2.1.2 f.2.2.2 },
    { intro f, induction f with f v, induction v with hl hr, induction hl, induction hr,
      refl },
    { intro f, induction f, refl }
  end

  @[hott] def is_contr_pright_inv (f : A ≃* B) : is_contr (Σ(g : B →* A), f.to_pmap ∘* g ~* pid B) :=
  begin
    apply is_trunc_equiv_closed -2
      (fiber.sigma_char _ _ ⬝e sigma_equiv_sigma_right (λg, pmap_eq_equiv _ _)),
    napply is_contr_fiber_of_is_equiv,
    exact pequiv.to_is_equiv (pequiv_ppcompose_left f)
  end

  @[hott] def is_contr_pleft_inv (f : A ≃* B) : is_contr (Σ(h : B →* A), h ∘* f.to_pmap ~* pid A) :=
  begin
    apply is_trunc_equiv_closed,
      { exact fiber.sigma_char _ _ ⬝e sigma_equiv_sigma_right (λg, pmap_eq_equiv _ _) },
    napply is_contr_fiber_of_is_equiv,
    exact pequiv.to_is_equiv (pequiv_ppcompose_right f)
  end

  @[hott] def pequiv_eq_equiv (f g : A ≃* B) : (f = g) ≃ f.to_pmap ~* g.to_pmap :=
  have Π(f : A →* B), is_prop ((Σ(g : B →* A), f ∘* g ~* pid B) × (Σ(h : B →* A), h ∘* f ~* pid A)),
  begin
    intro f, apply is_prop_of_imp_is_contr, intro v,
    let f' := pequiv.sigma_char⁻¹ᵉ.to_fun ⟨f, v⟩,
    napply prod.is_trunc_prod, exact is_contr_pright_inv f', exact is_contr_pleft_inv f'
  end,
  calc (f = g) ≃ (pequiv.sigma_char.to_fun f = pequiv.sigma_char.to_fun g)
                 : eq_equiv_fn_eq pequiv.sigma_char.to_fun f g
          ...  ≃ (f.to_pmap = g.to_pmap) : @subtype_eq_equiv _ _ this _ _
          ...  ≃ (f.to_pmap ~* g.to_pmap) : pmap_eq_equiv f.to_pmap g.to_pmap

  @[hott] def pequiv_eq {f g : A ≃* B} (H : f.to_pmap ~* g.to_pmap) : f = g :=
  (pequiv_eq_equiv f g)⁻¹ᵉ H

  open algebra
  -- @[hott] def pequiv_of_isomorphism_of_eq {G₁ G₂ : Group} (p : G₁ = G₂) :
  --   pequiv_of_isomorphism (isomorphism_of_eq p) = pequiv_of_eq (ap pType_of_Group p) :=
  -- begin
  --   induction p,
  --   apply pequiv_eq,
  --   fapply phomotopy.mk,
  --   { intro g, refl },
  --   { apply is_prop.elim }
  -- end

end pointed
end hott


/-
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
-/
import measure_theory.integral.lebesgue

/-!
# The Giry monad

Let X be a measurable space. The collection of all measures on X again
forms a measurable space. This construction forms a monad on
measurable spaces and measurable functions, called the Giry monad.

Note that most sources use the term "Giry monad" for the restriction
to *probability* measures. Here we include all measures on X.

See also `measure_theory/category/Meas.lean`, containing an upgrade of the type-level
monad to an honest monad of the functor `Measure : Meas ⥤ Meas`.

## References

* <https://ncatlab.org/nlab/show/Giry+monad>

## Tags

giry monad
-/

noncomputable theory
open_locale classical big_operators ennreal

open classical set filter

variables {α β γ δ ε : Type*}

namespace measure_theory

namespace measure

variables [measurable_space α] [measurable_space β]

/-- Measurability structure on `measure`: Measures are measurable w.r.t. all projections -/
instance : measurable_space (measure α) :=
⨆ (s : set α) (hs : measurable_set s), (borel ℝ≥0∞).comap (λμ, μ s)

lemma measurable_coe {s : set α} (hs : measurable_set s) : measurable (λμ : measure α, μ s) :=
measurable.of_comap_le $ le_supr_of_le s $ le_supr_of_le hs $ le_refl _

lemma measurable_of_measurable_coe (f : β → measure α)
  (h : ∀(s : set α) (hs : measurable_set s), measurable (λb, f b s)) :
  measurable f :=
measurable.of_le_map $ bsupr_le $ assume s hs, measurable_space.comap_le_iff_le_map.2 $
  by rw [measurable_space.map_comp]; exact h s hs

lemma measurable_measure {μ : α → measure β} :
  measurable μ ↔ ∀(s : set β) (hs : measurable_set s), measurable (λb, μ b s) :=
⟨λ hμ s hs, (measurable_coe hs).comp hμ, measurable_of_measurable_coe μ⟩

lemma measurable_map (f : α → β) (hf : measurable f) :
  measurable (λμ : measure α, map f μ) :=
measurable_of_measurable_coe _ $ assume s hs,
  suffices measurable (λ (μ : measure α), μ (f ⁻¹' s)),
    by simpa [map_apply, hs, hf],
  measurable_coe (hf hs)

lemma measurable_dirac :
  measurable (measure.dirac : α → measure α) :=
measurable_of_measurable_coe _ $ assume s hs,
  begin
    simp only [dirac_apply', hs],
    exact measurable_one.indicator hs
  end

lemma measurable_lintegral {f : α → ℝ≥0∞} (hf : measurable f) :
  measurable (λμ : measure α, ∫⁻ x, f x ∂μ) :=
begin
  simp only [lintegral_eq_supr_eapprox_lintegral, hf, simple_func.lintegral],
  refine measurable_supr (λ n, finset.measurable_sum _ (λ i _, _)),
  refine measurable.const_mul _ _,
  exact measurable_coe ((simple_func.eapprox f n).measurable_set_preimage _)
end

/-- Monadic join on `measure` in the category of measurable spaces and measurable
functions. -/
def join (m : measure (measure α)) : measure α :=
measure.of_measurable
  (λs hs, ∫⁻ μ, μ s ∂m)
  (by simp)
  begin
    assume f hf h,
    simp [measure_Union h hf],
    apply lintegral_tsum,
    assume i, exact measurable_coe (hf i)
  end

@[simp] lemma join_apply {m : measure (measure α)} :
  ∀{s : set α}, measurable_set s → join m s = ∫⁻ μ, μ s ∂m :=
measure.of_measurable_apply

@[simp] lemma join_zero : (0 : measure (measure α)).join = 0 :=
by { ext1 s hs, simp [hs] }

lemma measurable_join : measurable (join : measure (measure α) → measure α) :=
measurable_of_measurable_coe _ $ assume s hs,
  by simp only [join_apply hs]; exact measurable_lintegral (measurable_coe hs)

lemma lintegral_join {m : measure (measure α)} {f : α → ℝ≥0∞} (hf : measurable f) :
  ∫⁻ x, f x ∂(join m) = ∫⁻ μ, ∫⁻ x, f x ∂μ ∂m :=
begin
  rw [lintegral_eq_supr_eapprox_lintegral hf],
  have : ∀n x,
    join m (⇑(simple_func.eapprox (λ (a : α), f a) n) ⁻¹' {x}) =
      ∫⁻ μ, μ ((⇑(simple_func.eapprox (λ (a : α), f a) n) ⁻¹' {x})) ∂m :=
    assume n x, join_apply (simple_func.measurable_set_preimage _ _),
  simp only [simple_func.lintegral, this],
  transitivity,
  have : ∀(s : ℕ → finset ℝ≥0∞) (f : ℕ → ℝ≥0∞ → measure α → ℝ≥0∞)
    (hf : ∀n r, measurable (f n r)) (hm : monotone (λn μ, ∑ r in s n, r * f n r μ)),
    (⨆n:ℕ, ∑ r in s n, r * ∫⁻ μ, f n r μ ∂m) =
    ∫⁻ μ, ⨆n:ℕ, ∑ r in s n, r * f n r μ ∂m,
  { assume s f hf hm,
    symmetry,
    transitivity,
    apply lintegral_supr,
    { assume n,
      exact finset.measurable_sum _ (assume r _, (hf _ _).const_mul _) },
    { exact hm },
    congr, funext n,
    transitivity,
    apply lintegral_finset_sum,
    { assume r _, exact (hf _ _).const_mul _ },
    congr, funext r,
    apply lintegral_const_mul,
    exact hf _ _ },
  specialize this (λn, simple_func.range (simple_func.eapprox f n)),
  specialize this
    (λn r μ, μ (⇑(simple_func.eapprox (λ (a : α), f a) n) ⁻¹' {r})),
  refine this _ _; clear this,
  { assume n r,
    apply measurable_coe,
    exact simple_func.measurable_set_preimage _ _ },
  { change monotone (λn μ, (simple_func.eapprox f n).lintegral μ),
    assume n m h μ,
    refine simple_func.lintegral_mono _ (le_refl _),
    apply simple_func.monotone_eapprox,
    assumption },
  congr, funext μ,
  symmetry,
  apply lintegral_eq_supr_eapprox_lintegral,
  exact hf
end

/-- Monadic bind on `measure`, only works in the category of measurable spaces and measurable
functions. When the function `f` is not measurable the result is not well defined. -/
def bind (m : measure α) (f : α → measure β) : measure β := join (map f m)

@[simp] lemma bind_zero_left (f : α → measure β) : bind 0 f = 0 :=
by simp [bind]

@[simp] lemma bind_zero_right (m : measure α) :
  bind m (0 : α → measure β) = 0 :=
begin
  ext1 s hs,
  simp only [bind, hs, join_apply, coe_zero, pi.zero_apply],
  rw [lintegral_map (measurable_coe hs) measurable_zero],
  simp
end

@[simp] lemma bind_zero_right' (m : measure α) :
  bind m (λ _, 0 : α → measure β) = 0 :=
bind_zero_right m

@[simp] lemma bind_apply {m : measure α} {f : α → measure β} {s : set β}
  (hs : measurable_set s) (hf : measurable f) :
  bind m f s = ∫⁻ a, f a s ∂m :=
by rw [bind, join_apply hs, lintegral_map (measurable_coe hs) hf]

lemma measurable_bind' {g : α → measure β} (hg : measurable g) : measurable (λm, bind m g) :=
measurable_join.comp (measurable_map _ hg)

lemma lintegral_bind {m : measure α} {μ : α → measure β} {f : β → ℝ≥0∞}
  (hμ : measurable μ) (hf : measurable f) :
  ∫⁻ x, f x ∂ (bind m μ) = ∫⁻ a, ∫⁻ x, f x ∂(μ a) ∂m:=
(lintegral_join hf).trans (lintegral_map (measurable_lintegral hf) hμ)

lemma bind_bind {γ} [measurable_space γ] {m : measure α} {f : α → measure β} {g : β → measure γ}
  (hf : measurable f) (hg : measurable g) :
  bind (bind m f) g = bind m (λa, bind (f a) g) :=
measure.ext $ assume s hs,
begin
  rw [bind_apply hs hg, bind_apply hs ((measurable_bind' hg).comp hf), lintegral_bind hf],
  { congr, funext a,
    exact (bind_apply hs hg).symm },
  exact (measurable_coe hs).comp hg
end

lemma bind_dirac {f : α → measure β} (hf : measurable f) (a : α) : bind (dirac a) f = f a :=
measure.ext $ λ s hs, by rw [bind_apply hs hf, lintegral_dirac' a ((measurable_coe hs).comp hf)]

lemma dirac_bind {m : measure α} : bind m dirac = m :=
measure.ext $ assume s hs,
by simp [bind_apply hs measurable_dirac, dirac_apply' _ hs, lintegral_indicator 1 hs]

lemma join_eq_bind (μ : measure (measure α)) : join μ = bind μ id :=
by rw [bind, map_id]

lemma join_map_map {f : α → β} (hf : measurable f) (μ : measure (measure α)) :
  join (map (map f) μ) = map f (join μ) :=
measure.ext $ assume s hs,
  begin
    rw [join_apply hs, map_apply hf hs, join_apply,
      lintegral_map (measurable_coe hs) (measurable_map f hf)],
    { congr, funext ν, exact map_apply hf hs },
    exact hf hs
  end

lemma join_map_join (μ : measure (measure (measure α))) :
  join (map join μ) = join (join μ) :=
begin
  show bind μ join = join (join μ),
  rw [join_eq_bind, join_eq_bind, bind_bind measurable_id measurable_id],
  apply congr_arg (bind μ),
  funext ν,
  exact join_eq_bind ν
end

lemma join_map_dirac (μ : measure α) : join (map dirac μ) = μ :=
dirac_bind

lemma join_dirac (μ : measure α) : join (dirac μ) = μ :=
eq.trans (join_eq_bind (dirac μ)) (bind_dirac measurable_id _)

end measure

end measure_theory


/-
Copyright (c) 2022 James Gallicchio.

Authors: James Gallicchio
-/

import LeanColls.Classes
import LeanColls.List.Basic

open LeanColls

/-! ## Association Lists -/
def AList (κ τ) := List (κ × τ)

namespace AList

variable [DecidableEq κ]

def get? (k : κ) : AList κ τ → Option τ
| [] => none
| (k', t') :: as =>
  if k = k'
  then some t'
  else get? k as

instance : LeanColls.MapLike (AList κ τ) κ τ where
  fold l := l.foldl
  get? := get?

def update (k : κ) (t : Option τ) : AList κ τ → AList κ τ
| []  => match t with | none => [] | some t => [(k,t)]
| (k', t') :: as =>
  if k = k' then
    match t with
    | none => update k none as
    | some t => (k,t) :: as
  else
    (k', t') :: update k t as

def set (k : κ) (t : τ) (as : AList κ τ) := update k (some t) as

def remove (k : κ) (as : AList κ τ) := update k none as

def getAndUpdate (k : κ) (t : Option τ) : AList κ τ → Option τ × AList κ τ
| []  => match t with | none => (none, []) | some t => (none, [(k,t)])
| (k', t') :: as =>
  if k = k' then
    (t', match t with
    | none => update k none as
    | some t => (k,t) :: as)
  else
    let (old, as') := getAndUpdate k t as
    (old, (k', t') :: as')

def getAndSet (k : κ) (t : τ) (as : AList κ τ) := getAndUpdate k (some t) as

def getAndRemove (k : κ) (as : AList κ τ) := getAndUpdate k none as

@[simp]
theorem getAndUpdate_eq (k t) (as : AList κ τ)
  : getAndUpdate k t as = (get? k as, update k t as)
  := by
  induction as with
  | nil =>
    simp [getAndUpdate, get?, update]
    split <;> simp
  | cons hd tl ih =>
    simp [getAndUpdate, get?, update, ih]
    split <;> simp

@[simp]
theorem getAndSet_eq (k t) (as : AList κ τ)
  : getAndSet k t as = (get? k as, set k t as)
  := by simp [getAndSet, set]

@[simp]
theorem getAndRemove_eq (k) (as : AList κ τ)
  : getAndRemove k as = (get? k as, remove k as)
  := by simp [getAndRemove, remove]

@[simp]
theorem get?_update (k' k : κ) (t : Option τ) (as : AList κ τ)
  : get? k' (update k t as) = if k' = k then t else get? k' as
  := by
  induction as with
  | nil =>
    simp [update]
    split <;> simp [get?]
  | cons hd tl ih =>
    match hd with
    | (hd_k,hd_t) =>
    simp [update]
    split
    case inl h_hd =>
      cases h_hd
      split
      case h_2 =>
        split
        subst_vars; simp [get?]
        case inr h_k =>
        simp [h_k, get?]
      case h_1 =>
        split
        subst_vars; simp at ih; exact ih
        case inr h_k =>
        simp [h_k] at ih
        simp [get?, h_k, ih]
    case inr h_hd =>
      simp [get?]
      split
      case inl h_k' =>
        cases h_k'
        simp [Ne.symm h_hd]
      case inr =>
        assumption

@[simp]
theorem get?_set (k' k : κ) (t : τ) (as : AList κ τ)
  : get? k' (set k t as) = if k' = k then some t else get? k' as
  := by simp [set]

@[simp]
theorem get?_remove (k' k : κ) (as : AList κ τ)
  : get? k' (remove k as) = if k' = k then none else get? k' as
  := by simp [remove]

theorem length_remove (k : κ) (as : AList κ τ)
  : (remove k as).length ≤ as.length
  := by
  unfold remove
  induction as with
  | nil => simp [update]
  | cons hd tl ih =>
    simp [update]
    split
    apply Nat.le_step; assumption
    apply Nat.succ_le_succ; assumption

/-! Number of distinct keys in the map. Runtime is quadratic in the result;
this definition is used in LeanColls for expressing size invariants. -/
def size : AList κ τ → Nat
| [] => 0
| (k,_) :: as =>
  have := Nat.succ_le_succ <| length_remove k as
  1 + size (remove k as)
termination_by size as => as.length

theorem remove_update (k' k : κ) (t : Option τ) (as) (h_ks : k' ≠ k)
  : remove k' (update k t as) = update k t (remove k' as)
  := by
  induction as with
  | nil =>
    cases t <;> simp [update, remove, h_ks]
  | cons hd tl ih =>
    match hd with
    | (hd_k,hd_t) =>
    simp [update]
    split
    case inl h_k =>
      cases h_k
      cases t <;> simp [remove, update, h_ks]
      exact ih
    case inr h_k =>
      simp [remove, update]
      split
      case inl h_k' =>
        cases h_k'
        exact ih
      case inr h_k' =>
        simp [update, h_k]
        congr

theorem size_update (k t) (as : AList κ τ)
  : size (update k t as) + (if (get? k as).isSome then 1 else 0)
    = size as + (if t.isSome then 1 else 0)
  := by
  match as with
  | [] =>
    cases t <;> simp [update, size, remove, get?]
  | (hd_k,hd_t)::tl =>
    simp [update, get?]
    split
    case inl h_hd =>
      cases h_hd
      simp [size, remove]
      cases t
      simp [Nat.add_comm]
      simp [size, remove]
    case inr h_hd =>
    have :=
      have := Nat.succ_le_succ <| length_remove hd_k tl
      size_update k t (remove hd_k tl)
    simp [size]
    split
    case inl h_get =>
      simp [h_hd, h_get, update] at this
      rw [remove_update, Nat.add_assoc, this, Nat.add_assoc]
      exact Ne.symm h_hd
    case inr h_get =>
      simp [h_hd, h_get, set] at this
      rw [remove_update, this]
      simp [add_assoc]
      exact Ne.symm h_hd
termination_by size_update as => as.length

@[simp]
theorem size_set (k : κ) (t : τ) (as : AList κ τ)
  : size (set k t as) =
    if (get? k as).isSome then as.size else as.size + 1
  := by
  simp [set]
  have := size_update k (some t) as
  split
  case inl h_get =>
    simp [h_get] at this
    assumption
  case inr h_get =>
    simp [h_get] at this
    assumption

@[simp]
theorem size_remove (k : κ) (t : τ) (as : AList κ τ)
  : size (remove k as) + 1 =
    if (get? k as).isSome then as.size else as.size + 1
  := by
  simp [remove]
  have := size_update k none as
  split
  case inl h_get =>
    simp [h_get] at this
    assumption
  case inr h_get =>
    simp [h_get] at this
    rw [this]

theorem size_pos_of_get?_some (k : κ) (as : AList κ τ)
  : (get? k as).isSome → size as > 0
  := by
  intro h
  simp [Option.isSome] at h
  split at h <;> try contradiction
  clear h; rename get? _ _ = _ => h
  induction as with
  | nil => contradiction
  | cons hd tl ih =>
    cases hd
    simp [get?] at h
    split at h
    subst_vars; simp [size]
    apply Nat.le_add_right
    simp [size]
    apply Nat.le_add_right


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.limits.concrete_category
import group_theory.quotient_group
import category_theory.limits.shapes.kernels
import algebra.category.Module.basic

/-!
# The category of R-modules has all colimits.

This file uses a "pre-automated" approach, just as for `Mon/colimits.lean`.

Note that finite colimits can already be obtained from the instance `abelian (Module R)`.

TODO:
In fact, in `Module R` there is a much nicer model of colimits as quotients
of finitely supported functions, and we really should implement this as well (or instead).
-/

universes u v

open category_theory
open category_theory.limits

variables {R : Type v} [ring R]

-- [ROBOT VOICE]:
-- You should pretend for now that this file was automatically generated.
-- It follows the same template as colimits in Mon.

namespace Module.colimits
/-!
We build the colimit of a diagram in `Module` by constructing the
free group on the disjoint union of all the abelian groups in the diagram,
then taking the quotient by the abelian group laws within each abelian group,
and the identifications given by the morphisms in the diagram.
-/

variables {J : Type v} [small_category J] (F : J ⥤ Module.{v} R)

/--
An inductive type representing all module expressions (without relations)
on a collection of types indexed by the objects of `J`.
-/
inductive prequotient
-- There's always `of`
| of : Π (j : J) (x : F.obj j), prequotient
-- Then one generator for each operation
| zero : prequotient
| neg : prequotient → prequotient
| add : prequotient → prequotient → prequotient
| smul : R → prequotient → prequotient

instance : inhabited (prequotient F) := ⟨prequotient.zero⟩

open prequotient

/--
The relation on `prequotient` saying when two expressions are equal
because of the module laws, or
because one element is mapped to another by a morphism in the diagram.
-/
inductive relation : prequotient F → prequotient F → Prop
-- Make it an equivalence relation:
| refl : Π (x), relation x x
| symm : Π (x y) (h : relation x y), relation y x
| trans : Π (x y z) (h : relation x y) (k : relation y z), relation x z
-- There's always a `map` relation
| map : Π (j j' : J) (f : j ⟶ j') (x : F.obj j), relation (of j' (F.map f x)) (of j x)
-- Then one relation per operation, describing the interaction with `of`
| zero : Π (j), relation (of j 0) zero
| neg : Π (j) (x : F.obj j), relation (of j (-x)) (neg (of j x))
| add : Π (j) (x y : F.obj j), relation (of j (x + y)) (add (of j x) (of j y))
| smul : Π (j) (s) (x : F.obj j), relation (of j (s • x)) (smul s (of j x))
-- Then one relation per argument of each operation
| neg_1 : Π (x x') (r : relation x x'), relation (neg x) (neg x')
| add_1 : Π (x x' y) (r : relation x x'), relation (add x y) (add x' y)
| add_2 : Π (x y y') (r : relation y y'), relation (add x y) (add x y')
| smul_1 : Π (s) (x x') (r : relation x x'), relation (smul s x) (smul s x')
-- And one relation per axiom
| zero_add      : Π (x), relation (add zero x) x
| add_zero      : Π (x), relation (add x zero) x
| add_left_neg  : Π (x), relation (add (neg x) x) zero
| add_comm      : Π (x y), relation (add x y) (add y x)
| add_assoc     : Π (x y z), relation (add (add x y) z) (add x (add y z))
| one_smul      : Π (x), relation (smul 1 x) x
| mul_smul      : Π (s t) (x), relation (smul (s * t) x) (smul s (smul t x))
| smul_add      : Π (s) (x y), relation (smul s (add x y)) (add (smul s x) (smul s y))
| smul_zero     : Π (s), relation (smul s zero) zero
| add_smul      : Π (s t) (x), relation (smul (s + t) x) (add (smul s x) (smul t x))
| zero_smul     : Π (x), relation (smul 0 x) zero

/--
The setoid corresponding to module expressions modulo module relations and identifications.
-/
def colimit_setoid : setoid (prequotient F) :=
{ r := relation F, iseqv := ⟨relation.refl, relation.symm, relation.trans⟩ }
attribute [instance] colimit_setoid

/--
The underlying type of the colimit of a diagram in `Module R`.
-/
@[derive inhabited]
def colimit_type : Type v := quotient (colimit_setoid F)

instance : add_comm_group (colimit_type F) :=
{ zero :=
  begin
    exact quot.mk _ zero
  end,
  neg :=
  begin
    fapply @quot.lift,
    { intro x,
      exact quot.mk _ (neg x) },
    { intros x x' r,
      apply quot.sound,
      exact relation.neg_1 _ _ r },
  end,
  add :=
  begin
    fapply @quot.lift _ _ ((colimit_type F) → (colimit_type F)),
    { intro x,
      fapply @quot.lift,
      { intro y,
        exact quot.mk _ (add x y) },
      { intros y y' r,
        apply quot.sound,
        exact relation.add_2 _ _ _ r } },
    { intros x x' r,
      funext y,
      induction y,
      dsimp,
      apply quot.sound,
      { exact relation.add_1 _ _ _ r },
      { refl } },
  end,
  zero_add := λ x,
  begin
    induction x,
    dsimp,
    apply quot.sound,
    apply relation.zero_add,
    refl,
  end,
  add_zero := λ x,
  begin
    induction x,
    dsimp,
    apply quot.sound,
    apply relation.add_zero,
    refl,
  end,
  add_left_neg := λ x,
  begin
    induction x,
    dsimp,
    apply quot.sound,
    apply relation.add_left_neg,
    refl,
  end,
  add_comm := λ x y,
  begin
    induction x,
    induction y,
    dsimp,
    apply quot.sound,
    apply relation.add_comm,
    refl,
    refl,
  end,
  add_assoc := λ x y z,
  begin
    induction x,
    induction y,
    induction z,
    dsimp,
    apply quot.sound,
    apply relation.add_assoc,
    refl,
    refl,
    refl,
  end, }

instance : module R (colimit_type F) :=
{ smul := λ s,
  begin
    fapply @quot.lift,
    { intro x,
      exact quot.mk _ (smul s x) },
    { intros x x' r,
      apply quot.sound,
      exact relation.smul_1 s _ _ r },
  end,
  one_smul := λ x,
  begin
    induction x,
    dsimp,
    apply quot.sound,
    apply relation.one_smul,
    refl,
  end,
  mul_smul := λ s t x,
  begin
    induction x,
    dsimp,
    apply quot.sound,
    apply relation.mul_smul,
    refl,
  end,
  smul_add := λ s x y,
  begin
    induction x,
    induction y,
    dsimp,
    apply quot.sound,
    apply relation.smul_add,
    refl,
    refl,
  end,
  smul_zero := λ s, begin apply quot.sound, apply relation.smul_zero, end,
  add_smul := λ s t x,
  begin
    induction x,
    dsimp,
    apply quot.sound,
    apply relation.add_smul,
    refl,
  end,
  zero_smul := λ x,
  begin
    induction x,
    dsimp,
    apply quot.sound,
    apply relation.zero_smul,
    refl,
  end, }

@[simp] lemma quot_zero : quot.mk setoid.r zero = (0 : colimit_type F) := rfl
@[simp] lemma quot_neg (x) :
  quot.mk setoid.r (neg x) = (-(quot.mk setoid.r x) : colimit_type F) := rfl
@[simp] lemma quot_add (x y) :
  quot.mk setoid.r (add x y) = ((quot.mk setoid.r x) + (quot.mk setoid.r y) : colimit_type F) := rfl
@[simp] lemma quot_smul (s x) :
  quot.mk setoid.r (smul s x) = (s • (quot.mk setoid.r x) : colimit_type F) := rfl

/-- The bundled module giving the colimit of a diagram. -/
def colimit : Module R := Module.of R (colimit_type F)

/-- The function from a given module in the diagram to the colimit module. -/
def cocone_fun (j : J) (x : F.obj j) : colimit_type F :=
quot.mk _ (of j x)

/-- The group homomorphism from a given module in the diagram to the colimit module. -/
def cocone_morphism (j : J) : F.obj j ⟶ colimit F :=
{ to_fun := cocone_fun F j,
  map_smul' := by { intros, apply quot.sound, apply relation.smul, },
  map_add' := by intros; apply quot.sound; apply relation.add }

@[simp] lemma cocone_naturality {j j' : J} (f : j ⟶ j') :
  F.map f ≫ (cocone_morphism F j') = cocone_morphism F j :=
begin
  ext,
  apply quot.sound,
  apply relation.map,
end

@[simp] lemma cocone_naturality_components (j j' : J) (f : j ⟶ j') (x : F.obj j):
  (cocone_morphism F j') (F.map f x) = (cocone_morphism F j) x :=
by { rw ←cocone_naturality F f, refl }

/-- The cocone over the proposed colimit module. -/
def colimit_cocone : cocone F :=
{ X := colimit F,
  ι :=
  { app := cocone_morphism F } }.

/-- The function from the free module on the diagram to the cone point of any other cocone. -/
@[simp] def desc_fun_lift (s : cocone F) : prequotient F → s.X
| (of j x)  := (s.ι.app j) x
| zero      := 0
| (neg x)   := -(desc_fun_lift x)
| (add x y) := desc_fun_lift x + desc_fun_lift y
| (smul s x) := s • (desc_fun_lift x)

/-- The function from the colimit module to the cone point of any other cocone. -/
def desc_fun (s : cocone F) : colimit_type F → s.X :=
begin
  fapply quot.lift,
  { exact desc_fun_lift F s },
  { intros x y r,
    induction r; try { dsimp },
    -- refl
    { refl },
    -- symm
    { exact r_ih.symm },
    -- trans
    { exact eq.trans r_ih_h r_ih_k },
    -- map
    { simp, },
    -- zero
    { simp, },
    -- neg
    { simp, },
    -- add
    { simp, },
    -- smul,
    { simp, },
    -- neg_1
    { rw r_ih, },
    -- add_1
    { rw r_ih, },
    -- add_2
    { rw r_ih, },
    -- smul_1
    { rw r_ih, },
    -- zero_add
    { rw zero_add, },
    -- add_zero
    { rw add_zero, },
    -- add_left_neg
    { rw add_left_neg, },
    -- add_comm
    { rw add_comm, },
    -- add_assoc
    { rw add_assoc, },
    -- one_smul
    { rw one_smul, },
    -- mul_smul
    { rw mul_smul, },
    -- smul_add
    { rw smul_add, },
    -- smul_zero
    { rw smul_zero, },
    -- add_smul
    { rw add_smul, },
    -- zero_smul
    { rw zero_smul, }, }
end

/-- The group homomorphism from the colimit module to the cone point of any other cocone. -/
def desc_morphism (s : cocone F) : colimit F ⟶ s.X :=
{ to_fun := desc_fun F s,
  map_smul' := λ s x, by { induction x; refl, },
  map_add' := λ x y, by { induction x; induction y; refl }, }

/-- Evidence that the proposed colimit is the colimit. -/
def colimit_cocone_is_colimit : is_colimit (colimit_cocone F) :=
{ desc := λ s, desc_morphism F s,
  uniq' := λ s m w,
  begin
    ext,
    induction x,
    induction x,
    { have w' := congr_fun (congr_arg (λ f : F.obj x_j ⟶ s.X, (f : F.obj x_j → s.X)) (w x_j)) x_x,
      erw w',
      refl, },
    { simp *, },
    { simp *, },
    { simp *, },
    { simp *, },
    refl
  end }.

instance has_colimits_Module : has_colimits (Module R) :=
{ has_colimits_of_shape := λ J 𝒥, by exactI
  { has_colimit := λ F, has_colimit.mk
    { cocone := colimit_cocone F,
      is_colimit := colimit_cocone_is_colimit F } } }

end Module.colimits


import Structure.Generic.Axioms
import Structure.Generic.Instances.Bundled

set_option autoBoundImplicitLocal false
--set_option pp.universes true

universes u

def BundledSetoid := Bundled Setoid
@[reducible] def setoid : Universe := simpleBundledUniverse Setoid

namespace BundledSetoid

  instance isSetoid (S : setoid) : Setoid ⌈S⌉ := S.inst
  instance (S : setoid) : Setoid ⌈S⌉ := isSetoid S

  class IsFunctorial {S T : setoid} (f : S → T) : Type u where
  (mapEquiv {a b : S} : a ≈ b → f a ≈ f b)

  instance hasFunctoriality : Bundled.HasFunctoriality Setoid Setoid := ⟨IsFunctorial⟩

  namespace BundledFunctor

    theorem congrArg {S T : setoid} (F : S ⟶' T) {a b : S} : a ≈ b → F a ≈ F b := F.isFun.mapEquiv

    def Equiv {S T : setoid} (F G : S ⟶' T) := ∀ a, F a ≈ G a

    namespace Equiv

      variable {S T : setoid}

      theorem refl  (F     : S ⟶' T)                                 : Equiv F F := λ a => Setoid.refl  (F a)
      theorem symm  {F G   : S ⟶' T} (h : Equiv F G)                 : Equiv G F := λ a => Setoid.symm  (h a)
      theorem trans {F G H : S ⟶' T} (h : Equiv F G) (i : Equiv G H) : Equiv F H := λ a => Setoid.trans (h a) (i a)

      def isEquivalence : Equivalence (@Equiv S T) := ⟨refl, symm, trans⟩

    end Equiv

    instance isSetoid (S T : setoid) : Setoid (S ⟶' T) := ⟨Equiv, Equiv.isEquivalence⟩

    theorem congrFun {S T : setoid} {F G : S ⟶' T} (h : F ≈ G) (a : S) : F a ≈ G a := h a

    theorem congr {S T : setoid} {F G : S ⟶' T} {a b : S} : F ≈ G → a ≈ b → F a ≈ G b :=
    λ h₁ h₂ => Setoid.trans (congrFun h₁ a) (congrArg G h₂)

    instance hasFunctorInstances : Bundled.HasFunctorInstances Setoid := ⟨isSetoid⟩

  end BundledFunctor

  -- Although this duplicates generic proofs in `ConstructibleFunctors.lean`, we keep this version because
  -- it is much more readable and we can avoid the import.
  instance hasIdFun    : HasIdFun    setoid                             :=
  ⟨λ S           => ⟨id⟩⟩
  instance hasConstFun : HasConstFun setoid setoid               :=
  ⟨λ S {T}   c   => ⟨λ _ => Setoid.refl c⟩⟩
  instance hasCompFun  : HasCompFun  setoid setoid setoid :=
  ⟨λ {S T U} F G => ⟨BundledFunctor.congrArg G ∘ BundledFunctor.congrArg F⟩⟩

  -- Same.
  instance hasFunOp : HasFunOp setoid :=
  { constFunIsFun   := λ S T       => ⟨λ hc a   => hc⟩,
    appIsFun        := λ {S} a T   => ⟨λ hF     => BundledFunctor.congrFun hF a⟩,
    appFunIsFun     := λ S T       => ⟨λ ha F   => BundledFunctor.congrArg F ha⟩,
    dupIsFun        := λ {S T} F   => ⟨λ ha     => BundledFunctor.congr (BundledFunctor.congrArg F ha) ha⟩,
    dupFunIsFun     := λ S T       => ⟨λ hF a   => BundledFunctor.congrFun (BundledFunctor.congrFun hF a) a⟩,
    compFunIsFun    := λ {S T} F U => ⟨λ hG a   => BundledFunctor.congrFun hG (F a)⟩,
    compFunFunIsFun := λ S T U     => ⟨λ hF G a => BundledFunctor.congrArg G (BundledFunctor.congrFun hF a)⟩ }

  instance hasInstanceEquivalences : HasInstanceEquivalences setoid :=
  ⟨prop, λ S => (isSetoid S).r⟩

  instance hasEquivCongr : HasEquivCongr setoid :=
  { equivCongrArg := λ F => sort.toBundledFunctor (BundledFunctor.congrArg F),
    equivCongrFun := λ a => sort.toBundledFunctor (λ h => BundledFunctor.congrFun h a) }

  instance hasNaturalEquivalences : HasNaturalEquivalences setoid :=
  { equivHasInstEquivs := unit.hasUnitInstanceEquivalences prop,
    isNat              := λ _ _ _ _ => trivial }

  def eq (α : Sort u) : BundledSetoid :=
  { α    := α,
    inst := ⟨Eq, Eq.isEquivalence⟩ }

end BundledSetoid


import data.real.basic

lemma sub_sq_le_abs_sq_sub (u w : ℝ) (h : 0 ≤ u ↔ 0 ≤ w) : (u - w)^2 ≤ | u^2 - w^2| :=
begin
  rw sub_sq,
  by_cases diff : (w^2 ≤ u^2),
  by_cases sign : (0 ≤ u),
  have hw : 0 ≤ w := h.1 sign,
  rw sub_add,
  apply sub_le_sub (le_refl (u^2)) _,
  rw le_sub_iff_add_le,
  rw ← mul_two,
  rw mul_comm,
  rw sq,
  rw mul_assoc,
  apply mul_le_mul_of_nonneg_left,
  rw [le_sub, sub_zero] at diff,
  have := abs_le_abs_of_sq_le_sq diff,
  rw abs_of_nonneg hw at this,
  rw abs_of_nonneg sign at this,
  exact (mul_le_mul this (le_refl w)) hw sign,
  simp only [zero_le_one, zero_le_bit0],
  have hw : w < 0 := by {rw h at sign, exact not_le.1 sign},
  rw not_le at sign

  sorry,
  simp only [zero_le_one, zero_le_bit0],
  sorry,
end


import computability.primrec
import computability.partrec
import computability.partrec_code
import computability.halting
import data.pfun
import tactic
import lib

open encodable denumerable part

namespace nat

inductive rpartrec (o : ℕ →. ℕ) : (ℕ →. ℕ) → Prop
| oracle : rpartrec o
| zero : rpartrec (pure 0)
| succ : rpartrec succ
| left : rpartrec ↑(λ n : ℕ, n.unpair.1)
| right : rpartrec ↑(λ n : ℕ, n.unpair.2)
| pair {f g} : rpartrec f → rpartrec g → rpartrec (λ n, mkpair <$> f n <*> g n)
| comp {f g} : rpartrec f → rpartrec g → rpartrec (λ n, g n >>= f)
| prec {f g} : rpartrec f → rpartrec g → rpartrec (unpaired (λ a n,
    n.elim (f a) (λ y IH, do i ← IH, g (mkpair a (mkpair y i)))))
| rfind {f} : rpartrec f → rpartrec (λ a, rfind (λ n, (λ m, m = 0) <$> f (mkpair a n)))

namespace rpartrec

def reducible (f g) : Prop := rpartrec g f
local infix ` partrec_in `:80 := reducible

theorem of_eq {o f g : ℕ →. ℕ} (hf : rpartrec o f) (H : ∀ n, f n = g n) : rpartrec o g :=
(funext H : f = g) ▸ hf

theorem of_partrec {f} (g) (hf : nat.partrec f) : f partrec_in g :=
begin
  induction hf,
  case nat.partrec.zero { exact zero },
  case nat.partrec.succ { exact succ },
  case nat.partrec.left { exact left },
  case nat.partrec.right { exact right },
  case nat.partrec.pair : f g hf hg pf pg { exact pair pf pg },
  case nat.partrec.comp : f g hf hg pf pg { exact comp pf pg },
  case nat.partrec.prec : f g hf hg pf pg { exact prec pf pg },
  case nat.partrec.rfind : f pf hf { exact rfind hf },
end

theorem of_primrec {f} (g) (hf : primrec f) : f partrec_in g :=
of_partrec g (partrec.of_primrec hf)

theorem le_part_part {f g : ℕ →. ℕ} : g partrec_in f → nat.partrec f → nat.partrec g :=
begin
  assume rgf pf,
  induction rgf,
  case oracle { exact pf },
  case zero { exact nat.partrec.zero },
  case succ { exact nat.partrec.succ },
  case left { exact nat.partrec.left },
  case right { exact nat.partrec.right },
  case pair : f g hf hg pf pg { exact nat.partrec.pair pf pg },
  case comp : f g hf hg pf pg { exact nat.partrec.comp pf pg },
  case prec : f g hf hg pf pg { exact nat.partrec.prec pf pg },
  case rfind : f pf hf { exact nat.partrec.rfind hf },
end

protected theorem some {f} : part.some partrec_in f := of_primrec f primrec.id

theorem none {f} : (λ n, none) partrec_in f := of_partrec f partrec.none

theorem prec' {f g h o} (hf : f partrec_in o) (hg : g partrec_in o) (hh : h partrec_in o) :
  (λ a, (f a).bind (λ n, n.elim (g a) (λ y IH, do i ← IH, h (mkpair a (mkpair y i))))) partrec_in o :=
((prec hg hh).comp (pair rpartrec.some hf)).of_eq $ λ a, ext $ λ s, by simp [(<*>)]

theorem refl {f : ℕ →. ℕ} : f partrec_in f := oracle

theorem trans {f g h : ℕ →. ℕ} : f partrec_in g → g partrec_in h → f partrec_in h :=
begin
  assume pgf phg,
  induction pgf,
  case oracle { exact phg },
  case zero { exact zero },
  case succ { exact succ },
  case left { exact left },
  case right { exact right },
  case pair : _ _ _ _ pf pg { exact pair pf pg },
  case comp : _ _ _ _ pf pg { exact comp pf pg },
  case prec : _ _ _ _ pf pg { exact prec pf pg },
  case rfind : _ _ pf { exact rfind pf },
end

end rpartrec

end nat

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*} {σ : Type*} {τ : Type*} {μ : Type*}
variables [primcodable α] [primcodable β] [primcodable γ] [primcodable δ] [primcodable σ] [primcodable τ] [primcodable μ]

def rpartrec (f : α →. σ) (g : β →. τ) := nat.rpartrec.reducible
(λ n, part.bind (decode α n) (λ a, (f a).map encode))
(λ n, part.bind (decode β n) (λ a, (g a).map encode))

infix ` partrec_in `:80 := rpartrec

def rpartrec_tot (f : α →. σ) (g : β → τ) := f partrec_in ↑ᵣg

infix ` partrec_in! `:80 := rpartrec_tot

def rpartrec₂ (f : α → β →. σ) (g : γ →. τ) := (λ x : α × β, f x.1 x.2) partrec_in g

infix ` partrec₂_in `:80 := rpartrec₂

def rpartrec₂_tot (f : α → β →. σ) (g : γ → τ) := f partrec₂_in ↑ᵣg

infix ` partrec₂_in! `:80 := rpartrec₂_tot

def rcomputable (f : α → σ) (g : β →. τ) := ↑ᵣf partrec_in g

infix ` computable_in `:80 := rcomputable

def rcomputable_tot (f : α → σ) (g : β → τ) := f computable_in ↑ᵣg

infix ` computable_in! `:80 := rcomputable_tot

def rcomputable₂ (f : α → β → σ) (g : γ →. τ) := (λ x : α × β, f x.1 x.2) computable_in g

infix ` computable₂_in `:80 := rcomputable₂

def rcomputable₂_tot (f : α → β → σ) (g : γ → τ) := f computable₂_in ↑ᵣg

infix ` computable₂_in! `:80 := rcomputable₂_tot

theorem partrec.to_rpart {f : α →. σ} {g : β →. τ} (h : partrec f) : f partrec_in g :=
nat.rpartrec.of_partrec _ h

theorem partrec.to_rpart_in {f : α →. σ} (g : β →. τ) (h : partrec f) : f partrec_in g :=
nat.rpartrec.of_partrec _ h

theorem partrec₂.to_rpart {f : α → β →. σ} {g : γ →. τ} (h : partrec₂ f) : f partrec₂_in g :=
nat.rpartrec.of_partrec _ h

theorem partrec₂.to_rpart_in {f : α → β →. σ} (g : γ →. τ) (h : partrec₂ f) : f partrec₂_in g :=
nat.rpartrec.of_partrec _ h

theorem computable.to_rcomp {f : α → σ} {g : β →. τ} (h : computable f) : f computable_in g :=
nat.rpartrec.of_partrec _ h

theorem computable.to_rcomp_in {f : α → σ} (g : β →. τ) (h : computable f) : f computable_in g :=
nat.rpartrec.of_partrec _ h

theorem computable₂.to_rcomp {f : α → β → σ} {g : γ →. τ} (h : computable₂ f) : f computable₂_in g :=
nat.rpartrec.of_partrec _ h

theorem computable₂.to_rcomp_in {f : α → β → σ} (g : γ →. τ) (h : computable₂ f) : f computable₂_in g :=
nat.rpartrec.of_partrec _ h

theorem primrec.to_rcomp {f : α → σ} {g : β →. τ} (h : primrec f) : f computable_in g :=
h.to_comp.to_rcomp

theorem primrec.to_rcomp_in {f : α → σ} (g : β →. τ) (h : primrec f) : f computable_in g :=
h.to_comp.to_rcomp

theorem primrec₂.to_rcomp {f : α → β → σ} {g : γ →. τ} (h : primrec₂ f) : f computable₂_in g :=
h.to_comp.to_rcomp

theorem primrec₂.to_rcomp_in {f : α → β → σ} (g : γ →. τ) (h : primrec₂ f) : f computable₂_in g :=
h.to_comp.to_rcomp

namespace rpartrec

theorem of_eq {f g : α →. σ} {h : β →. τ} (hf : f partrec_in h) (H : ∀ n, f n = g n) : g partrec_in h :=
(funext H : f = g) ▸ hf

theorem comp {f : β →. γ} {g : α → β} {h : σ →. τ}
  (hf : f partrec_in h) (hg : g computable_in h) : (λ a, f (g a)) partrec_in h :=
(nat.rpartrec.comp hf hg).of_eq $ λ n, by simp; cases e : decode α n with a; simp [e, encodek]

theorem comp₂ {f : γ →. γ} {g : α → β → γ} {h : σ →. τ}
  (hf : f partrec_in h) (hg : g computable₂_in h) : (λ a b, f (g a b)) partrec₂_in h :=
hf.comp hg

@[protected] lemma coe {o : σ →. τ} :
  (coe : option α →. α) partrec_in o := computable.id.of_option.to_rpart

@[protected] lemma some {o : σ →. τ} :
  (part.some : α →. α) partrec_in o := partrec.some.to_rpart

theorem nat_elim {f : α → ℕ} {g : α →. σ} {h : α × ℕ × σ →. σ} {i : β →. γ}
  (hf : (f : α →. ℕ) partrec_in i) (hg : g partrec_in i) (hh : h partrec_in i) :
  (λ a, (f a).elim (g a) (λ y IH, IH.bind (λ i, h (a, y, i)))) partrec_in i :=
(nat.rpartrec.prec' hf hg hh).of_eq $ λ n, begin
  cases e : decode α n with a; simp [e],
  induction f a with m IH; simp,
  rw [IH, bind_map],
  congr, funext s,
  simp [encodek]
end

@[refl] theorem refl {f : α →. β} : f partrec_in f := nat.rpartrec.refl
theorem refl_in (f : α →. β) : f partrec_in f := nat.rpartrec.refl

@[trans] theorem trans {f : α →. σ} {g : β →. τ} {h : γ →. μ} : f partrec_in g → g partrec_in h → f partrec_in h :=
nat.rpartrec.trans

@[trans] theorem trans₂ {f : α →. σ} {g : β → γ →. τ} {h : δ →. μ} :
 f partrec_in (prod.unpaired g) → g partrec₂_in h → f partrec_in h :=
nat.rpartrec.trans

theorem nat_iff {f g} : f partrec_in g ↔ nat.rpartrec.reducible f g  :=
by simp[rpartrec, encodable.encode, map]

theorem nat_iff1 {f g} : f partrec_in g ↔ nat.rpartrec g f  :=
by simp[rpartrec, nat.rpartrec.reducible, encodable.encode, map]

theorem le_part_part {f : α →. σ} {g : β →. τ} : g partrec_in f → partrec f → partrec g :=
nat.rpartrec.le_part_part

theorem none {f : β →. τ} : (λ x, part.none : α →. σ) partrec_in f := partrec.none.to_rpart

theorem bind {f : α →. β} {g : α → β →. σ} {h : γ →. τ}
  (hf : f partrec_in h) (hg : g partrec₂_in h) : (λ a, (f a).bind (g a)) partrec_in h :=
(nat.rpartrec.comp hg (nat.rpartrec.some.pair hf)).of_eq $
λ n, by simp[(<*>)]; cases e : decode α n with a;
  simp [e, encodek]

theorem map {f : α →. β} {g : α → β → σ} {h : γ →. τ}
  (hf : f partrec_in h) (hg : g computable₂_in h) :
  (λ a, (f a).map (g a)) partrec_in h :=
by simpa [bind_some_eq_map]
  using @rpartrec.bind _ _ _ _ _ _ _ _ _ _ _ (λ x y, part.some (g x y)) _ hf hg

theorem rfind {p : α → ℕ →. bool} {f : β →. σ} (hp : p partrec₂_in f) :
  (λ a, nat.rfind (p a)) partrec_in f :=
  have c₀ : (λ x, (p x.1 x.2).map (λ b, cond b 0 1) : α × ℕ →. ℕ) partrec_in f :=
    hp.map ((
      (primrec.dom_bool (λ b, cond b 0 1)).comp primrec.snd).to_comp.to_rpart),
((nat.rpartrec.rfind c₀).of_eq $ λ n, by
{ cases e : decode α n with a;
  simp [e, nat.rfind_zero_none, map_id'],
  congr, funext n,
  simp [part.map_map, (∘)],
  apply map_id' (λ b, _),
  cases b; refl })

theorem rfind_refl {p : α → ℕ →. bool} : (λ a, nat.rfind (p a)) partrec_in prod.unpaired p :=
  have c₀ : (λ x : α × ℕ, (p x.1 x.2).map (λ b, cond b 0 1) : α × ℕ →. ℕ) partrec_in prod.unpaired p :=
    rpartrec.refl.map ((
      (primrec.dom_bool (λ b, cond b 0 1)).comp primrec.snd).to_comp.to_rpart),
((nat.rpartrec.rfind c₀).of_eq $ λ n, by
{ cases e : decode α n with a;
  simp [e, nat.rfind_zero_none, map_id'],
  congr, funext n,
  simp [part.map_map, (∘)],
  apply map_id' (λ b, _),
  cases b; refl })

theorem of_option_refl {f : α → option β} : ↑ʳf partrec_in! f :=
((nat.rpartrec.of_partrec _ nat.partrec.ppred).comp nat.rpartrec.oracle).of_eq $ λ n, begin
  cases decode α n with a; simp,
  cases f a with b; simp,
end

theorem of_option {f : α → option σ} {g : β →. τ}
  (h : f computable_in g) : ↑ʳf partrec_in g :=
of_option_refl.trans h

theorem of_option' {f : α → σ} {g : β →. τ}
  (h : f computable_in g) : (λ x, part.some (f x)) partrec_in g :=
rpartrec.some.comp h

theorem to₂ {f : α × β →. σ} {g : γ →. τ} (hf : f partrec_in g) : (λ a b, f (a, b)) partrec₂_in g :=
hf.of_eq $ λ ⟨a, b⟩, rfl

end rpartrec

namespace rcomputable

theorem of_eq {f g : α → σ} {h : β →. τ} (hf : f computable_in h) (H : ∀ n, f n = g n) :
  g computable_in h := (funext H : f = g) ▸ hf

theorem le_comp_comp {f : α → σ} {g : β → τ} :
  g computable_in! f → computable f → computable g :=
nat.rpartrec.le_part_part

theorem comp {f : β → γ} {g : α → β} {h : σ →. τ}
  (hf : f computable_in h) (hg : g computable_in h) : (λ a, f (g a)) computable_in h :=
(nat.rpartrec.comp hf hg).of_eq $ λ n, by simp; cases e : decode α n with a; simp [e, encodek]

theorem comp₂ {f : γ → σ} {g : α → β → γ} {o : τ →. μ}
  (hf : f computable_in o) (hg : g computable₂_in o) :
  (λ a b, f (g a b)) computable₂_in o := hf.comp hg

@[trans] theorem trans {f : α → σ} {g : β → τ} {h : γ → μ} : f computable_in! g → g computable_in! h → f computable_in! h :=
nat.rpartrec.trans

@[trans] theorem trans₂ {f : α → σ} {g : β → γ → τ} {h : δ →. μ} :
  f computable_in! (prod.unpaired g) → g computable₂_in h → f computable_in h :=
nat.rpartrec.trans

theorem nat_elim
  {f : α → ℕ} {g : α → σ} {h : α × ℕ × σ → σ} {o : β →. γ}
  (hf : f computable_in o) (hg : g computable_in o) (hh : h computable_in o) :
  (λ a, (f a).elim (g a) (λ y IH, h (a, y, IH))) computable_in o :=
((rpartrec.nat_elim hf hg hh).of_eq) $
λ a, by { simp, induction f a with m, simp, simp[ih] }

theorem nat_elim'
  {f : α → ℕ} {g : α → σ} {h : α → ℕ → σ → σ} {o : β →. γ}
  (hf : f computable_in o) (hg : g computable_in o) (hh : prod.unpaired3 h computable_in o) :
  (λ a, (f a).elim (g a) (h a)) computable_in o :=
((rpartrec.nat_elim hf hg hh).of_eq) $
λ a, by { simp, induction f a with m, simp, simp[ih] }

theorem id {f : β →. σ} : (@id α) computable_in f := computable.id.to_rcomp

theorem id' {f : β →. σ} : (λ x : α, x) computable_in f := computable.id.to_rcomp

theorem fst {f : γ →. σ} : (@prod.fst α β) computable_in f := computable.fst.to_rcomp

theorem snd {f : γ →. σ} : (@prod.snd α β) computable_in f := computable.snd.to_rcomp

theorem to_unary₁ {f : α → γ} {o : τ →. μ}
  (hf : f computable_in o) : (λ (x : α) (y : β), f x) computable₂_in o := hf.comp rcomputable.fst

theorem to_unary₂ {f : β → γ} {o : τ →. μ}
  (hf : f computable_in o) : (λ (x : α) (y : β), f y) computable₂_in o := hf.comp rcomputable.snd

theorem pair {f : α → σ} {g : α → τ} {h : γ →. μ}
  (hf : f computable_in h) (hg : g computable_in h) : (λ x, (f x, g x)) computable_in h :=
  (nat.rpartrec.pair hf hg).of_eq $ λ n, by cases decode α n; simp [(<*>)]

theorem const (a : α) {f : γ →. σ} : (λ x, a : β → α) computable_in f :=
(computable.const a).to_rcomp

protected theorem encode {f : β →. σ} : (@encode α _) computable_in f := computable.encode.to_rcomp

protected theorem decode {f : β →. σ} : (@decode α _) computable_in f := computable.decode.to_rcomp

@[refl] theorem refl {f : α → β} : f computable_in (f : α →. β) := nat.rpartrec.refl
theorem refl_in (f : α → β) : f computable_in (f : α →. β) := nat.rpartrec.refl

protected theorem cond {c : α → bool} {f : α → σ} {g : α → σ} {h : β →. τ}
  (hc : c computable_in h) (hf : f computable_in h) (hg : g computable_in h) :
  (λ a, cond (c a) (f a) (g a)) computable_in h :=
begin
  let f₀ := (λ a, cond a.1 a.2.1 a.2.2 : bool × σ × σ → σ),
  let f₁ := (λ a, (c a, f a, g a) : α → bool × σ × σ),
  have c₀ : computable f₀ :=
    computable.cond computable.fst
      (computable.fst.comp computable.snd) (computable.snd.comp computable.snd),
  have c₁ : f₁ computable_in h := pair hc (pair hf hg),
  exact c₀.to_rcomp.comp c₁
end

theorem encode_iff {f : α → σ} {g : β →. τ}: (λ a, encodable.encode (f a)) computable_in g ↔ f computable_in g :=
iff.rfl

theorem option_some_iff {f : α → σ} {g : β →. τ} : (λ a, some (f a)) computable_in g ↔ f computable_in g :=
⟨λ h, encode_iff.1 $ primrec.pred.to_comp.to_rcomp.comp $ encode_iff.2 h,
 computable.option_some.to_rcomp.comp⟩

theorem to₂ {f : α × β → σ} {g : γ →. τ} (hf : f computable_in g) : (λ a b, f (a, b)) computable₂_in g :=
hf.of_eq $ λ ⟨a, b⟩, rfl

end rcomputable

namespace rpartrec₂

theorem of_eq {f g : α → β →. γ} {h : σ →. τ} (hf : f partrec₂_in h) (H : ∀ n m, f n m = g n m) : g partrec₂_in h :=
(funext (λ n, funext (H n)) : f = g) ▸ hf

theorem unpaired {f : α → β →. σ} {o : τ →. μ} : (prod.unpaired f) partrec_in o ↔ f partrec₂_in o :=
by simp[rpartrec₂]

theorem comp  {f : β → γ →. σ} {g : α → β} {h : α → γ} {o : τ →. μ}
  (hf : f partrec₂_in o) (hg : g computable_in o) (hh : h computable_in o) :
  (λ x, f (g x) (h x)) partrec_in o := rpartrec.comp hf (hg.pair hh)

theorem comp₂ {f : γ → δ →. σ} {g : α → β → γ} {h : α → β → δ} {o : τ →. μ}
  (hf : f partrec₂_in o) (hg : g computable₂_in o) (hh : h computable₂_in o) :
  (λ a b, f (g a b) (h a b)) partrec₂_in o := hf.comp hg hh

end rpartrec₂

namespace rpartrec
open rcomputable

theorem rfind_opt {f : α → ℕ → option σ} {g : β →. τ}
  (hf : f computable₂_in g) :
  (λ a, nat.rfind_opt (f a)) partrec_in g :=
(rfind (rpartrec.some.comp₂ (rcomputable.comp₂ (primrec.option_is_some.to_comp.to_rcomp) hf))).bind (of_option hf)

theorem nat_cases_right
  {f : α → ℕ} {g : α → σ} {h : α × ℕ →. σ} {o : γ →. τ}
  (hf : f computable_in o) (hg : g computable_in o) (hh : h partrec_in o) :
  (λ a, (f a).cases (some (g a)) (λ x, h (a, x))) partrec_in o :=
(nat_elim hf hg (hh.comp $ fst.pair (computable.pred.to_rpart.comp $ hf.comp fst))).of_eq $
λ a, begin
  simp, cases f a; simp,
  refine ext (λ b, ⟨λ H, _, λ H, _⟩),
  { rcases mem_bind_iff.1 H with ⟨c, h₁, h₂⟩, exact h₂ },
  { have : ∀ m, (nat.elim (part.some (g a))
      (λ y IH, IH.bind (λ _, h (a, n))) m).dom,
    { intro, induction m; simp [*, H.fst] },
    exact ⟨⟨this n, H.fst⟩, H.snd⟩ }
end

theorem to_unary₁ {f : α →. γ} {o : τ →. μ}
  (hf : f partrec_in o) : (λ (x : α) (y : β), f x) partrec₂_in o := hf.comp rcomputable.fst

theorem to_unary₂ {f : β →. γ} {o : τ →. μ}
  (hf : f partrec_in o) : (λ (x : α) (y : β), f y) partrec₂_in o := hf.comp rcomputable.snd

end rpartrec

namespace rcomputable
open rpartrec

theorem comp₂' {f : β × γ → σ} {g : α → β} {h : α → γ} {o : τ →. μ}
  (hf : f computable_in o) (hg : g computable_in o) (hh : h computable_in o) :
  (λ a, f (g a, h a)) computable_in o :=
hf.comp (hg.pair hh)

theorem nat_cases {f : α → ℕ} {g : α → σ} {h : α → ℕ → σ} {o : β →. τ}
  (hf : f computable_in o) (hg : g computable_in o) (hh : h computable₂_in o) :
  (λ a, (f a).cases (g a) (h a)) computable_in o :=
nat_elim hf hg (hh.comp $ fst.pair $ fst.comp snd)

theorem bind_decode_iff {f : α × β → option σ} {h : γ →. τ} :
  (λ x : α × ℕ, (decode β x.2).bind (λ y, f (x.1, y))) computable_in h ↔ f computable_in h :=
⟨λ hf, nat.rpartrec.of_eq
    (((partrec.nat_iff.2 (nat.partrec.ppred.comp $
        nat.partrec.of_primrec $ primcodable.prim β)).comp computable.snd).to_rpart.bind (rpartrec.to_unary₁ hf)) $
  λ n, by simp;
    cases decode α n.unpair.1; simp;
    cases decode β n.unpair.2; simp,
λ hf, begin
  have H : (λ (a : (α × ℕ) × ℕ), part.map (λ (x : β), f (a.fst.fst, x)) ↑(encodable.decode β a.snd)) partrec_in h,
  { exact (rpartrec.coe.comp rcomputable.decode.to_unary₂).map
  (rcomputable.comp₂ hf ((rcomputable.to_unary₁ rcomputable.fst.to_unary₁).pair rcomputable.id'.to_unary₂)) },
  have : (λ a : α × ℕ, (encode (decode β a.2)).cases
    (some option.none) (λ n, part.map (λ x, f (a.1, x)) (decode β n))) partrec_in h :=
  nat_cases_right (primrec.encdec.to_comp.comp computable.snd).to_rpart
    (const option.none) H,
  refine this.of_eq (λ a, _),
  simp, cases decode β a.2; simp [encodek]
end⟩

theorem map_decode_iff {f : α × β → σ} {h : γ →. τ} :
  (λ x : α × ℕ, (decode β x.2).map (λ y, f (x.1, y))) computable_in h ↔ f computable_in h :=
have this : (λ x : α × ℕ, (decode β x.2).bind (λ y, some $ f (x.1, y))) computable_in h ↔ f computable_in h :=
  (bind_decode_iff.trans option_some_iff), this

theorem option_cases {o : α → option β} {f : α → σ} {g : α → β → σ} {h : γ →. τ}
  (ho : o computable_in h) (hf : f computable_in h) (hg : g computable₂_in h) :
  @rcomputable _ _ σ _ _ _ _ _ (λ a, option.cases_on (o a) (f a) (g a)) h :=
option_some_iff.1 $
(nat_cases (encode_iff.2 ho) (option_some_iff.2 hf)
    (map_decode_iff.2 hg).to₂).of_eq $
λ a, by cases o a; simp [encodek]; refl

theorem option_bind {f : α → option β} {g : α → β → option σ} {h : γ →. τ}
  (hf : f computable_in h) (hg : g computable₂_in h) :
  (λ a, (f a).bind (g a)) computable_in h :=
(option_cases hf (const option.none) hg.to₂).of_eq $
λ a, by cases f a; refl

theorem option_map {f : α → option β} {g : α → β → σ} {h : γ →. τ}
  (hf : f computable_in h) (hg : g computable₂_in h) :
  (λ a, (f a).map (g a)) computable_in h :=
option_bind hf (primrec.option_some.to_comp.to_rcomp.comp hg).to₂

theorem total_computable {f : α →. σ} (h : ∀ a, (f a).dom) :
  (λ a, (f a).get (h a)) computable_in f := (rpartrec.refl.of_eq $ by simp)

end rcomputable

namespace rcomputable₂
open rcomputable
variables {ν : Type*} [primcodable ν]

theorem of_eq {f g : α → β → γ} {h : σ →. τ} (hf : f computable₂_in h) (H : ∀ n m, f n m = g n m) :
  g computable₂_in h :=
(funext (λ n, funext (H n)) : f = g) ▸ hf

@[trans] theorem trans₂ {f : α → β → σ} {g : γ → δ → τ} {h : μ →. ν} :
  f computable₂_in! (prod.unpaired g) → g computable₂_in h → f computable₂_in h :=
nat.rpartrec.trans

theorem comp {f : γ → δ → σ} {g : α → γ} {h : α → δ} {o : τ →. μ}
  (hf : f computable₂_in o) (hg : g computable_in o) (hh : h computable_in o) :
  (λ a, f (g a) (h a)) computable_in o := hf.comp (hg.pair hh)

theorem comp₂ {f : γ → δ → σ} {g : α → β → γ} {h : α → β → δ} {o : τ →. μ}
  (hf : f computable₂_in o) (hg : g computable₂_in o) (hh : h computable₂_in o) :
  (λ a b, f (g a b) (h a b)) computable₂_in o := rcomputable.comp hf (hg.pair hh)

theorem pair {f : α → β → γ} {g : α → β → δ} {o : τ →. μ}
  (hf : f computable₂_in o) (hg : g computable₂_in o) :
  (λ x y, (f x y, g x y)) computable₂_in o := rcomputable.pair hf hg

end rcomputable₂

lemma rfind_dom_total {p : ℕ → bool} :
  (∃ n, p n = tt) → (nat.rfind p).dom :=
begin
  simp, intros n,
  induction n with n0 ih generalizing p,
  { assume h, use 0, simp [h] },
  { assume h,
    let q := (λ n : ℕ, (p n.succ)),
    have q0 : q n0 = tt, simp[q], exact h,
    rcases ih q0 with ⟨m, qm, hm⟩, simp[q] at qm, simp[q] at hm,
    cases ep : p 0 with p0 p0,
    { use m.succ, split, exact qm,
      intros l el, simp [part.some] },
    { use 0, exact ⟨eq.symm ep, by simp⟩ } }
end

lemma nat_bool_minimum {n : ℕ} : ∀ {p : ℕ → bool}, p n = tt → (∃ m, p m = tt ∧ ∀ l, l < m → p l = ff) :=
begin
  induction n with n0 ih,
  { assume p h, use 0, exact ⟨h, by simp⟩ },
  { assume p h,
    let q := (λ n : ℕ, (p n.succ)),
    have q0 : q n0 = tt, simp[q], exact h,
    rcases ih q0 with ⟨m, qm, hm⟩, simp[q] at qm, simp[q] at hm,
    cases ep : p 0 with p0 p0,
    { use m.succ, split, exact qm,
      intros l el, cases l, exact ep,
      exact hm _ (show l < m, by omega) },
    { use 0, exact ⟨ep, by simp⟩ } }
end

lemma nat_bool_minimum' {n : ℕ} : ∀ {p : ℕ → bool}, p n = tt → (∃ m, m ≤ n ∧ p m = tt ∧ ∀ l, l < m → p l = ff) :=
begin
  intros p h, rcases nat_bool_minimum h with ⟨m, mh⟩, use m,
  have l : m ≤ n,
  { cases (nat.lt_or_ge n m) with em em, exfalso,
    have c : p n = ff := mh.2 _ em, exact bool_iff_false.mpr c h,
    exact em },
  exact ⟨l, mh⟩
end

instance decidable.to_part_dom {α : Type*} {β : Type*} (f : α → β) :
  ∀ n, decidable ((↑ᵣf) n).dom := λ _, decidable.true

def computable_fun : ℕ → ℕ := λ _, 0

lemma computable.computable_fun : computable computable_fun := computable.const _


/-
Copyright (c) 2020 Dany Fabian. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Dany Fabian
-/
import tactic.unfold_cases

open tactic

variable {α : Type*}

inductive color
| red
| black

inductive node (α)
| leaf {} : node
| tree {} (color : color) (left : node) (val : α) (right : node) : node

/-- this function creates 122 cases as opposed to the 5 we see here. -/
def balance_eqn_compiler {α} : color → node α → α → node α → node α
| color.black (node.tree color.red (node.tree color.red a x b) y c) z d :=
    node.tree color.red (node.tree color.black a x b) y (node.tree color.black c z d)
| color.black (node.tree color.red a x (node.tree color.red b y c)) z d :=
    node.tree color.red (node.tree color.black a x b) y (node.tree color.black c z d)
| color.black a x (node.tree color.red (node.tree color.red b y c) z d) :=
    node.tree color.red (node.tree color.black a x b) y (node.tree color.black c z d)
| color.black a x (node.tree color.red b y (node.tree color.red c z d)) :=
    node.tree color.red (node.tree color.black a x b) y (node.tree color.black c z d)
| color a x b := node.tree color a x b

example : ∀ a (x:α) b y c z d, balance_eqn_compiler color.black (node.tree color.red (node.tree color.red a x b) y c) z d =
    node.tree color.red (node.tree color.black a x b) y (node.tree color.black c z d) :=
begin
  unfold_cases { refl },
end

/-- this function creates 122 cases as opposed to the 5 we see here. -/
def balance_match {α}  (c:color) (l:node α) (v:α) (r:node α) : node α :=
match c, l, v, r with
| color.black, node.tree color.red (node.tree color.red a x b) y c, z, d :=
    node.tree color.red (node.tree color.black a x b) y (node.tree color.black c z d)
| color.black, node.tree color.red a x (node.tree color.red b y c), z, d :=
    node.tree color.red (node.tree color.black a x b) y (node.tree color.black c z d)
| color.black, a, x, node.tree color.red (node.tree color.red b y c) z d :=
    node.tree color.red (node.tree color.black a x b) y (node.tree color.black c z d)
| color.black, a, x, node.tree color.red b y (node.tree color.red c z d) :=
     node.tree color.red (node.tree color.black a x b) y (node.tree color.black c z d)
| color, a, x, b := node.tree color a x b
end

example : ∀ a (x:α) b y c z d, balance_match color.black (node.tree color.red (node.tree color.red a x b) y c) z d =
    node.tree color.red (node.tree color.black a x b) y (node.tree color.black c z d) :=
begin
  unfold_cases { refl },
end

def foo : ℕ → ℕ → ℕ
| 0 0 := 17
| (n+2) 17 := 17
| 1 0 := 23
| 0 (n+18) := 15
| 0 17 := 17
| 1 17 := 17
| _ (n+18) := 27
| _ _ := 15

example : ∀ x, foo x 17 = 17 :=
begin
  unfold_cases { refl },
end

def bar : ℕ → ℕ
| 17 := 17
| 9 := 17
| n := 17

example : ∀ x, bar x = 17 :=
begin
  unfold_cases { refl }
end

def baz : ℕ → ℕ → Prop
| 0 0 := false
| 0 n := true
| n 0 := false
| n m := n < m

example : ∀ x, baz x 0 = false :=
begin
  unfold_cases { refl },
end