103 lines
3.1 KiB
Haskell
103 lines
3.1 KiB
Haskell
{-# LANGUAGE GADTs #-}
|
|
|
|
module Expr where
|
|
|
|
import Data.Function (on)
|
|
import Data.List (genericDrop)
|
|
|
|
data Expr where
|
|
Var :: Integer -> Expr
|
|
Star :: Expr
|
|
Square :: Expr
|
|
App :: Expr -> Expr -> Expr
|
|
Abs :: Expr -> Expr -> Expr
|
|
Pi :: Expr -> Expr -> Expr
|
|
deriving (Show, Eq)
|
|
|
|
occursFree :: Integer -> Expr -> Bool
|
|
occursFree n (Var k) = n == k
|
|
occursFree _ Star = False
|
|
occursFree _ Square = False
|
|
occursFree n (App a b) = occursFree n a || occursFree n b
|
|
occursFree n (Abs a b) = occursFree n a || occursFree (n + 1) b
|
|
occursFree n (Pi a b) = occursFree n a || occursFree (n + 1) b
|
|
|
|
{- --------------------- PRETTY PRINTING ----------------------------- -}
|
|
|
|
-- TODO : store parsed identifiers for better printing
|
|
genName :: Integer -> String
|
|
genName k = case genericDrop k ["x", "y", "z", "w", "u", "v"] of
|
|
[] -> 'x' : show (k - 6)
|
|
(v : _) -> v
|
|
|
|
pretty :: Expr -> String
|
|
pretty = helper 0
|
|
where
|
|
helper :: Integer -> Expr -> String
|
|
helper k (Var n) = genName $ k - n - 1
|
|
helper _ Star = "*"
|
|
helper _ Square = "□"
|
|
helper k (App e1 e2) = "(" ++ helper k e1 ++ " " ++ helper k e2 ++ ")"
|
|
helper k (Abs ty b) =
|
|
"(λ" ++ genName k ++ " : " ++ helper k ty ++ " . " ++ helper (k + 1) b ++ ")"
|
|
helper k (Pi ty b) =
|
|
if occursFree 0 b
|
|
then
|
|
"(∏" ++ genName k ++ " : " ++ helper k ty ++ " . " ++ helper (k + 1) b ++ ")"
|
|
else "(" ++ helper k ty ++ " -> " ++ helper (k + 1) b ++ ")"
|
|
|
|
{- --------------- ACTUAL MATH STUFF ---------------- -}
|
|
|
|
isSort :: Expr -> Bool
|
|
isSort Star = True
|
|
isSort Square = True
|
|
isSort _ = False
|
|
|
|
mapIndices :: (Integer -> Expr) -> Expr -> Expr
|
|
mapIndices f (Var n) = f n
|
|
mapIndices _ Star = Star
|
|
mapIndices _ Square = Square
|
|
mapIndices f (App m n) = App (mapIndices f m) (mapIndices f n)
|
|
mapIndices f (Abs m n) = Abs (mapIndices f m) (mapIndices f n)
|
|
mapIndices f (Pi m n) = Pi (mapIndices f m) (mapIndices f n)
|
|
|
|
incIndices :: Expr -> Expr
|
|
incIndices = mapIndices (Var . (+ 1))
|
|
|
|
decIndices :: Expr -> Expr
|
|
decIndices = mapIndices (Var . subtract 1)
|
|
|
|
-- substitute 0 for s *AND* decrement indices; only use after reducing a redex.
|
|
subst :: Expr -> Expr -> Expr
|
|
subst s (Var 0) = s
|
|
subst _ (Var n) = Var $ n - 1
|
|
subst _ Star = Star
|
|
subst _ Square = Square
|
|
subst s (App m n) = App (subst s m) (subst s n)
|
|
subst s (Abs m n) = Abs (subst s m) (subst s n)
|
|
subst s (Pi m n) = Pi (subst s m) (subst s n)
|
|
|
|
substnd :: Expr -> Expr -> Expr
|
|
substnd s (Var n) = if n == 0 then s else Var n
|
|
substnd _ Star = Star
|
|
substnd _ Square = Square
|
|
substnd s (App m n) = App (substnd s m) (substnd s n)
|
|
substnd s (Abs m n) = Abs (substnd s m) (substnd s n)
|
|
substnd s (Pi m n) = Pi (substnd s m) (substnd s n)
|
|
|
|
betaReduce :: Expr -> Expr
|
|
betaReduce (Var k) = Var k
|
|
betaReduce Star = Star
|
|
betaReduce Square = Square
|
|
betaReduce (App (Abs _ v) n) = subst n v
|
|
betaReduce (App m n) = App (betaReduce m) (betaReduce n)
|
|
betaReduce (Abs t v) = Abs (betaReduce t) (betaReduce v)
|
|
betaReduce (Pi t v) = Pi (betaReduce t) (betaReduce v)
|
|
|
|
betaNF :: Expr -> Expr
|
|
betaNF e = if e == e' then e else betaNF e'
|
|
where
|
|
e' = betaReduce e
|
|
|
|
betaEquiv :: Expr -> Expr -> Bool
|
|
betaEquiv = on (==) betaNF
|