+module SynacorEngine where
+
+import Debug.Trace
+
+-- import System.Environment
+import Data.Bits
+import Data.Word
+-- import Data.Binary.Get
+-- import qualified Data.ByteString.Lazy as BL
+import qualified Data.Map.Strict as M
+import Data.Map.Strict ((!))
+import Control.Lens
+import Data.List
+import Numeric
+
+import Control.Monad.State.Strict
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Control.Monad.RWS.Strict
+
+type Memory = M.Map Word16 Word16
+
+
+
+data Machine = Machine { _memory :: Memory
+ , _ip :: Word16
+ , _registers :: Memory
+ , _inputIndex :: Int
+ , _stack :: [Word16]
+ }
+ deriving (Show, Eq, Ord)
+makeLenses ''Machine
+
+type ProgrammedMachine = RWS [Word16] [Word16] Machine
+
+data ExecutionState = Runnable | Blocked | Terminated deriving (Ord, Eq, Show)
+
+-- returns (returnValue, finalMachine, outputs)
+
+runMachine :: [Word16] -> Machine -> (ExecutionState, Machine, [Word16])
+runMachine inputs machine = runRWS runAll inputs machine
+
+
+makeMachine :: Memory -> Machine
+makeMachine memory = Machine
+ { _ip = 0
+ , _inputIndex = 0
+ , _registers = M.fromList [ (r, 0) | r <- [0..7] ]
+ , _memory = memory
+ , _stack = []
+ }
+
+-- traceMachine x =
+-- do cip <- gets _ip
+-- opcode <- getLocation cip
+-- arg1 <- getValue (cip + 1)
+-- arg2 <- getValue (cip + 2)
+-- arg3 <- getValue (cip + 3)
+-- mem <- gets _memory
+-- regs <- gets _registers
+-- let raw1 = mem ! (cip + 1)
+-- let raw2 = mem ! (cip + 2)
+-- let raw3 = mem ! (cip + 3)
+-- let x' = trace (
+-- intercalate ": "
+-- [ "IP Addr"
+-- , show (showHex (cip * 2) "")
+-- , "IP"
+-- , (show (showHex cip ""))
+-- , "Op"
+-- , show (opcode)
+-- , "Args"
+-- , show (showHex arg1 "")
+-- , show (showHex arg2 "")
+-- , show (showHex arg3 "")
+-- , "Raw"
+-- , show (showHex raw1 "")
+-- , show (showHex raw2 "")
+-- , show (showHex raw3 "")
+-- , show (M.elems regs)
+-- ]
+-- ) x
+-- return x'
+
+runAll :: ProgrammedMachine ExecutionState
+runAll = do cip <- gets _ip
+ opcode <- getLocation cip
+ -- opcode' <- traceMachine opcode
+ -- exState <- runStep opcode'
+ exState <- runStep opcode
+ case exState of
+ Terminated -> return Terminated
+ Blocked -> return Blocked
+ _ -> runAll
+
+
+runStep :: Word16 -> ProgrammedMachine ExecutionState
+-- runStep n | trace (show n) False = undefined
+runStep 0 = return Terminated
+runStep 1 =
+ do cip <- gets _ip
+ regR <- getLocation (cip + 1)
+ let reg = regR .&. 7
+ value <- getValue (cip + 2)
+ advanceIP 3
+ modify (\m -> m & registers . ix reg .~ value)
+ return Runnable
+runStep 2 =
+ do cip <- gets _ip
+ value <- getValue (cip + 1)
+ advanceIP 2
+ modify (\m -> m & stack %~ (value :) )
+ return Runnable
+runStep 3 =
+ do cip <- gets _ip
+ tgt <- getLocation (cip + 1)
+ val <- gets (\m -> head $ m ^. stack)
+ modify (\m -> m & stack %~ tail )
+ putValue tgt val
+ advanceIP 2
+ return Runnable
+runStep 4 =
+ do cip <- gets _ip
+ tgt <- getLocation (cip + 1)
+ b <- getValue (cip + 2)
+ c <- getValue (cip + 3)
+ putValue tgt (if b == c then 1 else 0)
+ modify (\m -> m & ip %~ (+ 4))
+ return Runnable
+runStep 5 =
+ do cip <- gets _ip
+ tgt <- getLocation (cip + 1)
+ b <- getValue (cip + 2)
+ c <- getValue (cip + 3)
+ putValue tgt (if b > c then 1 else 0)
+ advanceIP 4
+ return Runnable
+runStep 6 =
+ do cip <- gets _ip
+ tgt <- getLocation (cip + 1)
+ modify (\m -> m & ip .~ tgt)
+ return Runnable
+runStep 7 =
+ do cip <- gets _ip
+ a <- getValue (cip + 1)
+ tgt <- getLocation (cip + 2)
+ if a /= 0
+ then modify (\m -> m & ip .~ tgt)
+ else advanceIP 3
+ return Runnable
+runStep 8 =
+ do cip <- gets _ip
+ a <- getValue (cip + 1)
+ tgt <- getLocation (cip + 2)
+ if a == 0
+ then modify (\m -> m & ip .~ tgt)
+ else advanceIP 3
+ return Runnable
+
+runStep 9 =
+ do cip <- gets _ip
+ a <- getLocation (cip + 1)
+ b <- getValue (cip + 2)
+ c <- getValue (cip + 3)
+ putValue a (b + c)
+ advanceIP 4
+ return Runnable
+runStep 10 =
+ do cip <- gets _ip
+ a <- getLocation (cip + 1)
+ b <- getValue (cip + 2)
+ c <- getValue (cip + 3)
+ putValue a (b * c)
+ advanceIP 4
+ return Runnable
+runStep 11 =
+ do cip <- gets _ip
+ a <- getLocation (cip + 1)
+ b <- getValue (cip + 2)
+ c <- getValue (cip + 3)
+ putValue a (b `mod` c)
+ advanceIP 4
+ return Runnable
+runStep 12 =
+ do cip <- gets _ip
+ a <- getLocation (cip + 1)
+ b <- getValue (cip + 2)
+ c <- getValue (cip + 3)
+ putValue a (b .&. c)
+ advanceIP 4
+ return Runnable
+runStep 13 =
+ do cip <- gets _ip
+ a <- getLocation (cip + 1)
+ b <- getValue (cip + 2)
+ c <- getValue (cip + 3)
+ putValue a (b .|. c)
+ advanceIP 4
+ return Runnable
+runStep 14 =
+ do cip <- gets _ip
+ a <- getLocation (cip + 1)
+ b <- getValue (cip + 2)
+ putValue a (complement b)
+ advanceIP 3
+ return Runnable
+
+runStep 15 =
+ do cip <- gets _ip
+ a <- getLocation (cip + 1)
+ b <- getValue (cip + 2)
+ v <- getValue b
+ putValue a v
+ advanceIP 3
+ return Runnable
+runStep 16 =
+ do cip <- gets _ip
+ a <- getValue (cip + 1)
+ b <- getValue (cip + 2)
+ putValue a b
+ advanceIP 3
+ return Runnable
+
+runStep 17 =
+ do cip <- gets _ip
+ a <- getValue (cip + 1)
+ modify (\m -> m & stack %~ ((cip + 2) :)
+ & ip .~ a)
+ return Runnable
+
+runStep 18 =
+ do val <- gets (\m -> head $ m ^. stack)
+ modify (\m -> m & stack %~ tail
+ & ip .~ val)
+ return Runnable
+
+runStep 19 =
+ do cip <- gets _ip
+ v <- getValue (cip + 1)
+ tell [v]
+ advanceIP 2
+ return Runnable
+
+runStep 20 =
+ do iIndex <- gets _inputIndex
+ inputs <- ask
+ cip <- gets _ip
+ tgt <- getLocation (cip + 1)
+ if (iIndex + 1) > (length inputs)
+ then return Blocked
+ else do let char = (inputs!!iIndex)
+ putValue tgt char
+ modify (\m -> m & inputIndex %~ (+ 1))
+ advanceIP 2
+ return Runnable
+
+runStep 21 =
+ do advanceIP 1
+ return Runnable
+runStep _ =
+ do advanceIP 1
+ return Runnable
+
+
+getValue :: Word16 -> ProgrammedMachine Word16
+getValue loc =
+ do mem <- gets _memory
+ regs <- gets _registers
+ let val = mem ! loc
+ if val < (2 ^ 15)
+ then return val
+ else return (regs ! (val .&. 7))
+
+
+
+ -- | loc < 32768 =
+ -- do mem <- gets _memory
+ -- return $ mem ! loc
+ -- | otherwise =
+ -- do regs <- gets _registers
+ -- return $ regs ! (loc `shiftR` 15)
+
+getLocation :: Word16 -> ProgrammedMachine Word16
+getLocation loc =
+ do mem <- gets _memory
+ return $ mem ! loc
+
+putValue :: Word16 -> Word16 -> ProgrammedMachine ()
+putValue loc value
+ | loc < (2 ^ 15) = modify (\m -> m & memory . ix loc .~ v)
+ | otherwise = modify (\m -> m & registers . ix (loc .&. 7) .~ v)
+ where v = value `mod` (2 ^ 15)
+
+advanceIP :: Word16 -> ProgrammedMachine ()
+advanceIP delta = modify (\m -> m & ip %~ (+ delta))
projects / synacor-challenge.git / commitdiff