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