packages feed

cubical (empty) → 0.1.0

raw patch · 47 files changed

+6557/−0 lines, 47 filesdep +BNFCdep +arraydep +basebuild-type:Customsetup-changed

Dependencies added: BNFC, array, base, directory, haskeline, mtl, transformers

Files

+ CTT.hs view
@@ -0,0 +1,461 @@+module CTT where+++import Data.List++import qualified MTT as A+import Pretty++--------------------------------------------------------------------------------+-- | Terms++type Binder = String+type Def    = (Binder,Ter)  -- without type annotations for now+type Ident  = String++data Ter = Var Binder+         | Id Ter Ter Ter | Refl Ter+         | Pi Ter Ter     | Lam Binder Ter | App Ter Ter+         | Where Ter [Def]+         | U++         | Undef A.Prim++           -- constructor c Ms+         | Con Ident [Ter]++           -- branches c1 xs1  -> M1,..., cn xsn -> Mn+         | Branch A.Prim [(Ident, ([Binder],Ter))]++           -- labelled sum c1 A1s,..., cn Ans (assumes terms are constructors)+         | LSum A.Prim [(Ident, [(Binder,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 Ter Ter++           -- (A:U) -> (a : A) -> Id A a (transport A (refl U A) a)+           -- Argument is a+         | TransURef Ter++           -- 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 : 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 Ter Ter Ter Ter++           -- 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++           -- Inc a : Inh A for a:A (A not needed ??)+         | Inc Ter++           -- Squash a b : Id (Inh A) a b+         | Squash Ter Ter++           -- 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++           -- 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++           -- (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++           -- (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)++instance Show Ter where+  show = showTer++--------------------------------------------------------------------------------+-- | Names, dimension, and nominal type class++type Name = Integer+type Dim  = [Name]++gensym :: Dim -> Name+gensym [] = 0+gensym xs = maximum xs + 1++gensyms :: Dim -> [Name]+gensyms d = let x = gensym d in x : gensyms (x : d)++class Nominal a where+  swap :: a -> Name -> Name -> a+  support :: a -> [Name]++fresh :: Nominal a => a -> Name+fresh = gensym . 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)++instance Nominal a => Nominal [a]  where+  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 n = [n]+  swap      = swapName++--------------------------------------------------------------------------------+-- | Boxes++data Dir = Up | Down+  deriving (Eq, Show)++mirror :: Dir -> Dir+mirror Up   = Down+mirror Down = Up++type Side = (Name,Dir)++allDirs :: [Name] -> [Side]+allDirs []     = []+allDirs (n:ns) = (n,Down) : (n,Up) : allDirs ns++data Box a = Box { dir   :: Dir+                 , pname :: Name+                 , pface :: a+                 , sides :: [(Side,a)] }+  deriving Eq++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 ]++instance Functor Box where+  fmap = mapBox++lookBox :: Show a => Side -> Box a -> a+lookBox (y,dir) (Box d x v _)  | x == y && mirror d == dir = v+lookBox xd box@(Box _ _ _ nvs) = case lookup xd nvs of+  Just v  -> v+  Nothing -> error $ "lookBox: box not defined on " +++                      show xd ++ "\nbox = " ++ show box++nonPrincipal :: Box a -> [Name]+nonPrincipal (Box _ _ _ nvs) = nub $ map (fst . fst) nvs++defBox :: Box a -> [(Name, Dir)]+defBox (Box d x _ nvs) = (x,mirror d) : [ zd | (zd,_) <- nvs ]++fromBox :: Box a -> [(Side,a)]+fromBox (Box d x v nvs) = ((x, mirror d),v) : nvs++modBox :: (Side -> a -> b) -> Box a -> Box b+modBox f (Box dir x v nvs) =+  Box dir x (f (x,mirror dir) v) [ (nd,f nd v) | (nd,v) <- nvs ]++-- Restricts the non-principal faces to np.+subBox :: [Name] -> Box a -> Box a+subBox np (Box dir x v nvs) =+  Box dir x v [ nv | nv@((n,_),_) <- nvs, n `elem` np]++shapeOfBox :: Box a -> Box ()+shapeOfBox = mapBox (const ())++-- 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++appendBox :: [(Name,(a,a))] -> Box a -> Box a+appendBox xs b = foldr consBox b xs++appendSides :: [(Side, a)] -> Box a -> Box a+appendSides sides (Box dir x v nvs) = Box dir x v (sides ++ nvs)++transposeBox :: Box [a] -> [Box a]+transposeBox b@(Box dir _ [] _)      = []+transposeBox (Box dir x (v:vs) nvss) =+  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 ]++instance Nominal a => Nominal (Box a) where+  swap    = swapBox+  support = supportBox++--------------------------------------------------------------------------------+-- | Values++data KanType = Fill | Com+  deriving (Show, Eq)++data Val = VU+         | Ter Ter Env+         | VPi Val Val+         | VId Val Val Val++           -- tag values which are paths+         | Path Name Val+         | VExt Name Val Val Val Val++           -- inhabited+         | VInh Val++           -- inclusion into inhabited+         | VInc Val++           -- 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+         | VEquivEq Name Val Val Val Val Val++           -- names x, y and values a, s, t+         | VEquivSquare Name Name Val Val Val++           -- of type VEquivEq+         | VPair Name Val Val++           -- of type VEquivSquare+         | VSquare Name Name Val++           -- 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+         | VFill Name (Box Val)+  deriving Eq++instance Show Val where+  show = showVal+++fstVal, sndVal, unSquare :: Val -> Val+fstVal (VPair _ a _)     = a+fstVal x                 = error $ "error fstVal: " ++ show x+sndVal (VPair _ _ v)     = v+sndVal x                 = error $ "error sndVal: " ++ show x+unSquare (VSquare _ _ v) = v+unSquare v               = error $ "unSquare bad input: " ++ show v++unCon :: Val -> [Val]+unCon (VCon _ vs) = vs+unCon v           = error $ "unCon: not a constructor: " ++ show v++unions :: Eq a => [[a]] -> [a]+unions = foldr union []++unionsMap :: Eq b => (a -> [b]) -> [a] -> [b]+unionsMap f = unions . map f++instance Nominal Val where+  support VU                = []+  support (Ter _ e)         = support e+  support (VId a v0 v1)     = support [a,v0,v1]+  support (Path x v)        = delete x $ support v+  support (VInh v)          = support v+  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++  swap u x y =+    let sw u = swap u x y in case u of+    VU          -> VU+    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)+                                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)+    VPi a f         -> VPi (sw a) (sw f)+    VInh v          -> VInh (sw v)+    VInc v          -> VInc (sw v)+    VSquash z v0 v1 -> VSquash (swap z x y) (sw v0) (sw v1)+    VCon c us       -> VCon c (map sw us)+    VEquivEq z a b f s t ->+      VEquivEq (swap z x y) (sw a) (sw b) (sw f) (sw s) (sw t)+    VPair z a v  -> VPair (swap z x y) (sw a) (sw v)+    VEquivSquare z w a s t ->+      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)+    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)+                         a' = swap a z z'+                     in sw (Kan Com 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)+                     in sw (VComp (swap b z z'))+    VFill z b@(Box dir n _ _)+      | z /= x && z /= x -> VFill z (swap b x y)+      | otherwise        -> let+        z' = gensym ([x] `union` [y] `union` support b)+        in sw (VFill z' (swap b z z'))++--------------------------------------------------------------------------------+-- | Environments++data Env = Empty+         | Pair Env (Binder,Val)+         | PDef [(Binder,Ter)] Env+  deriving Eq++instance Show Env where+  show = showEnv++showEnv :: Env -> String+showEnv Empty            = ""+showEnv (Pair env (x,u)) = parens $ showEnv1 env ++ show u+showEnv (PDef xas env)   = showEnv env++showEnv1 :: Env -> String+showEnv1 Empty            = ""+showEnv1 (Pair env (x,u)) = showEnv1 env ++ show u ++ ", "+showEnv1 (PDef xas env)   = show env++supportEnv :: Env -> [Name]+supportEnv Empty          = []+supportEnv (Pair e (_,v)) = supportEnv e `union` support v+supportEnv (PDef _ e)     = supportEnv e++instance Nominal Env where+  swap e x y = mapEnv (\u -> swap u x y) e+  support    = supportEnv++upds :: Env -> [(Binder,Val)] -> Env+upds = foldl Pair++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)+++--------------------------------------------------------------------------------+-- | 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++showDef :: Def -> String+showDef (x,t) = x <+> "=" <+> showTer t++showDefs :: [Def] -> String+showDefs = ccat . map showDef++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+++showVal :: Val -> String+showVal VU               = "U"+showVal (Ter t env)      = showTer 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 (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 (VSquash n u v)  = "squash" <+> show n <+> showVals [u,v]+showVal (Kan typ v box)  = "Kan" <+> show typ <+> showVal1 v <+> showBox 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 (VEquivSquare x y a s t) =+  "equivSquare" <+> show x <+> show y <+> showVals [a,s,t]++showVals :: [Val] -> String+showVals = hcat . map showVal1++showVal1 :: Val -> String+showVal1 VU          = "U"+showVal1 (VCon c []) = c+showVal1 u           = parens $ showVal u
+ Concrete.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE TupleSections #-}++-- Convert the concrete syntax into the syntax of miniTT.+module Concrete where++import Exp.Abs+import qualified MTT as A++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)++type Tele = [VDecl]++-- | 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++unArgsBinder :: [Binder] -> [String]+unArgsBinder = map unArgBinder++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++unPiDecl :: PiDecl -> VDecl+unPiDecl (PiDecl e t) = VDecl (map (Binder . unVar) (unApps e)) t++flattenTelePi :: [PiDecl] -> [VDecl]+flattenTelePi = flattenTele . map unPiDecl++namesTele :: Tele -> [String]+namesTele vs = unions [ unArgsBinder args | VDecl args _ <- vs ]++-------------------------------------------------------------------------------+-- | Resolver and environment++-- local environment for constructors+data Env = Env { constrs :: [String] }+         deriving (Eq, Show)++type Resolver a = ReaderT Env (StateT A.Prim (ErrorT String Identity)) a++emptyEnv :: Env+emptyEnv = Env []++runResolver :: Resolver a -> Either String a+runResolver x = runIdentity $ runErrorT $ evalStateT (runReaderT x emptyEnv) (0,"")++insertConstrs :: [String] -> Env -> Env+insertConstrs cs (Env cs') = Env $ cs ++ cs'++getEnv :: Resolver Env+getEnv = ask++getConstrs :: Resolver [String]+getConstrs = constrs <$> getEnv++genPrim :: Resolver A.Prim+genPrim = do+  prim <- lift get+  lift (modify (first succ))+  return prim++updateName :: String -> Resolver ()+updateName str = lift $ modify (\(g,_) -> (g,str))++lam :: Arg -> Resolver A.Exp -> Resolver A.Exp+lam a e = A.Lam (unArg a) <$> e++lams :: [Arg] -> Resolver A.Exp -> Resolver A.Exp+lams as e = foldr lam e as++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)++resolveWhere :: ExpWhere -> Resolver A.Exp+resolveWhere = resolveExp . unWhere++resolveBranch :: Branch -> Resolver (String,([String],A.Exp))+resolveBranch (Branch name args e) =+  ((unIdent name,) . (unArgs args,)) <$> resolveWhere e++-- 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++-- 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)++resolveLabel :: Sum -> Resolver (String,[(String,A.Exp)])+resolveLabel (Sum n tele) = (unIdent n,) <$> resolveTele (flattenTele tele)++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++checkDef :: (String,Def) -> Resolver (String,A.Exp)+checkDef (n,Def (AIdent (_,m)) args body) | n == m = do+  updateName n+  (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)+++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')+  where+    (tdecls,decls) = span isTDecl defs+    isTDecl d@(DefTDecl {}) = True+    isTDecl _               = False+    resolveTDecl (DefTDecl n e) = do e' <- resolveExp e+                                     return (unIdent n, e')+
+ Eval.hs view
@@ -0,0 +1,469 @@+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
+ Exp.cf view
@@ -0,0 +1,64 @@+entrypoints Module, Exp ;++comment "--" ;+comment "{-" "-}" ;++layout "where", "let", "of", "split" ;+layout stop "in" ;+-- Do not use layout toplevel as it makes pExp fail!++Module.   Module ::= "module" AIdent "where" "{" [Imp] [Def] "}" ;++Import.   Imp ::= "import" AIdent ;+separator Imp ";" ;++Def.       Def ::= AIdent [Arg] "=" ExpWhere ;+DefTDecl.  Def ::= AIdent ":" Exp ;+DefData.   Def ::= "data" AIdent [Arg] "=" [Sum] ;+-- TODO: Mutual not working.+-- NB: No iterated mutuals allowed!+-- DefMutual. Def ::= "mutual" "{" [Def] "}" "end" ;++separator  Def ";" ;++Where.    ExpWhere ::= Exp "where" "{" [Def] "}" ;+NoWhere.  ExpWhere ::= Exp ;++Let.      Exp  ::= "let" "{" [Def] "}" "in" Exp ;+Lam.      Exp  ::= "\\" [Binder] "->" Exp ;+Split.    Exp  ::= "split" "{" [Branch] "}" ;+Fun.      Exp1 ::= Exp2 "->" Exp1 ;+Pi.       Exp1 ::= [PiDecl] "->" Exp1 ;+App.      Exp2 ::= Exp2 Exp3 ;+Var.      Exp3 ::= Arg ;+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 ;+separator Branch ";" ;++-- Labelled sum alternatives+Sum.      Sum   ::= AIdent [VDecl] ;+separator Sum "|" ;++-- Telescopes+VDecl.     VDecl ::= "(" [Binder] ":" Exp ")" ;+terminator VDecl "" ;++-- Nonempty telescopes with Exp:s, this is hack to avoid ambiguities in the+-- grammar when parsing Pi+PiDecl.   PiDecl ::= "(" Exp ":" Exp ")" ;+terminator nonempty PiDecl "" ;++position token AIdent (letter(letter|digit|'\''|'_')*) ;
+ Exp/Lex.x view
@@ -0,0 +1,172 @@+-- -*- haskell -*-+-- This Alex file was machine-generated by the BNF converter+{+{-# OPTIONS -fno-warn-incomplete-patterns #-}+module Exp.Lex where++++import qualified Data.Bits+import Data.Word (Word8)+}+++$l = [a-zA-Z\192 - \255] # [\215 \247]    -- isolatin1 letter FIXME+$c = [A-Z\192-\221] # [\215]    -- capital isolatin1 letter FIXME+$s = [a-z\222-\255] # [\247]    -- small isolatin1 letter FIXME+$d = [0-9]                -- digit+$i = [$l $d _ ']          -- identifier character+$u = [\0-\255]          -- universal: any character++@rsyms =    -- symbols and non-identifier-like reserved words+   \{ | \} | \; | \= | \: | \\ | \- \> | \( | \) | \_ | \|++:-+"--" [.]* ; -- Toss single line comments+"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ; ++$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 $i*   { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }++++++{++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+                        ]+}
+ Exp/Par.y view
@@ -0,0 +1,182 @@+-- This Happy file was machine-generated by the BNF converter+{+{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}+module Exp.Par where+import Exp.Abs+import Exp.Lex+import Exp.ErrM++}++%name pModule Module+%name pExp Exp++-- no lexer declaration+%monad { Err } { thenM } { returnM }+%tokentype { Token }++%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) }++L_AIdent { PT _ (T_AIdent _) }+L_err    { _ }+++%%++AIdent    :: { AIdent} : L_AIdent { AIdent (mkPosToken $1)}++Module :: { Module }+Module : 'module' AIdent 'where' '{' ListImp ListDef '}' { Module $2 $5 $6 } +++Imp :: { Imp }+Imp : 'import' AIdent { Import $2 } +++ListImp :: { [Imp] }+ListImp : {- empty -} { [] } +  | Imp { (:[]) $1 }+  | 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 }+++ListDef :: { [Def] }+ListDef : {- empty -} { [] } +  | Def { (:[]) $1 }+  | Def ';' ListDef { (:) $1 $3 }+++ExpWhere :: { ExpWhere }+ExpWhere : Exp 'where' '{' ListDef '}' { Where $1 $4 } +  | Exp { NoWhere $1 }+++Exp :: { Exp }+Exp : 'let' '{' ListDef '}' 'in' Exp { Let $3 $6 } +  | '\\' ListBinder '->' Exp { Lam $2 $4 }+  | 'split' '{' ListBranch '}' { Split $3 }+  | Exp1 { $1 }+++Exp1 :: { Exp }+Exp1 : Exp2 '->' Exp1 { Fun $1 $3 } +  | ListPiDecl '->' Exp1 { Pi $1 $3 }+  | Exp2 { $1 }+++Exp2 :: { Exp }+Exp2 : Exp2 Exp3 { App $1 $2 } +  | Exp3 { $1 }+++Exp3 :: { Exp }+Exp3 : Arg { 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 } +++ListBranch :: { [Branch] }+ListBranch : {- empty -} { [] } +  | Branch { (:[]) $1 }+  | Branch ';' ListBranch { (:) $1 $3 }+++Sum :: { Sum }+Sum : AIdent ListVDecl { Sum $1 (reverse $2) } +++ListSum :: { [Sum] }+ListSum : {- empty -} { [] } +  | Sum { (:[]) $1 }+  | Sum '|' ListSum { (:) $1 $3 }+++VDecl :: { VDecl }+VDecl : '(' ListBinder ':' Exp ')' { VDecl $2 $4 } +++ListVDecl :: { [VDecl] }+ListVDecl : {- empty -} { [] } +  | ListVDecl VDecl { flip (:) $1 $2 }+++PiDecl :: { PiDecl }+PiDecl : '(' Exp ':' Exp ')' { PiDecl $2 $4 } +++ListPiDecl :: { [PiDecl] }+ListPiDecl : PiDecl { (:[]) $1 } +  | PiDecl ListPiDecl { (:) $1 $2 }++++{++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+}+
+ LICENSE view
@@ -0,0 +1,21 @@+Copyright (c) 2013 Cyril Cohen, Thierry Coquand, Simon Huber, Anders+Mörtberg++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ MTT.hs view
@@ -0,0 +1,334 @@+-- 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 view
@@ -0,0 +1,136 @@+{-# 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
@@ -0,0 +1,105 @@+module Main where++import Control.Monad.Trans.Reader+import Control.Monad.Error+import Data.List+import System.Environment+import System.Console.Haskeline+import System.Directory++import Exp.Lex+import Exp.Par+import Exp.Print+import Exp.Abs+import Exp.Layout+import Exp.ErrM+import MTTtoCTT+import Concrete+import qualified MTT  as A+import qualified CTT as C+import qualified Eval as E++type Interpreter a = InputT IO a++defaultPrompt :: String+defaultPrompt = "> "++lexer :: String -> [Token]+lexer = resolveLayout True . myLexer++showTree :: (Show a, Print a) => a -> IO ()+showTree tree = do+  putStrLn $ "\n[Abstract Syntax]\n\n" ++ show tree+  putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree++main :: IO ()+main = getArgs >>= runInputT defaultSettings . runInterpreter++-- (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  = fail ("Looping imports in " ++ f)+  | f `elem` loaded = return st+  | otherwise       = do+    s <- lift $ readFile f+    let ts = lexer s+    case pModule ts of+      Bad s  -> fail $ "Parse Failed in file " ++ show f ++ "\n" ++ show s+      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')++runInterpreter :: [FilePath] -> Interpreter ()+runInterpreter 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    -> outputStrLn $ "Resolver failed: " ++ err+      Right adefs -> case A.runDefs A.tEmpty adefs of+        Left err   -> outputStrLn $ "Type checking failed: " ++ err+        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 fs+        Just (':':'l':' ':str) -> runInterpreter (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++help :: String+help = "\nAvailable commands:\n" +++       "  <statement>     infer type and evaluate statement\n" +++       "  :q              quit\n" +++       "  :l <filename>   loads filename (and resets environment before)\n" +++       "  :cd <path>      change directory to path\n" +++       "  :r              reload\n" +++       "  :h              display this message\n"
+ Makefile view
@@ -0,0 +1,11 @@+all: +	ghc --make -O2 -o cubigle Main.hs+bnfc:+	bnfc -d Exp.cf+	happy -gca Exp/Par.y+	alex -g Exp/Lex.x+	ghc --make Exp/Test.hs -o Exp/Test+clean:+	rm -f *.log *.aux *.hi *.o cubigle+	cd Exp && rm -f ParExp.y LexExp.x LexhExp.hs \+                        ParExp.hs PrintExp.hs AbsExp.hs *.o *.hi
+ Pretty.hs view
@@ -0,0 +1,28 @@+-- Common functions used for pretty printing.+module Pretty where++--------------------------------------------------------------------------------+-- | Pretty printing combinators. Use the same names as in the pretty library.+(<+>) :: String -> String -> String+[] <+> y  = y+x  <+> [] = x+x  <+> y  = x ++ " " ++ y++infixl 6 <+>++hcat :: [String] -> String+hcat []     = []+hcat [x]    = x+hcat (x:xs) = x <+> hcat xs++ccat :: [String] -> String+ccat []     = []+ccat [x]    = x+ccat (x:xs) = x <+> ", " <+> ccat xs++parens :: String -> String+parens p = "(" ++ p ++ ")"++-- Angled brackets, not present in pretty library.+abrack :: String -> String+abrack p = "<" ++ p ++ ">"
+ README.md view
@@ -0,0 +1,234 @@+CUBICAL
+=======
+
+Cubical implements an experimental simple type-checker for type theory
+with univalence with an evaluator for closed terms.
+
+
+INSTALL
+-------
+
+To install cubical a working Haskell and cabal installation are
+required.  To build cubical go to the main directory and do
+
+  `cabal install`
+
+To only build cubical do
+
+  `cabal configure`
+
+  `cabal build`
+
+
+USAGE
+-----
+
+To run cubical type
+
+  `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.
+
+
+OVERVIEW
+--------
+
+The program is organized as follows:
+
+ * the files are parsed and produce a list of definitions; the syntax
+   is described in the file Exp/Doc.txt or Exp/Doc.tex (auto generated
+   by bnfc);
+
+ * this list of definitions is type-checked;
+
+ * if successful, we can then write an expression which is
+   type-checked w.r.t. these definitions;
+
+ * 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);
+
+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
+error messages.
+
+These primitives however have a meaning in cubical sets, and the
+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.
+
+For writing this semantics, it was convenient to use the alternative
+presentation of cubical sets as nominal sets with 01-substitutions
+(see A. Pitts' note, references listed below).
+
+
+DESCRIPTION OF THE LANGUAGE
+---------------------------
+
+We have
+
+ * dependent function types `(x:A) -> B`; non-dependent function types
+   can be written as `A -> B`
+
+ * abstraction `\x -> e`
+
+ * named/labelled sum `c1 (x1:A1)...(xn:An) | c2 ... | ...`
+   a data type is a recursively defined named sum
+
+ * function defined by case
+   `f = split c1 x1 ... xn -> e1 | c2 ... -> ... | ...`
+
+ * 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`
+
+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, in particular,
+there is no termination check.
+
+
+DESCRIPTION OF THE SEMANTICS/EVALUATION
+---------------------------------------
+
+The values depend on a new class of names, also called directions,
+which can be thought of as varying over the unit interval [0,1].  A
+path connecting a0 and a1 in the direction x is a value p(x) such that
+p(0) = a0 and p(1) = a1.  An element in the identity type a0 = a1 is
+then of the form <x>p(x) where the name x is bound.  An identity proof
+in an identity type will then be interpreted as a "square" of the form
+<x><y>p(x,y).  See examples/hedberg.cub and the example test3 (in the
+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
+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
+Kan filling operation for this new type.
+
+The Kan filling for the universe can be seen as a generalization of
+the operation of composition of relation.
+
+
+DESCRIPTION OF THE EXAMPLES
+---------------------------
+
+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
+file examples/primitive.cub should be the basis of any development
+using univalence.
+
+Most of the example files contain simple test examples of
+computations:
+
+ * the file hedberg.cub contains a test computation of a square in
+   Nat; the example is test. In the type Nat or Bool, any square
+   (proof of identity of two identity proofs) is constant.
+
+ * The file nIso.cub contains a non trivial example of a transport of
+   a section of a dependent type along the isomorphism between N and
+   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
+   a (surprisingly complex) composition of squares in the universe.
+
+ * The file quotient.cub contains an example of a computation from an
+   equivalence class.  The relation R over Nat is to have the same
+   parity, and the map is Nat/R -> Bool which returns true if the
+   equivalence class contains even number. The examples are test5 and
+   test8 which computes the value of this map on the equivalence class
+   of five and eight respectively. This uses the file description.cub
+   which justifies the axiom of description.
+
+ * The file Kraus.cub contains the example of Nicolai Kraus of the
+   myst function, which also shows that we can extract computational
+   information from propositions; the example is testMyst zero; the
+   computation does not create higher dimensional objects.
+
+ * The file swap.cub contains examples of transport along the
+   isomorphism between A x B and B x A; the examples are test14,
+   test15.
+
+
+
+FURTHER WORK (non-exhaustive)
+------------
+
+ * The Kan filling operations should be formally proved correct and
+   tested on higher inductive types.
+
+ * 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)`
+
+   has a semantics which satisfies the definitional equalities:
+
+    `cong (id A)       = id A`
+
+    `cong (g o f)      = (cong g) o (cong f)`
+
+    `cong 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.
+
+   Some proofs are then much simpler, 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.
+
+ * 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).
+
+ * To explore the termination of the resizing rule.  Computationally
+   the resizing rule does not do anything, but the termination seems
+   to be an interesting proof-theoretical problem.
+
+
+REFERENCES
+----------
+
+ * Voevodsky's home page on univalent foundation
+
+ * HoTT book 
+
+ * 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
+
+ * A cubical set model of type theory, M. Bezem, Th. Coquand and
+   S. Huber available at www.cse.chalmers.se/~coquand/model1.pdf
+
+ * A property of contractible types, Th. Coquand available at
+   www.cse.chalmers.se/~coquand/contr.pdf
+
+ * An equivalent presentation of the Bezem-Coquand-Huber category of
+   cubical sets, A. Pitts
+
+
+AUTHORS
+-------
+
+Cyril Cohen, Thierry Coquand, Simon Huber, Anders Mörtberg
+ Setup.hs view
@@ -0,0 +1,8 @@+import Distribution.Simple+import System.Process+import System.Exit+main = do+  ret <- system "bnfc -d Exp.cf"+  case ret of+    ExitSuccess   -> defaultMain+    ExitFailure n -> error $ "bnfc command not found or error" ++ show n
+ cubical.cabal view
@@ -0,0 +1,27 @@+name:                cubical+version:             0.1.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.+homepage:            https://github.com/simhu/cubical+extra-source-files:  Makefile, README.md, Exp.cf, examples/*.cub+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:      +  build-tools:         alex, happy+  default-language:    Haskell2010+  hs-source-dirs:      .+  other-modules:       CTT, Concrete, Eval, MTT, MTTtoCTT, Pretty
+ dist/build/cubical/cubical-tmp/Exp/Lex.hs view
@@ -0,0 +1,351 @@+{-# 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 view
@@ -0,0 +1,985 @@+{-# 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
@@ -0,0 +1,147 @@+module BoolEqBool where++import equivSet+import hedberg++notInj : (x y : Bool) -> Id Bool (not x) (not y) -> Id Bool x y+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++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++sNot : (b : Bool) -> notFiber b+sNot b = pair (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))++  rem : Id Bool (not b) b'+  rem = notInj (not b) b' rem1++eqBoolBool : Id U Bool Bool+eqBoolBool = equivEq Bool Bool not sNot tNot++transportInv : (A B : U) -> Id U A B -> B -> A+transportInv = substInv U (\x -> x)++notEqBool : Bool -> Bool+notEqBool = transport Bool Bool eqBoolBool++testBool : Bool+testBool = notEqBool (true)++compEqBool : Id U Bool Bool+compEqBool = comp U Bool Bool Bool eqBoolBool eqBoolBool++transport' : (A B : U) -> Id U A B -> A -> B+transport' = subst U (\x -> x)++funCompEqBool : Bool -> Bool+funCompEqBool = transport' Bool Bool compEqBool++newTestBool : Bool+newTestBool = funCompEqBool (true)++newCompEqBool : Id U Bool Bool+newCompEqBool = comp U Bool Bool Bool eqBoolBool (refl U Bool)++test2Bool : Bool+test2Bool = transport' Bool Bool newCompEqBool (true)++monoid : U -> U+monoid A = and A (A -> A -> A)++zm : (A : U) (m : monoid A) -> A+zm A m = fst A (\x -> A -> A -> A) m++opm : (A : U) (m : monoid A) -> (A -> A -> A)+opm A m = snd A (\x -> A -> A -> A) m++transm : (A B : U) -> Id U A B -> monoid A -> monoid B+transm = subst U monoid ++transun : (A B : U) -> Id U A B -> (A -> A) -> (B -> B)+transun = subst U (\X -> (X -> X))++transid : Bool -> Bool+transid = transun Bool Bool eqBoolBool (\x -> x)++True : Bool+True = true++False : Bool+False = false++testT : Bool+testT = transid True++testT' : Bool+testT' = transun Bool Bool (refl U Bool) (\x -> x) True++testF : Bool+testF = transid False++monoidAndBool : monoid Bool+monoidAndBool = pair (true) andBool++mBool2 : monoid Bool+mBool2 = transm Bool Bool eqBoolBool monoidAndBool++opBool2 : Bool -> Bool -> Bool+opBool2 = opm Bool mBool2++testTF : Bool+testTF = opBool2 True False++testFT : Bool+testFT = opBool2 False True++testFF : Bool+testFF = opBool2 False False++testTT : Bool+testTT = opBool2 True True++-- Bool tests:++equivBool : Id U Bool Bool+equivBool = equivSet Bool Bool not not notK notInj boolIsSet++mBool3 : monoid Bool+mBool3 = transm Bool Bool equivBool monoidAndBool++opBool3 : Bool -> Bool -> Bool+opBool3 = opm Bool mBool3++testTF3 : Bool+testTF3 = opBool3 True False++testFT3 : Bool+testFT3 = opBool3 False True++testFF3 : Bool+testFF3 = opBool3 False False++testTT3 : Bool+testTT3 = opBool3 True True+
+ examples/Kraus.cub view
@@ -0,0 +1,82 @@+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+testMyst n = myst (incI N n)
+ examples/UnotSet.cub view
@@ -0,0 +1,34 @@+module UnotSet where++import BoolEqBool++-- proves that U is not a set++negUIP : neg (set U)+negUIP uipU = tnotf lem5+  where+  eqreflnot : Id (Id U Bool Bool) (refl U Bool) eqBoolBool+  eqreflnot = uipU Bool Bool (refl U Bool) eqBoolBool++  frefl : Bool -> Bool+  frefl = transport Bool Bool (refl U Bool)++  fnot : Bool -> Bool+  fnot = transport Bool Bool eqBoolBool++  lem1 : Id (Bool -> Bool) frefl fnot+  lem1 = cong (Id U Bool Bool) (Bool -> Bool) (transport Bool Bool) +              (refl U Bool) eqBoolBool eqreflnot++  lem2 : Id Bool true (frefl true)+  lem2 = transportRef Bool true++  lem3 : Id Bool false (fnot true)+  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++  lem5 : Id Bool true false+  lem5 = compDown Bool true (frefl true) false (fnot true) lem2 lem3 lem4+
+ examples/axChoice.cub view
@@ -0,0 +1,52 @@+module axChoice where++import contr++-- an interesting isomorphism/equality++idTelProp : (A:U) (B:A -> U) (C:(x:A) -> B x -> U) -> +              Id U ((x:A) -> Sigma (B x) (C x)) (Sigma ((x:A) -> B x) (\ f -> (x:A) -> C x (f x)))+idTelProp A B C = isoId T0 T1 f g sfg rfg + where+  T0 : U +  T0 = (x:A) -> Sigma (B x) (C x) ++  T1 : U +  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))++  g : T1 -> T0+  g = split+       pair u v -> \ x -> pair (u x) (v 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++  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)++-- we deduce from this equality that isEquiv f is a proposition++propIsEquiv : (A B : U) -> (f : A -> B) -> prop (isEquiv A B f)+propIsEquiv A B f = subst U prop ((y:B) -> contr' (fiber A B f y)) (isEquiv A B f) rem rem1+ where +   rem : Id U ((y:B) -> contr' (fiber A B f y)) (isEquiv A B f) +   rem = idTelProp B (fiber A B f) (\ y -> \ s -> (v :fiber A B f y) -> Id (fiber A B f y) s v)++   rem1 : prop ((y:B) -> contr' (fiber A B f y))+   rem1 = isPropProd B (\ y -> contr' (fiber A B f y)) (\ y -> contr'IsProp (fiber A B f y))
+ examples/commutative.cub view
@@ -0,0 +1,6 @@+module weq where
+
+import univ
+
+com : U -> U
+com = pair (A -> A -> A) (
+ examples/cong.cub view
@@ -0,0 +1,82 @@+module cong where++import set+import function++-- All of these lemmas on cong 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))++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)+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)+  where+  rem1 : (u : A) -> Id (Id A u u) (refl A u) (cong 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)++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))+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+  Tgf : (a0 a1 : A) -> U +  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+  +  congg : (a0 a1 : A) -> Id B (f a0) (f a1) -> Tgf a0 a1+  congg a0 a1 = cong 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))++  rem : (a0 a1 : A) (p : Id A a0 a1) -> +        Id (Tgf a0 a1) (conggf a0 a1 p) (congg a0 a1 (congf a0 a1 p))+  rem a = J A a (\a1 p -> Id (Tgf a a1) (conggf a a1 p) (congg a a1 (congf a a1 p)))+             rem1+    where+    rem2 : Id (Tgf a a) (refl C (g (f a))) (conggf a a (refl A a))+    rem2 = congRefl A C (\x -> g (f x)) a++    rem4 : Id (Id B (f a) (f a)) (refl B (f a)) (congf a a (refl A a))+    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)) +                (congf a a (refl A a)) rem4++    rem5 : Id (Tgf a a) (refl C (g (f a))) (congg a a (refl B (f a)))+    rem5 = congRefl B C g (f a)++    rem1 : Id (Tgf a a) (conggf a a (refl A a)) (congg a a (congf a a (refl A a)))+    rem1 = compUp (Tgf a a) (refl C (g (f a))) (conggf a a (refl A a))+                              (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
@@ -0,0 +1,157 @@+module contr where++import gradLemma++-- a product of contractibles is contractible++contr : U -> U+contr A = Id U Unit A++contrIsProp : (A:U) -> contr A -> prop A+contrIsProp A cA = subst U prop Unit A cA propUnit++propContr : (A : U) -> A -> prop A -> contr A+propContr A a pA = propExt Unit A propUnit pA (\_ -> a) (\_ -> tt)++-- a singleton is a proposition++singlIsProp : (A:U) (a:A) -> prop (singl A a)+singlIsProp A a v0 v1 =+ comp (singl A a) v0 (sId A a) v1 (inv (singl A a) (sId A a) v0 (tId A a v0)) (tId A a v1)++-- another definition of contr++contr' : U -> U+contr' A = Sigma A (\ a -> (x:A) -> Id A a x)++-- 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))++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+ where+   rem : Id (A -> U) (\ _ -> Unit) B+   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++   f : Unit -> A -> Unit+   f z a = tt++   g : (A -> Unit) -> Unit+   g _ = tt++   sfg : (z : A -> Unit) -> Id (A -> Unit) (f (g z)) z+   sfg z = funExt A (\ _ -> Unit) (f (g z)) z (\ x -> propUnit (f (g z) x) (z x))++   rfg : (z:Unit) -> Id Unit (g (f z)) z+   rfg z = propUnit (g (f z)) z++   rem2 : Id U Unit (A -> Unit)+   rem2 = isoId Unit (A -> Unit) f g sfg rfg++-- 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)++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)++                 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) ++-- Voevodsky's definition of propositions++propIsContr : (A:U) -> prop A -> (a0 a1:A) -> contr (Id A a0 a1)+propIsContr A pA a0 a1 = propContr (Id A a0 a1) (pA a0 a1) (propUIP A pA a0 a1)++-- if A is contractible and a:A then Sigma A P is equal to P a++hasContrSig : U -> U+hasContrSig A =  (P : A -> U) -> (x: A) -> Id U (Sigma A P) (P x)++lemUnitSig : hasContrSig Unit+lemUnitSig P = + split+  tt -> isoId T F f g rfg sfg+   where +    T : U+    T = Sigma Unit P++    F : U+    F = P tt++    f : T -> F+    f = split+         pair x u -> rem x u+          where rem : (x:Unit) -> P x -> P tt+                rem = split+                       tt -> \ u -> u++    g : F -> T+    g u = pair 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)++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)+ 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+             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)))+ ++-- any function between two contractible types is an equivalence++equivUnit : (f : Unit -> Unit) -> isEquiv Unit Unit f+equivUnit f = subst (Unit -> Unit) (isEquiv Unit Unit) (id Unit) f rem (idIsEquiv Unit)+ where+  rem : Id (Unit->Unit) (id Unit) f+  rem = funExt Unit (\ _ -> Unit)  (id Unit) f (\ x -> propUnit x (f x))++-- an elimination principle for Contr++elimContr : (P : U -> U) -> P Unit -> (A : U) -> contr A -> P A+elimContr P d A cA = subst U P Unit A cA d++equivContr : (A : U) -> contr A -> (B : U) -> contr B -> (f : A -> B) -> isEquiv A B f+equivContr = elimContr (\ A ->  (B : U) -> contr B -> (f : A -> B) -> isEquiv A B f) rem+ where rem :  (B : U) -> contr B -> (f : Unit -> B) -> isEquiv Unit B f+       rem = elimContr (\ X ->  (f : Unit -> X) -> isEquiv Unit X f) equivUnit+
+ examples/description.cub view
@@ -0,0 +1,29 @@+module description where++import exists+import set++exAtOne : (A : U) (B : A -> U) -> exactOne A B -> atmostOne A B+exAtOne A B = split+  pair g h' -> h'++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))++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'++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')++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')++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')+iotaLem A B h h' a p = exAtOne A B h' a (iota A B h h') p (iotaSound A B h h')
+ examples/elimEquiv.cub view
@@ -0,0 +1,27 @@+module elimEquiv where++import univalence++-- a corollary of equivalence++allTransp : (A B : U) -> hasSection (Id U A B) (Equiv A B) (IdToEquiv A B)+allTransp A B = equivSec (Id U A B) (Equiv A B)  (IdToEquiv A B) (univAx A B)++-- an induction principle for isEquiv++transpRef : (A : U) -> Id (A->A) (id A) (transport A A (refl U A))+transpRef A = funExt A (\ _ -> A) (id A) (transport A A (refl U A)) (transportRef A)++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)+ 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++  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)+
+ examples/epi.cub view
@@ -0,0 +1,75 @@+-- the notion of surjection functions++module epi where++import omega++-- surjective and epi maps++isEpi : (A B: U) -> (A -> B) -> U+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)++-- these properties should be equivalent++surjIsEpi : (A B : U) (f : A -> B) -> isSurj A B f -> isEpi A B f+surjIsEpi A B f sf X sX g h egh = funExt B (\ _ -> X) g h rem+ where+  rem : (y:B) -> Id X (g y) (h y)+  rem y = rem6+    where+     G : U+     G = Id X (g y) (h y)++     rem1 : prop G+     rem1 = sX (g y) (h y)++     rem2 : exist A (\ x -> Id B (f x) y)+     rem2 = sf y++     rem4 : (x:A) -> Id X (g (f x)) (h (f x))+     rem4 a = appId A X a (\ x -> g (f x)) (\ x -> h (f x)) egh++     rem3 : (x:A) -> Id B (f x) y -> G+     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++     rem6 : G+     rem6 = exElim A (\ x -> Id B (f x) y) G rem1 rem5 rem2++-- the converse is interesting++epiIsSurj : (A B : U) (f : A -> B) -> isEpi A B f -> isSurj A B f+epiIsSurj A B f ef = rem6+ where +   rem : (g h : B -> Omega) -> Id (A -> Omega) (\ x -> g (f x)) (\ x -> h (f x)) -> Id (B -> Omega) g h+   rem = ef Omega omegaIsSet++   g : B -> Omega+   g y = pair 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)))++   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)))++   rem2 : (x:A) -> Id Omega (g (f x)) (h (f x))+   rem2 x = lemIsTrue (g (f x)) (h (f x)) (\ _ -> rem1 x) (\ _ -> tt)++   rem3 : Id (A -> Omega) (\ x -> g (f x)) (\ x -> h (f x))+   rem3 = funExt A (\ _ -> Omega)  (\ x -> g (f x)) (\ x -> h (f x)) rem2++   rem4 : Id (B -> Omega) g h +   rem4 = rem g h rem3++   rem5 : (y:B) -> Id Omega (g y) (h y)+   rem5 y = appId B Omega y g h rem4++   rem6 : (y:B) -> isTrue (h y)+   rem6 y = subst Omega isTrue (g y) (h y) (rem5 y) tt
+ examples/equivProp.cub view
@@ -0,0 +1,17 @@+module equivProp where
+
+import equivSet
+
+-- The goal is to prove that equivalent propositions are equal
+
+propExt : (A B : U) -> (prop A) -> (prop B) -> (A -> B) -> (B -> A) -> Id U A B
+propExt A B pA pB f g = equivSet A B f g sfg injf setB
+  where
+  sfg : section A B f g
+  sfg b = pB (f (g b)) b
+
+  injf : injective A B f
+  injf a0 a1 _ = pA a0 a1
+
+  setB : set B
+  setB = propUIP B pB
+ examples/equivSet.cub view
@@ -0,0 +1,38 @@+module equivSet where
+
+import function
+import set
+
+-- a sufficient condition for two sets being equal
+-- this is implied by the gradlemma, which has however a more complex proof
+
+equivSet : (A B : U) (f : A -> B) (g : B -> A) -> (section A B f g) 
+           -> (injective A B f) -> (set B) -> Id U A B
+equivSet A B f g sfg injf setB = equivEq A B f sf tf
+  where
+  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'
+  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)
+
+  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
+
+    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))
+
+    rem : Id A (g b) a'
+    rem = injf (g b) a' rem1
+
+ examples/equivTotal.cub view
@@ -0,0 +1,167 @@+module equivTotal where++import elimEquiv++-- 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)++lem1Sub : (A:U) (P: A -> U) (a:A) -> Id U (fiber (Sigma A P) A (fst A P) 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)++-- a corollary of equivalence++allTransp : (A B : U) -> hasSection (Id U A B) (Equiv A B) (IdToEquiv A B)+allTransp A B = equivSec (Id U A B) (Equiv A B)  (IdToEquiv A B) (univAx A B)++-- an induction principle for isEquiv++transpRef : (A : U) -> Id (A->A) (id A) (transport A A (refl U A))+transpRef A = funExt A (\ _ -> A) (id A) (transport A A (refl U A)) (transportRef A)++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)+ 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++  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)++-- a simple application; with yet another problem with eta conversion++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+ 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)++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++  T : U+  T = Sigma (Sigma A P) F++  G : Sigma A Q -> U+  G z = Id A (fst A Q z) a++  V : U+  V = Sigma (Sigma A Q) G++  rem : Id U T (P a)+  rem = lem1Sub A P a++  rem1 : Id U V (Q a)+  rem1 = lem1Sub A Q a++  F1 : Sigma A P -> U+  F1 z = G (liftTot A P Q g z)++  T1 : U+  T1 = Sigma (Sigma A P) F1++  rem2 : Id U T1 V+  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+      where fFF1 : (z : Sigma A P) -> Id U (F z) (F1 z)+            fFF1 = split+                    pair x u -> refl U (Id A x a)++            eFF1 : Id (Sigma A P -> U) F F1+            eFF1 = funExt (Sigma A P) (\ _ -> U) F F1 fFF1++  rem4 : Id U T V+  rem4 = comp U T T1 V rem3 rem2++  rem5 : Id U (P a) (Q a)+  rem5 = compUp U T (P a) V (Q a) rem rem1 rem4++-- now we should be able to show that any map Id (Pi A B) f g -> (x:A) -> Id (B x) (f x) (g x)+-- is an equivalence++singlPi : (A:U) (B:A->U) -> Pi A B -> Pi A B -> U+singlPi A B g f = (x:A) -> Id (B x) (f x) (g x)++singlPiContr : (A:U) (B:A->U) (g:Pi A B) -> contr (Sigma (Pi A B) (singlPi A B g))+singlPiContr A B g = subst U contr  ((x:A) -> Sigma (B x) (C x)) (Sigma (Pi A B) (\ z -> (x:A) -> C x (z x))) rem1 rem+ where+  C : (x:A) -> B x -> U+  C x y = Id (B x) y (g x)++  rem : contr ((x:A) -> Sigma (B x) (C x))+  rem = isContrProd A (\ x -> Sigma (B x) (C x)) (\ x -> singContr (B x) (g x))++  rem1 : Id U ((x:A) -> Sigma (B x) (C x)) (Sigma (Pi A B) (\ z -> (x:A) -> C x (z x)))+  rem1 = idTelProp A B C++-- we have enough to deduce that Id (Pi A B) f g and (x:A) -> Id (B x) (f x) (g x) are equal+eqIdProd : (A:U) (B:A->U) -> (f g : Pi A B) -> Id U (Id (Pi A B) f g) ((x:A) -> Id (B x) (f x) (g x))+eqIdProd A B f g = equivTot T P Q G rem f+ where +  P : (Pi A B) -> U+  P z = Id (Pi A B) z g++  Q : (Pi A B) -> U+  Q z = (x:A) -> Id (B x) (z x) (g x)++  T : U+  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++  rem1 : contr (Sigma T P)+  rem1 = singContr (Pi A B) g++  rem2 : contr (Sigma T Q)+  rem2 = singlPiContr A B g++  rem : isEquiv (Sigma T P) (Sigma T Q) (liftTot T P Q G)+  rem = equivContr (Sigma T P) rem1 (Sigma T Q) rem2 (liftTot T P Q G)++-- it follows from this that a product of sets is a set++isSetProd : (A:U) (B:A->U) (pB : (x:A) -> set (B x)) -> set (Pi A B)+isSetProd A B pB f g = substInv U prop  (Id (Pi A B) f g) ((x:A) -> Id (B x) (f x) (g x)) rem2 rem1+ where+  rem : (x:A) -> prop (Id (B x) (f x) (g x))+  rem x = pB x (f x) (g x)++  rem1 : prop ((x:A) -> Id (B x) (f x) (g x))+  rem1 = isPropProd A (\ x -> Id (B x) (f x) (g x)) rem++  rem2 : Id U (Id (Pi A B) f g) ((x:A) -> Id (B x) (f x) (g x))+  rem2 = eqIdProd A B f g++
+ examples/exists.cub view
@@ -0,0 +1,22 @@+module exists where++import prelude++-- existence: a new modality++exists : (A : U) (B : A -> U) -> U+exists A B = inh (Sigma A B)++exElim : (A : U) (B : A -> U) (C : U) -> prop C -> (Sigma A B -> C) ->+         exists A B -> C+exElim A B C p f = inhrec (Sigma A B) C p f++atmostOne : (A : U) (B : A -> U) -> U+atmostOne A B = (a b : A) -> B a -> B b -> Id A a b++exactOne : (A : U) (B : A -> U) -> U+exactOne A B = and (exists A B) (atmostOne A B)++lemInh : (A : U) -> prop A -> inh A -> A+lemInh A h = inhrec A A h (\x -> x)+
+ examples/function.cub view
@@ -0,0 +1,79 @@+module function where++import lemId++-- some general facts about functions++-- 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++injective : (A B : U) (f : A -> B) -> U+injective A B f = (a0 a1 : A) -> Id B (f a0) (f a1) -> Id A a0 a1++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) -> +             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+  rem1 : Id A (g (f a0)) a0+  rem1 = h a0++  rem2 : Id A (g (f a1)) a1+  rem2 = h a1++  rem3 : Id A (g (f a0)) (g (f a1))+  rem3 = cong 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) ++-- 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)++                        rem2 : Q y+                        rem2 = subst B Q (f (g y)) y (sfg y) rem1+++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+  where+  s : (y : B) -> fiber A B f y+  s y = pair (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++injProp : (A B : U) (f : A -> B) -> injective A B f -> prop B -> prop A+injProp A B f injf pB a0 a1 = injf a0 a1 (pB (f a0) (f a1))++injId : (X : U) -> injective X X (id X)+injId X a0 a1 h = h+++idempotent : (A:U) -> (A->A) -> U+idempotent A f = section A A f f +
+ examples/gradLemma.cub view
@@ -0,0 +1,145 @@+module gradLemma where
+
+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) 
+
+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 
+  rem : Id (A -> A) h (id A)
+  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 -> 
+            isEquiv A B f
+gradLemma A B f g sfg rfg = isEquivSection A B f g sfg rem
+  where
+  injf : injective A B f
+  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
+
+         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
+
+         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
+
+         rem11 : Id (B -> B) fg (id B)
+         rem11 = funExt B (\ _ -> B)  fg (id B) sfg
+
+         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
+
+         c1 : (a:A) -> E a -> E a
+         c1 a = cong B B (id B) (f a) b
+
+         rem13 : Id (E a0 -> E a0) (id (E a0)) (c1 a0) 
+         rem13 = congId B (f a0) b
+
+         rem14 : Id (E a0) e0 (c1 a0 e0) 
+         rem14 = appId (E a0) (E a0) e0  (id (E a0)) (c1 a0) rem13
+
+         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
+
+         rem16 : Id (E a1 -> E a1) (id (E a1)) (c1 a1) 
+         rem16 = congId B (f a1) b
+
+         rem17 : Id (E a1) e1 (c1 a1 e1) 
+         rem17 = appId (E a1) (E a1) e1  (id (E a1)) (c1 a1) rem16
+
+         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
+
+         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
+
+-- isomorphic types are equal
+
+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) -> 
+            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
@@ -0,0 +1,61 @@+module hedberg where++import set++-- proves that a type with decidable equality is a set+-- in particular both N and Bool are sets++const : (A : U) (f : A -> A) -> U+const A f = (x y : A) -> Id A (f x) (f y)++exConst : (A : U) -> U+exConst A = Sigma (A -> A) (const A)++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))++hedbergLemma : (A: U) (f : (a b : A) -> Id A a b -> Id A a b) (a b : A)+            (p : Id A a b) ->+            Id (Id A a b) (comp A a a b (f a a (refl A a)) p) (f a b p)+hedbergLemma A f a = J A a (\ b p -> Id (Id A a b) (comp A a a b (f a a (refl A a)) p) (f a b p)) rem+  where rem : Id (Id A a a) (comp A a a a (f a a (refl A a)) (refl A a)) (f a a (refl A a))+        rem = compIdr A a a (f a a (refl A a))++hedberg : (A : U) -> discrete A -> set A+hedberg A h a b p q = lemSimpl A a a b r p q rem5+  where+    rem1 : (x y : A) -> exConst (Id A x y)+    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)++    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)++    r : Id A a a+    r = f a a (refl A a)++    rem2 : Id (Id A a b) (comp A a a b r p) (f a b p)+    rem2 = hedbergLemma A f a b p++    rem3 : Id (Id A a b) (comp A a a b r q) (f a b q)+    rem3 = hedbergLemma A f a b q++    rem4 : Id (Id A a b) (f a b p) (f a b q)+    rem4 = fIsConst a b p q++    rem5 : Id (Id A a b) (comp A a a b r p) (comp A a a b r q)+    rem5 = compDown (Id A a b) (comp A a a b r p) (f a b p) (comp A a a b r q) (f a b q) rem2 rem3 rem4++NIsSet : set N+NIsSet = hedberg N natDec++test3 : Id (Id N zero zero) (refl N zero) (refl N zero)+test3 = NIsSet zero zero (refl N zero) (refl N zero)++boolIsSet : set Bool+boolIsSet = hedberg Bool boolDec+
+ examples/idempotent.cub view
@@ -0,0 +1,74 @@+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/lemId.cub view
@@ -0,0 +1,121 @@+module lemId where
+
+import prelude
+
+-- general lemmas about Identity type
+
+comp : (A : U) -> (a b c : A) -> Id A a b -> Id A b c -> Id A a c
+comp A a b c p q = subst A (Id A a) b c q p
+
+compInvIdr : (A : U) -> (a b : A) -> (p : Id A a b) -> Id (Id A a b) p (comp A a b b p (refl A b))
+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)
+
+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)
+
+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)
+
+compInvIdl : (A : U) -> (b c : A) -> (q : Id A b c) ->
+          Id (Id A b c) q (comp A b b c (refl A b) q)
+compInvIdl A b c q = J A b (\c q -> Id (Id A b c) q (comp A b b c (refl A b) q)) rem c q
+  where
+    rem : Id (Id A b b) (refl A b) (comp A b b b (refl A b) (refl A b))
+    rem = compInvIdr A b b (refl A b)
+
+compIdl : (A : U) -> (b c : A) -> (q : Id A b c) ->
+             Id (Id A b c) (comp A b b c (refl A b) q) q
+compIdl A b c q = inv (Id A b c) q (comp A b b c (refl A b) q) (compInvIdl A b c q)
+
+compInv : (A : U) -> (a b c : A) -> Id A a b -> Id A a c -> Id A b c
+compInv A a b c p r = subst A (\ x -> Id A x c) a b p r
+
+compInvIdl' : (A : U) (a b : A) (p : Id A a b) ->
+               Id (Id A a b) p (compInv A a a b (refl A a) p)
+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)
+
+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
+
+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
+
+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))
+lemInv A a b c p q =
+ J A a (\ b p -> (c : A) (q : Id A b c) ->
+        Id (Id A b c) q (compInv A a b c p (comp A a b c p q))) rem b p c q
+ where
+  rem1 : (c : A) (q : Id A a c) ->
+          Id (Id A a c) (comp A a a c (refl A a) q)
+                        (compInv A a a c (refl A a) (comp A a a c (refl A a) q))
+  rem1 c q = compInvIdl' A a c (comp A a a c (refl A a) q)
+
+  rem2 : (c : A) (q : Id A a c) -> Id (Id A a c) q (comp A a a c (refl A a) q)
+  rem2 c q = compInvIdl A a c q
+
+  rem : (c : A) (q : Id A a c) ->
+          Id (Id A a c) q (compInv A a a c (refl A a) (comp A a a c (refl A a) q))
+  rem c q = comp (Id A a c) q
+                        (comp A a a c (refl A a) q)
+                        (compInv A a a c (refl A a) (comp A a a c (refl A a) q))
+                        (rem2 c q)
+                        (rem1 c q)
+
+lemSimpl : (A:U) -> (a b c : A) -> (p : Id A a b) -> (q q' : Id A b c) ->
+   Id (Id A a c) (comp A a b c p q) (comp A a b c p q') -> Id (Id A b c) q q'
+lemSimpl A a b c p q q' h =
+ compDown (Id A b c)
+           q (compInv A a b c p (comp A a b c p q)) q' (compInv A a b c p (comp A a b c p q'))
+           rem rem1 rem2
+ where
+   rem : Id (Id A b c) q (compInv A a b c p (comp A a b c p q))
+   rem = lemInv A a b c p q
+
+   rem1 : Id (Id A b c) q' (compInv A a b c p (comp A a b c p q'))
+   rem1 = lemInv A a b c p q'
+
+   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)
+               (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)
+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
+  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)
+
+    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)
+    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)
+
+
+
+ examples/nIso.cub view
@@ -0,0 +1,153 @@+module nIso where++import univalence++-- an example with N and 1 + N isomorphic++NToOr : N -> or N Unit+NToOr = split+           zero -> inr tt+           suc n -> inl n++OrToN : or N Unit -> N+OrToN = split+            inl n -> suc n+            inr _ -> zero++secNO : (x:N) -> Id N (OrToN (NToOr x)) x+secNO = split+         zero -> refl N zero+         suc n -> refl N (suc n)++retNO : (z:or N Unit) -> Id (or N Unit) (NToOr (OrToN z)) z+retNO = split+         inl n -> refl (or N Unit) (inl n)+         inr y -> lem y+              where lem : (y:Unit) -> Id (or N Unit) (inr tt) (inr y)+                    lem = split+                            tt -> refl (or N Unit) (inr tt)++isoNO : Id U N (or N Unit)+isoNO = isoId N (or N Unit) NToOr OrToN retNO secNO++-- trying to build an example which involves Kan filling for product++vect : U -> N -> U+vect A = split+          zero -> A +          suc n -> and A (vect A n)++pBool : N -> U+pBool = vect Bool++notSN : (x:N) -> pBool x -> pBool x+notSN = split+         zero -> not+         suc n -> split+                    pair b u -> pair (not b) (notSN n u)++sBool : (x:N) -> pBool x+sBool = split+        zero -> true+        suc n -> pair 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)++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' : 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'++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'++appBool : (A : U) -> and A (A -> Bool) -> Bool+appBool A = split+             pair a f -> f a++pred' : or N Unit -> or N Unit+pred' = subst U (\ X -> X -> X) N (or N Unit) isoNO pred++testPred : or N Unit+testPred = pred' (inr tt)++saB' : or N Unit -> Bool+saB' z = appBool (pB' z) (sB' z)++testSN : Bool+testSN = saB' (inr tt)++testSN1 : Bool+testSN1 = saB' (inl zero)++testSN2 : Bool+testSN2 = saB' (inl (suc zero))++testSN3 : Bool+testSN3 = saB' (inl (suc (suc zero)))++add : N -> N -> N+add x = split +         zero -> x+         suc y -> suc (add x y)++-- add' : (or N Unit) -> (or N Unit) -> or N Unit+-- add' = subst U (\ X -> X -> X -> X) N (or N Unit) isoNO add+++-- a property that we can transport++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) +++++-- a property of N++aZero : U -> U+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' : 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'++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'++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'++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'+++testNO : or N Unit+testNO = add' (inl zero) (inl (suc zero))++testNO1 : Id (or N Unit) (add' zero' zero') zero'+testNO1 = propAdd' zero'
+ examples/omega.cub view
@@ -0,0 +1,130 @@+module omega where++import univalence++Omega : U+Omega = Sigma U prop++-- Omega is the -set- of truth values+-- not trivial and needs the following Lemmas++-- 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+ 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)++  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)++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++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+   where+    T : U+    T = Sigma A B ++    L : U+    L = Id T (pair a b) (pair a b)++    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)++    rem2 : C a (refl A a)+    rem2 b0 b1 = cong (B a) T (\ b -> pair a 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+             +    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++    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++    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++    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++-- we should be able to deduce from all this that Omega is a set++isTrue : Omega -> U+isTrue = fst U prop++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++   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 +++omegaIsSet : set Omega+omegaIsSet = rem4+ where+   rem : (A:U) -> prop (prop A)+   rem = propIsProp++   g : (x:Omega) -> prop (isTrue x)+   g = snd U prop++   injf : injective Omega U isTrue+   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 = 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+     where+        h : Id Omega x y -> Id U (isTrue x) (isTrue y)+        h = cong 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+
+ examples/prelude.cub view
@@ -0,0 +1,291 @@+-- some basic data types and functions++module prelude where++import primitive++rel : U -> U+rel A = A -> A -> U++euclidean : (A : U) -> rel A -> U+euclidean A R = (a b c : A) -> R a c -> R b c -> R a b++and : (A B : U) -> U+and A B = Sigma A (\_ -> B)++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+data Unit = tt++N : U+data N = zero | suc (n : N)++Bool : U+data Bool = true | false++andBool : Bool -> Bool -> Bool+andBool = split+  true -> \x -> x+  false -> \x -> false++not : Bool -> Bool+not = split+  true -> false+  false -> true++isEven : N -> Bool+isEven = split+  zero -> true+  suc n -> not (isEven n)++pred : N -> N+pred = split+        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++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++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))++N0 : U+data N0 =++efq : (A : U) -> N0 -> A+efq A = split {}++neg : U -> U+neg A = A -> N0++or : U -> U -> U+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 = + split+  inl a -> f a+  inr b -> g b++dec : U -> U+dec A = or A (neg A)++discrete : U -> U+discrete A = (a b : A) -> dec (Id A a b)++tnotf : neg (Id Bool (true) (false))+tnotf h =+  let+    T : Bool -> U+    T = split+          true  -> N+          false -> N0+  in subst Bool T (true) (false) h (zero)++fnott : neg (Id Bool false true)+fnott h = substInv Bool T false  true h zero+  where+    T : Bool -> U+    T = split+          true  -> N+          false -> N0++boolDec : discrete Bool+boolDec = split+  true -> split+    true -> inl (refl Bool (true))+    false -> inr tnotf+  false -> split+    true -> inr fnott+    false -> inl (refl Bool (false))++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) ++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) ++sId : (A : U) (a : A) -> pathTo A a+sId A a = pair a (refl A 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))++typEquivS : (A B : U) -> (f : A -> B) -> U+typEquivS A B f = (y : B) -> fiber A B f y++typEquivT : (A B : U) -> (f : A -> B) -> (typEquivS A B f) -> U+typEquivT A B f s =  (y : B) -> (v : fiber A B f y) -> Id (fiber A B f y) (s y) v++isEquiv : (A B : U) (f : A -> B) -> U+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++-- not needed if we have eta++etaId : (A:U) (B:A -> U) -> (f:Pi A B) -> Id (Pi A B) (\ x -> f x) f+etaId A B f = funExt A B (\ x -> f x) f (\ x -> refl (B x) (f x))++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++propN0 : prop N0+propN0 a b = efq (Id N0 a b) a++-- a product of propositions is a proposition++isPropProd : (A:U) (B:A->U) (pB : (x:A) -> prop (B x)) -> prop (Pi A B)+isPropProd A B pB f0 f1 = funExt A B f0 f1 (\ x -> pB x (f0 x) (f1 x))++propNeg : (A:U) -> prop (neg A)+propNeg A = isPropProd A (\ _ -> N0) (\ _ -> propN0)++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)+           inr nb -> efq (Id (dec A) (inl a) (inr nb)) (nb a)+ 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)++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)++propUnit : prop Unit+propUnit = split+  tt -> split+     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++decEqCong : (A B : U) (f : A -> B) (g : B -> A) -> dec A -> dec B+decEqCong A B f g = split+  inl a -> inl (f a)+  inr h -> inr (\b -> h (g b))++znots : (n : N) -> neg (Id N (zero) (suc n))+znots n h = subst N T zero (suc n) h zero+  where+    T : N -> U+    T = split+          zero -> N+          suc n -> N0++snotz : (n : N) -> neg (Id N (suc n) zero)+snotz n h = substInv N T (suc n) zero h zero+  where+    T : N -> U+    T = split+          zero -> N+          suc n -> N0++natDec : discrete N+natDec = split+  zero  -> split+    zero -> inl (refl N zero)+    suc m -> inr (znots m)+  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)++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)) ++propImply : (A B : U) -> (A -> prop B) -> prop (A -> B)+propImply A B h = propPi A (\_ -> B) h++propFam : (A : U) (B : A -> U) -> U+propFam A B = (a : A) -> prop (B a)++reflexive : (A : U) -> rel A -> U+reflexive A R = (a : A) -> R a a++symmetry : (A : U) -> rel A -> U+symmetry A R = (a b : A) -> R a b -> R b a++equivalence : (A : U) -> rel A -> U+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++eqToEucl : (A : U) (R : rel A) -> equivalence A R -> euclidean A R+eqToEucl A R = split+  pair _ e -> e++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)++eqToInvEucl : (A : U) (R : rel A) -> equivalence A R ->+              (a b c : A) -> R c a -> R c b -> R a b+eqToInvEucl A R eq a b c p q =+  eqToEucl A R eq a b c (eqToSym A R eq c a p) (eqToSym A R eq c b q)++-- 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+
+ examples/primitive.cub view
@@ -0,0 +1,68 @@+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/quotient.cub view
@@ -0,0 +1,153 @@+module quotient where++import description+import exists+import hedberg++Quot : (A : U) (R : rel A) -> U+data Quot A R =+  class (P : A -> U)+        (un : (a b : A) -> P a -> P b -> R a b)+        (cp : (a b : A) -> P a -> R a b -> P b)+        (ex : exists A P)+        (pr : propFam A P)++propRel : (A : U) (R : rel A) -> U+propRel A R = (a b : A) -> prop (R a b)++canSurj : (A : U) (R : rel A) -> equivalence A R -> propRel A R ->+            A -> Quot A R+canSurj A R h h' c = class (R c) un cp ex pr+  where un : (a b : A) -> R c a -> R c b -> R a b+        un a b p q = eqToInvEucl A R h a b c p q++        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))+        pr : propFam A (R c)+        pr a = h' c a++resp : (A B : U) (R : rel A) (f : A -> B) -> U+resp A B R f = (x y : A) -> R x y -> Id B (f x) (f y)++image : (A B : U) (f : A -> B) (P : A -> U) -> B -> U+image A B f P b = exists A (\a -> and (P a) (Id B (f a) b))++propAnd : (A B : U) -> prop A -> prop B -> prop (and A B)+propAnd A B p q = propSig A F rem (\a a' _ _ -> p a a')+  where F : A -> U+        F a = B+        rem : propFam A F+        rem a = q++-- should also contain the proof that Quot A R is a set and that+-- the equivalence class of two related elements are equal+-- but what we have is enough to test that we can compute with the axiom +-- of description++univQuot : (A B : U) (R : rel A) (f : A -> B) ->+           set B -> resp A B R f -> (eqR : equivalence A R) (pR : propRel A R)+                 (_ : Quot A R) -> B+univQuot A B R f uip fresp eqR pR = g -- pair g rem+  where+    g : Quot A R -> B+    g = split+      class P un cp ex pr -> iota B imfP rem1 rem2+        where+          imfP : B -> U+          imfP = image A B f P+          rem1 : propFam B imfP+          rem1 b = squash (Sigma A (\a -> and (P a) (Id B (f a) b)))+          S : B -> A -> U+          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))))))+          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+                where rem8 : R a a'+                      rem8 = un a a' p p'+                      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'++          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++          rem5 : atmostOne B imfP+          rem5 = rem9++          rem2 : exactOne B imfP+          rem2 = pair rem4 rem5+++kernel : (A B : U) (f : A -> B) -> rel A+kernel A B f a a' = Id B (f a) (f a')++kerRef : (A B : U) (f : A -> B) -> reflexive A (kernel A B f)+kerRef A B f a = refl B (f a)++kerEucl : (A B : U) (f : A -> B) -> euclidean A (kernel A B f)+kerEucl A B f a b c p q = compInv B (f c) (f a) (f b) rem rem1+ where rem : Id B (f c) (f a)+       rem = inv B (f a) (f c) p+       rem1 : Id B (f c) (f b)+       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)+++mod2 : rel N+mod2 = kernel N Bool isEven++propMod2 : propRel N mod2+propMod2 n m = boolIsSet (isEven n) (isEven m)++Z2 : U+Z2 = Quot N mod2++respIsEven : resp N Bool mod2 isEven+respIsEven n m h = h++barIsEven : Z2 -> Bool+barIsEven = univQuot N Bool mod2 isEven boolIsSet respIsEven (kerEquiv N Bool isEven) propMod2+++five : N+five = suc (suc (suc (suc  (suc (zero)))))++eigth : N+eigth = suc (suc (suc five))++fiveBar : Z2+fiveBar = canSurj N mod2 (kerEquiv N Bool isEven) propMod2 five++eigthBar : Z2+eigthBar = canSurj N mod2 (kerEquiv N Bool isEven) propMod2 eigth++test5 : Bool+test5 = barIsEven fiveBar++test8 : Bool+test8 = barIsEven eigthBar++
+ examples/set.cub view
@@ -0,0 +1,54 @@+module set where++import lemId++UIP : U -> U+UIP A = (a b : A) -> prop (Id A a b)++set : U -> U+set = UIP++lem1 : (A :U) -> (a:A) -> (h : (x:A) -> Id A a x) ->+       (x y : A) -> (p : Id A x y) -> Id (Id A a y) (comp A a x y (h x) p) (h y)+lem1 A a h x =+  J A x (\ y p -> Id (Id A a y) (comp A a x y (h x) p) (h y)) rem+ where+   rem : Id (Id A a x) (comp A a x x (h x) (refl A x)) (h x)+   rem = compIdr A a x (h x)++lem2 : (A :U) -> (a:A) -> ((x:A) -> Id A a x) -> UIP A+lem2 A a h x y p q =+ lemSimpl A a x y (h x) p q rem+   where+     remp : Id (Id A a y) (comp A a x y (h x) p) (h y)+     remp = lem1 A a h x y p+     remq : Id (Id A a y) (comp A a x y (h x) q) (h y)+     remq = lem1 A a h x y q+     rem : Id (Id A a y) (comp A a x y (h x) p) (comp A a x y (h x) q)+     rem = compDown (Id A a y) (comp A a x y (h x) p) (h y) (comp A a x y (h x) q) (h y)+               remp remq (refl (Id A a y) (h y))++propUIP : (A:U) -> prop A -> UIP A+propUIP A h a = lem2 A a (h a) a++propIsProp : (A : U) -> prop (prop A)+propIsProp A = lemProp1 (prop A) rem+  where+   rem : prop A -> prop (prop A)+   rem pA = rem3 +    where+      rem1 : UIP A+      rem1 = propUIP A pA++      rem2 : (a0:A) -> (f g : Pi A (Id A a0)) -> Id (Pi A (Id A a0)) f g+      rem2 a0 f g = funExt A (\ a1 -> Id A a0 a1) f g (\ a1 -> rem1 a0 a1 (f a1) (g a1))++      rem3 : (f g : (a0 a1 :A) -> Id A a0 a1) -> Id ((a0 a1:A) -> Id A a0 a1) f g+      rem3 f g = funExt A (\ a0 -> (Pi A (Id A a0))) f g (\ a0 -> rem2 a0 (f a0) (g a0))++lemunit : set Unit+lemunit = propUIP Unit propUnit++test2 : Id (Id Unit tt tt) (refl Unit tt) (refl Unit tt)+test2 = lemunit tt tt (refl Unit tt) (refl Unit tt)+
+ examples/subset.cub view
@@ -0,0 +1,61 @@+module subset where++import univalence++-- a non trivial equivalence: two different ways to represent subsets+-- this is not finished+-- it should provide a non trivial equivalence++subset1 : U -> U+subset1 A = Sigma U (\ X -> X -> A)++subset2 : U -> U+subset2 A = A -> U++-- map in both directions++sub12 : (A:U) -> subset1 A -> subset2 A+sub12 A = split+           pair X f -> fiber X A f++sub21 : (A:U) -> subset2 A -> subset1 A+sub21 A P = pair (Sigma A P) (fst A P)++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+   T : U+   T = Sigma (Sigma A (\ x -> Id A x a)) (\ z -> P (fst A (\ x -> Id A x a) z))++   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)+
+ examples/swap.cub view
@@ -0,0 +1,147 @@+module swap where++import gradLemma++-- the swap function defines an equality++swap : (A B :U) -> and A B -> and B A+swap A B = split+            pair a b -> pair b a++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)++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+ where+  rem : isEquiv (and A B) (and B A) (swap A B)+  rem = gradLemma (and A B) (and B A) (swap A B) (swap B A) (lemSwap B A) (lemSwap A B)++-- a simple test example++incr : and Bool N -> and Bool N+incr = split+     pair b n -> pair b (suc n)++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)++test7 : and N Bool+test7 = incr' (pair (suc zero) true)++-- what happens if we compose eqSwap with itself?++eqSwap2 : (A B : U) -> Id U (and A B) (and A B)+eqSwap2 A B = comp U (and A B) (and B A) (and A B) (eqSwap A B) (eqSwap B A)++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)++test9 : and Bool N+test9 = incr2 (pair 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))++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))+++-- 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+ 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+ where rem : Id (A -> U) B0 B1+       rem = funExt A (\ _ -> U) B0 B1 eB++eqPiTest : Id U (Pi U (\ X -> X -> and X Bool)) (Pi U (\ X -> X -> and Bool X))+eqPiTest = eqPi U (\ X -> X -> and X Bool) (\ X -> X -> and Bool X) rem1+ where rem : (X:U) -> Id U (and X Bool) (and Bool X)+       rem X = eqSwap X Bool++       rem1 : (X:U) -> Id U (X -> and X Bool) (X -> and Bool X)+       rem1 X = eqPi X (\ _ -> and X Bool) (\ _ -> and Bool X) (\ _ -> rem X)++       +transPiTest : ((X:U) -> X -> and X Bool) -> (X:U) -> X -> and Bool X+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++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+ where rem1 : (X:U) -> Id U (and X Bool) (and Bool X)+       rem1 X = eqSwap X Bool++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)))++test15 : Bool+test15 = fst Bool (\ _ -> test13) test14++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+ where rem1 : (X:U) -> Id U (and N Bool) (and Bool N)+       rem1 X = eqSwap N Bool++transSig1Test : (and U (and N Bool)) -> and U (and Bool N)+transSig1Test = transport (and U (and N Bool)) (and U (and Bool N)) eqSig1Test++eqSig2Test : Id U (Sigma N (\ _ -> and N Bool)) (Sigma N (\ _ -> and Bool N))+eqSig2Test = eqSig N (\ _ -> and N Bool) (\ _ -> and Bool N) rem1+ where rem1 : N -> Id U (and N Bool) (and Bool N)+       rem1 n = eqSwap N Bool++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)))++test215 : Bool+test215 = fst Bool (\ _ -> N) test214++--- simple test++eqNN : Id U (and N N) (and N N)+eqNN = eqSwap N N++testNN : and N N+testNN = transport (and N N) (and N N) eqNN (pair 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)+
+ examples/swapDisc.cub view
@@ -0,0 +1,123 @@+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++        ++
+ examples/testInh.cub view
@@ -0,0 +1,55 @@+module testInh where++import set++-- test the inh and squash functions++zz : inh N+zz = inc N zero++eq1 : Id (inh N) zz zz+eq1 = refl (inh N) zz++eq2 : Id (inh N) zz zz+eq2 = squash N zz zz++inhUIP : (A : U) -> set (inh A)+inhUIP A = propUIP (inh A) (squash A)++test : Id (Id (inh N) zz zz) eq1 eq2+test = inhUIP N zz zz eq1 eq2++-- impredicative encoding++inhI : U -> U+inhI A = (X : U) -> prop X -> (A -> X) -> X++incI : (A : U) -> A -> inhI A+incI A a = \X h f -> f a++squashI : (A : U) -> prop (inhI A)+squashI A = propPi U (\X -> prop X -> (A -> X) -> X) rem+  where+  rem1 : (X : U) -> prop X -> prop ((A -> X) -> X)+  rem1 X h = propImply (A -> X) X (\_ -> h)++  rem : (X : U) -> prop (prop X -> (A -> X) -> X)+  rem X =  propImply (prop X) ((A -> X) -> X) (rem1 X)++inhrecI : (A : U) (B : U) (p : prop B) (f : A -> B) (h : inhI A) -> B+inhrecI A B p f h = h B p f++inhUIPI : (A : U) -> UIP (inhI A)+inhUIPI A = propUIP (inhI A) (squashI A)++zzI : inhI N+zzI = incI N zero++eq1I : Id (inhI N) zzI zzI+eq1I = refl (inhI N) zzI++eq2I : Id (inhI N) zzI zzI+eq2I = squashI N zzI zzI++testI : Id (Id (inhI N) zzI zzI) eq1I eq2I+testI = inhUIPI N zzI zzI eq1I eq2I
+ examples/univalence.cub view
@@ -0,0 +1,116 @@+module univalence where++import axChoice++-- now we try to prove univalence+-- the identity is an equivalence++-- the transport of the reflexity is equal to the identity function++transpReflId : (A:U) -> Id (A->A) (id A) (transport A A (refl U A))+transpReflId A = funExt A (\ _ -> A)  (id A) (transport A A (refl U A)) (transportRef A)++-- the transport of any equality proof is an equivalence++transpIsEquiv : (A B:U) -> (p:Id U A B) -> isEquiv A B (transport A B p)+transpIsEquiv A = J U A (\ B p -> isEquiv A B (transport A B p)) rem+ where rem : isEquiv A A (transport A A (refl U A))+       rem = subst (A -> A) (isEquiv A A)  (id A) (transport A A (refl U A)) (transpReflId A) (idIsEquiv A)++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 = 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)++EquivToId : (A B:U) -> Equiv A B -> Id U A B+EquivToId A B = split+                  pair f ef -> isEquivEq A B f ef++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++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))+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+  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++    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++    rem2 : Id (Id U A A) (refl U A)  (EquivToId A A (pair (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+secIdEquiv A B p = inv (Id U A B)  p (EquivToId A B (IdToEquiv A B p)) (rem A B p)+ where +  rem1 : (A:U) -> Id (Id U A A) (refl U A) (EquivToId A A (IdToEquiv A A (refl U A)))+  rem1 A = lem1SecIdEquiv A tA rem3 rem2+       where+         tA : A -> A+         tA = transport A A (refl U A)++         rem2 : isEquiv A A tA+         rem2 = transpIsEquiv A A (refl U A)++         rem3 : Id (A -> A) (id A) tA+         rem3 = transpReflId A++  rem : (A B :U) -> (p : Id U A B) -> Id (Id U A B) p (EquivToId A B (IdToEquiv A B p))+  rem A = J U A (\ B p ->  Id (Id U A B) p (EquivToId A B (IdToEquiv A B p))) (rem1 A)++retIdEquiv : (A B :U) (s : Equiv A B) -> Id (Equiv A B) (IdToEquiv A B (EquivToId A B s)) s+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+            where+              p : Id U A B +              p = isEquivEq A B f ef++              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+                  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++-- and now univalence++univAx : (A B:U) -> isEquiv (Id U A B) (Equiv A B) (IdToEquiv A B)+univAx A B = gradLemma (Id U A B) (Equiv A B) (IdToEquiv A B) (EquivToId A B) (retIdEquiv A B) (secIdEquiv A B)++-- in particular Id U A B and Equiv A B are equal++corUnivAx : (A B : U) -> Id U (Id U A B) (Equiv A B)+corUnivAx A B = isEquivEq (Id U A B) (Equiv A B) (IdToEquiv A B) (univAx A B)++-- a simple application++idPropIsProp : (A B : U) -> prop A -> prop B -> prop (Id U A B)+idPropIsProp A B pA pB = substInv U prop (Id U A B) (Equiv A B) (corUnivAx A B) rem+ where+  rem : prop (Equiv A B)+  rem = sigIsProp (A->B) (isEquiv A B) (propIsEquiv A B) (isPropProd A (\ _ -> B) (\ _ -> pB))+