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
|
#!/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, Fractional 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` ["+", "-", "*", "/", "±", "+-", "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)
|
