lean2/hott/types/pointed.hlean

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

Ported from Coq HoTT
-/

import arity .eq .bool .unit .sigma
open is_trunc eq prod sigma nat equiv option is_equiv bool unit

structure pointed [class] (A : Type) :=
  (point : A)

structure Pointed :=
  {carrier : Type}
  (Point   : carrier)

open Pointed

namespace pointed
  attribute Pointed.carrier [coercion]
  variables {A B : Type}

  definition pt [unfold-c 2] [H : pointed A] := point A
  protected abbreviation Mk [constructor] := @Pointed.mk
  protected definition mk' [constructor] (A : Type) [H : pointed A] : Pointed :=
  Pointed.mk (point A)
  definition pointed_carrier [instance] [constructor] (A : Pointed) : pointed A :=
  pointed.mk (Point A)

  -- Any contractible type is pointed
  definition pointed_of_is_contr [instance] [constructor] (A : Type) [H : is_contr A] : pointed A :=
  pointed.mk !center

  -- A pi type with a pointed target is pointed
  definition pointed_pi [instance] [constructor] (P : A → Type) [H : Πx, pointed (P x)]
      : pointed (Πx, P x) :=
  pointed.mk (λx, pt)

  -- A sigma type of pointed components is pointed
  definition pointed_sigma [instance] [constructor] (P : A → Type) [G : pointed A]
      [H : pointed (P pt)] : pointed (Σx, P x) :=
  pointed.mk ⟨pt,pt⟩

  definition pointed_prod [instance] [constructor] (A B : Type) [H1 : pointed A] [H2 : pointed B]
      : pointed (A × B) :=
  pointed.mk (pt,pt)

  definition pointed_loop [instance] [constructor] (a : A) : pointed (a = a) :=
  pointed.mk idp

  definition pointed_bool [instance] [constructor] : pointed bool :=
  pointed.mk ff

  definition Bool [constructor] : Pointed :=
  pointed.mk' bool

  definition pointed_fun_closed [constructor] (f : A → B) [H : pointed A] : pointed B :=
  pointed.mk (f pt)

  definition Loop_space [reducible] [constructor] (A : Pointed) : Pointed :=
  pointed.mk' (point A = point A)

  -- definition Iterated_loop_space : Pointed → ℕ → Pointed
  -- | Iterated_loop_space A 0 := A
  -- | Iterated_loop_space A (n+1) := Iterated_loop_space (Loop_space A) n

  definition Iterated_loop_space [reducible] (n : ℕ) (A : Pointed) : Pointed :=
  nat.rec_on n (λA, A) (λn IH A, IH (Loop_space A)) A

  prefix `Ω`:(max+5) := Loop_space
  notation `Ω[`:95 n:0 `]`:0 A:95 := Iterated_loop_space n A

  definition iterated_loop_space (A : Type) [H : pointed A] (n : ℕ) : Type :=
  Ω[n] (pointed.mk' A)

  open equiv.ops
  definition Pointed_eq {A B : Pointed} (f : A ≃ B) (p : f pt = pt) : A = B :=
  begin
    cases A with A a, cases B with B b, esimp at *,
    fapply apd011 @Pointed.mk,
    { apply ua f},
    { rewrite [cast_ua,p]},
  end

  definition add_point [constructor] (A : Type) : Pointed :=
  Pointed.mk (none : option A)
  postfix `₊`:(max+1) := add_point
  -- the inclusion A → A₊ is called "some", the extra point "pt" or "none" ("@none A")
end pointed

open pointed
structure pointed_map (A B : Pointed) :=
  (map : A → B) (respect_pt : map (Point A) = Point B)

open pointed_map

namespace pointed

  abbreviation respect_pt := @pointed_map.respect_pt

  -- definition transport_to_sigma {A B : Pointed}
  --   {P : Π(X : Type) (m : X → A → B), (Π(f : X), m f (Point A) = Point B) → (Π(m : A → B), m (Point A) = Point B → X) →  Type}
  --   (H : P (Σ(f : A → B), f (Point A) = Point B) pr1 pr2 sigma.mk) :
  --   P (pointed_map A B) map respect_pt pointed_map.mk :=
  -- sorry


  notation `map₊` := pointed_map
  attribute pointed_map.map [coercion]
  definition pointed_map_eq {A B : Pointed} {f g : map₊ A B}
    (r : Πa, f a = g a) (s : respect_pt f = (r pt) ⬝ respect_pt g) : f = g :=
  begin
    cases f with f p, cases g with g q,
    esimp at *,
    fapply apo011 pointed_map.mk,
    { exact eq_of_homotopy r},
    { apply concato_eq, apply pathover_eq_Fl, apply inv_con_eq_of_eq_con,
      rewrite [ap_eq_ap10,↑ap10,apd10_eq_of_homotopy,↑respect_pt at *,s]}
  end

  definition pointed_map_equiv_left (A : Type) (B : Pointed) : map₊ A₊ B ≃ (A → B) :=
  begin
    fapply equiv.MK,
    { intro f a, cases f with f p, exact f (some a)},
    { intro f, fapply pointed_map.mk,
        intro a, cases a, exact pt, exact f a,
        reflexivity},
    { intro f, reflexivity},
    { intro f, cases f with f p, esimp, fapply pointed_map_eq,
      { intro a, cases a; all_goals (esimp at *), exact p⁻¹},
      { esimp, exact !con.left_inv⁻¹}},
  end

  -- set_option pp.notation false
  -- definition pointed_map_equiv_right (A : Pointed) (B : Type)
  --   : (Σ(b : B), map₊ A (pointed.Mk b)) ≃ (A → B) :=
  -- begin
  --   fapply equiv.MK,
  --   { intro u a, cases u with b f, cases f with f p, esimp at f, exact f a},
  --   { intro f, refine ⟨f pt, _⟩, fapply pointed_map.mk,
  --       intro a, esimp, exact f a,
  --       reflexivity},
  --   { intro f, reflexivity},
  --   { intro u, cases u with b f, cases f with f p, esimp at *, apply sigma_eq p,
  --     esimp, apply sorry
  --     }
  -- end

  definition pointed_map_bool_equiv (B : Pointed) : map₊ Bool B ≃ B :=
  begin
    fapply equiv.MK,
    { intro f, cases f with f p, exact f tt},
    { intro b, fapply pointed_map.mk,
        intro u, cases u, exact pt, exact b,
        reflexivity},
    { intro b, reflexivity},
    { intro f, cases f with f p, esimp, fapply pointed_map_eq,
      { intro a, cases a; all_goals (esimp at *), exact p⁻¹},
      { esimp, exact !con.left_inv⁻¹}},
  end
  -- calc
  --   map₊ (Pointed.mk' bool) B ≃ map₊ unit₊ B : sorry
  --     ... ≃ (unit → B) : pointed_map_equiv
  --     ... ≃ B : unit_imp_equiv

  definition apn {A B : Pointed} {n : ℕ} (f : map₊ A B) (p : Ω[n] A) : Ω[n] B :=
  begin
  revert A B f p, induction n with n IH,
  { intros A B f p, exact f p},
  { intros A B f p, rewrite [↑Iterated_loop_space at p,↓Iterated_loop_space n (Ω A) at p,
      ↑Iterated_loop_space, ↓Iterated_loop_space n (Ω B)],
    apply IH (Ω A),
    { esimp, fapply pointed_map.mk,
        intro q, refine !respect_pt⁻¹ ⬝ ap f q ⬝ !respect_pt,
        esimp, apply con.left_inv},
    { exact p}}
  end

end pointed