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

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

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

updateMachine' :: (MemoryModel m) =>
                  (RegisterStates, m) ->
                  ExecutionAST a ->
                  ((RegisterStates, m), a)
updateMachine' state@(regS, memS) e = case e of
  Return result -> (state, result)
  Bind l r -> let (s, result) = updateMachine' state l in
              updateMachine' 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

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