Mercurial > repo

comparison emmental.hs @ 2135:463776b34329

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
<oerjan> fetch http://oerjan.nvg.org/esoteric/emmental.hs
author HackBot
date Fri, 15 Feb 2013 07:16:34 +0000
parents
children
comparison
equal deleted inserted replaced
2134:9115bf1f2da4 2135:463776b34329
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!")) ++ "$"