amelia
/
cubical
1
0
Fork 0
Code Issues 0 Pull Requests 0 Projects 0 Releases 0 Wiki Activity
Browse Source

Composition for the universe

master
Amélia Liao 3 years ago
parent
8937bc16cc
commit
57970721b9
4 changed files with 24 additions and 18 deletions
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. +1
    -1
      src/Elab/Monad.hs
  2. +22
    -14
      src/Elab/WiredIn.hs
  3. +1
    -2
      src/Elab/WiredIn.hs-boot
  4. +0
    -1
      src/Main.hs

+ 1
- 1
src/Elab/Monad.hs View File

@ -159,4 +159,4 @@ throwElab = liftIO . throwIO
incName :: Name -> Name -> Name incName :: Name -> Name -> Name
incName (Bound x _) n = Bound x (getNameNum n + 1) incName (Bound x _) n = Bound x (getNameNum n + 1)
incName (Defined x k) n = Defined x (getNameNum n + 1)
incName (Defined x _) n = Defined x (getNameNum n + 1)

+ 22
- 14
src/Elab/WiredIn.hs View File

@ -22,8 +22,6 @@ import qualified Presyntax.Presyntax as P
import Syntax import Syntax
import System.IO.Unsafe import System.IO.Unsafe
import GHC.Stack
import Syntax.Pretty
wiType :: WiredIn -> NFType wiType :: WiredIn -> NFType
wiType WiType = VType wiType WiType = VType
@ -214,7 +212,7 @@ ielim _line _left _right fn i =
VSystem (Map.toList -> []) -> VSystem (Map.fromList []) VSystem (Map.toList -> []) -> VSystem (Map.fromList [])
_ -> error $ "can't ielim " ++ show fn _ -> error $ "can't ielim " ++ show fn
outS :: HasCallStack => NFSort -> NFEndp -> Value -> Value -> Value
outS :: NFSort -> NFEndp -> Value -> Value -> Value
outS _ (force -> VI1) u _ = u @@ VItIsOne outS _ (force -> VI1) u _ = u @@ VItIsOne
outS _ _phi _ (VInc _ _ x) = x outS _ _phi _ (VInc _ _ x) = x
@ -245,8 +243,8 @@ comp a psi@phi u (compOutS (a @@ VI1) phi (u @@ VI1 @@ VItIsOne) -> a0) =
(VInc (rng VI0 (ybar VI0 arg)) phi (vApp (plic VI0) a0 (ybar VI0 arg))) (VInc (rng VI0 (ybar VI0 arg)) phi (vApp (plic VI0) a0 (ybar VI0 arg)))
VSigma{} -> VSigma{} ->
let let
dom i = let VSigma d _ = a @@ i in d
rng i = let VSigma _ (Closure _ r) = a @@ i in r
dom i = let VSigma d _ = force (a @@ i) in d
rng i = let VSigma _ (Closure _ r) = force (a @@ i) in r
w i = fill (fun dom) phi (system \i isone -> vProj1 (u @@ i @@ isone)) (VInc (dom VI0) phi (vProj1 a0)) i w i = fill (fun dom) phi (system \i isone -> vProj1 (u @@ i @@ isone)) (VInc (dom VI0) phi (vProj1 a0)) i
c1 = comp (fun dom) phi (system \i isone -> vProj1 (u @@ i @@ isone)) (VInc (dom VI0) phi (vProj1 a0)) c1 = comp (fun dom) phi (system \i isone -> vProj1 (u @@ i @@ isone)) (VInc (dom VI0) phi (vProj1 a0))
@ -256,9 +254,9 @@ comp a psi@phi u (compOutS (a @@ VI1) phi (u @@ VI1 @@ VItIsOne) -> a0) =
VPath{} -> VPath{} ->
let let
a' i = let VPath thea _ _ = a @@ i in thea
u' i = let VPath _ theu _ = a @@ i in theu
v' i = let VPath _ _ thev = a @@ i in thev
a' i = let VPath thea _ _ = force (a @@ i) in thea
u' i = let VPath _ theu _ = force (a @@ i) in theu
v' i = let VPath _ _ thev = force (a @@ i) in thev
in in
VLine (a' VI1 @@ VI1) (u' VI1) (v' VI1) $ fun \j -> VLine (a' VI1 @@ VI1) (u' VI1) (v' VI1) $ fun \j ->
comp (fun a') comp (fun a')
@ -306,7 +304,9 @@ comp a psi@phi u (compOutS (a @@ VI1) phi (u @@ VI1 @@ VItIsOne) -> a0) =
a1' a1'
b1 = glueElem (base VI1) (phi VI1) (types VI1) (equivs VI1) (fun (const t1)) a1 b1 = glueElem (base VI1) (phi VI1) (types VI1) (equivs VI1) (fun (const t1)) a1
in b1 in b1
VType -> VGlueTy a0 phi (system \_ _ -> u @@ VI1 @@ VItIsOne) (system \_ _ -> makeEquiv (\j -> (u @@ inot j)))
-- fibrancy structure of the booleans is trivial -- fibrancy structure of the booleans is trivial
VBool{} -> a0 VBool{} -> a0
@ -394,14 +394,22 @@ contr a aC phi u =
(system \i is1 -> ielim (line (const a)) a (vProj1 (u is1)) (vProj2 (u is1)) i) (system \i is1 -> ielim (line (const a)) a (vProj1 (u is1)) (vProj2 (u is1)) i)
(vProj1 aC) (vProj1 aC)
makeEquiv :: (NFEndp -> Value) -> Value
makeEquiv line = comp (fun \i -> equiv a (line i)) VI0 (system \_ _ -> VSystem mempty) (VPair idfun idisequiv) where
a = line VI0
idfun = fun id
-- idEquiv y = ((y, \i -> y), \u i -> (u.2 (inot i), \j -> u.2 (ior (inot i) j)))
u_ty = exists' "y" a \x -> VPath (fun (const a)) x x
idisequiv = fun \y -> VPair (id_fiber y) $ fun \u ->
VLine u_ty (id_fiber y) u $ fun \i -> VPair (ielim (fun (const a)) y y (vProj2 u) i) $
VLine (fun (const a)) y (vProj1 u) $ fun \j ->
ielim (fun (const a)) y y (vProj2 u) (iand i j)
id_fiber y = VPair y (VLine a y y (fun (const y)))
elimBool :: NFSort -> Value -> Value -> Value -> Value elimBool :: NFSort -> Value -> Value -> Value -> Value
elimBool prop x y bool = elimBool prop x y bool =
case force bool of case force bool of
VTt -> x VTt -> x
VFf -> y VFf -> y
VNe _ (_ Seq.:|> PIElim _ a b c) ->
case c of
VI0 -> elimBool prop x y a
VI1 -> elimBool prop x y b
_ -> VIf prop x y bool
_ -> VIf prop x y bool _ -> VIf prop x y bool

