Initial commit

1 files changed, 78 insertions, 0 deletions

diff --git a/rpn.hs b/rpn.hs
new file mode 100644
index 0000000..a0d33ef
--- /dev/null
+++ b/rpn.hs
@@ -0,0 +1,78 @@
+import Control.Monad (join, sequence)
+import System.Environment (getArgs)
+import qualified Control.Monad.State as S
+
+data Symbol a = Number a a | Err | Add | Sub | Mult | Div | Unc deriving (Eq, Ord, Show)
+instance Floating a => Num (Symbol a) where
+  (Number x del) + (Number y del') = Number (x + y) (abs $ gMean [del, del'])
+  _ + _ = Err
+  (Number x del) * (Number y del') = Number (x * y) (abs $ (x * y) * (gMean [del / x, del' / y]))
+  _ * _ = Err
+  negate (Number x del) = Number (negate x) del
+  negate _ = Err
+  abs (Number x del) = Number (abs x) del
+  abs _ = Err
+  signum (Number x del) = Number (signum x) 0
+  signum _ = Err
+  fromInteger i = Number (fromInteger i) 0
+
+instance Floating a => Fractional (Symbol a) where
+  recip (Number x del) = Number (recip x) (abs $ (recip x) * (del / x))
+  recip _ = Err
+  fromRational x = Number (fromRational x) 0
+
+dropUnc :: Floating a => Symbol a -> a
+dropUnc (Number x _) = x
+dropUnc _ = 0
+
+gMean :: Floating a => [a] -> a
+gMean xs = sqrt $ foldl1 (+) $ map (\x -> x * x) xs
+
+fromSymbol :: Floating a => Symbol a -> (a, a)
+fromSymbol (Number x d) = (x, d)
+fromSymbol _ = (0, 0)
+
+main :: IO ()
+main = do
+  (mode:stdin:_) <- getArgs
+  let symbols = map interpreteSymbol $ join $ map words . lines $ stdin
+      result = evalExpVec symbols
+  case mode of
+    "n" -> putStrLn . show . fst $ fromSymbol result
+    "e" -> putStrLn . show . snd $ fromSymbol result
+
+interpreteSymbol :: String -> Symbol Double
+interpreteSymbol "+" = Add
+interpreteSymbol "-" = Sub
+interpreteSymbol "*" = Mult
+interpreteSymbol "/" = Div
+interpreteSymbol "±" = Unc
+interpreteSymbol x = Number (read x) 0
+
+evalExpVec :: Floating a => [Symbol a] -> Symbol a
+evalExpVec is = head . snd $ S.runState (evalExpVec' is) []
+
+evalExpVec' :: Floating a => [Symbol a] -> S.State [Symbol a] ()
+evalExpVec' is = do
+  sequence $ map evalExp is
+  return ()
+
+evalExp :: Floating a => Symbol a -> S.State [Symbol a] ()
+evalExp (Number x del) = do
+  state <- S.get
+  S.put $ ((Number x del):state)
+evalExp Unc = do
+  state <- S.get
+  S.put $ ((Number (dropUnc (state !! 1)) (dropUnc (state !! 0))):drop 2 state)
+evalExp Add = do
+  state <- S.get
+  S.put $ ((foldl1 (+) $ take 2 state):drop 2 state)
+evalExp Sub = do
+  state <- S.get
+  S.put $ ((foldl1 (-) . reverse $ take 2 state):drop 2 state)
+evalExp Mult = do
+  state <- S.get
+  S.put $ ((foldl1 (*) $ take 2 state):drop 2 state)
+evalExp Div = do
+  state <- S.get
+  S.put $ ((foldl1 (/) . reverse $ take 2 state):drop 2 state)