Universal Lambda Machine: Difference between revisions

← Older edit Newer edit →

Content deleted Content added

Inline

@@ Line 255: / Line 255: @@
 =={{header|Haskell}}==
-A bit-wise only ULM in (obfuscated) Haskell:
+A bit-wise only ULM:
-<syntaxhighlight lang="haskell">import Control.Applicative hiding((<|>),many)
+<syntaxhighlight lang="haskell">
-import Text.Parsec
 import System.IO
+import Data.List
-data W=S!Char|F(W->W)
+import Text.Parsec
-f=c$F id
+import Control.Applicative hiding ((<|>), many)
-c=F .const
-(F f)&w=f w
+data WHNF = SYM !Char | FUN (WHNF -> WHNF)
-a x y v=x v&y v
-l e v=F$ \a->e(a:v)
+fun :: WHNF -> WHNF -> WHNF
-q x y=F$ \z->z&x&y
+fun (SYM c) _ = error $ "Cannot apply symbol " ++ [c]
-b n=if even n then F c else f
-s w=c where(S c)=w&S '0'&S '1'
+fun (FUN f) w = f w
-o p=map s.g.(p[]&).foldr(q.b.fromEnum)f
+expr :: Monad m => ParsecT String u m ([WHNF] -> WHNF)
-g l=case (l&c(c.S$':'))of{S ':'->l&F c:g(l&f);F _->[]}
-x=char '0'*>(l<$char '0'<*>x<|>a<$char '1'<*>x<*>x)<|>flip(!!)<$>pred.length<$>many(char '1')<*char '0'
+expr = char '0' *> (buildLambda <$ char '0' <*> expr
+               <|>  buildApply  <$ char '1' <*> expr <*> expr)
-main=hSetBuffering stdout NoBuffering>>interact(either(error.show)id.parse(o<$>x<*>getInput)"")</syntaxhighlight>
+               <|> buildVar <$> pred.length <$> many (char '1') <* char '0' where
+    buildLambda e env = FUN $ \arg -> e (arg:env)
+    buildApply e1 e2 env = e1 env `fun` e2 env
+    buildVar n env = env !! n
+buildIO prog = whnfToString . (prog [] `fun` ) . stringToWhnf where
+    stringToWhnf :: [Char] -> WHNF
+    stringToWhnf = foldr (whnfCons . bitToWhnf . fromEnum) whnfFalse where
+        bitToWhnf :: Integral a => a -> WHNF
+        bitToWhnf n = if even n then whnfTrue else whnfFalse
+        whnfCons :: WHNF -> WHNF -> WHNF
+        whnfCons fw gw = FUN $ \hw -> hw `fun` fw `fun` gw
+    whnfToString = map whnfToChar . whnfToList where
+        cons2sym :: WHNF
+        cons2sym = whnfConst . whnfConst $ SYM ':'
+        whnfToList :: WHNF -> [WHNF]
+        whnfToList l = case (l `fun` cons2sym) of
+               SYM ':' -> l `fun` whnfTrue : whnfToList (l `fun` whnfFalse)
+               FUN  _  -> []
+        whnfToChar :: WHNF -> Char
+        whnfToChar iw = c where (SYM c) = iw `fun` SYM '0' `fun` SYM '1'
+    whnfConst :: WHNF -> WHNF
+    whnfConst = FUN . const
+    whnfTrue :: WHNF
+    whnfTrue  = FUN whnfConst
+    whnfFalse :: WHNF
+    whnfFalse = whnfConst $ FUN id
+main = do
+    hSetBuffering stdout NoBuffering
+    interact $ either (error . show) id . parse (buildIO <$> expr <*> getInput) ""
+</syntaxhighlight>
 Feel free to replace this by a solution for both bit-wise and byte-wise.