# HG changeset patch
# User HackBot
# Date 1360912594 0
# Node ID 463776b34329767fe0191d721db3799fcd649824
# Parent  9115bf1f2da4695921eef3ef3cdfb45f682b5748
<oerjan> fetch http://oerjan.nvg.org/esoteric/emmental.hs

diff -r 9115bf1f2da4 -r 463776b34329 emmental.hs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/emmental.hs	Fri Feb 15 07:16:34 2013 +0000
@@ -0,0 +1,431 @@
+--
+-- 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.
+--
+-- Ørjan Johansen added main
+--
+
+
+import qualified Data.Map as Map
+import qualified Data.Char as Char
+import System.Environment (getArgs)
+
+main = do
+    args <- getArgs
+    case args of
+        "-d" : as -> debug =<< parse return as
+        _ -> emmental =<< parse return args
+  where
+    parse :: (String -> IO String) -> [String] -> IO String
+    parse _ ("-f":as) = parse readFile as
+    parse _ ("-e":as) = parse return as
+    parse op (a:as) = op a >>= (`fmap` parse op as) . (++)
+    parse _ [] = return ""
+
+
+-----------------------------------------------------------------------
+-- ============================ 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!")) ++ "$"