lecture4.ctt

{-
            Lecture 4 on cubicaltt (Cubical Type Theory)
--------------------------------------------------------------------------
                        Anders Mörtberg

Contents:
  o Equivalences
  o Glue types
  o Univalence

-}
module lecture4 where

import lecture3

--------------------------------------------------------------------------
-- Equivalences

-- For more results about equivalences see chapter 4 of the HoTT book.

-- The fiber/preimage of a map:
fiber (A B : U) (f : A -> B) (y : B) : U =
  (x : A) * Path B y (f x)

-- A map is an equivalence
isEquiv (A B : U) (f : A -> B) : U =
  (y : B) -> isContr (fiber A B f y)

equiv (A B : U) : U = (f : A -> B) * isEquiv A B f

-- Recall:
-- contrSingl (A : U) (a b : A) (p : Path A a b) :
--            Path (singl A a) (a,<i> a) (b,p) =

-- The identity function is an equivalence
idIsEquiv (A : U) : isEquiv A A (idfun A) =
  \(a : A) -> ((a,<i> a),
         \(z : fiber A A (idfun A) a) -> contrSingl A a z.1 z.2)

idEquiv (A : U) : equiv A A = (idfun A,idIsEquiv A)

-- Compute the inverse of an equivalence
invEquiv (A B : U) (e : equiv A B) (y : B) : A =
  (e.2 y).1.1

-- Exercises (easy): the inverse is really the inverse
retEq (A B : U) (e : equiv A B) (y : B) : Path B (e.1 (invEquiv A B e y)) y = <i> (e.2 y).1.2 @ -i
secEq (A B : U) (e : equiv A B) (x : A) : Path A (invEquiv A B e (e.1 x)) x = <i> (((e.2 (e.1 x)).2 (x , <j> e.1 x)) @ i).1

-- Exercise (hard): prove that being contractible is a proposition.
-- (hint: use a composition)
isPropIsContr (A : U) : isProp (isContr A) = undefined  -- Changing this to ? results in crashing of the cubicaltt process.

-- Being an equivalence is hence a proposition. Note that propositions
-- in HoTT is different from Prop of Coq as we cannot erase them. If
-- we erase the proof that a map is an equivalence we cannot invert
-- it!
isPropIsEquiv (A B : U) (f : A -> B) : isProp (isEquiv A B f) =
  \(u0 u1 : isEquiv A B f) ->
  <i> \(y : B) -> isPropIsContr (fiber A B f y) (u0 y) (u1 y) @ i

-- The "isoToEquiv": any isomorphism is an equivalence
isoToEquiv (A B : U) (f : A -> B) (g : B -> A)
       (s : (y : B) -> Path B (f (g y)) y)
       (t : (x : A) -> Path A (g (f x)) x) : isEquiv A B f =
  \(y:B) -> ((g y,<i>s y@-i),\ (z:fiber A B f y) ->
    lemIso A B f g s t y (g y) z.1 (<i>s y@-i) z.2)
  where
  lemIso (A B : U) (f : A -> B) (g : B -> A)
       (s : (y : B) -> Path B (f (g y)) y)
       (t : (x : A) -> Path A (g (f x)) x)
       (y : B) (x0 x1 : A) (p0 : Path B y (f x0)) (p1 : Path B y (f x1)) :
       Path (fiber A B f y) (x0,p0) (x1,p1) = <i> (p @ i,sq1 @ i)
    where
    rem0 : Path A (g y) x0 =
      <i> comp (<k> A) (g (p0 @ i)) [ (i = 1) -> t x0, (i = 0) -> <k> g y ]

    rem1 : Path A (g y) x1 =
      <i> comp (<k> A) (g (p1 @ i)) [ (i = 1) -> t x1, (i = 0) -> <k> g y ]

    p : Path A x0 x1 =
     <i> comp (<k> A) (g y) [ (i = 0) -> rem0
                            , (i = 1) -> rem1 ]

    fill0 : Square A (g y) (g (f x0)) (g y) x0
                     (<i> g (p0 @ i)) rem0 (<i> g y) (t x0)  =
      <i j> comp (<k> A) (g (p0 @ i)) [ (i = 1) -> <k> t x0 @ j /\ k
                                      , (i = 0) -> <k> g y
                                      , (j = 0) -> <k> g (p0 @ i) ]

    fill1 : Square A (g y) (g (f x1)) (g y) x1
                     (<i> g (p1 @ i)) rem1 (<i> g y) (t x1) =
      <i j> comp (<k> A) (g (p1 @ i)) [ (i = 1) -> <k> t x1 @ j /\ k
                                      , (i = 0) -> <k> g y
                                      , (j = 0) -> <k> g (p1 @ i) ]

    fill2 : Square A (g y) (g y) x0 x1
                     (<k> g y) p rem0 rem1 =
      <i j> comp (<k> A) (g y) [ (i = 0) -> <k> rem0 @ j /\ k
                               , (i = 1) -> <k> rem1 @ j /\ k
                               , (j = 0) -> <k> g y ]

    sq : Square A (g y) (g y) (g (f x0)) (g (f x1))
                  (<i> g y) (<i> g (f (p @ i)))
                  (<j> g (p0 @ j)) (<j> g (p1 @ j)) =
      <i j> comp (<k> A) (fill2 @ i @ j) [ (i = 0) -> <k> fill0 @ j @ -k
                                         , (i = 1) -> <k> fill1 @ j @ -k
                                         , (j = 0) -> <k> g y
                                         , (j = 1) -> <k> t (p @ i) @ -k ]

    sq1 : Square B y y (f x0) (f x1)
                   (<k>y) (<i> f (p @ i)) p0 p1 =
      <i j> comp (<k> B) (f (sq @ i @j)) [ (i = 0) -> s (p0 @ j)
                                         , (i = 1) -> s (p1 @ j)
                                         , (j = 1) -> s (f (p @ i))
                                         , (j = 0) -> s y ]





{-
                          Glueing
--------------------------------------------------------------------------

The univalence axiom says that equality of types is equivalent to
equivalence of types:

       (A = B)  ~  (A ~ B)

Glueing is a weaker form of this for producing non-trivial equalities
from equivalences. In particular Glueing gives a map from equiv A B to
A = B. This weak form of univalence is useful for developing a lot of
examples.

If e : equiv A B then we can get a path between A and B by

G := <i> Glue B [ (i = 0) -> (A,e), (i = 1) -> (B,idEquiv B) ]

This can be illustrated as:

              G
        A - - - - > B
        |           |
       e|           | idEquiv B
        |           |
        V           V
        B --------> B
              B

The sides of this square are equivalence while the bottom and top are
lines in direction i.

The Glue type allows us to do two very hard things: prove that the
universe is fibrant (i.e. define composition for U) and prove the
univalence axiom.

-}

ua (A B : U) (e : equiv A B) : Path U A B =
  <i> Glue B [ (i = 0) -> (A,e), (i = 1) -> (B,idEquiv B) ]

      ---------------------------------------------------------
      -- Example: Non-trivial equality between bool and bool --
      ---------------------------------------------------------

-- recall: notK : (b : bool) -> Path bool (not (not b)) b = ...

notEquiv : equiv bool bool =
  (not,isoToEquiv bool bool not not notK notK)

-- Construct an equality in the universe using Glue
notEq : Path U bool bool =
  <i> Glue bool [ (i = 0) -> (bool,notEquiv)
                , (i = 1) -> (bool,idEquiv bool) ]

-- Transporting true along this equality gives false
testFalse : bool = transport notEq true


       ---------------------------------------------------
       -- Example: Non-trivial equality between Z and Z --
       ---------------------------------------------------

data or (A B : U) = inl (a : A)
                  | inr (b : B)


Z : U = or nat nat

-- Z represents:

--  +2 = inr (suc (suc zero))
--  +1 = inr (suc zero)
--   0 = inr zero
--  -1 = inl zero
--  -2 = inl (suc zero)

zeroZ : Z = inr zero

sucZ : Z -> Z = split
  inl u -> auxsucZ u
    where
    auxsucZ : nat -> Z = split
      zero  -> inr zero
      suc n -> inl n
  inr v -> inr (suc v)

predZ : Z -> Z = split
  inl u -> inl (suc u)
  inr v -> auxpredZ v
    where
    auxpredZ : nat -> Z = split
      zero  -> inl zero
      suc n -> inr n

sucpredZ : (x : Z) -> Path Z (sucZ (predZ x)) x = split
  inl u -> <i> inl u
  inr v -> lem v
   where
    lem : (u : nat) -> Path Z (sucZ (predZ (inr u))) (inr u) = split
      zero  -> <i> inr zero
      suc n -> <i> inr (suc n)

