fig-emulator-gb: Debugging the PPU

3 files changed, 124 insertions, 117 deletions

diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Misc.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Misc.hs
new file mode 100644
index 0000000..be15e56
--- /dev/null
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Misc.hs
@@ -0,0 +1,24 @@
+module Fig.Emulator.GB.Component.Misc where
+
+import Fig.Prelude
+
+import Fig.Emulator.GB.Utils
+import Fig.Emulator.GB.Bus
+
+newtype MiscError = MiscError Text
+  deriving Show
+instance Exception MiscError
+instance Pretty MiscError where
+  pretty (MiscError b) = mconcat
+    [ "misc component error: "
+    , b
+    ]
+
+compMisc :: Component
+compMisc = Component
+  { compState = ()
+  , compMatches = (== 0xff4d)
+  , compUpdate = \s _ -> pure s
+  , compWrite = \s _ _ -> pure s
+  , compRead = \_ _ -> pure 0x00
+  }
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs
index 7a4bceb..3912e5d 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs
@@ -14,7 +14,7 @@ newtype SerialError = SerialError Text
 instance Exception SerialError
 instance Pretty SerialError where
   pretty (SerialError b) = mconcat
-    [ "joystick error: "
+    [ "serial error: "
     , b
     ]
 
@@ -24,9 +24,9 @@ compSerial mh = Component
   , compMatches = (== 0xff01)
   , compUpdate = \s _ -> pure s
   , compWrite = \s _ v -> do
-      -- log $ mconcat
-      --   [ "wrote serial byte: ", tshow $ chr $ fromIntegral v
-      --   ]
+      log $ mconcat
+        [ "wrote serial byte: ", tshow $ chr $ fromIntegral v
+        ]
       case mh of
         Nothing -> pure ()
         Just h -> liftIO . hPutChar h . chr $ fromIntegral v
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 7ddf8f5..b1ddadc 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs
@@ -1,11 +1,12 @@
 module Fig.Emulator.GB.Component.Video where
 
 import Fig.Prelude
-import Prelude (error)
+import Prelude (error, ($!))
 
 import qualified Foreign.Ptr as Ptr
 import qualified Foreign.Storable as St
 
+import Control.DeepSeq (force)
 import Control.Monad (unless)
 
 import Data.Word (Word8, Word16, Word32)
@@ -27,10 +28,12 @@ instance Pretty VideoError where
     ]
 
 screenWidth :: Word16
-screenWidth = 160
+-- screenWidth = 160
+screenWidth = 8 * 32
 
 screenHeight :: Word16
-screenHeight = 144
+-- screenHeight = 144
+screenHeight = 8 * 32
 
 newtype Framebuffer = Framebuffer
   { fbSurface :: SDL.Surface
@@ -45,6 +48,7 @@ initializeFramebuffer = do
     { fbSurface = s
     }
 
+
 logTilemap :: V.Vector Word8 -> IO ()
 logTilemap v = do
   let base = 0x9800 - 0x8000
@@ -64,16 +68,19 @@ blitPixel c (x, y) fb = do
   liftIO $ St.poke p c
   SDL.unlockSurface $ fbSurface fb
 
-blitTile :: V.Vector Word8 -> Addr -> (Word8, Word8) -> Framebuffer -> IO ()
-blitTile v (Addr a) (bx, by) fb = do
+blitTile :: Int -> V.Vector Word8 -> Int -> (Word8, Word8) -> Framebuffer -> IO ()
+blitTile base v num (bx, by) fb = do
+  let a = num * 16
+  log "start"
   (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
+      b <- case v V.!? fromIntegral (base + a + (y * 2 + xb)) of
         Just b -> pure b
         Nothing -> throwM . VideoError $ mconcat
-          [ "tile address ", pretty $ Addr a
+          [ "tile offset ", pretty . Addr $ fromIntegral a
           , " out of bounds"
           ]
+      log $ show8 b
       pure
         [ (bx + fromIntegral xb, by + fromIntegral y, w8bits2 7 b)
         , (bx + fromIntegral xb + 1, by + fromIntegral y, w8bits2 5 b)
@@ -85,15 +92,23 @@ blitTile v (Addr a) (bx, by) fb = do
       blitPixel
         (case p of
            0x01 -> 0xff0000ff
-           0x02 -> 0x990000ff
-           0x03 -> 0x330000ff
+           0x02 -> 0x00ff00ff
+           0x03 -> 0x0000ffff
            _else -> error "unreachable"
         )
         (x, y) fb
 
+readTileMap :: Int -> V.Vector Word8 -> IO [(Int, Int, Word8)]
+readTileMap base vram = do
+  mconcat <$> forM ([0..32] :: [Int]) \x -> do
+    forM ([0..32] :: [Int]) \y -> do
+      case vram V.!? (base + y * 32 + x) of
+        Nothing -> error "unreachable"
+        Just a -> pure (x, y, a)
+
 data VideoAddrRange
-  = VideoAddrVRAM Addr
-  | VideoAddrStatus Addr
+  = VideoAddrVRAM !Addr
+  | VideoAddrStatus !Addr
   deriving Show
 
 videoAddrRange :: Addr -> Maybe VideoAddrRange
@@ -110,14 +125,15 @@ data RenderState
   deriving Show
 
 data VideoState = VideoState
-  { vstFb :: Framebuffer
-  , vstVRAM :: V.Vector Word8
-  , vstScx :: Word8
-  , vstScy :: Word8
-  , vstLy :: Word8
-  , vstLx :: Word8
-  , vstRenderState :: RenderState
-  , vstTick :: Word16
+  { vstFb :: !Framebuffer
+  , vstVRAM :: !(V.Vector Word8)
+  , vstLcdc :: !Word8
+  , vstScx :: !Word8
+  , vstScy :: !Word8
+  , vstLy :: !Word8
+  , vstLx :: !Word8
+  , vstRenderState :: !RenderState
+  , vstTick :: !Word16
   }
 
 compVideo :: Framebuffer -> Component
@@ -125,6 +141,7 @@ compVideo framebuffer = Component
   { compState = VideoState
     { vstFb = framebuffer
     , vstVRAM = V.replicate (8 * 1024) 0
+    , vstLcdc = 0
     , vstScx = 0
     , vstScy = 0
     , vstLy = 0
@@ -132,132 +149,96 @@ compVideo framebuffer = Component
     , vstRenderState = RenderOAMSearch
     , vstTick = 0
     }
+
   , compMatches = isJust  . videoAddrRange
+
   , compUpdate = \s t -> {-# SCC "ComponentVideoUpdate" #-} do
       let tick = vstTick s + t
-      -- let ly = vstLy s + 1
-      let ly = 0
+      let ly = vstLy s + 1
       case vstRenderState s of
         RenderOAMSearch
-          | tick == 40 -> pure s
+          | tick == 40 -> pure $! s
             { vstTick = tick
             , vstRenderState = RenderPixelTransfer
             }
-          | otherwise -> pure s
+          | otherwise -> pure $! s
             { vstTick = tick
             }
         RenderPixelTransfer
-          | tick == 200 -> pure s
+          | tick == 200 -> pure $! s
             { vstTick = tick
             , vstRenderState = RenderHBlank
             }
-          | otherwise -> pure s
+          | otherwise -> pure $! s
             { vstTick = tick
             }
         RenderHBlank
           | tick == 456 -> do
-              pure s
+              if ly == 144
+                then
+                pure $! s
+                { vstTick = 0
+                , vstLy = ly
+                , vstRenderState = RenderVBlank
+                }
+                else
+                pure $! s
                 { vstTick = 0
                 , vstLy = ly
                 , vstRenderState = RenderOAMSearch
                 }
-              -- let ly = vstLy s + 1
-              -- if ly == 144
-              --   then
-              --   pure s
-              --   { vstTick = 0
-              --   , vstLy = ly
-              --   -- , vstRenderState = RenderVBlank
-              --   , vstRenderState = RenderOAMSearch
-              --   }
-              --   else
-              --   pure s
-              --   { vstTick = 0
-              --   , vstLy = ly
-              --   , vstRenderState = RenderOAMSearch
-              --   }
-        _ -> pure s { vstTick = tick }
-      -- case vstRenderState s of
-      --   RenderOAMSearch
-      --     | tick == 40 -> pure $! s
-      --       { vstTick = tick
-      --       , vstRenderState = RenderPixelTransfer
-      --       }
-      --     | otherwise -> pure $! s
-      --       { vstTick = tick
-      --       }
-      --   RenderPixelTransfer
-      --     | tick == 200 -> pure $! s
-      --       { vstTick = tick
-      --       , vstRenderState = RenderHBlank
-      --       }
-      --     | otherwise -> pure $! s
-      --       { vstTick = tick
-      --       }
-      --   RenderHBlank
-      --     | tick == 456 -> do
-      --         let ly = vstLy s + 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
-      --       { vstTick = tick
-      --       }
-      --   RenderVBlank
-      --     | tick == 456 -> do
-      --         let ly = vstLy s + 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
-      --       { vstTick = tick
-      --       }
+          | otherwise -> pure $! s
+            { vstTick = tick
+            }
+        RenderVBlank
+          | tick == 456 -> do
+              if ly == 153
+                then do
+                -- log "vblank"
+                -- logTilemap $ vstVRAM s
+                let bgmapbase = (if w8bit 3 $ vstLcdc s then 0x9c00 else 0x9800) - 0x8000
+                let bgbase = (if w8bit 4 $ vstLcdc s then 0x8000 else 0x9000) - 0x8000
+                tiles <- readTileMap bgmapbase (vstVRAM s)
+                blitTile 0 (vstVRAM s) 48 (0, 8) $ vstFb s
+                -- forM_ tiles \(x, y, tile) -> do
+                --   blitTile bgbase (vstVRAM s)
+                --     (fromIntegral $ tile * 16)
+                --     (fromIntegral x * 8, fromIntegral y * 8)
+                --     $ vstFb s
+                -- forM_ (zip [0..] [48,52,45,111,112,32,114,44,105,109,109] :: [(Int, Int)]) \(idx, b) -> do
+                --   blitTile 0 (vstVRAM s)
+                --     (fromIntegral b)
+                --     (fromIntegral $ idx * 8, 0)
+                --     $ vstFb s
+                pure $! s
+                  { vstTick = 0
+                  , vstLy = 0
+                  , vstRenderState = RenderOAMSearch
+                  }
+                else
+                pure $! s
+                { vstTick = 0
+                , vstLy = ly
+                }
+          | otherwise -> pure $! s
+            { vstTick = tick
+            }
+
   , compWrite = \s a v -> {-# SCC "ComponentVideoWrite" #-} 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
+        log $ "write to vram: " <> pretty (0x8000 + 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
+        0x0 -> do
+          log $ "write to lcdc: " <> show8 v
+          pure s { vstLcdc = v }
         0x1 -> pure s
         0x2 -> pure s { vstScx = v }
         0x3 -> pure s { vstScy = v }
@@ -270,17 +251,19 @@ compVideo framebuffer = Component
         0xa -> pure s
         0xb -> pure s
         _ -> pure s
+
   , compRead = \s a -> {-# SCC "ComponentVideoRead" #-} 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
+        0x0 -> pure $ vstLcdc s
         0x1 -> pure 0x00
         0x2 -> pure $ vstScx s
         0x3 -> pure $ vstScy s
         0x4 -> pure $ vstLy s
+        -- 0x4 -> pure 0x00
         0x5 -> pure 0x00
         0x6 -> pure 0x00
         0x7 -> pure 0x00