Remove fig-emulator-gb

7 files changed, 0 insertions, 479 deletions

diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Interrupt.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Interrupt.hs
deleted file mode 100644
index f6ea420..0000000
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Interrupt.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-module Fig.Emulator.GB.Component.Interrupt where
-
-import Fig.Prelude
-
-import Fig.Emulator.GB.Utils
-import Fig.Emulator.GB.Bus
-
-newtype InterruptError = InterruptError Text
-  deriving Show
-instance Exception InterruptError
-instance Pretty InterruptError where
-  pretty (InterruptError b) = mconcat
-    [ "interrupt error: "
-    , b
-    ]
-
-compInterrupt :: Component
-compInterrupt = Component
-  { compState = ()
-  , compMatches = \a -> a == 0xff0f || a == 0xffff
-  , compUpdate = \s _ -> pure s
-  , compWrite = \s (Addr a) v -> do
-      case a of
-        0xff0f -> do
-          -- log $ "set IF:" <> show8 v
-          pure ()
-        0xffff -> do
-          -- log $ "set IE:" <> show8 v
-          pure ()
-        _ -> throwM . InterruptError $ "write to invalid address: " <> pretty (Addr a)
-      pure s
-  , compRead = \_ _ -> pure 0x00
-  }
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Joystick.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Joystick.hs
deleted file mode 100644
index 7519ea5..0000000
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Joystick.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-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 :: Component
-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/Misc.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Misc.hs
deleted file mode 100644
index be15e56..0000000
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Misc.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-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/RAM.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs
deleted file mode 100644
index 4dc5715..0000000
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs
+++ /dev/null
@@ -1,40 +0,0 @@
-module Fig.Emulator.GB.Component.RAM
-  ( compWRAM
-  ) where
-
-import Fig.Prelude
-
-import qualified Data.Vector as V
-import qualified Data.Vector.Mutable as MV
-import Data.Word (Word8)
-
-import Fig.Emulator.GB.Bus
-
-newtype RAMError = RAMError Text
-  deriving Show
-instance Exception RAMError
-instance Pretty RAMError where
-  pretty (RAMError b) = mconcat
-    [ "internal RAM error: "
-    , b
-    ]
-
-compWRAM :: Addr -> Int -> Component
-compWRAM start size = Component
-  { compState = V.replicate size 0 :: V.Vector Word8
-  , compMatches = \a ->
-      a >= start && a <= end
-  , compUpdate = \s _ -> {-# SCC "ComponentWRAMUpdate" #-} pure s
-  , compWrite = \s ad v -> {-# SCC "ComponentWRAMWrite" #-} do
-      let offset = fromIntegral . unAddr $ ad - start
-      pure $ V.modify (\ms -> MV.write ms offset v) s
-  , compRead = \s ad -> {-# SCC "ComponentWRAMRead" #-} do
-      let offset = fromIntegral . unAddr $ ad - start
-      case s V.!? offset of
-        Nothing -> throwM . RAMError $ mconcat
-          [ "address ", pretty ad, " out of bounds"
-          ]
-        Just v -> pure v
-  }
-  where
-    end = start + Addr (fromIntegral (size - 1))
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs
deleted file mode 100644
index 6aafc46..0000000
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-module Fig.Emulator.GB.Component.ROM
-  ( compROM
-  ) where
-
-import Fig.Prelude
-import Prelude (fromIntegral)
-
-import qualified Data.Vector as V
-import qualified Data.ByteString as BS
-
-import Fig.Emulator.GB.Bus
-
-newtype ROMError = ROMError Text
-  deriving Show
-instance Exception ROMError
-instance Pretty ROMError where
-  pretty (ROMError b) = mconcat
-    [ "internal ROM error: "
-    , b
-    ]
-
--- | Initialize base ROM (no mapper) from a ByteString
-compROM :: ByteString -> Component
-compROM bs = Component
-  { compState = V.fromList $ BS.unpack bs
-  , compMatches = \a ->
-      a >= start && a < end
-  , compUpdate = \s _ -> pure s
-  , compWrite = \s _ad _v ->
-      pure s
-      -- throwM . ROMError $ mconcat
-      -- [ "tried to write to ROM at ", pretty ad
-      -- ]
-  , compRead = \s ad -> do
-      let offset = fromIntegral . unAddr $ ad - start
-      case s V.!? offset of
-        Nothing -> throwM . ROMError $ mconcat
-          [ "address ", pretty ad, " out of bounds"
-          ]
-        Just v -> pure v
-  }
-  where
-    start = 0x0000
-    -- end = 0x4000
-    end = 0x8000
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs
deleted file mode 100644
index 3912e5d..0000000
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Serial.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-module Fig.Emulator.GB.Component.Serial where
-
-import Fig.Prelude
-
-import GHC.IO.Handle (hPutChar)
-
-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
-    [ "serial error: "
-    , b
-    ]
-
-compSerial :: Maybe Handle -> Component
-compSerial mh = Component
-  { compState = ()
-  , compMatches = (== 0xff01)
-  , compUpdate = \s _ -> pure s
-  , compWrite = \s _ v -> do
-      log $ mconcat
-        [ "wrote serial byte: ", tshow $ chr $ fromIntegral v
-        ]
-      case mh of
-        Nothing -> pure ()
-        Just h -> liftIO . hPutChar h . 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
deleted file mode 100644
index b1ddadc..0000000
--- a/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs
+++ /dev/null
@@ -1,279 +0,0 @@
-module Fig.Emulator.GB.Component.Video where
-
-import Fig.Prelude
-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)
-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
-
-newtype VideoError = VideoError Text
-  deriving Show
-instance Exception VideoError
-instance Pretty VideoError where
-  pretty (VideoError b) = mconcat
-    [ "video error: "
-    , b
-    ]
-
-screenWidth :: Word16
--- screenWidth = 160
-screenWidth = 8 * 32
-
-screenHeight :: Word16
--- screenHeight = 144
-screenHeight = 8 * 32
-
-newtype Framebuffer = Framebuffer
-  { fbSurface :: SDL.Surface
-  }
-
-initializeFramebuffer :: IO Framebuffer
-initializeFramebuffer = do
-  s <- liftIO $ SDL.createRGBSurface
-    (SDL.V2 (fromIntegral screenWidth) $ fromIntegral screenHeight)
-    SDL.RGBA8888
-  pure Framebuffer
-    { fbSurface = s
-    }
-
-
-logTilemap :: V.Vector Word8 -> IO ()
-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 :: Word32 -> (Word8, Word8) -> Framebuffer -> IO ()
-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 :: 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 (base + a + (y * 2 + xb)) of
-        Just b -> pure b
-        Nothing -> throwM . VideoError $ mconcat
-          [ "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)
-        , (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 -> 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
-  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)
-  , vstLcdc :: !Word8
-  , vstScx :: !Word8
-  , vstScy :: !Word8
-  , vstLy :: !Word8
-  , vstLx :: !Word8
-  , vstRenderState :: !RenderState
-  , vstTick :: !Word16
-  }
-
-compVideo :: Framebuffer -> Component
-compVideo framebuffer = Component
-  { compState = VideoState
-    { vstFb = framebuffer
-    , vstVRAM = V.replicate (8 * 1024) 0
-    , vstLcdc = 0
-    , vstScx = 0
-    , vstScy = 0
-    , vstLy = 0
-    , vstLx = 0
-    , vstRenderState = RenderOAMSearch
-    , vstTick = 0
-    }
-
-  , compMatches = isJust  . videoAddrRange
-
-  , compUpdate = \s t -> {-# SCC "ComponentVideoUpdate" #-} do
-      let tick = vstTick s + t
-      let ly = vstLy s + 1
-      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
-              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
-              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: " <> 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 -> do
-          log $ "write to lcdc: " <> show8 v
-          pure s { vstLcdc = v }
-        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 -> {-# 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 $ 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
-        0x8 -> pure 0x00
-        0x9 -> pure 0x00
-        0xa -> pure 0x00
-        0xb -> pure 0x00
-        _ -> pure 0x00
-      Just (VideoAddrVRAM off) -> do
-        case vstVRAM s V.!? fromIntegral (unAddr off) of
-          Nothing -> error "unreachable"
-          Just v -> pure v
-  }