diff --git a/CTT.hs b/CTT.hs --- a/CTT.hs +++ b/CTT.hs @@ -1,92 +1,252 @@ +{-# LANGUAGE TupleSections #-} module CTT where - +import Control.Applicative import Data.List - -import qualified MTT as A +import Data.Maybe import Pretty -------------------------------------------------------------------------------- -- | Terms -type Binder = String -type Def = (Binder,Ter) -- without type annotations for now +data Loc = Loc { locFile :: String + , locPos :: (Int, Int) } + deriving Eq + type Ident = String +type Label = String +type Binder = (Ident,Loc) -data Ter = Var Binder - | Id Ter Ter Ter | Refl Ter - | Pi Ter Ter | Lam Binder Ter | App Ter Ter - | Where Ter [Def] +noLoc :: String -> Binder +noLoc x = (x, Loc "" (0,0)) + +-- Branch of the form: c x1 .. xn -> e +type Brc = (Label,([Binder],Ter)) + +-- Telescope (x1 : A1) .. (xn : An) +type Tele = [(Binder,Ter)] + +-- Labelled sum: c (x1 : A1) .. (xn : An) +type LblSum = [(Binder,Tele)] + +-- Context gives type values to identifiers +type Ctxt = [(Binder,Val)] + +-- Mutual recursive definitions: (x1 : A1) .. (xn : An) and x1 = e1 .. xn = en +type Decls = [(Binder,Ter,Ter)] +data ODecls = ODecls Decls + | Opaque Binder + | Transp Binder + deriving (Eq,Show) + +declIdents :: Decls -> [Ident] +declIdents decl = [ x | ((x,_),_,_) <- decl] + +declBinders :: Decls -> [Binder] +declBinders decl = [ x | (x,_,_) <- decl] + +declTers :: Decls -> [Ter] +declTers decl = [ d | (_,_,d) <- decl] + +declTele :: Decls -> Tele +declTele decl = [ (x,t) | (x,t,_) <- decl] + +declDefs :: Decls -> [(Binder,Ter)] +declDefs decl = [ (x,d) | (x,_,d) <- decl] + +-- Terms +data Ter = App Ter Ter + | Pi Ter Ter + | Lam Binder Ter + | Sigma Ter Ter + | SPair Ter Ter + | Fst Ter + | Snd Ter + | Where Ter ODecls + | Var Ident | U + -- constructor c Ms + | Con Label [Ter] + -- branches c1 xs1 -> M1,..., cn xsn -> Mn + | Split Loc [Brc] + -- labelled sum c1 A1s,..., cn Ans (assumes terms are constructors) + | Sum Binder LblSum + | PN PN + deriving Eq - | Undef A.Prim +-- Primitive notions +data PN = Id | Refl + -- Inh A is an h-prop stating that A is inhabited. + -- Here we take h-prop A as (Pi x y : A) Id A x y. + | Inh + -- Inc a : Inh A for a:A (A not needed ??) + | Inc + -- Squash a b : Id (Inh A) a b + | Squash + -- InhRec B p phi a : B, + -- p : hprop(B), phi : A -> B, a : Inh A (cf. HoTT-book p.113) + | InhRec - -- constructor c Ms - | Con Ident [Ter] + -- (A B : U) -> Id U A B -> A -> B + -- For TransU we only need the eqproof and the element in A is needed + | TransU - -- branches c1 xs1 -> M1,..., cn xsn -> Mn - | Branch A.Prim [(Ident, ([Binder],Ter))] + -- (A B : U) -> Id U A B -> B -> A + -- For TransU we only need the eqproof and the element in A is needed + | TransInvU - -- labelled sum c1 A1s,..., cn Ans (assumes terms are constructors) - | LSum A.Prim [(Ident, [(Binder,Ter)])] + -- (A : U) -> (a : A) -> Id A a (transport A (refl U A) a) + | TransURef - -- (A B:U) -> Id U A B -> A -> B - -- For TransU we only need the eqproof and the element in A is needed - | TransU Ter Ter + -- (A : U) (a b:A) (p:Id A a b) -> Id (singl A a) (pair a (refl A a)) (pair b p) + | CSingl - -- (A:U) -> (a : A) -> Id A a (transport A (refl U A) a) - -- Argument is a - | TransURef Ter + -- (A B : U) (f : A -> B) (a b : A) -> + -- (p : Id A a b) -> Id B (f a) (f b) + -- TODO: remove? + | MapOnPath - -- The primitive J will have type: - -- J : (A : U) (u : A) (C : (v : A) -> Id A u v -> U) - -- (w : C u (refl A u)) (v : A) (p : Id A u v) -> C v p - | J Ter Ter Ter Ter Ter Ter + -- (A B : U) (f g : A -> B) (a b : A) -> + -- Id (A->B) f g -> Id A a b -> Id B (f a) (g b) + | AppOnPath - -- (A : U) (u : A) (C : (v:A) -> Id A u v -> U) - -- (w : C u (refl A u)) -> - -- Id (C u (refl A u)) w (J A u C w u (refl A u)) - | JEq Ter Ter Ter Ter + -- Ext B f g p : Id (Pi A B) f g, + -- (p : (Pi x:A) Id (Bx) (fx,gx)); A not needed ?? + -- | Ext - -- Ext B f g p : Id (Pi A B) f g, - -- (p : (Pi x:A) Id (Bx) (fx,gx)); A not needed ?? - | Ext Ter Ter Ter Ter + -- Ext B f g p : Id (Pi A B) f g, + -- (p : (Pi x y:A) IdS A (Bx) x y p fx gy) + | HExt - -- Inh A is an h-prop stating that A is inhabited. - -- Here we take h-prop A as (Pi x y : A) Id A x y. - | Inh Ter + -- EquivEq A B f s t where + -- A, B are types, f : A -> B, + -- s : (y : B) -> fiber f y, and + -- t : (y : B) (z : fiber f y) -> Id (fiber f y) (s y) z + -- where fiber f y is Sigma x : A. Id B (f x) z. + | EquivEq + -- (A : U) -> (s : (y : A) -> pathTo A a) -> + -- (t : (y : B) -> (v : pathTo A a) -> Id (path To A a) (s y) v) -> + -- Id (Id U A A) (refl U A) (equivEq A A (id A) s t) + | EquivEqRef - -- Inc a : Inh A for a:A (A not needed ??) - | Inc Ter + -- (A B : U) -> (f : A -> B) (s : (y : B) -> fiber A B f y) -> + -- (t : (y : B) -> (v : fiber A B f y) -> Id (fiber A B f y) (s y) v) -> + -- (a : A) -> Id B (f a) (transport A B (equivEq A B f s t) a) + | TransUEquivEq - -- Squash a b : Id (Inh A) a b - | Squash Ter Ter + -- IdP : (A B :U) -> Id U A B -> A -> B -> U + -- IdP A B p a b is the type of paths connecting a to b over p + | IdP - -- InhRec B p phi a : B, - -- p : hprop(B), phi : A -> B, a : Inh A (cf. HoTT-book p.113) - | InhRec Ter Ter Ter Ter + -- mapOnPathD : (A : U) (F : A -> U) (f : (x : A) -> F x) (a0 a1 : A) (p : Id A a0 a1) -> + -- IdS A F a0 a1 p (f a0) (f a1) + -- IdS : (A:U) (F:A -> U) (a0 a1:A) (p:Id A a0 a1) -> F a0 -> F a1 -> U + -- IdS A F a0 a1 p = IdP (F a0) (F a1) (mapOnPath A U F a0 a1 p) + -- TODO: remove in favor of AppOnPathD? + | MapOnPathD - -- EquivEq A B f s t where - -- A, B are types, f : A -> B, - -- s : (y : B) -> fiber f y, and - -- t : (y : B) (z : fiber f y) -> Id (fiber f y) (s y) z - -- where fiber f y is Sigma x : A. Id B (f x) z. - | EquivEq Ter Ter Ter Ter Ter + -- AppOnPathD : (A : U) (F : A -> U) (f g : (x : A) -> F x) -> Id ((x : A) -> F x) f g -> + -- (a0 a1 : A) (p : Id A a0 a1) -> IdS A F a0 a1 p (f a0) (g a1) + -- | AppOnPathD - -- (A : U) -> (s : (y : A) -> pathTo A a) -> - -- (t : (y : B) -> (v : pathTo A a) -> Id (path To A a) (s y) v) -> - -- Id (Id U A A) (refl U A) (equivEq A A (id A) s t) - | EquivEqRef Ter Ter Ter + -- mapOnPathS : (A:U)(F:A -> U) (C:U) (f: (x:A) -> F x -> C) (a0 a1 : A) (p:Id A a0 a1) + -- (b0:F a0) (b1:F a1) (q : IdS A F a0 a1 p b0 b1) -> Id C (f a0 b0) (f a1 b1) + | MapOnPathS -- TODO: AppOnPathS? - -- (A B : U) -> (f : A -> B) (s : (y : B) -> fiber A B f y) -> - -- (t : (y : B) -> (v : fiber A B f y) -> Id (fiber A B f y) (s y) v) -> - -- (a : A) -> Id B (f a) (transport A B (equivEq A B f s t) a) - | TransUEquivEq Ter Ter Ter Ter Ter Ter - deriving (Eq) + -- S1 : U + | Circle -instance Show Ter where - show = showTer + -- base : S1 + | Base + -- loop : Id S1 base base + | Loop + + -- S1rec : (F : S1 -> U) (b : F base) (l : IdS F base base loop) (x : S1) -> F x + | CircleRec + + -- I : U + | I + + -- I0, I1 : Int + | I0 | I1 + + -- line : Id Int I0 I1 + | Line + + + -- intrec : (F : I -> U) (s : F I0) (e : F I1) + -- (l : IdS Int F I0 I1 line s e) (x : I) -> F x + | IntRec + + -- undefined constant + | Undef Loc + deriving (Eq, Show) + +-- For an expression t, returns (u,ts) where u is no application +-- and t = u t +unApps :: Ter -> (Ter,[Ter]) +unApps = aux [] + where aux :: [Ter] -> Ter -> (Ter,[Ter]) + aux acc (App r s) = aux (s:acc) r + aux acc t = (t,acc) +-- Non tail reccursive version: +-- unApps (App r s) = let (t,ts) = unApps r in (t, ts ++ [s]) +-- unApps t = (t,[]) + +mkApps :: Ter -> [Ter] -> Ter +mkApps (Con l us) vs = Con l (us ++ vs) +mkApps t ts = foldl App t ts + +mkLams :: [String] -> Ter -> Ter +mkLams bs t = foldr Lam t [noLoc b | b <- bs] + +mkWheres :: [ODecls] -> Ter -> Ter +mkWheres [] e = e +mkWheres (d:ds) e = Where (mkWheres ds e) d + +-- Primitive notions +primHandle :: [(Ident,Int,PN)] +primHandle = + [("Id" , 3, Id ), + ("refl" , 2, Refl ), + -- ("funExt" , 5, Ext ), + ("funHExt" , 5, HExt ), + ("inh" , 1, Inh ), + ("inc" , 2, Inc ), + ("squash" , 3, Squash ), + ("inhrec" , 5, InhRec ), + ("equivEq" , 5, EquivEq ), + ("transport" , 4, TransU ), + ("transpInv" , 4, TransInvU ), + ("contrSingl" , 4, CSingl ), + ("transportRef" , 2, TransURef ), + ("equivEqRef" , 3, EquivEqRef ), + ("transpEquivEq" , 6, TransUEquivEq), + ("appOnPath" , 8, AppOnPath ), + ("mapOnPath" , 6, MapOnPath ), + ("IdP" , 5, IdP ), + ("mapOnPathD" , 6, MapOnPathD ), + ("mapOnPathS" , 10, MapOnPathS ), + ("S1" , 0, Circle ), + ("base" , 0, Base ), + ("loop" , 0, Loop ), + ("S1rec" , 4, CircleRec ), + ("I" , 0, I ), + ("I0" , 0, I0 ), + ("I1" , 0, I1 ), + ("line" , 0, Line ), + ("intrec" , 5, IntRec )] + +reservedNames :: [String] +reservedNames = [ s | (s,_,_) <- primHandle ] + +arity :: PN -> Int +arity pn = fromMaybe 0 $ listToMaybe [n | (_,n,pn') <- primHandle, pn == pn'] + +mkPN :: String -> Maybe PN +mkPN s = listToMaybe [pn | (s',_,pn) <- primHandle, s == s'] + -------------------------------------------------------------------------------- -- | Names, dimension, and nominal type class @@ -94,7 +254,7 @@ type Dim = [Name] gensym :: Dim -> Name -gensym [] = 0 +gensym [] = 2 gensym xs = maximum xs + 1 gensyms :: Dim -> [Name] @@ -107,6 +267,9 @@ fresh :: Nominal a => a -> Name fresh = gensym . support +freshs :: Nominal a => a -> [Name] +freshs = gensyms . support + instance (Nominal a, Nominal b) => Nominal (a, b) where support (a, b) = support a `union` support b swap (a, b) x y = (swap a x y, swap b x y) @@ -115,31 +278,36 @@ support vs = unions (map support vs) swap vs x y = [swap v x y | v <- vs] -swapName :: Name -> Name -> Name -> Name -swapName z x y | z == x = y - | z == y = x - | otherwise = z - -- Make Name an instance of Nominal instance Nominal Integer where + support 0 = [] + support 1 = [] support n = [n] - swap = swapName + swap z x y | z == x = y + | z == y = x + | otherwise = z + -------------------------------------------------------------------------------- -- | Boxes -data Dir = Up | Down - deriving (Eq, Show) +-- TODO: abstract the type of Intervals instead of exposing the encoding +type Dir = Integer mirror :: Dir -> Dir -mirror Up = Down -mirror Down = Up +mirror 0 = 1 +mirror 1 = 0 +mirror n = error $ "mirror: 0 or 1 expected but " ++ show n ++ " given" +up, down :: Dir +up = 1 +down = 0 + type Side = (Name,Dir) allDirs :: [Name] -> [Side] allDirs [] = [] -allDirs (n:ns) = (n,Down) : (n,Up) : allDirs ns +allDirs (n:ns) = (n,down) : (n,up) : allDirs ns data Box a = Box { dir :: Dir , pname :: Name @@ -150,13 +318,25 @@ instance Show a => Show (Box a) where show (Box dir n f xs) = "Box" <+> show dir <+> show n <+> show f <+> show xs --- Showing boxes with parenthesis around -showBox :: Show a => Box a -> String -showBox = parens . show - mapBox :: (a -> b) -> Box a -> Box b mapBox f (Box d n x xs) = Box d n (f x) [ (nnd,f v) | (nnd,v) <- xs ] +sequenceSnd :: Monad m => [(a,m b)] -> m [(a,b)] +sequenceSnd [] = return [] +sequenceSnd ((a,b):abs) = do + b' <- b + acs <- sequenceSnd abs + return $ (a,b') : acs + +sequenceBox :: Monad m => Box (m a) -> m (Box a) +sequenceBox (Box d n x xs) = do + x' <- x + xs' <- sequenceSnd xs + return $ Box d n x' xs' + +mapBoxM :: Monad m => (a -> m b) -> Box a -> m (Box b) +mapBoxM f = sequenceBox . mapBox f + instance Functor Box where fmap = mapBox @@ -180,6 +360,9 @@ modBox f (Box dir x v nvs) = Box dir x (f (x,mirror dir) v) [ (nd,f nd v) | (nd,v) <- nvs ] +modBoxM :: Monad m => (Side -> a -> m b) -> Box a -> m (Box b) +modBoxM f = sequenceBox . modBox f + -- Restricts the non-principal faces to np. subBox :: [Name] -> Box a -> Box a subBox np (Box dir x v nvs) = @@ -191,7 +374,7 @@ -- fst is down, snd is up consBox :: (Name,(a,a)) -> Box a -> Box a consBox (n,(v0,v1)) (Box dir x v nvs) = - Box dir x v $ ((n,Down),v0) : ((n,Up),v1) : nvs + Box dir x v $ ((n,down),v0) : ((n,up),v1) : nvs appendBox :: [(Name,(a,a))] -> Box a -> Box a appendBox xs b = foldr consBox b xs @@ -205,21 +388,11 @@ Box dir x v [ (nnd,head vs) | (nnd,vs) <- nvss ] : transposeBox (Box dir x vs [ (nnd,tail vs) | (nnd,vs) <- nvss ]) - -supportBox :: Nominal a => Box a -> [Name] -supportBox (Box dir n v vns) = [n] `union` support v `union` - unions [ [y] `union` support v | ((y,dir'),v) <- vns ] - --- Swap for boxes -swapBox :: Nominal a => Box a -> Name -> Name -> Box a -swapBox (Box dir z v nvs) x y = - let sw u = swap u x y - in Box dir (swap z x y) (sw v) - [ ((swap n x y,nd),sw v) | ((n,nd),v) <- nvs ] - +-- Nominal for boxes instance Nominal a => Nominal (Box a) where - swap = swapBox - support = supportBox + support (Box dir n v nvs) = support ((n, v), nvs) + swap (Box dir z v nvs) x y = Box dir z' v' nvs' where + ((z',v'), nvs') = swap ((z, v), nvs) x y -------------------------------------------------------------------------------- -- | Values @@ -228,51 +401,97 @@ deriving (Show, Eq) data Val = VU - | Ter Ter Env + | Ter Ter OEnv | VPi Val Val | VId Val Val Val - -- tag values which are paths + | VSigma Val Val + | VSPair Val Val + + -- tag values which are paths | Path Name Val - | VExt Name Val Val Val Val - -- inhabited + -- | VExt Name Val Val Val Val + | VHExt Name Val Val Val Val + + -- inhabited | VInh Val - -- inclusion into inhabited + -- inclusion into inhabited | VInc Val - -- squash type - connects the two values along the name + -- squash type - connects the two values along the name | VSquash Name Val Val | VCon Ident [Val] | Kan KanType Val (Box Val) - -- of type U connecting a and b along x - -- VEquivEq x a b f s t + -- of type U connecting a and b along x + -- VEquivEq x a b f s t | VEquivEq Name Val Val Val Val Val - -- names x, y and values a, s, t + -- names x, y and values a, s, t | VEquivSquare Name Name Val Val Val - -- of type VEquivEq + -- of type VEquivEq | VPair Name Val Val - -- of type VEquivSquare + -- of type VEquivSquare | VSquare Name Name Val - -- a value of type Kan Com VU (Box (type of values)) + -- a value of type Kan Com VU (Box (type of values)) | VComp (Box Val) - -- a value of type Kan Fill VU (Box (type of values minus name)) - -- the name is bound + -- a value of type Kan Fill VU (Box (type of values minus name)) + -- the name is bound | VFill Name (Box Val) + + -- circle + | VCircle + | VBase + | VLoop Name -- has type VCircle and connects base along the name + + -- interval + | VI + | VI0 + | VI1 + | VLine Name -- connects start and end point along name + + -- neutral values + | VApp Val Val -- the first Val must be neutral + | VAppName Val Name + | VSplit Val Val -- the second Val must be neutral + | VVar String Dim + | VInhRec Val Val Val Val -- the last Val must be neutral + | VCircleRec Val Val Val Val -- the last Val must be neutral + | VIntRec Val Val Val Val Val -- the last Val must be neutral + | VFillN Val (Box Val) + | VComN Val (Box Val) + | VFst Val + | VSnd Val deriving Eq -instance Show Val where - show = showVal +vepair :: Name -> Val -> Val -> Val +vepair x a b = VSPair a (Path x b) +mkVar :: Int -> Dim -> Val +mkVar k = VVar ('X' : show k) + +isNeutral :: Val -> Bool +isNeutral (VApp u _) = isNeutral u +isNeutral (VAppName u _) = isNeutral u +isNeutral (VSplit _ v) = isNeutral v +isNeutral (VVar _ _) = True +isNeutral (VInhRec _ _ _ v) = isNeutral v +isNeutral (VCircleRec _ _ _ v) = isNeutral v +isNeutral (VIntRec _ _ _ _ v) = isNeutral v +isNeutral (VFillN _ _) = True +isNeutral (VComN _ _) = True +isNeutral (VFst v) = isNeutral v +isNeutral (VSnd v) = isNeutral v +isNeutral _ = False + fstVal, sndVal, unSquare :: Val -> Val fstVal (VPair _ a _) = a fstVal x = error $ "error fstVal: " ++ show x @@ -300,15 +519,38 @@ support (VInc v) = support v support (VPi v1 v2) = support [v1,v2] support (VCon _ vs) = support vs - support (VSquash x v0 v1) = [x] `union` support [v0,v1] - support (VExt x b f g p) = [x] `union` support [b,f,g,p] - support (Kan Fill a box) = support a `union` support box - support (Kan Com a box@(Box _ n _ _)) = - delete n (support a `union` support box) - support (VEquivEq x a b f s t) = [x] `union` support [a,b,f,s,t] - support (VPair x a v) = [x] `union` support [a,v] - support (VComp box@(Box _ n _ _)) = delete n $ support box - support (VFill x box) = delete x $ support box + support (VSquash x v0 v1) = support (x, [v0,v1]) + -- support (VExt x b f g p) = support (x, [b,f,g,p]) + support (VHExt x b f g p) = support (x, [b,f,g,p]) + support (Kan Fill a box) = support (a, box) + support (VFillN a box) = support (a, box) + support (VComN a box@(Box _ n _ _)) = delete n (support (a, box)) + support (Kan Com a box@(Box _ n _ _)) = delete n (support (a, box)) + support (VEquivEq x a b f s t) = support (x, [a,b,f,s,t]) + -- names x, y and values a, s, t + support (VEquivSquare x y a s t) = support ((x,y), [a,s,t]) + support (VPair x a v) = support (x, [a,v]) + support (VComp box@(Box _ n _ _)) = delete n $ support box + support (VFill x box) = delete x $ support box + support (VApp u v) = support (u, v) + support (VAppName u n) = support (u, n) + support (VSplit u v) = support (u, v) + support (VVar x d) = support d + support (VSigma u v) = support (u,v) + support (VSPair u v) = support (u,v) + support (VFst u) = support u + support (VSnd u) = support u + support (VInhRec b p h a) = support [b,p,h,a] + support VCircle = [] + support VBase = [] + support (VLoop n) = [n] + support (VCircleRec f b l s) = support [f,b,l,s] + support VI = [] + support VI0 = [] + support VI1 = [] + support (VLine n) = [n] + support (VIntRec f s e l u) = support [f,s,e,l,u] + support v = error ("support " ++ show v) swap u x y = let sw u = swap u x y in case u of @@ -316,10 +558,11 @@ Ter t e -> Ter t (swap e x y) VId a v0 v1 -> VId (sw a) (sw v0) (sw v1) Path z v | z /= x && z /= y -> Path z (sw v) - | otherwise -> let z' = gensym ([x] `union` [y] `union` support v) + | otherwise -> let z' = fresh ([x, y], v) v' = swap v z z' in Path z' (sw v') - VExt z b f g p -> VExt (swap z x y) (sw b) (sw f) (sw g) (sw p) + -- VExt z b f g p -> VExt (swap z x y) (sw b) (sw f) (sw g) (sw p) + VHExt z b f g p -> VHExt (swap z x y) (sw b) (sw f) (sw g) (sw p) VPi a f -> VPi (sw a) (sw f) VInh v -> VInh (sw v) VInc v -> VInc (sw v) @@ -332,21 +575,46 @@ VEquivSquare (swap z x y) (swap w x y) (sw a) (sw s) (sw t) VSquare z w v -> VSquare (swap z x y) (swap w x y) (sw v) Kan Fill a b -> Kan Fill (sw a) (swap b x y) + VFillN a b -> VFillN (sw a) (swap b x y) Kan Com a b@(Box _ z _ _) | z /= x && z /= y -> Kan Com (sw a) (swap b x y) - | otherwise -> let z' = gensym ([x] `union` [y] `union` support u) + | otherwise -> let z' = fresh ([x, y], u) a' = swap a z z' in sw (Kan Com a' (swap b z z')) + VComN a b@(Box _ z _ _) + | z /= x && z /= y -> VComN (sw a) (swap b x y) + | otherwise -> let z' = fresh ([x, y], u) + a' = swap a z z' + in sw (VComN a' (swap b z z')) VComp b@(Box _ z _ _) | z /= x && z /= y -> VComp (swap b x y) - | otherwise -> let z' = gensym ([x] `union` [y] `union` support u) + | otherwise -> let z' = fresh ([x, y], u) in sw (VComp (swap b z z')) VFill z b@(Box dir n _ _) - | z /= x && z /= x -> VFill z (swap b x y) + | z /= x && z /= y -> VFill z (swap b x y) | otherwise -> let - z' = gensym ([x] `union` [y] `union` support b) + z' = fresh ([x, y], b) in sw (VFill z' (swap b z z')) + VApp u v -> VApp (sw u) (sw v) + VAppName u n -> VAppName (sw u) (swap n x y) + VSplit u v -> VSplit (sw u) (sw v) + VVar s d -> VVar s (swap d x y) + VSigma u v -> VSigma (sw u) (sw v) + VSPair u v -> VSPair (sw u) (sw v) + VFst u -> VFst (sw u) + VSnd u -> VSnd (sw u) + VInhRec b p h a -> VInhRec (sw b) (sw p) (sw h) (sw a) + VCircle -> VCircle + VBase -> VBase + VLoop z -> VLoop (swap z x y) + VCircleRec f b l a -> VCircleRec (sw f) (sw b) (sw l) (sw a) + VI -> VI + VI0 -> VI0 + VI1 -> VI1 + VLine z -> VLine (swap z x y) + VIntRec f s e l u -> VIntRec (sw f) (sw s) (sw e) (sw l) (sw u) + -------------------------------------------------------------------------------- -- | Environments @@ -356,104 +624,185 @@ deriving Eq instance Show Env where - show = showEnv + show Empty = "" + show (PDef xas env) = show env + show (Pair env (x,u)) = parens $ showEnv1 env ++ show u + where + showEnv1 (Pair env (x,u)) = showEnv1 env ++ show u ++ ", " + showEnv1 e = show e -showEnv :: Env -> String -showEnv Empty = "" -showEnv (Pair env (x,u)) = parens $ showEnv1 env ++ show u -showEnv (PDef xas env) = showEnv env +instance Nominal Env where + swap e x y = mapEnv (\u -> swap u x y) e -showEnv1 :: Env -> String -showEnv1 Empty = "" -showEnv1 (Pair env (x,u)) = showEnv1 env ++ show u ++ ", " -showEnv1 (PDef xas env) = show env + support Empty = [] + support (Pair e (_,v)) = support (e, v) + support (PDef _ e) = support e -supportEnv :: Env -> [Name] -supportEnv Empty = [] -supportEnv (Pair e (_,v)) = supportEnv e `union` support v -supportEnv (PDef _ e) = supportEnv e +data OEnv = OEnv { env :: Env, + opaques :: [Binder] } + deriving Eq -instance Nominal Env where - swap e x y = mapEnv (\u -> swap u x y) e - support = supportEnv +oEmpty :: OEnv +oEmpty = OEnv Empty [] -upds :: Env -> [(Binder,Val)] -> Env -upds = foldl Pair +oPair :: OEnv -> (Binder,Val) -> OEnv +oPair (OEnv e o) u = OEnv (Pair e u) o +oPDef :: Bool -> ODecls -> OEnv -> OEnv +oPDef _ (ODecls decls) (OEnv e o) = OEnv (PDef [(x,d) | (x,_,d) <- decls] e) o +oPDef True (Opaque d) (OEnv e o) = OEnv e (d:o) +oPDef True (Transp d) (OEnv e o) = OEnv e (d `delete` o) +oPDef _ _ e = e + +instance Show OEnv where + show (OEnv e s) = show e -- <+> parens ("with opaque:" <+> ccat s) + +instance Nominal OEnv where + swap (OEnv e s) x y = OEnv (swap e x y) s + support (OEnv e s) = support e + +upds :: OEnv -> [(Binder,Val)] -> OEnv +upds = foldl oPair + +lookupIdent :: Ident -> [(Binder,a)] -> Maybe (Binder, a) +lookupIdent x defs = lookup x [(y,((y,l),t)) | ((y,l),t) <- defs] + +getIdent :: Ident -> [(Binder,a)] -> Maybe a +getIdent x defs = do (_,t) <- lookupIdent x defs; return t + +getBinder :: Ident -> [(Binder,a)] -> Maybe Binder +getBinder x defs = do (b,_) <- lookupIdent x defs; return b + mapEnv :: (Val -> Val) -> Env -> Env mapEnv _ Empty = Empty mapEnv f (Pair e (x,v)) = Pair (mapEnv f e) (x,f v) mapEnv f (PDef ts e) = PDef ts (mapEnv f e) +mapEnvM :: Applicative m => (Val -> m Val) -> Env -> m Env +mapEnvM _ Empty = pure Empty +mapEnvM f (Pair e (x,v)) = Pair <$> mapEnvM f e <*> ( (x,) <$> f v) +mapEnvM f (PDef ts e) = PDef ts <$> mapEnvM f e +mapOEnv :: (Val -> Val) -> OEnv -> OEnv +mapOEnv f (OEnv e o) = OEnv (mapEnv f e) o + +mapOEnvM :: Applicative m => (Val -> m Val) -> OEnv -> m OEnv +mapOEnvM f (OEnv e o) = flip OEnv o <$> mapEnvM f e + +valOfEnv :: Env -> [Val] +valOfEnv Empty = [] +valOfEnv (Pair env (_,v)) = v : valOfEnv env +valOfEnv (PDef _ env) = valOfEnv env + +valOfOEnv :: OEnv -> [Val] +valOfOEnv (OEnv e o) = valOfEnv e + -------------------------------------------------------------------------------- -- | Pretty printing -showTer :: Ter -> String -showTer U = "U" -showTer (Var x) = x -showTer (App e0 e1) = showTer e0 <+> showTer1 e1 -showTer (Pi e0 e1) = "Pi" <+> showTers [e0,e1] -showTer (Lam x e) = "\\" ++ x <+> "->" <+> showTer e -showTer (LSum (_,str) _) = str -showTer (Branch (n,str) _) = str ++ show n -showTer (Undef (n,str)) = str ++ show n -showTer (Con ident ts) = ident <+> showTers ts -showTer (Id a t s) = "Id" <+> showTers [a,t,s] -showTer (TransU t s) = "transport" <+> showTers [t,s] -showTer (TransURef t) = "transportRef" <+> showTer t -showTer (Refl t) = "refl" <+> showTer t -showTer (J a b c d e f) = "J" <+> showTers [a,b,c,d,e,f] -showTer (JEq a b c d) = "Jeq" <+> showTers [a,b,c,d] -showTer (Ext b f g p) = "funExt" <+> showTers [b,f,g,p] -showTer (Inh t) = "inh" <+> showTer t -showTer (Inc t) = "inc" <+> showTer t -showTer (Squash a b) = "squash" <+> showTers [a,b] -showTer (InhRec a b c d) = "inhrec" <+> showTers [a,b,c,d] -showTer (EquivEq a b c d e) = "equivEq" <+> showTers [a,b,c,d,e] -showTer (EquivEqRef a b c) = "equivEqRef" <+> showTers [a,b,c] -showTer (TransUEquivEq a b c d e f) = "transpEquivEq" <+> showTers [a,b,c,d,e,f] -showTer (Where t defs) = showTer t <+> "where" <+> showDefs defs +instance Show Loc where + show (Loc name (i,j)) = name ++ "_L" ++ show i ++ "_C" ++ show j -showDef :: Def -> String -showDef (x,t) = x <+> "=" <+> showTer t +instance Show Ter where + show = showTer -showDefs :: [Def] -> String -showDefs = ccat . map showDef +showTer :: Ter -> String +showTer U = "U" +showTer (App e0 e1) = showTer e0 <+> showTer1 e1 +showTer (Pi e0 e1) = "Pi" <+> showTers [e0,e1] +showTer (Lam (x,_) e) = '\\' : x <+> "->" <+> showTer e +showTer (Fst e) = showTer e ++ ".1" +showTer (Snd e) = showTer e ++ ".2" +showTer (Sigma e0 e1) = "Sigma" <+> showTers [e0,e1] +showTer (SPair e0 e1) = "pair" <+> showTers [e0,e1] +showTer (Where e d) = showTer e <+> "where" <+> showODecls d +showTer (Var x) = x +showTer (Con c es) = c <+> showTers es +showTer (Split l _) = "split " ++ show l +showTer (Sum l _) = "sum " ++ show l +showTer (PN pn) = showPN pn showTers :: [Ter] -> String showTers = hcat . map showTer1 showTer1 :: Ter -> String -showTer1 U = "U" -showTer1 (Con c []) = c -showTer1 (Var x) = x -showTer1 u = parens $ showTer u +showTer1 U = "U" +showTer1 (Con c []) = c +showTer1 (Var x) = x +showTer1 u@(Split{}) = showTer u +showTer1 u@(Sum{}) = showTer u +showTer1 u@(PN{}) = showTer u +showTer1 u = parens $ showTer u +-- Warning: do not use showPN as a Show instance as it will loop +showPN :: PN -> String +showPN (Undef l) = show l +showPN pn = case [s | (s,_,pn') <- primHandle, pn == pn'] of + [s] -> s + _ -> error $ "showPN: unknown primitive " ++ show pn + +showDecls :: Decls -> String +showDecls defs = ccat (map (\((x,_),_,d) -> x <+> "=" <+> show d) defs) + +showODecls :: ODecls -> String +showODecls (ODecls defs) = showDecls defs +showODecls (Opaque x) = "opaque" <+> show x +showODecls (Transp x) = "transparent" <+> show x + +instance Show Val where + show = showVal + showVal :: Val -> String showVal VU = "U" -showVal (Ter t env) = showTer t <+> show env +showVal (Ter t env) = show t <+> show env showVal (VId a u v) = "Id" <+> showVal1 a <+> showVal1 u <+> showVal1 v showVal (Path n u) = abrack (show n) <+> showVal u -showVal (VExt n b f g p) = "funExt" <+> show n <+> showVals [b,f,g,p] +-- showVal (VExt n b f g p) = "funExt" <+> show n <+> showVals [b,f,g,p] +showVal (VHExt n b f g p) = "funHExt" <+> show n <+> showVals [b,f,g,p] showVal (VCon c us) = c <+> showVals us showVal (VPi a f) = "Pi" <+> showVals [a,f] showVal (VInh u) = "inh" <+> showVal1 u showVal (VInc u) = "inc" <+> showVal1 u +showVal (VInhRec b p h a) = "inhrec" <+> showVals [b,p,h,a] showVal (VSquash n u v) = "squash" <+> show n <+> showVals [u,v] -showVal (Kan typ v box) = "Kan" <+> show typ <+> showVal1 v <+> showBox box +showVal (Kan Fill v box) = "Fill" <+> showVal1 v <+> parens (show box) +showVal (Kan Com v box) = "Com" <+> showVal1 v <+> parens (show box) +showVal (VFillN v box) = "FillN" <+> showVal1 v <+> parens (show box) +showVal (VComN v box) = "ComN" <+> showVal1 v <+> parens (show box) showVal (VPair n u v) = "vpair" <+> show n <+> showVals [u,v] showVal (VSquare x y u) = "vsquare" <+> show x <+> show y <+> showVal1 u -showVal (VComp box) = "vcomp" <+> showBox box -showVal (VFill n box) = "vfill" <+> show n <+> showBox box -showVal (VEquivEq n a b f s t) = "equivEq" <+> show n <+> showVals [a,b,f,s,t] +showVal (VComp box) = "vcomp" <+> parens (show box) +showVal (VFill n box) = "vfill" <+> show n <+> parens (show box) +showVal (VApp u v) = showVal u <+> showVal1 v +showVal (VAppName u n) = showVal u <+> "@" <+> show n +showVal (VSplit u v) = showVal u <+> showVal1 v +showVal (VVar x d) = x <+> showDim d +showVal (VEquivEq n a b f _ _) = "equivEq" <+> show n <+> showVals [a,b,f] showVal (VEquivSquare x y a s t) = "equivSquare" <+> show x <+> show y <+> showVals [a,s,t] +showVal (VSPair u v) = "pair" <+> showVals [u,v] +showVal (VSigma u v) = "Sigma" <+> showVals [u,v] +showVal (VFst u) = showVal u ++ ".1" +showVal (VSnd u) = showVal u ++ ".2" +showVal VCircle = "S1" +showVal VBase = "base" +showVal (VLoop x) = "loop" <+> show x +showVal (VCircleRec f b l s) = "S1rec" <+> showVals [f,b,l,s] +showVal VI = "I" +showVal VI0 = "I0" +showVal VI1 = "I1" +showVal (VLine n) = "line" <+> show n +showVal (VIntRec f s e l u) = "intrec" <+> showVals [f,s,e,l,u] +showDim :: Show a => [a] -> String +showDim = parens . ccat . map show + showVals :: [Val] -> String showVals = hcat . map showVal1 showVal1 :: Val -> String -showVal1 VU = "U" -showVal1 (VCon c []) = c -showVal1 u = parens $ showVal u +showVal1 VU = "U" +showVal1 (VCon c []) = c +showVal1 u@(VVar{}) = showVal u +showVal1 u = parens $ showVal u + diff --git a/Concrete.hs b/Concrete.hs --- a/Concrete.hs +++ b/Concrete.hs @@ -1,201 +1,258 @@ -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections, ParallelListComp #-} --- Convert the concrete syntax into the syntax of miniTT. +-- | Convert the concrete syntax into the syntax of cubical TT. module Concrete where import Exp.Abs -import qualified MTT as A +import qualified CTT as C +import Pretty -import Control.Arrow (first) import Control.Applicative import Control.Monad.Trans -import Control.Monad.Trans.State import Control.Monad.Trans.Reader import Control.Monad.Trans.Error hiding (throwError) import Control.Monad.Error (throwError) import Control.Monad (when) import Data.Functor.Identity -import Data.List (union) +import Data.List (nub) -type Tele = [VDecl] +type Tele = [(AIdent,Exp)] +type Ter = C.Ter -- | Useful auxiliary functions -unions :: Eq a => [[a]] -> [a] -unions = foldr union [] -- Applicative cons (<:>) :: Applicative f => f a -> f [a] -> f [a] a <:> b = (:) <$> a <*> b -- un-something functions -unIdent :: AIdent -> String -unIdent (AIdent (_,n)) = n - -unArg :: Arg -> String -unArg (Arg n) = unIdent n -unArg NoArg = "_" - -unArgs :: [Arg] -> [String] -unArgs = map unArg - -unBinder :: Binder -> Arg -unBinder (Binder b) = b - -unArgBinder :: Binder -> String -unArgBinder = unArg . unBinder +unAIdent :: AIdent -> C.Ident +unAIdent (AIdent (_,x)) = x -unArgsBinder :: [Binder] -> [String] -unArgsBinder = map unArgBinder +unVar :: Exp -> Maybe AIdent +unVar (Var x) = Just x +unVar _ = Nothing unWhere :: ExpWhere -> Exp unWhere (Where e ds) = Let ds e unWhere (NoWhere e) = e --- Flatten a telescope, e.g., flatten (a b : A) (c : C) into --- (a : A) (b : A) (c : C). -flattenTele :: Tele -> [VDecl] -flattenTele = concatMap (\(VDecl bs e) -> [VDecl [b] e | b <- bs]) - --- Note: It is important to only apply unApps to e1 as otherwise the --- structure of the application will be destroyed which leads to trouble --- for constructor disambiguation! -unApps :: Exp -> [Exp] -unApps (App e1 e2) = unApps e1 ++ [e2] -unApps e = [e] - -unVar :: Exp -> Arg -unVar (Var b) = b -unVar e = error $ "unVar bad input: " ++ show e - -unVarBinder :: Exp -> String -unVarBinder = unArg . unVar +-- tail recursive form to transform a sequence of applications +-- App (App (App u v) ...) w into (u, [v, …, w]) +-- (cleaner than the previous version of unApps) +unApps :: Exp -> [Exp] -> (Exp, [Exp]) +unApps (App u v) ws = unApps u (v : ws) +unApps u ws = (u, ws) -unPiDecl :: PiDecl -> VDecl -unPiDecl (PiDecl e t) = VDecl (map (Binder . unVar) (unApps e)) t +vTele :: [VTDecl] -> Tele +vTele decls = [ (i, typ) | VTDecl id ids typ <- decls, i <- id:ids ] -flattenTelePi :: [PiDecl] -> [VDecl] -flattenTelePi = flattenTele . map unPiDecl +-- turns an expression of the form App (... (App id1 id2) ... idn) +-- into a list of idents +pseudoIdents :: Exp -> Maybe [AIdent] +pseudoIdents = mapM unVar . uncurry (:) . flip unApps [] -namesTele :: Tele -> [String] -namesTele vs = unions [ unArgsBinder args | VDecl args _ <- vs ] +pseudoTele :: [PseudoTDecl] -> Maybe Tele +pseudoTele [] = return [] +pseudoTele (PseudoTDecl exp typ : pd) = do + ids <- pseudoIdents exp + pt <- pseudoTele pd + return $ map (,typ) ids ++ pt ------------------------------------------------------------------------------- -- | Resolver and environment +data SymKind = Variable | Constructor + deriving (Eq,Show) + -- local environment for constructors -data Env = Env { constrs :: [String] } - deriving (Eq, Show) +data Env = Env { envModule :: String, + variables :: [(C.Binder,SymKind)] } + deriving (Eq, Show) -type Resolver a = ReaderT Env (StateT A.Prim (ErrorT String Identity)) a +type Resolver a = ReaderT Env (ErrorT String Identity) a emptyEnv :: Env -emptyEnv = Env [] +emptyEnv = Env "" [] runResolver :: Resolver a -> Either String a -runResolver x = runIdentity $ runErrorT $ evalStateT (runReaderT x emptyEnv) (0,"") +runResolver x = runIdentity $ runErrorT $ runReaderT x emptyEnv -insertConstrs :: [String] -> Env -> Env -insertConstrs cs (Env cs') = Env $ cs ++ cs' +updateModule :: String -> Env -> Env +updateModule mod e = e {envModule = mod} -getEnv :: Resolver Env -getEnv = ask +insertBinder :: (C.Binder,SymKind) -> Env -> Env +insertBinder (x@(n,_),var) e + | n == "_" || n == "undefined" = e + | otherwise = e {variables = (x, var) : variables e} -getConstrs :: Resolver [String] -getConstrs = constrs <$> getEnv +insertBinders :: [(C.Binder,SymKind)] -> Env -> Env +insertBinders = flip $ foldr insertBinder -genPrim :: Resolver A.Prim -genPrim = do - prim <- lift get - lift (modify (first succ)) - return prim +insertVar :: C.Binder -> Env -> Env +insertVar x = insertBinder (x,Variable) -updateName :: String -> Resolver () -updateName str = lift $ modify (\(g,_) -> (g,str)) +insertVars :: [C.Binder] -> Env -> Env +insertVars = flip $ foldr insertVar -lam :: Arg -> Resolver A.Exp -> Resolver A.Exp -lam a e = A.Lam (unArg a) <$> e +insertCon :: C.Binder -> Env -> Env +insertCon x = insertBinder (x,Constructor) -lams :: [Arg] -> Resolver A.Exp -> Resolver A.Exp -lams as e = foldr lam e as +insertCons :: [C.Binder] -> Env -> Env +insertCons = flip $ foldr insertCon -resolveExp :: Exp -> Resolver A.Exp -resolveExp U = return A.U -resolveExp Undef = A.Undef <$> genPrim -resolveExp PN = A.Undef <$> genPrim -resolveExp e@(App t s) = do - let x:xs = unApps e - cs <- getConstrs - if unVarBinder x `elem` cs - then A.Con (unVarBinder x) <$> mapM resolveExp xs - else A.App <$> resolveExp t <*> resolveExp s -resolveExp (Pi tele b) = resolveTelePi (flattenTelePi tele) (resolveExp b) -resolveExp (Fun a b) = A.Pi <$> resolveExp a <*> lam NoArg (resolveExp b) -resolveExp (Lam bs t) = lams (map unBinder bs) (resolveExp t) -resolveExp (Split brs) = A.Fun <$> genPrim <*> mapM resolveBranch brs -resolveExp (Let defs e) = A.lets <$> resolveDefs defs <*> resolveExp e -resolveExp (Var n) = do - let x = unArg n - when (x == "_") (throwError "_ not a valid variable name") - Env cs <- getEnv - return (if x `elem` cs then A.Con x [] else A.Var x) +getModule :: Resolver String +getModule = envModule <$> ask -resolveWhere :: ExpWhere -> Resolver A.Exp -resolveWhere = resolveExp . unWhere +getVariables :: Resolver [(C.Binder,SymKind)] +getVariables = variables <$> ask -resolveBranch :: Branch -> Resolver (String,([String],A.Exp)) -resolveBranch (Branch name args e) = - ((unIdent name,) . (unArgs args,)) <$> resolveWhere e +getLoc :: (Int,Int) -> Resolver C.Loc +getLoc l = C.Loc <$> getModule <*> pure l --- Assumes a flattened telescope. -resolveTele :: [VDecl] -> Resolver [(String,A.Exp)] -resolveTele [] = return [] -resolveTele (VDecl [Binder a] t:ds) = - ((unArg a,) <$> resolveExp t) <:> resolveTele ds -resolveTele ds = - throwError $ "resolveTele: non flattened telescope " ++ show ds +resolveBinder :: AIdent -> Resolver C.Binder +resolveBinder (AIdent (l,x)) = do l <- getLoc l; return (x, l) --- Assumes a flattened telescope. -resolveTelePi :: [VDecl] -> Resolver A.Exp -> Resolver A.Exp -resolveTelePi [] b = b -resolveTelePi (VDecl [Binder x] a:as) b = - A.Pi <$> resolveExp a <*> lam x (resolveTelePi as b) -resolveTelePi (t@(VDecl{}):as) _ = - throwError ("resolveTelePi: non flattened telescope " ++ show t) +resolveVar :: AIdent -> Resolver Ter +resolveVar (AIdent (l,x)) + | (x == "_") || (x == "undefined") = C.PN <$> C.Undef <$> getLoc l + | otherwise = do + modName <- getModule + vars <- getVariables + case C.getIdent x vars of + Just Variable -> return $ C.Var x + Just Constructor -> return $ C.Con x [] + _ -> throwError $ + "Cannot resolve variable" <+> x <+> "at position" <+> + show l <+> "in module" <+> modName -resolveLabel :: Sum -> Resolver (String,[(String,A.Exp)]) -resolveLabel (Sum n tele) = (unIdent n,) <$> resolveTele (flattenTele tele) +lam :: AIdent -> Resolver Ter -> Resolver Ter +lam a e = do x <- resolveBinder a; C.Lam x <$> local (insertVar x) e -resolveDefs :: [Def] -> Resolver [A.Def] -resolveDefs [] = return [] -resolveDefs (DefTDecl n e:d:ds) = do - e' <- resolveExp e - xd <- checkDef (unIdent n,d) - rest <- resolveDefs ds - return $ ([(unIdent n, e')],[xd]) : rest --- resolveDefs (DefMutual defs:ds) = resolveMutual defs <:> resolveDefs ds -resolveDefs (d:_) = error $ "Type declaration expected: " ++ show d +lams :: [AIdent] -> Resolver Ter -> Resolver Ter +lams = flip $ foldr lam -checkDef :: (String,Def) -> Resolver (String,A.Exp) -checkDef (n,Def (AIdent (_,m)) args body) | n == m = do - updateName n +bind :: (Ter -> Ter -> Ter) -> (AIdent, Exp) -> Resolver Ter -> Resolver Ter +bind f (x,t) e = f <$> resolveExp t <*> lam x e + +binds :: (Ter -> Ter -> Ter) -> Tele -> Resolver Ter -> Resolver Ter +binds f = flip $ foldr $ bind f + +resolveExp :: Exp -> Resolver Ter +resolveExp U = return C.U +resolveExp (Var x) = resolveVar x +resolveExp (App t s) = C.mkApps <$> resolveExp x <*> mapM resolveExp xs + where (x, xs) = unApps t [s] +resolveExp (Sigma t b) = case pseudoTele t of + Just tele -> binds C.Sigma tele (resolveExp b) + Nothing -> throwError "Telescope malformed in Sigma" +resolveExp (Pi t b) = case pseudoTele t of + Just tele -> binds C.Pi tele (resolveExp b) + Nothing -> throwError "Telescope malformed in Pigma" +resolveExp (Fun a b) = bind C.Pi (AIdent ((0,0),"_"), a) (resolveExp b) +resolveExp (Lam x xs t) = lams (x:xs) (resolveExp t) +resolveExp (Fst t) = C.Fst <$> resolveExp t +resolveExp (Snd t) = C.Snd <$> resolveExp t +resolveExp (Pair t0 t1) = C.SPair <$> resolveExp t0 <*> resolveExp t1 +resolveExp (Split brs) = do + brs' <- mapM resolveBranch brs + loc <- getLoc (case brs of Branch (AIdent (l,_)) _ _:_ -> l ; _ -> (0,0)) + return $ C.Split loc brs' +resolveExp (Let decls e) = do + (rdecls,names) <- resolveDecls decls + C.mkWheres rdecls <$> local (insertBinders names) (resolveExp e) + +resolveWhere :: ExpWhere -> Resolver Ter +resolveWhere = resolveExp . unWhere + +resolveBranch :: Branch -> Resolver (C.Label,([C.Binder],C.Ter)) +resolveBranch (Branch lbl args e) = do + binders <- mapM resolveBinder args + re <- local (insertVars binders) $ resolveWhere e + return (unAIdent lbl, (binders, re)) + +resolveTele :: [(AIdent,Exp)] -> Resolver C.Tele +resolveTele [] = return [] +resolveTele ((i,d):t) = do + x <- resolveBinder i + ((x,) <$> resolveExp d) <:> local (insertVar x) (resolveTele t) + +resolveLabel :: Label -> Resolver (C.Binder, C.Tele) +resolveLabel (Label n vdecl) = (,) <$> resolveBinder n <*> resolveTele (vTele vdecl) + +declsLabels :: [Decl] -> Resolver [C.Binder] +declsLabels decls = mapM resolveBinder [lbl | Label lbl _ <- sums] + where sums = concat [sum | DeclData _ _ sum <- decls] + +-- Resolve Data or Def declaration +resolveDDecl :: Decl -> Resolver (C.Ident, C.Ter) +resolveDDecl (DeclDef (AIdent (_,n)) args body) = (n,) <$> lams args (resolveWhere body) -checkDef (n,DefData (AIdent (_,m)) args sums) | n == m = do - updateName n - (n,) <$> lams args (A.Sum <$> genPrim <*> mapM resolveLabel sums) -checkDef (n,d) = - throwError ("Mismatching names in " ++ show n ++ " and " ++ show d) +resolveDDecl (DeclData x@(AIdent (l,n)) args sum) = + (n,) <$> lams args (C.Sum <$> resolveBinder x <*> mapM resolveLabel sum) +resolveDDecl d = throwError $ "Definition expected" <+> show d -resolveMutual :: [Def] -> Resolver A.Def -resolveMutual defs = do - tdecls' <- mapM resolveTDecl tdecls - let names = map fst tdecls' - when (length names /= length decls) $ - throwError $ "Definitions missing in " ++ show defs - tdef' <- mapM checkDef (zip names decls) - return (tdecls',tdef') +-- Resolve mutual declarations (possibly one) +resolveMutuals :: [Decl] -> Resolver (C.Decls,[(C.Binder,SymKind)]) +resolveMutuals decls = do + binders <- mapM resolveBinder idents + cs <- declsLabels decls + let cns = map fst cs ++ names + when (nub cns /= cns) $ + throwError $ "Duplicated constructor or ident:" <+> show cns + rddecls <- + mapM (local (insertVars binders . insertCons cs) . resolveDDecl) ddecls + when (names /= map fst rddecls) $ + throwError $ "Mismatching names in" <+> show decls + rtdecls <- resolveTele tdecls + return ([ (x,t,d) | (x,t) <- rtdecls | (_,d) <- rddecls ], + map (,Constructor) cs ++ map (,Variable) binders) where - (tdecls,decls) = span isTDecl defs - isTDecl d@(DefTDecl {}) = True - isTDecl _ = False - resolveTDecl (DefTDecl n e) = do e' <- resolveExp e - return (unIdent n, e') + idents = [ x | DeclType x _ <- decls ] + names = [ unAIdent x | x <- idents ] + tdecls = [ (x,t) | DeclType x t <- decls ] + ddecls = [ t | t <- decls, not $ isTDecl t ] + isTDecl d = case d of DeclType{} -> True; _ -> False + +-- Resolve opaque/transparent decls +resolveOTDecl :: (C.Binder -> C.ODecls) -> AIdent -> [Decl] -> + Resolver ([C.ODecls],[(C.Binder,SymKind)]) +resolveOTDecl c n ds = do + vars <- getVariables + (rest,names) <- resolveDecls ds + case C.getBinder (unAIdent n) vars of + Just x -> return (c x : rest, names) + Nothing -> throwError $ "Not in scope:" <+> show n + +-- Resolve declarations +resolveDecls :: [Decl] -> Resolver ([C.ODecls],[(C.Binder,SymKind)]) +resolveDecls [] = return ([],[]) +resolveDecls (DeclOpaque n:ds) = resolveOTDecl C.Opaque n ds +resolveDecls (DeclTransp n:ds) = resolveOTDecl C.Transp n ds +resolveDecls (td@DeclType{}:d:ds) = do + (rtd,names) <- resolveMutuals [td,d] + (rds,names') <- local (insertBinders names) $ resolveDecls ds + return (C.ODecls rtd : rds, names' ++ names) +resolveDecls (DeclPrim x t:ds) = case C.mkPN (unAIdent x) of + Just pn -> do + b <- resolveBinder x + rt <- resolveExp t + (rds,names) <- local (insertVar b) $ resolveDecls ds + return (C.ODecls [(b, rt, C.PN pn)] : rds, names ++ [(b,Variable)]) + Nothing -> throwError $ "Primitive notion not defined:" <+> unAIdent x +resolveDecls (DeclMutual defs : ds) = do + (rdefs,names) <- resolveMutuals defs + (rds, names') <- local (insertBinders names) $ resolveDecls ds + return (C.ODecls rdefs : rds, names' ++ names) +resolveDecls (decl:_) = throwError $ "Invalid declaration:" <+> show decl + +resolveModule :: Module -> Resolver ([C.ODecls],[(C.Binder,SymKind)]) +resolveModule (Module n imports decls) = + local (updateModule $ unAIdent n) $ resolveDecls decls + +resolveModules :: [Module] -> Resolver ([C.ODecls],[(C.Binder,SymKind)]) +resolveModules [] = return ([],[]) +resolveModules (mod:mods) = do + (rmod, names) <- resolveModule mod + (rmods,names') <- local (insertBinders names) $ resolveModules mods + return (rmod ++ rmods, names' ++ names) diff --git a/Eval.hs b/Eval.hs --- a/Eval.hs +++ b/Eval.hs @@ -1,469 +1,906 @@ -module Eval where - -import Control.Arrow (second) -import Data.List -import Data.Maybe (fromMaybe) -import Debug.Trace - -import CTT - --- Switch to False to turn off debugging -debug :: Bool -debug = True - -traceb :: String -> a -> a -traceb s x = if debug then trace s x else x - -evals :: Env -> [(Binder,Ter)] -> [(Binder,Val)] -evals e = map (second (eval e)) - -unCompAs :: Val -> Name -> Box Val -unCompAs (VComp box) y = swap box (pname box) y -unCompAs v _ = error $ "unCompAs: " ++ show v ++ " is not a VComp" - -unFillAs :: Val -> Name -> Box Val -unFillAs (VFill x box) y = swap box x y -unFillAs v _ = error $ "unFillAs: " ++ show v ++ " is not a VFill" - -appName :: Val -> Name -> Val -appName (Path x u) y = swap u x y -appName v _ = error $ "appName: " ++ show v ++ " should be a path" - --- Compute the face of a value -face :: Val -> Side -> Val -face u xdir@(x,dir) = - let fc v = v `face` (x,dir) in case u of - VU -> VU - Ter t e -> eval (e `faceEnv` xdir) t - VId a v0 v1 -> VId (fc a) (fc v0) (fc v1) - Path y v | x == y -> u - | otherwise -> Path y (fc v) - VExt y b f g p | x == y && dir == Down -> f - | x == y && dir == Up -> g - | otherwise -> VExt y (fc b) (fc f) (fc g) (fc p) - VPi a f -> VPi (fc a) (fc f) - VInh v -> VInh (fc v) - VInc v -> VInc (fc v) - VSquash y v0 v1 | x == y && dir == Down -> v0 - | x == y && dir == Up -> v1 - | otherwise -> VSquash y (fc v0) (fc v1) - VCon c us -> VCon c (map fc us) - VEquivEq y a b f s t | x == y && dir == Down -> a - | x == y && dir == Up -> b - | otherwise -> - VEquivEq y (fc a) (fc b) (fc f) (fc s) (fc t) - VPair y a v | x == y && dir == Down -> a - | x == y && dir == Up -> fc v - | otherwise -> VPair y (fc a) (fc v) - VEquivSquare y z a s t | x == y -> a - | x == z && dir == Down -> a - | x == z && dir == Up -> VEquivEq y a a idV s t - | otherwise -> - VEquivSquare y z (fc a) (fc s) (fc t) - VSquare y z v | x == y -> fc v - | x == z && dir == Down -> fc v - | x == z && dir == Up -> idVPair y (fc v) - | otherwise -> VSquare y z (fc v) - Kan Fill a b@(Box dir' y v nvs) - | x /= y && x `notElem` nonPrincipal b -> fill (fc a) (mapBox fc b) - | x `elem` nonPrincipal b -> lookBox (x,dir) b - | x == y && dir == mirror dir' -> v - | otherwise -> com a b - Kan Com a b@(Box dir' y v nvs) - | x == y -> u - | x `notElem` nonPrincipal b -> com (fc a) (mapBox fc b) - | x `elem` nonPrincipal b -> lookBox (x,dir) b `face` (y,dir') - VComp b@(Box dir' y _ _) - | x == y -> u - | x `notElem` nonPrincipal b -> VComp (mapBox fc b) - | x `elem` nonPrincipal b -> lookBox (x,dir) b `face` (y,dir') - VFill z b@(Box dir' y v nvs) - | x == z -> u - | x /= y && x `notElem` nonPrincipal b -> VFill z (mapBox fc b) - | (x,dir) `elem` defBox b -> - lookBox (x,dir) (mapBox (`face` (z,Down)) b) - | x == y && dir == dir' -> - VComp $ mapBox (`face` (z,Up)) b - -idV :: Val -idV = Ter (Lam "x" (Var "x")) Empty - -idVPair :: Name -> Val -> Val -idVPair x v = VPair x (v `face` (x,Down)) v - --- Compute the face of an environment -faceEnv :: Env -> Side -> Env -faceEnv e xd = mapEnv (`face` xd) e - -look :: Binder -> Env -> Val -look x (Pair s (y,u)) | x == y = u - | otherwise = look x s -look x r@(PDef es r1) = look x (upds r1 (evals r es)) - -cubeToBox :: Val -> Box () -> Box Val -cubeToBox v = modBox (\nd _ -> v `face` nd) - -eval :: Env -> Ter -> Val -eval _ U = VU -eval e (Var i) = look i e -eval e (Id a a0 a1) = VId (eval e a) (eval e a0) (eval e a1) -eval e (Refl a) = Path (fresh e) $ eval e a -eval e (TransU p t) = - com pv box - where x = fresh e - pv = appName (eval e p) x - box = Box Up x (eval e t) [] -eval e (TransURef t) = Path (fresh e) (eval e t) -eval e (TransUEquivEq a b f s t u) = Path x pv -- TODO: Check this! - where x = fresh e - pv = fill (eval e b) box - box = Box Up x (app (eval e f) (eval e u)) [] -eval e (J a u c w _ p) = com (app (app cv omega) sigma) box - where - x:y:_ = gensyms $ supportEnv e - uv = eval e u - pv = appName (eval e p) x - theta = fill (eval e a) (Box Up x uv [((y,Down),uv),((y,Up),pv)]) - sigma = Path x theta - omega = theta `face` (x,Up) - cv = eval e c - box = Box Up y (eval e w) [] -eval e (JEq a u c w) = Path y $ fill (app (app cv omega) sigma) box - where - x:y:_ = gensyms $ supportEnv e - uv = eval e u - theta = fill (eval e a) (Box Up x uv [((y,Down),uv),((y,Up),uv)]) - sigma = Path x theta - omega = theta `face` (x,Up) - cv = eval e c - box = Box Up y (eval e w) [] -eval e (Ext b f g p) = - Path x $ VExt x (eval e b) (eval e f) (eval e g) (eval e p) - where x = fresh e -eval e (Pi a b) = VPi (eval e a) (eval e b) -eval e (Lam x t) = Ter (Lam x t) e -- stop at lambdas -eval e (App r s) = app (eval e r) (eval e s) -eval e (Inh a) = VInh (eval e a) -eval e (Inc t) = VInc (eval e t) -eval e (Squash r s) = Path x $ VSquash x (eval e r) (eval e s) - where x = fresh e -eval e (InhRec b p phi a) = - inhrec (eval e b) (eval e p) (eval e phi) (eval e a) -eval e (Where t def) = eval (PDef def e) t -eval e (Con name ts) = VCon name (map (eval e) ts) -eval e (Branch pr alts) = Ter (Branch pr alts) e -eval e (LSum pr ntss) = Ter (LSum pr ntss) e -eval e (EquivEq a b f s t) = - Path x $ VEquivEq x (eval e a) (eval e b) (eval e f) (eval e s) (eval e t) - where x = fresh e -eval e (EquivEqRef a s t) = - Path y $ Path x $ VEquivSquare x y (eval e a) (eval e s) (eval e t) - where x:y:_ = gensyms (supportEnv e) - -inhrec :: Val -> Val -> Val -> Val -> Val -inhrec _ _ phi (VInc a) = app phi a -inhrec b p phi (VSquash x a0 a1) = appName (app (app p b0) b1) x - where fc w d = w `face` (x,d) - b0 = inhrec (fc b Down) (fc p Down) (fc phi Down) a0 - b1 = inhrec (fc b Up) (fc p Up) (fc phi Up) a1 -inhrec b p phi (Kan ktype (VInh a) box@(Box dir x v nvs)) = - kan ktype b (modBox irec box) - where irec (j,dir) v = let fc v = v `face` (j,dir) - in inhrec (fc b) (fc p) (fc phi) v -inhrec b p phi v = error $ "inhrec : " ++ show v - -kan :: KanType -> Val -> Box Val -> Val -kan Fill = fill -kan Com = com - --- Kan filling -fill :: Val -> Box Val -> Val -fill vid@(VId a v0 v1) box@(Box dir i v nvs) = Path x $ fill a box' - where x = gensym (support vid `union` support box) - box' = (x,(v0,v1)) `consBox` mapBox (`appName` x) box --- assumes cvs are constructor vals -fill (Ter (LSum _ nass) env) box@(Box _ _ (VCon n _) _) = VCon n ws - where as = case lookup n nass of - Just as -> as - Nothing -> error $ "fill: missing constructor " - ++ "in labelled sum " ++ n - boxes = transposeBox $ mapBox unCon box - -- fill boxes for each argument position of the constructor - ws = fills as env boxes -fill (VEquivSquare x y a s t) box@(Box dir x' vx' nvs) = - VSquare x y v - where v = fill a $ modBox unPack box - - unPack :: (Name,Dir) -> Val -> Val - unPack (z,c) v | z /= x && z /= y = unSquare v - | z == y && c == Up = sndVal v - | otherwise = v - --- a and b should be independent of x -fill veq@(VEquivEq x a b f s t) box@(Box dir z vz nvs) - | x /= z && x `notElem` nonPrincipal box = - let ax0 = fill a (mapBox fstVal box) - bx0 = app f ax0 - bx = mapBox sndVal box - bx1 = fill b $ mapBox (`face` (x,Up)) bx - v = fill b $ (x,(bx0,bx1)) `consBox` bx - in traceb "VEquivEq case 1" $ VPair x ax0 v - | x /= z && x `elem` nonPrincipal box = - let ax0 = lookBox (x,Down) box - bx = modBox (\(ny,dy) vy -> if x /= ny then sndVal vy else - if dy == Down then app f ax0 else vy) box - v = fill b bx - in traceb "VEquivEq case 2" $ VPair x ax0 v - | x == z && dir == Up = - let ax0 = vz - bx0 = app f ax0 - v = fill b $ Box dir z bx0 [ (nnd,sndVal v) | (nnd,v) <- nvs ] - in traceb "VEquivEq case 3" $ VPair x ax0 v - | x == z && dir == Down = - let y = gensym (support veq `union` support box) - VCon "pair" [gb,sb] = app s vz - vy = appName sb x - - vpTSq :: Name -> Dir -> Val -> (Val,Val) - vpTSq nz dz (VPair z a0 v0) = - let vp = VCon "pair" [a0, Path z v0] - t0 = t `face` (nz,dz) - b0 = vz `face` (nz,dz) - VCon "pair" [l0,sq0] = appName (app (app t0 b0) vp) y - in (l0,appName sq0 x) -- TODO: check the correctness of the square s0 - - -- TODO: Use modBox! - vsqs = [ ((n,d),vpTSq n d v) | ((n,d),v) <- nvs] - box1 = Box Up y gb [ (nnd,v) | (nnd,(v,_)) <- vsqs ] - afill = fill a box1 - - acom = afill `face` (y,Up) - fafill = app f afill - box2 = Box Up y vy (((x,Down),fafill) : ((x,Up),vz) : - [ (nnd,v) | (nnd,(_,v)) <- vsqs ]) - bcom = com b box2 - in traceb "VEquivEq case 4" $ VPair x acom bcom - | otherwise = error "fill EqEquiv" - -fill v@(Kan Com VU tbox') box@(Box dir x' vx' nvs') - | toAdd /= [] = -- W.l.o.g. assume that box contains faces for - let -- the non-principal sides of tbox. - add :: Side -> Val -- TODO: Is this correct? Do we have - -- to consider the auxsides? - add yc = fill (lookBox yc tbox) (mapBox (`face` yc) box) - newBox = [ (n,(add (n,Down),add (n,Up)))| n <- toAdd ] `appendBox` box - in traceb "Kan Com 1" $ fill v newBox - | x' `notElem` nK = - let principal = fill tx (mapBox (pickout (x,tdir')) boxL) - nonprincipal = - [ let side = [((x,tdir),lookBox yc box) - ,((x,tdir'),principal `face` yc)] - in (yc, fill (lookBox yc tbox) - (side `appendSides` mapBox (pickout yc) boxL)) - | yc <- allDirs nK ] - newBox = Box tdir x principal nonprincipal - in traceb ("Kan Com 2\nnewBox " ++ show newBox) VComp newBox - | x' `elem` nK = - let -- assumes zc in defBox tbox - auxsides zc = [ (yd,pickout zc (lookBox yd box)) | yd <- allDirs nL ] - -- extend input box along x with orientation tdir'; results - -- in the non-principal faces on the intersection of defBox - -- box and defBox tbox; note, that the intersection contains - -- (x',dir'), but not (x',dir) (and (x,_)) - npintbox = modBox (\yc boxside -> fill (lookBox yc tbox) - (Box tdir' x boxside (auxsides yc))) - (subBox (nK `intersect` nJ) box) - npint = fromBox npintbox - npintfacebox = mapBox (`face` (x,tdir')) npintbox - principal = fill tx (auxsides (x,tdir') `appendSides` npintfacebox) - nplp = principal `face` (x',dir) - nplnp = auxsides (x',dir) - ++ map (\(yc,v) -> (yc,v `face` (x',dir))) (sides npintbox) - -- the missing non-principal face on side (x',dir) - nplast = ((x',dir),fill (lookBox (x',dir) tbox) (Box tdir x nplp nplnp)) - newBox = Box tdir x principal (nplast:npint) - in traceb "Kan Com 3" $ VComp newBox - where nK = nonPrincipal tbox - nJ = nonPrincipal box - z = gensym $ support tbox' ++ support box - -- x is z - tbox@(Box tdir x tx nvs) = swap tbox' (pname tbox') z - toAdd = nK \\ (x' : nJ) - nL = nJ \\ nK - boxL = subBox nL box - dir' = mirror dir - tdir' = mirror tdir - -- asumes zd is in the sides of tbox - pickout zd vcomp = lookBox zd (unCompAs vcomp z) - -fill v@(Kan Fill VU tbox@(Box tdir x tx nvs)) box@(Box dir x' vx' nvs') - -- the cases should be (in order): - -- 1) W.l.o.g. K subset x', J - -- 2) x' = x & dir = tdir - -- 3) x' = x & dir = mirror tdir - -- 4) x `notElem` J (maybe combine with 1?) - -- 5) x' `notElem` K - -- 6) x' `elem` K - - | toAdd /= [] = - let - add :: Side -> Val - add zc = fill (lookBox zc tbox) (mapBox (`face` zc) box) - newBox = [ (zc,add zc) | zc <- allDirs toAdd ] `appendSides` box - in traceb "Kan Fill VU Case 1" fill v newBox -- W.l.o.g. nK subset x:nJ - | x == x' && dir == tdir = -- assumes K subset x',J - let - boxp = lookBox (x,dir') box -- is vx' - principal = fill (lookBox (x',tdir') tbox) (Box Up z boxp (auxsides (x',tdir'))) - nonprincipal = - [ (zc, - let principzc = lookBox zc box - sides = [((x,tdir'),principal `face` zc) - ,((x,tdir),principzc)] -- "degenerate" along z! - in fill (lookBox zc tbox) (Box Up z principzc (sides ++ auxsides zc))) - | zc <- allDirs nK ] - in traceb ("Kan Fill VU Case 2 v= " ++ show v ++ "\nbox= " ++ show box) - VFill z (Box tdir x' principal nonprincipal) - - | x == x' && dir == mirror tdir = -- assumes K subset x',J - let -- the principal side of box must be a VComp - upperbox = unCompAs (lookBox (x,dir') box) x - nonprincipal = - [ (zc, - let top = lookBox zc upperbox - bottom = lookBox zc box - princ = top `face` (x',tdir) -- same as: bottom `face` (x',tdir) - sides = [((z,Down),bottom),((z,Up),top)] - in fill (lookBox zc tbox) - (Box tdir' x princ -- "degenerate" along z! - (sides ++ auxsides zc))) - | zc <- allDirs nK ] - nonprincipalfaces = - map (\(zc,u) -> (zc,u `face` (x,dir))) nonprincipal - principal = - fill (lookBox (x,tdir') tbox) (Box Up z (lookBox (x,tdir') upperbox) - (nonprincipalfaces ++ auxsides (x,tdir'))) - in traceb "Kan Fill VU Case 3" - VFill z (Box tdir x' principal nonprincipal) - | x `notElem` nJ = -- assume x /= x' and K subset x', J - let - comU = v `face` (x,tdir) -- Kan Com VU (tbox (z=Up)) - xsides = [((x,tdir), fill comU (mapBox (`face` (x,tdir)) box)) - ,((x,tdir'),fill (lookBox (x,tdir') tbox) - (mapBox (`face` (x,tdir)) box))] - in traceb "Kan Fill VU Case 4" - fill v (xsides `appendSides` box) - | x' `notElem` nK = -- assumes x,K subset x',J - let - xaux = unCompAs (lookBox (x,tdir) box) x -- TODO: Do we need a fresh name? - boxprinc = unFillAs (lookBox (x',dir') box) z - princnp = [((z,Up),lookBox (x,tdir') xaux) - ,((z,Down),lookBox (x,tdir') box)] - ++ auxsides (x,tdir') - principal = fill (lookBox (x,tdir') tbox) -- tx - (Box dir x' (lookBox (x,tdir') boxprinc) princnp) - nonprincipal = - [ let up = lookBox yc xaux - np = [((z,Up),up),((z,Down),lookBox yc box) - ,((y,c), up `face` (x,tdir)) -- deg along z! - ,((y,mirror c), principal `face` yc)] - ++ auxsides yc - in (yc, fill (lookBox yc tbox) - (Box dir x' (lookBox yc boxprinc) np)) - | yc@(y,c) <- allDirs nK] - in traceb "Kan Fill VU Case 5" - VFill z (Box tdir x' principal nonprincipal) - - | x' `elem` nK = -- assumes x,K subset x',J - let -- surprisingly close to the last case of the Kan-Com-VU filling - upperbox = unCompAs (lookBox (x,dir') box) x - npintbox = - modBox (\zc downside -> - let bottom = lookBox zc box - top = lookBox zc upperbox - princ = downside -- same as bottom `face` (x',tdir) and - -- top `face` (x',tdir) - sides = [((z,Down),bottom),((z,Up),top)] - in fill (lookBox zc tbox) (Box tdir' x princ -- deg along z! - (sides ++ auxsides zc))) - (subBox (nK `intersect` nJ) box) - npint = fromBox npintbox - npintfacebox = mapBox (`face` (x,tdir)) npintbox - principalbox = ([((z,Down),lookBox (x,tdir') box) - ,((z,Up) ,lookBox (x,tdir')upperbox)] ++ - auxsides (x,tdir')) `appendSides` npintfacebox - principal = fill tx principalbox - nplp = lookBox (x',dir) upperbox - nplnp = [((x',dir), nplp `face` (x',dir)) -- deg along z! - ,((x', dir'),principal `face` (x',dir))] - ++ auxsides (x',dir) - ++ map (\(zc,u) -> (zc,u `face` (x',dir))) (sides npintbox) - nplast = ((x',dir),fill (lookBox (x',dir) tbox) (Box Down z nplp nplnp)) - in traceb "Kan Fill VU Case 6" - VFill z (Box tdir x' principal (nplast:npint)) - - where z = gensym $ support v ++ support box - nK = nonPrincipal tbox - nJ = nonPrincipal box - toAdd = nK \\ (x' : nJ) - nL = nJ \\ nK - boxL = subBox nL box - dir' = mirror dir - tdir' = mirror tdir - -- asumes zc is in the sides of tbox - pickout zc vfill = lookBox zc (unFillAs vfill z) - -- asumes zc is in the sides of tbox - auxsides zc = [ (yd,pickout zc (lookBox yd box)) | yd <- allDirs nL ] - -fill v b = Kan Fill v b - -fills :: [(Binder,Ter)] -> Env -> [Box Val] -> [Val] -fills [] _ [] = [] -fills ((x,a):as) e (box:boxes) = v : fills as (Pair e (x,v)) boxes - where v = fill (eval e a) box -fills _ _ _ = error "fills: different lengths of types and values" - --- Composition (ie., the face of fill which is created) -com :: Val -> Box Val -> Val -com vid@VId{} box@(Box dir i _ _) = fill vid box `face` (i,dir) -com ter@Ter{} box@(Box dir i _ _) = fill ter box `face` (i,dir) -com veq@VEquivEq{} box@(Box dir i _ _) = fill veq box `face` (i,dir) -com u@(Kan Com VU _) box@(Box dir i _ _) = fill u box `face` (i,dir) -com u@(Kan Fill VU _) box@(Box dir i _ _) = fill u box `face` (i,dir) -com v box = Kan Com v box - -appBox :: Box Val -> Box Val -> Box Val -appBox (Box dir x v nvs) (Box _ _ u nus) = Box dir x (app v u) nvus - where nvus = [ (nnd,app v (lookup' nnd nus)) | (nnd,v) <- nvs ] - lookup' x = fromMaybe (error "appBox") . lookup x - -app :: Val -> Val -> Val -app (Ter (Lam x t) e) u = eval (Pair e (x,u)) t -app (Kan Com (VPi a b) box@(Box dir x v nvs)) u = - traceb ("Pi Com:\nufill = " ++ show ufill ++ "\nbcu = " ++ show bcu) - com (app b ufill) (appBox box bcu) - where ufill = fill a (Box (mirror dir) x u []) - bcu = cubeToBox ufill (shapeOfBox box) -app kf@(Kan Fill (VPi a b) box@(Box dir i w nws)) v = - traceb "Pi fill" $ com (app b vfill) (Box Up x vx (((i,Down),vi0) : ((i,Up),vi1):nvs)) - where x = gensym (support kf `union` support v) - u = v `face` (i,dir) - ufill = fill a (Box (mirror dir) i u []) - bcu = cubeToBox ufill (shapeOfBox box) - vfill = fill a (Box (mirror dir) i u [((x,Down),ufill),((x,Up),v)]) - vx = fill (app b ufill) (appBox box bcu) - vi0 = app w (vfill `face` (i,Down)) - vi1 = com (app b ufill) (appBox box bcu) - nvs = [ ((n,d),app ws (vfill `face` (n,d))) | ((n,d),ws) <- nws ] -app vext@(VExt x bv fv gv pv) w = com (app bv w) (Box Up y pvxw [((x,Down),left),((x,Up),right)]) - -- NB: there are various choices how to construct this - where y = gensym (support vext `union` support w) - w0 = w `face` (x,Down) - left = app fv w0 - right = app gv (swap w x y) - pvxw = appName (app pv w0) x -app (Ter (Branch _ nvs) e) (VCon name us) = case lookup name nvs of - Just (xs,t) -> eval (upds e (zip xs us)) t - Nothing -> error $ "app: Branch with insufficient " - ++ "arguments; missing case for " ++ name -app r s = error $ "app" ++ show r ++ show s +{-# LANGUAGE TupleSections, GeneralizedNewtypeDeriving #-} +module Eval ( eval + , evals + , app + , conv + , fstSVal + , Eval + , runEval + ) where + +import Control.Applicative +import Control.Arrow (second) +import Control.Monad +import Control.Monad.Reader +import Data.Functor.Identity +import Data.List +import Data.Maybe (fromMaybe) + +import CTT + +trace :: String -> Eval () +trace s = do + debug <- ask + when debug $ liftIO (putStrLn s) + +-- For now only store the debugging boolean +type EState = Bool + +newtype Eval a = Eval { unEval :: ReaderT Bool IO a } + deriving (Functor, Applicative, Monad, MonadIO, MonadReader Bool) + +runEval :: Bool -> Eval a -> IO a +runEval debug e = runReaderT (unEval e) debug + +look :: Ident -> OEnv -> Eval (Binder, Val) +look x (OEnv (Pair rho (n@(y,l),u)) opaques) + | x == y = return (n, u) + | otherwise = look x (OEnv rho opaques) +look x r@(OEnv (PDef es r1) o) = case lookupIdent x es of + Just (y,t) -> (y,) <$> eval r t + Nothing -> look x (OEnv r1 o) + +eval :: OEnv -> Ter -> Eval Val +eval e U = return VU +eval e (PN pn) = evalAppPN e pn [] +eval e t@(App r s) = case unApps t of + (PN pn,us) -> evalAppPN e pn us + _ -> appM (eval e r) (eval e s) +eval e (Var i) = do + (x,v) <- look i e + return $ if x `elem` opaques e then VVar ("opaque_" ++ show x) $ support v else v +eval e (Pi a b) = VPi <$> eval e a <*> eval e b +eval e (Lam x t) = return $ Ter (Lam x t) e -- stop at lambdas +eval e (Sigma a b) = VSigma <$> eval e a <*> eval e b +eval e (SPair a b) = VSPair <$> eval e a <*> eval e b +eval e (Fst a) = fstSVal <$> eval e a +eval e (Snd a) = sndSVal <$> eval e a +eval e (Where t decls) = eval (oPDef False decls e) t +eval e (Con name ts) = VCon name <$> mapM (eval e) ts +eval e (Split pr alts) = return $ Ter (Split pr alts) e +eval e (Sum pr ntss) = return $ Ter (Sum pr ntss) e + +evals :: OEnv -> [(Binder,Ter)] -> Eval [(Binder,Val)] +evals env = sequenceSnd . map (second (eval env)) + +fstSVal, sndSVal :: Val -> Val +fstSVal (VSPair a b) = a +fstSVal u | isNeutral u = VFst u + | otherwise = error $ show u ++ " should be neutral" +sndSVal (VSPair a b) = b +sndSVal u | isNeutral u = VSnd u + | otherwise = error $ show u ++ " should be neutral" + +-- Application +app :: Val -> Val -> Eval Val +app (Ter (Lam x t) e) u = eval (oPair e (x,u)) t +app (Kan Com (VPi a b) box@(Box dir x v nvs)) u = do + trace "Pi Com" + ufill <- fill a (Box (mirror dir) x u []) + bcu <- cubeToBox ufill (shapeOfBox box) + comM (app b ufill) (appBox box bcu) +app kf@(Kan Fill (VPi a b) box@(Box dir i w nws)) v = do + trace "Pi fill" + let x = fresh (kf, v) + u <- v `face` (i,dir) + ufill <- fill a (Box (mirror dir) i u []) + bcu <- cubeToBox ufill (shapeOfBox box) + vfill <- fill a (Box (mirror dir) i u [((x,down),ufill),((x,up),v)]) + vx <- fillM (app b ufill) (appBox box bcu) + vi0 <- appM (return w) (vfill `face` (i,mirror dir)) + vi1 <- comM (app b ufill) (appBox box bcu) + nvs <- sequenceSnd [ ((n,d),appM (return ws) (vfill `face` (n,d))) + | ((n,d),ws) <- nws ] + comM (app b vfill) (return (Box up x vx (((i,mirror dir),vi0) : ((i,dir),vi1):nvs))) +-- app vext@(VExt x bv fv gv pv) w = do +-- -- NB: there are various choices how to construct this +-- let y = fresh (vext, w) +-- w0 <- w `face` (x,down) +-- left <- app fv w0 +-- right <- app gv (swap w x y) +-- pvxw <- appNameM (app pv w0) x +-- comM (app bv w) (return (Box up y pvxw [((x,down),left),((x,up),right)])) +app vhext@(VHExt x bv fv gv pv) w = do + a0 <- w `face` (x,down) + a1 <- w `face` (x,up) + appNameM (apps pv [a0, a1, Path x w]) x +app (Ter (Split _ nvs) e) (VCon name us) = case lookup name nvs of + Just (xs,t) -> eval (upds e (zip xs us)) t + Nothing -> error $ "app: Split with insufficient arguments; " ++ + "missing case for " ++ name +app u@(Ter (Split _ _) _) v + | isNeutral v = return $ VSplit u v -- v should be neutral + | otherwise = error $ "app: (VSplit) " ++ show v ++ " is not neutral" +app r s + | isNeutral r = return $ VApp r s -- r should be neutral + | otherwise = error $ "app: (VApp) " ++ show r ++ " is not neutral" + +-- Monadic version of app +appM :: Eval Val -> Eval Val -> Eval Val +appM t1 t2 = do + u <- t1 + v <- t2 + app u v + +apps :: Val -> [Val] -> Eval Val +apps = foldM app + +appBox :: Box Val -> Box Val -> Eval (Box Val) +appBox (Box dir x v nvs) (Box _ _ u nus) = do + let lookup' x = fromMaybe (error "appBox") . lookup x + sequenceBox $ Box dir x (app v u) [ (nnd,app v (lookup' nnd nus)) + | (nnd,v) <- nvs ] + +appName :: Val -> Name -> Eval Val +appName (Path x u) y | y `elem` [0,1] = u `face` (x,y) +appName p y | y `elem` [0,1] = return $ VAppName p y + -- p has to be neutral +appName (Path x u) y | x == y = return u + | y `elem` support u = error ("appName " ++ "\nu = " ++ + show u ++ "\ny = " ++ show y) + | otherwise = return $ swap u x y +appName v y = return $ VAppName v y + +appNameM :: Eval Val -> Name -> Eval Val +appNameM v n = do + v' <- v + appName v' n + +-- Apply a primitive notion +evalAppPN :: OEnv -> PN -> [Ter] -> Eval Val +evalAppPN e pn ts + | length ts < arity pn = + -- Eta expand primitive notions + let r = arity pn - length ts + binders = map (\n -> '_' : show n) [1..r] + vars = map Var binders + in return $ Ter (mkLams binders $ mkApps (PN pn) (ts ++ vars)) e + | otherwise = do + let (args,rest) = splitAt (arity pn) ts + vas <- mapM (eval e) args + p <- evalPN (freshs e) pn vas + r <- mapM (eval e) rest + apps p r + +-- Evaluate primitive notions +evalPN :: [Name] -> PN -> [Val] -> Eval Val +evalPN (x:_) Id [a,a0,a1] = return $ VId (Path x a) a0 a1 +evalPN (x:_) IdP [_,_,p,a0,a1] = return $ VId p a0 a1 +evalPN (x:_) Refl [_,a] = return $ Path x a +evalPN (x:_) TransU [_,_,p,t] = + comM (appName p x) (return (Box up x t [])) +evalPN (x:_) TransInvU [_,_,p,t] = + comM (appName p x) (return (Box down x t [])) +evalPN (x:_) TransURef [a,t] = Path x <$> fill a (Box up x t []) +evalPN (x:_) TransUEquivEq [_,b,f,_,_,u] = do + fu <- app f u + Path x <$> fill b (Box up x fu []) -- TODO: Check this! +evalPN (x:y:_) CSingl [a,u,v,p] = do + pv <- appName p y + theta <- fill a (Box up y u [((x,down),u),((x,up),pv)]) + omega <- theta `face` (y,up) + return $ Path x (VSPair omega (Path y theta)) +-- evalPN (x:_) Ext [_,b,f,g,p] = return $ Path x $ VExt x b f g p +evalPN (x:_) HExt [_,b,f,g,p] = return $ Path x $ VHExt x b f g p +evalPN _ Inh [a] = return $ VInh a +evalPN _ Inc [_,t] = return $ VInc t +evalPN (x:_) Squash [_,r,s] = return $ Path x $ VSquash x r s +evalPN _ InhRec [_,b,p,phi,a] = inhrec b p phi a +evalPN (x:_) EquivEq [a,b,f,s,t] = return $ Path x $ VEquivEq x a b f s t +evalPN (x:y:_) EquivEqRef [a,s,t] = + return $ Path y $ Path x $ VEquivSquare x y a s t +evalPN (x:_) MapOnPath [_,_,f,_,_,p] = + Path x <$> appM (return f) (appName p x) +evalPN (x:_) MapOnPathD [_,_,f,_,_,p] = + Path x <$> appM (return f) (appName p x) +evalPN (x:_) AppOnPath [_,_,_,_,_,_,p,q] = + Path x <$> appM (appName p x) (appName q x) +evalPN (x:_) MapOnPathS [_,_,_,f,_,_,p,_,_,q] = + Path x <$> appM (appM (pure f) (appName p x)) (appName q x) +evalPN _ Circle [] = return VCircle +evalPN _ Base [] = return VBase +evalPN (x:_) Loop [] = return $ Path x $ VLoop x +evalPN _ CircleRec [f,b,l,s] = circlerec f b l s +evalPN _ I [] = return VI +evalPN _ I0 [] = return VI0 +evalPN _ I1 [] = return VI1 +evalPN (x:_) Line [] = return $ Path x $ VLine x +evalPN _ IntRec [f,s,e,l,u] = intrec f s e l u +evalPN _ u _ = error ("evalPN " ++ show u) + + +appS1 :: Val -> Val -> Name -> Eval Val +appS1 f p x | x `elem` [0,1] = appName p x +appS1 f p x = do + let y = fresh (p,(f,x)) + q <- appName p y + a <- appName p 0 + b <- appName p 1 + newBox <- Box down y b <$> + sequenceSnd [ ((x,down),q `face` (x,down)) + , ((x,up),b `face` (x,up))] + fb <- app f VBase + fl <- app f (VLoop y) + tu <- fillM (return VU) (Box down y fb <$> + sequenceSnd [ ((x,down),fl `face` (x,down)) + , ((x,up),fb `face` (x,up))]) + com tu newBox + +-- Compute the face of an environment +faceEnv :: OEnv -> Side -> Eval OEnv +faceEnv e xd = mapOEnvM (`face` xd) e + +faceName :: Name -> Side -> Name +faceName 0 _ = 0 +faceName 1 _ = 1 +faceName x (y,d) | x == y = d + | otherwise = x + +-- Compute the face of a value +face :: Val -> Side -> Eval Val +face u xdir@(x,dir) = + let fc v = v `face` xdir in case u of + VU -> return VU + Ter t e -> do e' <- e `faceEnv` xdir + eval e' t + VId a v0 v1 -> VId <$> fc a <*> fc v0 <*> fc v1 + Path y v | x == y -> return u + | otherwise -> Path y <$> fc v + -- VExt y b f g p | x == y && dir == down -> return f + -- | x == y && dir == up -> return g + -- | otherwise -> + -- VExt y <$> fc b <*> fc f <*> fc g <*> fc p + VHExt y b f g p | x == y && dir == down -> return f + | x == y && dir == up -> return g + | otherwise -> + VHExt y <$> fc b <*> fc f <*> fc g <*> fc p + VPi a f -> VPi <$> fc a <*> fc f + VSigma a f -> VSigma <$> fc a <*> fc f + VSPair a b -> VSPair <$> fc a <*> fc b + VInh v -> VInh <$> fc v + VInc v -> VInc <$> fc v + VSquash y v0 v1 | x == y && dir == down -> return v0 + | x == y && dir == up -> return v1 + | otherwise -> VSquash y <$> fc v0 <*> fc v1 + VCon c us -> VCon c <$> mapM fc us + VEquivEq y a b f s t | x == y && dir == down -> return a + | x == y && dir == up -> return b + | otherwise -> + VEquivEq y <$> fc a <*> fc b <*> fc f <*> fc s <*> fc t + VPair y a v | x == y && dir == down -> return a + | x == y && dir == up -> fc v + | otherwise -> VPair y <$> fc a <*> fc v + VEquivSquare y z a s t | x == y -> return a + | x == z && dir == down -> return a + | x == z && dir == up -> do + let idV = Ter (Lam (noLoc "x") (Var "x")) oEmpty + return $ VEquivEq y a a idV s t + | otherwise -> + VEquivSquare y z <$> fc a <*> fc s <*> fc t + VSquare y z v | x == y -> fc v + | x == z && dir == down -> fc v + | x == z && dir == up -> do + v' <- fc v + VPair y <$> v' `face` (y,down) <*> pure v' + | otherwise -> VSquare y z <$> fc v + Kan Fill a b@(Box dir' y v nvs) + | x /= y && x `notElem` nonPrincipal b -> fillM (fc a) (mapBoxM fc b) + | x `elem` nonPrincipal b -> return $ lookBox (x,dir) b + | x == y && dir == mirror dir' -> return v + | otherwise -> com a b + VFillN a b@(Box dir' y v nvs) + | x /= y && x `notElem` nonPrincipal b -> fillM (fc a) (mapBoxM fc b) + | x `elem` nonPrincipal b -> return $ lookBox (x,dir) b + | x == y && dir == mirror dir' -> return v + | otherwise -> com a b + Kan Com a b@(Box dir' y v nvs) + | x == y -> return u + | x `notElem` nonPrincipal b -> comM (fc a) (mapBoxM fc b) + | x `elem` nonPrincipal b -> lookBox (x,dir) b `face` (y,dir') + VComN a b@(Box dir' y v nvs) + | x == y -> return u + | x `notElem` nonPrincipal b -> comM (fc a) (mapBoxM fc b) + | x `elem` nonPrincipal b -> lookBox (x,dir) b `face` (y,dir') + VComp b@(Box dir' y _ _) + | x == y -> return u + | x `notElem` nonPrincipal b -> VComp <$> mapBoxM fc b + | x `elem` nonPrincipal b -> lookBox (x,dir) b `face` (y,dir') + VFill z b@(Box dir' y v nvs) + | x == z -> return u + | x /= y && x `notElem` nonPrincipal b -> VFill z <$> mapBoxM fc b + | (x,dir) `elem` defBox b -> + lookBox (x,dir) <$> mapBoxM (`face` (z,down)) b + | x == y && dir == dir' -> + VComp <$> mapBoxM (`face` (z,up)) b + VInhRec b p h a -> join $ inhrec <$> fc b <*> fc p <*> fc h <*> fc a + VApp u v -> appM (fc u) (fc v) + VAppName u n -> do + trace ("face " ++ "\nxdir " ++ show xdir ++ + "\nu " ++ show u ++ "\nn " ++ show n) + appNameM (fc u) (faceName n xdir) + VSplit u v -> appM (fc u) (fc v) + VVar s d -> return $ VVar s [ faceName n xdir | n <- d ] + VFst p -> fstSVal <$> fc p + VSnd p -> sndSVal <$> fc p + VCircle -> return VCircle + VBase -> return VBase + VLoop y | x == y -> return VBase + | otherwise -> return $ VLoop y + VCircleRec f b l s -> join $ circlerec <$> fc f <*> fc b <*> fc l <*> fc s + VI -> return VI + VI0 -> return VI0 + VI1 -> return VI1 + VLine y + | x == y && dir == down -> return VI0 + | x == y && dir == up -> return VI1 + | otherwise -> return $ VLine y + VIntRec f s e l u -> join $ intrec <$> fc f <*> fc s <*> fc e <*> fc l <*> fc u + +faceM :: Eval Val -> Side -> Eval Val +faceM t xdir = do + v <- t + v `face` xdir + +unCompAs :: Val -> Name -> Box Val +unCompAs (VComp box) y = swap box (pname box) y +unCompAs v _ = error $ "unCompAs: " ++ show v ++ " is not a VComp" + +unFillAs :: Val -> Name -> Box Val +unFillAs (VFill x box) y = swap box x y +unFillAs v _ = error $ "unFillAs: " ++ show v ++ " is not a VFill" + +-- p(x) = q(x,z) +-- a(x) = q(x,0) b(x) = q(x,1) +-- q(0,y) connects a(0) and b(0) +-- we connect q(0,0) to q(1,1) +-- appDiag :: Val -> Val -> Name -> Val +-- appDiag tu p x | x `elem` [0,1] = appName p x +-- appDiag tu p x = +-- traceb ("appDiag " ++ "\ntu = " ++ show tu ++ "\np = " ++ show p ++ "\nx = " +-- -- ++ show x ++ " " ++ show y +-- -- ++ "\nq = " ++ show q) -- "\nnewBox =" ++ show newBox) +-- com tu newBox +-- where y = fresh (p,(tu,x)) +-- q = appName p y +-- a = appName p 0 +-- b = appName p 1 +-- newBox = Box down y b [((x,down),q `face` (x,down)),((x,up),b `face` (x,up))] + +cubeToBox :: Val -> Box () -> Eval (Box Val) +cubeToBox v = modBoxM (\nd _ -> v `face` nd) + +inhrec :: Val -> Val -> Val -> Val -> Eval Val +inhrec _ _ phi (VInc a) = app phi a +inhrec b p phi (VSquash x a0 a1) = do + let fc w d = w `face` (x,d) + b0 <- join $ inhrec <$> fc b down <*> fc p down <*> fc phi down <*> pure a0 + b1 <- join $ inhrec <$> fc b up <*> fc p up <*> fc phi up <*> pure a1 + let z = fresh [b,p,phi,b0,b1] + b0fill <- fill b (Box up x b0 []) + b0fillx1 <- b0fill `face` (x, up) + right <- appNameM (appM (appM (fc p up) (return b0fillx1)) (return b1)) z + com b (Box up z b0fill [((x,down),b0),((x,up),right)]) +inhrec b p phi (Kan ktype (VInh a) box) = do + let irec (j,dir) v = let fc v = v `face` (j,dir) + in join $ inhrec <$> fc b <*> fc p <*> fc phi <*> pure v + box' <- modBoxM irec box + kan ktype b box' +inhrec b p phi v = return $ VInhRec b p phi v -- v should be neutral + +circlerec :: Val -> Val -> Val -> Val -> Eval Val +circlerec _ b _ VBase = return b +circlerec f b l v@(VLoop x) = do + let y = fresh [f,b,l,v] + pxy <- appName l y + theta <- connection VCircle x y v + a <- app f theta + px1 <- pxy `face` (y,up) + p11 <- px1 `face` (x,up) + p0y <- pxy `face` (x,down) + trace ("circlerec " ++ "\nf = " ++ show f ++ "\nl = " ++ + show l ++ "\nx = " ++ show x) + com a (Box down y px1 [((x,down),p0y),((x,up),p11)]) +circlerec f b l v@(Kan ktype VCircle box) = do + let crec side u = let fc w = w `face` side + in join $ circlerec <$> fc f <*> fc b <*> fc l <*> pure u + fv <- app f v + box' <- modBoxM crec box + kan ktype fv box' +circlerec f b l v = return $ VCircleRec f b l v -- v should be neutral + +-- Assumes y is fresh and x fresh for a; constructs a connection +-- square with faces u (x), u (y), u (1), u (1). +connection :: Val -> Name -> Name -> Val -> Eval Val +connection a x y u = do + u1 <- u `face` (x,up) + ufill <- fill a (Box down y u1 [((x,down), swap u x y), ((x,up),u1)]) + let z = fresh ([x,y], [a,u]) + ufillzy = swap ufill x z + ufillzx = swap ufillzy y x + com a (Box down z u1 [ ((x,down),ufillzy), ((x,up),u1) + , ((y,down),ufillzx), ((y,up),u1)]) + +intrec :: Val -> Val -> Val -> Val -> Val -> Eval Val +intrec _ s _ _ VI0 = return s +intrec _ _ e _ VI1 = return e +intrec f s e l v@(VLine x) = do + let y = fresh [f,s,e,l,v] + pxy <- appName l y + theta <- connection VI x y v + a <- app f theta + px1 <- pxy `face` (y,up) + p11 <- px1 `face` (x,up) + p0y <- pxy `face` (x,down) + com a (Box down y px1 [((x,down),p0y),((x,up),p11)]) +intrec f s e l v@(Kan ktype VCircle box) = do + let irec side u = let fc w = w `face` side + in join $ intrec <$> fc f <*> fc s <*> + fc e <*> fc l <*> pure u + fv <- app f v + box' <- modBoxM irec box + kan ktype fv box' +intrec f s e l v = return $ VIntRec f s e l v -- v should be neutral + +kan :: KanType -> Val -> Box Val -> Eval Val +kan Fill = fill +kan Com = com + +isNeutralFill :: Val -> Box Val -> Eval Bool +isNeutralFill v box | isNeutral v = return True +isNeutralFill v@(Ter (PN (Undef _)) _) box = return True +isNeutralFill (Ter (Sum _ _) _) (Box _ _ v nvs) = + return $ isNeutral v || or [ isNeutral u | (_,u) <- nvs ] +isNeutralFill v@(Kan Com VU tbox') box@(Box d x _ _) = do + let nK = nonPrincipal tbox' + nJ = nonPrincipal box + nL = nJ \\ nK + aDs = if x `elem` nK then allDirs nL else (x,mirror d):allDirs nL + return $ or [ isNeutral (lookBox yc box) | yc <- aDs ] +isNeutralFill v@(Kan Fill VU tbox) box = + return $ or [ isNeutral (lookBox yc box) | yc <- defBox box \\ defBox tbox ] +isNeutralFill v@(VEquivSquare y z _ _ _) box@(Box d x _ _) = do + let nJ = nonPrincipal box + nL = nJ \\ [y,z] + aDs = if x `elem` [y,z] then allDirs nL else (x,mirror d) : allDirs nL + return $ or [ isNeutral (lookBox yc box) | yc <- aDs ] +isNeutralFill v@(VEquivEq z a b f s t) box@(Box d x vx nxs) + | d == down && z == x = isNeutral <$> app s vx + | otherwise = do -- TODO: check + let nJ = nonPrincipal box + nL = nJ \\ [z] + aDs = if x == z then allDirs nL else (x,mirror d) : allDirs nL + return $ or [ isNeutral (lookBox yc box) | yc <- aDs ] +isNeutralFill v box = return False + +-- Monadic version of fill +fillM :: Eval Val -> Eval (Box Val) -> Eval Val +fillM v b = do + v' <- v + b' <- b + fill v' b' + +fills :: [(Binder,Ter)] -> OEnv -> [Box Val] -> Eval [Val] +fills [] _ [] = return [] +fills ((x,a):as) e (box:boxes) = do + v <- fillM (eval e a) (return box) + vs <- fills as (oPair e (x,v)) boxes + return $ v : vs +fills _ _ _ = error "fills: different lengths of types and values" + +unPack :: Name -> Name -> (Name,Dir) -> Val -> Val +unPack x y (z,c) v | z /= x && z /= y = unSquare v + | z == y && c == up = sndVal v + | otherwise = v + +-- Kan filling +fill :: Val -> Box Val -> Eval Val +fill v box = do + b <- isNeutralFill v box + if b then return $ VFillN v box else fill' v box +fill' vid@(VId a v0 v1) box@(Box dir i v nvs) = do + let x = fresh (vid, box) + box' <- consBox (x,(v0,v1)) <$> mapBoxM (`appName` x) box + Path x <$> fillM (a `appName` x) (return box') +fill' (VSigma a f) box@(Box dir x v nvs) = do + u <- fill a (mapBox fstSVal box) + VSPair u <$> fillM (app f u) (return (mapBox sndSVal box)) +-- assumes cvs are constructor vals +fill' v@(Ter (Sum _ nass) env) box@(Box _ _ (VCon n _) _) = case getIdent n nass of + Just as -> do + let boxes = transposeBox $ mapBox unCon box + -- fill boxes for each argument position of the constructor + VCon n <$> fills as env boxes + Nothing -> error $ "fill: missing constructor in labelled sum " ++ n +fill' (VEquivSquare x y a s t) box@(Box dir x' vx' nvs) = + VSquare x y <$> fill a (modBox (unPack x y) box) +fill' veq@(VEquivEq x a b f s t) box@(Box dir z vz nvs) + | x /= z && x `notElem` nonPrincipal box = do + trace "VEquivEq case 1" + ax0 <- fill a (mapBox fstVal box) + bx0 <- app f ax0 + let bx = mapBox sndVal box + bx' <- mapBoxM (`face` (x,up)) bx + bx1 <- fill b bx' --- independent of x + v <- fill b $ (x,(bx0,bx1)) `consBox` bx + return $ VPair x ax0 v + | x /= z && x `elem` nonPrincipal box = do + trace "VEquivEq case 2" + let ax0 = lookBox (x,down) box + + -- modification function + mf (ny,dy) vy | x /= ny = return (sndVal vy) + | dy == down = app f ax0 + | otherwise = return vy + + bx <- sequenceBox $ modBox mf box + VPair x ax0 <$> fill b bx + | x == z && dir == up = do + trace "VEquivEq case 3" + let ax0 = vz + bx0 <- app f ax0 + v <- fill b $ Box dir z bx0 [ (nnd,sndVal v) | (nnd,v) <- nvs ] + return $ VPair x ax0 v + | x == z && dir == down = do + trace "VEquivEq case 4" + gbsb <- app s vz + let (gb,sb) = (fstSVal gbsb, sndSVal gbsb) + y = fresh (veq, box) + vy <- appName sb x + + let vpTSq :: Name -> Dir -> Val -> Eval (Val,Val) + vpTSq nz dz (VPair z a0 v0) = do + let vp = VSPair a0 (Path z v0) + t0 <- t `face` (nz,dz) + b0 <- vz `face` (nz,dz) + l0sq0 <- appNameM (appM (app t0 b0) (return vp)) y + let (l0,sq0) = (fstSVal l0sq0, sndSVal l0sq0) + sq0x <- appName sq0 x + return (l0,sq0x) -- TODO: check the correctness of the square s0 + + -- TODO: Use modBox! + vsqs <- sequenceSnd [ ((n,d),vpTSq n d v) | ((n,d),v) <- nvs] + let box1 = Box up y gb [ (nnd,v) | (nnd,(v,_)) <- vsqs ] + afill <- fill a box1 + + acom <- afill `face` (y,up) + fafill <- app f afill + + let box2 = Box up y vy (((x,down),fafill) : ((x,up),vz) : + [ (nnd,v) | (nnd,(_,v)) <- vsqs ]) + bcom <- com b box2 + return $ VPair x acom bcom + | otherwise = error "fill EqEquiv" +fill' v@(Kan Com VU tbox') box@(Box dir x' vx' nvs') + | toAdd /= [] = do -- W.l.o.g. assume that box contains faces for + -- the non-principal sides of tbox. + + trace "Kan Com 1" + + let -- TODO: Is this correct? Do we have to consider the auxsides? + add :: Side -> Eval Val + add yc = do box' <- mapBoxM (`face` yc) box + fillM (lookBox yc tbox `face` (x,tdir)) (return box') + + -- Note: This could be done nicer by providing a monad instance for (,) + sides' <- sequence [ do m1 <- add (n,down) + m2 <- add (n,up) + return (n,(m1,m2)) | n <- toAdd ] + + fill v (sides' `appendBox` box) + | x' `notElem` nK = do + trace "Kan Com 2" + + principal <- fill tx (mapBox (pickout (x,tdir')) boxL) + nonprincipal <- + sequence [ do pyc <- principal `face` yc + let side = [((x,tdir),lookBox yc box),((x,tdir'),pyc)] + v' <- fill (lookBox yc tbox) + (side `appendSides` mapBox (pickout yc) boxL) + return (yc,v') + | yc <- allDirs nK ] + + return $ VComp (Box tdir x principal nonprincipal) + | x' `elem` nK = do + trace "Kan Com 3" + + let -- assumes zc in defBox tbox + auxsides zc = [ (yd,pickout zc (lookBox yd box)) | yd <- allDirs nL ] + + -- extend input box along x with orientation tdir'; results + -- in the non-principal faces on the intersection of defBox + -- box and defBox tbox; note, that the intersection contains + -- (x',dir'), but not (x',dir) (and (x,_)) + npintbox <- modBoxM (\yc boxside -> fill (lookBox yc tbox) + (Box tdir' x boxside (auxsides yc))) + (subBox (nK `intersect` nJ) box) + + npintfacebox <- mapBoxM (`face` (x,tdir')) npintbox + principal <- fill tx (auxsides (x,tdir') `appendSides` npintfacebox) + nplp <- principal `face` (x',dir) + fnpintboxs <- sequence [ do fv <- v `face` (x',dir) + return (yc,fv) + | (yc,v) <- sides npintbox ] + + let nplnp = auxsides (x',dir) ++ fnpintboxs + -- the missing non-principal face on side (x',dir) + v' <- fill (lookBox (x',dir) tbox) (Box tdir x nplp nplnp) + let nplast = ((x',dir),v') + + return $ VComp (Box tdir x principal (nplast:fromBox npintbox)) + where nK = nonPrincipal tbox + nJ = nonPrincipal box + z = fresh (tbox', box) + -- x is z + tbox@(Box tdir x tx nvs) = swap tbox' (pname tbox') z + toAdd = nK \\ (x' : nJ) + nL = nJ \\ nK + boxL = subBox nL box + dir' = mirror dir + tdir' = mirror tdir + -- asumes zd is in the sides of tbox + pickout zd vcomp = lookBox zd (unCompAs vcomp z) + +fill' v@(Kan Fill VU tbox@(Box tdir x tx nvs)) box@(Box dir x' vx' nvs') + -- the cases should be (in order): + -- 1) W.l.o.g. K subset x', J + -- 2) x' = x & dir = tdir + -- 3) x' = x & dir = mirror tdir + -- 4) x `notElem` J (maybe combine with 1?) + -- 5) x' `notElem` K + -- 6) x' `elem` K + | toAdd /= [] = do + trace "Kan Fill VU Case 1" -- W.l.o.g. nK subset x':nJ + let add :: Side -> Eval Val + add zc = fillM (return (lookBox zc tbox)) (mapBoxM (`face` zc) box) + newSides <- sequenceSnd [ (zc,add zc) | zc <- allDirs toAdd ] + fill v (newSides `appendSides` box) + | x == x' && dir == tdir = do -- assumes K subset x',J + trace "Kan Fill VU Case 2" + let boxp = lookBox (x,dir') box -- is vx' + principal <- fill (lookBox (x',tdir') tbox) + (Box up z boxp (auxsides (x',tdir'))) + nonprincipal <- + sequenceSnd [ (zc,do let principzc = lookBox zc box + fpzc <- principal `face` zc + -- "degenerate" along z! + ppzc <- principzc `face` (x,tdir) + let sides = [((x,tdir'),fpzc),((x,tdir),ppzc)] + fill (lookBox zc tbox) + (Box up z principzc (sides ++ auxsides zc))) + | zc <- allDirs nK ] + return $ VFill z (Box tdir x principal nonprincipal) + + | x == x' && dir == mirror tdir = do -- assumes K subset x',J + trace "Kan Fill VU Case 3" + let -- the principal side of box must be a VComp + -- should be safe given the neutral test at the beginning + upperbox = unCompAs (lookBox (x,dir') box) x + nonprincipal <- sequenceSnd + [ (zc,do let top = lookBox zc upperbox + bottom = lookBox zc box + princ <- top `face` (x,tdir) -- same as: bottom `face` (x,tdir) + let sides = [((z,down),bottom),((z,up),top)] + fill (lookBox zc tbox) (Box tdir' x princ -- "degenerate" along z! + (sides ++ auxsides zc))) + | zc <- allDirs nK ] + nonprincipalfaces <- sequenceSnd [ (zc,u `face` (x,dir)) + | (zc,u) <- nonprincipal ] + principal <- fill (lookBox (x,tdir') tbox) + (Box up z (lookBox (x,tdir') upperbox) + (nonprincipalfaces ++ auxsides (x,tdir'))) + return $ VFill z (Box tdir x principal nonprincipal) + | x `notElem` nJ = do -- assume x /= x' and K subset x', J + trace "Kan Fill VU Case 4" + comU <- v `face` (x,tdir) -- Kan Com VU (tbox (z=up)) + let fcbox = mapBoxM (`face` (x,tdir)) box + xsides <- sequenceSnd [ ((x,tdir), fillM (return comU) fcbox) + , ((x,tdir'), + fillM (return (lookBox (x,tdir') tbox)) fcbox) ] + + fill v (xsides `appendSides` box) + | x' `notElem` nK = do -- assumes x,K subset x',J + trace "Kan Fill VU Case 5" + let -- TODO: Do we need a fresh name? (Probably not: doesn't depend on x!) + xaux = unCompAs (lookBox (x,tdir) box) x + boxprinc = unFillAs (lookBox (x',dir') box) z + princnp = [((z,up),lookBox (x,tdir') xaux),((z,down),lookBox (x,tdir') box)] + ++ auxsides (x,tdir') + principal <- fill (lookBox (x,tdir') tbox) -- tx + (Box dir x' (lookBox (x,tdir') boxprinc) princnp) + nonprincipal <- sequence + [ do let yup = lookBox yc xaux + fyup <- yup `face` (x,tdir) + fpyc <- principal `face` yc + let np = [ ((z,up),yup), ((z,down),lookBox yc box) + , ((y,c), fyup) -- deg along z! + , ((y,mirror c), fpyc) ] ++ auxsides yc + fb <- fill (lookBox yc tbox) (Box dir x' (lookBox yc boxprinc) np) + return (yc, fb) + | yc@(y,c) <- allDirs nK] + return $ VFill z (Box tdir x principal nonprincipal) + | x' `elem` nK = do -- assumes x,K subset x',J + trace "Kan Fill VU Case 6" + -- surprisingly close to the last case of the Kan-Com-VU filling + let upperbox = unCompAs (lookBox (x,dir') box) x + npintbox <- modBoxM (\zc downside -> + let bottom = lookBox zc box + top = lookBox zc upperbox + princ = downside -- same as bottom `face` (x',tdir) and + -- top `face` (x',tdir) + sides = [((z,down),bottom),((z,up),top)] + in fill (lookBox zc tbox) (Box tdir' x princ -- deg along z! + (sides ++ auxsides zc))) + (subBox (nK `intersect` nJ) box) + + let npint = fromBox npintbox + npintfacebox <- mapBoxM (`face` (x,tdir)) npintbox + let principalbox = ([ ((z,down),lookBox (x,tdir') box) + , ((z,up) ,lookBox (x,tdir') upperbox)] + ++ auxsides (x,tdir')) + `appendSides` npintfacebox + principal <- fill tx principalbox + let nplp = lookBox (x',dir) upperbox + nplnp <- sequenceSnd $ + [ ((x',dir), nplp `face` (x',dir)) -- deg along z! + , ((x', dir'),principal `face` (x',dir)) ] + ++ map (second return) (auxsides (x',dir)) + ++ [ (zc,u `face` (x',dir)) | (zc,u) <- sides npintbox ] + fb <- fill (lookBox (x',dir) tbox) (Box down z nplp nplnp) + + return $ VFill z (Box tdir x principal (((x',dir),fb) : npint)) + where z = fresh (v, box) + nK = nonPrincipal tbox + nJ = nonPrincipal box + toAdd = nK \\ (x' : nJ) + nL = nJ \\ (x : nK) + dir' = mirror dir + tdir' = mirror tdir + -- asumes zc is in the sides of tbox + pickout zc vfill = lookBox zc (unFillAs vfill z) + -- asumes zc is in the sides of tbox + auxsides zc = [ (yd,pickout zc (lookBox yd box)) | yd <- allDirs nL ] +fill' v b = return $ Kan Fill v b + +-- Composition (ie., the face of fill which is created) +com :: Val -> Box Val -> Eval Val +com u box = do + b <- isNeutralFill u box + if b then return $ VComN u box else com' u box +com' vid@VId{} box@(Box dir i _ _) = fill vid box `faceM` (i,dir) +com' vsigma@VSigma{} box@(Box dir i _ _) = fill vsigma box `faceM` (i,dir) +com' veq@VEquivEq{} box@(Box dir i _ _) = fill veq box `faceM` (i,dir) +com' u@(Kan Com VU _) box@(Box dir i _ _) = fill u box `faceM` (i,dir) +com' u@(Kan Fill VU _) box@(Box dir i _ _) = fill u box `faceM` (i,dir) +com' ter@Ter{} box@(Box dir i _ _) = fill ter box `faceM` (i,dir) +com' v box = return $ Kan Com v box + +-- Monadic version of com +comM :: Eval Val -> Eval (Box Val) -> Eval Val +comM t b = do + v <- t + b' <- b + com v b' + +-- Conversion functions +(<&&>) :: Monad m => m Bool -> m Bool -> m Bool +(<&&>) = liftM2 (&&) + +(<==>) :: (Monad m, Eq a) => a -> a -> m Bool +a <==> b = return (a == b) + +andM :: [Eval Bool] -> Eval Bool +andM = liftM and . sequence + +conv :: Int -> Val -> Val -> Eval Bool +conv k VU VU = return True +conv k (Ter (Lam x u) e) (Ter (Lam x' u') e') = do + let v = mkVar k $ support (e, e') + convM (k+1) (eval (oPair e (x,v)) u) (eval (oPair e' (x',v)) u') +conv k (Ter (Lam x u) e) u' = do + let v = mkVar k $ support e + convM (k+1) (eval (oPair e (x,v)) u) (app u' v) +conv k u' (Ter (Lam x u) e) = do + let v = mkVar k $ support e + convM (k+1) (app u' v) (eval (oPair e (x,v)) u) +conv k (Ter (Split p _) e) (Ter (Split p' _) e') = + liftM ((p == p') &&) $ convEnv k e e' +conv k (Ter (Sum p _) e) (Ter (Sum p' _) e') = + ((p == p') &&) <$> convEnv k e e' +conv k (Ter (PN (Undef p)) e) (Ter (PN (Undef p')) e') = + liftM ((p == p') &&) $ convEnv k e e' +conv k (VPi u v) (VPi u' v') = do + let w = mkVar k $ support [u,u',v,v'] + conv k u u' <&&> convM (k+1) (app v w) (app v' w) +conv k (VSigma u v) (VSigma u' v') = do + let w = mkVar k $ support [u,u',v,v'] + conv k u u' <&&> convM (k+1) (app v w) (app v' w) +conv k (VId a u v) (VId a' u' v') = andM [conv k a a', conv k u u', conv k v v'] +conv k (Path x u) (Path x' u') = conv k (swap u x z) (swap u' x' z) + where z = fresh (u,u') +conv k (Path x u) p' = convM k (return (swap u x z)) (appName p' z) + where z = fresh u +conv k p (Path x' u') = convM k (appName p z) (return (swap u' x' z)) + where z = fresh u' +-- conv k (VExt x b f g p) (VExt x' b' f' g' p') = +-- andM [x <==> x', conv k b b', conv k f f', conv k g g', conv k p p'] +conv k (VHExt x b f g p) (VHExt x' b' f' g' p') = + andM [x <==> x', conv k b b', conv k f f', conv k g g', conv k p p'] +conv k (VFst u) (VFst u') = conv k u u' +conv k (VSnd u) (VSnd u') = conv k u u' +conv k (VInh u) (VInh u') = conv k u u' +conv k (VInc u) (VInc u') = conv k u u' +conv k (VSquash x u v) (VSquash x' u' v') = + andM [x <==> x', conv k u u', conv k v v'] +conv k (VCon c us) (VCon c' us') = + liftM (\bs -> (c == c') && and bs) (zipWithM (conv k) us us') +conv k (Kan Fill v box) (Kan Fill v' box') = + conv k v v' <&&> convBox k box box' +conv k (Kan Com v box) (Kan Com v' box') = + andM [conv k v v', convBox k (swap box x y) (swap box' x' y)] + where y = fresh ((v,v'),(box,box')) + (x,x') = (pname box, pname box') +conv k (VComN v box) (VComN v' box') = + andM [conv k v v', convBox k (swap box x y) (swap box' x' y)] + where y = fresh ((v,v'),(box,box')) + (x,x') = (pname box, pname box') +conv k (VFillN v box) (VFillN v' box') = + andM [conv k v v', convBox k (swap box x y) (swap box' x' y)] + where y = fresh ((v,v'),(box,box')) + (x,x') = (pname box, pname box') +conv k (VEquivEq x a b f s t) (VEquivEq x' a' b' f' s' t') = + andM [x <==> x', conv k a a', conv k b b', + conv k f f', conv k s s', conv k t t'] +conv k (VEquivSquare x y a s t) (VEquivSquare x' y' a' s' t') = + andM [x <==> x', y <==> y', conv k a a', conv k s s', conv k t t'] +conv k (VPair x u v) (VPair x' u' v') = + andM [x <==> x', conv k u u', conv k v v'] +conv k (VSquare x y u) (VSquare x' y' u') = + andM [x <==> x', y <==> y', conv k u u'] +conv k (VComp box) (VComp box') = + convBox k (swap box x y) (swap box' x' y) + where y = fresh (box,box') + (x,x') = (pname box, pname box') +conv k (VFill x box) (VFill x' box') = + convBox k (swap box x y) (swap box' x' y) + where y = fresh (box,box') +conv k (VSPair u v) (VSPair u' v') = conv k u u' <&&> conv k v v' +conv k (VSPair u v) w = + conv k u (fstSVal w) <&&> conv k v (sndSVal w) +conv k w (VSPair u v) = + conv k (fstSVal w) u <&&> conv k (sndSVal w) v +conv k (VApp u v) (VApp u' v') = conv k u u' <&&> conv k v v' +conv k (VAppName u x) (VAppName u' x') = conv k u u' <&&> (x <==> x') +conv k (VSplit u v) (VSplit u' v') = conv k u u' <&&> conv k v v' +conv k (VVar x d) (VVar x' d') = return $ (x == x') && (d == d') +conv k (VInhRec b p phi v) (VInhRec b' p' phi' v') = + andM [conv k b b', conv k p p', conv k phi phi', conv k v v'] +conv k VCircle VCircle = return True +conv k VBase VBase = return True +conv k (VLoop x) (VLoop y) = x <==> y +conv k (VCircleRec f b l v) (VCircleRec f' b' l' v') = + andM [conv k f f', conv k b b', conv k l l', conv k v v'] +conv k VI VI = return True +conv k VI0 VI0 = return True +conv k VI1 VI1 = return True +conv k (VLine x) (VLine y) = x <==> y +conv k (VIntRec f s e l u) (VIntRec f' s' e' l' u') = + andM [conv k f f', conv k s s', conv k e e', conv k l l', conv k u u'] +conv k _ _ = return False + +-- Monadic version of conv +convM :: Int -> Eval Val -> Eval Val -> Eval Bool +convM k v1 v2 = do + v1' <- v1 + v2' <- v2 + conv k v1' v2' + +convBox :: Int -> Box Val -> Box Val -> Eval Bool +convBox k box@(Box d pn _ ss) box'@(Box d' pn' _ ss') = + if (d == d') && (pn == pn') && (sort np == sort np') + then and <$> sequence [ conv k (lookBox s box) (lookBox s box') + | s <- defBox box ] + else return False + where (np, np') = (nonPrincipal box, nonPrincipal box') + +convEnv :: Int -> OEnv -> OEnv -> Eval Bool +convEnv k e e' = liftM and $ zipWithM (conv k) (valOfOEnv e) (valOfOEnv e') diff --git a/Exp.cf b/Exp.cf --- a/Exp.cf +++ b/Exp.cf @@ -3,65 +3,57 @@ comment "--" ; comment "{-" "-}" ; -layout "where", "let", "of", "split" ; -- , "mutual" ; +layout "where", "let", "split", "mutual" ; layout stop "in" ; -- Do not use layout toplevel as it makes pExp fail! -Module. Module ::= "module" AIdent "where" "{" [Imp] [Def] "}" ; +Module. Module ::= "module" AIdent "where" "{" [Imp] [Decl] "}" ; Import. Imp ::= "import" AIdent ; separator Imp ";" ; -Def. Def ::= AIdent [Arg] "=" ExpWhere ; -DefTDecl. Def ::= AIdent ":" Exp ; -DefData. Def ::= "data" AIdent [Arg] "=" [Sum] ; - --- Anders: This is kind of an ugly way to get mutual to work, but at least it --- works, I guess there is a bug in bnfc when handling layout blocks and lists --- TODO: Bug report? --- DefMutual. Def ::= Def "mutual" "{" [Def] "}" ; --- Mutual. Def ::= "mutual" "{" [Def] "}" ; - -separator Def ";" ; +DeclDef. Decl ::= AIdent [AIdent] "=" ExpWhere ; +DeclType. Decl ::= AIdent ":" Exp ; +DeclPrim. Decl ::= "primitive" AIdent ":" Exp ; +DeclData. Decl ::= "data" AIdent [AIdent] "=" [Label] ; +DeclMutual. Decl ::= "mutual" "{" [Decl] "}" ; +DeclOpaque. Decl ::= "opaque" AIdent ; +DeclTransp. Decl ::= "transparent" AIdent ; +separator Decl ";" ; -Where. ExpWhere ::= Exp "where" "{" [Def] "}" ; +Where. ExpWhere ::= Exp "where" "{" [Decl] "}" ; NoWhere. ExpWhere ::= Exp ; -Let. Exp ::= "let" "{" [Def] "}" "in" Exp ; -Lam. Exp ::= "\\" [Binder] "->" Exp ; +Let. Exp ::= "let" "{" [Decl] "}" "in" Exp ; +Lam. Exp ::= "\\" AIdent [AIdent] "->" Exp ; Split. Exp ::= "split" "{" [Branch] "}" ; Fun. Exp1 ::= Exp2 "->" Exp1 ; -Pi. Exp1 ::= [PiDecl] "->" Exp1 ; +Pi. Exp1 ::= [PseudoTDecl] "->" Exp1 ; +Sigma. Exp1 ::= [PseudoTDecl] "*" Exp1 ; App. Exp2 ::= Exp2 Exp3 ; -Var. Exp3 ::= Arg ; +Fst. Exp3 ::= Exp3 ".1" ; +Snd. Exp3 ::= Exp3 ".2" ; +Pair. Exp3 ::= "(" Exp "," Exp ")" ; +Var. Exp3 ::= AIdent ; U. Exp3 ::= "U" ; -Undef. Exp3 ::= "undefined" ; -PN. Exp3 ::= "PN" ; coercions Exp 3 ; -Binder. Binder ::= Arg ; -separator nonempty Binder "" ; - --- Like Binder, but may be empty -Arg. Arg ::= AIdent ; -NoArg. Arg ::= "_" ; -terminator Arg "" ; - -- Branches -Branch. Branch ::= AIdent [Arg] "->" ExpWhere ; +Branch. Branch ::= AIdent [AIdent] "->" ExpWhere ; separator Branch ";" ; -- Labelled sum alternatives -Sum. Sum ::= AIdent [VDecl] ; -separator Sum "|" ; +Label. Label ::= AIdent [VTDecl] ; +separator Label "|" ; -- Telescopes -VDecl. VDecl ::= "(" [Binder] ":" Exp ")" ; -terminator VDecl "" ; +VTDecl. VTDecl ::= "(" AIdent [AIdent] ":" Exp ")" ; +terminator VTDecl "" ; --- Nonempty telescopes with Exp:s, this is hack to avoid ambiguities in the --- grammar when parsing Pi -PiDecl. PiDecl ::= "(" Exp ":" Exp ")" ; -terminator nonempty PiDecl "" ; +-- Nonempty telescopes with Exp:s, this is hack to avoid ambiguities +-- in the grammar when parsing Pi +PseudoTDecl. PseudoTDecl ::= "(" Exp ":" Exp ")" ; +terminator nonempty PseudoTDecl "" ; -position token AIdent (letter(letter|digit|'\''|'_')*) ; +position token AIdent ((letter|'\''|'_')(letter|digit|'\''|'_')*) ; +terminator AIdent "" ; diff --git a/Exp/Lex.x b/Exp/Lex.x --- a/Exp/Lex.x +++ b/Exp/Lex.x @@ -2,6 +2,7 @@ -- This Alex file was machine-generated by the BNF converter { {-# OPTIONS -fno-warn-incomplete-patterns #-} +{-# OPTIONS_GHC -w #-} module Exp.Lex where @@ -19,7 +20,7 @@ $u = [\0-\255] -- universal: any character @rsyms = -- symbols and non-identifier-like reserved words - \{ | \} | \; | \= | \: | \\ | \- \> | \( | \) | \_ | \| + \{ | \} | \; | \= | \: | \\ | \- \> | \* | \. "1" | \. "2" | \( | \, | \) | \| :- "--" [.]* ; -- Toss single line comments @@ -27,7 +28,7 @@ $white+ ; @rsyms { tok (\p s -> PT p (eitherResIdent (TV . share) s)) } -$l ($l | $d | \' | \_)* { tok (\p s -> PT p (eitherResIdent (T_AIdent . share) s)) } +($l | \' | \_)($l | $d | \' | \_)* { tok (\p s -> PT p (eitherResIdent (T_AIdent . share) s)) } $l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) } @@ -88,7 +89,7 @@ | s > a = treeFind right | s == a = t -resWords = b "data" 11 (b "=" 6 (b "->" 3 (b ")" 2 (b "(" 1 N N) N) (b ";" 5 (b ":" 4 N N) N)) (b "\\" 9 (b "U" 8 (b "PN" 7 N N) N) (b "_" 10 N N))) (b "undefined" 17 (b "let" 14 (b "in" 13 (b "import" 12 N N) N) (b "split" 16 (b "module" 15 N N) N)) (b "|" 20 (b "{" 19 (b "where" 18 N N) N) (b "}" 21 N N))) +resWords = b "import" 14 (b ".2" 7 (b "," 4 (b ")" 2 (b "(" 1 N N) (b "*" 3 N N)) (b ".1" 6 (b "->" 5 N N) N)) (b "U" 11 (b ";" 9 (b ":" 8 N N) (b "=" 10 N N)) (b "data" 13 (b "\\" 12 N N) N))) (b "split" 21 (b "mutual" 18 (b "let" 16 (b "in" 15 N N) (b "module" 17 N N)) (b "primitive" 20 (b "opaque" 19 N N) N)) (b "{" 24 (b "where" 23 (b "transparent" 22 N N) N) (b "}" 26 (b "|" 25 N N) N))) where b s n = let bs = id s in B bs (TS bs n) diff --git a/Exp/Par.y b/Exp/Par.y --- a/Exp/Par.y +++ b/Exp/Par.y @@ -18,25 +18,30 @@ %token '(' { PT _ (TS _ 1) } ')' { PT _ (TS _ 2) } - '->' { PT _ (TS _ 3) } - ':' { PT _ (TS _ 4) } - ';' { PT _ (TS _ 5) } - '=' { PT _ (TS _ 6) } - 'PN' { PT _ (TS _ 7) } - 'U' { PT _ (TS _ 8) } - '\\' { PT _ (TS _ 9) } - '_' { PT _ (TS _ 10) } - 'data' { PT _ (TS _ 11) } - 'import' { PT _ (TS _ 12) } - 'in' { PT _ (TS _ 13) } - 'let' { PT _ (TS _ 14) } - 'module' { PT _ (TS _ 15) } - 'split' { PT _ (TS _ 16) } - 'undefined' { PT _ (TS _ 17) } - 'where' { PT _ (TS _ 18) } - '{' { PT _ (TS _ 19) } - '|' { PT _ (TS _ 20) } - '}' { PT _ (TS _ 21) } + '*' { PT _ (TS _ 3) } + ',' { PT _ (TS _ 4) } + '->' { PT _ (TS _ 5) } + '.1' { PT _ (TS _ 6) } + '.2' { PT _ (TS _ 7) } + ':' { PT _ (TS _ 8) } + ';' { PT _ (TS _ 9) } + '=' { PT _ (TS _ 10) } + 'U' { PT _ (TS _ 11) } + '\\' { PT _ (TS _ 12) } + 'data' { PT _ (TS _ 13) } + 'import' { PT _ (TS _ 14) } + 'in' { PT _ (TS _ 15) } + 'let' { PT _ (TS _ 16) } + 'module' { PT _ (TS _ 17) } + 'mutual' { PT _ (TS _ 18) } + 'opaque' { PT _ (TS _ 19) } + 'primitive' { PT _ (TS _ 20) } + 'split' { PT _ (TS _ 21) } + 'transparent' { PT _ (TS _ 22) } + 'where' { PT _ (TS _ 23) } + '{' { PT _ (TS _ 24) } + '|' { PT _ (TS _ 25) } + '}' { PT _ (TS _ 26) } L_AIdent { PT _ (T_AIdent _) } L_err { _ } @@ -47,7 +52,7 @@ AIdent :: { AIdent} : L_AIdent { AIdent (mkPosToken $1)} Module :: { Module } -Module : 'module' AIdent 'where' '{' ListImp ListDef '}' { Module $2 $5 $6 } +Module : 'module' AIdent 'where' '{' ListImp ListDecl '}' { Module $2 $5 $6 } Imp :: { Imp } @@ -60,33 +65,38 @@ | Imp ';' ListImp { (:) $1 $3 } -Def :: { Def } -Def : AIdent ListArg '=' ExpWhere { Def $1 (reverse $2) $4 } - | AIdent ':' Exp { DefTDecl $1 $3 } - | 'data' AIdent ListArg '=' ListSum { DefData $2 (reverse $3) $5 } +Decl :: { Decl } +Decl : AIdent ListAIdent '=' ExpWhere { DeclDef $1 (reverse $2) $4 } + | AIdent ':' Exp { DeclType $1 $3 } + | 'primitive' AIdent ':' Exp { DeclPrim $2 $4 } + | 'data' AIdent ListAIdent '=' ListLabel { DeclData $2 (reverse $3) $5 } + | 'mutual' '{' ListDecl '}' { DeclMutual $3 } + | 'opaque' AIdent { DeclOpaque $2 } + | 'transparent' AIdent { DeclTransp $2 } -ListDef :: { [Def] } -ListDef : {- empty -} { [] } - | Def { (:[]) $1 } - | Def ';' ListDef { (:) $1 $3 } +ListDecl :: { [Decl] } +ListDecl : {- empty -} { [] } + | Decl { (:[]) $1 } + | Decl ';' ListDecl { (:) $1 $3 } ExpWhere :: { ExpWhere } -ExpWhere : Exp 'where' '{' ListDef '}' { Where $1 $4 } +ExpWhere : Exp 'where' '{' ListDecl '}' { Where $1 $4 } | Exp { NoWhere $1 } Exp :: { Exp } -Exp : 'let' '{' ListDef '}' 'in' Exp { Let $3 $6 } - | '\\' ListBinder '->' Exp { Lam $2 $4 } +Exp : 'let' '{' ListDecl '}' 'in' Exp { Let $3 $6 } + | '\\' AIdent ListAIdent '->' Exp { Lam $2 (reverse $3) $5 } | 'split' '{' ListBranch '}' { Split $3 } | Exp1 { $1 } Exp1 :: { Exp } Exp1 : Exp2 '->' Exp1 { Fun $1 $3 } - | ListPiDecl '->' Exp1 { Pi $1 $3 } + | ListPseudoTDecl '->' Exp1 { Pi $1 $3 } + | ListPseudoTDecl '*' Exp1 { Sigma $1 $3 } | Exp2 { $1 } @@ -96,34 +106,16 @@ Exp3 :: { Exp } -Exp3 : Arg { Var $1 } +Exp3 : Exp3 '.1' { Fst $1 } + | Exp3 '.2' { Snd $1 } + | '(' Exp ',' Exp ')' { Pair $2 $4 } + | AIdent { Var $1 } | 'U' { U } - | 'undefined' { Undef } - | 'PN' { PN } | '(' Exp ')' { $2 } -Binder :: { Binder } -Binder : Arg { Binder $1 } - - -ListBinder :: { [Binder] } -ListBinder : Binder { (:[]) $1 } - | Binder ListBinder { (:) $1 $2 } - - -Arg :: { Arg } -Arg : AIdent { Arg $1 } - | '_' { NoArg } - - -ListArg :: { [Arg] } -ListArg : {- empty -} { [] } - | ListArg Arg { flip (:) $1 $2 } - - Branch :: { Branch } -Branch : AIdent ListArg '->' ExpWhere { Branch $1 (reverse $2) $4 } +Branch : AIdent ListAIdent '->' ExpWhere { Branch $1 (reverse $2) $4 } ListBranch :: { [Branch] } @@ -132,32 +124,37 @@ | Branch ';' ListBranch { (:) $1 $3 } -Sum :: { Sum } -Sum : AIdent ListVDecl { Sum $1 (reverse $2) } +Label :: { Label } +Label : AIdent ListVTDecl { Label $1 (reverse $2) } -ListSum :: { [Sum] } -ListSum : {- empty -} { [] } - | Sum { (:[]) $1 } - | Sum '|' ListSum { (:) $1 $3 } +ListLabel :: { [Label] } +ListLabel : {- empty -} { [] } + | Label { (:[]) $1 } + | Label '|' ListLabel { (:) $1 $3 } -VDecl :: { VDecl } -VDecl : '(' ListBinder ':' Exp ')' { VDecl $2 $4 } +VTDecl :: { VTDecl } +VTDecl : '(' AIdent ListAIdent ':' Exp ')' { VTDecl $2 (reverse $3) $5 } -ListVDecl :: { [VDecl] } -ListVDecl : {- empty -} { [] } - | ListVDecl VDecl { flip (:) $1 $2 } +ListVTDecl :: { [VTDecl] } +ListVTDecl : {- empty -} { [] } + | ListVTDecl VTDecl { flip (:) $1 $2 } -PiDecl :: { PiDecl } -PiDecl : '(' Exp ':' Exp ')' { PiDecl $2 $4 } +PseudoTDecl :: { PseudoTDecl } +PseudoTDecl : '(' Exp ':' Exp ')' { PseudoTDecl $2 $4 } -ListPiDecl :: { [PiDecl] } -ListPiDecl : PiDecl { (:[]) $1 } - | PiDecl ListPiDecl { (:) $1 $2 } +ListPseudoTDecl :: { [PseudoTDecl] } +ListPseudoTDecl : PseudoTDecl { (:[]) $1 } + | PseudoTDecl ListPseudoTDecl { (:) $1 $2 } + + +ListAIdent :: { [AIdent] } +ListAIdent : {- empty -} { [] } + | ListAIdent AIdent { flip (:) $1 $2 } diff --git a/MTT.hs b/MTT.hs deleted file mode 100644 --- a/MTT.hs +++ /dev/null @@ -1,334 +0,0 @@ --- miniTT, with recursive definitions -module MTT where - -import Data.Either -import Data.List -import Data.Maybe -import Control.Monad -import Debug.Trace -import Control.Monad.Trans.Error hiding (throwError) -import Control.Monad.Trans.Reader -import Control.Monad.Identity -import Control.Monad.Error (throwError) -import Control.Applicative - -import Pretty - -type Label = String - --- Branch of the form: c x1 .. xn -> e -type Brc = (Label,([String],Exp)) - --- Telescope (x1 : A1) .. (xn : An) -type Tele = [(String,Exp)] - --- Labelled sum: c (x1 : A1) .. (xn : An) -type LblSum = [(Label,Tele)] - --- Mix values and expressions -type Val = Exp - --- Context gives type values to identifiers -type Ctxt = [(String,Val)] - --- Mutual recursive definitions: (x1 : A1) .. (xn : An) and x1 = e1 .. xn = en -type Def = (Tele,[(String,Exp)]) - --- De Bruijn levels -mkVar :: Int -> Exp -mkVar k = Var (genName k) - -genName :: Int -> String -genName n = 'X' : show n - -type Prim = (Integer,String) - -data Exp = Comp Exp Env -- for closures - | App Exp Exp - | Pi Exp Exp - | Lam String Exp - | Def Exp Def - | Var String - | U - | Con String [Exp] - | Fun Prim [Brc] - | Sum Prim LblSum - | Undef Prim - | EPrim Prim [Exp] -- used for reification - deriving (Eq) - -instance Show Exp where - show = showExp - -data Env = Empty - | Pair Env (String,Val) - | PDef Def Env -- for handling recursive definitions, - -- see getE - deriving (Eq) - -instance Show Env where - show = showEnv - -lets :: [Def] -> Exp -> Exp -lets [] e = e -lets (d:ds) e = Def (lets ds e) d - -defs :: Env -> Exp -> Exp -defs Empty e = e -defs (PDef d env) e = defs env (Def e d) -defs env _ = - error $ "defs: environment should a list of definitions " ++ show env - -upds :: Env -> [(String,Val)] -> Env -upds = foldl Pair - -eval :: Exp -> Env -> Val -eval (Def e d) s = eval e (PDef d s) -eval (App t1 t2) s = app (eval t1 s) (eval t2 s) -eval (Pi a b) s = Pi (eval a s) (eval b s) -eval (Con c ts) s = Con c (map (`eval` s) ts) -eval (Var k) s = getE k s -eval U _ = U -eval t s = Comp t s - -evals :: [(String,Exp)] -> Env -> [(String,Val)] -evals es r = map (\(x,e) -> (x,eval e r)) es - -app :: Val -> Val -> Val -app (Comp (Lam x b) s) u = eval b (Pair s (x,u)) -app a@(Comp (Fun _ ces) r) b@(Con c us) = case lookup c ces of - Just (xs,e) -> eval e (upds r (zip xs us)) - Nothing -> error $ "app: " ++ show a ++ " " ++ show b -app f u = App f u - -getE :: String -> Env -> Exp -getE x (Pair _ (y,u)) | x == y = u -getE x (Pair s _) = getE x s -getE x r@(PDef d r1) = getE x (upds r1 (evals (snd d) r)) - -addC :: Ctxt -> (Tele,Env) -> [(String,Val)] -> Ctxt -addC gam _ [] = gam -addC gam ((y,a):as,nu) ((x,u):xus) = - addC ((x,eval a nu):gam) (as,Pair nu (y,u)) xus - --- Extract the type of a label as a closure -getLblType :: String -> Exp -> Typing (Tele, Env) -getLblType c (Comp (Sum _ cas) r) = case lookup c cas of - Just as -> return (as,r) - Nothing -> throwError ("getLblType " ++ show c) -getLblType c u = throwError ("expected a data type for the constructor " - ++ c ++ " but got " ++ show u) - --- Environment for type checker -data TEnv = TEnv { index :: Int -- for de Bruijn levels - , env :: Env - , ctxt :: Ctxt } - deriving Eq - -tEmpty :: TEnv -tEmpty = TEnv 0 Empty [] - --- Type checking monad -type Typing a = ReaderT TEnv (ErrorT String Identity) a - -runTyping :: Typing a -> TEnv -> ErrorT String Identity a -runTyping = runReaderT - --- Used in the interaction loop -runDef :: TEnv -> Def -> Either String TEnv -runDef lenv d = do - runIdentity $ runErrorT $ runTyping (checkDef d) lenv - return $ addDef d lenv - -runDefs :: TEnv -> [Def] -> Either String TEnv -runDefs = foldM runDef - -runInfer :: TEnv -> Exp -> Either String Exp -runInfer lenv e = runIdentity $ runErrorT $ runTyping (checkInfer e) lenv - -addTypeVal :: (String,Val) -> TEnv -> TEnv -addTypeVal p@(x,_) (TEnv k rho gam) = TEnv (k+1) (Pair rho (x,mkVar k)) (p:gam) - -addType :: (String,Exp) -> TEnv -> TEnv -addType (x,a) tenv@(TEnv _ rho _) = addTypeVal (x,eval a rho) tenv - -addBranch :: [(String,Val)] -> (Tele,Env) -> TEnv -> TEnv -addBranch nvs (tele,env) (TEnv k rho gam) = - TEnv (k + length nvs) (upds rho nvs) (addC gam (tele,env) nvs) - -addDef :: Def -> TEnv -> TEnv -addDef d@(ts,es) (TEnv k rho gam) = - let rho1 = PDef d rho - in TEnv k rho1 (addC gam (ts,rho) (evals es rho1)) - -addTele :: Tele -> TEnv -> TEnv -addTele xas lenv = foldl (flip addType) lenv xas - -getIndex :: Typing Int -getIndex = index <$> ask - -getFresh :: Typing Exp -getFresh = mkVar <$> getIndex - -getEnv :: Typing Env -getEnv = env <$> ask - -getCtxt :: Typing Ctxt -getCtxt = ctxt <$> ask - -(=?=) :: Typing Exp -> Exp -> Typing () -m =?= s2 = do - s1 <- m - unless (s1 == s2) $ throwError (show s1 ++ " =/= " ++ show s2) - -checkDef :: Def -> Typing () -checkDef (xas,xes) = trace ("checking definition " ++ show (map fst xes)) $ do - checkTele xas - rho <- getEnv - local (addTele xas) $ checks (xas,rho) (map snd xes) - -checkTele :: Tele -> Typing () -checkTele [] = return () -checkTele ((x,a):xas) = do - check U a - local (addType (x,a)) $ checkTele xas - -check :: Val -> Exp -> Typing () -check a t = case (a,t) of - (_,Con c es) -> do - (bs,nu) <- getLblType c a - checks (bs,nu) es - (U,Pi a (Lam x b)) -> do - check U a - local (addType (x,a)) $ check U b - (U,Sum _ bs) -> sequence_ [checkTele as | (_,as) <- bs] - (Pi (Comp (Sum _ cas) nu) f,Fun _ ces) -> - if map fst ces == map fst cas - then sequence_ [ checkBranch (as,nu) f brc - | (brc, (_,as)) <- zip ces cas ] - else throwError "case branches does not match the data type" - (Pi a f,Lam x t) -> do - var <- getFresh - local (addTypeVal (x,a)) $ check (app f var) t - (_,Def e d) -> do - checkDef d - local (addDef d) $ check a e - (_,Undef _) -> return () - _ -> do - k <- getIndex - (reifyExp k <$> checkInfer t) =?= reifyExp k a - -checkBranch :: (Tele,Env) -> Val -> Brc -> Typing () -checkBranch (xas,nu) f (c,(xs,e)) = do - k <- getIndex - let l = length xas - let us = map mkVar [k..k+l-1] - local (addBranch (zip xs us) (xas,nu)) $ check (app f (Con c us)) e - -checkInfer :: Exp -> Typing Exp -checkInfer e = case e of - U -> return U -- U : U - Var n -> do - gam <- getCtxt - case lookup n gam of - Just v -> return v - Nothing -> throwError $ show n ++ " is not declared!" - App t u -> do - c <- checkInfer t - case c of - Pi a f -> do - check a u - rho <- getEnv - return (app f (eval u rho)) - _ -> throwError $ show c ++ " is not a product" - Def t d -> do - checkDef d - local (addDef d) $ checkInfer t - _ -> throwError ("checkInfer " ++ show e) - -checks :: (Tele,Env) -> [Exp] -> Typing () -checks _ [] = return () -checks ((x,a):xas,nu) (e:es) = do - check (eval a nu) e - rho <- getEnv - checks (xas,Pair nu (x,eval e rho)) es -checks _ _ = throwError "checks" - --- Reification of a value to an expression -reifyExp :: Int -> Val -> Exp -reifyExp _ U = U -reifyExp k (Comp (Lam x t) r) = - Lam (genName k) $ reifyExp (k+1) (eval t (Pair r (x,mkVar k))) -reifyExp k v@(Var l) = v -reifyExp k (App u v) = App (reifyExp k u) (reifyExp k v) -reifyExp k (Pi a f) = Pi (reifyExp k a) (reifyExp k f) -reifyExp k (Con n ts) = Con n (map (reifyExp k) ts) -reifyExp k (Comp (Fun prim _) r) = EPrim prim (reifyEnv k r) -reifyExp k (Comp (Sum prim _) r) = EPrim prim (reifyEnv k r) -reifyExp k (Comp (Undef prim) r) = EPrim prim (reifyEnv k r) - -reifyEnv :: Int -> Env -> [Exp] -reifyEnv _ Empty = [] -reifyEnv k (Pair r (_,u)) = reifyEnv k r ++ [reifyExp k u] -reifyEnv k (PDef ts r) = reifyEnv k r - --- Not used since we have U : U --- checkTs :: [(String,Exp)] -> Typing () --- checkTs [] = return () --- checkTs ((x,a):xas) = do --- checkType a --- local (addType (x,a)) (checkTs xas) --- --- checkType :: Exp -> Typing () --- checkType t = case t of --- U -> return () --- Pi a (Lam x b) -> do --- checkType a --- local (addType (x,a)) (checkType b) --- _ -> checkInfer t =?= U - --- a show function - -showExp :: Exp -> String -showExp1 :: Exp -> String - -showExps :: [Exp] -> String -showExps = hcat . map showExp1 - -showExp1 U = "U" -showExp1 (Con c []) = c -showExp1 (Var x) = x -showExp1 u@(Fun {}) = showExp u -showExp1 u@(Sum {}) = showExp u -showExp1 u@(Undef {}) = showExp u -showExp1 u@(EPrim {}) = showExp u -showExp1 u@(Comp {}) = showExp u -showExp1 u = parens $ showExp u - -showEnv :: Env -> String -showEnv Empty = "" -showEnv (Pair env (x,u)) = parens $ showEnv1 env ++ show u -showEnv (PDef xas env) = showEnv env - -showEnv1 Empty = "" -showEnv1 (Pair env (x,u)) = showEnv1 env ++ showExp u ++ ", " -showEnv1 (PDef xas env) = showEnv env - - -showExp e = case e of - App e0 e1 -> showExp e0 <+> showExp1 e1 - Pi e0 e1 -> "Pi" <+> showExps [e0,e1] - Lam x e -> "\\" ++ x ++ "->" <+> showExp e - Def e d -> showExp e <+> "where" <+> showDef d - Var x -> x - U -> "U" - Con c es -> c <+> showExps es - Fun (n,str) _ -> str ++ show n - Sum (_,str) _ -> str - Undef (n,str) -> str ++ show n - EPrim (n,str) es -> str ++ show n <+> showExps es - Comp e env -> showExp1 e <+> showEnv env - -showDef :: Def -> String -showDef (_,xts) = ccat (map (\(x,t) -> x <+> "=" <+> showExp t) xts) - diff --git a/MTTtoCTT.hs b/MTTtoCTT.hs deleted file mode 100644 --- a/MTTtoCTT.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE TupleSections #-} --- Tranlates the terms of MiniTT into the cubical syntax. -module MTTtoCTT where - -import qualified CTT as I -import Control.Monad.Error -import Control.Applicative -import Control.Arrow -import MTT - --- For an expression t, returns (u,ts) where u is no application --- and t = u ts -unApps :: Exp -> (Exp,[Exp]) -unApps (App r s) = let (t,ts) = unApps r in (t, ts ++ [s]) -unApps t = (t,[]) - -apps :: I.Ter -> [I.Ter] -> I.Ter -apps = foldl I.App - -lams :: [String] -> I.Ter -> I.Ter -lams bs t = foldr I.Lam t bs - -translate :: Exp -> Either String I.Ter -translate U = return I.U -translate (Undef prim) = return $ I.Undef prim -translate (Lam x t) = I.Lam x <$> translate t -translate (Pi a f) = I.Pi <$> translate a <*> translate f -translate t@(App _ _) = - let (hd,rest) = unApps t - in case hd of - Var n | n `elem` reservedNames -> translatePrimitive n rest - _ -> apps <$> translate hd <*> mapM translate rest -translate (Def e (_,ts)) = -- ignores types for now - I.Where <$> translate e <*> mapM (\(n,e') -> (n,) <$> translate e') ts -translate (Var n) | n `elem` reservedNames = translatePrimitive n [] - | otherwise = return (I.Var n) -translate (Con n ts) = I.Con n <$> mapM translate ts -translate (Fun pr bs) = - I.Branch pr <$> mapM (\(n,(ns,b)) -> (n,) <$> (ns,) <$> translate b) bs -translate (Sum pr lbs) = - I.LSum pr <$> sequence [ (n,) <$> mapM (\(n',e') -> (n',) <$> translate e') tl - | (n,tl) <- lbs ] -translate t = throwError $ "translate: can not handle " ++ show t - --- Gets a name for a primitive notion, a list of arguments which might be too --- long and returns the corresponding concept in the internal syntax. Applies --- the rest of the terms if the list of terms is longer than the arity. -translatePrimitive :: String -> [Exp] -> Either String I.Ter -translatePrimitive n ts = case lookup n primHandle of - Just (arity,_) | length ts < arity -> - let r = arity - length ts - binders = map (\n -> '_' : show n) [1..r] - vars = map Var binders - in lams binders <$> translatePrimitive n (ts ++ vars) - Just (arity,handler) -> - let (args,rest) = splitAt arity ts - in apps <$> handler args <*> mapM translate rest - Nothing -> - throwError ("unknown primitive: " ++ show n) - --- | Primitive notions - --- name, (arity for Exp, handler) -type PrimHandle = [(String, (Int, [Exp] -> Either String I.Ter))] - -primHandle :: PrimHandle -primHandle = - [ ("Id", (3, primId)) - , ("refl", (2, primRefl)) - , ("funExt", (5, primExt)) - , ("J", (6, primJ)) - , ("Jeq", (4, primJeq)) - , ("inh", (1, primInh)) - , ("inc", (2, primInc)) - , ("squash", (3, primSquash)) - , ("inhrec", (5, primInhRec)) - , ("equivEq", (5, primEquivEq)) - , ("transport", (4, primTransport)) - , ("transportRef", (2, primTransportRef)) - , ("equivEqRef", (3, primEquivEqRef)) - , ("transpEquivEq", (6, primTransUEquivEq)) - ] - -reservedNames :: [String] -reservedNames = map fst primHandle - -primId :: [Exp] -> Either String I.Ter -primId [a,x,y] = I.Id <$> translate a <*> translate x <*> translate y - -primRefl :: [Exp] -> Either String I.Ter -primRefl [a,x] = I.Refl <$> translate x - -primExt :: [Exp] -> Either String I.Ter -primExt [a,b,f,g,ptwise] = - I.Ext <$> translate b <*> translate f <*> translate g <*> translate ptwise - -primJ :: [Exp] -> Either String I.Ter -primJ [a,u,c,w,v,p] = - I.J <$> translate a <*> translate u <*> translate c - <*> translate w <*> translate v <*> translate p - -primJeq :: [Exp] -> Either String I.Ter -primJeq [a,u,c,w] = - I.JEq <$> translate a <*> translate u <*> translate c <*> translate w - -primInh :: [Exp] -> Either String I.Ter -primInh [a] = I.Inh <$> translate a - -primInc :: [Exp] -> Either String I.Ter -primInc [a,x] = I.Inc <$> translate x - -primSquash :: [Exp] -> Either String I.Ter -primSquash [a,x,y] = I.Squash <$> translate x <*> translate y - -primInhRec :: [Exp] -> Either String I.Ter -primInhRec [a,b,p,f,x] = - I.InhRec <$> translate b <*> translate p <*> translate f <*> translate x - -primEquivEq :: [Exp] -> Either String I.Ter -primEquivEq [a,b,f,s,t] = - I.EquivEq <$> translate a <*> translate b <*> translate f - <*> translate s <*> translate t - -primTransport :: [Exp] -> Either String I.Ter -primTransport [a,b,p,x] = I.TransU <$> translate p <*> translate x - -primTransportRef :: [Exp] -> Either String I.Ter -primTransportRef [a,x] = I.TransURef <$> translate x - -primEquivEqRef :: [Exp] -> Either String I.Ter -primEquivEqRef [a,s,t] = I.EquivEqRef <$> translate a <*> translate s <*> translate t - -primTransUEquivEq :: [Exp] -> Either String I.Ter -primTransUEquivEq [a,b,f,s,t,x] = - I.TransUEquivEq <$> translate a <*> translate b <*> translate f - <*> translate s <*> translate t <*> translate x diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -4,6 +4,7 @@ import Control.Monad.Error import Data.List import System.Directory +import System.FilePath import System.Environment import System.Console.GetOpt import System.Console.Haskeline @@ -14,29 +15,28 @@ import Exp.Abs hiding (NoArg) import Exp.Layout import Exp.ErrM -import MTTtoCTT -import Concrete -import qualified MTT as A +import Concrete hiding (getConstrs) +import qualified TypeChecker as TC import qualified CTT as C import qualified Eval as E type Interpreter a = InputT IO a -- Flag handling -data Flag = Debug +data Flag = Debug | Help | Version deriving (Eq,Show) options :: [OptDescr Flag] -options = [ Option "d" ["debug"] (NoArg Debug) "Run in debugging mode" ] - -parseOpts :: [String] -> IO ([Flag],[String]) -parseOpts argv = case getOpt Permute options argv of - (o,n,[]) -> return (o,n) - (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) - where header = "Usage: cubical [OPTION...] [FILES...]" +options = [ Option "d" ["debug"] (NoArg Debug) "run in debugging mode" + , Option "" ["help"] (NoArg Help) "print help" + , Option "" ["version"] (NoArg Version) "print version number" ] -defaultPrompt :: String -defaultPrompt = "> " +-- Version number, welcome message, usage and prompt strings +version, welcome, usage, prompt :: String +version = "0.2.0" +welcome = "cubical, version: " ++ version ++ " (:h for help)\n" +usage = "Usage: cubical [options] \nOptions:" +prompt = "> " lexer :: String -> [Token] lexer = resolveLayout True . myLexer @@ -46,87 +46,117 @@ putStrLn $ "\n[Abstract Syntax]\n\n" ++ show tree putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree +-- Used for auto completion +searchFunc :: [String] -> String -> [Completion] +searchFunc ns str = map simpleCompletion $ filter (str `isPrefixOf`) ns + +settings :: [String] -> Settings IO +settings ns = Settings + { historyFile = Nothing + , complete = completeWord Nothing " \t" $ return . searchFunc ns + , autoAddHistory = True } + main :: IO () main = do args <- getArgs - (flags,files) <- parseOpts args - runInputT defaultSettings $ runInterpreter (Debug `elem` flags) files + case getOpt Permute options args of + (flags,files,[]) + | Help `elem` flags -> putStrLn $ usageInfo usage options + | Version `elem` flags -> putStrLn version + | otherwise -> case files of + [] -> do + putStrLn welcome + runInputT (settings []) (loop flags [] [] TC.verboseEnv) + [f] -> do + putStrLn welcome + putStrLn $ "Loading " ++ show f + initLoop flags f + _ -> putStrLn $ "Input error: zero or one file expected\n\n" ++ + usageInfo usage options + (_,_,errs) -> putStrLn $ "Input error: " ++ concat errs ++ "\n" ++ + usageInfo usage options --- (not ok,loaded,already loaded defs) -> to load -> (newnotok, newloaded, newdefs) -imports :: ([String],[String],[Def]) -> String -> Interpreter ([String],[String],[Def]) -imports st@(notok,loaded,defs) f - | f `elem` notok = do - outputStrLn $ "Looping imports in " ++ f - return ([],[],[]) +-- Initialize the main loop +initLoop :: [Flag] -> FilePath -> IO () +initLoop flags f = do + -- Parse and type-check files + (_,_,mods) <- imports True ([],[],[]) f + -- Translate to CTT + let res = runResolver $ resolveModules mods + case res of + Left err -> do + putStrLn $ "Resolver failed: " ++ err + runInputT (settings []) (loop flags f [] TC.verboseEnv) + Right (adefs,names) -> do + (merr,tenv) <- TC.runDeclss (Debug `elem` flags) TC.verboseEnv adefs + case merr of + Just err -> putStrLn $ "Type checking failed: " ++ err + Nothing -> return () + putStrLn "File loaded." + -- Compute names for auto completion + runInputT (settings [n | ((n,_),_) <- names]) (loop flags f names tenv) + +-- The main loop +loop :: [Flag] -> FilePath -> [(C.Binder,SymKind)] -> TC.TEnv -> Interpreter () +loop flags f names tenv@(TC.TEnv _ rho _ _) = do + input <- getInputLine prompt + case input of + Nothing -> outputStrLn help >> loop flags f names tenv + Just ":q" -> return () + Just ":r" -> lift $ initLoop flags f + Just (':':'l':' ':str) + | ' ' `elem` str -> do outputStrLn "Only one file allowed after :l" + loop flags f names tenv + | otherwise -> lift $ initLoop flags str + Just (':':'c':'d':' ':str) -> do lift (setCurrentDirectory str) + loop flags f names tenv + Just ":h" -> outputStrLn help >> loop flags f names tenv + Just str -> case pExp (lexer str) of + Bad err -> outputStrLn ("Parse error: " ++ err) >> loop flags f names tenv + Ok exp -> + case runResolver $ local (insertBinders names) $ resolveExp exp of + Left err -> do outputStrLn ("Resolver failed: " ++ err) + loop flags f names tenv + Right body -> do + x <- liftIO $ TC.runInfer (Debug `elem` flags) tenv body + case x of + Left err -> do outputStrLn ("Could not type-check: " ++ err) + loop flags f names tenv + Right _ -> do + e <- liftIO $ E.runEval (Debug `elem` flags) $ E.eval rho body + outputStrLn ("EVAL: " ++ show e) + loop flags f names tenv + +-- (not ok,loaded,already loaded defs) -> to load -> +-- (new not ok, new loaded, new defs) +-- the bool determines if it should be verbose or not +imports :: Bool -> ([String],[String],[Module]) -> String -> + IO ([String],[String],[Module]) +imports v st@(notok,loaded,mods) f + | f `elem` notok = putStrLn ("Looping imports in " ++ f) >> return ([],[],[]) | f `elem` loaded = return st | otherwise = do - b <- lift $ doesFileExist f + b <- doesFileExist f + let prefix = dropFileName f if not b - then do - outputStrLn ("The file " ++ f ++ " does not exist") - return ([],[],[]) + then putStrLn (f ++ " does not exist") >> return ([],[],[]) else do - s <- lift $ readFile f + s <- readFile f let ts = lexer s case pModule ts of Bad s -> do - outputStrLn $ "Parse Failed in file " ++ show f ++ "\n" ++ show s + putStrLn $ "Parse failed in " ++ show f ++ "\n" ++ show s return ([],[],[]) - Ok mod@(Module _ imps defs') -> do - let imps' = [ unIdent s ++ ".cub" | Import s <- imps ] - (notok1,loaded1,def1) <- foldM imports (f:notok,loaded,defs) imps' - outputStrLn $ "Parsed file " ++ show f ++ " successfully!" - return (notok,f:loaded1,def1 ++ defs') - --- The Bool is intended to be whether or not to run in debug mode -runInterpreter :: Bool -> [FilePath] -> Interpreter () -runInterpreter b fs = case fs of - [f] -> do - -- parse and type-check files - (_,_,defs) <- imports ([],[],[]) f - -- Compute all constructors - let cs = concat [ [ unIdent n | Sum n _ <- lbls] | DefData _ _ lbls <- defs ] - let res = runResolver (local (insertConstrs cs) (resolveDefs defs)) - case res of - Left err -> do - outputStrLn $ "Resolver failed: " ++ err - loop [] A.tEmpty - Right adefs -> case A.runDefs A.tEmpty adefs of - Left err -> do - outputStrLn $ "Type checking failed: " ++ err - loop [] A.tEmpty - Right tenv -> do - outputStrLn "File loaded." - loop cs tenv - _ -> do - outputStrLn $ "Exactly one file expected: " ++ show fs - loop [] A.tEmpty - where - loop :: [String] -> A.TEnv -> Interpreter () - loop cs tenv@(A.TEnv _ rho _) = do - input <- getInputLine defaultPrompt - case input of - Nothing -> outputStrLn help >> loop cs tenv - Just ":q" -> return () - Just ":r" -> runInterpreter b fs - Just (':':'l':' ':str) -> runInterpreter b (words str) - Just (':':'c':'d':' ':str) -> lift (setCurrentDirectory str) >> loop cs tenv - Just ":h" -> outputStrLn help >> loop cs tenv - Just str -> let ts = lexer str in - case pExp ts of - Bad err -> outputStrLn ("Parse error: " ++ err) >> loop cs tenv - Ok exp -> - case runResolver (local (const (Env cs)) (resolveExp exp)) of - Left err -> outputStrLn ("Resolver failed: " ++ err) >> loop cs tenv - Right body -> - case A.runInfer tenv body of - Left err -> outputStrLn ("Could not type-check: " ++ err) >> loop cs tenv - Right _ -> - case translate (A.defs rho body) of - Left err -> outputStrLn ("Could not translate to internal syntax: " ++ err) >> - loop cs tenv - Right t -> let value = E.eval C.Empty t in - outputStrLn ("EVAL: " ++ show value) >> loop cs tenv + Ok mod@(Module id imp decls) -> + let name = unAIdent id + imp_cub = [prefix ++ unAIdent i ++ ".cub" | Import i <- imp] + in do + when (name /= dropExtension (takeFileName f)) $ + error $ "Module name mismatch " ++ show (f,name) + (notok1,loaded1,mods1) <- + foldM (imports v) (f:notok,loaded,mods) imp_cub + when v $ putStrLn $ "Parsed " ++ show f ++ " successfully!" + return (notok,f:loaded1,mods1 ++ [mod]) help :: String help = "\nAvailable commands:\n" ++ diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,11 +1,16 @@ -all: - ghc --make -O2 -o cubical Main.hs +OPT=2 + +all: + ghc --make -O$(OPT) -o cubical Main.hs bnfc: - bnfc -d Exp.cf + bnfc --haskell -d Exp.cf happy -gca Exp/Par.y alex -g Exp/Lex.x - ghc --make Exp/Test.hs -o Exp/Test + ghc --make -O$(OPT) Exp/Test.hs -o Exp/Test clean: rm -f *.log *.aux *.hi *.o cubical cd Exp && rm -f ParExp.y LexExp.x LexhExp.hs \ ParExp.hs PrintExp.hs AbsExp.hs *.o *.hi + +tests: + runghc Tests.hs diff --git a/Pretty.hs b/Pretty.hs --- a/Pretty.hs +++ b/Pretty.hs @@ -3,6 +3,7 @@ -------------------------------------------------------------------------------- -- | Pretty printing combinators. Use the same names as in the pretty library. + (<+>) :: String -> String -> String [] <+> y = y x <+> [] = x @@ -18,11 +19,13 @@ ccat :: [String] -> String ccat [] = [] ccat [x] = x -ccat (x:xs) = x <+> ", " <+> ccat xs +ccat (x:xs) = x <+> "," <+> ccat xs parens :: String -> String -parens p = "(" ++ p ++ ")" +parens [] = "" +parens p = "(" ++ p ++ ")" -- Angled brackets, not present in pretty library. abrack :: String -> String -abrack p = "<" ++ p ++ ">" +abrack [] = "" +abrack p = "<" ++ p ++ ">" diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,7 +8,7 @@ INSTALL ------- -To install cubical a working Haskell and cabal installation are +To install cubical, a working Haskell and cabal installation are required. To build cubical go to the main directory and do `cabal install` @@ -19,15 +19,36 @@ `cabal build` -Alternatively one can also use the Makefile to build the system by typing: +Alternatively one can also use the Makefile to build the system by +typing: `make bnfc && make` -However this requires that the following Haskell packages are installed: +However this requires that the following Haskell packages are +installed: mtl, haskeline, directory, BNFC, alex, happy +**Note:** In order to make the mutual keyword work a patched version +of BNFC is needed. To install this download the patched version from + +[https://github.com/simhu/bnfc](https://github.com/simhu/bnfc) + +and then `cabal install` it. + +###Emacs mode: + +To install syntax highlighting for cubical files load the cubical.el +file into emacs. In order to load it automatically add + +`(load-file "/path/to/cubical.el")` + +`(add-to-list 'auto-mode-alist '("\\.cub\\'" . cub-mode))` + +to your .emacs file. + + USAGE ----- @@ -35,9 +56,9 @@ `cubical ` -In the interaction loop type :h to get a list of available commands. -Note that the current directory will be taken as the search path for -the imports. +To enable the debugging mode add the -d flag. In the interaction loop +type :h to get a list of available commands. Note that the current +directory will be taken as the search path for the imports. OVERVIEW @@ -57,16 +78,16 @@ * if the expression is well-typed it is translated to the cubical syntax and evaluated by a "cubical abstract machine", which computes its semantics in cubical sets; the result is shown after - "EVAL:" (to disable the trace of the evaluation set the boolean - "debug" to False in Eval.hs); + "EVAL:" (to enable the trace of the evaluation run cubical with the + -d flag); During type-checking, we consider the primitives listed in -examples/primitive.cub as non interpreted constants. The type-checker -is in the file MTT.hs and is rudimentary (300 lines), without good +examples/primitive.cub as non interpreted constants. The type-checker +is in the file TypeChecker.hs and is rudimentary (200 lines), without good error messages. These primitives however have a meaning in cubical sets, and the -evaluation function computes this meaning. This semantics/evaluation +evaluation function computes this meaning. This semantics/evaluation is described in the file Eval.hs, which is the main file. The most complex part corresponds to the computations witnessing that the universe has Kan filling operations. @@ -75,7 +96,9 @@ presentation of cubical sets as nominal sets with 01-substitutions (see A. Pitts' note, references listed below). +The primitives needed to get univalence [are](notes/allprim.txt). + DESCRIPTION OF THE LANGUAGE --------------------------- @@ -92,21 +115,28 @@ * function defined by case `f = split c1 x1 ... xn -> e1 | c2 ... -> ... | ...` + * sigma types `(x:A) * B`, with the pair constructor (e1,e2) + and eliminators e.1 and e.2 + * a universe `U` and assume `U:U` for simplicity * let/where: `let D in e` where D is a list of definitions an alternative syntax is `e where D` -* `undefined` like in Haskell + * `undefined` like in Haskell + * mutual definitions (this requires a patched version of BNFC, see + the install instructions above). + + The syntax allows Landin's offside rule similar to Haskell. The basic (untyped) language has a direct simple denotational semantics. Type theory works with the total part of this language (it is possible to define totality at the denotational semantics level). -Our evaluator works in a nominal version of this semantics. The -type-checker assumes that we work in this total part, however, -there is no termination check. +Our evaluator works in a nominal version of this semantics. The +type-checker assumes that we work in this total part, however, there +is no termination check. DESCRIPTION OF THE SEMANTICS/EVALUATION @@ -122,14 +152,14 @@ current implementation directions/names are represented by numbers). Operationally, a type is explained by giving what are its Kan filling -operation. For instance, we have to explain what are the Kan filling +operation. For instance, we have to explain what are the Kan filling for the dependent product. The main step for interpreting univalence is to transform an equivalence A -> B to a path in any direction x connecting A and B. This is a new basic element of the universe, called VEquivEq in the file Eval.hs which takes a name and arguments A,B,f and the proof that -f is an equivalence. The main part of the work is then to explain the +f is an equivalence. The main part of the work is then to explain the Kan filling operation for this new type. The Kan filling for the universe can be seen as a generalization of @@ -141,7 +171,7 @@ The directory examples contains some examples of proofs. The file examples/primitive.cub list the new primitives that have cubical set -semantics. These primitive notions imply the axiom of univalence. The +semantics. These primitive notions imply the axiom of univalence. The file examples/primitive.cub should be the basis of any development using univalence. @@ -157,7 +187,7 @@ N+1; the examples are testSN, testSN1, testSN2, testSN3. * The file testInh.cub contains examples of computation for the - propositional reflection. It gives an example test which produces + propositional reflection. It gives an example test which produces a (surprisingly complex) composition of squares in the universe. * The file quotient.cub contains an example of a computation from an @@ -178,35 +208,41 @@ test15. - -FURTHER WORK (non-exhaustive) ------------- - - * The Kan filling operations should be formally proved correct and - tested on higher inductive types. +NEWS (to be detailed) +---- * Some constants have a direct cubical semantics having better behavior w.r.t. equality. For instance the constant - `cong : (A B : U) (f : A -> B) (a b : A) (p : Id A a b) -> Id B (f a) (f b)` + `mapOnPath : (A B : U) (f : A -> B) (a b : A) + (p : Id A a b) -> Id B (f a) (f b)` has a semantics which satisfies the definitional equalities: - `cong (id A) = id A` + `mapOnPath (id A) = id A` - `cong (g o f) = (cong g) o (cong f)` + `mapOnPath (g o f) = (mapOnPath g) o (mapOnPath f)` - `cong f (refl A a) = refl B (f a)` + `mapOnPath f (refl A a) = refl B (f a)` - The evaluation should be used for conversion during type-checking, - and then we shall get these equalities as definitional. + The evaluation is now used for conversion during type-checking, + and then we get these equalities definitionally. - Some proofs are then much simpler, e.g. the proof of the Graduate - Lemma. + Some proofs are now much simpler than before, e.g. the proof of the + Graduate Lemma. - * Similarly we should have eta conversion and surjective pairing; - this can be obtained by normalization by evaluation. + * Similarly we also have eta conversion and surjective pairing. + * As a test, the particular case of the circle (S1) and the interval + (I) has been added. + + +FURTHER WORK (non-exhaustive) +------------ + + * The Kan filling operations should be formally proved correct and + tested on higher inductive types. + * For higher inductive types, like the circle or the sphere, it would be appropriate to *extend* the syntax of type theory, in order to get natural elimination rules (see the paper on cubical sets). @@ -216,26 +252,43 @@ to be an interesting proof-theoretical problem. -REFERENCES ----------- +REFERENCES AND NOTES +-------------------- * Voevodsky's home page on univalent foundation - * HoTT book + * HoTT book and webpage: + [http://homotopytypetheory.org/](http://homotopytypetheory.org/) * Type Theory in Color, J.P. Bernardy, G. Moulin * A simple type-theoretic language: Mini-TT, Th. Coquand, - Y. Kinoshita, B. Nordstrom and M. Takeyama + Y. Kinoshita, B. Nordström and M. Takeyama - * A cubical set model of type theory, M. Bezem, Th. Coquand and - S. Huber available at www.cse.chalmers.se/~coquand/model1.pdf + * [A cubical set model of type + theory](http://www.cse.chalmers.se/~coquand/model1.pdf), M. Bezem, + Th. Coquand and S. Huber. - * A property of contractible types, Th. Coquand available at - www.cse.chalmers.se/~coquand/contr.pdf + * [A remark on contractible family of + type](http://www.cse.chalmers.se/~coquand/contr.pdf), Th. Coquand. - * An equivalent presentation of the Bezem-Coquand-Huber category of - cubical sets, A. Pitts + This note explains how to derive univalence. + + * [An equivalent presentation of the Bezem-Coquand-Huber category of + cubical sets](http://arxiv.org/abs/1401.7807), A. Pitts. + + This gives a presentation of the cubical set model in nominal sets. + + * [Remark on singleton + types](http://www.cse.chalmers.se/~coquand/singl.pdf), Th. Coquand. + + * [Note on Kripke + model](http://www.cse.chalmers.se/~coquand/countermodel.pdf), M. Bezem + and Th. Coquand. + + * [Some connections between cubical sets and + parametricity](http://www.cse.chalmers.se/~coquand/param.pdf), + Th. Coquand. AUTHORS diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -7,7 +7,7 @@ main :: IO () main = do b <- doesFileExist "Exp/Abs.hs" - -- run bnfc if the Exp directory does not exist + -- run bnfc if Exp/Abs.hs does not exist when (not b) bnfc t1 <- getModificationTime "Exp.cf" t2 <- getModificationTime "Exp" @@ -16,7 +16,7 @@ defaultMain where bnfc = do - ret <- system "bnfc -d Exp.cf" + ret <- system "bnfc --haskell -d Exp.cf" case ret of ExitSuccess -> defaultMain ExitFailure n -> error $ "bnfc command not found or error" ++ show n diff --git a/TypeChecker.hs b/TypeChecker.hs new file mode 100644 --- /dev/null +++ b/TypeChecker.hs @@ -0,0 +1,250 @@ +module TypeChecker ( runDecls + , runDeclss + , runInfer + , TEnv(..) + , verboseEnv + , silentEnv + ) where + +import Data.Either +import Data.List +import Data.Maybe +import Data.Monoid hiding (Sum) +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Trans.Error hiding (throwError) +import Control.Monad.Trans.Reader +import Control.Monad.Error (throwError) +import Control.Applicative +import Pretty + +import CTT +import Eval + +trace :: String -> Typing () +trace s = do + b <- verbose <$> ask + when b $ liftIO (putStrLn s) + +-- Type checking monad +type Typing a = ReaderT TEnv (ErrorT String Eval) a + +runTyping :: Bool -> TEnv -> Typing a -> IO (Either String a) +runTyping debug env t = runEval debug $ runErrorT $ runReaderT t env + +-- Used in the interaction loop +runDecls :: Bool -> TEnv -> ODecls -> IO (Either String TEnv) +runDecls debug tenv d = runTyping debug tenv $ do + checkDecls d + addDecls d tenv + +runDeclss :: Bool -> TEnv -> [ODecls] -> IO (Maybe String,TEnv) +runDeclss _ tenv [] = return (Nothing, tenv) +runDeclss debug tenv (d:ds) = do + x <- runDecls debug tenv d + case x of + Right tenv' -> runDeclss debug tenv' ds + Left s -> return (Just s, tenv) + +runInfer :: Bool -> TEnv -> Ter -> IO (Either String Val) +runInfer debug lenv e = runTyping debug lenv (checkInfer e) + +liftEval :: Eval a -> Typing a +liftEval = lift . lift + +addC :: Ctxt -> (Tele,OEnv) -> [(Binder,Val)] -> Typing Ctxt +addC gam _ [] = return gam +addC gam ((y,a):as,nu) ((x,u):xus) = do + v <- liftEval $ eval nu a + addC ((x,v):gam) (as,oPair nu (y,u)) xus + +-- Extract the type of a label as a closure +getLblType :: String -> Val -> Typing (Tele, OEnv) +getLblType c (Ter (Sum _ cas) r) = case getIdent c cas of + Just as -> return (as,r) + Nothing -> throwError ("getLblType " ++ show c) +getLblType c u = throwError ("expected a data type for the constructor " + ++ c ++ " but got " ++ show u) + +-- Environment for type checker +data TEnv = TEnv { index :: Int -- for de Bruijn levels + , oenv :: OEnv + , ctxt :: Ctxt + , verbose :: Bool -- Should it be verbose and print + -- what it typechecks? + } + deriving (Eq,Show) + +verboseEnv, silentEnv :: TEnv +verboseEnv = TEnv 0 oEmpty [] True +silentEnv = TEnv 0 oEmpty [] False + +addTypeVal :: (Binder,Val) -> TEnv -> TEnv +addTypeVal p@(x,_) (TEnv k rho gam v) = + TEnv (k+1) (oPair rho (x,mkVar k (support rho))) (p:gam) v + +addType :: (Binder,Ter) -> TEnv -> Typing TEnv +addType (x,a) tenv@(TEnv _ rho _ _) = do + v <- liftEval $ eval rho a + return $ addTypeVal (x,v) tenv + +addBranch :: [(Binder,Val)] -> (Tele,OEnv) -> TEnv -> Typing TEnv +addBranch nvs (tele,env) (TEnv k rho gam v) = do + e <- addC gam (tele,env) nvs + return $ TEnv (k + length nvs) (upds rho nvs) e v + +addDecls :: ODecls -> TEnv -> Typing TEnv +addDecls od@(ODecls d) (TEnv k rho gam v) = do + let rho1 = oPDef True od rho + es' <- liftEval $ evals rho1 (declDefs d) + gam' <- addC gam (declTele d,rho) es' + return $ TEnv k rho1 gam' v +addDecls od tenv = return $ tenv {oenv = oPDef True od (oenv tenv)} + +addTele :: Tele -> TEnv -> Typing TEnv +addTele xas lenv = foldM (flip addType) lenv xas + +-- Useful monadic versions of functions: +checkM :: Typing Val -> Ter -> Typing () +checkM v t = do + v' <- v + check v' t + +localM :: (TEnv -> Typing TEnv) -> Typing a -> Typing a +localM f r = do + e <- ask + a <- f e + local (const a) r + +getFresh :: Typing Val +getFresh = do + k <- index <$> ask + e <- oenv <$> ask + return $ mkVar k (support e) + +checkDecls :: ODecls -> Typing () +checkDecls (ODecls d) = do + let (idents, tele, ters) = (declIdents d, declTele d, declTers d) + trace ("Checking: " ++ unwords idents) + checkTele tele + rho <- oenv <$> ask + localM (addTele tele) $ checks (tele,rho) ters +checkDecls _ = return () + +checkTele :: Tele -> Typing () +checkTele [] = return () +checkTele ((x,a):xas) = do + check VU a + localM (addType (x,a)) $ checkTele xas + +check :: Val -> Ter -> Typing () +check a t = case (a,t) of + (_,Con c es) -> do + (bs,nu) <- getLblType c a + checks (bs,nu) es + (VU,Pi a (Lam x b)) -> do + check VU a + localM (addType (x,a)) $ check VU b + (VU,Sigma a (Lam x b)) -> do + check VU a + localM (addType (x,a)) $ check VU b + (VU,Sum _ bs) -> sequence_ [checkTele as | (_,as) <- bs] + (VPi (Ter (Sum _ cas) nu) f,Split _ ces) -> + if sort (map fst ces) == sort [n | ((n,_),_) <- cas] + then sequence_ [ checkBranch (as,nu) f brc + | (brc, (_,as)) <- zip ces cas ] + else throwError "case branches does not match the data type" + (VPi a f,Lam x t) -> do + var <- getFresh + local (addTypeVal (x,a)) $ checkM (liftEval (app f var)) t + (VSigma a f, SPair t1 t2) -> do + check a t1 + e <- oenv <$> ask + v <- liftEval $ eval e t1 + checkM (liftEval (app f v)) t2 + (_,Where e d) -> do + checkDecls d + localM (addDecls d) $ check a e + (_,PN _) -> return () + _ -> do + v <- checkInfer t + k <- index <$> ask + b <- liftEval $ conv k v a + unless b $ + throwError $ "check conv: " ++ show v ++ " /= " ++ show a + +checkBranch :: (Tele,OEnv) -> Val -> Brc -> Typing () +checkBranch (xas,nu) f (c,(xs,e)) = do + k <- index <$> ask + env <- oenv <$> ask + let d = support env + l = length xas + us = map (`mkVar` d) [k..k+l-1] + localM (addBranch (zip xs us) (xas,nu)) + $ checkM (liftEval (app f (VCon c us))) e + +checkInfer :: Ter -> Typing Val +checkInfer e = case e of + U -> return VU -- U : U + Var n -> do + gam <- ctxt <$> ask + case getIdent n gam of + Just v -> return v + Nothing -> throwError $ show n ++ " is not declared!" + App t u -> do + c <- checkInfer t + case c of + VPi a f -> do + check a u + rho <- oenv <$> ask + v <- liftEval $ eval rho u + liftEval $ app f v + _ -> throwError $ show c ++ " is not a product" + Fst t -> do + c <- checkInfer t + case c of + VSigma a f -> return a + _ -> throwError $ show c ++ " is not a sigma-type" + Snd t -> do + c <- checkInfer t + case c of + VSigma a f -> do + e <- oenv <$> ask + v <- liftEval $ eval e t + liftEval $ app f (fstSVal v) + _ -> throwError $ show c ++ " is not a sigma-type" + Where t d -> do + checkDecls d + localM (addDecls d) $ checkInfer t + _ -> throwError ("checkInfer " ++ show e) + +checks :: (Tele,OEnv) -> [Ter] -> Typing () +checks _ [] = return () +checks ((x,a):xas,nu) (e:es) = do + v <- liftEval $ eval nu a + check v e + rho <- oenv <$> ask + v' <- liftEval $ eval rho e + checks (xas,oPair nu (x,v')) es +checks _ _ = throwError "checks" + +-- Not used since we have U : U +-- +-- (=?=) :: Typing Ter -> Ter -> Typing () +-- m =?= s2 = do +-- s1 <- m +-- unless (s1 == s2) $ throwError (show s1 ++ " =/= " ++ show s2) +-- +-- checkTs :: [(String,Ter)] -> Typing () +-- checkTs [] = return () +-- checkTs ((x,a):xas) = do +-- checkType a +-- local (addType (x,a)) (checkTs xas) +-- +-- checkType :: Ter -> Typing () +-- checkType t = case t of +-- U -> return () +-- Pi a (Lam x b) -> do +-- checkType a +-- local (addType (x,a)) (checkType b) +-- _ -> checkInfer t =?= U diff --git a/cubical.cabal b/cubical.cabal --- a/cubical.cabal +++ b/cubical.cabal @@ -1,27 +1,29 @@ name: cubical -version: 0.1.2 +-- Same version as in Main.hs? +version: 0.2.0 synopsis: Implementation of Univalence in Cubical Sets -description: Cubical implements an experimental simple type checker - for type theory with univalence with an evaluator for closed terms. +description: Cubical implements an experimental simple type + checker for type theory with univalence with an + evaluator for closed terms. homepage: https://github.com/simhu/cubical -extra-source-files: Makefile, README.md, Exp.cf, examples/*.cub +extra-source-files: Makefile, README.md, Exp.cf, examples/*.cub, cubical.el license: MIT license-file: LICENSE author: Cyril Cohen, Thierry Coquand, Simon Huber, Anders Mörtberg maintainer: mortberg@chalmers.se --- copyright: category: Dependent Types build-type: Custom --- extra-source-files: cabal-version: >=1.10 executable cubical main-is: Main.hs other-modules: Exp.Lex, Exp.Par - other-extensions: TupleSections, CPP, MagicHash - build-depends: base >=4.5 && < 5, transformers >=0.3, mtl >=2.1, haskeline >=0.7, directory >=1.2, array >=0.4, BNFC >= 2.6 - -- hs-source-dirs: + other-extensions: TupleSections, ParallelListComp, CPP, MagicHash, + GeneralizedNewtypeDeriving + build-depends: base >= 4.5 && < 5, transformers >= 0.3, mtl >= 2.1, + haskeline >= 0.7, directory >= 1.2, array >= 0.4, + BNFC >= 2.5, filepath >= 1.3 build-tools: alex, happy - default-language: Haskell2010 + default-language: Haskell98 hs-source-dirs: . - other-modules: CTT, Concrete, Eval, MTT, MTTtoCTT, Pretty + other-modules: CTT, Concrete, Eval, Pretty, TypeChecker diff --git a/cubical.el b/cubical.el new file mode 100644 --- /dev/null +++ b/cubical.el @@ -0,0 +1,64 @@ +;; define several class of keywords +(setq cub-keywords '("data" "import" "mutual" "let" "in" "data" "split" + "module" "where" "U") ) +(setq cub-special '("undefined" "primitive")) + +;; create regex strings +(setq cub-keywords-regexp (regexp-opt cub-keywords 'words)) +(setq cub-operators-regexp (regexp-opt '(":" "->" "=" "\\" "|" "\\" "*" "_") t)) +(setq cub-special-regexp (regexp-opt cub-special 'words)) +(setq cub-def-regexp "^[[:word:]]+") + +;; clear memory +(setq cub-keywords nil) +(setq cub-special nil) + +;; create the list for font-lock. +;; each class of keyword is given a particular face +(setq cub-font-lock-keywords + `( + (,cub-keywords-regexp . font-lock-type-face) + (,cub-operators-regexp . font-lock-variable-name-face) + (,cub-special-regexp . font-lock-warning-face) + (,cub-def-regexp . font-lock-function-name-face) +)) + +;; command to comment/uncomment text +(defun cub-comment-dwim (arg) + "Comment or uncomment current line or region in a smart way. For detail, see `comment-dwim'." + (interactive "*P") + (require 'newcomment) + (let ((comment-start "--") (comment-end "")) + (comment-dwim arg))) + + +;; syntax table for comments, same as for haskell-mode +(defvar cub-syntax-table + (let ((st (make-syntax-table))) + (modify-syntax-entry ?\{ "(}1nb" st) + (modify-syntax-entry ?\} "){4nb" st) + (modify-syntax-entry ?- "_ 123" st) + (modify-syntax-entry ?\n ">" st) + st)) + +;; define the mode +(define-derived-mode cub-mode fundamental-mode + "cubical mode" + "Major mode for editing cubical files…" + + :syntax-table cub-syntax-table + + ;; code for syntax highlighting + (setq font-lock-defaults '(cub-font-lock-keywords)) + (setq mode-name "cub") + + ;; modify the keymap + (define-key cub-mode-map [remap comment-dwim] 'cub-comment-dwim) + + ;; clear memory + (setq cub-keywords-regexp nil) + (setq cub-operators-regexp nil) + (setq cub-special-regexp nil) +) + +(provide 'cub-mode) diff --git a/dist/build/cubical/cubical-tmp/Exp/Lex.hs b/dist/build/cubical/cubical-tmp/Exp/Lex.hs deleted file mode 100644 --- a/dist/build/cubical/cubical-tmp/Exp/Lex.hs +++ /dev/null @@ -1,351 +0,0 @@ -{-# LANGUAGE CPP,MagicHash #-} -{-# LINE 3 "Exp/Lex.x" #-} - -{-# OPTIONS -fno-warn-incomplete-patterns #-} -module Exp.Lex where - - - -import qualified Data.Bits -import Data.Word (Word8) - -#if __GLASGOW_HASKELL__ >= 603 -#include "ghcconfig.h" -#elif defined(__GLASGOW_HASKELL__) -#include "config.h" -#endif -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -import Data.Char (ord) -import Data.Array.Base (unsafeAt) -#else -import Array -import Char (ord) -#endif -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts -#else -import GlaExts -#endif -alex_base :: AlexAddr -alex_base = AlexA# "\xf8\xff\xff\xff\xd9\xff\xff\xff\x49\x00\x00\x00\x1c\x01\x00\x00\x9c\x01\x00\x00\x6f\x02\x00\x00\xef\x02\x00\x00\xef\x03\x00\x00\xb7\xff\xff\xff\x00\x00\x00\x00\xe0\x03\x00\x00\x00\x00\x00\x00\x8b\x00\x00\x00\x1d\x02\x00\x00\xe0\x04\x00\x00\xa0\x04\x00\x00\x00\x00\x00\x00\x96\x05\x00\x00\x69\x06\x00\x00\x00\x00\x00\x00\xfe\xff\xff\xff\xdf\xff\xff\xff\x00\x00\x00\x00\x42\x07\x00\x00"# - -alex_table :: AlexAddr -alex_table = AlexA# "\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x11\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x16\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x15\x00\x16\x00\x16\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x02\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x0f\x00\x04\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0b\x00\x0c\x00\x06\x00\x09\x00\x09\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -alex_check :: AlexAddr -alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x28\x00\x29\x00\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x2d\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xff\xff\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_deflt :: AlexAddr -alex_deflt = AlexA# "\xff\xff\xff\xff\x05\x00\x05\x00\xff\xff\x05\x00\xff\xff\x05\x00\x05\x00\x0b\x00\x0b\x00\x10\x00\x10\x00\xff\xff\x11\x00\x11\x00\x11\x00\x11\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_accept = listArray (0::Int,23) [AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccSkip,AlexAccSkip,AlexAccSkip,AlexAccSkip,AlexAcc (alex_action_3),AlexAcc (alex_action_3),AlexAcc (alex_action_4)] -{-# LINE 38 "Exp/Lex.x" #-} - - -tok f p s = f p s - -share :: String -> String -share = id - -data Tok = - TS !String !Int -- reserved words and symbols - | TL !String -- string literals - | TI !String -- integer literals - | TV !String -- identifiers - | TD !String -- double precision float literals - | TC !String -- character literals - | T_AIdent !String - - deriving (Eq,Show,Ord) - -data Token = - PT Posn Tok - | Err Posn - deriving (Eq,Show,Ord) - -tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l -tokenPos (Err (Pn _ l _) :_) = "line " ++ show l -tokenPos _ = "end of file" - -tokenPosn (PT p _) = p -tokenPosn (Err p) = p -tokenLineCol = posLineCol . tokenPosn -posLineCol (Pn _ l c) = (l,c) -mkPosToken t@(PT p _) = (posLineCol p, prToken t) - -prToken t = case t of - PT _ (TS s _) -> s - PT _ (TL s) -> s - PT _ (TI s) -> s - PT _ (TV s) -> s - PT _ (TD s) -> s - PT _ (TC s) -> s - PT _ (T_AIdent s) -> s - - -data BTree = N | B String Tok BTree BTree deriving (Show) - -eitherResIdent :: (String -> Tok) -> String -> Tok -eitherResIdent tv s = treeFind resWords - where - treeFind N = tv s - treeFind (B a t left right) | s < a = treeFind left - | s > a = treeFind right - | s == a = t - -resWords = b "data" 11 (b "=" 6 (b "->" 3 (b ")" 2 (b "(" 1 N N) N) (b ";" 5 (b ":" 4 N N) N)) (b "\\" 9 (b "U" 8 (b "PN" 7 N N) N) (b "_" 10 N N))) (b "undefined" 17 (b "let" 14 (b "in" 13 (b "import" 12 N N) N) (b "split" 16 (b "module" 15 N N) N)) (b "|" 20 (b "{" 19 (b "where" 18 N N) N) (b "}" 21 N N))) - where b s n = let bs = id s - in B bs (TS bs n) - -unescapeInitTail :: String -> String -unescapeInitTail = id . unesc . tail . id where - unesc s = case s of - '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs - '\\':'n':cs -> '\n' : unesc cs - '\\':'t':cs -> '\t' : unesc cs - '"':[] -> [] - c:cs -> c : unesc cs - _ -> [] - -------------------------------------------------------------------- --- Alex wrapper code. --- A modified "posn" wrapper. -------------------------------------------------------------------- - -data Posn = Pn !Int !Int !Int - deriving (Eq, Show,Ord) - -alexStartPos :: Posn -alexStartPos = Pn 0 1 1 - -alexMove :: Posn -> Char -> Posn -alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) -alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 -alexMove (Pn a l c) _ = Pn (a+1) l (c+1) - -type Byte = Word8 - -type AlexInput = (Posn, -- current position, - Char, -- previous char - [Byte], -- pending bytes on the current char - String) -- current input string - -tokens :: String -> [Token] -tokens str = go (alexStartPos, '\n', [], str) - where - go :: AlexInput -> [Token] - go inp@(pos, _, _, str) = - case alexScan inp 0 of - AlexEOF -> [] - AlexError (pos, _, _, _) -> [Err pos] - AlexSkip inp' len -> go inp' - AlexToken inp' len act -> act pos (take len str) : (go inp') - -alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) -alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s)) -alexGetByte (p, _, [], s) = - case s of - [] -> Nothing - (c:s) -> - let p' = alexMove p c - (b:bs) = utf8Encode c - in p' `seq` Just (b, (p', c, bs, s)) - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (p, c, bs, s) = c - - -- | Encode a Haskell String to a list of Word8 values, in UTF8 format. -utf8Encode :: Char -> [Word8] -utf8Encode = map fromIntegral . go . ord - where - go oc - | oc <= 0x7f = [oc] - - | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6) - , 0x80 + oc Data.Bits..&. 0x3f - ] - - | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12) - , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) - , 0x80 + oc Data.Bits..&. 0x3f - ] - | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18) - , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f) - , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) - , 0x80 + oc Data.Bits..&. 0x3f - ] - -alex_action_3 = tok (\p s -> PT p (eitherResIdent (TV . share) s)) -alex_action_4 = tok (\p s -> PT p (eitherResIdent (T_AIdent . share) s)) -alex_action_5 = tok (\p s -> PT p (eitherResIdent (TV . share) s)) -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# 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 diff --git a/dist/build/cubical/cubical-tmp/Exp/Par.hs b/dist/build/cubical/cubical-tmp/Exp/Par.hs deleted file mode 100644 --- a/dist/build/cubical/cubical-tmp/Exp/Par.hs +++ /dev/null @@ -1,985 +0,0 @@ -{-# OPTIONS_GHC -w #-} -{-# OPTIONS -fglasgow-exts -cpp #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} -module Exp.Par where -import Exp.Abs -import Exp.Lex -import Exp.ErrM -import qualified Data.Array as Happy_Data_Array -import qualified GHC.Exts as Happy_GHC_Exts - --- parser produced by Happy Version 1.18.8 - -newtype HappyAbsSyn = HappyAbsSyn HappyAny -#if __GLASGOW_HASKELL__ >= 607 -type HappyAny = Happy_GHC_Exts.Any -#else -type HappyAny = forall a . a -#endif -happyIn5 :: (AIdent) -> (HappyAbsSyn ) -happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn5 #-} -happyOut5 :: (HappyAbsSyn ) -> (AIdent) -happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut5 #-} -happyIn6 :: (Module) -> (HappyAbsSyn ) -happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn6 #-} -happyOut6 :: (HappyAbsSyn ) -> (Module) -happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut6 #-} -happyIn7 :: (Imp) -> (HappyAbsSyn ) -happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn ) -> (Imp) -happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut7 #-} -happyIn8 :: ([Imp]) -> (HappyAbsSyn ) -happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn ) -> ([Imp]) -happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut8 #-} -happyIn9 :: (Def) -> (HappyAbsSyn ) -happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn ) -> (Def) -happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut9 #-} -happyIn10 :: ([Def]) -> (HappyAbsSyn ) -happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn ) -> ([Def]) -happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut10 #-} -happyIn11 :: (ExpWhere) -> (HappyAbsSyn ) -happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn ) -> (ExpWhere) -happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut11 #-} -happyIn12 :: (Exp) -> (HappyAbsSyn ) -happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn ) -> (Exp) -happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut12 #-} -happyIn13 :: (Exp) -> (HappyAbsSyn ) -happyIn13 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn13 #-} -happyOut13 :: (HappyAbsSyn ) -> (Exp) -happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut13 #-} -happyIn14 :: (Exp) -> (HappyAbsSyn ) -happyIn14 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn14 #-} -happyOut14 :: (HappyAbsSyn ) -> (Exp) -happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut14 #-} -happyIn15 :: (Exp) -> (HappyAbsSyn ) -happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn15 #-} -happyOut15 :: (HappyAbsSyn ) -> (Exp) -happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut15 #-} -happyIn16 :: (Binder) -> (HappyAbsSyn ) -happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn16 #-} -happyOut16 :: (HappyAbsSyn ) -> (Binder) -happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut16 #-} -happyIn17 :: ([Binder]) -> (HappyAbsSyn ) -happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn17 #-} -happyOut17 :: (HappyAbsSyn ) -> ([Binder]) -happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut17 #-} -happyIn18 :: (Arg) -> (HappyAbsSyn ) -happyIn18 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn18 #-} -happyOut18 :: (HappyAbsSyn ) -> (Arg) -happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut18 #-} -happyIn19 :: ([Arg]) -> (HappyAbsSyn ) -happyIn19 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn19 #-} -happyOut19 :: (HappyAbsSyn ) -> ([Arg]) -happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut19 #-} -happyIn20 :: (Branch) -> (HappyAbsSyn ) -happyIn20 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn20 #-} -happyOut20 :: (HappyAbsSyn ) -> (Branch) -happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut20 #-} -happyIn21 :: ([Branch]) -> (HappyAbsSyn ) -happyIn21 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn21 #-} -happyOut21 :: (HappyAbsSyn ) -> ([Branch]) -happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut21 #-} -happyIn22 :: (Sum) -> (HappyAbsSyn ) -happyIn22 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn22 #-} -happyOut22 :: (HappyAbsSyn ) -> (Sum) -happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut22 #-} -happyIn23 :: ([Sum]) -> (HappyAbsSyn ) -happyIn23 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn23 #-} -happyOut23 :: (HappyAbsSyn ) -> ([Sum]) -happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut23 #-} -happyIn24 :: (VDecl) -> (HappyAbsSyn ) -happyIn24 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn24 #-} -happyOut24 :: (HappyAbsSyn ) -> (VDecl) -happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut24 #-} -happyIn25 :: ([VDecl]) -> (HappyAbsSyn ) -happyIn25 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn25 #-} -happyOut25 :: (HappyAbsSyn ) -> ([VDecl]) -happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut25 #-} -happyIn26 :: (PiDecl) -> (HappyAbsSyn ) -happyIn26 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn26 #-} -happyOut26 :: (HappyAbsSyn ) -> (PiDecl) -happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut26 #-} -happyIn27 :: ([PiDecl]) -> (HappyAbsSyn ) -happyIn27 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn27 #-} -happyOut27 :: (HappyAbsSyn ) -> ([PiDecl]) -happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut27 #-} -happyInTok :: (Token) -> (HappyAbsSyn ) -happyInTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> (Token) -happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOutTok #-} - - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\xd7\x00\xca\x00\xce\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xdb\x00\x00\x00\x00\x00\xde\x00\xcd\x00\xca\x00\x00\x00\x00\x00\x4b\x00\x00\x00\xc4\x00\xbb\x00\x00\x00\xb7\x00\xc3\x00\xba\x00\xaf\x00\x18\x00\x4b\x00\xc1\x00\x00\x00\x41\x00\x9c\x00\x00\x00\xca\x00\x00\x00\xca\x00\x9c\x00\x00\x00\xbd\x00\xb9\x00\x00\x00\x00\x00\xca\x00\xca\x00\x00\x00\xb8\x00\xae\x00\x8c\x00\x98\x00\x00\x00\xa0\x00\x89\x00\x8d\x00\x8a\x00\x00\x00\x7d\x00\x0a\x00\x00\x00\x84\x00\x18\x00\x3a\x00\xca\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\xca\x00\x37\x00\xca\x00\x00\x00\x81\x00\x18\x00\x78\x00\x00\x00\x61\x00\x77\x00\x00\x00\x6f\x00\x68\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x6a\x00\x00\x00\x00\x00\x18\x00\x5b\x00\x65\x00\x00\x00\x4b\x00\x00\x00\x59\x00\x00\x00\x60\x00\xca\x00\x6b\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x64\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\x00\x00\xed\xff\x00\x00\x92\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x26\x00\xb0\x00\xb6\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x82\x00\x00\x00\x72\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x52\x00\x00\x00\x48\x00\x00\x00\x00\x00\x54\x00\x40\x00\x00\x00\x00\x00\x00\x00\x31\x00\x00\x00\x21\x00\x51\x00\x38\x00\x00\x00\x90\x00\x51\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x32\x00\x51\x00\x01\x00\x00\x00\x00\x00\x80\x00\x3e\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x0c\x00\x02\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00"# - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\xfd\xff\xde\xff\x00\x00\xec\xff\xe9\xff\xe7\xff\xe6\xff\xce\xff\x00\x00\x00\x00\xe3\xff\xe5\xff\x00\x00\xdd\xff\x00\x00\x00\x00\xe4\xff\x00\x00\x00\x00\x00\x00\xd9\xff\xf4\xff\xe0\xff\x00\x00\xe1\xff\x00\x00\x00\x00\xcd\xff\x00\x00\xe8\xff\x00\x00\x00\x00\xeb\xff\x00\x00\x00\x00\xea\xff\xe2\xff\x00\x00\x00\x00\xdf\xff\xdc\xff\xf3\xff\x00\x00\x00\x00\xdc\xff\xd8\xff\x00\x00\x00\x00\xfa\xff\xed\xff\xd9\xff\x00\x00\xdc\xff\x00\x00\xf4\xff\x00\x00\x00\x00\xee\xff\x00\x00\xcf\xff\xf6\xff\xdb\xff\x00\x00\xf2\xff\x00\x00\x00\x00\x00\x00\xd7\xff\xf9\xff\xf4\xff\x00\x00\xfb\xff\x00\x00\xfa\xff\xda\xff\xf0\xff\xd5\xff\xef\xff\xf7\xff\xd1\xff\xd4\xff\xf5\xff\x00\x00\xf8\xff\xfc\xff\xf4\xff\xd5\xff\xd6\xff\xd0\xff\x00\x00\xd3\xff\x00\x00\xf1\xff\x00\x00\x00\x00\x00\x00\xd2\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x00\x00\x15\x00\x16\x00\x00\x00\x02\x00\x03\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x03\x00\x0d\x00\x0b\x00\x0c\x00\x0d\x00\x00\x00\x00\x00\x0a\x00\x13\x00\x15\x00\x16\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x11\x00\x12\x00\x0d\x00\x16\x00\x00\x00\x00\x00\x0b\x00\x11\x00\x12\x00\x00\x00\x15\x00\x16\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x14\x00\x16\x00\x0d\x00\x0f\x00\x10\x00\x00\x00\x02\x00\x03\x00\x0f\x00\x10\x00\x15\x00\x16\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x06\x00\x00\x00\x0d\x00\x06\x00\x0a\x00\x00\x00\x02\x00\x0a\x00\x04\x00\x0e\x00\x15\x00\x16\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x16\x00\x0e\x00\x0d\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x0e\x00\x15\x00\x16\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0a\x00\x0d\x00\x0d\x00\x0d\x00\x16\x00\x00\x00\x00\x00\x04\x00\x01\x00\x01\x00\x15\x00\x16\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x02\x00\x15\x00\x0d\x00\x00\x00\x16\x00\x00\x00\x14\x00\x04\x00\x05\x00\x15\x00\x15\x00\x16\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x13\x00\x16\x00\x0d\x00\x00\x00\x12\x00\x00\x00\x0c\x00\x04\x00\x05\x00\x05\x00\x15\x00\x16\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x02\x00\x16\x00\x0d\x00\x00\x00\x0d\x00\x00\x00\x16\x00\x04\x00\x05\x00\x0c\x00\x15\x00\x16\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x01\x00\x15\x00\x0d\x00\x13\x00\x15\x00\x00\x00\x07\x00\x08\x00\x05\x00\x0a\x00\x15\x00\x16\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x11\x00\x16\x00\x0d\x00\x00\x00\x00\x00\x16\x00\x05\x00\x04\x00\x05\x00\x00\x00\x15\x00\x16\x00\x08\x00\x09\x00\x0a\x00\x04\x00\x04\x00\x0d\x00\x02\x00\x00\x00\x0b\x00\x0c\x00\x0d\x00\x03\x00\x16\x00\x15\x00\x16\x00\x08\x00\x09\x00\x0a\x00\x01\x00\x12\x00\x0d\x00\x13\x00\x18\x00\x03\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x15\x00\x16\x00\x13\x00\x0e\x00\x16\x00\x10\x00\x11\x00\x01\x00\x00\x00\x03\x00\x01\x00\x16\x00\x18\x00\x07\x00\x08\x00\x16\x00\x0a\x00\x0f\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x04\x00\x0a\x00\x1e\x00\x04\x00\x47\x00\x56\x00\x4d\x00\x4e\x00\x06\x00\x07\x00\x08\x00\x52\x00\x46\x00\x09\x00\x19\x00\x60\x00\x1b\x00\x04\x00\x52\x00\x11\x00\x5b\x00\x0a\x00\x0b\x00\x51\x00\x4e\x00\x06\x00\x07\x00\x08\x00\x53\x00\x5d\x00\x09\x00\x04\x00\x2f\x00\x04\x00\x2f\x00\x53\x00\x54\x00\x2f\x00\x0a\x00\x0b\x00\x62\x00\x06\x00\x07\x00\x08\x00\x5a\x00\x04\x00\x09\x00\x30\x00\x46\x00\x04\x00\x47\x00\x48\x00\x30\x00\x31\x00\x0a\x00\x0b\x00\x50\x00\x06\x00\x07\x00\x08\x00\x50\x00\x4a\x00\x09\x00\x42\x00\x11\x00\x04\x00\x28\x00\x11\x00\x29\x00\x44\x00\x0a\x00\x0b\x00\x3f\x00\x06\x00\x07\x00\x08\x00\x04\x00\x36\x00\x09\x00\x04\x00\x04\x00\x04\x00\x04\x00\x37\x00\x11\x00\x3a\x00\x0a\x00\x0b\x00\x3c\x00\x06\x00\x07\x00\x08\x00\x20\x00\x40\x00\x09\x00\x09\x00\x04\x00\x04\x00\x16\x00\x62\x00\x14\x00\x5d\x00\x0a\x00\x0b\x00\x3d\x00\x06\x00\x07\x00\x08\x00\x64\x00\x60\x00\x09\x00\x2b\x00\x04\x00\x04\x00\x5a\x00\x2c\x00\x5e\x00\x58\x00\x0a\x00\x0b\x00\x24\x00\x06\x00\x07\x00\x08\x00\x59\x00\x04\x00\x09\x00\x2b\x00\x56\x00\x04\x00\x4a\x00\x2c\x00\x4b\x00\x4d\x00\x0a\x00\x0b\x00\x25\x00\x06\x00\x07\x00\x08\x00\x3f\x00\x04\x00\x09\x00\x2b\x00\x44\x00\x04\x00\x04\x00\x2c\x00\x42\x00\x4a\x00\x0a\x00\x0b\x00\x1c\x00\x06\x00\x07\x00\x08\x00\x0d\x00\x35\x00\x09\x00\x34\x00\x39\x00\x04\x00\x0e\x00\x0f\x00\x36\x00\x11\x00\x0a\x00\x0b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x14\x00\x04\x00\x09\x00\x2b\x00\x04\x00\x04\x00\x3a\x00\x2c\x00\x2d\x00\x04\x00\x0a\x00\x0b\x00\x23\x00\x07\x00\x08\x00\x3c\x00\x29\x00\x09\x00\x28\x00\x04\x00\x19\x00\x2a\x00\x1b\x00\x2a\x00\x04\x00\x0a\x00\x0b\x00\x26\x00\x07\x00\x08\x00\x0d\x00\x33\x00\x09\x00\x18\x00\xff\xff\x1e\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0a\x00\x0b\x00\x19\x00\x12\x00\x04\x00\x13\x00\x14\x00\x22\x00\x04\x00\x23\x00\x20\x00\x04\x00\xff\xff\x0e\x00\x0f\x00\x04\x00\x11\x00\x16\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = Happy_Data_Array.array (2, 50) [ - (2 , happyReduce_2), - (3 , happyReduce_3), - (4 , happyReduce_4), - (5 , happyReduce_5), - (6 , happyReduce_6), - (7 , happyReduce_7), - (8 , happyReduce_8), - (9 , happyReduce_9), - (10 , happyReduce_10), - (11 , happyReduce_11), - (12 , happyReduce_12), - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23), - (24 , happyReduce_24), - (25 , happyReduce_25), - (26 , happyReduce_26), - (27 , happyReduce_27), - (28 , happyReduce_28), - (29 , happyReduce_29), - (30 , happyReduce_30), - (31 , happyReduce_31), - (32 , happyReduce_32), - (33 , happyReduce_33), - (34 , happyReduce_34), - (35 , happyReduce_35), - (36 , happyReduce_36), - (37 , happyReduce_37), - (38 , happyReduce_38), - (39 , happyReduce_39), - (40 , happyReduce_40), - (41 , happyReduce_41), - (42 , happyReduce_42), - (43 , happyReduce_43), - (44 , happyReduce_44), - (45 , happyReduce_45), - (46 , happyReduce_46), - (47 , happyReduce_47), - (48 , happyReduce_48), - (49 , happyReduce_49), - (50 , happyReduce_50) - ] - -happy_n_terms = 25 :: Int -happy_n_nonterms = 23 :: Int - -happyReduce_2 = happySpecReduce_1 0# happyReduction_2 -happyReduction_2 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn5 - (AIdent (mkPosToken happy_var_1) - )} - -happyReduce_3 = happyReduce 7# 1# happyReduction_3 -happyReduction_3 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut5 happy_x_2 of { happy_var_2 -> - case happyOut8 happy_x_5 of { happy_var_5 -> - case happyOut10 happy_x_6 of { happy_var_6 -> - happyIn6 - (Module happy_var_2 happy_var_5 happy_var_6 - ) `HappyStk` happyRest}}} - -happyReduce_4 = happySpecReduce_2 2# happyReduction_4 -happyReduction_4 happy_x_2 - happy_x_1 - = case happyOut5 happy_x_2 of { happy_var_2 -> - happyIn7 - (Import happy_var_2 - )} - -happyReduce_5 = happySpecReduce_0 3# happyReduction_5 -happyReduction_5 = happyIn8 - ([] - ) - -happyReduce_6 = happySpecReduce_1 3# happyReduction_6 -happyReduction_6 happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - happyIn8 - ((:[]) happy_var_1 - )} - -happyReduce_7 = happySpecReduce_3 3# happyReduction_7 -happyReduction_7 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - case happyOut8 happy_x_3 of { happy_var_3 -> - happyIn8 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_8 = happyReduce 4# 4# happyReduction_8 -happyReduction_8 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut5 happy_x_1 of { happy_var_1 -> - case happyOut19 happy_x_2 of { happy_var_2 -> - case happyOut11 happy_x_4 of { happy_var_4 -> - happyIn9 - (Def happy_var_1 (reverse happy_var_2) happy_var_4 - ) `HappyStk` happyRest}}} - -happyReduce_9 = happySpecReduce_3 4# happyReduction_9 -happyReduction_9 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - case happyOut12 happy_x_3 of { happy_var_3 -> - happyIn9 - (DefTDecl happy_var_1 happy_var_3 - )}} - -happyReduce_10 = happyReduce 5# 4# happyReduction_10 -happyReduction_10 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut5 happy_x_2 of { happy_var_2 -> - case happyOut19 happy_x_3 of { happy_var_3 -> - case happyOut23 happy_x_5 of { happy_var_5 -> - happyIn9 - (DefData happy_var_2 (reverse happy_var_3) happy_var_5 - ) `HappyStk` happyRest}}} - -happyReduce_11 = happySpecReduce_0 5# happyReduction_11 -happyReduction_11 = happyIn10 - ([] - ) - -happyReduce_12 = happySpecReduce_1 5# happyReduction_12 -happyReduction_12 happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - happyIn10 - ((:[]) happy_var_1 - )} - -happyReduce_13 = happySpecReduce_3 5# happyReduction_13 -happyReduction_13 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_3 of { happy_var_3 -> - happyIn10 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_14 = happyReduce 5# 6# happyReduction_14 -happyReduction_14 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut12 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_4 of { happy_var_4 -> - happyIn11 - (Where happy_var_1 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_15 = happySpecReduce_1 6# happyReduction_15 -happyReduction_15 happy_x_1 - = case happyOut12 happy_x_1 of { happy_var_1 -> - happyIn11 - (NoWhere happy_var_1 - )} - -happyReduce_16 = happyReduce 6# 7# happyReduction_16 -happyReduction_16 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut10 happy_x_3 of { happy_var_3 -> - case happyOut12 happy_x_6 of { happy_var_6 -> - happyIn12 - (Let happy_var_3 happy_var_6 - ) `HappyStk` happyRest}} - -happyReduce_17 = happyReduce 4# 7# happyReduction_17 -happyReduction_17 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut17 happy_x_2 of { happy_var_2 -> - case happyOut12 happy_x_4 of { happy_var_4 -> - happyIn12 - (Lam happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_18 = happyReduce 4# 7# happyReduction_18 -happyReduction_18 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut21 happy_x_3 of { happy_var_3 -> - happyIn12 - (Split happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_19 = happySpecReduce_1 7# happyReduction_19 -happyReduction_19 happy_x_1 - = case happyOut13 happy_x_1 of { happy_var_1 -> - happyIn12 - (happy_var_1 - )} - -happyReduce_20 = happySpecReduce_3 8# happyReduction_20 -happyReduction_20 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut14 happy_x_1 of { happy_var_1 -> - case happyOut13 happy_x_3 of { happy_var_3 -> - happyIn13 - (Fun happy_var_1 happy_var_3 - )}} - -happyReduce_21 = happySpecReduce_3 8# happyReduction_21 -happyReduction_21 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut27 happy_x_1 of { happy_var_1 -> - case happyOut13 happy_x_3 of { happy_var_3 -> - happyIn13 - (Pi happy_var_1 happy_var_3 - )}} - -happyReduce_22 = happySpecReduce_1 8# happyReduction_22 -happyReduction_22 happy_x_1 - = case happyOut14 happy_x_1 of { happy_var_1 -> - happyIn13 - (happy_var_1 - )} - -happyReduce_23 = happySpecReduce_2 9# happyReduction_23 -happyReduction_23 happy_x_2 - happy_x_1 - = case happyOut14 happy_x_1 of { happy_var_1 -> - case happyOut15 happy_x_2 of { happy_var_2 -> - happyIn14 - (App happy_var_1 happy_var_2 - )}} - -happyReduce_24 = happySpecReduce_1 9# happyReduction_24 -happyReduction_24 happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> - happyIn14 - (happy_var_1 - )} - -happyReduce_25 = happySpecReduce_1 10# happyReduction_25 -happyReduction_25 happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - happyIn15 - (Var happy_var_1 - )} - -happyReduce_26 = happySpecReduce_1 10# happyReduction_26 -happyReduction_26 happy_x_1 - = happyIn15 - (U - ) - -happyReduce_27 = happySpecReduce_1 10# happyReduction_27 -happyReduction_27 happy_x_1 - = happyIn15 - (Undef - ) - -happyReduce_28 = happySpecReduce_1 10# happyReduction_28 -happyReduction_28 happy_x_1 - = happyIn15 - (PN - ) - -happyReduce_29 = happySpecReduce_3 10# happyReduction_29 -happyReduction_29 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut12 happy_x_2 of { happy_var_2 -> - happyIn15 - (happy_var_2 - )} - -happyReduce_30 = happySpecReduce_1 11# happyReduction_30 -happyReduction_30 happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - happyIn16 - (Binder happy_var_1 - )} - -happyReduce_31 = happySpecReduce_1 12# happyReduction_31 -happyReduction_31 happy_x_1 - = case happyOut16 happy_x_1 of { happy_var_1 -> - happyIn17 - ((:[]) happy_var_1 - )} - -happyReduce_32 = happySpecReduce_2 12# happyReduction_32 -happyReduction_32 happy_x_2 - happy_x_1 - = case happyOut16 happy_x_1 of { happy_var_1 -> - case happyOut17 happy_x_2 of { happy_var_2 -> - happyIn17 - ((:) happy_var_1 happy_var_2 - )}} - -happyReduce_33 = happySpecReduce_1 13# happyReduction_33 -happyReduction_33 happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - happyIn18 - (Arg happy_var_1 - )} - -happyReduce_34 = happySpecReduce_1 13# happyReduction_34 -happyReduction_34 happy_x_1 - = happyIn18 - (NoArg - ) - -happyReduce_35 = happySpecReduce_0 14# happyReduction_35 -happyReduction_35 = happyIn19 - ([] - ) - -happyReduce_36 = happySpecReduce_2 14# happyReduction_36 -happyReduction_36 happy_x_2 - happy_x_1 - = case happyOut19 happy_x_1 of { happy_var_1 -> - case happyOut18 happy_x_2 of { happy_var_2 -> - happyIn19 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_37 = happyReduce 4# 15# happyReduction_37 -happyReduction_37 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut5 happy_x_1 of { happy_var_1 -> - case happyOut19 happy_x_2 of { happy_var_2 -> - case happyOut11 happy_x_4 of { happy_var_4 -> - happyIn20 - (Branch happy_var_1 (reverse happy_var_2) happy_var_4 - ) `HappyStk` happyRest}}} - -happyReduce_38 = happySpecReduce_0 16# happyReduction_38 -happyReduction_38 = happyIn21 - ([] - ) - -happyReduce_39 = happySpecReduce_1 16# happyReduction_39 -happyReduction_39 happy_x_1 - = case happyOut20 happy_x_1 of { happy_var_1 -> - happyIn21 - ((:[]) happy_var_1 - )} - -happyReduce_40 = happySpecReduce_3 16# happyReduction_40 -happyReduction_40 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut20 happy_x_1 of { happy_var_1 -> - case happyOut21 happy_x_3 of { happy_var_3 -> - happyIn21 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_41 = happySpecReduce_2 17# happyReduction_41 -happyReduction_41 happy_x_2 - happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - case happyOut25 happy_x_2 of { happy_var_2 -> - happyIn22 - (Sum happy_var_1 (reverse happy_var_2) - )}} - -happyReduce_42 = happySpecReduce_0 18# happyReduction_42 -happyReduction_42 = happyIn23 - ([] - ) - -happyReduce_43 = happySpecReduce_1 18# happyReduction_43 -happyReduction_43 happy_x_1 - = case happyOut22 happy_x_1 of { happy_var_1 -> - happyIn23 - ((:[]) happy_var_1 - )} - -happyReduce_44 = happySpecReduce_3 18# happyReduction_44 -happyReduction_44 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut22 happy_x_1 of { happy_var_1 -> - case happyOut23 happy_x_3 of { happy_var_3 -> - happyIn23 - ((:) happy_var_1 happy_var_3 - )}} - -happyReduce_45 = happyReduce 5# 19# happyReduction_45 -happyReduction_45 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut17 happy_x_2 of { happy_var_2 -> - case happyOut12 happy_x_4 of { happy_var_4 -> - happyIn24 - (VDecl happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_46 = happySpecReduce_0 20# happyReduction_46 -happyReduction_46 = happyIn25 - ([] - ) - -happyReduce_47 = happySpecReduce_2 20# happyReduction_47 -happyReduction_47 happy_x_2 - happy_x_1 - = case happyOut25 happy_x_1 of { happy_var_1 -> - case happyOut24 happy_x_2 of { happy_var_2 -> - happyIn25 - (flip (:) happy_var_1 happy_var_2 - )}} - -happyReduce_48 = happyReduce 5# 21# happyReduction_48 -happyReduction_48 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut12 happy_x_2 of { happy_var_2 -> - case happyOut12 happy_x_4 of { happy_var_4 -> - happyIn26 - (PiDecl happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_49 = happySpecReduce_1 22# happyReduction_49 -happyReduction_49 happy_x_1 - = case happyOut26 happy_x_1 of { happy_var_1 -> - happyIn27 - ((:[]) happy_var_1 - )} - -happyReduce_50 = happySpecReduce_2 22# happyReduction_50 -happyReduction_50 happy_x_2 - happy_x_1 - = case happyOut26 happy_x_1 of { happy_var_1 -> - case happyOut27 happy_x_2 of { happy_var_2 -> - happyIn27 - ((:) happy_var_1 happy_var_2 - )}} - -happyNewToken action sts stk [] = - happyDoAction 24# notHappyAtAll action sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = happyDoAction i tk action sts stk tks in - case tk of { - PT _ (TS _ 1) -> cont 1#; - PT _ (TS _ 2) -> cont 2#; - PT _ (TS _ 3) -> cont 3#; - PT _ (TS _ 4) -> cont 4#; - PT _ (TS _ 5) -> cont 5#; - PT _ (TS _ 6) -> cont 6#; - PT _ (TS _ 7) -> cont 7#; - PT _ (TS _ 8) -> cont 8#; - PT _ (TS _ 9) -> cont 9#; - PT _ (TS _ 10) -> cont 10#; - PT _ (TS _ 11) -> cont 11#; - PT _ (TS _ 12) -> cont 12#; - PT _ (TS _ 13) -> cont 13#; - PT _ (TS _ 14) -> cont 14#; - PT _ (TS _ 15) -> cont 15#; - PT _ (TS _ 16) -> cont 16#; - PT _ (TS _ 17) -> cont 17#; - PT _ (TS _ 18) -> cont 18#; - PT _ (TS _ 19) -> cont 19#; - PT _ (TS _ 20) -> cont 20#; - PT _ (TS _ 21) -> cont 21#; - PT _ (T_AIdent _) -> cont 22#; - _ -> cont 23#; - _ -> happyError' (tk:tks) - } - -happyError_ 24# tk tks = happyError' tks -happyError_ _ tk tks = happyError' (tk:tks) - -happyThen :: () => Err a -> (a -> Err b) -> Err b -happyThen = (thenM) -happyReturn :: () => a -> Err a -happyReturn = (returnM) -happyThen1 m k tks = (thenM) m (\a -> k a tks) -happyReturn1 :: () => a -> b -> Err a -happyReturn1 = \a tks -> (returnM) a -happyError' :: () => [(Token)] -> Err a -happyError' = happyError - -pModule tks = happySomeParser where - happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut6 x)) - -pExp tks = happySomeParser where - happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut12 x)) - -happySeq = happyDontSeq - - -returnM :: a -> Err a -returnM = return - -thenM :: Err a -> (a -> Err b) -> Err b -thenM = (>>=) - -happyError :: [Token] -> Err a -happyError ts = - Bad $ "syntax error at " ++ tokenPos ts ++ - case ts of - [] -> [] - [Err _] -> " due to lexer error" - _ -> " before " ++ unwords (map (id . prToken) (take 4 ts)) - -myLexer = tokens -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 1 "" #-} -{-# 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. diff --git a/examples/BoolEqBool.cub b/examples/BoolEqBool.cub --- a/examples/BoolEqBool.cub +++ b/examples/BoolEqBool.cub @@ -7,36 +7,28 @@ notInj x y p = compUp Bool (not (not x)) x (not (not y)) y (notK x) (notK y) rem where rem : Id Bool (not (not x)) (not (not y)) - rem = cong Bool Bool not (not x) (not y) p + rem = mapOnPath Bool Bool not (not x) (not y) p notFiber : Bool -> U notFiber b = fiber Bool Bool not b -fstNotFiber : (b : Bool) -> notFiber b -> Bool -fstNotFiber b = fst Bool (\x -> Id Bool (not x) b) - eqNotFiber : (b : Bool) -> (v v' : notFiber b) -> - Id Bool (fstNotFiber b v) (fstNotFiber b v') -> Id (notFiber b) v v' -eqNotFiber b = eqPropFam Bool (\x -> Id Bool (not x) b) rem - where - rem : propFam Bool (\x -> Id Bool (not x) b) - rem = \x -> boolIsSet (not x) b + Id Bool v.1 v'.1 -> Id (notFiber b) v v' +eqNotFiber b = eqPropFam Bool (\x -> Id Bool (not x) b) + (\x -> boolIsSet (not x) b) sNot : (b : Bool) -> notFiber b -sNot b = pair (not b) (notK b) +sNot b = (not b, notK b) tNot : (b : Bool) (v : notFiber b) -> Id (notFiber b) (sNot b) v tNot b v = eqNotFiber b (sNot b) v rem where - b' : Bool - b' = fstNotFiber b v - - rem1 : Id Bool (not (not b)) (not b') - rem1 = comp Bool (not (not b)) b (not b') (notK b) - (inv Bool (not b') b (snd Bool (\x -> Id Bool (not x) b) v)) + rem1 : Id Bool (not (not b)) (not v.1) + rem1 = comp Bool (not (not b)) b (not v.1) (notK b) + (inv Bool (not v.1) b v.2) - rem : Id Bool (not b) b' - rem = notInj (not b) b' rem1 + rem : Id Bool (not b) v.1 + rem = notInj (not b) v.1 rem1 eqBoolBool : Id U Bool Bool eqBoolBool = equivEq Bool Bool not sNot tNot @@ -48,7 +40,7 @@ notEqBool = transport Bool Bool eqBoolBool testBool : Bool -testBool = notEqBool (true) +testBool = notEqBool true compEqBool : Id U Bool Bool compEqBool = comp U Bool Bool Bool eqBoolBool eqBoolBool @@ -72,13 +64,13 @@ monoid A = and A (A -> A -> A) zm : (A : U) (m : monoid A) -> A -zm A m = fst A (\x -> A -> A -> A) m +zm A m = m.1 opm : (A : U) (m : monoid A) -> (A -> A -> A) -opm A m = snd A (\x -> A -> A -> A) m +opm A m = m.2 transm : (A B : U) -> Id U A B -> monoid A -> monoid B -transm = subst U monoid +transm = subst U monoid transun : (A B : U) -> Id U A B -> (A -> A) -> (B -> B) transun = subst U (\X -> (X -> X)) @@ -96,7 +88,7 @@ testF = transid false monoidAndBool : monoid Bool -monoidAndBool = pair (true) andBool +monoidAndBool = (true, andBool) mBool2 : monoid Bool mBool2 = transm Bool Bool eqBoolBool monoidAndBool @@ -138,3 +130,10 @@ testTT3 : Bool testTT3 = opBool3 true true + +orBool : Bool -> Bool -> Bool +orBool = split true -> \x -> true + false -> \x -> x + +testTT4 : Id Bool (orBool false true) (opBool3 false true) +testTT4 = refl Bool true diff --git a/examples/Kraus.cub b/examples/Kraus.cub --- a/examples/Kraus.cub +++ b/examples/Kraus.cub @@ -1,82 +1,51 @@ -module Kraus where - -import swapDisc -import testInh -import idempotent -import contr -import elimEquiv - --- we encode the example of Nicolai Kraus --- for this we need the impredicative encoding of propositional truncation - --- the type of pointed types - -ptU : U -ptU = Sigma U (id U) - --- if f : A -> B is an equivalence and f a = b then (A,a) and (B,b) are equal in ptU - -lemPtEquiv : (A B : U) (f: A -> B) (ef: isEquiv A B f) -> (a:A) -> (b:B) -> (eab: Id B (f a) b) -> Id ptU (pair A a) (pair B b) -lemPtEquiv A = elimIsEquiv A P rem - where - P : (B:U) -> (A->B) -> U - P B f = (a:A) -> (b:B) -> (eab: Id B (f a) b) -> Id ptU (pair A a) (pair B b) - - rem : P A (id A) - rem = cong A ptU (\ x -> pair A x) - --- swap with zero - -swZero : N -> N -> N -swZero = swapDisc N natDec zero - -lemSwZero : (x:N) -> neg (Id N zero x) -> Id N (swZero x x) zero -lemSwZero x neqzx = idSwapDisc1 N natDec zero x neqzx - -lem1SwZero : (x:N) -> neg (Id N zero x) -> isEquiv N N (swZero x) -lem1SwZero x neqzx = idemIsEquiv N (swZero x) (idemSwapDisc N natDec zero x neqzx) - --- we deduce that (N,x) is equal to (N,0) for any x in N - -homogeneous : (x:N) -> Id ptU (pair N x) (pair N zero) -homogeneous x = orElim (Id N zero x) (neg (Id N zero x)) (G x) rem1 rem (natDec zero x) - where - G : N -> U - G y = Id ptU (pair N y) (pair N zero) - - rem0 : G zero - rem0 = refl ptU (pair N zero) - - rem : neg (Id N zero x) -> G x - rem neqzx = lemPtEquiv N N (swZero x) (lem1SwZero x neqzx) x zero (lemSwZero x neqzx) - - rem1 : Id N zero x -> G x - rem1 eqzx = subst N G zero x eqzx rem0 - --- the following type is a contractible, hence a proposition - -sNzero : U -sNzero = singl ptU (pair N zero) -- Sigma (Sigma U (id U)) (\ v -> Id ptU u (pair N zero)) - -propSNzero : prop sNzero -propSNzero = singlIsProp ptU (pair N zero) - --- we have a map inhI N -> sNzero, with the notation of Nicolai Kraus - -flifted : inhI N -> sNzero -flifted = inhrecI N sNzero propSNzero (\ x -> pair (pair N x) (homogeneous x)) - -Tmyst : inhI N -> U -Tmyst x = fst U (id U) (fst ptU (\ v -> Id ptU v (pair N zero)) (flifted x)) - -myst : (x: inhI N) -> Tmyst x -myst x = snd U (id U) (fst ptU (\ v -> Id ptU v (pair N zero)) (flifted x)) - -mystN : (n: N) -> Tmyst (incI N n) -mystN n = myst (incI N n) - -propMyst : (n:N) -> Id N (myst (incI N n)) n -propMyst n = refl N n - -testMyst : N -> N +module Kraus where + +import swapDisc +import testInh + +-- we encode the example of Nicolai Kraus +-- for this we need the impredicative encoding of propositional truncation + +-- swap with zero + +swZero : N -> N -> N +swZero = swapF N eqN zero + + +homogeneous : (x:N) -> Id ptU (N,x) (N,zero) +homogeneous x = homogDec N eqN f0N f1N x zero + +-- test : (x:N) -> Id (Id ptU (N,x) (N,zero)) (homogeneous x) (homogeneous x) +-- test x = refl (Id ptU (N,x) (N,zero)) (homogeneous x) + +-- the following type is a contractible, hence a proposition + +sNzero : U +sNzero = singl ptU (N,zero) -- Sigma (Sigma U (id U)) (\ v -> Id ptU u (N,zero)) + +propSNzero : prop sNzero +propSNzero = singlIsProp ptU (N,zero) + +-- we have a map inhI N -> sNzero, with the notation of Nicolai Kraus + +flifted : inhI N -> sNzero +flifted = inhrecI N sNzero propSNzero (\ x -> ((N,x),homogeneous x)) + +Tmyst : inhI N -> U +Tmyst x = (flifted x).1.1 + +opaque homogeneous + +myst : (x: inhI N) -> Tmyst x +myst x = (flifted x).1.2 + +transparent homogeneous + +mystN : (n: N) -> Tmyst (incI N n) +mystN n = myst (incI N n) + +propMyst : (n:N) -> Id N (myst (incI N n)) n +propMyst n = refl N n + +testMyst : N -> N testMyst n = myst (incI N n) diff --git a/examples/UnotSet.cub b/examples/UnotSet.cub --- a/examples/UnotSet.cub +++ b/examples/UnotSet.cub @@ -17,7 +17,7 @@ fnot = transport Bool Bool eqBoolBool lem1 : Id (Bool -> Bool) frefl fnot - lem1 = cong (Id U Bool Bool) (Bool -> Bool) (transport Bool Bool) + lem1 = mapOnPath (Id U Bool Bool) (Bool -> Bool) (transport Bool Bool) (refl U Bool) eqBoolBool eqreflnot lem2 : Id Bool true (frefl true) @@ -27,7 +27,7 @@ lem3 = transpEquivEq Bool Bool not sNot tNot true lem4 : Id Bool (frefl true) (fnot true) - lem4 = cong (Bool -> Bool) Bool (\f -> f true) frefl fnot lem1 + lem4 = mapOnPath (Bool -> Bool) Bool (\f -> f true) frefl fnot lem1 lem5 : Id Bool true false lem5 = compDown Bool true (frefl true) false (fnot true) lem2 lem3 lem4 diff --git a/examples/axChoice.cub b/examples/axChoice.cub --- a/examples/axChoice.cub +++ b/examples/axChoice.cub @@ -15,30 +15,16 @@ T1 = Sigma ((x:A) -> B x) (\ f -> (x:A) -> C x (f x)) f : T0 -> T1 - f = \ s -> pair (\ x -> fst (B x) (C x) (s x)) (\ x -> snd (B x) (C x) (s x)) + f s = (\ x -> (s x).1, \ x -> (s x).2) g : T1 -> T0 - g = split - pair u v -> \ x -> pair (u x) (v x) + g z = \ x -> (z.1 x, z.2 x) sfg : (y:T1) -> Id T1 (f (g y)) y - sfg = split - pair u v -> rem u v - where - rem2 : (u:Pi A B) (v:(x:A) -> C x (u x)) -> Id T1 (pair (\ x -> u x) (\ x -> v x)) (pair (\ x -> u x) (\ x -> v x)) - rem2 u v = refl T1 (pair (\ x -> u x) (\ x -> v x)) - - rem1 : (u:Pi A B) (v:(x:A) -> C x (u x)) -> Id T1 (pair (\ x -> u x) (\ x -> v x)) (pair (\ x -> u x) v) - rem1 u = funSplit A (\ x -> C x (u x)) (\ v -> Id T1 (pair (\ x -> u x) (\ x -> v x)) (pair (\ x -> u x) v)) (rem2 u) - - rem : (u:Pi A B) (v:(x:A) -> C x (u x)) -> Id T1 (pair (\ x -> u x) (\ x -> v x)) (pair u v) - rem = funSplit A B (\ u -> (v:(x:A) -> C x (u x)) -> Id T1 (pair (\ x -> u x) (\ x -> v x)) (pair u v)) rem1 + sfg z = refl T1 z -- rem2 u v rfg : (s:T0) -> Id T0 (g (f s)) s - rfg s = funExt A (\ x -> Sigma (B x) (C x)) (g (f s)) s rem - where - rem : (x:A) -> Id (Sigma (B x) (C x)) (pair (fst (B x) (C x) (s x)) (snd (B x) (C x) (s x))) (s x) - rem x = surjPair (B x) (C x) (s x) + rfg s = refl T0 s -- we deduce from this equality that isEquiv f is a proposition diff --git a/examples/cong.cub b/examples/cong.cub --- a/examples/cong.cub +++ b/examples/cong.cub @@ -3,27 +3,27 @@ import set import function --- All of these lemmas on cong will be trivial with definitional equalities +-- All of these lemmas on mapOnPath will be trivial with definitional equalities congRefl : (A B : U) (f : A -> B) (a : A) -> - Id (Id B (f a) (f a)) (refl B (f a)) (cong A B f a a (refl A a)) -congRefl A B f a = Jeq A a (\v p -> Id B (f a) (f v)) (refl B (f a)) + Id (Id B (f a) (f a)) (refl B (f a)) (mapOnPath A B f a a (refl A a)) +congRefl A B f a = refl (Id B (f a) (f a)) (refl B (f a)) congId : (A : U) (a0 a1 : A) -> - Id (Id A a0 a1 -> Id A a0 a1) (id (Id A a0 a1)) (cong A A (id A) a0 a1) + Id (Id A a0 a1 -> Id A a0 a1) (id (Id A a0 a1)) (mapOnPath A A (id A) a0 a1) congId A a0 a1 = funExt (Id A a0 a1) (\_ -> Id A a0 a1) (id (Id A a0 a1)) - (cong A A (id A) a0 a1) (rem a0 a1) + (mapOnPath A A (id A) a0 a1) (rem a0 a1) where - rem1 : (u : A) -> Id (Id A u u) (refl A u) (cong A A (id A) u u (refl A u)) + rem1 : (u : A) -> Id (Id A u u) (refl A u) (mapOnPath A A (id A) u u (refl A u)) rem1 = congRefl A A (id A) - rem : (u0 u1 : A) -> (p : Id A u0 u1) -> Id (Id A u0 u1) p (cong A A (id A) u0 u1 p) - rem u0 = J A u0 (\u1 p -> Id (Id A u0 u1) p (cong A A (id A) u0 u1 p)) (rem1 u0) + rem : (u0 u1 : A) -> (p : Id A u0 u1) -> Id (Id A u0 u1) p (mapOnPath A A (id A) u0 u1 p) + rem u0 = J A u0 (\u1 p -> Id (Id A u0 u1) p (mapOnPath A A (id A) u0 u1 p)) (rem1 u0) congComp : (A B C : U) (f : A -> B) (g : B -> C) (a0 a1 : A) -> Id (Id A a0 a1 -> Id C (g (f a0)) (g (f a1))) - (cong A C (\x -> g (f x)) a0 a1) - (\p -> cong B C g (f a0) (f a1) (cong A B f a0 a1 p)) + (mapOnPath A C (\x -> g (f x)) a0 a1) + (\p -> mapOnPath B C g (f a0) (f a1) (mapOnPath A B f a0 a1 p)) congComp A B C f g a0 a1 = funExt (Id A a0 a1) (\_ -> Tgf a0 a1) (conggf a0 a1) (\p -> congg a0 a1 (congf a0 a1 p)) (rem a0 a1) where @@ -31,13 +31,13 @@ Tgf a0 a1 = Id C (g (f a0)) (g (f a1)) congf : (a0 a1 : A) -> Id A a0 a1 -> Id B (f a0) (f a1) - congf = cong A B f + congf = mapOnPath A B f congg : (a0 a1 : A) -> Id B (f a0) (f a1) -> Tgf a0 a1 - congg a0 a1 = cong B C g (f a0) (f a1) + congg a0 a1 = mapOnPath B C g (f a0) (f a1) conggf : (a0 a1 : A) -> Id A a0 a1 -> Tgf a0 a1 - conggf = cong A C (\x -> g (f x)) + conggf = mapOnPath A C (\x -> g (f x)) rem : (a0 a1 : A) (p : Id A a0 a1) -> Id (Tgf a0 a1) (conggf a0 a1 p) (congg a0 a1 (congf a0 a1 p)) @@ -51,7 +51,7 @@ rem4 = congRefl A B f a rem3 : Id (Tgf a a) (congg a a (refl B (f a))) (congg a a (congf a a (refl A a))) - rem3 = cong (Id B (f a) (f a)) (Tgf a a) (congg a a) (refl B (f a)) + rem3 = mapOnPath (Id B (f a) (f a)) (Tgf a a) (congg a a) (refl B (f a)) (congf a a (refl A a)) rem4 rem5 : Id (Tgf a a) (refl C (g (f a))) (congg a a (refl B (f a))) @@ -62,21 +62,4 @@ (congg a a (refl B (f a))) (congg a a (congf a a (refl A a))) rem2 rem3 rem5 --- a lemma about injective function - -lemInj : (A B : U) (f : A -> B) -> (injf : injective A B f) - -> ((x:A) -> Id (Id A x x) (refl A x) (injf x x (refl B (f x)))) - -> (x y : A) -> (p:Id A x y) -> Id (Id A x y) p (injf x y (cong A B f x y p)) -lemInj A B f injf h x = - J A x (\ y p -> Id (Id A x y) p (injf x y (cong A B f x y p))) rem - where - rem1 : Id (Id A x x) (refl A x) (injf x x (refl B (f x))) - rem1 = h x - - rem2 : Id (Id A x x) (injf x x (refl B (f x))) (injf x x (cong A B f x x (refl A x))) - rem2 = cong (Id B (f x) (f x)) (Id A x x) (injf x x) (refl B (f x)) (cong A B f x x (refl A x)) (congRefl A B f x) - - rem : Id (Id A x x) (refl A x) (injf x x (cong A B f x x (refl A x))) - rem = comp (Id A x x) (refl A x) (injf x x (refl B (f x))) (injf x x (cong A B f x x (refl A x))) - rem1 rem2 diff --git a/examples/contr.cub b/examples/contr.cub --- a/examples/contr.cub +++ b/examples/contr.cub @@ -27,11 +27,10 @@ -- this implies the other definition isContr : (A:U) -> contr' A -> contr A -isContr A = split - pair a f -> rem a f - where - rem : (a:A) -> ((x:A) -> Id A a x) -> contr A - rem a f = propContr A a (\ a0 a1 -> compInv A a a0 a1 (f a0) (f a1)) +isContr A z = rem z.1 z.2 + where + rem : (a:A) -> ((x:A) -> Id A a x) -> contr A + rem a f = propContr A a (\ a0 a1 -> compInv A a a0 a1 (f a0) (f a1)) isContrProd : (A:U) (B:A->U) -> ((x:A) -> contr (B x)) -> contr (Pi A B) isContrProd A B pB = subst U contr (A->Unit) (Pi A B) rem1 rem2 @@ -40,7 +39,7 @@ rem = funExt A (\ _ -> U) (\ _ -> Unit) B pB rem1 : Id U (A -> Unit) (Pi A B) - rem1 = cong (A -> U) U (Pi A) (\ _ -> Unit) B rem + rem1 = mapOnPath (A -> U) U (Pi A) (\ _ -> Unit) B rem f : Unit -> A -> Unit f z a = tt @@ -60,25 +59,23 @@ -- a sigma of props over a prop is a prop sigIsProp : (A:U) (B:A->U) (pB : (x:A) -> prop (B x)) -> prop A -> prop (Sigma A B) -sigIsProp A B pB pA = - split - pair a0 b0 -> split - pair a1 b1 -> eqSigma A B a0 a1 (pA a0 a1) b0 b1 (pB a1 (subst A B a0 a1 (pA a0 a1) b0) b1) +sigIsProp A B pB pA u v = + eqSigma A B u.1 v.1 (pA u.1 v.1) u.2 v.2 + (pB v.1 (subst A B u.1 v.1 (pA u.1 v.1) u.2) v.2) contr'IsProp : (A : U) -> prop (contr' A) contr'IsProp A = lemProp1 (contr' A) rem where rem : contr' A -> prop (contr' A) - rem = split - pair a p -> sigIsProp A (\ a0 -> (x:A) -> Id A a0 x) rem3 rem1 - where - rem1 : prop A - rem1 a0 a1 = compInv A a a0 a1 (p a0) (p a1) + rem z = sigIsProp A (\ a0 -> (x:A) -> Id A a0 x) rem3 rem1 + where + rem1 : prop A + rem1 a0 a1 = compInv A z.1 a0 a1 (z.2 a0) (z.2 a1) - rem2 : (a0 a1:A) -> prop (Id A a0 a1) - rem2 = propUIP A rem1 + rem2 : (a0 a1:A) -> prop (Id A a0 a1) + rem2 = propUIP A rem1 - rem3 : (a0:A) -> prop ((x:A) -> Id A a0 x) - rem3 a0 = isPropProd A (Id A a0) (rem2 a0) + rem3 : (a0:A) -> prop ((x:A) -> Id A a0 x) + rem3 a0 = isPropProd A (Id A a0) (rem2 a0) -- Voevodsky's definition of propositions @@ -102,39 +99,34 @@ F = P tt f : T -> F - f = split - pair x u -> rem x u + f z = rem z.1 z.2 where rem : (x:Unit) -> P x -> P tt - rem = split - tt -> \ u -> u + rem = split tt -> \ u -> u g : F -> T - g u = pair tt u + g u = (tt, u) rfg : (v:F) -> Id F (f (g v)) v rfg v = refl F v sfg : (v:T) -> Id T (g (f v)) v - sfg = split - pair x u -> rem x u - where rem : (x:Unit) -> (u : P x) -> Id T (g (f (pair x u))) (pair x u) - rem = split - tt -> \ u -> refl T (pair tt u) + sfg z = rem z.1 z.2 + where rem : (x:Unit) -> (u : P x) -> Id T (g (f (x, u))) (x, u) + rem = split tt -> \ u -> refl T (tt, u) lemContrSig : (A:U) -> contr A -> hasContrSig A lemContrSig A p = subst U hasContrSig Unit A p lemUnitSig singContr : (A:U) (a:A) -> contr (singl A a) -singContr A a = isContr T (pair (pair a (refl A a)) f) +singContr A a = isContr T ((a, refl A a), f) where T : U T = singl A a - f : (z:T) -> Id T (pair a (refl A a)) z - f = split - pair b p -> rem b a p + f : (z:T) -> Id T (a, refl A a) z + f z = rem z.1 a z.2 where - rem : (b:A) (a:A) (p:Id A b a) -> Id (singl A a) (pair a (refl A a)) (pair b p) - rem b = J A b (\ a p -> Id (singl A a) (pair a (refl A a)) (pair b p)) (refl (singl A b) (pair b (refl A b))) + rem : (b:A) (a:A) (p:Id A b a) -> Id (singl A a) (a, refl A a) (b, p) + rem b = J A b (\ a p -> Id (singl A a) (a, refl A a) (b, p)) (refl (singl A b) (b, refl A b)) -- any function between two contractible types is an equivalence diff --git a/examples/curry.cub b/examples/curry.cub --- a/examples/curry.cub +++ b/examples/curry.cub @@ -3,37 +3,19 @@ import swap curry : (A B C:U) -> ((and A B) -> C) -> A -> B -> C -curry A B C f a b = f (pair a b) +curry A B C f a b = f (a,b) uncurry : (A B C:U) -> (A -> B -> C) -> (and A B) -> C -uncurry A B C g = split - pair a b -> g a b - -secCurry : (A B C :U) (f : (and A B) -> C) - -> Id ((and A B) -> C) (uncurry A B C (curry A B C f)) f -secCurry A B C f = funExt (and A B) (\ _ -> C) (uncurry A B C (curry A B C f)) f rem - where - rem : (z:and A B) -> Id C (uncurry A B C (curry A B C f) z) (f z) - rem = split - pair a b -> refl C (f (pair a b)) - -retCurry : (A B C :U) (g : A -> B -> C) - -> Id (A -> B -> C) (curry A B C (uncurry A B C g)) g -retCurry A B C g = funExt A (\ _ -> B -> C) (curry A B C (uncurry A B C g)) g rem - where - rem : (a:A) -> Id (B -> C) (curry A B C (uncurry A B C g) a) (g a) - rem a = funExt B (\ _ -> C) (curry A B C (uncurry A B C g) a) (g a) rem1 - where - rem1 : (b:B) -> Id C (curry A B C (uncurry A B C g) a b) (g a b) - rem1 b = refl C (g a b) - +uncurry A B C g z = g z.1 z.2 eqCurry : (A B C : U) -> Id U ((and A B) -> C) (A -> B -> C) -eqCurry A B C = isEquivEq ((and A B) -> C) (A -> B -> C) (curry A B C) rem +eqCurry A B C = + isEquivEq T V (curry A B C) (gradLemma T V (curry A B C) (uncurry A B C) (refl V) (refl T)) where - rem : isEquiv ((and A B) -> C) (A -> B -> C) (curry A B C) - rem = gradLemma ((and A B) -> C) (A -> B -> C) - (curry A B C) (uncurry A B C) (retCurry A B C) (secCurry A B C) + T:U + T = (and A B) -> C + V : U + V = A -> B -> C typFst : U typFst = (X Y:U) -> (and X Y) -> X @@ -41,11 +23,10 @@ typFst1 : U typFst1 = (X Y:U) -> X -> Y -> X - eqTest : Id U typFst typFst1 eqTest = eqPi U (\ X -> Pi U (\ Y -> (and X Y) -> X)) (\ X -> Pi U (\ Y -> X -> Y -> X)) rem - where - rem : (X:U) -> Id U (Pi U (\ Y -> (and X Y) -> X)) (Pi U (\ Y -> X -> Y -> X)) + where + rem : (X:U) -> Id U (Pi U (\ Y -> (and X Y) -> X)) (Pi U (\ Y -> X -> Y -> X)) rem X = eqPi U (\ Y -> (and X Y) -> X) (\ Y -> X -> Y -> X) rem1 where rem1 : (Y:U) -> Id U ((and X Y) -> X) (X -> Y -> X) @@ -57,18 +38,18 @@ test : N test = transport typFst typFst1 - eqTest (\ X Y -> (fst X (\ _ -> Y))) N Bool zero true - + eqTest (\ X Y z -> z.1) N Bool zero true + test1 : N test1 = transport typFst typFst1 - eqTest (\ X Y -> (fst X (\ _ -> Y))) N Bool (suc zero) false + eqTest (\ X Y z -> z.1) N Bool (suc zero) false test2 : N -test2 = +test2 = transport typFst1 typFst - eqTestInv (\ X Y a b -> a) N Bool (pair zero true) - + eqTestInv (\ X Y a b -> a) N Bool (zero,true) + -- more test for the equality in U eqTest2 : Id U typFst typFst @@ -83,17 +64,17 @@ test4 : N test4 = transport typFst typFst - eqTest2 (\ X Y -> (fst X (\ _ -> Y))) N Bool (pair (suc zero) false) + eqTest2 (\ X Y z -> z.1) N Bool (suc zero,false) test5 : N test5 = transport typFst typFst1 - eqTest3 (\ X Y -> (fst X (\ _ -> Y))) N Bool (suc zero) false + eqTest3 (\ X Y z -> z.1) N Bool (suc zero) false test6 : N test6 = transport typFst typFst - eqTest4 (\ X Y -> (fst X (\ _ -> Y))) N Bool (pair (suc zero) false) + eqTest4 (\ X Y z -> z.1) N Bool (suc zero,false) diff --git a/examples/description.cub b/examples/description.cub --- a/examples/description.cub +++ b/examples/description.cub @@ -4,25 +4,20 @@ import set exAtOne : (A : U) (B : A -> U) -> exactOne A B -> atmostOne A B -exAtOne A B = split - pair g h' -> h' +exAtOne A B z = z.2 propSig : (A : U) (B : A -> U) -> propFam A B -> atmostOne A B -> prop (Sigma A B) -propSig A B h h' au bv = - eqPropFam A B h au bv (h' (fst A B au) (fst A B bv) (snd A B au) (snd A B bv)) +propSig A B h h' au bv = eqPropFam A B h au bv (h' au.1 bv.1 au.2 bv.2) descrAx : (A : U) (B : A -> U) -> propFam A B -> exactOne A B -> Sigma A B -descrAx A B h = split - pair g h' -> lemInh (Sigma A B) rem g - where rem : prop (Sigma A B) - rem = propSig A B h h' +descrAx A B h z = lemInh (Sigma A B) (propSig A B h z.2) z.1 iota : (A : U) (B : A -> U) (h : propFam A B) (h' : exactOne A B) -> A -iota A B h h' = fst A B (descrAx A B h h') +iota A B h h' = (descrAx A B h h').1 iotaSound : (A : U) (B : A -> U) (h : propFam A B) (h' : exactOne A B) -> B (iota A B h h') -iotaSound A B h h' = snd A B (descrAx A B h h') +iotaSound A B h h' = (descrAx A B h h').2 iotaLem : (A : U) (B : A -> U) (h : propFam A B) (h' : exactOne A B) -> (a : A) -> B a -> Id A a (iota A B h h') diff --git a/examples/elimEquiv.cub b/examples/elimEquiv.cub --- a/examples/elimEquiv.cub +++ b/examples/elimEquiv.cub @@ -14,7 +14,7 @@ elimIsEquiv : (A:U) -> (P : (B:U) -> (A->B) -> U) -> P A (id A) -> (B :U) -> (f : A -> B) -> isEquiv A B f -> P B f -elimIsEquiv A P d = \ B f if -> rem2 B (pair f if) +elimIsEquiv A P d B f if = rem2 B (f,if) where rem1 : P A (transport A A (refl U A)) rem1 = subst (A->A) (P A) (id A) (transport A A (refl U A)) (transpRef A) d @@ -22,6 +22,6 @@ rem : (B:U) -> (p:Id U A B) -> P B (transport A B p) rem = J U A (\ B p -> P B (transport A B p)) rem1 - rem2 : (B:U) -> (p:Equiv A B) -> P B (funEquiv A B p) - rem2 B = allSection (Id U A B) (Equiv A B) (IdToEquiv A B) (allTransp A B) (\ p -> P B (funEquiv A B p)) (rem B) + rem2 : (B:U) -> (p:Equiv A B) -> P B p.1 + rem2 B = allSection (Id U A B) (Equiv A B) (IdToEquiv A B) (allTransp A B) (\ p -> P B p.1) (rem B) diff --git a/examples/epi.cub b/examples/epi.cub --- a/examples/epi.cub +++ b/examples/epi.cub @@ -3,6 +3,7 @@ module epi where import omega +import exists -- surjective and epi maps @@ -10,7 +11,7 @@ isEpi A B f = (X:U) -> set X -> (g h:B->X) -> Id (A->X) (\ a -> g (f a)) (\ a -> h (f a)) -> Id (B->X) g h isSurj : (A B:U) -> (A->B) -> U -isSurj A B f = (y:B) -> exist A (\ x -> Id B (f x) y) +isSurj A B f = (y:B) -> exists A (\ x -> Id B (f x) y) -- these properties should be equivalent @@ -26,7 +27,7 @@ rem1 : prop G rem1 = sX (g y) (h y) - rem2 : exist A (\ x -> Id B (f x) y) + rem2 : exists A (\ x -> Id B (f x) y) rem2 = sf y rem4 : (x:A) -> Id X (g (f x)) (h (f x)) @@ -36,8 +37,7 @@ rem3 x p = subst B (\ z -> Id X (g z) (h z)) (f x) y p (rem4 x) rem5 : (Sigma A (\ x -> Id B (f x) y)) -> G - rem5 = split - pair x p -> rem3 x p + rem5 z = rem3 z.1 z.2 rem6 : G rem6 = exElim A (\ x -> Id B (f x) y) G rem1 rem5 rem2 @@ -51,13 +51,13 @@ rem = ef Omega omegaIsSet g : B -> Omega - g y = pair Unit propUnit + g y = (Unit,propUnit) h : B -> Omega - h y = pair (exist A (\ x -> Id B (f x) y)) (squash (Sigma A (\ x -> Id B (f x) y))) + h y = (exists A (\ x -> Id B (f x) y),squash (Sigma A (\ x -> Id B (f x) y))) rem1 : (x:A) -> isTrue (h (f x)) - rem1 x = inc (Sigma A (\ z -> Id B (f z) (f x))) (pair x (refl B (f x))) + rem1 x = inc (Sigma A (\ z -> Id B (f z) (f x))) (x,refl B (f x)) rem2 : (x:A) -> Id Omega (g (f x)) (h (f x)) rem2 x = lemIsTrue (g (f x)) (h (f x)) (\ _ -> rem1 x) (\ _ -> tt) diff --git a/examples/equivSet.cub b/examples/equivSet.cub --- a/examples/equivSet.cub +++ b/examples/equivSet.cub @@ -13,25 +13,22 @@ fFiber : B -> U fFiber b = fiber A B f b - fstfFiber : (b : B) -> fFiber b -> A - fstfFiber b = fst A (\x -> Id B (f x) b) - eqfFiber : (b : B) -> (v v' : fFiber b) -> - Id A (fstfFiber b v) (fstfFiber b v') -> Id (fFiber b) v v' + Id A v.1 v'.1 -> Id (fFiber b) v v' eqfFiber b = eqPropFam A (\x -> Id B (f x) b) (\x -> setB (f x) b) sf : (b : B) -> fFiber b - sf b = pair (g b) (sfg b) + sf b = (g b, sfg b) tf : (b : B) (v : fFiber b) -> Id (fFiber b) (sf b) v tf b v = eqfFiber b (sf b) v rem where a' : A - a' = fstfFiber b v + a' = v.1 rem1 : Id B (f (g b)) (f a') rem1 = comp B (f (g b)) b (f a') (sfg b) - (inv B (f a') b (snd A (\x -> Id B (f x) b) v)) + (inv B (f a') b v.2) rem : Id A (g b) a' rem = injf (g b) a' rem1 diff --git a/examples/equivTotal.cub b/examples/equivTotal.cub --- a/examples/equivTotal.cub +++ b/examples/equivTotal.cub @@ -4,11 +4,8 @@ -- equivalence on total space -lem3Sub : (A:U) (P: A -> U) (a:A) -> Id U (Sigma (singl A a) (\ z -> P (fst A (\ x -> Id A x a) z))) (P a) -lem3Sub A P a = lemContrSig (singl A a) (singContr A a) Q (pair a (refl A a)) - where - Q : singl A a -> U - Q z = P (fst A (\ x -> Id A x a) z) +lem3Sub : (A:U) (P: A -> U) (a:A) -> Id U (Sigma (singl A a) (\ z -> P z.1)) (P a) +lem3Sub A P a = lemContrSig (singl A a) (singContr A a) (\ x -> P x.1) (a,refl A a) -- a corollary of equivalence @@ -22,7 +19,7 @@ elimIsEquiv : (A:U) -> (P : (B:U) -> (A->B) -> U) -> P A (id A) -> (B :U) -> (f : A -> B) -> isEquiv A B f -> P B f -elimIsEquiv A P d = \ B f if -> rem2 B (pair f if) +elimIsEquiv A P d = \ B f if -> rem2 B (f,if) where rem1 : P A (transport A A (refl U A)) rem1 = subst (A->A) (P A) (id A) (transport A A (refl U A)) (transpRef A) d @@ -30,100 +27,56 @@ rem : (B:U) -> (p:Id U A B) -> P B (transport A B p) rem = J U A (\ B p -> P B (transport A B p)) rem1 - rem2 : (B:U) -> (p:Equiv A B) -> P B (funEquiv A B p) - rem2 B = allSection (Id U A B) (Equiv A B) (IdToEquiv A B) (allTransp A B) (\ p -> P B (funEquiv A B p)) (rem B) + rem2 : (B:U) -> (p:Equiv A B) -> P B p.1 + rem2 B = allSection (Id U A B) (Equiv A B) (IdToEquiv A B) (allTransp A B) + (\ p -> P B p.1) (rem B) --- a simple application; with yet another problem with eta conversion +-- a simple application; with the problem with eta conversion resolved -equivSigId : (A B :U) -> (f:A -> B) -> isEquiv A B f -> (Q : B -> U) -> Id U (Sigma A (\ x -> Q (f x))) (Sigma B Q) -equivSigId A = elimIsEquiv A P d +equivSigId : (A B :U) (f:A -> B) + -> isEquiv A B f -> (Q : B -> U) -> Id U (Sigma A (\ x -> Q (f x))) (Sigma B Q) +equivSigId A = elimIsEquiv A P (\ Q -> refl U (Sigma A Q)) where P : (B:U) -> (A-> B) -> U P B f = (Q : B -> U) -> Id U (Sigma A (\ x -> Q (f x))) (Sigma B Q) - d : P A (id A) - d Q = rem - where - rem : Id U (Sigma A (\ x -> Q x)) (Sigma A Q) - rem = cong (A -> U) U (Sigma A) (\ x -> Q x) Q (funExt A (\ _ -> U) (\ x -> Q x) Q (\ x -> refl U (Q x))) - -- application to equivalences between total spaces liftTot : (A:U) (P Q : A -> U) (g : (x:A) -> P x -> Q x) -> Sigma A P -> Sigma A Q -liftTot A P Q g = split - pair a u -> pair a (g a u) - -lem3Sub : (A:U) (P: A -> U) (a:A) -> Id U (Sigma (singl A a) (\ z -> P (fst A (\ x -> Id A x a) z))) (P a) -lem3Sub A P a = lemContrSig (singl A a) (singContr A a) Q (pair a (refl A a)) - where - Q : singl A a -> U - Q z = P (fst A (\ x -> Id A x a) z) +liftTot A P Q g z = (z.1,g z.1 z.2) +lem3Sub : (A:U) (P: A -> U) (a:A) -> Id U (Sigma (singl A a) (\ z -> P z.1)) (P a) +lem3Sub A P a = lemContrSig (singl A a) (singContr A a) (\ x -> P x.1) (a,refl A a) -lem2Sub : (A:U) (P: A -> U) (a:A) -> Id U (fiber (Sigma A P) A (fst A P) a) - (Sigma (Sigma A (\ x -> Id A x a)) (\ z -> P (fst A (\ x -> Id A x a) z))) -lem2Sub A P a = isoId F T f g sfg rfg - where +lem2Sub : (A:U) (P: A -> U) (a:A) + -> Id U (fiber (Sigma A P) A (\x -> x.1) a) + (Sigma (Sigma A (\ x -> Id A x a)) (\ z -> P z.1)) +lem2Sub A P a = + isoId F T (\ u -> ((u.1.1,u.2),u.1.2)) (\ v -> ((v.1.1,v.2),v.1.2)) (refl T) (refl F) + where T : U - T = Sigma (Sigma A (\ x -> Id A x a)) (\ z -> P (fst A (\ x -> Id A x a) z)) + T = Sigma (Sigma A (\ x -> Id A x a)) (\ z -> P z.1) F : U - F = fiber (Sigma A P) A (fst A P) a - - f : F -> T - f = split - pair z p -> rem z p - where rem : (z : Sigma A P) (p : Id A (fst A P z) a) -> T - rem = split - pair x u -> \ p -> pair (pair x p) u - - g : T -> F - g = split - pair z u -> rem z u - where rem : (z: Sigma A (\x -> Id A x a)) -> (u: P (fst A (\ x -> Id A x a) z)) -> fiber (Sigma A P) A (fst A P) a - rem = split - pair x p -> \ u -> pair (pair x u) p - - rfg : (v :F) -> Id F (g (f v)) v - rfg = split - pair z p -> rem z p - where rem : (z : Sigma A P) (p : Id A (fst A P z) a) -> Id (fiber (Sigma A P) A (fst A P) a) (g (f (pair z p))) (pair z p) - rem = split - pair x u -> \ p -> refl F (pair (pair x u) p) - - sfg : (v:T) -> Id T (f (g v)) v - sfg = split - pair z u -> rem z u - where rem : (z: Sigma A (\x -> Id A x a)) -> (u: P (fst A (\ x -> Id A x a) z)) -> Id T (f (g (pair z u))) (pair z u) - rem = split - pair x p -> \ u -> refl T (pair (pair x p) u) + F = fiber (Sigma A P) A (\x -> x.1) a -lem1Sub : (A:U) (P: A -> U) (a:A) -> Id U (fiber (Sigma A P) A (fst A P) a) (P a) +lem1Sub : (A:U) (P: A -> U) (a:A) -> Id U (fiber (Sigma A P) A (\ z -> z.1) a) (P a) lem1Sub A P a = - comp U (fiber (Sigma A P) A (fst A P) a) (Sigma (singl A a) (\ z -> P (fst A (\ x -> Id A x a) z))) (P a) - (lem2Sub A P a) (lem3Sub A P a) - --- retsub : (A:U) -> (P : subset2 A) -> Id (subset2 A) (sub12 A (sub21 A P)) P --- retsub A P = funExt A (\ _ -> U) (fiber (Sigma A P) A (fst A P)) P (lem1Sub A P) - - - - - - + comp U (fiber (Sigma A P) A (\ x -> x.1) a) + (Sigma (singl A a) (\ z -> P z.1)) (P a) (lem2Sub A P a) (lem3Sub A P a) equivTot : (A:U) (P Q : A -> U) (g : (x:A) -> P x -> Q x) -> isEquiv (Sigma A P) (Sigma A Q) (liftTot A P Q g) -> (a:A) -> Id U (P a) (Q a) equivTot A P Q g igl a = rem5 where F : Sigma A P -> U - F z = Id A (fst A P z) a + F z = Id A z.1 a T : U T = Sigma (Sigma A P) F G : Sigma A Q -> U - G z = Id A (fst A Q z) a + G z = Id A z.1 a V : U V = Sigma (Sigma A Q) G @@ -144,10 +97,9 @@ rem2 = equivSigId (Sigma A P) (Sigma A Q) (liftTot A P Q g) igl G rem3 : Id U T T1 - rem3 = cong (Sigma A P -> U) U (Sigma (Sigma A P)) F F1 eFF1 + rem3 = mapOnPath (Sigma A P -> U) U (Sigma (Sigma A P)) F F1 eFF1 where fFF1 : (z : Sigma A P) -> Id U (F z) (F1 z) - fFF1 = split - pair x u -> refl U (Id A x a) + fFF1 z = refl U (Id A z.1 a) eFF1 : Id (Sigma A P -> U) F F1 eFF1 = funExt (Sigma A P) (\ _ -> U) F F1 fFF1 @@ -190,7 +142,7 @@ T = Pi A B G : (z:Pi A B) -> P z -> Q z - G z ez x = cong (Pi A B) (B x) (\ u -> u x) z g ez + G z ez x = mapOnPath (Pi A B) (B x) (\ u -> u x) z g ez rem1 : contr (Sigma T P) rem1 = singContr (Pi A B) g diff --git a/examples/finite.cub b/examples/finite.cub --- a/examples/finite.cub +++ b/examples/finite.cub @@ -1,11 +1,11 @@ module finite where --- definition of finite sets and cardinality +-- definition of finite sets and cardinality import description -import function +import function import gradLemma -import Kraus +import swapDisc_old step : U -> U step X = or Unit X @@ -41,17 +41,17 @@ inr _ -> Unit decSt : (X:U) -> discrete X -> discrete (step X) -decSt X dX = +decSt X dX = split inl a -> split - inl a1 -> inl (cong Unit (step X) (incUnSt X) a a1 (propUnit a a1)) + inl a1 -> inl (mapOnPath Unit (step X) (incUnSt X) a a1 (propUnit a a1)) inr b -> inr (inlNotinr Unit X a b) inr b -> split inl a -> inr (inrNotinl Unit X a b) inr b1 -> rem (dX b b1) where rem : dec (Id X b b1) -> dec (Id (step X) (inr b) (inr b1)) rem = split - inl p -> inl (cong X (step X) (incSt X) b b1 p) + inl p -> inl (mapOnPath X (step X) (incSt X) b b1 p) inr h -> inr (\ p -> h (injSt X b b1 p)) stFin : N -> U @@ -78,15 +78,12 @@ rfg : (x:X) -> Id X (f (g x)) x rfg x = refl X x - ef : isEquiv (or X N0) X f + ef : isEquiv (or X N0) X f ef = gradLemma (or X N0) X f g rfg sfg - - N0Dec : discrete N0 N0Dec = \ x y -> efq (dec (Id N0 x y)) x - finDec : (n:N) -> discrete (stFin n) finDec = split zero -> N0Dec @@ -97,124 +94,125 @@ tt -> split tt -> inl (refl Unit tt) - -isolated : (A:U) -> A -> U -isolated A a = (x:A) -> dec (Id A a x) - -- take away one element takeAway : (A:U) -> A -> U takeAway A a = Sigma A (\ x -> neg (Id A a x)) tAway : ptU -> U -tAway = split - pair A a -> takeAway A a +tAway z = takeAway z.1 z.2 -botEl : (n:N) -> stFin (suc n) -botEl n = inl tt +-- this has been generalized from a special case -eqTkA : (n:N) -> Id U (takeAway (stFin (suc n)) (botEl n)) (stFin n) -eqTkA n = isEquivEq tS (stFin n) f equivf +eqTkA : (X:U) -> Id U (takeAway (step X) (inl tt)) X +eqTkA X = isEquivEq tS X f equivf where stS : U - stS = stFin (suc n) + stS = step X bn : stS - bn = botEl n + bn = inl tt tS : U tS = takeAway stS bn - faux : (x:stS) -> neg (Id stS bn x) -> stFin n + faux : (x:stS) -> neg (Id stS bn x) -> X faux = split - inl u -> \ h -> efq (stFin n) (h rem) + inl u -> \ h -> efq X (h rem) where rem : Id stS bn (inl u) - rem = cong Unit stS (incUnSt (stFin n)) tt u (propUnit tt u) + rem = mapOnPath Unit stS (incUnSt X) tt u (propUnit tt u) inr z -> \ _ -> z - f : tS -> stFin n - f = split - pair x p -> faux x p + f : tS -> X + f z = faux z.1 z.2 - lem : (x:stFin n) -> neg (Id stS bn (inr x)) - lem x = inlNotinr Unit (stFin n) tt x + lem : (x:X) -> neg (Id stS bn (inr x)) + lem x = inlNotinr Unit X tt x - g : stFin n -> tS - g x = pair (inr x) (lem x) + g : X -> tS + g x = (inr x,lem x) T : stS -> U T x = neg (Id stS bn x) lem1 : (u:Unit) -> Id stS bn (inl u) - lem1 u = cong Unit stS (incUnSt (stFin n)) tt u (propUnit tt u) + lem1 u = mapOnPath Unit stS (incUnSt X) tt u (propUnit tt u) lem2 : propFam stS T lem2 = \ x -> propNeg (Id stS bn x) - sfg : (x:stFin n) -> Id (stFin n) (f (g x)) x - sfg x = refl (stFin n) x + sfg : (x:X) -> Id X (f (g x)) x + sfg x = refl X x rfg : (z:tS) -> Id tS (g (f z)) z - rfg = split - pair x p -> rem x p - where rem : (x:stS) -> (p : T x) -> Id tS (g (f (pair x p))) (pair x p) + rfg z = rem z.1 z.2 + where rem : (x:stS) -> (p : T x) -> Id tS (g (f (x,p))) (x,p) rem = split - inl u -> \ h -> efq (Id tS (g (f (pair (inl u) h))) (pair (inl u) h)) (h (lem1 u)) + inl u -> \ h -> efq (Id tS (g (f (inl u,h))) (inl u,h)) (h (lem1 u)) inr z -> \ h -> eqPropFam stS T lem2 - (pair (inr z) (lem (faux (inr z) h))) (pair (inr z) h) (refl stS (inr z)) - - equivf : isEquiv tS (stFin n) f - equivf = gradLemma tS (stFin n) f g sfg rfg - --- Pointed set with one isolated element + (inr z,lem (faux (inr z) h)) (inr z,h) (refl stS (inr z)) -hasPointIso : U -> U -hasPointIso A = Sigma A (isolated A) + equivf : isEquiv tS X f + equivf = gradLemma tS X f g sfg rfg + +botEl : (n:N) -> stFin (suc n) +botEl n = inl tt + ptBot : N -> ptU -ptBot n = pair (stFin (suc n)) (botEl n) +ptBot n = (stFin (suc n),botEl n) -corEqTkA : (n:N) -> Id U (tAway (ptBot n)) (stFin n) -corEqTkA = eqTkA +mkPtU : (n:N) (x:stFin (suc n)) -> ptU +mkPtU n x = (stFin (suc n),x) -mkPtU : (n:N) (x:stFin (suc n)) -> ptU -mkPtU n x = pair (stFin (suc n)) x +homogSt : (X:U) -> discrete X -> (x:step X) -> Id ptU (step X,x) (step X,inl tt) +homogSt X dX x = homogDec (step X) (decSt X dX) x (inl tt) -homogSt : (n:N) (x:stFin (suc n)) -> Id ptU (mkPtU n x) (ptBot n) -homogSt n x = undefined +corHomogSt : (X:U) -> discrete X -> (x:step X) -> Id U (takeAway (step X) x) X +corHomogSt X dX x = + substInv ptU (\ z -> Id U (tAway z) X) (step X,x) (step X,inl tt) + (homogSt X dX x) (eqTkA X) +-- eqTkA : (X:U) -> Id U (takeAway (step X) (inl tt)) X + +homogSt' : (n:N) (x:stFin (suc n)) -> Id ptU (mkPtU n x) (ptBot n) +homogSt' n = homogSt (stFin n) (finDec n) + +corEqTkA : (n:N) -> Id U (tAway (ptBot n)) (stFin n) +corEqTkA n = eqTkA (stFin n) + cor1EqTkA : (n:N) (x:stFin (suc n)) -> Id U (tAway (mkPtU n x)) (stFin n) -cor1EqTkA n x = - substInv ptU (\ z -> Id U (tAway z) (stFin n)) (mkPtU n x) (ptBot n) (homogSt n x) (corEqTkA n) +cor1EqTkA n x = + substInv ptU (\ z -> Id U (tAway z) (stFin n)) (mkPtU n x) (ptBot n) (homogSt' n x) (corEqTkA n) -lemInjSt : (n m:N) -> Id U (stFin (suc n)) (stFin (suc m)) -> Id U (stFin n) (stFin m) -lemInjSt n m h = lem5 +lemInjSt : (X Y:U) -> discrete X -> Id U (step X) (step Y) -> Id U X Y +lemInjSt X Y dX h = lem5 where P : U -> U - P X = (x:X) -> Id U (takeAway X x) (stFin n) + P Z = (x:Z) -> Id U (takeAway Z x) X - lem1 : P (stFin (suc n)) - lem1 = cor1EqTkA n + lem1 : P (step X) + lem1 = corHomogSt X dX - lem2 : P (stFin (suc m)) - lem2 = subst U P (stFin (suc n)) (stFin (suc m)) h lem1 + lem2 : P (step Y) + lem2 = subst U P (step X) (step Y) h lem1 Am : U - Am = takeAway (stFin (suc m)) (botEl m) + Am = takeAway (step Y) (inl tt) - lem3 : Id U Am (stFin m) - lem3 = cor1EqTkA m (botEl m) + lem3 : Id U Am Y + lem3 = eqTkA Y - lem4 : Id U Am (stFin n) - lem4 = lem2 (botEl m) + lem4 : Id U Am X + lem4 = lem2 (inl tt) - lem5 : Id U (stFin n) (stFin m) - lem5 = comp U (stFin n) Am (stFin m) (inv U Am (stFin n) lem4) lem3 + lem5 : Id U X Y + lem5 = comp U X Am Y (inv U Am X lem4) lem3 lem1InjSt : (n:N) -> neg (Id U N0 (stFin (suc n))) -lem1InjSt n h = transportInv N0 (stFin (suc n)) h (botEl n) +lem1InjSt n h = transportInv N0 (stFin (suc n)) h (botEl n) lem2InjSt : (n:N) -> neg (Id U (stFin (suc n)) N0) -lem2InjSt n h = transport (stFin (suc n)) N0 h (botEl n) +lem2InjSt n h = transport (stFin (suc n)) N0 h (botEl n) lemInj : injective N U stFin lemInj = split @@ -223,7 +221,8 @@ suc m -> \ h -> efq (Id N zero (suc m)) (lem1InjSt m h) suc n -> split zero -> \ h -> efq (Id N (suc n) zero) (lem2InjSt n h) - suc m -> \ h -> cong N N (\ x -> suc x) n m (lemInj n m (lemInjSt n m h)) + suc m -> \ h -> + mapOnPath N N (\ x -> suc x) n m (lemInj n m (lemInjSt (stFin n) (stFin m) (finDec n) h)) eqsT : U -> N -> U eqsT X n = inh (Id U (stFin n) X) @@ -235,7 +234,7 @@ lemEqsT X n m = rem2 where G : U - G = Id N n m + G = Id N n m pG : prop G pG = NIsSet n m @@ -244,10 +243,10 @@ rem ln lm = lemInj n m (comp U (stFin n) X (stFin m) ln (inv U (stFin m) X lm)) rem1 : Id U (stFin n) X -> eqsT X m -> G - rem1 ln = inhrec (Id U (stFin m) X) G pG (rem ln) + rem1 ln = inhrec (Id U (stFin m) X) G pG (rem ln) rem2 : eqsT X n -> eqsT X m -> G - rem2 hn hm = inhrec (Id U (stFin n) X) G pG (\ l -> rem1 l hm) hn + rem2 hn hm = inhrec (Id U (stFin n) X) G pG (\ l -> rem1 l hm) hn propEqsT : (X:U) -> prop (Sigma N (eqsT X)) propEqsT X = propSig N (eqsT X) (\ n -> squash (Id U (stFin n) X)) rem @@ -257,16 +256,15 @@ cardFin : (X:U) -> finite X -> Sigma N (eqsT X) cardFin X = inhrec (Sigma N (eqsT X)) (Sigma N (eqsT X)) (propEqsT X) (\ h -> h) --- Unit is finite +-- Unit is finite finUnit : finite Unit finUnit = inc (Sigma N (eqsT Unit)) rem where rem : Sigma N (eqsT Unit) - rem = pair (suc zero) (inc (Id U (stFin (suc zero)) Unit) (lemN0 Unit)) + rem = (suc zero,inc (Id U (stFin (suc zero)) Unit) (lemN0 Unit)) rem1 : Id U (stFin (suc zero)) Unit rem1 = lemN0 Unit test : N -test = fst N (eqsT Unit) (cardFin Unit finUnit) - +test = (cardFin Unit finUnit).1 diff --git a/examples/function.cub b/examples/function.cub --- a/examples/function.cub +++ b/examples/function.cub @@ -4,7 +4,7 @@ -- some general facts about functions --- g is a section of f +-- g is a section of f section : (A B : U) (f : A -> B) (g : B -> A) -> U section A B f g = (b : B) -> Id B (f (g b)) b @@ -14,7 +14,7 @@ retract : (A B : U) (f : A -> B) (g : B -> A) -> U retract A B f g = section B A g f -retractInj : (A B : U) (f : A -> B) (g : B -> A) -> +retractInj : (A B : U) (f : A -> B) (g : B -> A) -> retract A B f g -> injective A B f retractInj A B f g h a0 a1 h' = compUp A (g (f a0)) a0 (g (f a1)) a1 rem1 rem2 rem3 where @@ -25,44 +25,33 @@ rem2 = h a1 rem3 : Id A (g (f a0)) (g (f a1)) - rem3 = cong B A g (f a0) (f a1) h' - - + rem3 = mapOnPath B A g (f a0) (f a1) h' hasSection : (A B : U) -> (A -> B) -> U -hasSection A B f = Sigma (B->A) (section A B f) +hasSection A B f = Sigma (B->A) (section A B f) -- an equivalence has a section equivSec : (A B :U) -> (f:A->B) -> isEquiv A B f -> hasSection A B f -equivSec A B f = - split - pair s t -> pair g rem - where g : B -> A - g y = fst A (\ x -> Id B (f x) y) (s y) - - rem : (y:B) -> Id B (f (g y)) y - rem y = snd A (\ x -> Id B (f x) y) (s y) - -allSection : (A B : U) (f:A->B) -> hasSection A B f -> (Q : B->U) -> ((x:A) -> Q (f x)) -> Pi B Q -allSection A B f = - split - pair g sfg -> rem - where rem : (Q : B->U) -> ((x:A) -> Q (f x)) -> Pi B Q - rem Q h y = rem2 - where rem1 : Q (f (g y)) - rem1 = h (g y) +equivSec A B f st = (\y -> (st.1 y).1, \y -> (st.1 y).2) - rem2 : Q y - rem2 = subst B Q (f (g y)) y (sfg y) rem1 +allSection : (A B : U) (f:A->B) -> hasSection A B f + -> (Q : B->U) -> ((x:A) -> Q (f x)) -> Pi B Q +allSection A B f z = rem + where rem : (Q : B->U) -> ((x:A) -> Q (f x)) -> Pi B Q + rem Q h y = rem2 + where rem1 : Q (f (z.1 y)) + rem1 = h (z.1 y) + rem2 : Q y + rem2 = subst B Q (f (z.1 y)) y (z.2 y) rem1 -isEquivSection : (A B : U) (f : A -> B) (g : B -> A) -> section A B f g -> +isEquivSection : (A B : U) (f : A -> B) (g : B -> A) -> section A B f g -> ((b : B) -> prop (fiber A B f b)) -> isEquiv A B f -isEquivSection A B f g sfg h = pair s t +isEquivSection A B f g sfg h = (s, t) where s : (y : B) -> fiber A B f y - s y = pair (g y) (sfg y) + s y = (g y, sfg y) t : (y : B) -> (v : fiber A B f y) -> Id (fiber A B f y) (s y) v t y v = h y (s y) v @@ -74,6 +63,5 @@ injId X a0 a1 h = h -idempotent : (A:U) -> (A->A) -> U -idempotent A f = section A A f f - +involutive : (A:U) -> (A->A) -> U +involutive A f = section A A f f diff --git a/examples/gradLemma.cub b/examples/gradLemma.cub --- a/examples/gradLemma.cub +++ b/examples/gradLemma.cub @@ -2,19 +2,19 @@ import equivProp import BoolEqBool -import cong corrstId : (A : U) (a : A) -> prop (fiber A A (id A) a) -corrstId A a v0 v1 = compInv (pathTo A a) (sId A a) v0 v1 (tId A a v0) (tId A a v1) +corrstId A a v0 v1 = compInv (pathTo A a) (sId A a) v0 v1 (tId A a v0) (tId A a v1) -corr2stId : (A : U) (h : A -> A) (ph : (x : A) -> Id A (h x) x) (a : A) -> +corr2stId : (A : U) (h : A -> A) (ph : (x : A) -> Id A (h x) x) (a : A) -> prop (fiber A A h a) corr2stId A h ph a = substInv (A -> A) (\h -> prop (fiber A A h a)) h (id A) rem (corrstId A a) - where + where rem : Id (A -> A) h (id A) - rem = funExt A (\_ -> A) h (id A) ph + rem = funExt A (\_ -> A) h (id A) ph -gradLemma : (A B : U) (f : A -> B) (g : B -> A) -> section A B f g -> retract A B f g -> + +gradLemma : (A B : U) (f : A -> B) (g : B -> A) -> section A B f g -> retract A B f g -> isEquiv A B f gradLemma A B f g sfg rfg = isEquivSection A B f g sfg rem where @@ -22,124 +22,66 @@ injf = retractInj A B f g rfg rem : (b : B) -> prop (Sigma A (\a -> Id B (f a) b)) - rem b = split - pair a0 e0 -> - split - pair a1 e1 -> rem19 - where - E : A -> U - E a = Id B (f a) b - F : A -> U - F a = Id A (g (f a)) (g b) - G : A -> U - G a = Id B (f (g (f a))) (f (g b)) - - z0 : Sigma A E - z0 = pair a0 e0 - z1 : Sigma A E - z1 = pair a1 e1 - - cg : (a:A) -> E a -> F a - cg a = cong B A g (f a) b - - cf : (a:A) -> F a -> G a - cf a = cong A B f (g (f a)) (g b) - - cfg : (a:A) -> E a -> G a - cfg a = cong B B (\ x -> f (g x)) (f a) b - - pcg : Sigma A E -> Sigma A F - pcg = split - pair a e -> pair a (cg a e) - - pcf : Sigma A F -> Sigma A G - pcf = split - pair a e -> pair a (cf a e) - - fg : B -> B - fg y = f (g y) - - pc : (u:B -> B) -> Sigma A E -> Sigma A (\ a -> Id B (u (f a)) (u b)) - pc u = split - pair a e -> pair a (cong B B u (f a) b e) - - rem1 : prop (Sigma A F) - rem1 = corr2stId A (\ x -> g (f x)) rfg (g b) - - rem2 : Id (Sigma A F) (pcg z0) (pcg z1) - rem2 = rem1 (pcg z0) (pcg z1) - - rem3 : Id (Sigma A G) (pcf (pcg z0)) (pcf (pcg z1)) - rem3 = cong (Sigma A F) (Sigma A G) pcf (pcg z0) (pcg z1) rem2 - - rem4 : Id (E a0 -> G a0) (cfg a0) (\ e -> cf a0 (cg a0 e)) - rem4 = congComp B A B g f (f a0) b - - rem5 : Id (G a0) (cfg a0 e0) (cf a0 (cg a0 e0)) - rem5 = appId (E a0) (G a0) e0 (cfg a0) (\ e -> cf a0 (cg a0 e)) rem4 - - rem6 : Id (Sigma A G) (pc fg z0) (pcf (pcg z0)) - rem6 = cong (G a0) (Sigma A G) (\ e -> pair a0 e) (cfg a0 e0) (cf a0 (cg a0 e0)) rem5 - - rem7 : Id (E a1 -> G a1) (cfg a1) (\ e -> cf a1 (cg a1 e)) - rem7 = congComp B A B g f (f a1) b - - rem8 : Id (G a1) (cfg a1 e1) (cf a1 (cg a1 e1)) - rem8 = appId (E a1) (G a1) e1 (cfg a1) (\ e -> cf a1 (cg a1 e)) rem7 + rem b z0 z1 = rem5 + where + E : A -> U + E a = Id B (f a) b + F : A -> U + F a = Id A (g (f a)) (g b) + G : A -> U + G a = Id B (f (g (f a))) (f (g b)) - rem9 : Id (Sigma A G) (pc fg z1) (pcf (pcg z1)) - rem9 = cong (G a1) (Sigma A G) (\ e -> pair a1 e) (cfg a1 e1) (cf a1 (cg a1 e1)) rem8 + cg : (a:A) -> E a -> F a + cg a = mapOnPath B A g (f a) b - rem10 : Id (Sigma A G) (pc fg z0) (pc fg z1) - rem10 = compDown (Sigma A G) (pc fg z0) (pcf (pcg z0)) (pc fg z1) (pcf (pcg z1)) rem6 rem9 rem3 + cf : (a:A) -> F a -> G a + cf a = mapOnPath A B f (g (f a)) (g b) - rem11 : Id (B -> B) fg (id B) - rem11 = funExt B (\ _ -> B) fg (id B) sfg + cfg : (a:A) -> E a -> G a + cfg a = mapOnPath B B (\ x -> f (g x)) (f a) b - rem12 : Id (Sigma A E) (pc (id B) z0) (pc (id B) z1) - rem12 = subst (B->B) (\ u -> Id (Sigma A (\ x -> Id B (u (f x)) (u b))) (pc u z0) (pc u z1)) fg (id B) rem11 rem10 + pcf : Sigma A F -> Sigma A G + pcf z = (z.1, cf z.1 z.2) - c1 : (a:A) -> E a -> E a - c1 a = cong B B (id B) (f a) b + pcg : Sigma A E -> Sigma A F + pcg z = (z.1, cg z.1 z.2) - rem13 : Id (E a0 -> E a0) (id (E a0)) (c1 a0) - rem13 = congId B (f a0) b + fg : B -> B + fg y = f (g y) - rem14 : Id (E a0) e0 (c1 a0 e0) - rem14 = appId (E a0) (E a0) e0 (id (E a0)) (c1 a0) rem13 + pc : (u:B -> B) -> Sigma A E -> Sigma A (\ a -> Id B (u (f a)) (u b)) + pc u z = (z.1, mapOnPath B B u (f z.1) b z.2) - rem15 : Id (Sigma A E) z0 (pc (id B) z0) - rem15 = cong (E a0) (Sigma A E) (\ e -> pair a0 e) e0 (c1 a0 e0) rem14 + rem1 : prop (Sigma A F) + rem1 = corr2stId A (\ x -> g (f x)) rfg (g b) - rem16 : Id (E a1 -> E a1) (id (E a1)) (c1 a1) - rem16 = congId B (f a1) b + rem2 : Id (Sigma A F) (pcg z0) (pcg z1) + rem2 = rem1 (pcg z0) (pcg z1) - rem17 : Id (E a1) e1 (c1 a1 e1) - rem17 = appId (E a1) (E a1) e1 (id (E a1)) (c1 a1) rem16 + rem3 : Id (Sigma A G) (pcf (pcg z0)) (pcf (pcg z1)) + rem3 = mapOnPath (Sigma A F) (Sigma A G) pcf (pcg z0) (pcg z1) rem2 - rem18 : Id (Sigma A E) z1 (pc (id B) z1) - rem18 = cong (E a1) (Sigma A E) (\ e -> pair a1 e) e1 (c1 a1 e1) rem17 + rem4 : Id (B -> B) fg (id B) + rem4 = funExt B (\ _ -> B) fg (id B) sfg - rem19 : Id (Sigma A E) z0 z1 - rem19 = compDown (Sigma A E) z0 (pc (id B) z0) z1 (pc (id B) z1) rem15 rem18 rem12 + rem5 : Id (Sigma A E) (pc (id B) z0) (pc (id B) z1) + rem5 = subst (B->B) + (\ u -> Id (Sigma A (\ x -> Id B (u (f x)) (u b))) (pc u z0) (pc u z1)) fg (id B) rem4 rem3 -- isomorphic types are equal -isoId : (A B:U) -> (f : A -> B) (g : B -> A) -> section A B f g -> retract A B f g -> +isoId : (A B:U) -> (f : A -> B) (g : B -> A) -> section A B f g -> retract A B f g -> Id U A B isoId A B f g sfg rfg = isEquivEq A B f (gradLemma A B f g sfg rfg) -- some applications of the gradlemma -propId : (A B:U) -> prop A -> prop B -> (f : A -> B) (g : B -> A) -> +propId : (A B:U) -> prop A -> prop B -> (f : A -> B) (g : B -> A) -> Id U A B propId A B pA pB f g = isEquivEq A B f (gradLemma A B f g sfg rfg) where sfg : (b:B) -> Id B (f (g b)) b sfg b = pB (f (g b)) b - + rfg : (a:A) -> Id A (g (f a)) a rfg a = pA (g (f a)) a - - - diff --git a/examples/hedberg.cub b/examples/hedberg.cub --- a/examples/hedberg.cub +++ b/examples/hedberg.cub @@ -13,8 +13,8 @@ decConst : (A : U) -> dec A -> exConst A decConst A = split - inl a -> pair (\x -> a) (\ x y -> refl A a) - inr h -> pair (\x -> x) (\ x y -> efq (Id A x y) (h x)) + inl a -> (\x -> a, \ x y -> refl A a) + inr h -> (\x -> x, \ x y -> efq (Id A x y) (h x)) hedbergLemma : (A: U) (f : (a b : A) -> Id A a b -> Id A a b) (a b : A) (p : Id A a b) -> @@ -30,10 +30,10 @@ rem1 x y = decConst (Id A x y) (h x y) f : (x y : A) -> Id A x y -> Id A x y - f x y = fst (Id A x y -> Id A x y) (const (Id A x y)) (rem1 x y) + f x y = (rem1 x y).1 fIsConst : (x y : A) -> const (Id A x y) (f x y) - fIsConst x y = snd (Id A x y -> Id A x y) (const (Id A x y)) (rem1 x y) + fIsConst x y = (rem1 x y).2 r : Id A a a r = f a a (refl A a) @@ -58,4 +58,10 @@ boolIsSet : set Bool boolIsSet = hedberg Bool boolDec + +unitIsSet : set Unit +unitIsSet = hedberg Unit unitDec + +N0IsSet : set N0 +N0IsSet = hedberg N0 N0Dec diff --git a/examples/helix.cub b/examples/helix.cub new file mode 100644 --- /dev/null +++ b/examples/helix.cub @@ -0,0 +1,107 @@ +module helix where + +import integer + +helix : S1 -> U +helix = S1rec (\_ -> U) Z sucIdZ + +test : Id U Z (helix base) +test = refl U Z + +loopSpace : (A : U) (a : A) -> U +loopSpace A a = Id A a a + +loopS1 : U +loopS1 = loopSpace S1 base + +S1recbase : (F : S1 -> U) (b : F base) -> (l : IdS S1 F base base loop b b) -> + Id (F base) (S1rec F b l base) b +S1recbase F b l = refl (F base) b + +-- S1recloop : (F : S1 -> U) (b : F base) -> (l : IdS S1 F base base loop b b) -> +-- Id (IdS S1 F base base loop b b) +-- (mapOnPathD S1 F (S1rec F b l) base base loop) +-- l +-- S1recloop F b l = refl (IdS S1 F base base loop b b) l + +winding : loopS1 -> Z +winding l = transport Z Z (rem l) zeroZ + where + rem : loopS1 -> Id U Z Z + rem l = mapOnPath S1 U helix base base l + +compS1 : loopS1 -> loopS1 -> loopS1 +compS1 = comp S1 base base base + +invS1 : loopS1 -> loopS1 +invS1 = inv S1 base base + +test1 : Z +test1 = winding loop + +loop2 : loopS1 +loop2 = compS1 loop loop + +loop4 : loopS1 +loop4 = compS1 loop2 loop2 + +loop8 : loopS1 +loop8 = compS1 loop4 loop4 + +test2 : Z +test2 = winding (compS1 loop (invS1 loop)) + +test3 : Z +test3 = winding (invS1 loop2) + +test4 : Z +test4 = winding (compS1 loop4 (invS1 loop2)) + +test5 : Z +test5 = winding (compS1 loop8 (invS1 loop2)) + +encode : (x : S1) -> Id S1 base x -> helix x +encode x l = subst S1 helix base x l zeroZ + +loopN : N -> loopS1 +loopN = split + zero -> refl S1 base + suc n -> compS1 loop (loopN n) + +loopZ : Z -> loopS1 +loopZ = split + inl n -> invS1 (loopN (suc n)) + inr n -> loopN n + +-- loopZpred : (n : Z) -> Id loopS1 (loopZ (predZ n)) (compS1 (invS1 loop) (loopZ n)) +-- loopZpred n = undefined + +testDan : Id U Z Z +testDan = mapOnPath S1 U helix base base loop + +funDan : Z -> Z +funDan = transport Z Z testDan + +funDan1 : Z -> Z +funDan1 = transport Z Z sucIdZ + +-- testDan1 : Id (Z->Z) sucZ funDan1 +-- testDan1 = refl (Z -> Z) sucZ + +test0 : Z +test0 = transport Z Z testDan zeroZ + +vect : N -> U +vect = split + zero -> Unit + suc n -> and N (vect n) + +Peter : S1 -> N +Peter = S1rec (\ _ -> N) zero (refl N zero) + +testPeter : Id N zero zero +testPeter = mapOnPath S1 N Peter base base loop + + +-- helix = S1rec (\_ -> U) Z sucIdZ + diff --git a/examples/heterogeneous.cub b/examples/heterogeneous.cub new file mode 100644 --- /dev/null +++ b/examples/heterogeneous.cub @@ -0,0 +1,87 @@ +module heterogeneous where + +import primitives +import prelude +import gradLemma + +eqFst : (A : U) (B : A -> U) (u v : Sigma A B) -> + Id (Sigma A B) u v -> Id A u.1 v.1 +eqFst A B = mapOnPath (Sigma A B) A (\x -> x.1) + +eqSnd : (A : U) (B : A -> U) (u v : Sigma A B) (p : Id (Sigma A B) u v) -> + IdS A B u.1 v.1 (eqFst A B u v p) u.2 v.2 +eqSnd A B = mapOnPathD (Sigma A B) (\x -> B x.1) (\x -> x.2) + +eqPair1 : (A : U) (B : A -> U) (a0 a1 : A) (b0 : B a0) (b1 : B a1) -> + Id (Sigma A B) (a0,b0) (a1,b1) -> Id A a0 a1 +eqPair1 A B a0 a1 b0 b1 = eqFst A B (a0,b0) (a1,b1) + +-- eqPair2 : (A : U) (B : A -> U) (a0 a1 : A) (b0 : B a0) (b1 : B a1) +-- (p : Id (Sigma A B) (pair a0 b0) (pair a1 b1)) -> +-- IdS A B a0 a1 (eqPair1 A B a0 a1 b0 b1 p) b0 b1 +-- eqPair2 A B a0 a1 b0 b1 = eqSnd A B (pair a0 b0) (pair a1 b1) + +-- conversion test: +reflIdIdP : (A:U) (a b : A) -> Id U (Id A a b) (IdP A A (refl U A) a b) +reflIdIdP A a b = refl U (Id A a b) + +-- conversion test: +reflS : (A:U) (F:A -> U) (a:A) (b : F a) -> IdS A F a a (refl A a) b b +reflS A F a b = refl (F a) b + +-- conversion test: +composeMapOnPath : (A : U) (B : A -> U) (u v : Sigma A B) -> + (p : Id (Sigma A B) u v) -> + Id (Id U (B u.1) (B v.1)) + (mapOnPath (Sigma A B) U (\x -> B x.1) u v p) + (mapOnPath A U B u.1 v.1 (mapOnPath (Sigma A B) A (\x -> x.1) u v p)) +composeMapOnPath A B u v p = refl (Id U (B u.1) (B v.1)) + (mapOnPath (Sigma A B) U (\x -> B x.1) u v p) + +eqFstSnd : (A : U) (B : A -> U) (a0 a1 : A) (b0 : B a0) (b1 : B a1) -> + Id U + (Id (Sigma A B) (a0, b0) (a1, b1)) + (Sigma (Id A a0 a1) (\p -> IdS A B a0 a1 p b0 b1)) +eqFstSnd A B a0 a1 b0 b1 = isEquivEq IdSig SigId f + (gradLemma IdSig SigId f g (refl SigId) (refl IdSig)) + where IdSig : U + IdSig = Id (Sigma A B) (a0, b0) (a1, b1) + + SigId : U + SigId = Sigma (Id A a0 a1) (\p -> IdS A B a0 a1 p b0 b1) + + f : IdSig -> SigId + f p = (eqFst A B (a0,b0) (a1,b1) p, eqSnd A B (a0,b0) (a1,b1) p) + + + g : SigId -> IdSig + g z = mapOnPathS A B (Sigma A B) (\a b -> (a, b)) a0 a1 z.1 b0 b1 z.2 + + +eqSubstSig : (A : U) (B : A -> U) (a0 a1 : A) (p:Id A a0 a1) (b0 : B a0) (b1 : B a1) -> + Id U (IdS A B a0 a1 p b0 b1) (Id (B a1) (subst A B a0 a1 p b0) b1) +eqSubstSig A B a0 = + J A a0 (\ a1 p -> (b0 : B a0) (b1 : B a1) -> + Id U (IdS A B a0 a1 p b0 b1) (Id (B a1) (subst A B a0 a1 p b0) b1)) + rem + where rem :(b0 b1 :B a0) -> Id U (Id (B a0) b0 b1) (Id (B a0) (subst A B a0 a0 (refl A a0) b0) b1) + rem b0 b1 = mapOnPath (B a0) U (\ b -> Id (B a0) b b1) + b0 (subst A B a0 a0 (refl A a0) b0) (substeq A B a0 b0) + +pairEq : (A B:U) (a0 a1:A) (b0 b1:B) -> Id A a0 a1 -> Id B b0 b1 -> + Id (and A B) (a0, b0) (a1, b1) +pairEq A B a0 a1 b0 b1 p q = + appOnPath B (and A B) f0 f1 b0 b1 rem q + where f0 : B -> and A B + f0 y = (a0, y) + f1 : B -> and A B + f1 y = (a1, y) + rem : Id (B -> and A B) f0 f1 + rem = mapOnPath A (B -> and A B) (\ x y -> (x, y)) a0 a1 p + +test : (A B:U) (a0 a1:A) (b0 b1:B) (p:Id A a0 a1) (q:Id B b0 b1) -> + Id (Id A a0 a1) + p + (mapOnPath (and A B) A (\x -> x.1) (a0, b0) (a1, b1) + (pairEq A B a0 a1 b0 b1 p q)) +test A B a0 a1 b0 b1 p q = refl (Id A a0 a1) p diff --git a/examples/idempotent.cub b/examples/idempotent.cub deleted file mode 100644 --- a/examples/idempotent.cub +++ /dev/null @@ -1,74 +0,0 @@ -module idempotent where - -import gradLemma - --- any idempotent function defines an equality - -idemIsEquiv : (A:U) -> (f : A -> A) -> idempotent A f -> isEquiv A A f -idemIsEquiv A f if = gradLemma A A f f if if - -idemEq : (A:U) -> (f : A -> A) -> idempotent A f -> Id U A A -idemEq A f if = isEquivEq A A f (idemIsEquiv A f if) - -remIdFunEq : (A:U) -> (f:A -> A) -> (x:A) -> Id A x (f x) -> Id A x (f (f x)) -remIdFunEq A f x p = subst A (\ y -> Id A x (f y)) x (f x) p p - -invInvEq : (A:U) -> (a b :A) -> (p : Id A a b) -> Id (Id A a b) p (inv A b a (inv A a b p)) -invInvEq A a = J A a (\ b p -> Id (Id A a b) p (inv A b a (inv A a b p))) rem - where rem : Id (Id A a a) (refl A a) (inv A a a (inv A a a (refl A a))) - rem = remIdFunEq (Id A a a) (inv A a a) (refl A a) (invRefl A a) - -idemInv : (A:U) -> (a:A) -> idempotent (Id A a a) (inv A a a) -idemInv A a = rem - where - T : U - T = Id A a a - g : T -> T - g = inv A a a - rem : (p: T) -> Id T (g (g p)) p - rem p = inv T p (g (g p)) (invInvEq A a a p) - --- type of all loops - -aLoop : U -> U -aLoop A = Sigma A (\ a -> Id A a a) - -invALoop : (A:U) -> aLoop A -> aLoop A -invALoop A = split - pair a l -> pair a (inv A a a l) - -idemInvALoop : (A:U) -> idempotent (aLoop A) (invALoop A) -idemInvALoop A = split - pair a l -> cong (Id A a a) (aLoop A) (\ x -> pair a x) (inv A a a (inv A a a l)) l (idemInv A a l) - --- equality associated to this idempotent map - -eqInvALoop : (A:U) -> Id U (aLoop A) (aLoop A) -eqInvALoop A = idemEq (aLoop A) (invALoop A) (idemInvALoop A) - --- type of types with automorphisms - -autoM : U -autoM = aLoop U - --- this type is equal to itself - -eqAutoM : Id U autoM autoM -eqAutoM = eqInvALoop U - --- a particular element of autoM - -boolAuto : autoM -boolAuto = pair Bool eqBoolBool - --- by transport we deduce another type and another equality - -boolAuto' : autoM -boolAuto' = subst U (\ X -> X) autoM autoM eqAutoM boolAuto - -bool' : U -bool' = fst U (\ X -> Id U X X) boolAuto' - -eqBool' : Id U bool' bool' -eqBool' = snd U (\ X -> Id U X X) boolAuto' - diff --git a/examples/integer.cub b/examples/integer.cub new file mode 100644 --- /dev/null +++ b/examples/integer.cub @@ -0,0 +1,64 @@ +module integer where + +import gradLemma + +Z : U +Z = or N N + +zeroZ : Z +zeroZ = inr zero + +auxsucZ : N -> Z +auxsucZ = split + zero -> inr zero + suc n -> inl n + +sucZ : Z -> Z +sucZ = split + inl u -> auxsucZ u + inr v -> inr (suc v) + +auxpredZ : N -> Z +auxpredZ = split + zero -> inl zero + suc n -> inr n + +predZ : Z -> Z +predZ = split + inl u -> inl (suc u) + inr v -> auxpredZ v + +sucpredZ : (x:Z) -> Id Z (sucZ (predZ x)) x +sucpredZ = + split + inl u -> lem1 u + where + lem1 : (u:N) -> Id Z (sucZ (predZ (inl u))) (inl u) + lem1 = split + zero -> refl Z (inl zero) + suc n -> refl Z (inl (suc n)) + inr v -> lem2 v + where + lem2 : (u:N) -> Id Z (sucZ (predZ (inr u))) (inr u) + lem2 = split + zero -> refl Z (inr zero) + suc n -> refl Z (inr (suc n)) + +predsucZ : (x:Z) -> Id Z (predZ (sucZ x)) x +predsucZ = + split + inl u -> lem1 u + where + lem1 : (u:N) -> Id Z (predZ (sucZ (inl u))) (inl u) + lem1 = split + zero -> refl Z (inl zero) + suc n -> refl Z (inl (suc n)) + inr v -> lem2 v + where + lem2 : (u:N) -> Id Z (predZ (sucZ (inr u))) (inr u) + lem2 = split + zero -> refl Z (inr zero) + suc n -> refl Z (inr (suc n)) + +sucIdZ : Id U Z Z +sucIdZ = isoId Z Z sucZ predZ sucpredZ predsucZ diff --git a/examples/interval.cub b/examples/interval.cub new file mode 100644 --- /dev/null +++ b/examples/interval.cub @@ -0,0 +1,10 @@ +module interval where + +import primitives + +funExt' : (A : U) (B : A -> U) (f g : (x : A) -> B x) -> + ((x : A) -> Id (B x) (f x) (g x)) -> Id ((x : A) -> B x) f g +funExt' A B f g ptw = mapOnPath I ((x : A) -> B x) htpy I0 I1 line + where + htpy : I -> (x : A) -> B x + htpy i x = intrec (\_ -> B x) (f x) (g x) (ptw x) i diff --git a/examples/involutive.cub b/examples/involutive.cub new file mode 100644 --- /dev/null +++ b/examples/involutive.cub @@ -0,0 +1,70 @@ +module involutive where + +import gradLemma + +-- any involutive function defines an equality + +idemIsEquiv : (A:U) -> (f : A -> A) -> involutive A f -> isEquiv A A f +idemIsEquiv A f if = gradLemma A A f f if if + +idemEq : (A:U) -> (f : A -> A) -> involutive A f -> Id U A A +idemEq A f if = isEquivEq A A f (idemIsEquiv A f if) + +remIdFunEq : (A:U) -> (f:A -> A) -> (x:A) -> Id A x (f x) -> Id A x (f (f x)) +remIdFunEq A f x p = subst A (\ y -> Id A x (f y)) x (f x) p p + +invInvEq : (A:U) -> (a b :A) -> (p : Id A a b) -> Id (Id A a b) p (inv A b a (inv A a b p)) +invInvEq A a = J A a (\ b p -> Id (Id A a b) p (inv A b a (inv A a b p))) rem + where rem : Id (Id A a a) (refl A a) (inv A a a (inv A a a (refl A a))) + rem = remIdFunEq (Id A a a) (inv A a a) (refl A a) (invRefl A a) + +idemInv : (A:U) -> (a:A) -> involutive (Id A a a) (inv A a a) +idemInv A a = rem + where + T : U + T = Id A a a + g : T -> T + g = inv A a a + rem : (p: T) -> Id T (g (g p)) p + rem p = inv T p (g (g p)) (invInvEq A a a p) + +-- type of all loops + +aLoop : U -> U +aLoop A = Sigma A (\ a -> Id A a a) + +invALoop : (A:U) -> aLoop A -> aLoop A +invALoop A z = (z.1,inv A z.1 z.1 z.2) + +idemInvALoop : (A:U) -> involutive (aLoop A) (invALoop A) +idemInvALoop A z = + mapOnPath (Id A z.1 z.1) (aLoop A) + (\ x -> (z.1, x)) (inv A z.1 z.1 (inv A z.1 z.1 z.2)) z.2 (idemInv A z.1 z.2) + +-- equality associated to this involutive map + +eqInvALoop : (A:U) -> Id U (aLoop A) (aLoop A) +eqInvALoop A = idemEq (aLoop A) (invALoop A) (idemInvALoop A) + +-- type of types with automorphisms + +autoM : U +autoM = aLoop U + +-- this type is equal to itself + +eqAutoM : Id U autoM autoM +eqAutoM = eqInvALoop U + +-- a particular element of autoM + +boolAuto : autoM +boolAuto = (Bool,eqBoolBool) + +-- by transport we deduce another type and another equality + +boolAuto' : autoM +boolAuto' = subst U (\X -> X) autoM autoM eqAutoM boolAuto + +eqBool' : Id U boolAuto'.1 boolAuto'.1 +eqBool' = boolAuto'.2 diff --git a/examples/lemId.cub b/examples/lemId.cub --- a/examples/lemId.cub +++ b/examples/lemId.cub @@ -11,10 +11,10 @@ compInvIdr A a b p = substeq A (\x -> Id A a x) b p inv : (A : U) -> (a b :A) -> Id A a b -> Id A b a -inv A a b p = subst A (\ x -> Id A x a) a b p (refl A a) +inv A a b p = subst A (\x -> Id A x a) a b p (refl A a) invRefl : (A:U) -> (a:A) -> Id (Id A a a) (refl A a) (inv A a a (refl A a)) -invRefl A a = substeq A (\ x -> Id A x a) a (refl A a) +invRefl A a = substeq A (\x -> Id A x a) a (refl A a) compIdr : (A : U) -> (a b : A) -> (p : Id A a b) -> Id (Id A a b) (comp A a b b p (refl A b)) p compIdr A a b p = inv (Id A a b) p (comp A a b b p (refl A b)) (compInvIdr A a b p) @@ -38,21 +38,21 @@ compInvIdl' A a b p = substeq A (\x -> Id A x b) a p idEuclid : (A : U) -> euclidean A (Id A) -idEuclid A a b c p r = comp A a c b p (inv A b c r) +idEuclid A a b c p q = transpInv (Id A a b) (Id A a c) rem p + where rem : Id U (Id A a b) (Id A a c) + rem = mapOnPath A U (Id A a) b c q +-- similarity with ssreflect?? start to use equality on U + +lemUpDown : (A:U) -> (a a' b b':A) -> Id A a a' -> Id A b b' -> Id U (Id A a b) (Id A a' b') +lemUpDown A a a' b b' p q = + appOnPath A U (Id A a) (Id A a') b b' (mapOnPath A (A->U) (Id A) a a' p) q + compUp : (A:U) -> (a a' b b':A) -> Id A a a' -> Id A b b' -> Id A a b -> Id A a' b' -compUp A a a' b b' p q r = - subst A (\ x -> Id A x b') a a' p rem - where - rem : Id A a b' - rem = comp A a b b' r q +compUp A a a' b b' p q = transport (Id A a b) (Id A a' b') (lemUpDown A a a' b b' p q) compDown : (A:U) -> (a a' b b':A) -> Id A a a' -> Id A b b' -> Id A a' b' -> Id A a b -compDown A a a' b b' p q r = - subst A (\ x -> Id A a x) b' b (inv A b b' q) rem - where - rem : Id A a b' - rem = comp A a a' b' p r +compDown A a a' b b' p q = transpInv (Id A a b) (Id A a' b') (lemUpDown A a a' b b' p q) lemInv : (A:U) -> (a b c : A) -> (p : Id A a b) -> (q : Id A b c) -> Id (Id A b c) q (compInv A a b c p (comp A a b c p q)) @@ -91,31 +91,27 @@ rem2 : Id (Id A b c) (compInv A a b c p (comp A a b c p q)) (compInv A a b c p (comp A a b c p q')) - rem2 = cong (Id A a c) (Id A b c) (compInv A a b c p) + rem2 = mapOnPath (Id A a c) (Id A b c) (compInv A a b c p) (comp A a b c p q) (comp A a b c p q') h eqSigma : (A : U) (B : A -> U) (a b : A) (p : Id A a b) (u : B a) (v : B b) (q : Id (B b) (subst A B a b p u) v) -> - Id (Sigma A B) (pair a u) (pair b v) + Id (Sigma A B) (a, u) (b, v) eqSigma A B a = J A a (\b p -> (u : B a) (v : B b) (q : Id (B b) (subst A B a b p u) v) -> - Id (Sigma A B) (pair a u) (pair b v)) rem2 + Id (Sigma A B) (a, u) (b, v)) rem2 where rem1 : (u v : B a) -> Id (B a) u v -> - Id (Sigma A B) (pair a u) (pair a v) - rem1 = cong (B a) (Sigma A B) (\x -> pair a x) + Id (Sigma A B) (a, u) (a, v) + rem1 = mapOnPath (B a) (Sigma A B) (\x -> (a, x)) rem2 : (u v : B a) -> Id (B a) (subst A B a a (refl A a) u) v -> - Id (Sigma A B) (pair a u) (pair a v) + Id (Sigma A B) (a, u) (a, v) rem2 u v q = rem1 u v q' where q' : Id (B a) u v q' = comp (B a) u (subst A B a a (refl A a) u) v (substeq A B a u) q eqPropFam : (A : U) (B : A -> U) (h : propFam A B) (au bv : Sigma A B) -> - Id A (fst A B au) (fst A B bv) -> Id (Sigma A B) au bv -eqPropFam A B h = split - pair a u -> split - pair b v -> \p -> eqSigma A B a b p u v (h b (subst A B a b p u) v) - - - + Id A au.1 bv.1 -> Id (Sigma A B) au bv +eqPropFam A B h au bv p = + eqSigma A B au.1 bv.1 p au.2 bv.2 (h bv.1 (subst A B au.1 bv.1 p au.2) bv.2) diff --git a/examples/mutual.cub b/examples/mutual.cub new file mode 100644 --- /dev/null +++ b/examples/mutual.cub @@ -0,0 +1,29 @@ +module mutualtest where + +import prelude + +mutual + even : N -> Bool + odd : N -> Bool + + even = split + zero -> true + suc n -> odd n + odd = split + zero -> false + suc n -> even n + +testEven3 : Bool +testEven3 = even (suc (suc (suc zero))) + +mutual + V : U + T : V -> U + + data V = nat | pi (a : V) (b : T a -> V) + + T = split + nat -> N + pi a b -> Pi (T a) (\x -> T (b x)) + + diff --git a/examples/nIso.cub b/examples/nIso.cub --- a/examples/nIso.cub +++ b/examples/nIso.cub @@ -30,11 +30,17 @@ isoNO : Id U N (or N Unit) isoNO = isoId N (or N Unit) NToOr OrToN retNO secNO +isoNO2 : Id U N (or N Unit) +isoNO2 = comp U N N (or N Unit) (comp U N (or N Unit) N isoNO (inv U N (or N Unit) isoNO)) isoNO + +isoNO4 : Id U N (or N Unit) +isoNO4 = comp U N N (or N Unit) (comp U N (or N Unit) N isoNO2 (inv U N (or N Unit) isoNO2)) isoNO2 + -- trying to build an example which involves Kan filling for product vect : U -> N -> U vect A = split - zero -> A + zero -> A suc n -> and A (vect A n) pBool : N -> U @@ -43,38 +49,35 @@ notSN : (x:N) -> pBool x -> pBool x notSN = split zero -> not - suc n -> split - pair b u -> pair (not b) (notSN n u) + suc n -> \ z -> (not z.1,notSN n z.2) sBool : (x:N) -> pBool x sBool = split zero -> true - suc n -> pair false (sBool n) + suc n -> (false,sBool n) stBool : (x:N) -> pBool x -> Bool stBool = split zero -> \ z -> z - suc n -> split - pair b u -> andBool b (stBool n u) + suc n -> \ z -> andBool z.1 (stBool n z.2) hasSec : U -> U hasSec X = Sigma (X->U) (\ P -> (x:X) -> and (P x) (P x -> Bool)) hSN : hasSec N -hSN = pair pBool (\ n -> pair (sBool n) (stBool n)) +hSN = (pBool,\ n -> (sBool n,stBool n)) hSN' : hasSec (or N Unit) hSN' = subst U hasSec N (or N Unit) isoNO hSN pB' : (or N Unit) -> U -pB' = fst ((or N Unit) -> U) (\ P -> (x:or N Unit) -> and (P x) (P x -> Bool)) hSN' +pB' = hSN'.1 sB' : (z: or N Unit) -> and (pB' z) (pB' z -> Bool) -sB' = snd ((or N Unit) -> U) (\ P -> (x:or N Unit) -> and (P x) (P x -> Bool)) hSN' +sB' = hSN'.2 appBool : (A : U) -> and A (A -> Bool) -> Bool -appBool A = split - pair a f -> f a +appBool A z = z.2 z.1 pred' : or N Unit -> or N Unit pred' = subst U (\ X -> X -> X) N (or N Unit) isoNO pred @@ -98,7 +101,7 @@ testSN3 = saB' (inl (suc (suc zero))) add : N -> N -> N -add x = split +add x = split zero -> x suc y -> suc (add x y) @@ -111,8 +114,7 @@ propAdd : (x:N) -> Id N (add zero x) x propAdd = split zero -> refl N zero - suc n -> cong N N (\ x -> suc x) (add zero n) n (propAdd n) --- propAdd' : (z:or N Unit) + suc n -> mapOnPath N N (\ x -> suc x) (add zero n) n (propAdd n) @@ -123,31 +125,106 @@ aZero X = Sigma X (\ z -> Sigma (X -> X -> X) (\ f -> (x:X) -> Id X (f z x) x)) aZN : aZero N -aZN = pair zero (pair add propAdd) +aZN = (zero,(add,propAdd)) aZN' : aZero (or N Unit) aZN' = subst U aZero N (or N Unit) isoNO aZN zero' : or N Unit -zero' = fst (or N Unit) (\ z -> Sigma ((or N Unit) -> (or N Unit) -> (or N Unit)) - (\ f -> (x:(or N Unit)) -> Id (or N Unit) (f z x) x)) aZN' +zero' = aZN'.1 -sndaZN' : Sigma ((or N Unit) -> (or N Unit) -> (or N Unit)) +sndaZN' : Sigma ((or N Unit) -> (or N Unit) -> (or N Unit)) (\ f -> (x:(or N Unit)) -> Id (or N Unit) (f zero' x) x) -sndaZN' = snd (or N Unit) (\ z -> Sigma ((or N Unit) -> (or N Unit) -> (or N Unit)) - (\ f -> (x:(or N Unit)) -> Id (or N Unit) (f z x) x)) aZN' +sndaZN' = aZN'.2 add' : (or N Unit) -> (or N Unit) -> or N Unit -add' = fst ((or N Unit) -> (or N Unit) -> (or N Unit)) - (\ f -> (x:(or N Unit)) -> Id (or N Unit) (f zero' x) x) sndaZN' +add' = sndaZN'.1 propAdd' : (x:or N Unit) -> Id (or N Unit) (add' zero' x) x -propAdd' = snd ((or N Unit) -> (or N Unit) -> (or N Unit)) - (\ f -> (x:(or N Unit)) -> Id (or N Unit) (f zero' x) x) sndaZN' - +propAdd' = sndaZN'.2 testNO : or N Unit testNO = add' (inl zero) (inl (suc zero)) testNO1 : Id (or N Unit) (add' zero' zero') zero' testNO1 = propAdd' zero' + +testNO2 : or N Unit +testNO2 = zero' + +testNO3 : or N Unit +testNO3 = add' zero' zero' + +step : U -> U +step X = or X Unit + +lemIt : (A:U) (f:A->A) (a:A) -> Id A a (f a) -> Id A a (f (f a)) +lemIt A f a p = subst A (\ z -> Id A a (f z)) a (f a) p p + +isoNOIt : Id U N (step (step N)) +isoNOIt = lemIt U step N isoNO + +isoNOIt2 : Id U N (step (step (step (step N)))) +isoNOIt2 = lemIt U (\ x -> step (step x)) N isoNOIt + +aZNIt : aZero (step (step N)) +aZNIt = subst U aZero N (step (step N)) isoNOIt aZN + +zeroIt : step (step N) +zeroIt = aZNIt.1 + +sndaZNIt : Sigma ((step (step N)) -> (step (step N)) -> (step (step N))) + (\ f -> (x:(step (step N))) -> Id (step (step N)) (f zeroIt x) x) +sndaZNIt = aZNIt.2 + +addIt : (step (step N)) -> (step (step N)) -> step (step N) +addIt = sndaZNIt.1 + +propAddIt : (x:step (step N)) -> Id (step (step N)) (addIt zeroIt x) x +propAddIt = sndaZNIt.2 + +testIt : step (step N) +testIt = addIt (inl (inl zero)) (inl (inl (suc zero))) + +testIt1 : Id (step (step N)) (addIt zeroIt zeroIt) zeroIt +testIt1 = propAddIt zeroIt + +testIt2 : step (step N) +testIt2 = zeroIt + +testIt3 : step (step N) +testIt3 = addIt zeroIt zeroIt + +step4 : U -> U +step4 x = step (step (step (step x))) + +aZNIt2 : aZero (step4 N) +aZNIt2 = subst U aZero N (step4 N) isoNOIt2 aZN + +zeroIt2 : step4 N +zeroIt2 = aZNIt2.1 + +sndaZNIt2 : Sigma ((step4 N) -> (step4 N) -> (step4 N)) + (\ f -> (x:(step4 N)) -> Id (step4 N) (f zeroIt2 x) x) +sndaZNIt2 = aZNIt2.2 + +addIt2 : (step4 N) -> (step4 N) -> step4 N +addIt2 = sndaZNIt2.1 + +propAddIt2 : (x:step4 N) -> Id (step4 N) (addIt2 zeroIt2 x) x +propAddIt2 = sndaZNIt2.2 + +inl4 : N -> step4 N +inl4 x = inl (inl (inl (inl x))) + +testIt2 : step4 N +testIt2 = addIt2 (inl4 zero) (inl4 zero) + +testIt21 : Id (step4 N) (addIt2 zeroIt2 zeroIt2) zeroIt2 +testIt21 = propAddIt2 zeroIt2 + +testIt22 : step4 N +testIt22 = zeroIt2 + +testIt23 : step4 N +testIt23 = addIt2 zeroIt2 zeroIt2 diff --git a/examples/omega.cub b/examples/omega.cub --- a/examples/omega.cub +++ b/examples/omega.cub @@ -11,83 +11,82 @@ -- if B is a family of proposition over A then Sigma A B -> A is injective lemPInj1 : (A : U) (B : A -> U) -> ((x:A) -> prop (B x)) -> (a0 a1:A) -> (p:Id A a0 a1) -> - (b0:B a0) -> (b1:B a1) -> Id (Sigma A B) (pair a0 b0) (pair a1 b1) -lemPInj1 A B pB a0 = J A a0 C rem + (b0:B a0) -> (b1:B a1) -> Id (Sigma A B) (a0,b0) (a1,b1) +lemPInj1 A B pB a0 a1 p = subst A C a0 a1 p rem where - C : (a1:A) -> Id A a0 a1 -> U - C a1 p = (b0:B a0) -> (b1:B a1) -> Id (Sigma A B) (pair a0 b0) (pair a1 b1) + C : A -> U -- (a1:A) -> Id A a0 a1 -> U + C a1 = (b0:B a0) -> (b1:B a1) -> Id (Sigma A B) (a0,b0) (a1,b1) - rem : C a0 (refl A a0) - rem b0 b1 = cong (B a0) (Sigma A B) (\ b -> pair a0 b) b0 b1 (pB a0 b0 b1) + rem : C a0 + rem b0 b1 = mapOnPath (B a0) (Sigma A B) (\ b -> (a0,b)) b0 b1 (pB a0 b0 b1) -lemPropInj : (A : U) (B : A -> U) -> ((x:A) -> prop (B x)) -> injective (Sigma A B) A (fst A B) -lemPropInj A B pB = - split - pair a0 b0 -> split - pair a1 b1 -> \ p -> lemPInj1 A B pB a0 a1 p b0 b1 +lemPropInj : (A : U) (B : A -> U) -> ((x:A) -> prop (B x)) -> injective (Sigma A B) A (\ z -> z.1) +lemPropInj A B pB z0 z1 p = lemPInj1 A B pB z0.1 z1.1 p z0.2 z1.2 + lemPInj2 : (A : U) (B : A -> U) -> (pB: (x:A) -> prop (B x)) -> (z:Sigma A B) -> - Id (Id (Sigma A B) z z) (refl (Sigma A B) z) (lemPropInj A B pB z z (refl A (fst A B z))) -lemPInj2 A B pB = - split - pair a b -> rem + Id (Id (Sigma A B) z z) (refl (Sigma A B) z) (lemPropInj A B pB z z (refl A z.1)) +lemPInj2 A B pB z = rem where T : U - T = Sigma A B + T = Sigma A B + a:A + a = z.1 + + b : B a + b = z.2 + L : U - L = Id T (pair a b) (pair a b) + L = Id T z z - C : (a1:A) -> Id A a a1 -> U - C a1 p = (b0 : B a) -> (b1:B a1) -> Id T (pair a b0) (pair a1 b1) + C : A -> U + C a1 = (b0 : B a) -> (b1:B a1) -> Id T (z.1,b0) (a1,b1) - rem2 : C a (refl A a) - rem2 b0 b1 = cong (B a) T (\ b -> pair a b) b0 b1 (pB a b0 b1) + rem2 : C a + rem2 b0 b1 = mapOnPath (B a) T (\ b -> (z.1,b)) b0 b1 (pB a b0 b1) - rem1 : Id (C a (refl A a)) rem2 (lemPInj1 A B pB a a (refl A a)) - rem1 = Jeq A a C rem2 - + rem1 : Id (C a) rem2 (lemPInj1 A B pB a a (refl A a)) + rem1 = substeq A C a rem2 + Lb : U Lb = Id (B a) b b rem4 : Id Lb (refl (B a) b) (pB a b b) rem4 = propUIP (B a) (pB a) b b (refl (B a) b) (pB a b b) - rem3 : Id L (cong (B a) T (\ b -> pair a b) b b (refl (B a) b)) (rem2 b b) - rem3 = cong Lb L (cong (B a) T (\ b -> pair a b) b b) (refl (B a) b) (pB a b b) rem4 - - rem5 : Id ((b1 : B a) -> Id T (pair a b) (pair a b1)) (rem2 b) (lemPInj1 A B pB a a (refl A a) b) - rem5 = appEq (B a) (\ b0 -> (b1 : B a) -> Id T (pair a b0) (pair a b1)) b rem2 (lemPInj1 A B pB a a (refl A a)) rem1 - - rem6 : Id L (rem2 b b) (lemPInj1 A B pB a a (refl A a) b b) - rem6 = appEq (B a) (\ b1 -> Id T (pair a b) (pair a b1)) b (rem2 b) (lemPInj1 A B pB a a (refl A a) b) rem5 + rem3 : Id L (mapOnPath (B a) T (\ b -> (a,b)) b b (refl (B a) b)) (rem2 b b) + rem3 = mapOnPath Lb L (mapOnPath (B a) T (\ b -> (a,b)) b b) (refl (B a) b) (pB a b b) rem4 - rem7 : Id L (refl T (pair a b)) (cong (B a) T (\ b -> pair a b) b b (refl (B a) b)) - rem7 = congRefl (B a) T (\ b -> pair a b) b + rem5 : Id ((b1 : B a) -> Id T (a,b) (a,b1)) (rem2 b) (lemPInj1 A B pB a a (refl A a) b) + rem5 = appEq (B a) (\ b0 -> (b1 : B a) -> Id T (a,b0) (a,b1)) b rem2 (lemPInj1 A B pB a a (refl A a)) rem1 - rem8 : Id L (refl T (pair a b)) (rem2 b b) - rem8 = comp L (refl T (pair a b)) (cong (B a) T (\ b -> pair a b) b b (refl (B a) b)) (rem2 b b) rem7 rem3 + rem6 : Id L (rem2 b b) (lemPInj1 A B pB a a (refl A a) b b) + rem6 = appEq (B a) (\ b1 -> Id T (a,b) (a,b1)) b + (rem2 b) (lemPInj1 A B pB a a (refl A a) b) rem5 - rem : Id L (refl T (pair a b)) (lemPInj1 A B pB a a (refl A a) b b) - rem = comp L (refl T (pair a b)) (rem2 b b) (lemPInj1 A B pB a a (refl A a) b b) rem8 rem6 + rem : Id L (refl T (a,b)) (lemPInj1 A B pB a a (refl A a) b b) + rem = comp L (refl T (a,b)) (rem2 b b) (lemPInj1 A B pB a a (refl A a) b b) rem3 rem6 -- we should be able to deduce from all this that Omega is a set isTrue : Omega -> U -isTrue = fst U prop +isTrue z = z.1 lemIsTrue : (x y : Omega) -> (isTrue x -> isTrue y) -> (isTrue y -> isTrue x) -> Id Omega x y lemIsTrue x y f g = injf x y rem - where - G : (x:Omega) -> prop (isTrue x) - G = snd U prop - + where injf : injective Omega U isTrue injf = lemPropInj U prop propIsProp rem : Id U (isTrue x) (isTrue y) - rem = propId (isTrue x) (isTrue y) (G x) (G y) f g + rem = propId (isTrue x) (isTrue y) x.2 y.2 f g +lemInj : (A B : U) (f : A -> B) -> (injf : injective A B f) + -> ((x:A) -> Id (Id A x x) (refl A x) (injf x x (refl B (f x)))) + -> (x y : A) -> (p:Id A x y) -> Id (Id A x y) p (injf x y (mapOnPath A B f x y p)) +lemInj A B f injf h x = + J A x (\ y p -> Id (Id A x y) p (injf x y (mapOnPath A B f x y p))) (h x) omegaIsSet : set Omega omegaIsSet = rem4 @@ -96,35 +95,30 @@ rem = propIsProp g : (x:Omega) -> prop (isTrue x) - g = snd U prop + g x = x.2 injf : injective Omega U isTrue - injf = lemPropInj U prop rem + injf = lemPropInj U prop rem rem1 : (z:Omega) -> Id (Id Omega z z) (refl Omega z) (injf z z (refl U (isTrue z))) rem1 = lemPInj2 U prop rem - - rem2 : (x y : Omega) -> (p : Id Omega x y) -> Id (Id Omega x y) p (injf x y (cong Omega U isTrue x y p)) + + rem2 : (x y : Omega) -> (p : Id Omega x y) + -> Id (Id Omega x y) p (injf x y (mapOnPath Omega U isTrue x y p)) rem2 = lemInj Omega U isTrue injf rem1 rem3 : (x y : Omega) -> prop (Id U (isTrue x) (isTrue y)) rem3 x y = idPropIsProp (isTrue x) (isTrue y) (g x) (g y) rem4 : (x y : Omega) -> (p q : Id Omega x y) -> Id (Id Omega x y) p q - rem4 x y p q = compDown (Id Omega x y) p (injf x y (h p)) q (injf x y (h q)) rem6 rem7 rem8 + rem4 x y p q = compDown (Id Omega x y) p (injf x y (h p)) q (injf x y (h q)) + (rem2 x y p) (rem2 x y q) rem8 where h : Id Omega x y -> Id U (isTrue x) (isTrue y) - h = cong Omega U isTrue x y + h = mapOnPath Omega U isTrue x y rem5 : Id (Id U (isTrue x) (isTrue y)) (h p) (h q) rem5 = rem3 x y (h p) (h q) - rem6 : Id (Id Omega x y) p (injf x y (h p)) - rem6 = rem2 x y p - - rem7 : Id (Id Omega x y) q (injf x y (h q)) - rem7 = rem2 x y q - rem8 : Id (Id Omega x y) (injf x y (h p)) (injf x y (h q)) - rem8 = cong (Id U (isTrue x) (isTrue y)) (Id Omega x y) (injf x y) (h p) (h q) rem5 - + rem8 = mapOnPath (Id U (isTrue x) (isTrue y)) (Id Omega x y) (injf x y) (h p) (h q) rem5 diff --git a/examples/opacity.cub b/examples/opacity.cub new file mode 100644 --- /dev/null +++ b/examples/opacity.cub @@ -0,0 +1,12 @@ +module opacity where +import prelude + +-- The effect ot opacity is local +x : Unit +x = y where + y : Unit + y = tt + opaque y + +test : Id Unit x tt +test = refl Unit tt diff --git a/examples/opacity_fail.cub b/examples/opacity_fail.cub new file mode 100644 --- /dev/null +++ b/examples/opacity_fail.cub @@ -0,0 +1,21 @@ +module opacity_fail where + +import primitives + +Bool : U +data Bool = true | false + +x : Bool +x = false + +opaque x + +y : Bool +y = x + where x : Bool + x = true + +failure : Id Bool x y +failure = refl Bool x + +transparent x diff --git a/examples/prelude.cub b/examples/prelude.cub --- a/examples/prelude.cub +++ b/examples/prelude.cub @@ -1,8 +1,7 @@ -- some basic data types and functions - module prelude where -import primitive +import primitives rel : U -> U rel A = A -> A -> U @@ -16,14 +15,6 @@ Pi : (A:U) -> (A -> U) -> U Pi A B = (x:A) -> B x -fst : (A : U) (B : A -> U) -> Sigma A B -> A -fst A B = split - pair a b -> a - -snd : (A : U) (B : A -> U) (p : Sigma A B) -> B (fst A B p) -snd A B = split - pair a b -> b - -- some data types Unit : U @@ -55,18 +46,22 @@ zero -> zero suc n -> n +-- subst : (A : U) (P : A -> U) (a x : A) (p : Id A a x) -> P a -> P x +-- subst A P a x p d = J A a (\ x q -> P x) d x p + subst : (A : U) (P : A -> U) (a x : A) (p : Id A a x) -> P a -> P x -subst A P a x p d = J A a (\ x q -> P x) d x p +subst A P a x p = transport (P a) (P x) (mapOnPath A U P a x p) substInv : (A : U) (P : A -> U) (a x : A) (p : Id A a x) -> P x -> P a substInv A P a x p = subst A (\ y -> P y -> P a) a x p (\ h -> h) -substeq : (A : U) (P : A -> U) (a : A) (d : P a) -> - Id (P a) d (subst A P a a (refl A a) d) -substeq A P a d = Jeq A a (\ x q -> P x) d +-- substeq : (A : U) (P : A -> U) (a : A) (d : P a) -> +-- Id (P a) d (subst A P a a (refl A a) d) +-- substeq A P a d = Jeq A a (\ x q -> P x) d -cong : (A B : U) (f : A -> B) (a b : A) (p : Id A a b) -> Id B (f a) (f b) -cong A B f a b p = subst A (\x -> Id B (f a) (f x)) a b p (refl B (f a)) +substeq : (A : U) (P : A -> U) (a : A) (d : P a) -> + Id (P a) d (subst A P a a (refl A a) d) +substeq A P a d = transportRef (P a) d N0 : U data N0 = @@ -81,7 +76,7 @@ data or A B = inl (a : A) | inr (b : B) orElim : (A B C:U) -> (A->C) -> (B -> C) -> or A B -> C -orElim A B C f g = +orElim A B C f g = split inl a -> f a inr b -> g b @@ -118,26 +113,44 @@ true -> inr fnott false -> inl (refl Bool (false)) +N0Dec : discrete N0 +N0Dec x y = inl rem + where rem : Id N0 x y + rem = efq (Id N0 x y) x + +unitDec : discrete Unit +unitDec = split + tt -> split + tt -> inl (refl Unit tt) + notK : (x : Bool) -> Id Bool (not (not x)) x notK = split true -> refl Bool (true) false -> refl Bool (false) appId : (A B : U) (a : A) (f0 f1 : A -> B) -> Id (A -> B) f0 f1 -> Id B (f0 a) (f1 a) -appId A B a = cong (A->B) B (\ f -> f a) +appId A B a = mapOnPath (A->B) B (\ f -> f a) appEq : (A :U) (B : A -> U) (a : A) (f0 f1 : Pi A B) -> Id (Pi A B) f0 f1 -> Id (B a) (f0 a) (f1 a) -appEq A B a = cong (Pi A B) (B a) (\ f -> f a) +appEq A B a = mapOnPath (Pi A B) (B a) (\ f -> f a) -sId : (A : U) (a : A) -> pathTo A a -sId A a = pair a (refl A a) +J : (A : U) (a : A) (C : (x : A) -> Id A a x -> U) (d: C a (refl A a)) (x : A) (p : Id A a x) + -> C x p +J A a C d x p = subst (singl A a) T (a, refl A a) (x, p) (contrSingl A a x p) d + where T : singl A a -> U + T z = C (z.1) (z.2) +funExt : (A : U) (B : A -> U) (f g : (a : A) -> B a) + (p : ((x : A) -> (Id (B x) (f x) (g x)))) -> Id ((y : A) -> B y) f g +funExt A B f g p = funHExt A B f g rem + where rem : (a x : A) -> (p : Id A a x) -> (IdS A B a x p (f a) (g x)) + rem a = J A a (\ x p -> (IdS A B a x p (f a) (g x))) (p a) + tId : (A : U) (a : A) (v : pathTo A a) -> Id (pathTo A a) (sId A a) v -tId A a = split - pair x p -> rem x a p - where - rem : (x y : A) (p : Id A x y) -> Id (pathTo A y) (sId A y) (pair x p) - rem x = J A x (\y p -> Id (pathTo A y) (sId A y) (pair x p)) (refl (pathTo A x) (sId A x)) +tId A a z = rem (z.1) a (z.2) + where + rem : (x y : A) (p : Id A x y) -> Id (pathTo A y) (sId A y) (x, p) + rem x = J A x (\y p -> Id (pathTo A y) (sId A y) (x, p)) (refl (pathTo A x) (sId A x)) typEquivS : (A B : U) -> (f : A -> B) -> U typEquivS A B f = (y : B) -> fiber A B f y @@ -149,8 +162,7 @@ isEquiv A B f = Sigma (typEquivS A B f) (typEquivT A B f) isEquivEq : (A B : U) (f : A -> B) -> isEquiv A B f -> Id U A B -isEquivEq A B f = split - pair s t -> equivEq A B f s t +isEquivEq A B f z = equivEq A B f z.1 z.2 -- not needed if we have eta @@ -160,10 +172,6 @@ funSplit : (A:U) (B:A->U) (C: (Pi A B) -> U) -> ((f:Pi A B) -> C (\ x -> f x)) -> Pi (Pi A B) C funSplit A B C eC f = subst (Pi A B) C (\ x -> f x) f (etaId A B f) (eC f) -surjPair : (A:U) (B:A -> U) -> (s:Sigma A B) -> Id (Sigma A B) (pair (fst A B s) (snd A B s)) s -surjPair A B = split - pair a b -> refl (Sigma A B) (pair a b) - lemProp1 : (A : U) -> (A -> prop A) -> prop A lemProp1 A h a0 = h a0 a0 @@ -180,19 +188,19 @@ lemProp2 : (A : U) -> prop A -> prop (dec A) lemProp2 A pA = split - inl a -> split - inl b -> cong A (dec A) (\ x -> inl x) a b (pA a b) + inl a -> split + inl b -> mapOnPath A (dec A) (\ x -> inl x) a b (pA a b) inr nb -> efq (Id (dec A) (inl a) (inr nb)) (nb a) - inr na -> split + inr na -> split inl b -> efq (Id (dec A) (inr na) (inl b)) (na b) - inr nb -> cong (neg A) (dec A) (\ x -> inr x) na nb (propNeg A na nb) + inr nb -> mapOnPath (neg A) (dec A) (\ x -> inr x) na nb (propNeg A na nb) singl : (A:U) -> A -> U singl = pathTo -- singl = Sigma A (\ x -> Id A x a) idIsEquiv : (A:U) -> isEquiv A A (id A) -idIsEquiv A = pair (sId A) (tId A) +idIsEquiv A = (sId A, tId A) propUnit : prop Unit propUnit = split @@ -200,7 +208,7 @@ tt -> refl Unit (tt) sucInj : (n m : N) -> Id N (suc n) (suc m) -> Id N n m -sucInj n m h = cong N N pred (suc n) (suc m) h +sucInj n m h = mapOnPath N N pred (suc n) (suc m) h decEqCong : (A B : U) (f : A -> B) (g : B -> A) -> dec A -> dec B decEqCong A B f g = split @@ -231,10 +239,10 @@ suc n -> split zero -> inr (snotz n) suc m -> decEqCong (Id N n m) (Id N (suc n) (suc m)) - (cong N N (\ x -> suc x) n m) (sucInj n m) (natDec n m) + (mapOnPath N N (\ x -> suc x) n m) (sucInj n m) (natDec n m) propPi : (A : U) (B : A -> U) -> ((x : A) -> prop (B x)) -> prop ((x : A) -> B x) -propPi A B h f0 f1 = funExt A B f0 f1 (\x -> h x (f0 x) (f1 x)) +propPi A B h f0 f1 = funExt A B f0 f1 (\x -> h x (f0 x) (f1 x)) propImply : (A B : U) -> (A -> prop B) -> prop (A -> B) propImply A B h = propPi A (\_ -> B) h @@ -252,16 +260,13 @@ equivalence A R = and (reflexive A R) (euclidean A R) eqToRefl : (A : U) (R : rel A) -> equivalence A R -> reflexive A R -eqToRefl A R = split - pair r _ -> r +eqToRefl A R z = z.1 eqToEucl : (A : U) (R : rel A) -> equivalence A R -> euclidean A R -eqToEucl A R = split - pair _ e -> e +eqToEucl A R z = z.2 eqToSym : (A : U) (R : rel A) -> equivalence A R -> symmetry A R -eqToSym A R = split - pair r e -> \a b -> e b a b (r b) +eqToSym A R z a b = (z.2) b a b (z.1 b) eqToInvEucl : (A : U) (R : rel A) -> equivalence A R -> (a b c : A) -> R c a -> R c b -> R a b @@ -272,20 +277,19 @@ -- needed for Nicolai Kraus example defCase : (A X:U) -> X -> X -> dec A -> X -defCase A X x0 x1 = +defCase A X x0 x1 = split inl _ -> x0 inr _ -> x1 -IdDefCasel : (A X:U) (x0 x1 : X) (p : dec A) -> A -> +IdDefCasel : (A X:U) (x0 x1 : X) (p : dec A) -> A -> Id X (defCase A X x0 x1 p) x0 IdDefCasel A X x0 x1 = split inl _ -> \ _ -> refl X x0 inr v -> \ u -> efq (Id X (defCase A X x0 x1 (inr v)) x0) (v u) -IdDefCaser : (A X:U) (x0 x1 : X) (p : dec A) -> (neg A) -> +IdDefCaser : (A X:U) (x0 x1 : X) (p : dec A) -> (neg A) -> Id X (defCase A X x0 x1 p) x1 IdDefCaser A X x0 x1 = split inl u -> \ v -> efq (Id X (defCase A X x0 x1 (inl u)) x1) (v u) inr _ -> \ _ -> refl X x1 - diff --git a/examples/primitive.cub b/examples/primitive.cub deleted file mode 100644 --- a/examples/primitive.cub +++ /dev/null @@ -1,68 +0,0 @@ -module primitive where - -Id : (A : U) (a b : A) -> U -Id = PN - -refl : (A : U) (a : A) -> Id A a a -refl = PN -funExt : (A : U) (B : (a : A) -> U) (f g : (a : A) -> B a) - (p : ((x : A) -> (Id (B x) (f x) (g x)))) -> Id ((y : A) -> B y) f g -funExt = PN - -J : (A : U) (a : A) -> (C : (x : A) -> Id A a x -> U) -> C a (refl A a) -> - (x : A) -> (p : Id A a x) -> C x p -J = PN - -Jeq : (A : U) (a : A) -> (C : (x : A) -> Id A a x -> U) -> (d : C a (refl A a)) -> - Id (C a (refl A a)) d (J A a C d a (refl A a)) -Jeq = PN - -inh : U -> U -inh = PN - -inc : (A : U) -> A -> inh A -inc = PN - -prop : U -> U -prop A = (a b : A) -> Id A a b - -squash : (A : U) -> prop (inh A) -squash = PN - -inhrec : (A : U) (B : U) (p : prop B) (f : A -> B) (a : inh A) -> B -inhrec = PN - -Sigma : (A : U) (B : A -> U) -> U -data Sigma A B = pair (x : A) (y : B x) - -fiber : (A B : U) (f : A -> B) (y : B) -> U -fiber A B f y = Sigma A (\x -> Id B (f x) y) - -id : (A : U) -> A -> A -id A a = a - -pathTo : (A:U) -> A -> U -pathTo A = fiber A A (id A) - -equivEq : (A B : U) (f : A -> B) (s : (y : B) -> fiber A B f y) - (t : (y : B) -> (v : fiber A B f y) -> Id (fiber A B f y) (s y) v) -> - Id U A B -equivEq = PN - -transport : (A B : U) -> Id U A B -> A -> B -transport = PN - -transportRef : (A : U) -> (a : A) -> Id A a (transport A A (refl U A) a) -transportRef = PN - -equivEqRef : (A : U) -> (s : (y : A) -> pathTo A y) -> - (t : (y : A) -> (v : pathTo A y) -> Id (pathTo A y) (s y) v) -> - Id (Id U A A) (refl U A) (equivEq A A (id A) s t) -equivEqRef = PN - -transpEquivEq : (A B : U) -> (f : A -> B) (s : (y : B) -> fiber A B f y) -> - (t : (y : B) -> (v : fiber A B f y) -> Id (fiber A B f y) (s y) v) -> - (a : A) -> Id B (f a) (transport A B (equivEq A B f s t) a) -transpEquivEq = PN - - diff --git a/examples/primitives.cub b/examples/primitives.cub new file mode 100644 --- /dev/null +++ b/examples/primitives.cub @@ -0,0 +1,101 @@ +module primitives where + +primitive Id : (A : U) (a b : A) -> U + +primitive refl : (A : U) (a : A) -> Id A a a + +primitive inh : U -> U + +primitive inc : (A : U) -> A -> inh A + +prop : U -> U +prop A = (a b : A) -> Id A a b + +primitive squash : (A : U) -> prop (inh A) + +primitive inhrec : (A : U) (B : U) (p : prop B) (f : A -> B) (a : inh A) -> B + +Sigma : (A : U) (B : A -> U) -> U +Sigma A B = (x : A) * B x + +fiber : (A B : U) (f : A -> B) (y : B) -> U +fiber A B f y = Sigma A (\x -> Id B (f x) y) + +id : (A : U) -> A -> A +id A a = a + +pathTo : (A:U) -> A -> U +pathTo A = fiber A A (id A) + +sId : (A : U) (a : A) -> pathTo A a +sId A a = (a, refl A a) + +singl : (A : U) -> A -> U +singl A a = Sigma A (Id A a) + +primitive contrSingl : (A : U) (a b : A) (p : Id A a b) -> + Id (singl A a) (a, refl A a) (b, p) + +primitive equivEq : (A B : U) (f : A -> B) (s : (y : B) -> fiber A B f y) + (t : (y : B) -> (v : fiber A B f y) -> + Id (fiber A B f y) (s y) v) -> Id U A B + +primitive transport : (A B : U) -> Id U A B -> A -> B + +primitive transpInv : (A B : U) -> Id U A B -> B -> A + +primitive transportRef : (A : U) (a : A) -> Id A a (transport A A (refl U A) a) + +primitive equivEqRef : (A : U) -> (s : (y : A) -> pathTo A y) -> + (t : (y : A) -> (v : pathTo A y) -> + Id (pathTo A y) (s y) v) -> + Id (Id U A A) (refl U A) (equivEq A A (id A) s t) + +primitive transpEquivEq : + (A B : U) -> (f : A -> B) (s : (y : B) -> fiber A B f y) -> + (t : (y : B) -> (v : fiber A B f y) -> Id (fiber A B f y) (s y) v) -> + (a : A) -> Id B (f a) (transport A B (equivEq A B f s t) a) + +primitive mapOnPath : (A B : U) (f : A -> B) (a b : A) + (p : Id A a b) -> Id B (f a) (f b) + +primitive appOnPath : (A B : U) (f g : A -> B) (a b : A) + (q : Id (A -> B) f g) (p : Id A a b) -> Id B (f a) (g b) + +primitive IdP : (A B : U) -> Id U A B -> A -> B -> U + +IdS : (A : U) (F : A -> U) (a0 a1 : A) (p : Id A a0 a1) -> F a0 -> F a1 -> U +IdS A F a0 a1 p = IdP (F a0) (F a1) (mapOnPath A U F a0 a1 p) + +primitive mapOnPathD : (A : U) (F : A -> U) (f : (x : A) -> F x) (a0 a1 : A) + (p : Id A a0 a1) -> IdS A F a0 a1 p (f a0) (f a1) + +primitive mapOnPathS : (A : U) (F : A -> U) (C : U) (f : (x : A) -> F x -> C) + (a0 a1 : A) (p : Id A a0 a1) (b0 : F a0) (b1 : F a1) + (q : IdS A F a0 a1 p b0 b1) -> Id C (f a0 b0) (f a1 b1) + +primitive funHExt : (A : U) (B : A -> U) (f g : (a : A) -> B a) -> + ((x y : A) -> (p : Id A x y) -> IdS A B x y p (f x) (g y)) -> + Id ((y : A) -> B y) f g + +-- The circle. +primitive S1 : U + +primitive base : S1 + +primitive loop : Id S1 base base + +primitive S1rec : (F : S1 -> U) (b : F base) + (l : IdS S1 F base base loop b b) (x : S1) -> F x + +-- The interval. +primitive I : U + +primitive I0 : I + +primitive I1 : I + +primitive line : Id I I0 I1 + +primitive intrec : (F : I -> U) (s : F I0) (e : F I1) + (l : IdS I F I0 I1 line s e) (x : I) -> F x diff --git a/examples/quotient.cub b/examples/quotient.cub --- a/examples/quotient.cub +++ b/examples/quotient.cub @@ -24,7 +24,7 @@ cp : (a b : A) -> R c a -> R a b -> R c b cp a b p q = eqToEucl A R h c b a p (eqToSym A R h a b q) ex : exists A (R c) - ex = inc (Sigma A (R c)) (pair c (eqToRefl A R h c)) + ex = inc (Sigma A (R c)) (c,eqToRefl A R h c) pr : propFam A (R c) pr a = h' c a @@ -63,40 +63,34 @@ S b a = and (P a) (Id B (f a) b) rem3 : Sigma A P -> exists B imfP - rem3 = split - pair a p -> inc (Sigma B imfP) - (pair (f a) (inc (Sigma A (S (f a))) (pair a (pair p (refl B (f a)))))) + rem3 z = inc (Sigma B imfP) + (f z.1,inc (Sigma A (S (f z.1))) (z.1,(z.2,refl B (f z.1)))) rem4 : exists B imfP rem4 = inhrec (Sigma A P) (exists B imfP) (squash (Sigma B imfP)) rem3 ex rem6 : (b b' : B) (a a' : A) (_ : and (P a) (Id B (f a) b)) (_ : and (P a') (Id B (f a') b')) -> Id B b b' - rem6 b b' a a' = split - pair p ea -> split - pair p' ea' -> compUp B (f a) b (f a') b' ea ea' rem7 + rem6 b b' a a' z z' = compUp B (f a) b (f a') b' z.2 z'.2 rem7 where rem8 : R a a' - rem8 = un a a' p p' + rem8 = un a a' z.1 z'.1 rem7 : Id B (f a) (f a') rem7 = fresp a a' rem8 - rem7 : (b b' : B) (_ : Sigma A (S b)) (_ : Sigma A (S b')) - -> Id B b b' - rem7 b b' = split - pair a p -> split - pair a' p' -> rem6 b b' a a' p p' + rem7 : (b b' : B) -> Sigma A (S b) -> Sigma A (S b') -> Id B b b' + rem7 b b' z z' = rem6 b b' z.1 z'.1 z.2 z'.2 rem8 : (b b' : B) -> Sigma A (S b) -> exists A (S b') -> Id B b b' rem8 b b' h = exElim A (S b') (Id B b b') (uip b b') (rem7 b b' h) rem9 : (b b' : B) -> exists A (S b) -> exists A (S b') -> Id B b b' rem9 b b' h h' = exElim A (S b) (Id B b b') (uip b b') - (\h'' -> rem8 b b' h'' h') h + (\h'' -> rem8 b b' h'' h') h rem5 : atmostOne B imfP rem5 = rem9 rem2 : exactOne B imfP - rem2 = pair rem4 rem5 + rem2 = (rem4,rem5) kernel : (A B : U) (f : A -> B) -> rel A @@ -113,7 +107,7 @@ rem1 = inv B (f b) (f c) q kerEquiv : (A B : U) (f : A -> B) -> equivalence A (kernel A B f) -kerEquiv A B f = pair (kerRef A B f) (kerEucl A B f) +kerEquiv A B f = (kerRef A B f,kerEucl A B f) mod2 : rel N diff --git a/examples/spector.cub b/examples/spector.cub new file mode 100644 --- /dev/null +++ b/examples/spector.cub @@ -0,0 +1,68 @@ +-- An example similar to Martin Escardo on Cantor's search +-- implement Spector double negation shift, following the presentation in +-- a proof of strong normalization using domain theory + +-- needs mutual recursion + +module spector where + +import prelude + +leqN : N -> N -> U +leqN = split + zero -> \ m -> Unit + suc n -> split + zero -> N0 + suc m -> leqN n m + +lessN : (n:N) (m:N) -> or (leqN (suc n) m) (leqN m n) +lessN = split + zero -> split + zero -> inr tt + suc m -> inl tt + suc n -> split + zero -> inr tt + suc m -> lessN n m + +vect : (N->U) -> N -> U +vect B = split + zero -> Unit + suc n -> and (vect B n) (B n) + +head : (B:N->U) (n:N) -> vect B (suc n) -> B n +head B n p = p.2 + +tail : (B:N->U) (n:N) -> vect B (suc n) -> vect B n +tail B n p = p.1 + +-- we follow the notation of the paper + +get : (B:N-> U) (n m:N) -> (leqN (suc m) n) -> vect B n -> B m +get B n m p v = head B m (trim (suc m) n p (vect B) (tail B) v) + where + T : (N -> U) -> U + T P = (k:N) -> P (suc k) -> P k + + trim : (n m:N) -> (leqN n m) -> (P:N->U) -> T P -> P m -> P n + trim = split + zero -> split + zero -> \ p P h v -> v + suc m -> \ p P h v -> trim zero m p P h (h m v) + suc n -> split + zero -> \ p P h v -> efq (P (suc n)) p + suc m -> \ p P h v -> trim n m p (\ x -> P (suc x)) (\ x -> h (suc x)) v + +mutual + Phi : (B:N->U) -> ((n:N) -> neg (neg (B n))) -> + neg (Pi N B) -> (n:N) -> neg (vect B n) + Psi : (B:N->U) -> ((n:N) -> neg (neg (B n))) -> + neg (Pi N B) -> (n:N) -> vect B n -> + (x : N) -> (or (leqN (suc x) n) (leqN n x)) -> B x + + Phi B H K n v = K (\x -> Psi B H K n v x (lessN x n)) + Psi B H K n v x = split + inl p -> get B n x p v + inr p -> efq (B x) (H n (\ y -> Phi B H K (suc n) (v, y))) + +spector : (B:N->U) -> ((n:N) -> neg (neg (B n))) -> neg (neg (Pi N B)) +spector B H K = Phi B H K zero tt diff --git a/examples/subset.cub b/examples/subset.cub --- a/examples/subset.cub +++ b/examples/subset.cub @@ -17,42 +17,26 @@ -- map in both directions sub12 : (A:U) -> subset1 A -> subset2 A -sub12 A = split - pair X f -> fiber X A f +sub12 A z = fiber z.1 A z.2 sub21 : (A:U) -> subset2 A -> subset1 A -sub21 A P = pair (Sigma A P) (fst A P) +sub21 A P = (Sigma A P,\ x -> x.1) retsub : (A:U) -> (P : subset2 A) -> Id (subset2 A) (sub12 A (sub21 A P)) P -retsub A P = funExt A (\ _ -> U) (fiber (Sigma A P) A (fst A P)) P (lem1Sub A P) - +retsub A P = funExt A (\ _ -> U) (fiber (Sigma A P) A (\x -> x.1)) P (lem1Sub A P) -- in the other direction we use a corollary of equivalence -eqSigmaEquiv : (A B :U) (f:A -> B) -> isEquiv A B f -> (Q:B -> U) -> Id U (Sigma A (\ x -> Q (f x))) (Sigma B Q) -eqSigmaEquiv A = elimIsEquiv A C rem - where - C : (B:U) -> (A->B) -> U - C B f = (Q:B->U) -> Id U (Sigma A (\ y -> Q (f y))) (Sigma B Q) - - rem : (Q:A->U) -> Id U (Sigma A (\ y -> Q y)) (Sigma A Q) - rem Q = cong (A -> U) U (Sigma A) (\ y -> Q y) Q (funExt A (\ _ -> U) (\ y -> Q y) Q(\ y -> refl U (Q y))) - --- but actually this is not this consequence that we need - lemSecSub : (A X Y:U)(g:X->Y) -> isEquiv X Y g -> (f:Y -> A) -> - Id (subset1 A) (pair Y f) (pair X (\ y -> f (g y))) -lemSecSub A X = elimIsEquiv X P rem + Id (subset1 A) (Y,f) (X,\ y -> f (g y)) +lemSecSub A X = elimIsEquiv X P (\ f -> refl (subset1 A) (X,f)) where P : (Y:U) -> (X->Y) -> U - P Y g = (f:Y -> A) -> Id (subset1 A) (pair Y f) (pair X (\ y -> f (g y))) - - rem : (f:X -> A) -> Id (subset1 A) (pair X f) (pair X (\ y -> f y)) - rem f = cong (X->A) (subset1 A) (\ h -> pair X h) f (\ y -> f y) - (funExt X (\ _ -> A) f (\ y -> f y) (\ y -> refl A (f y))) + P Y g = (f:Y -> A) -> Id (subset1 A) (Y,f) (X,\ y -> f (g y)) -lem2SecSub : (A X:U) (f:X -> A) -> isEquiv X (Sigma A (fiber X A f)) (\ x -> pair (f x) (pair x (refl A (f x)))) -lem2SecSub A X f = rem2 +lem2SecSub : (A X:U) (f:X -> A) -> + isEquiv X (Sigma A (fiber X A f)) (\ x -> (f x,(x,refl A (f x)))) +lem2SecSub A X f = gradLemma X Y g h rgh sgh where F : A -> U F = fiber X A f @@ -61,104 +45,79 @@ Y = Sigma A F h : Y -> A - h = fst A F + h y = y.1 g : X -> Y - g x = pair (f x) (pair x (refl A (f x))) + g x = (f x,(x,refl A (f x))) h : Y -> X - h = split - pair a xp -> fst X (\ x -> Id A (f x) a) xp + h y = y.2.1 Z : U Z = Sigma X (\ x -> Sigma A (\ a -> Id A (f x) a)) sw1 : Y -> Z - sw1 = split - pair a xp -> asw1 xp - where asw1 : Sigma X (\ x -> Id A (f x) a) -> Z - asw1 = split - pair x p -> pair x (pair a p) + sw1 y = (y.2.1,(y.1,y.2.2)) sw2 : Z -> Y - sw2 = split - pair x ap -> asw2 ap - where asw2 : Sigma A (\ a -> Id A (f x) a) -> Y - asw2 = split - pair a p -> pair a (pair x p) - - lemsw : (y:Y) -> Id Y (sw2 (sw1 y)) y - lemsw = split - pair a xp -> lemsw1 xp - where lemsw1 : (xp : Sigma X (\ x -> Id A (f x) a)) -> Id Y (sw2 (sw1 (pair a xp))) (pair a xp) - lemsw1 = split - pair x p -> refl Y (pair a (pair x p)) + sw2 z = (z.2.1,(z.1,z.2.2)) sgh : (x:X) -> Id X (h (g x)) x sgh x = refl X x rgh : (y:Y) -> Id Y (g (h y)) y - rgh = split - pair a xp -> lem xp - where - lem : (xp : Sigma X (\ x -> Id A (f x) a)) -> Id Y (g (h (pair a xp))) (pair a xp) - lem = split - pair x p -> lem1 + rgh y = lem y.2 + where + lem : (xp : Sigma X (\ x -> Id A (f x) y.1)) -> Id Y (g (h (y.1,xp))) (y.1,xp) + lem xp = lem1 where + x:X + x = xp.1 + + p : Id A (f x) y.1 + p = xp.2 + C : (v u:A) -> Id A v u -> U - C v u q = Id (Sigma A (\ w -> Id A v w)) (pair v (refl A v)) (pair u q) + C v u q = Id (Sigma A (Id A v)) (v,refl A v) (u,q) lem5 : (v:A) -> C v v (refl A v) - lem5 v = refl (Sigma A (\ w -> Id A v w)) (pair v (refl A v)) + lem5 v = refl (Sigma A (Id A v)) (v,refl A v) lem4 : (v u:A) (q: Id A v u) -> C v u q lem4 v = J A v (C v) (lem5 v) - lem3 : Id (Sigma A (\ u -> Id A (f x) u)) (pair (f x) (refl A (f x))) (pair a p) - lem3 = lem4 (f x) a p - - lem2 : Id Z (pair x (pair (f x) (refl A (f x)))) (pair x (pair a p)) - lem2 = cong (Sigma A (\ a -> Id A (f x) a)) - (Sigma X (\ x -> Sigma A (\ a -> Id A (f x) a))) - (\ z -> pair x z) - (pair (f x) (refl A (f x))) (pair a p) lem3 - - lem1 : Id Y (pair (f x) (pair x (refl A (f x)))) (pair a (pair x p)) - lem1 = cong Z Y sw2 (pair x (pair (f x) (refl A (f x)))) (pair x (pair a p)) lem2 + lem3 : Id (Sigma A (Id A (f x))) (f x,refl A (f x)) (y.1,p) + lem3 = lem4 (f x) y.1 xp.2 - rem2 : isEquiv X Y g - rem2 = gradLemma X Y g h rgh sgh + lem2 : Id Z (x,(f x,refl A (f x))) (x,(y.1,xp.2)) + lem2 = mapOnPath (Sigma A (Id A (f x))) + (Sigma X (\ x -> Sigma A (Id A (f x)))) + (\ z -> (x,z)) + (f x,refl A (f x)) (y.1,xp.2) lem3 + lem1 : Id Y (f x,(x,refl A (f x))) (y.1,xp) + lem1 = mapOnPath Z Y sw2 (x,(f x,refl A (f x))) (x,(y.1,p)) lem2 secsub : (A:U) -> (z : subset1 A) -> Id (subset1 A) (sub21 A (sub12 A z)) z -secsub A = - split - pair X f -> rem +secsub A z = lemSecSub A z.1 Y g (lem2SecSub A z.1 z.2) h where + X : U + X = z.1 + F : A -> U - F = fiber X A f + F = fiber X A z.2 Y : U Y = Sigma A F + + f : X -> A + f = z.2 h : Y -> A - h = fst A F + h y = y.1 g : X -> Y - g x = pair (f x) (pair x (refl A (f x))) - - rem2 : isEquiv X Y (\ x -> g x) - rem2 = lem2SecSub A X f - - rem1 : Id (subset1 A) (pair Y h) (pair X (\ x -> f x)) - rem1 = lemSecSub A X Y g rem2 h - - rem3 : Id (subset1 A) (pair X (\ x -> f x)) (pair X f) - rem3 = cong (X->A) (subset1 A) (\ h -> pair X h) - (\ x -> f x) f (funExt X (\ _ -> A) (\ x-> f x) f (\x -> refl A (f x))) - - rem : Id (subset1 A) (pair Y h) (pair X f) - rem = comp (subset1 A) (pair Y h) (pair X (\ x -> f x)) (pair X f) rem1 rem3 + g x = (f x,(x,refl A (f x))) thmSubset : (A:U) -> Id U (subset1 A) (subset2 A) thmSubset A = isEquivEq (subset1 A) (subset2 A) (sub12 A) rem diff --git a/examples/swap.cub b/examples/swap.cub --- a/examples/swap.cub +++ b/examples/swap.cub @@ -4,13 +4,14 @@ -- the swap function defines an equality +and : U -> U -> U +and A B = (_ : A) * B + swap : (A B :U) -> and A B -> and B A -swap A B = split - pair a b -> pair b a +swap A B z = (z.2,z.1) lemSwap : (A B:U) -> (z: and A B) -> Id (and A B) (swap B A (swap A B z)) z -lemSwap A B = split - pair a b -> refl (and A B) (pair a b) +lemSwap A B z = refl (and A B) z eqSwap : (A B :U) -> Id U (and A B) (and B A) eqSwap A B = isEquivEq (and A B) (and B A) (swap A B) rem @@ -21,17 +22,16 @@ -- a simple test example incr : and Bool N -> and Bool N -incr = split - pair b n -> pair b (suc n) +incr z = (z.1,suc z.2) incr' : and N Bool -> and N Bool incr' = subst U (\ X -> X -> X) (and Bool N) (and N Bool) (eqSwap Bool N) incr -test6 : and N Bool -test6 = incr' (pair zero true) +test1 : and N Bool +test1 = incr' (zero,true) -test7 : and N Bool -test7 = incr' (pair (suc zero) true) +test2 : and N Bool +test2 = incr' (suc zero,true) -- what happens if we compose eqSwap with itself? @@ -41,36 +41,36 @@ incr2 : and Bool N -> and Bool N incr2 = subst U (\ X -> X -> X) (and Bool N) (and Bool N) (eqSwap2 Bool N) incr -test8 : and Bool N -test8 = incr2 (pair true zero) +test3 : and Bool N +test3 = incr2 (true,zero) -test9 : and Bool N -test9 = incr2 (pair true (suc zero)) +test4 : and Bool N +test4 = incr2 (true,suc zero) -- what happens if we compose eqSwap with its inverse? eqSwap3 : (A B : U) -> Id U (and A B) (and A B) -eqSwap3 A B = comp U (and A B) (and B A) (and A B) (eqSwap A B) (inv U (and A B) (and B A) (eqSwap A B)) +eqSwap3 A B = comp U (and A B) (and B A) (and A B) (eqSwap A B) + (inv U (and A B) (and B A) (eqSwap A B)) incr3 : and Bool N -> and Bool N incr3 = subst U (\ X -> X -> X) (and Bool N) (and Bool N) (eqSwap2 Bool N) incr -test10 : and Bool N -test10 = incr3 (pair true zero) - -test11 : and Bool N -test11 = incr3 (pair true (suc zero)) +test5 : and Bool N +test5 = incr3 (true,zero) +test6 : and Bool N +test6 = incr3 (true,suc zero) -- simple example with swap and product eqPi : (A:U) -> (B0 B1 : A -> U) -> ((x:A) -> Id U (B0 x) (B1 x)) -> Id U (Pi A B0) (Pi A B1) -eqPi A B0 B1 eB = cong (A->U) U (Pi A) B0 B1 rem +eqPi A B0 B1 eB = mapOnPath (A->U) U (Pi A) B0 B1 rem where rem : Id (A -> U) B0 B1 rem = funExt A (\ _ -> U) B0 B1 eB eqSig : (A:U) -> (B0 B1 : A -> U) -> ((x:A) -> Id U (B0 x) (B1 x)) -> Id U (Sigma A B0) (Sigma A B1) -eqSig A B0 B1 eB = cong (A->U) U (Sigma A) B0 B1 rem +eqSig A B0 B1 eB = mapOnPath (A->U) U (Sigma A) B0 B1 rem where rem : Id (A -> U) B0 B1 rem = funExt A (\ _ -> U) B0 B1 eB @@ -87,7 +87,7 @@ transPiTest = transport (Pi U (\ X -> X -> and X Bool)) (Pi U (\ X -> X -> and Bool X)) eqPiTest test12 : and Bool N -test12 = transPiTest (\ X -> \ x -> pair x true) N zero +test12 = transPiTest (\ X -> \ x -> (x,true)) N zero eqSigTest : Id U (Sigma U (\ X -> and X Bool)) (Sigma U (\ X -> and Bool X)) eqSigTest = eqSig U (\ X -> and X Bool) (\ X -> and Bool X) rem1 @@ -97,14 +97,11 @@ transSigTest : (Sigma U (\ X -> and X Bool)) -> Sigma U (and Bool) transSigTest = transport (Sigma U (\ X -> and X Bool)) (Sigma U (\ X -> and Bool X)) eqSigTest -test13 : U -test13 = fst U (and Bool) (transSigTest (pair Bool (pair false true))) - -test14 : and Bool test13 -test14 = snd U (and Bool) (transSigTest (pair Bool (pair false true))) +test7 : U +test7 = (transSigTest (Bool,(false,true))).1 -test15 : Bool -test15 = fst Bool (\ _ -> test13) test14 +test8 : and Bool test7 +test8 = (transSigTest (Bool,(false,true))).2 eqSig1Test : Id U (Sigma U (\ X -> and N Bool)) (Sigma U (\ X -> and Bool N)) eqSig1Test = eqSig U (\ X -> and N Bool) (\ X -> and Bool N) rem1 @@ -122,14 +119,11 @@ transSig2Test : (Sigma N (\ X -> and N Bool)) -> Sigma N (\ _ -> and Bool N) transSig2Test = transport (Sigma N (\ _ -> and N Bool)) (Sigma N (\ _ -> and Bool N)) eqSig2Test -test213 : N -test213 = fst N (\ _ -> and Bool N) (transSig2Test (pair zero (pair zero true))) - -test214 : and Bool N -test214 = snd N (\ _ -> and Bool N) (transSig2Test (pair zero (pair zero true))) +test9 : N +test9 = (transSig2Test (zero,(zero,true))).1 -test215 : Bool -test215 = fst Bool (\ _ -> N) test214 +test10 : and Bool N +test10 = (transSig2Test (zero,(zero,true))).2 --- simple test @@ -137,11 +131,11 @@ eqNN = eqSwap N N testNN : and N N -testNN = transport (and N N) (and N N) eqNN (pair zero (suc zero)) +testNN = transport (and N N) (and N N) eqNN (zero,suc zero) eqUU : Id U (U -> and U U) (U -> and U U) eqUU = eqPi U (\ _ -> and U U) (\ _ -> and U U) (\ _ -> eqSwap U U) testUU : U -testUU = fst U (\ _ -> U) (transport (U -> and U U) (U -> and U U) eqUU (\ X -> pair X X) Bool) +testUU = (transport (U -> and U U) (U -> and U U) eqUU (\ X -> (X,X)) Bool).1 diff --git a/examples/swapDisc.cub b/examples/swapDisc.cub --- a/examples/swapDisc.cub +++ b/examples/swapDisc.cub @@ -1,123 +1,170 @@ -module swapDisc where - -import lemId - --- defines the swap function over a discrete type and proves that this is an idempotent map --- needed for Nicolai Kraus example - --- intermediate function - -auxSwapD : (X:U) -> discrete X -> X -> X -> X -> X -auxSwapD X dX x0 x1 x = defCase (Id X x1 x) X x0 x (dX x1 x) - -swapDisc : (X:U) -> discrete X -> X -> X -> X -> X -swapDisc X dX x0 x1 x = defCase (Id X x0 x) X x1 (auxSwapD X dX x0 x1 x) (dX x0 x) - -idSwapDisc0 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> (x:X) -> Id X x0 x -> - Id X (swapDisc X dX x0 x1 x) x1 -idSwapDisc0 X dX x0 x1 x eqx0x = - IdDefCasel (Id X x0 x) X x1 (auxSwapD X dX x0 x1 x) (dX x0 x) eqx0x - -idSwapDiscn0 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> (x:X) -> neg (Id X x0 x) -> - Id X (swapDisc X dX x0 x1 x) (auxSwapD X dX x0 x1 x) -idSwapDiscn0 X dX x0 x1 x neqx0x = - IdDefCaser (Id X x0 x) X x1 (defCase (Id X x1 x) X x0 x (dX x1 x)) (dX x0 x) neqx0x - -idAuxSwap1 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> (x:X) -> Id X x1 x -> - Id X (auxSwapD X dX x0 x1 x) x0 -idAuxSwap1 X dX x0 x1 x eqx1x = - IdDefCasel (Id X x1 x) X x0 x (dX x1 x) eqx1x - -idAuxSwapn1 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> (x:X) -> neg (Id X x1 x) -> - Id X (auxSwapD X dX x0 x1 x) x -idAuxSwapn1 X dX x0 x1 x neqx1x = - IdDefCaser (Id X x1 x) X x0 x (dX x1 x) neqx1x - -idSwapDisc1 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> neg (Id X x0 x1) -> Id X (swapDisc X dX x0 x1 x1) x0 -idSwapDisc1 X dX x0 x1 neqx0x1 = - comp X (swapDisc X dX x0 x1 x1) (defCase (Id X x0 x1) X x1 x0 (dX x0 x1)) x0 rem2 rem1 - where - rem : Id X (defCase (Id X x1 x1) X x0 x1 (dX x1 x1)) x0 - rem = IdDefCasel (Id X x1 x1) X x0 x1 (dX x1 x1) (refl X x1) - - rem1 : Id X (defCase (Id X x0 x1) X x1 x0 (dX x0 x1)) x0 - rem1 = IdDefCaser (Id X x0 x1) X x1 x0 (dX x0 x1) neqx0x1 - - rem2 : Id X (swapDisc X dX x0 x1 x1) (defCase (Id X x0 x1) X x1 x0 (dX x0 x1)) - rem2 = cong X X (\ y -> defCase (Id X x0 x1) X x1 y (dX x0 x1)) (defCase (Id X x1 x1) X x0 x1 (dX x1 x1)) x0 rem - --- can we show that swapDisc is idempotent?? - -idemSwapDisc : (X:U) (dX: discrete X) -> (x0 x1 : X) -> neg (Id X x0 x1) -> (x:X) -> - Id X (swapDisc X dX x0 x1 (swapDisc X dX x0 x1 x)) x -idemSwapDisc X dX x0 x1 neqx0x1 x = orElim (Id X x0 x) (neg (Id X x0 x)) G rem9 rem11 (dX x0 x) - where - sD : X -> X - sD = swapDisc X dX x0 x1 - - G : U - G = Id X (sD (sD x)) x - - aD : X -> X - aD = auxSwapD X dX x0 x1 - - rem : Id X x0 x -> Id X (sD x) x1 - rem = idSwapDisc0 X dX x0 x1 x - - rem1 : neg (Id X x0 x) -> Id X (sD x) (aD x) - rem1 = idSwapDiscn0 X dX x0 x1 x - - rem2 : Id X x1 x -> Id X (aD x) x0 - rem2 = idAuxSwap1 X dX x0 x1 x - - rem3 : neg (Id X x1 x) -> Id X (aD x) x - rem3 = idAuxSwapn1 X dX x0 x1 x - - rem4 : Id X (aD x1) x0 - rem4 = idAuxSwap1 X dX x0 x1 x1 (refl X x1) - - rem5 : Id X (sD x1) (aD x1) - rem5 = idSwapDiscn0 X dX x0 x1 x1 neqx0x1 - - rem6 : Id X (sD x1) x0 - rem6 = comp X (sD x1) (aD x1) x0 rem5 rem4 - - rem7 : Id X x0 x -> Id X (sD (sD x)) (sD x1) - rem7 p = cong X X sD (sD x) x1 (rem p) - - rem8 : Id X x0 x -> Id X (sD (sD x)) x0 - rem8 p = comp X (sD (sD x)) (sD x1) x0 (rem7 p) rem6 - - rem9 : Id X x0 x -> G - rem9 p = comp X (sD (sD x)) x0 x (rem8 p) p - - rem10 : Id X (sD x0) x1 - rem10 = idSwapDisc0 X dX x0 x1 x0 (refl X x0) - - rem11 : neg (Id X x0 x) -> G - rem11 neqx0x = orElim (Id X x1 x) (neg (Id X x1 x)) G rem14 rem15 (dX x1 x) - where - rem12 : Id X (sD x) (aD x) - rem12 = rem1 neqx0x - - rem13 : Id X x1 x -> Id X (sD (aD x)) x1 - rem13 p = comp X (sD (aD x)) (sD x0) x1 (cong X X sD (aD x) x0 (rem2 p)) rem10 - - rem14 : Id X x1 x -> G - rem14 p = comp X (sD (sD x)) (sD (aD x)) x (cong X X sD (sD x) (aD x) rem12) (comp X (sD (aD x)) x1 x (rem13 p) p) - - rem15 : neg (Id X x1 x) -> G - rem15 neqx1x = comp X (sD (sD x)) (sD x) x rem17 rem18 - where - rem16 : Id X (aD x) x - rem16 = rem3 neqx1x - - rem17 : Id X (sD (sD x)) (sD x) - rem17 = comp X (sD (sD x)) (sD (aD x)) (sD x) (cong X X sD (sD x) (aD x) rem12) (cong X X sD (aD x) x rem16) - - rem18 : Id X (sD x) x - rem18 = comp X (sD x) (aD x) x rem12 rem16 - - - - +module swapDisc where + +import lemId +import involutive +import contr +import elimEquiv + +-- defines the swap function over a discrete type and proves that this is an involutive map +-- needed for Nicolai Kraus example +-- we try another representation since the other one is too slow + +if : (X:U) -> Bool -> X -> X -> X +if X = split true -> \ x y -> x + false -> \ x y -> y + +True : Bool -> U +True = split true -> Unit + false -> N0 + +lemIfT : (X:U) (b:Bool) (x y:X) -> True b -> Id X (if X b x y) x +lemIfT X = split true -> \ x y _ -> refl X x + false -> \ x y h -> efq (Id X (if X false x y) x) h + +lemIfF : (X:U) (b:Bool) (x y:X) -> True (not b) -> Id X (if X b x y) y +lemIfF X = split true -> \ x y h -> efq (Id X (if X true x y) y) h + false -> \ x y _ -> refl X y + +lemTrue : (a b : Bool) -> + or (True a) + (or (and (True (not a)) (True b)) (and (True (not a)) (True (not b)))) +lemTrue = split true -> \ b -> inl tt + false -> split true -> inr (inl (tt,tt)) + false -> inr (inr (tt,tt)) + +lemTrue : (a b : Bool) (G:U) -> + ((True a) -> G) -> ((and (True (not a)) (True b)) -> G) -> + ((and (True (not a)) (True (not b)))-> G) -> G +lemTrue = split true -> \ b -> \ G h0 h1 h2 -> h0 tt + false -> split true -> \ G h0 h1 h2 -> h1 (tt,tt) + false -> \ G h0 h1 h2 -> h2 (tt,tt) + + +swapF : (X:U) (eq:X->X-> Bool) -> X -> X -> X -> X +swapF X eq x y u = if X (eq x u) y (if X (eq y u) x u) + +lemSw0 : (X:U) (eq:X->X->Bool) (x y u:X) -> True (eq x u) -> Id X (swapF X eq x y u) y +lemSw0 X eq x y u h = lemIfT X (eq x u) y (if X (eq y u) x u) h + +lemSw1 : (X:U) (eq:X->X->Bool) (x y u:X) -> + and (True (not (eq x u))) (True (eq y u)) -> Id X (swapF X eq x y u) x +lemSw1 X eq x y u h = comp X (swapF X eq x y u) (if X (eq y u) x u) x rem rem1 + where rem : Id X (swapF X eq x y u) (if X (eq y u) x u) + rem = lemIfF X (eq x u) y (if X (eq y u) x u) h.1 + rem1 : Id X (if X (eq y u) x u) x + rem1 = lemIfT X (eq y u) x u h.2 + +lemSw2 : (X:U) (eq:X->X->Bool) (x y u:X) -> + and (True (not (eq x u))) (True (not (eq y u))) + -> Id X (swapF X eq x y u) u +lemSw2 X eq x y u h = comp X (swapF X eq x y u) (if X (eq y u) x u) u rem rem1 + where rem : Id X (swapF X eq x y u) (if X (eq y u) x u) + rem = lemIfF X (eq x u) y (if X (eq y u) x u) h.1 + rem1 : Id X (if X (eq y u) x u) u + rem1 = lemIfF X (eq y u) x u h.2 + +faith0 : (X:U) (eq:X->X->Bool) -> U +faith0 X eq = (x y : X) -> Id X x y -> True (eq x y) + +faith1 : (X:U) (eq:X->X->Bool) -> U +faith1 X eq = (x y : X) -> True (eq x y) -> Id X x y + +lemIdemSw : (X:U) (eq:X->X->Bool) (f0:faith0 X eq) (f1:faith1 X eq) (x y : X) (neq : True (not (eq x y))) + (u:X) -> Id X (swapF X eq x y (swapF X eq x y u)) u +lemIdemSw X eq f0 f1 x y neq u = lemTrue (eq x u) (eq y u) (H u) rem5 rem6 rem7 + where + sw : X -> X + sw = swapF X eq x y + + H : X -> U + H v = Id X (sw (sw v)) v + + rem1 : Id X (sw x) y + rem1 = lemSw0 X eq x y x (f0 x x (refl X x)) + + rem2 : Id X (sw y) x + rem2 = lemSw1 X eq x y y (neq,f0 y y (refl X y)) + + rem3 : H x + rem3 = comp X (sw (sw x)) (sw y) x (mapOnPath X X sw (sw x) y rem1) rem2 + + rem4 : H y + rem4 = comp X (sw (sw y)) (sw x) y (mapOnPath X X sw (sw y) x rem2) rem1 + + rem5 : True (eq x u) -> H u + rem5 h = subst X H x u (f1 x u h) rem3 + + rem6 : and (True (not (eq x u))) (True (eq y u)) -> H u + rem6 h = subst X H y u (f1 y u h.2) rem4 + + rem7 : and (True (not (eq x u))) (True (not (eq y u))) -> H u + rem7 h = comp X (sw (sw u)) (sw u) u (mapOnPath X X sw (sw u) u lem) lem + where lem : Id X (sw u) u + lem = lemSw2 X eq x y u h + +-- pointed sets + +ptU : U +ptU = Sigma U (id U) + +-- if f : A -> B is an equivalence and f a = b then (A,a) and (B,b) are equal in ptU + +lemPtEquiv : (A B : U) (f: A -> B) (ef: isEquiv A B f) (a:A) (b:B) (eab: Id B (f a) b) + -> Id ptU (A,a) (B,b) +lemPtEquiv A = elimIsEquiv A P rem + where + P : (B:U) -> (A->B) -> U + P B f = (a:A) -> (b:B) -> (eab: Id B (f a) b) -> Id ptU (A,a) (B,b) + + rem : P A (id A) + rem = mapOnPath A ptU (\ x -> (A,x)) + + +lemEM : (b:Bool) (G:U) -> ((True b) -> G) -> ((True (not b)) -> G) -> G +lemEM = split true -> \ G h0 h1 -> h0 tt + false -> \ G h0 h1 -> h1 tt + +homogDec : (X:U) (eq:X->X->Bool) (f0:faith0 X eq) (f1:faith1 X eq) (x y : X) + -> Id ptU (X,x) (X,y) +homogDec X eq f0 f1 x y = lemEM (eq x y) (G y) rem1 rem + where + G : X -> U + G z = Id ptU (X,x) (X,z) + + sw : X -> X + sw = swapF X eq x y + + rem : True (not (eq x y)) -> G y + rem neq = lemPtEquiv X X sw + (idemIsEquiv X sw (lemIdemSw X eq f0 f1 x y neq)) + x y (lemSw0 X eq x y x (f0 x x (refl X x))) + + rem1 : True (eq x y) -> G y + rem1 h = subst X G x y (f1 x y h) (refl ptU (X,x)) + + +-- an example of a decidable structure + +eqN : N -> N -> Bool +eqN = split zero -> split + zero -> true + suc _ -> false + suc n -> split + zero -> false + suc m -> eqN n m + +lemN : (x:N) -> True (eqN x x) +lemN = split + zero -> tt + suc n -> lemN n + +f0N : (x y : N) -> Id N x y -> True (eqN x y) +f0N x y p = subst N (\ y -> True (eqN x y)) x y p (lemN x) + +f1N : (x y : N) -> True (eqN x y) -> Id N x y +f1N = split zero -> split + zero -> \ _ ->refl N zero + suc m -> \ h -> efq (Id N zero (suc m)) h + suc n -> split + zero -> \ h -> efq (Id N (suc n) zero) h + suc m -> \ h -> mapOnPath N N (\ x -> suc x) n m (f1N n m h) diff --git a/examples/swapDisc_old.cub b/examples/swapDisc_old.cub new file mode 100644 --- /dev/null +++ b/examples/swapDisc_old.cub @@ -0,0 +1,178 @@ +module swapDisc_old where + +import lemId +import involutive +import contr +import elimEquiv + + +-- definition by case on a decidable equality +-- needed for Nicolai Kraus example + +defCase : (A X:U) -> X -> X -> dec A -> X +defCase A X x0 x1 = + split + inl _ -> x0 + inr _ -> x1 + +IdDefCasel : (A X:U) (x0 x1 : X) (p : dec A) -> A -> + Id X (defCase A X x0 x1 p) x0 +IdDefCasel A X x0 x1 = split + inl _ -> \ _ -> refl X x0 + inr v -> \ u -> efq (Id X (defCase A X x0 x1 (inr v)) x0) (v u) + +IdDefCaser : (A X:U) (x0 x1 : X) (p : dec A) -> (neg A) -> + Id X (defCase A X x0 x1 p) x1 +IdDefCaser A X x0 x1 = split + inl u -> \ v -> efq (Id X (defCase A X x0 x1 (inl u)) x1) (v u) + inr _ -> \ _ -> refl X x1 + +-- defines the swap function over a discrete type and proves that this is an involutive map +-- needed for Nicolai Kraus example + +-- intermediate function + +auxSwapD : (X:U) -> discrete X -> X -> X -> X -> X +auxSwapD X dX x0 x1 x = defCase (Id X x1 x) X x0 x (dX x1 x) + +swapDisc : (X:U) -> discrete X -> X -> X -> X -> X +swapDisc X dX x0 x1 x = defCase (Id X x0 x) X x1 (auxSwapD X dX x0 x1 x) (dX x0 x) + +idSwapDisc0 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> (x:X) -> Id X x0 x -> + Id X (swapDisc X dX x0 x1 x) x1 +idSwapDisc0 X dX x0 x1 x eqx0x = + IdDefCasel (Id X x0 x) X x1 (auxSwapD X dX x0 x1 x) (dX x0 x) eqx0x + +idSwapDiscn0 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> (x:X) -> neg (Id X x0 x) -> + Id X (swapDisc X dX x0 x1 x) (auxSwapD X dX x0 x1 x) +idSwapDiscn0 X dX x0 x1 x neqx0x = + IdDefCaser (Id X x0 x) X x1 (defCase (Id X x1 x) X x0 x (dX x1 x)) (dX x0 x) neqx0x + +idAuxSwap1 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> (x:X) -> Id X x1 x -> + Id X (auxSwapD X dX x0 x1 x) x0 +idAuxSwap1 X dX x0 x1 x eqx1x = + IdDefCasel (Id X x1 x) X x0 x (dX x1 x) eqx1x + +idAuxSwapn1 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> (x:X) -> neg (Id X x1 x) -> + Id X (auxSwapD X dX x0 x1 x) x +idAuxSwapn1 X dX x0 x1 x neqx1x = + IdDefCaser (Id X x1 x) X x0 x (dX x1 x) neqx1x + +idSwapDisc1 : (X:U) (dX: discrete X) -> (x0 x1 : X) -> neg (Id X x0 x1) -> Id X (swapDisc X dX x0 x1 x1) x0 +idSwapDisc1 X dX x0 x1 neqx0x1 = + comp X (swapDisc X dX x0 x1 x1) (defCase (Id X x0 x1) X x1 x0 (dX x0 x1)) x0 rem2 rem1 + where + rem : Id X (defCase (Id X x1 x1) X x0 x1 (dX x1 x1)) x0 + rem = IdDefCasel (Id X x1 x1) X x0 x1 (dX x1 x1) (refl X x1) + + rem1 : Id X (defCase (Id X x0 x1) X x1 x0 (dX x0 x1)) x0 + rem1 = IdDefCaser (Id X x0 x1) X x1 x0 (dX x0 x1) neqx0x1 + + rem2 : Id X (swapDisc X dX x0 x1 x1) (defCase (Id X x0 x1) X x1 x0 (dX x0 x1)) + rem2 = mapOnPath X X (\ y -> defCase (Id X x0 x1) X x1 y (dX x0 x1)) (defCase (Id X x1 x1) X x0 x1 (dX x1 x1)) x0 rem + +-- can we show that swapDisc is involutive?? + +idemSwapDisc : (X:U) (dX: discrete X) -> (x0 x1 : X) -> neg (Id X x0 x1) -> (x:X) -> + Id X (swapDisc X dX x0 x1 (swapDisc X dX x0 x1 x)) x +idemSwapDisc X dX x0 x1 neqx0x1 x = orElim (Id X x0 x) (neg (Id X x0 x)) G rem9 rem11 (dX x0 x) + where + sD : X -> X + sD = swapDisc X dX x0 x1 + + G : U + G = Id X (sD (sD x)) x + + aD : X -> X + aD = auxSwapD X dX x0 x1 + + rem : Id X x0 x -> Id X (sD x) x1 + rem = idSwapDisc0 X dX x0 x1 x + + rem1 : neg (Id X x0 x) -> Id X (sD x) (aD x) + rem1 = idSwapDiscn0 X dX x0 x1 x + + rem2 : Id X x1 x -> Id X (aD x) x0 + rem2 = idAuxSwap1 X dX x0 x1 x + + rem3 : neg (Id X x1 x) -> Id X (aD x) x + rem3 = idAuxSwapn1 X dX x0 x1 x + + rem4 : Id X (aD x1) x0 + rem4 = idAuxSwap1 X dX x0 x1 x1 (refl X x1) + + rem5 : Id X (sD x1) (aD x1) + rem5 = idSwapDiscn0 X dX x0 x1 x1 neqx0x1 + + rem6 : Id X (sD x1) x0 + rem6 = comp X (sD x1) (aD x1) x0 rem5 rem4 + + rem7 : Id X x0 x -> Id X (sD (sD x)) (sD x1) + rem7 p = mapOnPath X X sD (sD x) x1 (rem p) + + rem8 : Id X x0 x -> Id X (sD (sD x)) x0 + rem8 p = comp X (sD (sD x)) (sD x1) x0 (rem7 p) rem6 + + rem9 : Id X x0 x -> G + rem9 p = comp X (sD (sD x)) x0 x (rem8 p) p + + rem10 : Id X (sD x0) x1 + rem10 = idSwapDisc0 X dX x0 x1 x0 (refl X x0) + + rem11 : neg (Id X x0 x) -> G + rem11 neqx0x = orElim (Id X x1 x) (neg (Id X x1 x)) G rem14 rem15 (dX x1 x) + where + rem12 : Id X (sD x) (aD x) + rem12 = rem1 neqx0x + + rem13 : Id X x1 x -> Id X (sD (aD x)) x1 + rem13 p = comp X (sD (aD x)) (sD x0) x1 (mapOnPath X X sD (aD x) x0 (rem2 p)) rem10 + + rem14 : Id X x1 x -> G + rem14 p = comp X (sD (sD x)) (sD (aD x)) x (mapOnPath X X sD (sD x) (aD x) rem12) (comp X (sD (aD x)) x1 x (rem13 p) p) + + rem15 : neg (Id X x1 x) -> G + rem15 neqx1x = comp X (sD (sD x)) (sD x) x rem17 rem18 + where + rem16 : Id X (aD x) x + rem16 = rem3 neqx1x + + rem17 : Id X (sD (sD x)) (sD x) + rem17 = comp X (sD (sD x)) (sD (aD x)) (sD x) (mapOnPath X X sD (sD x) (aD x) rem12) (mapOnPath X X sD (aD x) x rem16) + + rem18 : Id X (sD x) x + rem18 = comp X (sD x) (aD x) x rem12 rem16 + +-- pointed sets + +ptU : U +ptU = Sigma U (id U) + +-- if f : A -> B is an equivalence and f a = b then (A,a) and (B,b) are equal in ptU + +lemPtEquiv : (A B : U) (f: A -> B) (ef: isEquiv A B f) (a:A) (b:B) (eab: Id B (f a) b) + -> Id ptU (A,a) (B,b) +lemPtEquiv A = elimIsEquiv A P rem + where + P : (B:U) -> (A->B) -> U + P B f = (a:A) -> (b:B) -> (eab: Id B (f a) b) -> Id ptU (A,a) (B,b) + + rem : P A (id A) + rem = mapOnPath A ptU (\ x -> (A,x)) + +homogDec : (X:U) -> discrete X -> (x y:X) -> Id ptU (X,x) (X,y) +homogDec X dX x y = orElim (Id X y x) (neg (Id X y x)) (G x) rem1 rem (dX y x) + where + G : X -> U + G z = Id ptU (X,z) (X,y) + + rem0 : G y + rem0 = refl ptU (X,y) + + rem : neg (Id X y x) -> G x + rem neqzx = lemPtEquiv X X (swapDisc X dX y x) + (idemIsEquiv X (swapDisc X dX y x) (idemSwapDisc X dX y x neqzx)) + x y (idSwapDisc1 X dX y x neqzx) + + rem1 : Id X y x -> G x + rem1 eqzx = subst X G y x eqzx rem0 diff --git a/examples/test.cub b/examples/test.cub deleted file mode 100644 --- a/examples/test.cub +++ /dev/null @@ -1,21 +0,0 @@ -module test where - -Id : (A : U) (a b : A) -> U -Id = PN - -refl : (A : U) (a : A) -> Id A a a -refl = PN - -Bool : U -data Bool = true | false - -orBool : Bool -> Bool -> Bool -orBool = split - true -> \x -> true - false -> \x -> x - -id : Bool -> Bool -id x = x - -test : Id Bool true (orBool true false) -test = refl Bool true diff --git a/examples/turn.cub b/examples/turn.cub new file mode 100644 --- /dev/null +++ b/examples/turn.cub @@ -0,0 +1,50 @@ +module turn where + +import helix + +transpL : (A:U)(a b:A) -> Id A a b -> Id A a a -> Id A b b +transpL A a b p l = (compInv A a b b p (comp A a a b l p)) + +lemTranspL : (A:U)(a:A)(l:Id A a a) -> Id (Id A a a) l (transpL A a a (refl A a) l) +lemTranspL A a l = rem2 + where + l1 : Id A a a + l1 = comp A a a a l (refl A a) + rem : Id (Id A a a) l1 l + rem = compIdr A a a l + rem1 : Id (Id A a a) l1 (compInv A a a a (refl A a) l1) + rem1 = compInvIdl' A a a l1 + rem2 : Id (Id A a a) l (compInv A a a a (refl A a) l1) + rem2 = compInv (Id A a a) l1 l (compInv A a a a (refl A a) l1) rem rem1 + +lemTranspL1 : (A:U)(a:A)(l:Id A a a) -> Id (Id A a a) l (transpL A a a l l) +lemTranspL1 A a l = lemInv A a a a l l + +lemG0 : (A:U)(a b:A)(p:Id A a b)(l : Id A a a) -> + IdS A (\ x -> Id A x x) a b p l (transpL A a b p l) +lemG0 A a = J A a (\ b p -> (l : Id A a a) -> IdS A (\ x -> Id A x x) a b p l (transpL A a b p l)) + (lemTranspL A a) + +lemG1 : (A:U)(a:A)(l:Id A a a) -> IdS A (\ x -> Id A x x) a a l l l +lemG1 A a l = + substInv (Id A a a) (IdS A (\ x -> Id A x x) a a l l) l (transpL A a a l l) + (lemTranspL1 A a l) (lemG0 A a a l l) + +lp : (x:S1) -> Id S1 x x +lp = S1rec (\ x -> Id S1 x x) loop (lemG1 S1 base loop) + +lp1 : S1 -> S1 +lp1 x = S1rec (\ _ -> S1) x (lp x) x + +path : Id S1 base base +path = mapOnPath S1 S1 lp1 base base loop + +test : Z +test = winding path + +path2 : Id S1 base base +path2 = mapOnPath S1 S1 lp1 base base (compS1 loop (compS1 loop loop)) + +test2 : Z +test2 = winding path2 + diff --git a/examples/univalence.cub b/examples/univalence.cub --- a/examples/univalence.cub +++ b/examples/univalence.cub @@ -20,36 +20,30 @@ Equiv : U -> U -> U Equiv A B = Sigma (A->B) (isEquiv A B) -funEquiv : (A B : U) -> Equiv A B -> A -> B -funEquiv A B = fst (A->B) (isEquiv A B) - -eqEquiv : (A B : U) (e0 e1:Equiv A B) -> Id (A -> B) (funEquiv A B e0) (funEquiv A B e1) -> Id (Equiv A B) e0 e1 +eqEquiv : (A B : U) (e0 e1:Equiv A B) -> Id (A -> B) e0.1 e1.1 -> Id (Equiv A B) e0 e1 eqEquiv A B = eqPropFam (A->B) (isEquiv A B) (propIsEquiv A B) IdToEquiv : (A B:U) -> Id U A B -> Equiv A B -IdToEquiv A B p = pair (transport A B p) (transpIsEquiv A B p) +IdToEquiv A B p = (transport A B p, transpIsEquiv A B p) EquivToId : (A B:U) -> Equiv A B -> Id U A B -EquivToId A B = split - pair f ef -> isEquivEq A B f ef +EquivToId A B z = isEquivEq A B z.1 z.2 -lemSecIdEquiv : (A:U) -> (eid : isEquiv A A (id A)) -> Id (Id U A A) (refl U A) (EquivToId A A (pair (id A) eid)) -lemSecIdEquiv A = - split - pair s t -> equivEqRef A s t +lemSecIdEquiv : (A:U) -> (eid : isEquiv A A (id A)) -> Id (Id U A A) (refl U A) (EquivToId A A (id A, eid)) +lemSecIdEquiv A z = equivEqRef A z.1 z.2 lem1SecIdEquiv : (A:U) -> (f:A -> A) -> Id (A->A) (id A) f -> (eid : isEquiv A A f) -> - Id (Id U A A) (refl U A) (EquivToId A A (pair f eid)) + Id (Id U A A) (refl U A) (EquivToId A A (f, eid)) lem1SecIdEquiv A f if eid = - comp (Id U A A) (refl U A) (EquivToId A A (pair (id A) (idIsEquiv A))) (EquivToId A A (pair f eid)) rem2 rem1 + comp (Id U A A) (refl U A) (EquivToId A A (id A, idIsEquiv A)) (EquivToId A A (f, eid)) rem2 rem1 where - rem : Id (Equiv A A) (pair (id A) (idIsEquiv A)) (pair f eid) - rem = eqEquiv A A (pair (id A) (idIsEquiv A)) (pair f eid) if + rem : Id (Equiv A A) (id A, idIsEquiv A) (f, eid) + rem = eqEquiv A A (id A, idIsEquiv A) (f, eid) if - rem1 : Id (Id U A A) (EquivToId A A (pair (id A) (idIsEquiv A))) (EquivToId A A (pair f eid)) - rem1 = cong (Equiv A A) (Id U A A) (EquivToId A A) (pair (id A) (idIsEquiv A)) (pair f eid) rem + rem1 : Id (Id U A A) (EquivToId A A (id A, idIsEquiv A)) (EquivToId A A (f, eid)) + rem1 = mapOnPath (Equiv A A) (Id U A A) (EquivToId A A) (id A, idIsEquiv A) (f, eid) rem - rem2 : Id (Id U A A) (refl U A) (EquivToId A A (pair (id A) (idIsEquiv A))) + rem2 : Id (Id U A A) (refl U A) (EquivToId A A (id A, idIsEquiv A)) rem2 = lemSecIdEquiv A (idIsEquiv A) secIdEquiv : (A B :U) -> (p : Id U A B) -> Id (Id U A B) (EquivToId A B (IdToEquiv A B p)) p @@ -74,26 +68,21 @@ retIdEquiv A B s = inv (Equiv A B) s (IdToEquiv A B (EquivToId A B s)) (rem s) where rem : (s : Equiv A B) -> Id (Equiv A B) s (IdToEquiv A B (EquivToId A B s)) - rem = - split - pair f ef -> - rem1 ef + rem u = rem1 u.2 where p : Id U A B - p = isEquivEq A B f ef + p = isEquivEq A B u.1 u.2 - rem1 : (ef : isEquiv A B f) -> - Id (Equiv A B) (pair f ef) (pair (transport A B (isEquivEq A B f ef)) (transpIsEquiv A B (isEquivEq A B f ef))) - rem1 = - split - pair s t -> rem2 + rem1 : (ef : isEquiv A B u.1) -> + Id (Equiv A B) (u.1, ef) (transport A B (isEquivEq A B u.1 ef), transpIsEquiv A B (isEquivEq A B u.1 ef)) + rem1 z = rem2 where - rem3 : Id (A->B) f (transport A B (equivEq A B f s t)) - rem3 = funExt A (\ _ -> B) f (transport A B (equivEq A B f s t)) (transpEquivEq A B f s t) - rem2 : Id (Equiv A B) (pair f (pair s t)) - (pair (transport A B (equivEq A B f s t)) (transpIsEquiv A B (equivEq A B f s t))) - rem2 = eqEquiv A B (pair f (pair s t)) - (pair (transport A B (equivEq A B f s t)) (transpIsEquiv A B (equivEq A B f s t))) + rem3 : Id (A->B) u.1 (transport A B (equivEq A B u.1 z.1 z.2)) + rem3 = funExt A (\ _ -> B) u.1 (transport A B (equivEq A B u.1 z.1 z.2)) (transpEquivEq A B u.1 z.1 z.2) + rem2 : Id (Equiv A B) (u.1, z) + (transport A B (equivEq A B u.1 z.1 z.2), transpIsEquiv A B (equivEq A B u.1 z.1 z.2)) + rem2 = eqEquiv A B (u.1, z) + (transport A B (equivEq A B u.1 z.1 z.2), transpIsEquiv A B (equivEq A B u.1 z.1 z.2)) rem3 -- and now univalence