#!/usr/bin/env runghc

{-# LANGUAGE ViewPatterns #-}

import Control.Monad (join, sequence, forever)
import Control.Applicative
import System.Environment
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 | Pow 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, Fractional a) => Symbol a -> String
pPrint (Number x d) = x `seq` d `seq` (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
    line <- maybe (putStr "Formula: " >> getLine) (<$ unsetEnv "FORMULA") =<< lookupEnv "FORMULA"
    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 = maybe clarify' (return . words) =<< lookupEnv s
  where
    clarify' = 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 "+-" = Unc
interpreteSymbol "e" = Exp
interpreteSymbol "^" = Pow
interpreteSymbol x = Number (read x) 0

evalExpVec :: (Floating a, RealFrac a, Eq a) => [Symbol a] -> Symbol a
evalExpVec is = head . snd $ S.runState (evalExpVec' is) []

evalExpVec' :: (Floating a, RealFrac a, Eq a) => [Symbol a] -> S.State [Symbol a] ()
evalExpVec' is = do
  sequence $ map evalExp is
  return ()

evalExp :: (Floating a, RealFrac a, Eq 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
  (e:b:state) <- S.get
  S.put $ (b * (Number (10 ** (fst $ fromSymbol e)) 0)):state
evalExp Pow = do
  ((Number b'@(round -> b) 0):(Number y dY):(Number a'@(round -> a) 0):(Number x dX):state) <- S.get
  let
    prod = (x^^a) * (y^^b)
    dX' = dX / x
    dY' = dY / y
    err = prod * (sqrt $ (a' * dX')^2 + (b' * dY')^2)
  S.put $ (Number prod err):state