Skip to content

Instantly share code, notes, and snippets.

@jhburns
Last active April 29, 2024 18:48
Show Gist options
  • Save jhburns/51f361cc8ab6a46666b0be1a54c8b7ed to your computer and use it in GitHub Desktop.
Save jhburns/51f361cc8ab6a46666b0be1a54c8b7ed to your computer and use it in GitHub Desktop.
Small RPN calculator
-- razz_lang
import Data.Function
import Data.Semigroup
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Text.Read as Read
-- Stack types
data StackValue =
VInt Int |
VDouble Double
instance Show StackValue where
show (VInt n) = show n
show (VDouble n) = show n
newtype Stack = Stack { unStack :: [StackValue] }
instance Show Stack where
show stack = "|[ "
++ (unStack stack & reverse & (map show) & List.intercalate " ")
instance Semigroup Stack where
(<>) first second = unStack first & (++ unStack second) & Stack
-- Helpers to wrap error handling
exeUna :: (StackValue -> Stack) -> Stack -> Stack
exeUna f stack = case unStack stack of
(item : rest) -> (f item) <> Stack rest
[] -> error "Cannot apply function, stack is empty"
exeBin :: (StackValue -> StackValue -> Stack) -> Stack -> Stack
exeBin f stack = case unStack stack of
(m : n : rest) -> (f n m) <> Stack rest
_ -> error "Cannot apply function, stack contains less than two items"
data FnType =
Una (StackValue -> Stack) |
Bin (StackValue -> StackValue -> Stack)
-- More helpers
tryUnaInt :: (Int -> Int) -> String -> StackValue -> StackValue
tryUnaInt f _ (VInt m) = f m & VInt
tryUnaInt _ name _ = "Cannot apply `" ++ name ++ "` because value is not of type Int" & error
tryBinInt :: (Int -> Int -> Int) -> String -> StackValue -> StackValue -> StackValue
tryBinInt f _ (VInt m) (VInt n) = f m n & VInt
tryBinInt _ name _ _ = "Cannot apply `" ++ name ++ "` because values are not of type Int" & error
tryUnaDouble :: (Double -> Double) -> String -> StackValue -> StackValue
tryUnaDouble f _ (VDouble m) = f m & VDouble
tryUnaDouble _ name _ = "Cannot apply `" ++ name ++ "` because value is not of type Double" & error
tryBinDouble :: (Double -> Double -> Double) -> String -> StackValue -> StackValue -> StackValue
tryBinDouble f _ (VDouble m) (VDouble n) = f m n & VDouble
tryBinDouble _ name _ _ = "Cannot apply `" ++ name ++ "` because values are not of type Double" & error
newUna :: String -> (String -> StackValue -> StackValue) -> (String, FnType)
newUna name f = (name, (\m -> [f name m] & Stack) & Una)
newBin :: String -> (String -> StackValue -> StackValue -> StackValue) -> (String, FnType)
newBin name f = (name, (\m n -> [f name m n] & Stack) & Bin)
-- All functions in the language
fns :: Map.Map String FnType
fns = Map.fromList [
-- Int
(newBin "+" $ tryBinInt (+)),
(newBin "-" $ tryBinInt (-)),
(newBin "*" $ tryBinInt (*)),
-- 1/0 = 0
(newBin "//" $ tryBinInt (\m n -> if n == 0 then 0 else m `div` n)),
(newUna "~" $ tryUnaInt (negate)),
-- Double
(newBin "+." $ tryBinDouble (+)),
(newBin "-." $ tryBinDouble (-)),
(newBin "*." $ tryBinDouble (*)),
-- 1.0/0.0 = 0
(newBin "/." $ tryBinDouble (\m n -> if n == 0 then 0 else m / n)),
(newUna "~." $ tryUnaDouble (negate)),
-- Conversion
("->double",
Una (\m -> case m of
(VInt m) -> Stack [fromIntegral m & VDouble]
_ -> error "Cannot convert Double to Double"
)
),
("->int",
Una (\m -> case m of
(VDouble m) -> Stack [round m & VInt]
_ -> error "Cannot convert Int to Int"
)
),
-- Universal
("swap", Bin (\m n -> Stack [n, m])),
("drop", Una (\_ -> Stack [])),
("copy", Una (\m -> Stack [m, m]))
]
-- Interpreter
exec :: String -> Stack
exec source = go (words source) (Stack [])
where
go :: [String] -> Stack -> Stack
go [] stack = stack
go (value : values) stack = case value of
-- comments start with `(`, no spaces allowed
('(': _) -> go values stack
-- Int being read before double means all numerics without a `.` are Ints
_ -> case (Read.readMaybe value) :: Maybe Int of
Just m -> Stack [VInt m] <> stack & go values
Nothing -> case (Read.readMaybe value) :: Maybe Double of
Just d -> Stack [VDouble d] <> stack & go values
Nothing -> case Map.lookup value fns of
Just (Una una) -> exeUna una stack & go values
Just (Bin bin) -> exeBin bin stack & go values
Nothing -> "Unrecoginzed thingy `" ++ value ++ "`" & error
main = "2.0 1.0 -. ->int -1 + 0 * 45 copy drop swap // ->double (output=0.0)"
& exec
& show
& putStrLn
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment