Created
May 7, 2014 18:12
-
-
Save MarcusVoelker/061b96c2010bd9ab4c9b to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module Main where | |
data SK = S | K | App SK SK deriving Eq | |
data CC = CCAtom Combinator | CCApp CC CC | |
data Combinator = Comb String SK deriving Eq | |
data BaseCombinator = BC String CC | |
data CombinatorDef = CombDef String [Char] DefBody deriving Show | |
data DefBody = DefAtom Char | DefApp DefBody DefBody | |
instance Show SK where | |
show S = "S" | |
show K = "K" | |
show (App l r) = "(" ++ show l ++ show r ++ ")" | |
instance Show Combinator where | |
show (Comb s d) = s ++ " = " ++ show d | |
instance Show BaseCombinator where | |
show (BC s d) = s ++ " = " ++ show d | |
instance Show DefBody where | |
show (DefAtom x) = [x] | |
show (DefApp l r) = '\'':show l ++ show r | |
s = Comb "S" S | |
k = Comb "K" K | |
i = Comb "I" (App (App S K) K) | |
instance Show CC where | |
show (CCAtom (Comb s _)) = s | |
show (CCApp ca cb) = "(" ++ show ca ++ show cb ++")" | |
parseDefBody :: String -> ((DefBody,String) -> r) -> (String -> r) -> r | |
parseDefBody [] _ error = error "Expected Token!" | |
parseDefBody ('\'':xs) ok error = parseDefBody xs (\(d,s) -> parseDefBody s (\(d',s') -> ok (DefApp d d', s')) error) error | |
parseDefBody (x:xs) ok error = ok $ (DefAtom x, xs) | |
parseCombDef :: String -> ((CombinatorDef,String) -> r) -> (String -> r) -> r | |
parseCombDef xs ok error = parseStringTo ':' xs (\(n,':':s) -> parseStringTo '=' s (\(l,'=':s) -> parseDefBody s (\(d,s) -> ok ((CombDef n l d),s)) error) error) error | |
parseStringTo :: Char -> String -> ((String,String) -> r) -> (String -> r) -> r | |
parseStringTo c [] _ error = error $ "Expected '" ++ [c] ++ "'!" | |
parseStringTo c (x:xs) ok error | c == x = ok ("",(x:xs)) | |
parseStringTo c (x:xs) ok error = parseStringTo c xs (\(s,r) -> ok ((x:s),r)) error | |
translateComb :: CombinatorDef -> Combinator | |
translateComb (CombDef n l d) = Comb n (translateBody l d) | |
translateBody :: [Char] -> DefBody -> SK | |
translateBody xs b = simplify . skify $ foldr reduce b xs | |
reduce :: Char -> DefBody -> DefBody | |
reduce c (DefAtom c') | c == c' = DefAtom 'I' | |
reduce c (DefAtom c') = DefApp (DefAtom 'K') (DefAtom c') | |
reduce c (DefApp r (DefAtom c')) | (c == c') && (not $ contained c r) = r | |
reduce c b | not $ contained c b = DefApp (DefAtom 'K') b | |
reduce c (DefApp l r) = DefApp (DefApp (DefAtom 'S') (reduce c l)) (reduce c r) | |
contained :: Char -> DefBody -> Bool | |
contained c (DefAtom c') = c == c' | |
contained c (DefApp l r) = contained c l || contained c r | |
skify :: DefBody -> SK | |
skify (DefAtom 'I') = App (App S K) K | |
skify (DefAtom 'K') = K | |
skify (DefAtom 'S') = S | |
skify (DefApp l r) = App (skify l) (skify r) | |
simplify :: SK -> SK | |
simplify K = K | |
simplify S = S | |
simplify (App (App K x) _) = simplify x | |
simplify (App (App (App S x) y) z) = simplify (App (App x z) (App y z)) | |
simplify (App l r) = App (simplify l) (simplify r) | |
replace :: [Combinator] -> SK -> CC | |
replace _ K = CCAtom k | |
replace _ S = CCAtom s | |
replace cs sk | any (cmatch sk) cs = creplace sk cs | |
replace cs (App l r) = CCApp (replace cs l) (replace cs r) | |
cmatch :: SK -> Combinator -> Bool | |
cmatch sk (Comb _ b) = sk == b | |
creplace :: SK -> [Combinator] -> CC | |
creplace sk (c:cs) | cmatch sk c = CCAtom c | |
creplace sk (_:cs) = creplace sk cs | |
parseComb s = translateComb $ parseCombDef s fst (const $ CombDef "ERROR" "ERROR" $ DefAtom ' ') | |
parseSK :: String -> ((SK,String) -> r) -> r | |
parseSK ('\'':r) ok = parseSK r (\(sk,s) -> parseSK s (\(sk',s') -> ok (App sk sk', s'))) | |
parseSK ('S':r) ok = ok (S,r) | |
parseSK ('K':r) ok = ok (K,r) | |
basedParse :: [Combinator] -> String -> BaseCombinator | |
basedParse cs s = (\(Comb n sk) -> BC n (replace cs sk)) $ parseComb s | |
intLoop :: [Combinator] -> IO ([Combinator]) | |
intLoop cs = do | |
putStrLn "Enter Combinator:" | |
c <- getLine | |
let bc = basedParse cs c | |
let nc = parseComb c | |
putStrLn (show bc) | |
intLoop (nc:cs) | |
main :: IO() | |
main = intLoop [] >>= (const $ return ()) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment