Completed puzzle

[synacor-challenge.git] / src / SynacorEngine.hs

diff --git a/src/SynacorEngine.hs b/src/SynacorEngine.hs
index e036f5c09193e91fd7e0b74f5704d53e3318ed1e..63fb20c60be300c6e4fa23402578523c8aad612d 100644 (file)
--- a/src/SynacorEngine.hs
+++ b/src/SynacorEngine.hs
@@ -1,6 +1,6 @@
 module SynacorEngine where
 
-import Debug.Trace
+-- import Debug.Trace
 
 -- import System.Environment
 import Data.Bits
@@ -11,7 +11,8 @@ import qualified Data.Map.Strict as M
 import Data.Map.Strict ((!))
 import Control.Lens
 import Data.List
-import Numeric
+import Data.Char
+-- import Numeric
 
 import Control.Monad.State.Strict
 import Control.Monad.Reader
@@ -27,6 +28,7 @@ data Machine = Machine { _memory :: Memory
                        , _registers :: Memory
                        , _inputIndex :: Int
                        , _stack :: [Word16]
+                       , _tracing :: Bool
                        } 
                deriving (Show, Eq, Ord)
 makeLenses ''Machine
@@ -38,16 +40,17 @@ data ExecutionState = Runnable | Blocked | Terminated  deriving (Ord, Eq, Show)
 -- returns (returnValue, finalMachine, outputs)
 
 runMachine :: [Word16] -> Machine -> (ExecutionState, Machine, [Word16])
-runMachine inputs machine = runRWS runAll inputs machine
+runMachine inputs machine = runRWS (runAll (10 ^ 6)) inputs machine
 
 
 makeMachine :: Memory -> Machine
-makeMachine memory = Machine
+makeMachine mem = Machine
   { _ip = 0
   , _inputIndex = 0
   , _registers = M.fromList [ (r, 0) | r <- [0..7] ]
-  , _memory = memory
+  , _memory = mem
   , _stack = []
+  , _tracing = False
   }
 
 -- traceMachine x = 
@@ -82,16 +85,20 @@ makeMachine memory = Machine
 --           ) x
 --      return x'
 
-runAll :: ProgrammedMachine ExecutionState
-runAll = do cip <- gets _ip
-            opcode <- getLocation cip
-            -- opcode' <- traceMachine opcode
-            -- exState <- runStep opcode'
-            exState <- runStep opcode
-            case exState of
-              Terminated -> return Terminated
-              Blocked -> return Blocked
-              _ -> runAll
+runAll :: Int -> ProgrammedMachine ExecutionState
+runAll executionLimit 
+  | executionLimit == 0 = return Terminated
+  | otherwise = 
+      do  cip <- gets _ip
+          opcode <- getLocation cip
+          traceMachine
+          -- opcode' <- traceMachine opcode
+          -- exState <- runStep opcode'
+          exState <- runStep opcode
+          case exState of
+            Terminated -> return Terminated
+            Blocked -> return Blocked
+            _ -> runAll (executionLimit - 1)
 
 
 runStep :: Word16 -> ProgrammedMachine ExecutionState
@@ -251,7 +258,7 @@ runStep 20 =
       else do let char = (inputs!!iIndex)
               putValue tgt char
               modify (\m -> m & inputIndex %~ (+ 1))
-              advanceIP 2
+              advanceIP 2     
               return Runnable
 
 runStep 21 = 
@@ -262,6 +269,81 @@ runStep _ =
      return Runnable
 
 
+traceMachine :: ProgrammedMachine ()
+traceMachine = do
+  isTracing <- gets _tracing
+  when isTracing
+       do cip <- gets _ip
+          (l, _) <- dissembleInstruction cip
+          regs <- gets _registers
+          let regVals = intercalate "; " $ fmap show $ M.elems regs
+          stk <- gets _stack
+          let stackVals = intercalate "; " $ fmap show $ take 10 stk
+          tell $ fmap (fromIntegral . ord) (">> " ++ l ++ " : r> " ++ regVals ++ " : s> " ++ stackVals ++ "<<")
+
+runDissemble :: Word16 -> Int -> Machine -> [String]
+runDissemble startAt num machine =fst $ evalRWS (dissemble startAt num) [] machine
+
+
+dissemble :: Word16 -> Int -> ProgrammedMachine [String]
+dissemble startAt num = go startAt num []
+  where go _ 0 ls = return $ reverse ls
+        go here n ls = 
+          do (line, step) <- dissembleInstruction here
+             go (here + step) (n - 1) (line : ls)
+
+dissembleInstruction :: Word16 -> ProgrammedMachine (String, Word16)  
+dissembleInstruction cip =
+    do  -- cip <- gets _ip
+        opcode <- getLocation cip
+        mem <- gets _memory
+        let a = mem ! (cip + 1)
+        let b = mem ! (cip + 2)
+        let c = mem ! (cip + 3)
+        let sa = show a
+        let sb = show b
+        let sc = show c
+        va <- getValue (cip + 1)
+        vb <- getValue (cip + 2)
+        vc <- getValue (cip + 3)
+        let sva = show va
+        let svb = show vb
+        let svc = show vc        
+        let traceText = 
+              case opcode of
+                0 -> ["halt"]
+                1 -> ["set", sa, sb, "*", sva, svb]
+                2 -> ["push", sa, "*", sva]
+                3 -> ["pop", sa, "*", sva]
+                4 -> ["eq", sa, sb, sc, "*", sva, svb, svc]
+                5 -> ["gt", sa, sb, sc, "*", sva, svb, svc]
+                6 -> ["jmp", sa, "*", sva]
+                7 -> ["jt", sa, sb, "*", sva, svb]
+                8 -> ["jf", sa, sb, "*", sva, svb]
+                9 -> ["add", sa, sb, sc, "*", sva, svb, svc]
+                10 -> ["mul", sa, sb, sc, "*", sva, svb, svc]
+                11 -> ["mod", sa, sb, sc, "*", sva, svb, svc]
+                12 -> ["and", sa, sb, sc, "*", sva, svb, svc]
+                13 -> ["or", sa, sb, sc, "*", sva, svb, svc]
+                14 -> ["not", sa, sb, "*", sva, svb]
+                15 -> ["rmem", sa, sb, "*", sva, svb]
+                16 -> ["wmem", sa, sb, "*", sva, svb]
+                17 -> ["call", sa, "*", sva]
+                18 -> ["ret"]
+                19 -> ["out", sa, "*", sva]
+                20 -> ["in", sa, "*", sva]
+                21 -> ["noop"]
+                _ -> ["illegal", sa, sb, sc, "*", sva, svb, svc]
+        let stepSize =
+              if | opcode `elem` [0, 18, 21] -> 1
+                 | opcode `elem` [2, 3, 6, 17, 19, 20] -> 2
+                 | opcode `elem` [1, 7, 8, 14, 15, 16] -> 3
+                 | opcode `elem` [4, 5, 9, 10, 11, 12, 13] -> 4
+                 | otherwise -> 1
+        return ( ((show cip) ++ ": " ++ (intercalate " " traceText))
+               , stepSize
+               )
+
 getValue :: Word16 -> ProgrammedMachine Word16
 getValue loc =
   do mem <- gets _memory