compressor.hs

   1 import Text.ParserCombinators.Parsec
   2 import System.Environment
   3 import Control.Concurrent
   4 import Control.Monad
   5 import System.FilePath
   6 import System.IO
   7 import qualified Data.Set as S
   8 import qualified Data.Map as M
   9 import Data.Map((!))
  10 import Data.Binary
  11 import qualified Data.ByteString.Lazy as B
  12 import Data.Word
  13 import Control.Concurrent.MVar
  14
  15 main = do
  16   files <- getArgs
  17   waiter <- newEmptyMVar
  18   mapM (\f -> forkIO $ compress f >> putMVar waiter ()) files
  19   replicateM (length files) (takeMVar waiter)
  20   where
  21     compress file = do
  22       parsed <- parseFromFile parser file
  23       case parsed of
  24         Left err -> print err
  25         Right tiles -> do
  26           outfile <- openFile (replaceExtension file ".dmp") WriteMode
  27           let flatTiles = concat tiles
  28               munge = M.fromList . flip zip [(1::Word32)..] . S.toList . S.fromList
  29               bytes = log256 (maximum (map M.size [kinds,values]))
  30               kinds = munge $ map fst flatTiles
  31               values = munge $ map snd flatTiles
  32               code num = case bytes of
  33                 1 -> encode (fromIntegral num :: Word8)
  34                 2 -> encode (fromIntegral num :: Word16)
  35                 _ -> encode num
  36           mapM_ (hPutStrLn outfile . show) [kinds,values]
  37           forM_ tiles $ \tile -> do
  38             forM_ tile $ \(kind,value) -> do
  39               B.hPut outfile $ code $ kinds ! kind
  40               B.hPut outfile $ code $ kinds ! kind
  41             B.hPut outfile $ code (0::Word32) -- A single 0 word terminates a tile. Note that the kinds and values are 1-indexed.
  42           hClose outfile
  43
  44
  45
  46 type Tile = [(String,String)]
  47
  48 parser :: Parser [Tile]
  49 parser = many $ (try hidden <|> element) `manyTill` (string "---" >> newline)
  50   where element = do
  51           kind <- anyChar `manyTill` string ": "
  52           value <- anyChar `manyTill` newline
  53           return (kind,value)
  54         hidden = string "Hidden" >> newline >> return ("Hidden","")
  55
  56 log256 0 = 0
  57 log256 n = 1 + log256 (n `div` 256)