packages feed

cubical 0.1.2 → 0.2.0

raw patch · 58 files changed

+3936/−4026 lines, 58 filesdep +filepathdep ~BNFCsetup-changed

Dependencies added: filepath

Dependency ranges changed: BNFC

Files

CTT.hs view
@@ -1,92 +1,252 @@+{-# LANGUAGE TupleSections #-} module CTT where -+import Control.Applicative import Data.List--import qualified MTT as A+import Data.Maybe import Pretty  -------------------------------------------------------------------------------- -- | Terms -type Binder = String-type Def    = (Binder,Ter)  -- without type annotations for now+data Loc = Loc { locFile :: String+               , locPos :: (Int, Int) }+  deriving Eq+ type Ident  = String+type Label  = String+type Binder = (Ident,Loc) -data Ter = Var Binder-         | Id Ter Ter Ter | Refl Ter-         | Pi Ter Ter     | Lam Binder Ter | App Ter Ter-         | Where Ter [Def]+noLoc :: String -> Binder+noLoc x = (x, Loc "" (0,0))++-- Branch of the form: c x1 .. xn -> e+type Brc    = (Label,([Binder],Ter))++-- Telescope (x1 : A1) .. (xn : An)+type Tele   = [(Binder,Ter)]++-- Labelled sum: c (x1 : A1) .. (xn : An)+type LblSum = [(Binder,Tele)]++-- Context gives type values to identifiers+type Ctxt   = [(Binder,Val)]++-- Mutual recursive definitions: (x1 : A1) .. (xn : An) and x1 = e1 .. xn = en+type Decls  = [(Binder,Ter,Ter)]+data ODecls = ODecls Decls+            | Opaque Binder+            | Transp Binder+  deriving (Eq,Show)++declIdents :: Decls -> [Ident]+declIdents decl = [ x | ((x,_),_,_) <- decl]++declBinders :: Decls -> [Binder]+declBinders decl = [ x | (x,_,_) <- decl]++declTers :: Decls -> [Ter]+declTers decl = [ d | (_,_,d) <- decl]++declTele :: Decls -> Tele+declTele decl = [ (x,t) | (x,t,_) <- decl]++declDefs :: Decls -> [(Binder,Ter)]+declDefs decl = [ (x,d) | (x,_,d) <- decl]++-- Terms+data Ter = App Ter Ter+         | Pi Ter Ter+         | Lam Binder Ter+         | Sigma Ter Ter+         | SPair Ter Ter+         | Fst Ter+         | Snd Ter+         | Where Ter ODecls+         | Var Ident          | U+         -- constructor c Ms+         | Con Label [Ter]+         -- branches c1 xs1  -> M1,..., cn xsn -> Mn+         | Split Loc [Brc]+         -- labelled sum c1 A1s,..., cn Ans (assumes terms are constructors)+         | Sum Binder LblSum+         | PN PN+  deriving Eq -         | Undef A.Prim+-- Primitive notions+data PN = Id | Refl+        -- Inh A is an h-prop stating that A is inhabited.+        -- Here we take h-prop A as (Pi x y : A) Id A x y.+        | Inh+        -- Inc a : Inh A for a:A (A not needed ??)+        | Inc+        -- Squash a b : Id (Inh A) a b+        | Squash+        -- InhRec B p phi a : B,+        -- p : hprop(B), phi : A -> B, a : Inh A (cf. HoTT-book p.113)+        | InhRec -           -- constructor c Ms-         | Con Ident [Ter]+        -- (A B : U) -> Id U A B -> A -> B+        -- For TransU we only need the eqproof and the element in A is needed+        | TransU -           -- branches c1 xs1  -> M1,..., cn xsn -> Mn-         | Branch A.Prim [(Ident, ([Binder],Ter))]+        -- (A B : U) -> Id U A B -> B -> A+        -- For TransU we only need the eqproof and the element in A is needed+        | TransInvU -           -- labelled sum c1 A1s,..., cn Ans (assumes terms are constructors)-         | LSum A.Prim [(Ident, [(Binder,Ter)])]+        -- (A : U) -> (a : A) -> Id A a (transport A (refl U A) a)+        | TransURef -           -- (A B:U) -> Id U A B -> A -> B-           -- For TransU we only need the eqproof and the element in A is needed-         | TransU Ter Ter+        -- (A : U) (a b:A) (p:Id A a b) -> Id (singl A a) (pair a (refl A a)) (pair b p)+        | CSingl -           -- (A:U) -> (a : A) -> Id A a (transport A (refl U A) a)-           -- Argument is a-         | TransURef Ter+        -- (A B : U) (f : A -> B) (a b : A) ->+        -- (p : Id A a b) -> Id B (f a) (f b)+        -- TODO: remove?+        | MapOnPath -           -- The primitive J will have type:-           -- J : (A : U) (u : A) (C : (v : A) -> Id A u v -> U)-           --  (w : C u (refl A u)) (v : A) (p : Id A u v) -> C v p-         | J Ter Ter Ter Ter Ter Ter+        -- (A B : U) (f g : A -> B) (a b : A) ->  +        -- Id (A->B) f g -> Id A a b -> Id B (f a) (g b)+        | AppOnPath -           -- (A : U) (u : A) (C : (v:A) -> Id A u v -> U)-           -- (w : C u (refl A u)) ->-           -- Id (C u (refl A u)) w (J A u C w u (refl A u))-         | JEq Ter Ter Ter Ter+        -- Ext B f g p : Id (Pi A B) f g,+        -- (p : (Pi x:A) Id (Bx) (fx,gx)); A not needed ??+        -- | Ext -           -- Ext B f g p : Id (Pi A B) f g,-           -- (p : (Pi x:A) Id (Bx) (fx,gx)); A not needed ??-         | Ext Ter Ter Ter Ter+        -- Ext B f g p : Id (Pi A B) f g,+        -- (p : (Pi x y:A) IdS A (Bx) x y p fx gy)+        | HExt -           -- Inh A is an h-prop stating that A is inhabited.-           -- Here we take h-prop A as (Pi x y : A) Id A x y.-         | Inh Ter+        -- EquivEq A B f s t where+        -- A, B are types, f : A -> B,+        -- s : (y : B) -> fiber f y, and+        -- t : (y : B) (z : fiber f y) -> Id (fiber f y) (s y) z+        -- where fiber f y is Sigma x : A. Id B (f x) z.+        | EquivEq+        -- (A : U) -> (s : (y : A) -> pathTo A a) ->+        -- (t : (y : B) -> (v : pathTo A a) -> Id (path To A a) (s y) v) ->+        -- Id (Id U A A) (refl U A) (equivEq A A (id A) s t)+        | EquivEqRef -           -- Inc a : Inh A for a:A (A not needed ??)-         | Inc Ter+        -- (A B : U) -> (f : A -> B) (s : (y : B) -> fiber A B f y) ->+        -- (t : (y : B) -> (v : fiber A B f y) -> Id (fiber A B f y) (s y) v) ->+        -- (a : A) -> Id B (f a) (transport A B (equivEq A B f s t) a)+        | TransUEquivEq -           -- Squash a b : Id (Inh A) a b-         | Squash Ter Ter+        -- IdP  :    (A B :U) -> Id U A B ->  A -> B -> U+        -- IdP A B p a b   is the type of paths  connecting a to b over p+        | IdP -           -- InhRec B p phi a : B,-           -- p : hprop(B), phi : A -> B, a : Inh A (cf. HoTT-book p.113)-         | InhRec Ter Ter Ter Ter+        -- mapOnPathD :  (A : U) (F : A -> U) (f : (x : A) -> F x) (a0 a1 : A) (p : Id A a0 a1) ->+        --               IdS A F a0 a1 p  (f a0) (f a1)+        -- IdS : (A:U) (F:A -> U) (a0 a1:A) (p:Id A a0 a1) -> F a0 -> F a1 -> U+        -- IdS A F a0 a1 p = IdP (F a0) (F a1) (mapOnPath A U F a0 a1 p)+        -- TODO: remove in favor of AppOnPathD?+        | MapOnPathD -           -- EquivEq A B f s t where-           -- A, B are types, f : A -> B,-           -- s : (y : B) -> fiber f y, and-           -- t : (y : B) (z : fiber f y) -> Id (fiber f y) (s y) z-           -- where fiber f y is Sigma x : A. Id B (f x) z.-         | EquivEq Ter Ter Ter Ter Ter+        -- AppOnPathD :  (A : U) (F : A -> U) (f g : (x : A) -> F x) -> Id ((x : A) -> F x) f g ->+        --               (a0 a1 : A) (p : Id A a0 a1) -> IdS A F a0 a1 p  (f a0) (g a1)+        -- | AppOnPathD -           -- (A : U) -> (s : (y : A) -> pathTo A a) ->-           -- (t : (y : B) -> (v : pathTo A a) -> Id (path To A a) (s y) v) ->-           -- Id (Id U A A) (refl U A) (equivEq A A (id A) s t)-         | EquivEqRef Ter Ter Ter+        -- mapOnPathS : (A:U)(F:A -> U) (C:U) (f: (x:A) -> F x -> C) (a0 a1 : A) (p:Id A a0 a1)+        -- (b0:F a0) (b1:F a1) (q : IdS A F a0 a1 p b0 b1) -> Id C (f a0 b0) (f a1 b1)+        | MapOnPathS -- TODO: AppOnPathS? -           -- (A B : U) -> (f : A -> B) (s : (y : B) -> fiber A B f y) ->-           -- (t : (y : B) -> (v : fiber A B f y) -> Id (fiber A B f y) (s y) v) ->-           -- (a : A) -> Id B (f a) (transport A B (equivEq A B f s t) a)-         | TransUEquivEq Ter Ter Ter Ter Ter Ter-  deriving (Eq)+        -- S1 : U+        | Circle -instance Show Ter where-  show = showTer+        -- base : S1+        | Base +        -- loop : Id S1 base base+        | Loop++        -- S1rec : (F : S1 -> U) (b : F base) (l : IdS F base base loop) (x : S1) -> F x+        | CircleRec++        -- I : U+        | I++        -- I0, I1 : Int+        | I0 | I1++        -- line : Id Int I0 I1+        | Line+++        -- intrec : (F : I -> U) (s : F I0) (e : F I1)+        --  (l : IdS Int F I0 I1 line s e) (x : I) -> F x+        | IntRec++        -- undefined constant+        | Undef Loc+  deriving (Eq, Show)++-- For an expression t, returns (u,ts) where u is no application+-- and t = u t+unApps :: Ter -> (Ter,[Ter])+unApps = aux []+  where aux :: [Ter] -> Ter -> (Ter,[Ter])+        aux acc (App r s) = aux (s:acc) r+        aux acc t         = (t,acc)+-- Non tail reccursive version:+-- unApps (App r s) = let (t,ts) = unApps r in (t, ts ++ [s])+-- unApps t         = (t,[])++mkApps :: Ter -> [Ter] -> Ter+mkApps (Con l us) vs = Con l (us ++ vs)+mkApps t ts          = foldl App t ts++mkLams :: [String] -> Ter -> Ter+mkLams bs t = foldr Lam t [noLoc b | b <- bs]++mkWheres :: [ODecls] -> Ter -> Ter+mkWheres []     e = e+mkWheres (d:ds) e = Where (mkWheres ds e) d++-- Primitive notions+primHandle :: [(Ident,Int,PN)]+primHandle =+  [("Id"            , 3,  Id           ),+   ("refl"          , 2,  Refl         ),+   -- ("funExt"        , 5,  Ext          ),+   ("funHExt"       , 5,  HExt          ),+   ("inh"           , 1,  Inh          ),+   ("inc"           , 2,  Inc          ),+   ("squash"        , 3,  Squash       ),+   ("inhrec"        , 5,  InhRec       ),+   ("equivEq"       , 5,  EquivEq      ),+   ("transport"     , 4,  TransU       ),+   ("transpInv"     , 4,  TransInvU    ),+   ("contrSingl"    , 4,  CSingl       ),+   ("transportRef"  , 2,  TransURef    ),+   ("equivEqRef"    , 3,  EquivEqRef   ),+   ("transpEquivEq" , 6,  TransUEquivEq),+   ("appOnPath"     , 8,  AppOnPath    ),+   ("mapOnPath"     , 6,  MapOnPath    ),+   ("IdP"           , 5,  IdP          ),+   ("mapOnPathD"    , 6,  MapOnPathD   ),+   ("mapOnPathS"    , 10, MapOnPathS   ),+   ("S1"            , 0,  Circle       ),+   ("base"          , 0,  Base         ),+   ("loop"          , 0,  Loop         ),+   ("S1rec"         , 4,  CircleRec    ),+   ("I"             , 0,  I            ),+   ("I0"            , 0,  I0           ),+   ("I1"            , 0,  I1           ),+   ("line"          , 0,  Line         ),+   ("intrec"        , 5,  IntRec       )]++reservedNames :: [String]+reservedNames = [ s | (s,_,_) <- primHandle ]++arity :: PN -> Int+arity pn = fromMaybe 0 $ listToMaybe [n | (_,n,pn') <- primHandle, pn == pn']++mkPN :: String -> Maybe PN+mkPN s = listToMaybe [pn | (s',_,pn) <- primHandle, s == s']+ -------------------------------------------------------------------------------- -- | Names, dimension, and nominal type class @@ -94,7 +254,7 @@ type Dim  = [Name]  gensym :: Dim -> Name-gensym [] = 0+gensym [] = 2 gensym xs = maximum xs + 1  gensyms :: Dim -> [Name]@@ -107,6 +267,9 @@ fresh :: Nominal a => a -> Name fresh = gensym . support +freshs :: Nominal a => a -> [Name]+freshs = gensyms . support+ instance (Nominal a, Nominal b) => Nominal (a, b) where   support (a, b)  = support a `union` support b   swap (a, b) x y = (swap a x y, swap b x y)@@ -115,31 +278,36 @@   support vs  = unions (map support vs)   swap vs x y = [swap v x y | v <- vs] -swapName :: Name -> Name -> Name -> Name-swapName z x y | z == x    = y-               | z == y    = x-               | otherwise = z- -- Make Name an instance of Nominal instance Nominal Integer where+  support 0 = []+  support 1 = []   support n = [n]-  swap      = swapName +  swap z x y | z == x    = y+             | z == y    = x+             | otherwise = z+ -------------------------------------------------------------------------------- -- | Boxes -data Dir = Up | Down-  deriving (Eq, Show)+-- TODO: abstract the type of Intervals instead of exposing the encoding+type Dir = Integer  mirror :: Dir -> Dir-mirror Up   = Down-mirror Down = Up+mirror 0 = 1+mirror 1 = 0+mirror n = error $ "mirror: 0 or 1 expected but " ++ show n ++ " given" +up, down :: Dir+up   = 1+down = 0+ type Side = (Name,Dir)  allDirs :: [Name] -> [Side] allDirs []     = []-allDirs (n:ns) = (n,Down) : (n,Up) : allDirs ns+allDirs (n:ns) = (n,down) : (n,up) : allDirs ns  data Box a = Box { dir   :: Dir                  , pname :: Name@@ -150,13 +318,25 @@ instance Show a => Show (Box a) where   show (Box dir n f xs) = "Box" <+> show dir <+> show n <+> show f <+> show xs --- Showing boxes with parenthesis around-showBox :: Show a => Box a -> String-showBox = parens . show- mapBox :: (a -> b) -> Box a -> Box b mapBox f (Box d n x xs) = Box d n (f x) [ (nnd,f v) | (nnd,v) <- xs ] +sequenceSnd :: Monad m => [(a,m b)] -> m [(a,b)]+sequenceSnd []          = return []+sequenceSnd ((a,b):abs) = do+  b' <- b+  acs <- sequenceSnd abs+  return $ (a,b') : acs++sequenceBox :: Monad m => Box (m a) -> m (Box a)+sequenceBox (Box d n x xs) = do+  x' <- x+  xs' <- sequenceSnd xs+  return $ Box d n x' xs'++mapBoxM :: Monad m => (a -> m b) -> Box a -> m (Box b)+mapBoxM f = sequenceBox . mapBox f+ instance Functor Box where   fmap = mapBox @@ -180,6 +360,9 @@ modBox f (Box dir x v nvs) =   Box dir x (f (x,mirror dir) v) [ (nd,f nd v) | (nd,v) <- nvs ] +modBoxM :: Monad m => (Side -> a -> m b) -> Box a -> m (Box b)+modBoxM f = sequenceBox . modBox f+ -- Restricts the non-principal faces to np. subBox :: [Name] -> Box a -> Box a subBox np (Box dir x v nvs) =@@ -191,7 +374,7 @@ -- fst is down, snd is up consBox :: (Name,(a,a)) -> Box a -> Box a consBox (n,(v0,v1)) (Box dir x v nvs) =-  Box dir x v $ ((n,Down),v0) : ((n,Up),v1) : nvs+  Box dir x v $ ((n,down),v0) : ((n,up),v1) : nvs  appendBox :: [(Name,(a,a))] -> Box a -> Box a appendBox xs b = foldr consBox b xs@@ -205,21 +388,11 @@   Box dir x v [ (nnd,head vs) | (nnd,vs) <- nvss ] :   transposeBox (Box dir x vs [ (nnd,tail vs) | (nnd,vs) <- nvss ]) --supportBox :: Nominal a => Box a -> [Name]-supportBox (Box dir n v vns) = [n] `union` support v `union`-  unions [ [y] `union` support v | ((y,dir'),v) <- vns ]---- Swap for boxes-swapBox :: Nominal a => Box a -> Name -> Name -> Box a-swapBox (Box dir z v nvs) x y =-  let sw u = swap u x y-  in Box dir (swap z x y) (sw v)-         [ ((swap n x y,nd),sw v) | ((n,nd),v) <- nvs ]-+-- Nominal for boxes instance Nominal a => Nominal (Box a) where-  swap    = swapBox-  support = supportBox+  support (Box dir n v nvs)  = support ((n, v), nvs)+  swap (Box dir z v nvs) x y = Box dir z' v' nvs' where+    ((z',v'), nvs') = swap ((z, v), nvs) x y  -------------------------------------------------------------------------------- -- | Values@@ -228,51 +401,97 @@   deriving (Show, Eq)  data Val = VU-         | Ter Ter Env+         | Ter Ter OEnv          | VPi Val Val          | VId Val Val Val -           -- tag values which are paths+         | VSigma Val Val+         | VSPair Val Val++         -- tag values which are paths          | Path Name Val-         | VExt Name Val Val Val Val -           -- inhabited+         -- | VExt Name Val Val Val Val+         | VHExt Name Val Val Val Val++         -- inhabited          | VInh Val -           -- inclusion into inhabited+         -- inclusion into inhabited          | VInc Val -           -- squash type - connects the two values along the name+         -- squash type - connects the two values along the name          | VSquash Name Val Val           | VCon Ident [Val]           | Kan KanType Val (Box Val) -           -- of type U connecting a and b along x-           -- VEquivEq x a b f s t+         -- of type U connecting a and b along x+         -- VEquivEq x a b f s t          | VEquivEq Name Val Val Val Val Val -           -- names x, y and values a, s, t+         -- names x, y and values a, s, t          | VEquivSquare Name Name Val Val Val -           -- of type VEquivEq+         -- of type VEquivEq          | VPair Name Val Val -           -- of type VEquivSquare+         -- of type VEquivSquare          | VSquare Name Name Val -           -- a value of type Kan Com VU (Box (type of values))+         -- a value of type Kan Com VU (Box (type of values))          | VComp (Box Val) -           -- a value of type Kan Fill VU (Box (type of values minus name))-           -- the name is bound+         -- a value of type Kan Fill VU (Box (type of values minus name))+         -- the name is bound          | VFill Name (Box Val)++         -- circle+         | VCircle+         | VBase+         | VLoop Name -- has type VCircle and connects base along the name++         -- interval+         | VI+         | VI0+         | VI1+         | VLine Name           -- connects start and end point along name++         -- neutral values+         | VApp Val Val            -- the first Val must be neutral+         | VAppName Val Name+         | VSplit Val Val          -- the second Val must be neutral+         | VVar String Dim+         | VInhRec Val Val Val Val     -- the last Val must be neutral+         | VCircleRec Val Val Val Val  -- the last Val must be neutral+         | VIntRec Val Val Val Val Val -- the last Val must be neutral+         | VFillN Val (Box Val)+         | VComN Val (Box Val)+         | VFst Val+         | VSnd Val   deriving Eq -instance Show Val where-  show = showVal+vepair :: Name -> Val -> Val -> Val+vepair x a b = VSPair a (Path x b) +mkVar :: Int -> Dim -> Val+mkVar k = VVar ('X' : show k)++isNeutral :: Val -> Bool+isNeutral (VApp u _)           = isNeutral u+isNeutral (VAppName u _)       = isNeutral u+isNeutral (VSplit _ v)         = isNeutral v+isNeutral (VVar _ _)           = True+isNeutral (VInhRec _ _ _ v)    = isNeutral v+isNeutral (VCircleRec _ _ _ v) = isNeutral v+isNeutral (VIntRec _ _ _ _ v)  = isNeutral v+isNeutral (VFillN _ _)         = True+isNeutral (VComN _ _)          = True+isNeutral (VFst v)             = isNeutral v+isNeutral (VSnd v)             = isNeutral v+isNeutral _                    = False+ fstVal, sndVal, unSquare :: Val -> Val fstVal (VPair _ a _)     = a fstVal x                 = error $ "error fstVal: " ++ show x@@ -300,15 +519,38 @@   support (VInc v)          = support v   support (VPi v1 v2)       = support [v1,v2]   support (VCon _ vs)       = support vs-  support (VSquash x v0 v1) = [x] `union` support [v0,v1]-  support (VExt x b f g p)  = [x] `union` support [b,f,g,p]-  support (Kan Fill a box)  = support a `union` support box-  support (Kan Com a box@(Box _ n _ _)) =-    delete n (support a `union` support box)-  support (VEquivEq x a b f s t)    = [x] `union` support [a,b,f,s,t]-  support (VPair x a v)             = [x] `union` support [a,v]-  support (VComp box@(Box _ n _ _)) = delete n $ support box-  support (VFill x box)             = delete x $ support box+  support (VSquash x v0 v1) = support (x, [v0,v1])+  -- support (VExt x b f g p)  = support (x, [b,f,g,p])+  support (VHExt x b f g p) = support (x, [b,f,g,p])+  support (Kan Fill a box)  = support (a, box)+  support (VFillN a box)    = support (a, box)+  support (VComN   a box@(Box _ n _ _)) = delete n (support (a, box))+  support (Kan Com a box@(Box _ n _ _)) = delete n (support (a, box))+  support (VEquivEq x a b f s t)        = support (x, [a,b,f,s,t])+           -- names x, y and values a, s, t+  support (VEquivSquare x y a s t)      = support ((x,y), [a,s,t])+  support (VPair x a v)                 = support (x, [a,v])+  support (VComp box@(Box _ n _ _))     = delete n $ support box+  support (VFill x box)                 = delete x $ support box+  support (VApp u v)           = support (u, v)+  support (VAppName u n)       = support (u, n)+  support (VSplit u v)         = support (u, v)+  support (VVar x d)           = support d+  support (VSigma u v)         = support (u,v)+  support (VSPair u v)         = support (u,v)+  support (VFst u)             = support u+  support (VSnd u)             = support u+  support (VInhRec b p h a)    = support [b,p,h,a]+  support VCircle              = []+  support VBase                = []+  support (VLoop n)            = [n]+  support (VCircleRec f b l s) = support [f,b,l,s]+  support VI                   = []+  support VI0                  = []+  support VI1                  = []+  support (VLine n)            = [n]+  support (VIntRec f s e l u)  = support [f,s,e,l,u]+  support v                    = error ("support " ++ show v)    swap u x y =     let sw u = swap u x y in case u of@@ -316,10 +558,11 @@     Ter t e     -> Ter t (swap e x y)     VId a v0 v1 -> VId (sw a) (sw v0) (sw v1)     Path z v | z /= x && z /= y    -> Path z (sw v)-             | otherwise -> let z' = gensym ([x] `union` [y] `union` support v)+             | otherwise -> let z' = fresh ([x, y], v)                                 v' = swap v z z'                             in Path z' (sw v')-    VExt z b f g p  -> VExt (swap z x y) (sw b) (sw f) (sw g) (sw p)+    -- VExt z b f g p  -> VExt (swap z x y) (sw b) (sw f) (sw g) (sw p)+    VHExt z b f g p -> VHExt (swap z x y) (sw b) (sw f) (sw g) (sw p)     VPi a f         -> VPi (sw a) (sw f)     VInh v          -> VInh (sw v)     VInc v          -> VInc (sw v)@@ -332,21 +575,46 @@       VEquivSquare (swap z x y) (swap w x y) (sw a) (sw s) (sw t)     VSquare z w v -> VSquare (swap z x y) (swap w x y) (sw v)     Kan Fill a b  -> Kan Fill (sw a) (swap b x y)+    VFillN a b    -> VFillN (sw a) (swap b x y)     Kan Com a b@(Box _ z _ _)       | z /= x && z /= y -> Kan Com (sw a) (swap b x y)-      | otherwise -> let z' = gensym ([x] `union` [y] `union` support u)+      | otherwise -> let z' = fresh ([x, y], u)                          a' = swap a z z'                      in sw (Kan Com a' (swap b z z'))+    VComN a b@(Box _ z _ _)+      | z /= x && z /= y -> VComN (sw a) (swap b x y)+      | otherwise -> let z' = fresh ([x, y], u)+                         a' = swap a z z'+                     in sw (VComN a' (swap b z z'))     VComp b@(Box _ z _ _)       | z /= x && z /= y -> VComp (swap b x y)-      | otherwise -> let z' = gensym ([x] `union` [y] `union` support u)+      | otherwise -> let z' = fresh ([x, y], u)                      in sw (VComp (swap b z z'))     VFill z b@(Box dir n _ _)-      | z /= x && z /= x -> VFill z (swap b x y)+      | z /= x && z /= y -> VFill z (swap b x y)       | otherwise        -> let-        z' = gensym ([x] `union` [y] `union` support b)+        z' = fresh ([x, y], b)         in sw (VFill z' (swap b z z'))+    VApp u v           -> VApp (sw u) (sw v)+    VAppName u n       -> VAppName (sw u) (swap n x y)+    VSplit u v         -> VSplit (sw u) (sw v)+    VVar s d           -> VVar s (swap d x y)+    VSigma u v         -> VSigma (sw u) (sw v)+    VSPair u v         -> VSPair (sw u) (sw v)+    VFst u             -> VFst (sw u)+    VSnd u             -> VSnd (sw u)+    VInhRec b p h a    -> VInhRec (sw b) (sw p) (sw h) (sw a)+    VCircle            -> VCircle+    VBase              -> VBase+    VLoop z            -> VLoop (swap z x y)+    VCircleRec f b l a -> VCircleRec (sw f) (sw b) (sw l) (sw a)+    VI                 -> VI+    VI0                -> VI0+    VI1                -> VI1+    VLine z            -> VLine (swap z x y)+    VIntRec f s e l u  -> VIntRec (sw f) (sw s) (sw e) (sw l) (sw u) + -------------------------------------------------------------------------------- -- | Environments @@ -356,104 +624,185 @@   deriving Eq  instance Show Env where-  show = showEnv+  show Empty            = ""+  show (PDef xas env)   = show env+  show (Pair env (x,u)) = parens $ showEnv1 env ++ show u+    where+      showEnv1 (Pair env (x,u)) = showEnv1 env ++ show u ++ ", "+      showEnv1 e                = show e -showEnv :: Env -> String-showEnv Empty            = ""-showEnv (Pair env (x,u)) = parens $ showEnv1 env ++ show u-showEnv (PDef xas env)   = showEnv env+instance Nominal Env where+  swap e x y = mapEnv (\u -> swap u x y) e -showEnv1 :: Env -> String-showEnv1 Empty            = ""-showEnv1 (Pair env (x,u)) = showEnv1 env ++ show u ++ ", "-showEnv1 (PDef xas env)   = show env+  support Empty          = []+  support (Pair e (_,v)) = support (e, v)+  support (PDef _ e)     = support e -supportEnv :: Env -> [Name]-supportEnv Empty          = []-supportEnv (Pair e (_,v)) = supportEnv e `union` support v-supportEnv (PDef _ e)     = supportEnv e+data OEnv = OEnv { env     :: Env,+                   opaques :: [Binder] }+  deriving Eq -instance Nominal Env where-  swap e x y = mapEnv (\u -> swap u x y) e-  support    = supportEnv+oEmpty :: OEnv+oEmpty = OEnv Empty [] -upds :: Env -> [(Binder,Val)] -> Env-upds = foldl Pair+oPair :: OEnv -> (Binder,Val) -> OEnv+oPair (OEnv e o) u = OEnv (Pair e u) o +oPDef :: Bool -> ODecls -> OEnv -> OEnv+oPDef _    (ODecls decls)  (OEnv e o) = OEnv (PDef [(x,d) | (x,_,d) <- decls] e) o+oPDef True (Opaque d)      (OEnv e o) = OEnv e (d:o)+oPDef True (Transp d)      (OEnv e o) = OEnv e (d `delete` o)+oPDef _ _ e = e++instance Show OEnv where+  show (OEnv e s) = show e -- <+> parens ("with opaque:" <+> ccat s)++instance Nominal OEnv where+  swap (OEnv e s) x y = OEnv (swap e x y) s+  support (OEnv e s)  = support e++upds :: OEnv -> [(Binder,Val)] -> OEnv+upds = foldl oPair++lookupIdent :: Ident -> [(Binder,a)] -> Maybe (Binder, a)+lookupIdent x defs = lookup x [(y,((y,l),t)) | ((y,l),t) <- defs]++getIdent :: Ident -> [(Binder,a)] -> Maybe a+getIdent x defs = do (_,t) <- lookupIdent x defs; return t++getBinder :: Ident -> [(Binder,a)] -> Maybe Binder+getBinder x defs = do (b,_) <- lookupIdent x defs; return b+ mapEnv :: (Val -> Val) -> Env -> Env mapEnv _ Empty          = Empty mapEnv f (Pair e (x,v)) = Pair (mapEnv f e) (x,f v) mapEnv f (PDef ts e)    = PDef ts (mapEnv f e) +mapEnvM :: Applicative m => (Val -> m Val) -> Env -> m Env+mapEnvM _ Empty          = pure Empty+mapEnvM f (Pair e (x,v)) = Pair <$> mapEnvM f e <*> ( (x,) <$> f v)+mapEnvM f (PDef ts e)    = PDef ts <$> mapEnvM f e +mapOEnv :: (Val -> Val) -> OEnv -> OEnv+mapOEnv f (OEnv e o) = OEnv (mapEnv f e) o++mapOEnvM :: Applicative m => (Val -> m Val) -> OEnv -> m OEnv+mapOEnvM f (OEnv e o) = flip OEnv o <$> mapEnvM f e++valOfEnv :: Env -> [Val]+valOfEnv Empty            = []+valOfEnv (Pair env (_,v)) = v : valOfEnv env+valOfEnv (PDef _ env)     = valOfEnv env++valOfOEnv :: OEnv -> [Val]+valOfOEnv (OEnv e o) = valOfEnv e+ -------------------------------------------------------------------------------- -- | Pretty printing -showTer :: Ter -> String-showTer U                  = "U"-showTer (Var x)            = x-showTer (App e0 e1)        = showTer e0 <+> showTer1 e1-showTer (Pi e0 e1)         = "Pi" <+> showTers [e0,e1]-showTer (Lam x e)          = "\\" ++ x <+> "->" <+> showTer e-showTer (LSum (_,str) _)   = str-showTer (Branch (n,str) _) = str ++ show n-showTer (Undef (n,str))    = str ++ show n-showTer (Con ident ts)     = ident <+> showTers ts-showTer (Id a t s)         = "Id" <+> showTers [a,t,s]-showTer (TransU t s)       = "transport" <+> showTers [t,s]-showTer (TransURef t)      = "transportRef" <+> showTer t-showTer (Refl t)           = "refl" <+> showTer t-showTer (J a b c d e f)    = "J" <+> showTers [a,b,c,d,e,f]-showTer (JEq a b c d)      = "Jeq" <+> showTers [a,b,c,d]-showTer (Ext b f g p)      = "funExt" <+> showTers [b,f,g,p]-showTer (Inh t)            = "inh" <+> showTer t-showTer (Inc t)            = "inc" <+> showTer t-showTer (Squash a b)       = "squash" <+> showTers [a,b]-showTer (InhRec a b c d)   = "inhrec" <+> showTers [a,b,c,d]-showTer (EquivEq a b c d e) = "equivEq" <+> showTers [a,b,c,d,e]-showTer (EquivEqRef a b c) = "equivEqRef" <+> showTers [a,b,c]-showTer (TransUEquivEq a b c d e f) = "transpEquivEq" <+> showTers [a,b,c,d,e,f]-showTer (Where t defs)     = showTer t <+> "where" <+> showDefs defs+instance Show Loc where+  show (Loc name (i,j)) = name ++ "_L" ++ show i ++ "_C" ++ show j -showDef :: Def -> String-showDef (x,t) = x <+> "=" <+> showTer t+instance Show Ter where+  show = showTer -showDefs :: [Def] -> String-showDefs = ccat . map showDef+showTer :: Ter -> String+showTer U                 = "U"+showTer (App e0 e1)       = showTer e0 <+> showTer1 e1+showTer (Pi e0 e1)        = "Pi" <+> showTers [e0,e1]+showTer (Lam (x,_) e)         = '\\' : x <+> "->" <+> showTer e+showTer (Fst e)           = showTer e ++ ".1"+showTer (Snd e)           = showTer e ++ ".2"+showTer (Sigma e0 e1)     = "Sigma" <+> showTers [e0,e1]+showTer (SPair e0 e1)      = "pair" <+> showTers [e0,e1]+showTer (Where e d)       = showTer e <+> "where" <+> showODecls d+showTer (Var x)           = x+showTer (Con c es)        = c <+> showTers es+showTer (Split l _)       = "split " ++ show l+showTer (Sum l _)         = "sum " ++ show l+showTer (PN pn)           = showPN pn  showTers :: [Ter] -> String showTers = hcat . map showTer1  showTer1 :: Ter -> String-showTer1 U          = "U"-showTer1 (Con c []) = c-showTer1 (Var x)    = x-showTer1 u          = parens $ showTer u+showTer1 U           = "U"+showTer1 (Con c [])  = c+showTer1 (Var x)     = x+showTer1 u@(Split{}) = showTer u+showTer1 u@(Sum{})   = showTer u+showTer1 u@(PN{})    = showTer u+showTer1 u           = parens $ showTer u +-- Warning: do not use showPN as a Show instance as it will loop+showPN :: PN -> String+showPN (Undef l) = show l+showPN pn              = case [s | (s,_,pn') <- primHandle, pn == pn'] of+  [s] -> s+  _   -> error $ "showPN: unknown primitive " ++ show pn++showDecls :: Decls -> String+showDecls defs = ccat (map (\((x,_),_,d) -> x <+> "=" <+> show d) defs)++showODecls :: ODecls -> String+showODecls (ODecls defs) = showDecls defs+showODecls (Opaque x)    = "opaque"      <+> show x+showODecls (Transp x)    = "transparent" <+> show x++instance Show Val where+  show = showVal+ showVal :: Val -> String showVal VU               = "U"-showVal (Ter t env)      = showTer t <+> show env+showVal (Ter t env)      = show t <+> show env showVal (VId a u v)      = "Id" <+> showVal1 a <+> showVal1 u <+> showVal1 v showVal (Path n u)       = abrack (show n) <+> showVal u-showVal (VExt n b f g p) = "funExt" <+> show n <+> showVals [b,f,g,p]+-- showVal (VExt n b f g p) = "funExt" <+> show n <+> showVals [b,f,g,p]+showVal (VHExt n b f g p) = "funHExt" <+> show n <+> showVals [b,f,g,p] showVal (VCon c us)      = c <+> showVals us showVal (VPi a f)        = "Pi" <+> showVals [a,f] showVal (VInh u)         = "inh" <+> showVal1 u showVal (VInc u)         = "inc" <+> showVal1 u+showVal (VInhRec b p h a) = "inhrec" <+> showVals [b,p,h,a] showVal (VSquash n u v)  = "squash" <+> show n <+> showVals [u,v]-showVal (Kan typ v box)  = "Kan" <+> show typ <+> showVal1 v <+> showBox box+showVal (Kan Fill v box) = "Fill" <+> showVal1 v <+> parens (show box)+showVal (Kan Com v box)  = "Com" <+> showVal1 v <+> parens (show box)+showVal (VFillN v box)   = "FillN" <+> showVal1 v <+> parens (show box)+showVal (VComN v box)    = "ComN" <+> showVal1 v <+> parens (show box) showVal (VPair n u v)    = "vpair" <+> show n <+> showVals [u,v] showVal (VSquare x y u)  = "vsquare" <+> show x <+> show y <+> showVal1 u-showVal (VComp box)      = "vcomp" <+> showBox box-showVal (VFill n box)    = "vfill" <+> show n <+> showBox box-showVal (VEquivEq n a b f s t) = "equivEq" <+> show n <+> showVals [a,b,f,s,t]+showVal (VComp box)      = "vcomp" <+> parens (show box)+showVal (VFill n box)    = "vfill" <+> show n <+> parens (show box)+showVal (VApp u v)       = showVal u <+> showVal1 v+showVal (VAppName u n)   = showVal u <+> "@" <+> show n+showVal (VSplit u v)     = showVal u <+> showVal1 v+showVal (VVar x d)       = x <+> showDim d+showVal (VEquivEq n a b f _ _)   = "equivEq" <+> show n <+> showVals [a,b,f] showVal (VEquivSquare x y a s t) =   "equivSquare" <+> show x <+> show y <+> showVals [a,s,t]+showVal (VSPair u v)     = "pair" <+> showVals [u,v]+showVal (VSigma u v)     = "Sigma" <+> showVals [u,v]+showVal (VFst u)         = showVal u ++ ".1"+showVal (VSnd u)         = showVal u ++ ".2"+showVal VCircle          = "S1"+showVal VBase            = "base"+showVal (VLoop x)        = "loop" <+> show x+showVal (VCircleRec f b l s) = "S1rec" <+> showVals [f,b,l,s]+showVal VI               = "I"+showVal VI0              = "I0"+showVal VI1              = "I1"+showVal (VLine n)        = "line" <+> show n+showVal (VIntRec f s e l u) = "intrec" <+> showVals [f,s,e,l,u] +showDim :: Show a => [a] -> String+showDim = parens . ccat . map show+ showVals :: [Val] -> String showVals = hcat . map showVal1  showVal1 :: Val -> String-showVal1 VU          = "U"-showVal1 (VCon c []) = c-showVal1 u           = parens $ showVal u+showVal1 VU           = "U"+showVal1 (VCon c [])  = c+showVal1 u@(VVar{})   = showVal u+showVal1 u            = parens $ showVal u+
Concrete.hs view
@@ -1,201 +1,258 @@-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TupleSections, ParallelListComp #-} --- Convert the concrete syntax into the syntax of miniTT.+-- | Convert the concrete syntax into the syntax of cubical TT. module Concrete where  import Exp.Abs-import qualified MTT as A+import qualified CTT as C+import Pretty -import Control.Arrow (first) import Control.Applicative import Control.Monad.Trans-import Control.Monad.Trans.State import Control.Monad.Trans.Reader import Control.Monad.Trans.Error hiding (throwError) import Control.Monad.Error (throwError) import Control.Monad (when) import Data.Functor.Identity-import Data.List (union)+import Data.List (nub) -type Tele = [VDecl]+type Tele = [(AIdent,Exp)]+type Ter  = C.Ter  -- | Useful auxiliary functions-unions :: Eq a => [[a]] -> [a]-unions = foldr union []  -- Applicative cons (<:>) :: Applicative f => f a -> f [a] -> f [a] a <:> b = (:) <$> a <*> b  -- un-something functions-unIdent :: AIdent -> String-unIdent (AIdent (_,n)) = n--unArg :: Arg -> String-unArg (Arg n) = unIdent n-unArg NoArg   = "_"--unArgs :: [Arg] -> [String]-unArgs = map unArg--unBinder :: Binder -> Arg-unBinder (Binder b) = b--unArgBinder :: Binder -> String-unArgBinder = unArg . unBinder+unAIdent :: AIdent -> C.Ident+unAIdent (AIdent (_,x)) = x -unArgsBinder :: [Binder] -> [String]-unArgsBinder = map unArgBinder+unVar :: Exp -> Maybe AIdent+unVar (Var x) = Just x+unVar _       = Nothing  unWhere :: ExpWhere -> Exp unWhere (Where e ds) = Let ds e unWhere (NoWhere e)  = e --- Flatten a telescope, e.g., flatten (a b : A) (c : C) into--- (a : A) (b : A) (c : C).-flattenTele :: Tele -> [VDecl]-flattenTele = concatMap (\(VDecl bs e) -> [VDecl [b] e | b <- bs])---- Note: It is important to only apply unApps to e1 as otherwise the--- structure of the application will be destroyed which leads to trouble--- for constructor disambiguation!-unApps :: Exp -> [Exp]-unApps (App e1 e2) = unApps e1 ++ [e2]-unApps e           = [e]--unVar :: Exp -> Arg-unVar (Var b) = b-unVar e       = error $ "unVar bad input: " ++ show e--unVarBinder :: Exp -> String-unVarBinder = unArg . unVar+-- tail recursive form to transform a sequence of applications+-- App (App (App u v) ...) w  into (u, [v, …, w])+-- (cleaner than the previous version of unApps)+unApps :: Exp -> [Exp] -> (Exp, [Exp])+unApps (App u v) ws = unApps u (v : ws)+unApps u         ws = (u, ws) -unPiDecl :: PiDecl -> VDecl-unPiDecl (PiDecl e t) = VDecl (map (Binder . unVar) (unApps e)) t+vTele :: [VTDecl] -> Tele+vTele decls = [ (i, typ) | VTDecl id ids typ <- decls, i <- id:ids ] -flattenTelePi :: [PiDecl] -> [VDecl]-flattenTelePi = flattenTele . map unPiDecl+-- turns an expression of the form App (... (App id1 id2) ... idn)+-- into a list of idents+pseudoIdents :: Exp -> Maybe [AIdent]+pseudoIdents = mapM unVar . uncurry (:) . flip unApps [] -namesTele :: Tele -> [String]-namesTele vs = unions [ unArgsBinder args | VDecl args _ <- vs ]+pseudoTele :: [PseudoTDecl] -> Maybe Tele+pseudoTele []                         = return []+pseudoTele (PseudoTDecl exp typ : pd) = do+    ids <- pseudoIdents exp+    pt  <- pseudoTele pd+    return $ map (,typ) ids ++ pt  ------------------------------------------------------------------------------- -- | Resolver and environment +data SymKind = Variable | Constructor+  deriving (Eq,Show)+ -- local environment for constructors-data Env = Env { constrs :: [String] }-         deriving (Eq, Show)+data Env = Env { envModule :: String,+                 variables :: [(C.Binder,SymKind)] }+  deriving (Eq, Show) -type Resolver a = ReaderT Env (StateT A.Prim (ErrorT String Identity)) a+type Resolver a = ReaderT Env (ErrorT String Identity) a  emptyEnv :: Env-emptyEnv = Env []+emptyEnv = Env "" []  runResolver :: Resolver a -> Either String a-runResolver x = runIdentity $ runErrorT $ evalStateT (runReaderT x emptyEnv) (0,"")+runResolver x = runIdentity $ runErrorT $ runReaderT x emptyEnv -insertConstrs :: [String] -> Env -> Env-insertConstrs cs (Env cs') = Env $ cs ++ cs'+updateModule :: String -> Env -> Env+updateModule mod e = e {envModule = mod} -getEnv :: Resolver Env-getEnv = ask+insertBinder :: (C.Binder,SymKind) -> Env -> Env+insertBinder (x@(n,_),var) e+  | n == "_" || n == "undefined" = e+  | otherwise                    = e {variables = (x, var) : variables e} -getConstrs :: Resolver [String]-getConstrs = constrs <$> getEnv+insertBinders :: [(C.Binder,SymKind)] -> Env -> Env+insertBinders = flip $ foldr insertBinder -genPrim :: Resolver A.Prim-genPrim = do-  prim <- lift get-  lift (modify (first succ))-  return prim+insertVar :: C.Binder -> Env -> Env+insertVar x = insertBinder (x,Variable) -updateName :: String -> Resolver ()-updateName str = lift $ modify (\(g,_) -> (g,str))+insertVars :: [C.Binder] -> Env -> Env+insertVars = flip $ foldr insertVar -lam :: Arg -> Resolver A.Exp -> Resolver A.Exp-lam a e = A.Lam (unArg a) <$> e+insertCon :: C.Binder -> Env -> Env+insertCon x = insertBinder (x,Constructor) -lams :: [Arg] -> Resolver A.Exp -> Resolver A.Exp-lams as e = foldr lam e as+insertCons :: [C.Binder] -> Env -> Env+insertCons = flip $ foldr insertCon -resolveExp :: Exp -> Resolver A.Exp-resolveExp U            = return A.U-resolveExp Undef        = A.Undef <$> genPrim-resolveExp PN           = A.Undef <$> genPrim-resolveExp e@(App t s)  = do-  let x:xs = unApps e-  cs <- getConstrs-  if unVarBinder x `elem` cs-    then A.Con (unVarBinder x) <$> mapM resolveExp xs-    else A.App <$> resolveExp t <*> resolveExp s-resolveExp (Pi tele b)  = resolveTelePi (flattenTelePi tele) (resolveExp b)-resolveExp (Fun a b)    = A.Pi <$> resolveExp a <*> lam NoArg (resolveExp b)-resolveExp (Lam bs t)   = lams (map unBinder bs) (resolveExp t)-resolveExp (Split brs)  = A.Fun <$> genPrim <*> mapM resolveBranch brs-resolveExp (Let defs e) = A.lets <$> resolveDefs defs <*> resolveExp e-resolveExp (Var n)      = do-  let x = unArg n-  when (x == "_") (throwError "_ not a valid variable name")-  Env cs <- getEnv-  return (if x `elem` cs then A.Con x [] else A.Var x)+getModule :: Resolver String+getModule = envModule <$> ask -resolveWhere :: ExpWhere -> Resolver A.Exp-resolveWhere = resolveExp . unWhere+getVariables :: Resolver [(C.Binder,SymKind)]+getVariables = variables <$> ask -resolveBranch :: Branch -> Resolver (String,([String],A.Exp))-resolveBranch (Branch name args e) =-  ((unIdent name,) . (unArgs args,)) <$> resolveWhere e+getLoc :: (Int,Int) -> Resolver C.Loc+getLoc l = C.Loc <$> getModule <*> pure l --- Assumes a flattened telescope.-resolveTele :: [VDecl] -> Resolver [(String,A.Exp)]-resolveTele []                      = return []-resolveTele (VDecl [Binder a] t:ds) =-  ((unArg a,) <$> resolveExp t) <:> resolveTele ds-resolveTele ds                      =-  throwError $ "resolveTele: non flattened telescope " ++ show ds+resolveBinder :: AIdent -> Resolver C.Binder+resolveBinder (AIdent (l,x)) = do l <- getLoc l; return (x, l) --- Assumes a flattened telescope.-resolveTelePi :: [VDecl] -> Resolver A.Exp -> Resolver A.Exp-resolveTelePi [] b                      = b-resolveTelePi (VDecl [Binder x] a:as) b =-  A.Pi <$> resolveExp a <*> lam x (resolveTelePi as b)-resolveTelePi (t@(VDecl{}):as) _        =-  throwError ("resolveTelePi: non flattened telescope " ++ show t)+resolveVar :: AIdent -> Resolver Ter+resolveVar (AIdent (l,x))+  | (x == "_") || (x == "undefined") = C.PN <$> C.Undef <$> getLoc l+  | otherwise = do+    modName <- getModule+    vars    <- getVariables+    case C.getIdent x vars of+      Just Variable    -> return $ C.Var x+      Just Constructor -> return $ C.Con x []+      _ -> throwError $+        "Cannot resolve variable" <+> x <+> "at position" <+>+        show l <+> "in module" <+> modName -resolveLabel :: Sum -> Resolver (String,[(String,A.Exp)])-resolveLabel (Sum n tele) = (unIdent n,) <$> resolveTele (flattenTele tele)+lam :: AIdent -> Resolver Ter -> Resolver Ter+lam a e = do x <- resolveBinder a; C.Lam x <$> local (insertVar x) e -resolveDefs :: [Def] -> Resolver [A.Def]-resolveDefs [] = return []-resolveDefs (DefTDecl n e:d:ds) = do-  e' <- resolveExp e-  xd <- checkDef (unIdent n,d)-  rest <- resolveDefs ds-  return $ ([(unIdent n, e')],[xd]) : rest--- resolveDefs (DefMutual defs:ds) = resolveMutual defs <:> resolveDefs ds-resolveDefs (d:_) = error $ "Type declaration expected: " ++ show d+lams :: [AIdent] -> Resolver Ter -> Resolver Ter+lams = flip $ foldr lam -checkDef :: (String,Def) -> Resolver (String,A.Exp)-checkDef (n,Def (AIdent (_,m)) args body) | n == m = do-  updateName n+bind :: (Ter -> Ter -> Ter) -> (AIdent, Exp) -> Resolver Ter -> Resolver Ter+bind f (x,t) e = f <$> resolveExp t <*> lam x e++binds :: (Ter -> Ter -> Ter) -> Tele -> Resolver Ter -> Resolver Ter+binds f = flip $ foldr $ bind f++resolveExp :: Exp -> Resolver Ter+resolveExp U            = return C.U+resolveExp (Var x)      = resolveVar x+resolveExp (App t s)    = C.mkApps <$> resolveExp x <*> mapM resolveExp xs+  where (x, xs) = unApps t [s]+resolveExp (Sigma t b)  = case pseudoTele t of+  Just tele -> binds C.Sigma tele (resolveExp b)+  Nothing   -> throwError "Telescope malformed in Sigma"+resolveExp (Pi t b)     =  case pseudoTele t of+  Just tele -> binds C.Pi tele (resolveExp b)+  Nothing   -> throwError "Telescope malformed in Pigma"+resolveExp (Fun a b)    = bind C.Pi (AIdent ((0,0),"_"), a) (resolveExp b)+resolveExp (Lam x xs t) = lams (x:xs) (resolveExp t)+resolveExp (Fst t)      = C.Fst <$> resolveExp t+resolveExp (Snd t)      = C.Snd <$> resolveExp t+resolveExp (Pair t0 t1) = C.SPair <$> resolveExp t0 <*> resolveExp t1+resolveExp (Split brs)  = do+    brs' <- mapM resolveBranch brs+    loc  <- getLoc (case brs of Branch (AIdent (l,_)) _ _:_ -> l ; _ -> (0,0))+    return $ C.Split loc brs'+resolveExp (Let decls e) = do+  (rdecls,names) <- resolveDecls decls+  C.mkWheres rdecls <$> local (insertBinders names) (resolveExp e)++resolveWhere :: ExpWhere -> Resolver Ter+resolveWhere = resolveExp . unWhere++resolveBranch :: Branch -> Resolver (C.Label,([C.Binder],C.Ter))+resolveBranch (Branch lbl args e) = do+    binders <- mapM resolveBinder args+    re      <- local (insertVars binders) $ resolveWhere e+    return (unAIdent lbl, (binders, re))++resolveTele :: [(AIdent,Exp)] -> Resolver C.Tele+resolveTele []        = return []+resolveTele ((i,d):t) = do+  x <- resolveBinder i+  ((x,) <$> resolveExp d) <:> local (insertVar x) (resolveTele t)++resolveLabel :: Label -> Resolver (C.Binder, C.Tele)+resolveLabel (Label n vdecl) = (,) <$> resolveBinder n <*> resolveTele (vTele vdecl)++declsLabels :: [Decl] -> Resolver [C.Binder]+declsLabels decls = mapM resolveBinder [lbl | Label lbl _ <- sums]+  where sums = concat [sum | DeclData _ _ sum <- decls]++-- Resolve Data or Def declaration+resolveDDecl :: Decl -> Resolver (C.Ident, C.Ter)+resolveDDecl (DeclDef  (AIdent (_,n)) args body) =   (n,) <$> lams args (resolveWhere body)-checkDef (n,DefData (AIdent (_,m)) args sums) | n == m = do-  updateName n-  (n,) <$> lams args (A.Sum <$> genPrim <*> mapM resolveLabel sums)-checkDef (n,d) =-  throwError ("Mismatching names in " ++ show n ++ " and " ++ show d)+resolveDDecl (DeclData x@(AIdent (l,n)) args sum) =+  (n,) <$> lams args (C.Sum <$> resolveBinder x <*> mapM resolveLabel sum)+resolveDDecl d = throwError $ "Definition expected" <+> show d -resolveMutual :: [Def] -> Resolver A.Def-resolveMutual defs = do-  tdecls' <- mapM resolveTDecl tdecls-  let names = map fst tdecls'-  when (length names /= length decls) $-    throwError $ "Definitions missing in " ++ show defs-  tdef' <- mapM checkDef (zip names decls)-  return (tdecls',tdef')+-- Resolve mutual declarations (possibly one)+resolveMutuals :: [Decl] -> Resolver (C.Decls,[(C.Binder,SymKind)])+resolveMutuals decls = do+    binders <- mapM resolveBinder idents+    cs      <- declsLabels decls+    let cns = map fst cs ++ names+    when (nub cns /= cns) $+      throwError $ "Duplicated constructor or ident:" <+> show cns+    rddecls <-+      mapM (local (insertVars binders . insertCons cs) . resolveDDecl) ddecls+    when (names /= map fst rddecls) $+      throwError $ "Mismatching names in" <+> show decls+    rtdecls <- resolveTele tdecls+    return ([ (x,t,d) | (x,t) <- rtdecls | (_,d) <- rddecls ],+            map (,Constructor) cs ++ map (,Variable) binders)   where-    (tdecls,decls) = span isTDecl defs-    isTDecl d@(DefTDecl {}) = True-    isTDecl _               = False-    resolveTDecl (DefTDecl n e) = do e' <- resolveExp e-                                     return (unIdent n, e')+    idents = [ x | DeclType x _ <- decls ]+    names  = [ unAIdent x | x <- idents ]+    tdecls = [ (x,t) | DeclType x t <- decls ]+    ddecls = [ t | t <- decls, not $ isTDecl t ]+    isTDecl d = case d of DeclType{} -> True; _ -> False++-- Resolve opaque/transparent decls+resolveOTDecl :: (C.Binder -> C.ODecls) -> AIdent -> [Decl] ->+                 Resolver ([C.ODecls],[(C.Binder,SymKind)])+resolveOTDecl c n ds = do+  vars         <- getVariables+  (rest,names) <- resolveDecls ds+  case C.getBinder (unAIdent n) vars of+    Just x  -> return (c x : rest, names)+    Nothing -> throwError $ "Not in scope:" <+> show n++-- Resolve declarations+resolveDecls :: [Decl] -> Resolver ([C.ODecls],[(C.Binder,SymKind)])+resolveDecls []                   = return ([],[])+resolveDecls (DeclOpaque n:ds)    = resolveOTDecl C.Opaque n ds+resolveDecls (DeclTransp n:ds)    = resolveOTDecl C.Transp n ds+resolveDecls (td@DeclType{}:d:ds) = do+    (rtd,names)  <- resolveMutuals [td,d]+    (rds,names') <- local (insertBinders names) $ resolveDecls ds+    return (C.ODecls rtd : rds, names' ++ names)+resolveDecls (DeclPrim x t:ds) = case C.mkPN (unAIdent x) of+  Just pn -> do+    b  <- resolveBinder x+    rt <- resolveExp t+    (rds,names) <- local (insertVar b) $ resolveDecls ds+    return (C.ODecls [(b, rt, C.PN pn)] : rds, names ++ [(b,Variable)])+  Nothing -> throwError $ "Primitive notion not defined:" <+> unAIdent x+resolveDecls (DeclMutual defs : ds) = do+  (rdefs,names)  <- resolveMutuals defs+  (rds,  names') <- local (insertBinders names) $ resolveDecls ds+  return (C.ODecls rdefs : rds, names' ++ names)+resolveDecls (decl:_) = throwError $ "Invalid declaration:" <+> show decl++resolveModule :: Module -> Resolver ([C.ODecls],[(C.Binder,SymKind)])+resolveModule (Module n imports decls) =+  local (updateModule $ unAIdent n) $ resolveDecls decls++resolveModules :: [Module] -> Resolver ([C.ODecls],[(C.Binder,SymKind)])+resolveModules []         = return ([],[])+resolveModules (mod:mods) = do+  (rmod, names)  <- resolveModule mod+  (rmods,names') <- local (insertBinders names) $ resolveModules mods+  return (rmod ++ rmods, names' ++ names)
Eval.hs view
@@ -1,469 +1,906 @@-module Eval where--import Control.Arrow (second)-import Data.List-import Data.Maybe (fromMaybe)-import Debug.Trace--import CTT---- Switch to False to turn off debugging-debug :: Bool-debug = True--traceb :: String -> a -> a-traceb s x = if debug then trace s x else x--evals :: Env -> [(Binder,Ter)] -> [(Binder,Val)]-evals e = map (second (eval e))--unCompAs :: Val -> Name -> Box Val-unCompAs (VComp box) y = swap box (pname box) y-unCompAs v           _ = error $ "unCompAs: " ++ show v ++ " is not a VComp"--unFillAs :: Val -> Name -> Box Val-unFillAs (VFill x box) y = swap box x y-unFillAs v             _ = error $ "unFillAs: " ++ show v ++ " is not a VFill"--appName :: Val -> Name -> Val-appName (Path x u) y = swap u x y-appName v _          = error $ "appName: " ++ show v ++ " should be a path"---- Compute the face of a value-face :: Val -> Side -> Val-face u xdir@(x,dir) =-  let fc v = v `face` (x,dir) in case u of-  VU          -> VU-  Ter t e     -> eval (e `faceEnv` xdir) t-  VId a v0 v1 -> VId (fc a) (fc v0) (fc v1)-  Path y v | x == y    -> u-           | otherwise -> Path y (fc v)-  VExt y b f g p | x == y && dir == Down -> f-                 | x == y && dir == Up   -> g-                 | otherwise             -> VExt y (fc b) (fc f) (fc g) (fc p)-  VPi a f    -> VPi (fc a) (fc f)-  VInh v     -> VInh (fc v)-  VInc v     -> VInc (fc v)-  VSquash y v0 v1 | x == y && dir == Down -> v0-                  | x == y && dir == Up   -> v1-                  | otherwise             -> VSquash y (fc v0) (fc v1)-  VCon c us -> VCon c (map fc us)-  VEquivEq y a b f s t | x == y && dir == Down -> a-                       | x == y && dir == Up   -> b-                       | otherwise             ->-                         VEquivEq y (fc a) (fc b) (fc f) (fc s) (fc t)-  VPair y a v | x == y && dir == Down -> a-              | x == y && dir == Up   -> fc v-              | otherwise             -> VPair y (fc a) (fc v)-  VEquivSquare y z a s t | x == y                -> a-                         | x == z && dir == Down -> a-                         | x == z && dir == Up   -> VEquivEq y a a idV s t-                         | otherwise             ->-                          VEquivSquare y z (fc a) (fc s) (fc t)-  VSquare y z v | x == y                -> fc v-                | x == z && dir == Down -> fc v-                | x == z && dir == Up   -> idVPair y (fc v)-                | otherwise             -> VSquare y z (fc v)-  Kan Fill a b@(Box dir' y v nvs)-    | x /= y && x `notElem` nonPrincipal b -> fill (fc a) (mapBox fc b)-    | x `elem` nonPrincipal b              -> lookBox (x,dir) b-    | x == y && dir == mirror dir'         -> v-    | otherwise                            -> com a b-  Kan Com a b@(Box dir' y v nvs)-    | x == y                     -> u-    | x `notElem` nonPrincipal b -> com (fc a) (mapBox fc b)-    | x `elem` nonPrincipal b    -> lookBox (x,dir) b `face` (y,dir')-  VComp b@(Box dir' y _ _)-    | x == y                     -> u-    | x `notElem` nonPrincipal b -> VComp (mapBox fc b)-    | x `elem` nonPrincipal b    -> lookBox (x,dir) b `face` (y,dir')-  VFill z b@(Box dir' y v nvs)-    | x == z                               -> u-    | x /= y && x `notElem` nonPrincipal b -> VFill z (mapBox fc b)-    | (x,dir) `elem` defBox b              ->-      lookBox (x,dir) (mapBox (`face` (z,Down)) b)-    | x == y && dir == dir'                ->-        VComp $ mapBox (`face` (z,Up)) b--idV :: Val-idV = Ter (Lam "x" (Var "x")) Empty--idVPair :: Name -> Val -> Val-idVPair x v = VPair x (v `face` (x,Down)) v---- Compute the face of an environment-faceEnv :: Env -> Side -> Env-faceEnv e xd = mapEnv (`face` xd) e--look :: Binder -> Env -> Val-look x (Pair s (y,u)) | x == y    = u-                      | otherwise = look x s-look x r@(PDef es r1)             = look x (upds r1 (evals r es))--cubeToBox :: Val -> Box () -> Box Val-cubeToBox v = modBox (\nd _ -> v `face` nd)--eval :: Env -> Ter -> Val-eval _ U             = VU-eval e (Var i)       = look i e-eval e (Id a a0 a1)  = VId (eval e a) (eval e a0) (eval e a1)-eval e (Refl a)      = Path (fresh e) $ eval e a-eval e (TransU p t) =-  com pv box-  where x   = fresh e-        pv  = appName (eval e p) x-        box = Box Up x (eval e t) []-eval e (TransURef t) = Path (fresh e) (eval e t)-eval e (TransUEquivEq a b f s t u) = Path x pv -- TODO: Check this!-  where x   = fresh e-        pv  = fill (eval e b) box-        box = Box Up x (app (eval e f) (eval e u)) []-eval e (J a u c w _ p) = com (app (app cv omega) sigma) box-  where-    x:y:_ = gensyms $ supportEnv e-    uv    = eval e u-    pv    = appName (eval e p) x-    theta = fill (eval e a) (Box Up x uv [((y,Down),uv),((y,Up),pv)])-    sigma = Path x theta-    omega = theta `face` (x,Up)-    cv    = eval e c-    box   = Box Up y (eval e w) []-eval e (JEq a u c w) = Path y $ fill (app (app cv omega) sigma) box-  where-    x:y:_ = gensyms $ supportEnv e-    uv    = eval e u-    theta = fill (eval e a) (Box Up x uv [((y,Down),uv),((y,Up),uv)])-    sigma = Path x theta-    omega = theta `face` (x,Up)-    cv    = eval e c-    box   = Box Up y (eval e w) []-eval e (Ext b f g p) =-  Path x $ VExt x (eval e b) (eval e f) (eval e g) (eval e p)-    where x = fresh e-eval e (Pi a b)      = VPi (eval e a) (eval e b)-eval e (Lam x t)     = Ter (Lam x t) e -- stop at lambdas-eval e (App r s)     = app (eval e r) (eval e s)-eval e (Inh a)       = VInh (eval e a)-eval e (Inc t)       = VInc (eval e t)-eval e (Squash r s)  = Path x $ VSquash x (eval e r) (eval e s)-  where x = fresh e-eval e (InhRec b p phi a)  =-  inhrec (eval e b) (eval e p) (eval e phi) (eval e a)-eval e (Where t def)       = eval (PDef def e) t-eval e (Con name ts)       = VCon name (map (eval e) ts)-eval e (Branch pr alts)    = Ter (Branch pr alts) e-eval e (LSum pr ntss)      = Ter (LSum pr ntss) e-eval e (EquivEq a b f s t) =-  Path x $ VEquivEq x (eval e a) (eval e b) (eval e f) (eval e s) (eval e t)-    where x = fresh e-eval e (EquivEqRef a s t)  =-  Path y $ Path x $ VEquivSquare x y (eval e a) (eval e s) (eval e t)-  where x:y:_ = gensyms (supportEnv e)--inhrec :: Val -> Val -> Val -> Val -> Val-inhrec _ _ phi (VInc a)          = app phi a-inhrec b p phi (VSquash x a0 a1) = appName (app (app p b0) b1) x-  where fc w d = w `face` (x,d)-        b0     = inhrec (fc b Down) (fc p Down) (fc phi Down) a0-        b1     = inhrec (fc b Up)   (fc p Up)   (fc phi Up)   a1-inhrec b p phi (Kan ktype (VInh a) box@(Box dir x v nvs)) =-  kan ktype b (modBox irec box)-    where irec (j,dir) v = let fc v = v `face` (j,dir)-                         in inhrec (fc b) (fc p) (fc phi) v-inhrec b p phi v = error $ "inhrec : " ++ show v--kan :: KanType -> Val -> Box Val -> Val-kan Fill = fill-kan Com  = com---- Kan filling-fill :: Val -> Box Val -> Val-fill vid@(VId a v0 v1) box@(Box dir i v nvs) = Path x $ fill a box'-  where x    = gensym (support vid `union` support box)-        box' = (x,(v0,v1)) `consBox` mapBox (`appName` x) box--- assumes cvs are constructor vals-fill (Ter (LSum _ nass) env) box@(Box _ _ (VCon n _) _) = VCon n ws-  where as = case lookup n nass of-               Just as -> as-               Nothing -> error $ "fill: missing constructor "-                               ++ "in labelled sum " ++ n-        boxes = transposeBox $ mapBox unCon box-        -- fill boxes for each argument position of the constructor-        ws    = fills as env boxes-fill (VEquivSquare x y a s t) box@(Box dir x' vx' nvs) =-  VSquare x y v-  where v = fill a $ modBox unPack box--        unPack :: (Name,Dir) -> Val -> Val-        unPack (z,c) v | z /= x && z /= y  = unSquare v-                       | z == y && c == Up = sndVal v-                       | otherwise         = v---- a and b should be independent of x-fill veq@(VEquivEq x a b f s t) box@(Box dir z vz nvs)-  | x /= z && x `notElem` nonPrincipal box =-    let ax0  = fill a (mapBox fstVal box)-        bx0  = app f ax0-        bx   = mapBox sndVal box-        bx1  = fill b $ mapBox (`face` (x,Up)) bx-        v    = fill b $ (x,(bx0,bx1)) `consBox` bx-    in traceb "VEquivEq case 1" $ VPair x ax0 v-  | x /= z && x `elem` nonPrincipal box =-    let ax0 = lookBox (x,Down) box-        bx  = modBox (\(ny,dy) vy -> if x /= ny then sndVal vy else-                                       if dy == Down then app f ax0 else vy) box-        v   = fill b bx-    in traceb "VEquivEq case 2" $ VPair x ax0 v-  | x == z && dir == Up =-    let ax0  = vz-        bx0  = app f ax0-        v    = fill b $ Box dir z bx0 [ (nnd,sndVal v) | (nnd,v) <- nvs ]-    in traceb "VEquivEq case 3" $ VPair x ax0 v-  | x == z && dir == Down =-     let y  = gensym (support veq `union` support box)-         VCon "pair" [gb,sb] = app s vz-         vy = appName sb x--         vpTSq :: Name -> Dir -> Val -> (Val,Val)-         vpTSq nz dz (VPair z a0 v0) =-             let vp = VCon "pair" [a0, Path z v0]-                 t0 = t `face` (nz,dz)-                 b0 = vz `face` (nz,dz)-                 VCon "pair" [l0,sq0] = appName (app (app t0 b0) vp) y-             in (l0,appName sq0 x)  -- TODO: check the correctness of the square s0--         -- TODO: Use modBox!-         vsqs   = [ ((n,d),vpTSq n d v) | ((n,d),v) <- nvs]-         box1   = Box Up y gb [ (nnd,v) | (nnd,(v,_)) <- vsqs ]-         afill  = fill a box1--         acom   = afill `face` (y,Up)-         fafill = app f afill-         box2   = Box Up y vy (((x,Down),fafill) : ((x,Up),vz) :-                                      [ (nnd,v) | (nnd,(_,v)) <- vsqs ])-         bcom   = com b box2-     in traceb "VEquivEq case 4" $ VPair x acom bcom-  | otherwise = error "fill EqEquiv"--fill v@(Kan Com VU tbox') box@(Box dir x' vx' nvs')-  | toAdd /= [] = -- W.l.o.g. assume that box contains faces for-    let           -- the non-principal sides of tbox.-      add :: Side -> Val  -- TODO: Is this correct? Do we have-                          -- to consider the auxsides?-      add yc = fill (lookBox yc tbox) (mapBox (`face` yc) box)-      newBox = [ (n,(add (n,Down),add (n,Up)))| n <- toAdd ] `appendBox` box-    in traceb "Kan Com 1" $ fill v newBox-  | x' `notElem` nK =-    let principal = fill tx (mapBox (pickout (x,tdir')) boxL)-        nonprincipal =-          [ let side = [((x,tdir),lookBox yc box)-                       ,((x,tdir'),principal `face` yc)]-            in (yc, fill (lookBox yc tbox)-                    (side `appendSides` mapBox (pickout yc) boxL))-          | yc <- allDirs nK ]-        newBox = Box tdir x principal nonprincipal-    in traceb ("Kan Com 2\nnewBox " ++ show newBox) VComp newBox-  | x' `elem` nK =-    let -- assumes zc in defBox tbox-      auxsides zc = [ (yd,pickout zc (lookBox yd box)) | yd <- allDirs nL ]-      -- extend input box along x with orientation tdir'; results-      -- in the non-principal faces on the intersection of defBox-      -- box and defBox tbox; note, that the intersection contains-      -- (x',dir'), but not (x',dir) (and (x,_))-      npintbox = modBox (\yc boxside -> fill (lookBox yc tbox)-                                  (Box tdir' x boxside (auxsides yc)))-                        (subBox (nK `intersect` nJ) box)-      npint = fromBox npintbox-      npintfacebox = mapBox (`face` (x,tdir')) npintbox-      principal = fill tx (auxsides (x,tdir') `appendSides` npintfacebox)-      nplp  = principal `face` (x',dir)-      nplnp = auxsides (x',dir)-              ++ map (\(yc,v) -> (yc,v `face` (x',dir))) (sides npintbox)-      -- the missing non-principal face on side (x',dir)-      nplast = ((x',dir),fill (lookBox (x',dir) tbox) (Box tdir x nplp nplnp))-      newBox = Box tdir x principal (nplast:npint)-    in traceb "Kan Com 3" $ VComp newBox-  where nK    = nonPrincipal tbox-        nJ    = nonPrincipal box-        z     = gensym $ support tbox' ++ support box-        -- x is z-        tbox@(Box tdir x tx nvs) = swap tbox' (pname tbox') z-        toAdd = nK \\ (x' : nJ)-        nL    = nJ \\ nK-        boxL  = subBox nL box-        dir'  = mirror dir-        tdir' = mirror tdir-        -- asumes zd is in the sides of tbox-        pickout zd vcomp = lookBox zd (unCompAs vcomp z)--fill v@(Kan Fill VU tbox@(Box tdir x tx nvs)) box@(Box dir x' vx' nvs')-  -- the cases should be (in order):-  -- 1) W.l.o.g. K subset x', J-  -- 2) x' = x &  dir = tdir-  -- 3) x' = x &  dir = mirror tdir-  -- 4) x `notElem` J (maybe combine with 1?)-  -- 5) x' `notElem` K-  -- 6) x' `elem` K--  | toAdd /= [] =-    let-      add :: Side -> Val-      add zc = fill (lookBox zc tbox) (mapBox (`face` zc) box)-      newBox = [ (zc,add zc) | zc <- allDirs toAdd ] `appendSides` box-    in traceb "Kan Fill VU Case 1" fill v newBox            -- W.l.o.g. nK subset x:nJ-  | x == x' && dir == tdir = -- assumes K subset x',J-    let-      boxp = lookBox (x,dir') box  -- is vx'-      principal = fill (lookBox (x',tdir') tbox) (Box Up z boxp (auxsides (x',tdir')))-      nonprincipal =-        [ (zc,-           let principzc = lookBox zc box-               sides = [((x,tdir'),principal `face` zc)-                       ,((x,tdir),principzc)] -- "degenerate" along z!-           in fill (lookBox zc tbox) (Box Up z principzc (sides ++ auxsides zc)))-        | zc <- allDirs nK ]-    in     traceb ("Kan Fill VU Case 2 v= " ++ show v ++ "\nbox= " ++ show box)-     VFill z (Box tdir x' principal nonprincipal)--  | x == x' && dir == mirror tdir = -- assumes K subset x',J-    let      -- the principal side of box must be a VComp-      upperbox = unCompAs (lookBox (x,dir') box) x-      nonprincipal =-        [ (zc,-           let top    = lookBox zc upperbox-               bottom = lookBox zc box-               princ  = top `face` (x',tdir) -- same as: bottom `face` (x',tdir)-               sides  = [((z,Down),bottom),((z,Up),top)]-           in fill (lookBox zc tbox)-                (Box tdir' x princ -- "degenerate" along z!-                 (sides ++ auxsides zc)))-        | zc <- allDirs nK ]-      nonprincipalfaces =-        map (\(zc,u) -> (zc,u `face` (x,dir))) nonprincipal-      principal =-        fill (lookBox (x,tdir') tbox) (Box Up z (lookBox (x,tdir') upperbox)-                                       (nonprincipalfaces ++ auxsides (x,tdir')))-    in    traceb "Kan Fill VU Case 3"-     VFill z (Box tdir x' principal nonprincipal)-  | x `notElem` nJ =  -- assume x /= x' and K subset x', J-    let-      comU   = v `face` (x,tdir) -- Kan Com VU (tbox (z=Up))-      xsides = [((x,tdir), fill comU (mapBox (`face` (x,tdir)) box))-               ,((x,tdir'),fill (lookBox (x,tdir') tbox)-                            (mapBox (`face` (x,tdir)) box))]-    in       traceb "Kan Fill VU Case 4"-     fill v (xsides `appendSides` box)-  | x' `notElem` nK =  -- assumes x,K subset x',J-      let-        xaux      = unCompAs (lookBox (x,tdir) box) x -- TODO: Do we need a fresh name?-        boxprinc  = unFillAs (lookBox (x',dir') box) z-        princnp   = [((z,Up),lookBox (x,tdir') xaux)-                    ,((z,Down),lookBox (x,tdir') box)]-                    ++ auxsides (x,tdir')-        principal = fill (lookBox (x,tdir') tbox) -- tx-                      (Box dir x' (lookBox (x,tdir') boxprinc) princnp)-        nonprincipal =-          [ let up = lookBox yc xaux-                np = [((z,Up),up),((z,Down),lookBox yc box)-                     ,((y,c), up `face` (x,tdir)) -- deg along z!-                     ,((y,mirror c), principal `face` yc)]-                     ++ auxsides yc-            in (yc, fill (lookBox yc tbox)-                      (Box dir x' (lookBox yc boxprinc) np))-          | yc@(y,c) <- allDirs nK]-      in     traceb "Kan Fill VU Case 5"-             VFill z (Box tdir x' principal nonprincipal)--  | x' `elem` nK =              -- assumes x,K subset x',J-      let -- surprisingly close to the last case of the Kan-Com-VU filling-        upperbox = unCompAs (lookBox (x,dir') box) x-        npintbox =-          modBox (\zc downside ->-                   let bottom = lookBox zc box-                       top    = lookBox zc upperbox-                       princ  = downside -- same as bottom `face` (x',tdir) and-                                         -- top `face` (x',tdir)-                       sides  = [((z,Down),bottom),((z,Up),top)]-                   in fill (lookBox zc tbox) (Box tdir' x princ -- deg along z!-                                              (sides ++ auxsides zc)))-                 (subBox (nK `intersect` nJ) box)-        npint = fromBox npintbox-        npintfacebox = mapBox (`face` (x,tdir)) npintbox-        principalbox = ([((z,Down),lookBox (x,tdir') box)-                       ,((z,Up)  ,lookBox (x,tdir')upperbox)] ++-                       auxsides (x,tdir')) `appendSides` npintfacebox-        principal = fill tx principalbox-        nplp   = lookBox (x',dir) upperbox-        nplnp  = [((x',dir), nplp `face` (x',dir)) -- deg along z!-                 ,((x', dir'),principal `face` (x',dir))]-                 ++ auxsides (x',dir)-                 ++ map (\(zc,u) -> (zc,u `face` (x',dir))) (sides npintbox)-        nplast = ((x',dir),fill (lookBox (x',dir) tbox) (Box Down z nplp nplnp))-      in       traceb "Kan Fill VU Case 6"-       VFill z (Box tdir x' principal (nplast:npint))--  where z     = gensym $ support v ++ support box-        nK    = nonPrincipal tbox-        nJ    = nonPrincipal box-        toAdd = nK \\ (x' : nJ)-        nL    = nJ \\ nK-        boxL  = subBox nL box-        dir'  = mirror dir-        tdir' = mirror tdir-        -- asumes zc is in the sides of tbox-        pickout zc vfill = lookBox zc (unFillAs vfill z)-        -- asumes zc is in the sides of tbox-        auxsides zc = [ (yd,pickout zc (lookBox yd box)) | yd <- allDirs nL ]--fill v b = Kan Fill v b--fills :: [(Binder,Ter)] -> Env -> [Box Val] -> [Val]-fills []         _ []          = []-fills ((x,a):as) e (box:boxes) = v : fills as (Pair e (x,v)) boxes-  where v = fill (eval e a) box-fills _ _ _ = error "fills: different lengths of types and values"---- Composition (ie., the face of fill which is created)-com :: Val -> Box Val -> Val-com vid@VId{} box@(Box dir i _ _)         = fill vid box `face` (i,dir)-com ter@Ter{} box@(Box dir i _ _)         = fill ter box `face` (i,dir)-com veq@VEquivEq{} box@(Box dir i _ _)    = fill veq box `face` (i,dir)-com u@(Kan Com VU _) box@(Box dir i _ _)  = fill u box `face` (i,dir)-com u@(Kan Fill VU _) box@(Box dir i _ _) = fill u box `face` (i,dir)-com v box                                 = Kan Com v box--appBox :: Box Val -> Box Val -> Box Val-appBox (Box dir x v nvs) (Box _ _ u nus) = Box dir x (app v u) nvus-  where nvus      = [ (nnd,app v (lookup' nnd nus)) | (nnd,v) <- nvs ]-        lookup' x = fromMaybe (error "appBox") . lookup x--app :: Val -> Val -> Val-app (Ter (Lam x t) e) u                         = eval (Pair e (x,u)) t-app (Kan Com (VPi a b) box@(Box dir x v nvs)) u =-  traceb ("Pi Com:\nufill = " ++ show ufill ++ "\nbcu = " ++ show bcu)-  com (app b ufill) (appBox box bcu)-  where ufill = fill a (Box (mirror dir) x u [])-        bcu   = cubeToBox ufill (shapeOfBox box)-app kf@(Kan Fill (VPi a b) box@(Box dir i w nws)) v =-  traceb "Pi fill" $ com (app b vfill) (Box Up x vx (((i,Down),vi0) : ((i,Up),vi1):nvs))-  where x     = gensym (support kf `union` support v)-        u     = v `face` (i,dir)-        ufill = fill a (Box (mirror dir) i u [])-        bcu   = cubeToBox ufill (shapeOfBox box)-        vfill = fill a (Box (mirror dir) i u [((x,Down),ufill),((x,Up),v)])-        vx    = fill (app b ufill) (appBox box bcu)-        vi0   = app w (vfill `face` (i,Down))-        vi1   = com (app b ufill) (appBox box bcu)-        nvs   = [ ((n,d),app ws (vfill `face` (n,d))) | ((n,d),ws) <- nws ]-app vext@(VExt x bv fv gv pv) w = com (app bv w) (Box Up y pvxw [((x,Down),left),((x,Up),right)])-  -- NB: there are various choices how to construct this-  where y     = gensym (support vext `union` support w)-        w0    = w `face` (x,Down)-        left  = app fv w0-        right = app gv (swap w x y)-        pvxw  = appName (app pv w0) x-app (Ter (Branch _ nvs) e) (VCon name us) = case lookup name nvs of-    Just (xs,t)  -> eval (upds e (zip xs us)) t-    Nothing -> error $ "app: Branch with insufficient "-               ++ "arguments; missing case for " ++ name-app r s = error $ "app"  ++ show r ++ show s+{-# LANGUAGE TupleSections, GeneralizedNewtypeDeriving #-}+module Eval ( eval+            , evals+            , app+            , conv+            , fstSVal+            , Eval+            , runEval+            ) where++import Control.Applicative+import Control.Arrow (second)+import Control.Monad+import Control.Monad.Reader+import Data.Functor.Identity+import Data.List+import Data.Maybe (fromMaybe)++import CTT++trace :: String -> Eval ()+trace s = do+  debug <- ask+  when debug $ liftIO (putStrLn s)++-- For now only store the debugging boolean+type EState = Bool++newtype Eval a = Eval { unEval :: ReaderT Bool IO a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadReader Bool)++runEval :: Bool -> Eval a -> IO a+runEval debug e = runReaderT (unEval e) debug++look :: Ident -> OEnv -> Eval (Binder, Val)+look x (OEnv (Pair rho (n@(y,l),u)) opaques)+  | x == y    = return (n, u)+  | otherwise = look x (OEnv rho opaques)+look x r@(OEnv (PDef es r1) o) = case lookupIdent x es of+  Just (y,t)  -> (y,) <$> eval r t+  Nothing     -> look x (OEnv r1 o)++eval :: OEnv -> Ter -> Eval Val+eval e U                 = return VU+eval e (PN pn)           = evalAppPN e pn []+eval e t@(App r s)       = case unApps t of+  (PN pn,us) -> evalAppPN e pn us+  _          -> appM (eval e r) (eval e s)+eval e (Var i)           = do+  (x,v) <- look i e+  return $ if x `elem` opaques e then VVar ("opaque_" ++ show x) $ support v else v+eval e (Pi a b)          = VPi <$> eval e a <*> eval e b+eval e (Lam x t)         = return $ Ter (Lam x t) e -- stop at lambdas+eval e (Sigma a b)       = VSigma <$> eval e a <*> eval e b+eval e (SPair a b)       = VSPair <$> eval e a <*> eval e b+eval e (Fst a)           = fstSVal <$> eval e a+eval e (Snd a)           = sndSVal <$> eval e a+eval e (Where t decls)   = eval (oPDef False decls e) t+eval e (Con name ts)     = VCon name <$> mapM (eval e) ts+eval e (Split pr alts)   = return $ Ter (Split pr alts) e+eval e (Sum pr ntss)     = return $ Ter (Sum pr ntss) e++evals :: OEnv -> [(Binder,Ter)] -> Eval [(Binder,Val)]+evals env = sequenceSnd . map (second (eval env))++fstSVal, sndSVal :: Val -> Val+fstSVal (VSPair a b)    = a+fstSVal u | isNeutral u = VFst u+          | otherwise   = error $ show u ++ " should be neutral"+sndSVal (VSPair a b)    = b+sndSVal u | isNeutral u = VSnd u+          | otherwise   = error $ show u ++ " should be neutral"++-- Application+app :: Val -> Val -> Eval Val+app (Ter (Lam x t) e) u                         = eval (oPair e (x,u)) t+app (Kan Com (VPi a b) box@(Box dir x v nvs)) u = do+  trace "Pi Com"+  ufill <- fill a (Box (mirror dir) x u [])+  bcu   <- cubeToBox ufill (shapeOfBox box)+  comM (app b ufill) (appBox box bcu)+app kf@(Kan Fill (VPi a b) box@(Box dir i w nws)) v = do+  trace "Pi fill"+  let x = fresh (kf, v)+  u     <- v `face` (i,dir)+  ufill <- fill a (Box (mirror dir) i u [])+  bcu   <- cubeToBox ufill (shapeOfBox box)+  vfill <- fill a (Box (mirror dir) i u [((x,down),ufill),((x,up),v)])+  vx    <- fillM (app b ufill) (appBox box bcu)+  vi0   <- appM (return w) (vfill `face` (i,mirror dir))+  vi1   <- comM (app b ufill) (appBox box bcu)+  nvs   <- sequenceSnd [ ((n,d),appM (return ws) (vfill `face` (n,d)))+                       | ((n,d),ws) <- nws ]+  comM (app b vfill) (return (Box up x vx (((i,mirror dir),vi0) : ((i,dir),vi1):nvs)))+-- app vext@(VExt x bv fv gv pv) w = do+--   -- NB: there are various choices how to construct this+--   let y = fresh (vext, w)+--   w0    <- w `face` (x,down)+--   left  <- app fv w0+--   right <- app gv (swap w x y)+--   pvxw  <- appNameM (app pv w0) x+--   comM (app bv w) (return (Box up y pvxw [((x,down),left),((x,up),right)]))+app vhext@(VHExt x bv fv gv pv) w = do+  a0    <- w `face` (x,down)+  a1    <- w `face` (x,up)+  appNameM (apps pv [a0, a1, Path x w]) x+app (Ter (Split _ nvs) e) (VCon name us) = case lookup name nvs of+    Just (xs,t)  -> eval (upds e (zip xs us)) t+    Nothing -> error $ "app: Split with insufficient arguments; " +++                        "missing case for " ++ name+app u@(Ter (Split _ _) _) v+  | isNeutral v = return $ VSplit u v -- v should be neutral+  | otherwise   = error $ "app: (VSplit) " ++ show v ++ " is not neutral"+app r s+  | isNeutral r = return $ VApp r s -- r should be neutral+  | otherwise   = error $ "app: (VApp) " ++ show r ++ " is not neutral"++-- Monadic version of app+appM :: Eval Val -> Eval Val -> Eval Val+appM t1 t2 = do+  u <- t1+  v <- t2+  app u v++apps :: Val -> [Val] -> Eval Val+apps = foldM app++appBox :: Box Val -> Box Val -> Eval (Box Val)+appBox (Box dir x v nvs) (Box _ _ u nus) = do+  let lookup' x = fromMaybe (error "appBox") . lookup x+  sequenceBox $ Box dir x (app v u) [ (nnd,app v (lookup' nnd nus))+                                    | (nnd,v) <- nvs ]++appName :: Val -> Name -> Eval Val+appName (Path x u) y | y `elem` [0,1] = u `face` (x,y)+appName p y          | y `elem` [0,1] = return $ VAppName p y+                                        -- p has to be neutral+appName (Path x u) y | x == y             = return u+                     | y `elem` support u = error ("appName " ++ "\nu = " +++                                                   show u ++ "\ny = " ++ show y)+                     | otherwise          = return $ swap u x y+appName v y          = return $ VAppName v y++appNameM :: Eval Val -> Name -> Eval Val+appNameM v n = do+  v' <- v+  appName v' n++-- Apply a primitive notion+evalAppPN :: OEnv -> PN -> [Ter] -> Eval Val+evalAppPN e pn ts+  | length ts < arity pn =+      -- Eta expand primitive notions+      let r       = arity pn - length ts+          binders = map (\n -> '_' : show n) [1..r]+          vars    = map Var binders+      in return $ Ter (mkLams binders $ mkApps (PN pn) (ts ++ vars)) e+  | otherwise = do+      let (args,rest) = splitAt (arity pn) ts+      vas <- mapM (eval e) args+      p   <- evalPN (freshs e) pn vas+      r   <- mapM (eval e) rest+      apps p r++-- Evaluate primitive notions+evalPN :: [Name] -> PN -> [Val] -> Eval Val+evalPN (x:_) Id            [a,a0,a1]     = return $ VId (Path x a) a0 a1+evalPN (x:_) IdP           [_,_,p,a0,a1] = return $ VId p a0 a1+evalPN (x:_) Refl          [_,a]         = return $ Path x a+evalPN (x:_) TransU        [_,_,p,t]     =+  comM (appName p x) (return (Box up x t []))+evalPN (x:_) TransInvU     [_,_,p,t]     =+  comM (appName p x) (return (Box down x t []))+evalPN (x:_) TransURef     [a,t]         = Path x <$> fill a (Box up x t [])+evalPN (x:_) TransUEquivEq [_,b,f,_,_,u] = do+  fu <- app f u+  Path x <$> fill b (Box up x fu [])   -- TODO: Check this!+evalPN (x:y:_) CSingl [a,u,v,p] = do+  pv    <- appName p y+  theta <- fill a (Box up y u [((x,down),u),((x,up),pv)])+  omega <- theta `face` (y,up)+  return $ Path x (VSPair omega (Path y theta))+-- evalPN (x:_)   Ext        [_,b,f,g,p]   = return $ Path x $ VExt x b f g p+evalPN (x:_)   HExt       [_,b,f,g,p]   = return $ Path x $ VHExt x b f g p+evalPN _       Inh        [a]           = return $ VInh a+evalPN _       Inc        [_,t]         = return $ VInc t+evalPN (x:_)   Squash     [_,r,s]       = return $ Path x $ VSquash x r s+evalPN _       InhRec     [_,b,p,phi,a] = inhrec b p phi a+evalPN (x:_)   EquivEq    [a,b,f,s,t]   = return $ Path x $ VEquivEq x a b f s t+evalPN (x:y:_) EquivEqRef [a,s,t]       =+  return $ Path y $ Path x $ VEquivSquare x y a s t+evalPN (x:_)   MapOnPath  [_,_,f,_,_,p]    =+  Path x <$> appM (return f) (appName p x)+evalPN (x:_)   MapOnPathD [_,_,f,_,_,p]    =+  Path x <$> appM (return f) (appName p x)+evalPN (x:_)   AppOnPath [_,_,_,_,_,_,p,q] =+  Path x <$> appM (appName p x) (appName q x)+evalPN (x:_)   MapOnPathS [_,_,_,f,_,_,p,_,_,q] =+  Path x <$> appM (appM (pure f) (appName p x)) (appName q x)+evalPN _       Circle     []               = return VCircle+evalPN _       Base       []               = return VBase+evalPN (x:_)   Loop       []               = return $ Path x $ VLoop x+evalPN _       CircleRec  [f,b,l,s]        = circlerec f b l s+evalPN _       I          []               = return VI+evalPN _       I0         []               = return VI0+evalPN _       I1         []               = return VI1+evalPN (x:_)   Line       []               = return $ Path x $ VLine x+evalPN _       IntRec     [f,s,e,l,u]      = intrec f s e l u+evalPN _       u          _                = error ("evalPN " ++ show u)+++appS1 :: Val -> Val -> Name -> Eval Val+appS1 f p x | x `elem` [0,1] = appName p x+appS1 f p x = do+  let y = fresh (p,(f,x))+  q <- appName p y+  a <- appName p 0+  b <- appName p 1+  newBox <- Box down y b <$>+            sequenceSnd  [ ((x,down),q `face` (x,down))+                         , ((x,up),b `face` (x,up))]+  fb <- app f VBase+  fl <- app f (VLoop y)+  tu <- fillM (return VU) (Box down y fb <$>+                           sequenceSnd [ ((x,down),fl `face` (x,down))+                                       , ((x,up),fb `face` (x,up))])+  com tu newBox++-- Compute the face of an environment+faceEnv :: OEnv -> Side -> Eval OEnv+faceEnv e xd = mapOEnvM (`face` xd) e++faceName :: Name -> Side -> Name+faceName 0 _                 = 0+faceName 1 _                 = 1+faceName x (y,d) | x == y    = d+                 | otherwise = x++-- Compute the face of a value+face :: Val -> Side -> Eval Val+face u xdir@(x,dir) =+  let fc v = v `face` xdir in case u of+  VU          -> return VU+  Ter t e -> do e' <- e `faceEnv` xdir+                eval e' t+  VId a v0 v1 -> VId <$> fc a <*> fc v0 <*> fc v1+  Path y v | x == y    -> return u+           | otherwise -> Path y <$> fc v+  -- VExt y b f g p | x == y && dir == down -> return f+  --                | x == y && dir == up   -> return g+  --                | otherwise             ->+  --                  VExt y <$> fc b <*> fc f <*> fc g <*> fc p+  VHExt y b f g p | x == y && dir == down -> return f+                  | x == y && dir == up   -> return g+                  | otherwise             ->+                    VHExt y <$> fc b <*> fc f <*> fc g <*> fc p+  VPi a f    -> VPi <$> fc a <*> fc f+  VSigma a f -> VSigma <$> fc a <*> fc f+  VSPair a b -> VSPair <$> fc a <*> fc b+  VInh v     -> VInh <$> fc v+  VInc v     -> VInc <$> fc v+  VSquash y v0 v1 | x == y && dir == down -> return v0+                  | x == y && dir == up   -> return v1+                  | otherwise             -> VSquash y <$> fc v0 <*> fc v1+  VCon c us -> VCon c <$> mapM fc us+  VEquivEq y a b f s t | x == y && dir == down -> return a+                       | x == y && dir == up   -> return b+                       | otherwise             ->+                         VEquivEq y <$> fc a <*> fc b <*> fc f <*> fc s <*> fc t+  VPair y a v | x == y && dir == down -> return a+              | x == y && dir == up   -> fc v+              | otherwise             -> VPair y <$> fc a <*> fc v+  VEquivSquare y z a s t | x == y                -> return a+                         | x == z && dir == down -> return a+                         | x == z && dir == up   -> do+                           let idV = Ter (Lam (noLoc "x") (Var "x")) oEmpty+                           return $ VEquivEq y a a idV s t+                         | otherwise             ->+                          VEquivSquare y z <$> fc a <*> fc s <*> fc t+  VSquare y z v | x == y                -> fc v+                | x == z && dir == down -> fc v+                | x == z && dir == up   -> do+                  v' <- fc v+                  VPair y <$> v' `face` (y,down) <*> pure v'+                | otherwise             -> VSquare y z <$> fc v+  Kan Fill a b@(Box dir' y v nvs)+    | x /= y && x `notElem` nonPrincipal b -> fillM (fc a) (mapBoxM fc b)+    | x `elem` nonPrincipal b              -> return $ lookBox (x,dir) b+    | x == y && dir == mirror dir'         -> return v+    | otherwise                            -> com a b+  VFillN a b@(Box dir' y v nvs)+    | x /= y && x `notElem` nonPrincipal b -> fillM (fc a) (mapBoxM fc b)+    | x `elem` nonPrincipal b              -> return $ lookBox (x,dir) b+    | x == y && dir == mirror dir'         -> return v+    | otherwise                            -> com a b+  Kan Com a b@(Box dir' y v nvs)+    | x == y                     -> return u+    | x `notElem` nonPrincipal b -> comM (fc a) (mapBoxM fc b)+    | x `elem` nonPrincipal b    -> lookBox (x,dir) b `face` (y,dir')+  VComN a b@(Box dir' y v nvs)+    | x == y                     -> return u+    | x `notElem` nonPrincipal b -> comM (fc a) (mapBoxM fc b)+    | x `elem` nonPrincipal b    -> lookBox (x,dir) b `face` (y,dir')+  VComp b@(Box dir' y _ _)+    | x == y                     -> return u+    | x `notElem` nonPrincipal b -> VComp <$> mapBoxM fc b+    | x `elem` nonPrincipal b    -> lookBox (x,dir) b `face` (y,dir')+  VFill z b@(Box dir' y v nvs)+    | x == z                               -> return u+    | x /= y && x `notElem` nonPrincipal b -> VFill z <$> mapBoxM fc b+    | (x,dir) `elem` defBox b              ->+      lookBox (x,dir) <$> mapBoxM (`face` (z,down)) b+    | x == y && dir == dir'                ->+        VComp <$> mapBoxM (`face` (z,up)) b+  VInhRec b p h a     -> join $ inhrec <$> fc b <*> fc p <*> fc h <*> fc a+  VApp u v            -> appM (fc u) (fc v)+  VAppName u n        -> do+   trace ("face " ++ "\nxdir " ++ show xdir +++          "\nu " ++ show u ++ "\nn " ++ show n)+   appNameM (fc u) (faceName n xdir)+  VSplit u v          -> appM (fc u) (fc v)+  VVar s d            -> return $ VVar s [ faceName n xdir | n <- d ]+  VFst p              -> fstSVal <$> fc p+  VSnd p              -> sndSVal <$> fc p+  VCircle             -> return VCircle+  VBase               -> return VBase+  VLoop y | x == y    -> return VBase+          | otherwise -> return $ VLoop y+  VCircleRec f b l s  -> join $ circlerec <$> fc f <*> fc b <*> fc l <*> fc s+  VI  -> return VI+  VI0 -> return VI0+  VI1 -> return VI1+  VLine y+    | x == y && dir == down -> return VI0+    | x == y && dir == up   -> return VI1+    | otherwise             -> return $ VLine y+  VIntRec f s e l u -> join $ intrec <$> fc f <*> fc s <*> fc e <*> fc l <*> fc u++faceM :: Eval Val -> Side -> Eval Val+faceM t xdir = do+  v <- t+  v `face` xdir++unCompAs :: Val -> Name -> Box Val+unCompAs (VComp box) y = swap box (pname box) y+unCompAs v           _ = error $ "unCompAs: " ++ show v ++ " is not a VComp"++unFillAs :: Val -> Name -> Box Val+unFillAs (VFill x box) y = swap box x y+unFillAs v             _ = error $ "unFillAs: " ++ show v ++ " is not a VFill"++-- p(x) = <z>q(x,z)+-- a(x) = q(x,0)     b(x) = q(x,1)+-- q(0,y) connects a(0) and b(0)+-- we connect q(0,0) to q(1,1)+-- appDiag :: Val -> Val -> Name -> Val+-- appDiag tu p x | x `elem` [0,1] = appName p x+-- appDiag tu p x =+-- traceb ("appDiag " ++ "\ntu = " ++ show tu ++ "\np = " ++ show p ++ "\nx = "+-- --                       ++ show x ++ " " ++ show y+-- --                       ++ "\nq = " ++ show q) -- "\nnewBox =" ++ show newBox)+--  com tu newBox+--    where y = fresh (p,(tu,x))+--          q = appName p y+--          a = appName p 0+--          b = appName p 1+--          newBox = Box down y b [((x,down),q `face` (x,down)),((x,up),b `face` (x,up))]++cubeToBox :: Val -> Box () -> Eval (Box Val)+cubeToBox v = modBoxM (\nd _ -> v `face` nd)++inhrec :: Val -> Val -> Val -> Val -> Eval Val+inhrec _ _ phi (VInc a)          = app phi a+inhrec b p phi (VSquash x a0 a1) = do+  let fc w d = w `face` (x,d)+  b0 <- join $ inhrec <$> fc b down <*> fc p down <*> fc phi down <*> pure a0+  b1 <- join $ inhrec <$> fc b up   <*> fc p up   <*> fc phi up   <*> pure a1+  let z = fresh [b,p,phi,b0,b1]+  b0fill   <- fill b (Box up x b0 [])+  b0fillx1 <- b0fill `face` (x, up)+  right    <- appNameM (appM (appM (fc p up) (return b0fillx1)) (return b1)) z+  com b (Box up z b0fill [((x,down),b0),((x,up),right)])+inhrec b p phi (Kan ktype (VInh a) box) = do+  let irec (j,dir) v = let fc v = v `face` (j,dir)+                       in join $ inhrec <$> fc b <*> fc p <*> fc phi <*> pure v+  box' <- modBoxM irec box+  kan ktype b box'+inhrec b p phi v = return $ VInhRec b p phi v -- v should be neutral++circlerec :: Val -> Val -> Val -> Val -> Eval Val+circlerec _ b _ VBase       = return b+circlerec f b l v@(VLoop x) = do+  let y = fresh [f,b,l,v]+  pxy   <- appName l y+  theta <- connection VCircle x y v+  a     <- app f theta+  px1   <- pxy `face` (y,up)+  p11   <- px1 `face` (x,up)+  p0y   <- pxy `face` (x,down)+  trace ("circlerec " ++ "\nf = " ++ show f ++ "\nl = " +++         show l ++ "\nx = " ++ show x)+  com a (Box down y px1 [((x,down),p0y),((x,up),p11)])+circlerec f b l v@(Kan ktype VCircle box) = do+  let crec side u = let fc w = w `face` side+                    in join $ circlerec <$> fc f <*> fc b <*> fc l <*> pure u+  fv   <- app f v+  box' <- modBoxM crec box+  kan ktype fv box'+circlerec f b l v = return $ VCircleRec f b l v -- v should be neutral++-- Assumes y is fresh and x fresh for a; constructs a connection+-- square with faces u (x), u (y), u (1), u (1).+connection :: Val -> Name -> Name -> Val -> Eval Val+connection a x y u = do+  u1    <- u `face` (x,up)+  ufill <- fill a (Box down y u1 [((x,down), swap u x y), ((x,up),u1)])+  let z       = fresh ([x,y], [a,u])+      ufillzy = swap ufill x z+      ufillzx = swap ufillzy y x+  com a (Box down z u1 [ ((x,down),ufillzy), ((x,up),u1)+                       , ((y,down),ufillzx), ((y,up),u1)])++intrec :: Val -> Val -> Val -> Val -> Val -> Eval Val+intrec _ s _ _ VI0         = return s+intrec _ _ e _ VI1         = return e+intrec f s e l v@(VLine x) = do+  let y = fresh [f,s,e,l,v]+  pxy   <- appName l y+  theta <- connection VI x y v+  a     <- app f theta+  px1   <- pxy `face` (y,up)+  p11   <- px1 `face` (x,up)+  p0y   <- pxy `face` (x,down)+  com a (Box down y px1 [((x,down),p0y),((x,up),p11)])+intrec f s e l v@(Kan ktype VCircle box) = do+  let irec side u = let fc w = w `face` side+                    in join $ intrec <$> fc f <*> fc s <*>+                                         fc e <*> fc l <*> pure u+  fv   <- app f v+  box' <- modBoxM irec box+  kan ktype fv box'+intrec f s e l v = return $ VIntRec f s e l v -- v should be neutral++kan :: KanType -> Val -> Box Val -> Eval Val+kan Fill = fill+kan Com  = com++isNeutralFill :: Val -> Box Val -> Eval Bool+isNeutralFill v box | isNeutral v               = return True+isNeutralFill v@(Ter (PN (Undef _)) _) box      = return True+isNeutralFill (Ter (Sum _ _) _) (Box _ _ v nvs) =+ return $ isNeutral v || or [ isNeutral u | (_,u) <- nvs ]+isNeutralFill v@(Kan Com VU tbox') box@(Box d x _ _) = do+  let nK  = nonPrincipal tbox'+      nJ  = nonPrincipal box+      nL  = nJ \\ nK+      aDs = if x `elem` nK then allDirs nL else (x,mirror d):allDirs nL+  return $ or [ isNeutral (lookBox yc box) | yc <- aDs ]+isNeutralFill v@(Kan Fill VU tbox) box =+  return $ or [ isNeutral (lookBox yc box) | yc <- defBox box \\ defBox tbox ]+isNeutralFill v@(VEquivSquare y z _ _ _) box@(Box d x _ _) = do+  let nJ  = nonPrincipal box+      nL  = nJ \\ [y,z]+      aDs = if x `elem` [y,z] then allDirs nL else (x,mirror d) : allDirs nL+  return $ or [ isNeutral (lookBox yc box) | yc <- aDs ]+isNeutralFill v@(VEquivEq z a b f s t) box@(Box d x vx nxs)+  | d == down && z == x = isNeutral <$> app s vx+  | otherwise           = do -- TODO: check+    let nJ  = nonPrincipal box+        nL  = nJ \\ [z]+        aDs = if x == z then allDirs nL else (x,mirror d) : allDirs nL+    return $ or [ isNeutral (lookBox yc box) | yc <- aDs ]+isNeutralFill v box = return False++-- Monadic version of fill+fillM :: Eval Val -> Eval (Box Val) -> Eval Val+fillM v b = do+  v' <- v+  b' <- b+  fill v' b'++fills :: [(Binder,Ter)] -> OEnv -> [Box Val] -> Eval [Val]+fills []         _ []          = return []+fills ((x,a):as) e (box:boxes) = do+  v  <- fillM (eval e a) (return box)+  vs <- fills as (oPair e (x,v)) boxes+  return $ v : vs+fills _ _ _ = error "fills: different lengths of types and values"++unPack :: Name -> Name -> (Name,Dir) -> Val -> Val+unPack x y (z,c) v | z /= x && z /= y  = unSquare v+                   | z == y && c == up = sndVal v+                   | otherwise         = v++-- Kan filling+fill :: Val -> Box Val -> Eval Val+fill v box = do+  b <- isNeutralFill v box+  if b then return $ VFillN v box else fill' v box+fill' vid@(VId a v0 v1) box@(Box dir i v nvs) = do+  let x = fresh (vid, box)+  box' <- consBox (x,(v0,v1)) <$> mapBoxM (`appName` x) box+  Path x <$> fillM (a `appName` x) (return box')+fill' (VSigma a f) box@(Box dir x v nvs) = do+  u <- fill a (mapBox fstSVal box)+  VSPair u <$> fillM (app f u) (return (mapBox sndSVal box))+-- assumes cvs are constructor vals+fill' v@(Ter (Sum _ nass) env) box@(Box _ _ (VCon n _) _) = case getIdent n nass of+  Just as -> do+    let boxes = transposeBox $ mapBox unCon box+    -- fill boxes for each argument position of the constructor+    VCon n <$> fills as env boxes+  Nothing -> error $ "fill: missing constructor in labelled sum " ++ n+fill' (VEquivSquare x y a s t) box@(Box dir x' vx' nvs) =+  VSquare x y <$> fill a (modBox (unPack x y) box)+fill' veq@(VEquivEq x a b f s t) box@(Box dir z vz nvs)+  | x /= z && x `notElem` nonPrincipal box = do+    trace "VEquivEq case 1"+    ax0 <- fill a (mapBox fstVal box)+    bx0 <- app f ax0+    let bx = mapBox sndVal box+    bx' <- mapBoxM (`face` (x,up)) bx+    bx1 <- fill b bx'        --- independent of x+    v   <- fill b $ (x,(bx0,bx1)) `consBox` bx+    return $ VPair x ax0 v+  | x /= z && x `elem` nonPrincipal box = do+    trace "VEquivEq case 2"+    let ax0 = lookBox (x,down) box++        -- modification function+        mf (ny,dy) vy | x /= ny    = return (sndVal vy)+                      | dy == down = app f ax0+                      | otherwise  = return vy++    bx  <- sequenceBox $ modBox mf box+    VPair x ax0 <$> fill b bx+  | x == z && dir == up = do+    trace "VEquivEq case 3"+    let ax0 = vz+    bx0 <- app f ax0+    v   <- fill b $ Box dir z bx0 [ (nnd,sndVal v) | (nnd,v) <- nvs ]+    return $ VPair x ax0 v+  | x == z && dir == down = do+    trace "VEquivEq case 4"+    gbsb <- app s vz+    let (gb,sb) = (fstSVal gbsb, sndSVal gbsb)+        y       = fresh (veq, box)+    vy <- appName sb x++    let vpTSq :: Name -> Dir -> Val -> Eval (Val,Val)+        vpTSq nz dz (VPair z a0 v0) = do+          let vp = VSPair a0 (Path z v0)+          t0 <- t `face` (nz,dz)+          b0 <- vz `face` (nz,dz)+          l0sq0 <- appNameM (appM (app t0 b0) (return vp)) y+          let (l0,sq0) = (fstSVal l0sq0, sndSVal l0sq0)+          sq0x <- appName sq0 x+          return (l0,sq0x)  -- TODO: check the correctness of the square s0++    -- TODO: Use modBox!+    vsqs <- sequenceSnd [ ((n,d),vpTSq n d v) | ((n,d),v) <- nvs]+    let box1   = Box up y gb [ (nnd,v) | (nnd,(v,_)) <- vsqs ]+    afill <- fill a box1++    acom <- afill `face` (y,up)+    fafill <- app f afill++    let box2 = Box up y vy (((x,down),fafill) : ((x,up),vz) :+                            [ (nnd,v) | (nnd,(_,v)) <- vsqs ])+    bcom <- com b box2+    return $ VPair x acom bcom+  | otherwise = error "fill EqEquiv"+fill' v@(Kan Com VU tbox') box@(Box dir x' vx' nvs')+  | toAdd /= [] = do  -- W.l.o.g. assume that box contains faces for+                      -- the non-principal sides of tbox.++    trace "Kan Com 1"++    let -- TODO: Is this correct? Do we have to consider the auxsides?+        add :: Side -> Eval Val+        add yc = do box' <- mapBoxM (`face` yc) box+                    fillM (lookBox yc tbox `face` (x,tdir)) (return box')++    -- Note: This could be done nicer by providing a monad instance for (,)+    sides' <- sequence [ do m1 <- add (n,down)+                            m2 <- add (n,up)+                            return (n,(m1,m2)) | n <- toAdd ]++    fill v (sides' `appendBox` box)+  | x' `notElem` nK = do+    trace "Kan Com 2"++    principal <- fill tx (mapBox (pickout (x,tdir')) boxL)+    nonprincipal <-+      sequence [ do pyc <- principal `face` yc+                    let side = [((x,tdir),lookBox yc box),((x,tdir'),pyc)]+                    v' <- fill (lookBox yc tbox)+                               (side `appendSides` mapBox (pickout yc) boxL)+                    return (yc,v')+               | yc <- allDirs nK ]++    return $ VComp (Box tdir x principal nonprincipal)+  | x' `elem` nK = do+    trace "Kan Com 3"++    let -- assumes zc in defBox tbox+        auxsides zc = [ (yd,pickout zc (lookBox yd box)) | yd <- allDirs nL ]++    -- extend input box along x with orientation tdir'; results+    -- in the non-principal faces on the intersection of defBox+    -- box and defBox tbox; note, that the intersection contains+    -- (x',dir'), but not (x',dir) (and (x,_))+    npintbox <- modBoxM (\yc boxside -> fill (lookBox yc tbox)+                                             (Box tdir' x boxside (auxsides yc)))+                        (subBox (nK `intersect` nJ) box)++    npintfacebox <- mapBoxM (`face` (x,tdir')) npintbox+    principal    <- fill tx (auxsides (x,tdir') `appendSides` npintfacebox)+    nplp         <- principal `face` (x',dir)+    fnpintboxs   <- sequence [ do fv <- v `face` (x',dir)+                                  return (yc,fv)+                             | (yc,v) <- sides npintbox ]++    let nplnp = auxsides (x',dir) ++ fnpintboxs+    -- the missing non-principal face on side (x',dir)+    v' <- fill (lookBox (x',dir) tbox) (Box tdir x nplp nplnp)+    let nplast = ((x',dir),v')++    return $ VComp (Box tdir x principal (nplast:fromBox npintbox))+  where nK    = nonPrincipal tbox+        nJ    = nonPrincipal box+        z     = fresh (tbox', box)+        -- x is z+        tbox@(Box tdir x tx nvs) = swap tbox' (pname tbox') z+        toAdd = nK \\ (x' : nJ)+        nL    = nJ \\ nK+        boxL  = subBox nL box+        dir'  = mirror dir+        tdir' = mirror tdir+        -- asumes zd is in the sides of tbox+        pickout zd vcomp = lookBox zd (unCompAs vcomp z)++fill' v@(Kan Fill VU tbox@(Box tdir x tx nvs)) box@(Box dir x' vx' nvs')+  -- the cases should be (in order):+  -- 1) W.l.o.g. K subset x', J+  -- 2) x' = x &  dir = tdir+  -- 3) x' = x &  dir = mirror tdir+  -- 4) x `notElem` J (maybe combine with 1?)+  -- 5) x' `notElem` K+  -- 6) x' `elem` K+  | toAdd /= [] = do+    trace "Kan Fill VU Case 1"  -- W.l.o.g. nK subset x':nJ+    let add :: Side -> Eval Val+        add zc = fillM (return (lookBox zc tbox)) (mapBoxM (`face` zc) box)+    newSides <- sequenceSnd [ (zc,add zc) | zc <- allDirs toAdd ]+    fill v (newSides `appendSides` box)+  | x == x' && dir == tdir = do -- assumes K subset x',J+    trace "Kan Fill VU Case 2"+    let boxp = lookBox (x,dir') box  -- is vx'+    principal <- fill (lookBox (x',tdir') tbox)+                      (Box up z boxp (auxsides (x',tdir')))+    nonprincipal <-+      sequenceSnd [ (zc,do let principzc = lookBox zc box+                           fpzc <- principal `face` zc+                           -- "degenerate" along z!+                           ppzc <- principzc `face` (x,tdir)+                           let sides = [((x,tdir'),fpzc),((x,tdir),ppzc)]+                           fill (lookBox zc tbox)+                                (Box up z principzc (sides ++ auxsides zc)))+                  | zc <- allDirs nK ]+    return $ VFill z (Box tdir x principal nonprincipal)++  | x == x' && dir == mirror tdir = do -- assumes K subset x',J+    trace "Kan Fill VU Case 3"+    let -- the principal side of box must be a VComp+        -- should be safe given the neutral test at the beginning+        upperbox = unCompAs (lookBox (x,dir') box) x+    nonprincipal <- sequenceSnd+      [ (zc,do let top    = lookBox zc upperbox+                   bottom = lookBox zc box+               princ <- top `face` (x,tdir) -- same as: bottom `face` (x,tdir)+               let sides  = [((z,down),bottom),((z,up),top)]+               fill (lookBox zc tbox) (Box tdir' x princ -- "degenerate" along z!+                                       (sides ++ auxsides zc)))+      | zc <- allDirs nK ]+    nonprincipalfaces <- sequenceSnd [ (zc,u `face` (x,dir))+                                     | (zc,u) <- nonprincipal ]+    principal <- fill (lookBox (x,tdir') tbox)+                      (Box up z (lookBox (x,tdir') upperbox)+                       (nonprincipalfaces ++ auxsides (x,tdir')))+    return $ VFill z (Box tdir x principal nonprincipal)+  | x `notElem` nJ = do  -- assume x /= x' and K subset x', J+    trace "Kan Fill VU Case 4"+    comU <- v `face` (x,tdir) -- Kan Com VU (tbox (z=up))+    let fcbox = mapBoxM (`face` (x,tdir)) box+    xsides <- sequenceSnd [ ((x,tdir), fillM (return comU) fcbox)+                          , ((x,tdir'),+                             fillM (return (lookBox (x,tdir') tbox)) fcbox) ]++    fill v (xsides `appendSides` box)+  | x' `notElem` nK = do -- assumes x,K subset x',J+    trace "Kan Fill VU Case 5"+    let -- TODO: Do we need a fresh name? (Probably not: doesn't depend on x!)+        xaux      = unCompAs (lookBox (x,tdir) box) x+        boxprinc  = unFillAs (lookBox (x',dir') box) z+        princnp   = [((z,up),lookBox (x,tdir') xaux),((z,down),lookBox (x,tdir') box)]+                    ++ auxsides (x,tdir')+    principal <- fill (lookBox (x,tdir') tbox) -- tx+                      (Box dir x' (lookBox (x,tdir') boxprinc) princnp)+    nonprincipal <- sequence+      [ do let yup = lookBox yc xaux+           fyup <- yup `face` (x,tdir)+           fpyc <- principal `face` yc+           let np  = [ ((z,up),yup), ((z,down),lookBox yc box)+                     , ((y,c), fyup) -- deg along z!+                     , ((y,mirror c), fpyc) ] ++ auxsides yc+           fb <- fill (lookBox yc tbox) (Box dir x' (lookBox yc boxprinc) np)+           return (yc, fb)+      | yc@(y,c) <- allDirs nK]+    return $ VFill z (Box tdir x principal nonprincipal)+  | x' `elem` nK = do -- assumes x,K subset x',J+    trace "Kan Fill VU Case 6"+    -- surprisingly close to the last case of the Kan-Com-VU filling+    let upperbox = unCompAs (lookBox (x,dir') box) x+    npintbox <- modBoxM (\zc downside ->+                     let bottom = lookBox zc box+                         top    = lookBox zc upperbox+                         princ  = downside -- same as bottom `face` (x',tdir) and+                                           -- top `face` (x',tdir)+                         sides  = [((z,down),bottom),((z,up),top)]+                     in fill (lookBox zc tbox) (Box tdir' x princ -- deg along z!+                                                (sides ++ auxsides zc)))+                        (subBox (nK `intersect` nJ) box)++    let npint = fromBox npintbox+    npintfacebox <- mapBoxM (`face` (x,tdir)) npintbox+    let principalbox = ([ ((z,down),lookBox (x,tdir') box)+                        , ((z,up)  ,lookBox (x,tdir') upperbox)]+                        ++ auxsides (x,tdir'))+                       `appendSides` npintfacebox+    principal <- fill tx principalbox+    let nplp = lookBox (x',dir) upperbox+    nplnp <- sequenceSnd $+     [ ((x',dir), nplp `face` (x',dir)) -- deg along z!+     , ((x', dir'),principal `face` (x',dir)) ]+     ++  map (second return) (auxsides (x',dir))+      ++ [ (zc,u `face` (x',dir)) | (zc,u) <- sides npintbox ]+    fb <- fill (lookBox (x',dir) tbox) (Box down z nplp nplnp)++    return $ VFill z (Box tdir x principal (((x',dir),fb) : npint))+    where z     = fresh (v, box)+          nK    = nonPrincipal tbox+          nJ    = nonPrincipal box+          toAdd = nK \\ (x' : nJ)+          nL    = nJ \\ (x : nK)+          dir'  = mirror dir+          tdir' = mirror tdir+          -- asumes zc is in the sides of tbox+          pickout zc vfill = lookBox zc (unFillAs vfill z)+          -- asumes zc is in the sides of tbox+          auxsides zc = [ (yd,pickout zc (lookBox yd box)) | yd <- allDirs nL ]+fill' v b = return $ Kan Fill v b++-- Composition (ie., the face of fill which is created)+com :: Val -> Box Val -> Eval Val+com u box = do+  b <- isNeutralFill u box+  if b then return $ VComN u box else com' u box+com' vid@VId{} box@(Box dir i _ _)         = fill vid box `faceM` (i,dir)+com' vsigma@VSigma{} box@(Box dir i _ _)   = fill vsigma box `faceM` (i,dir)+com' veq@VEquivEq{} box@(Box dir i _ _)    = fill veq box `faceM` (i,dir)+com' u@(Kan Com VU _) box@(Box dir i _ _)  = fill u box `faceM` (i,dir)+com' u@(Kan Fill VU _) box@(Box dir i _ _) = fill u box `faceM` (i,dir)+com' ter@Ter{} box@(Box dir i _ _)         = fill ter box `faceM` (i,dir)+com' v box                                 = return $ Kan Com v box++-- Monadic version of com+comM :: Eval Val -> Eval (Box Val) -> Eval Val+comM t b = do+  v  <- t+  b' <- b+  com v b'++-- Conversion functions+(<&&>) :: Monad m => m Bool -> m Bool -> m Bool+(<&&>) = liftM2 (&&)++(<==>) :: (Monad m, Eq a) => a -> a -> m Bool+a <==> b = return (a == b)++andM :: [Eval Bool] -> Eval Bool+andM = liftM and . sequence++conv :: Int -> Val -> Val -> Eval Bool+conv k VU VU                                  = return True+conv k (Ter (Lam x u) e) (Ter (Lam x' u') e') = do+  let v = mkVar k $ support (e, e')+  convM (k+1) (eval (oPair e (x,v)) u) (eval (oPair e' (x',v)) u')+conv k (Ter (Lam x u) e) u' = do+  let v = mkVar k $ support e+  convM (k+1) (eval (oPair e (x,v)) u) (app u' v)+conv k u' (Ter (Lam x u) e) = do+  let v = mkVar k $ support e+  convM (k+1) (app u' v) (eval (oPair e (x,v)) u)+conv k (Ter (Split p _) e) (Ter (Split p' _) e') =+  liftM ((p == p') &&) $ convEnv k e e'+conv k (Ter (Sum p _) e)   (Ter (Sum p' _) e') =+  ((p == p') &&) <$> convEnv k e e'+conv k (Ter (PN (Undef p)) e) (Ter (PN (Undef p')) e') =+  liftM ((p == p') &&) $ convEnv k e e'+conv k (VPi u v) (VPi u' v') = do+  let w = mkVar k $ support [u,u',v,v']+  conv k u u' <&&> convM (k+1) (app v w) (app v' w)+conv k (VSigma u v) (VSigma u' v') = do+  let w = mkVar k $ support [u,u',v,v']+  conv k u u' <&&> convM (k+1) (app v w) (app v' w)+conv k (VId a u v) (VId a' u' v') = andM [conv k a a', conv k u u', conv k v v']+conv k (Path x u) (Path x' u')    = conv k (swap u x z) (swap u' x' z)+  where z = fresh (u,u')+conv k (Path x u) p'              = convM k (return (swap u x z)) (appName p' z)+  where z = fresh u+conv k p (Path x' u')             = convM k (appName p z) (return (swap u' x' z))+  where z = fresh u'+-- conv k (VExt x b f g p) (VExt x' b' f' g' p') =+--   andM [x <==> x', conv k b b', conv k f f', conv k g g', conv k p p']+conv k (VHExt x b f g p) (VHExt x' b' f' g' p') =+  andM [x <==> x', conv k b b', conv k f f', conv k g g', conv k p p']+conv k (VFst u) (VFst u')                     = conv k u u'+conv k (VSnd u) (VSnd u')                     = conv k u u'+conv k (VInh u) (VInh u')                     = conv k u u'+conv k (VInc u) (VInc u')                     = conv k u u'+conv k (VSquash x u v) (VSquash x' u' v')     =+  andM [x <==> x', conv k u u', conv k v v']+conv k (VCon c us) (VCon c' us') =+  liftM (\bs -> (c == c') && and bs) (zipWithM (conv k) us us')+conv k (Kan Fill v box) (Kan Fill v' box')    =+  conv k v v' <&&> convBox k box box'+conv k (Kan Com v box) (Kan Com v' box')      =+  andM [conv k v v', convBox k (swap box x y) (swap box' x' y)]+  where y      = fresh ((v,v'),(box,box'))+        (x,x') = (pname box, pname box')+conv k (VComN v box) (VComN v' box')      =+  andM [conv k v v', convBox k (swap box x y) (swap box' x' y)]+  where y      = fresh ((v,v'),(box,box'))+        (x,x') = (pname box, pname box')+conv k (VFillN v box) (VFillN v' box')      =+  andM [conv k v v', convBox k (swap box x y) (swap box' x' y)]+  where y      = fresh ((v,v'),(box,box'))+        (x,x') = (pname box, pname box')+conv k (VEquivEq x a b f s t) (VEquivEq x' a' b' f' s' t') =+  andM [x <==> x', conv k a a', conv k b b',+       conv k f f', conv k s s', conv k t t']+conv k (VEquivSquare x y a s t) (VEquivSquare x' y' a' s' t') =+  andM [x <==> x', y <==> y', conv k a a', conv k s s', conv k t t']+conv k (VPair x u v) (VPair x' u' v')     =+  andM [x <==> x', conv k u u', conv k v v']+conv k (VSquare x y u) (VSquare x' y' u') =+  andM [x <==> x', y <==> y', conv k u u']+conv k (VComp box) (VComp box')           =+  convBox k (swap box x y) (swap box' x' y)+  where y      = fresh (box,box')+        (x,x') = (pname box, pname box')+conv k (VFill x box) (VFill x' box')      =+  convBox k (swap box x y) (swap box' x' y)+  where y      = fresh (box,box')+conv k (VSPair u v)   (VSPair u' v')   = conv k u u' <&&> conv k v v'+conv k (VSPair u v)   w                =+  conv k u (fstSVal w) <&&> conv k v (sndSVal w)+conv k w              (VSPair u v)     =+  conv k (fstSVal w) u <&&> conv k (sndSVal w) v+conv k (VApp u v)     (VApp u' v')     = conv k u u' <&&> conv k v v'+conv k (VAppName u x) (VAppName u' x') = conv k u u' <&&> (x <==> x')+conv k (VSplit u v)   (VSplit u' v')   = conv k u u' <&&> conv k v v'+conv k (VVar x d)     (VVar x' d')     = return $ (x == x')   && (d == d')+conv k (VInhRec b p phi v) (VInhRec b' p' phi' v') =+  andM [conv k b b', conv k p p', conv k phi phi', conv k v v']+conv k VCircle        VCircle          = return True+conv k VBase          VBase            = return True+conv k (VLoop x)      (VLoop y)        = x <==> y+conv k (VCircleRec f b l v) (VCircleRec f' b' l' v') =+  andM [conv k f f', conv k b b', conv k l l', conv k v v']+conv k VI             VI               = return True+conv k VI0            VI0              = return True+conv k VI1            VI1              = return True+conv k (VLine x)      (VLine y)        = x <==> y+conv k (VIntRec f s e l u) (VIntRec f' s' e' l' u') =+  andM [conv k f f', conv k s s', conv k e e', conv k l l', conv k u u']+conv k _              _                = return False++-- Monadic version of conv+convM :: Int -> Eval Val -> Eval Val -> Eval Bool+convM k v1 v2 = do+  v1' <- v1+  v2' <- v2+  conv k v1' v2'++convBox :: Int -> Box Val -> Box Val -> Eval Bool+convBox k box@(Box d pn _ ss) box'@(Box d' pn' _ ss') =+  if (d == d') && (pn == pn') && (sort np == sort np')+     then and <$> sequence [ conv k (lookBox s box) (lookBox s box')+                           | s <- defBox box ]+     else return False+  where (np, np') = (nonPrincipal box, nonPrincipal box')++convEnv :: Int -> OEnv -> OEnv -> Eval Bool+convEnv k e e' = liftM and $ zipWithM (conv k) (valOfOEnv e) (valOfOEnv e')
Exp.cf view
@@ -3,65 +3,57 @@ comment "--" ; comment "{-" "-}" ; -layout "where", "let", "of", "split" ; -- , "mutual" ;+layout "where", "let", "split", "mutual" ; layout stop "in" ; -- Do not use layout toplevel as it makes pExp fail! -Module.   Module ::= "module" AIdent "where" "{" [Imp] [Def] "}" ;+Module.   Module ::= "module" AIdent "where" "{" [Imp] [Decl] "}" ;  Import.   Imp ::= "import" AIdent ; separator Imp ";" ; -Def.       Def ::= AIdent [Arg] "=" ExpWhere ;-DefTDecl.  Def ::= AIdent ":" Exp ;-DefData.   Def ::= "data" AIdent [Arg] "=" [Sum] ;---- Anders: This is kind of an ugly way to get mutual to work, but at least it--- works, I guess there is a bug in bnfc when handling layout blocks and lists--- TODO: Bug report?--- DefMutual. Def ::= Def "mutual" "{" [Def] "}" ;--- Mutual.    Def ::= "mutual" "{" [Def] "}" ;--separator  Def ";" ;+DeclDef.    Decl ::= AIdent [AIdent] "=" ExpWhere ;+DeclType.   Decl ::= AIdent ":" Exp ;+DeclPrim.   Decl ::= "primitive" AIdent ":" Exp ;+DeclData.   Decl ::= "data" AIdent [AIdent] "=" [Label] ;+DeclMutual. Decl ::= "mutual" "{" [Decl] "}" ;+DeclOpaque. Decl ::= "opaque" AIdent ;+DeclTransp. Decl ::= "transparent" AIdent ;+separator   Decl ";" ; -Where.    ExpWhere ::= Exp "where" "{" [Def] "}" ;+Where.    ExpWhere ::= Exp "where" "{" [Decl] "}" ; NoWhere.  ExpWhere ::= Exp ; -Let.      Exp  ::= "let" "{" [Def] "}" "in" Exp ;-Lam.      Exp  ::= "\\" [Binder] "->" Exp ;+Let.      Exp  ::= "let" "{" [Decl] "}" "in" Exp ;+Lam.      Exp  ::= "\\" AIdent [AIdent] "->" Exp ; Split.    Exp  ::= "split" "{" [Branch] "}" ; Fun.      Exp1 ::= Exp2 "->" Exp1 ;-Pi.       Exp1 ::= [PiDecl] "->" Exp1 ;+Pi.       Exp1 ::= [PseudoTDecl] "->" Exp1 ;+Sigma.    Exp1 ::= [PseudoTDecl] "*" Exp1 ; App.      Exp2 ::= Exp2 Exp3 ;-Var.      Exp3 ::= Arg ;+Fst.      Exp3 ::= Exp3 ".1" ;+Snd.      Exp3 ::= Exp3 ".2" ;+Pair.     Exp3 ::= "(" Exp "," Exp ")" ;+Var.      Exp3 ::= AIdent ; U.        Exp3 ::= "U" ;-Undef.    Exp3 ::= "undefined" ;-PN.       Exp3 ::= "PN" ; coercions Exp 3 ; -Binder.   Binder ::= Arg ;-separator nonempty Binder "" ;---- Like Binder, but may be empty-Arg.       Arg ::= AIdent ;-NoArg.     Arg ::= "_" ;-terminator Arg "" ;- -- Branches-Branch.   Branch ::= AIdent [Arg] "->" ExpWhere ;+Branch.   Branch ::= AIdent [AIdent] "->" ExpWhere ; separator Branch ";" ;  -- Labelled sum alternatives-Sum.      Sum   ::= AIdent [VDecl] ;-separator Sum "|" ;+Label.    Label   ::= AIdent [VTDecl] ;+separator Label "|" ;  -- Telescopes-VDecl.     VDecl ::= "(" [Binder] ":" Exp ")" ;-terminator VDecl "" ;+VTDecl.    VTDecl ::= "(" AIdent [AIdent] ":" Exp ")" ;+terminator VTDecl "" ; --- Nonempty telescopes with Exp:s, this is hack to avoid ambiguities in the--- grammar when parsing Pi-PiDecl.   PiDecl ::= "(" Exp ":" Exp ")" ;-terminator nonempty PiDecl "" ;+-- Nonempty telescopes with Exp:s, this is hack to avoid ambiguities+-- in the grammar when parsing Pi+PseudoTDecl. PseudoTDecl ::= "(" Exp ":" Exp ")" ;+terminator nonempty PseudoTDecl "" ; -position token AIdent (letter(letter|digit|'\''|'_')*) ;+position token AIdent ((letter|'\''|'_')(letter|digit|'\''|'_')*) ;+terminator AIdent "" ;
Exp/Lex.x view
@@ -2,6 +2,7 @@ -- This Alex file was machine-generated by the BNF converter { {-# OPTIONS -fno-warn-incomplete-patterns #-}+{-# OPTIONS_GHC -w #-} module Exp.Lex where  @@ -19,7 +20,7 @@ $u = [\0-\255]          -- universal: any character  @rsyms =    -- symbols and non-identifier-like reserved words-   \{ | \} | \; | \= | \: | \\ | \- \> | \( | \) | \_ | \|+   \{ | \} | \; | \= | \: | \\ | \- \> | \* | \. "1" | \. "2" | \( | \, | \) | \|  :- "--" [.]* ; -- Toss single line comments@@ -27,7 +28,7 @@  $white+ ; @rsyms { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }-$l ($l | $d | \' | \_)* { tok (\p s -> PT p (eitherResIdent (T_AIdent . share) s)) }+($l | \' | \_)($l | $d | \' | \_)* { tok (\p s -> PT p (eitherResIdent (T_AIdent . share) s)) }  $l $i*   { tok (\p s -> PT p (eitherResIdent (TV . share) s)) } @@ -88,7 +89,7 @@                               | s > a  = treeFind right                               | s == a = t -resWords = b "data" 11 (b "=" 6 (b "->" 3 (b ")" 2 (b "(" 1 N N) N) (b ";" 5 (b ":" 4 N N) N)) (b "\\" 9 (b "U" 8 (b "PN" 7 N N) N) (b "_" 10 N N))) (b "undefined" 17 (b "let" 14 (b "in" 13 (b "import" 12 N N) N) (b "split" 16 (b "module" 15 N N) N)) (b "|" 20 (b "{" 19 (b "where" 18 N N) N) (b "}" 21 N N)))+resWords = b "import" 14 (b ".2" 7 (b "," 4 (b ")" 2 (b "(" 1 N N) (b "*" 3 N N)) (b ".1" 6 (b "->" 5 N N) N)) (b "U" 11 (b ";" 9 (b ":" 8 N N) (b "=" 10 N N)) (b "data" 13 (b "\\" 12 N N) N))) (b "split" 21 (b "mutual" 18 (b "let" 16 (b "in" 15 N N) (b "module" 17 N N)) (b "primitive" 20 (b "opaque" 19 N N) N)) (b "{" 24 (b "where" 23 (b "transparent" 22 N N) N) (b "}" 26 (b "|" 25 N N) N)))    where b s n = let bs = id s                   in B bs (TS bs n)
Exp/Par.y view
@@ -18,25 +18,30 @@ %token   '(' { PT _ (TS _ 1) }  ')' { PT _ (TS _ 2) }- '->' { PT _ (TS _ 3) }- ':' { PT _ (TS _ 4) }- ';' { PT _ (TS _ 5) }- '=' { PT _ (TS _ 6) }- 'PN' { PT _ (TS _ 7) }- 'U' { PT _ (TS _ 8) }- '\\' { PT _ (TS _ 9) }- '_' { PT _ (TS _ 10) }- 'data' { PT _ (TS _ 11) }- 'import' { PT _ (TS _ 12) }- 'in' { PT _ (TS _ 13) }- 'let' { PT _ (TS _ 14) }- 'module' { PT _ (TS _ 15) }- 'split' { PT _ (TS _ 16) }- 'undefined' { PT _ (TS _ 17) }- 'where' { PT _ (TS _ 18) }- '{' { PT _ (TS _ 19) }- '|' { PT _ (TS _ 20) }- '}' { PT _ (TS _ 21) }+ '*' { PT _ (TS _ 3) }+ ',' { PT _ (TS _ 4) }+ '->' { PT _ (TS _ 5) }+ '.1' { PT _ (TS _ 6) }+ '.2' { PT _ (TS _ 7) }+ ':' { PT _ (TS _ 8) }+ ';' { PT _ (TS _ 9) }+ '=' { PT _ (TS _ 10) }+ 'U' { PT _ (TS _ 11) }+ '\\' { PT _ (TS _ 12) }+ 'data' { PT _ (TS _ 13) }+ 'import' { PT _ (TS _ 14) }+ 'in' { PT _ (TS _ 15) }+ 'let' { PT _ (TS _ 16) }+ 'module' { PT _ (TS _ 17) }+ 'mutual' { PT _ (TS _ 18) }+ 'opaque' { PT _ (TS _ 19) }+ 'primitive' { PT _ (TS _ 20) }+ 'split' { PT _ (TS _ 21) }+ 'transparent' { PT _ (TS _ 22) }+ 'where' { PT _ (TS _ 23) }+ '{' { PT _ (TS _ 24) }+ '|' { PT _ (TS _ 25) }+ '}' { PT _ (TS _ 26) }  L_AIdent { PT _ (T_AIdent _) } L_err    { _ }@@ -47,7 +52,7 @@ AIdent    :: { AIdent} : L_AIdent { AIdent (mkPosToken $1)}  Module :: { Module }-Module : 'module' AIdent 'where' '{' ListImp ListDef '}' { Module $2 $5 $6 } +Module : 'module' AIdent 'where' '{' ListImp ListDecl '}' { Module $2 $5 $6 }    Imp :: { Imp }@@ -60,33 +65,38 @@   | Imp ';' ListImp { (:) $1 $3 }  -Def :: { Def }-Def : AIdent ListArg '=' ExpWhere { Def $1 (reverse $2) $4 } -  | AIdent ':' Exp { DefTDecl $1 $3 }-  | 'data' AIdent ListArg '=' ListSum { DefData $2 (reverse $3) $5 }+Decl :: { Decl }+Decl : AIdent ListAIdent '=' ExpWhere { DeclDef $1 (reverse $2) $4 } +  | AIdent ':' Exp { DeclType $1 $3 }+  | 'primitive' AIdent ':' Exp { DeclPrim $2 $4 }+  | 'data' AIdent ListAIdent '=' ListLabel { DeclData $2 (reverse $3) $5 }+  | 'mutual' '{' ListDecl '}' { DeclMutual $3 }+  | 'opaque' AIdent { DeclOpaque $2 }+  | 'transparent' AIdent { DeclTransp $2 }  -ListDef :: { [Def] }-ListDef : {- empty -} { [] } -  | Def { (:[]) $1 }-  | Def ';' ListDef { (:) $1 $3 }+ListDecl :: { [Decl] }+ListDecl : {- empty -} { [] } +  | Decl { (:[]) $1 }+  | Decl ';' ListDecl { (:) $1 $3 }   ExpWhere :: { ExpWhere }-ExpWhere : Exp 'where' '{' ListDef '}' { Where $1 $4 } +ExpWhere : Exp 'where' '{' ListDecl '}' { Where $1 $4 }    | Exp { NoWhere $1 }   Exp :: { Exp }-Exp : 'let' '{' ListDef '}' 'in' Exp { Let $3 $6 } -  | '\\' ListBinder '->' Exp { Lam $2 $4 }+Exp : 'let' '{' ListDecl '}' 'in' Exp { Let $3 $6 } +  | '\\' AIdent ListAIdent '->' Exp { Lam $2 (reverse $3) $5 }   | 'split' '{' ListBranch '}' { Split $3 }   | Exp1 { $1 }   Exp1 :: { Exp } Exp1 : Exp2 '->' Exp1 { Fun $1 $3 } -  | ListPiDecl '->' Exp1 { Pi $1 $3 }+  | ListPseudoTDecl '->' Exp1 { Pi $1 $3 }+  | ListPseudoTDecl '*' Exp1 { Sigma $1 $3 }   | Exp2 { $1 }  @@ -96,34 +106,16 @@   Exp3 :: { Exp }-Exp3 : Arg { Var $1 } +Exp3 : Exp3 '.1' { Fst $1 } +  | Exp3 '.2' { Snd $1 }+  | '(' Exp ',' Exp ')' { Pair $2 $4 }+  | AIdent { Var $1 }   | 'U' { U }-  | 'undefined' { Undef }-  | 'PN' { PN }   | '(' Exp ')' { $2 }  -Binder :: { Binder }-Binder : Arg { Binder $1 } ---ListBinder :: { [Binder] }-ListBinder : Binder { (:[]) $1 } -  | Binder ListBinder { (:) $1 $2 }---Arg :: { Arg }-Arg : AIdent { Arg $1 } -  | '_' { NoArg }---ListArg :: { [Arg] }-ListArg : {- empty -} { [] } -  | ListArg Arg { flip (:) $1 $2 }-- Branch :: { Branch }-Branch : AIdent ListArg '->' ExpWhere { Branch $1 (reverse $2) $4 } +Branch : AIdent ListAIdent '->' ExpWhere { Branch $1 (reverse $2) $4 }    ListBranch :: { [Branch] }@@ -132,32 +124,37 @@   | Branch ';' ListBranch { (:) $1 $3 }  -Sum :: { Sum }-Sum : AIdent ListVDecl { Sum $1 (reverse $2) } +Label :: { Label }+Label : AIdent ListVTDecl { Label $1 (reverse $2) }   -ListSum :: { [Sum] }-ListSum : {- empty -} { [] } -  | Sum { (:[]) $1 }-  | Sum '|' ListSum { (:) $1 $3 }+ListLabel :: { [Label] }+ListLabel : {- empty -} { [] } +  | Label { (:[]) $1 }+  | Label '|' ListLabel { (:) $1 $3 }  -VDecl :: { VDecl }-VDecl : '(' ListBinder ':' Exp ')' { VDecl $2 $4 } +VTDecl :: { VTDecl }+VTDecl : '(' AIdent ListAIdent ':' Exp ')' { VTDecl $2 (reverse $3) $5 }   -ListVDecl :: { [VDecl] }-ListVDecl : {- empty -} { [] } -  | ListVDecl VDecl { flip (:) $1 $2 }+ListVTDecl :: { [VTDecl] }+ListVTDecl : {- empty -} { [] } +  | ListVTDecl VTDecl { flip (:) $1 $2 }  -PiDecl :: { PiDecl }-PiDecl : '(' Exp ':' Exp ')' { PiDecl $2 $4 } +PseudoTDecl :: { PseudoTDecl }+PseudoTDecl : '(' Exp ':' Exp ')' { PseudoTDecl $2 $4 }   -ListPiDecl :: { [PiDecl] }-ListPiDecl : PiDecl { (:[]) $1 } -  | PiDecl ListPiDecl { (:) $1 $2 }+ListPseudoTDecl :: { [PseudoTDecl] }+ListPseudoTDecl : PseudoTDecl { (:[]) $1 } +  | PseudoTDecl ListPseudoTDecl { (:) $1 $2 }+++ListAIdent :: { [AIdent] }+ListAIdent : {- empty -} { [] } +  | ListAIdent AIdent { flip (:) $1 $2 }
− MTT.hs 
@@ -1,334 +0,0 @@--- miniTT, with recursive definitions
-module MTT where
-
-import Data.Either
-import Data.List
-import Data.Maybe
-import Control.Monad
-import Debug.Trace
-import Control.Monad.Trans.Error hiding (throwError)
-import Control.Monad.Trans.Reader
-import Control.Monad.Identity
-import Control.Monad.Error (throwError)
-import Control.Applicative
-
-import Pretty
-
-type Label  = String
-
--- Branch of the form: c x1 .. xn -> e
-type Brc    = (Label,([String],Exp))
-
--- Telescope (x1 : A1) .. (xn : An)
-type Tele   = [(String,Exp)]
-
--- Labelled sum: c (x1 : A1) .. (xn : An)
-type LblSum = [(Label,Tele)]
-
--- Mix values and expressions
-type Val = Exp
-
--- Context gives type values to identifiers
-type Ctxt = [(String,Val)]
-
--- Mutual recursive definitions: (x1 : A1) .. (xn : An) and x1 = e1 .. xn = en
-type Def = (Tele,[(String,Exp)])
-
--- De Bruijn levels
-mkVar :: Int -> Exp
-mkVar k = Var (genName k)
-
-genName :: Int -> String
-genName n = 'X' : show n
-
-type Prim = (Integer,String)
-
-data Exp = Comp Exp Env         -- for closures
-         | App Exp Exp
-         | Pi Exp Exp
-         | Lam String Exp
-         | Def Exp Def
-         | Var String
-         | U
-         | Con String [Exp]
-         | Fun Prim [Brc]
-         | Sum Prim LblSum
-         | Undef Prim
-         | EPrim Prim [Exp]     -- used for reification
-  deriving (Eq)
-
-instance Show Exp where
- show = showExp
-
-data Env = Empty
-         | Pair Env (String,Val)
-         | PDef Def Env         -- for handling recursive definitions,
-                                -- see getE
-  deriving (Eq)
-
-instance Show Env where
-  show = showEnv
-
-lets :: [Def] -> Exp -> Exp
-lets []     e = e
-lets (d:ds) e = Def (lets ds e) d
-
-defs :: Env -> Exp -> Exp
-defs Empty        e = e
-defs (PDef d env) e = defs env (Def e d)
-defs env          _ =
-  error $ "defs: environment should a list of definitions " ++ show env
-
-upds :: Env -> [(String,Val)] -> Env
-upds = foldl Pair
-
-eval :: Exp -> Env -> Val
-eval (Def e d)   s = eval e (PDef d s)
-eval (App t1 t2) s = app (eval t1 s) (eval t2 s)
-eval (Pi a b)    s = Pi (eval a s) (eval b s)
-eval (Con c ts)  s = Con c (map (`eval` s) ts)
-eval (Var k)     s = getE k s
-eval U           _ = U
-eval t           s = Comp t s
-
-evals :: [(String,Exp)] -> Env -> [(String,Val)]
-evals es r = map (\(x,e) -> (x,eval e r)) es
-
-app :: Val -> Val -> Val
-app (Comp (Lam x b) s)     u            = eval b (Pair s (x,u))
-app a@(Comp (Fun _ ces) r) b@(Con c us) = case lookup c ces of
-  Just (xs,e) -> eval e (upds r (zip xs us))
-  Nothing     -> error $ "app: " ++ show a ++ " " ++ show b
-app f                      u            = App f u
-
-getE :: String -> Env -> Exp
-getE x (Pair _ (y,u)) | x == y = u
-getE x (Pair s _)              = getE x s
-getE x r@(PDef d r1)           = getE x (upds r1 (evals (snd d) r))
-
-addC :: Ctxt -> (Tele,Env) -> [(String,Val)] -> Ctxt
-addC gam _             []          = gam
-addC gam ((y,a):as,nu) ((x,u):xus) =
-  addC ((x,eval a nu):gam) (as,Pair nu (y,u)) xus
-
--- Extract the type of a label as a closure
-getLblType :: String -> Exp -> Typing (Tele, Env)
-getLblType c (Comp (Sum _ cas) r) = case lookup c cas of
-  Just as -> return (as,r)
-  Nothing -> throwError ("getLblType " ++ show c)
-getLblType c u = throwError ("expected a data type for the constructor "
-                             ++ c ++ " but got " ++ show u)
-
--- Environment for type checker
-data TEnv = TEnv { index :: Int   -- for de Bruijn levels
-                 , env   :: Env
-                 , ctxt  :: Ctxt }
-          deriving Eq
-
-tEmpty :: TEnv
-tEmpty = TEnv 0 Empty []
-
--- Type checking monad
-type Typing a = ReaderT TEnv (ErrorT String Identity) a
-
-runTyping :: Typing a -> TEnv -> ErrorT String Identity a
-runTyping = runReaderT
-
--- Used in the interaction loop
-runDef :: TEnv -> Def -> Either String TEnv
-runDef lenv d = do
-  runIdentity $ runErrorT $ runTyping (checkDef d) lenv
-  return $ addDef d lenv
-
-runDefs :: TEnv -> [Def] -> Either String TEnv
-runDefs = foldM runDef
-
-runInfer :: TEnv -> Exp -> Either String Exp
-runInfer lenv e = runIdentity $ runErrorT $ runTyping (checkInfer e) lenv
-
-addTypeVal :: (String,Val) -> TEnv -> TEnv
-addTypeVal p@(x,_) (TEnv k rho gam) = TEnv (k+1) (Pair rho (x,mkVar k)) (p:gam)
-
-addType :: (String,Exp) -> TEnv -> TEnv
-addType (x,a) tenv@(TEnv _ rho _) = addTypeVal (x,eval a rho) tenv
-
-addBranch :: [(String,Val)] -> (Tele,Env) -> TEnv -> TEnv
-addBranch nvs (tele,env) (TEnv k rho gam) =
-  TEnv (k + length nvs) (upds rho nvs) (addC gam (tele,env) nvs)
-
-addDef :: Def -> TEnv -> TEnv
-addDef d@(ts,es) (TEnv k rho gam) =
-  let rho1 = PDef d rho
-  in TEnv k rho1 (addC gam (ts,rho) (evals es rho1))
-
-addTele :: Tele -> TEnv -> TEnv
-addTele xas lenv = foldl (flip addType) lenv xas
-
-getIndex :: Typing Int
-getIndex = index <$> ask
-
-getFresh :: Typing Exp
-getFresh = mkVar <$> getIndex
-
-getEnv :: Typing Env
-getEnv = env <$> ask
-
-getCtxt :: Typing Ctxt
-getCtxt = ctxt <$> ask
-
-(=?=) :: Typing Exp -> Exp -> Typing ()
-m =?= s2 = do
-  s1 <- m
-  unless (s1 == s2) $ throwError (show s1 ++ " =/= " ++ show s2)
-
-checkDef :: Def -> Typing ()
-checkDef (xas,xes) = trace ("checking definition " ++ show (map fst xes)) $ do
-  checkTele xas
-  rho <- getEnv
-  local (addTele xas) $ checks (xas,rho) (map snd xes)
-
-checkTele :: Tele -> Typing ()
-checkTele []          = return ()
-checkTele ((x,a):xas) = do
-  check U a
-  local (addType (x,a)) $ checkTele xas
-
-check :: Val -> Exp -> Typing ()
-check a t = case (a,t) of
-  (_,Con c es) -> do
-    (bs,nu) <- getLblType c a
-    checks (bs,nu) es
-  (U,Pi a (Lam x b)) -> do
-    check U a
-    local (addType (x,a)) $ check U b
-  (U,Sum _ bs) -> sequence_ [checkTele as | (_,as) <- bs]
-  (Pi (Comp (Sum _ cas) nu) f,Fun _ ces) ->
-    if map fst ces == map fst cas
-       then sequence_ [ checkBranch (as,nu) f brc
-                      | (brc, (_,as)) <- zip ces cas ]
-       else throwError "case branches does not match the data type"
-  (Pi a f,Lam x t)  -> do
-    var <- getFresh
-    local (addTypeVal (x,a)) $ check (app f var) t
-  (_,Def e d) -> do
-    checkDef d
-    local (addDef d) $ check a e
-  (_,Undef _) -> return ()
-  _ -> do
-    k <- getIndex
-    (reifyExp k <$> checkInfer t) =?= reifyExp k a
-
-checkBranch :: (Tele,Env) -> Val -> Brc -> Typing ()
-checkBranch (xas,nu) f (c,(xs,e)) = do
-  k <- getIndex
-  let l  = length xas
-  let us = map mkVar [k..k+l-1]
-  local (addBranch (zip xs us) (xas,nu)) $ check (app f (Con c us)) e
-
-checkInfer :: Exp -> Typing Exp
-checkInfer e = case e of
-  U -> return U                 -- U : U
-  Var n -> do
-    gam <- getCtxt
-    case lookup n gam of
-      Just v  -> return v
-      Nothing -> throwError $ show n ++ " is not declared!"
-  App t u -> do
-    c <- checkInfer t
-    case c of
-      Pi a f -> do
-        check a u
-        rho <- getEnv
-        return (app f (eval u rho))
-      _      ->  throwError $ show c ++ " is not a product"
-  Def t d -> do
-    checkDef d
-    local (addDef d) $ checkInfer t
-  _ -> throwError ("checkInfer " ++ show e)
-
-checks :: (Tele,Env) -> [Exp] -> Typing ()
-checks _              []     = return ()
-checks ((x,a):xas,nu) (e:es) = do
-  check (eval a nu) e
-  rho <- getEnv
-  checks (xas,Pair nu (x,eval e rho)) es
-checks _              _      = throwError "checks"
-
--- Reification of a value to an expression
-reifyExp :: Int -> Val -> Exp
-reifyExp _ U                     = U
-reifyExp k (Comp (Lam x t) r)    =
-  Lam (genName k) $ reifyExp (k+1) (eval t (Pair r (x,mkVar k)))
-reifyExp k v@(Var l)             = v
-reifyExp k (App u v)             = App (reifyExp k u) (reifyExp k v)
-reifyExp k (Pi a f)              = Pi (reifyExp k a) (reifyExp k f)
-reifyExp k (Con n ts)            = Con n (map (reifyExp k) ts)
-reifyExp k (Comp (Fun prim _) r) = EPrim prim (reifyEnv k r)
-reifyExp k (Comp (Sum prim _) r) = EPrim prim (reifyEnv k r)
-reifyExp k (Comp (Undef prim) r) = EPrim prim (reifyEnv k r)
-
-reifyEnv :: Int -> Env -> [Exp]
-reifyEnv _ Empty          = []
-reifyEnv k (Pair r (_,u)) = reifyEnv k r ++ [reifyExp k u]
-reifyEnv k (PDef ts r)    = reifyEnv k r
-
--- Not used since we have U : U
--- checkTs :: [(String,Exp)] -> Typing ()
--- checkTs [] = return ()
--- checkTs ((x,a):xas) = do
---   checkType a
---   local (addType (x,a)) (checkTs xas)
---
--- checkType :: Exp -> Typing ()
--- checkType t = case t of
---   U              -> return ()
---   Pi a (Lam x b) -> do
---     checkType a
---     local (addType (x,a)) (checkType b)
---   _ -> checkInfer t =?= U
-
--- a show function
-
-showExp :: Exp -> String
-showExp1 :: Exp -> String
-
-showExps :: [Exp] -> String
-showExps = hcat . map showExp1
-
-showExp1 U = "U"
-showExp1 (Con c []) = c
-showExp1 (Var x) = x
-showExp1 u@(Fun {}) = showExp u
-showExp1 u@(Sum {}) = showExp u
-showExp1 u@(Undef {}) = showExp u
-showExp1 u@(EPrim {}) = showExp u
-showExp1 u@(Comp {}) = showExp u
-showExp1 u = parens $ showExp u
-
-showEnv :: Env -> String
-showEnv Empty            = ""
-showEnv (Pair env (x,u)) = parens $ showEnv1 env ++ show u
-showEnv (PDef xas env)   = showEnv env
-
-showEnv1 Empty            = ""
-showEnv1 (Pair env (x,u)) = showEnv1 env ++ showExp u ++ ", "
-showEnv1 (PDef xas env)   = showEnv env
-
-
-showExp e = case e of
- App e0 e1 -> showExp e0 <+> showExp1 e1
- Pi e0 e1 -> "Pi" <+> showExps [e0,e1]
- Lam x e -> "\\" ++ x ++ "->" <+> showExp e
- Def e d -> showExp e <+> "where" <+> showDef d
- Var x -> x
- U -> "U"
- Con c es -> c <+> showExps es
- Fun (n,str) _ -> str ++ show n
- Sum (_,str) _ -> str
- Undef (n,str) -> str ++ show n
- EPrim (n,str) es -> str ++ show n <+> showExps es
- Comp e env -> showExp1 e <+> showEnv env
-
-showDef :: Def -> String
-showDef (_,xts) = ccat (map (\(x,t) -> x <+> "=" <+> showExp t) xts)
-
− MTTtoCTT.hs 
@@ -1,136 +0,0 @@-{-# LANGUAGE TupleSections #-}--- Tranlates the terms of MiniTT into the cubical syntax.-module MTTtoCTT where--import qualified CTT as I-import Control.Monad.Error-import Control.Applicative-import Control.Arrow-import MTT---- For an expression t, returns (u,ts) where u is no application--- and t = u ts-unApps :: Exp -> (Exp,[Exp])-unApps (App r s) = let (t,ts) = unApps r in (t, ts ++ [s])-unApps t         = (t,[])--apps :: I.Ter -> [I.Ter] -> I.Ter-apps = foldl I.App--lams :: [String] -> I.Ter -> I.Ter-lams bs t = foldr I.Lam t bs--translate :: Exp -> Either String I.Ter-translate U              = return I.U-translate (Undef prim)   = return $ I.Undef prim-translate (Lam x t)      = I.Lam x <$> translate t-translate (Pi a f)       = I.Pi <$> translate a <*> translate f-translate t@(App _ _)    =-  let (hd,rest) = unApps t-  in case hd of-    Var n | n `elem` reservedNames -> translatePrimitive n rest-    _ -> apps <$> translate hd <*> mapM translate rest-translate (Def e (_,ts)) = -- ignores types for now-  I.Where <$> translate e <*> mapM (\(n,e') -> (n,) <$> translate e') ts-translate (Var n) | n `elem` reservedNames = translatePrimitive n []-                  | otherwise              = return (I.Var n)-translate (Con n ts)     = I.Con n <$> mapM translate ts-translate (Fun pr bs)    =-  I.Branch pr <$> mapM (\(n,(ns,b)) -> (n,) <$> (ns,) <$> translate b) bs-translate (Sum pr lbs)   =-  I.LSum pr <$> sequence [ (n,) <$> mapM (\(n',e') -> (n',) <$> translate e') tl-                         | (n,tl) <- lbs ]-translate t              = throwError $ "translate: can not handle " ++ show t---- Gets a name for a primitive notion, a list of arguments which might be too--- long and returns the corresponding concept in the internal syntax. Applies--- the rest of the terms if the list of terms is longer than the arity.-translatePrimitive :: String -> [Exp] -> Either String I.Ter-translatePrimitive n ts = case lookup n primHandle of-  Just (arity,_) | length ts < arity ->-    let r       = arity - length ts-        binders = map (\n -> '_' : show n) [1..r]-        vars    = map Var binders-    in lams binders <$> translatePrimitive n (ts ++ vars)-  Just (arity,handler)               ->-    let (args,rest) = splitAt arity ts-    in apps <$> handler args <*> mapM translate rest-  Nothing                            ->-    throwError ("unknown primitive: " ++ show n)---- | Primitive notions---- name, (arity for Exp, handler)-type PrimHandle = [(String, (Int, [Exp] -> Either String I.Ter))]--primHandle :: PrimHandle-primHandle =-  [ ("Id",            (3, primId))-  , ("refl",          (2, primRefl))-  , ("funExt",        (5, primExt))-  , ("J",             (6, primJ))-  , ("Jeq",           (4, primJeq))-  , ("inh",           (1, primInh))-  , ("inc",           (2, primInc))-  , ("squash",        (3, primSquash))-  , ("inhrec",        (5, primInhRec))-  , ("equivEq",       (5, primEquivEq))-  , ("transport",     (4, primTransport))-  , ("transportRef",  (2, primTransportRef))-  , ("equivEqRef",    (3, primEquivEqRef))-  , ("transpEquivEq", (6, primTransUEquivEq))-  ]--reservedNames :: [String]-reservedNames = map fst primHandle--primId :: [Exp] -> Either String I.Ter-primId [a,x,y] = I.Id <$> translate a <*> translate x <*> translate y--primRefl :: [Exp] -> Either String I.Ter-primRefl [a,x] = I.Refl <$> translate x--primExt :: [Exp] -> Either String I.Ter-primExt [a,b,f,g,ptwise] =-  I.Ext <$> translate b <*> translate f <*> translate g <*> translate ptwise--primJ :: [Exp] -> Either String I.Ter-primJ [a,u,c,w,v,p] =-  I.J <$> translate a <*> translate u <*> translate c-      <*> translate w <*> translate v <*> translate p--primJeq :: [Exp] -> Either String I.Ter-primJeq [a,u,c,w] =-  I.JEq <$> translate a <*> translate u <*> translate c <*> translate w--primInh :: [Exp] -> Either String I.Ter-primInh [a] = I.Inh <$> translate a--primInc :: [Exp] -> Either String I.Ter-primInc [a,x] = I.Inc <$> translate x--primSquash :: [Exp] -> Either String I.Ter-primSquash [a,x,y] = I.Squash <$> translate x <*> translate y--primInhRec :: [Exp] -> Either String I.Ter-primInhRec [a,b,p,f,x] =-  I.InhRec <$> translate b <*> translate p <*> translate f <*> translate x--primEquivEq :: [Exp] -> Either String I.Ter-primEquivEq [a,b,f,s,t] =-  I.EquivEq <$> translate a <*> translate b <*> translate f-            <*> translate s <*> translate t--primTransport :: [Exp] -> Either String I.Ter-primTransport [a,b,p,x] = I.TransU <$> translate p <*> translate x--primTransportRef :: [Exp] -> Either String I.Ter-primTransportRef [a,x] = I.TransURef <$> translate x--primEquivEqRef :: [Exp] -> Either String I.Ter-primEquivEqRef [a,s,t] = I.EquivEqRef <$> translate a <*> translate s <*> translate t--primTransUEquivEq :: [Exp] -> Either String I.Ter-primTransUEquivEq [a,b,f,s,t,x] =-  I.TransUEquivEq <$> translate a <*> translate b <*> translate f-                  <*> translate s <*> translate t <*> translate x
Main.hs view
@@ -4,6 +4,7 @@ import Control.Monad.Error import Data.List import System.Directory+import System.FilePath import System.Environment import System.Console.GetOpt import System.Console.Haskeline@@ -14,29 +15,28 @@ import Exp.Abs hiding (NoArg) import Exp.Layout import Exp.ErrM-import MTTtoCTT-import Concrete-import qualified MTT  as A+import Concrete hiding (getConstrs)+import qualified TypeChecker as TC import qualified CTT as C import qualified Eval as E  type Interpreter a = InputT IO a  -- Flag handling-data Flag = Debug+data Flag = Debug | Help | Version   deriving (Eq,Show)  options :: [OptDescr Flag]-options = [ Option "d" ["debug"] (NoArg Debug) "Run in debugging mode" ]--parseOpts :: [String] -> IO ([Flag],[String])-parseOpts argv = case getOpt Permute options argv of-  (o,n,[])   -> return (o,n)-  (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))-    where header = "Usage: cubical [OPTION...] [FILES...]"+options = [ Option "d" ["debug"]   (NoArg Debug)   "run in debugging mode"+          , Option ""  ["help"]    (NoArg Help)    "print help"+          , Option ""  ["version"] (NoArg Version) "print version number" ] -defaultPrompt :: String-defaultPrompt = "> "+-- Version number, welcome message, usage and prompt strings+version, welcome, usage, prompt :: String+version = "0.2.0"+welcome = "cubical, version: " ++ version ++ "  (:h for help)\n"+usage   = "Usage: cubical [options] <file.cub>\nOptions:"+prompt  = "> "  lexer :: String -> [Token] lexer = resolveLayout True . myLexer@@ -46,87 +46,117 @@   putStrLn $ "\n[Abstract Syntax]\n\n" ++ show tree   putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree +-- Used for auto completion+searchFunc :: [String] -> String -> [Completion]+searchFunc ns str = map simpleCompletion $ filter (str `isPrefixOf`) ns++settings :: [String] -> Settings IO+settings ns = Settings+  { historyFile    = Nothing+  , complete       = completeWord Nothing " \t" $ return . searchFunc ns+  , autoAddHistory = True }+ main :: IO () main = do   args <- getArgs-  (flags,files) <- parseOpts args-  runInputT defaultSettings $ runInterpreter (Debug `elem` flags) files+  case getOpt Permute options args of+    (flags,files,[])+      | Help    `elem` flags -> putStrLn $ usageInfo usage options+      | Version `elem` flags -> putStrLn version+      | otherwise -> case files of+       []  -> do+         putStrLn welcome+         runInputT (settings []) (loop flags [] [] TC.verboseEnv)+       [f] -> do+         putStrLn welcome+         putStrLn $ "Loading " ++ show f+         initLoop flags f+       _   -> putStrLn $ "Input error: zero or one file expected\n\n" +++                         usageInfo usage options+    (_,_,errs) -> putStrLn $ "Input error: " ++ concat errs ++ "\n" +++                             usageInfo usage options --- (not ok,loaded,already loaded defs) -> to load -> (newnotok, newloaded, newdefs)-imports :: ([String],[String],[Def]) -> String -> Interpreter ([String],[String],[Def])-imports st@(notok,loaded,defs) f-  | f `elem` notok  = do-    outputStrLn $ "Looping imports in " ++ f-    return ([],[],[])+-- Initialize the main loop+initLoop :: [Flag] -> FilePath -> IO ()+initLoop flags f = do+  -- Parse and type-check files+  (_,_,mods) <- imports True ([],[],[]) f+  -- Translate to CTT+  let res = runResolver $ resolveModules mods+  case res of+    Left err    -> do+      putStrLn $ "Resolver failed: " ++ err+      runInputT (settings []) (loop flags f [] TC.verboseEnv)+    Right (adefs,names) -> do+      (merr,tenv) <- TC.runDeclss (Debug `elem` flags) TC.verboseEnv adefs+      case merr of+        Just err -> putStrLn $ "Type checking failed: " ++ err+        Nothing  -> return ()+      putStrLn "File loaded."+      -- Compute names for auto completion+      runInputT (settings [n | ((n,_),_) <- names]) (loop flags f names tenv)++-- The main loop+loop :: [Flag] -> FilePath -> [(C.Binder,SymKind)] -> TC.TEnv -> Interpreter ()+loop flags f names tenv@(TC.TEnv _ rho _ _) = do+  input <- getInputLine prompt+  case input of+    Nothing    -> outputStrLn help >> loop flags f names tenv+    Just ":q"  -> return ()+    Just ":r"  -> lift $ initLoop flags f+    Just (':':'l':' ':str)+      | ' ' `elem` str -> do outputStrLn "Only one file allowed after :l"+                             loop flags f names tenv+      | otherwise      -> lift $ initLoop flags str+    Just (':':'c':'d':' ':str) -> do lift (setCurrentDirectory str)+                                     loop flags f names tenv+    Just ":h"  -> outputStrLn help >> loop flags f names tenv+    Just str   -> case pExp (lexer str) of+      Bad err -> outputStrLn ("Parse error: " ++ err) >> loop flags f names tenv+      Ok  exp ->+        case runResolver $ local (insertBinders names) $ resolveExp exp of+          Left  err  -> do outputStrLn ("Resolver failed: " ++ err)+                           loop flags f names tenv+          Right body -> do+          x <- liftIO $ TC.runInfer (Debug `elem` flags) tenv body+          case x of+            Left err -> do outputStrLn ("Could not type-check: " ++ err)+                           loop flags f names tenv+            Right _  -> do+              e <- liftIO $ E.runEval (Debug `elem` flags) $ E.eval rho body+              outputStrLn ("EVAL: " ++ show e)+              loop flags f names tenv++-- (not ok,loaded,already loaded defs) -> to load ->+--   (new not ok, new loaded, new defs)+-- the bool determines if it should be verbose or not+imports :: Bool -> ([String],[String],[Module]) -> String ->+           IO ([String],[String],[Module])+imports v st@(notok,loaded,mods) f+  | f `elem` notok  = putStrLn ("Looping imports in " ++ f) >> return ([],[],[])   | f `elem` loaded = return st   | otherwise       = do-    b <- lift $ doesFileExist f+    b <- doesFileExist f+    let prefix = dropFileName f     if not b-      then do-        outputStrLn ("The file " ++ f ++ " does not exist")-        return ([],[],[])+      then putStrLn (f ++ " does not exist") >> return ([],[],[])       else do-        s <- lift $ readFile f+        s <- readFile f         let ts = lexer s         case pModule ts of           Bad s  -> do-            outputStrLn $ "Parse Failed in file " ++ show f ++ "\n" ++ show s+            putStrLn $ "Parse failed in " ++ show f ++ "\n" ++ show s             return ([],[],[])-          Ok mod@(Module _ imps defs') -> do-            let imps' = [ unIdent s ++ ".cub" | Import s <- imps ]-            (notok1,loaded1,def1) <- foldM imports (f:notok,loaded,defs) imps'-            outputStrLn $ "Parsed file " ++ show f ++ " successfully!"-            return (notok,f:loaded1,def1 ++ defs')---- The Bool is intended to be whether or not to run in debug mode-runInterpreter :: Bool -> [FilePath] -> Interpreter ()-runInterpreter b fs = case fs of-  [f] -> do-    -- parse and type-check files-    (_,_,defs) <- imports ([],[],[]) f-    -- Compute all constructors-    let cs = concat [ [ unIdent n | Sum n _ <- lbls] | DefData _ _ lbls <- defs ]-    let res = runResolver (local (insertConstrs cs) (resolveDefs defs))-    case res of-      Left err    -> do-        outputStrLn $ "Resolver failed: " ++ err-        loop [] A.tEmpty-      Right adefs -> case A.runDefs A.tEmpty adefs of-        Left err   -> do-          outputStrLn $ "Type checking failed: " ++ err-          loop [] A.tEmpty-        Right tenv -> do-          outputStrLn "File loaded."-          loop cs tenv-  _   -> do-    outputStrLn $ "Exactly one file expected: " ++ show fs-    loop [] A.tEmpty-  where-    loop :: [String] -> A.TEnv -> Interpreter ()-    loop cs tenv@(A.TEnv _ rho _) = do-      input <- getInputLine defaultPrompt-      case input of-        Nothing    -> outputStrLn help >> loop cs tenv-        Just ":q"  -> return ()-        Just ":r"  -> runInterpreter b fs-        Just (':':'l':' ':str) -> runInterpreter b (words str)-        Just (':':'c':'d':' ':str) -> lift (setCurrentDirectory str) >> loop cs tenv-        Just ":h"  -> outputStrLn help >> loop cs tenv-        Just str   -> let ts = lexer str in-          case pExp ts of-            Bad err -> outputStrLn ("Parse error: " ++ err) >> loop cs tenv-            Ok exp  ->-              case runResolver (local (const (Env cs)) (resolveExp exp)) of-                Left err   -> outputStrLn ("Resolver failed: " ++ err) >> loop cs tenv-                Right body ->-                  case A.runInfer tenv body of-                    Left err -> outputStrLn ("Could not type-check: " ++ err) >> loop cs tenv-                    Right _  ->-                      case translate (A.defs rho body) of-                        Left err -> outputStrLn ("Could not translate to internal syntax: " ++ err) >>-                                    loop cs tenv-                        Right t  -> let value = E.eval C.Empty t in-                          outputStrLn ("EVAL: " ++ show value) >> loop cs tenv+          Ok mod@(Module id imp decls) ->+            let name    = unAIdent id+                imp_cub = [prefix ++ unAIdent i ++ ".cub" | Import i <- imp]+            in do+              when (name /= dropExtension (takeFileName f)) $+                error $ "Module name mismatch " ++ show (f,name)+              (notok1,loaded1,mods1) <-+                foldM (imports v) (f:notok,loaded,mods) imp_cub+              when v $ putStrLn $ "Parsed " ++ show f ++ " successfully!"+              return (notok,f:loaded1,mods1 ++ [mod])  help :: String help = "\nAvailable commands:\n" ++
Makefile view
@@ -1,11 +1,16 @@-all: -	ghc --make -O2 -o cubical Main.hs+OPT=2++all:+	ghc --make -O$(OPT) -o cubical Main.hs bnfc:-	bnfc -d Exp.cf+	bnfc --haskell -d Exp.cf 	happy -gca Exp/Par.y 	alex -g Exp/Lex.x-	ghc --make Exp/Test.hs -o Exp/Test+	ghc --make -O$(OPT) Exp/Test.hs -o Exp/Test clean: 	rm -f *.log *.aux *.hi *.o cubical 	cd Exp && rm -f ParExp.y LexExp.x LexhExp.hs \                         ParExp.hs PrintExp.hs AbsExp.hs *.o *.hi++tests:+	runghc Tests.hs
Pretty.hs view
@@ -3,6 +3,7 @@  -------------------------------------------------------------------------------- -- | Pretty printing combinators. Use the same names as in the pretty library.+ (<+>) :: String -> String -> String [] <+> y  = y x  <+> [] = x@@ -18,11 +19,13 @@ ccat :: [String] -> String ccat []     = [] ccat [x]    = x-ccat (x:xs) = x <+> ", " <+> ccat xs+ccat (x:xs) = x <+> "," <+> ccat xs  parens :: String -> String-parens p = "(" ++ p ++ ")"+parens [] = ""+parens p  = "(" ++ p ++ ")"  -- Angled brackets, not present in pretty library. abrack :: String -> String-abrack p = "<" ++ p ++ ">"+abrack [] = ""+abrack p  = "<" ++ p ++ ">"
README.md view
@@ -8,7 +8,7 @@ INSTALL
 -------
 
-To install cubical a working Haskell and cabal installation are
+To install cubical, a working Haskell and cabal installation are
 required.  To build cubical go to the main directory and do
 
   `cabal install`
@@ -19,15 +19,36 @@ 
   `cabal build`
 
-Alternatively one can also use the Makefile to build the system by typing:
+Alternatively one can also use the Makefile to build the system by
+typing:
 
   `make bnfc && make`
 
-However this requires that the following Haskell packages are installed:
+However this requires that the following Haskell packages are
+installed:
 
   mtl, haskeline, directory, BNFC, alex, happy
 
 
+**Note:** In order to make the mutual keyword work a patched version
+of BNFC is needed. To install this download the patched version from
+
+[https://github.com/simhu/bnfc](https://github.com/simhu/bnfc)
+
+and then `cabal install` it.
+
+###Emacs mode:
+
+To install syntax highlighting for cubical files load the cubical.el
+file into emacs. In order to load it automatically add
+
+`(load-file "/path/to/cubical.el")`
+
+`(add-to-list 'auto-mode-alist '("\\.cub\\'" . cub-mode))`
+
+to your .emacs file.
+
+
 USAGE
 -----
 
@@ -35,9 +56,9 @@ 
   `cubical <filename>`
 
-In the interaction loop type :h to get a list of available commands.
-Note that the current directory will be taken as the search path for
-the imports.
+To enable the debugging mode add the -d flag. In the interaction loop
+type :h to get a list of available commands. Note that the current
+directory will be taken as the search path for the imports.
 
 
 OVERVIEW
@@ -57,16 +78,16 @@  * if the expression is well-typed it is translated to the cubical
    syntax and evaluated by a "cubical abstract machine", which
    computes its semantics in cubical sets; the result is shown after
-   "EVAL:" (to disable the trace of the evaluation set the boolean
-   "debug" to False in Eval.hs);
+   "EVAL:" (to enable the trace of the evaluation run cubical with the
+   -d flag);
 
 During type-checking, we consider the primitives listed in
-examples/primitive.cub as non interpreted constants.  The type-checker
-is in the file MTT.hs and is rudimentary (300 lines), without good
+examples/primitive.cub as non interpreted constants. The type-checker
+is in the file TypeChecker.hs and is rudimentary (200 lines), without good
 error messages.
 
 These primitives however have a meaning in cubical sets, and the
-evaluation function computes this meaning.  This semantics/evaluation
+evaluation function computes this meaning. This semantics/evaluation
 is described in the file Eval.hs, which is the main file. The most
 complex part corresponds to the computations witnessing that the
 universe has Kan filling operations.
@@ -75,7 +96,9 @@ presentation of cubical sets as nominal sets with 01-substitutions
 (see A. Pitts' note, references listed below).
 
+The primitives needed to get univalence [are](notes/allprim.txt).
 
+
 DESCRIPTION OF THE LANGUAGE
 ---------------------------
 
@@ -92,21 +115,28 @@  * function defined by case
    `f = split c1 x1 ... xn -> e1 | c2 ... -> ... | ...`
 
+ * sigma types `(x:A) * B`, with the pair constructor (e1,e2)
+   and eliminators e.1 and e.2
+
  * a universe `U` and assume `U:U` for simplicity
 
  * let/where: `let D in e` where D is a list of definitions an
    alternative syntax is `e where D`
 
-* `undefined` like in Haskell
+ * `undefined` like in Haskell
 
+ * mutual definitions (this requires a patched version of BNFC, see
+   the install instructions above).
+
+
 The syntax allows Landin's offside rule similar to Haskell.
 
 The basic (untyped) language has a direct simple denotational
 semantics. Type theory works with the total part of this language (it
 is possible to define totality at the denotational semantics level).
-Our evaluator works in a nominal version of this semantics.  The
-type-checker assumes that we work in this total part, however,
-there is no termination check.
+Our evaluator works in a nominal version of this semantics. The
+type-checker assumes that we work in this total part, however, there
+is no termination check.
 
 
 DESCRIPTION OF THE SEMANTICS/EVALUATION
@@ -122,14 +152,14 @@ current implementation directions/names are represented by numbers).
 
 Operationally, a type is explained by giving what are its Kan filling
-operation.  For instance, we have to explain what are the Kan filling
+operation. For instance, we have to explain what are the Kan filling
 for the dependent product.
 
 The main step for interpreting univalence is to transform an
 equivalence A -> B to a path in any direction x connecting A and B.
 This is a new basic element of the universe, called VEquivEq in the
 file Eval.hs which takes a name and arguments A,B,f and the proof that
-f is an equivalence.  The main part of the work is then to explain the
+f is an equivalence. The main part of the work is then to explain the
 Kan filling operation for this new type.
 
 The Kan filling for the universe can be seen as a generalization of
@@ -141,7 +171,7 @@ 
 The directory examples contains some examples of proofs. The file
 examples/primitive.cub list the new primitives that have cubical set
-semantics. These primitive notions imply the axiom of univalence.  The
+semantics. These primitive notions imply the axiom of univalence. The
 file examples/primitive.cub should be the basis of any development
 using univalence.
 
@@ -157,7 +187,7 @@    N+1; the examples are testSN, testSN1, testSN2, testSN3.
 
  * The file testInh.cub contains examples of computation for the
-   propositional reflection.  It gives an example test which produces
+   propositional reflection. It gives an example test which produces
    a (surprisingly complex) composition of squares in the universe.
 
  * The file quotient.cub contains an example of a computation from an
@@ -178,35 +208,41 @@    test15.
 
 
-
-FURTHER WORK (non-exhaustive)
-------------
-
- * The Kan filling operations should be formally proved correct and
-   tested on higher inductive types.
+NEWS (to be detailed)
+----
 
  * Some constants have a direct cubical semantics having better
    behavior w.r.t. equality.  For instance the constant
 
-    `cong : (A B : U) (f : A -> B) (a b : A) (p : Id A a b) -> Id B (f a) (f b)`
+    `mapOnPath : (A B : U) (f : A -> B) (a b : A)
+                 (p : Id A a b) -> Id B (f a) (f b)`
 
    has a semantics which satisfies the definitional equalities:
 
-    `cong (id A)       = id A`
+    `mapOnPath (id A)       = id A`
 
-    `cong (g o f)      = (cong g) o (cong f)`
+    `mapOnPath (g o f)      = (mapOnPath g) o (mapOnPath f)`
 
-    `cong f (refl A a) = refl B (f a)`
+    `mapOnPath f (refl A a) = refl B (f a)`
 
-   The evaluation should be used for conversion during type-checking,
-   and then we shall get these equalities as definitional.
+   The evaluation is now used for conversion during type-checking,
+   and then we get these equalities definitionally.
 
-   Some proofs are then much simpler, e.g. the proof of the Graduate
-   Lemma.
+   Some proofs are now much simpler than before, e.g. the proof of the
+   Graduate Lemma.
 
- * Similarly we should have eta conversion and surjective pairing;
-   this can be obtained by normalization by evaluation.
+ * Similarly we also have eta conversion and surjective pairing.
 
+ * As a test, the particular case of the circle (S1) and the interval
+   (I) has been added.
+
+
+FURTHER WORK (non-exhaustive)
+------------
+
+ * The Kan filling operations should be formally proved correct and
+   tested on higher inductive types.
+
  * For higher inductive types, like the circle or the sphere, it would
    be appropriate to *extend* the syntax of type theory, in order to
    get natural elimination rules (see the paper on cubical sets).
@@ -216,26 +252,43 @@    to be an interesting proof-theoretical problem.
 
 
-REFERENCES
-----------
+REFERENCES AND NOTES
+--------------------
 
  * Voevodsky's home page on univalent foundation
 
- * HoTT book
+ * HoTT book and webpage:
+   [http://homotopytypetheory.org/](http://homotopytypetheory.org/)
 
  * Type Theory in Color, J.P. Bernardy, G. Moulin
 
  * A simple type-theoretic language: Mini-TT, Th. Coquand,
-   Y. Kinoshita, B. Nordstrom and M. Takeyama
+   Y. Kinoshita, B. Nordström and M. Takeyama
 
- * A cubical set model of type theory, M. Bezem, Th. Coquand and
-   S. Huber available at www.cse.chalmers.se/~coquand/model1.pdf
+ * [A cubical set model of type
+   theory](http://www.cse.chalmers.se/~coquand/model1.pdf), M. Bezem,
+   Th. Coquand and S. Huber.
 
- * A property of contractible types, Th. Coquand available at
-   www.cse.chalmers.se/~coquand/contr.pdf
+ * [A remark on contractible family of
+   type](http://www.cse.chalmers.se/~coquand/contr.pdf), Th. Coquand.
 
- * An equivalent presentation of the Bezem-Coquand-Huber category of
-   cubical sets, A. Pitts
+   This note explains how to derive univalence.
+
+ * [An equivalent presentation of the Bezem-Coquand-Huber category of
+   cubical sets](http://arxiv.org/abs/1401.7807), A. Pitts.
+
+   This gives a presentation of the cubical set model in nominal sets.
+
+ * [Remark on singleton
+   types](http://www.cse.chalmers.se/~coquand/singl.pdf), Th. Coquand.
+
+ * [Note on Kripke
+   model](http://www.cse.chalmers.se/~coquand/countermodel.pdf), M. Bezem
+   and Th. Coquand.
+
+ * [Some connections between cubical sets and
+   parametricity](http://www.cse.chalmers.se/~coquand/param.pdf),
+   Th. Coquand.
 
 
 AUTHORS
Setup.hs view
@@ -7,7 +7,7 @@ main :: IO () main = do   b  <- doesFileExist "Exp/Abs.hs"-  -- run bnfc if the Exp directory does not exist+  -- run bnfc if Exp/Abs.hs does not exist   when (not b) bnfc   t1 <- getModificationTime "Exp.cf"   t2 <- getModificationTime "Exp"@@ -16,7 +16,7 @@   defaultMain   where     bnfc = do-      ret <- system "bnfc -d Exp.cf"+      ret <- system "bnfc --haskell -d Exp.cf"       case ret of         ExitSuccess   -> defaultMain         ExitFailure n -> error $ "bnfc command not found or error" ++ show n
+ TypeChecker.hs view
@@ -0,0 +1,250 @@+module TypeChecker ( runDecls
+                   , runDeclss
+                   , runInfer
+                   , TEnv(..)
+                   , verboseEnv
+                   , silentEnv
+                   ) where
+
+import Data.Either
+import Data.List
+import Data.Maybe
+import Data.Monoid hiding (Sum)
+import Control.Monad
+import Control.Monad.Trans
+import Control.Monad.Trans.Error hiding (throwError)
+import Control.Monad.Trans.Reader
+import Control.Monad.Error (throwError)
+import Control.Applicative
+import Pretty
+
+import CTT
+import Eval
+
+trace :: String -> Typing ()
+trace s = do
+  b <- verbose <$> ask
+  when b $ liftIO (putStrLn s)
+
+-- Type checking monad
+type Typing a = ReaderT TEnv (ErrorT String Eval) a
+
+runTyping :: Bool -> TEnv -> Typing a -> IO (Either String a)
+runTyping debug env t = runEval debug $ runErrorT $ runReaderT t env
+
+-- Used in the interaction loop
+runDecls :: Bool -> TEnv -> ODecls -> IO (Either String TEnv)
+runDecls debug tenv d = runTyping debug tenv $ do
+  checkDecls d
+  addDecls d tenv
+
+runDeclss :: Bool -> TEnv -> [ODecls] -> IO (Maybe String,TEnv)
+runDeclss _ tenv []         = return (Nothing, tenv)
+runDeclss debug tenv (d:ds) = do
+  x <- runDecls debug tenv d
+  case x of
+    Right tenv' -> runDeclss debug tenv' ds
+    Left s      -> return (Just s, tenv)
+
+runInfer :: Bool -> TEnv -> Ter -> IO (Either String Val)
+runInfer debug lenv e = runTyping debug lenv (checkInfer e)
+
+liftEval :: Eval a -> Typing a
+liftEval = lift . lift
+
+addC :: Ctxt -> (Tele,OEnv) -> [(Binder,Val)] -> Typing Ctxt
+addC gam _             []          = return gam
+addC gam ((y,a):as,nu) ((x,u):xus) = do
+  v <- liftEval $ eval nu a
+  addC ((x,v):gam) (as,oPair nu (y,u)) xus
+
+-- Extract the type of a label as a closure
+getLblType :: String -> Val -> Typing (Tele, OEnv)
+getLblType c (Ter (Sum _ cas) r) = case getIdent c cas of
+  Just as -> return (as,r)
+  Nothing -> throwError ("getLblType " ++ show c)
+getLblType c u = throwError ("expected a data type for the constructor "
+                             ++ c ++ " but got " ++ show u)
+
+-- Environment for type checker
+data TEnv = TEnv { index   :: Int   -- for de Bruijn levels
+                 , oenv     :: OEnv
+                 , ctxt    :: Ctxt
+                 , verbose :: Bool  -- Should it be verbose and print
+                                    -- what it typechecks?
+                 }
+  deriving (Eq,Show)
+
+verboseEnv, silentEnv :: TEnv
+verboseEnv = TEnv 0 oEmpty [] True
+silentEnv  = TEnv 0 oEmpty [] False
+
+addTypeVal :: (Binder,Val) -> TEnv -> TEnv
+addTypeVal p@(x,_) (TEnv k rho gam v) =
+  TEnv (k+1) (oPair rho (x,mkVar k (support rho))) (p:gam) v
+
+addType :: (Binder,Ter) -> TEnv -> Typing TEnv
+addType (x,a) tenv@(TEnv _ rho _ _) = do
+  v <- liftEval $ eval rho a
+  return $ addTypeVal (x,v) tenv
+
+addBranch :: [(Binder,Val)] -> (Tele,OEnv) -> TEnv -> Typing TEnv
+addBranch nvs (tele,env) (TEnv k rho gam v) = do
+  e <- addC gam (tele,env) nvs
+  return $ TEnv (k + length nvs) (upds rho nvs) e v
+
+addDecls :: ODecls -> TEnv -> Typing TEnv
+addDecls od@(ODecls d) (TEnv k rho gam v) = do
+  let rho1 = oPDef True od rho
+  es'  <- liftEval $ evals rho1 (declDefs d)
+  gam' <- addC gam (declTele d,rho) es'
+  return $ TEnv k rho1 gam' v
+addDecls od tenv = return $ tenv {oenv = oPDef True od (oenv tenv)}
+
+addTele :: Tele -> TEnv -> Typing TEnv
+addTele xas lenv = foldM (flip addType) lenv xas
+
+-- Useful monadic versions of functions:
+checkM :: Typing Val -> Ter -> Typing ()
+checkM v t = do
+  v' <- v
+  check v' t
+
+localM :: (TEnv -> Typing TEnv) -> Typing a -> Typing a
+localM f r = do
+  e <- ask
+  a <- f e
+  local (const a) r
+
+getFresh :: Typing Val
+getFresh = do
+    k <- index <$> ask
+    e <- oenv <$> ask
+    return $ mkVar k (support e)
+
+checkDecls :: ODecls -> Typing ()
+checkDecls (ODecls d) = do
+  let (idents, tele, ters) = (declIdents d, declTele d, declTers d)
+  trace ("Checking: " ++ unwords idents)
+  checkTele tele
+  rho <- oenv <$> ask
+  localM (addTele tele) $ checks (tele,rho) ters
+checkDecls _ = return ()
+
+checkTele :: Tele -> Typing ()
+checkTele []          = return ()
+checkTele ((x,a):xas) = do
+  check VU a
+  localM (addType (x,a)) $ checkTele xas
+
+check :: Val -> Ter -> Typing ()
+check a t = case (a,t) of
+  (_,Con c es) -> do
+    (bs,nu) <- getLblType c a
+    checks (bs,nu) es
+  (VU,Pi a (Lam x b)) -> do
+    check VU a
+    localM (addType (x,a)) $ check VU b
+  (VU,Sigma a (Lam x b)) -> do
+    check VU a
+    localM (addType (x,a)) $ check VU b
+  (VU,Sum _ bs) -> sequence_ [checkTele as | (_,as) <- bs]
+  (VPi (Ter (Sum _ cas) nu) f,Split _ ces) ->
+    if sort (map fst ces) == sort [n | ((n,_),_) <- cas]
+       then sequence_ [ checkBranch (as,nu) f brc
+                      | (brc, (_,as)) <- zip ces cas ]
+       else throwError "case branches does not match the data type"
+  (VPi a f,Lam x t)  -> do
+    var <- getFresh
+    local (addTypeVal (x,a)) $ checkM (liftEval (app f var)) t
+  (VSigma a f, SPair t1 t2) -> do
+    check a t1
+    e <- oenv <$> ask
+    v <- liftEval $ eval e t1
+    checkM (liftEval (app f v)) t2
+  (_,Where e d) -> do
+    checkDecls d
+    localM (addDecls d) $ check a e
+  (_,PN _) -> return ()
+  _ -> do
+    v <- checkInfer t
+    k <- index <$> ask
+    b <- liftEval $ conv k v a
+    unless b $
+      throwError $ "check conv: " ++ show v ++ " /= " ++ show a
+
+checkBranch :: (Tele,OEnv) -> Val -> Brc -> Typing ()
+checkBranch (xas,nu) f (c,(xs,e)) = do
+  k     <- index <$> ask
+  env   <- oenv <$> ask
+  let d  = support env
+      l  = length xas
+      us = map (`mkVar` d) [k..k+l-1]
+  localM (addBranch (zip xs us) (xas,nu))
+    $ checkM (liftEval (app f (VCon c us))) e
+
+checkInfer :: Ter -> Typing Val
+checkInfer e = case e of
+  U -> return VU                 -- U : U
+  Var n -> do
+    gam <- ctxt <$> ask
+    case getIdent n gam of
+      Just v  -> return v
+      Nothing -> throwError $ show n ++ " is not declared!"
+  App t u -> do
+    c <- checkInfer t
+    case c of
+      VPi a f -> do
+        check a u
+        rho <- oenv <$> ask
+        v   <- liftEval $ eval rho u
+        liftEval $ app f v
+      _       -> throwError $ show c ++ " is not a product"
+  Fst t -> do
+    c <- checkInfer t
+    case c of
+      VSigma a f -> return a
+      _          -> throwError $ show c ++ " is not a sigma-type"
+  Snd t -> do
+    c <- checkInfer t
+    case c of
+      VSigma a f -> do
+        e <- oenv <$> ask
+        v <- liftEval $ eval e t
+        liftEval $ app f (fstSVal v)
+      _          -> throwError $ show c ++ " is not a sigma-type"
+  Where t d -> do
+    checkDecls d
+    localM (addDecls d) $ checkInfer t
+  _ -> throwError ("checkInfer " ++ show e)
+
+checks :: (Tele,OEnv) -> [Ter] -> Typing ()
+checks _              []     = return ()
+checks ((x,a):xas,nu) (e:es) = do
+  v   <- liftEval $ eval nu a
+  check v e
+  rho <- oenv <$> ask
+  v'  <- liftEval $ eval rho e
+  checks (xas,oPair nu (x,v')) es
+checks _              _      = throwError "checks"
+
+-- Not used since we have U : U
+--
+-- (=?=) :: Typing Ter -> Ter -> Typing ()
+-- m =?= s2 = do
+--   s1 <- m
+--   unless (s1 == s2) $ throwError (show s1 ++ " =/= " ++ show s2)
+--
+-- checkTs :: [(String,Ter)] -> Typing ()
+-- checkTs [] = return ()
+-- checkTs ((x,a):xas) = do
+--   checkType a
+--   local (addType (x,a)) (checkTs xas)
+--
+-- checkType :: Ter -> Typing ()
+-- checkType t = case t of
+--   U              -> return ()
+--   Pi a (Lam x b) -> do
+--     checkType a
+--     local (addType (x,a)) (checkType b)
+--   _ -> checkInfer t =?= U
cubical.cabal view
@@ -1,27 +1,29 @@ name:                cubical-version:             0.1.2+-- Same version as in Main.hs?+version:             0.2.0 synopsis:            Implementation of Univalence in Cubical Sets-description:         Cubical implements an experimental simple type checker-                     for type theory with univalence with an evaluator for closed terms.+description:         Cubical implements an experimental simple type+                     checker for type theory with univalence with an+                     evaluator for closed terms. homepage:            https://github.com/simhu/cubical-extra-source-files:  Makefile, README.md, Exp.cf, examples/*.cub+extra-source-files:  Makefile, README.md, Exp.cf, examples/*.cub, cubical.el license:             MIT license-file:        LICENSE author:              Cyril Cohen, Thierry Coquand, Simon Huber, Anders Mörtberg maintainer:          mortberg@chalmers.se--- copyright:            category:            Dependent Types build-type:          Custom--- extra-source-files:   cabal-version:       >=1.10  executable cubical   main-is:             Main.hs   other-modules:       Exp.Lex, Exp.Par-  other-extensions:    TupleSections, CPP, MagicHash-  build-depends:       base >=4.5 && < 5, transformers >=0.3, mtl >=2.1, haskeline >=0.7, directory >=1.2, array >=0.4, BNFC >= 2.6-  -- hs-source-dirs:      +  other-extensions:    TupleSections, ParallelListComp, CPP, MagicHash, +                       GeneralizedNewtypeDeriving+  build-depends:       base >= 4.5 && < 5, transformers >= 0.3, mtl >= 2.1, +                       haskeline >= 0.7, directory >= 1.2, array >= 0.4, +                       BNFC >= 2.5, filepath >= 1.3   build-tools:         alex, happy-  default-language:    Haskell2010+  default-language:    Haskell98   hs-source-dirs:      .-  other-modules:       CTT, Concrete, Eval, MTT, MTTtoCTT, Pretty+  other-modules:       CTT, Concrete, Eval, Pretty, TypeChecker
+ cubical.el view
@@ -0,0 +1,64 @@+;; define several class of keywords+(setq cub-keywords '("data" "import" "mutual" "let" "in" "data" "split"+                     "module" "where" "U") )+(setq cub-special '("undefined" "primitive"))++;; create regex strings+(setq cub-keywords-regexp (regexp-opt cub-keywords 'words))+(setq cub-operators-regexp (regexp-opt '(":" "->" "=" "\\" "|" "\\" "*" "_") t))+(setq cub-special-regexp (regexp-opt cub-special 'words))+(setq cub-def-regexp "^[[:word:]]+")++;; clear memory+(setq cub-keywords nil)+(setq cub-special nil)++;; create the list for font-lock.+;; each class of keyword is given a particular face+(setq cub-font-lock-keywords+  `(+    (,cub-keywords-regexp . font-lock-type-face)+    (,cub-operators-regexp . font-lock-variable-name-face)+    (,cub-special-regexp . font-lock-warning-face)+    (,cub-def-regexp . font-lock-function-name-face)+))++;; command to comment/uncomment text+(defun cub-comment-dwim (arg)+  "Comment or uncomment current line or region in a smart way. For detail, see `comment-dwim'."+  (interactive "*P")+  (require 'newcomment)+  (let ((comment-start "--") (comment-end ""))+    (comment-dwim arg)))+++;; syntax table for comments, same as for haskell-mode+(defvar cub-syntax-table+  (let ((st (make-syntax-table)))+       (modify-syntax-entry ?\{  "(}1nb" st)+       (modify-syntax-entry ?\}  "){4nb" st)+       (modify-syntax-entry ?-  "_ 123" st)+       (modify-syntax-entry ?\n ">" st)+   st))++;; define the mode+(define-derived-mode cub-mode fundamental-mode+  "cubical mode"+  "Major mode for editing cubical files…"++  :syntax-table cub-syntax-table++  ;; code for syntax highlighting+  (setq font-lock-defaults '(cub-font-lock-keywords))+  (setq mode-name "cub")++  ;; modify the keymap+  (define-key cub-mode-map [remap comment-dwim] 'cub-comment-dwim)++  ;; clear memory+  (setq cub-keywords-regexp nil)+  (setq cub-operators-regexp nil)+  (setq cub-special-regexp nil)+)++(provide 'cub-mode)
− dist/build/cubical/cubical-tmp/Exp/Lex.hs 
@@ -1,351 +0,0 @@-{-# LANGUAGE CPP,MagicHash #-}-{-# LINE 3 "Exp/Lex.x" #-}--{-# OPTIONS -fno-warn-incomplete-patterns #-}-module Exp.Lex where----import qualified Data.Bits-import Data.Word (Word8)--#if __GLASGOW_HASKELL__ >= 603-#include "ghcconfig.h"-#elif defined(__GLASGOW_HASKELL__)-#include "config.h"-#endif-#if __GLASGOW_HASKELL__ >= 503-import Data.Array-import Data.Char (ord)-import Data.Array.Base (unsafeAt)-#else-import Array-import Char (ord)-#endif-#if __GLASGOW_HASKELL__ >= 503-import GHC.Exts-#else-import GlaExts-#endif-alex_base :: AlexAddr-alex_base = AlexA# "\xf8\xff\xff\xff\xd9\xff\xff\xff\x49\x00\x00\x00\x1c\x01\x00\x00\x9c\x01\x00\x00\x6f\x02\x00\x00\xef\x02\x00\x00\xef\x03\x00\x00\xb7\xff\xff\xff\x00\x00\x00\x00\xe0\x03\x00\x00\x00\x00\x00\x00\x8b\x00\x00\x00\x1d\x02\x00\x00\xe0\x04\x00\x00\xa0\x04\x00\x00\x00\x00\x00\x00\x96\x05\x00\x00\x69\x06\x00\x00\x00\x00\x00\x00\xfe\xff\xff\xff\xdf\xff\xff\xff\x00\x00\x00\x00\x42\x07\x00\x00"#--alex_table :: AlexAddr-alex_table = AlexA# "\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x11\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x16\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x15\x00\x16\x00\x16\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x02\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x0f\x00\x04\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0c\x00\x06\x00\x09\x00\x09\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--alex_check :: AlexAddr-alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x28\x00\x29\x00\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x2d\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xff\xff\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#--alex_deflt :: AlexAddr-alex_deflt = AlexA# "\xff\xff\xff\xff\x05\x00\x05\x00\xff\xff\x05\x00\xff\xff\x05\x00\x05\x00\x0b\x00\x0b\x00\x10\x00\x10\x00\xff\xff\x11\x00\x11\x00\x11\x00\x11\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#--alex_accept = listArray (0::Int,23) [AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccSkip,AlexAccSkip,AlexAccSkip,AlexAccSkip,AlexAcc (alex_action_3),AlexAcc (alex_action_3),AlexAcc (alex_action_4)]-{-# LINE 38 "Exp/Lex.x" #-}---tok f p s = f p s--share :: String -> String-share = id--data Tok =-   TS !String !Int    -- reserved words and symbols- | TL !String         -- string literals- | TI !String         -- integer literals- | TV !String         -- identifiers- | TD !String         -- double precision float literals- | TC !String         -- character literals- | T_AIdent !String-- deriving (Eq,Show,Ord)--data Token = -   PT  Posn Tok- | Err Posn-  deriving (Eq,Show,Ord)--tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l-tokenPos (Err (Pn _ l _) :_) = "line " ++ show l-tokenPos _ = "end of file"--tokenPosn (PT p _) = p-tokenPosn (Err p) = p-tokenLineCol = posLineCol . tokenPosn-posLineCol (Pn _ l c) = (l,c)-mkPosToken t@(PT p _) = (posLineCol p, prToken t)--prToken t = case t of-  PT _ (TS s _) -> s-  PT _ (TL s)   -> s-  PT _ (TI s)   -> s-  PT _ (TV s)   -> s-  PT _ (TD s)   -> s-  PT _ (TC s)   -> s-  PT _ (T_AIdent s) -> s---data BTree = N | B String Tok BTree BTree deriving (Show)--eitherResIdent :: (String -> Tok) -> String -> Tok-eitherResIdent tv s = treeFind resWords-  where-  treeFind N = tv s-  treeFind (B a t left right) | s < a  = treeFind left-                              | s > a  = treeFind right-                              | s == a = t--resWords = b "data" 11 (b "=" 6 (b "->" 3 (b ")" 2 (b "(" 1 N N) N) (b ";" 5 (b ":" 4 N N) N)) (b "\\" 9 (b "U" 8 (b "PN" 7 N N) N) (b "_" 10 N N))) (b "undefined" 17 (b "let" 14 (b "in" 13 (b "import" 12 N N) N) (b "split" 16 (b "module" 15 N N) N)) (b "|" 20 (b "{" 19 (b "where" 18 N N) N) (b "}" 21 N N)))-   where b s n = let bs = id s-                  in B bs (TS bs n)--unescapeInitTail :: String -> String-unescapeInitTail = id . unesc . tail . id where-  unesc s = case s of-    '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs-    '\\':'n':cs  -> '\n' : unesc cs-    '\\':'t':cs  -> '\t' : unesc cs-    '"':[]    -> []-    c:cs      -> c : unesc cs-    _         -> []------------------------------------------------------------------------ Alex wrapper code.--- A modified "posn" wrapper.----------------------------------------------------------------------data Posn = Pn !Int !Int !Int-      deriving (Eq, Show,Ord)--alexStartPos :: Posn-alexStartPos = Pn 0 1 1--alexMove :: Posn -> Char -> Posn-alexMove (Pn a l c) '\t' = Pn (a+1)  l     (((c+7) `div` 8)*8+1)-alexMove (Pn a l c) '\n' = Pn (a+1) (l+1)   1-alexMove (Pn a l c) _    = Pn (a+1)  l     (c+1)--type Byte = Word8--type AlexInput = (Posn,     -- current position,-                  Char,     -- previous char-                  [Byte],   -- pending bytes on the current char-                  String)   -- current input string--tokens :: String -> [Token]-tokens str = go (alexStartPos, '\n', [], str)-    where-      go :: AlexInput -> [Token]-      go inp@(pos, _, _, str) =-               case alexScan inp 0 of-                AlexEOF                   -> []-                AlexError (pos, _, _, _)  -> [Err pos]-                AlexSkip  inp' len        -> go inp'-                AlexToken inp' len act    -> act pos (take len str) : (go inp')--alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)-alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s))-alexGetByte (p, _, [], s) =-  case  s of-    []  -> Nothing-    (c:s) ->-             let p'     = alexMove p c-                 (b:bs) = utf8Encode c-              in p' `seq` Just (b, (p', c, bs, s))--alexInputPrevChar :: AlexInput -> Char-alexInputPrevChar (p, c, bs, s) = c--  -- | Encode a Haskell String to a list of Word8 values, in UTF8 format.-utf8Encode :: Char -> [Word8]-utf8Encode = map fromIntegral . go . ord- where-  go oc-   | oc <= 0x7f       = [oc]--   | oc <= 0x7ff      = [ 0xc0 + (oc `Data.Bits.shiftR` 6)-                        , 0x80 + oc Data.Bits..&. 0x3f-                        ]--   | oc <= 0xffff     = [ 0xe0 + (oc `Data.Bits.shiftR` 12)-                        , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)-                        , 0x80 + oc Data.Bits..&. 0x3f-                        ]-   | otherwise        = [ 0xf0 + (oc `Data.Bits.shiftR` 18)-                        , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f)-                        , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)-                        , 0x80 + oc Data.Bits..&. 0x3f-                        ]--alex_action_3 =  tok (\p s -> PT p (eitherResIdent (TV . share) s)) -alex_action_4 =  tok (\p s -> PT p (eitherResIdent (T_AIdent . share) s)) -alex_action_5 =  tok (\p s -> PT p (eitherResIdent (TV . share) s)) -{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "<command-line>" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}--- -------------------------------------------------------------------------------- ALEX TEMPLATE------ This code is in the PUBLIC DOMAIN; you may copy it freely and use--- it for any purpose whatsoever.---- -------------------------------------------------------------------------------- INTERNALS and main scanner engine--{-# LINE 35 "templates/GenericTemplate.hs" #-}--{-# LINE 45 "templates/GenericTemplate.hs" #-}---data AlexAddr = AlexA# Addr#--#if __GLASGOW_HASKELL__ < 503-uncheckedShiftL# = shiftL#-#endif--{-# INLINE alexIndexInt16OffAddr #-}-alexIndexInt16OffAddr (AlexA# arr) off =-#ifdef WORDS_BIGENDIAN-  narrow16Int# i-  where-        i    = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)-        high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))-        low  = int2Word# (ord# (indexCharOffAddr# arr off'))-        off' = off *# 2#-#else-  indexInt16OffAddr# arr off-#endif------{-# INLINE alexIndexInt32OffAddr #-}-alexIndexInt32OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN-  narrow32Int# i-  where-   i    = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`-		     (b2 `uncheckedShiftL#` 16#) `or#`-		     (b1 `uncheckedShiftL#` 8#) `or#` b0)-   b3   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))-   b2   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))-   b1   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))-   b0   = int2Word# (ord# (indexCharOffAddr# arr off'))-   off' = off *# 4#-#else-  indexInt32OffAddr# arr off-#endif------#if __GLASGOW_HASKELL__ < 503-quickIndex arr i = arr ! i-#else--- GHC >= 503, unsafeAt is available from Data.Array.Base.-quickIndex = unsafeAt-#endif------- -------------------------------------------------------------------------------- Main lexing routines--data AlexReturn a-  = AlexEOF-  | AlexError  !AlexInput-  | AlexSkip   !AlexInput !Int-  | AlexToken  !AlexInput !Int a---- alexScan :: AlexInput -> StartCode -> AlexReturn a-alexScan input (I# (sc))-  = alexScanUser undefined input (I# (sc))--alexScanUser user input (I# (sc))-  = case alex_scan_tkn user input 0# input sc AlexNone of-	(AlexNone, input') ->-		case alexGetByte input of-			Nothing -> ----				   AlexEOF-			Just _ ->----				   AlexError input'--	(AlexLastSkip input'' len, _) ->----		AlexSkip input'' len--	(AlexLastAcc k input''' len, _) ->----		AlexToken input''' len k----- Push the input through the DFA, remembering the most recent accepting--- state it encountered.--alex_scan_tkn user orig_input len input s last_acc =-  input `seq` -- strict in the input-  let -	new_acc = (check_accs (alex_accept `quickIndex` (I# (s))))-  in-  new_acc `seq`-  case alexGetByte input of-     Nothing -> (new_acc, input)-     Just (c, new_input) -> ----      case fromIntegral c of { (I# (ord_c)) ->-        let-                base   = alexIndexInt32OffAddr alex_base s-                offset = (base +# ord_c)-                check  = alexIndexInt16OffAddr alex_check offset-		-                new_s = if (offset >=# 0#) && (check ==# ord_c)-			  then alexIndexInt16OffAddr alex_table offset-			  else alexIndexInt16OffAddr alex_deflt s-	in-        case new_s of-	    -1# -> (new_acc, input)-		-- on an error, we want to keep the input *before* the-		-- character that failed, not after.-    	    _ -> alex_scan_tkn user orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len)-                                                -- note that the length is increased ONLY if this is the 1st byte in a char encoding)-			new_input new_s new_acc-      }-  where-	check_accs (AlexAccNone) = last_acc-	check_accs (AlexAcc a  ) = AlexLastAcc a input (I# (len))-	check_accs (AlexAccSkip) = AlexLastSkip  input (I# (len))-{-# LINE 191 "templates/GenericTemplate.hs" #-}--data AlexLastAcc a-  = AlexNone-  | AlexLastAcc a !AlexInput !Int-  | AlexLastSkip  !AlexInput !Int--instance Functor AlexLastAcc where-    fmap f AlexNone = AlexNone-    fmap f (AlexLastAcc x y z) = AlexLastAcc (f x) y z-    fmap f (AlexLastSkip x y) = AlexLastSkip x y--data AlexAcc a user-  = AlexAccNone-  | AlexAcc a-  | AlexAccSkip-{-# LINE 235 "templates/GenericTemplate.hs" #-}---- used by wrappers-iUnbox (I# (i)) = i
− dist/build/cubical/cubical-tmp/Exp/Par.hs 
@@ -1,985 +0,0 @@-{-# OPTIONS_GHC -w #-}-{-# OPTIONS -fglasgow-exts -cpp #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}-module Exp.Par where-import Exp.Abs-import Exp.Lex-import Exp.ErrM-import qualified Data.Array as Happy_Data_Array-import qualified GHC.Exts as Happy_GHC_Exts---- parser produced by Happy Version 1.18.8--newtype HappyAbsSyn  = HappyAbsSyn HappyAny-#if __GLASGOW_HASKELL__ >= 607-type HappyAny = Happy_GHC_Exts.Any-#else-type HappyAny = forall a . a-#endif-happyIn5 :: (AIdent) -> (HappyAbsSyn )-happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn5 #-}-happyOut5 :: (HappyAbsSyn ) -> (AIdent)-happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut5 #-}-happyIn6 :: (Module) -> (HappyAbsSyn )-happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn6 #-}-happyOut6 :: (HappyAbsSyn ) -> (Module)-happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut6 #-}-happyIn7 :: (Imp) -> (HappyAbsSyn )-happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn7 #-}-happyOut7 :: (HappyAbsSyn ) -> (Imp)-happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut7 #-}-happyIn8 :: ([Imp]) -> (HappyAbsSyn )-happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn8 #-}-happyOut8 :: (HappyAbsSyn ) -> ([Imp])-happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut8 #-}-happyIn9 :: (Def) -> (HappyAbsSyn )-happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn9 #-}-happyOut9 :: (HappyAbsSyn ) -> (Def)-happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut9 #-}-happyIn10 :: ([Def]) -> (HappyAbsSyn )-happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn10 #-}-happyOut10 :: (HappyAbsSyn ) -> ([Def])-happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut10 #-}-happyIn11 :: (ExpWhere) -> (HappyAbsSyn )-happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn11 #-}-happyOut11 :: (HappyAbsSyn ) -> (ExpWhere)-happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut11 #-}-happyIn12 :: (Exp) -> (HappyAbsSyn )-happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn12 #-}-happyOut12 :: (HappyAbsSyn ) -> (Exp)-happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut12 #-}-happyIn13 :: (Exp) -> (HappyAbsSyn )-happyIn13 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn13 #-}-happyOut13 :: (HappyAbsSyn ) -> (Exp)-happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut13 #-}-happyIn14 :: (Exp) -> (HappyAbsSyn )-happyIn14 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn14 #-}-happyOut14 :: (HappyAbsSyn ) -> (Exp)-happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut14 #-}-happyIn15 :: (Exp) -> (HappyAbsSyn )-happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn15 #-}-happyOut15 :: (HappyAbsSyn ) -> (Exp)-happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut15 #-}-happyIn16 :: (Binder) -> (HappyAbsSyn )-happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn16 #-}-happyOut16 :: (HappyAbsSyn ) -> (Binder)-happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut16 #-}-happyIn17 :: ([Binder]) -> (HappyAbsSyn )-happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn17 #-}-happyOut17 :: (HappyAbsSyn ) -> ([Binder])-happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut17 #-}-happyIn18 :: (Arg) -> (HappyAbsSyn )-happyIn18 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn18 #-}-happyOut18 :: (HappyAbsSyn ) -> (Arg)-happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut18 #-}-happyIn19 :: ([Arg]) -> (HappyAbsSyn )-happyIn19 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn19 #-}-happyOut19 :: (HappyAbsSyn ) -> ([Arg])-happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut19 #-}-happyIn20 :: (Branch) -> (HappyAbsSyn )-happyIn20 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn20 #-}-happyOut20 :: (HappyAbsSyn ) -> (Branch)-happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut20 #-}-happyIn21 :: ([Branch]) -> (HappyAbsSyn )-happyIn21 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn21 #-}-happyOut21 :: (HappyAbsSyn ) -> ([Branch])-happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut21 #-}-happyIn22 :: (Sum) -> (HappyAbsSyn )-happyIn22 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn22 #-}-happyOut22 :: (HappyAbsSyn ) -> (Sum)-happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut22 #-}-happyIn23 :: ([Sum]) -> (HappyAbsSyn )-happyIn23 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn23 #-}-happyOut23 :: (HappyAbsSyn ) -> ([Sum])-happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut23 #-}-happyIn24 :: (VDecl) -> (HappyAbsSyn )-happyIn24 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn24 #-}-happyOut24 :: (HappyAbsSyn ) -> (VDecl)-happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut24 #-}-happyIn25 :: ([VDecl]) -> (HappyAbsSyn )-happyIn25 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn25 #-}-happyOut25 :: (HappyAbsSyn ) -> ([VDecl])-happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut25 #-}-happyIn26 :: (PiDecl) -> (HappyAbsSyn )-happyIn26 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn26 #-}-happyOut26 :: (HappyAbsSyn ) -> (PiDecl)-happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut26 #-}-happyIn27 :: ([PiDecl]) -> (HappyAbsSyn )-happyIn27 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn27 #-}-happyOut27 :: (HappyAbsSyn ) -> ([PiDecl])-happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut27 #-}-happyInTok :: (Token) -> (HappyAbsSyn )-happyInTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyInTok #-}-happyOutTok :: (HappyAbsSyn ) -> (Token)-happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOutTok #-}---happyActOffsets :: HappyAddr-happyActOffsets = HappyA# "\xd7\x00\xca\x00\xce\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xdb\x00\x00\x00\x00\x00\xde\x00\xcd\x00\xca\x00\x00\x00\x00\x00\x4b\x00\x00\x00\xc4\x00\xbb\x00\x00\x00\xb7\x00\xc3\x00\xba\x00\xaf\x00\x18\x00\x4b\x00\xc1\x00\x00\x00\x41\x00\x9c\x00\x00\x00\xca\x00\x00\x00\xca\x00\x9c\x00\x00\x00\xbd\x00\xb9\x00\x00\x00\x00\x00\xca\x00\xca\x00\x00\x00\xb8\x00\xae\x00\x8c\x00\x98\x00\x00\x00\xa0\x00\x89\x00\x8d\x00\x8a\x00\x00\x00\x7d\x00\x0a\x00\x00\x00\x84\x00\x18\x00\x3a\x00\xca\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\xca\x00\x37\x00\xca\x00\x00\x00\x81\x00\x18\x00\x78\x00\x00\x00\x61\x00\x77\x00\x00\x00\x6f\x00\x68\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x6a\x00\x00\x00\x00\x00\x18\x00\x5b\x00\x65\x00\x00\x00\x4b\x00\x00\x00\x59\x00\x00\x00\x60\x00\xca\x00\x6b\x00\x00\x00\x00\x00"#--happyGotoOffsets :: HappyAddr-happyGotoOffsets = HappyA# "\x64\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\x00\x00\xed\xff\x00\x00\x92\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x26\x00\xb0\x00\xb6\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x82\x00\x00\x00\x72\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x52\x00\x00\x00\x48\x00\x00\x00\x00\x00\x54\x00\x40\x00\x00\x00\x00\x00\x00\x00\x31\x00\x00\x00\x21\x00\x51\x00\x38\x00\x00\x00\x90\x00\x51\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x32\x00\x51\x00\x01\x00\x00\x00\x00\x00\x80\x00\x3e\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x0c\x00\x02\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00"#--happyDefActions :: HappyAddr-happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\xfd\xff\xde\xff\x00\x00\xec\xff\xe9\xff\xe7\xff\xe6\xff\xce\xff\x00\x00\x00\x00\xe3\xff\xe5\xff\x00\x00\xdd\xff\x00\x00\x00\x00\xe4\xff\x00\x00\x00\x00\x00\x00\xd9\xff\xf4\xff\xe0\xff\x00\x00\xe1\xff\x00\x00\x00\x00\xcd\xff\x00\x00\xe8\xff\x00\x00\x00\x00\xeb\xff\x00\x00\x00\x00\xea\xff\xe2\xff\x00\x00\x00\x00\xdf\xff\xdc\xff\xf3\xff\x00\x00\x00\x00\xdc\xff\xd8\xff\x00\x00\x00\x00\xfa\xff\xed\xff\xd9\xff\x00\x00\xdc\xff\x00\x00\xf4\xff\x00\x00\x00\x00\xee\xff\x00\x00\xcf\xff\xf6\xff\xdb\xff\x00\x00\xf2\xff\x00\x00\x00\x00\x00\x00\xd7\xff\xf9\xff\xf4\xff\x00\x00\xfb\xff\x00\x00\xfa\xff\xda\xff\xf0\xff\xd5\xff\xef\xff\xf7\xff\xd1\xff\xd4\xff\xf5\xff\x00\x00\xf8\xff\xfc\xff\xf4\xff\xd5\xff\xd6\xff\xd0\xff\x00\x00\xd3\xff\x00\x00\xf1\xff\x00\x00\x00\x00\x00\x00\xd2\xff"#--happyCheck :: HappyAddr-happyCheck = HappyA# "\xff\xff\x00\x00\x15\x00\x16\x00\x00\x00\x02\x00\x03\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x03\x00\x0d\x00\x0b\x00\x0c\x00\x0d\x00\x00\x00\x00\x00\x0a\x00\x13\x00\x15\x00\x16\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x11\x00\x12\x00\x0d\x00\x16\x00\x00\x00\x00\x00\x0b\x00\x11\x00\x12\x00\x00\x00\x15\x00\x16\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x14\x00\x16\x00\x0d\x00\x0f\x00\x10\x00\x00\x00\x02\x00\x03\x00\x0f\x00\x10\x00\x15\x00\x16\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x06\x00\x00\x00\x0d\x00\x06\x00\x0a\x00\x00\x00\x02\x00\x0a\x00\x04\x00\x0e\x00\x15\x00\x16\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x16\x00\x0e\x00\x0d\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x0e\x00\x15\x00\x16\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0a\x00\x0d\x00\x0d\x00\x0d\x00\x16\x00\x00\x00\x00\x00\x04\x00\x01\x00\x01\x00\x15\x00\x16\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x02\x00\x15\x00\x0d\x00\x00\x00\x16\x00\x00\x00\x14\x00\x04\x00\x05\x00\x15\x00\x15\x00\x16\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x13\x00\x16\x00\x0d\x00\x00\x00\x12\x00\x00\x00\x0c\x00\x04\x00\x05\x00\x05\x00\x15\x00\x16\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x02\x00\x16\x00\x0d\x00\x00\x00\x0d\x00\x00\x00\x16\x00\x04\x00\x05\x00\x0c\x00\x15\x00\x16\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x01\x00\x15\x00\x0d\x00\x13\x00\x15\x00\x00\x00\x07\x00\x08\x00\x05\x00\x0a\x00\x15\x00\x16\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x11\x00\x16\x00\x0d\x00\x00\x00\x00\x00\x16\x00\x05\x00\x04\x00\x05\x00\x00\x00\x15\x00\x16\x00\x08\x00\x09\x00\x0a\x00\x04\x00\x04\x00\x0d\x00\x02\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x03\x00\x16\x00\x15\x00\x16\x00\x08\x00\x09\x00\x0a\x00\x01\x00\x12\x00\x0d\x00\x13\x00\x18\x00\x03\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x15\x00\x16\x00\x13\x00\x0e\x00\x16\x00\x10\x00\x11\x00\x01\x00\x00\x00\x03\x00\x01\x00\x16\x00\x18\x00\x07\x00\x08\x00\x16\x00\x0a\x00\x0f\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#--happyTable :: HappyAddr-happyTable = HappyA# "\x00\x00\x04\x00\x0a\x00\x1e\x00\x04\x00\x47\x00\x56\x00\x4d\x00\x4e\x00\x06\x00\x07\x00\x08\x00\x52\x00\x46\x00\x09\x00\x19\x00\x60\x00\x1b\x00\x04\x00\x52\x00\x11\x00\x5b\x00\x0a\x00\x0b\x00\x51\x00\x4e\x00\x06\x00\x07\x00\x08\x00\x53\x00\x5d\x00\x09\x00\x04\x00\x2f\x00\x04\x00\x2f\x00\x53\x00\x54\x00\x2f\x00\x0a\x00\x0b\x00\x62\x00\x06\x00\x07\x00\x08\x00\x5a\x00\x04\x00\x09\x00\x30\x00\x46\x00\x04\x00\x47\x00\x48\x00\x30\x00\x31\x00\x0a\x00\x0b\x00\x50\x00\x06\x00\x07\x00\x08\x00\x50\x00\x4a\x00\x09\x00\x42\x00\x11\x00\x04\x00\x28\x00\x11\x00\x29\x00\x44\x00\x0a\x00\x0b\x00\x3f\x00\x06\x00\x07\x00\x08\x00\x04\x00\x36\x00\x09\x00\x04\x00\x04\x00\x04\x00\x04\x00\x37\x00\x11\x00\x3a\x00\x0a\x00\x0b\x00\x3c\x00\x06\x00\x07\x00\x08\x00\x20\x00\x40\x00\x09\x00\x09\x00\x04\x00\x04\x00\x16\x00\x62\x00\x14\x00\x5d\x00\x0a\x00\x0b\x00\x3d\x00\x06\x00\x07\x00\x08\x00\x64\x00\x60\x00\x09\x00\x2b\x00\x04\x00\x04\x00\x5a\x00\x2c\x00\x5e\x00\x58\x00\x0a\x00\x0b\x00\x24\x00\x06\x00\x07\x00\x08\x00\x59\x00\x04\x00\x09\x00\x2b\x00\x56\x00\x04\x00\x4a\x00\x2c\x00\x4b\x00\x4d\x00\x0a\x00\x0b\x00\x25\x00\x06\x00\x07\x00\x08\x00\x3f\x00\x04\x00\x09\x00\x2b\x00\x44\x00\x04\x00\x04\x00\x2c\x00\x42\x00\x4a\x00\x0a\x00\x0b\x00\x1c\x00\x06\x00\x07\x00\x08\x00\x0d\x00\x35\x00\x09\x00\x34\x00\x39\x00\x04\x00\x0e\x00\x0f\x00\x36\x00\x11\x00\x0a\x00\x0b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x14\x00\x04\x00\x09\x00\x2b\x00\x04\x00\x04\x00\x3a\x00\x2c\x00\x2d\x00\x04\x00\x0a\x00\x0b\x00\x23\x00\x07\x00\x08\x00\x3c\x00\x29\x00\x09\x00\x28\x00\x04\x00\x19\x00\x2a\x00\x1b\x00\x2a\x00\x04\x00\x0a\x00\x0b\x00\x26\x00\x07\x00\x08\x00\x0d\x00\x33\x00\x09\x00\x18\x00\xff\xff\x1e\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0a\x00\x0b\x00\x19\x00\x12\x00\x04\x00\x13\x00\x14\x00\x22\x00\x04\x00\x23\x00\x20\x00\x04\x00\xff\xff\x0e\x00\x0f\x00\x04\x00\x11\x00\x16\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyReduceArr = Happy_Data_Array.array (2, 50) [-	(2 , happyReduce_2),-	(3 , happyReduce_3),-	(4 , happyReduce_4),-	(5 , happyReduce_5),-	(6 , happyReduce_6),-	(7 , happyReduce_7),-	(8 , happyReduce_8),-	(9 , happyReduce_9),-	(10 , happyReduce_10),-	(11 , happyReduce_11),-	(12 , happyReduce_12),-	(13 , happyReduce_13),-	(14 , happyReduce_14),-	(15 , happyReduce_15),-	(16 , happyReduce_16),-	(17 , happyReduce_17),-	(18 , happyReduce_18),-	(19 , happyReduce_19),-	(20 , happyReduce_20),-	(21 , happyReduce_21),-	(22 , happyReduce_22),-	(23 , happyReduce_23),-	(24 , happyReduce_24),-	(25 , happyReduce_25),-	(26 , happyReduce_26),-	(27 , happyReduce_27),-	(28 , happyReduce_28),-	(29 , happyReduce_29),-	(30 , happyReduce_30),-	(31 , happyReduce_31),-	(32 , happyReduce_32),-	(33 , happyReduce_33),-	(34 , happyReduce_34),-	(35 , happyReduce_35),-	(36 , happyReduce_36),-	(37 , happyReduce_37),-	(38 , happyReduce_38),-	(39 , happyReduce_39),-	(40 , happyReduce_40),-	(41 , happyReduce_41),-	(42 , happyReduce_42),-	(43 , happyReduce_43),-	(44 , happyReduce_44),-	(45 , happyReduce_45),-	(46 , happyReduce_46),-	(47 , happyReduce_47),-	(48 , happyReduce_48),-	(49 , happyReduce_49),-	(50 , happyReduce_50)-	]--happy_n_terms = 25 :: Int-happy_n_nonterms = 23 :: Int--happyReduce_2 = happySpecReduce_1  0# happyReduction_2-happyReduction_2 happy_x_1-	 =  case happyOutTok happy_x_1 of { happy_var_1 -> -	happyIn5-		 (AIdent (mkPosToken happy_var_1)-	)}--happyReduce_3 = happyReduce 7# 1# happyReduction_3-happyReduction_3 (happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut5 happy_x_2 of { happy_var_2 -> -	case happyOut8 happy_x_5 of { happy_var_5 -> -	case happyOut10 happy_x_6 of { happy_var_6 -> -	happyIn6-		 (Module happy_var_2 happy_var_5 happy_var_6-	) `HappyStk` happyRest}}}--happyReduce_4 = happySpecReduce_2  2# happyReduction_4-happyReduction_4 happy_x_2-	happy_x_1-	 =  case happyOut5 happy_x_2 of { happy_var_2 -> -	happyIn7-		 (Import happy_var_2-	)}--happyReduce_5 = happySpecReduce_0  3# happyReduction_5-happyReduction_5  =  happyIn8-		 ([]-	)--happyReduce_6 = happySpecReduce_1  3# happyReduction_6-happyReduction_6 happy_x_1-	 =  case happyOut7 happy_x_1 of { happy_var_1 -> -	happyIn8-		 ((:[]) happy_var_1-	)}--happyReduce_7 = happySpecReduce_3  3# happyReduction_7-happyReduction_7 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut7 happy_x_1 of { happy_var_1 -> -	case happyOut8 happy_x_3 of { happy_var_3 -> -	happyIn8-		 ((:) happy_var_1 happy_var_3-	)}}--happyReduce_8 = happyReduce 4# 4# happyReduction_8-happyReduction_8 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut5 happy_x_1 of { happy_var_1 -> -	case happyOut19 happy_x_2 of { happy_var_2 -> -	case happyOut11 happy_x_4 of { happy_var_4 -> -	happyIn9-		 (Def happy_var_1 (reverse happy_var_2) happy_var_4-	) `HappyStk` happyRest}}}--happyReduce_9 = happySpecReduce_3  4# happyReduction_9-happyReduction_9 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut5 happy_x_1 of { happy_var_1 -> -	case happyOut12 happy_x_3 of { happy_var_3 -> -	happyIn9-		 (DefTDecl happy_var_1 happy_var_3-	)}}--happyReduce_10 = happyReduce 5# 4# happyReduction_10-happyReduction_10 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut5 happy_x_2 of { happy_var_2 -> -	case happyOut19 happy_x_3 of { happy_var_3 -> -	case happyOut23 happy_x_5 of { happy_var_5 -> -	happyIn9-		 (DefData happy_var_2 (reverse happy_var_3) happy_var_5-	) `HappyStk` happyRest}}}--happyReduce_11 = happySpecReduce_0  5# happyReduction_11-happyReduction_11  =  happyIn10-		 ([]-	)--happyReduce_12 = happySpecReduce_1  5# happyReduction_12-happyReduction_12 happy_x_1-	 =  case happyOut9 happy_x_1 of { happy_var_1 -> -	happyIn10-		 ((:[]) happy_var_1-	)}--happyReduce_13 = happySpecReduce_3  5# happyReduction_13-happyReduction_13 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut9 happy_x_1 of { happy_var_1 -> -	case happyOut10 happy_x_3 of { happy_var_3 -> -	happyIn10-		 ((:) happy_var_1 happy_var_3-	)}}--happyReduce_14 = happyReduce 5# 6# happyReduction_14-happyReduction_14 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut12 happy_x_1 of { happy_var_1 -> -	case happyOut10 happy_x_4 of { happy_var_4 -> -	happyIn11-		 (Where happy_var_1 happy_var_4-	) `HappyStk` happyRest}}--happyReduce_15 = happySpecReduce_1  6# happyReduction_15-happyReduction_15 happy_x_1-	 =  case happyOut12 happy_x_1 of { happy_var_1 -> -	happyIn11-		 (NoWhere happy_var_1-	)}--happyReduce_16 = happyReduce 6# 7# happyReduction_16-happyReduction_16 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut10 happy_x_3 of { happy_var_3 -> -	case happyOut12 happy_x_6 of { happy_var_6 -> -	happyIn12-		 (Let happy_var_3 happy_var_6-	) `HappyStk` happyRest}}--happyReduce_17 = happyReduce 4# 7# happyReduction_17-happyReduction_17 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut17 happy_x_2 of { happy_var_2 -> -	case happyOut12 happy_x_4 of { happy_var_4 -> -	happyIn12-		 (Lam happy_var_2 happy_var_4-	) `HappyStk` happyRest}}--happyReduce_18 = happyReduce 4# 7# happyReduction_18-happyReduction_18 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut21 happy_x_3 of { happy_var_3 -> -	happyIn12-		 (Split happy_var_3-	) `HappyStk` happyRest}--happyReduce_19 = happySpecReduce_1  7# happyReduction_19-happyReduction_19 happy_x_1-	 =  case happyOut13 happy_x_1 of { happy_var_1 -> -	happyIn12-		 (happy_var_1-	)}--happyReduce_20 = happySpecReduce_3  8# happyReduction_20-happyReduction_20 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut14 happy_x_1 of { happy_var_1 -> -	case happyOut13 happy_x_3 of { happy_var_3 -> -	happyIn13-		 (Fun happy_var_1 happy_var_3-	)}}--happyReduce_21 = happySpecReduce_3  8# happyReduction_21-happyReduction_21 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut27 happy_x_1 of { happy_var_1 -> -	case happyOut13 happy_x_3 of { happy_var_3 -> -	happyIn13-		 (Pi happy_var_1 happy_var_3-	)}}--happyReduce_22 = happySpecReduce_1  8# happyReduction_22-happyReduction_22 happy_x_1-	 =  case happyOut14 happy_x_1 of { happy_var_1 -> -	happyIn13-		 (happy_var_1-	)}--happyReduce_23 = happySpecReduce_2  9# happyReduction_23-happyReduction_23 happy_x_2-	happy_x_1-	 =  case happyOut14 happy_x_1 of { happy_var_1 -> -	case happyOut15 happy_x_2 of { happy_var_2 -> -	happyIn14-		 (App happy_var_1 happy_var_2-	)}}--happyReduce_24 = happySpecReduce_1  9# happyReduction_24-happyReduction_24 happy_x_1-	 =  case happyOut15 happy_x_1 of { happy_var_1 -> -	happyIn14-		 (happy_var_1-	)}--happyReduce_25 = happySpecReduce_1  10# happyReduction_25-happyReduction_25 happy_x_1-	 =  case happyOut18 happy_x_1 of { happy_var_1 -> -	happyIn15-		 (Var happy_var_1-	)}--happyReduce_26 = happySpecReduce_1  10# happyReduction_26-happyReduction_26 happy_x_1-	 =  happyIn15-		 (U-	)--happyReduce_27 = happySpecReduce_1  10# happyReduction_27-happyReduction_27 happy_x_1-	 =  happyIn15-		 (Undef-	)--happyReduce_28 = happySpecReduce_1  10# happyReduction_28-happyReduction_28 happy_x_1-	 =  happyIn15-		 (PN-	)--happyReduce_29 = happySpecReduce_3  10# happyReduction_29-happyReduction_29 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut12 happy_x_2 of { happy_var_2 -> -	happyIn15-		 (happy_var_2-	)}--happyReduce_30 = happySpecReduce_1  11# happyReduction_30-happyReduction_30 happy_x_1-	 =  case happyOut18 happy_x_1 of { happy_var_1 -> -	happyIn16-		 (Binder happy_var_1-	)}--happyReduce_31 = happySpecReduce_1  12# happyReduction_31-happyReduction_31 happy_x_1-	 =  case happyOut16 happy_x_1 of { happy_var_1 -> -	happyIn17-		 ((:[]) happy_var_1-	)}--happyReduce_32 = happySpecReduce_2  12# happyReduction_32-happyReduction_32 happy_x_2-	happy_x_1-	 =  case happyOut16 happy_x_1 of { happy_var_1 -> -	case happyOut17 happy_x_2 of { happy_var_2 -> -	happyIn17-		 ((:) happy_var_1 happy_var_2-	)}}--happyReduce_33 = happySpecReduce_1  13# happyReduction_33-happyReduction_33 happy_x_1-	 =  case happyOut5 happy_x_1 of { happy_var_1 -> -	happyIn18-		 (Arg happy_var_1-	)}--happyReduce_34 = happySpecReduce_1  13# happyReduction_34-happyReduction_34 happy_x_1-	 =  happyIn18-		 (NoArg-	)--happyReduce_35 = happySpecReduce_0  14# happyReduction_35-happyReduction_35  =  happyIn19-		 ([]-	)--happyReduce_36 = happySpecReduce_2  14# happyReduction_36-happyReduction_36 happy_x_2-	happy_x_1-	 =  case happyOut19 happy_x_1 of { happy_var_1 -> -	case happyOut18 happy_x_2 of { happy_var_2 -> -	happyIn19-		 (flip (:) happy_var_1 happy_var_2-	)}}--happyReduce_37 = happyReduce 4# 15# happyReduction_37-happyReduction_37 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut5 happy_x_1 of { happy_var_1 -> -	case happyOut19 happy_x_2 of { happy_var_2 -> -	case happyOut11 happy_x_4 of { happy_var_4 -> -	happyIn20-		 (Branch happy_var_1 (reverse happy_var_2) happy_var_4-	) `HappyStk` happyRest}}}--happyReduce_38 = happySpecReduce_0  16# happyReduction_38-happyReduction_38  =  happyIn21-		 ([]-	)--happyReduce_39 = happySpecReduce_1  16# happyReduction_39-happyReduction_39 happy_x_1-	 =  case happyOut20 happy_x_1 of { happy_var_1 -> -	happyIn21-		 ((:[]) happy_var_1-	)}--happyReduce_40 = happySpecReduce_3  16# happyReduction_40-happyReduction_40 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut20 happy_x_1 of { happy_var_1 -> -	case happyOut21 happy_x_3 of { happy_var_3 -> -	happyIn21-		 ((:) happy_var_1 happy_var_3-	)}}--happyReduce_41 = happySpecReduce_2  17# happyReduction_41-happyReduction_41 happy_x_2-	happy_x_1-	 =  case happyOut5 happy_x_1 of { happy_var_1 -> -	case happyOut25 happy_x_2 of { happy_var_2 -> -	happyIn22-		 (Sum happy_var_1 (reverse happy_var_2)-	)}}--happyReduce_42 = happySpecReduce_0  18# happyReduction_42-happyReduction_42  =  happyIn23-		 ([]-	)--happyReduce_43 = happySpecReduce_1  18# happyReduction_43-happyReduction_43 happy_x_1-	 =  case happyOut22 happy_x_1 of { happy_var_1 -> -	happyIn23-		 ((:[]) happy_var_1-	)}--happyReduce_44 = happySpecReduce_3  18# happyReduction_44-happyReduction_44 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut22 happy_x_1 of { happy_var_1 -> -	case happyOut23 happy_x_3 of { happy_var_3 -> -	happyIn23-		 ((:) happy_var_1 happy_var_3-	)}}--happyReduce_45 = happyReduce 5# 19# happyReduction_45-happyReduction_45 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut17 happy_x_2 of { happy_var_2 -> -	case happyOut12 happy_x_4 of { happy_var_4 -> -	happyIn24-		 (VDecl happy_var_2 happy_var_4-	) `HappyStk` happyRest}}--happyReduce_46 = happySpecReduce_0  20# happyReduction_46-happyReduction_46  =  happyIn25-		 ([]-	)--happyReduce_47 = happySpecReduce_2  20# happyReduction_47-happyReduction_47 happy_x_2-	happy_x_1-	 =  case happyOut25 happy_x_1 of { happy_var_1 -> -	case happyOut24 happy_x_2 of { happy_var_2 -> -	happyIn25-		 (flip (:) happy_var_1 happy_var_2-	)}}--happyReduce_48 = happyReduce 5# 21# happyReduction_48-happyReduction_48 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut12 happy_x_2 of { happy_var_2 -> -	case happyOut12 happy_x_4 of { happy_var_4 -> -	happyIn26-		 (PiDecl happy_var_2 happy_var_4-	) `HappyStk` happyRest}}--happyReduce_49 = happySpecReduce_1  22# happyReduction_49-happyReduction_49 happy_x_1-	 =  case happyOut26 happy_x_1 of { happy_var_1 -> -	happyIn27-		 ((:[]) happy_var_1-	)}--happyReduce_50 = happySpecReduce_2  22# happyReduction_50-happyReduction_50 happy_x_2-	happy_x_1-	 =  case happyOut26 happy_x_1 of { happy_var_1 -> -	case happyOut27 happy_x_2 of { happy_var_2 -> -	happyIn27-		 ((:) happy_var_1 happy_var_2-	)}}--happyNewToken action sts stk [] =-	happyDoAction 24# notHappyAtAll action sts stk []--happyNewToken action sts stk (tk:tks) =-	let cont i = happyDoAction i tk action sts stk tks in-	case tk of {-	PT _ (TS _ 1) -> cont 1#;-	PT _ (TS _ 2) -> cont 2#;-	PT _ (TS _ 3) -> cont 3#;-	PT _ (TS _ 4) -> cont 4#;-	PT _ (TS _ 5) -> cont 5#;-	PT _ (TS _ 6) -> cont 6#;-	PT _ (TS _ 7) -> cont 7#;-	PT _ (TS _ 8) -> cont 8#;-	PT _ (TS _ 9) -> cont 9#;-	PT _ (TS _ 10) -> cont 10#;-	PT _ (TS _ 11) -> cont 11#;-	PT _ (TS _ 12) -> cont 12#;-	PT _ (TS _ 13) -> cont 13#;-	PT _ (TS _ 14) -> cont 14#;-	PT _ (TS _ 15) -> cont 15#;-	PT _ (TS _ 16) -> cont 16#;-	PT _ (TS _ 17) -> cont 17#;-	PT _ (TS _ 18) -> cont 18#;-	PT _ (TS _ 19) -> cont 19#;-	PT _ (TS _ 20) -> cont 20#;-	PT _ (TS _ 21) -> cont 21#;-	PT _ (T_AIdent _) -> cont 22#;-	_ -> cont 23#;-	_ -> happyError' (tk:tks)-	}--happyError_ 24# tk tks = happyError' tks-happyError_ _ tk tks = happyError' (tk:tks)--happyThen :: () => Err a -> (a -> Err b) -> Err b-happyThen = (thenM)-happyReturn :: () => a -> Err a-happyReturn = (returnM)-happyThen1 m k tks = (thenM) m (\a -> k a tks)-happyReturn1 :: () => a -> b -> Err a-happyReturn1 = \a tks -> (returnM) a-happyError' :: () => [(Token)] -> Err a-happyError' = happyError--pModule tks = happySomeParser where-  happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut6 x))--pExp tks = happySomeParser where-  happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut12 x))--happySeq = happyDontSeq---returnM :: a -> Err a-returnM = return--thenM :: Err a -> (a -> Err b) -> Err b-thenM = (>>=)--happyError :: [Token] -> Err a-happyError ts =-  Bad $ "syntax error at " ++ tokenPos ts ++ -  case ts of-    [] -> []-    [Err _] -> " due to lexer error"-    _ -> " before " ++ unwords (map (id . prToken) (take 4 ts))--myLexer = tokens-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "<built-in>" #-}-{-# LINE 1 "<command-line>" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}--- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp --{-# LINE 30 "templates/GenericTemplate.hs" #-}---data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList------{-# LINE 51 "templates/GenericTemplate.hs" #-}--{-# LINE 61 "templates/GenericTemplate.hs" #-}--{-# LINE 70 "templates/GenericTemplate.hs" #-}--infixr 9 `HappyStk`-data HappyStk a = HappyStk a (HappyStk a)---------------------------------------------------------------------------------- starting the parse--happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll---------------------------------------------------------------------------------- Accepting the parse---- If the current token is 0#, it means we've just accepted a partial--- parse (a %partial parser).  We must ignore the saved token on the top of--- the stack in this case.-happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =-	happyReturn1 ans-happyAccept j tk st sts (HappyStk ans _) = -	(happyTcHack j (happyTcHack st)) (happyReturn1 ans)---------------------------------------------------------------------------------- Arrays only: do the next action----happyDoAction i tk st-	= {- nothing -}---	  case action of-		0#		  -> {- nothing -}-				     happyFail i tk st-		-1# 	  -> {- nothing -}-				     happyAccept i tk st-		n | (n Happy_GHC_Exts.<# (0# :: Happy_GHC_Exts.Int#)) -> {- nothing -}--				     (happyReduceArr Happy_Data_Array.! rule) i tk st-				     where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#))))))-		n		  -> {- nothing -}---				     happyShift new_state i tk st-				     where (new_state) = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#))-   where (off)    = indexShortOffAddr happyActOffsets st-         (off_i)  = (off Happy_GHC_Exts.+# i)-	 check  = if (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#))-			then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==#  i)-			else False-         (action)-          | check     = indexShortOffAddr happyTable off_i-          | otherwise = indexShortOffAddr happyDefActions st--{-# LINE 130 "templates/GenericTemplate.hs" #-}---indexShortOffAddr (HappyA# arr) off =-	Happy_GHC_Exts.narrow16Int# i-  where-        i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)-        high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#)))-        low  = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off'))-        off' = off Happy_GHC_Exts.*# 2#------data HappyAddr = HappyA# Happy_GHC_Exts.Addr#------------------------------------------------------------------------------------- HappyState data type (not arrays)--{-# LINE 163 "templates/GenericTemplate.hs" #-}---------------------------------------------------------------------------------- Shifting a token--happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =-     let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in---     trace "shifting the error token" $-     happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)--happyShift new_state i tk st sts stk =-     happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)---- happyReduce is specialised for the common cases.--happySpecReduce_0 i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happySpecReduce_0 nt fn j tk st@((action)) sts stk-     = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)--happySpecReduce_1 i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')-     = let r = fn v1 in-       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happySpecReduce_2 i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')-     = let r = fn v1 v2 in-       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happySpecReduce_3 i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')-     = let r = fn v1 v2 v3 in-       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))--happyReduce k i fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happyReduce k nt fn j tk st sts stk-     = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of-	 sts1@((HappyCons (st1@(action)) (_))) ->-        	let r = fn stk in  -- it doesn't hurt to always seq here...-       		happyDoSeq r (happyGoto nt j tk st1 sts1 r)--happyMonadReduce k nt fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happyMonadReduce k nt fn j tk st sts stk =-        happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))-       where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts))-             drop_stk = happyDropStk k stk--happyMonad2Reduce k nt fn 0# tk st sts stk-     = happyFail 0# tk st sts stk-happyMonad2Reduce k nt fn j tk st sts stk =-       happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))-       where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts))-             drop_stk = happyDropStk k stk--             (off) = indexShortOffAddr happyGotoOffsets st1-             (off_i) = (off Happy_GHC_Exts.+# nt)-             (new_state) = indexShortOffAddr happyTable off_i-----happyDrop 0# l = l-happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t--happyDropStk 0# l = l-happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs---------------------------------------------------------------------------------- Moving to a new state after a reduction---happyGoto nt j tk st = -   {- nothing -}-   happyDoAction j tk new_state-   where (off) = indexShortOffAddr happyGotoOffsets st-         (off_i) = (off Happy_GHC_Exts.+# nt)-         (new_state) = indexShortOffAddr happyTable off_i------------------------------------------------------------------------------------- Error recovery (0# is the error token)---- parse error if we are in recovery and we fail again-happyFail 0# tk old_st _ stk@(x `HappyStk` _) =-     let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in---	trace "failing" $ -        happyError_ i tk--{-  We don't need state discarding for our restricted implementation of-    "error".  In fact, it can cause some bogus parses, so I've disabled it-    for now --SDM---- discard a state-happyFail  0# tk old_st (HappyCons ((action)) (sts)) -						(saved_tok `HappyStk` _ `HappyStk` stk) =---	trace ("discarding state, depth " ++ show (length stk))  $-	happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))--}---- Enter error recovery: generate an error token,---                       save the old token and carry on.-happyFail  i tk (action) sts stk =---      trace "entering error recovery" $-	happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk)---- Internal happy errors:--notHappyAtAll :: a-notHappyAtAll = error "Internal Happy error\n"---------------------------------------------------------------------------------- Hack to get the typechecker to accept our action functions---happyTcHack :: Happy_GHC_Exts.Int# -> a -> a-happyTcHack x y = y-{-# INLINE happyTcHack #-}----------------------------------------------------------------------------------- Seq-ing.  If the --strict flag is given, then Happy emits ---	happySeq = happyDoSeq--- otherwise it emits--- 	happySeq = happyDontSeq--happyDoSeq, happyDontSeq :: a -> b -> b-happyDoSeq   a b = a `seq` b-happyDontSeq a b = b---------------------------------------------------------------------------------- Don't inline any functions from the template.  GHC has a nasty habit--- of deciding to inline happyGoto everywhere, which increases the size of--- the generated parser quite a bit.---{-# NOINLINE happyDoAction #-}-{-# NOINLINE happyTable #-}-{-# NOINLINE happyCheck #-}-{-# NOINLINE happyActOffsets #-}-{-# NOINLINE happyGotoOffsets #-}-{-# NOINLINE happyDefActions #-}--{-# NOINLINE happyShift #-}-{-# NOINLINE happySpecReduce_0 #-}-{-# NOINLINE happySpecReduce_1 #-}-{-# NOINLINE happySpecReduce_2 #-}-{-# NOINLINE happySpecReduce_3 #-}-{-# NOINLINE happyReduce #-}-{-# NOINLINE happyMonadReduce #-}-{-# NOINLINE happyGoto #-}-{-# NOINLINE happyFail #-}---- end of Happy Template.
examples/BoolEqBool.cub view
@@ -7,36 +7,28 @@ notInj x y p = compUp Bool (not (not x)) x (not (not y)) y (notK x) (notK y) rem   where   rem : Id Bool (not (not x)) (not (not y))-  rem = cong Bool Bool not (not x) (not y) p+  rem = mapOnPath Bool Bool not (not x) (not y) p  notFiber : Bool -> U notFiber b = fiber Bool Bool not b -fstNotFiber : (b : Bool) -> notFiber b -> Bool-fstNotFiber b = fst Bool (\x -> Id Bool (not x) b)- eqNotFiber : (b : Bool) -> (v v' : notFiber b) ->-  Id Bool (fstNotFiber b v) (fstNotFiber b v') -> Id (notFiber b) v v'-eqNotFiber b = eqPropFam Bool (\x -> Id Bool (not x) b) rem-  where-  rem : propFam Bool (\x -> Id Bool (not x) b)-  rem = \x -> boolIsSet (not x) b+             Id Bool v.1 v'.1 -> Id (notFiber b) v v'+eqNotFiber b = eqPropFam Bool (\x -> Id Bool (not x) b)+                              (\x -> boolIsSet (not x) b)  sNot : (b : Bool) -> notFiber b-sNot b = pair (not b) (notK b)+sNot b = (not b, notK b)  tNot : (b : Bool) (v : notFiber b) -> Id (notFiber b) (sNot b) v tNot b v = eqNotFiber b (sNot b) v rem   where-  b' : Bool-  b' = fstNotFiber b v--  rem1 : Id Bool (not (not b)) (not b')-  rem1 = comp Bool (not (not b)) b (not b') (notK b)-         (inv Bool (not b') b (snd Bool (\x -> Id Bool (not x) b) v))+  rem1 : Id Bool (not (not b)) (not v.1)+  rem1 = comp Bool (not (not b)) b (not v.1) (notK b)+         (inv Bool (not v.1) b v.2) -  rem : Id Bool (not b) b'-  rem = notInj (not b) b' rem1+  rem : Id Bool (not b) v.1+  rem = notInj (not b) v.1 rem1  eqBoolBool : Id U Bool Bool eqBoolBool = equivEq Bool Bool not sNot tNot@@ -48,7 +40,7 @@ notEqBool = transport Bool Bool eqBoolBool  testBool : Bool-testBool = notEqBool (true)+testBool = notEqBool true  compEqBool : Id U Bool Bool compEqBool = comp U Bool Bool Bool eqBoolBool eqBoolBool@@ -72,13 +64,13 @@ monoid A = and A (A -> A -> A)  zm : (A : U) (m : monoid A) -> A-zm A m = fst A (\x -> A -> A -> A) m+zm A m = m.1  opm : (A : U) (m : monoid A) -> (A -> A -> A)-opm A m = snd A (\x -> A -> A -> A) m+opm A m = m.2  transm : (A B : U) -> Id U A B -> monoid A -> monoid B-transm = subst U monoid +transm = subst U monoid  transun : (A B : U) -> Id U A B -> (A -> A) -> (B -> B) transun = subst U (\X -> (X -> X))@@ -96,7 +88,7 @@ testF = transid false  monoidAndBool : monoid Bool-monoidAndBool = pair (true) andBool+monoidAndBool = (true, andBool)  mBool2 : monoid Bool mBool2 = transm Bool Bool eqBoolBool monoidAndBool@@ -138,3 +130,10 @@  testTT3 : Bool testTT3 = opBool3 true true++orBool : Bool -> Bool -> Bool+orBool = split true  -> \x -> true+               false -> \x -> x++testTT4 : Id Bool (orBool false true) (opBool3 false true)+testTT4 = refl Bool true
examples/Kraus.cub view
@@ -1,82 +1,51 @@-module Kraus where--import swapDisc-import testInh-import idempotent-import contr-import elimEquiv---- we encode the example of Nicolai Kraus--- for this we need the impredicative encoding of propositional truncation---- the type of pointed types--ptU : U-ptU = Sigma U (id U)---- if f : A -> B is an equivalence and f a = b then (A,a) and (B,b) are equal in ptU--lemPtEquiv : (A B : U) (f: A -> B) (ef: isEquiv A B f) -> (a:A) -> (b:B) -> (eab: Id B (f a) b) -> Id ptU (pair A a) (pair B b)-lemPtEquiv A = elimIsEquiv A P rem-  where-   P : (B:U) -> (A->B) -> U-   P B f = (a:A) -> (b:B) -> (eab: Id B (f a) b) -> Id ptU (pair A a) (pair B b)--   rem : P A (id A)-   rem = cong A ptU (\ x -> pair A x) ---- swap with zero--swZero : N -> N -> N-swZero = swapDisc N natDec zero--lemSwZero : (x:N) -> neg (Id N zero x) -> Id N (swZero x x) zero-lemSwZero x neqzx = idSwapDisc1 N natDec zero x neqzx--lem1SwZero : (x:N) -> neg (Id N zero x) -> isEquiv N N (swZero x)-lem1SwZero x neqzx = idemIsEquiv N (swZero x) (idemSwapDisc N natDec zero x neqzx)---- we deduce that (N,x) is equal to (N,0) for any x in N--homogeneous : (x:N) -> Id ptU (pair N x) (pair N zero)-homogeneous x = orElim (Id N zero x) (neg (Id N zero x)) (G x) rem1 rem (natDec zero x)- where-   G : N -> U-   G y = Id ptU (pair N y) (pair N zero)--   rem0 : G zero-   rem0 = refl ptU (pair N zero)--   rem : neg (Id N zero x) -> G x-   rem neqzx = lemPtEquiv N N (swZero x) (lem1SwZero x neqzx) x zero (lemSwZero x neqzx)--   rem1 : Id N zero x -> G x-   rem1 eqzx = subst N G zero x eqzx rem0---- the following type is a contractible, hence a proposition--sNzero : U-sNzero = singl ptU (pair N zero)  -- Sigma (Sigma U (id U)) (\ v -> Id ptU u (pair N zero))--propSNzero : prop sNzero-propSNzero = singlIsProp ptU (pair N zero)---- we have a map inhI N -> sNzero, with the notation of Nicolai Kraus--flifted : inhI N -> sNzero-flifted = inhrecI N sNzero propSNzero (\ x -> pair (pair N x) (homogeneous x))--Tmyst : inhI N -> U-Tmyst x = fst U (id U) (fst ptU (\ v -> Id ptU v (pair N zero)) (flifted x))--myst : (x: inhI N) -> Tmyst x-myst x = snd U (id U) (fst ptU (\ v -> Id ptU v (pair N zero)) (flifted x))--mystN : (n: N) -> Tmyst (incI N n)-mystN n = myst (incI N n)--propMyst : (n:N) -> Id N (myst (incI N n)) n-propMyst n = refl N n--testMyst : N -> N+module Kraus where
+
+import swapDisc
+import testInh
+
+-- we encode the example of Nicolai Kraus
+-- for this we need the impredicative encoding of propositional truncation
+
+-- swap with zero
+
+swZero : N -> N -> N
+swZero = swapF N eqN zero
+
+
+homogeneous : (x:N) -> Id ptU (N,x) (N,zero)
+homogeneous x = homogDec N eqN f0N f1N x zero
+
+-- test : (x:N) -> Id (Id ptU (N,x) (N,zero)) (homogeneous x) (homogeneous x)
+-- test x = refl (Id ptU (N,x) (N,zero)) (homogeneous x)
+
+-- the following type is a contractible, hence a proposition
+
+sNzero : U
+sNzero = singl ptU (N,zero)  -- Sigma (Sigma U (id U)) (\ v -> Id ptU u (N,zero))
+
+propSNzero : prop sNzero
+propSNzero = singlIsProp ptU (N,zero)
+
+-- we have a map inhI N -> sNzero, with the notation of Nicolai Kraus
+
+flifted : inhI N -> sNzero
+flifted = inhrecI N sNzero propSNzero (\ x -> ((N,x),homogeneous x))
+
+Tmyst : inhI N -> U
+Tmyst x = (flifted x).1.1
+
+opaque homogeneous
+
+myst : (x: inhI N) -> Tmyst x
+myst x = (flifted x).1.2
+
+transparent homogeneous
+
+mystN : (n: N) -> Tmyst (incI N n)
+mystN n = myst (incI N n)
+
+propMyst : (n:N) -> Id N (myst (incI N n)) n
+propMyst n = refl N n
+
+testMyst : N -> N
 testMyst n = myst (incI N n)
examples/UnotSet.cub view
@@ -17,7 +17,7 @@   fnot = transport Bool Bool eqBoolBool    lem1 : Id (Bool -> Bool) frefl fnot-  lem1 = cong (Id U Bool Bool) (Bool -> Bool) (transport Bool Bool) +  lem1 = mapOnPath (Id U Bool Bool) (Bool -> Bool) (transport Bool Bool)                (refl U Bool) eqBoolBool eqreflnot    lem2 : Id Bool true (frefl true)@@ -27,7 +27,7 @@   lem3 = transpEquivEq Bool Bool not sNot tNot true    lem4 : Id Bool (frefl true) (fnot true)-  lem4 = cong (Bool -> Bool) Bool (\f -> f true) frefl fnot lem1+  lem4 = mapOnPath (Bool -> Bool) Bool (\f -> f true) frefl fnot lem1    lem5 : Id Bool true false   lem5 = compDown Bool true (frefl true) false (fnot true) lem2 lem3 lem4
examples/axChoice.cub view
@@ -15,30 +15,16 @@   T1 = Sigma ((x:A) -> B x) (\ f -> (x:A) -> C x (f x))    f : T0 -> T1-  f = \ s -> pair (\ x -> fst (B x) (C x) (s x)) (\ x -> snd (B x) (C x) (s x))+  f s = (\ x -> (s x).1, \ x -> (s x).2)    g : T1 -> T0-  g = split-       pair u v -> \ x -> pair (u x) (v x)+  g z = \ x -> (z.1 x, z.2 x)    sfg : (y:T1) -> Id T1 (f (g y)) y-  sfg = split-         pair u v -> rem u v -           where-             rem2 : (u:Pi A B) (v:(x:A) -> C x (u x)) -> Id T1 (pair (\ x -> u x) (\ x -> v x)) (pair (\ x -> u x) (\ x -> v x))-             rem2 u v = refl T1 (pair (\ x -> u x) (\ x -> v x))--             rem1 : (u:Pi A B) (v:(x:A) -> C x (u x)) -> Id T1 (pair (\ x -> u x) (\ x -> v x)) (pair (\ x -> u x) v)-             rem1 u = funSplit A (\ x -> C x (u x)) (\ v -> Id T1 (pair (\ x -> u x) (\ x -> v x)) (pair (\ x -> u x) v)) (rem2 u)--             rem : (u:Pi A B) (v:(x:A) -> C x (u x)) -> Id T1 (pair (\ x -> u x) (\ x -> v x)) (pair u v)-             rem = funSplit A B (\ u -> (v:(x:A) -> C x (u x)) -> Id T1 (pair (\ x -> u x) (\ x -> v x)) (pair u v)) rem1+  sfg z = refl T1 z -- rem2 u v     rfg : (s:T0) -> Id T0 (g (f s)) s-  rfg s = funExt A (\ x ->  Sigma (B x) (C x)) (g (f s)) s rem-    where-      rem : (x:A) -> Id (Sigma (B x) (C x)) (pair (fst (B x) (C x) (s x)) (snd (B x) (C x) (s x))) (s x)-      rem x = surjPair (B x) (C x) (s x)+  rfg s = refl T0 s  -- we deduce from this equality that isEquiv f is a proposition
examples/cong.cub view
@@ -3,27 +3,27 @@ import set import function --- All of these lemmas on cong will be trivial with definitional equalities+-- All of these lemmas on mapOnPath will be trivial with definitional equalities  congRefl : (A B : U) (f : A -> B) (a : A) -> -           Id (Id B (f a) (f a)) (refl B (f a)) (cong A B f a a (refl A a))-congRefl A B f a = Jeq A a (\v p -> Id B (f a) (f v)) (refl B (f a))+           Id (Id B (f a) (f a)) (refl B (f a)) (mapOnPath A B f a a (refl A a))+congRefl A B f a = refl (Id B (f a) (f a)) (refl B (f a))  congId : (A : U) (a0 a1 : A) -> -         Id (Id A a0 a1 -> Id A a0 a1) (id (Id A a0 a1)) (cong A A (id A) a0 a1)+         Id (Id A a0 a1 -> Id A a0 a1) (id (Id A a0 a1)) (mapOnPath A A (id A) a0 a1) congId A a0 a1 = funExt (Id A a0 a1) (\_ -> Id A a0 a1) (id (Id A a0 a1)) -                        (cong A A (id A) a0 a1) (rem a0 a1)+                        (mapOnPath A A (id A) a0 a1) (rem a0 a1)   where-  rem1 : (u : A) -> Id (Id A u u) (refl A u) (cong A A (id A) u u (refl A u))+  rem1 : (u : A) -> Id (Id A u u) (refl A u) (mapOnPath A A (id A) u u (refl A u))   rem1 = congRefl A A (id A) -  rem : (u0 u1 : A) -> (p : Id A u0 u1) -> Id (Id A u0 u1) p (cong A A (id A) u0 u1 p) -  rem u0 = J A u0 (\u1 p -> Id (Id A u0 u1) p (cong A A (id A) u0 u1 p)) (rem1 u0)+  rem : (u0 u1 : A) -> (p : Id A u0 u1) -> Id (Id A u0 u1) p (mapOnPath A A (id A) u0 u1 p) +  rem u0 = J A u0 (\u1 p -> Id (Id A u0 u1) p (mapOnPath A A (id A) u0 u1 p)) (rem1 u0)  congComp : (A B C : U) (f : A -> B) (g : B -> C) (a0 a1 : A) ->             Id (Id A a0 a1 -> Id C (g (f a0)) (g (f a1))) -              (cong A C (\x -> g (f x)) a0 a1)-              (\p -> cong B C g (f a0) (f a1) (cong A B f a0 a1 p))+              (mapOnPath A C (\x -> g (f x)) a0 a1)+              (\p -> mapOnPath B C g (f a0) (f a1) (mapOnPath A B f a0 a1 p)) congComp A B C f g a0 a1 = funExt (Id A a0 a1) (\_ -> Tgf a0 a1)                                   (conggf a0 a1) (\p -> congg a0 a1 (congf a0 a1 p)) (rem a0 a1)   where@@ -31,13 +31,13 @@   Tgf a0 a1 = Id C (g (f a0)) (g (f a1))    congf : (a0 a1 : A) -> Id A a0 a1 -> Id B (f a0) (f a1)-  congf = cong A B f+  congf = mapOnPath A B f      congg : (a0 a1 : A) -> Id B (f a0) (f a1) -> Tgf a0 a1-  congg a0 a1 = cong B C g (f a0) (f a1)+  congg a0 a1 = mapOnPath B C g (f a0) (f a1)    conggf : (a0 a1 : A) -> Id A a0 a1 -> Tgf a0 a1-  conggf = cong A C (\x -> g (f x))+  conggf = mapOnPath A C (\x -> g (f x))    rem : (a0 a1 : A) (p : Id A a0 a1) ->          Id (Tgf a0 a1) (conggf a0 a1 p) (congg a0 a1 (congf a0 a1 p))@@ -51,7 +51,7 @@     rem4 = congRefl A B f a      rem3 : Id (Tgf a a) (congg a a (refl B (f a))) (congg a a (congf a a (refl A a)))-    rem3 = cong (Id B (f a) (f a)) (Tgf a a) (congg a a) (refl B (f a)) +    rem3 = mapOnPath (Id B (f a) (f a)) (Tgf a a) (congg a a) (refl B (f a))                  (congf a a (refl A a)) rem4      rem5 : Id (Tgf a a) (refl C (g (f a))) (congg a a (refl B (f a)))@@ -62,21 +62,4 @@                               (congg a a (refl B (f a))) (congg a a (congf a a (refl A a)))                     rem2 rem3 rem5 --- a lemma about injective function--lemInj : (A B : U) (f : A -> B) -> (injf : injective A B f)-              -> ((x:A) -> Id (Id A x x) (refl A x) (injf x x (refl B (f x))))-              -> (x y : A) -> (p:Id A x y) -> Id (Id A x y) p (injf x y (cong A B f x y p))-lemInj A B f injf h x = - J A x (\ y p -> Id (Id A x y) p (injf x y (cong A B f x y p))) rem- where-  rem1 : Id (Id A x x) (refl A x) (injf x x (refl B (f x)))-  rem1 = h x--  rem2 : Id (Id A x x) (injf x x (refl B (f x))) (injf x x (cong A B f x x (refl A x)))-  rem2 = cong (Id B (f x) (f x)) (Id A x x) (injf x x) (refl B (f x)) (cong A B f x x (refl A x)) (congRefl A B f x)--  rem : Id (Id A x x) (refl A x) (injf x x (cong A B f x x (refl A x)))-  rem = comp (Id A x x) (refl A x) (injf x x (refl B (f x))) (injf x x (cong A B f x x (refl A x)))-             rem1 rem2
examples/contr.cub view
@@ -27,11 +27,10 @@ -- this implies the other definition  isContr : (A:U) -> contr' A -> contr A-isContr A = split-             pair a f -> rem a f-               where -                  rem : (a:A) -> ((x:A) -> Id A a x) -> contr A-                  rem a f = propContr A a (\ a0 a1 -> compInv A a a0 a1 (f a0) (f a1))+isContr A z = rem z.1 z.2+  where +    rem : (a:A) -> ((x:A) -> Id A a x) -> contr A+    rem a f = propContr A a (\ a0 a1 -> compInv A a a0 a1 (f a0) (f a1))  isContrProd : (A:U) (B:A->U) -> ((x:A) -> contr (B x)) -> contr (Pi A B) isContrProd A B pB = subst U contr (A->Unit) (Pi A B) rem1 rem2@@ -40,7 +39,7 @@    rem = funExt A (\ _ -> U) (\ _ -> Unit) B pB     rem1 : Id U (A -> Unit) (Pi A B)-   rem1 = cong (A -> U) U (Pi A)  (\ _ -> Unit) B rem+   rem1 = mapOnPath (A -> U) U (Pi A)  (\ _ -> Unit) B rem     f : Unit -> A -> Unit    f z a = tt@@ -60,25 +59,23 @@ -- a sigma of props over a prop is a prop  sigIsProp : (A:U) (B:A->U) (pB : (x:A) -> prop (B x)) -> prop A -> prop (Sigma A B)-sigIsProp A B pB pA =- split-  pair a0 b0 -> split-                 pair a1 b1 -> eqSigma A B a0 a1 (pA a0 a1) b0 b1 (pB a1 (subst A B a0 a1 (pA a0 a1) b0) b1)+sigIsProp A B pB pA u v =+  eqSigma A B u.1 v.1 (pA u.1 v.1) u.2 v.2+          (pB v.1 (subst A B u.1 v.1 (pA u.1 v.1) u.2) v.2)  contr'IsProp : (A : U) -> prop (contr' A) contr'IsProp A = lemProp1 (contr' A) rem  where rem : contr' A -> prop (contr' A)-       rem = split-              pair a p -> sigIsProp A (\ a0 -> (x:A) -> Id A a0 x) rem3 rem1 -                where-                 rem1 : prop A-                 rem1 a0 a1 = compInv A a a0 a1 (p a0) (p a1)+       rem z = sigIsProp A (\ a0 -> (x:A) -> Id A a0 x) rem3 rem1 +         where+           rem1 : prop A+           rem1 a0 a1 = compInv A z.1 a0 a1 (z.2 a0) (z.2 a1) -                 rem2 : (a0 a1:A) -> prop (Id A a0 a1)-                 rem2 = propUIP A rem1+           rem2 : (a0 a1:A) -> prop (Id A a0 a1)+           rem2 = propUIP A rem1 -                 rem3 : (a0:A) -> prop ((x:A) -> Id A a0 x)-                 rem3 a0 = isPropProd A (Id A a0) (rem2 a0) +           rem3 : (a0:A) -> prop ((x:A) -> Id A a0 x)+           rem3 a0 = isPropProd A (Id A a0) (rem2 a0)   -- Voevodsky's definition of propositions @@ -102,39 +99,34 @@     F = P tt      f : T -> F-    f = split-         pair x u -> rem x u+    f z = rem z.1 z.2           where rem : (x:Unit) -> P x -> P tt-                rem = split-                       tt -> \ u -> u+                rem = split tt -> \ u -> u      g : F -> T-    g u = pair tt u+    g u = (tt, u)      rfg : (v:F) -> Id F (f (g v)) v     rfg v = refl F v      sfg : (v:T) -> Id T (g (f v)) v-    sfg = split-           pair x u -> rem x u-            where rem : (x:Unit) -> (u : P x) -> Id T (g (f (pair x u))) (pair x u)-                  rem = split-                         tt -> \ u -> refl T (pair tt u)+    sfg z = rem z.1 z.2+      where rem : (x:Unit) -> (u : P x) -> Id T (g (f (x, u))) (x, u)+            rem = split tt -> \ u -> refl T (tt, u)  lemContrSig : (A:U) -> contr A -> hasContrSig A lemContrSig A p = subst U hasContrSig Unit A p lemUnitSig  singContr : (A:U) (a:A) -> contr (singl A a)-singContr A a = isContr T (pair (pair a (refl A a)) f)+singContr A a = isContr T ((a, refl A a), f)  where T : U         T = singl A a   -       f : (z:T) -> Id T (pair a (refl A a)) z-       f = split-            pair b p -> rem b a p+       f : (z:T) -> Id T (a, refl A a) z+       f z = rem z.1 a z.2              where -               rem : (b:A) (a:A) (p:Id A b a) -> Id (singl A a) (pair a (refl A a)) (pair b p)-               rem b = J A b (\ a p ->  Id (singl A a) (pair a (refl A a)) (pair b p)) (refl (singl A b) (pair b (refl A b)))+               rem : (b:A) (a:A) (p:Id A b a) -> Id (singl A a) (a, refl A a) (b, p)+               rem b = J A b (\ a p ->  Id (singl A a) (a, refl A a) (b, p)) (refl (singl A b) (b, refl A b))    -- any function between two contractible types is an equivalence
examples/curry.cub view
@@ -3,37 +3,19 @@ import swap  curry : (A B C:U) -> ((and A B) -> C) -> A -> B -> C-curry A B C f a b = f (pair a b)+curry A B C f a b = f (a,b)  uncurry : (A B C:U) -> (A -> B -> C) -> (and A B) -> C-uncurry A B C g = split-                    pair a b -> g a b--secCurry : (A B C :U) (f : (and A B) -> C) -            -> Id ((and A B) -> C) (uncurry A B C (curry A B C f)) f-secCurry A B C f = funExt (and A B) (\ _ -> C) (uncurry A B C (curry A B C f)) f rem- where -  rem : (z:and A B) -> Id C (uncurry A B C (curry A B C f) z) (f z)-  rem = split-         pair a b -> refl C (f (pair a b))--retCurry : (A B C :U) (g : A -> B -> C)-            -> Id (A -> B -> C) (curry A B C (uncurry A B C g)) g-retCurry A B C g = funExt A (\ _ -> B -> C) (curry A B C (uncurry A B C g)) g rem- where -  rem : (a:A) -> Id (B -> C) (curry A B C (uncurry A B C g) a) (g a)-  rem a = funExt B (\ _ -> C) (curry A B C (uncurry A B C g) a) (g a) rem1-     where-       rem1 : (b:B) -> Id C (curry A B C (uncurry A B C g) a b) (g a b)-       rem1 b = refl C (g a b)-+uncurry A B C g z = g z.1 z.2  eqCurry : (A B C : U) -> Id U ((and A B) -> C) (A -> B -> C)-eqCurry A B C = isEquivEq ((and A B) -> C) (A -> B -> C) (curry A B C) rem+eqCurry A B C =+ isEquivEq T V (curry A B C) (gradLemma T V (curry A B C) (uncurry A B C) (refl V) (refl T))   where-   rem : isEquiv ((and A B) -> C) (A -> B -> C) (curry A B C) -   rem =  gradLemma ((and A B) -> C) (A -> B -> C) -                 (curry A B C) (uncurry A B C) (retCurry A B C) (secCurry A B C) +   T:U+   T = (and A B) -> C+   V : U+   V = A -> B -> C  typFst : U typFst = (X Y:U) -> (and X Y) -> X@@ -41,11 +23,10 @@ typFst1 : U typFst1 = (X Y:U) -> X -> Y -> X - eqTest : Id U typFst typFst1 eqTest = eqPi U  (\ X -> Pi U (\ Y -> (and X Y) -> X)) (\ X -> Pi U (\ Y -> X -> Y -> X)) rem- where -  rem : (X:U) -> Id U (Pi U (\ Y -> (and X Y) -> X)) (Pi U (\ Y -> X -> Y -> X)) + where+  rem : (X:U) -> Id U (Pi U (\ Y -> (and X Y) -> X)) (Pi U (\ Y -> X -> Y -> X))   rem X = eqPi U (\ Y -> (and X Y) -> X) (\ Y -> X -> Y -> X) rem1     where      rem1 : (Y:U) -> Id U ((and X Y) -> X) (X -> Y -> X)@@ -57,18 +38,18 @@ test : N test =  transport typFst typFst1-  eqTest (\ X Y -> (fst X (\ _ -> Y))) N Bool zero true-      +  eqTest (\ X Y z -> z.1) N Bool zero true+ test1 : N test1 =  transport typFst typFst1-  eqTest (\ X Y -> (fst X (\ _ -> Y))) N Bool (suc zero) false+  eqTest (\ X Y z -> z.1) N Bool (suc zero) false  test2 : N-test2 = +test2 =  transport typFst1 typFst-  eqTestInv (\ X Y a b -> a) N Bool (pair zero true)-      +  eqTestInv (\ X Y a b -> a) N Bool (zero,true)+ -- more test for the equality in U  eqTest2 : Id U typFst typFst@@ -83,17 +64,17 @@ test4 : N test4 =  transport typFst typFst-  eqTest2 (\ X Y -> (fst X (\ _ -> Y))) N Bool (pair (suc zero) false)+  eqTest2 (\ X Y z -> z.1) N Bool (suc zero,false)  test5 : N test5 =  transport typFst typFst1-  eqTest3 (\ X Y -> (fst X (\ _ -> Y))) N Bool (suc zero) false+  eqTest3 (\ X Y z -> z.1) N Bool (suc zero) false  test6 : N test6 =  transport typFst typFst-  eqTest4 (\ X Y -> (fst X (\ _ -> Y))) N Bool (pair (suc zero) false)+  eqTest4 (\ X Y z -> z.1) N Bool (suc zero,false)
examples/description.cub view
@@ -4,25 +4,20 @@ import set  exAtOne : (A : U) (B : A -> U) -> exactOne A B -> atmostOne A B-exAtOne A B = split-  pair g h' -> h'+exAtOne A B z = z.2  propSig : (A : U) (B : A -> U) -> propFam A B -> atmostOne A B ->           prop (Sigma A B)-propSig A B h h' au bv =-  eqPropFam A B h au bv (h' (fst A B au) (fst A B bv) (snd A B au) (snd A B bv))+propSig A B h h' au bv = eqPropFam A B h au bv (h' au.1 bv.1 au.2 bv.2)  descrAx : (A : U) (B : A -> U) -> propFam A B -> exactOne A B -> Sigma A B-descrAx A B h = split-  pair g h' -> lemInh (Sigma A B) rem g-  where rem : prop (Sigma A B)-        rem = propSig A B h h'+descrAx A B h z = lemInh (Sigma A B) (propSig A B h z.2) z.1  iota : (A : U) (B : A -> U) (h : propFam A B) (h' : exactOne A B) -> A-iota A B h h' = fst A B (descrAx A B h h')+iota A B h h' = (descrAx A B h h').1  iotaSound : (A : U) (B : A -> U) (h : propFam A B) (h' : exactOne A B) -> B (iota A B h h')-iotaSound A B h h' = snd A B (descrAx A B h h')+iotaSound A B h h' = (descrAx A B h h').2  iotaLem : (A : U) (B : A -> U) (h : propFam A B) (h' : exactOne A B) ->           (a : A) -> B a -> Id A a (iota A B h h')
examples/elimEquiv.cub view
@@ -14,7 +14,7 @@  elimIsEquiv : (A:U) -> (P : (B:U) -> (A->B) -> U) -> P A (id A) ->                (B :U) -> (f : A -> B) -> isEquiv A B f -> P B f-elimIsEquiv A P d = \ B f if -> rem2 B (pair f if)+elimIsEquiv A P d B f if = rem2 B (f,if)  where    rem1 : P A (transport A A (refl U A))   rem1 = subst (A->A) (P A) (id A) (transport A A (refl U A)) (transpRef A) d@@ -22,6 +22,6 @@   rem : (B:U) -> (p:Id U A B) -> P B (transport A B p)   rem = J U A (\ B p ->  P B (transport A B p)) rem1 -  rem2 : (B:U) -> (p:Equiv A B) -> P B (funEquiv A B p)-  rem2 B = allSection (Id U A B) (Equiv A B) (IdToEquiv A B) (allTransp A B) (\ p -> P B (funEquiv A B p)) (rem B)+  rem2 : (B:U) -> (p:Equiv A B) -> P B p.1+  rem2 B = allSection (Id U A B) (Equiv A B) (IdToEquiv A B) (allTransp A B) (\ p -> P B p.1) (rem B)
examples/epi.cub view
@@ -3,6 +3,7 @@ module epi where  import omega+import exists  -- surjective and epi maps @@ -10,7 +11,7 @@ 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  isSurj : (A B:U) -> (A->B) -> U-isSurj A B f = (y:B) -> exist A (\ x -> Id B (f x) y)+isSurj A B f = (y:B) -> exists A (\ x -> Id B (f x) y)  -- these properties should be equivalent @@ -26,7 +27,7 @@      rem1 : prop G      rem1 = sX (g y) (h y) -     rem2 : exist A (\ x -> Id B (f x) y)+     rem2 : exists A (\ x -> Id B (f x) y)      rem2 = sf y       rem4 : (x:A) -> Id X (g (f x)) (h (f x))@@ -36,8 +37,7 @@      rem3 x p = subst B (\ z -> Id X (g z) (h z)) (f x) y p (rem4 x)       rem5 : (Sigma A (\ x -> Id B (f x) y)) -> G-     rem5 = split-             pair x p -> rem3 x p+     rem5 z = rem3 z.1 z.2       rem6 : G      rem6 = exElim A (\ x -> Id B (f x) y) G rem1 rem5 rem2@@ -51,13 +51,13 @@    rem = ef Omega omegaIsSet     g : B -> Omega-   g y = pair Unit propUnit+   g y = (Unit,propUnit)     h : B -> Omega-   h y = pair (exist A (\ x -> Id B (f x) y)) (squash (Sigma A (\ x -> Id B (f x) y)))+   h y =  (exists A (\ x -> Id B (f x) y),squash (Sigma A (\ x -> Id B (f x) y)))     rem1 : (x:A) -> isTrue (h (f x))-   rem1 x = inc (Sigma A (\ z -> Id B (f z) (f x))) (pair x (refl B (f x)))+   rem1 x = inc (Sigma A (\ z -> Id B (f z) (f x))) (x,refl B (f x))     rem2 : (x:A) -> Id Omega (g (f x)) (h (f x))    rem2 x = lemIsTrue (g (f x)) (h (f x)) (\ _ -> rem1 x) (\ _ -> tt)
examples/equivSet.cub view
@@ -13,25 +13,22 @@   fFiber : B -> U
   fFiber b = fiber A B f b
 
-  fstfFiber : (b : B) -> fFiber b -> A
-  fstfFiber b = fst A (\x -> Id B (f x) b)
-
   eqfFiber : (b : B) -> (v v' : fFiber b) ->
-             Id A (fstfFiber b v) (fstfFiber b v') -> Id (fFiber b) v v'
+             Id A v.1 v'.1 -> Id (fFiber b) v v'
   eqfFiber b = eqPropFam A (\x -> Id B (f x) b) (\x -> setB (f x) b)
 
   sf : (b : B) -> fFiber b
-  sf b = pair (g b) (sfg b)
+  sf b = (g b, sfg b)
 
   tf : (b : B) (v : fFiber b) -> Id (fFiber b) (sf b) v
   tf b v = eqfFiber b (sf b) v rem
     where
     a' : A
-    a' = fstfFiber b v
+    a' = v.1
 
     rem1 : Id B (f (g b)) (f a')
     rem1 = comp B (f (g b)) b (f a') (sfg b)
-           (inv B (f a') b (snd A (\x -> Id B (f x) b) v))
+           (inv B (f a') b v.2)
 
     rem : Id A (g b) a'
     rem = injf (g b) a' rem1
examples/equivTotal.cub view
@@ -4,11 +4,8 @@  -- equivalence on total space -lem3Sub : (A:U) (P: A -> U) (a:A) -> Id U (Sigma (singl A a) (\ z -> P (fst A (\ x -> Id A x a) z))) (P a)-lem3Sub A P a = lemContrSig (singl A a) (singContr A a) Q (pair a (refl A a))- where-   Q : singl A a -> U-   Q z = P (fst A (\ x -> Id A x a) z)+lem3Sub : (A:U) (P: A -> U) (a:A) -> Id U (Sigma (singl A a) (\ z -> P z.1)) (P a)+lem3Sub A P a = lemContrSig (singl A a) (singContr A a) (\ x -> P x.1) (a,refl A a)  -- a corollary of equivalence @@ -22,7 +19,7 @@  elimIsEquiv : (A:U) -> (P : (B:U) -> (A->B) -> U) -> P A (id A) ->                (B :U) -> (f : A -> B) -> isEquiv A B f -> P B f-elimIsEquiv A P d = \ B f if -> rem2 B (pair f if)+elimIsEquiv A P d = \ B f if -> rem2 B (f,if)  where    rem1 : P A (transport A A (refl U A))   rem1 = subst (A->A) (P A) (id A) (transport A A (refl U A)) (transpRef A) d@@ -30,100 +27,56 @@   rem : (B:U) -> (p:Id U A B) -> P B (transport A B p)   rem = J U A (\ B p ->  P B (transport A B p)) rem1 -  rem2 : (B:U) -> (p:Equiv A B) -> P B (funEquiv A B p)-  rem2 B = allSection (Id U A B) (Equiv A B) (IdToEquiv A B) (allTransp A B) (\ p -> P B (funEquiv A B p)) (rem B)+  rem2 : (B:U) -> (p:Equiv A B) -> P B p.1+  rem2 B = allSection (Id U A B) (Equiv A B) (IdToEquiv A B) (allTransp A B) +                (\ p -> P B p.1) (rem B) --- a simple application; with yet another problem with eta conversion+-- a simple application; with the problem with eta conversion resolved -equivSigId : (A B :U) -> (f:A -> B) -> isEquiv A B f -> (Q : B -> U) -> Id U (Sigma A (\ x -> Q (f x))) (Sigma B Q)-equivSigId A = elimIsEquiv A P d+equivSigId : (A B :U) (f:A -> B) +         -> isEquiv A B f -> (Q : B -> U) -> Id U (Sigma A (\ x -> Q (f x))) (Sigma B Q)+equivSigId A = elimIsEquiv A P (\ Q -> refl U (Sigma A Q))  where     P : (B:U) -> (A-> B) -> U    P B f =  (Q : B -> U) -> Id U (Sigma A (\ x -> Q (f x))) (Sigma B Q) -   d : P A (id A)-   d Q = rem-      where-         rem : Id U (Sigma A (\ x -> Q x)) (Sigma A Q)-         rem = cong (A -> U) U (Sigma A) (\ x -> Q x) Q (funExt A (\ _ -> U) (\ x -> Q x) Q (\ x -> refl U (Q x)))- -- application to equivalences between total spaces  liftTot :  (A:U) (P Q : A -> U) (g : (x:A) -> P x -> Q x) -> Sigma A P -> Sigma A Q-liftTot A P Q g = split-                  pair a u -> pair a (g a u)--lem3Sub : (A:U) (P: A -> U) (a:A) -> Id U (Sigma (singl A a) (\ z -> P (fst A (\ x -> Id A x a) z))) (P a)-lem3Sub A P a = lemContrSig (singl A a) (singContr A a) Q (pair a (refl A a))- where-   Q : singl A a -> U-   Q z = P (fst A (\ x -> Id A x a) z)+liftTot A P Q g z = (z.1,g z.1 z.2) +lem3Sub : (A:U) (P: A -> U) (a:A) -> Id U (Sigma (singl A a) (\ z -> P z.1)) (P a)+lem3Sub A P a = lemContrSig (singl A a) (singContr A a) (\ x -> P x.1) (a,refl A a) -lem2Sub : (A:U) (P: A -> U) (a:A) -> Id U (fiber (Sigma A P) A (fst A P) a) -                                          (Sigma (Sigma A (\ x -> Id A x a)) (\ z -> P (fst A (\ x -> Id A x a) z)))-lem2Sub A P a = isoId F T f g sfg rfg- where+lem2Sub : (A:U) (P: A -> U) (a:A) +         -> Id U (fiber (Sigma A P) A (\x -> x.1) a) +                 (Sigma (Sigma A (\ x -> Id A x a)) (\ z -> P z.1))+lem2Sub A P a = + 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)+  where    T : U-   T = Sigma (Sigma A (\ x -> Id A x a)) (\ z -> P (fst A (\ x -> Id A x a) z))+   T = Sigma (Sigma A (\ x -> Id A x a)) (\ z -> P z.1)     F : U-   F = fiber (Sigma A P) A (fst A P) a--   f : F -> T-   f = split-        pair z p -> rem z p -          where rem : (z : Sigma A P) (p : Id A (fst A P z) a) -> T-                rem = split-                      pair x u -> \ p -> pair (pair x p) u--   g : T -> F-   g = split-        pair z u -> rem z u-          where rem : (z: Sigma A (\x -> Id A x a)) -> (u: P (fst A (\ x -> Id A x a) z)) -> fiber (Sigma A P) A (fst A P) a-                rem = split-                        pair x p -> \ u -> pair (pair x u) p--   rfg : (v :F) -> Id F (g (f v)) v-   rfg = split-          pair z p -> rem z p-           where rem : (z : Sigma A P) (p : Id A (fst A P z) a) -> Id (fiber (Sigma A P) A (fst A P) a) (g (f (pair z p))) (pair z p)-                 rem = split-                        pair x u -> \ p -> refl F (pair (pair x u) p)--   sfg : (v:T) -> Id T (f (g v)) v-   sfg = split-          pair z u -> rem z u-            where rem : (z: Sigma A (\x -> Id A x a)) -> (u: P (fst A (\ x -> Id A x a) z)) -> Id T (f (g (pair z u))) (pair z u)-                  rem = split-                        pair x p -> \ u -> refl T (pair (pair x p) u)+   F = fiber (Sigma A P) A (\x -> x.1) a -lem1Sub : (A:U) (P: A -> U) (a:A) -> Id U (fiber (Sigma A P) A (fst A P) a) (P a)+lem1Sub : (A:U) (P: A -> U) (a:A) -> Id U (fiber (Sigma A P) A (\ z -> z.1) a) (P a) lem1Sub A P a =- comp U (fiber (Sigma A P) A (fst A P) a) (Sigma (singl A a) (\ z -> P (fst A (\ x -> Id A x a) z))) (P a)-     (lem2Sub A P a) (lem3Sub A P a)---- retsub : (A:U) -> (P : subset2 A) -> Id (subset2 A) (sub12 A (sub21 A P)) P--- retsub A P = funExt A (\ _ -> U) (fiber (Sigma A P) A (fst A P)) P (lem1Sub A P)------+ comp U (fiber (Sigma A P) A (\ x -> x.1) a) +        (Sigma (singl A a) (\ z -> P z.1)) (P a) (lem2Sub A P a) (lem3Sub A P a)  equivTot : (A:U) (P Q : A -> U) (g : (x:A) -> P x -> Q x) ->            isEquiv (Sigma A P) (Sigma A Q) (liftTot A P Q g) -> (a:A) -> Id U (P a) (Q a) equivTot A P Q g igl a = rem5  where   F : Sigma A P -> U-  F z = Id A (fst A P z) a+  F z = Id A z.1 a    T : U   T = Sigma (Sigma A P) F    G : Sigma A Q -> U-  G z = Id A (fst A Q z) a+  G z = Id A z.1 a    V : U   V = Sigma (Sigma A Q) G@@ -144,10 +97,9 @@   rem2 = equivSigId (Sigma A P) (Sigma A Q) (liftTot A P Q g) igl G    rem3 : Id U T T1-  rem3 = cong (Sigma A P -> U) U (Sigma (Sigma A P)) F F1 eFF1+  rem3 = mapOnPath (Sigma A P -> U) U (Sigma (Sigma A P)) F F1 eFF1       where fFF1 : (z : Sigma A P) -> Id U (F z) (F1 z)-            fFF1 = split-                    pair x u -> refl U (Id A x a)+            fFF1 z = refl U (Id A z.1 a)              eFF1 : Id (Sigma A P -> U) F F1             eFF1 = funExt (Sigma A P) (\ _ -> U) F F1 fFF1@@ -190,7 +142,7 @@   T = Pi A B    G : (z:Pi A B) -> P z -> Q z-  G z ez x = cong (Pi A B) (B x) (\ u -> u x) z g ez+  G z ez x = mapOnPath (Pi A B) (B x) (\ u -> u x) z g ez    rem1 : contr (Sigma T P)   rem1 = singContr (Pi A B) g
examples/finite.cub view
@@ -1,11 +1,11 @@ module finite where --- definition of finite sets and cardinality +-- definition of finite sets and cardinality  import description-import function +import function import gradLemma-import Kraus+import swapDisc_old  step : U -> U step X = or Unit X@@ -41,17 +41,17 @@        inr _ -> Unit  decSt : (X:U) -> discrete X -> discrete (step X)-decSt X dX =  +decSt X dX =  split   inl a -> split-            inl a1 -> inl (cong Unit (step X) (incUnSt X) a a1 (propUnit a a1))+            inl a1 -> inl (mapOnPath Unit (step X) (incUnSt X) a a1 (propUnit a a1))             inr b -> inr (inlNotinr Unit X a b)   inr b -> split             inl a -> inr (inrNotinl Unit X a b)             inr b1 -> rem (dX b b1)                where rem : dec (Id X b b1) -> dec (Id (step X) (inr b) (inr b1))                      rem = split-                            inl p -> inl (cong X (step X) (incSt X) b b1 p)+                            inl p -> inl (mapOnPath X (step X) (incSt X) b b1 p)                             inr h -> inr (\ p -> h (injSt X b b1 p))  stFin : N -> U@@ -78,15 +78,12 @@   rfg : (x:X) -> Id X (f (g x)) x   rfg x = refl X x -  ef : isEquiv (or X N0) X f +  ef : isEquiv (or X N0) X f   ef = gradLemma (or X N0) X f g rfg sfg -- N0Dec : discrete N0 N0Dec = \ x y -> efq (dec (Id N0 x y)) x - finDec : (n:N) -> discrete (stFin n) finDec = split           zero -> N0Dec@@ -97,124 +94,125 @@            tt -> split                   tt -> inl (refl Unit tt) --isolated : (A:U) -> A -> U-isolated A a = (x:A) -> dec (Id A a x)- -- take away one element  takeAway : (A:U) -> A -> U takeAway A a = Sigma A (\ x -> neg (Id A a x))  tAway : ptU -> U-tAway = split-         pair A a -> takeAway A a+tAway z = takeAway z.1 z.2 -botEl : (n:N) -> stFin (suc n)-botEl n = inl tt+-- this has been generalized from a special case -eqTkA : (n:N) -> Id U (takeAway (stFin (suc n)) (botEl n)) (stFin n)-eqTkA n = isEquivEq tS (stFin n) f equivf+eqTkA : (X:U) -> Id U (takeAway (step X) (inl tt)) X+eqTkA X = isEquivEq tS X f equivf  where    stS : U-   stS = stFin (suc n)+   stS = step X     bn : stS-   bn = botEl n+   bn = inl tt     tS : U    tS = takeAway stS bn -   faux : (x:stS) -> neg (Id stS bn x) -> stFin n+   faux : (x:stS) -> neg (Id stS bn x) -> X    faux = split-            inl u -> \ h -> efq (stFin n) (h rem)+            inl u -> \ h -> efq X (h rem)               where rem : Id stS bn (inl u)-                    rem = cong Unit stS (incUnSt (stFin n)) tt u (propUnit tt u)+                    rem = mapOnPath Unit stS (incUnSt X) tt u (propUnit tt u)             inr z -> \ _ -> z -   f : tS -> stFin n-   f = split-        pair x p -> faux x p+   f : tS -> X+   f z = faux z.1 z.2 -   lem : (x:stFin n) -> neg (Id stS bn (inr x))-   lem x = inlNotinr Unit (stFin n) tt x+   lem : (x:X) -> neg (Id stS bn (inr x))+   lem x = inlNotinr Unit X tt x -   g : stFin n -> tS-   g x = pair (inr x) (lem x)+   g : X -> tS+   g x = (inr x,lem x)     T : stS -> U    T x = neg (Id stS bn x)     lem1 : (u:Unit) -> Id stS bn (inl u)-   lem1 u = cong Unit stS (incUnSt (stFin n)) tt u (propUnit tt u)+   lem1 u = mapOnPath Unit stS (incUnSt X) tt u (propUnit tt u)     lem2 : propFam stS T    lem2 = \ x -> propNeg (Id stS bn x) -   sfg : (x:stFin n) -> Id (stFin n) (f (g x)) x-   sfg x = refl (stFin n) x+   sfg : (x:X) -> Id X (f (g x)) x+   sfg x = refl X x     rfg : (z:tS) -> Id tS (g (f z)) z-   rfg = split-          pair x p -> rem x p-            where rem : (x:stS) -> (p : T x) -> Id tS (g (f (pair x p))) (pair x p)+   rfg z = rem z.1 z.2+            where rem : (x:stS) -> (p : T x) -> Id tS (g (f (x,p))) (x,p)                   rem = split-                   inl u -> \ h -> efq (Id tS (g (f (pair (inl u) h))) (pair (inl u) h)) (h (lem1 u))+                   inl u -> \ h -> efq (Id tS (g (f (inl u,h))) (inl u,h)) (h (lem1 u))                    inr z -> \ h -> eqPropFam stS T lem2-                                    (pair (inr z) (lem (faux (inr z) h))) (pair (inr z) h) (refl stS (inr z))-  -   equivf : isEquiv tS (stFin n) f -   equivf = gradLemma tS (stFin n) f g sfg rfg- --- Pointed set with one isolated element+                                    (inr z,lem (faux (inr z) h)) (inr z,h) (refl stS (inr z)) -hasPointIso : U -> U-hasPointIso A = Sigma A (isolated A)+   equivf : isEquiv tS X f+   equivf = gradLemma tS X f g sfg rfg++botEl : (n:N) -> stFin (suc n)+botEl n = inl tt+ ptBot : N -> ptU-ptBot n = pair (stFin (suc n)) (botEl n)+ptBot n = (stFin (suc n),botEl n) -corEqTkA : (n:N) -> Id U (tAway (ptBot n)) (stFin n)-corEqTkA = eqTkA +mkPtU : (n:N) (x:stFin (suc n)) -> ptU+mkPtU n x = (stFin (suc n),x) -mkPtU : (n:N) (x:stFin (suc n)) -> ptU -mkPtU n x = pair (stFin (suc n)) x+homogSt : (X:U) -> discrete X -> (x:step X) -> Id ptU (step X,x) (step X,inl tt)+homogSt X dX x = homogDec (step X) (decSt X dX) x (inl tt) -homogSt : (n:N) (x:stFin (suc n)) -> Id ptU (mkPtU n x) (ptBot n)-homogSt n x = undefined+corHomogSt : (X:U) -> discrete X -> (x:step X) -> Id U (takeAway (step X) x) X+corHomogSt X dX x =+ substInv ptU (\ z -> Id U (tAway z) X) (step X,x) (step X,inl tt)+    (homogSt X dX x) (eqTkA X) +-- eqTkA : (X:U) -> Id U (takeAway (step X) (inl tt)) X++homogSt' : (n:N) (x:stFin (suc n)) -> Id ptU (mkPtU n x) (ptBot n)+homogSt' n = homogSt (stFin n) (finDec n)++corEqTkA : (n:N) -> Id U (tAway (ptBot n)) (stFin n)+corEqTkA n = eqTkA (stFin n)+ cor1EqTkA : (n:N) (x:stFin (suc n)) -> Id U (tAway (mkPtU n x)) (stFin n)-cor1EqTkA n x = - substInv ptU (\ z -> Id U (tAway z) (stFin n)) (mkPtU n x) (ptBot n) (homogSt n x) (corEqTkA n)+cor1EqTkA n x =+ substInv ptU (\ z -> Id U (tAway z) (stFin n)) (mkPtU n x) (ptBot n) (homogSt' n x) (corEqTkA n) -lemInjSt : (n m:N) -> Id U (stFin (suc n)) (stFin (suc m)) -> Id U (stFin n) (stFin m)-lemInjSt n m h = lem5+lemInjSt : (X Y:U) -> discrete X -> Id U (step X) (step Y) -> Id U X Y+lemInjSt X Y dX h = lem5  where   P : U -> U-  P X = (x:X) -> Id U (takeAway X x) (stFin n)+  P Z = (x:Z) -> Id U (takeAway Z x) X -  lem1 : P (stFin (suc n))-  lem1 = cor1EqTkA n+  lem1 : P (step X)+  lem1 = corHomogSt X dX -  lem2 : P (stFin (suc m))-  lem2 = subst U P (stFin (suc n)) (stFin (suc m)) h lem1+  lem2 : P (step Y)+  lem2 = subst U P (step X) (step Y) h lem1    Am : U-  Am = takeAway (stFin (suc m)) (botEl m)+  Am = takeAway (step Y) (inl tt) -  lem3 : Id U Am (stFin m)-  lem3 = cor1EqTkA m (botEl m)+  lem3 : Id U Am Y+  lem3 = eqTkA Y -  lem4 : Id U Am (stFin n)-  lem4 = lem2 (botEl m)+  lem4 : Id U Am X+  lem4 = lem2 (inl tt) -  lem5 : Id U (stFin n) (stFin m)-  lem5 = comp U (stFin n) Am (stFin m) (inv U Am (stFin n) lem4) lem3+  lem5 : Id U X Y+  lem5 = comp U X Am Y (inv U Am X lem4) lem3  lem1InjSt : (n:N) -> neg (Id U N0 (stFin (suc n)))-lem1InjSt n h = transportInv N0 (stFin (suc n)) h (botEl n) +lem1InjSt n h = transportInv N0 (stFin (suc n)) h (botEl n)  lem2InjSt : (n:N) -> neg (Id U (stFin (suc n)) N0)-lem2InjSt n h = transport (stFin (suc n)) N0 h (botEl n) +lem2InjSt n h = transport (stFin (suc n)) N0 h (botEl n)  lemInj : injective N U stFin lemInj = split@@ -223,7 +221,8 @@                     suc m -> \ h -> efq (Id N zero (suc m)) (lem1InjSt m h)            suc n -> split                      zero -> \ h -> efq (Id N (suc n) zero) (lem2InjSt n h)-                     suc m -> \ h -> cong N N (\ x -> suc x) n m (lemInj n m (lemInjSt n m h))+                     suc m -> \ h ->+                       mapOnPath N N (\ x -> suc x) n m (lemInj n m (lemInjSt (stFin n) (stFin m) (finDec n) h))  eqsT : U -> N -> U eqsT X n = inh (Id U (stFin n) X)@@ -235,7 +234,7 @@ lemEqsT X n m = rem2  where   G : U-  G = Id N n m +  G = Id N n m    pG : prop G   pG = NIsSet n m@@ -244,10 +243,10 @@   rem ln lm = lemInj n m (comp U (stFin n) X (stFin m) ln (inv U (stFin m) X lm))    rem1 : Id U (stFin n) X -> eqsT X m -> G-  rem1 ln = inhrec (Id U (stFin m) X) G pG (rem ln) +  rem1 ln = inhrec (Id U (stFin m) X) G pG (rem ln)    rem2 : eqsT X n -> eqsT X m -> G-  rem2 hn hm = inhrec (Id U (stFin n) X) G pG (\ l -> rem1 l hm) hn +  rem2 hn hm = inhrec (Id U (stFin n) X) G pG (\ l -> rem1 l hm) hn  propEqsT : (X:U) -> prop (Sigma N (eqsT X)) propEqsT X = propSig N (eqsT X) (\ n -> squash (Id U (stFin n) X)) rem@@ -257,16 +256,15 @@ cardFin : (X:U) -> finite X -> Sigma N (eqsT X) cardFin X = inhrec (Sigma N (eqsT X)) (Sigma N (eqsT X)) (propEqsT X) (\ h -> h) --- Unit is finite +-- Unit is finite  finUnit : finite Unit finUnit = inc (Sigma N (eqsT Unit)) rem  where rem : Sigma N (eqsT Unit)-       rem = pair (suc zero) (inc (Id U (stFin (suc zero)) Unit) (lemN0 Unit))+       rem = (suc zero,inc (Id U (stFin (suc zero)) Unit) (lemN0 Unit))         rem1 : Id U (stFin (suc zero)) Unit        rem1 = lemN0 Unit  test : N-test = fst N (eqsT Unit) (cardFin Unit finUnit)-+test = (cardFin Unit finUnit).1
examples/function.cub view
@@ -4,7 +4,7 @@  -- some general facts about functions --- g is a section of f +-- g is a section of f section : (A B : U) (f : A -> B) (g : B -> A) -> U section A B f g = (b : B) -> Id B (f (g b)) b @@ -14,7 +14,7 @@ retract : (A B : U) (f : A -> B) (g : B -> A) -> U retract A B f g = section B A g f -retractInj : (A B : U) (f : A -> B) (g : B -> A) -> +retractInj : (A B : U) (f : A -> B) (g : B -> A) ->              retract A B f g -> injective A B f retractInj A B f g h a0 a1 h' = compUp A (g (f a0)) a0 (g (f a1)) a1 rem1 rem2 rem3   where@@ -25,44 +25,33 @@   rem2 = h a1    rem3 : Id A (g (f a0)) (g (f a1))-  rem3 = cong B A g (f a0) (f a1) h'--+  rem3 = mapOnPath B A g (f a0) (f a1) h'  hasSection : (A B : U) -> (A -> B) -> U-hasSection A B f = Sigma (B->A) (section A B f) +hasSection A B f = Sigma (B->A) (section A B f)  -- an equivalence has a section  equivSec : (A B :U) -> (f:A->B) -> isEquiv A B f -> hasSection A B f-equivSec A B f = - split -  pair s t -> pair g rem-    where g : B -> A-          g y = fst A (\ x -> Id B (f x) y) (s y)--          rem : (y:B) -> Id B (f (g y)) y-          rem y = snd A (\ x -> Id B (f x) y) (s y)--allSection : (A B : U) (f:A->B) -> hasSection A B f -> (Q : B->U) -> ((x:A) -> Q (f x)) -> Pi B Q-allSection A B f =- split-  pair g sfg -> rem -     where rem : (Q : B->U) -> ((x:A) -> Q (f x)) -> Pi B Q-           rem Q h y = rem2-                  where rem1 : Q (f (g y))-                        rem1 = h (g y)+equivSec A B f st = (\y -> (st.1 y).1, \y -> (st.1 y).2) -                        rem2 : Q y-                        rem2 = subst B Q (f (g y)) y (sfg y) rem1+allSection : (A B : U) (f:A->B) -> hasSection A B f+                -> (Q : B->U) -> ((x:A) -> Q (f x)) -> Pi B Q+allSection A B f z = rem+   where rem : (Q : B->U) -> ((x:A) -> Q (f x)) -> Pi B Q+         rem Q h y = rem2+                where rem1 : Q (f (z.1 y))+                      rem1 = h (z.1 y)+                      rem2 : Q y+                      rem2 = subst B Q (f (z.1 y)) y (z.2 y) rem1  -isEquivSection : (A B : U) (f : A -> B) (g : B -> A) -> section A B f g -> +isEquivSection : (A B : U) (f : A -> B) (g : B -> A) -> section A B f g ->                  ((b : B) -> prop (fiber A B f b)) -> isEquiv A B f-isEquivSection A B f g sfg h = pair s t+isEquivSection A B f g sfg h = (s, t)   where   s : (y : B) -> fiber A B f y-  s y = pair (g y) (sfg y)+  s y = (g y, sfg y)    t : (y : B) -> (v : fiber A B f y) -> Id (fiber A B f y) (s y) v   t y v = h y (s y) v@@ -74,6 +63,5 @@ injId X a0 a1 h = h  -idempotent : (A:U) -> (A->A) -> U-idempotent A f = section A A f f -+involutive : (A:U) -> (A->A) -> U+involutive A f = section A A f f
examples/gradLemma.cub view
@@ -2,19 +2,19 @@ 
 import equivProp
 import BoolEqBool
-import cong
 
 corrstId : (A : U) (a : A) -> prop (fiber A A (id A) a)
-corrstId A a v0 v1 = compInv (pathTo A a) (sId A a) v0 v1 (tId A a v0) (tId A a v1) 
+corrstId A a v0 v1 = compInv (pathTo A a) (sId A a) v0 v1 (tId A a v0) (tId A a v1)
 
-corr2stId : (A : U) (h : A -> A) (ph : (x : A) -> Id A (h x) x) (a : A) -> 
+corr2stId : (A : U) (h : A -> A) (ph : (x : A) -> Id A (h x) x) (a : A) ->
             prop (fiber A A h a)
 corr2stId A h ph a = substInv (A -> A) (\h -> prop (fiber A A h a)) h (id A) rem (corrstId A a)
-  where 
+  where
   rem : Id (A -> A) h (id A)
-  rem = funExt A (\_ -> A) h (id A) ph 
+  rem = funExt A (\_ -> A) h (id A) ph
 
-gradLemma : (A B : U) (f : A -> B) (g : B -> A) -> section A B f g -> retract A B f g -> 
+
+gradLemma : (A B : U) (f : A -> B) (g : B -> A) -> section A B f g -> retract A B f g ->
             isEquiv A B f
 gradLemma A B f g sfg rfg = isEquivSection A B f g sfg rem
   where
@@ -22,124 +22,66 @@   injf = retractInj A B f g rfg
 
   rem : (b : B) -> prop (Sigma A (\a -> Id B (f a) b))
-  rem b = split
-    pair a0 e0 -> 
-      split
-       pair a1 e1 -> rem19
-        where
-         E : A -> U
-         E a = Id B (f a) b
-         F : A -> U
-         F a = Id A (g (f a)) (g b)
-         G : A -> U
-         G a = Id B (f (g (f a))) (f (g b))
-
-         z0 : Sigma A E
-         z0 = pair a0 e0
-         z1 : Sigma A E
-         z1 = pair a1 e1
-        
-         cg : (a:A) -> E a -> F a
-         cg a = cong B A g (f a) b
-
-         cf : (a:A) -> F a -> G a
-         cf a = cong A B f (g (f a)) (g b)
-
-         cfg : (a:A) -> E a -> G a
-         cfg a = cong B B (\ x -> f (g x)) (f a) b
-
-         pcg : Sigma A E -> Sigma A F
-         pcg = split
-                pair a e -> pair a (cg a e)
-
-         pcf : Sigma A F -> Sigma A G
-         pcf = split
-                pair a e -> pair a (cf a e)
-
-         fg : B -> B
-         fg y = f (g y)
-
-         pc : (u:B -> B) -> Sigma A E -> Sigma A (\ a -> Id B (u (f a)) (u b))
-         pc u = split
-                pair a e -> pair a (cong B B u (f a) b e)
-
-         rem1 : prop (Sigma A F)
-         rem1 = corr2stId A (\ x -> g (f x)) rfg (g b)         
-
-         rem2 : Id (Sigma A F) (pcg z0) (pcg z1)
-         rem2 = rem1 (pcg z0) (pcg z1)
-
-         rem3 : Id (Sigma A G) (pcf (pcg z0)) (pcf (pcg z1))
-         rem3 = cong (Sigma A F) (Sigma A G) pcf (pcg z0) (pcg z1) rem2
-
-         rem4 : Id (E a0 -> G a0) (cfg a0) (\ e -> cf a0 (cg a0 e))
-         rem4 = congComp B A B g f (f a0) b 
-
-         rem5 : Id (G a0) (cfg a0 e0) (cf a0 (cg a0 e0))
-         rem5 = appId (E a0) (G a0) e0 (cfg a0) (\ e -> cf a0 (cg a0 e)) rem4
-
-         rem6 : Id (Sigma A G) (pc fg z0) (pcf (pcg z0))
-         rem6 = cong (G a0) (Sigma A G) (\ e -> pair a0 e)  (cfg a0 e0) (cf a0 (cg a0 e0)) rem5
-
-         rem7 : Id (E a1 -> G a1) (cfg a1) (\ e -> cf a1 (cg a1 e))
-         rem7 = congComp B A B g f (f a1) b 
-
-         rem8 : Id (G a1) (cfg a1 e1) (cf a1 (cg a1 e1))
-         rem8 = appId (E a1) (G a1) e1 (cfg a1) (\ e -> cf a1 (cg a1 e)) rem7
+  rem b z0 z1 = rem5
+   where
+    E : A -> U
+    E a = Id B (f a) b
+    F : A -> U
+    F a = Id A (g (f a)) (g b)
+    G : A -> U
+    G a = Id B (f (g (f a))) (f (g b))
 
-         rem9 : Id (Sigma A G) (pc fg z1) (pcf (pcg z1))
-         rem9 = cong (G a1) (Sigma A G) (\ e -> pair a1 e)  (cfg a1 e1) (cf a1 (cg a1 e1)) rem8
+    cg : (a:A) -> E a -> F a
+    cg a = mapOnPath B A g (f a) b
 
-         rem10 : Id (Sigma A G) (pc fg z0) (pc fg z1)
-         rem10 = compDown (Sigma A G) (pc fg z0) (pcf (pcg z0)) (pc fg z1) (pcf (pcg z1)) rem6 rem9 rem3
+    cf : (a:A) -> F a -> G a
+    cf a = mapOnPath A B f (g (f a)) (g b)
 
-         rem11 : Id (B -> B) fg (id B)
-         rem11 = funExt B (\ _ -> B)  fg (id B) sfg
+    cfg : (a:A) -> E a -> G a
+    cfg a = mapOnPath B B (\ x -> f (g x)) (f a) b
 
-         rem12 : Id (Sigma A E) (pc (id B) z0) (pc (id B) z1)
-         rem12 = subst (B->B) (\ u -> Id (Sigma A (\ x -> Id B (u (f x)) (u b))) (pc u z0) (pc u z1)) fg (id B) rem11 rem10
+    pcf : Sigma A F -> Sigma A G
+    pcf z = (z.1, cf z.1 z.2)
 
-         c1 : (a:A) -> E a -> E a
-         c1 a = cong B B (id B) (f a) b
+    pcg : Sigma A E -> Sigma A F
+    pcg z = (z.1, cg z.1 z.2)
 
-         rem13 : Id (E a0 -> E a0) (id (E a0)) (c1 a0) 
-         rem13 = congId B (f a0) b
+    fg : B -> B
+    fg y = f (g y)
 
-         rem14 : Id (E a0) e0 (c1 a0 e0) 
-         rem14 = appId (E a0) (E a0) e0  (id (E a0)) (c1 a0) rem13
+    pc : (u:B -> B) -> Sigma A E -> Sigma A (\ a -> Id B (u (f a)) (u b))
+    pc u z = (z.1, mapOnPath B B u (f z.1) b z.2)
 
-         rem15 : Id (Sigma A E) z0 (pc (id B) z0)
-         rem15 = cong (E a0) (Sigma A E) (\ e -> pair a0 e) e0 (c1 a0 e0) rem14
+    rem1 : prop (Sigma A F)
+    rem1 = corr2stId A (\ x -> g (f x)) rfg (g b)
 
-         rem16 : Id (E a1 -> E a1) (id (E a1)) (c1 a1) 
-         rem16 = congId B (f a1) b
+    rem2 : Id (Sigma A F) (pcg z0) (pcg z1)
+    rem2 = rem1 (pcg z0) (pcg z1)
 
-         rem17 : Id (E a1) e1 (c1 a1 e1) 
-         rem17 = appId (E a1) (E a1) e1  (id (E a1)) (c1 a1) rem16
+    rem3 : Id (Sigma A G) (pcf (pcg z0)) (pcf (pcg z1))
+    rem3 = mapOnPath (Sigma A F) (Sigma A G) pcf (pcg z0) (pcg z1) rem2
 
-         rem18 : Id (Sigma A E) z1 (pc (id B) z1)
-         rem18 = cong (E a1) (Sigma A E) (\ e -> pair a1 e) e1 (c1 a1 e1) rem17
+    rem4 : Id (B -> B) fg (id B)
+    rem4 = funExt B (\ _ -> B)  fg (id B) sfg
 
-         rem19 : Id (Sigma A E) z0 z1
-         rem19 = compDown (Sigma A E) z0 (pc (id B) z0) z1 (pc (id B) z1) rem15 rem18 rem12
+    rem5 : Id (Sigma A E) (pc (id B) z0) (pc (id B) z1)
+    rem5 = subst (B->B)
+             (\ u -> Id (Sigma A (\ x -> Id B (u (f x)) (u b))) (pc u z0) (pc u z1)) fg (id B) rem4 rem3
 
 -- isomorphic types are equal
 
-isoId : (A B:U) ->  (f : A -> B) (g : B -> A) -> section A B f g -> retract A B f g -> 
+isoId : (A B:U) ->  (f : A -> B) (g : B -> A) -> section A B f g -> retract A B f g ->
             Id U A B
 isoId A B f g sfg rfg = isEquivEq A B f (gradLemma A B f g sfg rfg)
 
 -- some applications of the gradlemma
 
-propId : (A B:U) ->  prop A -> prop B ->  (f : A -> B) (g : B -> A) -> 
+propId : (A B:U) ->  prop A -> prop B ->  (f : A -> B) (g : B -> A) ->
             Id U A B
 propId A B pA pB f g = isEquivEq A B f (gradLemma A B f g sfg rfg)
  where
   sfg : (b:B) -> Id B (f (g b)) b
   sfg b = pB (f (g b)) b
- 
+
   rfg : (a:A) -> Id A (g (f a)) a
   rfg a = pA (g (f a)) a
-
-
-
examples/hedberg.cub view
@@ -13,8 +13,8 @@  decConst : (A : U) -> dec A -> exConst A decConst A = split-  inl a -> pair (\x -> a) (\ x y -> refl A a)-  inr h -> pair (\x -> x) (\ x y -> efq (Id A x y) (h x))+  inl a -> (\x -> a, \ x y -> refl A a)+  inr h -> (\x -> x, \ x y -> efq (Id A x y) (h x))  hedbergLemma : (A: U) (f : (a b : A) -> Id A a b -> Id A a b) (a b : A)             (p : Id A a b) ->@@ -30,10 +30,10 @@     rem1 x y = decConst (Id A x y) (h x y)      f : (x y : A) -> Id A x y -> Id A x y-    f x y = fst (Id A x y -> Id A x y) (const (Id A x y)) (rem1 x y)+    f x y = (rem1 x y).1      fIsConst : (x y : A) -> const (Id A x y) (f x y)-    fIsConst x y = snd (Id A x y -> Id A x y) (const (Id A x y)) (rem1 x y)+    fIsConst x y = (rem1 x y).2      r : Id A a a     r = f a a (refl A a)@@ -58,4 +58,10 @@  boolIsSet : set Bool boolIsSet = hedberg Bool boolDec++unitIsSet : set Unit+unitIsSet = hedberg Unit unitDec++N0IsSet : set N0+N0IsSet = hedberg N0 N0Dec
+ examples/helix.cub view
@@ -0,0 +1,107 @@+module helix where++import integer++helix : S1 -> U+helix = S1rec (\_ -> U) Z sucIdZ++test : Id U Z (helix base)+test = refl U Z++loopSpace : (A : U) (a : A) -> U+loopSpace A a = Id A a a++loopS1 : U+loopS1 = loopSpace S1 base++S1recbase : (F : S1 -> U) (b : F base) -> (l : IdS S1 F base base loop b b) ->+  Id (F base) (S1rec F b l base) b+S1recbase F b l = refl (F base) b++-- S1recloop : (F : S1 -> U) (b : F base) -> (l : IdS S1 F base base loop b b) ->+--  Id (IdS S1 F base base loop b b)+--    (mapOnPathD S1 F (S1rec F b l) base base loop)+--    l+-- S1recloop F b l = refl (IdS S1 F base base loop b b) l++winding : loopS1 -> Z+winding l = transport Z Z (rem l) zeroZ+  where+    rem : loopS1 -> Id U Z Z+    rem l = mapOnPath S1 U helix base base l++compS1 : loopS1 -> loopS1 -> loopS1+compS1 = comp S1 base base base++invS1 : loopS1 -> loopS1+invS1 = inv S1 base base++test1 : Z+test1 = winding loop++loop2 : loopS1+loop2 = compS1 loop loop++loop4 : loopS1+loop4 = compS1 loop2 loop2++loop8 : loopS1+loop8 = compS1 loop4 loop4++test2 : Z+test2 = winding (compS1 loop (invS1 loop))++test3 : Z+test3 = winding (invS1 loop2)++test4 : Z+test4 = winding (compS1 loop4 (invS1 loop2))++test5 : Z+test5 = winding (compS1 loop8 (invS1 loop2))++encode : (x : S1) -> Id S1 base x -> helix x+encode x l = subst S1 helix base x l zeroZ++loopN : N -> loopS1+loopN = split+  zero -> refl S1 base+  suc n -> compS1 loop (loopN n)++loopZ : Z -> loopS1+loopZ = split+  inl n -> invS1 (loopN (suc n))+  inr n -> loopN n++-- loopZpred : (n : Z) -> Id loopS1 (loopZ (predZ n)) (compS1 (invS1 loop) (loopZ n))+-- loopZpred n = undefined++testDan : Id U Z Z +testDan = mapOnPath S1 U helix base base loop++funDan : Z -> Z+funDan = transport Z Z testDan++funDan1 : Z -> Z+funDan1 = transport Z Z sucIdZ++-- testDan1 : Id (Z->Z) sucZ funDan1+-- testDan1 = refl (Z -> Z) sucZ++test0 : Z+test0 = transport Z Z testDan zeroZ++vect : N -> U+vect = split +         zero -> Unit+         suc n -> and N (vect n)++Peter : S1 -> N+Peter = S1rec (\ _ -> N) zero (refl N zero)++testPeter : Id N zero zero+testPeter = mapOnPath S1 N Peter base base loop+++-- helix = S1rec (\_ -> U) Z sucIdZ+
+ examples/heterogeneous.cub view
@@ -0,0 +1,87 @@+module heterogeneous where++import primitives+import prelude+import gradLemma++eqFst : (A : U) (B : A -> U) (u v : Sigma A B) ->+        Id (Sigma A B) u v -> Id A u.1 v.1+eqFst A B = mapOnPath (Sigma A B) A (\x -> x.1)++eqSnd : (A : U) (B : A -> U) (u v : Sigma A B) (p : Id (Sigma A B) u v) ->+        IdS A B u.1 v.1 (eqFst A B u v p) u.2 v.2+eqSnd A B = mapOnPathD (Sigma A B) (\x -> B x.1) (\x -> x.2)++eqPair1 : (A : U) (B : A -> U) (a0 a1 : A) (b0 : B a0) (b1 : B a1) ->+        Id (Sigma A B) (a0,b0) (a1,b1) -> Id A a0 a1+eqPair1 A B a0 a1 b0 b1 = eqFst A B (a0,b0) (a1,b1)++-- eqPair2 : (A : U) (B : A -> U) (a0 a1 : A) (b0 : B a0) (b1 : B a1)+--        (p : Id (Sigma A B) (pair a0 b0) (pair a1 b1)) ->+--        IdS A B a0 a1 (eqPair1 A B a0 a1 b0 b1 p) b0 b1+-- eqPair2 A B a0 a1 b0 b1 = eqSnd A B (pair a0 b0) (pair a1 b1)++-- conversion test:+reflIdIdP : (A:U) (a b : A) -> Id U (Id A a b) (IdP A A (refl U A) a b)+reflIdIdP A a b = refl U (Id A a b)++-- conversion test:+reflS : (A:U) (F:A -> U) (a:A) (b : F a) -> IdS A F a a (refl A a) b b+reflS A F a b = refl (F a) b++-- conversion test:+composeMapOnPath : (A : U) (B : A -> U) (u v : Sigma A B) ->+                   (p : Id (Sigma A B) u v) ->+  Id (Id U (B u.1) (B v.1))+    (mapOnPath (Sigma A B) U (\x -> B x.1) u v p)+    (mapOnPath A U B u.1 v.1 (mapOnPath (Sigma A B) A (\x -> x.1) u v p))+composeMapOnPath A B u v p = refl (Id U (B u.1) (B v.1))+          (mapOnPath (Sigma A B) U (\x -> B x.1) u v p)++eqFstSnd : (A : U) (B : A -> U) (a0 a1 : A) (b0 : B a0) (b1 : B a1) ->+           Id U+             (Id (Sigma A B) (a0, b0) (a1, b1))+	     (Sigma (Id A a0 a1) (\p -> IdS A B a0 a1 p b0 b1))+eqFstSnd A B a0 a1 b0 b1 = isEquivEq IdSig SigId f+                           (gradLemma IdSig SigId f g (refl SigId) (refl IdSig))+  where IdSig : U+        IdSig = Id (Sigma A B) (a0, b0) (a1, b1)++        SigId : U+        SigId = Sigma (Id A a0 a1) (\p -> IdS A B a0 a1 p b0 b1)++        f : IdSig -> SigId+        f p = (eqFst A B (a0,b0) (a1,b1) p, eqSnd  A B (a0,b0) (a1,b1) p)+++        g : SigId -> IdSig+        g z =  mapOnPathS A B (Sigma A B) (\a b -> (a, b)) a0 a1 z.1 b0 b1 z.2+++eqSubstSig : (A : U) (B : A -> U) (a0 a1 : A) (p:Id A a0 a1) (b0 : B a0) (b1 : B a1) ->+           Id U (IdS A B a0 a1 p b0 b1) (Id (B a1) (subst A B a0 a1 p b0) b1)+eqSubstSig A B a0 =+ J A a0 (\ a1 p -> (b0 : B a0) (b1 : B a1) ->+                    Id U (IdS A B a0 a1 p b0 b1) (Id (B a1) (subst A B a0 a1 p b0) b1))+        rem+  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)+        rem b0 b1 = mapOnPath (B a0) U (\ b -> Id (B a0) b b1)+                     b0 (subst A B a0 a0 (refl A a0) b0) (substeq A B a0 b0)++pairEq : (A B:U) (a0 a1:A) (b0 b1:B) -> Id A a0 a1 -> Id B b0 b1 ->+         Id (and A B) (a0, b0) (a1, b1)+pairEq A B a0 a1 b0 b1 p q =+ appOnPath B (and A B) f0 f1 b0 b1 rem q+  where f0 : B -> and A B+        f0 y = (a0, y)+        f1 : B -> and A B+        f1 y = (a1, y)+        rem : Id (B -> and A B) f0 f1+        rem = mapOnPath A (B -> and A B) (\ x y -> (x, y)) a0 a1 p++test : (A B:U) (a0 a1:A) (b0 b1:B) (p:Id A a0 a1) (q:Id B b0 b1) ->+         Id (Id A a0 a1)+            p+            (mapOnPath (and A B) A (\x -> x.1) (a0, b0) (a1, b1)+                       (pairEq A B a0 a1 b0 b1 p q))+test A B a0 a1 b0 b1 p q = refl (Id A a0 a1) p
− examples/idempotent.cub 
@@ -1,74 +0,0 @@-module idempotent where--import gradLemma---- any idempotent function defines an equality --idemIsEquiv : (A:U) -> (f : A -> A) -> idempotent A f -> isEquiv A A f-idemIsEquiv A f if = gradLemma A A f f if if--idemEq : (A:U) -> (f : A -> A) -> idempotent A f -> Id U A A-idemEq A f if = isEquivEq A A f (idemIsEquiv A f if)--remIdFunEq : (A:U) -> (f:A -> A) -> (x:A) -> Id A x (f x) -> Id A x (f (f x))-remIdFunEq A f x p = subst A (\ y -> Id A x (f y)) x (f x) p p--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))-invInvEq A a = J A a (\ b p -> Id (Id A a b) p (inv A b a (inv A a b p))) rem- where rem : Id (Id A a a) (refl A a) (inv A a a (inv A a a (refl A a)))-       rem = remIdFunEq (Id A a a) (inv A a a) (refl A a) (invRefl A a)--idemInv : (A:U) -> (a:A) -> idempotent (Id A a a) (inv A a a)-idemInv A a = rem - where -      T : U-      T = Id A a a-      g : T -> T-      g = inv A a a -      rem : (p: T) -> Id T (g (g p)) p-      rem p = inv T p (g (g p)) (invInvEq A a a p)---- type of all loops --aLoop : U -> U-aLoop A = Sigma A (\ a -> Id A a a)--invALoop : (A:U) -> aLoop A -> aLoop A-invALoop A = split-              pair a l -> pair a (inv A a a l)--idemInvALoop : (A:U) -> idempotent (aLoop A) (invALoop A)-idemInvALoop A = split-                  pair a l -> cong (Id A a a) (aLoop A) (\ x -> pair a x) (inv A a a (inv A a a l)) l (idemInv A a l)---- equality associated to this idempotent map--eqInvALoop : (A:U) -> Id U (aLoop A) (aLoop A)-eqInvALoop A = idemEq (aLoop A) (invALoop A) (idemInvALoop A)---- type of types with automorphisms--autoM : U-autoM = aLoop U---- this type is equal to itself--eqAutoM : Id U autoM autoM-eqAutoM = eqInvALoop U---- a particular element of autoM--boolAuto : autoM-boolAuto = pair Bool eqBoolBool---- by transport we deduce another type and another equality--boolAuto' : autoM-boolAuto' = subst U (\ X -> X) autoM autoM eqAutoM boolAuto--bool' : U-bool' = fst U (\ X -> Id U X X) boolAuto'--eqBool' : Id U bool' bool'-eqBool' = snd  U (\ X -> Id U X X) boolAuto'-
+ examples/integer.cub view
@@ -0,0 +1,64 @@+module integer where++import gradLemma++Z : U +Z = or N N++zeroZ : Z+zeroZ = inr zero++auxsucZ : N -> Z+auxsucZ = split +         zero -> inr zero+         suc n -> inl n++sucZ : Z -> Z+sucZ = split+         inl u -> auxsucZ u+         inr v -> inr (suc v)++auxpredZ : N -> Z+auxpredZ = split +         zero -> inl zero+         suc n -> inr n++predZ : Z -> Z+predZ = split+         inl u -> inl (suc u)+         inr v -> auxpredZ v++sucpredZ : (x:Z) -> Id Z (sucZ (predZ x)) x+sucpredZ = + split+  inl u -> lem1 u+   where+    lem1 : (u:N) -> Id Z (sucZ (predZ (inl u))) (inl u)+    lem1 = split+            zero -> refl Z (inl zero)+            suc n -> refl Z (inl (suc n))+  inr v -> lem2 v+   where+    lem2 : (u:N) -> Id Z (sucZ (predZ (inr u))) (inr u)+    lem2 = split+            zero -> refl Z (inr zero)+            suc n -> refl Z (inr (suc n))++predsucZ : (x:Z) -> Id Z (predZ (sucZ x)) x+predsucZ = + split+  inl u -> lem1 u+   where+    lem1 : (u:N) -> Id Z (predZ (sucZ (inl u))) (inl u)+    lem1 = split+            zero -> refl Z (inl zero)+            suc n -> refl Z (inl (suc n))+  inr v -> lem2 v+   where+    lem2 : (u:N) -> Id Z (predZ (sucZ (inr u))) (inr u)+    lem2 = split+            zero -> refl Z (inr zero)+            suc n -> refl Z (inr (suc n))++sucIdZ : Id U Z Z+sucIdZ = isoId Z Z sucZ predZ sucpredZ predsucZ
+ examples/interval.cub view
@@ -0,0 +1,10 @@+module interval where++import primitives++funExt' : (A : U) (B : A -> U) (f g : (x : A) -> B x) ->+          ((x : A) -> Id (B x) (f x) (g x)) -> Id ((x : A) -> B x) f g+funExt' A B f g ptw = mapOnPath I ((x : A) -> B x) htpy I0 I1 line+  where+    htpy : I -> (x : A) -> B x+    htpy i x = intrec (\_ -> B x) (f x) (g x) (ptw x) i
+ examples/involutive.cub view
@@ -0,0 +1,70 @@+module involutive where++import gradLemma++-- any involutive function defines an equality++idemIsEquiv : (A:U) -> (f : A -> A) -> involutive A f -> isEquiv A A f+idemIsEquiv A f if = gradLemma A A f f if if++idemEq : (A:U) -> (f : A -> A) -> involutive A f -> Id U A A+idemEq A f if = isEquivEq A A f (idemIsEquiv A f if)++remIdFunEq : (A:U) -> (f:A -> A) -> (x:A) -> Id A x (f x) -> Id A x (f (f x))+remIdFunEq A f x p = subst A (\ y -> Id A x (f y)) x (f x) p p++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))+invInvEq A a = J A a (\ b p -> Id (Id A a b) p (inv A b a (inv A a b p))) rem+ where rem : Id (Id A a a) (refl A a) (inv A a a (inv A a a (refl A a)))+       rem = remIdFunEq (Id A a a) (inv A a a) (refl A a) (invRefl A a)++idemInv : (A:U) -> (a:A) -> involutive (Id A a a) (inv A a a)+idemInv A a = rem+ where+      T : U+      T = Id A a a+      g : T -> T+      g = inv A a a+      rem : (p: T) -> Id T (g (g p)) p+      rem p = inv T p (g (g p)) (invInvEq A a a p)++-- type of all loops++aLoop : U -> U+aLoop A = Sigma A (\ a -> Id A a a)++invALoop : (A:U) -> aLoop A -> aLoop A+invALoop A z = (z.1,inv A z.1 z.1 z.2)++idemInvALoop : (A:U) -> involutive (aLoop A) (invALoop A)+idemInvALoop A z =+ mapOnPath (Id A z.1 z.1) (aLoop A)+           (\ 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)++-- equality associated to this involutive map++eqInvALoop : (A:U) -> Id U (aLoop A) (aLoop A)+eqInvALoop A = idemEq (aLoop A) (invALoop A) (idemInvALoop A)++-- type of types with automorphisms++autoM : U+autoM = aLoop U++-- this type is equal to itself++eqAutoM : Id U autoM autoM+eqAutoM = eqInvALoop U++-- a particular element of autoM++boolAuto : autoM+boolAuto = (Bool,eqBoolBool)++-- by transport we deduce another type and another equality++boolAuto' : autoM+boolAuto' = subst U (\X -> X) autoM autoM eqAutoM boolAuto++eqBool' : Id U boolAuto'.1 boolAuto'.1+eqBool' = boolAuto'.2
examples/lemId.cub view
@@ -11,10 +11,10 @@ compInvIdr A a b p = substeq A (\x -> Id A a x) b p
 
 inv : (A : U) -> (a b :A) -> Id A a b -> Id A b a
-inv A a b p = subst A (\ x -> Id A x a) a b p (refl A a)
+inv A a b p = subst A (\x -> Id A x a) a b p (refl A a)
 
 invRefl : (A:U) -> (a:A) -> Id (Id A a a) (refl A a) (inv A a a (refl A a))
-invRefl A a = substeq A  (\ x -> Id A x a) a (refl A a)
+invRefl A a = substeq A  (\x -> Id A x a) a (refl A a)
 
 compIdr : (A : U) -> (a b : A) -> (p : Id A a b) -> Id (Id A a b) (comp A a b b p (refl A b)) p
 compIdr A a b p = inv (Id A a b) p (comp A a b b p (refl A b)) (compInvIdr A a b p)
@@ -38,21 +38,21 @@ compInvIdl' A a b p = substeq A (\x -> Id A x b) a p
 
 idEuclid : (A : U) -> euclidean A (Id A)
-idEuclid A a b c p r = comp A a c b p (inv A b c r)
+idEuclid A a b c p q = transpInv (Id A a b) (Id A a c) rem p
+ where rem : Id U (Id A a b) (Id A a c)
+       rem = mapOnPath A U (Id A a) b c q
 
+-- similarity with ssreflect?? start to use equality on U
+
+lemUpDown : (A:U) -> (a a' b b':A) -> Id A a a' -> Id A b b' -> Id U (Id A a b) (Id A a' b')
+lemUpDown A a a' b b' p q = 
+ appOnPath A U (Id A a) (Id A a') b b' (mapOnPath A (A->U) (Id A) a a' p)  q
+
 compUp : (A:U) -> (a a' b b':A) -> Id A a a' -> Id A b b' -> Id A a b -> Id A a' b'
-compUp A a a' b b' p q r =
- subst A (\ x -> Id A x b') a a' p rem
- where
-  rem : Id A a b'
-  rem = comp A a b b' r q
+compUp A a a' b b' p q = transport (Id A a b) (Id A a' b') (lemUpDown A a a' b b' p q)
 
 compDown : (A:U) -> (a a' b b':A) -> Id A a a' -> Id A b b' -> Id A a' b' -> Id A a b
-compDown A a a' b b' p q r =
- subst A (\ x -> Id A a x) b' b (inv A b b' q) rem
- where
-  rem : Id A a b'
-  rem = comp A a a' b' p r
+compDown A a a' b b' p q = transpInv (Id A a b) (Id A a' b') (lemUpDown A a a' b b' p q)
 
 lemInv : (A:U) -> (a b c : A) -> (p : Id A a b) -> (q : Id A b c) ->
          Id (Id A b c) q (compInv A a b c p (comp A a b c p q))
@@ -91,31 +91,27 @@ 
    rem2 : Id (Id A b c) (compInv A a b c p (comp A a b c p q))
                         (compInv A a b c p (comp A a b c p q'))
-   rem2 = cong (Id A a c) (Id A b c) (compInv A a b c p)
+   rem2 = mapOnPath (Id A a c) (Id A b c) (compInv A a b c p)
                (comp A a b c p q) (comp A a b c p q') h
 
 eqSigma : (A : U) (B : A -> U) (a b : A) (p : Id A a b)
           (u : B a) (v : B b) (q : Id (B b) (subst A B a b p u) v) ->
-          Id (Sigma A B) (pair a u) (pair b v)
+          Id (Sigma A B) (a, u) (b, v)
 eqSigma A B a =
   J A a (\b p -> (u : B a) (v : B b) (q : Id (B b) (subst A B a b p u) v) ->
-         Id (Sigma A B) (pair a u) (pair b v)) rem2
+         Id (Sigma A B) (a, u) (b, v)) rem2
   where
     rem1 : (u v : B a) -> Id (B a) u v ->
-           Id (Sigma A B) (pair a u) (pair a v)
-    rem1 = cong (B a) (Sigma A B) (\x -> pair a x)
+           Id (Sigma A B) (a, u) (a, v)
+    rem1 = mapOnPath (B a) (Sigma A B) (\x -> (a, x))
 
     rem2 : (u v : B a) -> Id (B a) (subst A B a a (refl A a) u) v ->
-           Id (Sigma A B) (pair a u) (pair a v)
+           Id (Sigma A B) (a, u) (a, v)
     rem2 u v q = rem1 u v q'
       where q' : Id (B a) u v
             q' = comp (B a) u (subst A B a a (refl A a) u) v (substeq A B a u) q
 
 eqPropFam : (A : U) (B : A -> U) (h : propFam A B) (au bv : Sigma A B) ->
-            Id A (fst A B au) (fst A B bv) -> Id (Sigma A B) au bv
-eqPropFam A B h = split
-  pair a u -> split
-    pair b v -> \p -> eqSigma A B a b p u v (h b (subst A B a b p u) v)
-
-
-
+            Id A au.1 bv.1 -> Id (Sigma A B) au bv
+eqPropFam A B h au bv p =
+  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 view
@@ -0,0 +1,29 @@+module mutualtest where++import prelude++mutual+  even : N -> Bool+  odd : N -> Bool++  even = split+    zero  -> true+    suc n -> odd n+  odd = split+    zero  -> false+    suc n -> even n++testEven3 : Bool+testEven3 = even (suc (suc (suc zero)))++mutual+  V : U+  T : V -> U++  data V = nat | pi (a : V) (b : T a -> V)++  T = split+    nat -> N+    pi a b -> Pi (T a) (\x -> T (b x))++
examples/nIso.cub view
@@ -30,11 +30,17 @@ isoNO : Id U N (or N Unit) isoNO = isoId N (or N Unit) NToOr OrToN retNO secNO +isoNO2 : Id U N (or N Unit)+isoNO2 = comp U N N (or N Unit) (comp U N (or N Unit) N isoNO (inv U N (or N Unit) isoNO)) isoNO++isoNO4 : Id U N (or N Unit)+isoNO4 = comp U N N (or N Unit) (comp U N (or N Unit) N isoNO2 (inv U N (or N Unit) isoNO2)) isoNO2+ -- trying to build an example which involves Kan filling for product  vect : U -> N -> U vect A = split-          zero -> A +          zero -> A           suc n -> and A (vect A n)  pBool : N -> U@@ -43,38 +49,35 @@ notSN : (x:N) -> pBool x -> pBool x notSN = split          zero -> not-         suc n -> split-                    pair b u -> pair (not b) (notSN n u)+         suc n -> \ z -> (not z.1,notSN n z.2)  sBool : (x:N) -> pBool x sBool = split         zero -> true-        suc n -> pair false (sBool n)+        suc n -> (false,sBool n)  stBool : (x:N) -> pBool x -> Bool stBool = split            zero -> \ z -> z-           suc n -> split-                      pair b u -> andBool b (stBool n u)+           suc n -> \ z -> andBool z.1 (stBool n z.2)  hasSec : U -> U hasSec X = Sigma (X->U) (\ P -> (x:X) -> and (P x) (P x -> Bool))  hSN : hasSec N-hSN = pair pBool (\ n -> pair (sBool n) (stBool n))+hSN = (pBool,\ n -> (sBool n,stBool n))  hSN' : hasSec (or N Unit) hSN' = subst U hasSec N (or N Unit) isoNO hSN  pB' : (or N Unit) -> U-pB' = fst ((or N Unit) -> U)  (\ P -> (x:or N Unit) -> and (P x) (P x -> Bool)) hSN'+pB' = hSN'.1  sB' : (z: or N Unit) -> and (pB' z) (pB' z -> Bool)-sB' = snd ((or N Unit) -> U)  (\ P -> (x:or N Unit) -> and (P x) (P x -> Bool)) hSN'+sB' = hSN'.2  appBool : (A : U) -> and A (A -> Bool) -> Bool-appBool A = split-             pair a f -> f a+appBool A z = z.2 z.1  pred' : or N Unit -> or N Unit pred' = subst U (\ X -> X -> X) N (or N Unit) isoNO pred@@ -98,7 +101,7 @@ testSN3 = saB' (inl (suc (suc zero)))  add : N -> N -> N-add x = split +add x = split          zero -> x          suc y -> suc (add x y) @@ -111,8 +114,7 @@ propAdd : (x:N) -> Id N (add zero x) x propAdd = split            zero -> refl N zero-           suc n -> cong N N (\ x -> suc x) (add zero n) n (propAdd n)--- propAdd' : (z:or N Unit) +           suc n -> mapOnPath N N (\ x -> suc x) (add zero n) n (propAdd n)   @@ -123,31 +125,106 @@ aZero X = Sigma X (\ z -> Sigma (X -> X -> X) (\ f -> (x:X) -> Id X (f z x) x))  aZN : aZero N-aZN = pair zero (pair add propAdd)+aZN =  (zero,(add,propAdd))  aZN' : aZero (or N Unit) aZN' = subst U aZero N (or N Unit) isoNO aZN  zero' : or N Unit-zero' = fst (or N Unit) (\ z -> Sigma ((or N Unit) -> (or N Unit) -> (or N Unit)) -                                 (\ f -> (x:(or N Unit)) -> Id (or N Unit) (f z x) x)) aZN'+zero' = aZN'.1 -sndaZN' : Sigma ((or N Unit) -> (or N Unit) -> (or N Unit)) +sndaZN' : Sigma ((or N Unit) -> (or N Unit) -> (or N Unit))                                  (\ f -> (x:(or N Unit)) -> Id (or N Unit) (f zero' x) x)-sndaZN' = snd (or N Unit) (\ z -> Sigma ((or N Unit) -> (or N Unit) -> (or N Unit)) -                                 (\ f -> (x:(or N Unit)) -> Id (or N Unit) (f z x) x)) aZN'+sndaZN' = aZN'.2  add' : (or N Unit) -> (or N Unit) -> or N Unit-add' = fst ((or N Unit) -> (or N Unit) -> (or N Unit)) -                                 (\ f -> (x:(or N Unit)) -> Id (or N Unit) (f zero' x) x) sndaZN'+add' = sndaZN'.1  propAdd' : (x:or N Unit) -> Id (or N Unit) (add' zero' x) x-propAdd' = snd ((or N Unit) -> (or N Unit) -> (or N Unit)) -                                 (\ f -> (x:(or N Unit)) -> Id (or N Unit) (f zero' x) x) sndaZN'-+propAdd' = sndaZN'.2  testNO : or N Unit testNO = add' (inl zero) (inl (suc zero))  testNO1 : Id (or N Unit) (add' zero' zero') zero' testNO1 = propAdd' zero'++testNO2 : or N Unit+testNO2 = zero'++testNO3 : or N Unit+testNO3 = add' zero' zero'++step : U -> U+step X = or X Unit++lemIt : (A:U) (f:A->A) (a:A) -> Id A a (f a) -> Id A a (f (f a))+lemIt A f a p = subst A (\ z -> Id A a (f z)) a (f a) p p++isoNOIt : Id U N (step (step N))+isoNOIt = lemIt U step N isoNO++isoNOIt2 : Id U N (step (step (step (step N))))+isoNOIt2 = lemIt U (\ x -> step (step x)) N isoNOIt++aZNIt : aZero (step (step N))+aZNIt = subst U aZero N (step (step N)) isoNOIt aZN++zeroIt : step (step N)+zeroIt = aZNIt.1++sndaZNIt : Sigma ((step (step N)) -> (step (step N)) -> (step (step N)))+           (\ f -> (x:(step (step N))) -> Id (step (step N)) (f zeroIt x) x)+sndaZNIt = aZNIt.2++addIt : (step (step N)) -> (step (step N)) -> step (step N)+addIt = sndaZNIt.1++propAddIt : (x:step (step N)) -> Id (step (step N)) (addIt zeroIt x) x+propAddIt = sndaZNIt.2++testIt : step (step N)+testIt = addIt (inl (inl zero)) (inl (inl (suc zero)))++testIt1 : Id (step (step N)) (addIt zeroIt zeroIt) zeroIt+testIt1 = propAddIt zeroIt++testIt2 : step (step N)+testIt2 = zeroIt++testIt3 : step (step N)+testIt3 = addIt zeroIt zeroIt++step4 : U -> U+step4 x = step (step (step (step x)))++aZNIt2 : aZero (step4 N)+aZNIt2 = subst U aZero N (step4 N) isoNOIt2 aZN++zeroIt2 : step4 N+zeroIt2 = aZNIt2.1++sndaZNIt2 : Sigma ((step4 N) -> (step4 N) -> (step4 N))+                                 (\ f -> (x:(step4 N)) -> Id (step4 N) (f zeroIt2 x) x)+sndaZNIt2 = aZNIt2.2++addIt2 : (step4 N) -> (step4 N) -> step4 N+addIt2 = sndaZNIt2.1++propAddIt2 : (x:step4 N) -> Id (step4 N) (addIt2 zeroIt2 x) x+propAddIt2 = sndaZNIt2.2++inl4 : N -> step4 N+inl4 x = inl (inl (inl (inl x)))++testIt2 : step4 N+testIt2 = addIt2 (inl4 zero) (inl4 zero)++testIt21 : Id (step4 N) (addIt2 zeroIt2 zeroIt2) zeroIt2+testIt21 = propAddIt2 zeroIt2++testIt22 : step4 N+testIt22 = zeroIt2++testIt23 : step4 N+testIt23 = addIt2 zeroIt2 zeroIt2
examples/omega.cub view
@@ -11,83 +11,82 @@ -- if B is a family of proposition over A then Sigma A B -> A is injective  lemPInj1 :  (A : U) (B : A -> U) -> ((x:A) -> prop (B x)) -> (a0 a1:A) -> (p:Id A a0 a1) ->-            (b0:B a0) -> (b1:B a1) -> Id (Sigma A B) (pair a0 b0) (pair a1 b1)-lemPInj1 A B pB a0 =  J A a0 C rem+            (b0:B a0) -> (b1:B a1) -> Id (Sigma A B) (a0,b0) (a1,b1)+lemPInj1 A B pB a0 a1 p = subst A C a0 a1 p rem  where-  C : (a1:A) -> Id A a0 a1 -> U-  C a1 p = (b0:B a0) -> (b1:B a1) -> Id (Sigma A B) (pair a0 b0) (pair a1 b1)+  C : A -> U                                      -- (a1:A) -> Id A a0 a1 -> U+  C a1 = (b0:B a0) -> (b1:B a1) -> Id (Sigma A B) (a0,b0) (a1,b1) -  rem : C a0 (refl A a0)-  rem b0 b1 = cong (B a0) (Sigma A B) (\ b -> pair a0 b) b0 b1 (pB a0 b0 b1)+  rem : C a0+  rem b0 b1 = mapOnPath (B a0) (Sigma A B) (\ b -> (a0,b)) b0 b1 (pB a0 b0 b1) -lemPropInj : (A : U) (B : A -> U) -> ((x:A) -> prop (B x)) -> injective (Sigma A B) A (fst A B)-lemPropInj A B pB =- split -  pair a0 b0 -> split-                 pair a1 b1 -> \ p -> lemPInj1 A B pB a0 a1 p b0 b1+lemPropInj : (A : U) (B : A -> U) -> ((x:A) -> prop (B x)) -> injective (Sigma A B) A (\ z -> z.1)+lemPropInj A B pB z0 z1 p = lemPInj1 A B pB z0.1 z1.1 p z0.2 z1.2 + lemPInj2 :  (A : U) (B : A -> U) -> (pB: (x:A) -> prop (B x)) -> (z:Sigma A B) ->-            Id (Id (Sigma A B) z z) (refl (Sigma A B) z) (lemPropInj A B pB z z (refl A (fst A B z)))-lemPInj2 A B pB = - split -  pair a b -> rem+            Id (Id (Sigma A B) z z) (refl (Sigma A B) z) (lemPropInj A B pB z z (refl A z.1))+lemPInj2 A B pB z = rem    where     T : U-    T = Sigma A B +    T = Sigma A B +    a:A+    a = z.1++    b : B a+    b = z.2+     L : U-    L = Id T (pair a b) (pair a b)+    L = Id T z z -    C : (a1:A) -> Id A a a1 -> U-    C a1 p = (b0 : B a) ->  (b1:B a1) -> Id T (pair a b0) (pair a1 b1)+    C : A -> U+    C a1 = (b0 : B a) ->  (b1:B a1) -> Id T (z.1,b0) (a1,b1) -    rem2 : C a (refl A a)-    rem2 b0 b1 = cong (B a) T (\ b -> pair a b) b0 b1 (pB a b0 b1)+    rem2 : C a+    rem2 b0 b1 = mapOnPath (B a) T (\ b -> (z.1,b)) b0 b1 (pB a b0 b1) -    rem1 : Id (C a (refl A a)) rem2 (lemPInj1 A B pB a a (refl A a))-    rem1 = Jeq A a C rem2-             +    rem1 : Id (C a) rem2 (lemPInj1 A B pB a a (refl A a))+    rem1 = substeq A C a rem2+     Lb : U     Lb = Id (B a) b b      rem4 : Id Lb  (refl (B a) b) (pB a b b)     rem4 = propUIP (B a) (pB a) b b (refl (B a) b) (pB a b b) -    rem3 : Id L (cong (B a) T (\ b -> pair a b) b b (refl (B a) b)) (rem2 b b)-    rem3 = cong Lb L (cong (B a) T (\ b -> pair a b) b b) (refl (B a) b) (pB a b b) rem4-        -    rem5 : Id ((b1 : B a) -> Id T (pair a b) (pair a b1)) (rem2 b) (lemPInj1 A B pB a a (refl A a) b)-    rem5 = appEq (B a) (\ b0 -> (b1 : B a) -> Id T (pair a b0) (pair a b1)) b rem2 (lemPInj1 A B pB a a (refl A a)) rem1-     -    rem6 : Id L (rem2 b b) (lemPInj1 A B pB a a (refl A a) b b)-    rem6 = appEq (B a) (\ b1 -> Id T (pair a b) (pair a b1)) b (rem2 b) (lemPInj1 A B pB a a (refl A a) b) rem5+    rem3 : Id L (mapOnPath (B a) T (\ b -> (a,b)) b b (refl (B a) b)) (rem2 b b)+    rem3 = mapOnPath Lb L (mapOnPath (B a) T (\ b -> (a,b)) b b) (refl (B a) b) (pB a b b) rem4 -    rem7 : Id L (refl T (pair a b)) (cong (B a) T (\ b -> pair a b) b b (refl (B a) b))-    rem7 = congRefl (B a) T (\ b -> pair a b) b+    rem5 : Id ((b1 : B a) -> Id T (a,b) (a,b1)) (rem2 b) (lemPInj1 A B pB a a (refl A a) b)+    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 -    rem8 : Id L (refl T (pair a b)) (rem2 b b)-    rem8 = comp L (refl T (pair a b)) (cong (B a) T (\ b -> pair a b) b b (refl (B a) b)) (rem2 b b) rem7 rem3+    rem6 : Id L (rem2 b b) (lemPInj1 A B pB a a (refl A a) b b)+    rem6 = appEq (B a) (\ b1 -> Id T (a,b) (a,b1)) b+                (rem2 b) (lemPInj1 A B pB a a (refl A a) b) rem5 -    rem : Id L (refl T (pair a b)) (lemPInj1 A B pB a a (refl A a) b b)-    rem = comp L (refl T (pair a b)) (rem2 b b) (lemPInj1 A B pB a a (refl A a) b b) rem8 rem6+    rem : Id L (refl T (a,b)) (lemPInj1 A B pB a a (refl A a) b b)+    rem = comp L (refl T (a,b)) (rem2 b b) (lemPInj1 A B pB a a (refl A a) b b) rem3 rem6  -- we should be able to deduce from all this that Omega is a set  isTrue : Omega -> U-isTrue = fst U prop+isTrue z = z.1  lemIsTrue : (x y : Omega) -> (isTrue x -> isTrue y) -> (isTrue y -> isTrue x) -> Id Omega x y lemIsTrue x y f g = injf x y rem- where -   G : (x:Omega) -> prop (isTrue x)-   G = snd U prop-+ where    injf : injective Omega U isTrue    injf = lemPropInj U prop propIsProp     rem : Id U (isTrue x) (isTrue y)-   rem = propId (isTrue x) (isTrue y) (G x) (G y) f g +   rem = propId (isTrue x) (isTrue y) x.2 y.2 f g +lemInj : (A B : U) (f : A -> B) -> (injf : injective A B f)+              -> ((x:A) -> Id (Id A x x) (refl A x) (injf x x (refl B (f x))))+              -> (x y : A) -> (p:Id A x y) -> Id (Id A x y) p (injf x y (mapOnPath A B f x y p))+lemInj A B f injf h x =+ J A x (\ y p -> Id (Id A x y) p (injf x y (mapOnPath A B f x y p))) (h x)  omegaIsSet : set Omega omegaIsSet = rem4@@ -96,35 +95,30 @@    rem = propIsProp     g : (x:Omega) -> prop (isTrue x)-   g = snd U prop+   g x = x.2     injf : injective Omega U isTrue-   injf = lemPropInj U prop rem +   injf = lemPropInj U prop rem     rem1 : (z:Omega) -> Id (Id Omega z z) (refl Omega z) (injf z z (refl U (isTrue z)))    rem1 = lemPInj2 U prop rem-   -   rem2 : (x y : Omega) -> (p : Id Omega x y) -> Id (Id Omega x y) p (injf x y (cong Omega U isTrue x y p))++   rem2 : (x y : Omega) -> (p : Id Omega x y)+      -> Id (Id Omega x y) p (injf x y (mapOnPath Omega U isTrue x y p))    rem2 = lemInj Omega U isTrue injf rem1     rem3 : (x y : Omega) -> prop (Id U (isTrue x) (isTrue y))    rem3 x y = idPropIsProp (isTrue x) (isTrue y) (g x) (g y)     rem4 : (x y : Omega) -> (p q : Id Omega x y) -> Id (Id Omega x y) p q-   rem4 x y p q = compDown (Id Omega x y) p (injf x y (h p)) q (injf x y (h q)) rem6 rem7 rem8+   rem4 x y p q = compDown (Id Omega x y) p (injf x y (h p)) q (injf x y (h q))+                       (rem2 x y p) (rem2 x y q) rem8      where         h : Id Omega x y -> Id U (isTrue x) (isTrue y)-        h = cong Omega U isTrue x y+        h = mapOnPath Omega U isTrue x y          rem5 : Id (Id U (isTrue x) (isTrue y)) (h p) (h q)         rem5 = rem3 x y (h p) (h q) -        rem6 : Id (Id Omega x y) p (injf x y (h p))-        rem6 = rem2 x y p--        rem7 : Id (Id Omega x y) q (injf x y (h q))-        rem7 = rem2 x y q-         rem8 : Id (Id Omega x y) (injf x y (h p)) (injf x y (h q))-        rem8 = cong (Id U (isTrue x) (isTrue y)) (Id Omega x y) (injf x y) (h p) (h q) rem5-+        rem8 = mapOnPath (Id U (isTrue x) (isTrue y)) (Id Omega x y) (injf x y) (h p) (h q) rem5
+ examples/opacity.cub view
@@ -0,0 +1,12 @@+module opacity where+import prelude++-- The effect ot opacity is local+x : Unit+x = y where+  y : Unit+  y = tt+  opaque y++test : Id Unit x tt+test = refl Unit tt
+ examples/opacity_fail.cub view
@@ -0,0 +1,21 @@+module opacity_fail where++import primitives++Bool : U+data Bool = true | false++x : Bool+x = false++opaque x++y : Bool+y = x+  where x : Bool+        x = true++failure : Id Bool x y+failure = refl Bool x++transparent x
examples/prelude.cub view
@@ -1,8 +1,7 @@ -- some basic data types and functions- module prelude where -import primitive+import primitives  rel : U -> U rel A = A -> A -> U@@ -16,14 +15,6 @@ Pi : (A:U) -> (A -> U) -> U Pi A B = (x:A) -> B x -fst : (A : U) (B : A -> U) -> Sigma A B -> A-fst A B = split-  pair a b -> a--snd : (A : U) (B : A -> U) (p : Sigma A B) -> B (fst A B p)-snd A B = split-  pair a b -> b- -- some data types  Unit : U@@ -55,18 +46,22 @@         zero -> zero         suc n -> n +-- subst : (A : U) (P : A -> U) (a x : A) (p : Id A a x) -> P a -> P x+-- subst A P a x p d = J A a (\ x q -> P x) d x p+ subst : (A : U) (P : A -> U) (a x : A) (p : Id A a x) -> P a -> P x-subst A P a x p d = J A a (\ x q -> P x) d x p+subst A P a x p = transport (P a) (P x) (mapOnPath A U P a x p)  substInv : (A : U) (P : A -> U) (a x : A) (p : Id A a x) -> P x -> P a substInv A P a x p = subst A (\ y -> P y -> P a) a x p (\ h -> h) -substeq : (A : U) (P : A -> U) (a : A) (d : P a) ->-          Id (P a) d (subst A P a a (refl A a) d)-substeq A P a d = Jeq A a (\ x q -> P x) d+-- substeq : (A : U) (P : A -> U) (a : A) (d : P a) ->+--           Id (P a) d (subst A P a a (refl A a) d)+-- substeq A P a d = Jeq A a (\ x q -> P x) d -cong : (A B : U) (f : A -> B) (a b : A) (p : Id A a b) -> Id B (f a) (f b)-cong A B f a b p = subst A (\x -> Id B (f a) (f x)) a b p (refl B (f a))+substeq : (A : U) (P : A -> U) (a : A) (d : P a) ->+           Id (P a) d (subst A P a a (refl A a) d)+substeq A P a d = transportRef (P a) d  N0 : U data N0 =@@ -81,7 +76,7 @@ data or A B = inl (a : A) | inr (b : B)  orElim : (A B C:U) -> (A->C) -> (B -> C) -> or A B -> C-orElim A B C f g = +orElim A B C f g =  split   inl a -> f a   inr b -> g b@@ -118,26 +113,44 @@     true -> inr fnott     false -> inl (refl Bool (false)) +N0Dec : discrete N0+N0Dec x y = inl rem+ where rem : Id N0 x y+       rem = efq (Id N0 x y) x++unitDec : discrete Unit+unitDec = split+  tt -> split+          tt -> inl (refl Unit tt)+ notK : (x : Bool) -> Id Bool (not (not x)) x notK = split   true  -> refl Bool (true)   false -> refl Bool (false)  appId : (A B : U) (a : A) (f0 f1 : A -> B) -> Id (A -> B) f0 f1 -> Id B (f0 a) (f1 a)-appId A B a = cong (A->B) B (\ f -> f a) +appId A B a = mapOnPath (A->B) B (\ f -> f a)  appEq : (A :U) (B : A -> U) (a : A) (f0 f1 : Pi A B) -> Id (Pi A B) f0 f1 -> Id (B a) (f0 a) (f1 a)-appEq A B a = cong (Pi A B) (B a) (\ f -> f a) +appEq A B a = mapOnPath (Pi A B) (B a) (\ f -> f a) -sId : (A : U) (a : A) -> pathTo A a-sId A a = pair a (refl A a)+J : (A : U) (a : A) (C : (x : A) -> Id A a x -> U) (d: C a (refl A a)) (x : A) (p : Id A a x)+      -> C x p+J A a C d x p = subst (singl A a) T (a, refl A a) (x, p) (contrSingl A a x p) d+ where T : singl A a -> U+       T z = C (z.1) (z.2) +funExt : (A : U) (B : A -> U) (f g : (a : A) -> B a)+         (p : ((x : A) -> (Id (B x) (f x) (g x)))) -> Id ((y : A) -> B y) f g+funExt A B f g p = funHExt A B f g rem+  where rem : (a x : A) -> (p : Id A a x) -> (IdS A B a x p (f a) (g x))+        rem a = J A a (\ x p -> (IdS A B a x p (f a) (g x))) (p a)+ tId : (A : U) (a : A) (v : pathTo A a) -> Id (pathTo A a) (sId A a) v-tId A a = split -  pair x p -> rem x a p -  where -  rem : (x y : A) (p : Id A x y) -> Id (pathTo A y) (sId A y) (pair x p)-  rem x = J A x (\y p -> Id (pathTo A y) (sId A y) (pair x p)) (refl (pathTo A x) (sId A x))+tId A a z = rem (z.1) a (z.2)+   where+    rem : (x y : A) (p : Id A x y) -> Id (pathTo A y) (sId A y) (x, p)+    rem x = J A x (\y p -> Id (pathTo A y) (sId A y) (x, p)) (refl (pathTo A x) (sId A x))  typEquivS : (A B : U) -> (f : A -> B) -> U typEquivS A B f = (y : B) -> fiber A B f y@@ -149,8 +162,7 @@ isEquiv A B f = Sigma (typEquivS A B f) (typEquivT A B f)  isEquivEq : (A B : U) (f : A -> B) -> isEquiv A B f -> Id U A B-isEquivEq A B f = split -  pair s t -> equivEq A B f s t+isEquivEq A B f z = equivEq A B f z.1 z.2  -- not needed if we have eta @@ -160,10 +172,6 @@ funSplit : (A:U) (B:A->U) (C: (Pi A B) -> U) -> ((f:Pi A B) -> C (\ x -> f x)) -> Pi (Pi A B) C funSplit A B C eC f = subst (Pi A B) C (\ x -> f x) f (etaId A B f) (eC f) -surjPair : (A:U) (B:A -> U) -> (s:Sigma A B) -> Id (Sigma A B) (pair (fst A B s) (snd A B s)) s-surjPair A B = split-                pair a b -> refl (Sigma A B) (pair a b)- lemProp1 : (A : U) -> (A -> prop A) -> prop A lemProp1 A h a0 = h a0 a0 @@ -180,19 +188,19 @@  lemProp2 : (A : U) -> prop A -> prop (dec A) lemProp2 A pA  = split- inl a -> split -           inl b -> cong A (dec A) (\ x -> inl x) a b (pA a b)+ inl a -> split+           inl b -> mapOnPath A (dec A) (\ x -> inl x) a b (pA a b)            inr nb -> efq (Id (dec A) (inl a) (inr nb)) (nb a)- inr na -> split + inr na -> split            inl b -> efq (Id (dec A) (inr na) (inl b)) (na b)-           inr nb -> cong (neg A) (dec A) (\ x -> inr x) na nb (propNeg A na nb)+           inr nb -> mapOnPath (neg A) (dec A) (\ x -> inr x) na nb (propNeg A na nb)  singl : (A:U) -> A -> U singl = pathTo -- singl = Sigma A (\ x -> Id A x a)  idIsEquiv : (A:U) -> isEquiv A A (id A)-idIsEquiv A = pair (sId A) (tId A)+idIsEquiv A = (sId A, tId A)  propUnit : prop Unit propUnit = split@@ -200,7 +208,7 @@      tt -> refl Unit (tt)  sucInj : (n m : N) -> Id N (suc n) (suc m) -> Id N n m-sucInj n m h = cong N N pred (suc n) (suc m) h+sucInj n m h = mapOnPath N N pred (suc n) (suc m) h  decEqCong : (A B : U) (f : A -> B) (g : B -> A) -> dec A -> dec B decEqCong A B f g = split@@ -231,10 +239,10 @@   suc n -> split     zero -> inr (snotz n)     suc m -> decEqCong (Id N n m) (Id N (suc n) (suc m))-                       (cong N N (\ x -> suc x) n m) (sucInj n m) (natDec n m)+                       (mapOnPath N N (\ x -> suc x) n m) (sucInj n m) (natDec n m)  propPi : (A : U) (B : A -> U) -> ((x : A) -> prop (B x)) -> prop ((x : A) -> B x)-propPi A B h f0 f1 = funExt A B f0 f1 (\x -> h x (f0 x) (f1 x)) +propPi A B h f0 f1 = funExt A B f0 f1 (\x -> h x (f0 x) (f1 x))  propImply : (A B : U) -> (A -> prop B) -> prop (A -> B) propImply A B h = propPi A (\_ -> B) h@@ -252,16 +260,13 @@ equivalence A R = and (reflexive A R) (euclidean A R)  eqToRefl : (A : U) (R : rel A) -> equivalence A R -> reflexive A R-eqToRefl A R = split-  pair r _ -> r+eqToRefl A R z = z.1  eqToEucl : (A : U) (R : rel A) -> equivalence A R -> euclidean A R-eqToEucl A R = split-  pair _ e -> e+eqToEucl A R z = z.2  eqToSym : (A : U) (R : rel A) -> equivalence A R -> symmetry A R-eqToSym A R = split-  pair r e -> \a b -> e b a b (r b)+eqToSym A R z a b = (z.2) b a b (z.1 b)  eqToInvEucl : (A : U) (R : rel A) -> equivalence A R ->               (a b c : A) -> R c a -> R c b -> R a b@@ -272,20 +277,19 @@ -- needed for Nicolai Kraus example  defCase : (A X:U) -> X -> X -> dec A -> X-defCase A X x0 x1 = +defCase A X x0 x1 =  split   inl _ -> x0   inr _ -> x1 -IdDefCasel : (A X:U) (x0 x1 : X) (p : dec A)  -> A -> +IdDefCasel : (A X:U) (x0 x1 : X) (p : dec A)  -> A ->              Id X (defCase A X x0 x1 p) x0 IdDefCasel A X x0 x1 = split  inl _ -> \ _ -> refl X x0  inr v -> \ u -> efq (Id X (defCase A X x0 x1 (inr v)) x0) (v u) -IdDefCaser : (A X:U) (x0 x1 : X) (p : dec A)  -> (neg A) -> +IdDefCaser : (A X:U) (x0 x1 : X) (p : dec A)  -> (neg A) ->              Id X (defCase A X x0 x1 p) x1 IdDefCaser A X x0 x1 = split  inl u -> \ v -> efq (Id X (defCase A X x0 x1 (inl u)) x1) (v u)  inr _ -> \ _ -> refl X x1-
− examples/primitive.cub 
@@ -1,68 +0,0 @@-module primitive where--Id   : (A : U) (a b : A) -> U-Id = PN--refl : (A : U) (a : A) -> Id A a a-refl = PN-funExt : (A : U) (B : (a : A) -> U) (f g : (a : A) -> B a)-         (p : ((x : A) -> (Id (B x) (f x) (g x)))) -> Id ((y : A) -> B y) f g-funExt = PN--J : (A : U) (a : A) -> (C : (x : A) -> Id A a x -> U) -> C a (refl A a) ->-      (x : A) -> (p : Id A a x) -> C x p-J = PN--Jeq : (A : U) (a : A) -> (C : (x : A) -> Id A a x -> U) -> (d : C a (refl A a)) ->-        Id (C a (refl A a)) d (J A a C d a (refl A a))-Jeq = PN--inh : U -> U-inh = PN--inc : (A : U) -> A -> inh A-inc = PN--prop : U -> U-prop A = (a b : A) -> Id A a b--squash : (A : U) -> prop (inh A)-squash = PN--inhrec : (A : U) (B : U) (p : prop B) (f : A -> B) (a : inh A) -> B-inhrec = PN--Sigma : (A : U) (B : A -> U) -> U-data Sigma A B = pair (x : A) (y : B x)--fiber : (A B : U) (f : A -> B) (y : B) -> U-fiber A B f y = Sigma A (\x -> Id B (f x) y)--id : (A : U) -> A -> A-id A a = a--pathTo : (A:U) -> A -> U-pathTo A = fiber A A (id A)--equivEq : (A B : U) (f : A -> B) (s : (y : B) -> fiber A B f y)-            (t : (y : B) -> (v : fiber A B f y) -> Id (fiber A B f y) (s y) v) ->-            Id U A B-equivEq = PN--transport : (A B : U) -> Id U A B -> A -> B-transport = PN--transportRef : (A : U) -> (a : A) -> Id A a (transport A A (refl U A) a)-transportRef = PN--equivEqRef : (A : U) -> (s : (y : A) -> pathTo A y) -> -             (t : (y : A) -> (v : pathTo A y) -> Id (pathTo A y) (s y) v) ->-             Id (Id U A A) (refl U A) (equivEq A A (id A) s t)-equivEqRef = PN	       --transpEquivEq : (A B : U) -> (f : A -> B) (s : (y : B) -> fiber A B f y) -> -                (t : (y : B) -> (v : fiber A B f y) -> Id (fiber A B f y) (s y) v) ->-                (a : A) -> Id B (f a) (transport A B (equivEq A B f s t) a)-transpEquivEq = PN--
+ examples/primitives.cub view
@@ -0,0 +1,101 @@+module primitives where++primitive Id : (A : U) (a b : A) -> U++primitive refl : (A : U) (a : A) -> Id A a a++primitive inh : U -> U++primitive inc : (A : U) -> A -> inh A++prop : U -> U+prop A = (a b : A) -> Id A a b++primitive squash : (A : U) -> prop (inh A)++primitive inhrec : (A : U) (B : U) (p : prop B) (f : A -> B) (a : inh A) -> B++Sigma : (A : U) (B : A -> U) -> U+Sigma A B = (x : A) * B x++fiber : (A B : U) (f : A -> B) (y : B) -> U+fiber A B f y = Sigma A (\x -> Id B (f x) y)++id : (A : U) -> A -> A+id A a = a++pathTo : (A:U) -> A -> U+pathTo A = fiber A A (id A)++sId : (A : U) (a : A) -> pathTo A a+sId A a = (a, refl A a)++singl : (A : U) -> A -> U+singl A a = Sigma A (Id A a)++primitive contrSingl : (A : U) (a b : A) (p : Id A a b) ->+                       Id (singl A a) (a, refl A a) (b, p)++primitive equivEq : (A B : U) (f : A -> B) (s : (y : B) -> fiber A B f y)+                    (t : (y : B) -> (v : fiber A B f y) ->+                    Id (fiber A B f y) (s y) v) -> Id U A B++primitive transport : (A B : U) -> Id U A B -> A -> B++primitive transpInv : (A B : U) -> Id U A B -> B -> A++primitive transportRef : (A : U) (a : A) -> Id A a (transport A A (refl U A) a)++primitive equivEqRef : (A : U) -> (s : (y : A) -> pathTo A y) ->+                       (t : (y : A) -> (v : pathTo A y) ->+                       Id (pathTo A y) (s y) v) ->+                       Id (Id U A A) (refl U A) (equivEq A A (id A) s t)++primitive transpEquivEq :+  (A B : U) -> (f : A -> B) (s : (y : B) -> fiber A B f y) ->+  (t : (y : B) -> (v : fiber A B f y) -> Id (fiber A B f y) (s y) v) ->+  (a : A) -> Id B (f a) (transport A B (equivEq A B f s t) a)++primitive mapOnPath : (A B : U) (f : A -> B) (a b : A)+                      (p : Id A a b) -> Id B (f a) (f b)++primitive 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)++primitive IdP : (A B : U) -> Id U A B -> A -> B -> U++IdS : (A : U) (F : A -> U) (a0 a1 : A) (p : Id A a0 a1) -> F a0 -> F a1 -> U+IdS A F a0 a1 p = IdP (F a0) (F a1) (mapOnPath A U F a0 a1 p)++primitive mapOnPathD : (A : U) (F : A -> U) (f : (x : A) -> F x) (a0 a1 : A)+                       (p : Id A a0 a1) -> IdS A F a0 a1 p  (f a0) (f a1)++primitive mapOnPathS : (A : U) (F : A -> U) (C : U) (f : (x : A) -> F x -> C)+                       (a0 a1 : A) (p : Id A a0 a1) (b0 : F a0) (b1 : F a1)+                       (q : IdS A F a0 a1 p b0 b1) -> Id C (f a0 b0) (f a1 b1)++primitive funHExt : (A : U) (B : A -> U) (f g : (a : A) -> B a) ->+                    ((x y : A) -> (p : Id A x y) -> IdS A B x y p (f x) (g y)) ->+                    Id ((y : A) -> B y) f g++-- The circle.+primitive S1 : U++primitive base : S1++primitive loop : Id S1 base base++primitive S1rec : (F : S1 -> U) (b : F base)+                  (l : IdS S1 F base base loop b b) (x : S1) -> F x++-- The interval.+primitive I : U++primitive I0 : I++primitive I1 : I++primitive line : Id I I0 I1++primitive intrec : (F : I -> U) (s : F I0) (e : F I1)+                   (l : IdS I F I0 I1 line s e) (x : I) -> F x
examples/quotient.cub view
@@ -24,7 +24,7 @@         cp : (a b : A) -> R c a -> R a b -> R c b         cp a b p q = eqToEucl A R h c b a p (eqToSym A R h a b q)         ex : exists A (R c)-        ex = inc (Sigma A (R c)) (pair c (eqToRefl A R h c))+        ex = inc (Sigma A (R c)) (c,eqToRefl A R h c)         pr : propFam A (R c)         pr a = h' c a @@ -63,40 +63,34 @@           S b a = and (P a) (Id B (f a) b)            rem3 : Sigma A P -> exists B imfP-          rem3 = split-            pair a p -> inc (Sigma B imfP)-                        (pair (f a) (inc (Sigma A (S (f a))) (pair a (pair p (refl B (f a))))))+          rem3 z = inc (Sigma B imfP)+                       (f z.1,inc (Sigma A (S (f z.1))) (z.1,(z.2,refl B (f z.1))))           rem4 : exists B imfP           rem4 = inhrec (Sigma A P) (exists B imfP) (squash (Sigma B imfP)) rem3 ex            rem6 : (b b' : B) (a a' : A) (_ : and (P a) (Id B (f a) b))              (_ : and (P a') (Id B (f a') b')) -> Id B b b'-          rem6 b b' a a' = split-            pair p ea -> split-              pair p' ea' -> compUp B (f a) b (f a') b' ea ea' rem7+          rem6 b b' a a' z z' = compUp B (f a) b (f a') b' z.2 z'.2 rem7                 where rem8 : R a a'-                      rem8 = un a a' p p'+                      rem8 = un a a' z.1 z'.1                       rem7 : Id B (f a) (f a')                       rem7 = fresp a a' rem8                      -          rem7 : (b b' : B)  (_ : Sigma A (S b)) (_ : Sigma A (S b'))-             -> Id B b b'-          rem7 b b' = split-            pair a p -> split-              pair a' p' -> rem6 b b' a a' p p'+          rem7 : (b b' : B) -> Sigma A (S b) ->  Sigma A (S b') -> Id B b b'+          rem7 b b' z z' = rem6 b b' z.1 z'.1 z.2 z'.2            rem8 : (b b' : B) -> Sigma A (S b) -> exists A (S b') -> Id B b b'           rem8 b b' h = exElim A (S b') (Id B b b') (uip b b') (rem7 b b' h)            rem9 : (b b' : B) -> exists A (S b) -> exists A (S b') -> Id B b b'           rem9 b b' h h' = exElim A (S b) (Id B b b') (uip b b')-                        (\h'' -> rem8 b b' h'' h') h+                                    (\h'' -> rem8 b b' h'' h') h            rem5 : atmostOne B imfP           rem5 = rem9            rem2 : exactOne B imfP-          rem2 = pair rem4 rem5+          rem2 = (rem4,rem5)   kernel : (A B : U) (f : A -> B) -> rel A@@ -113,7 +107,7 @@        rem1 = inv B (f b) (f c) q  kerEquiv : (A B : U) (f : A -> B) -> equivalence A (kernel A B f)-kerEquiv A B f = pair (kerRef A B f) (kerEucl A B f)+kerEquiv A B f = (kerRef A B f,kerEucl A B f)   mod2 : rel N
+ examples/spector.cub view
@@ -0,0 +1,68 @@+-- An example similar to Martin Escardo on Cantor's search+-- implement Spector double negation shift, following the presentation in+-- a proof of strong normalization using domain theory++-- needs mutual recursion++module spector where++import prelude++leqN : N -> N -> U+leqN = split+        zero -> \ m -> Unit+        suc n -> split+                  zero -> N0+                  suc m -> leqN n m++lessN : (n:N) (m:N) -> or (leqN (suc n) m) (leqN m n)+lessN = split+        zero ->  split+                  zero -> inr tt+                  suc m -> inl tt+        suc n -> split+                  zero -> inr tt+                  suc m -> lessN n m++vect : (N->U) -> N -> U+vect B = split+          zero -> Unit+          suc n -> and (vect B n) (B n)++head : (B:N->U) (n:N) -> vect B (suc n) -> B n+head B n p = p.2++tail : (B:N->U) (n:N) -> vect B (suc n) -> vect B n+tail B n p = p.1++-- we follow the notation of the paper++get : (B:N-> U) (n m:N) -> (leqN (suc m) n) -> vect B n -> B m+get B n m p v = head B m (trim (suc m) n p (vect B) (tail B) v)+ where+   T : (N -> U) -> U+   T P = (k:N) -> P (suc k) -> P k++   trim : (n m:N) -> (leqN n m) -> (P:N->U) -> T P -> P m -> P n+   trim = split+           zero -> split+                    zero -> \ p P h v -> v+                    suc m -> \ p P h v -> trim zero m p P h (h m v)+           suc n -> split+                    zero -> \ p P h v -> efq (P (suc n)) p+                    suc m -> \ p P h v -> trim n m p (\ x -> P (suc x)) (\ x -> h (suc x)) v++mutual+ Phi : (B:N->U) -> ((n:N) -> neg (neg (B n))) ->+        neg (Pi N B) -> (n:N) -> neg (vect B n)+ Psi : (B:N->U) -> ((n:N) -> neg (neg (B n))) ->+        neg (Pi N B) -> (n:N) -> vect B n ->+        (x : N) -> (or (leqN (suc x) n) (leqN n x)) -> B x++ Phi B H K n v = K (\x -> Psi B H K n v x (lessN x n))+ Psi B H K n v x = split+  inl p -> get B n x p v+  inr p -> efq (B x) (H n (\ y -> Phi B H K (suc n) (v, y)))++spector : (B:N->U) -> ((n:N) -> neg (neg (B n))) -> neg (neg (Pi N B))+spector B H K = Phi B H K zero tt
examples/subset.cub view
@@ -17,42 +17,26 @@ -- map in both directions  sub12 : (A:U) -> subset1 A -> subset2 A-sub12 A = split-           pair X f -> fiber X A f+sub12 A z = fiber z.1 A z.2  sub21 : (A:U) -> subset2 A -> subset1 A-sub21 A P = pair (Sigma A P) (fst A P)+sub21 A P = (Sigma A P,\ x -> x.1)  retsub : (A:U) -> (P : subset2 A) -> Id (subset2 A) (sub12 A (sub21 A P)) P-retsub A P = funExt A (\ _ -> U) (fiber (Sigma A P) A (fst A P)) P (lem1Sub A P)-+retsub A P = funExt A (\ _ -> U) (fiber (Sigma A P) A (\x -> x.1)) P (lem1Sub A P)  -- in the other direction we use a corollary of equivalence -eqSigmaEquiv : (A B :U) (f:A -> B) -> isEquiv A B f -> (Q:B -> U) -> Id U (Sigma A (\ x -> Q (f x))) (Sigma B Q)-eqSigmaEquiv A = elimIsEquiv A C rem- where-  C : (B:U) -> (A->B) -> U-  C B f = (Q:B->U) -> Id U (Sigma A (\ y -> Q (f y))) (Sigma B Q)--  rem : (Q:A->U) -> Id U (Sigma A (\ y -> Q y)) (Sigma A Q)-  rem Q =  cong (A -> U) U (Sigma A) (\ y -> Q y) Q (funExt A (\ _ -> U) (\ y -> Q y) Q(\ y -> refl U (Q y)))---- but actually this is not this consequence that we need- lemSecSub : (A X Y:U)(g:X->Y) -> isEquiv X Y g -> (f:Y -> A) ->-    Id (subset1 A) (pair Y f) (pair X (\ y -> f (g y))) -lemSecSub A X = elimIsEquiv X P rem+    Id (subset1 A) (Y,f) (X,\ y -> f (g y))+lemSecSub A X = elimIsEquiv X P (\ f -> refl (subset1 A) (X,f))  where   P : (Y:U) -> (X->Y) -> U-  P Y g = (f:Y -> A) -> Id (subset1 A) (pair Y f) (pair X (\ y -> f (g y))) --  rem : (f:X -> A) -> Id (subset1 A) (pair X f) (pair X (\ y -> f y)) -  rem f = cong (X->A) (subset1 A) (\ h -> pair X h) f (\ y -> f y) -                 (funExt X (\ _ -> A) f (\ y -> f y) (\ y -> refl A (f y)))+  P Y g = (f:Y -> A) -> Id (subset1 A) (Y,f) (X,\ y -> f (g y)) -lem2SecSub : (A X:U) (f:X -> A) -> isEquiv X (Sigma A (fiber X A f)) (\ x -> pair (f x) (pair x (refl A (f x))))-lem2SecSub A X f = rem2+lem2SecSub : (A X:U) (f:X -> A) -> +               isEquiv X (Sigma A (fiber X A f)) (\ x -> (f x,(x,refl A (f x))))+lem2SecSub A X f =  gradLemma X Y g h rgh sgh  where     F : A -> U     F = fiber X A f @@ -61,104 +45,79 @@     Y = Sigma A F      h : Y -> A-    h = fst A F+    h y = y.1      g : X -> Y-    g x = pair (f x) (pair x (refl A (f x)))+    g x = (f x,(x,refl A (f x)))      h : Y -> X-    h = split-         pair a xp -> fst X (\ x -> Id A (f x) a) xp+    h y = y.2.1      Z : U     Z = Sigma X (\ x -> Sigma A (\ a -> Id A (f x) a))      sw1 : Y -> Z-    sw1 = split-           pair a xp -> asw1 xp-              where asw1 : Sigma X (\ x -> Id A (f x) a) -> Z-                    asw1 = split -                             pair x p -> pair x (pair a p)+    sw1 y = (y.2.1,(y.1,y.2.2))      sw2 : Z -> Y-    sw2 = split-           pair x ap -> asw2 ap-              where asw2 : Sigma A (\ a -> Id A (f x) a) -> Y-                    asw2 = split -                             pair a p -> pair a (pair x p)--    lemsw : (y:Y) -> Id Y (sw2 (sw1 y)) y-    lemsw = split-             pair a xp -> lemsw1 xp-               where lemsw1 : (xp : Sigma X (\ x -> Id A (f x) a)) -> Id Y (sw2 (sw1 (pair a xp))) (pair a xp)-                     lemsw1 = split-                               pair x p -> refl Y (pair a (pair x p))               +    sw2 z = (z.2.1,(z.1,z.2.2))      sgh : (x:X) -> Id X (h (g x)) x     sgh x = refl X x      rgh : (y:Y) -> Id Y (g (h y)) y-    rgh = split-           pair a xp -> lem xp-             where -               lem : (xp : Sigma X (\ x -> Id A (f x) a)) -> Id Y (g (h (pair a xp))) (pair a xp)-               lem = split-                       pair x p -> lem1+    rgh y = lem y.2+              where +               lem : (xp : Sigma X (\ x -> Id A (f x) y.1)) -> Id Y (g (h (y.1,xp))) (y.1,xp)+               lem xp = lem1                             where+                              x:X+                              x = xp.1++                              p : Id A (f x) y.1+                              p = xp.2+                               C : (v u:A) -> Id A v u -> U-                              C v u q =  Id (Sigma A (\ w -> Id A v w)) (pair v (refl A v)) (pair u q)+                              C v u q =  Id (Sigma A (Id A v)) (v,refl A v) (u,q)                                lem5 : (v:A) -> C v v (refl A v)-                              lem5 v = refl (Sigma A (\ w -> Id A v w)) (pair v (refl A v))+                              lem5 v = refl (Sigma A (Id A v)) (v,refl A v)                                lem4 : (v u:A) (q: Id A v u) -> C v u q                               lem4 v =  J A v (C v) (lem5 v) -                              lem3 : Id (Sigma A (\ u -> Id A (f x) u)) (pair (f x) (refl A (f x))) (pair a p)-                              lem3 = lem4 (f x) a p --                              lem2 : Id Z (pair x (pair (f x) (refl A (f x)))) (pair x (pair a p))-                              lem2 = cong (Sigma A (\ a -> Id A (f x) a))-                                          (Sigma X (\ x -> Sigma A (\ a -> Id A (f x) a)))-                                          (\ z -> pair x z) -                                          (pair (f x) (refl A (f x))) (pair a p) lem3--                              lem1 : Id Y (pair (f x) (pair x (refl A (f x)))) (pair a (pair x p))-                              lem1 = cong Z Y sw2 (pair x (pair (f x) (refl A (f x)))) (pair x (pair a p)) lem2+                              lem3 : Id (Sigma A (Id A (f x))) (f x,refl A (f x)) (y.1,p)+                              lem3 = lem4 (f x) y.1 xp.2  -    rem2 : isEquiv X Y g-    rem2 = gradLemma X Y g h rgh sgh+                              lem2 : Id Z (x,(f x,refl A (f x))) (x,(y.1,xp.2))+                              lem2 = mapOnPath (Sigma A (Id A (f x)))+                                          (Sigma X (\ x -> Sigma A (Id A (f x))))+                                          (\ z -> (x,z)) +                                          (f x,refl A (f x)) (y.1,xp.2) lem3 +                              lem1 : Id Y (f x,(x,refl A (f x))) (y.1,xp)+                              lem1 = mapOnPath Z Y sw2 (x,(f x,refl A (f x))) (x,(y.1,p)) lem2  secsub : (A:U) -> (z : subset1 A) -> Id (subset1 A) (sub21 A (sub12 A z)) z-secsub A = - split-  pair X f -> rem+secsub A z = lemSecSub A z.1 Y g (lem2SecSub A z.1 z.2) h    where+    X : U+    X = z.1+     F : A -> U-    F = fiber X A f +    F = fiber X A z.2      Y : U     Y = Sigma A F+  +    f : X -> A+    f = z.2      h : Y -> A-    h = fst A F+    h y = y.1      g : X -> Y-    g x = pair (f x) (pair x (refl A (f x)))--    rem2 : isEquiv X Y (\ x -> g x)-    rem2 = lem2SecSub A X f --    rem1 : Id (subset1 A) (pair Y h) (pair X (\ x -> f x))-    rem1 = lemSecSub A X Y g rem2 h--    rem3 : Id (subset1 A) (pair X (\ x -> f x)) (pair X f)-    rem3 = cong (X->A) (subset1 A) (\ h -> pair X h) -                (\ x -> f x) f (funExt X (\ _ -> A) (\ x-> f x) f (\x -> refl A (f x)))--    rem : Id (subset1 A) (pair Y h) (pair X f)-    rem = comp (subset1 A) (pair Y h) (pair X (\ x -> f x)) (pair X f) rem1 rem3+    g x = (f x,(x,refl A (f x)))  thmSubset : (A:U) -> Id U (subset1 A) (subset2 A) thmSubset A = isEquivEq (subset1 A) (subset2 A) (sub12 A) rem
examples/swap.cub view
@@ -4,13 +4,14 @@  -- the swap function defines an equality +and : U -> U -> U+and A B = (_ : A) * B+ swap : (A B :U) -> and A B -> and B A-swap A B = split-            pair a b -> pair b a+swap A B z = (z.2,z.1)  lemSwap : (A B:U) -> (z: and A B) -> Id (and A B) (swap B A (swap A B z)) z-lemSwap A B = split-               pair a b -> refl (and A B) (pair a b)+lemSwap A B z = refl (and A B) z  eqSwap : (A B :U) -> Id U (and A B) (and B A) eqSwap A B = isEquivEq (and A B) (and B A) (swap A B) rem@@ -21,17 +22,16 @@ -- a simple test example  incr : and Bool N -> and Bool N-incr = split-     pair b n -> pair b (suc n)+incr z = (z.1,suc z.2)  incr' : and N Bool -> and N Bool incr' = subst U (\ X -> X -> X) (and Bool N) (and N Bool) (eqSwap Bool N) incr -test6 : and N Bool-test6 = incr' (pair zero true)+test1 : and N Bool+test1 = incr' (zero,true) -test7 : and N Bool-test7 = incr' (pair (suc zero) true)+test2 : and N Bool+test2 = incr' (suc zero,true)  -- what happens if we compose eqSwap with itself? @@ -41,36 +41,36 @@ incr2 : and Bool N -> and Bool N incr2 = subst U (\ X -> X -> X) (and Bool N) (and Bool N) (eqSwap2 Bool N) incr -test8 : and Bool N-test8 = incr2 (pair true zero)+test3 : and Bool N+test3 = incr2 (true,zero) -test9 : and Bool N-test9 = incr2 (pair true (suc zero))+test4 : and Bool N+test4 = incr2 (true,suc zero)  -- what happens if we compose eqSwap with its inverse?  eqSwap3 : (A B : U) -> Id U (and A B) (and A B)-eqSwap3 A B = comp U (and A B) (and B A) (and A B) (eqSwap A B) (inv U (and A B) (and B A) (eqSwap A B))+eqSwap3 A B = comp U (and A B) (and B A) (and A B) (eqSwap A B) +                    (inv U (and A B) (and B A) (eqSwap A B))  incr3 : and Bool N -> and Bool N incr3 = subst U (\ X -> X -> X) (and Bool N) (and Bool N) (eqSwap2 Bool N) incr -test10 : and Bool N-test10 = incr3 (pair true zero)--test11 : and Bool N-test11 = incr3 (pair true (suc zero))+test5 : and Bool N+test5 = incr3 (true,zero) +test6 : and Bool N+test6 = incr3 (true,suc zero)  -- simple example with swap and product  eqPi : (A:U) -> (B0 B1 : A -> U) -> ((x:A)  -> Id U (B0 x) (B1 x)) -> Id U (Pi A B0) (Pi A B1)-eqPi A B0 B1 eB = cong (A->U) U (Pi A) B0 B1 rem+eqPi A B0 B1 eB = mapOnPath (A->U) U (Pi A) B0 B1 rem  where rem : Id (A -> U) B0 B1        rem = funExt A (\ _ -> U) B0 B1 eB  eqSig : (A:U) -> (B0 B1 : A -> U) -> ((x:A)  -> Id U (B0 x) (B1 x)) -> Id U (Sigma A B0) (Sigma A B1)-eqSig A B0 B1 eB = cong (A->U) U (Sigma A) B0 B1 rem+eqSig A B0 B1 eB = mapOnPath (A->U) U (Sigma A) B0 B1 rem  where rem : Id (A -> U) B0 B1        rem = funExt A (\ _ -> U) B0 B1 eB @@ -87,7 +87,7 @@ transPiTest = transport  (Pi U (\ X -> X -> and X Bool)) (Pi U (\ X -> X -> and Bool X)) eqPiTest  test12 : and Bool N-test12 = transPiTest (\ X -> \ x -> pair x true) N zero+test12 = transPiTest (\ X -> \ x -> (x,true)) N zero  eqSigTest : Id U (Sigma U (\ X -> and X Bool)) (Sigma U (\ X -> and Bool X)) eqSigTest = eqSig U (\ X -> and X Bool) (\ X -> and Bool X) rem1@@ -97,14 +97,11 @@ transSigTest : (Sigma U (\ X -> and X Bool)) -> Sigma U (and Bool) transSigTest = transport (Sigma U (\ X -> and X Bool)) (Sigma U (\ X -> and Bool X)) eqSigTest -test13 : U-test13 = fst U (and Bool) (transSigTest (pair Bool (pair false true)))--test14 : and Bool test13-test14 = snd U (and Bool) (transSigTest (pair Bool (pair false true)))+test7 : U+test7 = (transSigTest (Bool,(false,true))).1 -test15 : Bool-test15 = fst Bool (\ _ -> test13) test14+test8 : and Bool test7+test8 = (transSigTest (Bool,(false,true))).2  eqSig1Test : Id U (Sigma U (\ X -> and N Bool)) (Sigma U (\ X -> and Bool N)) eqSig1Test = eqSig U (\ X -> and N Bool) (\ X -> and Bool N) rem1@@ -122,14 +119,11 @@ transSig2Test : (Sigma N (\ X -> and N Bool)) -> Sigma N (\ _ -> and Bool N) transSig2Test = transport (Sigma N (\ _ -> and N Bool)) (Sigma N (\ _ -> and Bool N)) eqSig2Test -test213 : N-test213 = fst N (\ _ -> and Bool N) (transSig2Test (pair zero (pair zero true)))--test214 : and Bool N-test214 = snd N (\ _ -> and Bool N) (transSig2Test (pair zero (pair zero true)))+test9 : N+test9 = (transSig2Test (zero,(zero,true))).1 -test215 : Bool-test215 = fst Bool (\ _ -> N) test214+test10 : and Bool N+test10 =  (transSig2Test (zero,(zero,true))).2  --- simple test @@ -137,11 +131,11 @@ eqNN = eqSwap N N  testNN : and N N-testNN = transport (and N N) (and N N) eqNN (pair zero (suc zero))+testNN = transport (and N N) (and N N) eqNN (zero,suc zero)  eqUU : Id U (U -> and U U) (U -> and U U) eqUU = eqPi U (\ _ -> and U U) (\ _ -> and U U) (\ _ -> eqSwap U U)  testUU : U-testUU = fst U (\ _ -> U) (transport (U -> and U U) (U -> and U U) eqUU (\ X -> pair X X) Bool)+testUU = (transport (U -> and U U) (U -> and U U) eqUU (\ X -> (X,X)) Bool).1
examples/swapDisc.cub view
@@ -1,123 +1,170 @@-module swapDisc where--import lemId---- defines the swap function over a discrete type and proves that this is an idempotent map--- needed for Nicolai Kraus example---- intermediate function--auxSwapD : (X:U) -> discrete X -> X -> X -> X -> X-auxSwapD X dX x0 x1 x = defCase (Id X x1 x) X x0 x (dX x1 x)--swapDisc : (X:U) -> discrete X -> X -> X -> X -> X-swapDisc X dX x0 x1 x = defCase (Id X x0 x) X x1 (auxSwapD X dX x0 x1 x) (dX x0 x)--idSwapDisc0 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> (x:X) -> Id X x0 x -> -     Id X (swapDisc X dX x0 x1 x) x1-idSwapDisc0 X dX x0 x1 x eqx0x =- IdDefCasel (Id X x0 x) X x1 (auxSwapD X dX x0 x1 x) (dX x0 x) eqx0x--idSwapDiscn0 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> (x:X) -> neg (Id X x0 x) -> -              Id X (swapDisc X dX x0 x1 x) (auxSwapD X dX x0 x1 x)-idSwapDiscn0 X dX x0 x1 x neqx0x =- IdDefCaser (Id X x0 x) X x1 (defCase (Id X x1 x) X x0 x (dX x1 x)) (dX x0 x) neqx0x--idAuxSwap1 :  (X:U) (dX: discrete X) -> (x0 x1 : X) -> (x:X) -> Id X x1 x -> -              Id X (auxSwapD X dX x0 x1 x) x0-idAuxSwap1 X dX x0 x1 x eqx1x =- IdDefCasel (Id X x1 x) X x0 x (dX x1 x) eqx1x--idAuxSwapn1 :  (X:U) (dX: discrete X) -> (x0 x1 : X) -> (x:X) -> neg (Id X x1 x) -> -            Id X (auxSwapD X dX x0 x1 x) x-idAuxSwapn1 X dX x0 x1 x neqx1x = - IdDefCaser (Id X x1 x) X x0 x (dX x1 x) neqx1x--idSwapDisc1 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> neg (Id X x0 x1) -> Id X (swapDisc X dX x0 x1 x1) x0-idSwapDisc1 X dX x0 x1 neqx0x1 = - comp X (swapDisc X dX x0 x1 x1) (defCase (Id X x0 x1) X x1 x0 (dX x0 x1)) x0 rem2 rem1- where-  rem : Id X (defCase (Id X x1 x1) X x0 x1 (dX x1 x1)) x0-  rem = IdDefCasel (Id X x1 x1) X x0 x1 (dX x1 x1) (refl X x1)--  rem1 : Id X (defCase (Id X x0 x1) X x1 x0 (dX x0 x1)) x0-  rem1 = IdDefCaser (Id X x0 x1) X x1 x0 (dX x0 x1) neqx0x1--  rem2 : Id X (swapDisc X dX x0 x1 x1) (defCase (Id X x0 x1) X x1 x0 (dX x0 x1))-  rem2 = cong 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---- can we show that swapDisc is idempotent??--idemSwapDisc : (X:U) (dX: discrete X) -> (x0 x1 : X) -> neg (Id X x0 x1) -> (x:X) -> -               Id X (swapDisc X dX x0 x1 (swapDisc X dX x0 x1 x)) x -idemSwapDisc X dX x0 x1 neqx0x1 x = orElim (Id X x0 x) (neg (Id X x0 x)) G rem9 rem11 (dX x0 x)- where-   sD : X -> X-   sD = swapDisc X dX x0 x1 --   G : U-   G = Id X (sD (sD x)) x--   aD : X -> X-   aD = auxSwapD X dX x0 x1 --   rem : Id X x0 x -> Id X (sD x) x1-   rem = idSwapDisc0 X dX x0 x1 x  --   rem1 : neg (Id X x0 x) -> Id X (sD x) (aD x)-   rem1 = idSwapDiscn0 X dX x0 x1 x--   rem2 : Id X x1 x -> Id X (aD x) x0-   rem2 = idAuxSwap1 X dX x0 x1 x--   rem3 : neg (Id X x1 x) -> Id X (aD x) x-   rem3 = idAuxSwapn1 X dX x0 x1 x--   rem4 : Id X (aD x1) x0-   rem4 = idAuxSwap1 X dX x0 x1 x1 (refl X x1)--   rem5 : Id X (sD x1) (aD x1)-   rem5 = idSwapDiscn0 X dX x0 x1 x1 neqx0x1--   rem6 : Id X (sD x1) x0-   rem6 = comp X (sD x1) (aD x1) x0 rem5 rem4--   rem7 : Id X x0 x -> Id X (sD (sD x)) (sD x1)-   rem7 p = cong X X sD (sD x) x1 (rem p)--   rem8 : Id X x0 x -> Id X (sD (sD x)) x0-   rem8 p = comp X (sD (sD x)) (sD x1) x0 (rem7 p) rem6--   rem9 : Id X x0 x -> G-   rem9 p = comp X (sD (sD x)) x0 x (rem8 p) p--   rem10 : Id X (sD x0) x1-   rem10 = idSwapDisc0 X dX x0 x1 x0 (refl X x0)--   rem11 : neg (Id X x0 x) -> G-   rem11 neqx0x = orElim (Id X x1 x) (neg (Id X x1 x)) G rem14 rem15 (dX x1 x)-      where-        rem12 : Id X (sD x) (aD x)-        rem12 = rem1 neqx0x--        rem13 : Id X x1 x -> Id X (sD (aD x)) x1-        rem13 p = comp X (sD (aD x)) (sD x0) x1 (cong X X sD (aD x) x0 (rem2 p)) rem10--        rem14 : Id X x1 x -> G-        rem14 p = comp X (sD (sD x)) (sD (aD x)) x (cong X X sD (sD x) (aD x) rem12) (comp X (sD (aD x)) x1 x (rem13 p) p)--        rem15 : neg (Id X x1 x) -> G-        rem15 neqx1x = comp X (sD (sD x)) (sD x) x rem17 rem18-            where-             rem16 : Id X (aD x) x-             rem16 = rem3 neqx1x--             rem17 : Id X (sD (sD x)) (sD x)-             rem17 = comp X (sD (sD x)) (sD (aD x)) (sD x) (cong X X sD (sD x) (aD x) rem12) (cong X X sD (aD x) x rem16)--             rem18 : Id X (sD x) x-             rem18 = comp X (sD x) (aD x) x rem12 rem16--        --+module swapDisc where
+
+import lemId
+import involutive
+import contr
+import elimEquiv
+
+-- defines the swap function over a discrete type and proves that this is an involutive map
+-- needed for Nicolai Kraus example
+-- we try another representation since the other one is too slow
+
+if : (X:U) -> Bool -> X -> X -> X
+if X = split true -> \ x y -> x
+             false -> \ x y -> y
+
+True : Bool -> U
+True = split true -> Unit
+             false -> N0
+
+lemIfT : (X:U) (b:Bool) (x y:X) -> True b -> Id X (if X b x y) x
+lemIfT X = split true -> \ x y _ -> refl X x
+                 false -> \ x y h -> efq (Id X (if X false x y) x) h
+
+lemIfF : (X:U) (b:Bool) (x y:X) -> True (not b) -> Id X (if X b x y) y
+lemIfF X = split true -> \ x y h -> efq (Id X (if X true x y) y) h
+                 false -> \ x y _ -> refl X y
+
+lemTrue : (a b : Bool) ->
+            or (True a)
+               (or (and (True (not a)) (True b)) (and (True (not a)) (True (not b))))
+lemTrue = split true -> \ b -> inl tt
+                false -> split true -> inr (inl (tt,tt))
+                               false -> inr (inr (tt,tt))
+
+lemTrue : (a b : Bool) (G:U) ->
+            ((True a) -> G) -> ((and (True (not a)) (True b)) -> G) ->
+            ((and (True (not a)) (True (not b)))-> G) -> G
+lemTrue = split true -> \ b -> \ G h0 h1 h2 -> h0 tt
+                false -> split true -> \ G h0 h1 h2 -> h1 (tt,tt)
+                               false -> \ G h0 h1 h2 -> h2 (tt,tt)
+
+
+swapF : (X:U) (eq:X->X-> Bool) -> X -> X -> X -> X
+swapF X eq x y u = if X (eq x u) y (if X (eq y u) x u)
+
+lemSw0 : (X:U) (eq:X->X->Bool) (x y u:X) -> True (eq x u) -> Id X (swapF X eq x y u) y
+lemSw0 X eq x y u h = lemIfT X (eq x u) y (if X (eq y u) x u) h
+
+lemSw1 : (X:U) (eq:X->X->Bool) (x y u:X) ->
+               and (True (not (eq x u))) (True (eq y u)) -> Id X (swapF X eq x y u) x
+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
+   where rem : Id X (swapF X eq x y u) (if X (eq y u) x u)
+         rem = lemIfF X (eq x u) y (if X (eq y u) x u) h.1
+         rem1 : Id X (if X (eq y u) x u) x
+         rem1 = lemIfT X (eq y u) x u h.2
+
+lemSw2 : (X:U) (eq:X->X->Bool) (x y u:X) ->
+               and (True (not (eq x u))) (True (not (eq y u)))
+          -> Id X (swapF X eq x y u) u
+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
+   where rem : Id X (swapF X eq x y u) (if X (eq y u) x u)
+         rem = lemIfF X (eq x u) y (if X (eq y u) x u) h.1
+         rem1 : Id X (if X (eq y u) x u) u
+         rem1 = lemIfF X (eq y u) x u h.2
+
+faith0 : (X:U) (eq:X->X->Bool) -> U
+faith0 X eq = (x y : X) -> Id X x y -> True (eq x y)
+
+faith1 : (X:U) (eq:X->X->Bool) -> U
+faith1 X eq = (x y : X) -> True (eq x y) -> Id X x y
+
+lemIdemSw : (X:U) (eq:X->X->Bool) (f0:faith0 X eq) (f1:faith1 X eq) (x y : X) (neq : True (not (eq x y)))
+            (u:X) -> Id X (swapF X eq x y (swapF X eq x y u)) u
+lemIdemSw X eq f0 f1 x y neq u = lemTrue (eq x u) (eq y u) (H u) rem5 rem6 rem7
+ where
+   sw : X -> X
+   sw = swapF X eq x y
+
+   H : X -> U
+   H v = Id X (sw (sw v)) v
+
+   rem1 : Id X (sw x) y
+   rem1 = lemSw0 X eq x y x (f0 x x (refl X x))
+
+   rem2 : Id X (sw y) x
+   rem2 = lemSw1 X eq x y y (neq,f0 y y (refl X y))
+
+   rem3 : H x
+   rem3 = comp X (sw (sw x)) (sw y) x (mapOnPath X X sw (sw x) y rem1) rem2
+
+   rem4 : H y
+   rem4 = comp X (sw (sw y)) (sw x) y (mapOnPath X X sw (sw y) x rem2) rem1
+
+   rem5 : True (eq x u) -> H u
+   rem5 h = subst X H x u (f1 x u h) rem3
+
+   rem6 : and (True (not (eq x u))) (True (eq y u)) -> H u
+   rem6 h = subst X H y u (f1 y u h.2) rem4
+
+   rem7 : and (True (not (eq x u))) (True (not (eq y u))) -> H u
+   rem7 h = comp X (sw (sw u)) (sw u) u (mapOnPath X X sw (sw u) u lem) lem
+     where lem : Id X (sw u) u
+           lem = lemSw2 X eq x y u h
+
+-- pointed sets
+
+ptU : U
+ptU = Sigma U (id U)
+
+-- if f : A -> B is an equivalence and f a = b then (A,a) and (B,b) are equal in ptU
+
+lemPtEquiv : (A B : U) (f: A -> B) (ef: isEquiv A B f) (a:A) (b:B) (eab: Id B (f a) b)
+             -> Id ptU (A,a) (B,b)
+lemPtEquiv A = elimIsEquiv A P rem
+  where
+   P : (B:U) -> (A->B) -> U
+   P B f = (a:A) -> (b:B) -> (eab: Id B (f a) b) -> Id ptU (A,a) (B,b)
+
+   rem : P A (id A)
+   rem = mapOnPath A ptU (\ x -> (A,x))
+
+
+lemEM : (b:Bool) (G:U) -> ((True b) -> G) -> ((True (not b)) -> G) -> G
+lemEM = split true -> \ G h0 h1 -> h0 tt
+              false -> \ G h0 h1 -> h1 tt
+
+homogDec : (X:U) (eq:X->X->Bool) (f0:faith0 X eq) (f1:faith1 X eq) (x y : X)
+           -> Id ptU (X,x) (X,y)
+homogDec X eq f0 f1 x y = lemEM (eq x y) (G y) rem1 rem
+ where
+   G : X -> U
+   G z = Id ptU (X,x) (X,z)
+
+   sw : X -> X
+   sw = swapF X eq x y
+
+   rem : True (not (eq x y)) -> G y
+   rem neq = lemPtEquiv X X sw
+                (idemIsEquiv X sw (lemIdemSw X eq f0 f1 x y neq))
+                x y (lemSw0 X eq x y x (f0 x x (refl X x)))
+
+   rem1 : True (eq x y) -> G y
+   rem1 h = subst X G x y (f1 x y h) (refl ptU (X,x))
+
+
+-- an example of a decidable structure
+
+eqN : N -> N -> Bool
+eqN = split zero -> split
+                      zero -> true
+                      suc _ -> false
+            suc n -> split
+                      zero -> false
+                      suc m -> eqN n m
+
+lemN : (x:N) -> True (eqN x x)
+lemN = split
+        zero -> tt
+        suc n -> lemN n
+
+f0N : (x y : N) -> Id N x y -> True (eqN x y)
+f0N x y p = subst N (\ y -> True (eqN x y)) x y p (lemN x)
+
+f1N : (x y : N) -> True (eqN x y) -> Id N x y
+f1N =  split zero -> split
+                      zero -> \ _ ->refl N zero
+                      suc m -> \ h -> efq (Id N zero (suc m)) h
+             suc n -> split
+                       zero ->  \ h -> efq (Id N (suc n) zero) h
+                       suc m -> \ h -> mapOnPath N N (\ x -> suc x) n m (f1N n m h)
+ examples/swapDisc_old.cub view
@@ -0,0 +1,178 @@+module swapDisc_old where++import lemId+import involutive+import contr+import elimEquiv+++-- definition by case on a decidable equality+-- needed for Nicolai Kraus example++defCase : (A X:U) -> X -> X -> dec A -> X+defCase A X x0 x1 = + split+  inl _ -> x0+  inr _ -> x1++IdDefCasel : (A X:U) (x0 x1 : X) (p : dec A)  -> A -> +             Id X (defCase A X x0 x1 p) x0+IdDefCasel A X x0 x1 = split+ inl _ -> \ _ -> refl X x0+ inr v -> \ u -> efq (Id X (defCase A X x0 x1 (inr v)) x0) (v u)++IdDefCaser : (A X:U) (x0 x1 : X) (p : dec A)  -> (neg A) -> +             Id X (defCase A X x0 x1 p) x1+IdDefCaser A X x0 x1 = split+ inl u -> \ v -> efq (Id X (defCase A X x0 x1 (inl u)) x1) (v u)+ inr _ -> \ _ -> refl X x1++-- defines the swap function over a discrete type and proves that this is an involutive map+-- needed for Nicolai Kraus example++-- intermediate function++auxSwapD : (X:U) -> discrete X -> X -> X -> X -> X+auxSwapD X dX x0 x1 x = defCase (Id X x1 x) X x0 x (dX x1 x)++swapDisc : (X:U) -> discrete X -> X -> X -> X -> X+swapDisc X dX x0 x1 x = defCase (Id X x0 x) X x1 (auxSwapD X dX x0 x1 x) (dX x0 x)++idSwapDisc0 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> (x:X) -> Id X x0 x -> +     Id X (swapDisc X dX x0 x1 x) x1+idSwapDisc0 X dX x0 x1 x eqx0x =+ IdDefCasel (Id X x0 x) X x1 (auxSwapD X dX x0 x1 x) (dX x0 x) eqx0x++idSwapDiscn0 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> (x:X) -> neg (Id X x0 x) -> +              Id X (swapDisc X dX x0 x1 x) (auxSwapD X dX x0 x1 x)+idSwapDiscn0 X dX x0 x1 x neqx0x =+ IdDefCaser (Id X x0 x) X x1 (defCase (Id X x1 x) X x0 x (dX x1 x)) (dX x0 x) neqx0x++idAuxSwap1 :  (X:U) (dX: discrete X) -> (x0 x1 : X) -> (x:X) -> Id X x1 x -> +              Id X (auxSwapD X dX x0 x1 x) x0+idAuxSwap1 X dX x0 x1 x eqx1x =+ IdDefCasel (Id X x1 x) X x0 x (dX x1 x) eqx1x++idAuxSwapn1 :  (X:U) (dX: discrete X) -> (x0 x1 : X) -> (x:X) -> neg (Id X x1 x) -> +            Id X (auxSwapD X dX x0 x1 x) x+idAuxSwapn1 X dX x0 x1 x neqx1x = + IdDefCaser (Id X x1 x) X x0 x (dX x1 x) neqx1x++idSwapDisc1 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> neg (Id X x0 x1) -> Id X (swapDisc X dX x0 x1 x1) x0+idSwapDisc1 X dX x0 x1 neqx0x1 = + comp X (swapDisc X dX x0 x1 x1) (defCase (Id X x0 x1) X x1 x0 (dX x0 x1)) x0 rem2 rem1+ where+  rem : Id X (defCase (Id X x1 x1) X x0 x1 (dX x1 x1)) x0+  rem = IdDefCasel (Id X x1 x1) X x0 x1 (dX x1 x1) (refl X x1)++  rem1 : Id X (defCase (Id X x0 x1) X x1 x0 (dX x0 x1)) x0+  rem1 = IdDefCaser (Id X x0 x1) X x1 x0 (dX x0 x1) neqx0x1++  rem2 : Id X (swapDisc X dX x0 x1 x1) (defCase (Id X x0 x1) X x1 x0 (dX x0 x1))+  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++-- can we show that swapDisc is involutive??++idemSwapDisc : (X:U) (dX: discrete X) -> (x0 x1 : X) -> neg (Id X x0 x1) -> (x:X) -> +               Id X (swapDisc X dX x0 x1 (swapDisc X dX x0 x1 x)) x +idemSwapDisc X dX x0 x1 neqx0x1 x = orElim (Id X x0 x) (neg (Id X x0 x)) G rem9 rem11 (dX x0 x)+ where+   sD : X -> X+   sD = swapDisc X dX x0 x1 ++   G : U+   G = Id X (sD (sD x)) x++   aD : X -> X+   aD = auxSwapD X dX x0 x1 ++   rem : Id X x0 x -> Id X (sD x) x1+   rem = idSwapDisc0 X dX x0 x1 x  ++   rem1 : neg (Id X x0 x) -> Id X (sD x) (aD x)+   rem1 = idSwapDiscn0 X dX x0 x1 x++   rem2 : Id X x1 x -> Id X (aD x) x0+   rem2 = idAuxSwap1 X dX x0 x1 x++   rem3 : neg (Id X x1 x) -> Id X (aD x) x+   rem3 = idAuxSwapn1 X dX x0 x1 x++   rem4 : Id X (aD x1) x0+   rem4 = idAuxSwap1 X dX x0 x1 x1 (refl X x1)++   rem5 : Id X (sD x1) (aD x1)+   rem5 = idSwapDiscn0 X dX x0 x1 x1 neqx0x1++   rem6 : Id X (sD x1) x0+   rem6 = comp X (sD x1) (aD x1) x0 rem5 rem4++   rem7 : Id X x0 x -> Id X (sD (sD x)) (sD x1)+   rem7 p = mapOnPath X X sD (sD x) x1 (rem p)++   rem8 : Id X x0 x -> Id X (sD (sD x)) x0+   rem8 p = comp X (sD (sD x)) (sD x1) x0 (rem7 p) rem6++   rem9 : Id X x0 x -> G+   rem9 p = comp X (sD (sD x)) x0 x (rem8 p) p++   rem10 : Id X (sD x0) x1+   rem10 = idSwapDisc0 X dX x0 x1 x0 (refl X x0)++   rem11 : neg (Id X x0 x) -> G+   rem11 neqx0x = orElim (Id X x1 x) (neg (Id X x1 x)) G rem14 rem15 (dX x1 x)+      where+        rem12 : Id X (sD x) (aD x)+        rem12 = rem1 neqx0x++        rem13 : Id X x1 x -> Id X (sD (aD x)) x1+        rem13 p = comp X (sD (aD x)) (sD x0) x1 (mapOnPath X X sD (aD x) x0 (rem2 p)) rem10++        rem14 : Id X x1 x -> G+        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)++        rem15 : neg (Id X x1 x) -> G+        rem15 neqx1x = comp X (sD (sD x)) (sD x) x rem17 rem18+            where+             rem16 : Id X (aD x) x+             rem16 = rem3 neqx1x++             rem17 : Id X (sD (sD x)) (sD x)+             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)++             rem18 : Id X (sD x) x+             rem18 = comp X (sD x) (aD x) x rem12 rem16++-- pointed sets+        +ptU : U+ptU = Sigma U (id U)++-- if f : A -> B is an equivalence and f a = b then (A,a) and (B,b) are equal in ptU++lemPtEquiv : (A B : U) (f: A -> B) (ef: isEquiv A B f) (a:A) (b:B) (eab: Id B (f a) b) +              -> Id ptU (A,a) (B,b)+lemPtEquiv A = elimIsEquiv A P rem+  where+   P : (B:U) -> (A->B) -> U+   P B f = (a:A) -> (b:B) -> (eab: Id B (f a) b) -> Id ptU (A,a) (B,b)++   rem : P A (id A)+   rem = mapOnPath A ptU (\ x -> (A,x))++homogDec : (X:U) -> discrete X -> (x y:X) -> Id ptU (X,x) (X,y)+homogDec X dX x y = orElim (Id X y x) (neg (Id X y x)) (G x) rem1 rem (dX y x)+ where+   G : X -> U+   G z = Id ptU (X,z) (X,y)++   rem0 : G y+   rem0 = refl ptU (X,y)++   rem : neg (Id X y x) -> G x+   rem neqzx = lemPtEquiv X X (swapDisc X dX y x) +                (idemIsEquiv X (swapDisc X dX y x) (idemSwapDisc X dX y x neqzx)) +                x y (idSwapDisc1 X dX y x neqzx)++   rem1 : Id X y x -> G x+   rem1 eqzx = subst X G y x eqzx rem0
− examples/test.cub 
@@ -1,21 +0,0 @@-module test where--Id : (A : U) (a b : A) -> U-Id = PN--refl : (A : U) (a : A) -> Id A a a-refl = PN--Bool : U-data Bool = true | false--orBool : Bool -> Bool -> Bool-orBool = split-  true -> \x -> true-  false -> \x -> x--id : Bool -> Bool-id x = x--test : Id Bool true (orBool true false)-test = refl Bool true
+ examples/turn.cub view
@@ -0,0 +1,50 @@+module turn where++import helix++transpL : (A:U)(a b:A) -> Id A a b -> Id A a a -> Id A b b+transpL A a b p l = (compInv A a b b p (comp A a a b l p))++lemTranspL : (A:U)(a:A)(l:Id A a a) -> Id (Id A a a) l (transpL A a a (refl A a) l)+lemTranspL A a l = rem2+ where+  l1 : Id A a a+  l1 = comp A a a a l (refl A a)+  rem : Id (Id A a a) l1 l+  rem = compIdr A a a l+  rem1 : Id (Id A a a) l1 (compInv A a a a (refl A a) l1) +  rem1 = compInvIdl' A a a l1+  rem2 : Id (Id A a a) l (compInv A a a a (refl A a) l1) +  rem2 = compInv (Id A a a) l1 l (compInv A a a a (refl A a) l1) rem rem1++lemTranspL1 : (A:U)(a:A)(l:Id A a a) -> Id (Id A a a) l (transpL A a a l l)+lemTranspL1 A a l = lemInv A a a a l l++lemG0 : (A:U)(a b:A)(p:Id A a b)(l : Id A a a) -> +        IdS A (\ x -> Id A x x) a b p l (transpL A a b p l)+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))+              (lemTranspL A a)++lemG1 : (A:U)(a:A)(l:Id A a a) -> IdS A (\ x -> Id A x x) a a l l l+lemG1 A a l = + substInv (Id A a a) (IdS A (\ x -> Id A x x) a a l l) l (transpL A a a l l) +    (lemTranspL1 A a l) (lemG0 A a a l l)++lp : (x:S1) -> Id S1 x x+lp = S1rec (\ x -> Id S1 x x) loop (lemG1 S1 base loop)++lp1 : S1 -> S1+lp1 x = S1rec (\ _ -> S1) x (lp x) x++path : Id S1 base base+path = mapOnPath S1 S1 lp1 base base loop++test : Z+test = winding path++path2 : Id S1 base base+path2 = mapOnPath S1 S1 lp1 base base (compS1 loop (compS1 loop loop))++test2 : Z+test2 = winding path2+
examples/univalence.cub view
@@ -20,36 +20,30 @@ Equiv : U -> U -> U Equiv A B = Sigma (A->B) (isEquiv A B) -funEquiv : (A B : U) -> Equiv A B -> A -> B-funEquiv A B = fst (A->B) (isEquiv A B)--eqEquiv : (A B : U) (e0 e1:Equiv A B) -> Id (A -> B) (funEquiv A B e0) (funEquiv A B e1) -> Id (Equiv A B) e0 e1+eqEquiv : (A B : U) (e0 e1:Equiv A B) -> Id (A -> B) e0.1 e1.1 -> Id (Equiv A B) e0 e1 eqEquiv A B = eqPropFam (A->B) (isEquiv A B) (propIsEquiv A B)  IdToEquiv : (A B:U) -> Id U A B -> Equiv A B-IdToEquiv A B p = pair (transport A B p) (transpIsEquiv A B p)+IdToEquiv A B p = (transport A B p, transpIsEquiv A B p)  EquivToId : (A B:U) -> Equiv A B -> Id U A B-EquivToId A B = split-                  pair f ef -> isEquivEq A B f ef+EquivToId A B z = isEquivEq A B z.1 z.2 -lemSecIdEquiv : (A:U) -> (eid : isEquiv A A (id A)) -> Id (Id U A A) (refl U A) (EquivToId A A (pair (id A) eid))-lemSecIdEquiv A = -  split-   pair s t -> equivEqRef A s t+lemSecIdEquiv : (A:U) -> (eid : isEquiv A A (id A)) -> Id (Id U A A) (refl U A) (EquivToId A A (id A, eid))+lemSecIdEquiv A z = equivEqRef A z.1 z.2  lem1SecIdEquiv : (A:U) -> (f:A -> A) -> Id (A->A) (id A) f -> (eid : isEquiv A A f) -> -      Id (Id U A A) (refl U A) (EquivToId A A (pair f eid))+      Id (Id U A A) (refl U A) (EquivToId A A (f, eid)) lem1SecIdEquiv A f if eid = -  comp (Id U A A)  (refl U A)  (EquivToId A A (pair (id A) (idIsEquiv A))) (EquivToId A A (pair f eid)) rem2 rem1+  comp (Id U A A)  (refl U A)  (EquivToId A A (id A, idIsEquiv A)) (EquivToId A A (f, eid)) rem2 rem1   where-    rem : Id (Equiv A A) (pair (id A) (idIsEquiv A)) (pair f eid)-    rem = eqEquiv A A (pair (id A) (idIsEquiv A)) (pair f eid) if+    rem : Id (Equiv A A) (id A, idIsEquiv A) (f, eid)+    rem = eqEquiv A A (id A, idIsEquiv A) (f, eid) if -    rem1 : Id (Id U A A) (EquivToId A A (pair (id A) (idIsEquiv A))) (EquivToId A A (pair f eid))-    rem1 = cong (Equiv A A) (Id U A A) (EquivToId A A) (pair (id A) (idIsEquiv A)) (pair f eid) rem+    rem1 : Id (Id U A A) (EquivToId A A (id A, idIsEquiv A)) (EquivToId A A (f, eid))+    rem1 = mapOnPath (Equiv A A) (Id U A A) (EquivToId A A) (id A, idIsEquiv A) (f, eid) rem -    rem2 : Id (Id U A A) (refl U A)  (EquivToId A A (pair (id A) (idIsEquiv A)))+    rem2 : Id (Id U A A) (refl U A)  (EquivToId A A (id A, idIsEquiv A))     rem2 = lemSecIdEquiv A (idIsEquiv A)  secIdEquiv : (A B :U) -> (p : Id U A B) -> Id (Id U A B) (EquivToId A B (IdToEquiv A B p)) p@@ -74,26 +68,21 @@ retIdEquiv A B s = inv (Equiv A B) s (IdToEquiv A B (EquivToId A B s)) (rem s)  where    rem : (s : Equiv A B) -> Id (Equiv A B) s (IdToEquiv A B (EquivToId A B s))-   rem = -     split-       pair f ef -> -          rem1 ef+   rem u = rem1 u.2              where               p : Id U A B -              p = isEquivEq A B f ef+              p = isEquivEq A B u.1 u.2 -              rem1 : (ef : isEquiv A B f) -> -                      Id (Equiv A B) (pair f ef) (pair (transport A B (isEquivEq A B f ef)) (transpIsEquiv A B (isEquivEq A B f ef)))-              rem1 = -                split-                 pair s t -> rem2+              rem1 : (ef : isEquiv A B u.1) -> +                      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))+              rem1 z = rem2                   where-                    rem3 : Id (A->B) f (transport A B (equivEq A B f s t))-                    rem3 = funExt A (\ _ -> B) f (transport A B (equivEq A B f s t)) (transpEquivEq A B f s t)-                    rem2 : Id (Equiv A B) (pair f (pair s t))-                                          (pair (transport A B (equivEq A B f s t)) (transpIsEquiv A B (equivEq A B f s t)))-                    rem2 = eqEquiv A B (pair f (pair s t))-                                       (pair (transport A B (equivEq A B f s t)) (transpIsEquiv A B (equivEq A B f s t)))+                    rem3 : Id (A->B) u.1 (transport A B (equivEq A B u.1 z.1 z.2))+                    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)+                    rem2 : Id (Equiv A B) (u.1, z)+                                          (transport A B (equivEq A B u.1 z.1 z.2), transpIsEquiv A B (equivEq A B u.1 z.1 z.2))+                    rem2 = eqEquiv A B (u.1, z)+                                       (transport A B (equivEq A B u.1 z.1 z.2), transpIsEquiv A B (equivEq A B u.1 z.1 z.2))                                        rem3  -- and now univalence