predsucZ : (x : Z) -> Path Z (predZ (sucZ x)) x = split
  inl u -> lem u
   where
    lem : (u : nat) -> Path Z (predZ (sucZ (inl u))) (inl u) = split
      zero  -> <i> inl zero
      suc n -> <i> inl (suc n)
  inr v -> <i> inr v

sucPathZ : Path U Z Z =
   <i> Glue Z [ (i = 0) -> (Z,sucZ,isoToEquiv Z Z sucZ predZ sucpredZ predsucZ)
              , (i = 1) -> (Z,idEquiv Z) ]

-- We can transport along the proof forward and backwards:
testOneZ : Z = transport sucPathZ zeroZ
sucPathZ2 : Path U Z Z =
  <i> comp (<_> U) (sucPathZ @ i) [ (i = 0) -> <j> Z, (i = 1) -> sucPathZ ]
testTwoZ : Z = transport sucPathZ2 zeroZ
testNOneZ : Z = transport (<i> sucPathZ @ - i) zeroZ



-- Structure identity principle: any structure on a type A can be
-- transported to an equivalent type B.

substEquiv (P : U -> U) (A B : U) (e : equiv A B) (h : P A) : P B =
  subst U P A B (ua A B e) h

-- substEquiv Monoid nat binnat nat_equiv_binnat monoid_nat : Monoid binnat

-- We can use this to do generic programming:
data food = cheese | beef | chicken

-- Predicate encoding which food someone eats
eats (X : U) : U = list (and food X)

anders : eats bool = cons (cheese,true)
                    (cons (beef,false)
                    (cons (chicken,false) nil))

-- Cyril eats the complement of Anders
cyril : eats bool = substEquiv eats bool bool notEquiv anders


-- This can also be used to do program and data refinements, see
-- examples/binnat.ctt where some property for unary numbers is proved
-- by computing with binary numbers.


--------------------------------------------------------------------------
-- Univalence

-- The file examples/univalence.ctt contains 3 proofs of univalence.
-- The simplest one is based on an idea of Dan Licata:
--
--   https://groups.google.com/forum/#!topic/homotopytypetheory/j2KBIvDw53s

-- The idea is to reduce univalence to two simple axioms:
--
--   ua (A B : U) (e : equiv A B) : Path U A B
--
-- and
--
--   uabeta (A B : U) (e : equiv A B) : Path (A -> B) (trans A B (ua A B e)) e.1

-- Exercise: prove the computation rule for ua
-- (hint: use fill with the empty system)
uabeta (A B : U) (e : equiv A B) : Path (A -> B) (trans A B (ua A B e)) e.1 = undefined

-- One would expect this computation rule to hold judgmentally, but it
-- doesn't as the algorithm for computation in the universe adds some
-- compositions with the empty system.
-- Open problem: construct a type theory where this holds judgmentally.

-- A further reduction of these axioms to even simpler axioms have
-- recently been found by Ian Orton and Andrew Pitts:
--
-- http://types2017.elte.hu/proc.pdf#page=93

data Unit = tt

-- Exercises: prove these 3 axioms (hint: Glue might be useful)

unit (A : U) : Path U A ((a : A) * Unit) = undefined

flip (A B : U) (C : A -> B -> U) :
  Path U ((a : A) * (b : B) * C a b)
         ((b : B) * (a : A) * C a b) = undefined

contract (A : U) : isContr A -> Path U A Unit = undefined

-- Exercises: prove these 2 computation rules for the above axioms

unitbeta (A : U) (a : A) :
  Path ((a : A) * Unit) (transport (unit A) a) (a,tt) = undefined

flipbeta (A B : U) (C : A -> B -> U) (a : A) (b : B) (c : C a b) :
  Path ((b : B) * (a : A) * C a b)
       (transport (flip A B C) (a,b,c)) (b,a,c) = undefined



--------------------------------------------------------------------------
{-

What I didn't talk about:

  o Id types: we can define a type from Path for which the
    computation rule for J holds judgmentally. See
    examples/idtypes.ctt

  o Higher inductive types: we can define some higher inductive types
    directly in the system. Non-recursive HITs like the circle or the
    spheres work correctly, but for more complicated HITs like
    propositional truncations or pushouts the composition operation
    doesn't work properly. We are currently working on fixing these
    issues.

  o The model in cubical sets with connections. For details see the
    paper.

-}


                               --------------
                               -- The end! --
                               --------------