#!/usr/bin/env runghc

import Control.Monad (join, sequence, forever)
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) ++ " (relative error: " ++ (show $ d / x) ++ ")"
pPrint s = show s

main :: IO ()
main = do
  hSetBuffering stdin LineBuffering
  hSetBuffering stdout NoBuffering
  forever $ do
    putStr "Formula: "
    line <- getLine
    let --symbols = join . join $ map (map words) . map lines $ args
      symbols = words line
      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''
    putStrLn . pPrint $ evalExpVec symbols''

clarifySymbol :: String -> IO [String]
clarifySymbol s = do
  putStr $ "Define " ++ s ++ ": "
  line <- getLine
  return $ words line

isKnownSymbol :: String -> Bool
isKnownSymbol s = or [
  s `elem` ["+", "-", "*", "/", "±", "pm", "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 "+-" = 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)