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 (10 ^ 6)) 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 :: Int -> ProgrammedMachine ExecutionState
  89 runAll executionLimit
  90   | executionLimit == 0 = return Terminated
  91   | otherwise =
  92       do  cip <- gets _ip
  93           opcode <- getLocation cip
  94           traceMachine
  95           -- opcode' <- traceMachine opcode
  96           -- exState <- runStep opcode'
  97           exState <- runStep opcode
  98           case exState of
  99             Terminated -> return Terminated
 100             Blocked -> return Blocked
 101             _ -> runAll (executionLimit - 1)
 102
 103
 104 runStep :: Word16 -> ProgrammedMachine ExecutionState
 105 -- runStep n | trace (show n) False = undefined
 106 runStep 0 = return Terminated
 107 runStep 1 =
 108   do cip <- gets _ip
 109      regR <- getLocation (cip + 1)
 110      let reg = regR .&. 7
 111      value <- getValue (cip + 2)
 112      advanceIP 3
 113      modify (\m -> m & registers . ix reg .~ value)
 114      return Runnable
 115 runStep 2 =
 116   do cip <- gets _ip
 117      value <- getValue (cip + 1)
 118      advanceIP 2
 119      modify (\m -> m & stack %~ (value :) )
 120      return Runnable
 121 runStep 3 =
 122   do cip <- gets _ip
 123      tgt <- getLocation (cip + 1)
 124      val <- gets (\m -> head $ m ^. stack)
 125      modify (\m -> m & stack %~ tail )
 126      putValue tgt val
 127      advanceIP 2
 128      return Runnable
 129 runStep 4 =
 130   do cip <- gets _ip
 131      tgt <- getLocation (cip + 1)
 132      b <- getValue (cip + 2)
 133      c <- getValue (cip + 3)
 134      putValue tgt (if b == c then 1 else 0)
 135      modify (\m -> m & ip %~ (+ 4))
 136      return Runnable
 137 runStep 5 =
 138   do cip <- gets _ip
 139      tgt <- getLocation (cip + 1)
 140      b <- getValue (cip + 2)
 141      c <- getValue (cip + 3)
 142      putValue tgt (if b > c then 1 else 0)
 143      advanceIP 4
 144      return Runnable
 145 runStep 6 =
 146   do cip <- gets _ip
 147      tgt <- getLocation (cip + 1)
 148      modify (\m -> m & ip .~ tgt)
 149      return Runnable
 150 runStep 7 =
 151   do cip <- gets _ip
 152      a <- getValue (cip + 1)
 153      tgt <- getLocation (cip + 2)
 154      if a /= 0
 155       then modify (\m -> m & ip .~ tgt)
 156       else advanceIP 3
 157      return Runnable
 158 runStep 8 =
 159   do cip <- gets _ip
 160      a <- getValue (cip + 1)
 161      tgt <- getLocation (cip + 2)
 162      if a == 0
 163       then modify (\m -> m & ip .~ tgt)
 164       else advanceIP 3
 165      return Runnable
 166
 167 runStep 9 =
 168   do cip <- gets _ip
 169      a <- getLocation (cip + 1)
 170      b <- getValue (cip + 2)
 171      c <- getValue (cip + 3)
 172      putValue a (b + c)
 173      advanceIP 4
 174      return Runnable
 175 runStep 10 =
 176   do cip <- gets _ip
 177      a <- getLocation (cip + 1)
 178      b <- getValue (cip + 2)
 179      c <- getValue (cip + 3)
 180      putValue a (b * c)
 181      advanceIP 4
 182      return Runnable
 183 runStep 11 =
 184   do cip <- gets _ip
 185      a <- getLocation (cip + 1)
 186      b <- getValue (cip + 2)
 187      c <- getValue (cip + 3)
 188      putValue a (b `mod` c)
 189      advanceIP 4
 190      return Runnable
 191 runStep 12 =
 192   do cip <- gets _ip
 193      a <- getLocation (cip + 1)
 194      b <- getValue (cip + 2)
 195      c <- getValue (cip + 3)
 196      putValue a (b .&. c)
 197      advanceIP 4
 198      return Runnable
 199 runStep 13 =
 200   do cip <- gets _ip
 201      a <- getLocation (cip + 1)
 202      b <- getValue (cip + 2)
 203      c <- getValue (cip + 3)
 204      putValue a (b .|. c)
 205      advanceIP 4
 206      return Runnable
 207 runStep 14 =
 208   do cip <- gets _ip
 209      a <- getLocation (cip + 1)
 210      b <- getValue (cip + 2)
 211      putValue a (complement b)
 212      advanceIP 3
 213      return Runnable
 214
 215 runStep 15 =
 216   do cip <- gets _ip
 217      a <- getLocation (cip + 1)
 218      b <- getValue (cip + 2)
 219      v <- getValue b
 220      putValue a v
 221      advanceIP 3
 222      return Runnable
 223 runStep 16 =
 224   do cip <- gets _ip
 225      a <- getValue (cip + 1)
 226      b <- getValue (cip + 2)
 227      putValue a b
 228      advanceIP 3
 229      return Runnable
 230
 231 runStep 17 =
 232   do cip <- gets _ip
 233      a <- getValue (cip + 1)
 234      modify (\m -> m & stack %~ ((cip + 2) :)
 235                      & ip .~ a)
 236      return Runnable
 237
 238 runStep 18 =
 239   do val <- gets (\m -> head $ m ^. stack)
 240      modify (\m -> m & stack %~ tail
 241                      & ip .~ val)
 242      return Runnable
 243
 244 runStep 19 =
 245   do cip <- gets _ip
 246      v <- getValue (cip + 1)
 247      tell [v]
 248      advanceIP 2
 249      return Runnable
 250
 251 runStep 20 =
 252   do iIndex <- gets _inputIndex
 253      inputs <- ask
 254      cip <- gets _ip
 255      tgt <- getLocation (cip + 1)
 256      if (iIndex + 1) > (length inputs)
 257       then return Blocked
 258       else do let char = (inputs!!iIndex)
 259               putValue tgt char
 260               modify (\m -> m & inputIndex %~ (+ 1))
 261               advanceIP 2
 262               return Runnable
 263
 264 runStep 21 =
 265   do advanceIP 1
 266      return Runnable
 267 runStep _ =
 268   do advanceIP 1
 269      return Runnable
 270
 271
 272 traceMachine :: ProgrammedMachine ()
 273 traceMachine = do
 274   isTracing <- gets _tracing
 275   when isTracing
 276        do cip <- gets _ip
 277           (l, _) <- dissembleInstruction cip
 278           registers <- gets _registers
 279           let regVals = intercalate "; " $ fmap show $ M.elems registers
 280           stack <- gets _stack
 281           let stackVals = intercalate "; " $ fmap show $ take 10 stack
 282           tell $ fmap (fromIntegral . ord) (">> " ++ l ++ " : r> " ++ regVals ++ " : s> " ++ stackVals ++ "<<")
 283
 284 runDissemble :: Word16 -> Int -> Machine -> [String]
 285 runDissemble startAt num machine =fst $ evalRWS (dissemble startAt num) [] machine
 286
 287
 288 dissemble :: Word16 -> Int -> ProgrammedMachine [String]
 289 dissemble startAt num = go startAt num []
 290   where go _ 0 ls = return $ reverse ls
 291         go here n ls =
 292           do (line, step) <- dissembleInstruction here
 293              go (here + step) (n - 1) (line : ls)
 294
 295 dissembleInstruction :: Word16 -> ProgrammedMachine (String, Word16)
 296 dissembleInstruction cip =
 297     do  -- cip <- gets _ip
 298         opcode <- getLocation cip
 299         mem <- gets _memory
 300         let a = mem ! (cip + 1)
 301         let b = mem ! (cip + 2)
 302         let c = mem ! (cip + 3)
 303         let sa = show a
 304         let sb = show b
 305         let sc = show c
 306         va <- getValue (cip + 1)
 307         vb <- getValue (cip + 2)
 308         vc <- getValue (cip + 3)
 309         let sva = show va
 310         let svb = show vb
 311         let svc = show vc
 312         let traceText =
 313               case opcode of
 314                 0 -> ["halt"]
 315                 1 -> ["set", sa, sb, "*", sva, svb]
 316                 2 -> ["push", sa, "*", sva]
 317                 3 -> ["pop", sa, "*", sva]
 318                 4 -> ["eq", sa, sb, sc, "*", sva, svb, svc]
 319                 5 -> ["gt", sa, sb, sc, "*", sva, svb, svc]
 320                 6 -> ["jmp", sa, "*", sva]
 321                 7 -> ["jt", sa, sb, "*", sva, svb]
 322                 8 -> ["jf", sa, sb, "*", sva, svb]
 323                 9 -> ["add", sa, sb, sc, "*", sva, svb, svc]
 324                 10 -> ["mul", sa, sb, sc, "*", sva, svb, svc]
 325                 11 -> ["mod", sa, sb, sc, "*", sva, svb, svc]
 326                 12 -> ["and", sa, sb, sc, "*", sva, svb, svc]
 327                 13 -> ["or", sa, sb, sc, "*", sva, svb, svc]
 328                 14 -> ["not", sa, sb, "*", sva, svb]
 329                 15 -> ["rmem", sa, sb, "*", sva, svb]
 330                 16 -> ["wmem", sa, sb, "*", sva, svb]
 331                 17 -> ["call", sa, "*", sva]
 332                 18 -> ["ret"]
 333                 19 -> ["out", sa, "*", sva]
 334                 20 -> ["in", sa, "*", sva]
 335                 21 -> ["noop"]
 336                 _ -> ["illegal", sa, sb, sc, "*", sva, svb, svc]
 337         let stepSize =
 338               if | opcode `elem` [0, 18, 21] -> 1
 339                  | opcode `elem` [2, 3, 6, 17, 19, 20] -> 2
 340                  | opcode `elem` [1, 7, 8, 14, 15, 16] -> 3
 341                  | opcode `elem` [4, 5, 9, 10, 11, 12, 13] -> 4
 342                  | otherwise -> 1
 343         return ( ((show cip) ++ ": " ++ (intercalate " " traceText))
 344                , stepSize
 345                )
 346
 347 getValue :: Word16 -> ProgrammedMachine Word16
 348 getValue loc =
 349   do mem <- gets _memory
 350      regs <- gets _registers
 351      let val = mem ! loc
 352      if val < (2 ^ 15)
 353         then return val
 354         else return (regs ! (val .&. 7))
 355
 356
 357
 358   -- | loc < 32768 =
 359   --     do mem <- gets _memory
 360   --        return $ mem ! loc
 361   -- | otherwise =
 362   --     do regs <- gets _registers
 363   --        return $ regs ! (loc `shiftR` 15)
 364
 365 getLocation :: Word16 -> ProgrammedMachine Word16
 366 getLocation loc =
 367   do mem <- gets _memory
 368      return $ mem ! loc
 369
 370 putValue :: Word16 -> Word16 -> ProgrammedMachine ()
 371 putValue loc value
 372   | loc < (2 ^ 15) = modify (\m -> m & memory . ix loc .~ v)
 373   | otherwise      = modify (\m -> m & registers . ix (loc .&. 7) .~ v)
 374   where v = value `mod` (2 ^ 15)
 375
 376 advanceIP :: Word16 -> ProgrammedMachine ()
 377 advanceIP delta = modify (\m -> m & ip %~ (+ delta))