|
2138
|
1 --
|
|
|
2 -- emmental.hs
|
|
|
3 -- Interpreter for the Emmental Programming Language
|
|
|
4 -- Chris Pressey, Cat's Eye Technologies
|
|
|
5 -- This work is in the public domain. See UNLICENSE for more information.
|
|
|
6 --
|
|
|
7 -- Ørjan Johansen added main
|
|
|
8 --
|
|
|
9
|
|
|
10
|
|
|
11 import qualified Data.Map as Map
|
|
|
12 import qualified Data.Char as Char
|
|
|
13 import System.Environment (getArgs)
|
|
|
14
|
|
|
15 main = do
|
|
|
16 args <- getArgs
|
|
|
17 case args of
|
|
|
18 "-d" : as -> debug =<< parse return as
|
|
|
19 _ -> emmental =<< parse return args
|
|
|
20 where
|
|
|
21 parse :: (String -> IO String) -> [String] -> IO String
|
|
|
22 parse _ ("-f":as) = parse readFile as
|
|
|
23 parse _ ("-e":as) = parse return as
|
|
|
24 parse op (a:as) = op a >>= (`fmap` parse op as) . (++)
|
|
|
25 parse _ [] = return ""
|
|
|
26
|
|
|
27
|
|
|
28 -----------------------------------------------------------------------
|
|
|
29 -- ============================ Symbols ============================ --
|
|
|
30 -----------------------------------------------------------------------
|
|
|
31
|
|
|
32 type Symbol = Char
|
|
|
33
|
|
|
34
|
|
|
35 -----------------------------------------------------------------------
|
|
|
36 -- ======================== Program States ========================= --
|
|
|
37 -----------------------------------------------------------------------
|
|
|
38
|
|
|
39 data State = State [Symbol] [Symbol]
|
|
|
40 deriving (Ord, Eq, Show)
|
|
|
41
|
|
|
42 pop (State (head:tail) queue) = (head, State tail queue)
|
|
|
43 push (State list queue) sym = (State (sym:list) queue)
|
|
|
44
|
|
|
45 popString (State (';':tail) queue) = ([], State tail queue)
|
|
|
46 popString (State (head:tail) queue) =
|
|
|
47 let
|
|
|
48 (string, state') = popString (State tail queue)
|
|
|
49 in
|
|
|
50 (string ++ [head], state')
|
|
|
51
|
|
|
52 enqueue (State stack queue) symbol = State stack (symbol:queue)
|
|
|
53 dequeue (State stack queue) =
|
|
|
54 let
|
|
|
55 symbol = last queue
|
|
|
56 queue' = init queue
|
|
|
57 in
|
|
|
58 (symbol, State stack queue')
|
|
|
59
|
|
|
60
|
|
|
61 -----------------------------------------------------------------------
|
|
|
62 -- ========================= Interpreters ========================== --
|
|
|
63 -----------------------------------------------------------------------
|
|
|
64
|
|
|
65 data Interpreter = Interp (Map.Map Symbol Operation)
|
|
|
66
|
|
|
67 fetch (Interp map) sym = Map.findWithDefault (fitRegOp opNop) sym map
|
|
|
68 supplant (Interp map) sym op = (Interp (Map.insert sym op map))
|
|
|
69
|
|
|
70
|
|
|
71 -----------------------------------------------------------------------
|
|
|
72 -- ========================== Operations =========================== --
|
|
|
73 -----------------------------------------------------------------------
|
|
|
74
|
|
|
75 type Operation = State -> Interpreter -> IO (State, Interpreter)
|
|
|
76
|
|
|
77 composeOps :: Operation -> Operation -> Operation
|
|
|
78
|
|
|
79 composeOps op1 op2 = f where
|
|
|
80 f state interpreter = do
|
|
|
81 (state', interpreter') <- op1 state interpreter
|
|
|
82 op2 state' interpreter'
|
|
|
83
|
|
|
84 createOp :: Interpreter -> [Symbol] -> Operation
|
|
|
85
|
|
|
86 createOp interpreter [] =
|
|
|
87 (fitRegOp opNop)
|
|
|
88 createOp interpreter (head:tail) =
|
|
|
89 composeOps (fetch interpreter head) (createOp interpreter tail)
|
|
|
90
|
|
|
91 --
|
|
|
92 -- It's useful for us to express a lot of our operators as non-monadic
|
|
|
93 -- functions that don't affect the interpreter. This is a little "adapter"
|
|
|
94 -- function that lets us create monadic functions with the right signature
|
|
|
95 -- from them.
|
|
|
96 --
|
|
|
97
|
|
|
98 fitRegOp :: (State -> State) -> Operation
|
|
|
99
|
|
|
100 fitRegOp regop = f where
|
|
|
101 f state interpreter =
|
|
|
102 let
|
|
|
103 state' = regop state
|
|
|
104 in
|
|
|
105 do return (state', interpreter)
|
|
|
106
|
|
|
107
|
|
|
108 ------------------------------------------------------------
|
|
|
109 --------------- The operations themselves. -----------------
|
|
|
110 ------------------------------------------------------------
|
|
|
111
|
|
|
112 --
|
|
|
113 -- Redefine the meaning of the symbol on the stack with
|
|
|
114 -- a mini-program also popped off the stack.
|
|
|
115 --
|
|
|
116
|
|
|
117 opSupplant state interpreter =
|
|
|
118 let
|
|
|
119 (opSym, state') = pop state
|
|
|
120 (newOpDefn, state'') = popString state'
|
|
|
121 newOp = createOp interpreter newOpDefn
|
|
|
122 in
|
|
|
123 do return (state'', supplant interpreter opSym newOp)
|
|
|
124
|
|
|
125 --
|
|
|
126 -- Execute the symbol on the stack with the current interpreter.
|
|
|
127 --
|
|
|
128
|
|
|
129 opEval state interpreter =
|
|
|
130 let
|
|
|
131 (opSym, state') = pop state
|
|
|
132 newOp = createOp interpreter [opSym]
|
|
|
133 in
|
|
|
134 newOp state' interpreter
|
|
|
135
|
|
|
136 --
|
|
|
137 -- I/O.
|
|
|
138 --
|
|
|
139
|
|
|
140 opInput state interpreter = do
|
|
|
141 symbol <- getChar
|
|
|
142 do return (push state symbol, interpreter)
|
|
|
143
|
|
|
144 opOutput state interpreter =
|
|
|
145 let
|
|
|
146 (symbol, state') = pop state
|
|
|
147 in do
|
|
|
148 putChar symbol
|
|
|
149 return (state', interpreter)
|
|
|
150
|
|
|
151 --
|
|
|
152 -- Primitive arithmetic.
|
|
|
153 --
|
|
|
154
|
|
|
155 opAdd state =
|
|
|
156 let
|
|
|
157 (symA, state') = pop state
|
|
|
158 (symB, state'') = pop state'
|
|
|
159 in
|
|
|
160 push state'' (Char.chr (((Char.ord symB) + (Char.ord symA)) `mod` 256))
|
|
|
161
|
|
|
162 opSubtract state =
|
|
|
163 let
|
|
|
164 (symA, state') = pop state
|
|
|
165 (symB, state'') = pop state'
|
|
|
166 in
|
|
|
167 push state'' (Char.chr (((Char.ord symB) - (Char.ord symA)) `mod` 256))
|
|
|
168
|
|
|
169 discreteLog 0 = 8
|
|
|
170 discreteLog 1 = 0
|
|
|
171 discreteLog 2 = 1
|
|
|
172 discreteLog n = (discreteLog (n `div` 2)) + 1
|
|
|
173
|
|
|
174 opDiscreteLog state =
|
|
|
175 let
|
|
|
176 (symbol, state') = pop state
|
|
|
177 in
|
|
|
178 push state' (Char.chr (discreteLog (Char.ord symbol)))
|
|
|
179
|
|
|
180 --
|
|
|
181 -- Stack manipulation.
|
|
|
182 --
|
|
|
183
|
|
|
184 --
|
|
|
185 -- Pop the top symbol of the stack, make a copy of it, push it back onto the
|
|
|
186 -- stack, and enqueue the copy onto the queue.
|
|
|
187 --
|
|
|
188
|
|
|
189 opEnqueueCopy state =
|
|
|
190 let
|
|
|
191 (sym, _) = pop state
|
|
|
192 in
|
|
|
193 enqueue state sym
|
|
|
194
|
|
|
195 --
|
|
|
196 -- Dequeue a symbol from the queue and push it onto the stack.
|
|
|
197 --
|
|
|
198
|
|
|
199 opDequeue state =
|
|
|
200 let
|
|
|
201 (sym, state') = dequeue state
|
|
|
202 in
|
|
|
203 push state' sym
|
|
|
204
|
|
|
205 --
|
|
|
206 -- Duplicate the top symbol of the stack.
|
|
|
207 --
|
|
|
208
|
|
|
209 opDuplicate state =
|
|
|
210 let
|
|
|
211 (symbol, _) = pop state
|
|
|
212 in
|
|
|
213 push state symbol
|
|
|
214
|
|
|
215 --
|
|
|
216 -- Miscellaneous operations.
|
|
|
217 --
|
|
|
218
|
|
|
219 opNop state =
|
|
|
220 state
|
|
|
221
|
|
|
222 --
|
|
|
223 -- Parameterizable operations.
|
|
|
224 --
|
|
|
225
|
|
|
226 opPushValue value state =
|
|
|
227 push state (Char.chr value)
|
|
|
228
|
|
|
229 opAccumValue value state =
|
|
|
230 let
|
|
|
231 (sym, state') = pop state
|
|
|
232 value' = ((Char.ord sym) * 10) + value
|
|
|
233 in
|
|
|
234 push state' (Char.chr (value' `mod` 256))
|
|
|
235
|
|
|
236
|
|
|
237 -----------------------------------------------------------------------
|
|
|
238 -- ===================== Debugging Functions ======================= --
|
|
|
239 -----------------------------------------------------------------------
|
|
|
240
|
|
|
241 type Debugger = State -> Interpreter -> IO ()
|
|
|
242
|
|
|
243 debugNop s i = do
|
|
|
244 return ()
|
|
|
245
|
|
|
246 debugPrintState s i = do
|
|
|
247 putStr ((show s) ++ "\n")
|
|
|
248 return ()
|
|
|
249
|
|
|
250
|
|
|
251 -----------------------------------------------------------------------
|
|
|
252 -- ============================ Executor =========================== --
|
|
|
253 -----------------------------------------------------------------------
|
|
|
254
|
|
|
255 execute :: [Symbol] -> State -> Interpreter -> Debugger -> IO (State, Interpreter)
|
|
|
256
|
|
|
257 execute [] state interpreter debugger =
|
|
|
258 return (state, interpreter)
|
|
|
259 execute (opSym:program') state interpreter debugger =
|
|
|
260 let
|
|
|
261 operation = fetch interpreter opSym
|
|
|
262 in do
|
|
|
263 (state', interpreter') <- operation state interpreter
|
|
|
264 debugger state' interpreter'
|
|
|
265 execute program' state' interpreter' debugger
|
|
|
266
|
|
|
267
|
|
|
268 -----------------------------------------------------------------------
|
|
|
269 -- ====================== Top-Level Function ======================= --
|
|
|
270 -----------------------------------------------------------------------
|
|
|
271
|
|
|
272 initialInterpreter = Interp
|
|
|
273 (Map.fromList
|
|
|
274 [
|
|
|
275 ('.', opOutput),
|
|
|
276 (',', opInput),
|
|
|
277
|
|
|
278 ('#', fitRegOp (opPushValue 0)),
|
|
|
279 ('0', fitRegOp (opAccumValue 0)),
|
|
|
280 ('1', fitRegOp (opAccumValue 1)),
|
|
|
281 ('2', fitRegOp (opAccumValue 2)),
|
|
|
282 ('3', fitRegOp (opAccumValue 3)),
|
|
|
283 ('4', fitRegOp (opAccumValue 4)),
|
|
|
284 ('5', fitRegOp (opAccumValue 5)),
|
|
|
285 ('6', fitRegOp (opAccumValue 6)),
|
|
|
286 ('7', fitRegOp (opAccumValue 7)),
|
|
|
287 ('8', fitRegOp (opAccumValue 8)),
|
|
|
288 ('9', fitRegOp (opAccumValue 9)),
|
|
|
289
|
|
|
290 ('+', fitRegOp opAdd),
|
|
|
291 ('-', fitRegOp opSubtract),
|
|
|
292 ('~', fitRegOp opDiscreteLog),
|
|
|
293
|
|
|
294 ('^', fitRegOp opEnqueueCopy),
|
|
|
295 ('v', fitRegOp opDequeue),
|
|
|
296 (':', fitRegOp opDuplicate),
|
|
|
297
|
|
|
298 ('!', opSupplant),
|
|
|
299 ('?', opEval),
|
|
|
300
|
|
|
301 (';', fitRegOp (opPushValue (Char.ord ';')))
|
|
|
302 ]
|
|
|
303 )
|
|
|
304
|
|
|
305 initialState = State [] []
|
|
|
306
|
|
|
307 emmental string = do
|
|
|
308 (state, interpreter) <- execute string initialState initialInterpreter debugNop
|
|
|
309 return state
|
|
|
310
|
|
|
311 debug string = do
|
|
|
312 (state, interpreter) <- execute string initialState initialInterpreter debugPrintState
|
|
|
313 return state
|
|
|
314
|
|
|
315
|
|
|
316 -----------------------------------------------------------------------
|
|
|
317 -- ========================== Test Cases =========================== --
|
|
|
318 -----------------------------------------------------------------------
|
|
|
319
|
|
|
320 --
|
|
|
321 -- Drivers for test cases. 'demo' runs them straight, whereas 'test'
|
|
|
322 -- uses the debugger.
|
|
|
323 --
|
|
|
324
|
|
|
325 demo n = emmental (testProg n)
|
|
|
326
|
|
|
327 test n = debug (testProg n)
|
|
|
328
|
|
|
329 --
|
|
|
330 -- Here we introduce a bit of a cheat, in order to make writing
|
|
|
331 -- complex Emmental programs tolerable. You can still see the
|
|
|
332 -- programs in their fully glory by executing "show (testProg n)".
|
|
|
333 --
|
|
|
334
|
|
|
335 quote [] = []
|
|
|
336 quote (symbol:rest) = "#" ++ (show (Char.ord symbol)) ++ (quote rest)
|
|
|
337
|
|
|
338 --
|
|
|
339 -- Add one and one.
|
|
|
340 --
|
|
|
341
|
|
|
342 testProg 1 = "#1#1+"
|
|
|
343
|
|
|
344 --
|
|
|
345 -- Redefine & as "+".
|
|
|
346 --
|
|
|
347
|
|
|
348 testProg 2 = ";#43#38!#1#1&" -- 59,43,38 ==> ";+&"
|
|
|
349
|
|
|
350 --
|
|
|
351 -- Redefine 0 as "9".
|
|
|
352 --
|
|
|
353
|
|
|
354 testProg 3 = ";#57#48!#0" -- 59,57,48 ==> ";90"
|
|
|
355
|
|
|
356 --
|
|
|
357 -- Redefine 0 as "#48?". This results in an infinite loop when 0 is executed.
|
|
|
358 --
|
|
|
359
|
|
|
360 testProg 4 = ";#35#52#56#63#48!0" -- 59,35,52,56,63,48 ==> ";#48?0"
|
|
|
361
|
|
|
362 --
|
|
|
363 -- Redefine $ as ".#36?". This results in a loop that pops symbols and
|
|
|
364 -- and prints them, until the stack underflows, when $ is executed.
|
|
|
365 --
|
|
|
366
|
|
|
367 testProg 5 = ";#46#35#51#54#63#36! #65#66#67#68#69$"
|
|
|
368
|
|
|
369 --
|
|
|
370 -- Duplicate the top stack element (assuming an empty queue.)
|
|
|
371 -- This shows that the : operation is not strictly necessary
|
|
|
372 -- (when you know the size of the queue.)
|
|
|
373 --
|
|
|
374
|
|
|
375 testProg 6 = "#65^v"
|
|
|
376
|
|
|
377 --
|
|
|
378 -- Discard the top stack element (assuming more than one element
|
|
|
379 -- on the stack, and an empty queue.)
|
|
|
380 --
|
|
|
381
|
|
|
382 testProg 7 = "#33#123^v-+"
|
|
|
383
|
|
|
384 --
|
|
|
385 -- Swap the top two elements of the stack (assuming an empty queue.)
|
|
|
386 --
|
|
|
387
|
|
|
388 testProg 8 = "#67#66#65^v^-+^^v^v^v-+^v-+^v-+vv"
|
|
|
389
|
|
|
390 --
|
|
|
391 -- Input a symbol. Report whether its ASCII value is even or odd.
|
|
|
392 --
|
|
|
393
|
|
|
394 testProg 9 = (quote ";^v:") ++ "!" ++ -- : = dup
|
|
|
395 (quote ";#69.") ++ "#!" ++ -- NUL = print "E"
|
|
|
396 (quote ";#79.") ++ "#128!" ++ -- \128 = print "O"
|
|
|
397 (quote (";" ++ (take 127 [':',':'..]) ++ -- m = mul by 128
|
|
|
398 (take 127 ['+','+'..]) ++ "m")) ++ "!" ++
|
|
|
399 ",m?"
|
|
|
400
|
|
|
401 --
|
|
|
402 -- Input a symbol. Report whether it is M or not.
|
|
|
403 --
|
|
|
404
|
|
|
405 testProg 10 = (quote ";#78.") ++ "#!" ++ -- NUL = print "N"
|
|
|
406 ";##1!" ++ -- SOH = same as NUL
|
|
|
407 ";##2!" ++ -- STX = same as NUL
|
|
|
408 ";##3!" ++ -- ETX = same as NUL
|
|
|
409 ";##4!" ++ -- EOT = same as NUL
|
|
|
410 ";##5!" ++ -- ENQ = same as NUL
|
|
|
411 ";##6!" ++ -- ACK = same as NUL
|
|
|
412 ";##7!" ++ -- BEL = same as NUL
|
|
|
413 (quote ";#89.") ++ "#8!" ++ -- BS = print "Y"
|
|
|
414 ",#77-~?"
|
|
|
415
|
|
|
416 --
|
|
|
417 -- Same as testProg 5, except stop printing when a NUL is
|
|
|
418 -- encountered, instead of just underflowing the stack.
|
|
|
419 --
|
|
|
420
|
|
|
421 testProg 11 = ";" ++ (quote ":~?$") ++ "!" ++ -- $ = dup & test
|
|
|
422 ";" ++ (quote ".$") ++ "#!" ++ -- NUL = print & repeat
|
|
|
423 ";#0#1!" ++ -- SOH = same as NUL
|
|
|
424 ";#0#2!" ++ -- STX = same as NUL
|
|
|
425 ";#0#3!" ++ -- ETX = same as NUL
|
|
|
426 ";#0#4!" ++ -- EOT = same as NUL
|
|
|
427 ";#0#5!" ++ -- ENQ = same as NUL
|
|
|
428 ";#0#6!" ++ -- ACK = same as NUL
|
|
|
429 ";#0#7!" ++ -- BEL = same as NUL
|
|
|
430 -- BS = stop (nop)
|
|
|
431 "#0" ++ (quote (reverse "Hello!")) ++ "$"
|
