-
Notifications
You must be signed in to change notification settings - Fork 0
/
Expressions.hs
162 lines (143 loc) · 4.3 KB
/
Expressions.hs
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
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
module Expressions where
import Data.Maybe
---------------------------------------------------------------------------
-- Type classes and class instances
data UnOp = Neg | Sin | Cos | Tan | Log
deriving (Eq, Ord)
data BinOp = Add | Mul | Div | Pow
deriving (Eq, Ord)
data Exp = Val Double
| Id String
| UnApp UnOp Exp
| BinApp BinOp Exp Exp
deriving (Eq, Ord)
type Env = [(String, Double)]
---------------------------------------------------------------------------
-- Convert normal expressions to Exp type
instance Num Exp where
fromInteger = Val . fromIntegral
-- Optimizations for negate
negate 0 = 0
negate (UnApp Neg n) = n
negate n = UnApp Neg n
-- Optimizations for (+)
(+) e 0 = e
(+) 0 e = e
(+) e e' = BinApp Add e e'
-- Optimizations for (*)
(*) 0 _ = 0
(*) _ 0 = 0
(*) e 1 = e
(*) 1 e = e
(*) e e' = BinApp Mul e e'
-- Functions below unimplemented
signum = error "No signum for symbolic numbers"
abs = error "No abs for symbolic numbers"
instance Fractional Exp where
fromRational = Val . realToFrac
-- Optimizations for (/)
(/) 0 _ = 0
(/) _ 0 = error "Division by zero!"
(/) e 1 = e
(/) e e' = BinApp Div e e'
-- Optimizations for recip
recip (BinApp Div e e') = (/) e' e
recip e = (/) 1 e
instance Floating Exp where
pi = Id "pi"
sin = UnApp Sin
cos = UnApp Cos
tan = UnApp Tan
exp = (**) (Id "e")
-- Optimizations for (**)
(**) 0 0 = error "0 ** 0 undefined!"
(**) 0 _ = 0
(**) _ 0 = 1
(**) 1 _ = 1
(**) e 1 = e
(**) e p = BinApp Pow e p
-- Optimizations for log
log (Id "e") = 1
log (BinApp Mul (Id "e") (Val n)) = Val n
log (BinApp Mul (Val n) (Id "e")) = Val n
log e = UnApp Log e
-- Optimizations for logBase
logBase b v = (/) (log v) (log b)
-- Functions below unimplemented
sqrt = error "sqrt not yet implemented"
asin = error "Inverse trigonometric function not yet implemented"
acos = error "Inverse trigonometric function not yet implemented"
atan = error "Inverse trigonometric function not yet implemented"
sinh = error "Hyperbolic function not yet implemented"
cosh = error "Hyperbolic function not yet implemented"
tanh = error "Hyperbolic function not yet implemented"
asinh = error "Hyperbolic function not yet implemented"
acosh = error "Hyperbolic function not yet implemented"
atanh = error "Hyperbolic function not yet implemented"
---------------------------------------------------------------------------
-- Displaying Expressions
instance Show UnOp where
show Neg = "-"
show Sin = "sin"
show Cos = "cos"
show Tan = "tan"
show Log = "log"
instance Show BinOp where
show Add = "+"
show Mul = "*"
show Div = "/"
show Pow = "**"
instance Show Exp where
show (Val e) = show e
show (Id "pi") = "π"
show (Id e) = e
-- Special cases for Unary Operators
show (UnApp Neg e)
= show Neg ++ show e
show (UnApp op e@(BinApp _ _ _))
= show op ++ show e
show (UnApp op e)
= show op ++ "(" ++ show e ++ ")"
-- Special cases for Binary Operators
show (BinApp Add e (UnApp Neg e'))
= "(" ++ show e ++ show Neg ++ show e' ++ ")"
show (BinApp op e e')
= "(" ++ show e ++ show op ++ show e' ++ ")"
---------------------------------------------------------------------------
-- Helper Functions
lookUp :: Eq a => a -> [(a, b)] -> b
lookUp
= (fromJust .) . lookup
unOpFunc :: (Num a, Fractional a, Floating a) => UnOp -> (a -> a)
unOpFunc op
= lookUp op table
where
table = [ (Neg, negate)
, (Sin, sin)
, (Cos, cos)
, (Tan, tan)
, (Log, log)
]
binOpFunc :: (Num a, Fractional a, Floating a) => BinOp -> (a -> a -> a)
binOpFunc op
= lookUp op table
where
table = [ (Add, (+))
, (Mul, (*))
, (Div, (/))
, (Pow, (**))
]
eval :: Exp -> Env -> Double
eval (Val v) _
= v
eval (Id "e") _
= exp 1
eval (Id "pi") _
= pi
eval (Id x) env
= lookUp x env
eval (UnApp op e) env
= (unOpFunc op) (eval e env)
eval (BinApp op e e') env
= (binOpFunc op) (eval e env) (eval e' env)