{-# 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