Cmd.hs

module Cmd where

import Data.Word
import qualified Data.ByteString as B
import Data.Array
import Data.Bits
import Debug.Trace
import Data.List

data State = State { pmem       :: B.ByteString
                   , dmem       :: Array Word8 Word8
                   , pc         :: Word8
                   , ir         :: Word8
                   , ar         :: Word8
                   , acc        :: Word8
                   , c          :: Bool
                   , z          :: Bool
                   , on         :: Bool
                   , dip        :: Word8
                   , futureDip  :: [Word8]
                   , btn        :: Word8
                   , futureBtn  :: [Word8]
                   }

data Cmd = Ldm | Ldi | Sta | Add | Sub | Lsr | Lsl | Inc | ClrM | ClrC | ClrZ
         | Cmp | And | Or  | Not | Jmp | Jeq | Jne | Jcs | Jcr  | Hlt  | Nop 
           deriving (Show, Eq)

-- Type of commands argument.
data CmdArg = NoneArg -- Don't need
            | DmemArg -- Pointer to data-memory (dmem)
            | ValueArg -- direct argument. (value are inline in bonary code)
            | PmemArg -- Pointer to program-memory (pmem)
              deriving Eq

cmd :: [(Word8, Cmd, CmdArg, [(State -> State)])]
cmd = [(0x01, Nop,  NoneArg,  [nop]),                       -- nope
       (0x00, Hlt,  NoneArg,  [hlt]),                       -- halt model
                                                                                                                                 
       (0x02, Ldm,  DmemArg,  [incPC . pmem2AR, dmem2acc]), -- acc = dmem[arg]; c = const; z = (dmem[arg] == 0)
       (0x03, Ldi,  ValueArg, [incPC . pmem2acc]),          -- acc = arg; c = const; z = (arg == 0)
       (0x04, Sta,  DmemArg,  [incPC . pmem2AR, acc2dmem]), -- dmem[arg] = acc

       (0x05, Add,  DmemArg,  [incPC . pmem2AR, sumAcc]),   -- acc + dmem[arg]
       (0x06, Sub,  DmemArg,  [incPC . pmem2AR, subAcc]),   -- acc - dmem[arg]
       (0x07, Lsr,  NoneArg,  [lsrAcc]),                    -- acc >> 1
       (0x08, Lsl,  NoneArg,  [lslAcc]),                    -- acc << 1
       (0x09, Inc,  NoneArg,  [incAcc]),                    -- acc++

       (0x0a, ClrC, NoneArg,  [clrC]),                      -- c = 0
       (0x0b, ClrZ, NoneArg,  [clrZ]),                      -- z = 0
       (0x0c, Cmp,  DmemArg,  [incPC . pmem2AR, cmpAcc]),   -- z = (dmem[arg] == acc); c = (acc < dmem[arg])
                                                                                                                        
       (0x0d, And,  DmemArg,  [incPC . pmem2AR, andAcc]),   -- acc & dmem[arg]
       (0x0e, Or,   DmemArg,  [incPC . pmem2AR, orAcc]),    -- acc | dmem[arg]
       (0x0f, Not,  NoneArg,  [notAcc]),                    -- ~acc
                                                                                                                        
       (0x10, Jmp,  PmemArg,  [pmem2PC]),                   -- pc = pmem[arg]
       (0x13, Jne,  PmemArg,  [when z True  pmem2PC]),      -- z == 1 ? pc = pmem[arg]
       (0x12, Jeq,  PmemArg,  [when z False pmem2PC]),      -- z == 0 ? pc = pmem[arg]
       (0x14, Jcs,  PmemArg,  [when c True  pmem2PC]),      -- c == 1 ? pc = pmem[arg]
       (0x15, Jcr,  PmemArg,  [when c False pmem2PC])       -- c == 0 ? pc = pmem[arg]
      ]

-- getter for cmd
getCommandInfo hex = let Just info = find (\x -> commandHexFromInfo x == hex) cmd in info

commandFlowFromInfo = \(_, _, _, flow) -> flow
commandHexFromInfo = \(hex, _, _, _) -> hex
commandArgFromInfo = \(_, _, arg, _) -> arg
commandSizeFromInfo = \(_, _, _, flow) -> length flow

showBin x = showBin' 8 (x, "")
    where
      showBin' 0 (x, a) = a
      showBin' n (x, a) = showBin' (n - 1) 
                          ((x `div` 2),
                           (if x `mod` 2 == 0 then '0':a else '1':a))


-- memory access
getPmem s = B.index (pmem s) (fromIntegral $ pc s)

getDmem s 
    | (ar s) == 0x00 && null (futureDip s) = s{acc = (dip s)}
    | (ar s) == 0x00 = s{acc = head (futureDip s), futureDip = tail (futureDip s), dip = head (futureDip s)}
    | (ar s) == 0x01 && null (futureBtn s) = s{acc = (btn s)}
    | (ar s) == 0x01 = s{acc = head (futureBtn s), futureBtn = tail (futureBtn s), btn = head (futureBtn s)}
    | otherwise = s{acc = (dmem s) ! fromIntegral (ar s)}

setDmem s value
    | (ar s) == 0x00 = trace ("DIN: " ++ showBin value) s
    | otherwise = s{dmem = (dmem s) // [(fromIntegral $ ar s, value)]}

nextCommand = incPC . pmem2IR

-- micro-commands
pmem2IR   s = s{ir = getPmem s}
incPC     s = s{pc = (pc s) + 1}

pmem2AR   s = s{ar = getPmem s}

dmem2acc  = getDmem

setZ      s = s{z = (acc s) == 0}
pmem2acc  s = s{acc = getPmem s}


acc2dmem s = setDmem s (acc s)

sumAcc    s = s{acc = acc', c = c', z = acc' == 0} 
    where acc' = acc s' + acc s
          c' = (toInteger $ acc s') + (toInteger $ acc s) > 255
          s' = getDmem s

subAcc    s = s{acc = acc', c = c', z = acc' == 0} 
    where acc' = acc s - acc s'
          c' = acc s < acc s'
          s' = getDmem s

cmpAcc    s = s'{c = c', z = z', acc = acc s}
    where z' = acc s == acc s'
          c' = acc s < acc s'
          s' = getDmem s

lsrAcc    s = s{acc = rotateR (acc s) 1}
lslAcc    s = s{acc = rotateL (acc s) 1}
incAcc    s = s{acc = (acc s) + 1, z = f, c = f}
    where f = acc s == 255

andAcc    s = s{acc = acc s .&. (acc $ getDmem s)}
orAcc     s = s{acc = acc s .|. (acc $ getDmem s)}
notAcc    s = s{acc = complement $ acc s}

dmem2PC   s = s'{pc = acc s', acc = acc s}
    where s' = getDmem s
pmem2PC   s = s{pc = getPmem s}

-- "temlate" function for Jeq, Jne, Jcs, Jcr
when :: (State -> Bool) -> Bool -> (State -> State) -> State -> State
when reg value action s | (reg s) == value = action s
                        | otherwise = incPC s

clrC      s = s{c = False}
clrZ      s = s{z = False}

nop       s = s
hlt       s = s{on = False}