univalence.ctt

module univalence where

import gradLemma

transEquivToId (A B : U) (w : equiv A B) : Id U A B =
  <i> glue B [ (i = 1) -> (B,eB.1,invEq B B eB,retEq B B eB,secEq B B eB)
             , (i = 0) -> (A,w.1,invEq A B w,retEq A B w,secEq A B w) ]
 where eB : equiv B B = transDelta B

eqToEq (A B : U) (p : Id U A B)
  : Id (Id U A B) (transEquivToId A B (transEquiv A B p)) p
  = <j i> let e : equiv A B = transEquiv A B p
              f : equiv B B = transDelta B
              Ai : U = p@i
              g : equiv Ai B = transEquiv Ai B (<k> p @ (i \/ k))
          in glue B
           [ (i = 0) -> (A,e.1,invEq A B e,retEq A B e,secEq A B e)
           , (i = 1) -> (B,f.1,invEq B B f,retEq B B f,secEq B B f)
           , (j = 1) -> (p@i,g.1,invEq Ai B g,retEq Ai B g,secEq Ai B g) ]

transIdFun (A B : U) (w : equiv A B)
  : Id (A -> B) (trans A B (transEquivToId A B w)) w.1 =
  <i> \(a : A) -> let b : B = w.1 a
                  in addf (f (f (f b))) b (addf (f (f b)) b (addf (f b) b (trf b))) @ i
  where f (b : B) : B = comp (<_> B) b []
        trf (b : B) : Id B (f b) b =
          <i> fill (<_> B) b [] @ -i
        addf (b b' : B) : Id B b b' -> Id B (f b) b' =
          compId B (f b) b b' (trf b)

idToId (A B : U) (w : equiv A B)
  : Id (equiv A B) (transEquiv A B (transEquivToId A B w)) w
  = equivLemma A B (transEquiv A B (transEquivToId A B w)) w
      (transIdFun A B w)

transEquivIsEquiv (A B : U)
  : isEquiv (Id U A B) (equiv A B) (transEquiv A B)
  = gradLemma (Id U A B) (equiv A B) (transEquiv A B)
      (transEquivToId A B) (idToId A B) (eqToEq A B)

univalence (A B : U) : equiv (Id U A B) (equiv A B) =
  (transEquiv A B,transEquivIsEquiv A B)

univalence1 (A B:U) : Id U (Id U A B) (equiv A B) = 
 isoId (Id U A B) (equiv A B) (transEquiv A B) (transEquivToId A B) (idToId A B) (eqToEq A B)


-- This takes too long to normalize:
test (A : U) : Id (equiv A A) (transEquiv A A (transEquivToId A A (idEquiv A))) (idEquiv A) =
  idToId A A (idEquiv A)


-- The canonical map defined using J
canIdToEquiv (A : U) : (B : U) -> Id U A B -> equiv A B =
  J U A (\ (B : U) (_ : Id U A B) -> equiv A B) (idEquiv A)

canDiagTrans (A : U) : Id (A -> A) (canIdToEquiv A A (<_> A)).1 (idfun A) =
  <i> fill (<_> A -> A) (idfun A) [] @ -i

transDiagTrans (A : U) : Id (A -> A) (idfun A) (trans A A (<_> A)) =
  <i> \ (a : A) -> fill (<_> A) a [] @ i

canIdToEquivLem (A : U) : (B : U) (p : Id U A B) ->
  Id (A -> B) (canIdToEquiv A B p).1 (transEquiv A B p).1
  = J U A
      (\ (B : U) (p : Id U A B) ->
        Id (A -> B) (canIdToEquiv A B p).1 (transEquiv A B p).1)
      (compId (A -> A)
        (canIdToEquiv A A (<_> A)).1 (idfun A) (trans A A (<_> A))
        (canDiagTrans A) (transDiagTrans A))

canIdToEquivIsTransEquiv (A B : U) :
  Id (Id U A B -> equiv A B) (canIdToEquiv A B) (transEquiv A B) =
  <i> \ (p : Id U A B) ->
        equivLemma A B (canIdToEquiv A B p) (transEquiv A B p)
          (canIdToEquivLem A B p) @ i

-- The canonical map is an equivalence
univalence2 (A B : U) : isEquiv (Id U A B) (equiv A B) (canIdToEquiv A B) =
  substInv (Id U A B -> equiv A B)
    (isEquiv (Id U A B) (equiv A B))
     (canIdToEquiv A B) (transEquiv A B)
     (canIdToEquivIsTransEquiv A B)
     (transEquivIsEquiv A B)