fork download 
  1. module Main where
  2.  
  3.     import Control.Monad.Identity
  4.     import Text.Parsec
  5.  
  6.     data Term = Var String
  7.       | Idx Int
  8.       | Abs Term
  9.       | App Term Term
  10.  
  11.     avnames = map (\x -> [x]) "abcdexyzuw"
  12.     names = avnames ++ map ('\'' :) names
  13.  
  14.     nameidx i n (Abs t) = Abs (nameidx (i + 1) n t)
  15.     nameidx i n (App x y) = App (nameidx i n x) (nameidx i n y)
  16.     nameidx i n (Idx d)
  17.       | i == d = Var n
  18.       | otherwise = Idx d
  19.     nameidx _ _ v = v
  20.  
  21.     markfree (Abs t) = Abs (markfree t)
  22.     markfree (App x y) = App (markfree x) (markfree y)
  23.     markfree (Var s) = Var ('*' : s)
  24.     markfree i = i
  25.  
  26.     showTerm :: [String] -> Term -> ShowS
  27.     showTerm (n:ns) (Abs t) =
  28.           ("(\\" ++)
  29.         . showString n
  30.         . (". " ++)
  31.         . showTerm ns (nameidx 0 n t)
  32.         . (")" ++)
  33.     showTerm ns (App x y) =
  34.           ("(" ++)
  35.         . showTerm ns x
  36.         . (" " ++)
  37.         . showTerm ns y
  38.         . (")" ++)
  39.     showTerm ns (Idx i) = ('#' :) . (show i ++)
  40.     showTerm ns (Var s) = (s ++)
  41.  
  42.     instance Show Term where
  43.         show t = showTerm names (markfree t) $ []
  44.  
  45.     type Eval a = Identity a
  46.  
  47.     runEval :: Eval Term -> Term
  48.     runEval = runIdentity
  49.  
  50.     eval :: Term -> Eval Term
  51.     eval (App x y) = do
  52.         x' <- eval x
  53.         case x' of
  54.           (Abs t) -> eval (subst 0 t y)
  55.           proc -> return (App proc y)
  56.     eval other = return other
  57.  
  58.     subst :: Int -> Term -> Term -> Term
  59.     subst i (Idx d) s
  60.       | d == i = s
  61.       | otherwise = Idx d
  62.     subst i (App x y) s = App (subst i x s) (subst i y s)
  63.     subst i (Var x) s = Var x
  64.     subst i (Abs t) s = Abs (subst (i + 1) t s)
  65.  
  66.     setidx :: String -> Int -> Term -> Term
  67.     setidx name i (App x y) = App (setidx name i x) (setidx name i y)
  68.     setidx name i (Abs t) = Abs (setidx name (i + 1) t)
  69.     setidx name i (Var n)
  70.       | name == n = Idx i
  71.       | otherwise = Var n
  72.     setidx _ _ t = t
  73.  
  74.     setVariable :: String -> Term -> Term -> Term
  75.     setVariable name t' (App x y) =
  76.         App (setVariable name t' x) (setVariable name t' y)
  77.     setVariable name t' (Abs t) = Abs (setVariable name t' t)
  78.     setVariable name t' (Var s)
  79.       | s == name = t'
  80.       | otherwise = Var s
  81.     setVariable _ _ other = other
  82.  
  83.     identifier :: Parsec String () String
  84.     identifier = many1 alphaNum
  85.  
  86.     lambda :: Parsec String () Term
  87.     lambda = do
  88.         char '('
  89.         char '\\'
  90.         spaces
  91.         varname <- identifier
  92.         spaces
  93.         char '.'
  94.         t <- term
  95.         char ')'
  96.         return $ Abs (setidx varname 0 t)
  97.  
  98.     single :: Parsec String () Term
  99.     single = (spaces >>) $ try (fmap Var identifier) <|> try lambda <|> application
  100.  
  101.     application :: Parsec String () Term
  102.     application = do
  103.         char '('
  104.         f <- term
  105.         char ')'
  106.         return f
  107.  
  108.     substitution :: Parsec String () (String, Term)
  109.     substitution = do
  110.         char '['
  111.         spaces
  112.         varname <- identifier
  113.         spaces
  114.         string "->"
  115.         t <- term
  116.         char ']'
  117.         return (varname, t)
  118.  
  119.     term :: Parsec String () Term
  120.     term = do
  121.         spaces
  122.         sub <- try (optionMaybe substitution)
  123.         t <- try (fmap (foldl1 App) (many1 single))
  124.         case sub of
  125.             Nothing -> return t
  126.             Just (var, t') -> return (setVariable var t' t)
  127.  
  128.     lambdaEval str =
  129.         case parse term "lambda" str of
  130.             Right t -> Right $ runEval (eval t)
  131.             Left e -> Left e
  132.  
  133.     loop :: IO ()
  134.     loop = do
  135.       x <- getLine
  136.       case x of
  137.           ":end" -> return ()
  138.           str -> putStr "> " >> print (lambdaEval x) >> loop
  139.  
  140.     main :: IO ()
  141.     main = do
  142.         putStrLn "Lambda-Expressions Evaluator.\n> "
  143.         loop
Not running #stdin #stdout 0s 0KB
comments (?)
stdin 
Standard input is empty
stdout 
Standard output is empty
https://ideone.com/vOQTy
language:
Haskell (ghc 8.4.4)
created:
14 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!