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
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
|
import Control.Monad (ap)
import Control.Applicative (Applicative(..), (<$>))
-- Représenter la récursion au niveau du typage
newtype Mu f = Mu { unMu :: f (Mu f) }
-- Utiliser un fonction d'ordre supérieur pour parcourir une structure récursive
foldMu :: Functor f => (f a -> a) -> Mu f -> a
foldMu f = f . fmap (foldMu f) . unMu
-- Nos structures récursives
type Ids = String
type Exp = Mu Exp1
data Exp1 a = Id Ids
| Const Tree
| Add a a
| Sub a a
| Multi a a
| Comp a a
| Neg a
| And a a
| Or a a
| Equal a a
| Pair a a
| Fst a
| Snd a
| If a a a
type Tree = Mu Tree1
data Tree1 a = PairTree a a
| TreeValue Value deriving Show
data Value = Number Int
| Boolean Bool deriving Show
type Memory = [(Ids, Tree)]
-- Accès au point de récursion de chaque structure récursive
instance Functor Exp1 where
fmap _ (Id i) = Id i
fmap _ (Const t) = Const t
fmap f (Add x y) = Add (f x) (f y)
fmap f (Sub x y) = Sub (f x) (f y)
fmap f (Multi x y) = Multi (f x) (f y)
fmap f (Comp x y) = Comp (f x) (f y)
fmap f (Neg x) = Neg (f x)
fmap f (And x y) = And (f x) (f y)
fmap f (Or x y) = Or (f x) (f y)
fmap f (Equal x y) = Equal (f x) (f y)
fmap f (Pair x y) = Pair (f x) (f y)
fmap f (Fst x) = Fst (f x)
fmap f (Snd x) = Snd (f x)
fmap f (If x y z) = If (f x) (f y) (f z)
instance Functor Tree1 where
fmap f (PairTree x y) = PairTree (f x) (f y)
fmap _ (TreeValue v) = TreeValue v
-- Exp Api
newId :: Ids -> Exp
newId = Mu . Id
constExp :: Tree -> Exp
constExp = Mu . Const
add :: Exp -> Exp -> Exp
add x y = Mu $ Add x y
sub :: Exp -> Exp -> Exp
sub x y = Mu $ Sub x y
multi :: Exp -> Exp -> Exp
multi x y = Mu $ Multi x y
comp :: Exp -> Exp -> Exp
comp x y = Mu $ Comp x y
neg :: Exp -> Exp
neg = Mu . Neg
and :: Exp -> Exp -> Exp
and x y = Mu $ And x y
or :: Exp -> Exp -> Exp
or x y = Mu $ Or x y
equal :: Exp -> Exp -> Exp
equal x y = Mu $ Equal x y
pair :: Exp -> Exp -> Exp
pair x y = Mu $ Pair x y
-- Conflit possible si Control.Arrow est importé
first :: Exp -> Exp
first = Mu . Fst
-- Conflit possible si Control.Arrow est importé
second :: Exp -> Exp
second = Mu . Snd
ifExp :: Exp -> Exp -> Exp -> Exp
ifExp x y z = Mu $ If x y z
-- Tree Api
pairTree :: Tree -> Tree -> Tree
pairTree x y = Mu $ PairTree x y
treeValue :: Value -> Tree
treeValue = Mu . TreeValue
toNumber :: Int -> Tree
toNumber = treeValue . Number
toBoolean :: Bool -> Tree
toBoolean = treeValue . Boolean
-- eval Api
newtype Eval a = Eval { runEval :: Memory -> Maybe a } -- équivalent de ReaderT Memory Maybe a
instance Functor Eval where
fmap f (Eval k) = Eval (fmap f . k)
instance Applicative Eval where
pure = return
(<*>) = ap
instance Monad Eval where
return = Eval . const . Just
(Eval k) >>= f =
Eval $ \mem -> do
a <- k mem
runEval (f a) mem
askMemory :: Eval Memory
askMemory = Eval Just
evalError :: Eval a
evalError = Eval $ const Nothing
evalInt :: Tree -> Eval Int
evalInt = foldMu go
where
go (TreeValue v) =
case v of
Number i -> return i
_ -> evalError
go _ = evalError
evalBool :: Tree -> Eval Bool
evalBool = foldMu go
where
go (TreeValue v) =
case v of
Boolean b -> return b
_ -> evalError
go _ = evalError
evalPair :: Tree -> Eval (Tree, Tree)
evalPair tree = do
res <- foldMu go tree $ 0
case res of
(1, Mu(PairTree x y)) -> return (x, y)
_ -> evalError
where
go (PairTree kx ky) level = do
let level2 = level+1
(_,x) <- kx level2
(_,y) <- ky level2
let res = pairTree x y
if level == 0
then return (1, res) -- c'est un Pair !
else return (level, res)
go (TreeValue v) level = return (level, treeValue v)
lookupMemory :: Ids -> Eval Tree
lookupMemory x = do
mem <- askMemory
maybe evalError return (lookup x mem)
evalExp :: Exp -> Memory -> Maybe Tree
evalExp = runEval . foldMu go
where
go (Id x) = lookupMemory x
go (Const t) = return t
go (Add ex ey) = do
x <- ex >>= evalInt
y <- ey >>= evalInt
return $ toNumber (x + y)
go (Sub ex ey) = do
x <- ex >>= evalInt
y <- ey >>= evalInt
return $ toNumber (x - y)
go (Multi ex ey) = do
x <- ex >>= evalInt
y <- ey >>= evalInt
return $ toNumber (x * y)
go (Comp ex ey) = do
x <- ex >>= evalInt
y <- ey >>= evalInt
return $ toBoolean (x < y)
go (Neg ex) = do
x <- ex >>= evalBool
return $ toBoolean $ not x
go (And ex ey) = do
x <- ex >>= evalBool
y <- ey >>= evalBool
return $ toBoolean (x && y)
go (Or ex ey) = do
x <- ex >>= evalBool
y <- ey >>= evalBool
return $ toBoolean (x || y)
go (Equal ex ey) = do
x <- ex >>= evalInt
y <- ey >>= evalInt
return $ toBoolean (x == y)
go (Pair ex ey) = pairTree <$> ex <*> ey
go (Fst ex) = do
(l,_) <- ex >>= evalPair
return l
go (Snd ex) = do
(_,r) <- ex >>= evalPair
return r
go (If ep et ef) = do
p <- ep >>= evalBool
if p
then et
else ef |
