69804097165c557a2f2e6c59b0ccfef8c8d49694
[ghc.git] / testsuite / tests / simplCore / should_compile / simpl007.hs
1 {-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
2 {-# LANGUAGE UndecidableInstances,
3 ExistentialQuantification, FlexibleInstances #-}
4
5 -- module Formula where
6 module Main where
7
8 import Prelude hiding (logBase)
9
10 import Data.Maybe
11
12 -------------------------------------------------------------------------------
13
14 -- Formula
15 -- The data type for formulas (algegraic expressions).
16 --
17 -- It should be an extensible type, so that users of
18 -- the library can add new kinds of formulas.
19 -- For example, in this prototype I explore:
20 -- integer constants (FInt)
21 -- unknown variables (FVar)
22 -- sums (FSum)
23 -- products (FPro)
24 -- powers (FPow)
25 -- logarithms (FLog)
26 -- The user of the library may want to extend it with
27 -- trigonometric formulas or derivative formulas, for
28 -- example.
29 --
30 -- The idea is to let each kind of formula be a new data
31 -- type. Similar operations with them are implemented
32 -- using overloading. So there is a class (FORMULA) to collect
33 -- them and each kind of formula should be an instance of it.
34
35 class (Eq f, Show f) => FORMULA f where
36 ty :: f -> FType
37 intVal :: f -> Integer
38 varName :: f -> String
39 argList :: f -> [Formula]
40 same :: (FORMULA f1) => f -> f1 -> Bool
41 intVal = error ""
42 varName = error ""
43 argList = error ""
44 same _ _ = False
45
46 -- By now extensibility is accomplished by existentially
47 -- quantified type variables.
48
49 data Formula = forall f . ( FORMULA f
50 , AddT f
51 ) =>
52 Formula f
53
54 instance Show Formula where
55 show (Formula f) = show f
56
57 instance Eq Formula where
58 (Formula x) == (Formula y) = same x y
59
60 instance FORMULA Formula where
61 ty (Formula f) = ty f
62 intVal (Formula f) = intVal f
63 varName (Formula f) = varName f
64 argList (Formula f) = argList f
65 same (Formula f) = same f
66
67 -------------------------------------------------------------------------------
68
69 -- How to uniquely identify the type of formula?
70 -- Each type of formula is associated to a key (FType)
71 -- that identifies it.
72 --
73 -- Here I use an enumated data type. When extending
74 -- the library, the user will have to modify this
75 -- data type adding a new constant constructor.
76
77 data FType = INT
78 | VAR
79 | SUM
80 | PRO
81 | POW
82 | LOG
83 deriving (Eq,Ord,Enum,Show)
84
85 -------------------------------------------------------------------------------
86
87 -- Integer formula
88
89 data FInt = FInt Integer
90 deriving (Eq,Show)
91
92 mkInt = Formula . FInt
93
94 instance FORMULA FInt where
95 ty _ = INT
96 intVal (FInt x) = x
97 same (FInt x) y = isInt y && x == intVal y
98
99 -- Variable formula
100
101 data FVar = FVar String
102 deriving (Eq,Show)
103
104 mkVar = Formula . FVar
105
106 instance FORMULA FVar where
107 ty _ = VAR
108 varName (FVar x) = x
109 same (FVar x) y = isVar y && x == varName y
110
111 -- Sum formula
112
113 data FSum = FSum [Formula]
114 deriving (Eq,Show)
115
116 mkSum = Formula . FSum
117
118 instance FORMULA FSum where
119 ty _ = SUM
120 argList (FSum xs) = xs
121 same (FSum xs) y = isSum y && xs == argList y
122
123 -- Product formula
124
125 data FPro = FPro [Formula]
126 deriving (Eq,Show)
127
128 mkPro = Formula . FPro
129
130 instance FORMULA FPro where
131 ty _ = PRO
132 argList (FPro xs) = xs
133 same (FPro xs) y = isPro y && xs == argList y
134
135 -- Exponentiation formula
136
137 data FPow = FPow Formula Formula
138 deriving (Eq,Show)
139
140 mkPow x y = Formula (FPow x y)
141
142 instance FORMULA FPow where
143 ty _ = POW
144 argList (FPow b e) = [b,e]
145 same (FPow b e) y = isPow y && [b,e] == argList y
146
147 -- Logarithm formula
148
149 data FLog = FLog Formula Formula
150 deriving (Eq,Show)
151
152 mkLog x b = Formula (FLog x b)
153
154 instance FORMULA FLog where
155 ty _ = LOG
156 argList (FLog x b) = [x,b]
157 same (FLog x b) y = isLog y && [x,b] == argList y
158
159 -------------------------------------------------------------------------------
160
161 -- Some predicates
162
163 isInt x = ty x == INT
164 isVar x = ty x == VAR
165 isSum x = ty x == SUM
166 isPro x = ty x == PRO
167 isPow x = ty x == POW
168
169 isZero x = isInt x && intVal x == 0
170
171 -------------------------------------------------------------------------------
172
173 -- Adding two formulas
174 -- This is a really very simple algorithm for adding
175 -- two formulas.
176
177 add :: Formula -> Formula -> Formula
178 add x y
179 | isJust u = fromJust u
180 | isJust v = fromJust v
181 | otherwise = mkSum [x,y]
182 where
183 u = addT x y
184 v = addT y x
185
186 class AddT a where
187 addT :: a -> Formula -> Maybe Formula
188 addT _ _ = Nothing
189
190 instance {-# OVERLAPPABLE #-} (FORMULA a) => AddT a where {}
191
192 instance AddT Formula where
193 addT (Formula f) = addT f
194
195 instance AddT FInt where
196 addT (FInt 0) y = Just y
197 addT (FInt x) y
198 | isInt y = Just (mkInt (x + intVal y))
199 | otherwise = Nothing
200
201 instance AddT FSum where
202 addT (FSum xs) y
203 | isSum y = Just (mkSum (merge xs (argList y)))
204 | otherwise = Just (mkSum (merge xs [y]))
205 where
206 merge = (++)
207
208 instance AddT FLog where
209 addT (FLog x b) y
210 | isLog y && b == logBase y = Just (mkLog (mkPro [x,logExp y]) b)
211 | otherwise = Nothing
212 where
213 merge = (++)
214
215 isLog x = ty x == LOG
216
217 logBase x
218 | isLog x = head (tail (argList x))
219
220 logExp x
221 | isLog x = head (argList x)
222
223 -------------------------------------------------------------------------------
224
225 -- Test addition of formulas
226
227 main = print [ add (mkInt 78) (mkInt 110)
228 , add (mkInt 0) (mkVar "x")
229 , add (mkVar "x") (mkInt 0)
230 , add (mkVar "x") (mkVar "y")
231 , add (mkSum [mkInt 13,mkVar "x"]) (mkVar "y")
232 , add (mkLog (mkVar "x") (mkInt 10))
233 (mkLog (mkVar "y") (mkInt 10))
234 , add (mkLog (mkVar "x") (mkInt 10))
235 (mkLog (mkVar "y") (mkVar "e"))
236 ]