Done tracing

diff --git a/src/Main.hs b/src/Main.hs
index 0c9ceea89dc24a1b597f6cc964f8eacbe9d86a43..be6e522cf64b1980bab72cb877512a8f37a44f72 100644 (file)
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -28,6 +28,8 @@ data SynacorState = SynacorState
   , _ssContinue :: Bool
   , _ssUnsaved :: Bool
   , _ssState :: [ExecutionState]
+  , _ssTracing :: Bool
+  , _ssDumpFile :: String
   } deriving (Ord, Eq)
 makeLenses ''SynacorState
 
@@ -42,6 +44,8 @@ instance Show SynacorState
             , "conts " ++ (show $ state ^. ssContinue)
             , "unsaved " ++ (show $ state ^. ssUnsaved)
             , "states " ++ (show $ state ^. ssState)
+            , "tracing " ++ (show $ state ^. ssTracing) 
+            , "dumping to " ++ (state ^. ssDumpFile)
             ]
 
 main :: IO ()
@@ -77,19 +81,43 @@ emptyState :: IO SynacorState
 emptyState = 
   do  mem <- getMemory
       let machine = makeMachine mem
-      return $ SynacorState [machine] [] [] True False [Runnable]
+      return $ SynacorState 
+                { _ssMachines = [machine]
+                , _ssInputs = []
+                , _ssOutputs = []
+                , _ssContinue = True
+                , _ssUnsaved = False
+                , _ssState = [Runnable]
+                , _ssTracing = False
+                , _ssDumpFile = ""
+              }
+     -- [machine] [] [] True False [Runnable]
 
 adventureHarness :: SynacorState -> IO SynacorState
 adventureHarness state =
   do command <- prompt "> "
      state' <- handleCommand command state
-     let newOutput = head $ state' ^. ssOutputs
+     let traceAndOutput = head $ state' ^. ssOutputs
+     let (newOutput, tracing) = spliceOut traceAndOutput
      putStrLn newOutput
+     when (state' ^. ssTracing)
+          (appendFile (state' ^. ssDumpFile) $ unlines tracing)
      if (state' ^. ssContinue) 
         then (adventureHarness state')
         else return state'
 
 
+spliceOut :: String -> (String, [String])
+spliceOut s = doingOut s "" []
+  where doingOut s out traces
+          | null s = (reverse out, reverse traces)
+          | ">> " `isPrefixOf` s = doingTrace (drop 3 s) out traces ""
+          | otherwise = doingOut (tail s) (head s : out) traces
+        doingTrace s out traces tr
+          | "<<" `isPrefixOf` s = doingOut (drop 2 s) out (reverse tr : traces)
+          | otherwise = doingTrace (tail s) out traces (head s : tr)
+
+
 handleCommand :: String -> SynacorState -> IO SynacorState
 handleCommand ":quit" state = return $ state & ssContinue .~ False
 handleCommand ":save" state = 
@@ -102,7 +130,7 @@ handleCommand ":load" state =
       machineInput <- readFile filename
       let inputs = lines machineInput
       initialState <- emptyState
-      let nonComments = filter (\i -> head i == '#') inputs
+      let nonComments = filter (\i -> head i /= '#') inputs
       let state = foldl' runOneInput initialState ("" : nonComments)
       return $ state & ssUnsaved .~ False
 handleCommand ":undo" state =
@@ -121,6 +149,16 @@ handleCommand ":recap" state =
            putStrLn o
         )
      return state
+handleCommand ":trace" state = 
+  do  filename <- prompt "Dump to? "
+      return $ state & ssTracing .~ True & ssDumpFile .~ filename
+handleCommand ":untrace" state = 
+  return $ state & ssTracing .~ False & ssDumpFile .~ ""
+handleCommand ":poke8"  state =
+  do let machines = state ^. ssMachines
+     let machine = head machines
+     let machine' = machine & registers . ix 7 .~ 1
+     return $ state & ssMachines .~ (machine' : (tail machines)) 
 handleCommand command state = return $ runOneInput state command
 
 
@@ -141,7 +179,10 @@ runOneInput state input = state & ssMachines %~ (machine' :)
                                 & ssContinue .~ True
                                 & ssUnsaved .~ True
                                 & ssState %~ (exState :)
-  where machine = head $ state ^. ssMachines
+  where machine0 = head $ state ^. ssMachines
+        machine = if (state ^. ssTracing)
+                     then machine0 & tracing .~ True
+                     else machine0 & tracing .~ False
         inputW = wordify (input ++ "\n")
         (exState, machine', output) = runMachine inputW (machine & inputIndex .~ 0)
         -- output' = trace ("runone " ++ (show (machine == machine')) ++ " " ++ (show exState) ++ " " ++ (showOutput output)) output

diff --git a/src/SynacorEngine.hs b/src/SynacorEngine.hs
index e036f5c09193e91fd7e0b74f5704d53e3318ed1e..cbd5e047c0792ade68966ec4d92788923218e446 100644 (file)
--- a/src/SynacorEngine.hs
+++ b/src/SynacorEngine.hs
@@ -11,6 +11,7 @@ import qualified Data.Map.Strict as M
 import Data.Map.Strict ((!))
 import Control.Lens
 import Data.List
+import Data.Char
 import Numeric
 
 import Control.Monad.State.Strict
@@ -27,6 +28,7 @@ data Machine = Machine { _memory :: Memory
                        , _registers :: Memory
                        , _inputIndex :: Int
                        , _stack :: [Word16]
+                       , _tracing :: Bool
                        } 
                deriving (Show, Eq, Ord)
 makeLenses ''Machine
@@ -48,6 +50,7 @@ makeMachine memory = Machine
   , _registers = M.fromList [ (r, 0) | r <- [0..7] ]
   , _memory = memory
   , _stack = []
+  , _tracing = False
   }
 
 -- traceMachine x = 
@@ -85,6 +88,7 @@ makeMachine memory = Machine
 runAll :: ProgrammedMachine ExecutionState
 runAll = do cip <- gets _ip
             opcode <- getLocation cip
+            traceMachine
             -- opcode' <- traceMachine opcode
             -- exState <- runStep opcode'
             exState <- runStep opcode
@@ -251,7 +255,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 +266,51 @@ runStep _ =
      return Runnable
 
 
+traceMachine :: ProgrammedMachine ()
+traceMachine = do
+  isTracing <- gets _tracing
+  when isTracing
+    do  cip <- gets _ip
+        opcode <- getLocation cip
+        a <- getLocation (cip + 1)
+        b <- getLocation (cip + 2)
+        c <- getLocation (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", sa, sb, sc, "*", sva, svb, svc]
+                _ -> ["illegal", sa, sb, sc, "*", sva, svb, svc]
+        tell $ fmap (fromIntegral . ord) (">> " ++ (show cip) ++ ": " ++ (intercalate " " traceText) ++ "<<")
+
 getValue :: Word16 -> ProgrammedMachine Word16
 getValue loc =
   do mem <- gets _memory