Some basic emulator graphics

5 files changed, 262 insertions, 18 deletions

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
   }