Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
146 lines (121 sloc) 5.63 KB
module Main where
import Data.Binary.Get
import Data.Bits
import qualified Data.ByteString.Lazy as Bs
import Data.Int
import Data.List
import Data.Word
import Numeric (showHex)
import System.Environment
import Text.Printf
data RleEntry = Raw Word8
| FillByte {len :: Int, fillByte :: Word8} --standard RLE
| FillWord {len :: Int, fillWord :: Word16}
| InterleaveByte {byte :: Word8, block :: [Word8]} --const hi byte
| InterleaveHi {hiNybble :: Word8, loNybbles :: [Word8]} --const hi nybble
| InterleaveLo {loNybble :: Word8, hiNybbles :: [Word8]} -- const lo nybble
instance Show RleEntry where
show (Raw b) = printf "0x%02X" b
show (FillByte l b) = printf "{FillByte %d 0x%02X}" l b
show (FillWord l w) = printf "{FillWord %d 0x%04X}" l w
show (InterleaveByte b bs) = printf "{InterleaveByte %02X " b ++ listToHex bs ++ "}"
show (InterleaveHi n ns) = printf "{InterleaveHi %02X " n ++ listToHex ns ++ "}"
show (InterleaveLo n ns) = printf "{InterleaveLo %02X " n ++ listToHex ns ++ "}"
listToHex :: [Word8] -> String
listToHex xs = "["++ concatMap (printf "0x%02X,") xs ++ "]"
bitsToNum :: (Num a) => [Bool] -> a
bitsToNum = foldl' (\byte b -> byte*2 + if b then 1 else 0) 0
numToBits :: (Bits a, Num a) => Int -> a -> [Bool] --number with a given bitfield width to bits list
numToBits n b = map (testBit b) [n-1, n-2..0]
getEntries :: Get [RleEntry]
getEntries = do
stopByte <- getWord8 --read stopByte initially
go stopByte
where
go :: Word8 -> Get [RleEntry]
go stop = do
copyByte <- getWord8
if copyByte /= stop
then do --stopByte not reached - raw copy
rest <- go stop
return $ Raw copyByte : rest
else do --it will be RLE code
command <- getWord8
case numToBits 8 command of
(True:True:False:False:False:False:rest) -> return [] --exit
(False:True:count) -> do --fill FF count
rest <- go stop
return $ FillByte (bitsToNum count) 0xFF : rest
(False:False:count) -> do --fill 00 count
rest <- go stop
return $ FillByte (bitsToNum count) 0 : rest
(True:False:count) -> do --fill 00FF count
rest <- go stop
return $ FillWord (bitsToNum count) 0x00FF : rest
(True:True:False:True:count) -> do
fillWord <- getWord16be --RLE word16
rest <- go stop
return $ FillWord (bitsToNum count) fillWord : rest
(True:True:False:False:False:True:rest) -> do
newStopByte <- getWord8 --get new stopByte
go newStopByte
(True:True:False:False:True:count) -> do
let count' = bitsToNum count + 3-- interleave with const hiByte as 0
block <- getLazyByteString count'
rest <- go stop
return $ InterleaveByte 0 (Bs.unpack block) : rest
(True:True:True:False:lNybble) -> do
let lNybble' = bitsToNum lNybble --interleave with const loNybble
byte <- getWord8
let
count = (byte `shiftR` 4) + 7
hNybble = byte .&. 0xF
block <- getLazyByteString $ fromIntegral (count `shiftR` 1)
let nybbles = take (fromIntegral count) $ hNybble : getNybbles block
rest <- go stop
return $ InterleaveLo lNybble' nybbles : rest
(True:True:True:True:hNybble) -> do
let hNybble' = bitsToNum hNybble --interleave with const hiNybble
byte <- getWord8
let
count = (byte `shiftR` 4) + 7
lNybble = byte .&. 0xF
block <- getLazyByteString $ fromIntegral (count `shiftR` 1)
let nybbles = take (fromIntegral count) $ lNybble : getNybbles block
rest <- go stop
return $ InterleaveHi hNybble' nybbles : rest
_ -> error "unknown RLE command"
getNybbles :: Bs.ByteString -> [Word8] --return list of hi-lo nyblles from bytestring
getNybbles bs = concatMap separate $ Bs.unpack bs
where separate x = [x `shiftR` 4, x .&. 0xF]
serializeEntry :: RleEntry -> [Word8]
serializeEntry (Raw x) = [x]
serializeEntry (FillByte len val) = replicate len val
serializeEntry (FillWord len val) = map fromIntegral $ concat $ replicate len [val `shiftR` 8, val .&. 0xFF]
serializeEntry (InterleaveByte val block) = concatMap (\x -> [val, x]) block
serializeEntry (InterleaveHi hNyb lNybs) = map (\lo -> (hNyb `shiftL` 4) .|. lo) lNybs
serializeEntry (InterleaveLo lNyb hNybs) = map (\hi -> (hi `shiftL` 4) .|. lNyb) hNybs
main :: IO ()
main = getArgs >>= parse
where
parse ["-v"] = putStrLn "gbc2Tga tool 0.1"
parse [name, offset] = go name offset
parse _ = putStrLn "Provide one ROM name and one data offset"
go name offsetStr = do
rom <- Bs.readFile name
let
gfxOffset = read offsetStr
entriesResult = runGetOrFail getEntries $ Bs.drop gfxOffset rom
case entriesResult of
Left (_, _, err) -> putStrLn err
Right (_, readCount, entries) -> do
let
out = concatMap serializeEntry entries
outLen = length out
compressRatio :: Float
compressRatio = fromIntegral outLen / fromIntegral readCount
putStrLn $ printf "Compressed block 0x%X - 0x%X (0x%X bytes)\n"
gfxOffset (gfxOffset + readCount - 1) readCount
putStrLn $ printf "Decompressed size 0x%X, compression raito %g\n"
outLen compressRatio
Bs.writeFile "decoded.bin" $ Bs.pack out
You can’t perform that action at this time.