summaryrefslogtreecommitdiff
path: root/fig-emulator-gb/src/Fig/Emulator
diff options
context:
space:
mode:
Diffstat (limited to 'fig-emulator-gb/src/Fig/Emulator')
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB.hs42
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs10
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs4
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB/Component/Misc.hs24
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs8
-rw-r--r--fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs209
6 files changed, 154 insertions, 143 deletions
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB.hs b/fig-emulator-gb/src/Fig/Emulator/GB.hs
index cc68afe..a2cfa1d 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB.hs
@@ -22,7 +22,8 @@ import Fig.Emulator.GB.Component.ROM
import Fig.Emulator.GB.Component.Video
import Fig.Emulator.GB.Component.Joystick
import Fig.Emulator.GB.Component.Serial
-import Fig.Emulator.GB.Component.Interrupt (compInterrupt)
+import Fig.Emulator.GB.Component.Misc
+import Fig.Emulator.GB.Component.Interrupt
cpuDMG :: Maybe Handle -> ByteString -> Framebuffer -> CPU
cpuDMG serial rom fb = CPU
@@ -37,6 +38,7 @@ cpuDMG serial rom fb = CPU
, compJoystick
, compSerial serial
, compInterrupt
+ , compMisc
, compWRAM 0xff80 0x7e -- HRAM
]
}
@@ -54,11 +56,11 @@ testRun serialOut rom = do
let
loop :: Int -> Emulating ()
loop cycle = do
- -- events <- SDL.pollEvents
- -- forM_ events \ev ->
- -- case SDL.eventPayload ev of
- -- SDL.QuitEvent -> running .= False
- -- _else -> pure ()
+ 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
@@ -69,20 +71,20 @@ testRun serialOut rom = do
step ins
when (rem cycle 1000000 == 0) do
log "1 million"
- -- 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
+ when (rem cycle 300000 == 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 * 4)
+ (fromIntegral screenHeight * 4)))
+ SDL.updateWindowSurface window
r <- use running
when r . loop $ cycle + 1
void $ flip (runStateT . runEmulating) cpu do
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs
index f0c461f..2b71f2f 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs
@@ -20,11 +20,11 @@ instance Pretty Addr where
pretty (Addr w) = "$" <> pack (showHex w "")
data Component = forall (s :: Type). Component
- { compState :: s
- , compMatches :: Addr -> Bool
- , compUpdate :: s -> Word16 -> IO s
- , compWrite :: s -> Addr -> Word8 -> IO s
- , compRead :: s -> Addr -> IO Word8
+ { compState :: !s
+ , compMatches :: !(Addr -> Bool)
+ , compUpdate :: !(s -> Word16 -> IO s)
+ , compWrite :: !(s -> Addr -> Word8 -> IO s)
+ , compRead :: !(s -> Addr -> IO Word8)
}
newtype Bus = Bus { busComponents :: [Component] }
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs b/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
index 651b27b..26a00de 100644
--- a/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
@@ -110,6 +110,7 @@ updateComps t = do
decode :: Emulating Instruction
decode = do
+ updateComps 4
b <- use bus
pc <- use $ regs . regPC
lastPC .= pc
@@ -126,6 +127,7 @@ cond CondC = use (regs . regFlagC)
read8 :: Addr -> Emulating Word8
read8 a = do
+ updateComps 4
b <- use bus
pc <- use lastPC
ins <- use lastIns
@@ -149,6 +151,7 @@ read16 a = do
write8 :: Addr -> Word8 -> Emulating ()
write8 a v = do
+ updateComps 4
b <- use bus
b' <- liftIO $ Bus.write b a v
bus .= b'
@@ -677,7 +680,6 @@ step ins = do
CbSetB3R8 (B3 idx) r -> {-# SCC "CbSetB3R8" #-} do
v <- r8 r
setR8 r $ v .|. shiftL 0b1 idx
- updateComps 4
where
unimplemented :: Emulating ()
unimplemented = do
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
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-09 23:41:53 +0000