Personal tools

Haskell Quiz/Chip Eight/Solution Jethr0

From HaskellWiki

< Haskell Quiz | Chip Eight(Difference between revisions)
Jump to: navigation, search
m
 
m (added a few comments)
 
(One intermediate revision by one user not shown)
Line 1: Line 1:
 
[[Category:Haskell Quiz solutions|Chip Eight]]
 
[[Category:Haskell Quiz solutions|Chip Eight]]
  
As vincenz pointed out in one of my other solutions, I'm probably using State too heavily now that I've (hopefully) figured out how to use it ;)
+
Interpreter isn't fully tested, but the sample program seems to be "running" correctly.
 
+
At the moment the <hask>eval</hask> function could be written in pure fashion and maybe I'll do that refactoring some time. Interpreter isn't fully tested, but the sample program seems to be "running" correctly
+
  
 
<haskell>
 
<haskell>
Line 46: Line 44:
 
---
 
---
  
modify_rv      func = modify (\st -> st{rv      = func . rv      $ st})
+
modify_rv      func st = st{rv      = func . rv      $ st}
modify_rip    func = modify (\st -> st{rip    = func . rip    $ st})
+
modify_rip    func st = st{rip    = func . rip    $ st}
modify_rmemory func = modify (\st -> st{rmemory = func . rmemory $ st})
+
modify_rmemory func st = st{rmemory = func . rmemory $ st}
getReg x    = do {MachineState{rv = regs} <- get; return $ regs!x}
+
getReg x    st = let MachineState{rv = regs} = st in regs!x
setReg x val = modify_rv (// [(fromIntegral x, val)])
+
setReg x val st = modify_rv (// [(fromIntegral x, val)]) st
  
  
step :: St ()
+
eval :: Word16 -> MachineState -> MachineState
step = do
+
eval instr st = case firstDigit instr of
  MachineState{rip = ip, rmemory = mem} <- get
+
  -- 0x1NNN
  let (i1,i2) = (fromIntegral $ mem ! (fromIntegral ip)
+
   0x1 ->  
                ,fromIntegral $ mem ! (fromIntegral $ ip+1))
+
     modify_rip (const nnn) st
      instr  = (shiftL i1 8) + i2 :: Word16
+
    where nnn = instr .&. 0x0FFF
  case instr of
+
    0x0000    -> return ()
+
    otherwise -> eval instr >> modify_rip (2+) >> step
+
 
+
 
+
eval :: Word16 -> St ()
+
eval instr = case firstDigit instr of
+
   0x1 -> do
+
     let nnn = instr .&. 0x0FFF
+
    modify_rip (const nnn)
+
  
   0x3 -> do
+
  -- 0x3XKK
     let (x, kk) = (bitX, bitKK)
+
   0x3 ->
    vx <- getReg x
+
     if vx == kk  
    when (vx == kk) (modify_rip (2+))
+
      then modify_rip (2+) st
 +
      else st
  
   0x6 -> do
+
  -- 0x6XKK
    let (x, kk) = (bitX, bitKK)
+
   0x6 ->  
     setReg x kk
+
     setReg x kk st
 
      
 
      
   0x7 -> do
+
  -- 0x7XKK
    let (x, kk) = (bitX, bitKK)
+
   0x7 ->  
    vx <- getReg x
+
     rPlus x vx kk st
     rPlus x vx kk
+
  
   0x8 -> do
+
  -- 0x8XY_
     let x = bitX
+
   0x8 ->  
        y = fromIntegral $ shiftR (instr .&. 0x00F0) 4
+
     (case instr .&. 0x000F of  
    vx <- getReg x
+
       0x0 -> setReg  x vy        
    vy <- getReg y
+
       0x1 -> setReg  x (vx .|. vy)
    case (instr .&. 0x000F) of  
+
       0x2 -> setReg  x (vx .&. vy)
       0x0 -> setReg  x $ vy
+
       0x3 -> setReg  x (vx `Bits.xor` vy)
       0x1 -> setReg  x $ vx .|. vy
+
       0x2 -> setReg  x $ vx .&. vy
+
       0x3 -> setReg  x $ vx `Bits.xor` vy
+
 
       0x4 -> rPlus  x vx vy
 
       0x4 -> rPlus  x vx vy
 
       0x5 -> rMinus  x vx vy
 
       0x5 -> rMinus  x vx vy
       0x6 -> rShiftR x vx 1
+
       0x6 -> rShiftR x vx 1  
 
       0x7 -> rMinus  x vy vx
 
       0x7 -> rMinus  x vy vx
 
       0xE -> rShiftL x vx 1
 
       0xE -> rShiftL x vx 1
     where rShiftR target vx n = do
+
    ) st
            setReg 0xF    $ vx .&. 0x01
+
     where = fromIntegral $ shiftR (instr .&. 0x00F0) 4
            setReg target $ shiftR vx n
+
          vy = getReg y st
          rShiftL target vx n = do
+
            setReg 0xF    $ shiftR (vx .&. 0x80) 7 -- FIXME: is this correct
+
            setReg target $ shiftL vx n
+
  
   0xC -> do
+
  -- 0xCXKK
     let (x, kk) = (bitX, bitKK)
+
   0xC ->  
    r <- rRandom
+
     setReg x (r .&. kk) st'
    setReg x $ r .&. kk
+
    where (r, st') = rRandom st
  
 
   otherwise ->  
 
   otherwise ->  
 
     error $ "opcode not implemented " ++ showHex instr ""
 
     error $ "opcode not implemented " ++ showHex instr ""
 
      
 
      
   where bitX = fromIntegral $ shiftR (instr .&. 0x0F00) 8
+
   where x = fromIntegral $ shiftR (instr .&. 0x0F00) 8
         bitKK = fromIntegral $ instr .&. 0x00FF
+
         vx = getReg x st
 
+
        kk = fromIntegral $ instr .&. 0x00FF
 +
        (>.>) = flip ($)
 +
       
 
         firstDigit w = fromIntegral $ shiftR w 12
 
         firstDigit w = fromIntegral $ shiftR w 12
  
         rRandom = do
+
         rRandom s = (fromIntegral r, s{rand = gen})
           state@MachineState{rand = gen} <- get
+
           where MachineState{rand = gen} = s
          let (r, gen') = randomR (0, 2^8-1) gen
+
                (r, gen') = randomR (0, 2^8-1) gen
          put state{rand = gen'}
+
          return $ fromIntegral r
+
  
        rPlus :: Integral i => i -> Word8 -> Word8 -> St ()
+
         rPlus target a b s =
         rPlus target a b = do
+
           s
           let sum = (fromIntegral a) + (fromIntegral b) :: Integer
+
           >.> setReg 0xF   (if sum >= 2^8 then 1 else 0)
           setReg 0xF $ if sum >= 2^8 then 1 else 0
+
           >.> setReg target ((fromIntegral sum) .&. 0x00FF)
           setReg target $ (fromIntegral sum) .&. 0x00FF
+
          where sum = (fromIntegral a) + (fromIntegral b) :: Integer
  
        rMinus :: Integral i => i -> Word8 -> Word8 -> St ()
+
         rMinus target a b s =
         rMinus target a b = do
+
           s
           let sum = (fromIntegral a) - (fromIntegral b) :: Integer
+
           >.> setReg 0xF (if (sum < 0) then 0 else 1)
           setReg 0xF $ if (sum < 0) then 0 else 1
+
           >.> setReg target (fromIntegral (if (sum < 0) then (sum + 2^8)  
           setReg target . fromIntegral $ if (sum < 0) then (sum + 2^8) else sum
+
                                                        else sum))
 +
          where sum = (fromIntegral a) - (fromIntegral b) :: Integer
 
    
 
    
 +
        rShiftR target vx n s =
 +
          s
 +
          >.> setReg 0xF    (vx .&. 0x01)
 +
          >.> setReg target (shiftR vx n)
 +
 +
        rShiftL target vx n s =
 +
          s
 +
          >.> setReg 0xF    (shiftR (vx .&. 0x80) 7) -- FIXME: is this correct
 +
          >.> setReg target (shiftL vx n)
  
 
---
 
---
Line 157: Line 149:
 
modifyRegisters pairs state =  
 
modifyRegisters pairs state =  
 
   state{rv = rv state // pairs}
 
   state{rv = rv state // pairs}
 +
 +
 +
step :: St ()
 +
step = do
 +
  MachineState{rip = ip, rmemory = mem} <- get
 +
  let (i1,i2) = (fromIntegral $ mem ! (fromIntegral ip)
 +
                ,fromIntegral $ mem ! (fromIntegral $ ip+1))
 +
      instr  = (shiftL i1 8) + i2 :: Word16
 +
  case instr of
 +
    0x0000    -> return ()
 +
    otherwise -> do
 +
      modify $ eval instr
 +
      modify $ modify_rip (+2)
 +
      step
 +
  
 
main = do
 
main = do

Latest revision as of 21:51, 15 July 2007


Interpreter isn't fully tested, but the sample program seems to be "running" correctly.

module Main where
 
import qualified Data.Array as Array
import qualified Data.Bits as Bits
import qualified Data.Char as Char
import Data.Word            (Word8, Word16)
import Data.Bits            ((.&.), (.|.), shiftL, shiftR)
import Data.Array           ((!), (//), Array, listArray, accumArray)
import Control.Monad        (when)
import Control.Monad.State  (get, put, modify, liftIO, execStateT, StateT)
import Control.Monad.Identity
import Numeric              (showHex, showIntAtBase)
import Text.Printf          (printf)
import System.Random        (randomR, mkStdGen, StdGen, newStdGen)
 
numRegisters = 16
sizeMemory   = 2^12
 
data MachineState = MachineState {
  rv      :: Array Int Word8,
  rip     :: Word16,
  rmemory :: Array Int Word8,
  rand    :: StdGen
}
 
instance Show MachineState where
  show MachineState {rv = regs, rmemory = mem, rip = ip} =
    unlines showRegs ++ "IP: " ++ (printf "%08x" (fromIntegral ip :: Integer))
    where showRegs  = zipWith (\r v -> r ++ ": " ++ v) regNames regValues
          regNames  = [printf "V%x" (fromIntegral x :: Integer) | x <- [0..]]
          --regValues = [printf "%04x" (fromIntegral x :: Integer) | x <- Array.elems regs]
          regValues = [showIntAtBase 2 Char.intToDigit x "" | x <- Array.elems regs]
 
type StT = StateT MachineState
type St  = StT Identity
type Offset = Int
 
 
---
 
modify_rv      func st = st{rv      = func . rv      $ st}
modify_rip     func st = st{rip     = func . rip     $ st}
modify_rmemory func st = st{rmemory = func . rmemory $ st}
getReg x     st = let MachineState{rv = regs} = st in regs!x
setReg x val st = modify_rv (// [(fromIntegral x, val)]) st
 
 
eval :: Word16 -> MachineState -> MachineState
eval instr st = case firstDigit instr of
  -- 0x1NNN
  0x1 -> 
    modify_rip (const nnn) st
    where nnn = instr .&. 0x0FFF
 
  -- 0x3XKK
  0x3 ->
    if vx == kk 
      then modify_rip (2+) st 
      else st
 
  -- 0x6XKK
  0x6 -> 
    setReg x kk st
 
  -- 0x7XKK
  0x7 -> 
    rPlus x vx kk st
 
  -- 0x8XY_
  0x8 -> 
    (case instr .&. 0x000F of 
      0x0 -> setReg  x vy         
      0x1 -> setReg  x (vx .|. vy)
      0x2 -> setReg  x (vx .&. vy)
      0x3 -> setReg  x (vx `Bits.xor` vy)
      0x4 -> rPlus   x vx vy
      0x5 -> rMinus  x vx vy
      0x6 -> rShiftR x vx 1 
      0x7 -> rMinus  x vy vx
      0xE -> rShiftL x vx 1
    ) st
    where y  = fromIntegral $ shiftR (instr .&. 0x00F0) 4
          vy = getReg y st
 
  -- 0xCXKK
  0xC -> 
    setReg x (r .&. kk) st'
    where (r, st') = rRandom st
 
  otherwise -> 
    error $ "opcode not implemented " ++ showHex instr ""
 
  where x  = fromIntegral $ shiftR (instr .&. 0x0F00) 8
        vx = getReg x st
        kk = fromIntegral $ instr .&. 0x00FF
        (>.>) = flip ($)
 
        firstDigit w = fromIntegral $ shiftR w 12
 
        rRandom s = (fromIntegral r, s{rand = gen})
          where MachineState{rand = gen} = s
                (r, gen') = randomR (0, 2^8-1) gen
 
        rPlus target a b s =
          s
          >.> setReg 0xF    (if sum >= 2^8 then 1 else 0)
          >.> setReg target ((fromIntegral sum) .&. 0x00FF)
          where sum = (fromIntegral a) + (fromIntegral b) :: Integer
 
        rMinus target a b s =
          s
          >.> setReg 0xF (if (sum < 0) then 0 else 1)
          >.> setReg target (fromIntegral (if (sum < 0) then (sum + 2^8) 
                                                        else sum))
          where sum = (fromIntegral a) - (fromIntegral b) :: Integer
 
        rShiftR target vx n s = 
          s 
          >.> setReg 0xF    (vx .&. 0x01)
          >.> setReg target (shiftR vx n)
 
        rShiftL target vx n s =
          s
          >.> setReg 0xF    (shiftR (vx .&. 0x80) 7) -- FIXME: is this correct
          >.> setReg target (shiftL vx n)
 
---
 
 
initialState :: StdGen -> MachineState
initialState gen = MachineState {
  rv      = accumArray const 0 (0, numRegisters-1) [],
  rmemory = accumArray const 0 (0, sizeMemory-1)   [],
  rip     = 0,
  rand    = gen
}
 
 
modifyMemory :: Offset -> [Word8] -> MachineState -> MachineState
modifyMemory offset words state = 
  state{rmemory = rmemory state // zip [offset..] words}
 
modifyRegisters :: [(Int, Word8)] -> MachineState -> MachineState
modifyRegisters pairs state = 
  state{rv = rv state // pairs}
 
 
step :: St ()
step = do
  MachineState{rip = ip, rmemory = mem} <- get
  let (i1,i2) = (fromIntegral $ mem ! (fromIntegral ip)
                ,fromIntegral $ mem ! (fromIntegral $ ip+1))
      instr   = (shiftL i1 8) + i2 :: Word16
  case instr of
    0x0000    -> return ()
    otherwise -> do
      modify $ eval instr
      modify $ modify_rip (+2)
      step
 
 
main = do
  g       <- newStdGen
  file    <- readFile "Chip8Test"
  let program = map (fromIntegral . Char.ord) file
      start   = initialState g
      new     = modifyMemory 0 program
              . modifyRegisters []
              $ start
  let res = runIdentity $ execStateT step new
  print res