NES CHR-ROM pattern table renderer

NES0A.hs

-- output PGM (greyscale) image representation of NES CHR-ROM pattern tables
-- usage: NES0A smb.nes [bank to use, default 0]
-- This represents my first attempt at Haskell, please forgive me.

module Main where

import qualified Data.ByteString.Lazy as BL
import Data.Binary.Get
import Data.Bits
import Data.Word
import qualified System.Environment as Env

data NESHeader = NESHeader
  { prgrom_size  :: Int
  , chrrom_size  :: Int
  } deriving (Show)

getHeader :: Get (Maybe NESHeader)
getHeader = do
  head <- getWord32be
  if (head /= 0x4E45531A)
    then return Nothing
    else do
      prgrom_pages <- getWord8
      chrrom_pages <- getWord8
      return (Just NESHeader
        { prgrom_size = 16 * 1024 * fromIntegral prgrom_pages
        , chrrom_size =  8 * 1024 * fromIntegral chrrom_pages
        })

getChrrom :: NESHeader -> Get BL.ByteString
getChrrom header = do
  skip (prgrom_size header + 16)
  getLazyByteString (fromIntegral (chrrom_size header))

chrromBankToPGM :: BL.ByteString -> String
chrromBankToPGM bytes =
  let tiles = renderChr bytes
      width = 16 * 9 * 2; height = 16 * 9 * 2 in
        ("P2 " ++ (show width) ++ " " ++ (show height) ++ " 3\n") ++
        showRows tiles [0,16..240] ""

renderChr :: BL.ByteString -> [[[Word8]]]
renderChr bytes =
  if BL.null bytes then []
  else let
    (thisTile, rest) = BL.splitAt 16 bytes
    (b0, b1) = BL.splitAt 8 thisTile in
    renderChrTile (BL.zip b0 b1) : renderChr rest

-- render 8x8 tiles to 9x9 with 1 pixel border on the right and bottom
renderChrTile :: [(Word8,Word8)] -> [[Word8]]
renderChrTile pairs =
  (replicate 9 3) : [ [ renderChrRow b0 b1 i | i <- [8,7..0] ] | (b0, b1) <- pairs ]

renderChrRow :: Word8 -> Word8 -> Int -> Word8
renderChrRow b0 b1 i =
  let color = (b0 `shiftR`   i  .&. 1) .|.
              (b1 `shift` (1-i) .&. 2) in
  3 - color


showRows :: [[[Word8]]] -> [Int] -> String -> String
showRows tiles rows =
  case rows of
    []        -> id
    this:rest ->
      foldr (\local_row ffs -> (showRowOfTileRows tiles this local_row) . ffs ) (showRows tiles rest) (concat [ [x,x] | x <- [0..8] ])

showRowOfTileRows :: [[[Word8]]] -> Int -> Int -> String -> String
showRowOfTileRows tiles first_tile local_row =
  foldr (\tile_idx fs -> (showTileRow (tiles !! tile_idx !! local_row)) . ('\t':) . fs) ('\n':) [first_tile..first_tile+15]

showTileRow :: [Word8] -> String -> String
showTileRow row =
  foldr (\pix fs -> (shows pix) . (' ':) . (shows pix) . (' ':) . fs) id row

main :: IO ()
main = do
  args <- Env.getArgs
  input <- BL.readFile (args !! 0)
  bank <- if null $ tail args then
    return 0
  else
    return (read (args !! 1))
  case runGet getHeader input of
    Just header -> do
      let chrrom_contents = runGet (getChrrom header) input in
        putStr $ chrromBankToPGM (BL.take (16*256) $ BL.drop (bank*16*256) chrrom_contents)
    Nothing -> return ()