Skip to content

Instantly share code, notes, and snippets.

@L8D

L8D/rl.hs

Last active Aug 29, 2015
Embed
What would you like to do?
Function{al,ing} RL interpreter written in Haskell
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
import System.Environment (getArgs)
import System.Exit (ExitCode(..), exitWith)
import Data.Maybe (listToMaybe, fromMaybe)
import Data.Fixed (mod', div')
showDouble :: Double -> String
showDouble n = if n `mod'` 1 == 0 then show (n `div'` 1) else show n
maybeRead :: Read a => String -> Maybe a
maybeRead s0 = listToMaybe [a | (a,s1) <- reads s0,("","") <- lex s1]
eitherRead :: Read a => String -> Either String a
eitherRead x = maybe (Left x) Right $ maybeRead x
newtype Dict = Dict [(String, Runner)]
type Runner = Dict -> [Double] -> [Either String Double] -> IO [Double]
run :: Runner
run d s (Right x:xs) = run d (x:s) xs
run d s (Left x:xs) = word x d s xs
run _ s [] = return s
find :: Dict -> String -> [Double] -> [Either String Double] -> IO [Double]
find (Dict d) w = fromMaybe (error $ "unknown word " ++ w) (lookup w d) $ Dict d
word :: String -> Dict -> [Double] -> [Either String Double] -> IO [Double]
word ":" d xs (Left w:ws) = define d xs w ws
word "bye" _ _ _ = return [0]
word w d xs ws = find d w xs ws
define :: Dict -> [Double] -> String -> [Either String Double] -> IO [Double]
define (Dict d) xs w ws = run (Dict $ (w, de):d) xs rest where
de (Dict d') xs' ws' = run (Dict $ (w, de):d') xs' (block ++ ws')
(block, _:rest) = break (== Left ";") ws
parse :: String -> [Either String Double]
parse = map eitherRead . words
source :: [String] -> IO String
source [] = getContents
source as = fmap concat $ mapM readFile as
exit :: Int -> IO a
exit 0 = exitWith ExitSuccess
exit n = exitWith $ ExitFailure n
main :: IO ()
main = getArgs
>>= source
>>= run library (repeat 0) . parse
>>= exit . (`div'` 1) . head
library :: Dict
library = Dict
( map (fmap iowrapper)
[ "." ~> \(x:xs) -> putStrLn (showDouble x) >> return xs
] ++ map (fmap wrapper)
[ "pick" ~> \(x:xs) -> (xs !! (x `div'` 1)):xs
, "roll" ~> \(x:xs) -> let n = (x `div'` 1)
(h, x:r) = splitAt (n - 1) xs
in x:h ++ r
-- : dup 0 pick ;
, "dup" ~> \(x:xs) -> x:x:xs
-- : 2dup 1 pick 1 pick ;
, "2dup" ~> \(x:x':xs) -> x:x':x:x':xs
-- : swap 1 roll ;
, "swap" ~> \(x:x':xs) -> x':x:xs
-- : over 1 pick ;
, "over" ~> \(x:x':xs) -> x':x:x':xs
-- : rot 2 roll ;
, "rot" ~> \(x:y:z:xs) -> z:x:y:xs
-- : tuck 1 roll 1 pick ;
, "tuck" ~> \(x:y:xs) -> x:y:x:xs
, "not" ~> \case (0:xs) -> 1:xs; (x:xs) -> 0:xs
, "drop" ~> tail
, "+" ~> op (+)
, "-" ~> op (-)
, "*" ~> op (*)
, "/" ~> op (/)
, "pow" ~> op (**)
, "mod" ~> op mod'
, ">" ~> bop (>)
, "<" ~> bop (<)
, "<=" ~> bop (<=)
, ">=" ~> bop (>=)
, "=" ~> bop (==)
, "and" ~> tbop (&&)
, "or" ~> tbop (||)
, "sqrt" ~> fn sqrt
, "sin" ~> fn sin
, "cos" ~> fn cos
, "tan" ~> fn tan
-- more words here...
]
) where
fn f (x:xs) = f x:xs
op f (x':x:xs) = f x x':xs
bop f (x':x:xs) = fromB (f x x'):xs
tbop f (x':x:xs) = fromB (f (toB x) (toB x')):xs
fromB b = if b then 1 else 0
toB = (/= 0)
iowrapper f d xs ws = f xs >>= flip (run d) ws
wrapper f d xs ws = run d (f xs) ws
(~>) = (,)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.