src/SynacorEngine.hs

   1 module SynacorEngine where
   2
   3 import Debug.Trace
   4
   5 -- import System.Environment
   6 import Data.Bits
   7 import Data.Word
   8 -- import Data.Binary.Get
   9 -- import qualified Data.ByteString.Lazy as BL
  10 import qualified Data.Map.Strict as M
  11 import Data.Map.Strict ((!))
  12 import Control.Lens
  13 import Data.List
  14 import Data.Char
  15 import Numeric
  16
  17 import Control.Monad.State.Strict
  18 import Control.Monad.Reader
  19 import Control.Monad.Writer
  20 import Control.Monad.RWS.Strict
  21
  22 type Memory = M.Map Word16 Word16
  23
  24
  25
  26 data Machine = Machine { _memory :: Memory
  27                        , _ip :: Word16
  28                        , _registers :: Memory
  29                        , _inputIndex :: Int
  30                        , _stack :: [Word16]
  31                        , _tracing :: Bool
  32                        }
  33                deriving (Show, Eq, Ord)
  34 makeLenses ''Machine
  35
  36 type ProgrammedMachine = RWS [Word16] [Word16] Machine
  37
  38 data ExecutionState = Runnable | Blocked | Terminated  deriving (Ord, Eq, Show)
  39
  40 -- returns (returnValue, finalMachine, outputs)
  41
  42 runMachine :: [Word16] -> Machine -> (ExecutionState, Machine, [Word16])
  43 runMachine inputs machine = runRWS runAll inputs machine
  44
  45
  46 makeMachine :: Memory -> Machine
  47 makeMachine memory = Machine
  48   { _ip = 0
  49   , _inputIndex = 0
  50   , _registers = M.fromList [ (r, 0) | r <- [0..7] ]
  51   , _memory = memory
  52   , _stack = []
  53   , _tracing = False
  54   }
  55
  56 -- traceMachine x =
  57 --   do cip <- gets _ip
  58 --      opcode <- getLocation cip
  59 --      arg1 <- getValue (cip + 1)
  60 --      arg2 <- getValue (cip + 2)
  61 --      arg3 <- getValue (cip + 3)
  62 --      mem <- gets _memory
  63 --      regs <- gets _registers
  64 --      let raw1 = mem ! (cip + 1)
  65 --      let raw2 = mem ! (cip + 2)
  66 --      let raw3 = mem ! (cip + 3)
  67 --      let x' = trace (
  68 --               intercalate ": "
  69 --                 [ "IP Addr"
  70 --                 , show (showHex (cip * 2) "")
  71 --                 , "IP"
  72 --                 , (show (showHex cip ""))
  73 --                 , "Op"
  74 --                 , show (opcode)
  75 --                 , "Args"
  76 --                 , show (showHex arg1 "")
  77 --                 , show (showHex arg2 "")
  78 --                 , show (showHex arg3 "")
  79 --                 , "Raw"
  80 --                 , show (showHex raw1 "")
  81 --                 , show (showHex raw2 "")
  82 --                 , show (showHex raw3 "")
  83 --                 , show (M.elems regs)
  84 --                 ]
  85 --           ) x
  86 --      return x'
  87
  88 runAll :: ProgrammedMachine ExecutionState
  89 runAll = do cip <- gets _ip
  90             opcode <- getLocation cip
  91             traceMachine
  92             -- opcode' <- traceMachine opcode
  93             -- exState <- runStep opcode'
  94             exState <- runStep opcode
  95             case exState of
  96               Terminated -> return Terminated
  97               Blocked -> return Blocked
  98               _ -> runAll
  99
 100
 101 runStep :: Word16 -> ProgrammedMachine ExecutionState
 102 -- runStep n | trace (show n) False = undefined
 103 runStep 0 = return Terminated
 104 runStep 1 =
 105   do cip <- gets _ip
 106      regR <- getLocation (cip + 1)
 107      let reg = regR .&. 7
 108      value <- getValue (cip + 2)
 109      advanceIP 3
 110      modify (\m -> m & registers . ix reg .~ value)
 111      return Runnable
 112 runStep 2 =
 113   do cip <- gets _ip
 114      value <- getValue (cip + 1)
 115      advanceIP 2
 116      modify (\m -> m & stack %~ (value :) )
 117      return Runnable
 118 runStep 3 =
 119   do cip <- gets _ip
 120      tgt <- getLocation (cip + 1)
 121      val <- gets (\m -> head $ m ^. stack)
 122      modify (\m -> m & stack %~ tail )
 123      putValue tgt val
 124      advanceIP 2
 125      return Runnable
 126 runStep 4 =
 127   do cip <- gets _ip
 128      tgt <- getLocation (cip + 1)
 129      b <- getValue (cip + 2)
 130      c <- getValue (cip + 3)
 131      putValue tgt (if b == c then 1 else 0)
 132      modify (\m -> m & ip %~ (+ 4))
 133      return Runnable
 134 runStep 5 =
 135   do cip <- gets _ip
 136      tgt <- getLocation (cip + 1)
 137      b <- getValue (cip + 2)
 138      c <- getValue (cip + 3)
 139      putValue tgt (if b > c then 1 else 0)
 140      advanceIP 4
 141      return Runnable
 142 runStep 6 =
 143   do cip <- gets _ip
 144      tgt <- getLocation (cip + 1)
 145      modify (\m -> m & ip .~ tgt)
 146      return Runnable
 147 runStep 7 =
 148   do cip <- gets _ip
 149      a <- getValue (cip + 1)
 150      tgt <- getLocation (cip + 2)
 151      if a /= 0
 152       then modify (\m -> m & ip .~ tgt)
 153       else advanceIP 3
 154      return Runnable
 155 runStep 8 =
 156   do cip <- gets _ip
 157      a <- getValue (cip + 1)
 158      tgt <- getLocation (cip + 2)
 159      if a == 0
 160       then modify (\m -> m & ip .~ tgt)
 161       else advanceIP 3
 162      return Runnable
 163
 164 runStep 9 =
 165   do cip <- gets _ip
 166      a <- getLocation (cip + 1)
 167      b <- getValue (cip + 2)
 168      c <- getValue (cip + 3)
 169      putValue a (b + c)
 170      advanceIP 4
 171      return Runnable
 172 runStep 10 =
 173   do cip <- gets _ip
 174      a <- getLocation (cip + 1)
 175      b <- getValue (cip + 2)
 176      c <- getValue (cip + 3)
 177      putValue a (b * c)
 178      advanceIP 4
 179      return Runnable
 180 runStep 11 =
 181   do cip <- gets _ip
 182      a <- getLocation (cip + 1)
 183      b <- getValue (cip + 2)
 184      c <- getValue (cip + 3)
 185      putValue a (b `mod` c)
 186      advanceIP 4
 187      return Runnable
 188 runStep 12 =
 189   do cip <- gets _ip
 190      a <- getLocation (cip + 1)
 191      b <- getValue (cip + 2)
 192      c <- getValue (cip + 3)
 193      putValue a (b .&. c)
 194      advanceIP 4
 195      return Runnable
 196 runStep 13 =
 197   do cip <- gets _ip
 198      a <- getLocation (cip + 1)
 199      b <- getValue (cip + 2)
 200      c <- getValue (cip + 3)
 201      putValue a (b .|. c)
 202      advanceIP 4
 203      return Runnable
 204 runStep 14 =
 205   do cip <- gets _ip
 206      a <- getLocation (cip + 1)
 207      b <- getValue (cip + 2)
 208      putValue a (complement b)
 209      advanceIP 3
 210      return Runnable
 211
 212 runStep 15 =
 213   do cip <- gets _ip
 214      a <- getLocation (cip + 1)
 215      b <- getValue (cip + 2)
 216      v <- getValue b
 217      putValue a v
 218      advanceIP 3
 219      return Runnable
 220 runStep 16 =
 221   do cip <- gets _ip
 222      a <- getValue (cip + 1)
 223      b <- getValue (cip + 2)
 224      putValue a b
 225      advanceIP 3
 226      return Runnable
 227
 228 runStep 17 =
 229   do cip <- gets _ip
 230      a <- getValue (cip + 1)
 231      modify (\m -> m & stack %~ ((cip + 2) :)
 232                      & ip .~ a)
 233      return Runnable
 234
 235 runStep 18 =
 236   do val <- gets (\m -> head $ m ^. stack)
 237      modify (\m -> m & stack %~ tail
 238                      & ip .~ val)
 239      return Runnable
 240
 241 runStep 19 =
 242   do cip <- gets _ip
 243      v <- getValue (cip + 1)
 244      tell [v]
 245      advanceIP 2
 246      return Runnable
 247
 248 runStep 20 =
 249   do iIndex <- gets _inputIndex
 250      inputs <- ask
 251      cip <- gets _ip
 252      tgt <- getLocation (cip + 1)
 253      if (iIndex + 1) > (length inputs)
 254       then return Blocked
 255       else do let char = (inputs!!iIndex)
 256               putValue tgt char
 257               modify (\m -> m & inputIndex %~ (+ 1))
 258               advanceIP 2
 259               return Runnable
 260
 261 runStep 21 =
 262   do advanceIP 1
 263      return Runnable
 264 runStep _ =
 265   do advanceIP 1
 266      return Runnable
 267
 268
 269 traceMachine :: ProgrammedMachine ()
 270 traceMachine = do
 271   isTracing <- gets _tracing
 272   when isTracing
 273     do  cip <- gets _ip
 274         opcode <- getLocation cip
 275         a <- getLocation (cip + 1)
 276         b <- getLocation (cip + 2)
 277         c <- getLocation (cip + 3)
 278         let sa = show a
 279         let sb = show b
 280         let sc = show c
 281         va <- getValue (cip + 1)
 282         vb <- getValue (cip + 2)
 283         vc <- getValue (cip + 3)
 284         let sva = show va
 285         let svb = show vb
 286         let svc = show vc
 287         let traceText =
 288               case opcode of
 289                 0 -> ["halt"]
 290                 1 -> ["set", sa, sb, "*", sva, svb]
 291                 2 -> ["push", sa, "*", sva]
 292                 3 -> ["pop", sa, "*", sva]
 293                 4 -> ["eq", sa, sb, sc, "*", sva, svb, svc]
 294                 5 -> ["gt", sa, sb, sc, "*", sva, svb, svc]
 295                 6 -> ["jmp", sa, "*", sva]
 296                 7 -> ["jt", sa, sb, "*", sva, svb]
 297                 8 -> ["jf", sa, sb, "*", sva, svb]
 298                 9 -> ["add", sa, sb, sc, "*", sva, svb, svc]
 299                 10 -> ["mul", sa, sb, sc, "*", sva, svb, svc]
 300                 11 -> ["mod", sa, sb, sc, "*", sva, svb, svc]
 301                 12 -> ["and", sa, sb, sc, "*", sva, svb, svc]
 302                 13 -> ["or", sa, sb, sc, "*", sva, svb, svc]
 303                 14 -> ["not", sa, sb, "*", sva, svb]
 304                 15 -> ["rmem", sa, sb, "*", sva, svb]
 305                 16 -> ["wmem", sa, sb, "*", sva, svb]
 306                 17 -> ["call", sa, "*", sva]
 307                 18 -> ["ret"]
 308                 19 -> ["out", sa, "*", sva]
 309                 20 -> ["in", sa, "*", sva]
 310                 21 -> ["noop", sa, sb, sc, "*", sva, svb, svc]
 311                 _ -> ["illegal", sa, sb, sc, "*", sva, svb, svc]
 312         tell $ fmap (fromIntegral . ord) (">> " ++ (show cip) ++ ": " ++ (intercalate " " traceText) ++ "<<")
 313
 314 getValue :: Word16 -> ProgrammedMachine Word16
 315 getValue loc =
 316   do mem <- gets _memory
 317      regs <- gets _registers
 318      let val = mem ! loc
 319      if val < (2 ^ 15)
 320         then return val
 321         else return (regs ! (val .&. 7))
 322
 323
 324
 325   -- | loc < 32768 =
 326   --     do mem <- gets _memory
 327   --        return $ mem ! loc
 328   -- | otherwise =
 329   --     do regs <- gets _registers
 330   --        return $ regs ! (loc `shiftR` 15)
 331
 332 getLocation :: Word16 -> ProgrammedMachine Word16
 333 getLocation loc =
 334   do mem <- gets _memory
 335      return $ mem ! loc
 336
 337 putValue :: Word16 -> Word16 -> ProgrammedMachine ()
 338 putValue loc value
 339   | loc < (2 ^ 15) = modify (\m -> m & memory . ix loc .~ v)
 340   | otherwise      = modify (\m -> m & registers . ix (loc .&. 7) .~ v)
 341   where v = value `mod` (2 ^ 15)
 342
 343 advanceIP :: Word16 -> ProgrammedMachine ()
 344 advanceIP delta = modify (\m -> m & ip %~ (+ delta))