├── .gitignore ├── CTT.hs ├── Concrete.hs ├── Eval.hs ├── Exp.cf ├── LICENSE ├── Main.hs ├── Makefile ├── Pretty.hs ├── README.md ├── Setup.hs ├── TODO ├── Tests.hs ├── TypeChecker.hs ├── cubical.cabal ├── cubical.el ├── examples ├── BoolEqBool.cub ├── Kraus.cub ├── UnotSet.cub ├── axChoice.cub ├── binnat.cub ├── cong.cub ├── contr.cub ├── curry.cub ├── description.cub ├── elimEquiv.cub ├── epi.cub ├── equivProp.cub ├── equivSet.cub ├── equivTotal.cub ├── exists.cub ├── finite.cub ├── function.cub ├── gradLemma.cub ├── hedberg.cub ├── helix.cub ├── heterogeneous.cub ├── integer.cub ├── interval.cub ├── involutive.cub ├── lemId.cub ├── mutual.cub ├── nIso.cub ├── omega.cub ├── opacity.cub ├── opacity_fail.cub ├── prelude.cub ├── primitives.cub ├── quotient.cub ├── set.cub ├── spector.cub ├── subset.cub ├── swap.cub ├── swapDisc.cub ├── swapDisc_old.cub ├── testInh.cub ├── turn.cub └── univalence.cub └── notes └── allprim.txt /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.hi 3 | *.ho 4 | *.o 5 | dist/ 6 | Exp/ 7 | -------------------------------------------------------------------------------- /CTT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | module CTT where 3 | 4 | import Control.Applicative 5 | import Data.List 6 | import Data.Maybe 7 | import Pretty 8 | 9 | -------------------------------------------------------------------------------- 10 | -- | Terms 11 | 12 | data Loc = Loc { locFile :: String 13 | , locPos :: (Int, Int) } 14 | deriving Eq 15 | 16 | type Ident = String 17 | type Label = String 18 | type Binder = (Ident,Loc) 19 | 20 | noLoc :: String -> Binder 21 | noLoc x = (x, Loc "" (0,0)) 22 | 23 | -- Branch of the form: c x1 .. xn -> e 24 | type Brc = (Label,([Binder],Ter)) 25 | 26 | -- Telescope (x1 : A1) .. (xn : An) 27 | type Tele = [(Binder,Ter)] 28 | 29 | -- Labelled sum: c (x1 : A1) .. (xn : An) 30 | type LblSum = [(Binder,Tele)] 31 | 32 | -- Context gives type values to identifiers 33 | type Ctxt = [(Binder,Val)] 34 | 35 | -- Mutual recursive definitions: (x1 : A1) .. (xn : An) and x1 = e1 .. xn = en 36 | type Decls = [(Binder,Ter,Ter)] 37 | data ODecls = ODecls Decls 38 | | Opaque Binder 39 | | Transp Binder 40 | deriving (Eq,Show) 41 | 42 | declIdents :: Decls -> [Ident] 43 | declIdents decl = [ x | ((x,_),_,_) <- decl] 44 | 45 | declBinders :: Decls -> [Binder] 46 | declBinders decl = [ x | (x,_,_) <- decl] 47 | 48 | declTers :: Decls -> [Ter] 49 | declTers decl = [ d | (_,_,d) <- decl] 50 | 51 | declTele :: Decls -> Tele 52 | declTele decl = [ (x,t) | (x,t,_) <- decl] 53 | 54 | declDefs :: Decls -> [(Binder,Ter)] 55 | declDefs decl = [ (x,d) | (x,_,d) <- decl] 56 | 57 | -- Terms 58 | data Ter = App Ter Ter 59 | | Pi Ter Ter 60 | | Lam Binder Ter 61 | | Sigma Ter Ter 62 | | SPair Ter Ter 63 | | Fst Ter 64 | | Snd Ter 65 | | Where Ter ODecls 66 | | Var Ident 67 | | U 68 | -- constructor c Ms 69 | | Con Label [Ter] 70 | -- branches c1 xs1 -> M1,..., cn xsn -> Mn 71 | | Split Loc [Brc] 72 | -- labelled sum c1 A1s,..., cn Ans (assumes terms are constructors) 73 | | Sum Binder LblSum 74 | | PN PN 75 | deriving Eq 76 | 77 | -- Primitive notions 78 | data PN = Id | Refl 79 | -- Inh A is an h-prop stating that A is inhabited. 80 | -- Here we take h-prop A as (Pi x y : A) Id A x y. 81 | | Inh 82 | -- Inc a : Inh A for a:A (A not needed ??) 83 | | Inc 84 | -- Squash a b : Id (Inh A) a b 85 | | Squash 86 | -- InhRec B p phi a : B, 87 | -- p : hprop(B), phi : A -> B, a : Inh A (cf. HoTT-book p.113) 88 | | InhRec 89 | 90 | -- (A B : U) -> Id U A B -> A -> B 91 | -- For TransU we only need the eqproof and the element in A is needed 92 | | TransU 93 | 94 | -- (A B : U) -> Id U A B -> B -> A 95 | -- For TransU we only need the eqproof and the element in A is needed 96 | | TransInvU 97 | 98 | -- (A : U) -> (a : A) -> Id A a (transport A (refl U A) a) 99 | | TransURef 100 | 101 | -- (A : U) (a b:A) (p:Id A a b) -> Id (singl A a) (pair a (refl A a)) (pair b p) 102 | | CSingl 103 | 104 | -- (A B : U) (f : A -> B) (a b : A) -> 105 | -- (p : Id A a b) -> Id B (f a) (f b) 106 | -- TODO: remove? 107 | | MapOnPath 108 | 109 | -- (A B : U) (f g : A -> B) (a b : A) -> 110 | -- Id (A->B) f g -> Id A a b -> Id B (f a) (g b) 111 | | AppOnPath 112 | 113 | -- Ext B f g p : Id (Pi A B) f g, 114 | -- (p : (Pi x:A) Id (Bx) (fx,gx)); A not needed ?? 115 | -- | Ext 116 | 117 | -- Ext B f g p : Id (Pi A B) f g, 118 | -- (p : (Pi x y:A) IdS A (Bx) x y p fx gy) 119 | | HExt 120 | 121 | -- EquivEq A B f s t where 122 | -- A, B are types, f : A -> B, 123 | -- s : (y : B) -> fiber f y, and 124 | -- t : (y : B) (z : fiber f y) -> Id (fiber f y) (s y) z 125 | -- where fiber f y is Sigma x : A. Id B (f x) z. 126 | | EquivEq 127 | -- (A : U) -> (s : (y : A) -> pathTo A a) -> 128 | -- (t : (y : B) -> (v : pathTo A a) -> Id (path To A a) (s y) v) -> 129 | -- Id (Id U A A) (refl U A) (equivEq A A (id A) s t) 130 | | EquivEqRef 131 | 132 | -- (A B : U) -> (f : A -> B) (s : (y : B) -> fiber A B f y) -> 133 | -- (t : (y : B) -> (v : fiber A B f y) -> Id (fiber A B f y) (s y) v) -> 134 | -- (a : A) -> Id B (f a) (transport A B (equivEq A B f s t) a) 135 | | TransUEquivEq 136 | 137 | -- IdP : (A B :U) -> Id U A B -> A -> B -> U 138 | -- IdP A B p a b is the type of paths connecting a to b over p 139 | | IdP 140 | 141 | -- mapOnPathD : (A : U) (F : A -> U) (f : (x : A) -> F x) (a0 a1 : A) (p : Id A a0 a1) -> 142 | -- IdS A F a0 a1 p (f a0) (f a1) 143 | -- IdS : (A:U) (F:A -> U) (a0 a1:A) (p:Id A a0 a1) -> F a0 -> F a1 -> U 144 | -- IdS A F a0 a1 p = IdP (F a0) (F a1) (mapOnPath A U F a0 a1 p) 145 | -- TODO: remove in favor of AppOnPathD? 146 | | MapOnPathD 147 | 148 | -- AppOnPathD : (A : U) (F : A -> U) (f g : (x : A) -> F x) -> Id ((x : A) -> F x) f g -> 149 | -- (a0 a1 : A) (p : Id A a0 a1) -> IdS A F a0 a1 p (f a0) (g a1) 150 | -- | AppOnPathD 151 | 152 | -- mapOnPathS : (A:U)(F:A -> U) (C:U) (f: (x:A) -> F x -> C) (a0 a1 : A) (p:Id A a0 a1) 153 | -- (b0:F a0) (b1:F a1) (q : IdS A F a0 a1 p b0 b1) -> Id C (f a0 b0) (f a1 b1) 154 | | MapOnPathS -- TODO: AppOnPathS? 155 | 156 | -- S1 : U 157 | | Circle 158 | 159 | -- base : S1 160 | | Base 161 | 162 | -- loop : Id S1 base base 163 | | Loop 164 | 165 | -- S1rec : (F : S1 -> U) (b : F base) (l : IdS F base base loop) (x : S1) -> F x 166 | | CircleRec 167 | 168 | -- I : U 169 | | I 170 | 171 | -- I0, I1 : Int 172 | | I0 | I1 173 | 174 | -- line : Id Int I0 I1 175 | | Line 176 | 177 | 178 | -- intrec : (F : I -> U) (s : F I0) (e : F I1) 179 | -- (l : IdS Int F I0 I1 line s e) (x : I) -> F x 180 | | IntRec 181 | 182 | -- undefined constant 183 | | Undef Loc 184 | deriving (Eq, Show) 185 | 186 | -- For an expression t, returns (u,ts) where u is no application 187 | -- and t = u t 188 | unApps :: Ter -> (Ter,[Ter]) 189 | unApps = aux [] 190 | where aux :: [Ter] -> Ter -> (Ter,[Ter]) 191 | aux acc (App r s) = aux (s:acc) r 192 | aux acc t = (t,acc) 193 | -- Non tail reccursive version: 194 | -- unApps (App r s) = let (t,ts) = unApps r in (t, ts ++ [s]) 195 | -- unApps t = (t,[]) 196 | 197 | mkApps :: Ter -> [Ter] -> Ter 198 | mkApps (Con l us) vs = Con l (us ++ vs) 199 | mkApps t ts = foldl App t ts 200 | 201 | mkLams :: [String] -> Ter -> Ter 202 | mkLams bs t = foldr Lam t [noLoc b | b <- bs] 203 | 204 | mkWheres :: [ODecls] -> Ter -> Ter 205 | mkWheres [] e = e 206 | mkWheres (d:ds) e = Where (mkWheres ds e) d 207 | 208 | -- Primitive notions 209 | primHandle :: [(Ident,Int,PN)] 210 | primHandle = 211 | [("Id" , 3, Id ), 212 | ("refl" , 2, Refl ), 213 | -- ("funExt" , 5, Ext ), 214 | ("funHExt" , 5, HExt ), 215 | ("inh" , 1, Inh ), 216 | ("inc" , 2, Inc ), 217 | ("squash" , 3, Squash ), 218 | ("inhrec" , 5, InhRec ), 219 | ("equivEq" , 5, EquivEq ), 220 | ("transport" , 4, TransU ), 221 | ("transpInv" , 4, TransInvU ), 222 | ("contrSingl" , 4, CSingl ), 223 | ("transportRef" , 2, TransURef ), 224 | ("equivEqRef" , 3, EquivEqRef ), 225 | ("transpEquivEq" , 6, TransUEquivEq), 226 | ("appOnPath" , 8, AppOnPath ), 227 | ("mapOnPath" , 6, MapOnPath ), 228 | ("IdP" , 5, IdP ), 229 | ("mapOnPathD" , 6, MapOnPathD ), 230 | ("mapOnPathS" , 10, MapOnPathS ), 231 | ("S1" , 0, Circle ), 232 | ("base" , 0, Base ), 233 | ("loop" , 0, Loop ), 234 | ("S1rec" , 4, CircleRec ), 235 | ("I" , 0, I ), 236 | ("I0" , 0, I0 ), 237 | ("I1" , 0, I1 ), 238 | ("line" , 0, Line ), 239 | ("intrec" , 5, IntRec )] 240 | 241 | reservedNames :: [String] 242 | reservedNames = [ s | (s,_,_) <- primHandle ] 243 | 244 | arity :: PN -> Int 245 | arity pn = fromMaybe 0 $ listToMaybe [n | (_,n,pn') <- primHandle, pn == pn'] 246 | 247 | mkPN :: String -> Maybe PN 248 | mkPN s = listToMaybe [pn | (s',_,pn) <- primHandle, s == s'] 249 | 250 | -------------------------------------------------------------------------------- 251 | -- | Names, dimension, and nominal type class 252 | 253 | type Name = Integer 254 | type Dim = [Name] 255 | 256 | gensym :: Dim -> Name 257 | gensym [] = 2 258 | gensym xs = maximum xs + 1 259 | 260 | gensyms :: Dim -> [Name] 261 | gensyms d = let x = gensym d in x : gensyms (x : d) 262 | 263 | class Nominal a where 264 | swap :: a -> Name -> Name -> a 265 | support :: a -> [Name] 266 | 267 | fresh :: Nominal a => a -> Name 268 | fresh = gensym . support 269 | 270 | freshs :: Nominal a => a -> [Name] 271 | freshs = gensyms . support 272 | 273 | instance (Nominal a, Nominal b) => Nominal (a, b) where 274 | support (a, b) = support a `union` support b 275 | swap (a, b) x y = (swap a x y, swap b x y) 276 | 277 | instance Nominal a => Nominal [a] where 278 | support vs = unions (map support vs) 279 | swap vs x y = [swap v x y | v <- vs] 280 | 281 | instance Nominal a => Nominal (Maybe a) where 282 | support = maybe [] support 283 | swap v x y = fmap (\u -> swap u x y) v 284 | 285 | -- Make Name an instance of Nominal 286 | instance Nominal Integer where 287 | support 0 = [] 288 | support 1 = [] 289 | support n = [n] 290 | 291 | swap z x y | z == x = y 292 | | z == y = x 293 | | otherwise = z 294 | 295 | -------------------------------------------------------------------------------- 296 | -- | Boxes 297 | 298 | -- TODO: abstract the type of Intervals instead of exposing the encoding 299 | type Dir = Integer 300 | 301 | mirror :: Dir -> Dir 302 | mirror 0 = 1 303 | mirror 1 = 0 304 | mirror n = error $ "mirror: 0 or 1 expected but " ++ show n ++ " given" 305 | 306 | up, down :: Dir 307 | up = 1 308 | down = 0 309 | 310 | type Side = (Name,Dir) 311 | 312 | allDirs :: [Name] -> [Side] 313 | allDirs [] = [] 314 | allDirs (n:ns) = (n,down) : (n,up) : allDirs ns 315 | 316 | data Box a = Box { dir :: Dir 317 | , pname :: Name 318 | , pface :: a 319 | , sides :: [(Side,a)] } 320 | deriving Eq 321 | 322 | instance Show a => Show (Box a) where 323 | show (Box dir n f xs) = "Box" <+> show dir <+> show n <+> show f <+> show xs 324 | 325 | mapBox :: (a -> b) -> Box a -> Box b 326 | mapBox f (Box d n x xs) = Box d n (f x) [ (nnd,f v) | (nnd,v) <- xs ] 327 | 328 | sequenceSnd :: Monad m => [(a,m b)] -> m [(a,b)] 329 | sequenceSnd [] = return [] 330 | sequenceSnd ((a,b):abs) = do 331 | b' <- b 332 | acs <- sequenceSnd abs 333 | return $ (a,b') : acs 334 | 335 | sequenceBox :: Monad m => Box (m a) -> m (Box a) 336 | sequenceBox (Box d n x xs) = do 337 | x' <- x 338 | xs' <- sequenceSnd xs 339 | return $ Box d n x' xs' 340 | 341 | mapBoxM :: Monad m => (a -> m b) -> Box a -> m (Box b) 342 | mapBoxM f = sequenceBox . mapBox f 343 | 344 | instance Functor Box where 345 | fmap = mapBox 346 | 347 | lookBox :: Show a => Side -> Box a -> a 348 | lookBox (y,dir) (Box d x v _) | x == y && mirror d == dir = v 349 | lookBox xd box@(Box _ _ _ nvs) = case lookup xd nvs of 350 | Just v -> v 351 | Nothing -> error $ "lookBox: box not defined on " ++ 352 | show xd ++ "\nbox = " ++ show box 353 | 354 | nonPrincipal :: Box a -> [Name] 355 | nonPrincipal (Box _ _ _ nvs) = nub $ map (fst . fst) nvs 356 | 357 | defBox :: Box a -> [(Name, Dir)] 358 | defBox (Box d x _ nvs) = (x,mirror d) : [ zd | (zd,_) <- nvs ] 359 | 360 | fromBox :: Box a -> [(Side,a)] 361 | fromBox (Box d x v nvs) = ((x, mirror d),v) : nvs 362 | 363 | modBox :: (Side -> a -> b) -> Box a -> Box b 364 | modBox f (Box dir x v nvs) = 365 | Box dir x (f (x,mirror dir) v) [ (nd,f nd v) | (nd,v) <- nvs ] 366 | 367 | modBoxM :: Monad m => (Side -> a -> m b) -> Box a -> m (Box b) 368 | modBoxM f = sequenceBox . modBox f 369 | 370 | -- Restricts the non-principal faces to np. 371 | subBox :: [Name] -> Box a -> Box a 372 | subBox np (Box dir x v nvs) = 373 | Box dir x v [ nv | nv@((n,_),_) <- nvs, n `elem` np] 374 | 375 | shapeOfBox :: Box a -> Box () 376 | shapeOfBox = mapBox (const ()) 377 | 378 | -- fst is down, snd is up 379 | consBox :: (Name,(a,a)) -> Box a -> Box a 380 | consBox (n,(v0,v1)) (Box dir x v nvs) = 381 | Box dir x v $ ((n,down),v0) : ((n,up),v1) : nvs 382 | 383 | appendBox :: [(Name,(a,a))] -> Box a -> Box a 384 | appendBox xs b = foldr consBox b xs 385 | 386 | appendSides :: [(Side, a)] -> Box a -> Box a 387 | appendSides sides (Box dir x v nvs) = Box dir x v (sides ++ nvs) 388 | 389 | transposeBox :: Box [a] -> [Box a] 390 | transposeBox b@(Box dir _ [] _) = [] 391 | transposeBox (Box dir x (v:vs) nvss) = 392 | Box dir x v [ (nnd,head vs) | (nnd,vs) <- nvss ] : 393 | transposeBox (Box dir x vs [ (nnd,tail vs) | (nnd,vs) <- nvss ]) 394 | 395 | -- Nominal for boxes 396 | instance Nominal a => Nominal (Box a) where 397 | support (Box dir n v nvs) = support ((n, v), nvs) 398 | swap (Box dir z v nvs) x y = Box dir z' v' nvs' where 399 | ((z',v'), nvs') = swap ((z, v), nvs) x y 400 | 401 | -------------------------------------------------------------------------------- 402 | -- | Values 403 | 404 | data KanType = Fill | Com 405 | deriving (Show, Eq) 406 | 407 | data Val = VU 408 | | Ter Ter OEnv 409 | | VPi Val Val 410 | | VId Val Val Val 411 | 412 | | VSigma Val Val 413 | | VSPair Val Val 414 | 415 | -- tag values which are paths 416 | | Path Name Val 417 | 418 | -- | VExt Name Val Val Val Val 419 | | VHExt Name Val Val Val Val 420 | 421 | -- inhabited 422 | | VInh Val 423 | 424 | -- inclusion into inhabited 425 | | VInc Val 426 | 427 | -- squash type - connects the two values along the name 428 | | VSquash Name Val Val 429 | 430 | | VCon Ident [Val] 431 | 432 | | Kan KanType Val (Box Val) 433 | 434 | -- of type U connecting a and b along x 435 | -- VEquivEq x a b f s t 436 | | VEquivEq Name Val Val Val Val Val 437 | 438 | -- names x, y and values a, s, t 439 | | VEquivSquare Name Name Val Val Val 440 | 441 | -- of type VEquivEq 442 | | VPair Name Val Val 443 | 444 | -- of type VEquivSquare 445 | | VSquare Name Name Val 446 | 447 | -- a value of type Kan Com VU (Box (type of values)) 448 | | VComp (Box Val) 449 | 450 | -- a value of type Kan Fill VU (Box (type of values minus name)) 451 | -- the name is bound 452 | | VFill Name (Box Val) 453 | 454 | -- circle 455 | | VCircle 456 | | VBase 457 | | VLoop Name -- has type VCircle and connects base along the name 458 | 459 | -- interval 460 | | VI 461 | | VI0 462 | | VI1 463 | | VLine Name -- connects start and end point along name 464 | 465 | -- neutral values 466 | | VApp Val Val -- the first Val must be neutral 467 | | VAppName Val Name 468 | | VSplit Val Val -- the second Val must be neutral 469 | | VVar String Dim 470 | | VInhRec Val Val Val Val -- the last Val must be neutral 471 | | VCircleRec Val Val Val Val -- the last Val must be neutral 472 | | VIntRec Val Val Val Val Val -- the last Val must be neutral 473 | | VFillN Val (Box Val) 474 | | VComN Val (Box Val) 475 | | VFst Val 476 | | VSnd Val 477 | deriving Eq 478 | 479 | vepair :: Name -> Val -> Val -> Val 480 | vepair x a b = VSPair a (Path x b) 481 | 482 | mkVar :: Int -> Dim -> Val 483 | mkVar k = VVar ('X' : show k) 484 | 485 | isNeutral :: Val -> Bool 486 | isNeutral (VApp u _) = isNeutral u 487 | isNeutral (VAppName u _) = isNeutral u 488 | isNeutral (VSplit _ v) = isNeutral v 489 | isNeutral (VVar _ _) = True 490 | isNeutral (VInhRec _ _ _ v) = isNeutral v 491 | isNeutral (VCircleRec _ _ _ v) = isNeutral v 492 | isNeutral (VIntRec _ _ _ _ v) = isNeutral v 493 | isNeutral (VFillN _ _) = True 494 | isNeutral (VComN _ _) = True 495 | isNeutral (VFst v) = isNeutral v 496 | isNeutral (VSnd v) = isNeutral v 497 | isNeutral _ = False 498 | 499 | fstVal, sndVal, unSquare :: Val -> Val 500 | fstVal (VPair _ a _) = a 501 | fstVal x = error $ "error fstVal: " ++ show x 502 | sndVal (VPair _ _ v) = v 503 | sndVal x = error $ "error sndVal: " ++ show x 504 | unSquare (VSquare _ _ v) = v 505 | unSquare v = error $ "unSquare bad input: " ++ show v 506 | 507 | unCon :: Val -> [Val] 508 | unCon (VCon _ vs) = vs 509 | unCon v = error $ "unCon: not a constructor: " ++ show v 510 | 511 | unions :: Eq a => [[a]] -> [a] 512 | unions = foldr union [] 513 | 514 | unionsMap :: Eq b => (a -> [b]) -> [a] -> [b] 515 | unionsMap f = unions . map f 516 | 517 | instance Nominal Val where 518 | support VU = [] 519 | support (Ter _ e) = support e 520 | support (VId a v0 v1) = support [a,v0,v1] 521 | support (Path x v) = delete x $ support v 522 | support (VInh v) = support v 523 | support (VInc v) = support v 524 | support (VPi v1 v2) = support [v1,v2] 525 | support (VCon _ vs) = support vs 526 | support (VSquash x v0 v1) = support (x, [v0,v1]) 527 | -- support (VExt x b f g p) = support (x, [b,f,g,p]) 528 | support (VHExt x b f g p) = support (x, [b,f,g,p]) 529 | support (Kan Fill a box) = support (a, box) 530 | support (VFillN a box) = support (a, box) 531 | support (VComN a box@(Box _ n _ _)) = delete n (support (a, box)) 532 | support (Kan Com a box@(Box _ n _ _)) = delete n (support (a, box)) 533 | support (VEquivEq x a b f s t) = support (x, [a,b,f,s,t]) 534 | -- names x, y and values a, s, t 535 | support (VEquivSquare x y a s t) = support ((x,y), [a,s,t]) 536 | support (VPair x a v) = support (x, [a,v]) 537 | support (VComp box@(Box _ n _ _)) = delete n $ support box 538 | support (VFill x box) = delete x $ support box 539 | support (VApp u v) = support (u, v) 540 | support (VAppName u n) = support (u, n) 541 | support (VSplit u v) = support (u, v) 542 | support (VVar x d) = support d 543 | support (VSigma u v) = support (u,v) 544 | support (VSPair u v) = support (u,v) 545 | support (VFst u) = support u 546 | support (VSnd u) = support u 547 | support (VInhRec b p h a) = support [b,p,h,a] 548 | support VCircle = [] 549 | support VBase = [] 550 | support (VLoop n) = [n] 551 | support (VCircleRec f b l s) = support [f,b,l,s] 552 | support VI = [] 553 | support VI0 = [] 554 | support VI1 = [] 555 | support (VLine n) = [n] 556 | support (VIntRec f s e l u) = support [f,s,e,l,u] 557 | support v = error ("support " ++ show v) 558 | 559 | swap u x y = 560 | let sw u = swap u x y in case u of 561 | VU -> VU 562 | Ter t e -> Ter t (sw e) 563 | VId a v0 v1 -> VId (sw a) (sw v0) (sw v1) 564 | Path z v -> Path (sw z) (sw v) 565 | -- VExt z b f g p -> VExt (swap z x y) (sw b) (sw f) (sw g) (sw p) 566 | VHExt z b f g p -> VHExt (sw z) (sw b) (sw f) (sw g) (sw p) 567 | VPi a f -> VPi (sw a) (sw f) 568 | VInh v -> VInh (sw v) 569 | VInc v -> VInc (sw v) 570 | VSquash z v0 v1 -> VSquash (sw z) (sw v0) (sw v1) 571 | VCon c us -> VCon c (map sw us) 572 | VEquivEq z a b f s t -> 573 | VEquivEq (sw z) (sw a) (sw b) (sw f) (sw s) (sw t) 574 | VPair z a v -> VPair (sw z) (sw a) (sw v) 575 | VEquivSquare z w a s t -> 576 | VEquivSquare (sw z) (sw w) (sw a) (sw s) (sw t) 577 | VSquare z w v -> VSquare (sw z) (sw w) (sw v) 578 | Kan Fill a b -> Kan Fill (sw a) (sw b) 579 | VFillN a b -> VFillN (sw a) (sw b) 580 | Kan Com a b -> Kan Com (sw a) (sw b) 581 | VComN a b -> VComN (sw a) (sw b) 582 | VComp b -> VComp (sw b) 583 | VFill z b -> VFill (sw z) (sw b) 584 | VApp u v -> VApp (sw u) (sw v) 585 | VAppName u n -> VAppName (sw u) (sw n) 586 | VSplit u v -> VSplit (sw u) (sw v) 587 | VVar s d -> VVar s (sw d) 588 | VSigma u v -> VSigma (sw u) (sw v) 589 | VSPair u v -> VSPair (sw u) (sw v) 590 | VFst u -> VFst (sw u) 591 | VSnd u -> VSnd (sw u) 592 | VInhRec b p h a -> VInhRec (sw b) (sw p) (sw h) (sw a) 593 | VCircle -> VCircle 594 | VBase -> VBase 595 | VLoop z -> VLoop (sw z) 596 | VCircleRec f b l a -> VCircleRec (sw f) (sw b) (sw l) (sw a) 597 | VI -> VI 598 | VI0 -> VI0 599 | VI1 -> VI1 600 | VLine z -> VLine (sw z) 601 | VIntRec f s e l u -> VIntRec (sw f) (sw s) (sw e) (sw l) (sw u) 602 | 603 | 604 | -------------------------------------------------------------------------------- 605 | -- | Environments 606 | 607 | data Env = Empty 608 | | Pair Env (Binder,Val) 609 | | PDef [(Binder,Ter)] Env 610 | deriving Eq 611 | 612 | instance Show Env where 613 | show Empty = "" 614 | show (PDef xas env) = show env 615 | show (Pair env (x,u)) = parens $ showEnv1 env ++ show u 616 | where 617 | showEnv1 (Pair env (x,u)) = showEnv1 env ++ show u ++ ", " 618 | showEnv1 e = show e 619 | 620 | instance Nominal Env where 621 | swap e x y = mapEnv (\u -> swap u x y) e 622 | 623 | support Empty = [] 624 | support (Pair e (_,v)) = support (e, v) 625 | support (PDef _ e) = support e 626 | 627 | data OEnv = OEnv { env :: Env, 628 | opaques :: [Binder] } 629 | deriving Eq 630 | 631 | oEmpty :: OEnv 632 | oEmpty = OEnv Empty [] 633 | 634 | oPair :: OEnv -> (Binder,Val) -> OEnv 635 | oPair (OEnv e o) u = OEnv (Pair e u) o 636 | 637 | oPDef :: Bool -> ODecls -> OEnv -> OEnv 638 | oPDef _ (ODecls decls) (OEnv e o) = OEnv (PDef [(x,d) | (x,_,d) <- decls] e) o 639 | oPDef True (Opaque d) (OEnv e o) = OEnv e (d:o) 640 | oPDef True (Transp d) (OEnv e o) = OEnv e (d `delete` o) 641 | oPDef _ _ e = e 642 | 643 | instance Show OEnv where 644 | show (OEnv e s) = show e -- <+> parens ("with opaque:" <+> ccat s) 645 | 646 | instance Nominal OEnv where 647 | swap (OEnv e s) x y = OEnv (swap e x y) s 648 | support (OEnv e s) = support e 649 | 650 | upds :: OEnv -> [(Binder,Val)] -> OEnv 651 | upds = foldl oPair 652 | 653 | lookupIdent :: Ident -> [(Binder,a)] -> Maybe (Binder, a) 654 | lookupIdent x defs = lookup x [(y,((y,l),t)) | ((y,l),t) <- defs] 655 | 656 | getIdent :: Ident -> [(Binder,a)] -> Maybe a 657 | getIdent x defs = snd <$> lookupIdent x defs 658 | 659 | getBinder :: Ident -> [(Binder,a)] -> Maybe Binder 660 | getBinder x defs = fst <$> lookupIdent x defs 661 | 662 | mapEnv :: (Val -> Val) -> Env -> Env 663 | mapEnv _ Empty = Empty 664 | mapEnv f (Pair e (x,v)) = Pair (mapEnv f e) (x,f v) 665 | mapEnv f (PDef ts e) = PDef ts (mapEnv f e) 666 | 667 | mapEnvM :: Applicative m => (Val -> m Val) -> Env -> m Env 668 | mapEnvM _ Empty = pure Empty 669 | mapEnvM f (Pair e (x,v)) = Pair <$> mapEnvM f e <*> ( (x,) <$> f v) 670 | mapEnvM f (PDef ts e) = PDef ts <$> mapEnvM f e 671 | 672 | mapOEnv :: (Val -> Val) -> OEnv -> OEnv 673 | mapOEnv f (OEnv e o) = OEnv (mapEnv f e) o 674 | 675 | mapOEnvM :: Applicative m => (Val -> m Val) -> OEnv -> m OEnv 676 | mapOEnvM f (OEnv e o) = flip OEnv o <$> mapEnvM f e 677 | 678 | valOfEnv :: Env -> [Val] 679 | valOfEnv Empty = [] 680 | valOfEnv (Pair env (_,v)) = v : valOfEnv env 681 | valOfEnv (PDef _ env) = valOfEnv env 682 | 683 | valOfOEnv :: OEnv -> [Val] 684 | valOfOEnv (OEnv e o) = valOfEnv e 685 | 686 | -------------------------------------------------------------------------------- 687 | -- | Pretty printing 688 | 689 | instance Show Loc where 690 | show (Loc name (i,j)) = name ++ "_L" ++ show i ++ "_C" ++ show j 691 | 692 | instance Show Ter where 693 | show = showTer 694 | 695 | showTer :: Ter -> String 696 | showTer U = "U" 697 | showTer (App e0 e1) = showTer e0 <+> showTer1 e1 698 | showTer (Pi e0 e1) = "Pi" <+> showTers [e0,e1] 699 | showTer (Lam (x,_) e) = '\\' : x <+> "->" <+> showTer e 700 | showTer (Fst e) = showTer e ++ ".1" 701 | showTer (Snd e) = showTer e ++ ".2" 702 | showTer (Sigma e0 e1) = "Sigma" <+> showTers [e0,e1] 703 | showTer (SPair e0 e1) = "pair" <+> showTers [e0,e1] 704 | showTer (Where e d) = showTer e <+> "where" <+> showODecls d 705 | showTer (Var x) = x 706 | showTer (Con c es) = c <+> showTers es 707 | showTer (Split l _) = "split " ++ show l 708 | showTer (Sum l _) = "sum " ++ show l 709 | showTer (PN pn) = showPN pn 710 | 711 | showTers :: [Ter] -> String 712 | showTers = hcat . map showTer1 713 | 714 | showTer1 :: Ter -> String 715 | showTer1 U = "U" 716 | showTer1 (Con c []) = c 717 | showTer1 (Var x) = x 718 | showTer1 u@(Split{}) = showTer u 719 | showTer1 u@(Sum{}) = showTer u 720 | showTer1 u@(PN{}) = showTer u 721 | showTer1 u = parens $ showTer u 722 | 723 | -- Warning: do not use showPN as a Show instance as it will loop 724 | showPN :: PN -> String 725 | showPN (Undef l) = show l 726 | showPN pn = case [s | (s,_,pn') <- primHandle, pn == pn'] of 727 | [s] -> s 728 | _ -> error $ "showPN: unknown primitive " ++ show pn 729 | 730 | showDecls :: Decls -> String 731 | showDecls defs = ccat (map (\((x,_),_,d) -> x <+> "=" <+> show d) defs) 732 | 733 | showODecls :: ODecls -> String 734 | showODecls (ODecls defs) = showDecls defs 735 | showODecls (Opaque x) = "opaque" <+> show x 736 | showODecls (Transp x) = "transparent" <+> show x 737 | 738 | instance Show Val where 739 | show = showVal 740 | 741 | showVal :: Val -> String 742 | showVal VU = "U" 743 | showVal (Ter t env) = show t <+> show env 744 | showVal (VId a u v) = 745 | "Id" <+> showVal1 a <+> showVal1 u <+> showVal1 v 746 | showVal (Path n u) = abrack (show n) <+> showVal u 747 | -- showVal (VExt n b f g p) = "funExt" <+> show n <+> showVals [b,f,g,p] 748 | showVal (VHExt n b f g p) = "funHExt" <+> show n <+> showVals [b,f,g,p] 749 | showVal (VCon c us) = c <+> showVals us 750 | showVal (VPi a f) = "Pi" <+> showVals [a,f] 751 | showVal (VInh u) = "inh" <+> showVal1 u 752 | showVal (VInc u) = "inc" <+> showVal1 u 753 | showVal (VInhRec b p h a) = "inhrec" <+> showVals [b,p,h,a] 754 | showVal (VSquash n u v) = "squash" <+> show n <+> showVals [u,v] 755 | showVal (Kan Fill v box) = "Fill" <+> showVal1 v <+> parens (show box) 756 | showVal (Kan Com v box) = "Com" <+> showVal1 v <+> parens (show box) 757 | showVal (VFillN v box) = "FillN" <+> showVal1 v <+> parens (show box) 758 | showVal (VComN v box) = "ComN" <+> showVal1 v <+> parens (show box) 759 | showVal (VPair n u v) = "vpair" <+> show n <+> showVals [u,v] 760 | showVal (VSquare x y u) = "vsquare" <+> show x <+> show y <+> showVal1 u 761 | showVal (VComp box) = "vcomp" <+> parens (show box) 762 | showVal (VFill n box) = "vfill" <+> show n <+> parens (show box) 763 | showVal (VApp u v) = showVal u <+> showVal1 v 764 | showVal (VAppName u n) = showVal u <+> "@" <+> show n 765 | showVal (VSplit u v) = showVal u <+> showVal1 v 766 | showVal (VVar x d) = x <+> showDim d 767 | showVal (VEquivEq n a b f _ _) = "equivEq" <+> show n <+> showVals [a,b,f] 768 | showVal (VEquivSquare x y a s t) = 769 | "equivSquare" <+> show x <+> show y <+> showVals [a,s,t] 770 | showVal (VSPair u v) = "pair" <+> showVals [u,v] 771 | showVal (VSigma u v) = "Sigma" <+> showVals [u,v] 772 | showVal (VFst u) = showVal u ++ ".1" 773 | showVal (VSnd u) = showVal u ++ ".2" 774 | showVal VCircle = "S1" 775 | showVal VBase = "base" 776 | showVal (VLoop x) = "loop" <+> show x 777 | showVal (VCircleRec f b l s) = "S1rec" <+> showVals [f,b,l,s] 778 | showVal VI = "I" 779 | showVal VI0 = "I0" 780 | showVal VI1 = "I1" 781 | showVal (VLine n) = "line" <+> show n 782 | showVal (VIntRec f s e l u) = "intrec" <+> showVals [f,s,e,l,u] 783 | 784 | showDim :: Show a => [a] -> String 785 | showDim = parens . ccat . map show 786 | 787 | showVals :: [Val] -> String 788 | showVals = hcat . map showVal1 789 | 790 | showVal1 :: Val -> String 791 | showVal1 VU = "U" 792 | showVal1 (VCon c []) = c 793 | showVal1 u@(VVar{}) = showVal u 794 | showVal1 u = parens $ showVal u 795 | -------------------------------------------------------------------------------- /Concrete.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections, ParallelListComp #-} 2 | 3 | -- | Convert the concrete syntax into the syntax of cubical TT. 4 | module Concrete where 5 | 6 | import Exp.Abs 7 | import qualified CTT as C 8 | import Pretty 9 | 10 | import Control.Applicative 11 | import Control.Arrow (second) 12 | import Control.Monad.Trans 13 | import Control.Monad.Trans.Reader 14 | import Control.Monad.Trans.Error hiding (throwError) 15 | import Control.Monad.Error (throwError) 16 | import Control.Monad (when) 17 | import Data.Functor.Identity 18 | import Data.List (nub) 19 | 20 | type Tele = [(AIdent,Exp)] 21 | type Ter = C.Ter 22 | 23 | -- | Useful auxiliary functions 24 | 25 | -- Applicative cons 26 | (<:>) :: Applicative f => f a -> f [a] -> f [a] 27 | a <:> b = (:) <$> a <*> b 28 | 29 | -- un-something functions 30 | unAIdent :: AIdent -> C.Ident 31 | unAIdent (AIdent (_,x)) = x 32 | 33 | unVar :: Exp -> Maybe AIdent 34 | unVar (Var x) = Just x 35 | unVar _ = Nothing 36 | 37 | unWhere :: ExpWhere -> Exp 38 | unWhere (Where e ds) = Let ds e 39 | unWhere (NoWhere e) = e 40 | 41 | -- tail recursive form to transform a sequence of applications 42 | -- App (App (App u v) ...) w into (u, [v, …, w]) 43 | -- (cleaner than the previous version of unApps) 44 | unApps :: Exp -> [Exp] -> (Exp, [Exp]) 45 | unApps (App u v) ws = unApps u (v : ws) 46 | unApps u ws = (u, ws) 47 | 48 | vTele :: [VTDecl] -> Tele 49 | vTele decls = [ (i, typ) | VTDecl id ids typ <- decls, i <- id:ids ] 50 | 51 | -- turns an expression of the form App (... (App id1 id2) ... idn) 52 | -- into a list of idents 53 | pseudoIdents :: Exp -> Maybe [AIdent] 54 | pseudoIdents = mapM unVar . uncurry (:) . flip unApps [] 55 | 56 | pseudoTele :: [PseudoTDecl] -> Maybe Tele 57 | pseudoTele [] = return [] 58 | pseudoTele (PseudoTDecl exp typ : pd) = do 59 | ids <- pseudoIdents exp 60 | pt <- pseudoTele pd 61 | return $ map (,typ) ids ++ pt 62 | 63 | ------------------------------------------------------------------------------- 64 | -- | Resolver and environment 65 | 66 | type Arity = Int 67 | 68 | data SymKind = Variable | Constructor Arity 69 | deriving (Eq,Show) 70 | 71 | -- local environment for constructors 72 | data Env = Env { envModule :: String, 73 | variables :: [(C.Binder,SymKind)] } 74 | deriving (Eq, Show) 75 | 76 | type Resolver a = ReaderT Env (ErrorT String Identity) a 77 | 78 | emptyEnv :: Env 79 | emptyEnv = Env "" [] 80 | 81 | runResolver :: Resolver a -> Either String a 82 | runResolver x = runIdentity $ runErrorT $ runReaderT x emptyEnv 83 | 84 | updateModule :: String -> Env -> Env 85 | updateModule mod e = e {envModule = mod} 86 | 87 | insertBinder :: (C.Binder,SymKind) -> Env -> Env 88 | insertBinder (x@(n,_),var) e 89 | | n == "_" || n == "undefined" = e 90 | | otherwise = e {variables = (x, var) : variables e} 91 | 92 | insertBinders :: [(C.Binder,SymKind)] -> Env -> Env 93 | insertBinders = flip $ foldr insertBinder 94 | 95 | insertVar :: C.Binder -> Env -> Env 96 | insertVar x = insertBinder (x,Variable) 97 | 98 | insertVars :: [C.Binder] -> Env -> Env 99 | insertVars = flip $ foldr insertVar 100 | 101 | insertCon :: (C.Binder,Arity) -> Env -> Env 102 | insertCon (x,a) = insertBinder (x,Constructor a) 103 | 104 | insertCons :: [(C.Binder,Arity)] -> Env -> Env 105 | insertCons = flip $ foldr insertCon 106 | 107 | getModule :: Resolver String 108 | getModule = envModule <$> ask 109 | 110 | getVariables :: Resolver [(C.Binder,SymKind)] 111 | getVariables = variables <$> ask 112 | 113 | getLoc :: (Int,Int) -> Resolver C.Loc 114 | getLoc l = C.Loc <$> getModule <*> pure l 115 | 116 | resolveBinder :: AIdent -> Resolver C.Binder 117 | resolveBinder (AIdent (l,x)) = (x,) <$> getLoc l 118 | 119 | -- Eta expand constructors 120 | expandConstr :: Arity -> String -> [Exp] -> Resolver Ter 121 | expandConstr a x es = do 122 | let r = a - length es 123 | binders = map (('_' :) . show) [1..r] 124 | args = map C.Var binders 125 | ts <- mapM resolveExp es 126 | return $ C.mkLams binders $ C.mkApps (C.Con x []) (ts ++ args) 127 | 128 | resolveVar :: AIdent -> Resolver Ter 129 | resolveVar (AIdent (l,x)) 130 | | (x == "_") || (x == "undefined") = C.PN <$> C.Undef <$> getLoc l 131 | | otherwise = do 132 | modName <- getModule 133 | vars <- getVariables 134 | case C.getIdent x vars of 135 | Just Variable -> return $ C.Var x 136 | Just (Constructor a) -> expandConstr a x [] 137 | _ -> throwError $ 138 | "Cannot resolve variable" <+> x <+> "at position" <+> 139 | show l <+> "in module" <+> modName 140 | 141 | lam :: AIdent -> Resolver Ter -> Resolver Ter 142 | lam a e = do x <- resolveBinder a; C.Lam x <$> local (insertVar x) e 143 | 144 | lams :: [AIdent] -> Resolver Ter -> Resolver Ter 145 | lams = flip $ foldr lam 146 | 147 | bind :: (Ter -> Ter -> Ter) -> (AIdent, Exp) -> Resolver Ter -> Resolver Ter 148 | bind f (x,t) e = f <$> resolveExp t <*> lam x e 149 | 150 | binds :: (Ter -> Ter -> Ter) -> Tele -> Resolver Ter -> Resolver Ter 151 | binds f = flip $ foldr $ bind f 152 | 153 | resolveExp :: Exp -> Resolver Ter 154 | resolveExp U = return C.U 155 | resolveExp (Var x) = resolveVar x 156 | resolveExp (App t s) = case unApps t [s] of 157 | (x@(Var (AIdent (_,n))),xs) -> do 158 | -- Special treatment in the case of a constructor in order not to 159 | -- eta expand too much 160 | vars <- getVariables 161 | case C.getIdent n vars of 162 | Just (Constructor a) -> expandConstr a n xs 163 | _ -> C.mkApps <$> resolveExp x <*> mapM resolveExp xs 164 | (x,xs) -> C.mkApps <$> resolveExp x <*> mapM resolveExp xs 165 | 166 | resolveExp (Sigma t b) = case pseudoTele t of 167 | Just tele -> binds C.Sigma tele (resolveExp b) 168 | Nothing -> throwError "Telescope malformed in Sigma" 169 | resolveExp (Pi t b) = case pseudoTele t of 170 | Just tele -> binds C.Pi tele (resolveExp b) 171 | Nothing -> throwError "Telescope malformed in Pigma" 172 | resolveExp (Fun a b) = bind C.Pi (AIdent ((0,0),"_"), a) (resolveExp b) 173 | resolveExp (Lam x xs t) = lams (x:xs) (resolveExp t) 174 | resolveExp (Fst t) = C.Fst <$> resolveExp t 175 | resolveExp (Snd t) = C.Snd <$> resolveExp t 176 | resolveExp (Pair t0 t1) = C.SPair <$> resolveExp t0 <*> resolveExp t1 177 | resolveExp (Split brs) = do 178 | brs' <- mapM resolveBranch brs 179 | loc <- getLoc (case brs of Branch (AIdent (l,_)) _ _:_ -> l ; _ -> (0,0)) 180 | return $ C.Split loc brs' 181 | resolveExp (Let decls e) = do 182 | (rdecls,names) <- resolveDecls decls 183 | C.mkWheres rdecls <$> local (insertBinders names) (resolveExp e) 184 | 185 | resolveWhere :: ExpWhere -> Resolver Ter 186 | resolveWhere = resolveExp . unWhere 187 | 188 | resolveBranch :: Branch -> Resolver (C.Label,([C.Binder],C.Ter)) 189 | resolveBranch (Branch lbl args e) = do 190 | binders <- mapM resolveBinder args 191 | re <- local (insertVars binders) $ resolveWhere e 192 | return (unAIdent lbl, (binders, re)) 193 | 194 | resolveTele :: [(AIdent,Exp)] -> Resolver C.Tele 195 | resolveTele [] = return [] 196 | resolveTele ((i,d):t) = do 197 | x <- resolveBinder i 198 | ((x,) <$> resolveExp d) <:> local (insertVar x) (resolveTele t) 199 | 200 | resolveLabel :: Label -> Resolver (C.Binder, C.Tele) 201 | resolveLabel (Label n vdecl) = 202 | (,) <$> resolveBinder n <*> resolveTele (vTele vdecl) 203 | 204 | declsLabels :: [Decl] -> Resolver [(C.Binder,Arity)] 205 | declsLabels decls = do 206 | let sums = concat [sum | DeclData _ _ sum <- decls] 207 | sequence [ (,length args) <$> resolveBinder lbl | Label lbl args <- sums ] 208 | 209 | -- Resolve Data or Def declaration 210 | resolveDDecl :: Decl -> Resolver (C.Ident, C.Ter) 211 | resolveDDecl (DeclDef (AIdent (_,n)) args body) = 212 | (n,) <$> lams args (resolveWhere body) 213 | resolveDDecl (DeclData x@(AIdent (l,n)) args sum) = 214 | (n,) <$> lams args (C.Sum <$> resolveBinder x <*> mapM resolveLabel sum) 215 | resolveDDecl d = throwError $ "Definition expected" <+> show d 216 | 217 | -- Resolve mutual declarations (possibly one) 218 | resolveMutuals :: [Decl] -> Resolver (C.Decls,[(C.Binder,SymKind)]) 219 | resolveMutuals decls = do 220 | binders <- mapM resolveBinder idents 221 | cs <- declsLabels decls 222 | let cns = map (fst . fst) cs ++ names 223 | when (nub cns /= cns) $ 224 | throwError $ "Duplicated constructor or ident:" <+> show cns 225 | rddecls <- 226 | mapM (local (insertVars binders . insertCons cs) . resolveDDecl) ddecls 227 | when (names /= map fst rddecls) $ 228 | throwError $ "Mismatching names in" <+> show decls 229 | rtdecls <- resolveTele tdecls 230 | return ([ (x,t,d) | (x,t) <- rtdecls | (_,d) <- rddecls ], 231 | map (second Constructor) cs ++ map (,Variable) binders) 232 | where 233 | idents = [ x | DeclType x _ <- decls ] 234 | names = [ unAIdent x | x <- idents ] 235 | tdecls = [ (x,t) | DeclType x t <- decls ] 236 | ddecls = filter (not . isTDecl) decls 237 | isTDecl d = case d of DeclType{} -> True; _ -> False 238 | 239 | -- Resolve opaque/transparent decls 240 | resolveOTDecl :: (C.Binder -> C.ODecls) -> AIdent -> [Decl] -> 241 | Resolver ([C.ODecls],[(C.Binder,SymKind)]) 242 | resolveOTDecl c n ds = do 243 | vars <- getVariables 244 | (rest,names) <- resolveDecls ds 245 | case C.getBinder (unAIdent n) vars of 246 | Just x -> return (c x : rest, names) 247 | Nothing -> throwError $ "Not in scope:" <+> show n 248 | 249 | -- Resolve declarations 250 | resolveDecls :: [Decl] -> Resolver ([C.ODecls],[(C.Binder,SymKind)]) 251 | resolveDecls [] = return ([],[]) 252 | resolveDecls (DeclOpaque n:ds) = resolveOTDecl C.Opaque n ds 253 | resolveDecls (DeclTransp n:ds) = resolveOTDecl C.Transp n ds 254 | resolveDecls (td@DeclType{}:d:ds) = do 255 | (rtd,names) <- resolveMutuals [td,d] 256 | (rds,names') <- local (insertBinders names) $ resolveDecls ds 257 | return (C.ODecls rtd : rds, names' ++ names) 258 | resolveDecls (DeclPrim x t:ds) = case C.mkPN (unAIdent x) of 259 | Just pn -> do 260 | b <- resolveBinder x 261 | rt <- resolveExp t 262 | (rds,names) <- local (insertVar b) $ resolveDecls ds 263 | return (C.ODecls [(b, rt, C.PN pn)] : rds, names ++ [(b,Variable)]) 264 | Nothing -> throwError $ "Primitive notion not defined:" <+> unAIdent x 265 | resolveDecls (DeclMutual defs : ds) = do 266 | (rdefs,names) <- resolveMutuals defs 267 | (rds, names') <- local (insertBinders names) $ resolveDecls ds 268 | return (C.ODecls rdefs : rds, names' ++ names) 269 | resolveDecls (decl:_) = throwError $ "Invalid declaration:" <+> show decl 270 | 271 | resolveModule :: Module -> Resolver ([C.ODecls],[(C.Binder,SymKind)]) 272 | resolveModule (Module n imports decls) = 273 | local (updateModule $ unAIdent n) $ resolveDecls decls 274 | 275 | resolveModules :: [Module] -> Resolver ([C.ODecls],[(C.Binder,SymKind)]) 276 | resolveModules [] = return ([],[]) 277 | resolveModules (mod:mods) = do 278 | (rmod, names) <- resolveModule mod 279 | (rmods,names') <- local (insertBinders names) $ resolveModules mods 280 | return (rmod ++ rmods, names' ++ names) 281 | -------------------------------------------------------------------------------- /Exp.cf: -------------------------------------------------------------------------------- 1 | entrypoints Module, Exp ; 2 | 3 | comment "--" ; 4 | comment "{-" "-}" ; 5 | 6 | layout "where", "let", "split", "mutual" ; 7 | layout stop "in" ; 8 | -- Do not use layout toplevel as it makes pExp fail! 9 | 10 | Module. Module ::= "module" AIdent "where" "{" [Imp] [Decl] "}" ; 11 | 12 | Import. Imp ::= "import" AIdent ; 13 | separator Imp ";" ; 14 | 15 | DeclDef. Decl ::= AIdent [AIdent] "=" ExpWhere ; 16 | DeclType. Decl ::= AIdent ":" Exp ; 17 | DeclPrim. Decl ::= "primitive" AIdent ":" Exp ; 18 | DeclData. Decl ::= "data" AIdent [AIdent] "=" [Label] ; 19 | DeclMutual. Decl ::= "mutual" "{" [Decl] "}" ; 20 | DeclOpaque. Decl ::= "opaque" AIdent ; 21 | DeclTransp. Decl ::= "transparent" AIdent ; 22 | separator Decl ";" ; 23 | 24 | Where. ExpWhere ::= Exp "where" "{" [Decl] "}" ; 25 | NoWhere. ExpWhere ::= Exp ; 26 | 27 | Let. Exp ::= "let" "{" [Decl] "}" "in" Exp ; 28 | Lam. Exp ::= "\\" AIdent [AIdent] "->" Exp ; 29 | Split. Exp ::= "split" "{" [Branch] "}" ; 30 | Fun. Exp1 ::= Exp2 "->" Exp1 ; 31 | Pi. Exp1 ::= [PseudoTDecl] "->" Exp1 ; 32 | Sigma. Exp1 ::= [PseudoTDecl] "*" Exp1 ; 33 | App. Exp2 ::= Exp2 Exp3 ; 34 | Fst. Exp3 ::= Exp3 ".1" ; 35 | Snd. Exp3 ::= Exp3 ".2" ; 36 | Pair. Exp3 ::= "(" Exp "," Exp ")" ; 37 | Var. Exp3 ::= AIdent ; 38 | U. Exp3 ::= "U" ; 39 | coercions Exp 3 ; 40 | 41 | -- Branches 42 | Branch. Branch ::= AIdent [AIdent] "->" ExpWhere ; 43 | separator Branch ";" ; 44 | 45 | -- Labelled sum alternatives 46 | Label. Label ::= AIdent [VTDecl] ; 47 | separator Label "|" ; 48 | 49 | -- Telescopes 50 | VTDecl. VTDecl ::= "(" AIdent [AIdent] ":" Exp ")" ; 51 | terminator VTDecl "" ; 52 | 53 | -- Nonempty telescopes with Exp:s, this is hack to avoid ambiguities 54 | -- in the grammar when parsing Pi 55 | PseudoTDecl. PseudoTDecl ::= "(" Exp ":" Exp ")" ; 56 | terminator nonempty PseudoTDecl "" ; 57 | 58 | position token AIdent ((letter|'\''|'_')(letter|digit|'\''|'_')*) ; 59 | terminator AIdent "" ; -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/simhu/cubical/53bab8a89246ec658d4a6436534242d0ce15eb35/LICENSE -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad.Trans.Reader 4 | import Control.Monad.Error 5 | import Data.List 6 | import System.Directory 7 | import System.FilePath 8 | import System.Environment 9 | import System.Console.GetOpt 10 | import System.Console.Haskeline 11 | 12 | import Exp.Lex 13 | import Exp.Par 14 | import Exp.Print 15 | import Exp.Abs 16 | import Exp.Layout 17 | import Exp.ErrM 18 | import Concrete 19 | import qualified TypeChecker as TC 20 | import qualified CTT as C 21 | import qualified Eval as E 22 | 23 | type Interpreter a = InputT IO a 24 | 25 | -- Flag handling 26 | data Flag = Help | Version 27 | deriving (Eq,Show) 28 | 29 | options :: [OptDescr Flag] 30 | options = [ Option "" ["help"] (NoArg Help) "print help" 31 | , Option "" ["version"] (NoArg Version) "print version number" ] 32 | 33 | -- Version number, welcome message, usage and prompt strings 34 | version, welcome, usage, prompt :: String 35 | version = "0.2.0" 36 | welcome = "cubical, version: " ++ version ++ " (:h for help)\n" 37 | usage = "Usage: cubical [options] \nOptions:" 38 | prompt = "> " 39 | 40 | lexer :: String -> [Token] 41 | lexer = resolveLayout True . myLexer 42 | 43 | showTree :: (Show a, Print a) => a -> IO () 44 | showTree tree = do 45 | putStrLn $ "\n[Abstract Syntax]\n\n" ++ show tree 46 | putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree 47 | 48 | -- Used for auto completion 49 | searchFunc :: [String] -> String -> [Completion] 50 | searchFunc ns str = map simpleCompletion $ filter (str `isPrefixOf`) ns 51 | 52 | settings :: [String] -> Settings IO 53 | settings ns = Settings 54 | { historyFile = Nothing 55 | , complete = completeWord Nothing " \t" $ return . searchFunc ns 56 | , autoAddHistory = True } 57 | 58 | main :: IO () 59 | main = do 60 | args <- getArgs 61 | case getOpt Permute options args of 62 | (flags,files,[]) 63 | | Help `elem` flags -> putStrLn $ usageInfo usage options 64 | | Version `elem` flags -> putStrLn version 65 | | otherwise -> case files of 66 | [] -> do 67 | putStrLn welcome 68 | runInputT (settings []) (loop flags [] [] TC.verboseEnv) 69 | [f] -> do 70 | putStrLn welcome 71 | putStrLn $ "Loading " ++ show f 72 | initLoop flags f 73 | _ -> putStrLn $ "Input error: zero or one file expected\n\n" ++ 74 | usageInfo usage options 75 | (_,_,errs) -> putStrLn $ "Input error: " ++ concat errs ++ "\n" ++ 76 | usageInfo usage options 77 | 78 | -- Initialize the main loop 79 | initLoop :: [Flag] -> FilePath -> IO () 80 | initLoop flags f = do 81 | -- Parse and type-check files 82 | (_,_,mods) <- imports True ([],[],[]) f 83 | -- Translate to CTT 84 | let res = runResolver $ resolveModules mods 85 | case res of 86 | Left err -> do 87 | putStrLn $ "Resolver failed: " ++ err 88 | runInputT (settings []) (loop flags f [] TC.verboseEnv) 89 | Right (adefs,names) -> do 90 | (merr,tenv) <- TC.runDeclss TC.verboseEnv adefs 91 | case merr of 92 | Just err -> putStrLn $ "Type checking failed: " ++ err 93 | Nothing -> return () 94 | putStrLn "File loaded." 95 | -- Compute names for auto completion 96 | runInputT (settings [n | ((n,_),_) <- names]) (loop flags f names tenv) 97 | 98 | -- The main loop 99 | loop :: [Flag] -> FilePath -> [(C.Binder,SymKind)] -> TC.TEnv -> Interpreter () 100 | loop flags f names tenv@(TC.TEnv _ rho _ _) = do 101 | input <- getInputLine prompt 102 | case input of 103 | Nothing -> outputStrLn help >> loop flags f names tenv 104 | Just ":q" -> return () 105 | Just ":r" -> lift $ initLoop flags f 106 | Just (':':'l':' ':str) 107 | | ' ' `elem` str -> do outputStrLn "Only one file allowed after :l" 108 | loop flags f names tenv 109 | | otherwise -> lift $ initLoop flags str 110 | Just (':':'c':'d':' ':str) -> do lift (setCurrentDirectory str) 111 | loop flags f names tenv 112 | Just ":h" -> outputStrLn help >> loop flags f names tenv 113 | Just str -> case pExp (lexer str) of 114 | Bad err -> outputStrLn ("Parse error: " ++ err) >> loop flags f names tenv 115 | Ok exp -> 116 | case runResolver $ local (insertBinders names) $ resolveExp exp of 117 | Left err -> do outputStrLn ("Resolver failed: " ++ err) 118 | loop flags f names tenv 119 | Right body -> do 120 | x <- liftIO $ TC.runInfer tenv body 121 | case x of 122 | Left err -> do outputStrLn ("Could not type-check: " ++ err) 123 | loop flags f names tenv 124 | Right _ -> do 125 | let e = E.eval rho body 126 | outputStrLn ("EVAL: " ++ show e) 127 | loop flags f names tenv 128 | 129 | -- (not ok,loaded,already loaded defs) -> to load -> 130 | -- (new not ok, new loaded, new defs) 131 | -- the bool determines if it should be verbose or not 132 | imports :: Bool -> ([String],[String],[Module]) -> String -> 133 | IO ([String],[String],[Module]) 134 | imports v st@(notok,loaded,mods) f 135 | | f `elem` notok = putStrLn ("Looping imports in " ++ f) >> return ([],[],[]) 136 | | f `elem` loaded = return st 137 | | otherwise = do 138 | b <- doesFileExist f 139 | let prefix = dropFileName f 140 | if not b 141 | then putStrLn (f ++ " does not exist") >> return ([],[],[]) 142 | else do 143 | s <- readFile f 144 | let ts = lexer s 145 | case pModule ts of 146 | Bad s -> do 147 | putStrLn $ "Parse failed in " ++ show f ++ "\n" ++ show s 148 | return ([],[],[]) 149 | Ok mod@(Module id imp decls) -> 150 | let name = unAIdent id 151 | imp_cub = [prefix ++ unAIdent i ++ ".cub" | Import i <- imp] 152 | in do 153 | when (name /= dropExtension (takeFileName f)) $ 154 | error $ "Module name mismatch " ++ show (f,name) 155 | (notok1,loaded1,mods1) <- 156 | foldM (imports v) (f:notok,loaded,mods) imp_cub 157 | when v $ putStrLn $ "Parsed " ++ show f ++ " successfully!" 158 | return (notok,f:loaded1,mods1 ++ [mod]) 159 | 160 | help :: String 161 | help = "\nAvailable commands:\n" ++ 162 | " infer type and evaluate statement\n" ++ 163 | " :q quit\n" ++ 164 | " :l loads filename (and resets environment before)\n" ++ 165 | " :cd change directory to path\n" ++ 166 | " :r reload\n" ++ 167 | " :h display this message\n" 168 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | OPT=0 2 | 3 | all: 4 | ghc --make -O$(OPT) -o cubical Main.hs 5 | debug: 6 | ghc --make -Ddebugmode -O$(OPT) -o cubical Main.hs 7 | bnfc: 8 | bnfc --haskell -d Exp.cf 9 | happy -gca Exp/Par.y 10 | alex -g Exp/Lex.x 11 | ghc --make -O$(OPT) Exp/Test.hs -o Exp/Test 12 | clean: 13 | rm -f *.log *.aux *.hi *.o cubical 14 | cd Exp && rm -f ParExp.y LexExp.x LexhExp.hs \ 15 | ParExp.hs PrintExp.hs AbsExp.hs *.o *.hi 16 | tests: 17 | ghc --make -O2 -main-is Tests.main Tests.hs 18 | 19 | -------------------------------------------------------------------------------- /Pretty.hs: -------------------------------------------------------------------------------- 1 | -- Common functions used for pretty printing. 2 | module Pretty where 3 | 4 | -------------------------------------------------------------------------------- 5 | -- | Pretty printing combinators. Use the same names as in the pretty library. 6 | 7 | (<+>) :: String -> String -> String 8 | [] <+> y = y 9 | x <+> [] = x 10 | x <+> y = x ++ " " ++ y 11 | 12 | infixl 6 <+> 13 | 14 | hcat :: [String] -> String 15 | hcat [] = [] 16 | hcat [x] = x 17 | hcat (x:xs) = x <+> hcat xs 18 | 19 | ccat :: [String] -> String 20 | ccat [] = [] 21 | ccat [x] = x 22 | ccat (x:xs) = x <+> "," <+> ccat xs 23 | 24 | parens :: String -> String 25 | parens [] = "" 26 | parens p = "(" ++ p ++ ")" 27 | 28 | -- Angled brackets, not present in pretty library. 29 | abrack :: String -> String 30 | abrack [] = "" 31 | abrack p = "<" ++ p ++ ">" 32 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | CUBICAL 2 | ======= 3 | 4 | Cubical implements an experimental simple type-checker for type theory 5 | with univalence with an evaluator for closed terms. 6 | 7 | 8 | INSTALL 9 | ------- 10 | 11 | To install cubical, a working Haskell and cabal installation are 12 | required. To build cubical go to the main directory and do 13 | 14 | `cabal install` 15 | 16 | To only build (not install) cubical do 17 | 18 | `cabal configure` 19 | 20 | `cabal build` 21 | 22 | Alternatively one can also use the Makefile to build the system by 23 | typing: 24 | 25 | `make bnfc && make` 26 | 27 | However this requires that the following Haskell packages are 28 | installed: 29 | 30 | mtl, haskeline, directory, BNFC, alex, happy 31 | 32 | 33 | **Note:** In order to make the mutual keyword work a patched version 34 | of BNFC is needed. To install this download the patched version from 35 | 36 | [https://github.com/simhu/bnfc](https://github.com/simhu/bnfc) 37 | 38 | and then `cabal install` it. 39 | 40 | ###Emacs mode: 41 | 42 | To install syntax highlighting for cubical files load the cubical.el 43 | file into emacs. In order to load it automatically add 44 | 45 | `(load-file "/path/to/cubical.el")` 46 | 47 | `(add-to-list 'auto-mode-alist '("\\.cub\\'" . cub-mode))` 48 | 49 | to your .emacs file. 50 | 51 | 52 | USAGE 53 | ----- 54 | 55 | To run cubical type 56 | 57 | `cubical ` 58 | 59 | To enable the debugging mode add the -d flag. In the interaction loop 60 | type :h to get a list of available commands. Note that the current 61 | directory will be taken as the search path for the imports. 62 | 63 | 64 | OVERVIEW 65 | -------- 66 | 67 | The program is organized as follows: 68 | 69 | * the files are parsed and produce a list of definitions; the syntax 70 | is described in the file Exp/Doc.txt or Exp/Doc.tex (auto generated 71 | by bnfc); 72 | 73 | * this list of definitions is type-checked; 74 | 75 | * if successful, we can then write an expression which is 76 | type-checked w.r.t. these definitions; 77 | 78 | * if the expression is well-typed it is translated to the cubical 79 | syntax and evaluated by a "cubical abstract machine", which 80 | computes its semantics in cubical sets; the result is shown after 81 | "EVAL:" (to enable the trace of the evaluation run cubical with the 82 | -d flag); 83 | 84 | During type-checking, we consider the primitives listed in 85 | examples/primitive.cub as non interpreted constants. The type-checker 86 | is in the file TypeChecker.hs and is rudimentary (200 lines), without good 87 | error messages. 88 | 89 | These primitives however have a meaning in cubical sets, and the 90 | evaluation function computes this meaning. This semantics/evaluation 91 | is described in the file Eval.hs, which is the main file. The most 92 | complex part corresponds to the computations witnessing that the 93 | universe has Kan filling operations. 94 | 95 | For writing this semantics, it was convenient to use the alternative 96 | presentation of cubical sets as nominal sets with 01-substitutions 97 | (see A. Pitts' note, references listed below). 98 | 99 | The primitives needed to get univalence [are](notes/allprim.txt). 100 | 101 | 102 | DESCRIPTION OF THE LANGUAGE 103 | --------------------------- 104 | 105 | We have 106 | 107 | * dependent function types `(x:A) -> B`; non-dependent function types 108 | can be written as `A -> B` 109 | 110 | * abstraction `\x -> e` 111 | 112 | * named/labelled sum `c1 (x1:A1)...(xn:An) | c2 ... | ...` 113 | a data type is a recursively defined named sum 114 | 115 | * function defined by case 116 | `f = split c1 x1 ... xn -> e1 | c2 ... -> ... | ...` 117 | 118 | * sigma types `(x:A) * B`, with the pair constructor (e1,e2) 119 | and eliminators e.1 and e.2 120 | 121 | * a universe `U` and assume `U:U` for simplicity 122 | 123 | * let/where: `let D in e` where D is a list of definitions an 124 | alternative syntax is `e where D` 125 | 126 | * `undefined` like in Haskell 127 | 128 | * mutual definitions (this requires a patched version of BNFC, see 129 | the install instructions above). 130 | 131 | 132 | The syntax allows Landin's offside rule similar to Haskell. 133 | 134 | The basic (untyped) language has a direct simple denotational 135 | semantics. Type theory works with the total part of this language (it 136 | is possible to define totality at the denotational semantics level). 137 | Our evaluator works in a nominal version of this semantics. The 138 | type-checker assumes that we work in this total part, however, there 139 | is no termination check. 140 | 141 | 142 | DESCRIPTION OF THE SEMANTICS/EVALUATION 143 | --------------------------------------- 144 | 145 | The values depend on a new class of names, also called directions, 146 | which can be thought of as varying over the unit interval [0,1]. A 147 | path connecting a0 and a1 in the direction x is a value p(x) such that 148 | p(0) = a0 and p(1) = a1. An element in the identity type a0 = a1 is 149 | then of the form \p(x) where the name x is bound. An identity proof 150 | in an identity type will then be interpreted as a "square" of the form 151 | \\p(x,y). See examples/hedberg.cub and the example test3 (in the 152 | current implementation directions/names are represented by numbers). 153 | 154 | Operationally, a type is explained by giving what are its Kan filling 155 | operation. For instance, we have to explain what are the Kan filling 156 | for the dependent product. 157 | 158 | The main step for interpreting univalence is to transform an 159 | equivalence A -> B to a path in any direction x connecting A and B. 160 | This is a new basic element of the universe, called VEquivEq in the 161 | file Eval.hs which takes a name and arguments A,B,f and the proof that 162 | f is an equivalence. The main part of the work is then to explain the 163 | Kan filling operation for this new type. 164 | 165 | The Kan filling for the universe can be seen as a generalization of 166 | the operation of composition of relation. 167 | 168 | 169 | DESCRIPTION OF THE EXAMPLES 170 | --------------------------- 171 | 172 | The directory examples contains some examples of proofs. The file 173 | examples/primitive.cub list the new primitives that have cubical set 174 | semantics. These primitive notions imply the axiom of univalence. The 175 | file examples/primitive.cub should be the basis of any development 176 | using univalence. 177 | 178 | Most of the example files contain simple test examples of 179 | computations: 180 | 181 | * the file hedberg.cub contains a test computation of a square in 182 | Nat; the example is test. In the type Nat or Bool, any square 183 | (proof of identity of two identity proofs) is constant. 184 | 185 | * The file nIso.cub contains a non trivial example of a transport of 186 | a section of a dependent type along the isomorphism between N and 187 | N+1; the examples are testSN, testSN1, testSN2, testSN3. 188 | 189 | * The file testInh.cub contains examples of computation for the 190 | propositional reflection. It gives an example test which produces 191 | a (surprisingly complex) composition of squares in the universe. 192 | 193 | * The file quotient.cub contains an example of a computation from an 194 | equivalence class. The relation R over Nat is to have the same 195 | parity, and the map is Nat/R -> Bool which returns true if the 196 | equivalence class contains even number. The examples are test5 and 197 | test8 which computes the value of this map on the equivalence class 198 | of five and eight respectively. This uses the file description.cub 199 | which justifies the axiom of description. 200 | 201 | * The file Kraus.cub contains the example of Nicolai Kraus of the 202 | myst function, which also shows that we can extract computational 203 | information from propositions; the example is testMyst zero; the 204 | computation does not create higher dimensional objects. 205 | 206 | * The file swap.cub contains examples of transport along the 207 | isomorphism between A x B and B x A; the examples are test14, 208 | test15. 209 | 210 | 211 | NEWS (to be detailed) 212 | ---- 213 | 214 | * Some constants have a direct cubical semantics having better 215 | behavior w.r.t. equality. For instance the constant 216 | 217 | `mapOnPath : (A B : U) (f : A -> B) (a b : A) 218 | (p : Id A a b) -> Id B (f a) (f b)` 219 | 220 | has a semantics which satisfies the definitional equalities: 221 | 222 | `mapOnPath (id A) = id A` 223 | 224 | `mapOnPath (g o f) = (mapOnPath g) o (mapOnPath f)` 225 | 226 | `mapOnPath f (refl A a) = refl B (f a)` 227 | 228 | The evaluation is now used for conversion during type-checking, 229 | and then we get these equalities definitionally. 230 | 231 | Some proofs are now much simpler than before, e.g. the proof of the 232 | Graduate Lemma. 233 | 234 | * Similarly we also have eta conversion and surjective pairing. 235 | 236 | * As a test, the particular case of the circle (S1) and the interval 237 | (I) has been added. 238 | 239 | 240 | FURTHER WORK (non-exhaustive) 241 | ------------ 242 | 243 | * The Kan filling operations should be formally proved correct and 244 | tested on higher inductive types. 245 | 246 | * For higher inductive types, like the circle or the sphere, it would 247 | be appropriate to *extend* the syntax of type theory, in order to 248 | get natural elimination rules (see the paper on cubical sets). 249 | 250 | * To explore the termination of the resizing rule. Computationally 251 | the resizing rule does not do anything, but the termination seems 252 | to be an interesting proof-theoretical problem. 253 | 254 | 255 | REFERENCES AND NOTES 256 | -------------------- 257 | 258 | * Voevodsky's home page on univalent foundation 259 | 260 | * HoTT book and webpage: 261 | [http://homotopytypetheory.org/](http://homotopytypetheory.org/) 262 | 263 | * [Type Theory in Color](http://www.cse.chalmers.se/~bernardy/CCCC.pdf), J.P. Bernardy, G. Moulin 264 | 265 | * A simple type-theoretic language: Mini-TT, Th. Coquand, 266 | Y. Kinoshita, B. Nordström and M. Takeyama 267 | 268 | * [A cubical set model of type 269 | theory](http://www.cse.chalmers.se/~coquand/model1.pdf), M. Bezem, 270 | Th. Coquand and S. Huber. 271 | 272 | * [A remark on contractible family of 273 | type](http://www.cse.chalmers.se/~coquand/contr.pdf), Th. Coquand. 274 | 275 | This note explains how to derive univalence. 276 | 277 | * [An equivalent presentation of the Bezem-Coquand-Huber category of 278 | cubical sets](http://arxiv.org/abs/1401.7807), A. Pitts. 279 | 280 | This gives a presentation of the cubical set model in nominal sets. 281 | 282 | * [Remark on singleton 283 | types](http://www.cse.chalmers.se/~coquand/singl.pdf), Th. Coquand. 284 | 285 | * [Note on Kripke 286 | model](http://www.cse.chalmers.se/~coquand/countermodel.pdf), M. Bezem 287 | and Th. Coquand. 288 | 289 | * [Some connections between cubical sets and 290 | parametricity](http://www.cse.chalmers.se/~coquand/param.pdf), 291 | Th. Coquand. 292 | 293 | 294 | AUTHORS 295 | ------- 296 | 297 | Cyril Cohen, Thierry Coquand, Simon Huber, Anders Mörtberg 298 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | import Distribution.Simple 3 | import System.Directory 4 | import System.Process 5 | import System.Exit 6 | 7 | main :: IO () 8 | main = do 9 | b <- doesFileExist "Exp/Abs.hs" 10 | -- run bnfc if Exp/Abs.hs does not exist 11 | when (not b) bnfc 12 | t1 <- getModificationTime "Exp.cf" 13 | t2 <- getModificationTime "Exp" 14 | -- run bnfc if Exp.cf has been modified 15 | when (t1 > t2) bnfc 16 | defaultMain 17 | where 18 | bnfc = do 19 | ret <- system "bnfc --haskell -d Exp.cf" 20 | case ret of 21 | ExitSuccess -> defaultMain 22 | ExitFailure n -> error $ "bnfc command not found or error" ++ show n 23 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | TODO: 2 | *High priority* 3 | - reinsert names of sums 4 | - fix bug evalPN of Undef 5 | - review the code for the filling of the universe 6 | - find the right abstraction for Box manipulation 7 | (more functional, less association lists in the abstraction) 8 | - abstract names and dim (remove hack with {0,1} + ...) 9 | - find a characterization for neutral values 10 | - eta for constructors 11 | - reorganize the primitive notions 12 | - subst can be defined in terms of transport 13 | - J in terms of mapOnPath, transport and contractible 14 | - fix showVal for 15 | - VVar X(x1,...,xn), 16 | - Kan (remove extra parenthesis), ... 17 | 18 | *Undecided priority* 19 | - Quickcheck for box shapes? 20 | 21 | *Low priority* 22 | - rudimentary emacs mode (send the current buffer to a process) 23 | - namespacing 24 | - make the import system-independent 25 | -------------------------------------------------------------------------------- /Tests.hs: -------------------------------------------------------------------------------- 1 | -- | Unit testing - to run type "runghc Tests". 2 | -- Note: requires that HUnit is installed (cabal update && cabal install HUnit) 3 | module Tests where 4 | 5 | import Control.Monad.Error 6 | import Control.Monad.Reader 7 | import Prelude hiding (curry) 8 | import System.Directory 9 | import Test.HUnit hiding (Label) 10 | 11 | import Exp.Lex 12 | import Exp.Par 13 | import Exp.Abs 14 | import Exp.Layout 15 | import Exp.ErrM 16 | import Concrete 17 | import Pretty 18 | import qualified TypeChecker as TC 19 | import qualified CTT as C 20 | import qualified Eval as E 21 | import Main hiding (main) 22 | 23 | -- The folder where the tests are located 24 | folder :: FilePath 25 | folder = "examples/" 26 | 27 | loadFile :: FilePath -> IO C.OEnv 28 | loadFile f = do 29 | (_,_,mods) <- imports False ([],[],[]) f 30 | case runResolver (resolveModules mods) of 31 | Left err -> do assertFailure $ "Resolver failed:" <+> err <+> "on" <+> f 32 | return C.oEmpty 33 | Right (ds,_) -> TC.runDeclss TC.silentEnv ds >>= \(x,e) -> case x of 34 | Just err -> do assertFailure $ "Type checking failed:" <+> 35 | err <+> "on" <+> f 36 | return (TC.oenv e) 37 | Nothing -> return (TC.oenv e) 38 | 39 | testFile :: FilePath -> [(String,String)] -> IO () 40 | testFile f xs = do 41 | env <- loadFile f 42 | sequence_ [ do let v = E.eval env (C.Var n) 43 | assertEqual ("for" <+> n) output (show v) 44 | | (n,output) <- xs ] 45 | 46 | toTests :: String -> [(String,String)] -> Test 47 | toTests n = TestLabel n . TestCase . testFile (folder ++ n ++ ".cub") 48 | 49 | boolEqBool :: Test 50 | boolEqBool = toTests "BoolEqBool" [ ("testBool" ,"false") 51 | , ("newTestBool","true") 52 | , ("test2Bool" ,"false") 53 | , ("testT" ,"true") 54 | , ("testT'" ,"true") 55 | , ("testF" ,"false") 56 | , ("testTT1" ,"true") 57 | , ("testTF1" ,"true") 58 | , ("testFT1" ,"true") 59 | , ("testFF1" ,"false") 60 | , ("testTT2" ,"true") 61 | , ("testTF2" ,"true") 62 | , ("testFT2" ,"true") 63 | , ("testFF2" ,"false") 64 | , ("testTT2'" ,"<2> true") ] 65 | 66 | curry :: Test 67 | curry = toTests "curry" [ ("test" ,"zero") 68 | , ("test1","suc zero") 69 | , ("test2","zero") 70 | , ("test4","suc zero") 71 | , ("test5","suc zero") 72 | , ("test6","suc zero") ] 73 | 74 | finite :: Test 75 | finite = toTests "finite" [ ("test" ,"suc zero") ] 76 | 77 | heterogeneous :: Test 78 | heterogeneous = toTests "heterogeneous" 79 | [ ("test","\\A -> \\B -> \\a0 -> \\a1 -> \\b0 -> \\b1 -> " ++ 80 | "\\p -> \\q -> refl (Id A a0 a1) p") ] 81 | 82 | hedberg :: Test 83 | hedberg = toTests "hedberg" [ ("test3","<3> <4> zero") ] 84 | 85 | nIso :: Test 86 | nIso = toTests "nIso" [ ("testNO" ,"inl (suc (suc zero))") 87 | , ("testNO1","<3> inr tt") 88 | , ("testNO2","inr tt") 89 | , ("testNO3","inr tt") ] 90 | 91 | 92 | quotient :: Test 93 | quotient = toTests "quotient" [ ("test5","false") 94 | , ("test8","true") ] 95 | 96 | set :: Test 97 | set = toTests "set" [ ("test2" ,"<3> <4> tt") ] 98 | 99 | -- swap :: Test 100 | -- swap = toTests "swap" [ ("test6" ,"pair true (suc (suc zero))") 101 | -- , ("test7" ,"Com U (Box 1 2 Bool [])") 102 | -- , ("test8" ,"pair true (suc zero)") 103 | -- , ("test9" ,"pair true (suc (suc zero))") 104 | -- , ("test10" ,"pair true (suc zero)") 105 | -- , ("test11" ,"pair true (suc (suc zero))") 106 | -- , ("test12" ,"pair true zero") 107 | -- , ("test13" ,"Com U (Box 1 2 Bool [])") 108 | -- , ("test14" ,"pair true (vcomp (Box 1 4 false []))") 109 | -- , ("test15" ,"true") 110 | -- , ("test213","zero") 111 | -- , ("test214","pair true zero") 112 | -- , ("test215","true") ] 113 | 114 | turn :: Test 115 | turn = toTests "turn" [ ("test", "inr (suc (suc zero))") 116 | , ("test2", "inr (suc (suc (suc (suc (suc (suc zero))))))")] 117 | 118 | tests :: Test 119 | tests = TestList [boolEqBool,curry,finite,heterogeneous,hedberg,nIso,quotient,set,turn] 120 | 121 | main :: IO () 122 | main = void $ runTestTT tests 123 | -------------------------------------------------------------------------------- /TypeChecker.hs: -------------------------------------------------------------------------------- 1 | module TypeChecker ( runDecls 2 | , runDeclss 3 | , runInfer 4 | , TEnv(..) 5 | , verboseEnv 6 | , silentEnv 7 | ) where 8 | 9 | import Data.Either 10 | import Data.Function 11 | import Data.List 12 | import Data.Maybe 13 | import Data.Monoid hiding (Sum) 14 | import Control.Monad 15 | import Control.Monad.Trans 16 | import Control.Monad.Trans.Error hiding (throwError) 17 | import Control.Monad.Trans.Reader 18 | import Control.Monad.Error (throwError) 19 | import Control.Applicative 20 | import Pretty 21 | 22 | import CTT 23 | import Eval 24 | 25 | trace :: String -> Typing () 26 | trace s = do 27 | b <- asks verbose 28 | when b $ liftIO (putStrLn s) 29 | 30 | -- Type checking monad 31 | type Typing a = ReaderT TEnv (ErrorT String IO) a 32 | 33 | runTyping :: TEnv -> Typing a -> IO (Either String a) 34 | runTyping env t = runErrorT $ runReaderT t env 35 | 36 | -- Used in the interaction loop 37 | runDecls :: TEnv -> ODecls -> IO (Either String TEnv) 38 | runDecls tenv d = runTyping tenv $ do 39 | checkDecls d 40 | return $ addDecls d tenv 41 | 42 | runDeclss :: TEnv -> [ODecls] -> IO (Maybe String,TEnv) 43 | runDeclss tenv [] = return (Nothing, tenv) 44 | runDeclss tenv (d:ds) = do 45 | x <- runDecls tenv d 46 | case x of 47 | Right tenv' -> runDeclss tenv' ds 48 | Left s -> return (Just s, tenv) 49 | 50 | runInfer :: TEnv -> Ter -> IO (Either String Val) 51 | runInfer lenv e = runTyping lenv (checkInfer e) 52 | 53 | addC :: Ctxt -> (Tele,OEnv) -> [(Binder,Val)] -> Ctxt 54 | addC gam _ [] = gam 55 | addC gam ((y,a):as,nu) ((x,u):xus) = 56 | let v = eval nu a 57 | in addC ((x,v):gam) (as,oPair nu (y,u)) xus 58 | 59 | -- Extract the type of a label as a closure 60 | getLblType :: String -> Val -> Typing (Tele, OEnv) 61 | getLblType c (Ter (Sum _ cas) r) = case getIdent c cas of 62 | Just as -> return (as,r) 63 | Nothing -> throwError ("getLblType " ++ show c) 64 | getLblType c u = throwError ("expected a data type for the constructor " 65 | ++ c ++ " but got " ++ show u) 66 | 67 | -- Environment for type checker 68 | data TEnv = TEnv { index :: Int -- for de Bruijn levels 69 | , oenv :: OEnv 70 | , ctxt :: Ctxt 71 | , verbose :: Bool -- Should it be verbose and print 72 | -- what it typechecks? 73 | } 74 | deriving (Eq,Show) 75 | 76 | verboseEnv, silentEnv :: TEnv 77 | verboseEnv = TEnv 0 oEmpty [] True 78 | silentEnv = TEnv 0 oEmpty [] False 79 | 80 | addTypeVal :: (Binder,Val) -> TEnv -> TEnv 81 | addTypeVal p@(x,_) (TEnv k rho gam v) = 82 | TEnv (k+1) (oPair rho (x,mkVar k (support rho))) (p:gam) v 83 | 84 | addType :: (Binder,Ter) -> TEnv -> TEnv 85 | addType (x,a) tenv@(TEnv _ rho _ _) = addTypeVal (x,eval rho a) tenv 86 | 87 | addBranch :: [(Binder,Val)] -> (Tele,OEnv) -> TEnv -> TEnv 88 | addBranch nvs (tele,env) (TEnv k rho gam v) = 89 | let e = addC gam (tele,env) nvs 90 | in TEnv (k + length nvs) (upds rho nvs) e v 91 | 92 | addDecls :: ODecls -> TEnv -> TEnv 93 | addDecls od@(ODecls d) (TEnv k rho gam v) = 94 | let rho1 = oPDef True od rho 95 | es' = evals rho1 (declDefs d) 96 | gam' = addC gam (declTele d,rho) es' 97 | in TEnv k rho1 gam' v 98 | addDecls od tenv = tenv {oenv = oPDef True od (oenv tenv)} 99 | 100 | addTele :: Tele -> TEnv -> TEnv 101 | addTele xas lenv = foldl (flip addType) lenv xas 102 | 103 | getFresh :: Typing Val 104 | getFresh = mkVar <$> asks index <*> (support <$> asks oenv) 105 | 106 | checkDecls :: ODecls -> Typing () 107 | checkDecls (ODecls d) = do 108 | let (idents, tele, ters) = (declIdents d, declTele d, declTers d) 109 | trace ("Checking: " ++ unwords idents) 110 | checkTele tele 111 | rho <- asks oenv 112 | local (addTele tele) $ checks (tele,rho) ters 113 | checkDecls _ = return () 114 | 115 | checkTele :: Tele -> Typing () 116 | checkTele [] = return () 117 | checkTele ((x,a):xas) = do 118 | check VU a 119 | local (addType (x,a)) $ checkTele xas 120 | 121 | check :: Val -> Ter -> Typing () 122 | check a t = case (a,t) of 123 | (_,Con c es) -> do 124 | (bs,nu) <- getLblType c a 125 | checks (bs,nu) es 126 | (VU,Pi a (Lam x b)) -> do 127 | check VU a 128 | local (addType (x,a)) $ check VU b 129 | (VU,Sigma a (Lam x b)) -> do 130 | check VU a 131 | local (addType (x,a)) $ check VU b 132 | (VU,Sum _ bs) -> sequence_ [checkTele as | (_,as) <- bs] 133 | (VPi (Ter (Sum _ cas) nu) f,Split _ ces) -> do 134 | let cas' = sortBy (compare `on` fst . fst) cas 135 | ces' = sortBy (compare `on` fst) ces 136 | if map (fst . fst) cas' == map fst ces' 137 | then sequence_ [ checkBranch (as,nu) f brc 138 | | (brc, (_,as)) <- zip ces' cas' ] 139 | else throwError "case branches does not match the data type" 140 | (VPi a f,Lam x t) -> do 141 | var <- getFresh 142 | local (addTypeVal (x,a)) $ check (app f var) t 143 | (VSigma a f, SPair t1 t2) -> do 144 | check a t1 145 | e <- asks oenv 146 | check (app f (eval e t1)) t2 147 | (_,Where e d) -> do 148 | checkDecls d 149 | local (addDecls d) $ check a e 150 | (_,PN _) -> return () 151 | _ -> do 152 | v <- checkInfer t 153 | k <- asks index 154 | unless (conv k v a) $ 155 | throwError $ "check conv: " ++ show v ++ " /= " ++ show a 156 | 157 | checkBranch :: (Tele,OEnv) -> Val -> Brc -> Typing () 158 | checkBranch (xas,nu) f (c,(xs,e)) = do 159 | k <- asks index 160 | env <- asks oenv 161 | let d = support env 162 | l = length xas 163 | us = map (`mkVar` d) [k..k+l-1] 164 | local (addBranch (zip xs us) (xas,nu)) $ check (app f (VCon c us)) e 165 | 166 | checkInfer :: Ter -> Typing Val 167 | checkInfer e = case e of 168 | U -> return VU -- U : U 169 | Var n -> do 170 | gam <- asks ctxt 171 | case getIdent n gam of 172 | Just v -> return v 173 | Nothing -> throwError $ show n ++ " is not declared!" 174 | App t u -> do 175 | c <- checkInfer t 176 | case c of 177 | VPi a f -> do 178 | check a u 179 | rho <- asks oenv 180 | return $ app f (eval rho u) 181 | _ -> throwError $ show c ++ " is not a product" 182 | Fst t -> do 183 | c <- checkInfer t 184 | case c of 185 | VSigma a f -> return a 186 | _ -> throwError $ show c ++ " is not a sigma-type" 187 | Snd t -> do 188 | c <- checkInfer t 189 | case c of 190 | VSigma a f -> do 191 | e <- asks oenv 192 | return $ app f (fstSVal (eval e t)) 193 | _ -> throwError $ show c ++ " is not a sigma-type" 194 | Where t d -> do 195 | checkDecls d 196 | local (addDecls d) $ checkInfer t 197 | _ -> throwError ("checkInfer " ++ show e) 198 | 199 | checks :: (Tele,OEnv) -> [Ter] -> Typing () 200 | checks _ [] = return () 201 | checks ((x,a):xas,nu) (e:es) = do 202 | check (eval nu a) e 203 | rho <- asks oenv 204 | checks (xas,oPair nu (x,eval rho e)) es 205 | checks _ _ = throwError "checks" 206 | 207 | -- Not used since we have U : U 208 | -- 209 | -- (=?=) :: Typing Ter -> Ter -> Typing () 210 | -- m =?= s2 = do 211 | -- s1 <- m 212 | -- unless (s1 == s2) $ throwError (show s1 ++ " =/= " ++ show s2) 213 | -- 214 | -- checkTs :: [(String,Ter)] -> Typing () 215 | -- checkTs [] = return () 216 | -- checkTs ((x,a):xas) = do 217 | -- checkType a 218 | -- local (addType (x,a)) (checkTs xas) 219 | -- 220 | -- checkType :: Ter -> Typing () 221 | -- checkType t = case t of 222 | -- U -> return () 223 | -- Pi a (Lam x b) -> do 224 | -- checkType a 225 | -- local (addType (x,a)) (checkType b) 226 | -- _ -> checkInfer t =?= U 227 | -------------------------------------------------------------------------------- /cubical.cabal: -------------------------------------------------------------------------------- 1 | name: cubical 2 | -- Same version as in Main.hs? 3 | version: 0.2.0 4 | synopsis: Implementation of Univalence in Cubical Sets 5 | description: Cubical implements an experimental simple type 6 | checker for type theory with univalence with an 7 | evaluator for closed terms. 8 | homepage: https://github.com/simhu/cubical 9 | extra-source-files: Makefile, README.md, Exp.cf, examples/*.cub, cubical.el 10 | license: MIT 11 | license-file: LICENSE 12 | author: Cyril Cohen, Thierry Coquand, Simon Huber, Anders Mörtberg 13 | maintainer: mortberg@chalmers.se 14 | category: Dependent Types 15 | build-type: Custom 16 | cabal-version: >=1.10 17 | 18 | executable cubical 19 | main-is: Main.hs 20 | other-modules: Exp.Lex, Exp.Par 21 | other-extensions: TupleSections, ParallelListComp, CPP, MagicHash 22 | build-depends: base >= 4.5 && < 5, transformers >= 0.3, mtl >= 2.1, 23 | haskeline >= 0.7, directory >= 1.2, array >= 0.4, 24 | BNFC >= 2.5, filepath >= 1.3 25 | build-tools: alex, happy 26 | default-language: Haskell98 27 | hs-source-dirs: . 28 | other-modules: CTT, Concrete, Eval, Pretty, TypeChecker -------------------------------------------------------------------------------- /cubical.el: -------------------------------------------------------------------------------- 1 | ;; define several class of keywords 2 | (setq cub-keywords '("data" "import" "mutual" "let" "in" "split" 3 | "module" "where" "U") ) 4 | (setq cub-special '("undefined" "primitive")) 5 | 6 | ;; create regex strings 7 | (setq cub-keywords-regexp (regexp-opt cub-keywords 'words)) 8 | (setq cub-operators-regexp (regexp-opt '(":" "->" "=" "\\" "|" "\\" "*" "_") t)) 9 | (setq cub-special-regexp (regexp-opt cub-special 'words)) 10 | (setq cub-def-regexp "^[[:word:]]+") 11 | 12 | ;; clear memory 13 | (setq cub-keywords nil) 14 | (setq cub-special nil) 15 | 16 | ;; create the list for font-lock. 17 | ;; each class of keyword is given a particular face 18 | (setq cub-font-lock-keywords 19 | `( 20 | (,cub-keywords-regexp . font-lock-type-face) 21 | (,cub-operators-regexp . font-lock-variable-name-face) 22 | (,cub-special-regexp . font-lock-warning-face) 23 | (,cub-def-regexp . font-lock-function-name-face) 24 | )) 25 | 26 | ;; command to comment/uncomment text 27 | (defun cub-comment-dwim (arg) 28 | "Comment or uncomment current line or region in a smart way. For detail, see `comment-dwim'." 29 | (interactive "*P") 30 | (require 'newcomment) 31 | (let ((comment-start "--") (comment-end "")) 32 | (comment-dwim arg))) 33 | 34 | 35 | ;; syntax table for comments, same as for haskell-mode 36 | (defvar cub-syntax-table 37 | (let ((st (make-syntax-table))) 38 | (modify-syntax-entry ?\{ "(}1nb" st) 39 | (modify-syntax-entry ?\} "){4nb" st) 40 | (modify-syntax-entry ?- "_ 123" st) 41 | (modify-syntax-entry ?\n ">" st) 42 | st)) 43 | 44 | ;; define the mode 45 | (define-derived-mode cub-mode fundamental-mode 46 | "cubical mode" 47 | "Major mode for editing cubical files…" 48 | 49 | :syntax-table cub-syntax-table 50 | 51 | ;; code for syntax highlighting 52 | (setq font-lock-defaults '(cub-font-lock-keywords)) 53 | (setq mode-name "cub") 54 | 55 | ;; modify the keymap 56 | (define-key cub-mode-map [remap comment-dwim] 'cub-comment-dwim) 57 | 58 | ;; clear memory 59 | (setq cub-keywords-regexp nil) 60 | (setq cub-operators-regexp nil) 61 | (setq cub-special-regexp nil) 62 | ) 63 | 64 | (provide 'cub-mode) 65 | -------------------------------------------------------------------------------- /examples/BoolEqBool.cub: -------------------------------------------------------------------------------- 1 | module BoolEqBool where 2 | 3 | import equivSet 4 | import hedberg 5 | 6 | notInj : (x y : Bool) -> Id Bool (not x) (not y) -> Id Bool x y 7 | notInj x y p = compUp Bool (not (not x)) x (not (not y)) y (notK x) (notK y) rem 8 | where 9 | rem : Id Bool (not (not x)) (not (not y)) 10 | rem = mapOnPath Bool Bool not (not x) (not y) p 11 | 12 | notFiber : Bool -> U 13 | notFiber b = fiber Bool Bool not b 14 | 15 | eqNotFiber : (b : Bool) -> (v v' : notFiber b) -> 16 | Id Bool v.1 v'.1 -> Id (notFiber b) v v' 17 | eqNotFiber b = 18 | eqPropFam Bool (\x -> Id Bool (not x) b) (\x -> boolIsSet (not x) b) 19 | 20 | sNot : (b : Bool) -> notFiber b 21 | sNot b = (not b, notK b) 22 | 23 | tNot : (b : Bool) (v : notFiber b) -> Id (notFiber b) (sNot b) v 24 | tNot b v = eqNotFiber b (sNot b) v rem 25 | where 26 | rem1 : Id Bool (not (not b)) (not v.1) 27 | rem1 = comp Bool (not (not b)) b (not v.1) (notK b) 28 | (inv Bool (not v.1) b v.2) 29 | 30 | rem : Id Bool (not b) v.1 31 | rem = notInj (not b) v.1 rem1 32 | 33 | -- Directly use equivEq 34 | eqBoolBool1 : Id U Bool Bool 35 | eqBoolBool1 = equivEq Bool Bool not sNot tNot 36 | 37 | monoidAndBool : Monoid Bool 38 | monoidAndBool = monoid true andBool andBoolA andBoolTrue andTrueBool 39 | 40 | monoidOrBool1 : Monoid Bool 41 | monoidOrBool1 = transMonoid Bool Bool eqBoolBool1 monoidAndBool 42 | 43 | zBool1 : Bool 44 | zBool1 = zm Bool monoidOrBool1 45 | 46 | orBool1 : Bool -> Bool -> Bool 47 | orBool1 = opm Bool monoidOrBool1 48 | 49 | -- It works to transfer proofs as well 50 | orBool1A : 51 | (a b c : Bool) -> Id Bool (orBool1 a (orBool1 b c)) (orBool1 (orBool1 a b) c) 52 | orBool1A = opmA Bool monoidOrBool1 53 | 54 | -- Check that we really get or 55 | testFF1 : Bool 56 | testFF1 = orBool1 false false 57 | 58 | testFT1: Bool 59 | testFT1 = orBool1 false true 60 | 61 | testTF1 : Bool 62 | testTF1 = orBool1 true false 63 | 64 | testTT1 : Bool 65 | testTT1 = orBool1 true true 66 | 67 | -- Use the necessary condition for sets instead 68 | eqBoolBool2 : Id U Bool Bool 69 | eqBoolBool2 = equivSet Bool Bool not not notK notInj boolIsSet 70 | 71 | monoidOrBool2 : Monoid Bool 72 | monoidOrBool2 = transMonoid Bool Bool eqBoolBool2 monoidAndBool 73 | 74 | orBool2 : Bool -> Bool -> Bool 75 | orBool2 = opm Bool monoidOrBool2 76 | 77 | -- Check that we get or again 78 | testFF2 : Bool 79 | testFF2 = orBool2 false false 80 | 81 | testFT2 : Bool 82 | testFT2 = orBool2 false true 83 | 84 | testTF2 : Bool 85 | testTF2 = orBool2 true false 86 | 87 | testTT2 : Bool 88 | testTT2 = orBool2 true true 89 | 90 | testTT2' : Id Bool (orBool false true) (orBool2 false true) 91 | testTT2' = refl Bool true 92 | 93 | ----------- 94 | transun : (A B : U) -> Id U A B -> (A -> A) -> (B -> B) 95 | transun = subst U (\X -> (X -> X)) 96 | 97 | transid : Bool -> Bool 98 | transid = transun Bool Bool eqBoolBool1 (\x -> x) 99 | 100 | testT : Bool 101 | testT = transid true 102 | 103 | testT' : Bool 104 | testT' = transun Bool Bool (refl U Bool) (\x -> x) true 105 | 106 | testF : Bool 107 | testF = transid false 108 | 109 | notEqBool : Bool -> Bool 110 | notEqBool = transport Bool Bool eqBoolBool1 111 | 112 | testBool : Bool 113 | testBool = notEqBool true 114 | 115 | compEqBool : Id U Bool Bool 116 | compEqBool = comp U Bool Bool Bool eqBoolBool1 eqBoolBool1 117 | 118 | transport' : (A B : U) -> Id U A B -> A -> B 119 | transport' = subst U (\x -> x) 120 | 121 | funCompEqBool : Bool -> Bool 122 | funCompEqBool = transport' Bool Bool compEqBool 123 | 124 | newTestBool : Bool 125 | newTestBool = funCompEqBool true 126 | 127 | newCompEqBool : Id U Bool Bool 128 | newCompEqBool = comp U Bool Bool Bool eqBoolBool1 (refl U Bool) 129 | 130 | test2Bool : Bool 131 | test2Bool = transport' Bool Bool newCompEqBool true -------------------------------------------------------------------------------- /examples/Kraus.cub: -------------------------------------------------------------------------------- 1 | module Kraus where 2 | 3 | import swapDisc 4 | import testInh 5 | 6 | -- we encode the example of Nicolai Kraus 7 | -- for this we need the impredicative encoding of propositional truncation 8 | 9 | -- swap with zero 10 | 11 | swZero : N -> N -> N 12 | swZero = swapF N eqN zero 13 | 14 | 15 | homogeneous : (x:N) -> Id ptU (N,x) (N,zero) 16 | homogeneous x = homogDec N eqN f0N f1N x zero 17 | 18 | -- test : (x:N) -> Id (Id ptU (N,x) (N,zero)) (homogeneous x) (homogeneous x) 19 | -- test x = refl (Id ptU (N,x) (N,zero)) (homogeneous x) 20 | 21 | -- the following type is a contractible, hence a proposition 22 | 23 | sNzero : U 24 | sNzero = singl ptU (N,zero) -- Sigma (Sigma U (id U)) (\ v -> Id ptU u (N,zero)) 25 | 26 | propSNzero : prop sNzero 27 | propSNzero = singlIsProp ptU (N,zero) 28 | 29 | -- we have a map inhI N -> sNzero, with the notation of Nicolai Kraus 30 | 31 | flifted : inhI N -> sNzero 32 | flifted = inhrecI N sNzero propSNzero (\ x -> ((N,x),homogeneous x)) 33 | 34 | Tmyst : inhI N -> U 35 | Tmyst x = (flifted x).1.1 36 | 37 | opaque homogeneous 38 | 39 | myst : (x: inhI N) -> Tmyst x 40 | myst x = (flifted x).1.2 41 | 42 | transparent homogeneous 43 | 44 | mystN : (n: N) -> Tmyst (incI N n) 45 | mystN n = myst (incI N n) 46 | 47 | propMyst : (n:N) -> Id N (myst (incI N n)) n 48 | propMyst n = refl N n 49 | 50 | testMyst : N -> N 51 | testMyst n = myst (incI N n) -------------------------------------------------------------------------------- /examples/UnotSet.cub: -------------------------------------------------------------------------------- 1 | module UnotSet where 2 | 3 | import BoolEqBool 4 | 5 | -- proves that U is not a set 6 | 7 | negUIP : neg (set U) 8 | negUIP uipU = tnotf lem5 9 | where 10 | eqreflnot : Id (Id U Bool Bool) (refl U Bool) eqBoolBool1 11 | eqreflnot = uipU Bool Bool (refl U Bool) eqBoolBool1 12 | 13 | frefl : Bool -> Bool 14 | frefl = transport Bool Bool (refl U Bool) 15 | 16 | fnot : Bool -> Bool 17 | fnot = transport Bool Bool eqBoolBool1 18 | 19 | lem1 : Id (Bool -> Bool) frefl fnot 20 | lem1 = mapOnPath (Id U Bool Bool) (Bool -> Bool) (transport Bool Bool) 21 | (refl U Bool) eqBoolBool1 eqreflnot 22 | 23 | lem2 : Id Bool true (frefl true) 24 | lem2 = transportRef Bool true 25 | 26 | lem3 : Id Bool false (fnot true) 27 | lem3 = transpEquivEq Bool Bool not sNot tNot true 28 | 29 | lem4 : Id Bool (frefl true) (fnot true) 30 | lem4 = mapOnPath (Bool -> Bool) Bool (\f -> f true) frefl fnot lem1 31 | 32 | lem5 : Id Bool true false 33 | lem5 = compDown Bool true (frefl true) false (fnot true) lem2 lem3 lem4 34 | 35 | -------------------------------------------------------------------------------- /examples/axChoice.cub: -------------------------------------------------------------------------------- 1 | module axChoice where 2 | 3 | import contr 4 | 5 | -- an interesting isomorphism/equality 6 | 7 | idTelProp : (A : U) (B : A -> U) (C : (x : A) -> B x -> U) -> 8 | Id U ((x : A) -> Sigma (B x) (C x)) 9 | (Sigma ((x : A) -> B x) (\f -> (x : A) -> C x (f x))) 10 | idTelProp A B C = isoId T0 T1 f g (refl T1) (refl T0) 11 | where 12 | T0 : U 13 | T0 = (x : A) -> Sigma (B x) (C x) 14 | 15 | T1 : U 16 | T1 = Sigma ((x : A) -> B x) (\f -> (x : A) -> C x (f x)) 17 | 18 | f : T0 -> T1 19 | f s = (\x -> (s x).1, \x -> (s x).2) 20 | 21 | g : T1 -> T0 22 | g z = \x -> (z.1 x, z.2 x) 23 | 24 | -- we deduce from this equality that isEquiv f is a proposition 25 | 26 | propIsEquiv : (A B : U) -> (f : A -> B) -> prop (isEquiv A B f) 27 | propIsEquiv A B f = 28 | subst U prop ((y:B) -> contr' (fiber A B f y)) (isEquiv A B f) rem rem1 29 | where 30 | rem : Id U ((y:B) -> contr' (fiber A B f y)) (isEquiv A B f) 31 | rem = idTelProp B (fiber A B f) 32 | (\y s -> (v : fiber A B f y) -> Id (fiber A B f y) s v) 33 | 34 | rem1 : prop ((y:B) -> contr' (fiber A B f y)) 35 | rem1 = isPropProd B (\y -> contr' (fiber A B f y)) 36 | (\y -> contr'IsProp (fiber A B f y)) 37 | -------------------------------------------------------------------------------- /examples/binnat.cub: -------------------------------------------------------------------------------- 1 | module binnat where 2 | 3 | import function 4 | import hedberg 5 | import gradLemma 6 | import elimEquiv 7 | 8 | -- Positive binary numbers like in Coq 9 | pos : U 10 | data pos = x1 (p : pos) | x0 (p : pos) | pos1 11 | 12 | sucPos : pos -> pos 13 | sucPos = split 14 | x1 p -> x0 (sucPos p) 15 | x0 p -> x1 p 16 | pos1 -> x0 pos1 17 | 18 | doubleN : N -> N 19 | doubleN = split 20 | zero -> zero 21 | suc n -> suc (suc (doubleN n)) 22 | 23 | PosToN : pos -> N 24 | PosToN = split 25 | pos1 -> suc zero 26 | x0 p -> doubleN (PosToN p) 27 | x1 p -> suc (doubleN (PosToN p)) 28 | 29 | posInd : (P : pos -> U) -> P pos1 -> ((p : pos) -> P p -> P (sucPos p)) -> ((p : pos) -> P p) 30 | posInd P h1 hS = 31 | let H : (p : pos) -> P (x0 p) -> P (x0 (sucPos p)) 32 | H p hx0p = hS (x1 p) (hS (x0 p) hx0p) 33 | in split 34 | pos1 -> h1 35 | x0 p -> posInd (\p -> P (x0 p)) (hS pos1 h1) H p 36 | x1 p -> hS (x0 p) (posInd (\p -> P (x0 p)) (hS pos1 h1) H p) 37 | 38 | sucPosSuc : (p : pos) -> Id N (PosToN (sucPos p)) (suc (PosToN p)) 39 | sucPosSuc = split 40 | pos1 -> refl N (suc (suc zero)) 41 | x0 p -> refl N (suc (doubleN (PosToN p))) 42 | x1 p -> mapOnPath N N doubleN (PosToN (sucPos p)) (suc (PosToN p)) (sucPosSuc p) 43 | 44 | zeronPosToN : (p : pos) -> neg (Id N zero (PosToN p)) 45 | zeronPosToN p = posInd (\p -> neg (Id N zero (PosToN p))) (\prf -> znots zero prf) hS p 46 | where 47 | hS : (p : pos) -> neg (Id N zero (PosToN p)) -> neg (Id N zero (PosToN (sucPos p))) 48 | hS p _ prf = znots (PosToN p) rem 49 | where 50 | rem : Id N zero (suc (PosToN p)) 51 | rem = comp N zero (PosToN (sucPos p)) (suc (PosToN p)) prf (sucPosSuc p) 52 | 53 | -- Inverse of PosToN: 54 | NtoPos' : N -> pos 55 | NtoPos' = split 56 | zero -> pos1 57 | suc n -> sucPos (NtoPos' n) 58 | 59 | NtoPos : N -> pos 60 | NtoPos = split 61 | zero -> pos1 62 | suc n -> NtoPos' n 63 | 64 | PosToNK : (n : N) -> Id N (PosToN (NtoPos (suc n))) (suc n) 65 | PosToNK = split 66 | zero -> refl N (suc zero) 67 | suc n -> 68 | let ih : Id N (suc (PosToN (NtoPos' n))) (suc (suc n)) 69 | ih = mapOnPath N N suc (PosToN (NtoPos (suc n))) (suc n) (PosToNK n) 70 | in comp N (PosToN (NtoPos (suc (suc n)))) (suc (PosToN (NtoPos' n))) 71 | (suc (suc n)) (sucPosSuc (NtoPos' n)) ih 72 | 73 | NtoPosSuc : (n : N) -> neg (Id N zero n) -> Id pos (NtoPos (suc n)) (sucPos (NtoPos n)) 74 | NtoPosSuc = split 75 | zero -> \p -> efq (Id pos (NtoPos (suc zero)) (sucPos (NtoPos zero))) (p (refl N zero)) 76 | suc n -> \_ -> refl pos (sucPos (NtoPos' n)) 77 | 78 | NtoPosK : retract pos N PosToN NtoPos 79 | NtoPosK p = posInd (\p -> Id pos (NtoPos (PosToN p)) p) (refl pos pos1) hS p 80 | where 81 | hS : (p : pos) -> 82 | Id pos (NtoPos (PosToN p)) p -> 83 | Id pos (NtoPos (PosToN (sucPos p))) (sucPos p) 84 | hS p hp = 85 | let H1 : Id pos (NtoPos (PosToN (sucPos p))) (NtoPos (suc (PosToN p))) 86 | H1 = mapOnPath N pos NtoPos (PosToN (sucPos p)) (suc (PosToN p)) (sucPosSuc p) 87 | 88 | H2 : Id pos (NtoPos (suc (PosToN p))) (sucPos (NtoPos (PosToN p))) 89 | H2 = NtoPosSuc (PosToN p) (zeronPosToN p) 90 | 91 | H3 : Id pos (sucPos (NtoPos (PosToN p))) (sucPos p) 92 | H3 = mapOnPath pos pos sucPos (NtoPos (PosToN p)) p hp 93 | in comp pos (NtoPos (PosToN (sucPos p))) (sucPos (NtoPos (PosToN p))) (sucPos p) 94 | (comp pos (NtoPos (PosToN (sucPos p))) (NtoPos (suc (PosToN p))) (sucPos (NtoPos (PosToN p))) H1 H2) 95 | H3 96 | 97 | posToNinj : injective pos N PosToN 98 | posToNinj = retractInj pos N PosToN NtoPos NtoPosK 99 | 100 | -- Binary natural numbers 101 | binN : U 102 | data binN = binN0 | binNpos (p : pos) 103 | 104 | NtoBinN : N -> binN 105 | NtoBinN = split 106 | zero -> binN0 107 | suc n -> binNpos (NtoPos (suc n)) 108 | 109 | BinNtoN : binN -> N 110 | BinNtoN = split 111 | binN0 -> zero 112 | binNpos p -> PosToN p 113 | 114 | NtoBinNK : section binN N BinNtoN NtoBinN 115 | NtoBinNK = split 116 | zero -> refl N zero 117 | suc n -> PosToNK n 118 | 119 | rem : (p : pos) -> Id binN (NtoBinN (PosToN (sucPos p))) (binNpos (sucPos p)) 120 | rem p = comp binN (NtoBinN (PosToN (sucPos p))) (binNpos (NtoPos (suc (PosToN p)))) 121 | (binNpos (sucPos p)) rem1 rem2 122 | where 123 | rem1 : Id binN (NtoBinN (PosToN (sucPos p))) (binNpos (NtoPos (suc (PosToN p)))) 124 | rem1 = mapOnPath N binN NtoBinN (PosToN (sucPos p)) (suc (PosToN p)) (sucPosSuc p) 125 | 126 | rem2 : Id binN (binNpos (NtoPos (suc (PosToN p)))) (binNpos (sucPos p)) 127 | rem2 = mapOnPath pos binN binNpos (NtoPos (suc (PosToN p))) (sucPos p) 128 | (comp pos (NtoPos (suc (PosToN p))) (sucPos (NtoPos (PosToN p))) (sucPos p) 129 | (NtoPosSuc (PosToN p) (zeronPosToN p)) 130 | (mapOnPath pos pos sucPos (NtoPos (PosToN p)) p (NtoPosK p))) 131 | 132 | lem1 : (p : pos) -> Id binN (NtoBinN (PosToN p)) (binNpos p) 133 | lem1 p = posInd (\p -> Id binN (NtoBinN (PosToN p)) (binNpos p)) (refl binN (binNpos pos1)) 134 | (\p _ -> rem p) p 135 | 136 | BinNtoNK : retract binN N BinNtoN NtoBinN 137 | BinNtoNK = split 138 | binN0 -> refl binN binN0 139 | binNpos p -> lem1 p 140 | 141 | IdbinNN : Id U binN N 142 | IdbinNN = isoId binN N BinNtoN NtoBinN NtoBinNK BinNtoNK 143 | 144 | binNMonoid : Monoid binN 145 | binNMonoid = transMonoidInv binN N IdbinNN monoidAddN 146 | 147 | zeroBinN : binN 148 | zeroBinN = zm binN binNMonoid 149 | 150 | addBinN : binN -> binN -> binN 151 | addBinN = opm binN binNMonoid 152 | 153 | addBinNA : (a b c : binN) -> 154 | Id binN (addBinN a (addBinN b c)) (addBinN (addBinN a b) c) 155 | addBinNA = opmA binN binNMonoid 156 | 157 | test : binN 158 | test = addBinN (binNpos (x1 (x1 (x0 pos1)))) (binNpos (x0 (x0 (x0 (x1 pos1))))) 159 | 160 | -- Doubling 161 | 162 | one : N 163 | one = suc zero 164 | 165 | two : N 166 | two = suc one 167 | 168 | three : N 169 | three = suc two 170 | 171 | four : N 172 | four = suc three 173 | 174 | five : N 175 | five = suc four 176 | 177 | -- doublesN n m = 2^n * m 178 | doublesN : N -> N -> N 179 | doublesN = split 180 | zero -> \m -> m 181 | suc n -> \m -> doublesN n (doubleN m) 182 | 183 | n1024 : N 184 | n1024 = doublesN (addN four four) four 185 | 186 | doubleBinN : binN -> binN 187 | doubleBinN = split 188 | binN0 -> binN0 189 | binNpos p -> binNpos (x0 p) 190 | 191 | doublesBinN : N -> binN -> binN 192 | doublesBinN = split 193 | zero -> \m -> m 194 | suc n -> \m -> doublesBinN n (doubleBinN m) 195 | 196 | -- Doubling structure 197 | Double : U 198 | data Double = 199 | D (A : U) -- carrier 200 | (double : A -> A) -- doubling function computing 2 * x 201 | (elt : A) -- element to double 202 | 203 | carrier : Double -> U 204 | carrier = split D c _ _ -> c 205 | 206 | double : (D : Double) -> (carrier D -> carrier D) 207 | double = split D _ op _ -> op 208 | 209 | elt : (D : Double) -> carrier D 210 | elt = split D _ _ e -> e 211 | 212 | DoubleN : Double 213 | DoubleN = D N doubleN n1024 214 | 215 | DoubleBinN : Double 216 | DoubleBinN = D binN doubleBinN (NtoBinN n1024) 217 | 218 | -- iterate 219 | iter : (A : U) -> N -> (A -> A) -> A -> A 220 | iter A = split 221 | zero -> \_ z -> z 222 | suc n -> \f z -> f (iter A n f z) 223 | 224 | -- 2^10 * e = 2^5 * (2^5 * e) 225 | propDouble : (D : Double) -> U 226 | propDouble D = Id (carrier D) (iter (carrier D) (doubleN five) (double D) (elt D)) 227 | (iter (carrier D) five (double D) (iter (carrier D) five (double D) (elt D))) 228 | 229 | -- The property we want to prove that takes long to typecheck: 230 | -- 2^10 * 1024 = 2^5 * (2^5 * 1024) 231 | -- propN : propDouble DoubleN 232 | -- propN = refl N (doublesN (addN five five) n1024) 233 | 234 | -- With binary numbers it is instant 235 | propBin : propDouble DoubleBinN 236 | propBin = refl binN (doublesBinN (addN five five) (elt DoubleBinN)) 237 | 238 | -- Define intermediate structure: 239 | doubleBinN' : binN -> binN 240 | doubleBinN' b = NtoBinN (doubleN (BinNtoN b)) 241 | 242 | DoubleBinN' : Double 243 | DoubleBinN' = D binN doubleBinN' (NtoBinN n1024) 244 | 245 | eqDouble1 : Id Double DoubleN DoubleBinN' 246 | eqDouble1 = elimIsIso N (\B f g -> Id Double DoubleN (D B (\b -> f (doubleN (g b))) (f n1024))) 247 | (refl Double DoubleN) binN NtoBinN BinNtoN BinNtoNK NtoBinNK 248 | 249 | eqDouble2 : Id Double DoubleBinN' DoubleBinN 250 | eqDouble2 = mapOnPath (binN -> binN) Double F doubleBinN' doubleBinN rem 251 | where 252 | F : (binN -> binN) -> Double 253 | F d = D binN d (NtoBinN n1024) 254 | 255 | rem : Id (binN -> binN) doubleBinN' doubleBinN 256 | rem = funExt binN (\_ -> binN) doubleBinN' doubleBinN rem1 257 | where 258 | rem1 : (n : binN) -> Id binN (doubleBinN' n) (doubleBinN n) 259 | rem1 = split 260 | binN0 -> refl binN binN0 261 | binNpos p -> 262 | let p1 : Id binN (NtoBinN (doubleN (PosToN p))) (NtoBinN (PosToN (x0 p))) 263 | p1 = mapOnPath N binN NtoBinN (doubleN (PosToN p)) (PosToN (x0 p)) (refl N (doubleN (PosToN p))) 264 | in comp binN (NtoBinN (doubleN (PosToN p))) (NtoBinN (PosToN (x0 p))) (binNpos (x0 p)) p1 (lem1 (x0 p)) 265 | 266 | eqDouble : Id Double DoubleN DoubleBinN 267 | eqDouble = comp Double DoubleN DoubleBinN' DoubleBinN eqDouble1 eqDouble2 268 | 269 | opaque doubleN 270 | 271 | -- goal : propDouble DoubleN 272 | -- goal = substInv Double propDouble DoubleN DoubleBinN eqDouble propBin -------------------------------------------------------------------------------- /examples/cong.cub: -------------------------------------------------------------------------------- 1 | module cong where 2 | 3 | import set 4 | import function 5 | 6 | -- All of these lemmas on mapOnPath will be trivial with definitional equalities 7 | 8 | congRefl : (A B : U) (f : A -> B) (a : A) -> 9 | Id (Id B (f a) (f a)) (refl B (f a)) (mapOnPath A B f a a (refl A a)) 10 | congRefl A B f a = refl (Id B (f a) (f a)) (refl B (f a)) 11 | 12 | congId : (A : U) (a0 a1 : A) -> 13 | Id (Id A a0 a1 -> Id A a0 a1) (id (Id A a0 a1)) (mapOnPath A A (id A) a0 a1) 14 | congId A a0 a1 = funExt (Id A a0 a1) (\_ -> Id A a0 a1) (id (Id A a0 a1)) 15 | (mapOnPath A A (id A) a0 a1) (rem a0 a1) 16 | where 17 | rem1 : (u : A) -> Id (Id A u u) (refl A u) (mapOnPath A A (id A) u u (refl A u)) 18 | rem1 = congRefl A A (id A) 19 | 20 | rem : (u0 u1 : A) -> (p : Id A u0 u1) -> Id (Id A u0 u1) p (mapOnPath A A (id A) u0 u1 p) 21 | rem u0 = J A u0 (\u1 p -> Id (Id A u0 u1) p (mapOnPath A A (id A) u0 u1 p)) (rem1 u0) 22 | 23 | congComp : (A B C : U) (f : A -> B) (g : B -> C) (a0 a1 : A) -> 24 | Id (Id A a0 a1 -> Id C (g (f a0)) (g (f a1))) 25 | (mapOnPath A C (\x -> g (f x)) a0 a1) 26 | (\p -> mapOnPath B C g (f a0) (f a1) (mapOnPath A B f a0 a1 p)) 27 | congComp A B C f g a0 a1 = funExt (Id A a0 a1) (\_ -> Tgf a0 a1) 28 | (conggf a0 a1) (\p -> congg a0 a1 (congf a0 a1 p)) (rem a0 a1) 29 | where 30 | Tgf : (a0 a1 : A) -> U 31 | Tgf a0 a1 = Id C (g (f a0)) (g (f a1)) 32 | 33 | congf : (a0 a1 : A) -> Id A a0 a1 -> Id B (f a0) (f a1) 34 | congf = mapOnPath A B f 35 | 36 | congg : (a0 a1 : A) -> Id B (f a0) (f a1) -> Tgf a0 a1 37 | congg a0 a1 = mapOnPath B C g (f a0) (f a1) 38 | 39 | conggf : (a0 a1 : A) -> Id A a0 a1 -> Tgf a0 a1 40 | conggf = mapOnPath A C (\x -> g (f x)) 41 | 42 | rem : (a0 a1 : A) (p : Id A a0 a1) -> 43 | Id (Tgf a0 a1) (conggf a0 a1 p) (congg a0 a1 (congf a0 a1 p)) 44 | rem a = J A a (\a1 p -> Id (Tgf a a1) (conggf a a1 p) (congg a a1 (congf a a1 p))) 45 | rem1 46 | where 47 | rem2 : Id (Tgf a a) (refl C (g (f a))) (conggf a a (refl A a)) 48 | rem2 = congRefl A C (\x -> g (f x)) a 49 | 50 | rem4 : Id (Id B (f a) (f a)) (refl B (f a)) (congf a a (refl A a)) 51 | rem4 = congRefl A B f a 52 | 53 | rem3 : Id (Tgf a a) (congg a a (refl B (f a))) (congg a a (congf a a (refl A a))) 54 | rem3 = mapOnPath (Id B (f a) (f a)) (Tgf a a) (congg a a) (refl B (f a)) 55 | (congf a a (refl A a)) rem4 56 | 57 | rem5 : Id (Tgf a a) (refl C (g (f a))) (congg a a (refl B (f a))) 58 | rem5 = congRefl B C g (f a) 59 | 60 | rem1 : Id (Tgf a a) (conggf a a (refl A a)) (congg a a (congf a a (refl A a))) 61 | rem1 = compUp (Tgf a a) (refl C (g (f a))) (conggf a a (refl A a)) 62 | (congg a a (refl B (f a))) (congg a a (congf a a (refl A a))) 63 | rem2 rem3 rem5 64 | 65 | 66 | -------------------------------------------------------------------------------- /examples/contr.cub: -------------------------------------------------------------------------------- 1 | module contr where 2 | 3 | import gradLemma 4 | 5 | -- a product of contractibles is contractible 6 | 7 | contr : U -> U 8 | contr A = Id U Unit A 9 | 10 | contrIsProp : (A : U) -> contr A -> prop A 11 | contrIsProp A cA = subst U prop Unit A cA propUnit 12 | 13 | propContr : (A : U) -> A -> prop A -> contr A 14 | propContr A a pA = propId Unit A propUnit pA (\_ -> a) (\_ -> tt) 15 | 16 | -- a singleton is a proposition 17 | 18 | singlIsProp : (A:U) (a:A) -> prop (singl A a) 19 | singlIsProp A a v0 v1 = 20 | comp (singl A a) v0 (sId A a) v1 21 | (inv (singl A a) (sId A a) v0 (tId A a v0)) (tId A a v1) 22 | 23 | -- another definition of contr 24 | 25 | contr' : U -> U 26 | contr' A = Sigma A (\a -> (x : A) -> Id A a x) 27 | 28 | -- this implies the other definition 29 | 30 | isContr : (A : U) -> contr' A -> contr A 31 | isContr A z = rem z.1 z.2 32 | where 33 | rem : (a : A) -> ((x : A) -> Id A a x) -> contr A 34 | rem a f = propContr A a (\ a0 a1 -> compInv A a a0 a1 (f a0) (f a1)) 35 | 36 | isContrProd : (A : U) (B : A->U) -> ((x : A) -> contr (B x)) -> contr (Pi A B) 37 | isContrProd A B pB = subst U contr (A->Unit) (Pi A B) rem1 rem2 38 | where 39 | rem : Id (A -> U) (\_ -> Unit) B 40 | rem = funExt A (\_ -> U) (\_ -> Unit) B pB 41 | 42 | rem1 : Id U (A -> Unit) (Pi A B) 43 | rem1 = mapOnPath (A -> U) U (Pi A) (\_ -> Unit) B rem 44 | 45 | f : Unit -> A -> Unit 46 | f z a = tt 47 | 48 | g : (A -> Unit) -> Unit 49 | g _ = tt 50 | 51 | sfg : (z : A -> Unit) -> Id (A -> Unit) (f (g z)) z 52 | sfg z = funExt A (\_ -> Unit) (f (g z)) z 53 | (\x -> propUnit (f (g z) x) (z x)) 54 | 55 | rfg : (z:Unit) -> Id Unit (g (f z)) z 56 | rfg z = propUnit (g (f z)) z 57 | 58 | rem2 : Id U Unit (A -> Unit) 59 | rem2 = isoId Unit (A -> Unit) f g sfg rfg 60 | 61 | -- a sigma of props over a prop is a prop 62 | 63 | sigIsProp : (A : U) (B : A -> U) (pB : (x : A) -> prop (B x)) -> 64 | prop A -> prop (Sigma A B) 65 | sigIsProp A B pB pA u v = 66 | eqSigma A B u.1 v.1 (pA u.1 v.1) u.2 v.2 67 | (pB v.1 (subst A B u.1 v.1 (pA u.1 v.1) u.2) v.2) 68 | 69 | contr'IsProp : (A : U) -> prop (contr' A) 70 | contr'IsProp A = lemProp1 (contr' A) rem 71 | where rem : contr' A -> prop (contr' A) 72 | rem z = sigIsProp A (\ a0 -> (x:A) -> Id A a0 x) rem3 rem1 73 | where 74 | rem1 : prop A 75 | rem1 a0 a1 = compInv A z.1 a0 a1 (z.2 a0) (z.2 a1) 76 | 77 | rem2 : (a0 a1:A) -> prop (Id A a0 a1) 78 | rem2 = propUIP A rem1 79 | 80 | rem3 : (a0:A) -> prop ((x:A) -> Id A a0 x) 81 | rem3 a0 = isPropProd A (Id A a0) (rem2 a0) 82 | 83 | -- Voevodsky's definition of propositions 84 | 85 | propIsContr : (A : U) -> prop A -> (a0 a1 : A) -> contr (Id A a0 a1) 86 | propIsContr A pA a0 a1 = propContr (Id A a0 a1) (pA a0 a1) (propUIP A pA a0 a1) 87 | 88 | -- if A is contractible and a:A then Sigma A P is equal to P a 89 | 90 | hasContrSig : U -> U 91 | hasContrSig A = (P : A -> U) -> (x : A) -> Id U (Sigma A P) (P x) 92 | 93 | lemUnitSig : hasContrSig Unit 94 | lemUnitSig P = split 95 | tt -> isoId T (P tt) f g rfg sfg 96 | where 97 | T : U 98 | T = Sigma Unit P 99 | 100 | f : T -> P tt 101 | f z = rem z.1 z.2 102 | where rem : (x : Unit) -> P x -> P tt 103 | rem = split tt -> \u -> u 104 | 105 | g : P tt -> T 106 | g u = (tt, u) 107 | 108 | rfg : (v : P tt) -> Id (P tt) (f (g v)) v 109 | rfg v = refl (P tt) v 110 | 111 | sfg : (v:T) -> Id T (g (f v)) v 112 | sfg z = rem z.1 z.2 113 | where rem : (x : Unit) -> (u : P x) -> Id T (g (f (x,u))) (x,u) 114 | rem = split tt -> \u -> refl T (tt, u) 115 | 116 | lemContrSig : (A : U) -> contr A -> hasContrSig A 117 | lemContrSig A p = subst U hasContrSig Unit A p lemUnitSig 118 | 119 | singContr : (A : U) (a : A) -> contr (singl A a) 120 | singContr A a = isContr T ((a, refl A a), f) 121 | where 122 | T : U 123 | T = singl A a 124 | 125 | f : (z : T) -> Id T (a, refl A a) z 126 | f z = rem z.1 a z.2 127 | where 128 | rem : (b : A) (a : A) (p : Id A b a) -> Id (singl A a) (a, refl A a) (b, p) 129 | rem b = J A b (\a p -> Id (singl A a) (a,refl A a) (b,p)) 130 | (refl (singl A b) (b, refl A b)) 131 | 132 | -- any function between two contractible types is an equivalence 133 | equivUnit : (f : Unit -> Unit) -> isEquiv Unit Unit f 134 | equivUnit f = subst (Unit -> Unit) (isEquiv Unit Unit) (id Unit) f rem 135 | (idIsEquiv Unit) 136 | where 137 | rem : Id (Unit -> Unit) (id Unit) f 138 | rem = funExt Unit (\_ -> Unit) (id Unit) f (\x -> propUnit x (f x)) 139 | 140 | -- an elimination principle for Contr 141 | elimContr : (P : U -> U) -> P Unit -> (A : U) -> contr A -> P A 142 | elimContr P d A cA = subst U P Unit A cA d 143 | 144 | equivContr : (A : U) -> contr A -> (B : U) -> contr B -> 145 | (f : A -> B) -> isEquiv A B f 146 | equivContr = 147 | elimContr (\A -> (B : U) -> contr B -> (f : A -> B) -> isEquiv A B f) rem 148 | where rem : (B : U) -> contr B -> (f : Unit -> B) -> isEquiv Unit B f 149 | rem = elimContr (\X -> (f : Unit -> X) -> isEquiv Unit X f) equivUnit 150 | -------------------------------------------------------------------------------- /examples/curry.cub: -------------------------------------------------------------------------------- 1 | module curry where 2 | 3 | import swap 4 | 5 | curry : (A B C:U) -> ((and A B) -> C) -> A -> B -> C 6 | curry A B C f a b = f (a,b) 7 | 8 | uncurry : (A B C:U) -> (A -> B -> C) -> (and A B) -> C 9 | uncurry A B C g z = g z.1 z.2 10 | 11 | eqCurry : (A B C : U) -> Id U ((and A B) -> C) (A -> B -> C) 12 | eqCurry A B C = 13 | isEquivEq T V (curry A B C) (gradLemma T V (curry A B C) (uncurry A B C) (refl V) (refl T)) 14 | where 15 | T:U 16 | T = (and A B) -> C 17 | V : U 18 | V = A -> B -> C 19 | 20 | typFst : U 21 | typFst = (X Y:U) -> (and X Y) -> X 22 | 23 | typFst1 : U 24 | typFst1 = (X Y:U) -> X -> Y -> X 25 | 26 | eqTest : Id U typFst typFst1 27 | eqTest = eqPi U (\ X -> Pi U (\ Y -> (and X Y) -> X)) (\ X -> Pi U (\ Y -> X -> Y -> X)) rem 28 | where 29 | rem : (X:U) -> Id U (Pi U (\ Y -> (and X Y) -> X)) (Pi U (\ Y -> X -> Y -> X)) 30 | rem X = eqPi U (\ Y -> (and X Y) -> X) (\ Y -> X -> Y -> X) rem1 31 | where 32 | rem1 : (Y:U) -> Id U ((and X Y) -> X) (X -> Y -> X) 33 | rem1 Y = eqCurry X Y X 34 | 35 | eqTestInv : Id U typFst1 typFst 36 | eqTestInv = inv U ((X Y:U) -> (and X Y) -> X) ((X Y:U) -> X -> Y -> X) eqTest 37 | 38 | test : N 39 | test = 40 | transport typFst typFst1 41 | eqTest (\ X Y z -> z.1) N Bool zero true 42 | 43 | test1 : N 44 | test1 = 45 | transport typFst typFst1 46 | eqTest (\ X Y z -> z.1) N Bool (suc zero) false 47 | 48 | test2 : N 49 | test2 = 50 | transport typFst1 typFst 51 | eqTestInv (\ X Y a b -> a) N Bool (zero,true) 52 | 53 | -- more test for the equality in U 54 | 55 | eqTest2 : Id U typFst typFst 56 | eqTest2 = comp U typFst typFst1 typFst eqTest eqTestInv 57 | 58 | eqTest3 : Id U typFst typFst1 59 | eqTest3 = comp U typFst typFst typFst1 eqTest2 eqTest 60 | 61 | eqTest4 : Id U typFst typFst 62 | eqTest4 = comp U typFst typFst1 typFst eqTest3 (inv U typFst typFst1 eqTest3) 63 | 64 | test4 : N 65 | test4 = 66 | transport typFst typFst 67 | eqTest2 (\ X Y z -> z.1) N Bool (suc zero,false) 68 | 69 | test5 : N 70 | test5 = 71 | transport typFst typFst1 72 | eqTest3 (\ X Y z -> z.1) N Bool (suc zero) false 73 | 74 | test6 : N 75 | test6 = 76 | transport typFst typFst 77 | eqTest4 (\ X Y z -> z.1) N Bool (suc zero,false) 78 | 79 | 80 | 81 | -------------------------------------------------------------------------------- /examples/description.cub: -------------------------------------------------------------------------------- 1 | module description where 2 | 3 | import exists 4 | import set 5 | 6 | exAtOne : (A : U) (B : A -> U) -> exactOne A B -> atmostOne A B 7 | exAtOne A B z = z.2 8 | 9 | propSig : (A : U) (B : A -> U) -> propFam A B -> atmostOne A B -> 10 | prop (Sigma A B) 11 | propSig A B h h' au bv = eqPropFam A B h au bv (h' au.1 bv.1 au.2 bv.2) 12 | 13 | descrAx : (A : U) (B : A -> U) -> propFam A B -> exactOne A B -> Sigma A B 14 | descrAx A B h z = lemInh (Sigma A B) (propSig A B h z.2) z.1 15 | 16 | iota : (A : U) (B : A -> U) (h : propFam A B) (h' : exactOne A B) -> A 17 | iota A B h h' = (descrAx A B h h').1 18 | 19 | iotaSound : (A : U) (B : A -> U) (h : propFam A B) (h' : exactOne A B) -> B (iota A B h h') 20 | iotaSound A B h h' = (descrAx A B h h').2 21 | 22 | iotaLem : (A : U) (B : A -> U) (h : propFam A B) (h' : exactOne A B) -> 23 | (a : A) -> B a -> Id A a (iota A B h h') 24 | iotaLem A B h h' a p = exAtOne A B h' a (iota A B h h') p (iotaSound A B h h') 25 | -------------------------------------------------------------------------------- /examples/elimEquiv.cub: -------------------------------------------------------------------------------- 1 | module elimEquiv where 2 | 3 | import univalence 4 | 5 | -- a corollary of equivalence 6 | 7 | allTransp : (A B : U) -> hasSection (Id U A B) (Equiv A B) (IdToEquiv A B) 8 | allTransp A B = equivSec (Id U A B) (Equiv A B) (IdToEquiv A B) (univAx A B) 9 | 10 | -- an induction principle for isEquiv 11 | 12 | transpRef : (A : U) -> Id (A->A) (id A) (transport A A (refl U A)) 13 | transpRef A = funExt A (\ _ -> A) (id A) (transport A A (refl U A)) (transportRef A) 14 | 15 | elimIsEquiv : (A:U) -> (P : (B:U) -> (A->B) -> U) -> P A (id A) -> 16 | (B :U) -> (f : A -> B) -> isEquiv A B f -> P B f 17 | elimIsEquiv A P d B f if = rem2 B (f,if) 18 | where 19 | rem1 : P A (transport A A (refl U A)) 20 | rem1 = subst (A->A) (P A) (id A) (transport A A (refl U A)) (transpRef A) d 21 | 22 | rem : (B:U) -> (p:Id U A B) -> P B (transport A B p) 23 | rem = J U A (\ B p -> P B (transport A B p)) rem1 24 | 25 | rem2 : (B:U) -> (p:Equiv A B) -> P B p.1 26 | rem2 B = allSection (Id U A B) (Equiv A B) (IdToEquiv A B) (allTransp A B) (\ p -> P B p.1) (rem B) 27 | 28 | 29 | -- a corollary 30 | 31 | elimIsIso : (A : U) -> (Q : (B : U) -> (A -> B) -> (B -> A) -> U) -> 32 | Q A (id A) (id A) -> (B : U) -> (f : A -> B) -> (g : B-> A) -> 33 | section A B f g -> retract A B f g -> Q B f g 34 | elimIsIso A Q d = rem1 35 | where 36 | P : (B : U) -> (A -> B) -> U 37 | P B f = (g : B-> A) -> section A B f g -> retract A B f g -> Q B f g 38 | 39 | rem : P A (id A) 40 | rem g sg rg = substInv (A -> A) (Q A (id A)) g (id A) rem1 d 41 | where rem1 : Id (A -> A) g (id A) 42 | rem1 = funExt A (\_ -> A) g (id A) sg 43 | 44 | rem1 : (B : U) -> (f : A->B) -> P B f 45 | rem1 B f g sg rg = elimIsEquiv A P rem B f (gradLemma A B f g sg rg) g sg rg -------------------------------------------------------------------------------- /examples/epi.cub: -------------------------------------------------------------------------------- 1 | -- the notion of surjection functions 2 | 3 | module epi where 4 | 5 | import omega 6 | import exists 7 | 8 | -- surjective and epi maps 9 | 10 | isEpi : (A B: U) -> (A -> B) -> U 11 | isEpi A B f = (X:U) -> set X -> (g h:B->X) -> Id (A->X) (\ a -> g (f a)) (\ a -> h (f a)) -> Id (B->X) g h 12 | 13 | isSurj : (A B:U) -> (A->B) -> U 14 | isSurj A B f = (y:B) -> exists A (\ x -> Id B (f x) y) 15 | 16 | -- these properties should be equivalent 17 | 18 | surjIsEpi : (A B : U) (f : A -> B) -> isSurj A B f -> isEpi A B f 19 | surjIsEpi A B f sf X sX g h egh = funExt B (\ _ -> X) g h rem 20 | where 21 | rem : (y:B) -> Id X (g y) (h y) 22 | rem y = rem6 23 | where 24 | G : U 25 | G = Id X (g y) (h y) 26 | 27 | rem1 : prop G 28 | rem1 = sX (g y) (h y) 29 | 30 | rem2 : exists A (\ x -> Id B (f x) y) 31 | rem2 = sf y 32 | 33 | rem4 : (x:A) -> Id X (g (f x)) (h (f x)) 34 | rem4 a = appId A X a (\ x -> g (f x)) (\ x -> h (f x)) egh 35 | 36 | rem3 : (x:A) -> Id B (f x) y -> G 37 | rem3 x p = subst B (\ z -> Id X (g z) (h z)) (f x) y p (rem4 x) 38 | 39 | rem5 : (Sigma A (\ x -> Id B (f x) y)) -> G 40 | rem5 z = rem3 z.1 z.2 41 | 42 | rem6 : G 43 | rem6 = exElim A (\ x -> Id B (f x) y) G rem1 rem5 rem2 44 | 45 | -- the converse is interesting 46 | 47 | epiIsSurj : (A B : U) (f : A -> B) -> isEpi A B f -> isSurj A B f 48 | epiIsSurj A B f ef = rem6 49 | where 50 | rem : (g h : B -> Omega) -> Id (A -> Omega) (\ x -> g (f x)) (\ x -> h (f x)) -> Id (B -> Omega) g h 51 | rem = ef Omega omegaIsSet 52 | 53 | g : B -> Omega 54 | g y = (Unit,propUnit) 55 | 56 | h : B -> Omega 57 | h y = (exists A (\ x -> Id B (f x) y),squash (Sigma A (\ x -> Id B (f x) y))) 58 | 59 | rem1 : (x:A) -> isTrue (h (f x)) 60 | rem1 x = inc (Sigma A (\ z -> Id B (f z) (f x))) (x,refl B (f x)) 61 | 62 | rem2 : (x:A) -> Id Omega (g (f x)) (h (f x)) 63 | rem2 x = lemIsTrue (g (f x)) (h (f x)) (\ _ -> rem1 x) (\ _ -> tt) 64 | 65 | rem3 : Id (A -> Omega) (\ x -> g (f x)) (\ x -> h (f x)) 66 | rem3 = funExt A (\ _ -> Omega) (\ x -> g (f x)) (\ x -> h (f x)) rem2 67 | 68 | rem4 : Id (B -> Omega) g h 69 | rem4 = rem g h rem3 70 | 71 | rem5 : (y:B) -> Id Omega (g y) (h y) 72 | rem5 y = appId B Omega y g h rem4 73 | 74 | rem6 : (y:B) -> isTrue (h y) 75 | rem6 y = subst Omega isTrue (g y) (h y) (rem5 y) tt 76 | -------------------------------------------------------------------------------- /examples/equivProp.cub: -------------------------------------------------------------------------------- 1 | module equivProp where 2 | 3 | import equivSet 4 | 5 | -- The goal is to prove that equivalent propositions are equal 6 | 7 | -- This is also proved using the grad lemma 8 | propExt : (A B : U) -> prop A -> prop B -> (A -> B) -> (B -> A) -> Id U A B 9 | propExt A B pA pB f g = equivSet A B f g sfg injf setB 10 | where 11 | sfg : section A B f g 12 | sfg b = pB (f (g b)) b 13 | 14 | injf : injective A B f 15 | injf a0 a1 _ = pA a0 a1 16 | 17 | setB : set B 18 | setB = propUIP B pB -------------------------------------------------------------------------------- /examples/equivSet.cub: -------------------------------------------------------------------------------- 1 | module equivSet where 2 | 3 | import function 4 | import set 5 | 6 | -- a sufficient condition for two sets being equal 7 | -- this is implied by the gradlemma, which has however a more complex proof 8 | 9 | equivSet : (A B : U) (f : A -> B) (g : B -> A) -> section A B f g -> 10 | injective A B f -> set B -> Id U A B 11 | equivSet A B f g sfg injf setB = equivEq A B f sf tf 12 | where 13 | fFiber : B -> U 14 | fFiber b = fiber A B f b 15 | 16 | eqfFiber : (b : B) -> (v v' : fFiber b) -> 17 | Id A v.1 v'.1 -> Id (fFiber b) v v' 18 | eqfFiber b = eqPropFam A (\x -> Id B (f x) b) (\x -> setB (f x) b) 19 | 20 | sf : (b : B) -> fFiber b 21 | sf b = (g b, sfg b) 22 | 23 | tf : (b : B) (v : fFiber b) -> Id (fFiber b) (sf b) v 24 | tf b v = eqfFiber b (sf b) v rem 25 | where 26 | rem1 : Id B (f (g b)) (f v.1) 27 | rem1 = comp B (f (g b)) b (f v.1) (sfg b) (inv B (f v.1) b v.2) 28 | 29 | rem : Id A (g b) v.1 30 | rem = injf (g b) v.1 rem1 31 | 32 | -------------------------------------------------------------------------------- /examples/equivTotal.cub: -------------------------------------------------------------------------------- 1 | module equivTotal where 2 | 3 | import elimEquiv 4 | 5 | -- equivalence on total space 6 | 7 | lem3Sub : (A:U) (P: A -> U) (a:A) -> Id U (Sigma (singl A a) (\ z -> P z.1)) (P a) 8 | lem3Sub A P a = lemContrSig (singl A a) (singContr A a) (\ x -> P x.1) (a,refl A a) 9 | 10 | -- a corollary of equivalence 11 | 12 | allTransp : (A B : U) -> hasSection (Id U A B) (Equiv A B) (IdToEquiv A B) 13 | allTransp A B = equivSec (Id U A B) (Equiv A B) (IdToEquiv A B) (univAx A B) 14 | 15 | -- an induction principle for isEquiv 16 | 17 | transpRef : (A : U) -> Id (A->A) (id A) (transport A A (refl U A)) 18 | transpRef A = funExt A (\ _ -> A) (id A) (transport A A (refl U A)) (transportRef A) 19 | 20 | elimIsEquiv : (A:U) -> (P : (B:U) -> (A->B) -> U) -> P A (id A) -> 21 | (B :U) -> (f : A -> B) -> isEquiv A B f -> P B f 22 | elimIsEquiv A P d = \ B f if -> rem2 B (f,if) 23 | where 24 | rem1 : P A (transport A A (refl U A)) 25 | rem1 = subst (A->A) (P A) (id A) (transport A A (refl U A)) (transpRef A) d 26 | 27 | rem : (B:U) -> (p:Id U A B) -> P B (transport A B p) 28 | rem = J U A (\ B p -> P B (transport A B p)) rem1 29 | 30 | rem2 : (B:U) -> (p:Equiv A B) -> P B p.1 31 | rem2 B = allSection (Id U A B) (Equiv A B) (IdToEquiv A B) (allTransp A B) 32 | (\ p -> P B p.1) (rem B) 33 | 34 | -- a simple application; with the problem with eta conversion resolved 35 | 36 | equivSigId : (A B :U) (f:A -> B) 37 | -> isEquiv A B f -> (Q : B -> U) -> Id U (Sigma A (\ x -> Q (f x))) (Sigma B Q) 38 | equivSigId A = elimIsEquiv A P (\ Q -> refl U (Sigma A Q)) 39 | where 40 | P : (B:U) -> (A-> B) -> U 41 | P B f = (Q : B -> U) -> Id U (Sigma A (\ x -> Q (f x))) (Sigma B Q) 42 | 43 | -- application to equivalences between total spaces 44 | 45 | liftTot : (A:U) (P Q : A -> U) (g : (x:A) -> P x -> Q x) -> Sigma A P -> Sigma A Q 46 | liftTot A P Q g z = (z.1,g z.1 z.2) 47 | 48 | lem3Sub : (A:U) (P: A -> U) (a:A) -> Id U (Sigma (singl A a) (\ z -> P z.1)) (P a) 49 | lem3Sub A P a = lemContrSig (singl A a) (singContr A a) (\ x -> P x.1) (a,refl A a) 50 | 51 | lem2Sub : (A:U) (P: A -> U) (a:A) 52 | -> Id U (fiber (Sigma A P) A (\x -> x.1) a) 53 | (Sigma (Sigma A (\ x -> Id A x a)) (\ z -> P z.1)) 54 | lem2Sub A P a = 55 | isoId F T (\ u -> ((u.1.1,u.2),u.1.2)) (\ v -> ((v.1.1,v.2),v.1.2)) (refl T) (refl F) 56 | where 57 | T : U 58 | T = Sigma (Sigma A (\ x -> Id A x a)) (\ z -> P z.1) 59 | 60 | F : U 61 | F = fiber (Sigma A P) A (\x -> x.1) a 62 | 63 | lem1Sub : (A:U) (P: A -> U) (a:A) -> Id U (fiber (Sigma A P) A (\ z -> z.1) a) (P a) 64 | lem1Sub A P a = 65 | comp U (fiber (Sigma A P) A (\ x -> x.1) a) 66 | (Sigma (singl A a) (\ z -> P z.1)) (P a) (lem2Sub A P a) (lem3Sub A P a) 67 | 68 | equivTot : (A:U) (P Q : A -> U) (g : (x:A) -> P x -> Q x) -> 69 | isEquiv (Sigma A P) (Sigma A Q) (liftTot A P Q g) -> (a:A) -> Id U (P a) (Q a) 70 | equivTot A P Q g igl a = rem5 71 | where 72 | F : Sigma A P -> U 73 | F z = Id A z.1 a 74 | 75 | T : U 76 | T = Sigma (Sigma A P) F 77 | 78 | G : Sigma A Q -> U 79 | G z = Id A z.1 a 80 | 81 | V : U 82 | V = Sigma (Sigma A Q) G 83 | 84 | rem : Id U T (P a) 85 | rem = lem1Sub A P a 86 | 87 | rem1 : Id U V (Q a) 88 | rem1 = lem1Sub A Q a 89 | 90 | F1 : Sigma A P -> U 91 | F1 z = G (liftTot A P Q g z) 92 | 93 | T1 : U 94 | T1 = Sigma (Sigma A P) F1 95 | 96 | rem2 : Id U T1 V 97 | rem2 = equivSigId (Sigma A P) (Sigma A Q) (liftTot A P Q g) igl G 98 | 99 | rem3 : Id U T T1 100 | rem3 = mapOnPath (Sigma A P -> U) U (Sigma (Sigma A P)) F F1 eFF1 101 | where fFF1 : (z : Sigma A P) -> Id U (F z) (F1 z) 102 | fFF1 z = refl U (Id A z.1 a) 103 | 104 | eFF1 : Id (Sigma A P -> U) F F1 105 | eFF1 = funExt (Sigma A P) (\ _ -> U) F F1 fFF1 106 | 107 | rem4 : Id U T V 108 | rem4 = comp U T T1 V rem3 rem2 109 | 110 | rem5 : Id U (P a) (Q a) 111 | rem5 = compUp U T (P a) V (Q a) rem rem1 rem4 112 | 113 | -- now we should be able to show that any map Id (Pi A B) f g -> (x:A) -> Id (B x) (f x) (g x) 114 | -- is an equivalence 115 | 116 | singlPi : (A:U) (B:A->U) -> Pi A B -> Pi A B -> U 117 | singlPi A B g f = (x:A) -> Id (B x) (f x) (g x) 118 | 119 | singlPiContr : (A:U) (B:A->U) (g:Pi A B) -> contr (Sigma (Pi A B) (singlPi A B g)) 120 | singlPiContr A B g = subst U contr ((x:A) -> Sigma (B x) (C x)) (Sigma (Pi A B) (\ z -> (x:A) -> C x (z x))) rem1 rem 121 | where 122 | C : (x:A) -> B x -> U 123 | C x y = Id (B x) y (g x) 124 | 125 | rem : contr ((x:A) -> Sigma (B x) (C x)) 126 | rem = isContrProd A (\ x -> Sigma (B x) (C x)) (\ x -> singContr (B x) (g x)) 127 | 128 | rem1 : Id U ((x:A) -> Sigma (B x) (C x)) (Sigma (Pi A B) (\ z -> (x:A) -> C x (z x))) 129 | rem1 = idTelProp A B C 130 | 131 | -- we have enough to deduce that Id (Pi A B) f g and (x:A) -> Id (B x) (f x) (g x) are equal 132 | eqIdProd : (A:U) (B:A->U) -> (f g : Pi A B) -> Id U (Id (Pi A B) f g) ((x:A) -> Id (B x) (f x) (g x)) 133 | eqIdProd A B f g = equivTot T P Q G rem f 134 | where 135 | P : (Pi A B) -> U 136 | P z = Id (Pi A B) z g 137 | 138 | Q : (Pi A B) -> U 139 | Q z = (x:A) -> Id (B x) (z x) (g x) 140 | 141 | T : U 142 | T = Pi A B 143 | 144 | G : (z:Pi A B) -> P z -> Q z 145 | G z ez x = mapOnPath (Pi A B) (B x) (\ u -> u x) z g ez 146 | 147 | rem1 : contr (Sigma T P) 148 | rem1 = singContr (Pi A B) g 149 | 150 | rem2 : contr (Sigma T Q) 151 | rem2 = singlPiContr A B g 152 | 153 | rem : isEquiv (Sigma T P) (Sigma T Q) (liftTot T P Q G) 154 | rem = equivContr (Sigma T P) rem1 (Sigma T Q) rem2 (liftTot T P Q G) 155 | 156 | -- it follows from this that a product of sets is a set 157 | 158 | isSetProd : (A:U) (B:A->U) (pB : (x:A) -> set (B x)) -> set (Pi A B) 159 | isSetProd A B pB f g = substInv U prop (Id (Pi A B) f g) ((x:A) -> Id (B x) (f x) (g x)) rem2 rem1 160 | where 161 | rem : (x:A) -> prop (Id (B x) (f x) (g x)) 162 | rem x = pB x (f x) (g x) 163 | 164 | rem1 : prop ((x:A) -> Id (B x) (f x) (g x)) 165 | rem1 = isPropProd A (\ x -> Id (B x) (f x) (g x)) rem 166 | 167 | rem2 : Id U (Id (Pi A B) f g) ((x:A) -> Id (B x) (f x) (g x)) 168 | rem2 = eqIdProd A B f g 169 | 170 | 171 | -------------------------------------------------------------------------------- /examples/exists.cub: -------------------------------------------------------------------------------- 1 | module exists where 2 | 3 | import prelude 4 | 5 | -- existence: a new modality 6 | 7 | exists : (A : U) (B : A -> U) -> U 8 | exists A B = inh (Sigma A B) 9 | 10 | exElim : (A : U) (B : A -> U) (C : U) -> prop C -> (Sigma A B -> C) -> 11 | exists A B -> C 12 | exElim A B C p f = inhrec (Sigma A B) C p f 13 | 14 | atmostOne : (A : U) (B : A -> U) -> U 15 | atmostOne A B = (a b : A) -> B a -> B b -> Id A a b 16 | 17 | exactOne : (A : U) (B : A -> U) -> U 18 | exactOne A B = and (exists A B) (atmostOne A B) 19 | 20 | lemInh : (A : U) -> prop A -> inh A -> A 21 | lemInh A h = inhrec A A h (\x -> x) 22 | 23 | -------------------------------------------------------------------------------- /examples/finite.cub: -------------------------------------------------------------------------------- 1 | module finite where 2 | 3 | -- definition of finite sets and cardinality 4 | 5 | import description 6 | import function 7 | import gradLemma 8 | import swapDisc_old 9 | 10 | step : U -> U 11 | step X = or Unit X 12 | 13 | incSt : (X:U) -> X -> step X 14 | incSt X x = inr x 15 | 16 | injSt : (X:U) -> injective X (step X) (incSt X) 17 | injSt X x0 x1 h = subst (step X) T (inr x0) (inr x1) h (refl X x0) 18 | where 19 | T : step X -> U 20 | T = split 21 | inl _ -> N0 22 | inr x -> Id X x0 x 23 | 24 | incUnSt : (X:U) -> Unit -> step X 25 | incUnSt X x = inl x 26 | 27 | inlNotinr : (A B:U) (a:A) (b:B) -> neg (Id (or A B) (inl a) (inr b)) 28 | inlNotinr A B a b h = subst (or A B) T (inl a) (inr b) h tt 29 | where 30 | T : or A B -> U 31 | T = split 32 | inl _ -> Unit 33 | inr _ -> N0 34 | 35 | inrNotinl : (A B:U) (a:A) (b:B) -> neg (Id (or A B) (inr b) (inl a)) 36 | inrNotinl A B a b h = subst (or A B) T (inr b) (inl a) h tt 37 | where 38 | T : or A B -> U 39 | T = split 40 | inl _ -> N0 41 | inr _ -> Unit 42 | 43 | decSt : (X:U) -> discrete X -> discrete (step X) 44 | decSt X dX = 45 | split 46 | inl a -> split 47 | inl a1 -> inl (mapOnPath Unit (step X) (incUnSt X) a a1 (propUnit a a1)) 48 | inr b -> inr (inlNotinr Unit X a b) 49 | inr b -> split 50 | inl a -> inr (inrNotinl Unit X a b) 51 | inr b1 -> rem (dX b b1) 52 | where rem : dec (Id X b b1) -> dec (Id (step X) (inr b) (inr b1)) 53 | rem = split 54 | inl p -> inl (mapOnPath X (step X) (incSt X) b b1 p) 55 | inr h -> inr (\ p -> h (injSt X b b1 p)) 56 | 57 | stFin : N -> U 58 | stFin = split 59 | zero -> N0 60 | suc n -> step (stFin n) 61 | 62 | lemN0 : (X:U) -> Id U (or X N0) X 63 | lemN0 X = isEquivEq (or X N0) X f ef 64 | where 65 | f : or X N0 -> X 66 | f = split 67 | inl x -> x 68 | inr y -> efq X y 69 | 70 | g : X -> or X N0 71 | g x = inl x 72 | 73 | sfg : (z:or X N0) -> Id (or X N0) (g (f z)) z 74 | sfg = split 75 | inl x -> refl (or X N0) (inl x) 76 | inr y -> efq (Id (or X N0) (g (f (inr y))) (inr y)) y 77 | 78 | rfg : (x:X) -> Id X (f (g x)) x 79 | rfg x = refl X x 80 | 81 | ef : isEquiv (or X N0) X f 82 | ef = gradLemma (or X N0) X f g rfg sfg 83 | 84 | N0Dec : discrete N0 85 | N0Dec = \ x y -> efq (dec (Id N0 x y)) x 86 | 87 | finDec : (n:N) -> discrete (stFin n) 88 | finDec = split 89 | zero -> N0Dec 90 | suc m -> decSt (stFin m) (finDec m) 91 | 92 | unitDec : discrete Unit 93 | unitDec = split 94 | tt -> split 95 | tt -> inl (refl Unit tt) 96 | 97 | -- take away one element 98 | 99 | takeAway : (A:U) -> A -> U 100 | takeAway A a = Sigma A (\ x -> neg (Id A a x)) 101 | 102 | tAway : ptU -> U 103 | tAway z = takeAway z.1 z.2 104 | 105 | -- this has been generalized from a special case 106 | 107 | eqTkA : (X:U) -> Id U (takeAway (step X) (inl tt)) X 108 | eqTkA X = isEquivEq tS X f equivf 109 | where 110 | stS : U 111 | stS = step X 112 | 113 | bn : stS 114 | bn = inl tt 115 | 116 | tS : U 117 | tS = takeAway stS bn 118 | 119 | faux : (x:stS) -> neg (Id stS bn x) -> X 120 | faux = split 121 | inl u -> \ h -> efq X (h rem) 122 | where rem : Id stS bn (inl u) 123 | rem = mapOnPath Unit stS (incUnSt X) tt u (propUnit tt u) 124 | inr z -> \ _ -> z 125 | 126 | f : tS -> X 127 | f z = faux z.1 z.2 128 | 129 | lem : (x:X) -> neg (Id stS bn (inr x)) 130 | lem x = inlNotinr Unit X tt x 131 | 132 | g : X -> tS 133 | g x = (inr x,lem x) 134 | 135 | T : stS -> U 136 | T x = neg (Id stS bn x) 137 | 138 | lem1 : (u:Unit) -> Id stS bn (inl u) 139 | lem1 u = mapOnPath Unit stS (incUnSt X) tt u (propUnit tt u) 140 | 141 | lem2 : propFam stS T 142 | lem2 = \ x -> propNeg (Id stS bn x) 143 | 144 | sfg : (x:X) -> Id X (f (g x)) x 145 | sfg x = refl X x 146 | 147 | rfg : (z:tS) -> Id tS (g (f z)) z 148 | rfg z = rem z.1 z.2 149 | where rem : (x:stS) -> (p : T x) -> Id tS (g (f (x,p))) (x,p) 150 | rem = split 151 | inl u -> \ h -> efq (Id tS (g (f (inl u,h))) (inl u,h)) (h (lem1 u)) 152 | inr z -> \ h -> eqPropFam stS T lem2 153 | (inr z,lem (faux (inr z) h)) (inr z,h) (refl stS (inr z)) 154 | 155 | equivf : isEquiv tS X f 156 | equivf = gradLemma tS X f g sfg rfg 157 | 158 | botEl : (n:N) -> stFin (suc n) 159 | botEl n = inl tt 160 | 161 | ptBot : N -> ptU 162 | ptBot n = (stFin (suc n),botEl n) 163 | 164 | mkPtU : (n:N) (x:stFin (suc n)) -> ptU 165 | mkPtU n x = (stFin (suc n),x) 166 | 167 | homogSt : (X:U) -> discrete X -> (x:step X) -> Id ptU (step X,x) (step X,inl tt) 168 | homogSt X dX x = homogDec (step X) (decSt X dX) x (inl tt) 169 | 170 | corHomogSt : (X:U) -> discrete X -> (x:step X) -> Id U (takeAway (step X) x) X 171 | corHomogSt X dX x = 172 | substInv ptU (\ z -> Id U (tAway z) X) (step X,x) (step X,inl tt) 173 | (homogSt X dX x) (eqTkA X) 174 | 175 | -- eqTkA : (X:U) -> Id U (takeAway (step X) (inl tt)) X 176 | 177 | homogSt' : (n:N) (x:stFin (suc n)) -> Id ptU (mkPtU n x) (ptBot n) 178 | homogSt' n = homogSt (stFin n) (finDec n) 179 | 180 | corEqTkA : (n:N) -> Id U (tAway (ptBot n)) (stFin n) 181 | corEqTkA n = eqTkA (stFin n) 182 | 183 | cor1EqTkA : (n:N) (x:stFin (suc n)) -> Id U (tAway (mkPtU n x)) (stFin n) 184 | cor1EqTkA n x = 185 | substInv ptU (\ z -> Id U (tAway z) (stFin n)) (mkPtU n x) (ptBot n) (homogSt' n x) (corEqTkA n) 186 | 187 | lemInjSt : (X Y:U) -> discrete X -> Id U (step X) (step Y) -> Id U X Y 188 | lemInjSt X Y dX h = lem5 189 | where 190 | P : U -> U 191 | P Z = (x:Z) -> Id U (takeAway Z x) X 192 | 193 | lem1 : P (step X) 194 | lem1 = corHomogSt X dX 195 | 196 | lem2 : P (step Y) 197 | lem2 = subst U P (step X) (step Y) h lem1 198 | 199 | Am : U 200 | Am = takeAway (step Y) (inl tt) 201 | 202 | lem3 : Id U Am Y 203 | lem3 = eqTkA Y 204 | 205 | lem4 : Id U Am X 206 | lem4 = lem2 (inl tt) 207 | 208 | lem5 : Id U X Y 209 | lem5 = comp U X Am Y (inv U Am X lem4) lem3 210 | 211 | lem1InjSt : (n:N) -> neg (Id U N0 (stFin (suc n))) 212 | lem1InjSt n h = transpInv N0 (stFin (suc n)) h (botEl n) 213 | 214 | lem2InjSt : (n:N) -> neg (Id U (stFin (suc n)) N0) 215 | lem2InjSt n h = transport (stFin (suc n)) N0 h (botEl n) 216 | 217 | lemInj : injective N U stFin 218 | lemInj = split 219 | zero -> split 220 | zero -> \ _ -> refl N zero 221 | suc m -> \ h -> efq (Id N zero (suc m)) (lem1InjSt m h) 222 | suc n -> split 223 | zero -> \ h -> efq (Id N (suc n) zero) (lem2InjSt n h) 224 | suc m -> \ h -> 225 | mapOnPath N N (\ x -> suc x) n m (lemInj n m (lemInjSt (stFin n) (stFin m) (finDec n) h)) 226 | 227 | eqsT : U -> N -> U 228 | eqsT X n = inh (Id U (stFin n) X) 229 | 230 | finite : U -> U 231 | finite X = exists N (eqsT X) 232 | 233 | lemEqsT : (X:U) (n m:N) -> eqsT X n -> eqsT X m -> Id N n m 234 | lemEqsT X n m = rem2 235 | where 236 | G : U 237 | G = Id N n m 238 | 239 | pG : prop G 240 | pG = NIsSet n m 241 | 242 | rem : Id U (stFin n) X -> Id U (stFin m) X -> G 243 | rem ln lm = lemInj n m (comp U (stFin n) X (stFin m) ln (inv U (stFin m) X lm)) 244 | 245 | rem1 : Id U (stFin n) X -> eqsT X m -> G 246 | rem1 ln = inhrec (Id U (stFin m) X) G pG (rem ln) 247 | 248 | rem2 : eqsT X n -> eqsT X m -> G 249 | rem2 hn hm = inhrec (Id U (stFin n) X) G pG (\ l -> rem1 l hm) hn 250 | 251 | propEqsT : (X:U) -> prop (Sigma N (eqsT X)) 252 | propEqsT X = propSig N (eqsT X) (\ n -> squash (Id U (stFin n) X)) rem 253 | where rem : atmostOne N (eqsT X) 254 | rem = lemEqsT X 255 | 256 | cardFin : (X:U) -> finite X -> Sigma N (eqsT X) 257 | cardFin X = inhrec (Sigma N (eqsT X)) (Sigma N (eqsT X)) (propEqsT X) (\ h -> h) 258 | 259 | -- Unit is finite 260 | 261 | finUnit : finite Unit 262 | finUnit = inc (Sigma N (eqsT Unit)) rem 263 | where rem : Sigma N (eqsT Unit) 264 | rem = (suc zero,inc (Id U (stFin (suc zero)) Unit) (lemN0 Unit)) 265 | 266 | rem1 : Id U (stFin (suc zero)) Unit 267 | rem1 = lemN0 Unit 268 | 269 | test : N 270 | test = (cardFin Unit finUnit).1 271 | -------------------------------------------------------------------------------- /examples/function.cub: -------------------------------------------------------------------------------- 1 | module function where 2 | 3 | import lemId 4 | 5 | -- some general facts about functions 6 | 7 | -- g is a section of f 8 | section : (A B : U) (f : A -> B) (g : B -> A) -> U 9 | section A B f g = (b : B) -> Id B (f (g b)) b 10 | 11 | injective : (A B : U) (f : A -> B) -> U 12 | injective A B f = (a0 a1 : A) -> Id B (f a0) (f a1) -> Id A a0 a1 13 | 14 | retract : (A B : U) (f : A -> B) (g : B -> A) -> U 15 | retract A B f g = section B A g f 16 | 17 | retractInj : (A B : U) (f : A -> B) (g : B -> A) -> 18 | retract A B f g -> injective A B f 19 | retractInj A B f g h a0 a1 h' = 20 | compUp A (g (f a0)) a0 (g (f a1)) a1 rem1 rem2 rem3 21 | where 22 | rem1 : Id A (g (f a0)) a0 23 | rem1 = h a0 24 | 25 | rem2 : Id A (g (f a1)) a1 26 | rem2 = h a1 27 | 28 | rem3 : Id A (g (f a0)) (g (f a1)) 29 | rem3 = mapOnPath B A g (f a0) (f a1) h' 30 | 31 | hasSection : (A B : U) -> (A -> B) -> U 32 | hasSection A B f = Sigma (B -> A) (section A B f) 33 | 34 | -- an equivalence has a section 35 | 36 | equivSec : (A B : U) -> (f : A -> B) -> isEquiv A B f -> hasSection A B f 37 | equivSec A B f st = (\y -> (st.1 y).1, \y -> (st.1 y).2) 38 | 39 | allSection : (A B : U) (f : A -> B) -> hasSection A B f -> 40 | (Q : B -> U) -> ((x : A) -> Q (f x)) -> Pi B Q 41 | allSection A B f z Q h y = subst B Q (f (z.1 y)) y (z.2 y) (h (z.1 y)) 42 | 43 | isEquivSection : (A B : U) (f : A -> B) (g : B -> A) -> section A B f g -> 44 | ((b : B) -> prop (fiber A B f b)) -> isEquiv A B f 45 | isEquivSection A B f g sfg h = (s, t) 46 | where 47 | s : (y : B) -> fiber A B f y 48 | s y = (g y, sfg y) 49 | 50 | t : (y : B) -> (v : fiber A B f y) -> Id (fiber A B f y) (s y) v 51 | t y v = h y (s y) v 52 | 53 | injProp : (A B : U) (f : A -> B) -> injective A B f -> prop B -> prop A 54 | injProp A B f injf pB a0 a1 = injf a0 a1 (pB (f a0) (f a1)) 55 | 56 | injId : (X : U) -> injective X X (id X) 57 | injId X a0 a1 h = h 58 | 59 | involutive : (A : U) -> (A -> A) -> U 60 | involutive A f = section A A f f -------------------------------------------------------------------------------- /examples/gradLemma.cub: -------------------------------------------------------------------------------- 1 | module gradLemma where 2 | 3 | import BoolEqBool 4 | 5 | corrstId : (A : U) (a : A) -> prop (fiber A A (id A) a) 6 | corrstId A a v0 v1 = 7 | compInv (pathTo A a) (sId A a) v0 v1 (tId A a v0) (tId A a v1) 8 | 9 | corr2stId : (A : U) (h : A -> A) (ph : (x : A) -> Id A (h x) x) (a : A) -> 10 | prop (fiber A A h a) 11 | corr2stId A h ph a = 12 | substInv (A -> A) (\h -> prop (fiber A A h a)) h (id A) rem (corrstId A a) 13 | where 14 | rem : Id (A -> A) h (id A) 15 | rem = funExt A (\_ -> A) h (id A) ph 16 | 17 | gradLemma : (A B : U) (f : A -> B) (g : B -> A) -> 18 | section A B f g -> retract A B f g -> isEquiv A B f 19 | gradLemma A B f g sfg rfg = isEquivSection A B f g sfg rem 20 | where 21 | injf : injective A B f 22 | injf = retractInj A B f g rfg 23 | 24 | rem : (b : B) -> prop (Sigma A (\a -> Id B (f a) b)) 25 | rem b z0 z1 = rem5 26 | where 27 | E : A -> U 28 | E a = Id B (f a) b 29 | F : A -> U 30 | F a = Id A (g (f a)) (g b) 31 | G : A -> U 32 | G a = Id B (f (g (f a))) (f (g b)) 33 | 34 | cg : (a:A) -> E a -> F a 35 | cg a = mapOnPath B A g (f a) b 36 | 37 | cf : (a:A) -> F a -> G a 38 | cf a = mapOnPath A B f (g (f a)) (g b) 39 | 40 | cfg : (a:A) -> E a -> G a 41 | cfg a = mapOnPath B B (\ x -> f (g x)) (f a) b 42 | 43 | pcf : Sigma A F -> Sigma A G 44 | pcf z = (z.1, cf z.1 z.2) 45 | 46 | pcg : Sigma A E -> Sigma A F 47 | pcg z = (z.1, cg z.1 z.2) 48 | 49 | fg : B -> B 50 | fg y = f (g y) 51 | 52 | pc : (u:B -> B) -> Sigma A E -> Sigma A (\ a -> Id B (u (f a)) (u b)) 53 | pc u z = (z.1, mapOnPath B B u (f z.1) b z.2) 54 | 55 | rem1 : prop (Sigma A F) 56 | rem1 = corr2stId A (\x -> g (f x)) rfg (g b) 57 | 58 | rem2 : Id (Sigma A F) (pcg z0) (pcg z1) 59 | rem2 = rem1 (pcg z0) (pcg z1) 60 | 61 | rem3 : Id (Sigma A G) (pcf (pcg z0)) (pcf (pcg z1)) 62 | rem3 = mapOnPath (Sigma A F) (Sigma A G) pcf (pcg z0) (pcg z1) rem2 63 | 64 | rem4 : Id (B -> B) fg (id B) 65 | rem4 = funExt B (\_ -> B) fg (id B) sfg 66 | 67 | rem5 : Id (Sigma A E) (pc (id B) z0) (pc (id B) z1) 68 | rem5 = subst (B -> B) 69 | (\u -> Id (Sigma A (\x -> Id B (u (f x)) (u b))) 70 | (pc u z0) (pc u z1)) fg (id B) rem4 rem3 71 | 72 | -- isomorphic types are equal 73 | isoId : (A B : U) -> (f : A -> B) (g : B -> A) -> 74 | section A B f g -> retract A B f g -> Id U A B 75 | isoId A B f g sfg rfg = isEquivEq A B f (gradLemma A B f g sfg rfg) 76 | 77 | -- some applications of the gradlemma 78 | propId : (A B : U) -> prop A -> prop B -> (f : A -> B) (g : B -> A) -> 79 | Id U A B 80 | propId A B pA pB f g = isEquivEq A B f (gradLemma A B f g sfg rfg) 81 | where 82 | sfg : (b:B) -> Id B (f (g b)) b 83 | sfg b = pB (f (g b)) b 84 | 85 | rfg : (a:A) -> Id A (g (f a)) a 86 | rfg a = pA (g (f a)) a 87 | -------------------------------------------------------------------------------- /examples/hedberg.cub: -------------------------------------------------------------------------------- 1 | module hedberg where 2 | 3 | import set 4 | 5 | -- proves that a type with decidable equality is a set 6 | -- in particular both N and Bool are sets 7 | 8 | const : (A : U) (f : A -> A) -> U 9 | const A f = (x y : A) -> Id A (f x) (f y) 10 | 11 | exConst : (A : U) -> U 12 | exConst A = Sigma (A -> A) (const A) 13 | 14 | decConst : (A : U) -> dec A -> exConst A 15 | decConst A = split 16 | inl a -> (\x -> a, \ x y -> refl A a) 17 | inr h -> (\x -> x, \ x y -> efq (Id A x y) (h x)) 18 | 19 | hedbergLemma : (A: U) (f : (a b : A) -> Id A a b -> Id A a b) (a b : A) 20 | (p : Id A a b) -> 21 | Id (Id A a b) (comp A a a b (f a a (refl A a)) p) (f a b p) 22 | hedbergLemma A f a = 23 | J A a (\b p -> Id (Id A a b) (comp A a a b (f a a (refl A a)) p) (f a b p)) rem 24 | where 25 | rem : Id (Id A a a) (comp A a a a (f a a (refl A a)) (refl A a)) 26 | (f a a (refl A a)) 27 | rem = compIdr A a a (f a a (refl A a)) 28 | 29 | hedberg : (A : U) -> discrete A -> set A 30 | hedberg A h a b p q = lemSimpl A a a b r p q rem5 31 | where 32 | rem1 : (x y : A) -> exConst (Id A x y) 33 | rem1 x y = decConst (Id A x y) (h x y) 34 | 35 | f : (x y : A) -> Id A x y -> Id A x y 36 | f x y = (rem1 x y).1 37 | 38 | fIsConst : (x y : A) -> const (Id A x y) (f x y) 39 | fIsConst x y = (rem1 x y).2 40 | 41 | r : Id A a a 42 | r = f a a (refl A a) 43 | 44 | rem2 : Id (Id A a b) (comp A a a b r p) (f a b p) 45 | rem2 = hedbergLemma A f a b p 46 | 47 | rem3 : Id (Id A a b) (comp A a a b r q) (f a b q) 48 | rem3 = hedbergLemma A f a b q 49 | 50 | rem4 : Id (Id A a b) (f a b p) (f a b q) 51 | rem4 = fIsConst a b p q 52 | 53 | rem5 : Id (Id A a b) (comp A a a b r p) (comp A a a b r q) 54 | rem5 = compDown (Id A a b) (comp A a a b r p) (f a b p) (comp A a a b r q) 55 | (f a b q) rem2 rem3 rem4 56 | 57 | NIsSet : set N 58 | NIsSet = hedberg N natDec 59 | 60 | test3 : Id (Id N zero zero) (refl N zero) (refl N zero) 61 | test3 = NIsSet zero zero (refl N zero) (refl N zero) 62 | 63 | boolIsSet : set Bool 64 | boolIsSet = hedberg Bool boolDec 65 | 66 | unitIsSet : set Unit 67 | unitIsSet = hedberg Unit unitDec 68 | 69 | N0IsSet : set N0 70 | N0IsSet = hedberg N0 N0Dec 71 | -------------------------------------------------------------------------------- /examples/helix.cub: -------------------------------------------------------------------------------- 1 | module helix where 2 | 3 | import integer 4 | 5 | helix : S1 -> U 6 | helix = S1rec (\_ -> U) Z sucIdZ 7 | 8 | test : Id U Z (helix base) 9 | test = refl U Z 10 | 11 | loopSpace : (A : U) (a : A) -> U 12 | loopSpace A a = Id A a a 13 | 14 | loopS1 : U 15 | loopS1 = loopSpace S1 base 16 | 17 | S1recbase : (F : S1 -> U) (b : F base) -> (l : IdS S1 F base base loop b b) -> 18 | Id (F base) (S1rec F b l base) b 19 | S1recbase F b l = refl (F base) b 20 | 21 | -- S1recloop : (F : S1 -> U) (b : F base) -> (l : IdS S1 F base base loop b b) -> 22 | -- Id (IdS S1 F base base loop b b) 23 | -- (mapOnPathD S1 F (S1rec F b l) base base loop) 24 | -- l 25 | -- S1recloop F b l = refl (IdS S1 F base base loop b b) l 26 | 27 | winding : loopS1 -> Z 28 | winding l = transport Z Z (rem l) zeroZ 29 | where 30 | rem : loopS1 -> Id U Z Z 31 | rem l = mapOnPath S1 U helix base base l 32 | 33 | compS1 : loopS1 -> loopS1 -> loopS1 34 | compS1 = comp S1 base base base 35 | 36 | invS1 : loopS1 -> loopS1 37 | invS1 = inv S1 base base 38 | 39 | test1 : Z 40 | test1 = winding loop 41 | 42 | loop2 : loopS1 43 | loop2 = compS1 loop loop 44 | 45 | loop4 : loopS1 46 | loop4 = compS1 loop2 loop2 47 | 48 | loop8 : loopS1 49 | loop8 = compS1 loop4 loop4 50 | 51 | test2 : Z 52 | test2 = winding (compS1 loop (invS1 loop)) 53 | 54 | test3 : Z 55 | test3 = winding (invS1 loop2) 56 | 57 | test4 : Z 58 | test4 = winding (compS1 loop4 (invS1 loop2)) 59 | 60 | test5 : Z 61 | test5 = winding (compS1 loop8 (invS1 loop2)) 62 | 63 | encode : (x : S1) -> Id S1 base x -> helix x 64 | encode x l = subst S1 helix base x l zeroZ 65 | 66 | loopN : N -> loopS1 67 | loopN = split 68 | zero -> refl S1 base 69 | suc n -> compS1 loop (loopN n) 70 | 71 | loopZ : Z -> loopS1 72 | loopZ = split 73 | inl n -> invS1 (loopN (suc n)) 74 | inr n -> loopN n 75 | 76 | -- loopZpred : (n : Z) -> Id loopS1 (loopZ (predZ n)) (compS1 (invS1 loop) (loopZ n)) 77 | -- loopZpred n = undefined 78 | 79 | testDan : Id U Z Z 80 | testDan = mapOnPath S1 U helix base base loop 81 | 82 | funDan : Z -> Z 83 | funDan = transport Z Z testDan 84 | 85 | funDan1 : Z -> Z 86 | funDan1 = transport Z Z sucIdZ 87 | 88 | -- testDan1 : Id (Z->Z) sucZ funDan1 89 | -- testDan1 = refl (Z -> Z) sucZ 90 | 91 | test0 : Z 92 | test0 = transport Z Z testDan zeroZ 93 | 94 | vect : N -> U 95 | vect = split 96 | zero -> Unit 97 | suc n -> and N (vect n) 98 | 99 | Peter : S1 -> N 100 | Peter = S1rec (\ _ -> N) zero (refl N zero) 101 | 102 | testPeter : Id N zero zero 103 | testPeter = mapOnPath S1 N Peter base base loop 104 | 105 | 106 | -- helix = S1rec (\_ -> U) Z sucIdZ 107 | 108 | -------------------------------------------------------------------------------- /examples/heterogeneous.cub: -------------------------------------------------------------------------------- 1 | module heterogeneous where 2 | 3 | import primitives 4 | import prelude 5 | import gradLemma 6 | 7 | eqFst : (A : U) (B : A -> U) (u v : Sigma A B) -> 8 | Id (Sigma A B) u v -> Id A u.1 v.1 9 | eqFst A B = mapOnPath (Sigma A B) A (\x -> x.1) 10 | 11 | eqSnd : (A : U) (B : A -> U) (u v : Sigma A B) (p : Id (Sigma A B) u v) -> 12 | IdS A B u.1 v.1 (eqFst A B u v p) u.2 v.2 13 | eqSnd A B = mapOnPathD (Sigma A B) (\x -> B x.1) (\x -> x.2) 14 | 15 | eqPair1 : (A : U) (B : A -> U) (a0 a1 : A) (b0 : B a0) (b1 : B a1) -> 16 | Id (Sigma A B) (a0,b0) (a1,b1) -> Id A a0 a1 17 | eqPair1 A B a0 a1 b0 b1 = eqFst A B (a0,b0) (a1,b1) 18 | 19 | -- eqPair2 : (A : U) (B : A -> U) (a0 a1 : A) (b0 : B a0) (b1 : B a1) 20 | -- (p : Id (Sigma A B) (pair a0 b0) (pair a1 b1)) -> 21 | -- IdS A B a0 a1 (eqPair1 A B a0 a1 b0 b1 p) b0 b1 22 | -- eqPair2 A B a0 a1 b0 b1 = eqSnd A B (pair a0 b0) (pair a1 b1) 23 | 24 | -- conversion test: 25 | reflIdIdP : (A:U) (a b : A) -> Id U (Id A a b) (IdP A A (refl U A) a b) 26 | reflIdIdP A a b = refl U (Id A a b) 27 | 28 | -- conversion test: 29 | reflS : (A:U) (F:A -> U) (a:A) (b : F a) -> IdS A F a a (refl A a) b b 30 | reflS A F a b = refl (F a) b 31 | 32 | -- conversion test: 33 | composeMapOnPath : (A : U) (B : A -> U) (u v : Sigma A B) -> 34 | (p : Id (Sigma A B) u v) -> 35 | Id (Id U (B u.1) (B v.1)) 36 | (mapOnPath (Sigma A B) U (\x -> B x.1) u v p) 37 | (mapOnPath A U B u.1 v.1 (mapOnPath (Sigma A B) A (\x -> x.1) u v p)) 38 | composeMapOnPath A B u v p = refl (Id U (B u.1) (B v.1)) 39 | (mapOnPath (Sigma A B) U (\x -> B x.1) u v p) 40 | 41 | eqFstSnd : (A : U) (B : A -> U) (a0 a1 : A) (b0 : B a0) (b1 : B a1) -> 42 | Id U 43 | (Id (Sigma A B) (a0, b0) (a1, b1)) 44 | (Sigma (Id A a0 a1) (\p -> IdS A B a0 a1 p b0 b1)) 45 | eqFstSnd A B a0 a1 b0 b1 = isEquivEq IdSig SigId f 46 | (gradLemma IdSig SigId f g (refl SigId) (refl IdSig)) 47 | where IdSig : U 48 | IdSig = Id (Sigma A B) (a0, b0) (a1, b1) 49 | 50 | SigId : U 51 | SigId = Sigma (Id A a0 a1) (\p -> IdS A B a0 a1 p b0 b1) 52 | 53 | f : IdSig -> SigId 54 | f p = (eqFst A B (a0,b0) (a1,b1) p, eqSnd A B (a0,b0) (a1,b1) p) 55 | 56 | 57 | g : SigId -> IdSig 58 | g z = mapOnPathS A B (Sigma A B) (\a b -> (a, b)) a0 a1 z.1 b0 b1 z.2 59 | 60 | 61 | eqSubstSig : (A : U) (B : A -> U) (a0 a1 : A) (p:Id A a0 a1) (b0 : B a0) (b1 : B a1) -> 62 | Id U (IdS A B a0 a1 p b0 b1) (Id (B a1) (subst A B a0 a1 p b0) b1) 63 | eqSubstSig A B a0 = 64 | J A a0 (\ a1 p -> (b0 : B a0) (b1 : B a1) -> 65 | Id U (IdS A B a0 a1 p b0 b1) (Id (B a1) (subst A B a0 a1 p b0) b1)) 66 | rem 67 | where rem :(b0 b1 :B a0) -> Id U (Id (B a0) b0 b1) (Id (B a0) (subst A B a0 a0 (refl A a0) b0) b1) 68 | rem b0 b1 = mapOnPath (B a0) U (\ b -> Id (B a0) b b1) 69 | b0 (subst A B a0 a0 (refl A a0) b0) (substeq A B a0 b0) 70 | 71 | pairEq : (A B:U) (a0 a1:A) (b0 b1:B) -> Id A a0 a1 -> Id B b0 b1 -> 72 | Id (and A B) (a0, b0) (a1, b1) 73 | pairEq A B a0 a1 b0 b1 p q = 74 | appOnPath B (and A B) f0 f1 b0 b1 rem q 75 | where f0 : B -> and A B 76 | f0 y = (a0, y) 77 | f1 : B -> and A B 78 | f1 y = (a1, y) 79 | rem : Id (B -> and A B) f0 f1 80 | rem = mapOnPath A (B -> and A B) (\ x y -> (x, y)) a0 a1 p 81 | 82 | test : (A B:U) (a0 a1:A) (b0 b1:B) (p:Id A a0 a1) (q:Id B b0 b1) -> 83 | Id (Id A a0 a1) 84 | p 85 | (mapOnPath (and A B) A (\x -> x.1) (a0, b0) (a1, b1) 86 | (pairEq A B a0 a1 b0 b1 p q)) 87 | test A B a0 a1 b0 b1 p q = refl (Id A a0 a1) p 88 | -------------------------------------------------------------------------------- /examples/integer.cub: -------------------------------------------------------------------------------- 1 | module integer where 2 | 3 | import gradLemma 4 | 5 | Z : U 6 | Z = or N N 7 | 8 | zeroZ : Z 9 | zeroZ = inr zero 10 | 11 | sucZ : Z -> Z 12 | sucZ = split 13 | inl u -> auxsucZ u 14 | where 15 | auxsucZ : N -> Z 16 | auxsucZ = split 17 | zero -> inr zero 18 | suc n -> inl n 19 | inr v -> inr (suc v) 20 | 21 | predZ : Z -> Z 22 | predZ = split 23 | inl u -> inl (suc u) 24 | inr v -> auxpredZ v 25 | where 26 | auxpredZ : N -> Z 27 | auxpredZ = split 28 | zero -> inl zero 29 | suc n -> inr n 30 | 31 | sucpredZ : (x : Z) -> Id Z (sucZ (predZ x)) x 32 | sucpredZ = split 33 | inl u -> refl Z (inl u) 34 | inr v -> lem v 35 | where 36 | lem : (u : N) -> Id Z (sucZ (predZ (inr u))) (inr u) 37 | lem = split 38 | zero -> refl Z (inr zero) 39 | suc n -> refl Z (inr (suc n)) 40 | 41 | predsucZ : (x : Z) -> Id Z (predZ (sucZ x)) x 42 | predsucZ = split 43 | inl u -> lem u 44 | where 45 | lem : (u : N) -> Id Z (predZ (sucZ (inl u))) (inl u) 46 | lem = split 47 | zero -> refl Z (inl zero) 48 | suc n -> refl Z (inl (suc n)) 49 | inr v -> refl Z (inr v) 50 | 51 | sucIdZ : Id U Z Z 52 | sucIdZ = isoId Z Z sucZ predZ sucpredZ predsucZ 53 | -------------------------------------------------------------------------------- /examples/interval.cub: -------------------------------------------------------------------------------- 1 | module interval where 2 | 3 | import primitives 4 | 5 | funExt' : (A : U) (B : A -> U) (f g : (x : A) -> B x) -> 6 | ((x : A) -> Id (B x) (f x) (g x)) -> Id ((x : A) -> B x) f g 7 | funExt' A B f g ptw = mapOnPath I ((x : A) -> B x) htpy I0 I1 line 8 | where 9 | htpy : I -> (x : A) -> B x 10 | htpy i x = intrec (\_ -> B x) (f x) (g x) (ptw x) i 11 | -------------------------------------------------------------------------------- /examples/involutive.cub: -------------------------------------------------------------------------------- 1 | module involutive where 2 | 3 | import gradLemma 4 | 5 | -- any involutive function defines an equality 6 | 7 | idemIsEquiv : (A:U) -> (f : A -> A) -> involutive A f -> isEquiv A A f 8 | idemIsEquiv A f if = gradLemma A A f f if if 9 | 10 | idemEq : (A:U) -> (f : A -> A) -> involutive A f -> Id U A A 11 | idemEq A f if = isEquivEq A A f (idemIsEquiv A f if) 12 | 13 | remIdFunEq : (A:U) -> (f:A -> A) -> (x:A) -> Id A x (f x) -> Id A x (f (f x)) 14 | remIdFunEq A f x p = subst A (\ y -> Id A x (f y)) x (f x) p p 15 | 16 | invInvEq : (A:U) -> (a b :A) -> (p : Id A a b) -> Id (Id A a b) p (inv A b a (inv A a b p)) 17 | invInvEq A a = J A a (\ b p -> Id (Id A a b) p (inv A b a (inv A a b p))) rem 18 | where rem : Id (Id A a a) (refl A a) (inv A a a (inv A a a (refl A a))) 19 | rem = remIdFunEq (Id A a a) (inv A a a) (refl A a) (invRefl A a) 20 | 21 | idemInv : (A:U) -> (a:A) -> involutive (Id A a a) (inv A a a) 22 | idemInv A a = rem 23 | where 24 | T : U 25 | T = Id A a a 26 | g : T -> T 27 | g = inv A a a 28 | rem : (p: T) -> Id T (g (g p)) p 29 | rem p = inv T p (g (g p)) (invInvEq A a a p) 30 | 31 | -- type of all loops 32 | 33 | aLoop : U -> U 34 | aLoop A = Sigma A (\ a -> Id A a a) 35 | 36 | invALoop : (A:U) -> aLoop A -> aLoop A 37 | invALoop A z = (z.1,inv A z.1 z.1 z.2) 38 | 39 | idemInvALoop : (A:U) -> involutive (aLoop A) (invALoop A) 40 | idemInvALoop A z = 41 | mapOnPath (Id A z.1 z.1) (aLoop A) 42 | (\ x -> (z.1, x)) (inv A z.1 z.1 (inv A z.1 z.1 z.2)) z.2 (idemInv A z.1 z.2) 43 | 44 | -- equality associated to this involutive map 45 | 46 | eqInvALoop : (A:U) -> Id U (aLoop A) (aLoop A) 47 | eqInvALoop A = idemEq (aLoop A) (invALoop A) (idemInvALoop A) 48 | 49 | -- type of types with automorphisms 50 | 51 | autoM : U 52 | autoM = aLoop U 53 | 54 | -- this type is equal to itself 55 | 56 | eqAutoM : Id U autoM autoM 57 | eqAutoM = eqInvALoop U 58 | 59 | -- a particular element of autoM 60 | 61 | boolAuto : autoM 62 | boolAuto = (Bool,eqBoolBool1) 63 | 64 | -- by transport we deduce another type and another equality 65 | 66 | boolAuto' : autoM 67 | boolAuto' = subst U (\X -> X) autoM autoM eqAutoM boolAuto 68 | 69 | eqBool' : Id U boolAuto'.1 boolAuto'.1 70 | eqBool' = boolAuto'.2 71 | -------------------------------------------------------------------------------- /examples/lemId.cub: -------------------------------------------------------------------------------- 1 | module lemId where 2 | 3 | import prelude 4 | 5 | -- general lemmas about Identity type 6 | 7 | comp : (A : U) -> (a b c : A) -> Id A a b -> Id A b c -> Id A a c 8 | comp A a b c p q = subst A (Id A a) b c q p 9 | 10 | compInvIdr : (A : U) -> (a b : A) -> (p : Id A a b) -> 11 | Id (Id A a b) p (comp A a b b p (refl A b)) 12 | compInvIdr A a b p = substeq A (\x -> Id A a x) b p 13 | 14 | inv : (A : U) -> (a b : A) -> Id A a b -> Id A b a 15 | inv A a b p = subst A (\x -> Id A x a) a b p (refl A a) 16 | 17 | invRefl : (A : U) -> (a : A) -> Id (Id A a a) (refl A a) (inv A a a (refl A a)) 18 | invRefl A a = substeq A (\x -> Id A x a) a (refl A a) 19 | 20 | compIdr : (A : U) -> (a b : A) -> (p : Id A a b) -> 21 | Id (Id A a b) (comp A a b b p (refl A b)) p 22 | compIdr A a b p = 23 | inv (Id A a b) p (comp A a b b p (refl A b)) (compInvIdr A a b p) 24 | 25 | compInvIdl : (A : U) -> (b c : A) -> (q : Id A b c) -> 26 | Id (Id A b c) q (comp A b b c (refl A b) q) 27 | compInvIdl A b c q = 28 | J A b (\c q -> Id (Id A b c) q (comp A b b c (refl A b) q)) rem c q 29 | where 30 | rem : Id (Id A b b) (refl A b) (comp A b b b (refl A b) (refl A b)) 31 | rem = compInvIdr A b b (refl A b) 32 | 33 | compIdl : (A : U) -> (b c : A) -> (q : Id A b c) -> 34 | Id (Id A b c) (comp A b b c (refl A b) q) q 35 | compIdl A b c q = 36 | inv (Id A b c) q (comp A b b c (refl A b) q) (compInvIdl A b c q) 37 | 38 | compInv : (A : U) -> (a b c : A) -> Id A a b -> Id A a c -> Id A b c 39 | compInv A a b c p r = subst A (\ x -> Id A x c) a b p r 40 | 41 | compInvIdl' : (A : U) (a b : A) (p : Id A a b) -> 42 | Id (Id A a b) p (compInv A a a b (refl A a) p) 43 | compInvIdl' A a b p = substeq A (\x -> Id A x b) a p 44 | 45 | idEuclid : (A : U) -> euclidean A (Id A) 46 | idEuclid A a b c p q = transpInv (Id A a b) (Id A a c) rem p 47 | where rem : Id U (Id A a b) (Id A a c) 48 | rem = mapOnPath A U (Id A a) b c q 49 | 50 | -- similarity with ssreflect?? start to use equality on U 51 | 52 | lemUpDown : (A : U) -> (a a' b b' : A) -> Id A a a' -> Id A b b' -> 53 | Id U (Id A a b) (Id A a' b') 54 | lemUpDown A a a' b b' p q = 55 | appOnPath A U (Id A a) (Id A a') b b' (mapOnPath A (A -> U) (Id A) a a' p) q 56 | 57 | compUp : (A : U) -> (a a' b b' : A) -> 58 | Id A a a' -> Id A b b' -> Id A a b -> Id A a' b' 59 | compUp A a a' b b' p q = 60 | transport (Id A a b) (Id A a' b') (lemUpDown A a a' b b' p q) 61 | 62 | compDown : (A : U) -> (a a' b b' : A) -> 63 | Id A a a' -> Id A b b' -> Id A a' b' -> Id A a b 64 | compDown A a a' b b' p q = 65 | transpInv (Id A a b) (Id A a' b') (lemUpDown A a a' b b' p q) 66 | 67 | lemInv : (A : U) -> (a b c : A) -> (p : Id A a b) -> (q : Id A b c) -> 68 | Id (Id A b c) q (compInv A a b c p (comp A a b c p q)) 69 | lemInv A a b c p q = 70 | J A a (\ b p -> (c : A) (q : Id A b c) -> 71 | Id (Id A b c) q (compInv A a b c p (comp A a b c p q))) rem b p c q 72 | where 73 | rem1 : (c : A) (q : Id A a c) -> 74 | Id (Id A a c) (comp A a a c (refl A a) q) 75 | (compInv A a a c (refl A a) (comp A a a c (refl A a) q)) 76 | rem1 c q = compInvIdl' A a c (comp A a a c (refl A a) q) 77 | 78 | rem2 : (c : A) (q : Id A a c) -> Id (Id A a c) q (comp A a a c (refl A a) q) 79 | rem2 c q = compInvIdl A a c q 80 | 81 | rem : (c : A) (q : Id A a c) -> 82 | Id (Id A a c) q (compInv A a a c (refl A a) (comp A a a c (refl A a) q)) 83 | rem c q = comp (Id A a c) q 84 | (comp A a a c (refl A a) q) 85 | (compInv A a a c (refl A a) (comp A a a c (refl A a) q)) 86 | (rem2 c q) 87 | (rem1 c q) 88 | 89 | lemSimpl : (A:U) -> (a b c : A) -> (p : Id A a b) -> (q q' : Id A b c) -> 90 | Id (Id A a c) (comp A a b c p q) (comp A a b c p q') -> Id (Id A b c) q q' 91 | lemSimpl A a b c p q q' h = 92 | compDown (Id A b c) 93 | q (compInv A a b c p (comp A a b c p q)) 94 | q' (compInv A a b c p (comp A a b c p q')) 95 | rem rem1 rem2 96 | where 97 | rem : Id (Id A b c) q (compInv A a b c p (comp A a b c p q)) 98 | rem = lemInv A a b c p q 99 | 100 | rem1 : Id (Id A b c) q' (compInv A a b c p (comp A a b c p q')) 101 | rem1 = lemInv A a b c p q' 102 | 103 | rem2 : Id (Id A b c) (compInv A a b c p (comp A a b c p q)) 104 | (compInv A a b c p (comp A a b c p q')) 105 | rem2 = mapOnPath (Id A a c) (Id A b c) (compInv A a b c p) 106 | (comp A a b c p q) (comp A a b c p q') h 107 | 108 | eqSigma : (A : U) (B : A -> U) (a b : A) (p : Id A a b) 109 | (u : B a) (v : B b) (q : Id (B b) (subst A B a b p u) v) -> 110 | Id (Sigma A B) (a, u) (b, v) 111 | eqSigma A B a = 112 | J A a (\b p -> (u : B a) (v : B b) (q : Id (B b) (subst A B a b p u) v) -> 113 | Id (Sigma A B) (a, u) (b, v)) rem2 114 | where 115 | rem1 : (u v : B a) -> Id (B a) u v -> 116 | Id (Sigma A B) (a, u) (a, v) 117 | rem1 = mapOnPath (B a) (Sigma A B) (\x -> (a, x)) 118 | 119 | rem2 : (u v : B a) -> Id (B a) (subst A B a a (refl A a) u) v -> 120 | Id (Sigma A B) (a, u) (a, v) 121 | rem2 u v q = rem1 u v q' 122 | where q' : Id (B a) u v 123 | q' = comp (B a) u (subst A B a a (refl A a) u) v (substeq A B a u) q 124 | 125 | eqPropFam : (A : U) (B : A -> U) (h : propFam A B) (au bv : Sigma A B) -> 126 | Id A au.1 bv.1 -> Id (Sigma A B) au bv 127 | eqPropFam A B h au bv p = 128 | eqSigma A B au.1 bv.1 p au.2 bv.2 (h bv.1 (subst A B au.1 bv.1 p au.2) bv.2) -------------------------------------------------------------------------------- /examples/mutual.cub: -------------------------------------------------------------------------------- 1 | module mutualtest where 2 | 3 | import prelude 4 | 5 | mutual 6 | even : N -> Bool 7 | odd : N -> Bool 8 | 9 | even = split 10 | zero -> true 11 | suc n -> odd n 12 | odd = split 13 | zero -> false 14 | suc n -> even n 15 | 16 | testEven3 : Bool 17 | testEven3 = even (suc (suc (suc zero))) 18 | 19 | mutual 20 | V : U 21 | T : V -> U 22 | 23 | data V = nat | pi (a : V) (b : T a -> V) 24 | 25 | T = split 26 | nat -> N 27 | pi a b -> Pi (T a) (\x -> T (b x)) 28 | 29 | 30 | -------------------------------------------------------------------------------- /examples/nIso.cub: -------------------------------------------------------------------------------- 1 | module nIso where 2 | 3 | import gradLemma 4 | 5 | -- an example with N and 1 + N isomorphic 6 | 7 | NToOr : N -> or N Unit 8 | NToOr = split 9 | zero -> inr tt 10 | suc n -> inl n 11 | 12 | OrToN : or N Unit -> N 13 | OrToN = split 14 | inl n -> suc n 15 | inr _ -> zero 16 | 17 | secNO : (x:N) -> Id N (OrToN (NToOr x)) x 18 | secNO = split 19 | zero -> refl N zero 20 | suc n -> refl N (suc n) 21 | 22 | retNO : (z:or N Unit) -> Id (or N Unit) (NToOr (OrToN z)) z 23 | retNO = split 24 | inl n -> refl (or N Unit) (inl n) 25 | inr y -> lem y 26 | where lem : (y:Unit) -> Id (or N Unit) (inr tt) (inr y) 27 | lem = split 28 | tt -> refl (or N Unit) (inr tt) 29 | 30 | isoNO : Id U N (or N Unit) 31 | isoNO = isoId N (or N Unit) NToOr OrToN retNO secNO 32 | 33 | isoNO2 : Id U N (or N Unit) 34 | isoNO2 = comp U N N (or N Unit) (comp U N (or N Unit) N isoNO (inv U N (or N Unit) isoNO)) isoNO 35 | 36 | isoNO4 : Id U N (or N Unit) 37 | isoNO4 = comp U N N (or N Unit) (comp U N (or N Unit) N isoNO2 (inv U N (or N Unit) isoNO2)) isoNO2 38 | 39 | -- trying to build an example which involves Kan filling for product 40 | 41 | vect : U -> N -> U 42 | vect A = split 43 | zero -> A 44 | suc n -> and A (vect A n) 45 | 46 | pBool : N -> U 47 | pBool = vect Bool 48 | 49 | notSN : (x:N) -> pBool x -> pBool x 50 | notSN = split 51 | zero -> not 52 | suc n -> \ z -> (not z.1,notSN n z.2) 53 | 54 | sBool : (x:N) -> pBool x 55 | sBool = split 56 | zero -> true 57 | suc n -> (false,sBool n) 58 | 59 | stBool : (x:N) -> pBool x -> Bool 60 | stBool = split 61 | zero -> \ z -> z 62 | suc n -> \ z -> andBool z.1 (stBool n z.2) 63 | 64 | hasSec : U -> U 65 | hasSec X = Sigma (X->U) (\ P -> (x:X) -> and (P x) (P x -> Bool)) 66 | 67 | hSN : hasSec N 68 | hSN = (pBool,\ n -> (sBool n,stBool n)) 69 | 70 | hSN' : hasSec (or N Unit) 71 | hSN' = subst U hasSec N (or N Unit) isoNO hSN 72 | 73 | pB' : (or N Unit) -> U 74 | pB' = hSN'.1 75 | 76 | sB' : (z: or N Unit) -> and (pB' z) (pB' z -> Bool) 77 | sB' = hSN'.2 78 | 79 | appBool : (A : U) -> and A (A -> Bool) -> Bool 80 | appBool A z = z.2 z.1 81 | 82 | pred' : or N Unit -> or N Unit 83 | pred' = subst U (\ X -> X -> X) N (or N Unit) isoNO pred 84 | 85 | testPred : or N Unit 86 | testPred = pred' (inr tt) 87 | 88 | saB' : or N Unit -> Bool 89 | saB' z = appBool (pB' z) (sB' z) 90 | 91 | testSN : Bool 92 | testSN = saB' (inr tt) 93 | 94 | testSN1 : Bool 95 | testSN1 = saB' (inl zero) 96 | 97 | testSN2 : Bool 98 | testSN2 = saB' (inl (suc zero)) 99 | 100 | testSN3 : Bool 101 | testSN3 = saB' (inl (suc (suc zero))) 102 | 103 | add : N -> N -> N 104 | add x = split 105 | zero -> x 106 | suc y -> suc (add x y) 107 | 108 | -- add' : (or N Unit) -> (or N Unit) -> or N Unit 109 | -- add' = subst U (\ X -> X -> X -> X) N (or N Unit) isoNO add 110 | 111 | 112 | -- a property that we can transport 113 | 114 | propAdd : (x:N) -> Id N (add zero x) x 115 | propAdd = split 116 | zero -> refl N zero 117 | suc n -> mapOnPath N N (\ x -> suc x) (add zero n) n (propAdd n) 118 | 119 | 120 | 121 | 122 | -- a property of N 123 | 124 | aZero : U -> U 125 | aZero X = Sigma X (\ z -> Sigma (X -> X -> X) (\ f -> (x:X) -> Id X (f z x) x)) 126 | 127 | aZN : aZero N 128 | aZN = (zero,(add,propAdd)) 129 | 130 | aZN' : aZero (or N Unit) 131 | aZN' = subst U aZero N (or N Unit) isoNO aZN 132 | 133 | zero' : or N Unit 134 | zero' = aZN'.1 135 | 136 | sndaZN' : Sigma ((or N Unit) -> (or N Unit) -> (or N Unit)) 137 | (\ f -> (x:(or N Unit)) -> Id (or N Unit) (f zero' x) x) 138 | sndaZN' = aZN'.2 139 | 140 | add' : (or N Unit) -> (or N Unit) -> or N Unit 141 | add' = sndaZN'.1 142 | 143 | propAdd' : (x:or N Unit) -> Id (or N Unit) (add' zero' x) x 144 | propAdd' = sndaZN'.2 145 | 146 | testNO : or N Unit 147 | testNO = add' (inl zero) (inl (suc zero)) 148 | 149 | testNO1 : Id (or N Unit) (add' zero' zero') zero' 150 | testNO1 = propAdd' zero' 151 | 152 | testNO2 : or N Unit 153 | testNO2 = zero' 154 | 155 | testNO3 : or N Unit 156 | testNO3 = add' zero' zero' 157 | 158 | step : U -> U 159 | step X = or X Unit 160 | 161 | lemIt : (A:U) (f:A->A) (a:A) -> Id A a (f a) -> Id A a (f (f a)) 162 | lemIt A f a p = subst A (\ z -> Id A a (f z)) a (f a) p p 163 | 164 | isoNOIt : Id U N (step (step N)) 165 | isoNOIt = lemIt U step N isoNO 166 | 167 | isoNOIt2 : Id U N (step (step (step (step N)))) 168 | isoNOIt2 = lemIt U (\ x -> step (step x)) N isoNOIt 169 | 170 | aZNIt : aZero (step (step N)) 171 | aZNIt = subst U aZero N (step (step N)) isoNOIt aZN 172 | 173 | zeroIt : step (step N) 174 | zeroIt = aZNIt.1 175 | 176 | sndaZNIt : Sigma ((step (step N)) -> (step (step N)) -> (step (step N))) 177 | (\ f -> (x:(step (step N))) -> Id (step (step N)) (f zeroIt x) x) 178 | sndaZNIt = aZNIt.2 179 | 180 | addIt : (step (step N)) -> (step (step N)) -> step (step N) 181 | addIt = sndaZNIt.1 182 | 183 | propAddIt : (x:step (step N)) -> Id (step (step N)) (addIt zeroIt x) x 184 | propAddIt = sndaZNIt.2 185 | 186 | testIt : step (step N) 187 | testIt = addIt (inl (inl zero)) (inl (inl (suc zero))) 188 | 189 | testIt1 : Id (step (step N)) (addIt zeroIt zeroIt) zeroIt 190 | testIt1 = propAddIt zeroIt 191 | 192 | testIt2 : step (step N) 193 | testIt2 = zeroIt 194 | 195 | testIt3 : step (step N) 196 | testIt3 = addIt zeroIt zeroIt 197 | 198 | step4 : U -> U 199 | step4 x = step (step (step (step x))) 200 | 201 | aZNIt2 : aZero (step4 N) 202 | aZNIt2 = subst U aZero N (step4 N) isoNOIt2 aZN 203 | 204 | zeroIt2 : step4 N 205 | zeroIt2 = aZNIt2.1 206 | 207 | sndaZNIt2 : Sigma ((step4 N) -> (step4 N) -> (step4 N)) 208 | (\ f -> (x:(step4 N)) -> Id (step4 N) (f zeroIt2 x) x) 209 | sndaZNIt2 = aZNIt2.2 210 | 211 | addIt2 : (step4 N) -> (step4 N) -> step4 N 212 | addIt2 = sndaZNIt2.1 213 | 214 | propAddIt2 : (x:step4 N) -> Id (step4 N) (addIt2 zeroIt2 x) x 215 | propAddIt2 = sndaZNIt2.2 216 | 217 | inl4 : N -> step4 N 218 | inl4 x = inl (inl (inl (inl x))) 219 | 220 | testIt2 : step4 N 221 | testIt2 = addIt2 (inl4 zero) (inl4 zero) 222 | 223 | testIt21 : Id (step4 N) (addIt2 zeroIt2 zeroIt2) zeroIt2 224 | testIt21 = propAddIt2 zeroIt2 225 | 226 | testIt22 : step4 N 227 | testIt22 = zeroIt2 228 | 229 | testIt23 : step4 N 230 | testIt23 = addIt2 zeroIt2 zeroIt2 231 | -------------------------------------------------------------------------------- /examples/omega.cub: -------------------------------------------------------------------------------- 1 | module omega where 2 | 3 | import univalence 4 | 5 | Omega : U 6 | Omega = Sigma U prop 7 | 8 | -- Omega is the -set- of truth values 9 | -- not trivial and needs the following Lemmas 10 | 11 | -- if B is a family of proposition over A then Sigma A B -> A is injective 12 | 13 | lemPInj1 : (A : U) (B : A -> U) -> ((x:A) -> prop (B x)) -> (a0 a1:A) -> (p:Id A a0 a1) -> 14 | (b0:B a0) -> (b1:B a1) -> Id (Sigma A B) (a0,b0) (a1,b1) 15 | lemPInj1 A B pB a0 a1 p = subst A C a0 a1 p rem 16 | where 17 | C : A -> U -- (a1:A) -> Id A a0 a1 -> U 18 | C a1 = (b0:B a0) -> (b1:B a1) -> Id (Sigma A B) (a0,b0) (a1,b1) 19 | 20 | rem : C a0 21 | rem b0 b1 = mapOnPath (B a0) (Sigma A B) (\ b -> (a0,b)) b0 b1 (pB a0 b0 b1) 22 | 23 | lemPropInj : (A : U) (B : A -> U) -> ((x:A) -> prop (B x)) -> injective (Sigma A B) A (\ z -> z.1) 24 | lemPropInj A B pB z0 z1 p = lemPInj1 A B pB z0.1 z1.1 p z0.2 z1.2 25 | 26 | 27 | lemPInj2 : (A : U) (B : A -> U) -> (pB: (x:A) -> prop (B x)) -> (z:Sigma A B) -> 28 | Id (Id (Sigma A B) z z) (refl (Sigma A B) z) (lemPropInj A B pB z z (refl A z.1)) 29 | lemPInj2 A B pB z = rem 30 | where 31 | T : U 32 | T = Sigma A B 33 | 34 | a:A 35 | a = z.1 36 | 37 | b : B a 38 | b = z.2 39 | 40 | L : U 41 | L = Id T z z 42 | 43 | C : A -> U 44 | C a1 = (b0 : B a) -> (b1:B a1) -> Id T (z.1,b0) (a1,b1) 45 | 46 | rem2 : C a 47 | rem2 b0 b1 = mapOnPath (B a) T (\ b -> (z.1,b)) b0 b1 (pB a b0 b1) 48 | 49 | rem1 : Id (C a) rem2 (lemPInj1 A B pB a a (refl A a)) 50 | rem1 = substeq A C a rem2 51 | 52 | Lb : U 53 | Lb = Id (B a) b b 54 | 55 | rem4 : Id Lb (refl (B a) b) (pB a b b) 56 | rem4 = propUIP (B a) (pB a) b b (refl (B a) b) (pB a b b) 57 | 58 | rem3 : Id L (mapOnPath (B a) T (\ b -> (a,b)) b b (refl (B a) b)) (rem2 b b) 59 | rem3 = mapOnPath Lb L (mapOnPath (B a) T (\ b -> (a,b)) b b) (refl (B a) b) (pB a b b) rem4 60 | 61 | rem5 : Id ((b1 : B a) -> Id T (a,b) (a,b1)) (rem2 b) (lemPInj1 A B pB a a (refl A a) b) 62 | rem5 = appEq (B a) (\ b0 -> (b1 : B a) -> Id T (a,b0) (a,b1)) b rem2 (lemPInj1 A B pB a a (refl A a)) rem1 63 | 64 | rem6 : Id L (rem2 b b) (lemPInj1 A B pB a a (refl A a) b b) 65 | rem6 = appEq (B a) (\ b1 -> Id T (a,b) (a,b1)) b 66 | (rem2 b) (lemPInj1 A B pB a a (refl A a) b) rem5 67 | 68 | rem : Id L (refl T (a,b)) (lemPInj1 A B pB a a (refl A a) b b) 69 | rem = comp L (refl T (a,b)) (rem2 b b) (lemPInj1 A B pB a a (refl A a) b b) rem3 rem6 70 | 71 | -- we should be able to deduce from all this that Omega is a set 72 | 73 | isTrue : Omega -> U 74 | isTrue z = z.1 75 | 76 | lemIsTrue : (x y : Omega) -> (isTrue x -> isTrue y) -> (isTrue y -> isTrue x) -> Id Omega x y 77 | lemIsTrue x y f g = injf x y rem 78 | where 79 | injf : injective Omega U isTrue 80 | injf = lemPropInj U prop propIsProp 81 | 82 | rem : Id U (isTrue x) (isTrue y) 83 | rem = propId (isTrue x) (isTrue y) x.2 y.2 f g 84 | 85 | lemInj : (A B : U) (f : A -> B) -> (injf : injective A B f) 86 | -> ((x:A) -> Id (Id A x x) (refl A x) (injf x x (refl B (f x)))) 87 | -> (x y : A) -> (p:Id A x y) -> Id (Id A x y) p (injf x y (mapOnPath A B f x y p)) 88 | lemInj A B f injf h x = 89 | J A x (\ y p -> Id (Id A x y) p (injf x y (mapOnPath A B f x y p))) (h x) 90 | 91 | omegaIsSet : set Omega 92 | omegaIsSet = rem4 93 | where 94 | rem : (A:U) -> prop (prop A) 95 | rem = propIsProp 96 | 97 | g : (x:Omega) -> prop (isTrue x) 98 | g x = x.2 99 | 100 | injf : injective Omega U isTrue 101 | injf = lemPropInj U prop rem 102 | 103 | rem1 : (z:Omega) -> Id (Id Omega z z) (refl Omega z) (injf z z (refl U (isTrue z))) 104 | rem1 = lemPInj2 U prop rem 105 | 106 | rem2 : (x y : Omega) -> (p : Id Omega x y) 107 | -> Id (Id Omega x y) p (injf x y (mapOnPath Omega U isTrue x y p)) 108 | rem2 = lemInj Omega U isTrue injf rem1 109 | 110 | rem3 : (x y : Omega) -> prop (Id U (isTrue x) (isTrue y)) 111 | rem3 x y = idPropIsProp (isTrue x) (isTrue y) (g x) (g y) 112 | 113 | rem4 : (x y : Omega) -> (p q : Id Omega x y) -> Id (Id Omega x y) p q 114 | rem4 x y p q = compDown (Id Omega x y) p (injf x y (h p)) q (injf x y (h q)) 115 | (rem2 x y p) (rem2 x y q) rem8 116 | where 117 | h : Id Omega x y -> Id U (isTrue x) (isTrue y) 118 | h = mapOnPath Omega U isTrue x y 119 | 120 | rem5 : Id (Id U (isTrue x) (isTrue y)) (h p) (h q) 121 | rem5 = rem3 x y (h p) (h q) 122 | 123 | rem8 : Id (Id Omega x y) (injf x y (h p)) (injf x y (h q)) 124 | rem8 = mapOnPath (Id U (isTrue x) (isTrue y)) (Id Omega x y) (injf x y) (h p) (h q) rem5 125 | -------------------------------------------------------------------------------- /examples/opacity.cub: -------------------------------------------------------------------------------- 1 | module opacity where 2 | import prelude 3 | 4 | -- The effect ot opacity is local 5 | x : Unit 6 | x = y where 7 | y : Unit 8 | y = tt 9 | opaque y 10 | 11 | test : Id Unit x tt 12 | test = refl Unit tt 13 | -------------------------------------------------------------------------------- /examples/opacity_fail.cub: -------------------------------------------------------------------------------- 1 | module opacity_fail where 2 | 3 | import primitives 4 | 5 | Bool : U 6 | data Bool = true | false 7 | 8 | x : Bool 9 | x = false 10 | 11 | opaque x 12 | 13 | y : Bool 14 | y = x 15 | where x : Bool 16 | x = true 17 | 18 | failure : Id Bool x y 19 | failure = refl Bool x 20 | 21 | transparent x 22 | -------------------------------------------------------------------------------- /examples/prelude.cub: -------------------------------------------------------------------------------- 1 | -- some basic data types and functions 2 | module prelude where 3 | 4 | import primitives 5 | 6 | rel : U -> U 7 | rel A = A -> A -> U 8 | 9 | euclidean : (A : U) -> rel A -> U 10 | euclidean A R = (a b c : A) -> R a c -> R b c -> R a b 11 | 12 | and : (A B : U) -> U 13 | and A B = Sigma A (\_ -> B) 14 | 15 | Pi : (A:U) -> (A -> U) -> U 16 | Pi A B = (x:A) -> B x 17 | 18 | -- subst : (A : U) (P : A -> U) (a x : A) (p : Id A a x) -> P a -> P x 19 | -- subst A P a x p d = J A a (\ x q -> P x) d x p 20 | 21 | subst : (A : U) (P : A -> U) (a x : A) (p : Id A a x) -> P a -> P x 22 | subst A P a x p = transport (P a) (P x) (mapOnPath A U P a x p) 23 | 24 | substInv : (A : U) (P : A -> U) (a x : A) (p : Id A a x) -> P x -> P a 25 | substInv A P a x p = subst A (\ y -> P y -> P a) a x p (\ h -> h) 26 | 27 | -- substeq : (A : U) (P : A -> U) (a : A) (d : P a) -> 28 | -- Id (P a) d (subst A P a a (refl A a) d) 29 | -- substeq A P a d = Jeq A a (\ x q -> P x) d 30 | 31 | substeq : (A : U) (P : A -> U) (a : A) (d : P a) -> 32 | Id (P a) d (subst A P a a (refl A a) d) 33 | substeq A P a d = transportRef (P a) d 34 | 35 | -- Monoids 36 | Monoid : U -> U 37 | data Monoid A = 38 | monoid (z : A) 39 | (op : A -> A -> A) 40 | (_ : (a b c : A) -> Id A (op a (op b c)) (op (op a b) c)) 41 | (_ : (a : A) -> Id A (op a z) a) 42 | (_ : (a : A) -> Id A (op z a) a) 43 | 44 | zm : (A : U) (m : Monoid A) -> A 45 | zm A = split monoid a -> a 46 | 47 | opm : (A : U) (m : Monoid A) -> (A -> A -> A) 48 | opm A = split monoid _ op -> op 49 | 50 | opmA : (A : U) (m : Monoid A) -> 51 | ((a b c : A) -> Id A (opm A m a (opm A m b c)) (opm A m (opm A m a b) c)) 52 | opmA A = split monoid _ _ assoc -> assoc 53 | 54 | opm0 : (A : U) (m : Monoid A) -> ((a : A) -> Id A (opm A m a (zm A m)) a) 55 | opm0 A = split monoid _ _ _ p -> p 56 | 57 | op0m : (A : U) (m : Monoid A) -> ((a : A) -> Id A (opm A m (zm A m) a) a) 58 | op0m A = split monoid _ _ _ _ p -> p 59 | 60 | transMonoid : (A B : U) -> Id U A B -> Monoid A -> Monoid B 61 | transMonoid = subst U Monoid 62 | 63 | transMonoidInv : (A B : U) -> Id U A B -> Monoid B -> Monoid A 64 | transMonoidInv = substInv U Monoid 65 | 66 | -- some data types 67 | 68 | Unit : U 69 | data Unit = tt 70 | 71 | N0 : U 72 | data N0 = 73 | 74 | efq : (A : U) -> N0 -> A 75 | efq A = split {} 76 | 77 | neg : U -> U 78 | neg A = A -> N0 79 | 80 | or : U -> U -> U 81 | data or A B = inl (a : A) | inr (b : B) 82 | 83 | orElim : (A B C : U) -> (A -> C) -> (B -> C) -> or A B -> C 84 | orElim A B C f g = split 85 | inl a -> f a 86 | inr b -> g b 87 | 88 | dec : U -> U 89 | dec A = or A (neg A) 90 | 91 | discrete : U -> U 92 | discrete A = (a b : A) -> dec (Id A a b) 93 | 94 | N0Dec : discrete N0 95 | N0Dec x y = inl rem 96 | where rem : Id N0 x y 97 | rem = efq (Id N0 x y) x 98 | 99 | decEqCong : (A B : U) (f : A -> B) (g : B -> A) -> dec A -> dec B 100 | decEqCong A B f g = split 101 | inl a -> inl (f a) 102 | inr h -> inr (\b -> h (g b)) 103 | 104 | -- Nat 105 | N : U 106 | data N = zero | suc (n : N) 107 | 108 | pred : N -> N 109 | pred = split 110 | zero -> zero 111 | suc n -> n 112 | 113 | sucInj : (n m : N) -> Id N (suc n) (suc m) -> Id N n m 114 | sucInj n m h = mapOnPath N N pred (suc n) (suc m) h 115 | 116 | addN : N -> N -> N 117 | addN = split 118 | zero -> \n -> n 119 | suc m -> \n -> suc (addN m n) 120 | 121 | add0N : (m : N) -> Id N (addN zero m) m 122 | add0N = refl N 123 | 124 | addN0 : (m : N) -> Id N (addN m zero) m 125 | addN0 = split 126 | zero -> refl N zero 127 | suc n -> mapOnPath N N (\x -> suc x) (addN n zero) n (addN0 n) 128 | 129 | addNA : (m n p : N) -> Id N (addN m (addN n p)) (addN (addN m n) p) 130 | addNA = split 131 | zero -> \n p -> refl N (addN n p) 132 | suc m' -> \n p -> mapOnPath N N (\x -> suc x) (addN m' (addN n p)) 133 | (addN (addN m' n) p) (addNA m' n p) 134 | 135 | -- Subtract m from n 136 | subN : N -> N -> N 137 | subN = split 138 | zero -> \n -> n 139 | suc m -> split 140 | zero -> zero 141 | suc n -> subN m n 142 | 143 | -- This cannot be defined here because it relies on function... 144 | -- subNK : (m : N) -> retract N N (addN m) (subN m) 145 | -- subNK = split 146 | -- zero -> \a -> refl N a 147 | -- suc m' -> \a -> subNK m' a 148 | 149 | -- addNinj : (m : N) -> injective N N (addN m) 150 | -- addNinj m = retractInj N N (addN m) (subN m) (subNK m) 151 | 152 | -- Additive monoid on N 153 | monoidAddN : Monoid N 154 | monoidAddN = monoid zero addN addNA addN0 add0N 155 | 156 | znots : (n : N) -> neg (Id N zero (suc n)) 157 | znots n h = subst N T zero (suc n) h zero 158 | where 159 | T : N -> U 160 | T = split 161 | zero -> N 162 | suc n -> N0 163 | 164 | snotz : (n : N) -> neg (Id N (suc n) zero) 165 | snotz n h = substInv N T (suc n) zero h zero 166 | where 167 | T : N -> U 168 | T = split 169 | zero -> N 170 | suc n -> N0 171 | 172 | natDec : discrete N 173 | natDec = split 174 | zero -> split 175 | zero -> inl (refl N zero) 176 | suc m -> inr (znots m) 177 | suc n -> split 178 | zero -> inr (snotz n) 179 | suc m -> decEqCong (Id N n m) (Id N (suc n) (suc m)) 180 | (mapOnPath N N (\x -> suc x) n m) (sucInj n m) (natDec n m) 181 | 182 | -- Bool 183 | Bool : U 184 | data Bool = true | false 185 | 186 | andBool : Bool -> Bool -> Bool 187 | andBool = split 188 | true -> \x -> x 189 | false -> \x -> false 190 | 191 | orBool : Bool -> Bool -> Bool 192 | orBool = split 193 | true -> \_ -> true 194 | false -> \x -> x 195 | 196 | not : Bool -> Bool 197 | not = split 198 | true -> false 199 | false -> true 200 | 201 | notK : (x : Bool) -> Id Bool (not (not x)) x 202 | notK = split 203 | true -> refl Bool true 204 | false -> refl Bool false 205 | 206 | isEven : N -> Bool 207 | isEven = split 208 | zero -> true 209 | suc n -> not (isEven n) 210 | 211 | andBoolTrue : (a : Bool) -> Id Bool (andBool a true) a 212 | andBoolTrue = split 213 | true -> refl Bool true 214 | false -> refl Bool false 215 | 216 | andTrueBool : (a : Bool) -> Id Bool (andBool true a) a 217 | andTrueBool a = refl Bool a 218 | 219 | andBoolA : (a b c : Bool) -> 220 | Id Bool (andBool a (andBool b c)) (andBool (andBool a b) c) 221 | andBoolA = split 222 | true -> \b c -> refl Bool (andBool b c) 223 | false -> \_ _ -> refl Bool false 224 | 225 | tnotf : neg (Id Bool true false) 226 | tnotf h = 227 | let T : Bool -> U 228 | T = split 229 | true -> N 230 | false -> N0 231 | in subst Bool T true false h zero 232 | 233 | fnott : neg (Id Bool false true) 234 | fnott h = substInv Bool T false true h zero 235 | where 236 | T : Bool -> U 237 | T = split 238 | true -> N 239 | false -> N0 240 | 241 | boolDec : discrete Bool 242 | boolDec = split 243 | true -> split 244 | true -> inl (refl Bool (true)) 245 | false -> inr tnotf 246 | false -> split 247 | true -> inr fnott 248 | false -> inl (refl Bool (false)) 249 | 250 | unitDec : discrete Unit 251 | unitDec = split tt -> split tt -> inl (refl Unit tt) 252 | 253 | appId : (A B : U) (a : A) (f0 f1 : A -> B) -> 254 | Id (A -> B) f0 f1 -> Id B (f0 a) (f1 a) 255 | appId A B a = mapOnPath (A -> B) B (\f -> f a) 256 | 257 | appEq : (A : U) (B : A -> U) (a : A) (f0 f1 : Pi A B) -> 258 | Id (Pi A B) f0 f1 -> Id (B a) (f0 a) (f1 a) 259 | appEq A B a = mapOnPath (Pi A B) (B a) (\ f -> f a) 260 | 261 | J : (A : U) (a : A) (C : (x : A) -> Id A a x -> U) 262 | (d : C a (refl A a)) (x : A) (p : Id A a x) -> C x p 263 | J A a C d x p = subst (singl A a) T (a, refl A a) (x, p) (contrSingl A a x p) d 264 | where T : singl A a -> U 265 | T z = C (z.1) (z.2) 266 | 267 | funExt : (A : U) (B : A -> U) (f g : (a : A) -> B a) 268 | (p : ((x : A) -> (Id (B x) (f x) (g x)))) -> Id ((y : A) -> B y) f g 269 | funExt A B f g p = funHExt A B f g rem 270 | where rem : (a x : A) -> (p : Id A a x) -> (IdS A B a x p (f a) (g x)) 271 | rem a = J A a (\x p -> (IdS A B a x p (f a) (g x))) (p a) 272 | 273 | tId : (A : U) (a : A) (v : pathTo A a) -> Id (pathTo A a) (sId A a) v 274 | tId A a z = rem (z.1) a (z.2) 275 | where 276 | rem : (x y : A) (p : Id A x y) -> Id (pathTo A y) (sId A y) (x, p) 277 | rem x = J A x (\y p -> Id (pathTo A y) (sId A y) (x, p)) 278 | (refl (pathTo A x) (sId A x)) 279 | 280 | typEquivS : (A B : U) -> (f : A -> B) -> U 281 | typEquivS A B f = (y : B) -> fiber A B f y 282 | 283 | typEquivT : (A B : U) -> (f : A -> B) -> typEquivS A B f -> U 284 | typEquivT A B f s = (y : B) -> (v : fiber A B f y) -> Id (fiber A B f y) (s y) v 285 | 286 | isEquiv : (A B : U) (f : A -> B) -> U 287 | isEquiv A B f = Sigma (typEquivS A B f) (typEquivT A B f) 288 | 289 | isEquivEq : (A B : U) (f : A -> B) -> isEquiv A B f -> Id U A B 290 | isEquivEq A B f z = equivEq A B f z.1 z.2 291 | 292 | -- not needed if we have eta 293 | 294 | etaId : (A : U) (B : A -> U) -> (f : Pi A B) -> Id (Pi A B) (\x -> f x) f 295 | etaId A B f = funExt A B (\x -> f x) f (\x -> refl (B x) (f x)) 296 | 297 | funSplit : (A : U) (B : A -> U) (C : Pi A B -> U) -> 298 | ((f : Pi A B) -> C (\x -> f x)) -> Pi (Pi A B) C 299 | funSplit A B C eC f = subst (Pi A B) C (\x -> f x) f (etaId A B f) (eC f) 300 | 301 | lemProp1 : (A : U) -> (A -> prop A) -> prop A 302 | lemProp1 A h a0 = h a0 a0 303 | 304 | propN0 : prop N0 305 | propN0 a b = efq (Id N0 a b) a 306 | 307 | -- a product of propositions is a proposition 308 | 309 | isPropProd : (A : U) (B : A -> U) (pB : (x : A) -> prop (B x)) -> prop (Pi A B) 310 | isPropProd A B pB f0 f1 = funExt A B f0 f1 (\x -> pB x (f0 x) (f1 x)) 311 | 312 | propNeg : (A : U) -> prop (neg A) 313 | propNeg A = isPropProd A (\_ -> N0) (\_ -> propN0) 314 | 315 | lemProp2 : (A : U) -> prop A -> prop (dec A) 316 | lemProp2 A pA = split 317 | inl a -> split 318 | inl b -> mapOnPath A (dec A) (\x -> inl x) a b (pA a b) 319 | inr nb -> efq (Id (dec A) (inl a) (inr nb)) (nb a) 320 | inr na -> split 321 | inl b -> efq (Id (dec A) (inr na) (inl b)) (na b) 322 | inr nb -> mapOnPath (neg A) (dec A) (\x -> inr x) na nb (propNeg A na nb) 323 | 324 | singl : (A : U) -> A -> U 325 | singl = pathTo 326 | 327 | idIsEquiv : (A : U) -> isEquiv A A (id A) 328 | idIsEquiv A = (sId A, tId A) 329 | 330 | propUnit : prop Unit 331 | propUnit = split tt -> split tt -> refl Unit tt 332 | 333 | propPi : (A : U) (B : A -> U) -> ((x : A) -> prop (B x)) -> prop ((x : A) -> B x) 334 | propPi A B h f0 f1 = funExt A B f0 f1 (\x -> h x (f0 x) (f1 x)) 335 | 336 | propImply : (A B : U) -> (A -> prop B) -> prop (A -> B) 337 | propImply A B h = propPi A (\_ -> B) h 338 | 339 | propFam : (A : U) (B : A -> U) -> U 340 | propFam A B = (a : A) -> prop (B a) 341 | 342 | reflexive : (A : U) -> rel A -> U 343 | reflexive A R = (a : A) -> R a a 344 | 345 | symmetry : (A : U) -> rel A -> U 346 | symmetry A R = (a b : A) -> R a b -> R b a 347 | 348 | equivalence : (A : U) -> rel A -> U 349 | equivalence A R = and (reflexive A R) (euclidean A R) 350 | 351 | eqToSym : (A : U) (R : rel A) -> equivalence A R -> symmetry A R 352 | eqToSym A R z a b = (z.2) b a b (z.1 b) 353 | 354 | eqToInvEucl : (A : U) (R : rel A) -> equivalence A R -> 355 | (a b c : A) -> R c a -> R c b -> R a b 356 | eqToInvEucl A R eq a b c p q = 357 | eq.2 a b c (eqToSym A R eq c a p) (eqToSym A R eq c b q) 358 | 359 | -- definition by case on a decidable equality 360 | -- needed for Nicolai Kraus example 361 | 362 | defCase : (A X : U) -> X -> X -> dec A -> X 363 | defCase A X x0 x1 = split 364 | inl _ -> x0 365 | inr _ -> x1 366 | 367 | IdDefCasel : (A X : U) (x0 x1 : X) (p : dec A) -> A -> 368 | Id X (defCase A X x0 x1 p) x0 369 | IdDefCasel A X x0 x1 = split 370 | inl _ -> \_ -> refl X x0 371 | inr v -> \u -> efq (Id X (defCase A X x0 x1 (inr v)) x0) (v u) 372 | 373 | IdDefCaser : (A X : U) (x0 x1 : X) (p : dec A) -> neg A -> 374 | Id X (defCase A X x0 x1 p) x1 375 | IdDefCaser A X x0 x1 = split 376 | inl u -> \v -> efq (Id X (defCase A X x0 x1 (inl u)) x1) (v u) 377 | inr _ -> \_ -> refl X x1 -------------------------------------------------------------------------------- /examples/primitives.cub: -------------------------------------------------------------------------------- 1 | module primitives where 2 | 3 | primitive Id : (A : U) (a b : A) -> U 4 | 5 | primitive refl : (A : U) (a : A) -> Id A a a 6 | 7 | primitive inh : U -> U 8 | 9 | primitive inc : (A : U) -> A -> inh A 10 | 11 | prop : U -> U 12 | prop A = (a b : A) -> Id A a b 13 | 14 | primitive squash : (A : U) -> prop (inh A) 15 | 16 | primitive inhrec : (A : U) (B : U) (p : prop B) (f : A -> B) (a : inh A) -> B 17 | 18 | Sigma : (A : U) (B : A -> U) -> U 19 | Sigma A B = (x : A) * B x 20 | 21 | fiber : (A B : U) (f : A -> B) (y : B) -> U 22 | fiber A B f y = Sigma A (\x -> Id B (f x) y) 23 | 24 | id : (A : U) -> A -> A 25 | id A a = a 26 | 27 | pathTo : (A:U) -> A -> U 28 | pathTo A = fiber A A (id A) 29 | 30 | sId : (A : U) (a : A) -> pathTo A a 31 | sId A a = (a, refl A a) 32 | 33 | singl : (A : U) -> A -> U 34 | singl A a = Sigma A (Id A a) 35 | 36 | primitive contrSingl : (A : U) (a b : A) (p : Id A a b) -> 37 | Id (singl A a) (a, refl A a) (b, p) 38 | 39 | primitive equivEq : (A B : U) (f : A -> B) (s : (y : B) -> fiber A B f y) 40 | (t : (y : B) -> (v : fiber A B f y) -> 41 | Id (fiber A B f y) (s y) v) -> Id U A B 42 | 43 | primitive transport : (A B : U) -> Id U A B -> A -> B 44 | 45 | primitive transpInv : (A B : U) -> Id U A B -> B -> A 46 | 47 | primitive transportRef : (A : U) (a : A) -> Id A a (transport A A (refl U A) a) 48 | 49 | primitive equivEqRef : (A : U) -> (s : (y : A) -> pathTo A y) -> 50 | (t : (y : A) -> (v : pathTo A y) -> 51 | Id (pathTo A y) (s y) v) -> 52 | Id (Id U A A) (refl U A) (equivEq A A (id A) s t) 53 | 54 | primitive transpEquivEq : 55 | (A B : U) -> (f : A -> B) (s : (y : B) -> fiber A B f y) -> 56 | (t : (y : B) -> (v : fiber A B f y) -> Id (fiber A B f y) (s y) v) -> 57 | (a : A) -> Id B (f a) (transport A B (equivEq A B f s t) a) 58 | 59 | primitive mapOnPath : (A B : U) (f : A -> B) (a b : A) 60 | (p : Id A a b) -> Id B (f a) (f b) 61 | 62 | primitive appOnPath : (A B : U) (f g : A -> B) (a b : A) 63 | (q : Id (A -> B) f g) (p : Id A a b) -> Id B (f a) (g b) 64 | 65 | primitive IdP : (A B : U) -> Id U A B -> A -> B -> U 66 | 67 | IdS : (A : U) (F : A -> U) (a0 a1 : A) (p : Id A a0 a1) -> F a0 -> F a1 -> U 68 | IdS A F a0 a1 p = IdP (F a0) (F a1) (mapOnPath A U F a0 a1 p) 69 | 70 | primitive mapOnPathD : (A : U) (F : A -> U) (f : (x : A) -> F x) (a0 a1 : A) 71 | (p : Id A a0 a1) -> IdS A F a0 a1 p (f a0) (f a1) 72 | 73 | primitive mapOnPathS : (A : U) (F : A -> U) (C : U) (f : (x : A) -> F x -> C) 74 | (a0 a1 : A) (p : Id A a0 a1) (b0 : F a0) (b1 : F a1) 75 | (q : IdS A F a0 a1 p b0 b1) -> Id C (f a0 b0) (f a1 b1) 76 | 77 | primitive funHExt : (A : U) (B : A -> U) (f g : (a : A) -> B a) -> 78 | ((x y : A) -> (p : Id A x y) -> IdS A B x y p (f x) (g y)) -> 79 | Id ((y : A) -> B y) f g 80 | 81 | -- The circle. 82 | primitive S1 : U 83 | 84 | primitive base : S1 85 | 86 | primitive loop : Id S1 base base 87 | 88 | primitive S1rec : (F : S1 -> U) (b : F base) 89 | (l : IdS S1 F base base loop b b) (x : S1) -> F x 90 | 91 | -- The interval. 92 | primitive I : U 93 | 94 | primitive I0 : I 95 | 96 | primitive I1 : I 97 | 98 | primitive line : Id I I0 I1 99 | 100 | primitive intrec : (F : I -> U) (s : F I0) (e : F I1) 101 | (l : IdS I F I0 I1 line s e) (x : I) -> F x 102 | -------------------------------------------------------------------------------- /examples/quotient.cub: -------------------------------------------------------------------------------- 1 | module quotient where 2 | 3 | import description 4 | import exists 5 | import hedberg 6 | 7 | Quot : (A : U) (R : rel A) -> U 8 | data Quot A R = 9 | class (P : A -> U) 10 | (un : (a b : A) -> P a -> P b -> R a b) 11 | (cp : (a b : A) -> P a -> R a b -> P b) 12 | (ex : exists A P) 13 | (pr : propFam A P) 14 | 15 | propRel : (A : U) (R : rel A) -> U 16 | propRel A R = (a b : A) -> prop (R a b) 17 | 18 | canSurj : (A : U) (R : rel A) -> equivalence A R -> propRel A R -> 19 | A -> Quot A R 20 | canSurj A R h h' c = class (R c) un cp ex pr 21 | where un : (a b : A) -> R c a -> R c b -> R a b 22 | un a b p q = eqToInvEucl A R h a b c p q 23 | 24 | cp : (a b : A) -> R c a -> R a b -> R c b 25 | cp a b p q = h.2 c b a p (eqToSym A R h a b q) 26 | ex : exists A (R c) 27 | ex = inc (Sigma A (R c)) (c,h.1 c) 28 | pr : propFam A (R c) 29 | pr a = h' c a 30 | 31 | resp : (A B : U) (R : rel A) (f : A -> B) -> U 32 | resp A B R f = (x y : A) -> R x y -> Id B (f x) (f y) 33 | 34 | image : (A B : U) (f : A -> B) (P : A -> U) -> B -> U 35 | image A B f P b = exists A (\a -> and (P a) (Id B (f a) b)) 36 | 37 | propAnd : (A B : U) -> prop A -> prop B -> prop (and A B) 38 | propAnd A B p q = propSig A F rem (\a a' _ _ -> p a a') 39 | where F : A -> U 40 | F a = B 41 | rem : propFam A F 42 | rem a = q 43 | 44 | -- should also contain the proof that Quot A R is a set and that 45 | -- the equivalence class of two related elements are equal 46 | -- but what we have is enough to test that we can compute with the axiom 47 | -- of description 48 | 49 | univQuot : (A B : U) (R : rel A) (f : A -> B) -> 50 | set B -> resp A B R f -> (eqR : equivalence A R) (pR : propRel A R) 51 | (_ : Quot A R) -> B 52 | univQuot A B R f uip fresp eqR pR = g -- pair g rem 53 | where 54 | g : Quot A R -> B 55 | g = split 56 | class P un cp ex pr -> iota B imfP rem1 rem2 57 | where 58 | imfP : B -> U 59 | imfP = image A B f P 60 | rem1 : propFam B imfP 61 | rem1 b = squash (Sigma A (\a -> and (P a) (Id B (f a) b))) 62 | S : B -> A -> U 63 | S b a = and (P a) (Id B (f a) b) 64 | 65 | rem3 : Sigma A P -> exists B imfP 66 | rem3 z = inc (Sigma B imfP) 67 | (f z.1,inc (Sigma A (S (f z.1))) (z.1,(z.2,refl B (f z.1)))) 68 | rem4 : exists B imfP 69 | rem4 = inhrec (Sigma A P) (exists B imfP) (squash (Sigma B imfP)) rem3 ex 70 | 71 | rem6 : (b b' : B) (a a' : A) (_ : and (P a) (Id B (f a) b)) 72 | (_ : and (P a') (Id B (f a') b')) -> Id B b b' 73 | rem6 b b' a a' z z' = compUp B (f a) b (f a') b' z.2 z'.2 rem7 74 | where rem8 : R a a' 75 | rem8 = un a a' z.1 z'.1 76 | rem7 : Id B (f a) (f a') 77 | rem7 = fresp a a' rem8 78 | 79 | rem7 : (b b' : B) -> Sigma A (S b) -> Sigma A (S b') -> Id B b b' 80 | rem7 b b' z z' = rem6 b b' z.1 z'.1 z.2 z'.2 81 | 82 | rem8 : (b b' : B) -> Sigma A (S b) -> exists A (S b') -> Id B b b' 83 | rem8 b b' h = exElim A (S b') (Id B b b') (uip b b') (rem7 b b' h) 84 | 85 | rem9 : (b b' : B) -> exists A (S b) -> exists A (S b') -> Id B b b' 86 | rem9 b b' h h' = exElim A (S b) (Id B b b') (uip b b') 87 | (\h'' -> rem8 b b' h'' h') h 88 | 89 | rem5 : atmostOne B imfP 90 | rem5 = rem9 91 | 92 | rem2 : exactOne B imfP 93 | rem2 = (rem4,rem5) 94 | 95 | 96 | kernel : (A B : U) (f : A -> B) -> rel A 97 | kernel A B f a a' = Id B (f a) (f a') 98 | 99 | kerRef : (A B : U) (f : A -> B) -> reflexive A (kernel A B f) 100 | kerRef A B f a = refl B (f a) 101 | 102 | kerEucl : (A B : U) (f : A -> B) -> euclidean A (kernel A B f) 103 | kerEucl A B f a b c p q = compInv B (f c) (f a) (f b) rem rem1 104 | where rem : Id B (f c) (f a) 105 | rem = inv B (f a) (f c) p 106 | rem1 : Id B (f c) (f b) 107 | rem1 = inv B (f b) (f c) q 108 | 109 | kerEquiv : (A B : U) (f : A -> B) -> equivalence A (kernel A B f) 110 | kerEquiv A B f = (kerRef A B f,kerEucl A B f) 111 | 112 | 113 | mod2 : rel N 114 | mod2 = kernel N Bool isEven 115 | 116 | propMod2 : propRel N mod2 117 | propMod2 n m = boolIsSet (isEven n) (isEven m) 118 | 119 | Z2 : U 120 | Z2 = Quot N mod2 121 | 122 | respIsEven : resp N Bool mod2 isEven 123 | respIsEven n m h = h 124 | 125 | barIsEven : Z2 -> Bool 126 | barIsEven = univQuot N Bool mod2 isEven boolIsSet respIsEven (kerEquiv N Bool isEven) propMod2 127 | 128 | 129 | five : N 130 | five = suc (suc (suc (suc (suc (zero))))) 131 | 132 | eigth : N 133 | eigth = suc (suc (suc five)) 134 | 135 | fiveBar : Z2 136 | fiveBar = canSurj N mod2 (kerEquiv N Bool isEven) propMod2 five 137 | 138 | eigthBar : Z2 139 | eigthBar = canSurj N mod2 (kerEquiv N Bool isEven) propMod2 eigth 140 | 141 | test5 : Bool 142 | test5 = barIsEven fiveBar 143 | 144 | test8 : Bool 145 | test8 = barIsEven eigthBar 146 | 147 | 148 | -------------------------------------------------------------------------------- /examples/set.cub: -------------------------------------------------------------------------------- 1 | module set where 2 | 3 | import lemId 4 | 5 | UIP : U -> U 6 | UIP A = (a b : A) -> prop (Id A a b) 7 | 8 | set : U -> U 9 | set = UIP 10 | 11 | lem1 : (A :U) -> (a:A) -> (h : (x:A) -> Id A a x) -> 12 | (x y : A) -> (p : Id A x y) -> Id (Id A a y) (comp A a x y (h x) p) (h y) 13 | lem1 A a h x = 14 | J A x (\ y p -> Id (Id A a y) (comp A a x y (h x) p) (h y)) rem 15 | where 16 | rem : Id (Id A a x) (comp A a x x (h x) (refl A x)) (h x) 17 | rem = compIdr A a x (h x) 18 | 19 | lem2 : (A :U) -> (a:A) -> ((x:A) -> Id A a x) -> UIP A 20 | lem2 A a h x y p q = 21 | lemSimpl A a x y (h x) p q rem 22 | where 23 | remp : Id (Id A a y) (comp A a x y (h x) p) (h y) 24 | remp = lem1 A a h x y p 25 | remq : Id (Id A a y) (comp A a x y (h x) q) (h y) 26 | remq = lem1 A a h x y q 27 | rem : Id (Id A a y) (comp A a x y (h x) p) (comp A a x y (h x) q) 28 | rem = compDown (Id A a y) (comp A a x y (h x) p) (h y) (comp A a x y (h x) q) (h y) 29 | remp remq (refl (Id A a y) (h y)) 30 | 31 | propUIP : (A:U) -> prop A -> UIP A 32 | propUIP A h a = lem2 A a (h a) a 33 | 34 | propIsProp : (A : U) -> prop (prop A) 35 | propIsProp A = lemProp1 (prop A) rem 36 | where 37 | rem : prop A -> prop (prop A) 38 | rem pA = rem3 39 | where 40 | rem1 : UIP A 41 | rem1 = propUIP A pA 42 | 43 | rem2 : (a0:A) -> (f g : Pi A (Id A a0)) -> Id (Pi A (Id A a0)) f g 44 | rem2 a0 f g = funExt A (\ a1 -> Id A a0 a1) f g (\ a1 -> rem1 a0 a1 (f a1) (g a1)) 45 | 46 | rem3 : (f g : (a0 a1 :A) -> Id A a0 a1) -> Id ((a0 a1:A) -> Id A a0 a1) f g 47 | rem3 f g = funExt A (\ a0 -> (Pi A (Id A a0))) f g (\ a0 -> rem2 a0 (f a0) (g a0)) 48 | 49 | lemunit : set Unit 50 | lemunit = propUIP Unit propUnit 51 | 52 | test2 : Id (Id Unit tt tt) (refl Unit tt) (refl Unit tt) 53 | test2 = lemunit tt tt (refl Unit tt) (refl Unit tt) 54 | 55 | -- to be a set is a proposition 56 | 57 | setIsProp : (A:U) -> prop (set A) 58 | setIsProp A = propPi A (\ x0 -> (x1:A) -> prop (Id A x0 x1)) rem 59 | where rem : (x0:A) -> prop (Pi A (\ x1 -> prop (Id A x0 x1))) 60 | rem x0 = propPi A (\ x1 -> prop (Id A x0 x1)) rem1 61 | where rem1 : (x1:A) -> prop (prop (Id A x0 x1)) 62 | rem1 x1 = propIsProp (Id A x0 x1) 63 | 64 | -- propIsProp : (A : U) -> prop (prop A) -------------------------------------------------------------------------------- /examples/spector.cub: -------------------------------------------------------------------------------- 1 | -- An example similar to Martin Escardo on Cantor's search 2 | -- implement Spector double negation shift, following the presentation in 3 | -- a proof of strong normalization using domain theory 4 | 5 | -- needs mutual recursion 6 | 7 | module spector where 8 | 9 | import prelude 10 | 11 | leqN : N -> N -> U 12 | leqN = split 13 | zero -> \ m -> Unit 14 | suc n -> split 15 | zero -> N0 16 | suc m -> leqN n m 17 | 18 | lessN : (n:N) (m:N) -> or (leqN (suc n) m) (leqN m n) 19 | lessN = split 20 | zero -> split 21 | zero -> inr tt 22 | suc m -> inl tt 23 | suc n -> split 24 | zero -> inr tt 25 | suc m -> lessN n m 26 | 27 | vect : (N->U) -> N -> U 28 | vect B = split 29 | zero -> Unit 30 | suc n -> and (vect B n) (B n) 31 | 32 | head : (B:N->U) (n:N) -> vect B (suc n) -> B n 33 | head B n p = p.2 34 | 35 | tail : (B:N->U) (n:N) -> vect B (suc n) -> vect B n 36 | tail B n p = p.1 37 | 38 | -- we follow the notation of the paper 39 | 40 | get : (B:N-> U) (n m:N) -> (leqN (suc m) n) -> vect B n -> B m 41 | get B n m p v = head B m (trim (suc m) n p (vect B) (tail B) v) 42 | where 43 | T : (N -> U) -> U 44 | T P = (k:N) -> P (suc k) -> P k 45 | 46 | trim : (n m:N) -> (leqN n m) -> (P:N->U) -> T P -> P m -> P n 47 | trim = split 48 | zero -> split 49 | zero -> \ p P h v -> v 50 | suc m -> \ p P h v -> trim zero m p P h (h m v) 51 | suc n -> split 52 | zero -> \ p P h v -> efq (P (suc n)) p 53 | suc m -> \ p P h v -> trim n m p (\ x -> P (suc x)) (\ x -> h (suc x)) v 54 | 55 | mutual 56 | Phi : (B:N->U) -> ((n:N) -> neg (neg (B n))) -> 57 | neg (Pi N B) -> (n:N) -> neg (vect B n) 58 | Psi : (B:N->U) -> ((n:N) -> neg (neg (B n))) -> 59 | neg (Pi N B) -> (n:N) -> vect B n -> 60 | (x : N) -> (or (leqN (suc x) n) (leqN n x)) -> B x 61 | 62 | Phi B H K n v = K (\x -> Psi B H K n v x (lessN x n)) 63 | Psi B H K n v x = split 64 | inl p -> get B n x p v 65 | inr p -> efq (B x) (H n (\ y -> Phi B H K (suc n) (v, y))) 66 | 67 | spector : (B:N->U) -> ((n:N) -> neg (neg (B n))) -> neg (neg (Pi N B)) 68 | spector B H K = Phi B H K zero tt -------------------------------------------------------------------------------- /examples/subset.cub: -------------------------------------------------------------------------------- 1 | module subset where 2 | 3 | import univalence 4 | import equivTotal 5 | import elimEquiv 6 | 7 | -- a non trivial equivalence: two different ways to represent subsets 8 | -- this is not finished 9 | -- it should provide a non trivial equivalence 10 | 11 | subset1 : U -> U 12 | subset1 A = Sigma U (\ X -> X -> A) 13 | 14 | subset2 : U -> U 15 | subset2 A = A -> U 16 | 17 | -- map in both directions 18 | 19 | sub12 : (A:U) -> subset1 A -> subset2 A 20 | sub12 A z = fiber z.1 A z.2 21 | 22 | sub21 : (A:U) -> subset2 A -> subset1 A 23 | sub21 A P = (Sigma A P,\ x -> x.1) 24 | 25 | retsub : (A:U) -> (P : subset2 A) -> Id (subset2 A) (sub12 A (sub21 A P)) P 26 | retsub A P = funExt A (\ _ -> U) (fiber (Sigma A P) A (\x -> x.1)) P (lem1Sub A P) 27 | 28 | -- in the other direction we use a corollary of equivalence 29 | 30 | lemSecSub : (A X Y:U)(g:X->Y) -> isEquiv X Y g -> (f:Y -> A) -> 31 | Id (subset1 A) (Y,f) (X,\ y -> f (g y)) 32 | lemSecSub A X = elimIsEquiv X P (\ f -> refl (subset1 A) (X,f)) 33 | where 34 | P : (Y:U) -> (X->Y) -> U 35 | P Y g = (f:Y -> A) -> Id (subset1 A) (Y,f) (X,\ y -> f (g y)) 36 | 37 | lem2SecSub : (A X:U) (f:X -> A) -> 38 | isEquiv X (Sigma A (fiber X A f)) (\ x -> (f x,(x,refl A (f x)))) 39 | lem2SecSub A X f = gradLemma X Y g h rgh sgh 40 | where 41 | F : A -> U 42 | F = fiber X A f 43 | 44 | Y : U 45 | Y = Sigma A F 46 | 47 | h : Y -> A 48 | h y = y.1 49 | 50 | g : X -> Y 51 | g x = (f x,(x,refl A (f x))) 52 | 53 | h : Y -> X 54 | h y = y.2.1 55 | 56 | Z : U 57 | Z = Sigma X (\ x -> Sigma A (\ a -> Id A (f x) a)) 58 | 59 | sw1 : Y -> Z 60 | sw1 y = (y.2.1,(y.1,y.2.2)) 61 | 62 | sw2 : Z -> Y 63 | sw2 z = (z.2.1,(z.1,z.2.2)) 64 | 65 | sgh : (x:X) -> Id X (h (g x)) x 66 | sgh x = refl X x 67 | 68 | rgh : (y:Y) -> Id Y (g (h y)) y 69 | rgh y = lem y.2 70 | where 71 | lem : (xp : Sigma X (\ x -> Id A (f x) y.1)) -> Id Y (g (h (y.1,xp))) (y.1,xp) 72 | lem xp = lem1 73 | where 74 | x:X 75 | x = xp.1 76 | 77 | p : Id A (f x) y.1 78 | p = xp.2 79 | 80 | C : (v u:A) -> Id A v u -> U 81 | C v u q = Id (Sigma A (Id A v)) (v,refl A v) (u,q) 82 | 83 | lem5 : (v:A) -> C v v (refl A v) 84 | lem5 v = refl (Sigma A (Id A v)) (v,refl A v) 85 | 86 | lem4 : (v u:A) (q: Id A v u) -> C v u q 87 | lem4 v = J A v (C v) (lem5 v) 88 | 89 | lem3 : Id (Sigma A (Id A (f x))) (f x,refl A (f x)) (y.1,p) 90 | lem3 = lem4 (f x) y.1 xp.2 91 | 92 | lem2 : Id Z (x,(f x,refl A (f x))) (x,(y.1,xp.2)) 93 | lem2 = mapOnPath (Sigma A (Id A (f x))) 94 | (Sigma X (\ x -> Sigma A (Id A (f x)))) 95 | (\ z -> (x,z)) 96 | (f x,refl A (f x)) (y.1,xp.2) lem3 97 | 98 | lem1 : Id Y (f x,(x,refl A (f x))) (y.1,xp) 99 | lem1 = mapOnPath Z Y sw2 (x,(f x,refl A (f x))) (x,(y.1,p)) lem2 100 | 101 | secsub : (A:U) -> (z : subset1 A) -> Id (subset1 A) (sub21 A (sub12 A z)) z 102 | secsub A z = lemSecSub A z.1 Y g (lem2SecSub A z.1 z.2) h 103 | where 104 | X : U 105 | X = z.1 106 | 107 | F : A -> U 108 | F = fiber X A z.2 109 | 110 | Y : U 111 | Y = Sigma A F 112 | 113 | f : X -> A 114 | f = z.2 115 | 116 | h : Y -> A 117 | h y = y.1 118 | 119 | g : X -> Y 120 | g x = (f x,(x,refl A (f x))) 121 | 122 | thmSubset : (A:U) -> Id U (subset1 A) (subset2 A) 123 | thmSubset A = isEquivEq (subset1 A) (subset2 A) (sub12 A) rem 124 | where rem : isEquiv (subset1 A) (subset2 A) (sub12 A) 125 | rem = gradLemma (subset1 A) (subset2 A) (sub12 A) (sub21 A) (retsub A) (secsub A) -------------------------------------------------------------------------------- /examples/swap.cub: -------------------------------------------------------------------------------- 1 | module swap where 2 | 3 | import gradLemma 4 | 5 | -- the swap function defines an equality 6 | 7 | and : U -> U -> U 8 | and A B = (_ : A) * B 9 | 10 | swap : (A B :U) -> and A B -> and B A 11 | swap A B z = (z.2,z.1) 12 | 13 | lemSwap : (A B:U) -> (z: and A B) -> Id (and A B) (swap B A (swap A B z)) z 14 | lemSwap A B z = refl (and A B) z 15 | 16 | eqSwap : (A B :U) -> Id U (and A B) (and B A) 17 | eqSwap A B = isEquivEq (and A B) (and B A) (swap A B) rem 18 | where 19 | rem : isEquiv (and A B) (and B A) (swap A B) 20 | rem = gradLemma (and A B) (and B A) (swap A B) (swap B A) (lemSwap B A) (lemSwap A B) 21 | 22 | -- a simple test example 23 | 24 | incr : and Bool N -> and Bool N 25 | incr z = (z.1,suc z.2) 26 | 27 | incr' : and N Bool -> and N Bool 28 | incr' = subst U (\ X -> X -> X) (and Bool N) (and N Bool) (eqSwap Bool N) incr 29 | 30 | test1 : and N Bool 31 | test1 = incr' (zero,true) 32 | 33 | test2 : and N Bool 34 | test2 = incr' (suc zero,true) 35 | 36 | -- what happens if we compose eqSwap with itself? 37 | 38 | eqSwap2 : (A B : U) -> Id U (and A B) (and A B) 39 | eqSwap2 A B = comp U (and A B) (and B A) (and A B) (eqSwap A B) (eqSwap B A) 40 | 41 | incr2 : and Bool N -> and Bool N 42 | incr2 = subst U (\ X -> X -> X) (and Bool N) (and Bool N) (eqSwap2 Bool N) incr 43 | 44 | test3 : and Bool N 45 | test3 = incr2 (true,zero) 46 | 47 | test4 : and Bool N 48 | test4 = incr2 (true,suc zero) 49 | 50 | -- what happens if we compose eqSwap with its inverse? 51 | 52 | eqSwap3 : (A B : U) -> Id U (and A B) (and A B) 53 | eqSwap3 A B = comp U (and A B) (and B A) (and A B) (eqSwap A B) 54 | (inv U (and A B) (and B A) (eqSwap A B)) 55 | 56 | incr3 : and Bool N -> and Bool N 57 | incr3 = subst U (\ X -> X -> X) (and Bool N) (and Bool N) (eqSwap2 Bool N) incr 58 | 59 | test5 : and Bool N 60 | test5 = incr3 (true,zero) 61 | 62 | test6 : and Bool N 63 | test6 = incr3 (true,suc zero) 64 | 65 | -- simple example with swap and product 66 | 67 | eqPi : (A:U) -> (B0 B1 : A -> U) -> ((x:A) -> Id U (B0 x) (B1 x)) -> Id U (Pi A B0) (Pi A B1) 68 | eqPi A B0 B1 eB = mapOnPath (A->U) U (Pi A) B0 B1 rem 69 | where rem : Id (A -> U) B0 B1 70 | rem = funExt A (\ _ -> U) B0 B1 eB 71 | 72 | eqSig : (A:U) -> (B0 B1 : A -> U) -> ((x:A) -> Id U (B0 x) (B1 x)) -> Id U (Sigma A B0) (Sigma A B1) 73 | eqSig A B0 B1 eB = mapOnPath (A->U) U (Sigma A) B0 B1 rem 74 | where rem : Id (A -> U) B0 B1 75 | rem = funExt A (\ _ -> U) B0 B1 eB 76 | 77 | eqPiTest : Id U (Pi U (\ X -> X -> and X Bool)) (Pi U (\ X -> X -> and Bool X)) 78 | eqPiTest = eqPi U (\ X -> X -> and X Bool) (\ X -> X -> and Bool X) rem1 79 | where rem : (X:U) -> Id U (and X Bool) (and Bool X) 80 | rem X = eqSwap X Bool 81 | 82 | rem1 : (X:U) -> Id U (X -> and X Bool) (X -> and Bool X) 83 | rem1 X = eqPi X (\ _ -> and X Bool) (\ _ -> and Bool X) (\ _ -> rem X) 84 | 85 | 86 | transPiTest : ((X:U) -> X -> and X Bool) -> (X:U) -> X -> and Bool X 87 | transPiTest = transport (Pi U (\ X -> X -> and X Bool)) (Pi U (\ X -> X -> and Bool X)) eqPiTest 88 | 89 | test12 : and Bool N 90 | test12 = transPiTest (\ X -> \ x -> (x,true)) N zero 91 | 92 | eqSigTest : Id U (Sigma U (\ X -> and X Bool)) (Sigma U (\ X -> and Bool X)) 93 | eqSigTest = eqSig U (\ X -> and X Bool) (\ X -> and Bool X) rem1 94 | where rem1 : (X:U) -> Id U (and X Bool) (and Bool X) 95 | rem1 X = eqSwap X Bool 96 | 97 | transSigTest : (Sigma U (\ X -> and X Bool)) -> Sigma U (and Bool) 98 | transSigTest = transport (Sigma U (\ X -> and X Bool)) (Sigma U (\ X -> and Bool X)) eqSigTest 99 | 100 | test7 : U 101 | test7 = (transSigTest (Bool,(false,true))).1 102 | 103 | test8 : and Bool test7 104 | test8 = (transSigTest (Bool,(false,true))).2 105 | 106 | eqSig1Test : Id U (Sigma U (\ X -> and N Bool)) (Sigma U (\ X -> and Bool N)) 107 | eqSig1Test = eqSig U (\ X -> and N Bool) (\ X -> and Bool N) rem1 108 | where rem1 : (X:U) -> Id U (and N Bool) (and Bool N) 109 | rem1 X = eqSwap N Bool 110 | 111 | transSig1Test : (and U (and N Bool)) -> and U (and Bool N) 112 | transSig1Test = transport (and U (and N Bool)) (and U (and Bool N)) eqSig1Test 113 | 114 | eqSig2Test : Id U (Sigma N (\ _ -> and N Bool)) (Sigma N (\ _ -> and Bool N)) 115 | eqSig2Test = eqSig N (\ _ -> and N Bool) (\ _ -> and Bool N) rem1 116 | where rem1 : N -> Id U (and N Bool) (and Bool N) 117 | rem1 n = eqSwap N Bool 118 | 119 | transSig2Test : (Sigma N (\ X -> and N Bool)) -> Sigma N (\ _ -> and Bool N) 120 | transSig2Test = transport (Sigma N (\ _ -> and N Bool)) (Sigma N (\ _ -> and Bool N)) eqSig2Test 121 | 122 | test9 : N 123 | test9 = (transSig2Test (zero,(zero,true))).1 124 | 125 | test10 : and Bool N 126 | test10 = (transSig2Test (zero,(zero,true))).2 127 | 128 | --- simple test 129 | 130 | eqNN : Id U (and N N) (and N N) 131 | eqNN = eqSwap N N 132 | 133 | testNN : and N N 134 | testNN = transport (and N N) (and N N) eqNN (zero,suc zero) 135 | 136 | eqUU : Id U (U -> and U U) (U -> and U U) 137 | eqUU = eqPi U (\ _ -> and U U) (\ _ -> and U U) (\ _ -> eqSwap U U) 138 | 139 | testUU : U 140 | testUU = (transport (U -> and U U) (U -> and U U) eqUU (\ X -> (X,X)) Bool).1 141 | 142 | -------------------------------------------------------------------------------- /examples/swapDisc.cub: -------------------------------------------------------------------------------- 1 | module swapDisc where 2 | 3 | import lemId 4 | import involutive 5 | import contr 6 | import elimEquiv 7 | 8 | -- defines the swap function over a discrete type and proves that this is an involutive map 9 | -- needed for Nicolai Kraus example 10 | -- we try another representation since the other one is too slow 11 | 12 | if : (X:U) -> Bool -> X -> X -> X 13 | if X = split true -> \ x y -> x 14 | false -> \ x y -> y 15 | 16 | True : Bool -> U 17 | True = split true -> Unit 18 | false -> N0 19 | 20 | lemIfT : (X:U) (b:Bool) (x y:X) -> True b -> Id X (if X b x y) x 21 | lemIfT X = split true -> \ x y _ -> refl X x 22 | false -> \ x y h -> efq (Id X (if X false x y) x) h 23 | 24 | lemIfF : (X:U) (b:Bool) (x y:X) -> True (not b) -> Id X (if X b x y) y 25 | lemIfF X = split true -> \ x y h -> efq (Id X (if X true x y) y) h 26 | false -> \ x y _ -> refl X y 27 | 28 | lemTrue : (a b : Bool) -> 29 | or (True a) 30 | (or (and (True (not a)) (True b)) (and (True (not a)) (True (not b)))) 31 | lemTrue = split true -> \ b -> inl tt 32 | false -> split true -> inr (inl (tt,tt)) 33 | false -> inr (inr (tt,tt)) 34 | 35 | lemTrue : (a b : Bool) (G:U) -> 36 | ((True a) -> G) -> ((and (True (not a)) (True b)) -> G) -> 37 | ((and (True (not a)) (True (not b)))-> G) -> G 38 | lemTrue = split true -> \ b -> \ G h0 h1 h2 -> h0 tt 39 | false -> split true -> \ G h0 h1 h2 -> h1 (tt,tt) 40 | false -> \ G h0 h1 h2 -> h2 (tt,tt) 41 | 42 | 43 | swapF : (X:U) (eq:X->X-> Bool) -> X -> X -> X -> X 44 | swapF X eq x y u = if X (eq x u) y (if X (eq y u) x u) 45 | 46 | lemSw0 : (X:U) (eq:X->X->Bool) (x y u:X) -> True (eq x u) -> Id X (swapF X eq x y u) y 47 | lemSw0 X eq x y u h = lemIfT X (eq x u) y (if X (eq y u) x u) h 48 | 49 | lemSw1 : (X:U) (eq:X->X->Bool) (x y u:X) -> 50 | and (True (not (eq x u))) (True (eq y u)) -> Id X (swapF X eq x y u) x 51 | lemSw1 X eq x y u h = comp X (swapF X eq x y u) (if X (eq y u) x u) x rem rem1 52 | where rem : Id X (swapF X eq x y u) (if X (eq y u) x u) 53 | rem = lemIfF X (eq x u) y (if X (eq y u) x u) h.1 54 | rem1 : Id X (if X (eq y u) x u) x 55 | rem1 = lemIfT X (eq y u) x u h.2 56 | 57 | lemSw2 : (X:U) (eq:X->X->Bool) (x y u:X) -> 58 | and (True (not (eq x u))) (True (not (eq y u))) 59 | -> Id X (swapF X eq x y u) u 60 | lemSw2 X eq x y u h = comp X (swapF X eq x y u) (if X (eq y u) x u) u rem rem1 61 | where rem : Id X (swapF X eq x y u) (if X (eq y u) x u) 62 | rem = lemIfF X (eq x u) y (if X (eq y u) x u) h.1 63 | rem1 : Id X (if X (eq y u) x u) u 64 | rem1 = lemIfF X (eq y u) x u h.2 65 | 66 | faith0 : (X:U) (eq:X->X->Bool) -> U 67 | faith0 X eq = (x y : X) -> Id X x y -> True (eq x y) 68 | 69 | faith1 : (X:U) (eq:X->X->Bool) -> U 70 | faith1 X eq = (x y : X) -> True (eq x y) -> Id X x y 71 | 72 | lemIdemSw : (X:U) (eq:X->X->Bool) (f0:faith0 X eq) (f1:faith1 X eq) (x y : X) (neq : True (not (eq x y))) 73 | (u:X) -> Id X (swapF X eq x y (swapF X eq x y u)) u 74 | lemIdemSw X eq f0 f1 x y neq u = lemTrue (eq x u) (eq y u) (H u) rem5 rem6 rem7 75 | where 76 | sw : X -> X 77 | sw = swapF X eq x y 78 | 79 | H : X -> U 80 | H v = Id X (sw (sw v)) v 81 | 82 | rem1 : Id X (sw x) y 83 | rem1 = lemSw0 X eq x y x (f0 x x (refl X x)) 84 | 85 | rem2 : Id X (sw y) x 86 | rem2 = lemSw1 X eq x y y (neq,f0 y y (refl X y)) 87 | 88 | rem3 : H x 89 | rem3 = comp X (sw (sw x)) (sw y) x (mapOnPath X X sw (sw x) y rem1) rem2 90 | 91 | rem4 : H y 92 | rem4 = comp X (sw (sw y)) (sw x) y (mapOnPath X X sw (sw y) x rem2) rem1 93 | 94 | rem5 : True (eq x u) -> H u 95 | rem5 h = subst X H x u (f1 x u h) rem3 96 | 97 | rem6 : and (True (not (eq x u))) (True (eq y u)) -> H u 98 | rem6 h = subst X H y u (f1 y u h.2) rem4 99 | 100 | rem7 : and (True (not (eq x u))) (True (not (eq y u))) -> H u 101 | rem7 h = comp X (sw (sw u)) (sw u) u (mapOnPath X X sw (sw u) u lem) lem 102 | where lem : Id X (sw u) u 103 | lem = lemSw2 X eq x y u h 104 | 105 | -- pointed sets 106 | 107 | ptU : U 108 | ptU = Sigma U (id U) 109 | 110 | -- if f : A -> B is an equivalence and f a = b then (A,a) and (B,b) are equal in ptU 111 | 112 | lemPtEquiv : (A B : U) (f: A -> B) (ef: isEquiv A B f) (a:A) (b:B) (eab: Id B (f a) b) 113 | -> Id ptU (A,a) (B,b) 114 | lemPtEquiv A = elimIsEquiv A P rem 115 | where 116 | P : (B:U) -> (A->B) -> U 117 | P B f = (a:A) -> (b:B) -> (eab: Id B (f a) b) -> Id ptU (A,a) (B,b) 118 | 119 | rem : P A (id A) 120 | rem = mapOnPath A ptU (\ x -> (A,x)) 121 | 122 | 123 | lemEM : (b:Bool) (G:U) -> ((True b) -> G) -> ((True (not b)) -> G) -> G 124 | lemEM = split true -> \ G h0 h1 -> h0 tt 125 | false -> \ G h0 h1 -> h1 tt 126 | 127 | homogDec : (X:U) (eq:X->X->Bool) (f0:faith0 X eq) (f1:faith1 X eq) (x y : X) 128 | -> Id ptU (X,x) (X,y) 129 | homogDec X eq f0 f1 x y = lemEM (eq x y) (G y) rem1 rem 130 | where 131 | G : X -> U 132 | G z = Id ptU (X,x) (X,z) 133 | 134 | sw : X -> X 135 | sw = swapF X eq x y 136 | 137 | rem : True (not (eq x y)) -> G y 138 | rem neq = lemPtEquiv X X sw 139 | (idemIsEquiv X sw (lemIdemSw X eq f0 f1 x y neq)) 140 | x y (lemSw0 X eq x y x (f0 x x (refl X x))) 141 | 142 | rem1 : True (eq x y) -> G y 143 | rem1 h = subst X G x y (f1 x y h) (refl ptU (X,x)) 144 | 145 | 146 | -- an example of a decidable structure 147 | 148 | eqN : N -> N -> Bool 149 | eqN = split zero -> split 150 | zero -> true 151 | suc _ -> false 152 | suc n -> split 153 | zero -> false 154 | suc m -> eqN n m 155 | 156 | lemN : (x:N) -> True (eqN x x) 157 | lemN = split 158 | zero -> tt 159 | suc n -> lemN n 160 | 161 | f0N : (x y : N) -> Id N x y -> True (eqN x y) 162 | f0N x y p = subst N (\ y -> True (eqN x y)) x y p (lemN x) 163 | 164 | f1N : (x y : N) -> True (eqN x y) -> Id N x y 165 | f1N = split zero -> split 166 | zero -> \ _ ->refl N zero 167 | suc m -> \ h -> efq (Id N zero (suc m)) h 168 | suc n -> split 169 | zero -> \ h -> efq (Id N (suc n) zero) h 170 | suc m -> \ h -> mapOnPath N N (\ x -> suc x) n m (f1N n m h) 171 | -------------------------------------------------------------------------------- /examples/swapDisc_old.cub: -------------------------------------------------------------------------------- 1 | module swapDisc_old where 2 | 3 | import lemId 4 | import involutive 5 | import contr 6 | import elimEquiv 7 | 8 | 9 | -- definition by case on a decidable equality 10 | -- needed for Nicolai Kraus example 11 | 12 | defCase : (A X:U) -> X -> X -> dec A -> X 13 | defCase A X x0 x1 = 14 | split 15 | inl _ -> x0 16 | inr _ -> x1 17 | 18 | IdDefCasel : (A X:U) (x0 x1 : X) (p : dec A) -> A -> 19 | Id X (defCase A X x0 x1 p) x0 20 | IdDefCasel A X x0 x1 = split 21 | inl _ -> \ _ -> refl X x0 22 | inr v -> \ u -> efq (Id X (defCase A X x0 x1 (inr v)) x0) (v u) 23 | 24 | IdDefCaser : (A X:U) (x0 x1 : X) (p : dec A) -> (neg A) -> 25 | Id X (defCase A X x0 x1 p) x1 26 | IdDefCaser A X x0 x1 = split 27 | inl u -> \ v -> efq (Id X (defCase A X x0 x1 (inl u)) x1) (v u) 28 | inr _ -> \ _ -> refl X x1 29 | 30 | -- defines the swap function over a discrete type and proves that this is an involutive map 31 | -- needed for Nicolai Kraus example 32 | 33 | -- intermediate function 34 | 35 | auxSwapD : (X:U) -> discrete X -> X -> X -> X -> X 36 | auxSwapD X dX x0 x1 x = defCase (Id X x1 x) X x0 x (dX x1 x) 37 | 38 | swapDisc : (X:U) -> discrete X -> X -> X -> X -> X 39 | swapDisc X dX x0 x1 x = defCase (Id X x0 x) X x1 (auxSwapD X dX x0 x1 x) (dX x0 x) 40 | 41 | idSwapDisc0 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> (x:X) -> Id X x0 x -> 42 | Id X (swapDisc X dX x0 x1 x) x1 43 | idSwapDisc0 X dX x0 x1 x eqx0x = 44 | IdDefCasel (Id X x0 x) X x1 (auxSwapD X dX x0 x1 x) (dX x0 x) eqx0x 45 | 46 | idSwapDiscn0 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> (x:X) -> neg (Id X x0 x) -> 47 | Id X (swapDisc X dX x0 x1 x) (auxSwapD X dX x0 x1 x) 48 | idSwapDiscn0 X dX x0 x1 x neqx0x = 49 | IdDefCaser (Id X x0 x) X x1 (defCase (Id X x1 x) X x0 x (dX x1 x)) (dX x0 x) neqx0x 50 | 51 | idAuxSwap1 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> (x:X) -> Id X x1 x -> 52 | Id X (auxSwapD X dX x0 x1 x) x0 53 | idAuxSwap1 X dX x0 x1 x eqx1x = 54 | IdDefCasel (Id X x1 x) X x0 x (dX x1 x) eqx1x 55 | 56 | idAuxSwapn1 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> (x:X) -> neg (Id X x1 x) -> 57 | Id X (auxSwapD X dX x0 x1 x) x 58 | idAuxSwapn1 X dX x0 x1 x neqx1x = 59 | IdDefCaser (Id X x1 x) X x0 x (dX x1 x) neqx1x 60 | 61 | idSwapDisc1 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> neg (Id X x0 x1) -> Id X (swapDisc X dX x0 x1 x1) x0 62 | idSwapDisc1 X dX x0 x1 neqx0x1 = 63 | comp X (swapDisc X dX x0 x1 x1) (defCase (Id X x0 x1) X x1 x0 (dX x0 x1)) x0 rem2 rem1 64 | where 65 | rem : Id X (defCase (Id X x1 x1) X x0 x1 (dX x1 x1)) x0 66 | rem = IdDefCasel (Id X x1 x1) X x0 x1 (dX x1 x1) (refl X x1) 67 | 68 | rem1 : Id X (defCase (Id X x0 x1) X x1 x0 (dX x0 x1)) x0 69 | rem1 = IdDefCaser (Id X x0 x1) X x1 x0 (dX x0 x1) neqx0x1 70 | 71 | rem2 : Id X (swapDisc X dX x0 x1 x1) (defCase (Id X x0 x1) X x1 x0 (dX x0 x1)) 72 | rem2 = mapOnPath X X (\ y -> defCase (Id X x0 x1) X x1 y (dX x0 x1)) (defCase (Id X x1 x1) X x0 x1 (dX x1 x1)) x0 rem 73 | 74 | -- can we show that swapDisc is involutive?? 75 | 76 | idemSwapDisc : (X:U) (dX: discrete X) -> (x0 x1 : X) -> neg (Id X x0 x1) -> (x:X) -> 77 | Id X (swapDisc X dX x0 x1 (swapDisc X dX x0 x1 x)) x 78 | idemSwapDisc X dX x0 x1 neqx0x1 x = orElim (Id X x0 x) (neg (Id X x0 x)) G rem9 rem11 (dX x0 x) 79 | where 80 | sD : X -> X 81 | sD = swapDisc X dX x0 x1 82 | 83 | G : U 84 | G = Id X (sD (sD x)) x 85 | 86 | aD : X -> X 87 | aD = auxSwapD X dX x0 x1 88 | 89 | rem : Id X x0 x -> Id X (sD x) x1 90 | rem = idSwapDisc0 X dX x0 x1 x 91 | 92 | rem1 : neg (Id X x0 x) -> Id X (sD x) (aD x) 93 | rem1 = idSwapDiscn0 X dX x0 x1 x 94 | 95 | rem2 : Id X x1 x -> Id X (aD x) x0 96 | rem2 = idAuxSwap1 X dX x0 x1 x 97 | 98 | rem3 : neg (Id X x1 x) -> Id X (aD x) x 99 | rem3 = idAuxSwapn1 X dX x0 x1 x 100 | 101 | rem4 : Id X (aD x1) x0 102 | rem4 = idAuxSwap1 X dX x0 x1 x1 (refl X x1) 103 | 104 | rem5 : Id X (sD x1) (aD x1) 105 | rem5 = idSwapDiscn0 X dX x0 x1 x1 neqx0x1 106 | 107 | rem6 : Id X (sD x1) x0 108 | rem6 = comp X (sD x1) (aD x1) x0 rem5 rem4 109 | 110 | rem7 : Id X x0 x -> Id X (sD (sD x)) (sD x1) 111 | rem7 p = mapOnPath X X sD (sD x) x1 (rem p) 112 | 113 | rem8 : Id X x0 x -> Id X (sD (sD x)) x0 114 | rem8 p = comp X (sD (sD x)) (sD x1) x0 (rem7 p) rem6 115 | 116 | rem9 : Id X x0 x -> G 117 | rem9 p = comp X (sD (sD x)) x0 x (rem8 p) p 118 | 119 | rem10 : Id X (sD x0) x1 120 | rem10 = idSwapDisc0 X dX x0 x1 x0 (refl X x0) 121 | 122 | rem11 : neg (Id X x0 x) -> G 123 | rem11 neqx0x = orElim (Id X x1 x) (neg (Id X x1 x)) G rem14 rem15 (dX x1 x) 124 | where 125 | rem12 : Id X (sD x) (aD x) 126 | rem12 = rem1 neqx0x 127 | 128 | rem13 : Id X x1 x -> Id X (sD (aD x)) x1 129 | rem13 p = comp X (sD (aD x)) (sD x0) x1 (mapOnPath X X sD (aD x) x0 (rem2 p)) rem10 130 | 131 | rem14 : Id X x1 x -> G 132 | rem14 p = comp X (sD (sD x)) (sD (aD x)) x (mapOnPath X X sD (sD x) (aD x) rem12) (comp X (sD (aD x)) x1 x (rem13 p) p) 133 | 134 | rem15 : neg (Id X x1 x) -> G 135 | rem15 neqx1x = comp X (sD (sD x)) (sD x) x rem17 rem18 136 | where 137 | rem16 : Id X (aD x) x 138 | rem16 = rem3 neqx1x 139 | 140 | rem17 : Id X (sD (sD x)) (sD x) 141 | rem17 = comp X (sD (sD x)) (sD (aD x)) (sD x) (mapOnPath X X sD (sD x) (aD x) rem12) (mapOnPath X X sD (aD x) x rem16) 142 | 143 | rem18 : Id X (sD x) x 144 | rem18 = comp X (sD x) (aD x) x rem12 rem16 145 | 146 | -- pointed sets 147 | 148 | ptU : U 149 | ptU = Sigma U (id U) 150 | 151 | -- if f : A -> B is an equivalence and f a = b then (A,a) and (B,b) are equal in ptU 152 | 153 | lemPtEquiv : (A B : U) (f: A -> B) (ef: isEquiv A B f) (a:A) (b:B) (eab: Id B (f a) b) 154 | -> Id ptU (A,a) (B,b) 155 | lemPtEquiv A = elimIsEquiv A P rem 156 | where 157 | P : (B:U) -> (A->B) -> U 158 | P B f = (a:A) -> (b:B) -> (eab: Id B (f a) b) -> Id ptU (A,a) (B,b) 159 | 160 | rem : P A (id A) 161 | rem = mapOnPath A ptU (\ x -> (A,x)) 162 | 163 | homogDec : (X:U) -> discrete X -> (x y:X) -> Id ptU (X,x) (X,y) 164 | homogDec X dX x y = orElim (Id X y x) (neg (Id X y x)) (G x) rem1 rem (dX y x) 165 | where 166 | G : X -> U 167 | G z = Id ptU (X,z) (X,y) 168 | 169 | rem0 : G y 170 | rem0 = refl ptU (X,y) 171 | 172 | rem : neg (Id X y x) -> G x 173 | rem neqzx = lemPtEquiv X X (swapDisc X dX y x) 174 | (idemIsEquiv X (swapDisc X dX y x) (idemSwapDisc X dX y x neqzx)) 175 | x y (idSwapDisc1 X dX y x neqzx) 176 | 177 | rem1 : Id X y x -> G x 178 | rem1 eqzx = subst X G y x eqzx rem0 179 | -------------------------------------------------------------------------------- /examples/testInh.cub: -------------------------------------------------------------------------------- 1 | module testInh where 2 | 3 | import set 4 | 5 | -- test the inh and squash functions 6 | 7 | zz : inh N 8 | zz = inc N zero 9 | 10 | eq1 : Id (inh N) zz zz 11 | eq1 = refl (inh N) zz 12 | 13 | eq2 : Id (inh N) zz zz 14 | eq2 = squash N zz zz 15 | 16 | inhUIP : (A : U) -> set (inh A) 17 | inhUIP A = propUIP (inh A) (squash A) 18 | 19 | test : Id (Id (inh N) zz zz) eq1 eq2 20 | test = inhUIP N zz zz eq1 eq2 21 | 22 | -- impredicative encoding 23 | 24 | inhI : U -> U 25 | inhI A = (X : U) -> prop X -> (A -> X) -> X 26 | 27 | incI : (A : U) -> A -> inhI A 28 | incI A a = \X h f -> f a 29 | 30 | squashI : (A : U) -> prop (inhI A) 31 | squashI A = propPi U (\X -> prop X -> (A -> X) -> X) rem 32 | where 33 | rem1 : (X : U) -> prop X -> prop ((A -> X) -> X) 34 | rem1 X h = propImply (A -> X) X (\_ -> h) 35 | 36 | rem : (X : U) -> prop (prop X -> (A -> X) -> X) 37 | rem X = propImply (prop X) ((A -> X) -> X) (rem1 X) 38 | 39 | inhrecI : (A : U) (B : U) (p : prop B) (f : A -> B) (h : inhI A) -> B 40 | inhrecI A B p f h = h B p f 41 | 42 | inhUIPI : (A : U) -> UIP (inhI A) 43 | inhUIPI A = propUIP (inhI A) (squashI A) 44 | 45 | zzI : inhI N 46 | zzI = incI N zero 47 | 48 | eq1I : Id (inhI N) zzI zzI 49 | eq1I = refl (inhI N) zzI 50 | 51 | eq2I : Id (inhI N) zzI zzI 52 | eq2I = squashI N zzI zzI 53 | 54 | testI : Id (Id (inhI N) zzI zzI) eq1I eq2I 55 | testI = inhUIPI N zzI zzI eq1I eq2I 56 | -------------------------------------------------------------------------------- /examples/turn.cub: -------------------------------------------------------------------------------- 1 | module turn where 2 | 3 | import helix 4 | 5 | transpL : (A:U)(a b:A) -> Id A a b -> Id A a a -> Id A b b 6 | transpL A a b p l = (compInv A a b b p (comp A a a b l p)) 7 | 8 | lemTranspL : (A:U)(a:A)(l:Id A a a) -> Id (Id A a a) l (transpL A a a (refl A a) l) 9 | lemTranspL A a l = rem2 10 | where 11 | l1 : Id A a a 12 | l1 = comp A a a a l (refl A a) 13 | rem : Id (Id A a a) l1 l 14 | rem = compIdr A a a l 15 | rem1 : Id (Id A a a) l1 (compInv A a a a (refl A a) l1) 16 | rem1 = compInvIdl' A a a l1 17 | rem2 : Id (Id A a a) l (compInv A a a a (refl A a) l1) 18 | rem2 = compInv (Id A a a) l1 l (compInv A a a a (refl A a) l1) rem rem1 19 | 20 | lemTranspL1 : (A:U)(a:A)(l:Id A a a) -> Id (Id A a a) l (transpL A a a l l) 21 | lemTranspL1 A a l = lemInv A a a a l l 22 | 23 | lemG0 : (A:U)(a b:A)(p:Id A a b)(l : Id A a a) -> 24 | IdS A (\ x -> Id A x x) a b p l (transpL A a b p l) 25 | lemG0 A a = J A a (\ b p -> (l : Id A a a) -> IdS A (\ x -> Id A x x) a b p l (transpL A a b p l)) 26 | (lemTranspL A a) 27 | 28 | lemG1 : (A:U)(a:A)(l:Id A a a) -> IdS A (\ x -> Id A x x) a a l l l 29 | lemG1 A a l = 30 | substInv (Id A a a) (IdS A (\ x -> Id A x x) a a l l) l (transpL A a a l l) 31 | (lemTranspL1 A a l) (lemG0 A a a l l) 32 | 33 | lp : (x:S1) -> Id S1 x x 34 | lp = S1rec (\ x -> Id S1 x x) loop (lemG1 S1 base loop) 35 | 36 | lp1 : S1 -> S1 37 | lp1 x = S1rec (\ _ -> S1) x (lp x) x 38 | 39 | path : Id S1 base base 40 | path = mapOnPath S1 S1 lp1 base base loop 41 | 42 | test : Z 43 | test = winding path 44 | 45 | path2 : Id S1 base base 46 | path2 = mapOnPath S1 S1 lp1 base base (compS1 loop (compS1 loop loop)) 47 | 48 | test2 : Z 49 | test2 = winding path2 50 | 51 | -------------------------------------------------------------------------------- /examples/univalence.cub: -------------------------------------------------------------------------------- 1 | module univalence where 2 | 3 | import axChoice 4 | 5 | -- now we try to prove univalence 6 | -- the identity is an equivalence 7 | 8 | -- the transport of the reflexity is equal to the identity function 9 | 10 | transpReflId : (A:U) -> Id (A->A) (id A) (transport A A (refl U A)) 11 | transpReflId A = funExt A (\ _ -> A) (id A) (transport A A (refl U A)) (transportRef A) 12 | 13 | -- the transport of any equality proof is an equivalence 14 | 15 | transpIsEquiv : (A B:U) -> (p:Id U A B) -> isEquiv A B (transport A B p) 16 | transpIsEquiv A = J U A (\ B p -> isEquiv A B (transport A B p)) rem 17 | where rem : isEquiv A A (transport A A (refl U A)) 18 | rem = subst (A -> A) (isEquiv A A) (id A) (transport A A (refl U A)) (transpReflId A) (idIsEquiv A) 19 | 20 | Equiv : U -> U -> U 21 | Equiv A B = Sigma (A->B) (isEquiv A B) 22 | 23 | eqEquiv : (A B : U) (e0 e1:Equiv A B) -> Id (A -> B) e0.1 e1.1 -> Id (Equiv A B) e0 e1 24 | eqEquiv A B = eqPropFam (A->B) (isEquiv A B) (propIsEquiv A B) 25 | 26 | IdToEquiv : (A B:U) -> Id U A B -> Equiv A B 27 | IdToEquiv A B p = (transport A B p, transpIsEquiv A B p) 28 | 29 | EquivToId : (A B:U) -> Equiv A B -> Id U A B 30 | EquivToId A B z = isEquivEq A B z.1 z.2 31 | 32 | lemSecIdEquiv : (A:U) -> (eid : isEquiv A A (id A)) -> Id (Id U A A) (refl U A) (EquivToId A A (id A, eid)) 33 | lemSecIdEquiv A z = equivEqRef A z.1 z.2 34 | 35 | lem1SecIdEquiv : (A:U) -> (f:A -> A) -> Id (A->A) (id A) f -> (eid : isEquiv A A f) -> 36 | Id (Id U A A) (refl U A) (EquivToId A A (f, eid)) 37 | lem1SecIdEquiv A f if eid = 38 | comp (Id U A A) (refl U A) (EquivToId A A (id A, idIsEquiv A)) (EquivToId A A (f, eid)) rem2 rem1 39 | where 40 | rem : Id (Equiv A A) (id A, idIsEquiv A) (f, eid) 41 | rem = eqEquiv A A (id A, idIsEquiv A) (f, eid) if 42 | 43 | rem1 : Id (Id U A A) (EquivToId A A (id A, idIsEquiv A)) (EquivToId A A (f, eid)) 44 | rem1 = mapOnPath (Equiv A A) (Id U A A) (EquivToId A A) (id A, idIsEquiv A) (f, eid) rem 45 | 46 | rem2 : Id (Id U A A) (refl U A) (EquivToId A A (id A, idIsEquiv A)) 47 | rem2 = lemSecIdEquiv A (idIsEquiv A) 48 | 49 | secIdEquiv : (A B :U) -> (p : Id U A B) -> Id (Id U A B) (EquivToId A B (IdToEquiv A B p)) p 50 | secIdEquiv A B p = inv (Id U A B) p (EquivToId A B (IdToEquiv A B p)) (rem A B p) 51 | where 52 | rem1 : (A:U) -> Id (Id U A A) (refl U A) (EquivToId A A (IdToEquiv A A (refl U A))) 53 | rem1 A = lem1SecIdEquiv A tA rem3 rem2 54 | where 55 | tA : A -> A 56 | tA = transport A A (refl U A) 57 | 58 | rem2 : isEquiv A A tA 59 | rem2 = transpIsEquiv A A (refl U A) 60 | 61 | rem3 : Id (A -> A) (id A) tA 62 | rem3 = transpReflId A 63 | 64 | rem : (A B :U) -> (p : Id U A B) -> Id (Id U A B) p (EquivToId A B (IdToEquiv A B p)) 65 | rem A = J U A (\ B p -> Id (Id U A B) p (EquivToId A B (IdToEquiv A B p))) (rem1 A) 66 | 67 | retIdEquiv : (A B :U) (s : Equiv A B) -> Id (Equiv A B) (IdToEquiv A B (EquivToId A B s)) s 68 | retIdEquiv A B s = inv (Equiv A B) s (IdToEquiv A B (EquivToId A B s)) (rem s) 69 | where 70 | rem : (s : Equiv A B) -> Id (Equiv A B) s (IdToEquiv A B (EquivToId A B s)) 71 | rem u = rem1 u.2 72 | where 73 | p : Id U A B 74 | p = isEquivEq A B u.1 u.2 75 | 76 | rem1 : (ef : isEquiv A B u.1) -> 77 | Id (Equiv A B) (u.1, ef) (transport A B (isEquivEq A B u.1 ef), transpIsEquiv A B (isEquivEq A B u.1 ef)) 78 | rem1 z = rem2 79 | where 80 | rem3 : Id (A->B) u.1 (transport A B (equivEq A B u.1 z.1 z.2)) 81 | rem3 = funExt A (\ _ -> B) u.1 (transport A B (equivEq A B u.1 z.1 z.2)) (transpEquivEq A B u.1 z.1 z.2) 82 | rem2 : Id (Equiv A B) (u.1, z) 83 | (transport A B (equivEq A B u.1 z.1 z.2), transpIsEquiv A B (equivEq A B u.1 z.1 z.2)) 84 | rem2 = eqEquiv A B (u.1, z) 85 | (transport A B (equivEq A B u.1 z.1 z.2), transpIsEquiv A B (equivEq A B u.1 z.1 z.2)) 86 | rem3 87 | 88 | -- and now univalence 89 | 90 | univAx : (A B:U) -> isEquiv (Id U A B) (Equiv A B) (IdToEquiv A B) 91 | univAx A B = gradLemma (Id U A B) (Equiv A B) (IdToEquiv A B) (EquivToId A B) (retIdEquiv A B) (secIdEquiv A B) 92 | 93 | -- in particular Id U A B and Equiv A B are equal 94 | 95 | corUnivAx : (A B : U) -> Id U (Id U A B) (Equiv A B) 96 | corUnivAx A B = isEquivEq (Id U A B) (Equiv A B) (IdToEquiv A B) (univAx A B) 97 | 98 | -- a simple application 99 | 100 | idPropIsProp : (A B : U) -> prop A -> prop B -> prop (Id U A B) 101 | idPropIsProp A B pA pB = substInv U prop (Id U A B) (Equiv A B) (corUnivAx A B) rem 102 | where 103 | rem : prop (Equiv A B) 104 | rem = sigIsProp (A->B) (isEquiv A B) (propIsEquiv A B) (isPropProd A (\ _ -> B) (\ _ -> pB)) 105 | 106 | -------------------------------------------------------------------------------- /notes/allprim.txt: -------------------------------------------------------------------------------- 1 | Id : (A : U) (a b : A) -> U 2 | 3 | refl : (A : U) (a : A) -> Id A a a 4 | 5 | funExt : (A : U) (B : (a : A) -> U) (f g : (a : A) -> B a) 6 | (p : ((x : A) -> (Id (B x) (f x) (g x)))) -> Id ((y : A) -> B y) f g 7 | 8 | fiber : (A B : U) (f : A -> B) (y : B) -> U 9 | fiber A B f y = (x : A) * Id B (f x) y 10 | 11 | id : (A : U) -> A -> A 12 | id A a = a 13 | 14 | pathTo : (A:U) -> A -> U 15 | pathTo A = fiber A A (id A) 16 | 17 | singl : (A:U) -> A -> U 18 | singl A a = Sigma A (Id A a) 19 | 20 | contrSingl : (A : U) (a b:A) (p:Id A a b) -> Id (singl A a) (a, refl A a) (b, p) 21 | 22 | equivEq : (A B : U) (f : A -> B) (s : (y : B) -> fiber A B f y) 23 | (t : (y : B) -> (v : fiber A B f y) -> Id (fiber A B f y) (s y) v) -> 24 | Id U A B 25 | 26 | transport : (A B : U) -> Id U A B -> A -> B 27 | 28 | transpInv : (A B : U) -> Id U A B -> B -> A 29 | 30 | transportRef : (A : U) (a : A) -> Id A a (transport A A (refl U A) a) 31 | 32 | equivEqRef : (A : U) -> (s : (y : A) -> pathTo A y) -> 33 | (t : (y : A) -> (v : pathTo A y) -> Id (pathTo A y) (s y) v) -> 34 | Id (Id U A A) (refl U A) (equivEq A A (id A) s t) 35 | 36 | transpEquivEq : (A B : U) -> (f : A -> B) (s : (y : B) -> fiber A B f y) -> 37 | (t : (y : B) -> (v : fiber A B f y) -> Id (fiber A B f y) (s y) v) -> 38 | (a : A) -> Id B (f a) (transport A B (equivEq A B f s t) a) 39 | 40 | mapOnPath : (A B : U) (f : A -> B) (a b : A) (p : Id A a b) -> Id B (f a) (f b) 41 | 42 | appOnPath : (A B : U) (f g : A -> B) (a b : A) (q:Id (A->B) f g) (p : Id A a b) -> Id B (f a) (g b) 43 | 44 | IdP : (A B :U) -> Id U A B -> A -> B -> U 45 | 46 | IdS : (A:U) (F:A -> U) (a0 a1:A) (p:Id A a0 a1) -> F a0 -> F a1 -> U 47 | IdS A F a0 a1 p = IdP (F a0) (F a1) (mapOnPath A U F a0 a1 p) 48 | 49 | mapOnPathD : (A : U) (F : A -> U) (f : (x : A) -> F x) (a0 a1 : A) (p : Id A a0 a1) -> 50 | IdS A F a0 a1 p (f a0) (f a1) 51 | 52 | mapOnPathS : (A:U)(F:A -> U) (C:U) (f: (x:A) -> F x -> C) (a0 a1 : A) (p:Id A a0 a1) 53 | (b0:F a0) (b1:F a1) (q : IdS A F a0 a1 p b0 b1) -> Id C (f a0 b0) (f a1 b1) 54 | 55 | --------------------------------------------------------------------------------