celestemap.hs

import Data.Binary.Get
import qualified Data.ByteString.Lazy as BSS
import Data.Bits (Bits((.|.), (.&.), shiftL))

import Data.Text.Encoding (decodeUtf8)
import Data.Text (unpack)

import qualified Data.Map as M
import Data.Char (chr)

import Control.Monad (join)

import Debug.Trace (trace)

data BValue
    = BInt Int
    | BFloat Float
    | BBool Bool
    | BString String
    | BNull
    deriving (Eq, Show)

data BElement = BElement {
    name :: String,
    children :: [BElement],
    attrs :: M.Map String BValue
} deriving (Eq, Show)

data BMap = BMap {
    header :: String,
    package :: String,
    dat :: BElement
} deriving (Eq, Show)

type Lookup = [String]

parseMap :: Get BMap
parseMap = do
    header <- parseString
    package <- parseString
    lookup <- parseLookupTable
    dat <- parseElement lookup
    return BMap { header, package, dat }

parseElement :: Lookup -> Get BElement
parseElement lk = do
    nameIdx <- getInt16le
    let name = lk !! fromIntegral nameIdx
    attrCount <- getInt8
    attrs <- rep (fromIntegral attrCount) (parseValue lk)
    childrenCount <- getInt16le
    children <- rep (fromIntegral childrenCount) (parseElement lk)
    return BElement { name, attrs = M.fromAscList attrs, children }

parseValue :: Lookup -> Get (String, BValue)
parseValue lk = do
    nameIdx <- getInt16le
    let name = lk !! fromIntegral nameIdx
    typeId <- getInt8
    value :: BValue <- case typeId of
        0 -> do
            b <- getInt8
            return $ BBool $ b > 0
        1 -> BInt . fromIntegral <$> getInt8
        2 -> BInt . fromIntegral <$> getInt16le
        3 -> BInt . fromIntegral <$> getInt32le
        4 -> BFloat <$> getFloatle
        5 -> do
            idx <- getInt16le
            return $ BString $ lk !! fromIntegral idx
        6 -> BString <$> parseString
        7 -> BString <$> parseRleString
        _ -> return BNull
    return (name, value)

parseLookupTable :: Get Lookup
parseLookupTable = do
    len <- getInt16le
    rep (fromIntegral len) parseString

parseRleString :: Get String
parseRleString = do
    len <- getInt16le
    parts <- rep (fromIntegral len `div` 2) parsePart
    return $ join parts
      where
        parsePart :: Get String
        parsePart = do
            len <- getInt8
            ch <- getInt8
            return $ replicate (fromIntegral len) (chr $ fromIntegral ch)

parseString :: Get String
parseString = do
    len <- parseVarInt
    bytes <- getByteString len
    return $ Data.Text.unpack (Data.Text.Encoding.decodeUtf8 bytes)

parseVarInt :: Get Int
parseVarInt = do
    first <- getInt8
    -- if the high bit is unset, return as is
    -- otherwise return ((first & 0b01111111) | next << 7) ?
    if first >= 0 then return (fromIntegral first) else do
        next <- parseVarInt
        return ((fromIntegral first .&. 127) .|. (next `shiftL` 7))

rep :: Monad m => Int -> m a -> m [a]
rep 0 _ = return []
rep x g = do
    v <- g
    rst <- rep (x - 1) g
    return $ v : rst

main :: IO ()
main = do
    dat2 :: BSS.ByteString <- BSS.readFile "./tempotemple.bin"
    let u = runGet parseMap dat2
    print u