Mercurial > repo
changeset 2134:9115bf1f2da4
<oerjan> rm emmental.hs
| author | HackBot |
|---|---|
| date | Fri, 15 Feb 2013 07:16:15 +0000 |
| parents | 68c6eed90574 |
| children | 463776b34329 |
| files | emmental.hs |
| diffstat | 1 files changed, 0 insertions(+), 416 deletions(-) [+] |
line wrap: on
line diff
--- a/emmental.hs Fri Feb 15 06:44:00 2013 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,416 +0,0 @@ --- --- emmental.hs --- Interpreter for the Emmental Programming Language --- Chris Pressey, Cat's Eye Technologies --- This work is in the public domain. See UNLICENSE for more information. --- - - -import qualified Data.Map as Map -import qualified Data.Char as Char - - ------------------------------------------------------------------------ --- ============================ Symbols ============================ -- ------------------------------------------------------------------------ - -type Symbol = Char - - ------------------------------------------------------------------------ --- ======================== Program States ========================= -- ------------------------------------------------------------------------ - -data State = State [Symbol] [Symbol] - deriving (Ord, Eq, Show) - -pop (State (head:tail) queue) = (head, State tail queue) -push (State list queue) sym = (State (sym:list) queue) - -popString (State (';':tail) queue) = ([], State tail queue) -popString (State (head:tail) queue) = - let - (string, state') = popString (State tail queue) - in - (string ++ [head], state') - -enqueue (State stack queue) symbol = State stack (symbol:queue) -dequeue (State stack queue) = - let - symbol = last queue - queue' = init queue - in - (symbol, State stack queue') - - ------------------------------------------------------------------------ --- ========================= Interpreters ========================== -- ------------------------------------------------------------------------ - -data Interpreter = Interp (Map.Map Symbol Operation) - -fetch (Interp map) sym = Map.findWithDefault (fitRegOp opNop) sym map -supplant (Interp map) sym op = (Interp (Map.insert sym op map)) - - ------------------------------------------------------------------------ --- ========================== Operations =========================== -- ------------------------------------------------------------------------ - -type Operation = State -> Interpreter -> IO (State, Interpreter) - -composeOps :: Operation -> Operation -> Operation - -composeOps op1 op2 = f where - f state interpreter = do - (state', interpreter') <- op1 state interpreter - op2 state' interpreter' - -createOp :: Interpreter -> [Symbol] -> Operation - -createOp interpreter [] = - (fitRegOp opNop) -createOp interpreter (head:tail) = - composeOps (fetch interpreter head) (createOp interpreter tail) - --- --- It's useful for us to express a lot of our operators as non-monadic --- functions that don't affect the interpreter. This is a little "adapter" --- function that lets us create monadic functions with the right signature --- from them. --- - -fitRegOp :: (State -> State) -> Operation - -fitRegOp regop = f where - f state interpreter = - let - state' = regop state - in - do return (state', interpreter) - - ------------------------------------------------------------- ---------------- The operations themselves. ----------------- ------------------------------------------------------------- - --- --- Redefine the meaning of the symbol on the stack with --- a mini-program also popped off the stack. --- - -opSupplant state interpreter = - let - (opSym, state') = pop state - (newOpDefn, state'') = popString state' - newOp = createOp interpreter newOpDefn - in - do return (state'', supplant interpreter opSym newOp) - --- --- Execute the symbol on the stack with the current interpreter. --- - -opEval state interpreter = - let - (opSym, state') = pop state - newOp = createOp interpreter [opSym] - in - newOp state' interpreter - --- --- I/O. --- - -opInput state interpreter = do - symbol <- getChar - do return (push state symbol, interpreter) - -opOutput state interpreter = - let - (symbol, state') = pop state - in do - putChar symbol - return (state', interpreter) - --- --- Primitive arithmetic. --- - -opAdd state = - let - (symA, state') = pop state - (symB, state'') = pop state' - in - push state'' (Char.chr (((Char.ord symB) + (Char.ord symA)) `mod` 256)) - -opSubtract state = - let - (symA, state') = pop state - (symB, state'') = pop state' - in - push state'' (Char.chr (((Char.ord symB) - (Char.ord symA)) `mod` 256)) - -discreteLog 0 = 8 -discreteLog 1 = 0 -discreteLog 2 = 1 -discreteLog n = (discreteLog (n `div` 2)) + 1 - -opDiscreteLog state = - let - (symbol, state') = pop state - in - push state' (Char.chr (discreteLog (Char.ord symbol))) - --- --- Stack manipulation. --- - --- --- Pop the top symbol of the stack, make a copy of it, push it back onto the --- stack, and enqueue the copy onto the queue. --- - -opEnqueueCopy state = - let - (sym, _) = pop state - in - enqueue state sym - --- --- Dequeue a symbol from the queue and push it onto the stack. --- - -opDequeue state = - let - (sym, state') = dequeue state - in - push state' sym - --- --- Duplicate the top symbol of the stack. --- - -opDuplicate state = - let - (symbol, _) = pop state - in - push state symbol - --- --- Miscellaneous operations. --- - -opNop state = - state - --- --- Parameterizable operations. --- - -opPushValue value state = - push state (Char.chr value) - -opAccumValue value state = - let - (sym, state') = pop state - value' = ((Char.ord sym) * 10) + value - in - push state' (Char.chr (value' `mod` 256)) - - ------------------------------------------------------------------------ --- ===================== Debugging Functions ======================= -- ------------------------------------------------------------------------ - -type Debugger = State -> Interpreter -> IO () - -debugNop s i = do - return () - -debugPrintState s i = do - putStr ((show s) ++ "\n") - return () - - ------------------------------------------------------------------------ --- ============================ Executor =========================== -- ------------------------------------------------------------------------ - -execute :: [Symbol] -> State -> Interpreter -> Debugger -> IO (State, Interpreter) - -execute [] state interpreter debugger = - return (state, interpreter) -execute (opSym:program') state interpreter debugger = - let - operation = fetch interpreter opSym - in do - (state', interpreter') <- operation state interpreter - debugger state' interpreter' - execute program' state' interpreter' debugger - - ------------------------------------------------------------------------ --- ====================== Top-Level Function ======================= -- ------------------------------------------------------------------------ - -initialInterpreter = Interp - (Map.fromList - [ - ('.', opOutput), - (',', opInput), - - ('#', fitRegOp (opPushValue 0)), - ('0', fitRegOp (opAccumValue 0)), - ('1', fitRegOp (opAccumValue 1)), - ('2', fitRegOp (opAccumValue 2)), - ('3', fitRegOp (opAccumValue 3)), - ('4', fitRegOp (opAccumValue 4)), - ('5', fitRegOp (opAccumValue 5)), - ('6', fitRegOp (opAccumValue 6)), - ('7', fitRegOp (opAccumValue 7)), - ('8', fitRegOp (opAccumValue 8)), - ('9', fitRegOp (opAccumValue 9)), - - ('+', fitRegOp opAdd), - ('-', fitRegOp opSubtract), - ('~', fitRegOp opDiscreteLog), - - ('^', fitRegOp opEnqueueCopy), - ('v', fitRegOp opDequeue), - (':', fitRegOp opDuplicate), - - ('!', opSupplant), - ('?', opEval), - - (';', fitRegOp (opPushValue (Char.ord ';'))) - ] - ) - -initialState = State [] [] - -emmental string = do - (state, interpreter) <- execute string initialState initialInterpreter debugNop - return state - -debug string = do - (state, interpreter) <- execute string initialState initialInterpreter debugPrintState - return state - - ------------------------------------------------------------------------ --- ========================== Test Cases =========================== -- ------------------------------------------------------------------------ - --- --- Drivers for test cases. 'demo' runs them straight, whereas 'test' --- uses the debugger. --- - -demo n = emmental (testProg n) - -test n = debug (testProg n) - --- --- Here we introduce a bit of a cheat, in order to make writing --- complex Emmental programs tolerable. You can still see the --- programs in their fully glory by executing "show (testProg n)". --- - -quote [] = [] -quote (symbol:rest) = "#" ++ (show (Char.ord symbol)) ++ (quote rest) - --- --- Add one and one. --- - -testProg 1 = "#1#1+" - --- --- Redefine & as "+". --- - -testProg 2 = ";#43#38!#1#1&" -- 59,43,38 ==> ";+&" - --- --- Redefine 0 as "9". --- - -testProg 3 = ";#57#48!#0" -- 59,57,48 ==> ";90" - --- --- Redefine 0 as "#48?". This results in an infinite loop when 0 is executed. --- - -testProg 4 = ";#35#52#56#63#48!0" -- 59,35,52,56,63,48 ==> ";#48?0" - --- --- Redefine $ as ".#36?". This results in a loop that pops symbols and --- and prints them, until the stack underflows, when $ is executed. --- - -testProg 5 = ";#46#35#51#54#63#36! #65#66#67#68#69$" - --- --- Duplicate the top stack element (assuming an empty queue.) --- This shows that the : operation is not strictly necessary --- (when you know the size of the queue.) --- - -testProg 6 = "#65^v" - --- --- Discard the top stack element (assuming more than one element --- on the stack, and an empty queue.) --- - -testProg 7 = "#33#123^v-+" - --- --- Swap the top two elements of the stack (assuming an empty queue.) --- - -testProg 8 = "#67#66#65^v^-+^^v^v^v-+^v-+^v-+vv" - --- --- Input a symbol. Report whether its ASCII value is even or odd. --- - -testProg 9 = (quote ";^v:") ++ "!" ++ -- : = dup - (quote ";#69.") ++ "#!" ++ -- NUL = print "E" - (quote ";#79.") ++ "#128!" ++ -- \128 = print "O" - (quote (";" ++ (take 127 [':',':'..]) ++ -- m = mul by 128 - (take 127 ['+','+'..]) ++ "m")) ++ "!" ++ - ",m?" - --- --- Input a symbol. Report whether it is M or not. --- - -testProg 10 = (quote ";#78.") ++ "#!" ++ -- NUL = print "N" - ";##1!" ++ -- SOH = same as NUL - ";##2!" ++ -- STX = same as NUL - ";##3!" ++ -- ETX = same as NUL - ";##4!" ++ -- EOT = same as NUL - ";##5!" ++ -- ENQ = same as NUL - ";##6!" ++ -- ACK = same as NUL - ";##7!" ++ -- BEL = same as NUL - (quote ";#89.") ++ "#8!" ++ -- BS = print "Y" - ",#77-~?" - --- --- Same as testProg 5, except stop printing when a NUL is --- encountered, instead of just underflowing the stack. --- - -testProg 11 = ";" ++ (quote ":~?$") ++ "!" ++ -- $ = dup & test - ";" ++ (quote ".$") ++ "#!" ++ -- NUL = print & repeat - ";#0#1!" ++ -- SOH = same as NUL - ";#0#2!" ++ -- STX = same as NUL - ";#0#3!" ++ -- ETX = same as NUL - ";#0#4!" ++ -- EOT = same as NUL - ";#0#5!" ++ -- ENQ = same as NUL - ";#0#6!" ++ -- ACK = same as NUL - ";#0#7!" ++ -- BEL = same as NUL - -- BS = stop (nop) - "#0" ++ (quote (reverse "Hello!")) ++ "$"