|
|
|
@ -4,8 +4,51 @@ module Lambda where
|
|
|
|
|
import Eval |
|
|
|
|
import System.IO |
|
|
|
|
|
|
|
|
|
import Text.ParserCombinators.ReadP |
|
|
|
|
import Data.Char |
|
|
|
|
import Control.Monad |
|
|
|
|
|
|
|
|
|
data Term = Const Int | Prim Card | Seq Term Term | Apply Term Term |
|
|
|
|
|
|
|
|
|
cardNamesX = map (\(a,b) -> (b,a)) cardNames |
|
|
|
|
|
|
|
|
|
ptConst :: ReadP Term |
|
|
|
|
ptConst = readS_to_P reads >>= return . Const |
|
|
|
|
ptPrim = do |
|
|
|
|
c <- satisfy isAlpha |
|
|
|
|
s' <- many (satisfy isAlpha) |
|
|
|
|
let s = c:s' |
|
|
|
|
case lookup s cardNamesX of |
|
|
|
|
Just c -> return $ Prim c |
|
|
|
|
Nothing -> pfail |
|
|
|
|
ptGroup = do |
|
|
|
|
char '(' |
|
|
|
|
t <- ptTerm |
|
|
|
|
skipSpaces; char ')' |
|
|
|
|
return t |
|
|
|
|
ptEnd = eof <++ do |
|
|
|
|
c:_ <- look |
|
|
|
|
when (isAlphaNum c || c == ';' || c == '(') pfail |
|
|
|
|
ptApply f = do |
|
|
|
|
skipSpaces |
|
|
|
|
(ptEnd >> return f) <++ |
|
|
|
|
(char ';' >> ptTerm >>= \g -> return $ Seq f g) <++ |
|
|
|
|
(ptTerm1 >>= \x -> ptApply (Apply f x)) |
|
|
|
|
ptTerm1 = skipSpaces >> (ptConst <++ ptPrim <++ ptGroup) |
|
|
|
|
|
|
|
|
|
ptTerm = ptTerm1 >>= ptApply |
|
|
|
|
|
|
|
|
|
instance Show Term where |
|
|
|
|
show (Const i) = show i |
|
|
|
|
show (Prim c) = show c |
|
|
|
|
show (Seq f g) = show f ++ ";" ++ show g |
|
|
|
|
show (Apply f (Const i)) = show f ++ " " ++ show i |
|
|
|
|
show (Apply f (Prim c)) = show f ++ " " ++ show c |
|
|
|
|
show (Apply f x) = show f ++ "(" ++ show x ++ ")" |
|
|
|
|
|
|
|
|
|
instance Read Term where |
|
|
|
|
readsPrec _ = readP_to_S ptTerm |
|
|
|
|
|
|
|
|
|
cI = Prim Card_I |
|
|
|
|
cGet n = Apply (Prim Card_Get) (Const n) |
|
|
|
|
cPut = Prim Card_Put |
|
|
|
|