import Control.Monad (join, sequence) import System.Environment (getArgs) import Data.Maybe (listToMaybe, isJust) import Data.Char (isSpace) import Data.List (nub) import qualified Control.Monad.State as S import qualified Data.Map as M import System.IO data Symbol a = Number a a | Err | Add | Sub | Mult | Div | Unc | Exp 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) pPrint :: Show a => Symbol a -> String pPrint (Number x d) = (show x) ++ " ± " ++ (show d) pPrint s = show s main :: IO () main = do hSetBuffering stdin LineBuffering hSetBuffering stdout NoBuffering (mode:args) <- getArgs let symbols = join . join $ map (map words) . map lines $ args unknownSymbols = nub $ filter (not . isKnownSymbol) symbols symbolMap <- sequence $ map (sequencePair . (\x -> (x, clarifySymbol x))) unknownSymbols let symbolMap' = M.fromList symbolMap symbols' = map (\x -> if x `elem` (M.keys symbolMap') then symbolMap' M.! x else [x]) symbols symbols'' = map interpreteSymbol $ join symbols' let result = evalExpVec symbols'' case mode of "n" -> putStrLn . show . fst $ fromSymbol result "e" -> putStrLn . show . snd $ fromSymbol result _ -> putStrLn $ pPrint result clarifySymbol :: String -> IO [String] clarifySymbol s = do putStr $ "Define " ++ s ++ ": " line <- getLine return $ words line isKnownSymbol :: String -> Bool isKnownSymbol s = or [ s `elem` ["+", "-", "*", "/", "±", "e"], isJust $ (maybeRead s :: Maybe Double) ] sequencePair :: (a, IO b) -> IO (a, b) sequencePair (a, b) = do b' <- b return (a, b') maybeRead :: (Read a) => String -> Maybe a maybeRead = fmap fst . listToMaybe . filter (null . dropWhile isSpace . snd) . reads interpreteSymbol :: String -> Symbol Double interpreteSymbol "+" = Add interpreteSymbol "-" = Sub interpreteSymbol "*" = Mult interpreteSymbol "/" = Div interpreteSymbol "±" = Unc interpreteSymbol "e" = Exp 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) evalExp Exp = do state <- S.get let b = state !! 1 e = state !! 0 S.put $ ((b * (Number (10 ** (fst $ fromSymbol e)) 0)):drop 2 state)