summaryrefslogtreecommitdiff
path: root/fig-emulator-gb/src
diff options
context:
space:
mode:
Diffstat (limited to 'fig-emulator-gb/src')
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB.hs82
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs8
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs152
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB/Component/Joystick.hs23
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs2
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs2
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs31
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs222
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs8
9 files changed, 430 insertions, 100 deletions
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB.hs b/fig-emulator-gb/src/Fig/Emulator/GB.hs
index 50cb49d..d5ae4e7 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB.hs
@@ -1 +1,83 @@
+{-# Language ImplicitParams #-}
module Fig.Emulator.GB where
+
+import Fig.Prelude
+import Prelude (fromIntegral)
+
+import System.IO (withFile, IOMode (WriteMode))
+
+import Control.Lens ((.=), use)
+import Control.Monad (when)
+import Control.Monad.State (StateT(..))
+
+import qualified SDL
+
+import Fig.Emulator.GB.CPU
+import Fig.Emulator.GB.CPU.Instruction
+import Fig.Emulator.GB.Bus (Bus(..), Addr(..))
+import Fig.Emulator.GB.Component.RAM
+import Fig.Emulator.GB.Component.ROM
+import Fig.Emulator.GB.Component.Video
+import Fig.Emulator.GB.Component.Joystick
+import Fig.Emulator.GB.Component.Serial
+
+cpuDMG :: (MonadIO m, MonadThrow m) => ByteString -> Framebuffer -> CPU m
+cpuDMG rom fb = CPU
+ { _lastPC = 0x0
+ , _lastIns = Nop
+ , _running = True
+ , _regs = initialRegs
+ , _bus = Bus
+ [ compROM rom
+ , compWRAM 0xc000 $ 8 * 1024
+ , compVideo fb
+ , compJoystick
+ , compSerial
+ , compWRAM 0xff80 0x7e -- HRAM
+ ]
+ }
+
+testRun :: forall m. (MonadIO m, MonadThrow m) => ByteString -> m ()
+testRun rom = do
+ SDL.initializeAll
+ window <- SDL.createWindow "taking" SDL.defaultWindow
+ fb <- initializeFramebuffer
+ let cpu = cpuDMG rom fb
+ let
+ loop :: forall m'. Emulating m' => Int -> m' ()
+ loop cycle = do
+ events <- SDL.pollEvents
+ forM_ events \ev ->
+ case SDL.eventPayload ev of
+ SDL.QuitEvent -> running .= False
+ _else -> pure ()
+ pc <- use $ regs . regPC
+ ins <- decode
+ when (pc == 0x2817) do
+ log $ mconcat
+ [ pretty $ Addr pc
+ , ": ", tshow ins
+ ]
+ step ins
+ -- logCPUState
+ when (rem cycle 70224 == 0) do
+ ws <- SDL.getWindowSurface window
+ SDL.surfaceFillRect ws Nothing $ SDL.V4 0x00 0x00 0x00 0xff
+ void $
+ SDL.surfaceBlitScaled
+ (fbSurface fb)
+ Nothing
+ ws
+ (Just $ SDL.Rectangle
+ (SDL.P $ SDL.V2 0 0)
+ (SDL.V2
+ (fromIntegral screenWidth * 8)
+ (fromIntegral screenHeight * 8)))
+ SDL.updateWindowSurface window
+ r <- use running
+ when r . loop $ cycle + 1
+ liftIO $ withFile "log.txt" WriteMode \h -> do
+ let ?log = h
+ void $ flip runStateT cpu do
+ -- logCPUState
+ loop 0
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs
index 730378a..dd61dbc 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs
@@ -22,16 +22,16 @@ instance Pretty Addr where
data Component m = forall (s :: Type). Component
{ compState :: !s
, compMatches :: !(Addr -> Bool)
- , compUpdate :: !(s -> m s)
+ , compUpdate :: !(s -> Int -> m s)
, compWrite :: !(s -> Addr -> Word8 -> m s)
, compRead :: !(s -> Addr -> m Word8)
}
newtype Bus m = Bus { busComponents :: [Component m] }
-update :: forall m. MonadIO m => Bus m -> m (Bus m)
-update b = Bus <$> forM (busComponents b) \Component{..} -> do
- s <- compUpdate compState
+update :: forall m. MonadIO m => Int -> Bus m -> m (Bus m)
+update t b = Bus <$> forM (busComponents b) \Component{..} -> do
+ s <- compUpdate compState t
pure Component { compState = s, ..}
write :: forall m. MonadIO m => Bus m -> Addr -> Word8 -> m (Bus m)
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs b/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
index 33c4ac3..40fd6c8 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
@@ -1,30 +1,34 @@
{-# Language TemplateHaskell, ImplicitParams #-}
-module Fig.Emulator.GB.CPU where
+module Fig.Emulator.GB.CPU
+ ( CPU(..)
+ , Registers(..), initialRegs
+ , Emulating
+ , running, regs, bus, regPC
+ , updateComps
+ , decode
+ , step
+ , logCPUState
+ ) where
import Control.Lens.TH (makeLenses)
+import Data.Maybe (fromJust)
+
import Fig.Prelude
import Prelude (fromIntegral)
-import System.IO (withFile, IOMode (WriteMode))
-
import qualified Text.Printf as Pr
import Control.Lens ((.=), use, (^.))
-import Control.Monad (when, unless)
-import Control.Monad.State (StateT(..))
+import Control.Monad (when)
import Data.Word (Word8, Word16)
+import Data.Int (Int8)
import Data.Bits
-import qualified SDL
-
import Fig.Emulator.GB.Utils
import Fig.Emulator.GB.Bus (Bus(..), Addr(..))
import qualified Fig.Emulator.GB.Bus as Bus
-import Fig.Emulator.GB.Component.RAM
-import Fig.Emulator.GB.Component.ROM
-import Fig.Emulator.GB.Component.Video
import Fig.Emulator.GB.CPU.Instruction
newtype CPUError = CPUError Text
@@ -65,6 +69,7 @@ initialRegs = Registers
data CPU m = CPU
{ _lastPC :: !Word16
, _lastIns :: !Instruction
+ , _running :: !Bool
, _regs :: !Registers
, _bus :: !(Bus m)
}
@@ -73,27 +78,15 @@ makeLenses 'CPU
type EmulatingT f m = (MonadIO m, MonadThrow m, MonadState (CPU f) m, ?log :: Handle)
type Emulating m = EmulatingT IO m
-cpuDMG :: (MonadIO m, MonadThrow m) => ByteString -> CPU m
-cpuDMG rom = CPU
- { _lastPC = 0x0
- , _lastIns = Nop
- , _regs = initialRegs
- , _bus = Bus
- [ compROM rom
- , compWRAM 0x8000 $ 8 * 1024 -- vram placeholder
- , compWRAM 0xc000 $ 8 * 1024
- , compLCD
- ]
- }
-
logCPUState :: Emulating m => m ()
logCPUState = do
rs <- use regs
let pc = rs ^. regPC
- m0 <- read8 $ Addr pc
- m1 <- read8 $ Addr pc + 1
- m2 <- read8 $ Addr pc + 2
- m3 <- read8 $ Addr pc + 3
+ b <- use bus
+ m0 <- fromJust <$> liftIO (Bus.read b $ Addr pc)
+ m1 <- fromJust <$> liftIO (Bus.read b $ Addr pc + 1)
+ m2 <- fromJust <$> liftIO (Bus.read b $ Addr pc + 2)
+ m3 <- fromJust <$> liftIO (Bus.read b $ Addr pc + 3)
liftIO . hPutStrLn ?log $ mconcat
[ "A:", rreg8 $ rs ^. regA
, " F:", rreg8 $ flagsw8 (rs ^. regFlagZ) (rs ^. regFlagN) (rs ^. regFlagH) (rs ^. regFlagC)
@@ -111,8 +104,15 @@ logCPUState = do
rreg8 = pack . Pr.printf "%02X"
rreg16 = pack . Pr.printf "%04X"
+updateComps :: Emulating m => Int -> m ()
+updateComps t = do
+ b <- use bus
+ b' <- liftIO $ Bus.update t b
+ bus .= b'
+
decode :: Emulating m => m Instruction
decode = do
+ updateComps 4
b <- use bus
pc <- use $ regs . regPC
lastPC .= pc
@@ -129,6 +129,7 @@ cond CondC = use (regs . regFlagC)
read8 :: Emulating m => Addr -> m Word8
read8 a = do
+ updateComps 4
b <- use bus
pc <- use lastPC
ins <- use lastIns
@@ -152,6 +153,7 @@ read16 a = do
write8 :: Emulating m => Addr -> Word8 -> m ()
write8 a v = do
+ updateComps 4
b <- use bus
b' <- liftIO $ Bus.write b a v
bus .= b'
@@ -239,22 +241,6 @@ r16Mem R16MemHLMinus = do
setR16 R16HL $ hl - 1
pure hl
-renderTile :: Emulating m => SDL.Renderer -> Addr -> Int -> Int -> m ()
-renderTile renderer a bx by = do
- (ps :: [(Int, Int, Word8)]) <- mconcat <$> forM [0..8] \y -> do
- mconcat <$> forM [0 .. 1] \x -> do
- b <- read8 $ a + Addr (y * 2 + x)
- pure
- [ (bx + fromIntegral x, by + fromIntegral y, w8bits2 7 b)
- , (bx + fromIntegral x, by + fromIntegral y, w8bits2 5 b)
- , (bx + fromIntegral x, by + fromIntegral y, w8bits2 3 b)
- , (bx + fromIntegral x, by + fromIntegral y, w8bits2 1 b)
- ]
- SDL.rendererDrawColor renderer SDL.$= SDL.V4 0 0 0 255
- forM_ ps \(x, y, p) -> do
- unless (p == 0) do
- SDL.drawPoint renderer . SDL.P $ SDL.V2 (fromIntegral x) (fromIntegral y)
-
step :: forall m. Emulating m => Instruction -> m ()
step ins = do
let
@@ -571,11 +557,51 @@ step ins = do
CbRlcR8 _ -> unimplemented
CbRrcR8 _ -> unimplemented
CbRlR8 _ -> unimplemented
- CbRrR8 _ -> unimplemented
- CbSlaR8 _ -> unimplemented
- CbSraR8 _ -> unimplemented
- CbSwapR8 _ -> unimplemented
- CbSrlR8 _ -> unimplemented
+ CbRrR8 r -> do
+ v <- r8 r
+ c <- use $ regs . regFlagC
+ regs . regFlagH .= False
+ regs . regFlagZ .= False
+ regs . regFlagN .= False
+ regs . regFlagC .= w8bit 0 v
+ setR8 R8A $ rotateR v 1 .|. if c then 0b10000000 else 0
+ CbSlaR8 r -> do
+ v <- r8 r
+ let res = shiftL v 1
+ regs . regFlagZ .= (res == 0)
+ regs . regFlagH .= False
+ regs . regFlagN .= False
+ regs . regFlagC .= w8bit 7 v
+ setR8 R8A res
+ CbSraR8 r -> do
+ v <- r8 r
+ let
+ vs :: Int8
+ vs = fromIntegral v
+ ress = shiftR vs 1
+ res :: Word8
+ res = fromIntegral ress
+ regs . regFlagZ .= (res == 0)
+ regs . regFlagH .= False
+ regs . regFlagN .= False
+ regs . regFlagC .= w8bit 0 v
+ setR8 R8A res
+ CbSwapR8 r -> do
+ v <- r8 r
+ let res = rotate v 4
+ regs . regFlagZ .= (res == 0)
+ regs . regFlagH .= False
+ regs . regFlagN .= False
+ regs . regFlagC .= False
+ setR8 R8A res
+ CbSrlR8 r -> do
+ v <- r8 r
+ let res = shiftR v 1
+ regs . regFlagZ .= (res == 0)
+ regs . regFlagH .= False
+ regs . regFlagN .= False
+ regs . regFlagC .= w8bit 0 v
+ setR8 R8A res
CbBitB3R8 _ _ -> unimplemented
CbResB3R8 _ _ -> unimplemented
CbSetB3R8 _ _ -> unimplemented
@@ -589,33 +615,3 @@ step ins = do
, "): "
, tshow ins
]
-
-testRun :: forall m. (MonadIO m, MonadThrow m) => ByteString -> m ()
-testRun rom = do
- SDL.initializeAll
- window <- SDL.createWindow "taking" SDL.defaultWindow
- renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer
- let cpu = cpuDMG rom
- let
- loop :: forall m'. Emulating m' => Int -> m' ()
- loop cycle = do
- -- pc <- use $ regs . regPC
- ins <- decode
- -- log $ mconcat
- -- [ pretty $ Addr pc
- -- , ": ", tshow ins
- -- ]
- step ins
- -- logCPUState
- when (rem cycle 70224 == 0) do
- SDL.rendererDrawColor renderer SDL.$= SDL.V4 255 255 255 255
- SDL.clear renderer
- forM_ ([0..255] :: [Int]) \i -> do
- renderTile renderer (Addr . fromIntegral $ 0x8000 + i * 16) 0 0
- SDL.present renderer
- loop $ cycle + 1
- liftIO $ withFile "log.txt" WriteMode \h -> do
- let ?log = h
- void $ flip runStateT cpu do
- -- logCPUState
- loop 0
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Joystick.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Joystick.hs
new file mode 100644
index 0000000..84785b6
--- /dev/null
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Joystick.hs
@@ -0,0 +1,23 @@
+module Fig.Emulator.GB.Component.Joystick where
+
+import Fig.Prelude
+
+import Fig.Emulator.GB.Bus
+
+newtype JoystickError = JoystickError Text
+ deriving Show
+instance Exception JoystickError
+instance Pretty JoystickError where
+ pretty (JoystickError b) = mconcat
+ [ "joystick error: "
+ , b
+ ]
+
+compJoystick :: (MonadIO m, MonadThrow m) => Component m
+compJoystick = Component
+ { compState = ()
+ , compMatches = (== 0xff00)
+ , compUpdate = \s _ -> pure s
+ , compWrite = \s _ _ -> pure s
+ , compRead = \_ _ -> pure 0x00
+ }
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs
index c88033e..f5c08b4 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs
@@ -25,7 +25,7 @@ compWRAM start size = Component
{ compState = V.replicate size 0 :: V.Vector Word8
, compMatches = \a ->
a >= start && a < end
- , compUpdate = pure
+ , compUpdate = \s _ -> pure s
, compWrite = \s ad v -> do
let offset = fromIntegral . unAddr $ ad - start
pure $ V.modify (\ms -> MV.write ms offset v) s
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs
index b5ea24f..bfdc2fb 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs
@@ -25,7 +25,7 @@ compROM bs = Component
{ compState = V.fromList $ BS.unpack bs
, compMatches = \a ->
a >= start && a < end
- , compUpdate = pure
+ , compUpdate = \s _ -> pure s
, compWrite = \s _ad _v ->
pure s
-- throwM . ROMError $ mconcat
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs
new file mode 100644
index 0000000..68bc477
--- /dev/null
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs
@@ -0,0 +1,31 @@
+module Fig.Emulator.GB.Component.Serial where
+
+import Fig.Prelude
+import Prelude (fromIntegral)
+
+import Data.Char (chr)
+
+import Fig.Emulator.GB.Utils
+import Fig.Emulator.GB.Bus
+
+newtype SerialError = SerialError Text
+ deriving Show
+instance Exception SerialError
+instance Pretty SerialError where
+ pretty (SerialError b) = mconcat
+ [ "joystick error: "
+ , b
+ ]
+
+compSerial :: (MonadIO m, MonadThrow m) => Component m
+compSerial = Component
+ { compState = ()
+ , compMatches = (== 0xff01)
+ , compUpdate = \s _ -> pure s
+ , compWrite = \s _ v -> do
+ log $ mconcat
+ [ "wrote serial byte: ", tshow $ chr $ fromIntegral v
+ ]
+ pure s
+ , compRead = \_ _ -> pure 0x00
+ }
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs
index 00f0e4d..3f73be0 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs
@@ -1,8 +1,22 @@
module Fig.Emulator.GB.Component.Video where
import Fig.Prelude
+import Prelude (error, fromIntegral)
+import qualified Foreign.Ptr as Ptr
+import qualified Foreign.Storable as St
+
+import Control.Monad (unless)
+
+import Data.Word (Word8, Word16, Word32)
+import qualified Data.Vector as V
+import qualified Data.Vector.Mutable as MV
+
+import qualified SDL
+
+import Fig.Emulator.GB.Utils
import Fig.Emulator.GB.Bus
+import Data.Vector.Generic.Lens (vector)
newtype VideoError = VideoError Text
deriving Show
@@ -13,20 +27,195 @@ instance Pretty VideoError where
, b
]
-compLCD :: (MonadIO m, MonadThrow m) => Component m
-compLCD = Component
- { compState = ()
- , compMatches = \a -> a >= 0xff40 && a <= 0xff4b
- , compUpdate = pure
- , compWrite = \s _ _ -> pure s
- , compRead = \_ (Addr a) -> do
- let off = a - 0xff40
- case off of
+screenWidth :: Word16
+screenWidth = 160
+
+screenHeight :: Word16
+screenHeight = 144
+
+newtype Framebuffer = Framebuffer
+ { fbSurface :: SDL.Surface
+ }
+
+initializeFramebuffer :: MonadIO m => m Framebuffer
+initializeFramebuffer = do
+ s <- liftIO $ SDL.createRGBSurface
+ (SDL.V2 (fromIntegral screenWidth) $ fromIntegral screenHeight)
+ SDL.RGBA8888
+ pure Framebuffer
+ { fbSurface = s
+ }
+
+logTilemap :: MonadIO m => V.Vector Word8 -> m ()
+logTilemap v = do
+ let base = 0x9800 - 0x8000
+ bytes <- forM ([0..(32 * 32)] :: [Int]) \i -> do
+ case v V.!? (base + i) of
+ Nothing -> error "unreachable"
+ Just a -> pure a
+ log $ "tilemap:" <> tshow bytes
+
+blitPixel :: MonadIO m => Word32 -> (Word8, Word8) -> Framebuffer -> m ()
+blitPixel c (x, y) fb = do
+ SDL.lockSurface $ fbSurface fb
+ (base :: Ptr.Ptr Word32) <- Ptr.castPtr <$> SDL.surfacePixels (fbSurface fb)
+ let p = Ptr.plusPtr base
+ $ 4
+ * (fromIntegral y * fromIntegral screenWidth + fromIntegral x)
+ liftIO $ St.poke p c
+ SDL.unlockSurface $ fbSurface fb
+
+blitTile :: (MonadIO m, MonadThrow m) => V.Vector Word8 -> Addr -> (Word8, Word8) -> Framebuffer -> m ()
+blitTile v (Addr a) (bx, by) fb = do
+ (ps :: [(Word8, Word8, Word8)]) <- mconcat <$> forM [0..7] \y -> do
+ mconcat <$> forM [0..1] \xb -> do
+ b <- case v V.!? fromIntegral (a + (y * 2 + xb)) of
+ Just b -> pure b
+ Nothing -> throwM . VideoError $ mconcat
+ [ "tile address ", pretty $ Addr a
+ , " out of bounds"
+ ]
+ pure
+ [ (bx + fromIntegral xb, by + fromIntegral y, w8bits2 7 b)
+ , (bx + fromIntegral xb + 1, by + fromIntegral y, w8bits2 5 b)
+ , (bx + fromIntegral xb + 2, by + fromIntegral y, w8bits2 3 b)
+ , (bx + fromIntegral xb + 3, by + fromIntegral y, w8bits2 1 b)
+ ]
+ forM_ ps \(x, y, p) -> do
+ unless (p == 0) do
+ blitPixel
+ (case p of
+ 0x01 -> 0xff0000ff
+ 0x02 -> 0x990000ff
+ 0x03 -> 0x330000ff
+ _else -> error "unreachable"
+ )
+ (x, y) fb
+
+data VideoAddrRange
+ = VideoAddrVRAM !Addr
+ | VideoAddrStatus !Addr
+ deriving Show
+
+videoAddrRange :: Addr -> Maybe VideoAddrRange
+videoAddrRange a = if
+ | a >= 0x8000 && a < 0xa000 -> Just . VideoAddrVRAM $ a - 0x8000
+ | a >= 0xff40 && a <= 0xff4b -> Just . VideoAddrStatus $ a - 0xff40
+ | otherwise -> Nothing
+
+data RenderState
+ = RenderOAMSearch
+ | RenderPixelTransfer
+ | RenderHBlank
+ | RenderVBlank
+ deriving Show
+
+data VideoState = VideoState
+ { vstFb :: !Framebuffer
+ , vstVRAM :: !(V.Vector Word8)
+ , vstScx :: !Word8
+ , vstScy :: !Word8
+ , vstLy :: !Word8
+ , vstLx :: !Word8
+ , vstRenderState :: !RenderState
+ , vstTick :: !Word16
+ }
+
+compVideo :: (MonadIO m, MonadThrow m) => Framebuffer -> Component m
+compVideo framebuffer = Component
+ { compState = VideoState
+ { vstFb = framebuffer
+ , vstVRAM = V.replicate (8 * 1024) 0
+ , vstScx = 0
+ , vstScy = 0
+ , vstLy = 0
+ , vstLx = 0
+ , vstRenderState = RenderOAMSearch
+ , vstTick = 0
+ }
+ , compMatches = isJust . videoAddrRange
+ , compUpdate = \olds t -> do
+ let tick = vstTick olds + fromIntegral t
+ let s = olds { vstTick = tick }
+ case vstRenderState s of
+ RenderOAMSearch
+ | tick == 40 -> pure s
+ { vstRenderState = RenderPixelTransfer
+ }
+ | otherwise -> pure s
+ RenderPixelTransfer
+ | tick == 200 -> pure s
+ { vstRenderState = RenderHBlank
+ }
+ | otherwise -> pure s
+ RenderHBlank
+ | tick == 456 -> do
+ let ly = vstLy olds + 1
+ if ly == 144
+ then
+ pure s { vstTick = 0, vstLy = ly, vstRenderState = RenderVBlank }
+ else
+ pure s { vstTick = 0, vstLy = ly, vstRenderState = RenderOAMSearch }
+ | otherwise -> pure s
+ RenderVBlank
+ | tick == 456 -> do
+ let ly = vstLy olds + 1
+ if ly == 153
+ then do
+ log "vblank"
+ -- logTilemap $ vstVRAM s
+ forM_ (zip [0..] [48,52,45,111,112,32,114,44,105,109,109] :: [(Int, Int)]) \(idx, b) -> do
+ blitTile (vstVRAM s)
+ (fromIntegral $ b * 16)
+ (fromIntegral $ idx * 8, 0)
+ $ vstFb s
+ -- forM_ ([0..10] :: [Int]) \x -> do
+ -- forM_ ([0..10] :: [Int]) \y -> do
+ -- let i = y * 10 + x
+ -- blitTile (vstVRAM s)
+ -- (0x200 + fromIntegral i * 16)
+ -- (fromIntegral $ x * 8, fromIntegral $ y * 8)
+ -- $ vstFb s
+ pure s { vstTick = 0, vstLy = 0, vstRenderState = RenderOAMSearch }
+ else
+ pure s { vstTick = 0, vstLy = ly }
+ | otherwise -> pure s
+ , compWrite = \s a v -> case videoAddrRange a of
+ Nothing -> throwM $ VideoError $ mconcat
+ [ "write address out of bounds for video system: "
+ , pretty a
+ ]
+ Just (VideoAddrVRAM off) -> do
+ -- log $ "write to vram offset: " <> pretty off
+ pure s
+ { vstVRAM =
+ V.modify (\ms -> MV.write ms (fromIntegral $ unAddr off) v) $ vstVRAM s
+ }
+ Just (VideoAddrStatus off) -> case off of
+ 0x0 -> pure s
+ 0x1 -> pure s
+ 0x2 -> pure s { vstScx = v }
+ 0x3 -> pure s { vstScy = v }
+ 0x4 -> pure s
+ 0x5 -> pure s
+ 0x6 -> pure s
+ 0x7 -> pure s
+ 0x8 -> pure s
+ 0x9 -> pure s
+ 0xa -> pure s
+ 0xb -> pure s
+ _ -> pure s
+ , compRead = \s a -> case videoAddrRange a of
+ Nothing -> throwM $ VideoError $ mconcat
+ [ "read address out of bounds for video system: "
+ , pretty a
+ ]
+ Just (VideoAddrStatus off) -> case off of
0x0 -> pure 0x00
0x1 -> pure 0x00
- 0x2 -> pure 0x00
- 0x3 -> pure 0x00
- 0x4 -> pure 0x00
+ 0x2 -> pure $ vstScx s
+ 0x3 -> pure $ vstScy s
+ 0x4 -> pure $ vstLy s
0x5 -> pure 0x00
0x6 -> pure 0x00
0x7 -> pure 0x00
@@ -34,8 +223,9 @@ compLCD = Component
0x9 -> pure 0x00
0xa -> pure 0x00
0xb -> pure 0x00
- _ -> throwM $ VideoError $ mconcat
- [ "address out of bounds for LCD: "
- , pretty $ Addr a
- ]
+ _ -> pure 0x00
+ Just (VideoAddrVRAM off) -> do
+ case vstVRAM s V.!? fromIntegral (unAddr off) of
+ Nothing -> error "unreachable"
+ Just v -> pure v
}
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs
index 694f2ea..4d00743 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs
@@ -4,10 +4,18 @@ import Fig.Prelude
import Prelude (fromIntegral)
+import qualified Text.Printf as Pr
+
import Data.Word (Word8, Word16)
import Data.Int (Int8)
import Data.Bits
+show8 :: Word8 -> Text
+show8 = pack . Pr.printf "%02X"
+
+show16 :: Word8 -> Text
+show16 = pack . Pr.printf "%04X"
+
w8w8 :: Word8 -> Word8 -> Word16
w8w8 high low = shiftL (fromIntegral high) 8 .|. fromIntegral low
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-09 09:01:03 +0000