diff options
Diffstat (limited to 'fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs')
| -rw-r--r-- | fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs | 222 |
1 files changed, 206 insertions, 16 deletions
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 } |