-- Copyright 2006 mutantlemon.com

module Machine where

import Data.Array.IArray
import Data.Word
import Data.Bits

import WordUtil
import Cpu
import CpuExecution
import Memory

import Debug.Trace

--cpuClockFrequency :: Double
--cpuClockFrequency = 4194304

--horizSync :: Double
--horizSync = 9198000

--vertSync :: Double
--vertSync = 59.73

--vblankPeriod = cpuClockFrequency / vertSync

--scanlinePeriod = vblankPeriod / 153

type RegisterStates = (Word8,  -- A
                       Word8,  -- B
                       Word8,  -- C
                       Word8,  -- D
                       Word8,  -- E
                       Word8,  -- F
                       Word8,  -- H
                       Word8,  -- L
                       Word16, -- PC
                       Word16) -- SP

getRegState :: RegisterStates -> M_Register -> Word8
getRegState rs r =
  let (a, b, c, d, e, f, h, l, _, _) = rs in
  case r of
    M_A -> a
    M_B -> b
    M_C -> c
    M_D -> d
    M_E -> e
    M_F -> f
    M_H -> h
    M_L -> l

setRegState :: RegisterStates -> M_Register -> Word8 -> RegisterStates
setRegState rs r n =
  let (a, b, c, d, e, f, h, l, pc, sp) = rs in
  case r of
    M_A -> (n, b, c, d, e, f, h, l, pc, sp)
    M_B -> (a, n, c, d, e, f, h, l, pc, sp)
    M_C -> (a, b, n, d, e, f, h, l, pc, sp)
    M_D -> (a, b, c, n, e, f, h, l, pc, sp)
    M_E -> (a, b, c, d, n, f, h, l, pc, sp)
    M_F -> (a, b, c, d, e, n.&.0xF0, h, l, pc, sp)
    M_H -> (a, b, c, d, e, f, n, l, pc, sp)
    M_L -> (a, b, c, d, e, f, h, n, pc, sp)

getReg2State :: RegisterStates -> M_Register2 -> Word16
getReg2State rs r2 =
  let (a, b, c, d, e, f, h, l, pc, sp) = rs in
  case r2 of
    M_AF -> joinWord16 a f
    M_BC -> joinWord16 b c
    M_DE -> joinWord16 d e
    M_HL -> joinWord16 h l
    M_PC -> pc
    M_SP -> sp

setReg2State :: RegisterStates -> M_Register2 -> Word16 -> RegisterStates
setReg2State rs r2 nn =
  let (a, b, c, d, e, f, h, l, pc, sp) = rs
      (hi, lo) = splitWord16 nn in
  case r2 of
    M_AF -> (hi, b, c, d, e, lo.&.0xF0, h, l, pc, sp)
    M_BC -> (a, hi, lo, d, e, f, h, l, pc, sp)
    M_DE -> (a, b, c, hi, lo, f, h, l, pc, sp)
    M_HL -> (a, b, c, d, e, f, hi, lo, pc, sp)
    M_PC -> (a, b, c, d, e, f, h, l, nn, sp)
    M_SP -> (a, b, c, d, e, f, h, l, pc, nn)

initialA_GB, initialA_GBP, initialA_GBC :: Word8
initialA_GB  = 0x01
initialA_GBP = 0xFF
initialA_GBC = 0x11

initialRegisterStates :: RegisterStates
initialRegisterStates =
  (initialA_GB, -- A
  0x00,         -- B
  0x13,         -- C
  0x00,         -- D
  0xD8,         -- E
  0xB0,         -- F
  0x01,         -- H
  0x4D,         -- L
  0x0100,       -- PC
  0xFFFE)       -- SP

hBlankPeriod = 456

data IrqStates = IrqStates {
  irqStateIME :: Bool,         -- Interrupt Master Enable
  irqStateHBlankCounter :: Int -- CPU cycles until next hblank
}

initialIrqStates = IrqStates {
  irqStateIME = False,
  irqStateHBlankCounter = hBlankPeriod
}

irqUpdate :: IrqStates ->
             CycleCount ->
             Maybe Bool ->
             (IrqStates,
              (RegisterStates, Memory) -> (RegisterStates, Memory))
irqUpdate is c ime =
  let is' = is {
        irqStateHBlankCounter = (irqStateHBlankCounter is)-c,
        irqStateIME = case ime of
                        Just b -> b
                        Nothing -> irqStateIME is
               } in
  if irqStateHBlankCounter is' <= 0
  then (is' { irqStateHBlankCounter = (irqStateHBlankCounter is')+hBlankPeriod },
        \(r, m) -> let oldLY = (memRam m)!0xFF44
                       newLY = incWrap 153 oldLY in
                   (r, m { memRam = (memRam m)//[(0xFF44, newLY)] })
       )
  else (is', id)
  where incWrap limit n = if (n+1) > limit then 0 else n+1

machineCpuExecute :: (MemoryModel m) =>
                 (RegisterStates, m) ->
                 ExecutionAST () ->
                 (RegisterStates, m)
machineCpuExecute s e = fst (machineCpuExecute' s e)

machineCpuExecute' :: (MemoryModel m) =>
                  (RegisterStates, m) ->
                  ExecutionAST a ->
                  ((RegisterStates, m), a)
machineCpuExecute' state@(regS, memS) e = case e of
  Return result -> (state, result)
  Bind l r -> let (s, result) = machineCpuExecute' state l in
              machineCpuExecute' s (r result)
  WriteRegister reg n -> ((setRegState regS reg n, memS), ())
  ReadRegister reg -> (state, getRegState regS reg)
  WriteRegister2 reg2 nn -> ((setReg2State regS reg2 nn, memS), ())
  ReadRegister2 reg2 -> (state, getReg2State regS reg2)
  WriteMemory a n -> ((regS, writeMem memS a n), ())
  ReadMemory a -> (state, readMem memS a)

fetchInstruction :: (MemoryModel m) => (RegisterStates, m) -> Instruction
fetchInstruction (regS, memS) =
  let pc = getReg2State regS M_PC
      opcode = readMem memS pc
      n :: Word8
      n = readMem memS (pc+1)
      nn :: Word16
      nn = joinWord16 (readMem memS (pc+2)) (readMem memS (pc+1))
      instruction = machineCodeToInstruction opcode (n, nn) in
  instruction

machineStepInstruction :: (MemoryModel m) =>
                          (RegisterStates, m) ->
                          (RegisterStates, m)
machineStepInstruction state@(regS, memS) =
  let instruction = fetchInstruction state
      execution = executeInstruction instruction in
  machineCpuExecute state execution

updateMachine :: ((RegisterStates, Memory), IrqStates) ->
                 ((RegisterStates, Memory), IrqStates)
updateMachine (state@(regS, memS), irqS) =
  let stepInstruction = machineStepInstruction state
      pc = getReg2State regS M_PC
      opcode = readMem memS pc
      cycles = opcodeCycleCount opcode
      ime = opcodeQueryIME opcode
      (irqS', interrupt) = irqUpdate irqS cycles ime in
  (interrupt stepInstruction, irqS')