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 mem = Machine
  48   { _ip = 0
  49   , _inputIndex = 0
  50   , _registers = M.fromList [ (r, 0) | r <- [0..7] ]
  51   , _memory = mem
  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           regs <- gets _registers
 279           let regVals = intercalate "; " $ fmap show $ M.elems regs
 280           stk <- gets _stack
 281           let stackVals = intercalate "; " $ fmap show $ take 10 stk
 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))