From 3a0a7b0a89fd841edd5f25f79cdb877051d0e948 Mon Sep 17 00:00:00 2001
From: LLLL Colonq <llll@colonq>
Date: Tue, 9 Apr 2024 22:35:42 -0400
Subject: End-of-stream emulator WIP

---
 fig-emulator-gb/src/Fig/Emulator/GB.hs             |   1 +
 fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs         |  48 ++
 fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs         | 621 +++++++++++++++++++++
 .../src/Fig/Emulator/GB/CPU/Instruction.hs         | 343 ++++++++++++
 .../src/Fig/Emulator/GB/Component/RAM.hs           |  41 ++
 .../src/Fig/Emulator/GB/Component/ROM.hs           |  45 ++
 .../src/Fig/Emulator/GB/Component/Video.hs         |  41 ++
 fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs       |  66 +++
 8 files changed, 1206 insertions(+)
 create mode 100644 fig-emulator-gb/src/Fig/Emulator/GB.hs
 create mode 100644 fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs
 create mode 100644 fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
 create mode 100644 fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs
 create mode 100644 fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs
 create mode 100644 fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs
 create mode 100644 fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs
 create mode 100644 fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs

(limited to 'fig-emulator-gb/src/Fig/Emulator')

diff --git a/fig-emulator-gb/src/Fig/Emulator/GB.hs b/fig-emulator-gb/src/Fig/Emulator/GB.hs
new file mode 100644
index 0000000..50cb49d
--- /dev/null
+++ b/fig-emulator-gb/src/Fig/Emulator/GB.hs
@@ -0,0 +1 @@
+module Fig.Emulator.GB where
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs
new file mode 100644
index 0000000..730378a
--- /dev/null
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Bus.hs
@@ -0,0 +1,48 @@
+module Fig.Emulator.GB.Bus
+  ( Addr(..)
+  , Component(..)
+  , Bus(..)
+  , update
+  , write
+  , read
+  ) where
+
+import Fig.Prelude
+
+import Numeric (showHex)
+
+import qualified Data.List as List
+import Data.Word (Word16, Word8)
+
+newtype Addr = Addr { unAddr :: Word16 }
+  deriving (Show, Num, Eq, Ord)
+instance Pretty Addr where
+  pretty (Addr w) = "$" <> pack (showHex w "")
+
+data Component m = forall (s :: Type). Component
+  { compState :: !s
+  , compMatches :: !(Addr -> Bool)
+  , compUpdate :: !(s -> m s)
+  , compWrite :: !(s -> Addr -> Word8 -> m s)
+  , compRead :: !(s -> Addr -> m Word8)
+  }
+
+newtype Bus m = Bus { busComponents :: [Component m] }
+
+update :: forall m. MonadIO m => Bus m -> m (Bus m)
+update b = Bus <$> forM (busComponents b) \Component{..} -> do
+  s <- compUpdate compState
+  pure Component { compState = s, ..}
+
+write :: forall m. MonadIO m => Bus m -> Addr -> Word8 -> m (Bus m)
+write b a v = Bus <$> forM (busComponents b) \c@Component{..} ->
+  if compMatches a
+  then do
+    s <- compWrite compState a v
+    pure Component { compState = s, ..}
+  else pure c
+
+read :: forall m. (MonadIO m, MonadThrow m) => Bus m -> Addr -> m (Maybe Word8)
+read b a = case List.find (`compMatches` a) $ busComponents b of
+  Nothing -> pure Nothing
+  Just Component{..} -> Just <$> compRead compState a
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs b/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
new file mode 100644
index 0000000..33c4ac3
--- /dev/null
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/CPU.hs
@@ -0,0 +1,621 @@
+{-# Language TemplateHaskell, ImplicitParams #-}
+module Fig.Emulator.GB.CPU where
+
+import Control.Lens.TH (makeLenses)
+
+import Fig.Prelude
+import Prelude (fromIntegral)
+
+import System.IO (withFile, IOMode (WriteMode))
+
+import qualified Text.Printf as Pr
+
+import Control.Lens ((.=), use, (^.))
+import Control.Monad (when, unless)
+import Control.Monad.State (StateT(..))
+
+import Data.Word (Word8, Word16)
+import Data.Bits
+
+import qualified SDL
+
+import Fig.Emulator.GB.Utils
+import Fig.Emulator.GB.Bus (Bus(..), Addr(..))
+import qualified Fig.Emulator.GB.Bus as Bus
+import Fig.Emulator.GB.Component.RAM
+import Fig.Emulator.GB.Component.ROM
+import Fig.Emulator.GB.Component.Video
+import Fig.Emulator.GB.CPU.Instruction
+
+newtype CPUError = CPUError Text
+  deriving Show
+instance Exception CPUError
+instance Pretty CPUError where
+  pretty (CPUError b) = mconcat
+    [ "CPU error: "
+    , b
+    ]
+
+data Registers = Registers
+  { _regA :: !Word8
+  , _regB :: !Word8, _regC :: !Word8
+  , _regD :: !Word8, _regE :: !Word8
+  , _regH :: !Word8, _regL :: !Word8
+  , _regSP :: !Word16
+  , _regPC :: !Word16
+  , _regFlagZ :: !Bool, _regFlagC :: !Bool
+  , _regFlagN :: !Bool, _regFlagH :: !Bool
+  , _regFlagIME :: !Bool
+  }
+makeLenses 'Registers
+
+initialRegs :: Registers
+initialRegs = Registers
+  { _regA = 0x01
+  , _regB = 0x00, _regC = 0x13
+  , _regD = 0x00, _regE = 0xd8
+  , _regH = 0x01, _regL = 0x4d
+  , _regSP = 0xfffe
+  , _regPC = 0x0100
+  , _regFlagZ = True, _regFlagC = True
+  , _regFlagN = False, _regFlagH = True
+  , _regFlagIME = False
+  }
+
+data CPU m = CPU
+  { _lastPC :: !Word16
+  , _lastIns :: !Instruction
+  , _regs :: !Registers
+  , _bus :: !(Bus m)
+  }
+makeLenses 'CPU
+
+type EmulatingT f m = (MonadIO m, MonadThrow m, MonadState (CPU f) m, ?log :: Handle)
+type Emulating m = EmulatingT IO m
+
+cpuDMG :: (MonadIO m, MonadThrow m) => ByteString -> CPU m
+cpuDMG rom = CPU
+  { _lastPC = 0x0
+  , _lastIns = Nop
+  , _regs = initialRegs
+  , _bus = Bus
+    [ compROM rom
+    , compWRAM 0x8000 $ 8 * 1024 -- vram placeholder
+    , compWRAM 0xc000 $ 8 * 1024
+    , compLCD
+    ]
+  }
+
+logCPUState :: Emulating m => m ()
+logCPUState = do
+  rs <- use regs
+  let pc = rs ^. regPC
+  m0 <- read8 $ Addr pc
+  m1 <- read8 $ Addr pc + 1
+  m2 <- read8 $ Addr pc + 2
+  m3 <- read8 $ Addr pc + 3
+  liftIO . hPutStrLn ?log $ mconcat 
+    [ "A:", rreg8 $ rs ^. regA
+    , " F:", rreg8 $ flagsw8 (rs ^. regFlagZ) (rs ^. regFlagN) (rs ^. regFlagH) (rs ^. regFlagC)
+    , " B:", rreg8 $ rs ^. regB
+    , " C:", rreg8 $ rs ^. regC
+    , " D:", rreg8 $ rs ^. regD
+    , " E:", rreg8 $ rs ^. regE
+    , " H:", rreg8 $ rs ^. regH
+    , " L:", rreg8 $ rs ^. regL
+    , " SP:", rreg16 $ rs ^. regSP
+    , " PC:", rreg16 pc
+    , " PCMEM:", rreg8 m0, ",", rreg8 m1, ",", rreg8 m2, ",", rreg8 m3
+    ]
+  where
+    rreg8 = pack . Pr.printf "%02X"
+    rreg16 = pack . Pr.printf "%04X"
+
+decode :: Emulating m => m Instruction
+decode = do
+  b <- use bus
+  pc <- use $ regs . regPC
+  lastPC .= pc
+  (ins, Addr a) <- liftIO $ readInstruction b $ Addr pc
+  lastIns .= ins
+  regs . regPC .= a
+  pure ins
+
+cond :: Emulating m => Cond -> m Bool
+cond CondNz = not <$> use (regs . regFlagZ)
+cond CondZ = use (regs . regFlagZ)
+cond CondNc = not <$> use (regs . regFlagC)
+cond CondC = use (regs . regFlagC)
+
+read8 :: Emulating m => Addr -> m Word8
+read8 a = do
+  b <- use bus
+  pc <- use lastPC
+  ins <- use lastIns
+  liftIO (Bus.read b a) >>= \case
+    Just v -> pure v
+    Nothing -> throwM . CPUError $ mconcat
+      [ "read from unmapped address "
+      , pretty a
+      , " while executing instruction "
+      , tshow ins
+      , " (at "
+      , pretty $ Addr pc
+      , ")"
+      ]
+
+read16 :: Emulating m => Addr -> m Word16
+read16 a = do
+  lo <- read8 a
+  hi <- read8 $ a + 1
+  pure $ w8w8 hi lo
+
+write8 :: Emulating m => Addr -> Word8 -> m ()
+write8 a v = do
+  b <- use bus
+  b' <- liftIO $ Bus.write b a v
+  bus .= b'
+
+write16 :: Emulating m => Addr -> Word16 -> m ()
+write16 a v = do
+  write8 a $ w16lo v
+  write8 (a + 1) $ w16hi v
+
+r8 :: Emulating m => R8 -> m Word8
+r8 R8B = use $ regs . regB
+r8 R8C = use $ regs . regC
+r8 R8D = use $ regs . regD
+r8 R8E = use $ regs . regE
+r8 R8H = use $ regs . regH
+r8 R8L = use $ regs . regL
+r8 R8MemHL = do
+  hl <- r16 R16HL
+  read8 $ Addr hl
+r8 R8A = use $ regs . regA
+
+setR8 :: Emulating m => R8 -> Word8 -> m ()
+setR8 R8B v = regs . regB .= v
+setR8 R8C v = regs . regC .= v
+setR8 R8D v = regs . regD .= v
+setR8 R8E v = regs . regE .= v
+setR8 R8H v = regs . regH .= v
+setR8 R8L v = regs . regL .= v
+setR8 R8MemHL v = do
+  hl <- r16 R16HL
+  write8 (Addr hl) v
+setR8 R8A v = regs . regA .= v
+
+r16 :: Emulating m => R16 -> m Word16
+r16 R16BC = w8w8 <$> r8 R8B <*> r8 R8C
+r16 R16DE = w8w8 <$> r8 R8D <*> r8 R8E
+r16 R16HL = w8w8 <$> r8 R8H <*> r8 R8L
+r16 R16SP = use $ regs . regSP
+
+setR16 :: Emulating m => R16 -> Word16 -> m ()
+setR16 R16BC v = do
+  regs . regB .= w16hi v
+  regs . regC .= w16lo v
+setR16 R16DE v = do
+  regs . regD .= w16hi v
+  regs . regE .= w16lo v
+setR16 R16HL v = do
+  regs . regH .= w16hi v
+  regs . regL .= w16lo v
+setR16 R16SP v = regs . regSP .= v
+
+r16Stk :: Emulating m => R16Stk -> m Word16
+r16Stk R16StkBC = r16 R16BC
+r16Stk R16StkDE = r16 R16DE
+r16Stk R16StkHL = r16 R16HL
+r16Stk R16StkAF = do
+  hi <- r8 R8A
+  z <- use $ regs . regFlagZ
+  n <- use $ regs . regFlagN
+  h <- use $ regs . regFlagH
+  c <- use $ regs . regFlagC
+  pure . w8w8 hi $ flagsw8 z n h c
+
+setR16Stk :: Emulating m => R16Stk -> Word16 -> m ()
+setR16Stk R16StkBC v = setR16 R16BC v
+setR16Stk R16StkDE v = setR16 R16DE v
+setR16Stk R16StkHL v = setR16 R16HL v
+setR16Stk R16StkAF v = do
+  setR8 R8A $ w16hi v
+  let lo = w16lo v
+  regs . regFlagZ .= w8bit 7 lo
+  regs . regFlagN .= w8bit 6 lo
+  regs . regFlagH .= w8bit 5 lo
+  regs . regFlagC .= w8bit 4 lo
+
+r16Mem :: Emulating m => R16Mem -> m Word16
+r16Mem R16MemBC = r16 R16BC
+r16Mem R16MemDE = r16 R16DE
+r16Mem R16MemHLPlus = do
+  hl <- r16 R16HL
+  setR16 R16HL $ hl + 1
+  pure hl
+r16Mem R16MemHLMinus = do
+  hl <- r16 R16HL
+  setR16 R16HL $ hl - 1
+  pure hl
+
+renderTile :: Emulating m => SDL.Renderer -> Addr -> Int -> Int -> m ()
+renderTile renderer a bx by = do
+  (ps :: [(Int, Int, Word8)]) <- mconcat <$> forM [0..8] \y -> do
+    mconcat <$> forM [0 .. 1] \x -> do
+      b <- read8 $ a + Addr (y * 2 + x)
+      pure
+        [ (bx + fromIntegral x, by + fromIntegral y, w8bits2 7 b)
+        , (bx + fromIntegral x, by + fromIntegral y, w8bits2 5 b)
+        , (bx + fromIntegral x, by + fromIntegral y, w8bits2 3 b)
+        , (bx + fromIntegral x, by + fromIntegral y, w8bits2 1 b)
+        ]
+  SDL.rendererDrawColor renderer SDL.$= SDL.V4 0 0 0 255
+  forM_ ps \(x, y, p) -> do
+    unless (p == 0) do
+      SDL.drawPoint renderer . SDL.P $ SDL.V2 (fromIntegral x) (fromIntegral y)
+
+step :: forall m. Emulating m => Instruction -> m ()
+step ins = do
+  let
+    sub8 :: (Word16 -> Word16 -> Word16) -> Word8 -> Word8 -> m Word8
+    sub8 op x y = do
+      let res = op (sext x) (sext y)
+      regs . regFlagH .= (w8bits4 3 y > w8bits4 3 x)
+      regs . regFlagC .= (y > x)
+      regs . regFlagZ .= (res .&. 0xff == 0)
+      regs . regFlagN .= True
+      pure $ trunc res
+    bitwise8 :: (Word8 -> Word8 -> Word8) -> Word8 -> Word8 -> m Word8
+    bitwise8 op x y = do
+      let res = op x y
+      regs . regFlagH .= False
+      regs . regFlagC .= False
+      regs . regFlagZ .= (res .&. 0xff == 0)
+      regs . regFlagN .= False
+      pure res
+  case ins of
+    Nop -> pure ()
+    LdR16Imm16 r (Imm16 i) -> setR16 r i
+    LdR16MemA r -> do
+      addr <- r16Mem r
+      a <- r8 R8A
+      write8 (Addr addr) a
+    LdAR16Mem r -> do
+      addr <- r16Mem r
+      v <- read8 $ Addr addr
+      setR8 R8A v
+    LdImm16Sp (Imm16 addr) -> do
+      sp <- r16 R16SP
+      write8 (Addr addr) $ w16lo sp
+      write8 (Addr addr + 1) $ w16hi sp
+    IncR16 r -> do
+      v <- r16 r
+      setR16 r $ v + 1
+    DecR16 r -> do
+      v <- r16 r
+      setR16 r $ v - 1
+    AddHlR16 r -> do
+      x <- r16 R16HL
+      y <- r16 r
+      let
+        res :: Word16
+        res = x + y
+      regs . regFlagH .= (shiftR res 11 .&. 0b1 == 0b1)
+      regs . regFlagC .= (shiftR res 15 .&. 0b1 == 0b1)
+      regs . regFlagZ .= (res .&. 0xffff == 0)
+      regs . regFlagN .= False
+      setR16 R16HL res
+    IncR8 r -> do
+      v <- r8 r
+      let (res, _) = addC False v 1
+      regs . regFlagH .= addH False v 1
+      regs . regFlagZ .= (res == 0)
+      regs . regFlagN .= False
+      setR8 r res
+    DecR8 r -> do
+      v <- r8 r
+      let
+        res :: Word8
+        res = v - 1
+      regs . regFlagH .= subH v 1
+      regs . regFlagZ .= (res == 0)
+      regs . regFlagN .= True
+      setR8 r res
+    LdR8Imm8 r (Imm8 i) -> setR8 r i
+    Rlca -> do
+      v <- r8 R8A
+      regs . regFlagH .= False
+      regs . regFlagZ .= False
+      regs . regFlagN .= False
+      regs . regFlagC .= w8bit 7 v
+      setR8 R8A $ rotateL v 1
+    Rrca -> do
+      v <- r8 R8A
+      regs . regFlagH .= False
+      regs . regFlagZ .= False
+      regs . regFlagN .= False
+      regs . regFlagC .= w8bit 0 v
+      setR8 R8A $ rotateR v 1
+    Rla -> do
+      v <- r8 R8A
+      c <- use $ regs . regFlagC
+      regs . regFlagH .= False
+      regs . regFlagZ .= False
+      regs . regFlagN .= False
+      regs . regFlagC .= w8bit 7 v
+      setR8 R8A $ rotateL v 1 .|. if c then 1 else 0
+    Rra -> do
+      v <- r8 R8A
+      c <- use $ regs . regFlagC
+      regs . regFlagH .= False
+      regs . regFlagZ .= False
+      regs . regFlagN .= False
+      regs . regFlagC .= w8bit 0 v
+      setR8 R8A $ rotateR v 1 .|. if c then 0b10000000 else 0
+    Daa -> unimplemented
+    Cpl -> do
+      v <- r8 R8A
+      regs . regFlagH .= True
+      regs . regFlagN .= True
+      setR8 R8A $ complement v
+    Scf -> do
+      regs . regFlagH .= False
+      regs . regFlagN .= False
+      regs . regFlagC .= True
+    Ccf -> do
+      c <- use $ regs . regFlagC
+      regs . regFlagH .= False
+      regs . regFlagN .= False
+      regs . regFlagC .= not c
+    JrImm8 (Imm8 i) -> do
+      pc <- use $ regs . regPC
+      regs . regPC .= pc + sext i
+    JrCondImm8 c (Imm8 i) -> do
+      b <- cond c
+      when b do
+        pc <- use $ regs . regPC
+        regs . regPC .= pc + sext i
+    Stop -> unimplemented
+    LdR8R8 dst src -> do
+      v <- r8 src
+      setR8 dst v
+    Halt -> unimplemented
+    AddAR8 i -> do
+      x <- r8 R8A
+      y <- r8 i
+      let (res, carry) = addC False x y
+      regs . regFlagH .= addH False x y
+      regs . regFlagC .= carry
+      regs . regFlagZ .= (res .&. 0xff == 0)
+      regs . regFlagN .= False
+      regs . regA .= res
+    AdcAR8 i -> do
+      x <- r8 R8A
+      y <- r8 i
+      c <- use $ regs . regFlagC
+      let (res, carry) = addC c x y
+      regs . regFlagH .= addH c x y
+      regs . regFlagC .= carry
+      regs . regFlagZ .= (res .&. 0xff == 0)
+      regs . regFlagN .= False
+      regs . regA .= res
+    SubAR8 i -> do
+      x <- r8 R8A
+      y <- r8 i
+      res <- sub8 (-) x y
+      regs . regA .= res
+    SbcAR8 i -> do
+      x <- r8 R8A
+      y <- r8 i
+      c <- use $ regs . regFlagC
+      res <- sub8 (\a b -> a - (b + if c then 1 else 0)) x y
+      regs . regA .= res
+    AndAR8 i -> do
+      x <- r8 R8A
+      y <- r8 i
+      res <- bitwise8 (.&.) x y
+      regs . regA .= res
+    XorAR8 i -> do
+      x <- r8 R8A
+      y <- r8 i
+      res <- bitwise8 xor x y
+      regs . regA .= res
+    OrAR8 i -> do
+      x <- r8 R8A
+      y <- r8 i
+      res <- bitwise8 (.|.) x y
+      regs . regA .= res
+    CpAR8 i -> do
+      x <- r8 R8A
+      y <- r8 i
+      void $ sub8 (-) x y
+    AddAImm8 (Imm8 y) -> do
+      x <- r8 R8A
+      let (res, carry) = addC False x y
+      regs . regFlagH .= addH False x y
+      regs . regFlagC .= carry
+      regs . regFlagZ .= (res .&. 0xff == 0)
+      regs . regFlagN .= False
+      regs . regA .= res
+    AdcAImm8 (Imm8 y) -> do
+      x <- r8 R8A
+      c <- use $ regs . regFlagC
+      let (res, carry) = addC c x y
+      regs . regFlagH .= addH c x y
+      regs . regFlagC .= carry
+      regs . regFlagZ .= (res .&. 0xff == 0)
+      regs . regFlagN .= False
+      regs . regA .= res
+    SubAImm8 (Imm8 y) -> do
+      x <- r8 R8A
+      res <- sub8 (-) x y
+      regs . regA .= res
+    SbcAImm8 (Imm8 y) -> do
+      x <- r8 R8A
+      c <- use $ regs . regFlagC
+      res <- sub8 (\a b -> a - (b + if c then 1 else 0)) x y
+      regs . regA .= res
+    AndAImm8 (Imm8 y) -> do
+      x <- r8 R8A
+      res <- bitwise8 (.&.) x y
+      regs . regA .= res
+    XorAImm8 (Imm8 y) -> do
+      x <- r8 R8A
+      res <- bitwise8 xor x y
+      regs . regA .= res
+    OrAImm8 (Imm8 y) -> do
+      x <- r8 R8A
+      res <- bitwise8 (.|.) x y
+      regs . regA .= res
+    CpAImm8 (Imm8 y) -> do
+      x <- r8 R8A
+      void $ sub8 (-) x y
+    RetCond c -> do
+      b <- cond c
+      when b do
+        sp <- r16 R16SP
+        v <- read16 $ Addr sp
+        setR16 R16SP $ sp + 2
+        regs . regPC .= v
+    Ret -> do
+      sp <- r16 R16SP
+      v <- read16 $ Addr sp
+      setR16 R16SP $ sp + 2
+      regs . regPC .= v
+    Reti -> unimplemented
+    JpCondImm16 c (Imm16 i) -> do
+      b <- cond c
+      when b do
+        regs . regPC .= i
+    JpImm16 (Imm16 i) -> do
+      regs . regPC .= i
+    JpHl -> do
+      hl <- r16 R16HL
+      regs . regPC .= hl
+    CallCondImm16 c (Imm16 i) -> do
+      b <- cond c
+      when b do
+        next <- use $ regs . regPC
+        sp <- (\x -> x - 2) <$> r16 R16SP
+        setR16 R16SP sp
+        write16 (Addr sp) next
+        regs . regPC .= i
+    CallImm16 (Imm16 i) -> do
+      next <- use $ regs . regPC
+      sp <- (\x -> x - 2) <$> r16 R16SP
+      setR16 R16SP sp
+      write16 (Addr sp) next
+      regs . regPC .= i
+    RstTgt3 (Tgt3 v) -> do
+      next <- use $ regs . regPC
+      sp <- (\x -> x - 2) <$> r16 R16SP
+      setR16 R16SP sp
+      write16 (Addr sp) next
+      regs . regPC .= shiftL (fromIntegral v) 3
+    PopR16Stk r -> do
+      sp <- r16 R16SP
+      v <- read16 $ Addr sp
+      setR16 R16SP $ sp + 2
+      setR16Stk r v
+    PushR16Stk r -> do
+      sp <- (\x -> x - 2) <$> r16 R16SP
+      v <- r16Stk r
+      setR16 R16SP sp
+      write16 (Addr sp) v
+    LdhCA -> do
+      c <- r8 R8C
+      a <- r8 R8A
+      write8 (Addr $ 0xff00 + zext c) a
+    LdhImm8A (Imm8 i) -> do
+      a <- r8 R8A
+      write8 (Addr $ 0xff00 + zext i) a
+    LdImm16A (Imm16 i) -> do
+      a <- r8 R8A
+      write8 (Addr i) a
+    LdhAC -> do
+      c <- r8 R8C
+      v <- read8 (Addr $ 0xff00 + zext c)
+      setR8 R8A v
+    LdhAImm8 (Imm8 i) -> do
+      v <- read8 (Addr $ 0xff00 + zext i)
+      setR8 R8A v
+    LdAImm16 (Imm16 i) -> do
+      v <- read8 (Addr i)
+      setR8 R8A v
+    AddSpImm8 (Imm8 y) -> do
+      x <- r16 R16SP
+      let
+        res :: Word16
+        res = x + sext y
+      regs . regFlagH .= (shiftR res 3 .&. 0b1 == 0b1)
+      regs . regFlagC .= (shiftR res 7 .&. 0b1 == 0b1)
+      regs . regFlagZ .= False
+      regs . regFlagN .= False
+      setR16 R16SP res
+    LdHlSpPlusImm8 (Imm8 y) -> do
+      x <- r16 R16SP
+      let
+        res :: Word16
+        res = x + sext y
+      regs . regFlagH .= (shiftR res 3 .&. 0b1 == 0b1)
+      regs . regFlagC .= (shiftR res 7 .&. 0b1 == 0b1)
+      regs . regFlagZ .= False
+      regs . regFlagN .= False
+      setR16 R16HL res
+    LdSpHl -> do
+      v <- r16 R16HL
+      setR16 R16SP v
+    Di -> regs . regFlagIME .= False
+    Ei -> regs . regFlagIME .= True
+    CbRlcR8 _ -> unimplemented
+    CbRrcR8 _ -> unimplemented
+    CbRlR8 _ -> unimplemented
+    CbRrR8 _ -> unimplemented
+    CbSlaR8 _ -> unimplemented
+    CbSraR8 _ -> unimplemented
+    CbSwapR8 _ -> unimplemented
+    CbSrlR8 _ -> unimplemented
+    CbBitB3R8 _ _ -> unimplemented
+    CbResB3R8 _ _ -> unimplemented
+    CbSetB3R8 _ _ -> unimplemented
+  where
+    unimplemented :: m ()
+    unimplemented = do
+      a <- use lastPC
+      throwM . CPUError $ mconcat
+        [ "unimplemented instruction (at "
+        , pretty $ Addr a
+        , "): "
+        , tshow ins
+        ]
+
+testRun :: forall m. (MonadIO m, MonadThrow m) => ByteString -> m ()
+testRun rom = do
+  SDL.initializeAll
+  window <- SDL.createWindow "taking" SDL.defaultWindow
+  renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer
+  let cpu = cpuDMG rom
+  let
+    loop :: forall m'. Emulating m' => Int -> m' ()
+    loop cycle = do
+      -- pc <- use $ regs . regPC
+      ins <- decode
+      -- log $ mconcat
+      --   [ pretty $ Addr pc
+      --   , ": ", tshow ins
+      --   ]
+      step ins
+      -- logCPUState
+      when (rem cycle 70224 == 0) do
+        SDL.rendererDrawColor renderer SDL.$= SDL.V4 255 255 255 255
+        SDL.clear renderer
+        forM_ ([0..255] :: [Int]) \i -> do
+          renderTile renderer (Addr . fromIntegral $ 0x8000 + i * 16) 0 0
+        SDL.present renderer
+      loop $ cycle + 1
+  liftIO $ withFile "log.txt" WriteMode \h -> do
+    let ?log = h
+    void $ flip runStateT cpu do
+      -- logCPUState
+      loop 0
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs b/fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs
new file mode 100644
index 0000000..b74a8ee
--- /dev/null
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/CPU/Instruction.hs
@@ -0,0 +1,343 @@
+module Fig.Emulator.GB.CPU.Instruction where
+
+import Fig.Prelude
+import Prelude (Integral, fromIntegral, error)
+
+import Data.Word (Word8, Word16)
+
+import Fig.Emulator.GB.Utils
+import Fig.Emulator.GB.Bus as Bus
+
+newtype DecodeError = DecodeError Text
+  deriving Show
+instance Exception DecodeError
+instance Pretty DecodeError where
+  pretty (DecodeError b) = mconcat
+    [ "instruction decoding error: "
+    , b
+    ]
+
+class ExtractFromOpcode t where
+  ext :: Integral i => i -> t
+
+data R8 = R8B | R8C | R8D | R8E | R8H | R8L | R8MemHL | R8A
+  deriving (Show)
+instance ExtractFromOpcode R8 where
+  ext i = case (fromIntegral i :: Int) of
+    0 -> R8B
+    1 -> R8C
+    2 -> R8D
+    3 -> R8E
+    4 -> R8H
+    5 -> R8L
+    6 -> R8MemHL
+    7 -> R8A
+    _ -> error "unreachable"
+
+data R16 = R16BC | R16DE | R16HL | R16SP
+  deriving (Show)
+instance ExtractFromOpcode R16 where
+  ext i = case (fromIntegral i :: Int) of
+    0 -> R16BC
+    1 -> R16DE
+    2 -> R16HL
+    3 -> R16SP
+    _ -> error "unreachable"
+
+data R16Stk = R16StkBC | R16StkDE | R16StkHL | R16StkAF
+  deriving (Show)
+instance ExtractFromOpcode R16Stk where
+  ext i = case (fromIntegral i :: Int) of
+    0 -> R16StkBC
+    1 -> R16StkDE
+    2 -> R16StkHL
+    3 -> R16StkAF
+    _ -> error "unreachable"
+
+data R16Mem = R16MemBC | R16MemDE | R16MemHLPlus | R16MemHLMinus
+  deriving (Show)
+instance ExtractFromOpcode R16Mem where
+  ext i = case (fromIntegral i :: Int) of
+    0 -> R16MemBC
+    1 -> R16MemDE
+    2 -> R16MemHLPlus
+    3 -> R16MemHLMinus
+    _ -> error "unreachable"
+
+data Cond = CondNz | CondZ | CondNc | CondC
+  deriving (Show)
+instance ExtractFromOpcode Cond where
+  ext i = case (fromIntegral i :: Int) of
+    0 -> CondNz
+    1 -> CondZ
+    2 -> CondNc
+    3 -> CondC
+    _ -> error "unreachable"
+
+newtype B3 = B3 Int
+  deriving (Show)
+instance ExtractFromOpcode B3 where
+  ext i = B3 $ fromIntegral i
+
+newtype Tgt3 = Tgt3 Int
+  deriving (Show)
+instance ExtractFromOpcode Tgt3 where
+  ext i = Tgt3 $ fromIntegral i
+
+newtype Imm8 = Imm8 Word8
+  deriving (Show)
+readImm8 :: (MonadIO m, MonadThrow m) => Bus.Bus m -> Addr -> m Imm8
+readImm8 b a = Bus.read b a >>= \case
+  Just i -> pure $ Imm8 i
+  Nothing -> throwM . DecodeError $ mconcat
+    [ "failed to read immediate at unmapped address"
+    , pretty a
+    ]
+
+newtype Imm16 = Imm16 Word16
+  deriving (Show)
+readImm16 :: (MonadIO m, MonadThrow m) => Bus.Bus m -> Addr -> m Imm16
+readImm16 b a = do
+  mlo <- Bus.read b a
+  mhi <- Bus.read b $ a + 1
+  case (mlo, mhi) of
+    (Just lo, Just hi) -> pure . Imm16 $ w8w8 hi lo
+    _otherwise -> throwM . DecodeError $ mconcat
+      [ "failed to read 16-bit immediate at unmapped address"
+      , pretty a
+      ]
+
+data Instruction
+  -- Block 0
+  = Nop
+
+  | LdR16Imm16 !R16 !Imm16
+  | LdR16MemA !R16Mem
+  | LdAR16Mem !R16Mem
+  | LdImm16Sp !Imm16
+
+  | IncR16 !R16
+  | DecR16 !R16
+  | AddHlR16 !R16
+
+  | IncR8 !R8
+  | DecR8 !R8
+
+  | LdR8Imm8 !R8 !Imm8
+
+  | Rlca
+  | Rrca
+  | Rla
+  | Rra
+  | Daa
+  | Cpl
+  | Scf
+  | Ccf
+
+  | JrImm8 !Imm8
+  | JrCondImm8 !Cond !Imm8
+
+  | Stop
+
+  -- Block 1
+  | LdR8R8 !R8 !R8
+
+  | Halt
+
+  -- Block 2
+  | AddAR8 !R8
+  | AdcAR8 !R8
+  | SubAR8 !R8
+  | SbcAR8 !R8
+  | AndAR8 !R8
+  | XorAR8 !R8
+  | OrAR8 !R8
+  | CpAR8 !R8
+
+  -- Block 3
+  | AddAImm8 !Imm8
+  | AdcAImm8 !Imm8
+  | SubAImm8 !Imm8
+  | SbcAImm8 !Imm8
+  | AndAImm8 !Imm8
+  | XorAImm8 !Imm8
+  | OrAImm8 !Imm8
+  | CpAImm8 !Imm8
+
+  | RetCond !Cond
+  | Ret
+  | Reti
+  | JpCondImm16 !Cond !Imm16
+  | JpImm16 !Imm16
+  | JpHl
+  | CallCondImm16 !Cond !Imm16
+  | CallImm16 !Imm16
+  | RstTgt3 !Tgt3
+
+  | PopR16Stk !R16Stk
+  | PushR16Stk !R16Stk
+
+  | LdhCA
+  | LdhImm8A !Imm8
+  | LdImm16A !Imm16
+  | LdhAC
+  | LdhAImm8 !Imm8
+  | LdAImm16 !Imm16
+
+  | AddSpImm8 !Imm8
+  | LdHlSpPlusImm8 !Imm8
+  | LdSpHl
+
+  | Di
+  | Ei
+
+  -- 0xcb prefixed 16-bit instructions
+  | CbRlcR8 !R8
+  | CbRrcR8 !R8
+  | CbRlR8 !R8
+  | CbRrR8 !R8
+  | CbSlaR8 !R8
+  | CbSraR8 !R8
+  | CbSwapR8 !R8
+  | CbSrlR8 !R8
+
+  | CbBitB3R8 !B3 !R8
+  | CbResB3R8 !B3 !R8
+  | CbSetB3R8 !B3 !R8
+  deriving (Show)
+
+readInstruction ::
+  (MonadIO m, MonadThrow m) =>
+  Bus.Bus m -> Addr ->
+  m (Instruction, Addr)
+readInstruction b a = do
+  op <- Bus.read b a >>= \case
+    Just o -> pure o
+    Nothing -> throwM . DecodeError $ mconcat
+      [ "failed to read opcode at unmapped address "
+      , pretty a
+      ]
+  let blk = w8bits2 7 op
+  let bot3 = w8bits3 2 op
+  let bot4 = w8bits4 3 op
+  let no i = pure (i, a + 1)
+  let imm8 f = do
+        x <- readImm8 b $ a + 1
+        pure (f x, a + 2)
+  let imm16 f = do
+        x <- readImm16 b $ a + 1
+        pure (f x, a + 3)
+  case (op, blk, bot4, bot3) of
+    -- Block 0
+    (0b00000000, _, _, _) -> no Nop
+
+    (_, 0b00, 0b0001, _) -> imm16 $ LdR16Imm16 (ext $ w8bits2 5 op)
+    (_, 0b00, 0b0010, _) -> no $ LdR16MemA (ext $ w8bits2 5 op)
+    (_, 0b00, 0b1010, _) -> no $ LdAR16Mem (ext $ w8bits2 5 op)
+    (0b00001000, _, _, _) -> imm16 LdImm16Sp
+
+    (_, 0b00, 0b0011, _) -> no $ IncR16 (ext $ w8bits2 5 op)
+    (_, 0b00, 0b1011, _) -> no $ DecR16 (ext $ w8bits2 5 op)
+    (_, 0b00, 0b1001, _) -> no $ AddHlR16 (ext $ w8bits2 5 op)
+
+    (_, 0b00, _, 0b100) -> no $ IncR8 (ext $ w8bits3 5 op)
+    (_, 0b00, _, 0b101) -> no $ DecR8 (ext $ w8bits3 5 op)
+
+    (_, 0b00, _, 0b110) -> imm8 $ LdR8Imm8 (ext $ w8bits3 5 op)
+
+    (0b00000111, _, _, _) -> no Rlca
+    (0b00001111, _, _, _) -> no Rrca
+    (0b00010111, _, _, _) -> no Rla
+    (0b00011111, _, _, _) -> no Rra
+    (0b00100111, _, _, _) -> no Daa
+    (0b00101111, _, _, _) -> no Cpl
+    (0b00110111, _, _, _) -> no Scf
+    (0b00111111, _, _, _) -> no Ccf
+
+    (0b00011000, _, _, _) -> imm8 JrImm8
+    (0b00010000, _, _, _) -> no Stop
+    (_, 0b00, _, 0b000) -> imm8 $ JrCondImm8 (ext $ w8bits2 4 op)
+
+    -- Block 1
+    (0b01110110, _, _, _) -> no Halt
+    (_, 0b01, _, _) -> no $ LdR8R8 (ext $ w8bits3 5 op) (ext $ w8bits3 2 op)
+
+    -- Block 2
+    (_, 0b10, _, _) -> do
+      let ins = case w8bits3 5 op of
+            0b000 -> AddAR8
+            0b001 -> AdcAR8
+            0b010 -> SubAR8
+            0b011 -> SbcAR8
+            0b100 -> AndAR8
+            0b101 -> XorAR8
+            0b110 -> OrAR8
+            0b111 -> CpAR8
+            _ -> error "unreachable"
+      no $ ins (ext $ w8bits3 2 op)
+
+    -- Block 3
+    (0b11000110, _, _, _) -> imm8 AddAImm8
+    (0b11001110, _, _, _) -> imm8 AdcAImm8
+    (0b11010110, _, _, _) -> imm8 SubAImm8
+    (0b11011110, _, _, _) -> imm8 SbcAImm8
+    (0b11100110, _, _, _) -> imm8 AndAImm8
+    (0b11101110, _, _, _) -> imm8 XorAImm8
+    (0b11110110, _, _, _) -> imm8 OrAImm8
+    (0b11111110, _, _, _) -> imm8 CpAImm8
+
+    (0b11001001, _, _, _) -> no Ret
+    (0b11011001, _, _, _) -> no Reti
+    (0b11000011, _, _, _) -> imm16 JpImm16
+    (0b11101001, _, _, _) -> no JpHl
+    (0b11001101, _, _, _) -> imm16 CallImm16
+
+    (0b11100010, _, _, _) -> no LdhCA
+    (0b11100000, _, _, _) -> imm8 LdhImm8A
+    (0b11101010, _, _, _) -> imm16 LdImm16A
+    (0b11110010, _, _, _) -> no LdhAC
+    (0b11110000, _, _, _) -> imm8 LdhAImm8
+    (0b11111010, _, _, _) -> imm16 LdAImm16
+
+    (0b11101000, _, _, _) -> imm8 AddSpImm8
+    (0b11111000, _, _, _) -> imm8 LdHlSpPlusImm8
+    (0b11111001, _, _, _) -> no LdSpHl
+
+    (0b11110011, _, _, _) -> no Di
+    (0b11111011, _, _, _) -> no Ei
+
+    (0b11001011, _, _, _) -> do
+      -- 0xcb prefix
+      op2 <- Bus.read b (a + 1) >>= \case
+        Just o -> pure o
+        Nothing -> throwM . DecodeError $ mconcat
+          [ "failed to read (0xCB-prefixed) opcode at unmapped address "
+          , pretty $ a + 1
+          ]
+      case w8bits2 7 op2 of
+
+        0b00 -> case w8bits3 5 op2 of
+          0b000 -> pure (CbRlcR8 $ ext $ w8bits3 2 op2, a + 2)
+          0b001 -> pure (CbRrcR8 $ ext $ w8bits3 2 op2, a + 2)
+          0b010 -> pure (CbRlR8 $ ext $ w8bits3 2 op2, a + 2)
+          0b011 -> pure (CbRrR8 $ ext $ w8bits3 2 op2, a + 2)
+          0b100 -> pure (CbSlaR8 $ ext $ w8bits3 2 op2, a + 2)
+          0b101 -> pure (CbSraR8 $ ext $ w8bits3 2 op2, a + 2)
+          0b110 -> pure (CbSwapR8 $ ext $ w8bits3 2 op2, a + 2)
+          0b111 -> pure (CbSrlR8 $ ext $ w8bits3 2 op2, a + 2)
+          _ -> error "unreachable"
+        0b01 -> pure (CbBitB3R8 (ext $ w8bits3 5 op2) $ ext $ w8bits3 2 op2, a + 2)
+        0b10 -> pure (CbResB3R8 (ext $ w8bits3 5 op2) $ ext $ w8bits3 2 op2, a + 2)
+        0b11 -> pure (CbSetB3R8 (ext $ w8bits3 5 op2) $ ext $ w8bits3 2 op2, a + 2)
+        _ -> error "unreachable"
+
+    (_, 0b11, _, 0b000) -> no $ RetCond (ext $ w8bits2 4 op)
+    (_, 0b11, _, 0b010) -> imm16 $ JpCondImm16 (ext $ w8bits2 4 op)
+    (_, 0b11, _, 0b100) -> imm16 $ CallCondImm16 (ext $ w8bits2 4 op)
+    (_, 0b11, _, 0b111) -> no $ RstTgt3 (ext $ w8bits3 5 op)
+    (_, 0b11, 0b0001, _) -> no $ PopR16Stk (ext $ w8bits2 5 op)
+    (_, 0b11, 0b0101, _) -> no $ PushR16Stk (ext $ w8bits2 5 op)
+
+    _unknown -> do
+      log $ "unknown opcode: " <> tshow op
+      no Nop
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs
new file mode 100644
index 0000000..c88033e
--- /dev/null
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/RAM.hs
@@ -0,0 +1,41 @@
+module Fig.Emulator.GB.Component.RAM
+  ( compWRAM
+  ) where
+
+import Fig.Prelude
+import Prelude (fromIntegral)
+
+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 :: (MonadIO m, MonadThrow m) => Addr -> Int -> Component m
+compWRAM start size = Component
+  { compState = V.replicate size 0 :: V.Vector Word8
+  , compMatches = \a ->
+      a >= start && a < end
+  , compUpdate = pure
+  , compWrite = \s ad v -> do
+      let offset = fromIntegral . unAddr $ ad - start
+      pure $ V.modify (\ms -> MV.write ms offset v) s
+  , compRead = \s ad -> 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)
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs
new file mode 100644
index 0000000..b5ea24f
--- /dev/null
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/ROM.hs
@@ -0,0 +1,45 @@
+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 :: (MonadIO m, MonadThrow m) => ByteString -> Component m
+compROM bs = Component
+  { compState = V.fromList $ BS.unpack bs
+  , compMatches = \a ->
+      a >= start && a < end
+  , compUpdate = pure
+  , 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/Video.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs
new file mode 100644
index 0000000..00f0e4d
--- /dev/null
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Component/Video.hs
@@ -0,0 +1,41 @@
+module Fig.Emulator.GB.Component.Video where
+
+import Fig.Prelude
+
+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
+    ]
+
+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
+        0x0 -> pure 0x00
+        0x1 -> pure 0x00
+        0x2 -> pure 0x00
+        0x3 -> pure 0x00
+        0x4 -> pure 0x00
+        0x5 -> pure 0x00
+        0x6 -> pure 0x00
+        0x7 -> pure 0x00
+        0x8 -> pure 0x00
+        0x9 -> pure 0x00
+        0xa -> pure 0x00
+        0xb -> pure 0x00
+        _ -> throwM $ VideoError $ mconcat
+          [ "address out of bounds for LCD: "
+          , pretty $ Addr a
+          ]
+  }
diff --git a/fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs b/fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs
new file mode 100644
index 0000000..694f2ea
--- /dev/null
+++ b/fig-emulator-gb/src/Fig/Emulator/GB/Utils.hs
@@ -0,0 +1,66 @@
+module Fig.Emulator.GB.Utils where
+
+import Fig.Prelude
+
+import Prelude (fromIntegral)
+
+import Data.Word (Word8, Word16)
+import Data.Int (Int8)
+import Data.Bits
+
+w8w8 :: Word8 -> Word8 -> Word16
+w8w8 high low = shiftL (fromIntegral high) 8 .|. fromIntegral low
+
+w16hi :: Word16 -> Word8
+w16hi v = fromIntegral $ shiftR v 8
+
+w16lo :: Word16 -> Word8
+w16lo v = fromIntegral $ v .&. 0xff
+
+w8bit :: Int -> Word8 -> Bool
+w8bit i v = shiftR v i .&. 0b1 == 1
+
+w8bits2 :: Int -> Word8 -> Word8
+w8bits2 i v = shiftR v (i - 1) .&. 0b11
+
+w8bits3 :: Int -> Word8 -> Word8
+w8bits3 i v = shiftR v (i - 2) .&. 0b111
+
+w8bits4 :: Int -> Word8 -> Word8
+w8bits4 i v = shiftR v (i - 3) .&. 0b1111
+
+flagsw8 :: Bool -> Bool -> Bool -> Bool -> Word8
+flagsw8 z n h c =
+  shiftL (if z then 1 else 0) 7
+  .|. shiftL (if n then 1 else 0) 6
+  .|. shiftL (if h then 1 else 0) 5
+  .|. shiftL (if c then 1 else 0) 4
+
+zext :: Word8 -> Word16
+zext = fromIntegral
+
+sext :: Word8 -> Word16
+sext x = fromIntegral y
+  where
+    y :: Int8
+    y = fromIntegral x
+
+trunc :: Word16 -> Word8
+trunc = fromIntegral
+
+addC :: Bool -> Word8 -> Word8 -> (Word8, Bool)
+addC c x y = (trunc res, shiftR res 8 .&. 1 == 1)
+  where
+    res :: Word16
+    res = sext x + sext y + if c then 1 else 0
+
+addH :: Bool -> Word8 -> Word8 -> Bool
+addH c x y = shiftR res 4 .&. 1 == 1
+  where
+    xlo = x .&. 0xf
+    ylo = y .&. 0xf
+    res :: Word8
+    res = xlo + ylo + if c then 1 else 0
+
+subH :: Word8 -> Word8 -> Bool
+subH x y = w8bits4 3 x < w8bits4 3 y
-- 
cgit v1.2.3