1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
#!/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
|
