dcpu16 (empty) → 0.1.0.0

raw patch · 15 files changed

+910/−0 lines, 15 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, dcpu16, filepath, optparse-applicative, parsec, sdl2, spool, vector

Files

• LICENSE +30/−0
• README.md +13/−0
• Setup.hs +2/−0
• app/Main.hs +25/−0
• dcpu16.cabal +57/−0
• src/Dcpu16.hs +6/−0
• src/Dcpu16/Assembler.hs +108/−0
• src/Dcpu16/Assembler/Parser.hs +156/−0
• src/Dcpu16/Assembler/Syntax.hs +34/−0
• src/Dcpu16/Cpu.hs +251/−0
• src/Dcpu16/Dumper.hs +34/−0
• src/Dcpu16/Emulator.hs +100/−0
• src/Dcpu16/Utils.hs +15/−0
• src/Dcpu16/Video.hs +75/−0
• test/Spec.hs +4/−0

@@ -0,0 +1,30 @@+Copyright Anatoly Krivolapov (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,13 @@+DCPU-16 Emulator & Assembler
+===============
+DCPU-16 is a 16-bit processor designed by Markus "Notch" Persson for the postponed video game 0x10c.
+
+Features
+--------
+- Full spec 1.1 implementation
+- Loads binary programs
+- Loads assembler programs
+- Graphics mode support: 128 x 96 screen
+- Sprites
+- Keyboard input
+- Runs pacman

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,25 @@+module Main where++import qualified Dcpu16 as D+import System.FilePath (takeExtension)+import Options.Applicative+import Data.Char++data Opts = Opts { prog :: String }++opts :: Parser Opts+opts = Opts <$> argument str (metavar "PROG" <> help "assembler or binary program" )++main :: IO ()+main = do +    (Opts prog) <- execParser fullOpts+    emu <- D.newEmulator+    let isAsm = map toLower (takeExtension prog) `elem` [".asm", ".dasm16"]+    if isAsm+        then do putStrLn $ "Loading asm program " ++ prog+                D.loadAsmProgram emu prog+        else do putStrLn $ "Loading binary program " ++ prog+                D.loadBinaryProgram emu prog+    D.runEmulatorLoop emu+  where+    fullOpts = info (helper <*> opts) (fullDesc <> progDesc "DCPU-16 Emulator")

@@ -0,0 +1,57 @@+name:                dcpu16+version:             0.1.0.0+synopsis:            Initial project template from stack+description:         Please see README.md+homepage:            https://github.com/githubuser/dcpu16#readme+license:             BSD3+license-file:        LICENSE+author:              Anatoly Krivolapov+maintainer:          example@example.com+copyright:           2016 Anatoly Krivolapov+category:            Compilers/Interpreters+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Dcpu16+                     , Dcpu16.Cpu+                     , Dcpu16.Emulator+                     , Dcpu16.Video+                     , Dcpu16.Dumper+                     , Dcpu16.Assembler+                     , Dcpu16.Assembler.Syntax+                     , Dcpu16.Assembler.Parser+  other-modules:       Dcpu16.Utils+  build-depends:       base >= 4.7 && < 5+                     , sdl2+                     , vector+                     , bytestring+                     , parsec+                     , containers+                     , spool+  default-language:    Haskell2010++executable dcpu16-exe+  hs-source-dirs:      app+  main-is:             Main.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  build-depends:       base+                     , dcpu16+                     , optparse-applicative+                     , filepath+  default-language:    Haskell2010++test-suite dcpu16-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , dcpu16+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/anatolat/dcpu16

@@ -0,0 +1,6 @@+module Dcpu16 (module X) where++import Dcpu16.Emulator as X+import Dcpu16.Cpu as X+import Dcpu16.Dumper as X+import Dcpu16.Assembler as X

@@ -0,0 +1,108 @@+module Dcpu16.Assembler 
+    ( module Dcpu16.Assembler.Syntax
+    , module Dcpu16.Assembler.Parser
+    , compileFile
+    , compileFileToVec
+    , compileInstructions
+    ) where
+
+import Dcpu16.Cpu
+import Dcpu16.Utils
+import Dcpu16.Assembler.Syntax
+import Dcpu16.Assembler.Parser
+import Data.Word
+import Data.List (foldl')
+import Control.Monad (foldM_)
+import Data.Bits
+import qualified Data.Map.Strict as Map
+import qualified Data.Vector.Storable.Mutable as MV
+import qualified Data.Vector.Storable as SV
+
+buildLabelMap :: [AInstr] -> (Map.Map String Int, Int)
+buildLabelMap = foldl' go (Map.empty, 0)
+    where go (mp, offs) (AInstrLabel sym) = (Map.insert sym offs mp, offs)
+          go (mp, offs) instr = (mp, offs + asmInstrSize instr)
+
+resolveAsmValue :: AValue -> Map.Map String Int -> Value
+resolveAsmValue (AValue value) _ = value
+resolveAsmValue (AValueSym value) labelMap = 
+    ValueSymLit $ fromIntegral $ labelMap Map.! value
+resolveAsmValue (AValueSymAddr value) labelMap = 
+    ValueAddr $ fromIntegral $ labelMap Map.! value
+resolveAsmValue (AValueSymAddrPlusLit label w) labelMap = 
+    ValueSymLit $ fromIntegral (labelMap Map.! label) + w
+resolveAsmValue (AValueSymAddrPlusReg label reg) labelMap =
+    ValueAddrRegPlus reg $ fromIntegral $ labelMap Map.! label
+    
+resolveAsmInstruction :: Map.Map String Int -> AInstr -> [InstrItem]
+resolveAsmInstruction labelMap (AInstr instr a b) = [(instr, resolveAsmValue a labelMap, resolveAsmValue b labelMap)]
+resolveAsmInstruction _        (AInstrDat ws)     = map (\w -> (Dat, ValueLit w, ValueLit 0)) ws 
+resolveAsmInstruction _        (AInstrLabel _)    = []
+
+resolveAsmInstructions :: Map.Map String Int -> [AInstr] -> [InstrItem]
+resolveAsmInstructions labelMap = concatMap $ resolveAsmInstruction labelMap
+
+compileValue :: Value -> MV.IOVector Word16 -> Int -> IO (Word16, Int)
+compileValue (ValueReg reg) _ ptr = return (wreg, ptr)
+    where wreg = fromIntegral $ fromEnum reg
+compileValue (ValueAddrReg reg) _ ptr = return (wreg + 0x08, ptr)
+    where wreg = fromIntegral $ fromEnum reg
+compileValue (ValueAddrRegPlus reg nw) buf ptr = do
+    let wreg = fromIntegral $ fromEnum reg 
+    MV.write buf ptr nw
+    return (wreg + 0x10, ptr + 1) 
+compileValue ValuePop _ ptr = return (0x18, ptr)
+compileValue ValuePeek _ ptr = return (0x19, ptr)
+compileValue ValuePush _ ptr = return (0x1a, ptr)
+compileValue ValueSP _ ptr = return (0x1b, ptr)
+compileValue ValuePC _ ptr = return (0x1c, ptr)
+compileValue ValueO _ ptr = return (0x1d, ptr)
+compileValue (ValueAddr nw) buf ptr = do
+    MV.write buf ptr nw
+    return (0x1e, ptr + 1) 
+compileValue (ValueLit nw) buf ptr = 
+    if nw <= 0x1f 
+        then return (0x20 + nw, ptr)
+        else MV.write buf ptr nw >> return (0x1f, ptr + 1)
+compileValue (ValueSymLit nw) buf ptr = do
+    MV.write buf ptr nw
+    return (0x1f, ptr + 1)
+
+compileInstr :: InstrItem -> MV.IOVector Word16 -> Int -> IO Int
+compileInstr (Dat, ValueLit w, _) buf ptr = do
+    --putStrLn $ "compile Dat " ++ show a
+    MV.write buf ptr w
+    return $ ptr + 1
+-- a non-basic insruction format: aaaaaaoooooo0000
+compileInstr (Jsr, a, _) buf ptr = do
+    --putStrLn $ "compile Jsr " ++ show a
+    (wa, ptr') <- compileValue a buf $ ptr + 1
+    let wop = fromIntegral $ fromEnum 1
+    let w = (wa `shiftL` 10) .|. (wop `shiftL` 4)
+    MV.write buf ptr w
+    return ptr'
+-- a basic instruction format:    bbbbbbaaaaaaoooo    
+compileInstr (instr, a, b) buf ptr = do
+    --putStrLn $ "compile " ++ show instr ++ " " ++ show a ++ ", " ++ show b
+    (wa, ptr') <- compileValue a buf $ ptr + 1
+    (wb, ptr'') <- compileValue b buf ptr'
+    let wop = fromIntegral $ fromEnum instr + 1
+    let w = wop .|. (wa `shiftL` 4) .|. (wb `shiftL` 10)
+    MV.write buf ptr w
+    return ptr''
+
+compileInstructions :: [AInstr] -> IO (SV.Vector Word16)
+compileInstructions asmInstrs = do
+    let (labelMap, size) = buildLabelMap asmInstrs
+    let instrs = resolveAsmInstructions labelMap asmInstrs
+    buf <- MV.new size
+    foldM_ (\ptr instr -> compileInstr instr buf ptr) 0 instrs
+    SV.unsafeFreeze buf
+
+compileFileToVec :: FilePath -> IO (SV.Vector Word16)
+compileFileToVec src = parseFile src >>= compileInstructions
+
+compileFile :: FilePath -> FilePath -> IO ()
+compileFile src dst = do
+    vec <- compileFileToVec src
+    writeVectorToFile vec dst

@@ -0,0 +1,156 @@+module Dcpu16.Assembler.Parser 
+    ( parseString
+    , parseFile
+    ) where
+
+import Dcpu16.Cpu
+import Dcpu16.Assembler.Syntax
+import Text.Parsec
+import Text.Parsec.Language (emptyDef)
+import Data.Word
+import Data.Char
+import qualified Control.Applicative as A
+import qualified Text.Parsec.Token as Token
+
+type Parser = Parsec String ()
+
+id2regTable = 
+    [ ("A", RegA)
+    , ("B", RegB)
+    , ("C", RegC)
+    , ("X", RegX)
+    , ("Y", RegY)
+    , ("Z", RegZ)
+    , ("I", RegI)
+    , ("J", RegJ)
+    , ("PC", RegPC)
+    , ("SP", RegSP)
+    , ("O", RegEx)
+    ]
+
+id2valueTable = 
+    [ ("POP", ValuePop)
+    , ("PEEK", ValuePeek)
+    , ("PUSH", ValuePush)
+    , ("PC", ValuePC)
+    , ("SP", ValueSP)
+    , ("O", ValueO)
+    ]
+
+id2instrTable = 
+    [ ("SET", Set)
+    , ("ADD", Add)
+    , ("SUB", Sub)
+    , ("MUL", Mul)
+    , ("DIV", Div)
+    , ("MOD", Mod)
+    , ("SHL", Shl)
+    , ("SHR", Shr)
+    , ("AND", And)
+    , ("BOR", Bor)
+    , ("XOR", Xor)
+    , ("IFE", Ife)
+    , ("IFN", Ifn)
+    , ("IFG", Ifg)
+    , ("IFB", Ifb)
+    , ("JSR", Jsr)
+    ]
+
+lexer = Token.makeTokenParser langDef
+  where 
+    langDef = emptyDef 
+      { Token.identStart = letter <|> char '_'
+      , Token.identLetter = alphaNum  <|> char '_'
+      , Token.commentLine = ";"
+      , Token.caseSensitive = False
+      }
+
+parseString :: String -> [AInstr]
+parseString str = case runParser toplevel () "" str of
+  Left e -> error $ show e
+  Right t -> t
+
+parseFile :: FilePath -> IO [AInstr]
+parseFile filePath = parseString <$> readFile filePath  
+
+colon = Token.colon lexer
+comma = Token.comma lexer
+ident = Token.identifier lexer
+
+toplevel :: Parser [AInstr]
+toplevel = Token.whiteSpace lexer *> many stmt <* eof 
+
+datStmt :: Parser AInstr
+datStmt = AInstrDat <$> (Token.reserved lexer "dat" *> Token.commaSep1 lexer literal)
+
+name2instr :: String -> Maybe Instr
+name2instr name = lookup (map toUpper name) id2instrTable
+
+instrStmt :: Parser AInstr
+instrStmt = do
+    name <- ident
+    instr <- maybe (unexpected $ "Unknown instruction " ++ name) return $ name2instr name
+    a <- value 
+    b <- case instr of 
+        Jsr -> return $ AValue $ ValueLit 0 -- placeholder value
+        _ -> comma >> value
+    return $ AInstr instr a b
+         
+stmt :: Parser AInstr
+stmt = (AInstrLabel . map toUpper) <$> (colon *> ident)
+    <|> datStmt
+    <|> instrStmt
+    <?> "stmt"
+
+literal :: Parser Word16
+literal = fromIntegral <$> Token.integer lexer
+
+value :: Parser AValue
+value = term False
+     <|> Token.brackets lexer (term True)
+     <?> "value"
+
+toAddrValue :: AValue -> Maybe AValue
+toAddrValue (AValue (ValueReg r)) = Just $ AValue $ ValueAddrReg r
+toAddrValue (AValue (ValueLit v)) = Just $ AValue $ ValueAddr v
+toAddrValue (AValueSym v) = Just $AValueSymAddr v
+toAddrValue _ = Nothing
+
+sumValues :: AValue -> AValue -> Maybe AValue
+sumValues (AValue (ValueLit a)) (AValue (ValueLit b)) = Just $ AValue $ ValueLit $ a + b
+sumValues _ _ = Nothing
+
+sumAddrValues' :: AValue -> AValue -> Maybe AValue
+sumAddrValues' (AValue (ValueLit a)) (AValue (ValueLit b)) = Just $ AValue $ ValueAddr $ a + b
+sumAddrValues' (AValue (ValueReg a)) (AValue (ValueLit b)) = Just $ AValue $ ValueAddrRegPlus a b
+sumAddrValues' (AValueSym a) (AValue (ValueLit b)) = Just $ AValueSymAddrPlusLit a b
+sumAddrValues' (AValueSym a) (AValue (ValueReg b)) = Just $ AValueSymAddrPlusReg a b
+sumAddrValues' _ _ = Nothing
+
+sumAddrValues :: AValue -> AValue -> Maybe AValue
+sumAddrValues a b = sumAddrValues' a b A.<|> sumAddrValues b a
+
+term :: Bool -> Parser AValue
+term addr = do
+    values <- sepBy1 atom (Token.reservedOp lexer "+")
+    let v = case  values of
+                [x] | addr -> toAddrValue x
+                [x] -> Just x
+                [x, y] | addr -> sumAddrValues x y
+                [x, y] -> sumValues x y
+                _ -> Nothing
+
+    maybe (unexpected "Unexpected term") return v
+
+name2value :: String -> AValue
+name2value name' =
+    case (lookup name id2valueTable, lookup name id2regTable) of
+        (Just v, _) -> AValue v
+        (Nothing, Just reg) -> AValue $ ValueReg reg
+        (Nothing, Nothing) -> AValueSym name
+    where name = map toUpper name'
+
+atom :: Parser AValue
+atom = (AValue . ValueLit) <$> literal
+    <|> name2value <$> ident
+    <?> "atom value"

@@ -0,0 +1,34 @@+module Dcpu16.Assembler.Syntax where
+
+import Data.Word
+import Dcpu16.Cpu
+
+data AValue = AValue Value
+            | AValueSym String      -- symbol
+            | AValueSymAddr String  -- [symbol]
+            | AValueSymAddrPlusLit String Word16 -- [symbol + lit]
+            | AValueSymAddrPlusReg String Reg -- [symbol + reg]
+            deriving (Show)
+
+data AInstr = AInstr Instr AValue AValue
+            | AInstrDat [Word16]
+            | AInstrLabel String
+            deriving (Show)
+
+
+valueSize :: Value -> Int
+valueSize (ValueAddrRegPlus _ _) = 1
+valueSize (ValueAddr _ ) = 1
+valueSize (ValueLit w) = if w <= 0x1f then 0 else 1
+valueSize (ValueSymLit 0) = 0
+valueSize _ = 0
+
+asmValueSize :: AValue -> Int
+asmValueSize (AValue value) = valueSize value
+asmValueSize _ = 1
+
+asmInstrSize :: AInstr -> Int
+asmInstrSize (AInstr Jsr a _) = 1 + asmValueSize a
+asmInstrSize (AInstr _ a b) = 1 + asmValueSize a + asmValueSize b
+asmInstrSize (AInstrDat ws) = length ws
+asmInstrSize (AInstrLabel _) = 0

@@ -0,0 +1,251 @@+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+module Dcpu16.Cpu where
+
+import qualified Data.Vector.Storable as SV
+import qualified Data.Vector.Storable.Mutable as MV
+import Data.Word
+import Data.Bits
+import Control.Monad
+import Control.Applicative ((<$>))
+
+screenWidth = 128 :: Int
+screenHeight = 96 :: Int 
+screenScale = 4   :: Int
+gfxStart = 0x8000 :: Int
+spritesStart = 0x9050 :: Int
+spriteCount = 16 :: Int
+inputStart = 0x9000 :: Int
+inputMaxCount = 0x10 :: Int
+
+memorySize = 0x10000
+
+data Reg = RegA
+         | RegB
+         | RegC
+         | RegX
+         | RegY
+         | RegZ
+         | RegI
+         | RegJ
+         | RegPC  -- program counter
+         | RegSP  -- stack pointer
+         | RegEx
+         deriving (Show, Bounded, Enum)
+
+data CpuState = CpuState { memory :: MV.IOVector Word16
+                         , regs :: MV.IOVector Word16
+                         }
+
+data Instr = Set
+           | Add
+           | Sub
+           | Mul
+           | Div
+           | Mod
+           | Shl
+           | Shr
+           | And
+           | Bor
+           | Xor
+           | Ife
+           | Ifn
+           | Ifg
+           | Ifb
+           | Jsr
+           | Dat
+           deriving (Show, Enum)
+
+data Value = ValueReg Reg           -- register
+           | ValueAddrReg Reg       -- [regiter]
+           | ValueAddrRegPlus Reg Word16    -- [next word + register]
+           | ValuePop
+           | ValuePeek
+           | ValuePush
+           | ValueSP
+           | ValuePC
+           | ValueO
+           | ValueAddr Word16        -- [next word]
+           | ValueLit Word16
+           | ValueSymLit Word16
+           deriving (Show)
+
+type InstrItem = (Instr, Value, Value)   
+
+regCount = fromEnum (maxBound :: Reg) + 1
+
+newCpu :: IO CpuState
+newCpu = do
+    mem <- MV.new memorySize
+    regs <- MV.new regCount
+    return CpuState {memory = mem, regs = regs }
+
+readMemory :: CpuState -> Int -> IO Word16
+readMemory CpuState {memory = memory} = MV.read memory
+
+writeMemory :: CpuState -> Int -> Word16 -> IO ()
+writeMemory CpuState {memory = memory} = MV.write memory
+
+readRegister :: CpuState -> Reg -> IO Word16
+readRegister CpuState {regs = regs} reg = MV.read regs (fromEnum reg)
+
+writeRegister :: CpuState -> Reg -> Word16 -> IO ()
+writeRegister CpuState {regs = regs} reg = MV.write regs (fromEnum reg)
+
+incPC :: CpuState -> IO Word16
+incPC cpu = do
+    addr <- readRegister cpu RegPC
+    result <- readMemory cpu (fromIntegral addr)
+    writeRegister cpu RegPC (addr + 1)
+    return result
+
+
+parseInstrParts :: Word16 -> (Word16, Word16, Word16)
+parseInstrParts w = if oo == 0 then (aa + 0xf, bb, 0) else (oo, aa, bb)
+-- a basic instruction format:    bbbbbbaaaaaaoooo
+-- a non-basic insruction format: aaaaaaoooooo0000
+    where (oo, aa, bb) = (w .&. 0xf, (w `shiftR` 4) .&. 0x3f, (w `shiftR` 10) .&. 0x3f)
+
+withNextWord :: CpuState -> (Word16 -> a) -> IO a
+withNextWord cpu f = do
+    w <- incPC cpu
+    return $ f w
+
+readValue :: CpuState -> Word16 -> IO Value
+readValue cpu w = do
+    let reg w = toEnum $ fromIntegral w :: Reg
+    case w of
+        w | w <= 0x07 -> return $ ValueReg $ reg w
+        w | w <= 0x0f -> return $ ValueAddrReg $ reg $ w - 0x08
+        w | w <= 0x17 -> withNextWord cpu $ ValueAddrRegPlus (reg $ w - 0x10)
+        0x18 -> return ValuePop
+        0x19 -> return ValuePeek
+        0x1a -> return ValuePush
+        0x1b -> return ValueSP
+        0x1c -> return ValuePC
+        0x1d -> return ValueO
+        0x1e -> withNextWord cpu ValueAddr
+        0x1f -> withNextWord cpu ValueLit
+        w | w <= 0x3f -> return $ ValueLit (w - 0x20)
+        _ -> fail "readValue: wrong value"
+
+readInstr :: CpuState -> IO InstrItem
+readInstr cpu = do
+    w <- incPC cpu
+    let (oo, aa, bb) = parseInstrParts w
+    let instr = toEnum (fromIntegral $ oo - 1) :: Instr
+    a <- readValue cpu aa
+    b <- readValue cpu bb
+    return (instr, a, b)
+
+getValue :: CpuState -> Value -> IO Word16
+getValue cpu (ValueReg reg) = readRegister cpu reg
+getValue cpu (ValueAddrReg reg) = do
+    w <- readRegister cpu reg
+    readMemory cpu (fromIntegral w)
+getValue cpu (ValueAddrRegPlus reg next) = do
+    w <- readRegister cpu reg
+    let addr = w + next
+    readMemory cpu (fromIntegral addr)
+getValue cpu ValuePop = do
+    sp <- readRegister cpu RegSP
+    writeRegister cpu RegSP (sp + 1)
+    readMemory cpu (fromIntegral sp)
+getValue cpu ValuePeek = do 
+    sp <- readRegister cpu RegSP
+    readMemory cpu (fromIntegral sp)
+getValue cpu ValuePush = do
+    sp0 <- readRegister cpu RegSP
+    let sp = sp0 - 1
+    writeRegister cpu RegSP sp
+    readMemory cpu (fromIntegral sp)
+getValue cpu ValueSP = readRegister cpu RegSP
+getValue cpu ValuePC = readRegister cpu RegPC
+getValue cpu ValueO = readRegister cpu RegEx
+getValue cpu (ValueAddr addr) = readMemory cpu (fromIntegral addr)
+getValue _ (ValueLit lit) = return lit
+getValue _ (ValueSymLit lit) = return lit
+
+setValue :: CpuState -> Value -> Word16 -> IO ()
+setValue cpu (ValueReg reg) v = writeRegister cpu reg v
+setValue cpu (ValueAddrReg reg) v = do
+    w <- readRegister cpu reg
+    writeMemory cpu (fromIntegral w) v
+setValue cpu (ValueAddrRegPlus reg next) v = do
+    w <- readRegister cpu reg
+    let addr = w + next
+    writeMemory cpu (fromIntegral addr) v
+setValue cpu ValuePop v = do
+    sp <- readRegister cpu RegSP
+    writeRegister cpu RegSP (sp + 1)
+    writeMemory cpu (fromIntegral sp) v
+setValue cpu ValuePeek v = do 
+    sp <- readRegister cpu RegSP
+    writeMemory cpu (fromIntegral sp) v
+setValue cpu ValuePush v = do
+    sp0 <- readRegister cpu RegSP
+    let sp = sp0 - 1
+    writeRegister cpu RegSP sp
+    writeMemory cpu (fromIntegral sp) v
+setValue cpu ValueSP v = writeRegister cpu RegSP v
+setValue cpu ValuePC v = writeRegister cpu RegPC v
+setValue cpu ValueO  v = writeRegister cpu RegEx  v
+setValue cpu (ValueAddr addr) v = writeMemory cpu (fromIntegral addr) v
+setValue _ (ValueLit _) _ = return () -- TODO: warn
+setValue _ (ValueSymLit _) _ = return () -- TODO: warn
+
+evalInstr :: CpuState -> InstrItem -> IO ()
+evalInstr cpu (Set, dst, src) = do
+    w <- getValue cpu src
+    setValue cpu dst w
+evalInstr cpu (Add, a, b) = evalArithInstr cpu a b op
+    where op a b = let res = a + b in (res, if res > 0xffff then 1 else 0)
+evalInstr cpu (Sub, a, b) = evalArithInstr cpu a b op
+    where op a b = let res = a - b in (res, if res < 0 then 0xffff else 0)
+evalInstr cpu (Mul, a, b) = evalArithInstr cpu a b op
+    where op a b = let res = a * b in (res, (res `shiftR` 16) .&. 0xffff)
+evalInstr cpu (Div, a, b) = evalArithInstr cpu a b op
+    where op a b = if b == 0 then (0, 0) else (a`div`b, ((a `shiftL` 16) `div` b) .&. 0xffff)
+evalInstr cpu (Mod, a, b) = evalArithInstr cpu a b op
+    where op a b = if b == 0 then (0, -1) else (a`mod`b, -1)
+evalInstr cpu (Shl, a, b) = evalArithInstr cpu a b op
+    where op a b = let res = a `shiftL` b in (res, (res `shiftR` 16) .&. 0xffff)
+evalInstr cpu (Shr, a, b) = evalArithInstr cpu a b op
+    where op a b = let res = a `shiftR` b in (res, ((res `shiftL` 16) `shiftR` b).&. 0xffff)
+evalInstr cpu (And, a, b) = evalArithInstr cpu a b op
+    where op a b = if b == 0 then (0, -1) else (a .&. b, -1)
+evalInstr cpu (Bor, a, b) = evalArithInstr cpu a b op
+    where op a b = if b == 0 then (0, -1) else (a .|. b, -1)
+evalInstr cpu (Xor, a, b) = evalArithInstr cpu a b op
+    where op a b = if b == 0 then (0, -1) else (a `xor` b, -1)
+evalInstr cpu (Ife, a, b) = evalIfInstr cpu a b (==)
+evalInstr cpu (Ifn, a, b) = evalIfInstr cpu a b (/=)
+evalInstr cpu (Ifg, a, b) = evalIfInstr cpu a b (>)
+evalInstr cpu (Ifb, a, b) = evalIfInstr cpu a b (\a b -> (a .&. b) /= 0)
+evalInstr cpu (Jsr, a, _) = do
+    evalInstr cpu (Set, ValuePush, ValuePC)
+    evalInstr cpu (Set, ValuePC, a)
+evalInstr _ (Dat, _, _)  = return ()
+
+evalArithInstr :: CpuState -> Value -> Value -> (Int -> Int -> (Int, Int)) -> IO ()
+evalArithInstr cpu a b op = do
+    aa <- fromIntegral <$> getValue cpu a
+    bb <- fromIntegral <$> getValue cpu b
+    let (result, ex) = op aa bb
+    when (ex >= 0) $ writeRegister cpu RegEx $ fromIntegral ex
+    setValue cpu a $ fromIntegral result
+
+evalIfInstr :: CpuState -> Value -> Value -> (Word16 -> Word16 -> Bool) -> IO ()
+evalIfInstr cpu a b op = do
+    aa <- getValue cpu a
+    bb <- getValue cpu b
+    unless (op aa bb) $ void $ readInstr cpu
+
+writeMemoryData :: CpuState -> SV.Vector Word16 -> IO ()
+writeMemoryData cpu vec = SV.copy (MV.slice 0 (SV.length vec) $ memory cpu) vec
+
+runNextInstruction :: CpuState -> IO ()
+runNextInstruction cpu = do
+    instr <- readInstr cpu
+    evalInstr cpu instr    

@@ -0,0 +1,34 @@+module Dcpu16.Dumper (dump) where
+
+import Dcpu16.Cpu
+import Control.Monad
+import Text.Printf
+
+dumpMemLine :: CpuState -> Int -> IO ()
+dumpMemLine cpu addr = do
+    putStr (printf "%04X:" addr)
+    forM_ [0..7] (\i -> readMemory cpu (addr + i) >>= putStr . printf " %04X")
+    putStrLn ""
+
+dumpMemPage :: CpuState -> Int -> IO ()
+dumpMemPage cpu base = forM_ [0,8..56] (\i -> dumpMemLine cpu (base + i))
+
+dump :: CpuState -> IO ()
+dump cpu = do
+    pc <- readRegister cpu RegPC
+    sp <- readRegister cpu RegSP
+    a <- readRegister cpu RegA
+    b <- readRegister cpu RegB
+    c <- readRegister cpu RegC
+    x <- readRegister cpu RegX
+    y <- readRegister cpu RegY
+    z <- readRegister cpu RegZ
+    i <- readRegister cpu RegI
+    j <- readRegister cpu RegJ
+    putStrLn $ printf "PC: %04X  SP: %04X" pc sp
+    putStrLn $ printf "A:  %04X  B:  %04X C:  %04X" a b c
+    putStrLn $ printf "X:  %04X  Y:  %04X Z:  %04X" x y z
+    putStrLn $ printf "I:  %04X  J:  %04X" i j
+    putStrLn "\nMemory dump:"
+    dumpMemPage cpu 0
+    putStrLn ""

@@ -0,0 +1,100 @@+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+module Dcpu16.Emulator 
+    ( newEmulator
+    , loadBinaryProgram
+    , loadAsmProgram
+    , runEmulatorLoop
+    ) where
+
+import Dcpu16.Cpu
+import Dcpu16.Video
+import Dcpu16.Utils
+import Dcpu16.Assembler
+
+import qualified Data.Vector.Storable as SV
+import qualified Data.Vector.Storable.Mutable as MV
+import qualified SDL
+import qualified Data.ByteString as BS
+import Data.IORef
+import Control.Monad
+import Control.Concurrent (threadDelay)
+
+data Emulator = Emulator { cpu :: CpuState }
+
+updateInput :: CpuState -> IORef Int -> [SDL.EventPayload] -> IO ()
+updateInput cpu pointerRef events = do
+    let codes = concatMap 
+            (\case SDL.KeyboardEvent e | SDL.keyboardEventKeyMotion e == SDL.Pressed ->
+                            case SDL.keysymKeycode (SDL.keyboardEventKeysym e) of
+                                SDL.KeycodeLeft  -> [1]
+                                SDL.KeycodeRight -> [2]
+                                SDL.KeycodeUp    -> [3]
+                                SDL.KeycodeDown  -> [4]
+                                _ -> []
+                   _ -> []) 
+            events
+
+    forM_ codes $ \code -> do
+        addr <- (+ inputStart) <$> readIORef pointerRef
+        old <- readMemory cpu addr
+        when (old == 0) $ do
+            writeMemory cpu addr $ fromIntegral code
+            modifyIORef' pointerRef (\x -> (x + 1) `mod` inputMaxCount)
+
+newEmulator :: IO Emulator
+newEmulator = Emulator <$> newCpu
+
+loadBinaryProgram :: Emulator -> FilePath -> IO ()
+loadBinaryProgram Emulator {cpu = cpu} path = do  
+    bs <- BS.readFile path
+    writeMemoryData cpu $ byteStringToVector bs
+
+loadAsmProgram :: Emulator -> FilePath -> IO ()
+loadAsmProgram Emulator {cpu = cpu} src = 
+    compileFileToVec src >>= writeMemoryData cpu
+    
+runEmulatorLoop :: Emulator -> IO ()
+runEmulatorLoop Emulator {cpu = cpu} = do
+    SDL.initialize [SDL.InitVideo]
+
+    let windowSize = SDL.V2 (fromIntegral $ screenWidth * screenScale) (fromIntegral $ screenHeight * screenScale)
+    let windowConfig = SDL.defaultWindow { SDL.windowInitialSize = windowSize }
+    window <- SDL.createWindow "DCPU-16" windowConfig
+    SDL.showWindow window
+
+    renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer
+    texture <- SDL.createTexture renderer SDL.RGBA8888 SDL.TextureAccessStreaming $
+        SDL.V2 (fromIntegral screenWidth) (fromIntegral screenHeight)
+
+    screenBuf <- MV.new (screenWidth * screenHeight)
+    counterRef :: IORef Int <- newIORef 0
+    keypointerRef :: IORef Int <- newIORef 0
+    
+    let loop = do
+            events <- map SDL.eventPayload <$> SDL.pollEvents
+            let quit = SDL.QuitEvent `elem` events
+
+            updateInput cpu keypointerRef events
+            runNextInstruction cpu
+
+            counterValue <- readIORef counterRef
+            when (counterValue `mod` 1000 == 0) $ do
+                --putStrLn $ "Step " ++ show (counterValue + 1)
+                threadDelay 8000
+                updateScreen cpu screenBuf
+
+                screenBs <- vectorToByteString <$> SV.freeze screenBuf
+                SDL.updateTexture texture Nothing screenBs (fromIntegral $ screenWidth * 4)
+
+                SDL.copy renderer texture Nothing Nothing
+                SDL.present renderer
+
+            modifyIORef' counterRef (+1)
+            unless quit loop
+    loop
+
+    SDL.destroyWindow window
+    SDL.quit
+

@@ -0,0 +1,15 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Dcpu16.Utils +    ( module Data.Vector.Storable.ByteString+    , writeVectorToFile+    ) where++import qualified Data.Vector.Storable as SV+import qualified Data.ByteString as BS+import qualified Foreign.Storable as FS+import Data.Vector.Storable.ByteString+          +writeVectorToFile :: (FS.Storable a) => SV.Vector a -> FilePath -> IO ()+writeVectorToFile vec filePath = BS.writeFile filePath bs+    where bs = vectorToByteString vec

@@ -0,0 +1,75 @@+{-# LANGUAGE ScopedTypeVariables #-}
+module Dcpu16.Video where
+
+import Dcpu16.Cpu
+import qualified Data.Vector.Storable.Mutable as MV
+import qualified Data.Vector.Storable as SV 
+import Data.Bits
+import Data.Word
+import Control.Monad
+
+data SpriteMode = SpriteMode { width :: Int, height :: Int, bitsPerPixel :: Int }
+
+spriteModes :: [SpriteMode]
+spriteModes = [ SpriteMode 8 8 4
+              , SpriteMode 16 8 2
+              , SpriteMode 8 16 2
+              , SpriteMode 16 16 1]
+
+pallete :: SV.Vector Word32
+pallete = SV.fromList 
+            [ 0x000000FF, 0x1B2632FF, 0x493C2BFF, 0x2F484EFF
+            , 0x005784FF, 0xBE2633FF, 0x44891AFF, 0xA46422FF
+            , 0x31A2F2FF, 0xE06F8BFF, 0xEB8931FF, 0x9D9D9DFF
+            , 0xA3CE27FF, 0xB2DCEFFF, 0xFFE26BFF, 0xFFFFFFFF]
+
+writeTexturePixel :: MV.IOVector Word32 -> Int -> Int -> Word16 -> IO ()
+writeTexturePixel screen x y pixel = do
+    let color = pallete SV.! fromIntegral pixel
+    MV.write screen (y * screenWidth + x) color
+
+drawBgPixel :: CpuState -> MV.IOVector Word32 -> Int -> Int -> IO ()
+drawBgPixel cpu screen x y = do
+    let addr = gfxStart + x `div` 3 + (y `div` 3) * (screenWidth `div` 3)
+    w <- readMemory cpu addr
+    let c1 = w `shiftR` 12
+    let c2 = (w `shiftR` 8) .&. 0xf
+    let idx = x `mod` 3 + (y `mod` 3) * 3
+    let b = w .&. (0x80 `shiftR` idx)
+    writeTexturePixel screen x y (if b /= 0 then c1 else c2)
+
+drawBg :: CpuState -> MV.IOVector Word32 -> IO ()
+drawBg cpu screen = do
+    let yx = [(y, x) | y <- [0..screenHeight-1], x <- [0..screenWidth-2]]
+    forM_ yx (\(y, x) -> drawBgPixel cpu screen x y)
+
+drawSprites :: CpuState -> MV.IOVector Word32 -> IO ()
+drawSprites cpu screen = forM_ [0..spriteCount-1] $ drawSprite cpu screen
+
+drawSprite :: CpuState -> MV.IOVector Word32 -> Int -> IO ()    
+drawSprite cpu screen index = do
+    let addr = spritesStart + index * 2
+    w1 :: Int <- fromIntegral <$> readMemory cpu addr
+    w2 :: Int <- fromIntegral <$> readMemory cpu (addr + 1)
+    let (sx, sy) = ((w1 `shiftR` 8) - 64, (w1 .&. 0xFF) - 64)
+    let (modeIndex, color) = (w2 `shiftR` 14, (w2 `shiftR` 10) .&. 0xf)
+    let dataAddr = gfxStart + (2 * (w2 .&. 0x3FF))
+    let (SpriteMode width height bitsPerPixel) = spriteModes !! modeIndex
+
+    forM_ [(y, x) | y <- [0..height-1], x <- [0..width-1]] $ \(y, x) -> do
+        let xy = y * width + x
+        let pixelAddr = dataAddr + xy * bitsPerPixel `div` 16
+        w <- readMemory cpu pixelAddr
+        let offs = 16 - bitsPerPixel - (xy * bitsPerPixel) `mod` 16
+        let col = (w `shiftR` offs) .&. ((1 `shiftL` bitsPerPixel) - 1)
+
+        let transparent = if modeIndex == 3 then col == 0 else fromIntegral col == color
+        unless transparent $ do
+            let (rx, ry) = (sx + x, sy + y)
+            when (rx >= 0 && ry >= 0 && rx < screenWidth && ry < screenHeight) $
+                writeTexturePixel screen rx ry col
+
+updateScreen :: CpuState -> MV.IOVector Word32 -> IO ()
+updateScreen cpu screen = do 
+    drawBg cpu screen
+    drawSprites cpu screen

@@ -0,0 +1,4 @@+++main :: IO ()+main = putStrLn "Test suite not yet implemented"