├── Conv.hs ├── CoreCTT.hs ├── Eval.hs ├── Ident.hs ├── Interval.hs ├── LexCTT.x ├── MainCTT.hs ├── Makefile ├── ParCTT.y ├── README.md ├── TypeChecker.hs ├── examples ├── comp.ctt ├── comp2.ctt ├── comp3.ctt ├── conv.ctt ├── cubical.ctt ├── cubical2.ctt ├── eval.ctt ├── identity.ctt ├── nat.ctt ├── paradox.ctt ├── path.ctt ├── simple.ctt ├── sum.ctt └── unit.ctt └── tesi.pdf /Conv.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | module Conv where 4 | 5 | import Data.List (find) 6 | import Data.Maybe (fromJust) 7 | 8 | import Ident 9 | import Interval 10 | import CoreCTT 11 | import Eval 12 | 13 | 14 | -- Generic class for objects that allow a notion of α-conversion 15 | class Convertible a where 16 | conv :: [Ident] -> DirEnv -> a -> a -> Bool 17 | 18 | -- Check convertibility under a conjunctive formula 19 | -- If the formula is false, the values are trivally convertible 20 | convPartialConj :: [Ident] -> ConjFormula -> DirEnv -> Value -> Value -> Bool 21 | --convPartialConj used conj dirs v1 v2 = myTrace ("[convPartialConj] conj = " ++ show conj ++ ", v1 = " ++ show v1 ++ ", v2 = " ++ show v2) $ 22 | convPartialConj used conj dirs v1 v2 = 23 | let dirs' = addConj dirs conj 24 | in inconsistent dirs' || conv used dirs' v1 v2 25 | 26 | -- Two values are convertible under a disjunctive formula iff 27 | -- they are so under each conjunction 28 | convPartialDisj :: [Ident] -> DisjFormula -> DirEnv -> Value -> Value -> Bool 29 | --convPartialDisj used (Disj df) dirs v1 v2 = myTrace ("[convPartialDisj] disj = " ++ show (Disj df) ++ ", v1 = " ++ show v1 ++ ", v2 = " ++ show v2) $ 30 | convPartialDisj used (Disj df) dirs v1 v2 = 31 | all (\conj -> convPartialConj used conj dirs v1 v2) df 32 | 33 | -- Check if two ∏/∑-abstractions are of the same kind 34 | sameKind :: Term -> Term -> Bool 35 | sameKind Abst{} Abst{} = True 36 | sameKind Sigma{} Sigma{} = True 37 | sameKind _ _ = False 38 | 39 | {- The following functions are used to simplify neutral values 40 | that may become non-neutral under the added constraints in `dirs`. 41 | They are used only during `conv`, and NOT during `eval`. -} 42 | 43 | -- Check if a restriction type contains a true formula 44 | -- under the directions environment `dirs` 45 | isSimplRestr :: DirEnv -> Value -> Bool 46 | isSimplRestr dirs ty = case ty of 47 | Restr sys _ -> isSimplSys dirs sys 48 | otherwise -> False 49 | 50 | -- Simplify a restriction type if it contains a true formula 51 | -- under the directions environment `dirs` 52 | simplRestr :: DirEnv -> Value -> Value 53 | simplRestr dirs (Restr sys _) = simplSys dirs sys 54 | 55 | -- Check if a system contains a true formula 56 | -- under the directions environment `dirs` 57 | isSimplSys :: DirEnv -> System -> Bool 58 | isSimplSys dirs = any ((dirs `makesTrueConj`) . fst) 59 | 60 | -- Simplify a system if it contains a true formula 61 | -- under the directions environment `dirs` 62 | simplSys :: DirEnv -> System -> Value 63 | simplSys dirs sys = snd . fromJust $ 64 | find ((dirs `makesTrueConj`) . fst) sys 65 | 66 | -- Simplify a system or neutral value if possibile, otherwise do nothing 67 | simpl :: DirEnv -> Value -> Value 68 | simpl dirs (Sys sys) | isSimplSys dirs sys = simplSys dirs sys 69 | simpl dirs (Neutral _ ty) | isSimplRestr dirs ty = simplRestr dirs ty 70 | simpl _ v = v 71 | 72 | -- Check if the type can be simplified; in that case two values 73 | -- of that type are automatically convertible, because they 74 | -- shall reduce to the same value. That is, we don't need 75 | -- to look inside the terms, i.e. we can ignore the proof 76 | proofIrrelevant :: DirEnv -> Value -> Bool 77 | proofIrrelevant dirs ty = case ty of 78 | Restr _ ty' -> isSimplRestr dirs ty 79 | || proofIrrelevant dirs ty' 80 | Closure cl ctx -> let 81 | -- Fresh variable to evaluate closures 82 | varV :: Ident -> Value -> CtxEntry 83 | varV s t = Val $ Neutral (Var $ newVar (keys ctx) s) (eval ctx t) 84 | in case cl of 85 | -- ∏-types: codomain proof irrelevant 86 | Abst s t e -> proofIrrelevant dirs $ 87 | eval (extend ctx s (varV s t)) e 88 | -- ∑-types: both components proof irrelevant 89 | Sigma s t e -> proofIrrelevant dirs (eval ctx t) && 90 | proofIrrelevant dirs (eval (extend ctx s (varV s t)) e) 91 | otherwise -> False 92 | 93 | -- αη convertibility for values, which are supposed to have the 94 | -- same type. For efficiency, we first test exact syntactical equality 95 | instance Convertible Value where 96 | conv used dirs v1 v2 = myTrace ("[conv] " ++ show v1 ++ " ~ " ++ show v2 ++ ", dirs = " ++ show dirs) 97 | -- conv used dirs v1 v2 = 98 | v1 == v2 || let cnv = conv used dirs in case (v1,v2) of 99 | (Universe,Universe) -> True 100 | -- ∏/∑ closures 101 | (Closure cl1 ctx1,Closure cl2 ctx2) | sameKind cl1 cl2 -> let 102 | (_,s1,t1,_) = extract cl1 103 | (_,_ ,t2,_) = extract cl2 104 | var = newVar used s1 105 | t1V = eval ctx1 t1 106 | t2V = eval ctx2 t2 107 | e1' = evalClosure v1 (Neutral (Var var) t1V) 108 | e2' = evalClosure v2 (Neutral (Var var) t2V) 109 | in cnv t1V t2V && conv (var : used) dirs e1' e2' 110 | -- η-rule for ∏ (first case) 111 | (Closure (Abst s1 t1 _) ctx1,Neutral _ (Closure Abst{} _)) -> let 112 | var = newVar used s1 113 | t1V = eval ctx1 t1 114 | e1' = evalClosure v1 (Neutral (Var var) t1V) 115 | e2' = doApply v2 (Neutral (Var var) t1V) 116 | in conv (var : used) dirs e1' e2' 117 | -- η-rule for ∏ (second case) 118 | (Neutral _ (Closure Abst{} _),Closure (Abst s2 t2 _) ctx2) -> let 119 | var = newVar used s2 120 | t2V = eval ctx2 t2 121 | e1' = doApply v1 (Neutral (Var var) t2V) 122 | e2' = evalClosure v2 (Neutral (Var var) t2V) 123 | in conv (var : used) dirs e1' e2' 124 | {- Sigma types -} 125 | (Fst v,Fst v') -> cnv v v' 126 | (Snd v,Snd v') -> cnv v v' 127 | (Pair vp1 vp1',Pair vp2 vp2') -> cnv vp1 vp2 && 128 | cnv vp1' vp2' 129 | -- η-rule for ∑ (first case) 130 | (vp,Pair v v') -> cnv (doFst vp) v && 131 | cnv (doSnd vp) v' 132 | -- η-rule for ∑ (second case) 133 | (Pair v v',vp) -> cnv v (doFst vp) && 134 | cnv v' (doSnd vp) 135 | {- Coproduct types -} 136 | (Sum ty1 ty2,Sum ty1' ty2') -> cnv ty1 ty1' && cnv ty2 ty2' 137 | (InL v,InL v') -> cnv v v' 138 | (InR v,InR v') -> cnv v v' 139 | {- Naturals -} 140 | (Nat,Nat) -> True 141 | (Zero,Zero) -> True 142 | (Succ n1,Succ n2) -> cnv n1 n2 143 | {- Cubical -} 144 | (I,I) -> True 145 | (I0,I0) -> True 146 | (I1,I1) -> True 147 | -- Systems. We have to check is the system is simplifiable 148 | -- to avoid an infinite loop 149 | (Sys sys,_) | isSimplSys dirs sys -> 150 | cnv (simpl dirs v1) v2 151 | (_,Sys sys) | isSimplSys dirs sys -> 152 | cnv v1 (simpl dirs v2) 153 | (Sys sys,Sys sys') -> conv used dirs sys sys' 154 | (Partial phi v,Partial phi' v') -> eqFormulas dirs phi phi' && 155 | cnv v v' 156 | (Restr sys t,Restr sys' t') -> conv used dirs sys sys' && cnv t t' 157 | {- Values inside the `Neutral` wrapper -} 158 | (Var s1,Var s2) -> s1 == s2 159 | (App f1 a1,App f2 a2) -> cnv f1 f2 && cnv a1 a2 160 | (Ind ty1 b1 s1 n1,Ind ty2 b2 s2 n2) -> 161 | cnv ty1 ty2 && cnv b1 b2 && 162 | cnv s1 s2 && cnv n1 n2 163 | (Split ty1 f1 g1 x1,Split ty2 f2 g2 x2) -> cnv ty1 ty2 164 | && cnv f1 f2 && cnv g1 g2 && cnv x1 x2 165 | (Comp fam1 phi1 i01 u1 b1 i1,Comp fam2 phi2 i02 u2 b2 i2) -> 166 | cnv fam1 fam2 && eqFormulas dirs phi1 phi2 && 167 | cnv i01 i02 && cnv u1 u2 && cnv b1 b2 && cnv i1 i2 168 | -- Interval names 169 | (Neutral (Var x1) I,Neutral (Var x2) I) -> 170 | dirs `makesTrueAtomic` Diag x1 x2 171 | (Neutral (Var x1) I,I0) -> 172 | dirs `makesTrueAtomic` Eq0 x1 173 | (Neutral (Var x1) I,I1) -> 174 | dirs `makesTrueAtomic` Eq1 x1 175 | (I0,Neutral (Var x2) I) -> 176 | dirs `makesTrueAtomic` Eq0 x2 177 | (I1,Neutral (Var x2) I) -> 178 | dirs `makesTrueAtomic` Eq1 x2 179 | {- Neutrals -} 180 | -- Simplest case: both neutral, with proof irrelevant type 181 | (Neutral v ty,Neutral v' _) | proofIrrelevant dirs ty -> 182 | True 183 | -- One value neutral with simplifiable restriction type, 184 | -- the other value not neutral 185 | (Neutral _ ty1,_) | isSimplRestr dirs ty1 -> 186 | cnv (simpl dirs v1) v2 187 | (_,Neutral _ ty2) | isSimplRestr dirs ty2 -> 188 | cnv v1 (simpl dirs v2) 189 | -- Type is not a simplifiable restriction type, 190 | -- we must look inside the term (or proof) 191 | (Neutral v _,Neutral v' _) -> cnv v v' 192 | -- No other cases 193 | otherwise -> False 194 | 195 | -- Convertibility between two systems 196 | instance Convertible System where 197 | conv used dirs sys1 sys2 = 198 | eqFormulas dirs (getSystemFormula sys1) (getSystemFormula sys2) 199 | && all (\(conj,t1,t2) -> convPartialConj used conj dirs t1 t2) meets 200 | where meets = [(conj1 `meet` conj2, sys1 `at` conj1, sys2 `at` conj2) | 201 | conj1 <- keys sys1, conj2 <- keys sys2] -------------------------------------------------------------------------------- /CoreCTT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | module CoreCTT where 5 | 6 | import Data.Maybe (fromJust) 7 | 8 | import Ident 9 | import Interval 10 | 11 | {- Syntax (terms/values) -} 12 | 13 | data Term 14 | = Var Ident 15 | | Universe 16 | {- Let-definition `[x:ty = e]t` -} 17 | | TDef (Ident,Term,Term) Term 18 | {- ∏ types -} 19 | | Abst Ident Term Term 20 | | App Term Term 21 | {- ∑ types -} 22 | | Sigma Ident Term Term 23 | | Pair Term Term 24 | | Fst Term 25 | | Snd Term 26 | {- Coproducts -} 27 | | Sum Term Term 28 | | InL Term 29 | | InR Term 30 | -- fam f_0 f_1 x 31 | | Split Term Term Term Term 32 | {- Naturals -} 33 | | Nat 34 | | Zero 35 | | Succ Term 36 | -- fam c_0 c_s n 37 | | Ind Term Term Term Term 38 | {- Cubical -} 39 | | I | I0 | I1 40 | | Sys System 41 | | Partial DisjFormula Term 42 | | Restr System Term 43 | -- fam phi i0 u base i 44 | | Comp Term DisjFormula Term Term Term Term 45 | {- For values only: -} 46 | | Closure Term Ctx 47 | -- val type 48 | | Neutral Value Value 49 | -- Just for composition (wrap a value inside a term) 50 | | TermV Value 51 | deriving (Eq, Ord) 52 | 53 | type Value = Term 54 | 55 | newtype Program = Program [Toplevel] 56 | 57 | data Toplevel = Definition Ident Term Term 58 | | Declaration Ident Term 59 | | Example Term 60 | deriving (Eq, Ord) 61 | 62 | -- Useful for printing 63 | {- 64 | isNumeral :: Term -> (Bool,Int) 65 | isNumeral Zero = (True,0) 66 | isNumeral (Succ t) = (isNum,n + 1) 67 | where (isNum,n) = isNumeral t 68 | isNumeral _ = (False,0) 69 | -} 70 | 71 | -- Generate a fresh name starting from 'x' 72 | newVar :: [Ident] -> Ident -> Ident 73 | newVar used x 74 | | x `elem` used = newVar used (Ident $ show x ++ "'") 75 | | otherwise = x 76 | 77 | -- For printing purposes: e.g. collectApps ((App (App f x_1) x_2) x_3) [] 78 | -- returns (f,[x_1,x_2,x_3]) 79 | collectApps :: Term -> [Term] -> (Term,[Term]) 80 | collectApps t apps = case t of 81 | App t1 t2' -> collectApps t1 (t2' : apps) 82 | otherwise -> (t,apps) 83 | 84 | -- Generic class for objects (terms,values,top-levels,formulas,etc.) 85 | -- which contain variables 86 | class SyntacticObject a where 87 | containsVar :: Ident -> a -> Bool 88 | containsVar s x = s `elem` freeVars x 89 | vars :: a -> [Ident] 90 | freeVars :: a -> [Ident] 91 | 92 | instance SyntacticObject Ident where 93 | vars s = [s] 94 | freeVars s = [s] 95 | 96 | instance SyntacticObject System where 97 | vars sys = concatMap vars (keys sys) ++ concatMap vars (elems sys) 98 | freeVars = vars 99 | 100 | -- For terms only and not for values (which means we don't 101 | -- define `vars` and `freeVars` for closures and neutral values) 102 | instance SyntacticObject Term where 103 | vars = \case 104 | Var s -> [s] 105 | Universe -> [] 106 | TDef (s,t,e) t' -> s : vars t ++ vars e ++ vars t' 107 | Abst s t e -> s : vars t ++ vars e 108 | App fun arg -> vars fun ++ vars arg 109 | Sigma s t e -> s : vars t ++ vars e 110 | Pair t1 t2 -> vars t1 ++ vars t2 111 | Fst t -> vars t 112 | Snd t -> vars t 113 | Sum ty1 ty2 -> vars ty1 ++ vars ty2 114 | InL t1 -> vars t1 115 | InR t2 -> vars t2 116 | Split ty f1 f2 x -> vars ty ++ vars f1 ++ vars f2 ++ vars x 117 | Nat -> [] 118 | Zero -> [] 119 | Succ t -> vars t 120 | Ind ty b s n -> vars ty ++ vars b ++ vars s ++ vars n 121 | I -> [] 122 | I0 -> [] 123 | I1 -> [] 124 | Sys sys -> vars sys 125 | Partial phi t -> vars phi ++ vars t 126 | Restr sys t -> vars sys ++ vars t 127 | Comp fam phi i0 u b i -> vars fam ++ vars phi ++ vars i0 ++ vars u 128 | ++ vars b ++ vars i 129 | Closure t ctx -> vars t ++ keys ctx 130 | Neutral v _ -> vars v 131 | TermV v -> [] -- Dummy value (not necessary) 132 | freeVars = \case 133 | Var s -> [s] 134 | Universe -> [] 135 | TDef (s,t,e) t' -> freeVars t ++ filter (/= s) 136 | (freeVars e ++ freeVars t') 137 | Abst s t e -> freeVars t ++ filter (/= s) (freeVars e) 138 | App fun arg -> freeVars fun ++ freeVars arg 139 | Sigma s t e -> freeVars t ++ filter (/= s) (freeVars e) 140 | Pair t1 t2 -> freeVars t1 ++ freeVars t2 141 | Fst t -> freeVars t 142 | Snd t -> freeVars t 143 | Sum ty1 ty2 -> freeVars ty1 ++ freeVars ty2 144 | InL t1 -> freeVars t1 145 | InR t2 -> freeVars t2 146 | Split ty f1 f2 x -> freeVars ty ++ freeVars f1 ++ freeVars f2 147 | ++ freeVars x 148 | Nat -> [] 149 | Zero -> [] 150 | Succ t -> freeVars t 151 | Ind ty b s n -> freeVars ty ++ freeVars b ++ freeVars s 152 | ++ freeVars n 153 | I -> [] 154 | I0 -> [] 155 | I1 -> [] 156 | Sys sys -> freeVars sys 157 | Partial phi t -> freeVars phi ++ freeVars t 158 | Restr sys t -> freeVars sys ++ freeVars t 159 | Comp fam phi i0 u b i -> freeVars fam ++ freeVars phi ++ freeVars i0 160 | ++ freeVars u ++ freeVars b ++ freeVars i 161 | TermV v -> [] 162 | 163 | instance SyntacticObject AtomicFormula where 164 | vars af = case af of 165 | Eq0 s -> [s] 166 | Eq1 s -> [s] 167 | Diag s1 s2 -> [s1,s2] 168 | freeVars = vars 169 | 170 | instance SyntacticObject ConjFormula where 171 | vars (Conj cf) = concatMap vars cf 172 | freeVars = vars 173 | 174 | instance SyntacticObject DisjFormula where 175 | vars (Disj df) = concatMap vars df 176 | freeVars = vars 177 | 178 | checkTermShadowing :: [Ident] -> Term -> Bool 179 | checkTermShadowing used term = case term of 180 | Var _ -> True 181 | Universe -> True 182 | TDef (s,t,e) t' -> 183 | s `notElem` used && checkTermShadowing used t && 184 | checkTermShadowing (if s == Ident "" then used else s : used) e && 185 | checkTermShadowing (if s == Ident "" then used else s : used) t' 186 | Abst s t e -> s `notElem` used && checkTermShadowing used t && 187 | checkTermShadowing (if s == Ident "" then used else s : used) e 188 | App fun arg -> checkTermShadowing used fun && 189 | checkTermShadowing used arg 190 | Sigma s t e -> s `notElem` used && checkTermShadowing used t && 191 | checkTermShadowing (if s == Ident "" then used else s : used) e 192 | Pair t1 t2 -> checkTermShadowing used t1 && 193 | checkTermShadowing used t2 194 | Fst t -> checkTermShadowing used t 195 | Snd t -> checkTermShadowing used t 196 | Sum ty1 ty2 -> checkTermShadowing used ty1 && 197 | checkTermShadowing used ty2 198 | InL t1 -> checkTermShadowing used t1 199 | InR t2 -> checkTermShadowing used t2 200 | Split ty f1 f2 x -> 201 | checkTermShadowing used ty && checkTermShadowing used f1 && 202 | checkTermShadowing used f2 && checkTermShadowing used x 203 | Nat -> True 204 | Zero -> True 205 | Succ n -> checkTermShadowing used n 206 | Ind ty b s n -> 207 | checkTermShadowing used ty && checkTermShadowing used b && 208 | checkTermShadowing used s && checkTermShadowing used n 209 | I -> True 210 | I0 -> True 211 | I1 -> True 212 | Sys sys -> all (checkTermShadowing used) (elems sys) 213 | Partial _ t -> checkTermShadowing used t 214 | Restr sys t -> all (checkTermShadowing used) (elems sys) && 215 | checkTermShadowing used t 216 | Comp fam _ i0 u b i -> 217 | checkTermShadowing used fam && checkTermShadowing used i0 && 218 | checkTermShadowing used u && checkTermShadowing used b && 219 | checkTermShadowing used i 220 | otherwise -> error "[checkTermShadowing] got non-term" 221 | 222 | {- Printing functions are in 'Eval.hs' -} 223 | 224 | type ErrorString = String 225 | 226 | {- Generic association lists utilities -} 227 | 228 | extend :: Ctx -> Ident -> CtxEntry -> Ctx 229 | extend ctx s e = if s == Ident "" then ctx else (s,e) : ctx 230 | 231 | keys :: [(k,a)] -> [k] 232 | keys = map fst 233 | 234 | elems :: [(k,a)] -> [a] 235 | elems = map snd 236 | 237 | at :: (Eq k) => [(k,a)] -> k -> a 238 | al `at` s = fromJust $ lookup s al 239 | 240 | {- Contexts -} 241 | 242 | type Ctx = [(Ident,CtxEntry)] 243 | 244 | data CtxEntry = Decl Term -- Type 245 | | Def Term Term -- Type and definition 246 | | Val Value -- Value binding for `eval` 247 | deriving (Eq, Ord) 248 | 249 | emptyCtx :: Ctx 250 | emptyCtx = [] 251 | 252 | -- Extract the value bindings from a context 253 | getBindings :: Ctx -> [(Ident,Value)] 254 | getBindings = concatMap $ 255 | \(s,entry) -> case entry of Val v -> [(s,v)]; _ -> [] 256 | 257 | -- Add interval value bindings of a conjunction to a context 258 | -- It is used solely in evaluating composition for partial types 259 | addConjBindings :: Ctx -> ConjFormula -> Ctx 260 | addConjBindings ctx (Conj cf) = map getAtomicBinding cf ++ ctx 261 | where getAtomicBinding :: AtomicFormula -> (Ident,CtxEntry) 262 | getAtomicBinding = \case 263 | Eq0 s -> (s,Val I0) 264 | Eq1 s -> (s,Val I1) 265 | Diag s1 s2 -> (s2,Val (Neutral (Var s2) I)) 266 | 267 | -- Shall not be called with values in the context 268 | -- (it is used only in `removeFromCtx`) 269 | instance SyntacticObject CtxEntry where 270 | vars entry = case entry of 271 | Decl t -> vars t 272 | Def ty def -> vars ty ++ vars def 273 | freeVars entry = case entry of 274 | Decl t -> freeVars t 275 | Def ty def -> freeVars ty ++ freeVars def 276 | 277 | -- Remove an identifier from context and also all the others 278 | -- (recursively) which depend on it 279 | removeFromCtx :: Ctx -> Ident -> Ctx 280 | removeFromCtx ctx s = if s `elem` keys ctx then 281 | let dep = map fst $ filter (\(_,entry) -> s `elem` freeVars entry) ctx 282 | ctx' = filter (\(s',_) -> s /= s') ctx 283 | in foldl removeFromCtx ctx' dep 284 | else 285 | ctx 286 | 287 | {- Systems -} 288 | 289 | type System = [(ConjFormula,Term)] 290 | 291 | -- Get the disjunction of the (conjunctive) formulas of the system 292 | getSystemFormula :: System -> DisjFormula 293 | getSystemFormula = Disj . map fst 294 | 295 | -- Utility `map` function for systems: it applies a function 296 | -- to the values inside the system 297 | mapSys :: (Value -> Value) -> System -> System 298 | mapSys f = map (\(psi,v) -> (psi,f v)) 299 | 300 | -- Split a type into the form [phi]A, with `phi` eventually trivial 301 | -- It is used in the function `compTypes` of `TypeChecker.hs` 302 | split :: Value -> (DisjFormula,Value) 303 | split v = case v of 304 | Partial phi ty -> (phi,ty) 305 | Restr _ ty -> (fTrue,ty) 306 | otherwise -> (fTrue,v) 307 | -------------------------------------------------------------------------------- /Eval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE BlockArguments #-} 4 | 5 | module Eval where 6 | 7 | import Data.List (intercalate,nub,find) 8 | import Data.Foldable (foldrM) 9 | import Data.Maybe (mapMaybe,fromJust) 10 | 11 | import Ident 12 | import Interval 13 | import CoreCTT 14 | 15 | import Debug.Trace 16 | 17 | -- For debug purposes only 18 | debug :: Bool 19 | debug = False 20 | 21 | myTrace :: String -> a -> a 22 | myTrace s x = if debug then trace s x else x 23 | 24 | -- Retrieve the evaluated type of a variable from the context 25 | lookupType :: Ident -> Ctx -> Value 26 | lookupType s [] = error $ "[lookupType] got unknown identifier " ++ show s 27 | lookupType s ((s',entry):ctx) = if s == s' then 28 | case entry of 29 | Decl ty -> eval ctx ty 30 | Def ty _ -> eval ctx ty 31 | Val _ -> lookupType s ctx 32 | else 33 | lookupType s ctx 34 | 35 | -- Evaluate a term in the given context 36 | eval :: Ctx -> Term -> Value 37 | eval ctx term = myTrace ("[eval] " ++ show term ++ ", ctx = " ++ showCtx ctx) $ case term of 38 | --eval ctx term = case term of 39 | Var s -> case lookup s ctx of 40 | Nothing -> error $ "[eval] not found var `" ++ show s ++ "` in ctx" 41 | Just (Val v) -> v 42 | Just (Decl ty) -> simplNeutralValue $ Neutral (Var s) (eval ctx ty) 43 | Just (Def _ e) -> eval ctx e 44 | Universe -> Universe 45 | TDef (s,t,e) t' -> eval (extend ctx s (Def t e)) t' 46 | Abst{} -> Closure term ctx 47 | App e1 e2 -> doApply (eval ctx e1) (eval ctx e2) 48 | Sigma{} -> Closure term ctx 49 | Pair t1 t2 -> Pair (eval ctx t1) (eval ctx t2) 50 | Fst t -> doFst (eval ctx t) 51 | Snd t -> doSnd (eval ctx t) 52 | Sum ty1 ty2 -> Sum (eval ctx ty1) (eval ctx ty2) 53 | InL t1 -> InL (eval ctx t1) 54 | InR t2 -> InR (eval ctx t2) 55 | Split ty f1 f2 x -> 56 | doSplit (eval ctx ty) (eval ctx f1) (eval ctx f2) (eval ctx x) 57 | Nat -> Nat 58 | Zero -> Zero 59 | Succ t -> Succ (eval ctx t) 60 | Ind ty base step n -> doInd (eval ctx ty) (eval ctx base) 61 | (eval ctx step) (eval ctx n) 62 | I -> I 63 | I0 -> I0 64 | I1 -> I1 65 | Sys sys -> evalSystem ctx sys 66 | Partial phi t -> foldPartial (evalDisjFormula ctx phi) (eval ctx t) 67 | Restr sys t -> foldRestr (evalRestrSystem ctx sys) (eval ctx t) 68 | Comp fam phi i0 u b i -> doComp ctx fam phi i0 u b i 69 | -- Already evaluated term (used solely for `doComp`) 70 | TermV v -> v 71 | otherwise -> error $ "[eval] got " ++ show term 72 | 73 | -- Evaluate a conjunctive formula 74 | evalConjFormula :: Ctx -> ConjFormula -> Maybe ConjFormula 75 | evalConjFormula ctx conj = myTrace ("[evalConjFormula] " ++ show conj ++ " => " ++ show conj') $ conj' 76 | where 77 | -- Get the bindings which concern the formula's variables 78 | entries' = filter (\(s,_) -> s `elem` vars conj) (getBindings ctx) 79 | -- Get only the last one of each binding 80 | entries = map (\s -> fromJust $ find (\(s',_) -> s' == s) entries') 81 | (nub $ keys entries') 82 | -- Get the renamings from the entries (i.e. the ones of the form i -> j) 83 | renamings = concatMap (\case { (s,Neutral (Var s') I) -> [(s,s')] ; 84 | _ -> []}) entries 85 | -- Apply renamings to the conjuction 86 | renamedConj = foldr substConj conj renamings 87 | -- Apply value substitutions to the renamed conjuction 88 | vals = filter (\(_,v) -> v == I0 || v == I1) entries 89 | conj' = foldrM evalConj renamedConj vals 90 | 91 | -- Evaluate a single conjuction by replacing `s` with 0 92 | -- Returns `Nothing` if the resulting formula is false 93 | evalConj :: (Ident,Value) -> ConjFormula -> Maybe ConjFormula 94 | evalConj (s,I0) conj@(Conj cf) = 95 | if conjToDirEnv conj `makesTrueAtomic` Eq1 s -- Inconsistent cases 96 | || inconsistent (conjToDirEnv conj') then 97 | Nothing 98 | else 99 | Just conj' -- Substitute into each atomic formula 100 | where 101 | conj' = Conj . nub $ concatMap (\case 102 | Eq0 s' | s == s' -> []; 103 | Diag s1 s2 -> if s == s1 && s1 == s2 then [] 104 | else [if s == s1 then Eq0 s2 105 | else if s == s2 then Eq0 s1 else Diag s1 s2]; 106 | af -> [af]) cf 107 | 108 | -- Same as before, now replacing `s` with 1 109 | evalConj (s,I1) conj@(Conj cf) = 110 | if conjToDirEnv conj `makesTrueAtomic` Eq0 s -- Inconsistent cases 111 | || inconsistent (conjToDirEnv conj') then 112 | Nothing 113 | else 114 | Just conj' -- Substitute into each atomic formula 115 | where 116 | conj' = Conj . nub $ concatMap (\case 117 | Eq1 s' | s == s' -> []; 118 | Diag s1 s2 -> if s == s1 && s1 == s2 then [] 119 | else [if s == s1 then Eq1 s2 120 | else if s == s2 then Eq1 s1 else Diag s1 s2]; 121 | af -> [af]) cf 122 | 123 | -- Evaluate a disjunctive formula, by first checking if it contains 124 | -- a true conjunction 125 | evalDisjFormula :: Ctx -> DisjFormula -> DisjFormula 126 | evalDisjFormula ctx (Disj df) = if Conj [] `elem` df then 127 | fTrue 128 | else -- Otherwise evaluate each conjunction, disregarding the false ones 129 | Disj $ mapMaybe (evalConjFormula ctx) df 130 | 131 | -- Simplify cascading restriction types into one restriction type 132 | -- E.g. [psi_1 -> t_1]([psi_2 -> t_2]([psi_3 -> t_3]A)) becomes 133 | -- [psi_1 -> t_1 | psi_2 -> t_2 | psi_3 -> t_3]A 134 | foldRestr :: System -> Value -> Value 135 | foldRestr sys0 v0 = -- If the system if empty, return just the type 136 | if null sys then v else Restr (nub sys) v 137 | where 138 | (sys,v) = foldRestr' sys0 v0 139 | foldRestr' :: System -> Value -> (System,Value) 140 | foldRestr' sys v = case v of 141 | Restr sys' v' -> foldRestr' (sys ++ sys') v' 142 | otherwise -> (sys,v) 143 | 144 | -- Simplify cascading partial types into one partial type 145 | -- E.g. [phi_1]([phi_2]([phi_3]A)) becomes 146 | -- [phi /\ psi_2 /\ psi_3]A 147 | foldPartial :: DisjFormula -> Value -> Value 148 | foldPartial (Disj df0) v0 = -- If the formula is true, return just the type 149 | if makesTrueDisj emptyDirEnv (Disj df) then 150 | v 151 | else -- `nub` removes duplicate formulas 152 | Partial (Disj $ nub df) v 153 | where 154 | (df,v) = foldPartial' df0 v0 155 | foldPartial' :: [ConjFormula] -> Value -> ([ConjFormula],Value) 156 | foldPartial' df v = case v of 157 | Partial (Disj df') v' -> foldPartial' (dnf df' df) v' 158 | otherwise -> (df,v) 159 | -- Get the conjuction of the two disjunctive formulas, 160 | -- in disjunctive normal form 161 | dnf :: [ConjFormula] -> [ConjFormula] -> [ConjFormula] 162 | dnf df1 df2 = [cf1 `meet` cf2 | cf1 <- df1, cf2 <- df2] 163 | 164 | -- Evaluate the system of a restriction type, 165 | -- by dropping false formulas 166 | evalRestrSystem :: Ctx -> System -> System 167 | evalRestrSystem ctx sys = 168 | concatMap (\(phi,t) -> evalConjFormula' phi (eval ctx t)) sys 169 | where 170 | -- Need to handle the case of false formulas 171 | evalConjFormula' phi v = case evalConjFormula ctx phi of 172 | Nothing -> [] 173 | Just cf -> [(cf,v)] 174 | 175 | -- Evaluate a system and eventually simplify it (recursively) 176 | -- if there is a true formula 177 | evalSystem :: Ctx -> System -> Value 178 | evalSystem ctx sys = 179 | case foldrM evalConjFormula' [] sys of 180 | Left val -> val -- System has been simplified 181 | Right sys' -> Sys sys' -- There were no true formulas 182 | where 183 | -- The following function gets the new pair (formula,term) and the 184 | -- part of the system already evaluated. If the new formula is true, 185 | -- it returns the given value using `Left`; otherwise, the new evaluated 186 | -- system is returned inside `Right` 187 | evalConjFormula' :: (ConjFormula,Term) -> System -> Either Value System 188 | evalConjFormula' (psi,t) sys' = case evalConjFormula ctx psi of 189 | Nothing -> Right sys -- False formula: nothing to add 190 | Just (Conj []) -> Left $ eval ctx t -- True formula, return the value 191 | Just cf -> Right $ (cf,eval ctx t) : sys' -- Otherwise, append 192 | 193 | -- Simplify a neutral value if the type is a restriction type with a true 194 | -- formula, otherwise do nothing. 195 | -- `simplNeutralValue` is used only in evaluation. 196 | simplNeutralValue :: Value -> Value 197 | simplNeutralValue neu@(Neutral _ ty) = case ty of 198 | Restr sys _ | any (isTrueConj . fst) sys -> 199 | snd . fromJust $ find (isTrueConj . fst) sys 200 | otherwise -> neu 201 | 202 | -- Split the Abst/Sigma constructor and the arguments from a value 203 | -- inside a closure 204 | extract :: Value -> (Ident -> Term -> Term -> Value,Ident,Term,Term) 205 | extract (Abst s t e) = (Abst ,s,t,e) 206 | extract (Sigma s t e) = (Sigma,s,t,e) 207 | extract v = error $ "[extract] got " ++ show v 208 | 209 | -- Evaluate a closure, extending the context by assigning the variable to 210 | -- the given value. In case of non-dependent abstractions, i.e. empty 211 | -- variable, we don't need to extend the context 212 | evalClosure :: Value -> Value -> Value 213 | evalClosure (Closure (Abst s t e) ctx) arg = 214 | eval (if s == Ident "" then ctx else extend ctx s (Val arg)) e 215 | evalClosure (Closure (Sigma s t e) ctx) arg = 216 | eval (if s == Ident "" then ctx else extend ctx s (Val arg)) e 217 | {-evalClosure (Closure (Abst s t e) ctx) arg = 218 | eval (if s == Ident "" then ctx else extend (case arg of Neutral (Var (Ident s')) _ -> extend ctx (Ident s') (Decl t); _ -> ctx) s (Val arg)) e 219 | evalClosure (Closure (Sigma s t e) ctx) arg = 220 | eval (if s == Ident "" then ctx else extend (case arg of Neutral (Var (Ident s')) _ -> extend ctx (Ident s') (Decl t); _ -> ctx) s (Val arg)) e-} 221 | evalClosure v arg = error $ "[evalClosure] got non-closure " ++ show v 222 | ++ " applied to " ++ show arg 223 | 224 | -- Handler of `App` (function application, i.e. ∏-type eliminator) 225 | doApply :: Value -> Value -> Value 226 | -- Standard case: do β-reduction 227 | doApply fun@(Closure Abst{} ctx) arg = evalClosure fun arg 228 | -- Restricted abstraction case, which requires to apply the function 229 | -- inside the restriction too 230 | doApply (Restr sys fun@Closure{}) arg = foldRestr sys' (doApply fun arg) 231 | where sys' = mapSys (`doApply` arg) sys 232 | -- Standard neutral case 233 | doApply fun@(Neutral _ fty@Closure{}) arg = 234 | simplNeutralValue $ Neutral (App fun arg) (doApply fty arg) 235 | -- Restricted neutral case 236 | doApply fun@(Neutral _ (Restr sys cl@Closure{})) arg = 237 | simplNeutralValue $ Neutral (App fun arg) (foldRestr sys' (doApply cl arg)) 238 | where sys' = mapSys (`doApply` arg) sys 239 | -- System case 240 | doApply (Sys sys) arg = Sys $ mapSys (`doApply` arg) sys 241 | -- Partial type case 242 | doApply fun@(Neutral _ (Partial phi cl@Closure{})) arg = 243 | Neutral (App fun arg) (foldPartial phi (doApply cl arg)) 244 | doApply v arg = error $ "[doApply] got " ++ show v ++ ", " ++ show arg 245 | 246 | -- Handler of `Fst` (i.e. ∑-type first projection) 247 | doFst :: Value -> Value 248 | doFst v = case v of 249 | -- Standard case: do β-redution 250 | Pair v1 _ -> v1 251 | -- Stardard neutral case; need to compute the type 252 | Neutral _ (Closure (Sigma _ t _) ctx) -> simplNeutralValue $ Neutral (Fst v) 253 | (eval ctx t) 254 | -- Restricted neutral case 255 | Neutral x (Restr sys cl@(Closure (Sigma _ t _) ctx)) -> 256 | simplNeutralValue $ Neutral (Fst (Neutral x cl)) 257 | (foldRestr sys' (eval ctx t)) 258 | where sys' = mapSys doFst sys 259 | -- System case 260 | Sys sys -> Sys $ mapSys doFst sys 261 | -- Partial type case 262 | Neutral x (Partial phi cl@(Closure (Sigma _ t _) ctx)) -> 263 | Neutral (Fst (Neutral x cl)) (foldPartial phi (eval ctx t)) 264 | otherwise -> error $ "[doFst] got " ++ show v 265 | 266 | -- Handler of `Snd` (i.e. ∑-type second projection) 267 | doSnd :: Value -> Value 268 | doSnd v = case v of 269 | -- Standard case: do β-redution 270 | Pair _ v2 -> v2 271 | -- Stardard neutral case; need to compute the type 272 | Neutral _ ty@(Closure Sigma{} _) -> simplNeutralValue $ Neutral (Snd v) 273 | (evalClosure ty (doFst v)) 274 | -- Restricted neutral case 275 | Neutral x (Restr sys cl@(Closure Sigma{} _)) -> 276 | simplNeutralValue $ Neutral (Snd (Neutral x cl)) 277 | (foldRestr sys' (evalClosure cl (doFst (Neutral x cl)))) 278 | where sys' = mapSys doSnd sys 279 | -- System case 280 | Sys sys -> Sys $ mapSys doSnd sys 281 | -- Partial type case 282 | Neutral x (Partial phi cl@(Closure Sigma{} _)) -> 283 | Neutral (Snd (Neutral x cl)) 284 | (foldPartial phi (evalClosure cl (doFst (Neutral x cl)))) 285 | otherwise -> error $ "[doSnd] got " ++ show v 286 | 287 | -- Handler of `Split` (i.e. (+)-type eliminator) 288 | doSplit :: Value -> Value -> Value -> Value -> Value 289 | doSplit fam f1 f2 x = case x of 290 | -- Standard cases (left/right injection): do β-redution 291 | InL x1 -> doApply f1 x1 292 | InR x2 -> doApply f2 x2 293 | -- Stardard neutral case; need to compute the type 294 | Neutral _ (Sum _ _) -> simplNeutralValue $ 295 | Neutral (Split fam f1 f2 x) (doApply fam x) 296 | -- Restricted neutral case 297 | Neutral _ (Restr sys (Sum ty1 ty2)) -> simplNeutralValue $ 298 | Neutral (Split fam f1 f2 (Neutral x (Sum ty1 ty2))) 299 | (foldRestr sys' (doApply fam x)) 300 | where sys' = mapSys (doSplit fam f1 f2) sys 301 | -- System case 302 | Sys sys -> Sys $ mapSys (doSplit fam f1 f2) sys 303 | -- Partial type case 304 | Neutral _ (Partial phi (Sum ty1 ty2)) -> 305 | Neutral (Split fam f1 f2 (Neutral x (Sum ty1 ty2))) 306 | (foldPartial phi (doApply fam x)) 307 | otherwise -> error $ "[doSplit] got " ++ show x 308 | 309 | -- Handler of `Ind` (i.e. Nat eliminator) 310 | doInd :: Value -> Value -> Value -> Value -> Value 311 | doInd fam base step m = case m of 312 | -- Standard base and inductive cases: do β-redution 313 | Zero -> base 314 | Succ n' -> doApply fun prev 315 | where 316 | fun = doApply step n' 317 | prev = doInd fam base step n' 318 | -- Stardard neutral case; need to compute the type 319 | Neutral n Nat -> simplNeutralValue $ Neutral (Ind fam base step n) 320 | (doApply fam (Neutral n Nat)) 321 | -- Restricted neutral case 322 | Neutral n (Restr sys Nat) -> 323 | simplNeutralValue $ Neutral (Ind fam base step n) 324 | (foldRestr sys' (doApply fam (Neutral n Nat))) 325 | where sys' = mapSys (doInd fam base step) sys 326 | -- System case 327 | Sys sys -> Sys $ mapSys (doInd fam base step) sys 328 | -- Partial type case 329 | Neutral n (Partial phi Nat) -> 330 | Neutral (Ind fam base step n) 331 | (foldPartial phi (doApply fam (Neutral n Nat))) 332 | otherwise -> error $ "[doInd] got " ++ show m 333 | 334 | -- Utility function to handle eventually empty strings 335 | ifEmpty :: Ident -> String -> Ident 336 | ifEmpty (Ident "") s = Ident s 337 | ifEmpty i _ = i 338 | 339 | 340 | {- Handler of composition (which is not an eliminator!). 341 | The problem with composition is that we need to pattern-match inside 342 | a closure (`famV`); when calling `doComp` recursively, we must 343 | read-back terms, but we cannot do so for the type family (otherwise 344 | it would then be evaluated under the general context and not in its own). 345 | Therefore, we introduce a wrapper `TermV` which makes it possible to 346 | include values (closures) inside terms, so that when the whole term is 347 | evaluated, the closure is evaluated with the right context. The wrapper 348 | `TermV` is used solely in the evaluation of composition. 349 | -} 350 | doComp :: Ctx -> Term -> DisjFormula -> Term -> Term -> Term -> Term -> Value 351 | --doComp ctx fam phi i0 u b i = myTrace ("[doComp-?] " ++ show (Comp fam phi i0 u b i) ++ ", ctx = " ++ showCtx ctx) $ 352 | doComp ctx fam phi i0 u b i = 353 | if isTrue phiV then -- 1° trivial case: `phi` is True 354 | doApply uV iV 355 | else if i0V == iV then -- 2° trivial case: i = i_0 (no need for `conv`) 356 | bV 357 | else 358 | -- Fresh variables: `var` to pattern-match the type family 359 | -- `var2` to handle the partially defined `u` 360 | let var = newVar (keys ctx) (Ident "_i") 361 | var2 = case uV of 362 | Closure (Abst v _ _) _ -> newVar (keys ctx) (ifEmpty v "j") 363 | emptySys = Abst (Ident "") I (Sys []) 364 | ctxOf v = case v of Closure _ gctx -> gctx 365 | -- Evaluate the type-family, pattern-matching inside the closure 366 | in case doApply famV (Neutral (Var var) I) of 367 | -- ∏-type `[x:ty]e`, with `ty` a type 368 | cl@(Closure (Abst x ty e) ctx') | eval ctx' ty /= I -> myTrace ("[doComp-∏] " ++ show (Comp fam phi i0 u b i) ++ ", ctx = " ++ showCtx ctx ++ ", ctx' = " ++ showCtx ctx') $ 369 | Closure (Abst yi tyc comp) ctx 370 | where 371 | -- Variable of the target type `tyc`, i.e. `ty(i)` 372 | yi = newVar (var : var2 : keys ctx) (ifEmpty x "u") 373 | -- Transport of that variable at `i0` and `var' 374 | yt0 = Comp (TermV fam1) fFalse i emptySys (Var yi) i0 375 | yt = Comp (TermV fam1) fFalse i emptySys (Var yi) (Var var) 376 | -- Resulting composition 377 | comp = Comp (TermV fam2) phi i0 u' (App b yt0) i 378 | -- Type families 379 | fam1 = Closure (Abst var I ty) ctx' 380 | fam2 = Closure (Abst var I (App (Abst x ty e) yt)) ctx' 381 | -- Target type: `ty(i)` 382 | tyc = readBack (keys ctx) $ case doApply famV iV of 383 | Closure (Abst _ ty' _) ctx'' -> eval ctx'' ty' 384 | -- Apply functions to `yt` inside `u` 385 | u' = case isFalse phiV of 386 | True -> u 387 | False -> Abst var2 I (App (App u (Var var2)) yt) 388 | -- ∏-type `[x:I]e` 389 | cl@(Closure (Abst x ty e) ctx') | eval ctx' ty == I -> myTrace ("[doComp-∏I] " ++ show (Comp fam phi i0 u b i) ++ ", ctx = " ++ showCtx ctx ++ ", ctx' = " ++ showCtx ctx') $ 390 | Closure (Abst x' I comp) ctx 391 | where 392 | -- Fresh nterval variable 393 | x' = newVar (var : var2 : keys ctx) (ifEmpty x "i") 394 | -- Resulting composition 395 | comp = Comp (TermV fam') phi i0 u' (App b (Var x')) i 396 | fam' = Closure (Abst var I e) ctx' 397 | -- Apply functions to `x'` inside `u` 398 | u' = case isFalse phiV of 399 | True -> u 400 | False -> Abst var2 I (App (App u (Var var2)) (Var x')) 401 | -- ∑-type `e` 402 | cl@(Closure (Sigma _ ty _) ctx') -> myTrace ("[doComp-∑] " ++ show (Comp fam phi i0 u b i) ++ ", ctx = " ++ showCtx ctx ++ ", ctx' = " ++ showCtx ctx') $ Pair c1 c2 403 | where 404 | -- Composition on each pair 405 | c1 = doComp ctx (TermV fam1) phi i0 u0 (Fst b) i 406 | c2 = doComp ctx (TermV fam2) phi i0 u1 (Snd b) i 407 | -- The type family of `c2` needs the comp. on the first component 408 | fam1 = Closure (Abst var I ty) ctx' 409 | fam2 = Closure (Abst var I ty2) ctx' 410 | ty2 = readBack (keys ctx) $ evalClosure cl c1' 411 | c1' = doComp ctx (TermV fam1) phi i0 u0 (Fst b) (Var var) 412 | -- Apply projections inside `u` 413 | (u0,u1) = case isFalse phiV of 414 | True -> (u,u) 415 | False -> (Abst var2 I (Fst (App u (Var var2))), 416 | Abst var2 I (Snd (App u (Var var2)))) 417 | -- Coproduct `ty1 + ty2` 418 | Sum ty1 ty2 -> myTrace ("[doComp-Coproduct] " ++ show (Comp fam phi i0 u b i) ++ ", ctx = " ++ showCtx ctx) $ 419 | -- If `b` is neutral, the result is neutral 420 | case bV of 421 | Neutral{} -> doNeutralComp 422 | otherwise -> inj comp 423 | where (inj,bV',ty) = case bV of 424 | -- Extract the injection, the inner value and the type 425 | InL b1 -> (InL,b1,ty1) 426 | InR b2 -> (InR,b2,ty2) 427 | -- Resulting composition 428 | comp = doComp ctx (TermV fam') phi i0 u' b' i 429 | b' = readBack (keys ctx) bV' 430 | fam' = Closure (Abst var I ty') (ctxOf famV) 431 | ty' = readBack (keys (ctxOf famV)) ty 432 | -- Remove the outer injections from `u` 433 | u' = case isFalse phiV of 434 | True -> u 435 | False -> Abst var2 I (readBack (keys ctx) sys') 436 | where app = App u (Var var2) 437 | sys' = case eval (extend ctx var2 (Decl I)) app of 438 | Sys sysV -> Sys $ map (\case {(psi,InL q) -> (psi,q); 439 | (psi,InR q) -> (psi,q)}) sysV 440 | InL q -> q 441 | InR q -> q 442 | -- Naturals 443 | Nat -> myTrace ("[doComp-Nat] " ++ show (Comp fam phi i0 u b i) ++ ", ctx = " ++ showCtx ctx) $ case bV of 444 | Zero -> Zero 445 | Succ b' -> Succ $ doComp ctx fam phi i0 u' b' i 446 | -- Remove the outer `S` from `u` 447 | where u' = case isFalse phiV of 448 | True -> u 449 | False -> Abst var2 I (readBack (keys ctx) sys') 450 | where app = App u (Var var2) 451 | sys' = case eval (extend ctx var2 (Decl I)) app of 452 | Sys sysV -> Sys $ 453 | map (\case (psi,Succ m) -> (psi,m)) sysV 454 | Succ m -> m 455 | Neutral{} -> doNeutralComp 456 | _ -> error $ "[doComp-Nat] got " ++ show bV 457 | -- Partial type `[phi]ty` 458 | Partial (Disj df) tyV -> myTrace ("[doComp-Partial] " ++ show (Comp fam phi i0 u b i) ++ ", ctx = " ++ showCtx ctx) $ 459 | if var `elem` vars (Disj df) then 460 | error $ "Type family '" ++ show (readBack (keys ctx) famV) 461 | ++ "' is not fibrant" 462 | else 463 | sysComp 464 | where 465 | -- Type family (without the formula) 466 | fam' = Closure (Abst var I ty') (ctxOf famV) 467 | ty' = readBack (keys (ctxOf famV)) tyV 468 | -- Obtain a system will a composition for each conjunction 469 | -- If the system has just one value, return it 470 | sysCompVals = map helperComp df 471 | sysComp = if length df == 1 then 472 | head sysCompVals 473 | else 474 | Sys $ zip df sysCompVals 475 | -- Do composition on each conjunction 476 | helperComp :: ConjFormula -> Value 477 | helperComp conj = doComp (addConjBindings ctx conj) 478 | (TermV fam') phi i0 u (b' conj) i 479 | -- Eventually simplify `b` (as it may have already been evaluated) 480 | b' :: ConjFormula -> Value 481 | b' conj = readBack (keys ctx) $ case bV of 482 | -- A formula is true 483 | Sys sysU | any ((conjToDirEnv conj `makesTrueConj`) . fst) sysU 484 | -> snd . fromJust $ 485 | find ((conjToDirEnv conj `makesTrueConj`) . fst) sysU 486 | _ -> bV 487 | -- Restriction type `[psi -> w]ty` 488 | Restr sysR tyV -> myTrace ("[doComp-Restr] " ++ show (Comp fam phi i0 u b i) ++ ", ctx = " ++ showCtx ctx) $ 489 | if var `elem` concatMap vars (keys sys) then 490 | error $ "Type family '" ++ show (readBack (keys ctx) famV) 491 | ++ "' is not fibrant" 492 | else 493 | doComp ctx (TermV fam') formula i0 u' b i 494 | where 495 | -- Get the new formula 496 | formula = Disj $ phi' ++ psis 497 | phi' = case phi of Disj ff -> ff 498 | psis = keys sysR 499 | -- Type family (without the restriction) 500 | fam' = Closure (Abst var I ty') (ctxOf famV) 501 | ty' = readBack (keys (ctxOf famV)) tyV 502 | u' = Abst var2 I (Sys sys') 503 | -- Concatenate the two systems 504 | sys' = map (\conj -> (conj,App u (Var var2))) phi' 505 | ++ case doApply famV (Neutral (Var var2) I) of 506 | Restr sys'' _ -> 507 | mapSys (TermV . readBack (keys ctx)) sys'' 508 | 509 | -- Neutral type family; the result of the composition is neutral too 510 | otherwise -> myTrace ("[doComp-neutral] " ++ 511 | show (Comp fam phi i0 u b i)) $ doNeutralComp 512 | where 513 | -- Values computed for each argument (remember that Haskell is lazy!) 514 | famV = myTrace ("[doComp - fam = " ++ show fam ++ "]" ++ show (Comp fam phi i0 u b i)) $ eval ctx fam 515 | phiV = evalDisjFormula ctx phi 516 | i0V = eval ctx i0 517 | uV = myTrace ("[doComp - u = " ++ show u ++ "]" ++ show (Comp fam phi i0 u b i)) $ eval ctx u 518 | bV = myTrace ("[doComp - b = " ++ show b ++ "]" ++ show (Comp fam phi i0 u b i)) $ eval ctx b 519 | iV = eval ctx i 520 | -- Compute the type of the composition, and prepare the neutral value 521 | doNeutralComp = simplNeutralValue $ 522 | Neutral (Comp famV phiV i0V uV bV iV) (eval ctx compTy) 523 | sys = getCompSys phi i0 u b i 524 | compTy = Restr sys (App fam i) 525 | 526 | -- Get the system of the restriction type of a composition 527 | getCompSys :: DisjFormula -> Term -> Term -> Term -> Term -> System 528 | getCompSys (Disj df) i0 u b i = eq ++ map (\conj -> (conj,App u i)) df 529 | where 530 | -- Extract the variables from eventual values 531 | i' = case i of { Neutral (Var x) _ -> Var x ; _ -> i } 532 | i0' = case i0 of { Neutral (Var x) _ -> Var x ; _ -> i0 } 533 | -- Translate `i = i0` into a real formula 534 | eq = case (i0',i') of 535 | (I0,I0) -> [(Conj [],b)] 536 | (I0,I1) -> [] 537 | (I0,Var s) -> [(Conj [Eq0 s],b)] 538 | (Var s,I0) -> [(Conj [Eq0 s],b)] 539 | (Var s,I1) -> [(Conj [Eq1 s],b)] 540 | (Var s,Var s') -> [(Conj [Diag s s'],b)] 541 | (I1,I0) -> [] 542 | (I1,I1) -> [(Conj [],b)] 543 | (I1,Var s) -> [(Conj [Eq1 s],b)] 544 | _ -> error $ "[getCompSys] got " ++ show (i,i0) 545 | 546 | -- Read-back function which converts values back into terms 547 | -- The first argument is the list of already used names 548 | -- The only non-trivial case is that of closures 549 | readBack :: [Ident] -> Value -> Term 550 | readBack used val = case val of 551 | App fun arg -> App (readBack used fun) (readBack used arg) 552 | Succ v -> Succ (readBack used v) 553 | Fst v -> Fst (readBack used v) 554 | Snd v -> Snd (readBack used v) 555 | Pair v1 v2 -> Pair (readBack used v1) (readBack used v2) 556 | Sum v1 v2 -> Sum (readBack used v1) (readBack used v2) 557 | InL v -> InL (readBack used v) 558 | InR v -> InR (readBack used v) 559 | Split ty f1 f2 x -> Split (readBack used ty) (readBack used f1) 560 | (readBack used f2) (readBack used x) 561 | Sys sys -> Sys $ mapSys (readBack used) sys 562 | Partial phi ty -> foldPartial phi (readBack used ty) 563 | Restr sys ty -> foldRestr (mapSys (readBack used) sys) (readBack used ty) 564 | Ind ty b e n -> Ind (readBack used ty) (readBack used b) (readBack used e) 565 | (readBack used n) 566 | Comp fam phi i0 u b i -> Comp (readBack used fam) phi (readBack used i0) 567 | (readBack used u) (readBack used b) (readBack used i) 568 | -- Closure case: first evaluate the body with a fresh name, then read-back 569 | cl@(Closure f ctx) -> let 570 | -- `constr` is `Abst` or `Sigma` 571 | (constr,s,t,e) = extract f 572 | s' = newVar used s 573 | eVal = evalClosure cl (Neutral (Var s') (eval ctx t)) 574 | e' = readBack (s' : used) eVal 575 | t' = readBack used (eval ctx t) 576 | in constr s' t' e' 577 | -- For neutrals, read-back the value, ignoring the type 578 | Neutral v _ -> readBack used v 579 | otherwise -> val 580 | 581 | -- Normalization means first evaluating and then reading-back 582 | normalize :: Ctx -> Term -> Term 583 | normalize ctx e = readBack (keys ctx) (eval ctx e) 584 | 585 | {- Linear head reduction -} 586 | 587 | {- 588 | headRedV :: Ctx -> Term -> Value 589 | headRedV ctx (Var s) = getLeastEval ctx s 590 | headRedV ctx (App k n) = doApply (headRedV ctx k) (eval ctx n) 591 | headRedV ctx (Ind ty b s k) = doInd (eval ctx ty) (eval ctx b) (eval ctx s) (headRedV ctx k) 592 | headRedV ctx (Fst t) = doFst (eval ctx t) 593 | headRedV ctx (Snd t) = doSnd (eval ctx t) 594 | headRedV ctx t = eval ctx t 595 | 596 | --Gets the least evaluated form of 'x' from context 597 | getLeastEval :: Ctx -> Ident -> Value 598 | getLeastEval ctx s = case lookup s ctx of 599 | Just (Def _ e) -> eval ctx e 600 | Just (Decl ty) -> Neutral (Var s) (eval ctx ty) 601 | 602 | --Do head reduction step 603 | headRed :: Ctx -> Term -> Term 604 | headRed ctx term = case term of 605 | Abst s t e -> Abst s t e' 606 | where e' = headRed (extend ctx s (Decl t)) e 607 | Sigma s t e -> Sigma s t e' 608 | where e' = headRed (extend ctx s (Decl t)) e 609 | Succ t -> Succ (headRed ctx t) 610 | Pair t1 t2 -> Pair (headRed ctx t1) (headRed ctx t2) 611 | otherwise -> readBack (keys ctx) (headRedV ctx term) 612 | -} 613 | 614 | {- Printing utilities (should be in AbsCTT but these need 'readBack') -} 615 | 616 | -- Print function for a term or value (which is read-back into 617 | -- a term, except when debugging) 618 | instance Show Term where 619 | show t = printTerm' 0 (if debug then t else readBack [] t) 620 | 621 | -- Helper function; the first argument `i` measures the depth 622 | -- of the term (but is reset in some cases), which is used to 623 | -- avoid unnecessary parentheses 624 | printTerm' :: Int -> Term -> String 625 | printTerm' i = \case 626 | Var s -> show s 627 | Universe -> "U" 628 | TDef (s,t,e) t' -> 629 | "[" ++ show s ++ ":" ++ printTerm' 0 t ++ " = " 630 | ++ printTerm' 0 e ++ "]" ++ printTerm' 0 t' 631 | Abst s t e -> par1 ++ abstS ++ par2 632 | where abstS = if s == Ident "" || not (containsVar s e) 633 | then -- A -> B (no dependency) 634 | printTerm' (i+1) t ++ " -> " ++ printTerm' 0 e 635 | else 636 | "[" ++ show s ++ ":" ++ printTerm' 0 t ++ "]" ++ printTerm' 0 e 637 | Sigma s t e -> par1 ++ abstS ++ par2 638 | where abstS = if s == Ident "" || not (containsVar s e) 639 | then -- A * B (no dependency) 640 | printTerm' (i+1) t ++ " * " ++ printTerm' 0 e 641 | else 642 | "<" ++ show s ++ ":" ++ printTerm' 0 t ++ ">" 643 | ++ printTerm' 0 e 644 | Pair t1 t2 -> par1 ++ printTerm' i t1 ++ "," ++ printTerm' i t2 ++ par2 645 | Fst t -> par1 ++ printTerm' (i + 1) t ++ ".1" ++ par2 646 | Snd t -> par1 ++ printTerm' (i + 1) t ++ ".2" ++ par2 647 | Sum ty1 ty2 -> par1 ++ printTerm' (i + 1) ty1 ++ " + " 648 | ++ printTerm' (i + 1) ty2 ++ par2 649 | InL t1 -> par1 ++ "inl " ++ printTerm' (i + 1) t1 ++ par2 650 | InR t2 -> par1 ++ "inr " ++ printTerm' (i + 1) t2 ++ par2 651 | Split ty f1 f2 x -> par1 ++ "split " ++ printTerm' (i+1) ty ++ " " 652 | ++ printTerm' (i+1) f1 ++ " " ++ printTerm' (i+1) f2 ++ " " 653 | ++ printTerm' (i+1) x ++ par2 654 | App fun arg -> par1 ++ printTerm' (i+1) inner ++ " " ++ unwords printedArgs ++ par2 655 | where (inner,args) = collectApps (App fun arg) [] 656 | printedArgs = map (printTerm' (i+1)) args 657 | Nat -> "N" 658 | Zero -> "Z" 659 | Succ t -> par1 ++ "S " ++ printTerm' (i+1) t ++ par2 660 | Ind ty b s n -> par1 ++ "ind " ++ printTerm' (i+1) ty ++ " " 661 | ++ printTerm' (i+1) b ++ " " ++ printTerm' (i+1) s ++ " " 662 | ++ printTerm' (i+1) n ++ par2 663 | I -> "I" 664 | I0 -> "0" 665 | I1 -> "1" 666 | Sys sys -> showSystem sys 667 | Partial phi t -> "[" ++ show phi ++ "]" ++ printTerm' (i+1) t 668 | -- If the restriction is empty, don't print it, otherwise it 669 | -- could be mistaken for a partial type with false formula 670 | Restr sys t -> (if null sys then "" else showSystem sys) ++ printTerm' (i+1) t 671 | Comp fam phi i0 u b i' -> par1 ++ "comp " ++ printTerm' (i+1) fam 672 | ++ " (" ++ show phi ++ ") " ++ printTerm' (i+1) i0 ++ " " 673 | ++ printTerm' (i+1) u ++ " " ++ printTerm' (i+1) b 674 | ++ " " ++ printTerm' (i+1) i' ++ par2 675 | -------- Used only when debugging, to print proper values 676 | Closure cl ctx -> "Cl(" ++ show cl ++ ")"-- ";" ++ showCtx ctx ++ ")" 677 | Neutral v t -> printTerm' i v -- "N{" ++ printTerm' i v ++ "}:" ++ printTerm' (i+1) t 678 | TermV v -> show v 679 | -- Parentheses are not needed if `i` is zero 680 | where (par1,par2) = if i == 0 then ("","") else ("(",")") 681 | 682 | -- Print a context (in one line) 683 | showCtx :: Ctx -> String 684 | showCtx ctx = "[" ++ intercalate ", " (map showEntry (reverse ctx)) ++ "]" 685 | 686 | -- Print a single context entry 687 | showEntry :: (Ident,CtxEntry) -> String 688 | showEntry (s,Decl ty) = show s ++ " : " ++ show ty 689 | showEntry (s,Def ty val) = show s ++ " : " ++ show ty ++ " = " ++ show val 690 | showEntry (s,Val val) = show s ++ " => " ++ show val 691 | 692 | -- Print a system 693 | showSystem :: System -> String 694 | showSystem sys = "[" ++ sysS ++ "]" 695 | where sysS = intercalate " | " $ 696 | map (\(ff,t) -> show ff ++ " -> " ++ show t) sys -------------------------------------------------------------------------------- /Ident.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module Ident where 4 | 5 | import Data.String 6 | 7 | newtype Ident = Ident String 8 | deriving (Eq, Ord, IsString) 9 | 10 | instance Show Ident where 11 | show (Ident s) = s -------------------------------------------------------------------------------- /Interval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | module Interval where 4 | 5 | import Data.List (intercalate,delete) 6 | import Ident 7 | 8 | -- Atomic formulas are of the kind `i = 0`, `i = 1` or `i = j` 9 | data AtomicFormula 10 | = Eq0 Ident 11 | | Eq1 Ident 12 | | Diag Ident Ident 13 | deriving (Ord) 14 | 15 | -- Equality between atomic formulas 16 | instance Eq AtomicFormula where 17 | af1 == af2 = case (af1,af2) of 18 | (Eq0 s1,Eq0 s2) -> s1 == s2 19 | (Eq1 s1,Eq1 s2) -> s1 == s2 20 | (Diag s1 s2,Diag s3 s4) -> (s1 == s3 && s2 == s4) 21 | || (s1 == s4 && s2 == s3) 22 | otherwise -> False 23 | 24 | -- A conjunctive formula is a list of atomic formulas 25 | newtype ConjFormula = Conj [AtomicFormula] 26 | deriving (Eq,Ord) 27 | 28 | -- A disjunctive formula is a list of conjunctive formulas 29 | newtype DisjFormula = Disj [ConjFormula] 30 | deriving (Eq,Ord) 31 | 32 | {- Pretty printing of atomic/conjunctive/disjunctive formulas -} 33 | 34 | instance Show AtomicFormula where 35 | show af = case af of 36 | Eq0 s -> show s ++ " = 0" 37 | Eq1 s -> show s ++ " = 1" 38 | Diag s1 s2 -> show s1 ++ " = " ++ show s2 39 | 40 | instance Show ConjFormula where 41 | show (Conj cf) 42 | | null cf = "True" 43 | | otherwise = intercalate " /\\ " (map show cf) 44 | 45 | instance Show DisjFormula where 46 | show disj@(Disj df) 47 | | disj == fFalse = "False" 48 | | disj == fTrue = "True" 49 | | otherwise = intercalate " \\/ " $ 50 | map (\cf -> "(" ++ show cf ++ ")") df 51 | 52 | {- Helpers -} 53 | 54 | -- True (disjunctive) formula: just one empty conjunction 55 | fTrue :: DisjFormula 56 | fTrue = Disj [Conj []] 57 | 58 | -- False formula: empty disjunction 59 | fFalse :: DisjFormula 60 | fFalse = Disj [] 61 | 62 | isTrue :: DisjFormula -> Bool 63 | isTrue = (== fTrue) 64 | 65 | isFalse :: DisjFormula -> Bool 66 | isFalse = (== fFalse) 67 | 68 | isTrueConj :: ConjFormula -> Bool 69 | isTrueConj (Conj cf) = null cf 70 | 71 | {- Implication and equivalence -} 72 | 73 | {- A disjunctive formula implies another one if each of its conjunctions 74 | makes the second formula true. The case where the second formula is false 75 | must be handled separately. The first two checks are unnecessary, used only 76 | for efficiency -} 77 | impDisj :: DirEnv -> DisjFormula -> DisjFormula -> Bool 78 | impDisj dirs (Disj df1) disj2 = isFalse (Disj df1) || isTrue disj2 || 79 | if isFalse disj2 then 80 | all (inconsistent . addConj dirs) df1 -- First formula must be false 81 | else 82 | all (\cf1 -> addConj dirs cf1 `makesTrueDisj` disj2) df1 83 | 84 | -- Two formulas are equal is they imply each other 85 | eqFormulas :: DirEnv -> DisjFormula -> DisjFormula -> Bool 86 | eqFormulas dirs disj1 disj2 = impDisj dirs disj1 disj2 && impDisj dirs disj2 disj1 87 | 88 | 89 | {- Directions enviroment -} 90 | 91 | -- A `DirEnv` stores the list of zeros, ones and the diagonals partitions 92 | type DirEnv = ([Ident],[Ident],[[Ident]]) 93 | 94 | emptyDirEnv :: DirEnv 95 | emptyDirEnv = ([],[],[]) 96 | 97 | -- A `DirEnv` is inconsistent if there is an identifier 98 | -- which is set both to zero and one 99 | inconsistent :: DirEnv -> Bool 100 | inconsistent (zeros,ones,diags) = 101 | any (`elem` ones) zeros || any (`elem` zeros) ones 102 | 103 | -- Find the partition which contains `s`, if it exists. 104 | -- Otherwise return the fake partition [s] 105 | findPartition :: [[Ident]] -> Ident -> [Ident] 106 | findPartition diags s = case filter (s `elem`) diags of 107 | [] -> [s] 108 | l -> head l 109 | 110 | -- Set an identifier to zero. Any eventual identifier which is in the same 111 | -- partition must then be set to zero, and that partition is removed 112 | addZero :: DirEnv -> Ident -> DirEnv 113 | addZero (zeros,ones,diags) s = 114 | let toadd = findPartition diags s 115 | in (toadd ++ zeros,ones,delete toadd diags) 116 | 117 | -- Set an identifier to one. Any eventual identifier which is in the same 118 | -- partition must then be set to one, and that partition is removed 119 | addOne :: DirEnv -> Ident -> DirEnv 120 | addOne (zeros,ones,diags) s = 121 | let toadd = findPartition diags s 122 | in (zeros,toadd ++ ones,delete toadd diags) 123 | 124 | -- Add a new diagonal `s1 = s2` 125 | addDiag :: DirEnv -> Ident -> Ident -> DirEnv 126 | addDiag dirs@(zeros,ones,diags) s1 s2 127 | | s1 == s2 = dirs -- Trivial, nothing to do 128 | | s1 `elem` zeros = addZero dirs s2 -- `s1` already zero -> set `s2` to zero 129 | | s2 `elem` zeros = addZero dirs s1 -- `s2` already zero -> set `s1` to zero 130 | | s1 `elem` ones = addOne dirs s2 -- `s1` already one -> set `s2` to one 131 | | s2 `elem` ones = addOne dirs s1 -- `s2` already one -> set `s1` to zero 132 | | otherwise = let 133 | -- Add `s1` and `s2` to the existing partitions if it's the case: 134 | -- it means that e.g if partition `set` contains `s1`, then `s2` 135 | -- shall be added to `set` too 136 | diags' = [if s1 `elem` set then s2 : set else if s2 `elem` set then s1 : set 137 | else set | set <- diags] 138 | -- Add a new partition if `s1` and `s2` are new (= not found in the partitions) 139 | diags'' = diags' ++ 140 | [[s1,s2] | not (s1 `elem` concat diags' || s2 `elem` concat diags')] 141 | par1 = findPartition diags'' s1 142 | par2 = findPartition diags'' s2 143 | -- Eventually join the two partitions 144 | -- (e.g. [i,k] [j,k,l] gets joined into [i,j,k,l]) 145 | diags''' = if par1 /= par2 then 146 | delete par2 (delete par1 diags'') ++ [par1 ++ par2] 147 | else 148 | diags'' 149 | in (zeros,ones,diags''') 150 | 151 | -- Add a conjunction to a `DirEnv` 152 | addConj :: DirEnv -> ConjFormula -> DirEnv 153 | addConj dirs (Conj conj) = foldl addAtomic dirs conj 154 | where 155 | addAtomic :: DirEnv -> AtomicFormula -> DirEnv 156 | addAtomic dirs' ff = case ff of 157 | Eq0 s -> addZero dirs' s 158 | Eq1 s -> addOne dirs' s 159 | Diag s s' -> addDiag dirs' s s' 160 | 161 | -- Conversion from a conjunction to a `DirEnv` 162 | conjToDirEnv :: ConjFormula -> DirEnv 163 | conjToDirEnv = addConj emptyDirEnv 164 | 165 | -- Test if a `DirEnv` makes an atomic formula true. 166 | -- A diagonal is true iff both are zero, or both are true, or if 167 | -- they are in the same partition 168 | makesTrueAtomic :: DirEnv -> AtomicFormula -> Bool 169 | (zeros,ones,diags) `makesTrueAtomic` af = case af of 170 | Eq0 s -> s `elem` zeros 171 | Eq1 s -> s `elem` ones 172 | Diag s1 s2 -> s1 == s2 || bothIn zeros || bothIn ones || any bothIn diags 173 | where bothIn set = s1 `elem` set && s2 `elem` set 174 | 175 | -- A conjunction is true iff all of its atomic formulas are true 176 | makesTrueConj :: DirEnv -> ConjFormula -> Bool 177 | makesTrueConj dirs (Conj cf) = all (dirs `makesTrueAtomic`) cf 178 | 179 | -- A disjunction is true iff one of its conjunctive formulas is true 180 | makesTrueDisj :: DirEnv -> DisjFormula -> Bool 181 | makesTrueDisj dirs (Disj df) = any (dirs `makesTrueConj`) df 182 | 183 | -- Substitute `s'` for `s` in an atomic formula 184 | substAtomic :: (Ident,Ident) -> AtomicFormula -> AtomicFormula 185 | substAtomic (s,s') af = case af of 186 | Eq0 x | s == x -> Eq0 s' 187 | Eq1 x | s == x -> Eq1 s' 188 | Diag x y -> Diag (if x == s then s' else x) (if y == s then s' else y) 189 | otherwise -> af 190 | 191 | -- Substitute into each atomic formula of the conjunction 192 | substConj :: (Ident,Ident) -> ConjFormula -> ConjFormula 193 | substConj (s,s') (Conj cf) = Conj $ map (substAtomic (s,s')) cf 194 | 195 | -- Concatenation (logical AND) between two conjunctive formulas 196 | meet :: ConjFormula -> ConjFormula -> ConjFormula 197 | (Conj cf1) `meet` (Conj cf2) = Conj $ cf1 ++ cf2 -------------------------------------------------------------------------------- /LexCTT.x: -------------------------------------------------------------------------------- 1 | -- -*- haskell -*- 2 | -- This Alex file was machine-generated by the BNF converter 3 | { 4 | {-# OPTIONS -fno-warn-incomplete-patterns #-} 5 | {-# OPTIONS_GHC -w #-} 6 | module LexCTT where 7 | 8 | import Prelude 9 | 10 | import qualified Data.Bits 11 | import Data.Word (Word8) 12 | import Data.Char (ord) 13 | } 14 | 15 | 16 | $c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter (215 = \times) FIXME 17 | $s = [a-z\222-\255] # [\247] -- small isolatin1 letter (247 = \div ) FIXME 18 | $l = [$c $s] -- letter 19 | $d = [0-9] -- digit 20 | $i = [$l $d _ '] -- identifier character 21 | $u = [. \n] -- universal: any character 22 | 23 | @rsyms = -- symbols and non-identifier-like reserved words 24 | \( | \) | \- \> | \* | \[ | \: | \] | \< | \> | \, | \. "1" | \. "2" | "0" | "1" | \+ | \= | \; | \\ \/ | \/ \\ | \| 25 | 26 | :- 27 | 28 | -- Line comments 29 | "--" [.]* ; 30 | 31 | -- Block comments 32 | \{ \- [$u # \-]* \- ([$u # [\- \}]] [$u # \-]* \- | \-)* \} ; 33 | 34 | $white+ ; 35 | @rsyms 36 | { tok (\p s -> PT p (eitherResIdent TV s)) } 37 | 38 | $l $i* 39 | { tok (\p s -> PT p (eitherResIdent TV s)) } 40 | 41 | 42 | 43 | 44 | 45 | { 46 | 47 | tok :: (Posn -> String -> Token) -> (Posn -> String -> Token) 48 | tok f p s = f p s 49 | 50 | data Tok = 51 | TS !String !Int -- reserved words and symbols 52 | | TL !String -- string literals 53 | | TI !String -- integer literals 54 | | TV !String -- identifiers 55 | | TD !String -- double precision float literals 56 | | TC !String -- character literals 57 | 58 | deriving (Eq,Show,Ord) 59 | 60 | data Token = 61 | PT Posn Tok 62 | | Err Posn 63 | deriving (Eq,Show,Ord) 64 | 65 | printPosn :: Posn -> String 66 | printPosn (Pn _ l c) = "line " ++ show l ++ ", column " ++ show c 67 | 68 | tokenPos :: [Token] -> String 69 | tokenPos (t:_) = printPosn (tokenPosn t) 70 | tokenPos [] = "end of file" 71 | 72 | tokenPosn :: Token -> Posn 73 | tokenPosn (PT p _) = p 74 | tokenPosn (Err p) = p 75 | 76 | tokenLineCol :: Token -> (Int, Int) 77 | tokenLineCol = posLineCol . tokenPosn 78 | 79 | posLineCol :: Posn -> (Int, Int) 80 | posLineCol (Pn _ l c) = (l,c) 81 | 82 | mkPosToken :: Token -> ((Int, Int), String) 83 | mkPosToken t@(PT p _) = (posLineCol p, tokenText t) 84 | 85 | tokenText :: Token -> String 86 | tokenText t = case t of 87 | PT _ (TS s _) -> s 88 | PT _ (TL s) -> show s 89 | PT _ (TI s) -> s 90 | PT _ (TV s) -> s 91 | PT _ (TD s) -> s 92 | PT _ (TC s) -> s 93 | Err _ -> "#error" 94 | 95 | prToken :: Token -> String 96 | prToken t = tokenText t 97 | 98 | data BTree = N | B String Tok BTree BTree deriving (Show) 99 | 100 | eitherResIdent :: (String -> Tok) -> String -> Tok 101 | eitherResIdent tv s = treeFind resWords 102 | where 103 | treeFind N = tv s 104 | treeFind (B a t left right) | s < a = treeFind left 105 | | s > a = treeFind right 106 | | s == a = t 107 | 108 | resWords :: BTree 109 | resWords = b ">" 16 (b ".2" 8 (b "+" 4 (b ")" 2 (b "(" 1 N N) (b "*" 3 N N)) (b "->" 6 (b "," 5 N N) (b ".1" 7 N N))) (b ":" 12 (b "0" 10 (b "/\\" 9 N N) (b "1" 11 N N)) (b "<" 14 (b ";" 13 N N) (b "=" 15 N N)))) (b "]" 24 (b "U" 20 (b "N" 18 (b "I" 17 N N) (b "S" 19 N N)) (b "[" 22 (b "Z" 21 N N) (b "\\/" 23 N N))) (b "inr" 28 (b "ind" 26 (b "comp" 25 N N) (b "inl" 27 N N)) (b "|" 30 (b "split" 29 N N) N))) 110 | where b s n = let bs = s 111 | in B bs (TS bs n) 112 | 113 | unescapeInitTail :: String -> String 114 | unescapeInitTail = id . unesc . tail . id 115 | where 116 | unesc s = case s of 117 | '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs 118 | '\\':'n':cs -> '\n' : unesc cs 119 | '\\':'t':cs -> '\t' : unesc cs 120 | '\\':'r':cs -> '\r' : unesc cs 121 | '\\':'f':cs -> '\f' : unesc cs 122 | '"':[] -> [] 123 | c:cs -> c : unesc cs 124 | _ -> [] 125 | 126 | ------------------------------------------------------------------- 127 | -- Alex wrapper code. 128 | -- A modified "posn" wrapper. 129 | ------------------------------------------------------------------- 130 | 131 | data Posn = Pn !Int !Int !Int 132 | deriving (Eq, Show,Ord) 133 | 134 | alexStartPos :: Posn 135 | alexStartPos = Pn 0 1 1 136 | 137 | alexMove :: Posn -> Char -> Posn 138 | alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1) 139 | alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1 140 | alexMove (Pn a l c) _ = Pn (a+1) l (c+1) 141 | 142 | type Byte = Word8 143 | 144 | type AlexInput = (Posn, -- current position, 145 | Char, -- previous char 146 | [Byte], -- pending bytes on the current char 147 | String) -- current input string 148 | 149 | tokens :: String -> [Token] 150 | tokens str = go (alexStartPos, '\n', [], str) 151 | where 152 | go :: AlexInput -> [Token] 153 | go inp@(pos, _, _, str) = 154 | case alexScan inp 0 of 155 | AlexEOF -> [] 156 | AlexError (pos, _, _, _) -> [Err pos] 157 | AlexSkip inp' len -> go inp' 158 | AlexToken inp' len act -> act pos (take len str) : (go inp') 159 | 160 | alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) 161 | alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s)) 162 | alexGetByte (p, _, [], s) = 163 | case s of 164 | [] -> Nothing 165 | (c:s) -> 166 | let p' = alexMove p c 167 | (b:bs) = utf8Encode c 168 | in p' `seq` Just (b, (p', c, bs, s)) 169 | 170 | alexInputPrevChar :: AlexInput -> Char 171 | alexInputPrevChar (p, c, bs, s) = c 172 | 173 | -- | Encode a Haskell String to a list of Word8 values, in UTF8 format. 174 | utf8Encode :: Char -> [Word8] 175 | utf8Encode = map fromIntegral . go . ord 176 | where 177 | go oc 178 | | oc <= 0x7f = [oc] 179 | 180 | | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6) 181 | , 0x80 + oc Data.Bits..&. 0x3f 182 | ] 183 | 184 | | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12) 185 | , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) 186 | , 0x80 + oc Data.Bits..&. 0x3f 187 | ] 188 | | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18) 189 | , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f) 190 | , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f) 191 | , 0x80 + oc Data.Bits..&. 0x3f 192 | ] 193 | } 194 | -------------------------------------------------------------------------------- /MainCTT.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import System.IO ( hFlush, stdout ) 4 | import System.Environment ( getArgs ) 5 | import System.Exit ( exitSuccess ) 6 | import Control.Monad.State 7 | import Data.List ( intercalate ) 8 | import Data.Maybe ( isJust ) 9 | 10 | import ParCTT ( pTerm, pToplevel, pProgram, myLexer ) 11 | 12 | import Ident 13 | import Interval 14 | import CoreCTT 15 | import Eval 16 | import TypeChecker 17 | 18 | type Err = Either String 19 | 20 | -- Current context, last term checked, list of locked names 21 | type ReplState = (Ctx,Term,[Ident]) 22 | 23 | -- Initial state 24 | initReplState :: ReplState 25 | initReplState = ([],Zero,[]) 26 | 27 | -- Read from a file and call `run` 28 | runFile :: FilePath -> StateT ReplState IO Bool 29 | runFile f = do 30 | printLnIO $ "Reading file " ++ f 31 | contents <- liftIO . readFile $ f 32 | res <- run contents 33 | liftIO . when res . putStrLn $ "\nFile " ++ f ++ " loaded successfully" 34 | return res 35 | 36 | -- Parse and call `checkProgram` 37 | run :: String -> StateT ReplState IO Bool 38 | run s = case pProgram ts of 39 | Left err -> do 40 | liftIO $ putStrLn "\nParse failed!" 41 | liftIO $ showErr err 42 | return False 43 | Right program -> do 44 | checkProgram program 45 | where 46 | ts = myLexer s 47 | 48 | -- Check a whole program, by type-checking every top-level 49 | -- declaration 50 | checkProgram :: Program -> StateT ReplState IO Bool 51 | checkProgram (Program []) = return True 52 | checkProgram (Program (toplevel : decls)) = do 53 | res <- checkSingleToplevel toplevel 54 | if res then 55 | checkProgram (Program decls) 56 | else 57 | return False 58 | 59 | -- Check if a term contains undeclared variables (True = OK) 60 | checkVars :: Ctx -> Term -> Bool 61 | checkVars ctx term = case term of 62 | Var s -> isJust $ lookup s ctx 63 | Universe -> True 64 | Abst s t e -> checkVars ctx t && 65 | checkVars (extend ctx s (Decl {-dummy-}Universe)) e 66 | TDef (s,t,e) t' -> checkVars ctx t && 67 | checkVars (extend ctx s (Decl {-dummy-}Universe)) e && 68 | checkVars (extend ctx s (Def t e)) t' 69 | App fun arg -> checkVars ctx fun && checkVars ctx arg 70 | Sigma s t e -> checkVars ctx t && 71 | checkVars (extend ctx s (Decl {-dummy-}Universe)) e 72 | Pair t1 t2 -> checkVars ctx t1 && checkVars ctx t2 73 | Fst t -> checkVars ctx t 74 | Snd t -> checkVars ctx t 75 | Sum ty1 ty2 -> checkVars ctx ty1 && checkVars ctx ty2 76 | InL t1 -> checkVars ctx t1 77 | InR t2 -> checkVars ctx t2 78 | Split ty f1 f2 x -> checkVars ctx ty && checkVars ctx f1 && 79 | checkVars ctx f2 && checkVars ctx x 80 | Nat -> True 81 | Zero -> True 82 | Succ t -> checkVars ctx t 83 | Ind ty b s n -> checkVars ctx ty && checkVars ctx b && 84 | checkVars ctx s && checkVars ctx n 85 | I -> True 86 | I0 -> True 87 | I1 -> True 88 | Sys sys -> all (\phi -> all (`elem` keys ctx) (vars phi)) 89 | (keys sys) && all (checkVars ctx) (elems sys) 90 | Partial phi t -> all (`elem` keys ctx) (vars phi) && 91 | checkVars ctx t 92 | Restr sys t -> checkVars ctx (Sys sys) && checkVars ctx t 93 | Comp fam phi i0 u b i -> checkVars ctx fam && 94 | all (`elem` keys ctx) (vars phi) && checkVars ctx i0 && 95 | checkVars ctx u && checkVars ctx b && checkVars ctx i 96 | 97 | -- Check a single top-level declaration, calling `checkSingleToplevel'` 98 | -- Here we mostly check variables 99 | checkSingleToplevel :: Toplevel -> StateT ReplState IO Bool 100 | -- Example: infer its type 101 | checkSingleToplevel (Example t) = do 102 | (ctx,_,_) <- get 103 | if not (checkTermShadowing (keys ctx) t) then do 104 | liftIO . showErr $ "term '" ++ show t ++ "' contains shadowed variables" 105 | return False 106 | else if not (checkVars ctx t) then do 107 | liftIO . showErr $ "term '" ++ show t ++ "' contains undeclared variables" 108 | return False 109 | else 110 | checkSingleToplevel' (Example t) 111 | -- Add a declaration to the context 112 | checkSingleToplevel decl@(Declaration s t) = do 113 | (ctx,_,_) <- get 114 | if not (checkTermShadowing (keys ctx) t) then do 115 | liftIO . showErr $ "term '" ++ show t ++ "' contains shadowed variables" 116 | return False 117 | else if not (checkVars ctx t) then do 118 | liftIO . showErr $ "term '" ++ show t ++ "' contains undeclared variables" 119 | return False 120 | else case lookup s ctx of 121 | Nothing -> checkSingleToplevel' decl 122 | Just _ -> do 123 | liftIO . showErr $ "context already contains name '" ++ show s ++ "'" 124 | return False 125 | -- Add a definition to the context 126 | checkSingleToplevel def@(Definition s t e) = do 127 | (ctx,_,_) <- get 128 | if not (checkTermShadowing (s : keys ctx) t && 129 | checkTermShadowing (s : keys ctx) e) then do --avoid "x : N->N = [x:N]x" 130 | liftIO . showErr $ "definition of '" ++ show s 131 | ++ "' contains shadowed variables" 132 | return False 133 | else if not (checkVars ctx t && checkVars ctx e) then do 134 | liftIO . showErr $ "definition of '" ++ show s 135 | ++ "' contains undeclared variables" 136 | return False 137 | else case lookup s ctx of 138 | Nothing -> checkSingleToplevel' def 139 | Just _ -> do 140 | liftIO . showErr $ "context already contains name '" 141 | ++ show s ++ "'" 142 | return False 143 | 144 | 145 | checkSingleToplevel' :: Toplevel -> StateT ReplState IO Bool 146 | checkSingleToplevel' (Example t) = do 147 | -- Get the context with the locked names (i.e. erasing definitions 148 | -- of locked names) 149 | (unlockedCtx,_,lockedNames) <- get 150 | let ctx = getLockedCtx lockedNames unlockedCtx 151 | ty = inferType ctx emptyDirEnv t 152 | printLnIO $ "\nInferring type of term '" ++ show t ++ "'" 153 | case ty of 154 | Left err -> do 155 | liftIO $ showErr err 156 | return False 157 | Right tyVal -> do 158 | printLnIO $ "\n'" ++ show t ++ "' has (inferred) type '" 159 | ++ show (readBack (keys ctx) tyVal) ++ "'" 160 | -- Since `t` typechecks, `t` must have a normal form 161 | let norm = normalize ctx t 162 | printLnIO $ "'" ++ show t ++ "' reduces to '" ++ show norm ++ "'" 163 | -- Update `ans` 164 | put (ctx,t,lockedNames) 165 | return True 166 | 167 | checkSingleToplevel' (Declaration s t) = do 168 | -- Get the context with the locked names (i.e. erasing definitions 169 | -- of locked names) 170 | (unlockedCtx,_,lockedNames) <- get 171 | let ctx = getLockedCtx lockedNames unlockedCtx 172 | printLnIO $ "\nType-checking term '" ++ show s ++ "' of type '" 173 | ++ show t ++ "'" 174 | case addDecl ctx (s,t) of 175 | Left err -> do 176 | liftIO . showErr $ err 177 | return False 178 | Right ctx' -> do 179 | printLnIO "Declaration check OK!" 180 | -- Update `ans` 181 | put (ctx',t,lockedNames) 182 | return True 183 | 184 | checkSingleToplevel' (Definition s t e) = do 185 | -- Get the context with the locked names (i.e. erasing definitions 186 | -- of locked names) 187 | (unlockedCtx,_,lockedNames) <- get 188 | let ctx = getLockedCtx lockedNames unlockedCtx 189 | printLnIO $ "\nType-checking term '" ++ show s ++ "' of type '" 190 | ++ show t ++ "' and body '" ++ show e ++ "'" 191 | case addDef ctx (s,t,e) of 192 | Left err -> do 193 | liftIO . showErr $ err 194 | return False 195 | Right ctx' -> do 196 | printLnIO "Type check OK!" 197 | -- Update `ans` 198 | put (ctx',e,lockedNames) 199 | return True 200 | 201 | -- Main REPL (infinite) loop 202 | doRepl :: StateT ReplState IO () 203 | doRepl = do 204 | (ctx,ans,lockedNames) <- get 205 | printIO "\n> " 206 | s <- liftIO getLine 207 | let w = words s 208 | case w of 209 | -- Quit 210 | [":q"] -> do 211 | liftIO exitSuccess 212 | -- Print last type-checked term 213 | [":ans"] -> do 214 | printLnIO $ show ans 215 | -- Show context (with locked names) 216 | [":ctx"] -> do 217 | liftIO . printCtxLn $ getLockedCtx lockedNames ctx 218 | {-- TODO 219 | [":head"] -> do 220 | let ans' = headRed ctx ans 221 | printLnIO $ show ans' 222 | put (ctx,ans',lockedNames) 223 | ":head" : sterm -> do 224 | case pTerm (myLexer (unwords sterm)) of 225 | Left err -> 226 | printLnIO $ "could not parse term: " ++ err 227 | Right term -> do 228 | let ans' = headRed ctx term 229 | printLnIO $ show ans' 230 | put (ctx,ans',lockedNames) 231 | -} 232 | -- Delete from context the given names (and also the ones 233 | -- that depend on them) 234 | ":clear" : idents -> do 235 | let ctx' = foldl removeFromCtx ctx (map Ident idents) 236 | put (ctx',ans,lockedNames) 237 | -- Lock a list of identiers 238 | ":lock" : idents -> do 239 | let idents' = map Ident idents 240 | isInCtx = (`elem` (keys ctx)) 241 | identsToAdd = filter isInCtx idents' 242 | identsWrong = filter (not . isInCtx) idents' 243 | when (length identsWrong > 0) $ 244 | printLnIO $ "identifier(s) " ++ intercalate ", " (map show identsWrong) 245 | ++ " not found in the current context" 246 | let lockedNames' = identsToAdd ++ lockedNames 247 | put (ctx,ans,lockedNames') 248 | -- Unlock a list of identiers 249 | ":unlock" : idents -> do 250 | let lockedNames' = filter (`notElem` map Ident idents) lockedNames 251 | put (ctx,ans,lockedNames') 252 | -- Clear the list of locked identiers 253 | [":unlockall"] -> 254 | put (ctx,ans,[]) 255 | -- Show the locked identifiers 256 | [":printlock"] -> 257 | printLnIO $ "Locked names are: " ++ intercalate ", " (map show lockedNames) 258 | -- Show help menu 259 | [":help"] -> do 260 | liftIO printUsage 261 | -- Unknown command 262 | (':' : _ ) : _ -> 263 | printLnIO "Command not found. Type :help" 264 | -- Otherwise, check a new declaration 265 | otherwise -> do 266 | let ts = myLexer s 267 | case pToplevel ts of 268 | Left err -> do 269 | printLnIO "\nParse failed!" 270 | liftIO . showErr $ err 271 | Right toplevel -> do 272 | _ <- checkSingleToplevel toplevel 273 | return () 274 | doRepl -- Repeat 275 | 276 | -- Add a definition to the current context 277 | addDef :: Ctx -> (Ident,Term,Term) -> Either ErrorString Ctx 278 | addDef ctx (s,t,e) = do 279 | checkType ctx emptyDirEnv t Universe -- Check that `t` is a type 280 | let tVal = eval ctx t 281 | checkType ctx emptyDirEnv e tVal -- Check that `e` has type `t` 282 | Right $ extend ctx s (Def t e) 283 | 284 | -- Add a definition to the current context 285 | addDecl :: Ctx -> (Ident,Term) -> Either ErrorString Ctx 286 | addDecl ctx (s,t) = do 287 | -- Check that `t` is a type or the interval 288 | unless (t == I) $ checkType ctx emptyDirEnv t Universe 289 | Right $ extend ctx s (Decl t) 290 | 291 | -- Lock each given identifier in the context, 292 | -- i.e. erase its eventual definition from the context 293 | getLockedCtx :: [Ident] -> Ctx -> Ctx 294 | getLockedCtx idents ctx0 = foldr getLockedCtx' ctx0 idents 295 | where 296 | getLockedCtx' :: Ident -> Ctx -> Ctx 297 | getLockedCtx' s ((s',Def ty def) : ctx) = 298 | if s == s' then (s,Decl ty) : ctx 299 | else (s',Def ty def) : getLockedCtx' s ctx 300 | getLockedCtx' s ((s',Decl ty) : ctx) = 301 | (s',Decl ty) : getLockedCtx' s ctx 302 | getLockedCtx' _ ctx = ctx 303 | 304 | -- Print the context, line by line 305 | printCtxLn :: Ctx -> IO () 306 | printCtxLn ctx = mapM_ (putStrLn . showEntry) (reverse ctx) 307 | 308 | -- Print an error 309 | showErr :: String -> IO () 310 | showErr err = putStrLn $ "\nError: " ++ err 311 | 312 | main :: IO () 313 | main = do 314 | printUsage 315 | args <- getArgs 316 | case args of 317 | -- No files given: start the REPL loop 318 | [] -> do 319 | evalStateT doRepl initReplState 320 | exitSuccess 321 | -- Some files given: parse each file, then start the REPL loop 322 | fs -> evalStateT ( 323 | do 324 | -- `b` is the result of the type-check of each file 325 | res <- foldM (\b fp -> (b &&) <$> runFile fp) True fs 326 | liftIO $ unless res exitSuccess 327 | (ctx,_,_) <- get 328 | printLnIO "\nCurrent context is:" 329 | liftIO . printCtxLn $ ctx 330 | doRepl 331 | ) initReplState 332 | 333 | -- Print help menu 334 | printUsage :: IO () 335 | printUsage = do 336 | putStr $ unlines 337 | [ " -------------------------------------------------------------------------- " 338 | , "| Usage: ./CTT .. load and type-check files |" 339 | , "| then start a REPL |" 340 | , "| Commands: |" 341 | , "| x : add declaration of 'x' to the context |" 342 | , "| x : = add definition of 'x' to the context |" 343 | , "| infer type of t and normalize it |" 344 | , "| :help print help |" 345 | , "| :q quit |" 346 | , "| :ans print the last term used |" 347 | -- , "| :head apply head reduction to the last term used |" 348 | -- , "| :head apply head reduction to (NOT type-checked)|" 349 | , "| :ctx print current context |" 350 | , "| :clear .. remove 's from context (recursively) |" 351 | , "| :lock .. lock 's definition |" 352 | , "| :unlock .. unlock 's definition |" 353 | , "| :unlockall unlock every currently locked definition |" 354 | , "| :printlock print locked definitions |" 355 | , " -------------------------------------------------------------------------- " 356 | ] 357 | hFlush stdout 358 | 359 | -- Auxiliary printing functions 360 | printIO :: String -> StateT ReplState IO () 361 | printIO s = liftIO $ do 362 | putStr s 363 | hFlush stdout 364 | 365 | printLnIO :: String -> StateT ReplState IO () 366 | printLnIO s = printIO $ s ++ "\n" 367 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # Makefile generated by BNFC. 2 | 3 | GHC = ghc 4 | GHC_OPTS = -package mtl -O3 -o CTT #-Wall 5 | HAPPY = happy 6 | HAPPY_OPTS = --array --info --ghc --coerce 7 | ALEX = alex 8 | ALEX_OPTS = --ghc 9 | 10 | 11 | 12 | # List of goals not corresponding to file names. 13 | 14 | .PHONY : all clean distclean 15 | 16 | # Default goal. 17 | 18 | all : MainCTT 19 | 20 | %.hs : %.y 21 | ${HAPPY} ${HAPPY_OPTS} $< 22 | 23 | %.hs : %.x 24 | ${ALEX} ${ALEX_OPTS} $< 25 | 26 | MainCTT : CoreCTT.hs LexCTT.hs ParCTT.hs MainCTT.hs TypeChecker.hs Eval.hs Interval.hs Ident.hs 27 | ${GHC} ${GHC_OPTS} $@ 28 | 29 | # Rules for cleaning generated files. 30 | 31 | clean : 32 | -rm -f *.hi *.o *.log *.aux *.dvi CTT 33 | 34 | distclean : clean 35 | -rm -f CoreCTT.hs CoreCTT.hs.bak ComposOp.hs ComposOp.hs.bak DocCTT.txt DocCTT.txt.bak ErrM.hs ErrM.hs.bak LayoutCTT.hs LayoutCTT.hs.bak LexCTT.x LexCTT.x.bak ParCTT.y ParCTT.y.bak PrintCTT.hs PrintCTT.hs.bak SkelCTT.hs SkelCTT.hs.bak MainCTT.hs MainCTT.hs.bak XMLCTT.hs XMLCTT.hs.bak ASTCTT.agda ASTCTT.agda.bak ParserCTT.agda ParserCTT.agda.bak IOLib.agda IOLib.agda.bak Main.agda Main.agda.bak CTT.dtd CTT.dtd.bak CTT LexCTT.hs ParCTT.hs ParCTT.info ParDataCTT.hs Makefile 36 | 37 | 38 | # EOF 39 | -------------------------------------------------------------------------------- /ParCTT.y: -------------------------------------------------------------------------------- 1 | { 2 | module ParCTT ( happyError, myLexer, pProgram,pToplevel, pTerm ) 3 | where 4 | 5 | import Prelude 6 | import qualified Data.Map as Map 7 | 8 | import Ident 9 | import qualified CoreCTT 10 | import Interval 11 | import LexCTT 12 | } 13 | 14 | %name pProgram Program 15 | %name pToplevel Toplevel 16 | %name pTerm Term 17 | %monad { Err } { (>>=) } { return } 18 | %tokentype {Token} 19 | %token 20 | '(' { PT _ (TS _ 1) } 21 | ')' { PT _ (TS _ 2) } 22 | '*' { PT _ (TS _ 3) } 23 | '+' { PT _ (TS _ 4) } 24 | ',' { PT _ (TS _ 5) } 25 | '->' { PT _ (TS _ 6) } 26 | '.1' { PT _ (TS _ 7) } 27 | '.2' { PT _ (TS _ 8) } 28 | '/\\' { PT _ (TS _ 9) } 29 | '0' { PT _ (TS _ 10) } 30 | '1' { PT _ (TS _ 11) } 31 | ':' { PT _ (TS _ 12) } 32 | ';' { PT _ (TS _ 13) } 33 | '<' { PT _ (TS _ 14) } 34 | '=' { PT _ (TS _ 15) } 35 | '>' { PT _ (TS _ 16) } 36 | 'I' { PT _ (TS _ 17) } 37 | 'N' { PT _ (TS _ 18) } 38 | 'S' { PT _ (TS _ 19) } 39 | 'U' { PT _ (TS _ 20) } 40 | 'Z' { PT _ (TS _ 21) } 41 | '[' { PT _ (TS _ 22) } 42 | '\\/' { PT _ (TS _ 23) } 43 | ']' { PT _ (TS _ 24) } 44 | 'comp' { PT _ (TS _ 25) } 45 | 'ind' { PT _ (TS _ 26) } 46 | 'inl' { PT _ (TS _ 27) } 47 | 'inr' { PT _ (TS _ 28) } 48 | 'split' { PT _ (TS _ 29) } 49 | '|' { PT _ (TS _ 30) } 50 | L_Ident { PT _ (TV $$) } 51 | 52 | %% 53 | 54 | Ident :: { Ident } 55 | Ident : L_Ident { Ident $1 } 56 | 57 | ListIdent :: { [Ident] } 58 | ListIdent : Ident { [$1] } 59 | | Ident ',' ListIdent { (:) $1 $3 } 60 | 61 | Program :: { CoreCTT.Program } 62 | Program : ListToplevel { CoreCTT.Program $1 } 63 | 64 | Term :: { CoreCTT.Term } 65 | Term : Term1 '->' Term { CoreCTT.Abst (Ident "") $1 $3 } 66 | | '[' Ident ':' Term '=' Term ']' Term { CoreCTT.TDef ($2,$4,$6) $8 } 67 | | '[' Ident ':' Term ']' Term { CoreCTT.Abst $2 $4 $6 } 68 | | '[' ListIdent ':' Term ']' Term 69 | { foldr (\i e -> CoreCTT.Abst i $4 e) $6 $2 } 70 | | Term1 { $1 } 71 | 72 | Term1 :: { CoreCTT.Term } 73 | Term1 : Term2 '+' Term1 { CoreCTT.Sum $1 $3 } 74 | | Term2 '*' Term1 { CoreCTT.Sigma (Ident "") $1 $3 } 75 | | '<' ListIdent ':' Term '>' Term 76 | { foldr (\i e -> CoreCTT.Sigma i $4 e) $6 $2 } 77 | | '[' DisjFormula ']' Term1 { CoreCTT.Partial $2 $4 } 78 | | System Term1 { CoreCTT.Restr $1 $2 } 79 | | Term2 ',' Term2 { CoreCTT.Pair $1 $3 } 80 | | Term2 { $1 } 81 | 82 | Term2 :: { CoreCTT.Term } 83 | Term2 : Term2 Term3 { CoreCTT.App $1 $2 } 84 | | 'ind' Term3 Term3 Term3 Term3 { CoreCTT.Ind $2 $3 $4 $5 } 85 | | 'comp' Term3 '(' DisjFormula ')' Term3 Term3 Term3 Term3 86 | { CoreCTT.Comp $2 $4 $6 $7 $8 $9 } 87 | | 'comp' Term3 '(' ')' Term3 Term3 Term3 Term3 88 | { CoreCTT.Comp $2 fFalse $5 $6 $7 $8 } 89 | | 'S' Term3 { CoreCTT.Succ $2 } 90 | | 'inl' Term3 { CoreCTT.InL $2 } 91 | | 'inr' Term3 { CoreCTT.InR $2 } 92 | | 'split' Term3 Term3 Term3 Term3 { CoreCTT.Split $2 $3 $4 $5 } 93 | | Term3 { $1 } 94 | 95 | Term3 :: { CoreCTT.Term } 96 | Term3 : Ident { CoreCTT.Var $1 } 97 | | 'U' { CoreCTT.Universe } 98 | | 'N' { CoreCTT.Nat } 99 | | 'Z' { CoreCTT.Zero } 100 | | 'I' { CoreCTT.I } 101 | | Term3 '.1' { CoreCTT.Fst $1 } 102 | | Term3 '.2' { CoreCTT.Snd $1 } 103 | | System { CoreCTT.Sys $1 } 104 | | '0' { CoreCTT.I0 } 105 | | '1' { CoreCTT.I1 } 106 | | '(' Term ')' { $2 } 107 | 108 | 109 | Toplevel :: { CoreCTT.Toplevel } 110 | Toplevel : Ident ':' Term '=' Term { CoreCTT.Definition $1 $3 $5 } 111 | | Ident ':' Term { CoreCTT.Declaration $1 $3 } 112 | | Term { CoreCTT.Example $1 } 113 | 114 | ListToplevel :: { [CoreCTT.Toplevel] } 115 | ListToplevel : {- empty -} { [] } 116 | | Toplevel ';' ListToplevel { (:) $1 $3 } 117 | 118 | 119 | AtomicFormula :: { AtomicFormula } 120 | AtomicFormula : Ident '=' '0' { Eq0 $1 } 121 | | Ident '=' '1' { Eq1 $1 } 122 | | Ident '=' Ident { Diag $1 $3 } 123 | 124 | ConjFormula1 :: { [AtomicFormula] } 125 | ConjFormula1 : AtomicFormula { [$1] } 126 | | AtomicFormula '/\\' ConjFormula1 { $1 : $3 } 127 | 128 | ConjFormula :: { ConjFormula } 129 | ConjFormula : ConjFormula1 { Conj $1 } 130 | | '(' ConjFormula ')' { $2 } 131 | 132 | DisjFormula1 :: { [ConjFormula] } 133 | DisjFormula1 : ConjFormula { [$1] } 134 | | ConjFormula '\\/' DisjFormula1 { $1 : $3 } 135 | 136 | DisjFormula :: { DisjFormula } 137 | DisjFormula : DisjFormula1 { Disj $1 } 138 | 139 | System :: { CoreCTT.System } 140 | System : '[' ListSysElem ']' { $2 } 141 | 142 | SysElem :: { (ConjFormula,CoreCTT.Term) } 143 | SysElem : ConjFormula '->' Term { ($1,$3) } 144 | 145 | ListSysElem :: { [(ConjFormula,CoreCTT.Term)] } 146 | ListSysElem : {- empty -} { [] } 147 | | SysElem { [$1] } 148 | | SysElem '|' ListSysElem { $1 : $3 } 149 | 150 | { 151 | type Err = Either String 152 | 153 | happyError :: [Token] -> Err a 154 | happyError ts = Left $ 155 | "syntax error at " ++ tokenPos ts ++ 156 | case ts of 157 | [] -> [] 158 | [Err _] -> " due to lexer error" 159 | t:_ -> " before `" ++ (prToken t) ++ "'" 160 | 161 | myLexer :: String -> [Token] 162 | myLexer = tokens 163 | } -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Haskell implementation of Cubical Type Theory 2 | 3 | ## Compile 4 | 5 | `make` 6 | 7 | ## Usage 8 | 9 | `./CTT file1.ctt file2.ctt ... fileN.ctt` 10 | 11 | The program loads and type-checks the files, then it starts a REPL. 12 | 13 | Type `:help` to show usage. 14 | -------------------------------------------------------------------------------- /TypeChecker.hs: -------------------------------------------------------------------------------- 1 | module TypeChecker where 2 | 3 | import Control.Monad 4 | 5 | import Ident 6 | import Interval 7 | import CoreCTT 8 | import Eval 9 | import Conv 10 | 11 | -- Infer the type of a term, in the given context and directions environment 12 | inferType :: Ctx -> DirEnv -> Term -> Either ErrorString Value 13 | inferType ctx dirs term = myTrace ("[inferType] " ++ show term ++ ", ctx = " ++ showCtx ctx ++ ", dirs = " ++ show dirs) $ case term of 14 | -- Variables: look up the type in the context 15 | Var s -> Right $ lookupType s ctx 16 | -- Universe 17 | Universe -> Right Universe 18 | -- Function application: the type of the function is inferred 19 | App fun arg -> do 20 | funTy <- inferType ctx dirs fun 21 | -- Handle restriction and partial types: `box` is used 22 | -- to put the resulting type in the eventual restriction 23 | -- or partial type 24 | let (funTy',box) = case funTy of 25 | Restr sys v -> (v,makeRestr sys) 26 | Partial phi v -> (v,makePartial phi) 27 | otherwise -> (funTy,curry snd) 28 | makeRestr :: System -> Value -> Value -> Value 29 | makeRestr sys val = foldRestr $ mapSys (`doApply` val) sys 30 | makePartial :: DisjFormula -> Value -> Value -> Value 31 | makePartial phi _ = foldPartial phi 32 | -- The type must be a ∏-type 33 | case funTy' of 34 | c@(Closure (Abst _ t _) ctx1) -> do 35 | checkType ctx dirs arg (eval ctx1 t) 36 | let argVal = eval ctx arg 37 | return $ box argVal (doApply c argVal) 38 | otherwise -> Left $ 39 | "term '" ++ show fun ++ "' has type '" ++ show funTy 40 | ++"' , which is not a product" 41 | -- First projection: the type of the argument is inferred 42 | Fst p -> do 43 | ty <- inferType ctx dirs p 44 | 45 | -- Handle restriction and partial types 46 | let (ty',box) = case ty of 47 | Restr sys t -> (t,makeRestr sys) 48 | Partial phi v -> (v,foldPartial phi) 49 | otherwise -> (ty,id) 50 | makeRestr :: System -> Value -> Value 51 | makeRestr = foldRestr . mapSys doFst 52 | -- The type must be a ∑-type 53 | case ty' of 54 | Closure (Sigma _ t _) ctx1 -> do 55 | return $ box (eval ctx1 t) 56 | otherwise -> Left $ 57 | "term '" ++ show term ++ "' has type '" ++ show ty 58 | ++ "' , which is not a sum" 59 | -- Second projection: the type of the argument is inferred 60 | Snd p -> do 61 | ty <- inferType ctx dirs p 62 | 63 | --Handle restriction and partial types 64 | let (ty',box) = case ty of 65 | Restr sys t -> (t,makeRestr sys) 66 | Partial phi v -> (v,foldPartial phi) 67 | otherwise -> (ty,id) 68 | makeRestr :: System -> Value -> Value 69 | makeRestr = foldRestr . mapSys doSnd 70 | -- The type must be a ∑-type 71 | case ty' of 72 | c@(Closure Sigma{} ctx1) -> do 73 | return . box $ evalClosure c (doFst $ eval ctx p) 74 | otherwise -> Left $ 75 | "term '" ++ show term ++ "' has type '" ++ show ty 76 | ++ "' , which is not a sum" 77 | 78 | -- Coproduct eliminator: the type of the argument is inferred 79 | Split fam f1 f2 x -> do 80 | ty <- inferType ctx dirs x 81 | 82 | --Handle restriction and partial types 83 | let (ty',box) = case ty of 84 | Restr sys t -> (t,makeRestr sys) 85 | Partial phi v -> (v,foldPartial phi) 86 | otherwise -> (ty,id) 87 | famV = eval ctx fam 88 | makeRestr :: System -> Value -> Value 89 | makeRestr = foldRestr . mapSys 90 | (doSplit famV (eval ctx f1) (eval ctx f2)) 91 | -- The type must be a coproduct 92 | case ty' of 93 | Sum{} -> do 94 | let sty@(Sum sty1 sty2) = readBack (keys ctx) ty' 95 | var = newVar (keys ctx) (Ident "a") 96 | checkType ctx dirs fam 97 | (Closure (Abst (Ident "_") sty Universe) ctx) 98 | checkType ctx dirs f1 99 | (eval ctx $ Abst var sty1 (App fam (InL (Var var)))) 100 | checkType ctx dirs f2 101 | (eval ctx $ Abst var sty2 (App fam (InR (Var var)))) 102 | return . box $ eval ctx (App fam x) 103 | otherwise -> Left $ "expected a sum type, got term '" ++ show x 104 | ++ "' of type '" ++ show ty ++ "' instead" 105 | -- Naturals 106 | Nat -> Right Universe 107 | Zero -> Right Nat 108 | Succ n -> do 109 | checkType ctx dirs n Nat 110 | Right Nat 111 | -- Induction for naturals 112 | Ind fam base step n -> do 113 | -- Check that `n` is a natural (eventually partial/restricted) 114 | nTyVal <- inferType ctx dirs n 115 | isNat n nTyVal 116 | -- Check that `fam` has type N -> U 117 | checkType ctx dirs fam (makeFunTypeVal Nat Universe) 118 | 119 | -- Handle restriction and partial types 120 | let box = case nTyVal of 121 | Restr sys Nat -> makeRestr sys 122 | Partial phi _ -> foldPartial phi 123 | Nat -> id 124 | famV = eval ctx fam 125 | makeRestr :: System -> Value -> Value 126 | makeRestr = foldRestr . mapSys 127 | (doInd famV (eval ctx base) (eval ctx step)) 128 | 129 | -- Evaluate the type-family `fam`, checking that `base` has 130 | -- type `fam Z` 131 | let tyVal = eval ctx fam 132 | tyVal0 = doApply tyVal Zero 133 | checkType ctx dirs base tyVal0 134 | 135 | -- Checking that the "inductive step" `step` has type 136 | -- [n : nat] fam n -> fam (suc n) 137 | let varname = newVar (keys ctx) (Ident "n") 138 | var = Var varname 139 | ctx' = extend ctx varname (Decl Nat) 140 | checkType ctx dirs step (eval ctx' 141 | (Abst varname Nat 142 | (Abst (Ident "") (App fam var) 143 | (App fam (Succ var))) 144 | )) -- [n : nat] fam n -> fam (suc n) 145 | 146 | return . box $ doApply tyVal (eval ctx n) 147 | -- Interval endpoints 148 | I0 -> Right I 149 | I1 -> Right I 150 | -- Composition 151 | Comp fam phi@(Disj df) i0 u b i -> do 152 | -- Fresh variable for `ctx` 153 | let var = newVar (keys ctx) (Ident "_i") 154 | -- Checking the type-family `fam`, point `i_0` and formula `phi` 155 | checkType ctx dirs fam (makeFunTypeVal I Universe) -- I -> U 156 | checkType ctx dirs i0 I 157 | checkDisjFormula ctx phi 158 | -- Checking that `u` has the correct type 159 | checkType ctx dirs u (eval ctx 160 | (Abst var I (Partial phi (App fam (Var var))))) 161 | -- Checking that `b` has type `[phi -> u i0](fam i0)` 162 | checkType ctx dirs b $ 163 | eval ctx (Restr (map (\psi -> (psi,App u i0)) df) (App fam i0)) 164 | -- Return the evaluated type, without the restriction if it's empty 165 | let sys = getCompSys phi i0 u b i 166 | return $ eval ctx $ (if null sys then id else Restr sys) (App fam i) 167 | 168 | -- Failed type inference 169 | _ -> Left $ "don't know how to infer type of '" ++ show term ++ "'" 170 | 171 | -- Check if a term has Nat type 172 | isNat :: Term -> Value -> Either ErrorString () 173 | isNat _ Nat = Right () 174 | isNat _ (Restr _ Nat) = Right () 175 | isNat _ (Partial _ Nat) = Right () 176 | isNat t v = Left $ "expected type nat, got term '" ++ show t ++ 177 | "' of type '" ++ show v ++ "' instead" 178 | 179 | -- Utility function to get type values of the form A -> B 180 | makeFunTypeVal :: Term -> Term -> Value 181 | makeFunTypeVal ty e = eval emptyCtx (Abst (Ident "") ty e) 182 | 183 | -- Check the type of a term under a conjunction 184 | -- If the conjunction is false, type-check is trivially true 185 | checkTypePartialConj :: ConjFormula -> Ctx -> DirEnv -> Term -> Value -> Either ErrorString () 186 | --checkTypePartialConj conj ctx dirs e v = myTrace ("[checkTypePartialConj] conj = " ++ show conj ++ ", dirs' = " ++ show (addConj dirs conj) ++ ", e = " ++ show e ++ ", v = " ++ show v) $ do 187 | checkTypePartialConj conj ctx dirs e v = do 188 | let dirs' = addConj dirs conj 189 | unless (inconsistent dirs') $ 190 | checkType ctx dirs' e v 191 | 192 | -- Check the type of a term under a disjunction, that is 193 | -- under each conjunction 194 | checkTypePartialDisj :: DisjFormula -> Ctx -> DirEnv -> Term -> Value -> Either ErrorString () 195 | --checkTypePartialDisj (Disj df) ctx dirs e v = myTrace ("[checkTypePartialDisj] disj = " ++ show (Disj df) ++ ", e = " ++ show e ++ ", v = " ++ show v) $ 196 | checkTypePartialDisj (Disj df) ctx dirs e v = 197 | mapM_ (\conj -> checkTypePartialConj conj ctx dirs e v) df 198 | 199 | -- Check the type of a term against a given type 200 | -- The type must be a value (i.e. in β-normal form) 201 | checkType :: Ctx -> DirEnv -> Term -> Value -> Either ErrorString () 202 | checkType ctx dirs term v = myTrace ("[checkType]<= term = " ++ show term ++ ", v = " ++ show v ++ ", ctx = " ++ showCtx ctx ++ ", dirs = " ++ show dirs) $ case (term,v) of 203 | --checkType ctx dirs term v = case (term,v) of 204 | -- Let-definition 205 | (TDef (s,t,e) t',_) -> do 206 | checkType ctx dirs t Universe 207 | checkType (extend ctx s (Decl t)) dirs e (eval ctx t) 208 | checkType (extend ctx s (Def t e)) dirs t' v 209 | -- ∏-type former 210 | (Abst s t e,Universe) -> do 211 | -- Handle also path types 212 | unless (t == I) $ checkType ctx dirs t Universe 213 | checkType (extend ctx s (Decl t)) dirs e Universe 214 | -- ∑-type former 215 | (Sigma s t e,Universe) -> do 216 | checkType ctx dirs t Universe 217 | checkType (extend ctx s (Decl t)) dirs e Universe 218 | -- λ- or ∏- abstraction 219 | (Abst s t e,Closure (Abst _ t1 _) ctx1) -> do 220 | -- Handle also I-abstractions 221 | unless (t == I) $ checkType ctx dirs t Universe 222 | let tVal = eval ctx t 223 | t1Val = eval ctx1 t1 224 | unless (conv (keys ctx) dirs tVal t1Val) $ 225 | Left $ "type '" ++ show tVal ++ "' is not convertible to type '" 226 | ++ show t1Val ++ "' (while checking term '" ++ show (Abst s t e) 227 | ++ "' against type '" ++ show v ++ "')" 228 | -- Introduce a fresh variable and check the body 229 | let var = newVar (keys ctx1) s 230 | e1Val = doApply v (Neutral (Var var) t1Val) 231 | ctx' = if s == var then 232 | extend ctx s (Decl t) 233 | else 234 | extend (extend ctx s (Decl t)) s (Val (Neutral (Var var) tVal)) 235 | checkType ctx' dirs e e1Val 236 | -- ∑-type constructor (pair) 237 | (Pair p1 p2,Closure (Sigma _ t1 _) ctx1) -> do 238 | let t1Val = eval ctx1 t1 239 | e1Val = evalClosure v (eval ctx p1) 240 | checkType ctx dirs p1 t1Val 241 | checkType ctx dirs p2 e1Val 242 | -- Coproduct type former 243 | (Sum ty1 ty2,Universe) -> do 244 | checkType ctx dirs ty1 Universe 245 | checkType ctx dirs ty2 Universe 246 | -- ∑-type left injection 247 | (InL t1,Sum ty1 _) -> do 248 | checkType ctx dirs t1 ty1 249 | -- ∑-type right injection 250 | (InR t2,Sum _ ty2) -> do 251 | checkType ctx dirs t2 ty2 252 | -- Restriction type 253 | (e,Restr sys ty) -> do 254 | let eVal = eval ctx e 255 | phi = getSystemFormula sys 256 | checkType ctx dirs e ty 257 | unless (convPartialDisj (keys ctx) phi dirs eVal (Sys sys)) $ 258 | Left $ "term '" ++ show e ++ "' does not agree with '" ++ 259 | show (Sys sys) ++ "' on " ++ show phi 260 | -- System 261 | (Sys sys,Partial phi ty) -> do 262 | let psis = keys sys 263 | mapM_ (checkConjFormula ctx) psis 264 | unless (eqFormulas dirs phi (Disj psis)) $ 265 | Left $ show phi ++ " is not logically equivalent to " 266 | ++ show (Disj psis) 267 | 268 | mapM_ (\(psi,t) -> checkTypePartialConj psi ctx dirs t ty) sys 269 | let eq_check = all (\((psi1,t1),(psi2,t2)) -> 270 | convPartialConj (keys ctx) (psi1 `meet` psi2) dirs 271 | (eval ctx t1) (eval ctx t2) 272 | ) [(x1,x2) | x1 <- sys, x2 <- sys, x1 /= x2] 273 | unless eq_check $ 274 | Left "values are not adjacent" 275 | -- Partial type former 276 | (Partial phi ty,Universe) -> do 277 | checkDisjFormula ctx phi 278 | checkType ctx dirs ty Universe 279 | -- Restriction type former 280 | (Restr sys ty,Universe) -> do 281 | checkType ctx dirs ty Universe 282 | let tyVal = eval ctx ty 283 | phi = getSystemFormula sys 284 | checkDisjFormula ctx phi 285 | -- Check the elements in the system 286 | mapM_ (\(conj,t) -> checkTypePartialConj conj ctx dirs t tyVal) sys 287 | -- If no other rule match, try inferring the type and 288 | -- check if it's compatible 289 | otherwise -> do 290 | ty <- inferType ctx dirs term 291 | -- Check for sub-typing: `v` more general than `ty` 292 | myTrace ("[checkType] inferred type of " ++ show term ++ " = " ++ show ty ++ ", ctx = " ++ showCtx ctx) $ 293 | unless (compTypes (keys ctx) dirs ty v) $ 294 | Left $ "type '" ++ show v ++ "' expected, got term '" ++ show term 295 | ++ "' of type '" ++ show ty ++ "' instead" 296 | 297 | -- Check compatibility (subtyping) between two partial or restriction types, 298 | -- as specified by the typing rules: `v1` more general than `v2` 299 | compTypes :: [Ident] -> DirEnv -> Value -> Value -> Bool 300 | compTypes used dirs v1 v2 = 301 | -- Split the type and get eventual partial type formulas 302 | -- (by default `True` in the other cases) 303 | let (iphi,ity) = split v1 304 | (vphi,vty) = split v2 305 | syscheck = case (v1,v2) of 306 | (Restr isys _,Restr vsys _) -> 307 | convPartialDisj used (getSystemFormula vsys) 308 | dirs (Sys isys) (Sys vsys) 309 | otherwise -> True 310 | -- Check sub-typing compatibility for restrictions, for the base 311 | -- types and for formulas in the case of partial types 312 | in syscheck && conv used dirs ity vty && impDisj dirs vphi iphi 313 | 314 | -- Check that the variables of the conjunctive formula are in the context 315 | checkConjFormula :: Ctx -> ConjFormula -> Either ErrorString () 316 | checkConjFormula ctx cf = do 317 | let dom = keys ctx 318 | support = vars cf 319 | unless (all (`elem` dom) support) $ 320 | Left $ "formula '" ++ show cf ++ "' contains undeclared names" 321 | 322 | -- Check that the variables of the disjunctive formula are in the context 323 | checkDisjFormula :: Ctx -> DisjFormula -> Either ErrorString () 324 | checkDisjFormula ctx (Disj df) = mapM_ (checkConjFormula ctx) df 325 | -------------------------------------------------------------------------------- /examples/comp.ctt: -------------------------------------------------------------------------------- 1 | Path : [A : U] A -> A -> U = 2 | [A : U][a0 : A][a1 : A][i : I] [(i = 0) -> a0 | (i = 1) -> a1] A ; 3 | 4 | refl : [A : U][a : A] Path A a a = [A : U][a : A][i : I] a ; 5 | 6 | const : [A:U]I -> U = [A:U][i:I]A ; 7 | 8 | concat : [A:U][a,b,c:A] Path A a b -> Path A b c -> Path A a c = 9 | [A:U][a,b,c:A][p:Path A a b][q:Path A b c] 10 | [i:I] comp (const A) (i = 0 \/ i = 1) 0 ([j:I][i = 0 -> a | i = 1 -> q j]) (p i) 1 ; 11 | 12 | concatFill : [A:U][a,b,c:A][p:Path A a b][q:Path A b c][i,j:I][j = 0 -> p i | i = 0 -> a | i = 1 -> q j]A = 13 | [A:U][a,b,c:A][p:Path A a b][q:Path A b c] 14 | [i,j:I] comp (const A) (i = 0 \/ i = 1) 0 ([j':I][i = 0 -> a | i = 1 -> q j']) (p i) j ; 15 | 16 | inv : [A:U][a,b:A] Path A a b -> Path A b a = [A:U][a,b:A][p:Path A a b] 17 | [i:I] (comp (const A) (i = 0 \/ i = 1) 0 ([j:I][i = 0 -> p j | i = 1 -> a]) a 1) ; 18 | 19 | invFill : [A:U][a,b:A][p:Path A a b][i,j:I][j = 0 -> a | i = 0 -> p j | i = 1 -> a]A = [A:U][a,b:A][p:Path A a b] 20 | [i,j:I] comp (const A) (i = 0 \/ i = 1) 0 ([j':I][i = 0 -> p j' | i = 1 -> a]) a j ; 21 | 22 | invFillrc : [A:U][a,b:A][p:Path A a b][k,i:I][k = 0 -> p i | k = 1 -> a | i = 0 -> a]A = [A:U][a,b:A][p:Path A a b] 23 | [k,i:I] comp (const A) (k = 0 \/ k = 1) 0 ([i':I][k = 0 -> p i' | k = 1 -> a]) a i ; 24 | 25 | 26 | rc : [A:U][a,b:A][p:Path A a b] Path (Path A a a) 27 | (concat A a b a p (inv A a b p)) (refl A a) = 28 | [A:U][a,b:A][p:Path A a b][j,i:I] comp (I -> A) (i = 0 \/ i = 1 \/ j = 0 \/ j = 1) 0 29 | ([k : I][i = 0 -> a | 30 | i = 1 -> inv A a b p k | 31 | j = 0 -> concatFill A a b a p (inv A a b p) i k | 32 | j = 1 -> invFillrc A a b p k i]) (p i) 1 ; 33 | 34 | 35 | xx : [A:U][a,b:A][p:Path A a b][i:I] Path A a (inv A a b p i) ; 36 | 37 | A : U ; 38 | a : A ; 39 | b : A ; 40 | --c : A ; 41 | p : Path A a b ; 42 | --q : Path A b c ; 43 | 44 | {- 45 | 46 | fill : [i,j:I][j = 0 -> p i | i = 0 -> a | i = 1 -> q j]A = 47 | [i:I] comp (const A) (i = 0 \/ i = 1) 0 ([j:I][i = 0 -> a | i = 1 -> q j]) (p i); 48 | 49 | -- fill 0 : [j:I][True -> a]A = [j:I]a ; 50 | -- fill 1 : [j:I][True -> q j]A = [j:I] q j = q ; 51 | -- [i:I] fill i 0 : [i:I][True -> p i]A = p ; 52 | -- [i:I] fill i 1 : [i:I][i = 0 -> a | i = 1 -> c]A ; 53 | 54 | comppq : Path A a c = [i:I] fill i 1; 55 | 56 | a0 : N ; 57 | 58 | compTest : I -> N = comp (I -> N) () 0 (I -> []) a0 ; 59 | --compTest' : [i:I][i = 0 -> a0]N = comp (I -> N) 0 [] a0 ; 60 | 61 | 62 | ap : [B:U][C:U][f:B->C][b1:B][b2:B] Path B b1 b2 -> Path C (f b1) (f b2) = 63 | [B:U][C:U][f:B->C][b1:B][b2:B][pB : Path B b1 b2][i:I] f (pB i) ; 64 | 65 | -} 66 | 67 | {- 68 | y : [i,j:I][i = 0 /\ j = 0 \/ i = 1 /\ j = j /\ j = i]N ; 69 | yy : [i,j:I][i = 0 /\ j = 0 -> S Z | i = 1 /\ j = j /\ j = i -> S (S Z)]N ; 70 | y' : [i,j:I][(i = 1 /\ j = j /\ j = i)]N ; 71 | -} 72 | 73 | {- 74 | B : U ; 75 | bV : B ; 76 | f : [i:I]B -> [i = 0 -> a | i = 1 -> b]A ; 77 | pred : ([i:I]B -> [i = 0 \/ i = 1]A) -> U ; 78 | predf : pred f ; 79 | 80 | fTest' : [i:I][i = 0 -> f1 i bV]A = [i : I] f2 i bV ; 81 | -} 82 | 83 | {- 84 | transport' : [B : U][P : B -> U][x : B][y : B][pB : Path B x y][u : P x][i:I][i = 0 -> u]P (pB i) = 85 | [B : U][P : B -> U][x : B][y : B][pB : Path B x y][u : P x] 86 | comp ([i : I]P (pB i)) () 0 (I -> []) u ; 87 | -} 88 | 89 | transport : [B : U][P : B -> U][x : B][y : B][pB : Path B x y] P x -> P y = 90 | [B : U][P : B -> U][x : B][y : B][pB : Path B x y][u : P x] 91 | comp ([i : I]P (pB i)) () 0 (I -> []) u 1; 92 | 93 | transp : [F : I -> U] F 0 -> F 1 = [F : I -> U][a0 : F 0] 94 | comp F () 0 (I -> []) a0 1 ; 95 | 96 | 97 | transport'' : [B : U][P : B -> U][x : B][y : B][pB : Path B x y] P x -> P y = 98 | [B : U][P : B -> U][x : B][y : B][pB : Path B x y][u : P x] 99 | transp ([i : I] P (pB i)) u ; 100 | 101 | B : I -> U ; 102 | b0 : B 0 ; 103 | transpCoupleEx : A * B 1 = transp ([i:I] A * B i) (a,b0) ; 104 | 105 | -------------------------------------------------------------------------------- /examples/comp2.ctt: -------------------------------------------------------------------------------- 1 | Path : [A : U] A -> A -> U = 2 | [A : U][a0 : A][a1 : A][i : I] [(i = 0) -> a0 | (i = 1) -> a1] A ; 3 | 4 | PathD : [A : I -> U] A 0 -> A 1 -> U = 5 | [A : I -> U][a0 : A 0][a1 : A 1][i : I] [(i = 0) -> a0 | (i = 1) -> a1] A i ; 6 | 7 | refl : [A : U][a : A] Path A a a = [A : U][a : A][i : I] a ; 8 | 9 | reflD : [A : U][a : A] PathD (I -> A) a a = [A : U][a : A][i : I] a ; 10 | 11 | concat : [A:U][a,b,c:A] Path A a b -> Path A b c -> Path A a c = 12 | [A:U][a,b,c:A][p:Path A a b][q:Path A b c] 13 | [i:I] comp (I -> A) (i = 0 \/ i = 1) 0 ([j:I][i = 0 -> a | i = 1 -> q j]) (p i) 1 ; 14 | 15 | concatFill : [A:U][a,b,c:A][p:Path A a b][q:Path A b c][i,j:I][j = 0 -> p i | i = 0 -> a | i = 1 -> q j]A 16 | = [A:U][a,b,c:A][p:Path A a b][q:Path A b c] 17 | [i,j:I] comp (I -> A) (i = 0 \/ i = 1) 0 ([j':I][i = 0 -> a | i = 1 -> q j']) (p i) j ; 18 | 19 | {- 20 | weakMeet' : [A:U][a,b:A][p:Path A a b][i,j:I][j = 0 -> a | i = 0 -> a | i = 1 -> p j]A 21 | = [A:U][a,b:A][p:Path A a b][i,j:I] comp (I -> A) (i = 0 \/ i = 1) 0 ([j':I][i = 0 -> a | i = 1 -> p j']) a j; 22 | 23 | weakMeet : [A:U][a,b:A][p:Path A a b][i,k:I][i = 0 -> a | i = 1 -> p k | k = 0 -> a | k = 1 -> p i]A 24 | = [A:U][a,b:A][p:Path A a b][i:I][k:I] comp (I -> A) (i = 0 \/ i = 1 \/ k = 0 \/ k = 1) 0 25 | ([j:I] 26 | [ i = 0 -> a | 27 | i = 1 -> weakMeet' A a b p j k | 28 | k = 0 -> a | 29 | k = 1 -> weakMeet' A a b p j i 30 | ]) a 1 ; 31 | -} 32 | 33 | weakMeet : [A:U][a,b:A][p:Path A a b][i,k:I][i = 0 -> a | i = 1 -> p k | k = 0 -> a | k = 1 -> p i]A 34 | = [A:U][a,b:A][p:Path A a b][i,k:I] comp (I -> A) (i = 0 \/ i = 1 \/ k = 0 \/ k = 1) 0 35 | ([j:I] 36 | [ i = 0 -> a | 37 | i = 1 -> concatFill A a a b (refl A a) p j k | 38 | k = 0 -> a | 39 | k = 1 -> concatFill A a a b (refl A a) p j i 40 | ]) a 1 ; 41 | 42 | 43 | weakMeetDP : [A:U][a,b:A][p:Path A a b] PathD ([i:I] Path A a (p i) ) (refl A a) p 44 | = [A:U][a,b:A][p:Path A a b][i,k:I] comp (I -> A) (i = 0 \/ i = 1 \/ k = 0 \/ k = 1) 0 45 | ([j:I] 46 | [ i = 0 -> a | 47 | i = 1 -> concatFill A a a b (refl A a) p j k | 48 | k = 0 -> a | 49 | k = 1 -> concatFill A a a b (refl A a) p j i 50 | ]) a 1 ; 51 | 52 | invFill : [A:U][a,b:A][p:Path A a b][i,j:I][j = 0 -> a | i = 0 -> p j | i = 1 -> a]A 53 | = [A:U][a,b:A][p:Path A a b] 54 | [i,j:I] comp (I -> A) (i = 0 \/ i = 1) 0 ([j':I][i = 0 -> p j' | i = 1 -> a]) a j ; 55 | 56 | inv : [A:U][a,b:A] Path A a b -> Path A b a 57 | = [A:U][a,b:A][p:Path A a b] 58 | [i:I] (comp (I -> A) (i = 0 \/ i = 1) 0 ([j:I][i = 0 -> p j | i = 1 -> a]) a 1) ; 59 | 60 | rightUnit : [A:U][a,b,c:A][p:Path A a b] Path (Path A a b) p (concat A a b b p (refl A b)) 61 | = [A:U][a,b,c:A][p:Path A a b][i,j:I] concatFill A a b b p (refl A b) j i ; 62 | 63 | gamma : [A:U][a,b:A][p:Path A a b][k,i:I][k = 0 -> inv A a b p i | k = 1 -> b | i = 0 -> b | i = 1 -> p k ]A 64 | = [A:U][a,b:A][p:Path A a b][k,i:I] 65 | comp (I -> A) (i = 0 \/ i = 1 \/ k = 0 \/ k = 1) 0 ([j:I][i = 0 -> p j | i = 1 -> weakMeet A a b p j k | k = 0 -> invFill A a b p i j | k = 1 -> p j]) a 1 ; 66 | 67 | leftUnit : [A:U][a,b,c:A][p:Path A a b] Path (Path A a b) p (concat A a a b (refl A a) p) 68 | = [A:U][a,b,c:A][p:Path A a b][k,i:I] 69 | comp (I -> A) (i = 0 \/ i = 1 \/ k = 0 \/ k = 1) 0 ([j:I][i = 0 -> a | i = 1 -> gamma A a b p j k | k = 0 -> p i | k = 1 -> concatFill A a a b (refl A a) p i j]) (invFill A a b p k i) 1 ; 70 | 71 | isContr : [A:U]([y:A] Path A x y) ; 72 | 73 | --contrSum : [A:U][x:A][c:Path A x x] Path ( Path A y y) (x,c) (x,refl A x) ; 74 | 75 | transp : [F : I -> U] F 0 -> F 1 = [F : I -> U][a0 : F 0] 76 | comp F () 0 (I -> []) a0 1 ; 77 | 78 | transp' : [F : I -> U][i0,i1:I] F i0 -> F i1 = [F : I -> U][i0,i1:I][a0 : F i0] 79 | comp F () i0 (I -> []) a0 i1 ; 80 | 81 | transport : [B : U][P : B -> U][x : B][y : B][pB : Path B x y] P x -> P y = 82 | [B : U][P : B -> U][x : B][y : B][pB : Path B x y][u : P x] 83 | transp ([i : I] P (pB i)) u ; 84 | 85 | funext : [A:U][B:U][f:A -> B][g:A -> B] ([x:A] Path B (f x) (g x)) -> Path (A -> B) f g = 86 | [A:U][B:U][f:A -> B][g:A -> B][p:[x:A] Path B (f x) (g x)][i:I][x:A] (p x i) ; 87 | 88 | ap : [A,B:U][x,y:A][f:A->B] Path A x y -> Path B (f x) (f y) = 89 | [A,B:U][x,y:A][f:A->B][p:Path A x y][i:I] f (p i); 90 | 91 | pathInd : [A:U][a:A][C:[x:A](Path A a x)->U][x:A][p:Path A a x] C a (refl A a) -> C x p 92 | = [A:U][a:A][C:[x:A](Path A a x)->U][x:A][p:Path A a x][c: C a (refl A a)] 93 | transp ([i:I] C (weakMeet A a x p i 1) ([j:I] weakMeet A a x p i j)) c ; 94 | 95 | pathInd' : [A:U][a:A][C:[x:A](Path A a x)->U][x:A][p:Path A a x] C a (refl A a) -> C x p 96 | = [A:U][a:A][C:[x:A](Path A a x)->U][x:A][p:Path A a x][c: C a (refl A a)] 97 | [D : I -> U = [i:I] C (weakMeet A a x p i 1) ([j:I] weakMeet A a x p i j)] 98 | transp D c ; 99 | 100 | 101 | alphaFill : [A:U][a:A][k,i,j:I][k = 0 -> a | k = 1 -> a | i = 0 -> weakMeet A a a (refl A a) k j | i = 1 -> a | j = 0 -> a]A 102 | = [A:U][a:A][k,i,j:I] comp (I -> A) (i = 0 \/ i = 1 \/ k = 0 \/ k = 1) 0 103 | ([j':I][i = 0 -> weakMeet A a a (refl A a) k j' | i = 1 -> a | k = 0 -> a | k = 1 -> a]) a j ; 104 | 105 | alpha : [A:U][a:A][k,i:I][k = 0 -> a | k = 1 -> a | i = 0 -> weakMeet A a a (refl A a) k 1 | i = 1 -> a]A 106 | = [A:U][a:A][k,i:I] alphaFill A a k i 1 ; 107 | 108 | D : [A:U][a:A][C:[x:A](Path A a x) -> U] I -> I -> U 109 | = [A:U][a:A][C:[x:A](Path A a x) -> U] 110 | -- [i:I][k:I] C (alpha A a k i) (alphaFill A a k i) ; 111 | [i:I][k:I] C (alpha A a k i) ([x:I] alphaFill A a k i x) ; --ATTENZIONE! È dovuto al sub-typing ristretto! 112 | 113 | pathIndComp : [A:U][a:A][C:[x:A](Path A a x)->U][x:A][p:Path A a x][c:C a (refl A a)] 114 | Path (C a (refl A a)) (pathInd A a C a (refl A a) c) c 115 | = [A:U][a:A][C:[x:A](Path A a x)->U][x:A][p:Path A a x][c:C a (refl A a)][i:I] 116 | comp (D A a C i) (i = 0 \/ i = 1) 0 117 | ([j:I][i = 0 -> transp' ([i':I] C (weakMeet A a a (refl A a) i' 1) ([j':I] weakMeet A a a (refl A a) i' j')) 0 j c | i = 1 -> c]) c 1 ; 118 | 119 | HOTT2221 : [A,B:U][f:A->B][x,y,z:A][p:Path A x y][q:Path A y z] Path (Path B (f x) (f z)) (ap A B x z f (concat A x y z p q)) (concat B (f x) (f y) (f z) (ap A B x y f p) (ap A B y z f q)) ; 120 | 121 | reflInvLemma : [A:U][a:A] Path (Path A a a) (refl A a) (inv A a a (refl A a)) 122 | = [A:U][a:A][j,i:I] 123 | comp (I -> A) (i = 0 \/ i = 1 \/ j = 0 \/ j = 1) 0 124 | ([k:I][i = 0 -> a | i = 1 -> a | j = 0 -> a | j = 1 -> invFill A a a (refl A a) i k]) a 1 ; 125 | 126 | HOTT2222 : [A,B:U][f:A->B][x,y:A][p:Path A x y] Path (Path B (f y) (f x)) (ap A B y x f (inv A x y p)) (inv B (f x) (f y) (ap A B x y f p)) 127 | = [A,B:U][f:A->B][x,y:A][p:Path A x y] 128 | pathInd A x 129 | ([b:A][q:Path A x b] Path (Path B (f b) (f x)) (ap A B b x f (inv A x b q)) (inv B (f x) (f b) (ap A B x b f q))) 130 | y p 131 | (concat (Path B (f x) (f x)) 132 | (ap A B x x f (inv A x x (refl A x))) (refl B (f x)) (inv B (f x) (f x) (refl B (f x))) 133 | (ap (Path A x x) (Path B (f x) (f x)) (inv A x x (refl A x)) (refl A x) (ap A B x x f) (inv (Path A x x) (refl A x) (inv A x x (refl A x)) (reflInvLemma A x))) 134 | (reflInvLemma B (f x)) 135 | ) ; 136 | 137 | A : I -> U ; 138 | u : [i:I] A i ; 139 | v : [i:I] A i ; 140 | p0 : Path (A 0) (u 0) (v 0) ; 141 | 142 | p1 : Path (A 1) (u 1) (v 1) = transp ([i:I] Path (A i) (u i) (v i)) p0 ; 143 | 144 | B : U ; 145 | b : B ; 146 | p2 : Path B b b ; 147 | p2' : Path B b b ; 148 | p3 : Path (Path B b b) p2 p2' ; 149 | 150 | inv (Path B b b) p2 p2 (refl (Path B b b) p2) ; 151 | inv (Path B b b) p2 p2' p3 ; 152 | 153 | -- reflInvLemma : [A:U][a:A] Path (Path A a a) (refl A a) (inv A a a (refl A a)) 154 | -------------------------------------------------------------------------------- /examples/comp3.ctt: -------------------------------------------------------------------------------- 1 | Path : [A : U] A -> A -> U = 2 | [A : U][a0 : A][a1 : A][i : I] [(i = 0) -> a0 | (i = 1) -> a1] A ; 3 | 4 | refl : [A : U][a : A] Path A a a = [A : U][a : A][i : I] a ; 5 | 6 | const : [A:U]I -> U = [A:U][i:I]A ; 7 | 8 | concat : [A:U][a,b,c:A] Path A a b -> Path A b c -> Path A a c = 9 | [A:U][a,b,c:A][p:Path A a b][q:Path A b c] 10 | [i:I] comp (const A) (i = 0 \/ i = 1) 0 ([j:I][i = 0 -> a | i = 1 -> q j]) (p i) 1 ; 11 | 12 | transport : [B : U][P : B -> U][x : B][y : B][pB : Path B x y] P x -> P y = 13 | [B : U][P : B -> U][x : B][y : B][pB : Path B x y][u : P x] 14 | comp ([i : I]P (pB i)) () 0 (I -> []) u 1; 15 | 16 | transp : [F : I -> U] F 0 -> F 1 = [F : I -> U][a0 : F 0] 17 | comp F () 0 (I -> []) a0 1 ; 18 | 19 | 20 | transport'' : [B : U][P : B -> U][x : B][y : B][pB : Path B x y] P x -> P y = 21 | [B : U][P : B -> U][x : B][y : B][pB : Path B x y][u : P x] 22 | transp ([i : I] P (pB i)) u ; 23 | 24 | A : U ; 25 | B : I -> U ; 26 | a : A ; 27 | b0 : B 0 ; 28 | transpCoupleEx : A * B 1 = transp ([i:I] A * B i) (a,b0) ; 29 | 30 | f : A -> B 0 ; 31 | transpFunEx : A -> B 1 = transp ([i:I] A -> B i) f ; 32 | 33 | 34 | P : I -> U ; 35 | f' : (A -> B 0) -> P 0 ; 36 | transpFunEx' : (A -> B 1) -> P 1 = transp ([i:I] (A -> B i) -> P i) f' ; 37 | 38 | f'' : A -> (B 0 -> P 0) ; 39 | transpFunEx'' : A -> (B 1 -> P 1) = transp ([i:I] A -> (B i -> P i)) f'' ; 40 | 41 | 42 | h : B 0 -> P 0 ; 43 | g : B 0 -> (P 0 * A) = [b0' : B 0] (h b0',a) ; 44 | tce : A * (B 1 -> (P 1 * A)) = transp ([i:I] A * (B i -> (P i * A))) (a,g) ; 45 | b1 : B 1 ; 46 | tce ; -- has (inferred) type 'A * (B 1 -> (P 1 * A))' 47 | tce.2 ; -- has (inferred) type '(B 1 -> (P 1 * A))' 48 | (tce.2) b1 ; -- has (inferred) type 'A * P 1' 49 | ((tce.2) b1).1 ; -- has (inferred) type 'A' 50 | ((tce.2) b1).2 ; -- has (inferred) type 'P 1' 51 | 52 | 53 | D : I -> U ; 54 | d0 : D 0 ; 55 | db0 : D 0 + B 0 = inl d0 ; 56 | 57 | db1 : D 1 + B 1 = transp ([i:I] D i + B i) db0 ; 58 | 59 | j : I ; 60 | d0' : [i:I][i = 0 -> d0] D i ; 61 | d0'' : [i:I][i = 0 -> d0] D i ; 62 | 63 | comp ([k:I] D k + B k) (j = 0 \/ j = 1) 0 ([z:I][j = 0 -> inl (d0' z) | j = 1 -> inl (d0'' z)]) db0 1 ; 64 | -- inferred type '[j = 0 -> inl (d0' 1)| j = 1 -> inl (d0'' 1)] ((D 1) + (B 1))' 65 | 66 | 67 | 68 | 69 | 70 | ii : I ; 71 | 72 | unit : U = [ii = ii -> Z]N ; 73 | 74 | tt : unit = Z ; 75 | 76 | unitInd : [C:unit -> U] C tt -> [x:unit] C x 77 | = [C:unit -> U][p: C tt][x:unit] p ; 78 | 79 | unitEq : [x:unit] Path unit tt x 80 | = [x:unit] unitInd ([y:unit] Path unit tt y) (refl unit tt) x ; 81 | 82 | 83 | bool : U = unit + unit ; 84 | 85 | false : bool = inl tt ; 86 | true : bool = inr tt ; 87 | 88 | boolInd : [C:bool -> U] C false -> C true -> [x:bool] C x 89 | = [C:bool -> U][cf:C false][ct:C true][x:bool] 90 | split C ([u:unit] unitInd ([u':unit] C (inl u')) cf u) ([u:unit] unitInd ([u':unit] C (inr u')) ct u) x ; 91 | 92 | boolRec : [C:U] C -> C -> bool -> C 93 | = [C:U][iff:C][ift:C][x:bool] boolInd (bool -> C) iff ift x ; 94 | 95 | If : [C:U] bool -> C -> C -> C = [C:U][x:bool][ift:C][iff:C] boolRec C iff ift x ; 96 | 97 | 98 | 99 | comp (I -> bool) () 0 (I -> []) true 1 ; 100 | 101 | b0' : B 0 ; 102 | 103 | p0 : Path (B 0) b0 b0' ; 104 | 105 | 106 | -------------------------------------------------------------------------------- /examples/conv.ctt: -------------------------------------------------------------------------------- 1 | zeroEx : [i:I][i = 0 -> Z]N ; 2 | subEx : [i:I][i = 0 -> Z]N = [i:I]Z ; 3 | subEx' : [i:I]N = [i:I] zeroEx i ; 4 | 5 | idty : N -> U = N -> U ; 6 | Path : [A:U]A -> A -> U = [A:U][a0:A][a1:A][i:I][(i = 0) -> a0 | (i = 1) -> a1]A ; 7 | refl : [A:U][a:A]Path A a a = [A:U][a:A]I -> a ; 8 | A : U ; 9 | a : A ; 10 | b : A ; 11 | x : Path A a b ; 12 | P : A -> U ; 13 | i : I ; 14 | j : I ; 15 | c : P (x i) ; 16 | d : P (x j) ; 17 | 18 | failX : [i = 0 \/ i = 1]N ; 19 | failX2 : [i = 0]N = failX ; 20 | 21 | partEx' : N ; 22 | partEx : [i = 0 -> partEx']N = partEx' ; 23 | 24 | sysEx' : [i = 0 \/ i = 1]N = [i = 0 -> Z | i = 1 -> S Z] ; 25 | sysEx : [i = 0]N = sysEx' ; 26 | 27 | 28 | sysExR' : [i = 0 -> Z | i = 1 -> S Z]N ; 29 | sysExR : [i = 0 -> Z]N = sysExR' ; 30 | --sysExRF : [i = 0 -> S Z]N = sysExR' ; --indeed it fails 31 | sysExRR : [i = 0]N = sysExR' ; 32 | 33 | example : [i = j]P(x i) = [i = j -> d] ; 34 | 35 | example' : [i = j]U = [i = j -> P(x i) | i = j -> P(x j)] ; 36 | 37 | g : N -> N ; 38 | h : N -> N ; 39 | f : [i = 0 -> g | i = 1 -> h] (N -> N) ; 40 | 41 | fOK : N = f Z ; -- f Z => [i = 0 -> g Z | i = 1 -> h Z] N 42 | fOK' : [i = 0 -> f Z]N = fOK ; 43 | 44 | gU : N -> U = [n:N] ind (N -> U) N (N -> U -> [XX:U]XX) n ; 45 | fU : [k:I][k = 0 -> gU | k = 1 -> idty](N -> U) ; 46 | 47 | sys : [k:I][k = 0 \/ k = 1]U = [k:I][k = 0 -> fU k Z | k = 1 -> N] ; 48 | 49 | test : [i = 0 \/ (i = j /\ i = 1)]U = [i = 0 -> sys i | (i = 1 /\ i = j) -> sys j] ; 50 | 51 | B : U ; 52 | b0 : B ; 53 | b1 : B ; 54 | ff : [k:I] (([k = 0 -> a | k = 1 -> a]A) * [k = 0 -> b0 | k = 1 -> b1]B) ; 55 | ff2 : [k:I] [k = 0 -> (a,b0) | k = 1 -> (a,b1)] (A*B) ; 56 | ff3 : (([i = 0 -> a | i = 1 -> a]A) * [i = 0 -> b0 | i = 1 -> b1]B) ; 57 | ff4 : [i = 0 -> (a,b0) | i = 1 -> (a,b1)] (A*B) ; 58 | 59 | ff5 : [z:I](([z = 0 -> a | z = 1 -> a]A) * [z = 0 -> b0 | z = 1 -> b1]B) ; 60 | ff6 : [z:I] [z = 0 -> (a,b0) | z = 1 -> (a,b1)] (A*B) ; 61 | 62 | fu : [i = 0 -> [n:N] Z | i = 1 -> [n:N] S n] (N -> N) ; 63 | 64 | ff7: [k:I] [k = 0 -> (a,b0) | k = 1 -> (a,b1)](([k = 0 -> a | k = 1 -> a]A) * [k = 0 -> b0 | k = 1 -> b1]B) ; 65 | a' : [j = 0 -> a | j = 1 -> a]A ; 66 | b' : [z:I][z = 0 -> b0 | z = 1 -> b1]B ; 67 | ff8: [z:I][j = 0 -> (a',b' z) | j = 1 -> (a',b' z)](([z = 0 -> a | z = 1 -> a]A) * [z = 0 -> b0 | z = 1 -> b1]B) ; 68 | 69 | z : I ; 70 | ff9: [j = 0 -> (a',b' z) | j = 1 -> (a',b' z)](([z = 0 -> a | z = 1 -> a]A) * [z = 0 -> b0 | z = 1 -> b1]B) ; 71 | 72 | 73 | gg : [i = 0 -> inl a | i = 1 -> inr b0] (A + B) ; 74 | gg2 : ([i = 0 -> a | i = 1 -> a]A) + ([i = 0 -> b0 | i = 1 -> b1]B) ; 75 | 76 | F : A + B -> U = [cp:A + B] split (A + B -> U) (A -> N) (B -> Path N Z Z) cp ; 77 | 78 | s : F gg = split F (A -> Z) (B -> refl N Z) gg ; 79 | 80 | -- 'split F (A -> Z) (B -> refl N Z) gg' has (inferred) type 81 | -- [i = 0 -> N | i = 1 -> Path N Z Z] F gg 82 | 83 | {- 84 | gg' : [z = 1 -> inl a | z = 0 -> inr b0] (A + B) ; 85 | 86 | s' : F gg' = split F ([a':A] Z) ([b':B] refl N Z) gg' ; 87 | 88 | F1 : A + B -> U = (A + B) -> [z = 0 -> Z | z = 1 -> S Z]N ; 89 | 90 | s1 : F1 gg' = split F1 ([a':A] Z) ([b':B] Z) gg' ; 91 | -} 92 | 93 | 94 | m : N ; 95 | n : [i = 0 -> m]N ; 96 | n' : [i = 0 -> S m]N = S n; 97 | -------------------------------------------------------------------------------- /examples/cubical.ctt: -------------------------------------------------------------------------------- 1 | 2 | --system : [i:I][i = 0 \/ i = 1]N = [i:I][(i=0) -> Z | (i=1) -> S Z] ; 3 | 4 | -- system' : [i:I][i = 0 \/ i = 1]N = [j:I][(j=0) -> Z | (j=1) -> S Z] ; 5 | 6 | -- systemI : [i:I][i = 0 \/ i = 1]I = [i:I][(i=0) -> i | (i=1) -> i] ; --rejected OK `I` cannot be codomain 7 | 8 | -- system' : [i:I][i = 0 \/ i = 1]N = [i:I][i=0 \/ i = 1 -> Z | i=1 -> S Z] ; --rejected OK terms are not adjacent 9 | 10 | -- system : [i:I][i = 0]N = [j:I][j=0 -> Z | j=1 -> S Z] ; --rejected OK formulas don't match 11 | 12 | -- system : [i:I]N = [i:I][i = i -> Z] ; 13 | 14 | 15 | Path : [A : U] A -> A -> U = 16 | [A : U][a0 : A][a1 : A][i : I] [(i = 0) -> a0 | (i = 1) -> a1] A ; 17 | 18 | refl : [A : U][a : A] Path A a a = [A : U][a : A][i : I] a ; 19 | 20 | A : U ; 21 | a : A ; 22 | b : A ; 23 | c : A ; 24 | d : A ; 25 | p : Path A a b ; 26 | q : Path A b c ; 27 | 28 | 29 | --j : I ; 30 | 31 | u : [j : I][i : I][j = 0 \/ i = 0 \/ i = 1]A = 32 | [j : I][i : I][(j = 0) -> p i | (i = 0) -> a | (i = 1) -> q j] ; 33 | 34 | u0 : [i : I][i = 0]A = [i : I][(i = 0) -> a] ; 35 | 36 | P : A -> U ; 37 | Pa : P a ; 38 | Pb : P b ; 39 | --test : P (p I0) = a' ; 40 | 41 | s1 : [i:I][j:I][i = 0 /\ j = 0 \/ i = 1 /\ j = 1]N = [i:I][j:I][i = 0 /\ j = 0 -> Z | i = 1 /\ j = 1 -> S Z] ; 42 | 43 | s2 : [i:I][j:I][k:I][i = 0 /\ j = 0 \/ i = 1 /\ k = 0]N = [i:I][j:I][k:I][i = 0 /\ j = 0 -> Z | i = 1 /\ k = 0 -> S Z] ; 44 | 45 | 46 | p' : Path A a b ; 47 | fill : Path (Path A a b) p p' ; 48 | 49 | ss : [i:I][j:I][i = 0 \/ i = 1]A = [i:I][j:I][i = 0 -> fill i j | i = 1 -> c] ; 50 | --ss' : [i:I][j:I][i = 0 \/ i = 1]A = [i:I][j:I][i = 0 -> fill j i | i = 1 -> b] ; 51 | 52 | 53 | {-works : [i:I][j:I][j = 0 \/ j = 1 \/ i = 0][i = 0 \/ i = 1]A = [i:I][j:I][ 54 | i = 0 -> [i = 0 -> a] | 55 | j = 0 -> ss i j | 56 | j = 1 -> ss' i j 57 | ] ;-} 58 | 59 | ut : [i:I][i = 0 -> a | i = 1 -> b]A ; 60 | 61 | test : [i:I][j:I][i = 0 \/ (i = 1 /\ j = 0) \/ (i = 1 /\ j = 1)]A = [i:I][j:I][ 62 | i = 0 -> ut i | 63 | i = 1 /\ j = 0 -> b | 64 | i = 1 /\ j = 1 -> c 65 | ] ; 66 | 67 | -------------------------------------------------------------------------------- /examples/cubical2.ctt: -------------------------------------------------------------------------------- 1 | s : [i:I][i = 0]N = [i:I][(i = 0) -> S Z] ; 2 | 3 | f : [y:N][i:I][i = 0 \/ i = 1]N = [y:N][i:I][i = 0 -> S y | i = 1 -> Z] ; 4 | 5 | fd : [y:N][i:I][i = 0 -> S y | i = 1 -> Z]N ; 6 | 7 | i : I ; 8 | 9 | fnat : N -> N ; 10 | fnat' : ([i = 0]N) -> N ; 11 | n : [i = 0 -> S Z][i = 1 -> S (S Z)] N ; 12 | m : [i = 0 \/ i = 1]N ; 13 | k : [i = 0 -> S Z | i = 1 -> S (S Z)]N ; 14 | 15 | {- 16 | i : I ; 17 | j : I ; 18 | 19 | u : [i = 0 -> Z | i = 1 -> S Z][j = 0 -> Z]N; 20 | uwrong : [i = 0 -> Z | i = 1 -> S Z][i = 0 -> Z]N; 21 | -} -------------------------------------------------------------------------------- /examples/eval.ctt: -------------------------------------------------------------------------------- 1 | Path : [A : U] A -> A -> U = 2 | [A : U][a0 : A][a1 : A][i : I] [(i = 0) -> a0 | (i = 1) -> a1] A ; 3 | 4 | refl : [A : U][a : A] Path A a a = [A : U][a : A][i : I] a ; 5 | 6 | const : [A:U]I -> U = [A:U][i:I]A ; 7 | 8 | ii : I ; 9 | 10 | unit : U = [ii = ii -> Z]N ; 11 | 12 | tt : unit = Z ; 13 | 14 | unitInd : [C:unit -> U] C tt -> [x:unit] C x 15 | = [C:unit -> U][p: C tt][x:unit] p ; 16 | 17 | unitEq : [x:unit] Path unit tt x 18 | = [x:unit] unitInd ([y:unit] Path unit tt y) (refl unit tt) x ; 19 | 20 | transp : [F : I -> U] F 0 -> F 1 = [F : I -> U][a0 : F 0] 21 | comp F () 0 (I -> []) a0 1 ; 22 | 23 | bool : U = unit + unit ; 24 | 25 | false : bool = inl tt ; 26 | true : bool = inr tt ; 27 | 28 | boolInd : [C:bool -> U] C false -> C true -> [x:bool] C x 29 | = [C:bool -> U][cf:C false][ct:C true][x:bool] 30 | split C ([u:unit] unitInd ([u':unit] C (inl u')) cf u) ([u:unit] unitInd ([u':unit] C (inr u')) ct u) x ; 31 | 32 | boolRec : [C:U] C -> C -> bool -> C 33 | = [C:U][iff:C][ift:C][x:bool] boolInd (bool -> C) iff ift x ; 34 | 35 | A : U ; 36 | i : I ; 37 | f : [i = 0](A -> N) ; 38 | a : [i = 0 \/ i = 1]A ; 39 | 40 | 41 | adt : U = unit + (bool * N) + ((N -> N) * bool * N) ; 42 | 43 | adt1 : adt = inl tt ; 44 | adt2 : adt = inr (inl (true,S Z)) ; 45 | adt3 : adt = inr (inr ((N -> S (S Z)),(false,Z))) ; 46 | 47 | g : N -> N ; 48 | adt3' : adt = inr (inr (g,(false,Z))) ; 49 | 50 | transp (I -> adt) adt3 ; 51 | 52 | -------------------------------------------------------------------------------- /examples/identity.ctt: -------------------------------------------------------------------------------- 1 | Path : [A : U] A -> A -> U = 2 | [A : U][a0 : A][a1 : A][i : I] [(i = 0) -> a0 | (i = 1) -> a1] A ; 3 | 4 | refl : [A : U][a : A] Path A a a = [A : U][a : A][i : I] a ; 5 | 6 | Id : [A:U] A -> A -> U ; 7 | -------------------------------------------------------------------------------- /examples/nat.ctt: -------------------------------------------------------------------------------- 1 | {- Induction testing -} 2 | 3 | idU : N -> U = [x:N]U ; 4 | idN : N -> U = [x:N]N ; 5 | 6 | zero : N = ind idN Z ([n:N][m:N]Z) Z ; 7 | 8 | succ : N -> N = [n : N] ind idN (S Z) ([n':N][m:N] S m) n ; 9 | 10 | plus : N -> N -> N = [m : N][n : N] ind idN m ([n':N][mPlusn:N] S mPlusn) n ; 11 | 12 | mult : N -> N -> N = [m : N][n : N] ind idN Z ([n':N][mTimesn:N] plus mTimesn m) n ; 13 | 14 | exp : N -> N -> N = [m : N][n : N] ind idN (S Z) ([n':N][mExpn:N] mult mExpn m) n ; 15 | 16 | tetra : N -> N -> N = [m : N][n : N] ind idN (S Z) ([n':N][mTetran:N] exp m mTetran) n ; 17 | 18 | succ (S (S (S (S Z)))) ; 19 | 20 | plus (S (S (S Z))) (S (S (S Z))) ; 21 | 22 | mult (S Z) (S Z) ; 23 | 24 | exp (S (S (S Z))) (S (S (S Z))) ; 25 | 26 | 27 | {- Some logic -} 28 | 29 | bot : U = [X:U]X ; 30 | 31 | neg : U -> U = [A:U] A -> U ; 32 | 33 | ind_bot : [A:U] bot -> A = [A:U][b:bot] b A ; 34 | 35 | --one : U = [A:U] bot -> A ; 36 | 37 | --star : one = [A:U][b:bot] b A ; 38 | 39 | --Is it provable?? 40 | --ind_one : [C:one -> U][h:C star][x:one] C x = Z; 41 | 42 | 43 | 44 | {- Product of two types -} 45 | --Not really, I should use "2" instead of "nat" 46 | 47 | prod : U -> U -> U = [A:U][B:U][x:N] ind ([y:N]U) A ([n:N][p:U]B) x ; 48 | pi1 : [A:U][B:U] prod A B -> A = [A:U][B:U][p : prod A B] p Z ; 49 | pi2 : [A:U][B:U] prod A B -> B = [A:U][B:U][p : prod A B] p (S Z) ; 50 | couple : [A:U][B:U] A -> B -> prod A B = [A:U][B:U][a:A][b:B][x:N] ind ([y:N]ind ([z:N]U) A ([n:N][p:U]B) y) a ([n:N][p:ind ([w:N]U) A ([m:N][q:U]B) n] b) x; 51 | 52 | NpN : U = prod N N ; 53 | couple13 : NpN = couple N N (S Z) (S (S (S Z))) ; 54 | pi1 N N couple13 ; 55 | pi2 N N couple13 ; 56 | 57 | NpNpN : U = prod NpN N ; 58 | triple135 : NpNpN = couple NpN N couple13 (S (S (S (S (S Z))))) ; 59 | --triple135' : NpNpN = couple NpN N (couple N N (S Z) (exp (S (S (S Z))) (S ([f:N->N]Z)(S Z) ))) (plus (S (S (S (S Z)))) (tetra Z Z)) ; 60 | 61 | pi1 N N (pi1 NpN N triple135) ; --reduces to 1 62 | pi2 N N (pi1 NpN N triple135) ; --reduces to 3 63 | pi2 NpN N triple135 ; --reduces to 5 64 | 65 | --OpN : U = prod one N ; 66 | --extract_OpN : [f:OpN -> N] N -> N = [f:OpN -> N][n:N] f (couple one N star n) ; 67 | 68 | 69 | {- Booleans -} 70 | 71 | Bool : U = [X:U] X -> X -> X ; 72 | True : Bool = [X:U][x:X][y:X] x ; 73 | False : Bool = [X:U][x:X][y:X] y ; 74 | If : [A:U] Bool -> A -> A -> A = [A:U][cond:Bool][u:A][v:A] cond A u v ; 75 | 76 | rec_Bool : [C:U] C -> C -> Bool -> C = [C:U][x1:C][x2:C][x:Bool] If C x x1 x2 ; --it's the same as 'If'! 77 | 78 | --Can it be proved? 79 | --ind_Bool : [C:Bool -> U] C False -> C True -> [x:Bool] C x = [C:Bool -> U][h1:C False][h2:C True][x:Bool] rec_Bool ([y:Bool] C y) h1 h2 x ; 80 | 81 | 82 | 83 | {- Coproduct built using Bool -} 84 | 85 | prod' : U -> U -> U = [A:U][B:U][x:Bool] rec_Bool U A B x ; 86 | p1' : [A:U][B:U] prod' A B -> A = [A:U][B:U][p:prod' A B] p True ; 87 | p2' : [A:U][B:U] prod' A B -> B = [A:U][B:U][p:prod' A B] p False ; 88 | 89 | --does not work.. I need the inductor for Bool! 90 | --makeCouple : [A:U][B:U] A -> B -> prod A B = [A:U][B:U][a:A][b:B][x:Bool] rec_Bool ([y:Bool] rec_Bool U A B y) a b x ; 91 | 92 | 93 | --trick : [n:N] ind idU N ([m:N][p:U]N) n = [n:N]Z ; --'N' is different from 'ind idU N ([m:N][p:U]N) n' 94 | trick : [n:N] ind idU N ([m:N][p:U]N) n = [n:N] ind ([n':N] ind idU N ([m:N][p:U]N) n') Z ([m:N][p:ind idU N ([m':N][p':U]N) m]Z) n ; -------------------------------------------------------------------------------- /examples/paradox.ctt: -------------------------------------------------------------------------------- 1 | Pow : U -> U = 2 | [X : U] X -> U ; 3 | 4 | T : U -> U = 5 | [X : U] Pow (Pow X) ; 6 | 7 | 8 | abs : U = [X : U] X; 9 | 10 | not : U -> U = [X : U] X -> abs ; 11 | 12 | A : U = [X : U] (T X -> X) -> X ; 13 | 14 | 15 | intro : T A -> A = [t : T A][X : U][f : T X -> X] f ([g : Pow X] t ([z : A] g (z X f))) ; 16 | 17 | match : A -> T A = [z : A]z (T A) ([t : T (T A)][g : Pow A] t ([x : T A] g (intro x))) ; 18 | 19 | 20 | delta : A -> A = [z : A] intro (match z) ; 21 | 22 | Q : T A = [p : Pow A][z : A]match z p -> p z; 23 | 24 | cDelta : Pow A -> Pow A = [p : Pow A][z:A]p (delta z) ; 25 | 26 | a0 : A = intro Q ; 27 | 28 | lem1 : [p : Pow A]Q p -> p a0 = [p : Pow A][h : Q p]h a0 ([x : A]h (delta x)) ; 29 | 30 | Ed : Pow A = [z:A][p:Pow A]match z p -> p (delta z) ; 31 | 32 | lem2 : Ed a0 = [p:Pow A]lem1 (cDelta p) ; 33 | 34 | B : Pow A = [z : A] not (Ed z) ; 35 | 36 | lem3 : Q B = [z : A] [k : match z B] [l : Ed z] l B k ([p:Pow A]l (cDelta p)); 37 | 38 | lem4 : not (Ed a0) = lem1 B lem3 ; 39 | 40 | --loop : abs = lem4 lem2 ; 41 | 42 | --test : abs -> U = [x : abs] A ; 43 | 44 | --test2 : test loop = a0 ; -------------------------------------------------------------------------------- /examples/path.ctt: -------------------------------------------------------------------------------- 1 | id : [A:U] A -> A = [A:U][a:A] a ; 2 | 3 | Path : [A : U] A -> A -> U = 4 | [A : U][a0:A][a1 : A][i : I] [(i = 0) -> a0 | (i = 1) -> a1] A ; 5 | 6 | refl : [A : U][a : A] Path A a a = [A : U][a : A][i : I] a ; 7 | 8 | fcomp : [A,B,C:U][f:B -> C][g:A -> B] A -> C 9 | = [A,B,C:U][f:B -> C][g:A -> B][a:A] f (g a) ; 10 | 11 | isEquiv : [A,B:U] (A -> B) -> U 12 | = [A,B:U][f:A -> B] ( A> Path (B -> B) (fcomp B A B f g) (id B)) * ( A> Path (A -> A) (fcomp A B A h f) (id A)) ; 13 | 14 | equiv : U -> U -> U 15 | = [A,B:U] B> isEquiv A B f; 16 | 17 | funext : [A,B:U][f,g:A -> B] ([x:A] Path B (f x) (g x)) -> Path (A -> B) f g = 18 | [A,B:U][f,g:A -> B][p:[x:A] Path B (f x) (g x)][i:I][x:A] (p x i) ; 19 | 20 | ap : [A,B:U][f:A->B][a1,a2:A] Path A a1 a2 -> Path B (f a1) (f a2) = 21 | [A,B:U][f:A->B][a1,a2:A][p:Path A a1 a2][i:I] f (p i) ; 22 | 23 | transp : [F : I -> U] F 0 -> F 1 = [F : I -> U][a0 : F 0] 24 | comp F () 0 (I -> []) a0 1 ; 25 | 26 | transp' : [F : I -> U][i0,i1:I] F i0 -> F i1 = [F : I -> U][i0,i1:I][a0 : F i0] 27 | comp F () i0 (I -> []) a0 i1 ; 28 | 29 | invFill : [A:U][a,b:A][p:Path A a b][i,j:I][j = 0 -> a | i = 0 -> p j | i = 1 -> a]A 30 | = [A:U][a,b:A][p:Path A a b] 31 | [i,j:I] comp (I -> A) (i = 0 \/ i = 1) 0 ([j':I][i = 0 -> p j' | i = 1 -> a]) a j ; 32 | 33 | inv : [A:U][a,b:A] Path A a b -> Path A b a 34 | = [A:U][a,b:A][p:Path A a b] 35 | [i:I] (comp (I -> A) (i = 0 \/ i = 1) 0 ([j:I][i = 0 -> p j | i = 1 -> a]) a 1) ; 36 | 37 | concatFill : [A:U][a,b,c:A][p:Path A a b][q:Path A b c][i,j:I][j = 0 -> p i | i = 0 -> a | i = 1 -> q j]A 38 | = [A:U][a,b,c:A][p:Path A a b][q:Path A b c] 39 | [i,j:I] comp (I -> A) (i = 0 \/ i = 1) 0 ([j':I][i = 0 -> a | i = 1 -> q j']) (p i) j ; 40 | 41 | concat : [A:U][a,b,c:A] Path A a b -> Path A b c -> Path A a c = 42 | [A:U][a,b,c:A][p:Path A a b][q:Path A b c] 43 | [i:I] comp (I -> A) (i = 0 \/ i = 1) 0 ([j:I][i = 0 -> a | i = 1 -> q j]) (p i) 1 ; 44 | 45 | rightUnit : [A:U][a,b:A][p:Path A a b] Path (Path A a b) p (concat A a b b p (refl A b)) 46 | = [A:U][a,b:A][p:Path A a b][i,j:I] concatFill A a b b p (refl A b) j i ; 47 | 48 | weakMeet : [A:U][a,b:A][p:Path A a b][i,k:I][i = 0 -> a | i = 1 -> p k | k = 0 -> a | k = 1 -> p i]A 49 | = [A:U][a,b:A][p:Path A a b][i,k:I] comp (I -> A) (i = 0 \/ i = 1 \/ k = 0 \/ k = 1) 0 50 | ([j:I] 51 | [ i = 0 -> a | 52 | i = 1 -> concatFill A a a b (refl A a) p j k | 53 | k = 0 -> a | 54 | k = 1 -> concatFill A a a b (refl A a) p j i 55 | ]) a 1 ; 56 | 57 | gamma : [A:U][a,b:A][p:Path A a b][k,i:I][k = 0 -> inv A a b p i | k = 1 -> b | i = 0 -> b | i = 1 -> p k ]A 58 | = [A:U][a,b:A][p:Path A a b][k,i:I] 59 | comp (I -> A) (i = 0 \/ i = 1 \/ k = 0 \/ k = 1) 0 ([j:I][i = 0 -> p j | i = 1 -> weakMeet A a b p j k | k = 0 -> invFill A a b p i j | k = 1 -> p j]) a 1 ; 60 | 61 | leftUnit : [A:U][a,b:A][p:Path A a b] Path (Path A a b) p (concat A a a b (refl A a) p) 62 | = [A:U][a,b:A][p:Path A a b][k,i:I] 63 | comp (I -> A) (i = 0 \/ i = 1 \/ k = 0 \/ k = 1) 0 ([j:I][i = 0 -> a | i = 1 -> gamma A a b p j k | k = 0 -> p i | k = 1 -> concatFill A a a b (refl A a) p i j]) (invFill A a b p k i) 1 ; 64 | 65 | pathInd : [A:U][a:A][C:[x:A](Path A a x)->U] C a (refl A a) -> [x:A][p:Path A a x] C x p 66 | = [A:U][a:A][C:[x:A](Path A a x)->U][c: C a (refl A a)][x:A][p:Path A a x] 67 | transp ([i:I] C (weakMeet A a x p i 1) ([j:I] weakMeet A a x p i j)) c ; 68 | 69 | alphaFill : [A:U][a:A][k,i,j:I][k = 0 -> a | k = 1 -> a | i = 0 -> weakMeet A a a (refl A a) k j | i = 1 -> a | j = 0 -> a]A 70 | = [A:U][a:A][k,i,j:I] comp (I -> A) (i = 0 \/ i = 1 \/ k = 0 \/ k = 1) 0 71 | ([j':I][i = 0 -> weakMeet A a a (refl A a) k j' | i = 1 -> a | k = 0 -> a | k = 1 -> a]) a j ; 72 | 73 | alpha : [A:U][a:A][k,i:I][k = 0 -> a | k = 1 -> a | i = 0 -> weakMeet A a a (refl A a) k 1 | i = 1 -> a]A 74 | = [A:U][a:A][k,i:I] alphaFill A a k i 1 ; 75 | 76 | D : [A:U][a:A][C:[x:A](Path A a x) -> U] I -> I -> U 77 | = [A:U][a:A][C:[x:A](Path A a x) -> U] 78 | [i:I][k:I] C (alpha A a k i) ([x:I] alphaFill A a k i x) ; 79 | 80 | pathIndComp : [A:U][a:A][C:[x:A](Path A a x)->U][x:A][p:Path A a x][c:C a (refl A a)] 81 | Path (C a (refl A a)) (pathInd A a C c a (refl A a)) c 82 | = [A:U][a:A][C:[x:A](Path A a x)->U][x:A][p:Path A a x][c:C a (refl A a)][i:I] 83 | comp (D A a C i) (i = 0 \/ i = 1) 0 84 | ([j:I][i = 0 -> transp' ([i':I] C (weakMeet A a a (refl A a) i' 1) ([j':I] weakMeet A a a (refl A a) i' j')) 0 j c | i = 1 -> c]) c 1 ; 85 | 86 | transport : [A : U][P : A -> U][x,y:A][p : Path A x y] P x -> P y = 87 | [A : U][P : A -> U][x,y:A][p : Path A x y][u : P x] 88 | transp ([i : I] P (p i)) u ; 89 | 90 | transportRefl' : [A : U][P : A -> U][x:A][y:P x] 91 | Path (P x) (transport A P x x (refl A x) y) y 92 | = [A : U][P : A -> U][x:A][y:P x] 93 | [i:I] comp (I -> P x) () i (I -> []) y 1 ; 94 | 95 | transportRefl : [A : U][P : A -> U][x:A] 96 | Path (P x -> P x) (transport A P x x (refl A x)) (id (P x)) 97 | = [A : U][P : A -> U][x:A] funext (P x) (P x) 98 | (transport A P x x (refl A x)) (id (P x)) 99 | (transportRefl' A P x); 100 | 101 | transportReflApp : [A : U][P : A -> U][x:A][u:P x] 102 | Path (P x) (transport A P x x (refl A x) u) u 103 | = [A : U][P : A -> U][x:A][u:P x] 104 | ap (P x -> P x) (P x) ([f:P x -> P x] f u) (transport A P x x (refl A x)) 105 | (id (P x)) (transportRefl A P x) ; 106 | 107 | --- 108 | 109 | HOTT_2_11_2' : [A:U][a,x1:A][q:Path A a x1] 110 | Path (Path A a x1) (transport A ([x:A] Path A a x) x1 x1 (refl A x1) q) (concat A a x1 x1 q (refl A x1)) 111 | = [A:U][a,x1:A][q:Path A a x1] concat (Path A a x1) 112 | (transport A ([x:A] Path A a x) x1 x1 (refl A x1) q) q (concat A a x1 x1 q (refl A x1)) 113 | (transportReflApp A ([x:A] Path A a x) x1 q) (rightUnit A a x1 q); 114 | 115 | HOTT_2_11_2 : [A:U][a,x1:A][q:Path A a x1][x2:A][p:Path A x1 x2] 116 | Path (Path A a x2) (transport A ([x:A] Path A a x) x1 x2 p q) (concat A a x1 x2 q p) 117 | = [A:U][a,x1:A][q:Path A a x1] pathInd A x1 ([x2:A][p:Path A x1 x2] 118 | Path (Path A a x2) (transport A ([x:A] Path A a x) x1 x2 p q) (concat A a x1 x2 q p)) 119 | (HOTT_2_11_2' A a x1 q) ; 120 | 121 | --- 122 | 123 | HOTT_2_3_10' : [A,B:U][f:A->B][P:B->U][x:A][u: P (f x)] 124 | Path (P (f x)) (transport A ([z:A] P (f z)) x x (refl A x) u) 125 | (transport B P (f x) (f x) (ap A B f x x (refl A x)) u) 126 | = [A,B:U][f:A->B][P:B->U][x:A][u: P (f x)] concat (P (f x)) 127 | (transport B P (f x) (f x) (ap A B f x x (refl A x)) u) u 128 | (transport A ([z:A] P (f z)) x x (refl A x) u) 129 | (transportReflApp B P (f x) u) 130 | (inv (P (f x)) (transport A ([z:A] P (f z)) x x (refl A x) u) u (transportReflApp A ([z:A] P (f z)) x u)) 131 | ; 132 | 133 | HOTT_2_3_10 : [A,B:U][f:A->B][P:B->U][x:A][u: P (f x)][y:A][p:Path A x y] 134 | Path (P (f y)) (transport A ([z:A] P (f z)) x y p u) 135 | (transport B P (f x) (f y) (ap A B f x y p) u) 136 | = [A,B:U][f:A->B][P:B->U][x:A][u: P (f x)] pathInd A x 137 | ([y:A][p:Path A x y] Path (P (f y)) (transport A ([z:A] P (f z)) x y p u) 138 | (transport B P (f x) (f y) (ap A B f x y p) u)) 139 | (HOTT_2_3_10' A B f P x u) ; 140 | 141 | --- 142 | 143 | empty : U = [X:U] X ; 144 | 145 | emptyInd : [C:empty -> U][z:empty] C z 146 | = [C:empty -> U][z:empty] z (C z) ; 147 | 148 | emptyRec : [C:U] empty -> C 149 | = [C:U][z:empty] z C ; 150 | 151 | --- 152 | 153 | ii : I ; 154 | 155 | unit : U = [ii = ii -> Z]N ; 156 | 157 | tt : unit = Z ; 158 | 159 | unitInd : [C:unit -> U] C tt -> [x:unit] C x 160 | = [C:unit -> U][p: C tt][x:unit] p ; 161 | 162 | bool : U = unit + unit ; 163 | 164 | false : bool = inl tt ; 165 | true : bool = inr tt ; 166 | 167 | boolInd : [C:bool -> U] C false -> C true -> [x:bool] C x 168 | = [C:bool -> U][cf:C false][ct:C true][x:bool] 169 | split C ([u:unit] unitInd ([u':unit] C (inl u')) cf u) ([u:unit] unitInd ([u':unit] C (inr u')) ct u) x ; 170 | 171 | boolRec : [C:U] C -> C -> bool -> C 172 | = [C:U][iff:C][ift:C][x:bool] boolInd (bool -> C) iff ift x ; 173 | 174 | --- 175 | 176 | code : [A,B:U][a0:A] A + B -> U = [A,B:U][a0:A][x:A + B] 177 | split (A + B -> U) ([a:A] Path A a0 a) (B -> empty) x ; 178 | 179 | 180 | encode : [A,B:U][a0:A][x:A + B][p : Path (A + B) (inl a0) x] code A B a0 x 181 | = [A,B:U][a0:A][x:A + B][p : Path (A + B) (inl a0) x] 182 | transport (A + B) ([x':A + B] code A B a0 x') (inl a0) x 183 | p (refl A a0) ; 184 | 185 | decode : [A,B:U][a0:A][x:A + B][c: code A B a0 x] Path (A + B) (inl a0) x 186 | = [A,B:U][a0:A][x:A + B] split 187 | ([x':A + B] code A B a0 x' -> Path (A + B) (inl a0) x') 188 | ([a:A][c:code A B a0 (inl a)] ap A (A + B) ([a':A] inl a') a0 a c) 189 | ([b:B][c:code A B a0 (inr b)] emptyRec (Path (A + B) (inl a0) (inr b)) c) 190 | x 191 | ; 192 | 193 | {-AA : U ; 194 | BB : U ; 195 | a0 : AA ; 196 | 197 | F : I -> U = I -> AA + BB ; 198 | 199 | 200 | transportReflApp (AA+BB) ([x:AA+BB] Path (AA+BB) (inl a0) x) (inl a0) (refl (AA+BB) (inl a0)) ; 201 | -} 202 | --transportReflApp (AA+BB) (code AA BB a0) (inl a0) ; --(refl AA a0) ; 203 | 204 | 205 | -- pathInd : [A:U][a:A][C:[x:A](Path A a x)->U] C a (refl A a) -> [x:A][p:Path A a x] C x p 206 | 207 | decode_encode_helper : [A,B:U][a0:A] Path (Path (A + B) (inl a0) (inl a0)) 208 | (decode A B a0 (inl a0) (encode A B a0 (inl a0) (refl (A + B) (inl a0)))) (decode A B a0 (inl a0) (refl A a0)) 209 | = [A,B:U][a0:A] ap 210 | (Path A a0 a0) 211 | (Path (A + B) (inl a0) (inl a0)) 212 | ([p:Path A a0 a0] decode A B a0 (inl a0) p) 213 | (encode A B a0 (inl a0) (refl (A + B) (inl a0))) 214 | (refl A a0) 215 | (transportReflApp (A+B) (code A B a0) (inl a0) (refl A a0)) 216 | ; 217 | 218 | decode_encode : [A,B:U][a0:A][x:A + B][p : Path (A + B) (inl a0) x] 219 | Path (Path (A + B) (inl a0) x) (decode A B a0 x (encode A B a0 x p)) p 220 | = [A,B:U][a0:A] pathInd (A + B) (inl a0) 221 | ([x':A + B][p' : Path (A + B) (inl a0) x'] 222 | Path (Path (A + B) (inl a0) x') (decode A B a0 x' (encode A B a0 x' p')) p') 223 | (decode_encode_helper A B a0) ; 224 | 225 | decode_encode_inv : [A,B:U][a0:A][x:A + B][P : U = Path (A + B) (inl a0) x] 226 | Path (P -> P) ([p:P] decode A B a0 x (encode A B a0 x p)) (id P) 227 | = [A,B:U][a0:A][x:A + B][P : U = Path (A + B) (inl a0) x] funext P P 228 | ([p:P] decode A B a0 x (encode A B a0 x p)) (id P) 229 | (decode_encode A B a0 x) ; 230 | 231 | encode_decode_helper1 : [A,B:U][a0:A][a:A][c:code A B a0 (inl a)] Path (code A B a0 (inl a)) 232 | (encode A B a0 (inl a) (decode A B a0 (inl a) c)) (concat A a0 a0 a (refl A a0) c) 233 | = [A,B:U][a0:A][a:A][c:code A B a0 (inl a)] 234 | concat (code A B a0 (inl a)) (encode A B a0 (inl a) (decode A B a0 (inl a) c)) 235 | (transport A ([a':A] Path A a0 a') a0 a c (refl A a0)) (concat A a0 a0 a (refl A a0) c) 236 | (HOTT_2_3_10 A (A+B) ([x:A] inl x) (code A B a0) a0 (refl A a0) a c) 237 | (HOTT_2_11_2 A a0 a0 (refl A a0) a c) ; 238 | 239 | encode_decode_helper : [A,B:U][a0:A][a:A][c:code A B a0 (inl a)] 240 | Path (code A B a0 (inl a)) (encode A B a0 (inl a) (decode A B a0 (inl a) c)) c 241 | = [A,B:U][a0:A][a:A][c:code A B a0 (inl a)] concat (code A B a0 (inl a)) 242 | (encode A B a0 (inl a) (decode A B a0 (inl a) c)) (concat A a0 a0 a (refl A a0) c) c 243 | (encode_decode_helper1 A B a0 a c) 244 | (inv (code A B a0 (inl a)) c (concat A a0 a0 a (refl A a0) c) (leftUnit A a0 a c)) ; 245 | 246 | encode_decode : [A,B:U][a0:A][x:A+B][c:code A B a0 x] 247 | Path (code A B a0 x) (encode A B a0 x (decode A B a0 x c)) c 248 | = [A,B:U][a0:A][x:A+B] split 249 | ([x':A+B][c:code A B a0 x'] Path (code A B a0 x') (encode A B a0 x' (decode A B a0 x' c)) c) 250 | ([a:A] encode_decode_helper A B a0 a) 251 | ([b:B] ([c:code A B a0 (inr b)] emptyRec (Path (code A B a0 (inr b)) (encode A B a0 (inr b) (decode A B a0 (inr b) c))c)c)) 252 | x ; 253 | 254 | encode_decode_inv : [A,B:U][a0:A][x:A + B][P : U = code A B a0 x] 255 | Path (P -> P) ([c:P] encode A B a0 x (decode A B a0 x c)) (id P) 256 | = [A,B:U][a0:A][x:A + B][P : U = code A B a0 x] funext P P 257 | ([c:P] encode A B a0 x (decode A B a0 x c)) (id P) 258 | (encode_decode A B a0 x) ; 259 | 260 | HOTT_2_12_5 : [A,B:U][a0:A][x:A+B] equiv (Path (A+B) (inl a0) x) (code A B a0 x) 261 | = [A,B:U][a0:A][x:A+B] encode A B a0 x, 262 | ((decode A B a0 x, (encode_decode_inv A B a0 x)), 263 | (decode A B a0 x, (decode_encode_inv A B a0 x))) ; 264 | 265 | 266 | coproduct_injectivity : [A,B:U][a0,a1:A] Path (A+B) (inl a0) (inl a1) -> Path A a0 a1 267 | = [A,B:U][a0,a1:A] encode A B a0 (inl a1) ; 268 | 269 | coproduct_disjointness : [A,B:U][a0:A][b:B] Path (A+B) (inl a0) (inr b) -> empty 270 | = [A,B:U][a0:A][b:B] encode A B a0 (inr b) ; 271 | 272 | true_neq_false : Path bool false true -> empty 273 | = coproduct_disjointness unit unit tt tt; 274 | 275 | -------------------------------------------------------------------------------- /examples/simple.ctt: -------------------------------------------------------------------------------- 1 | 2 | 3 | A : U ; 4 | B : U ; 5 | a : A ; 6 | b : B ; 7 | 8 | c1 : A * B ; 9 | c2 : A * B ; 10 | i : I; 11 | 12 | c3 : [i = 0 -> c1 | i = 1 -> c2](A * B) ; 13 | 14 | -- These shall not be accepted, as it makes no sense to write iterated systems, 15 | -- and if I use a variable for the inner system, it already has to type-check, 16 | -- which excludes these "wrong" inner systems 17 | -- T : [i = 0 -> N | i = 1 -> N * ([i = 0 -> Z | i = 1 -> N])]U ; 18 | -- t : [i = 0 -> [i = 0 -> S Z | i = 1 -> N]]N ; -------------------------------------------------------------------------------- /examples/sum.ctt: -------------------------------------------------------------------------------- 1 | idN : N -> U = [x:N]N ; 2 | 3 | zero : N = ind idN Z ([n:N][m:N]Z) Z ; 4 | 5 | succ : N -> N = [n : N] ind idN (S Z) ([n':N][m:N]S m) n ; 6 | 7 | plus : N -> N -> N = [m : N][n : N] ind idN m ([n':N][mPlusn:N]S mPlusn) n ; 8 | 9 | 10 | curry : [A:U][B:U][C:U] ((A * B) -> C) -> A -> B -> C = 11 | [A:U][B:U][C:U][f : (A * B) -> C][a:A][b:B] f (a,b) ; 12 | uncurry : [A:U][B:U][C:U] (A -> B -> C) -> (A * B) -> C = 13 | [A:U][B:U][C:U][g : A -> B -> C][p: A * B] g (p.1) (p.2) ; 14 | 15 | prod : U -> U -> U = [A:U][B:U][x:N] ind ([y:N]U) A ([n:N][p:U]B) x ; 16 | pi1 : [A:U][B:U] prod A B -> A = [A:U][B:U][p : prod A B] p Z ; 17 | pi2 : [A:U][B:U] prod A B -> B = [A:U][B:U][p : prod A B] p (S Z) ; 18 | couple : [A:U][B:U] A -> B -> prod A B = [A:U][B:U][a:A][b:B][x:N] ind ([y:N]ind ([z:N]U) A ([n:N][p:U]B) y) a ([n:N][p:ind ([w:N]U) A ([m:N][q:U]B) n] b) x; 19 | 20 | NpN : U = prod N N ; 21 | couple13 : NpN = couple N N (S Z) (S (S (S Z))) ; 22 | 23 | prod2sum : [A:U][B:U] prod A B -> A * B = [A:U][B:U][p : prod A B] 24 | (pi1 A B p,pi2 A B p) ; 25 | 26 | sum2prod : [A:U][B:U] (A * B) -> prod A B = [A:U][B:U] 27 | uncurry A B (prod A B) (couple A B) ; 28 | 29 | couple13' : N * N = prod2sum N N couple13 ; 30 | 31 | couple' : [A:U][B:U] (A * B) -> prod A B = [A:U][B:U] 32 | uncurry A B (prod A B) (couple A B); 33 | 34 | couple'' : [AB:U * U] AB.1 -> AB.2 -> prod AB.1 AB.2 = [AB:U * U] 35 | [x : AB.1][y : AB.2] couple AB.1 AB.2 x y ; 36 | 37 | couple13'' : NpN = couple'' ((N,N)) couple13'.1 couple13'.2 ; 38 | 39 | 40 | ------------- 41 | 42 | --These need eta-conversion 43 | 44 | AC : [A:U][B:U][C:A -> B -> U]([x:A] C x y) -> B>[x:A] C x (f x) = 45 | [A:U][B:U][C:A -> B -> U][h : [x:A] C x y] 46 | (([x:A](h x).1),([x:A](h x).2)) ; 47 | 48 | indSigma : [A:U][B:A->U][C:(B x)->U]([a:A][b:B a]C (a,b)) -> [p:B x] C p = 49 | [A:U][B:A->U][C:(B x)->U][h:[a:A][b:B a]C((a,b))][p:B x] 50 | h p.1 p.2; 51 | 52 | recSigma : [A:U][B:U][C:A*B->U]([a:A][b:B]C (a,b)) -> [p:A*B] C p = 53 | [A:U][B:U][C:A*B->U][h:[a:A][b:B]C (a,b)] indSigma A (A->B) C h ; 54 | 55 | 56 | ------------- 57 | 58 | i : I ; 59 | 60 | rs : [i = 0 -> (S Z, S (S Z)) | i = 1 -> couple13'] (N*N) ; 61 | -------------------------------------------------------------------------------- /examples/unit.ctt: -------------------------------------------------------------------------------- 1 | Path : [A : U] A -> A -> U = 2 | [A : U][a0 : A][a1 : A][i : I] [(i = 0) -> a0 | (i = 1) -> a1] A ; 3 | 4 | refl : [A : U][a : A] Path A a a = [A : U][a : A][i : I] a ; 5 | 6 | const : [A:U]I -> U = [A:U][i:I]A ; 7 | 8 | indSigma : [A:U][B:A->U][C:(B x)->U]([a:A][b:B a]C (a,b)) -> [p:B x] C p = 9 | [A:U][B:A->U][C:(B x)->U][h:[a:A][b:B a]C((a,b))][p:B x] 10 | h p.1 p.2; 11 | 12 | recSigma : [A:U][B:U][C:A*B->U]([a:A][b:B]C (a,b)) -> [p:A*B] C p = 13 | [A:U][B:U][C:A*B->U][h:[a:A][b:B]C (a,b)] indSigma A (A->B) C h ; 14 | 15 | funext : [A,B:U][f,g:A -> B] ([x:A] Path B (f x) (g x)) -> Path (A -> B) f g = 16 | [A,B:U][f,g:A -> B][p:[x:A] Path B (f x) (g x)][i:I][x:A] (p x i) ; 17 | 18 | dfunext : [A:U][B:A -> U][f,g:[x:A] B x]([x:A] Path (B x) (f x) (g x)) -> Path ([x:A] B x) f g = 19 | [A:U][B:A -> U][f,g:[x:A] B x][p:[x:A] Path (B x) (f x) (g x)][i:I][x:A] (p x i) ; 20 | 21 | transp : [F : I -> U] F 0 -> F 1 = [F : I -> U][a0 : F 0] 22 | comp F () 0 (I -> []) a0 1 ; 23 | 24 | transp' : [F : I -> U][i0,i1:I] F i0 -> F i1 = [F : I -> U][i0,i1:I][a0 : F i0] 25 | comp F () i0 (I -> []) a0 i1 ; 26 | 27 | transport : [B : U][P : B -> U][x : B][y : B][pB : Path B x y] P x -> P y = 28 | [B : U][P : B -> U][x : B][y : B][pB : Path B x y][u : P x] 29 | transp ([i : I] P (pB i)) u ; 30 | 31 | invFill : [A:U][a,b:A][p:Path A a b][i,j:I][j = 0 -> a | i = 0 -> p j | i = 1 -> a]A 32 | = [A:U][a,b:A][p:Path A a b][i,j:I] 33 | comp (const A) (i = 0 \/ i = 1) 0 ([j':I][i = 0 -> p j' | i = 1 -> a]) a j ; 34 | 35 | inv : [A:U][a,b:A] Path A a b -> Path A b a = [A:U][a,b:A][p:Path A a b] 36 | [i:I] (comp (const A) (i = 0 \/ i = 1) 0 ([j:I][i = 0 -> p j | i = 1 -> a]) a 1) ; 37 | 38 | ii : I ; 39 | 40 | unit : U = [ii = ii -> Z]N ; 41 | 42 | tt : unit = Z ; 43 | 44 | unitInd : [C:unit -> U] C tt -> [x:unit] C x 45 | = [C:unit -> U][p: C tt][x:unit] p ; 46 | 47 | unitEq : [x:unit] Path unit tt x 48 | = [x:unit] unitInd ([y:unit] Path unit tt y) (refl unit tt) x ; 49 | 50 | 51 | bool : U = unit + unit ; 52 | 53 | false : bool = inl tt ; 54 | true : bool = inr tt ; 55 | 56 | boolInd : [C:bool -> U] C false -> C true -> [x:bool] C x 57 | = [C:bool -> U][cf:C false][ct:C true][x:bool] 58 | split C ([u:unit] unitInd ([u':unit] C (inl u')) cf u) ([u:unit] unitInd ([u':unit] C (inr u')) ct u) x ; 59 | 60 | boolRec : [C:U] C -> C -> bool -> C 61 | = [C:U][iff:C][ift:C][x:bool] boolInd (bool -> C) iff ift x ; 62 | 63 | If : [C:U] bool -> C -> C -> C = [C:U][x:bool][ift:C][iff:C] boolRec C iff ift x ; 64 | 65 | not : bool -> bool 66 | = [b:bool] If bool b false true ; 67 | 68 | and : bool -> bool -> bool 69 | = [b1,b2:bool] If bool b1 b2 false ; 70 | 71 | or : bool -> bool -> bool 72 | = [b1,b2:bool] not (and (not b1) (not b2)) ; 73 | 74 | nat_eq : N -> N -> bool 75 | = [m:N] ind (N -> N -> bool) ([n:N] ind (N -> bool) true (N -> bool -> false) n) 76 | ([m':N][IH:N -> bool][n:N] ind (N -> bool) false ([n':N] bool -> IH n') n) m; 77 | 78 | nat_neq : N -> N -> bool 79 | = [m,n:N] not (nat_eq m n) ; 80 | 81 | nat_leq : N -> N -> bool 82 | = [m:N] ind (N -> N -> bool) (N -> true) 83 | ([m':N][IH:N -> bool][n:N] ind (N -> bool) false ([n':N] bool -> IH n') n) m; 84 | 85 | nat_le : N -> N -> bool 86 | = [m,n:N] and (nat_leq m n) (nat_neq m n) ; 87 | 88 | empty : U = [X:U] X ; 89 | 90 | emptyRec : [C:empty -> U][z:empty] C z 91 | = [C:empty -> U][z:empty] z (C z) ; 92 | 93 | finiteSet : N -> U 94 | = [n : N] ind (N -> U) empty ([m:N][mFin:U] mFin + unit) n ; 95 | 96 | 97 | Fin : N -> U 98 | = [n:N] If U (nat_leq k n) unit empty ; 99 | 100 | zero_one : Fin (S Z) = Z,tt ; 101 | zero_two : Fin (S (S Z)) = Z,tt ; 102 | one_two : Fin (S (S Z)) = S Z,tt ; 103 | 104 | fcomp : [A,B,C:U][f:B -> C][g:A -> B] A -> C 105 | = [A,B,C:U][f:B -> C][g:A -> B][a:A] f (g a) ; 106 | 107 | id : [A:U] A -> A = [A:U][x:A] x ; 108 | 109 | isEquiv : [A,B:U] (A -> B) -> U 110 | = [A,B:U][f:A -> B] ( A> Path (B -> B) (fcomp B A B f g) (id B)) * ( A> Path (A -> A) (fcomp A B A h f) (id A)) ; 111 | 112 | equiv : U -> U -> U 113 | = [A,B:U] B> isEquiv A B f; 114 | 115 | Lemma_2_4_12a : [A:U] isEquiv A A (id A) 116 | = [A:U] (id A,refl (A -> A) (id A)),(id A,refl (A -> A) (id A)) ; 117 | 118 | 119 | 120 | prod : U -> U -> U = [A,B:U][x:bool] boolRec U A B x ; 121 | couple : [A,B:U] A -> B -> prod A B = [A,B:U][a:A][b:B] 122 | boolInd ([x:bool] boolRec U A B x) a b ; 123 | pi1 : [A,B:U] prod A B -> A = [A,B:U][p : prod A B] p false ; 124 | pi2 : [A,B:U] prod A B -> B = [A,B:U][p : prod A B] p true ; 125 | 126 | prodEta : [A,B:U][p:prod A B] Path (prod A B) (couple A B (pi1 A B p) (pi2 A B p)) p 127 | = [A,B:U][p:prod A B] dfunext bool ([x:bool] boolRec U A B x) (couple A B (pi1 A B p) (pi2 A B p)) p 128 | (boolInd 129 | ([y:bool] Path (boolRec U A B y) (couple A B (pi1 A B p) (pi2 A B p) y) (p y)) 130 | (refl A (p false)) 131 | (refl B (p true)) 132 | ) ; 133 | 134 | prodInd : [A,B:U][C: prod A B -> U]([a:A][b:B] C (couple A B a b)) -> [p:prod A B] C p 135 | = [A,B:U][C: prod A B -> U][f:[a:A][b:B] C (couple A B a b)][p:prod A B] 136 | transport (prod A B) C (couple A B (pi1 A B p) (pi2 A B p)) p (prodEta A B p) (f (pi1 A B p) (pi2 A B p)) ; 137 | 138 | to : [A,B:U] A * B -> prod A B = [A,B:U][p:A * B] 139 | couple A B (p.1) (p.2) ; 140 | 141 | from : [A,B:U] prod A B -> A * B = [A,B:U][p:prod A B] 142 | (pi1 A B p , pi2 A B p) ; 143 | 144 | -- to A B (from A B (couple A B a b)) == to A B (pi1 A B (couple A B a b),pi2 A B (couple A B a b)) == to A B (a,b) == couple A B a b 145 | 146 | to_from' : [A,B:U][p:prod A B] Path (prod A B) (to A B (from A B p)) p 147 | = [A,B:U] prodInd A B ([p':prod A B] Path (prod A B) (to A B (from A B p')) p') 148 | ([a:A][b:B] refl (prod A B) (couple A B a b)) ; 149 | 150 | to_from : [A,B:U] Path (prod A B -> prod A B) 151 | (fcomp (prod A B) (A * B) (prod A B) (to A B) (from A B)) (id (prod A B)) 152 | = [A,B:U] funext (prod A B) (prod A B) 153 | (fcomp (prod A B) (A * B) (prod A B) (to A B) (from A B)) (id (prod A B)) 154 | (to_from' A B) ; 155 | 156 | from_to' : [A,B:U][p:A*B] Path (A*B) (from A B (to A B p)) p 157 | = [A,B:U] recSigma A B ([p':A*B] Path (A*B) (from A B (to A B p')) p') 158 | ([a:A][b:B] refl (A*B) (a,b)) ; 159 | 160 | from_to : [A,B:U] Path (A * B -> A * B) 161 | (fcomp (A*B) (prod A B) (A*B) (from A B) (to A B)) (id (A*B)) 162 | = [A,B:U] funext (A * B) (A * B) 163 | (fcomp (A*B) (prod A B) (A*B) (from A B) (to A B)) (id (A*B)) 164 | (from_to' A B) ; 165 | 166 | prodEquiv : [A,B:U] equiv (A * B) (prod A B) 167 | = [A,B:U] (to A B,((from A B,to_from A B),(from A B,from_to A B))) ; 168 | 169 | 170 | 171 | A : U ; 172 | a : A ; 173 | b : A ; 174 | p : Path A a b ; 175 | 176 | p' : [j:I][j=0 -> a][j = 1 -> b]A = p ; 177 | -------------------------------------------------------------------------------- /tesi.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mattia-furlan/MasterThesisCTT/4a5d1821c61d7897a48adfa19e53b5608cf71db7/tesi.pdf --------------------------------------------------------------------------------