+ 1
- 2
src/Elab/WiredIn.hs-boot View File

@ -1,7 +1,6 @@
module Elab.WiredIn where module Elab.WiredIn where
import Syntax import Syntax
import GHC.Stack
wiType :: WiredIn -> NFType wiType :: WiredIn -> NFType
wiValue :: WiredIn -> NFType wiValue :: WiredIn -> NFType
@ -10,7 +9,7 @@ iand, ior :: NFEndp -> NFEndp -> NFEndp
inot :: NFEndp -> NFEndp inot :: NFEndp -> NFEndp
ielim :: NFSort -> Value -> Value -> Value -> NFEndp -> Value ielim :: NFSort -> Value -> Value -> Value -> NFEndp -> Value
outS :: HasCallStack => NFSort -> NFEndp -> Value -> Value -> Value
outS :: NFSort -> NFEndp -> Value -> Value -> Value
comp :: NFLine -> NFEndp -> Value -> Value -> Value comp :: NFLine -> NFEndp -> Value -> Value -> Value
glueType :: NFSort -> NFEndp -> NFPartial -> NFPartial -> Value glueType :: NFSort -> NFEndp -> NFPartial -> NFPartial -> Value


+ 0
- 1
src/Main.hs View File

@ -8,7 +8,6 @@ module Main where
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Reader import Control.Monad.Reader
import Control.Exception import Control.Exception
import Control.Monad
import qualified Data.ByteString.Lazy as Bsl import qualified Data.ByteString.Lazy as Bsl
import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding as T


Write Preview
Loading…
Cancel
Save