diff -r 20066da10268 -r e0ab70a90718 tools/replay2hwd.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tools/replay2hwd.hs Sat Oct 12 23:13:32 2019 +0200 @@ -0,0 +1,237 @@ +{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} + +import qualified Data.ByteString.Char8 as B +import Control.Exception as E +import System.Environment +import Control.Monad +import qualified Data.Map as Map +import Data.Word +import Data.Int +import qualified Codec.Binary.Base64 as Base64 +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString as BW +import qualified Codec.Compression.Zlib.Internal as ZI +import qualified Codec.Compression.Zlib as Z +import qualified Data.List as L +import qualified Data.Set as Set +import Data.Binary +import Data.Binary.Put +import Data.Bits +import Control.Arrow +import Data.Maybe +import qualified Data.Either as Ei + + +decompressWithoutExceptions :: BL.ByteString -> BL.ByteString +decompressWithoutExceptions = BL.fromChunks . ZI.foldDecompressStreamWithInput chunk end err decomp + where + decomp = ZI.decompressST ZI.zlibFormat ZI.defaultDecompressParams + chunk = (:) + end _ = [] + err = const $ [BW.empty] + +data HedgehogInfo = + HedgehogInfo B.ByteString B.ByteString + deriving (Show, Read) + +data TeamInfo = + TeamInfo + { + teamowner :: !B.ByteString, + teamname :: !B.ByteString, + teamcolor :: !B.ByteString, + teamgrave :: !B.ByteString, + teamfort :: !B.ByteString, + teamvoicepack :: !B.ByteString, + teamflag :: !B.ByteString, + isOwnerRegistered :: !Bool, + difficulty :: !Int, + hhnum :: !Int, + hedgehogs :: ![HedgehogInfo] + } + deriving (Show, Read) + +readInt_ :: (Num a) => B.ByteString -> a +readInt_ str = + case B.readInt str of + Just (i, t) | B.null t -> fromIntegral i + _ -> 0 + +toEngineMsg :: B.ByteString -> B.ByteString +toEngineMsg msg = fromIntegral (BW.length msg) `BW.cons` msg + +em :: B.ByteString -> B.ByteString +em = toEngineMsg + +eml :: [B.ByteString] -> B.ByteString +eml = em . B.concat + +showB :: (Show a) => a -> B.ByteString +showB = B.pack . show + +replayToDemo :: [TeamInfo] + -> Map.Map B.ByteString B.ByteString + -> Map.Map B.ByteString [B.ByteString] + -> [B.ByteString] + -> B.ByteString +replayToDemo ti mParams prms msgs = if not sane then "" else (B.concat $ concat [ + [em "TD"] + , maybeScript + , maybeMap + , [eml ["etheme ", head $ prms Map.! "THEME"]] + , [eml ["eseed ", mParams Map.! "SEED"]] + , [eml ["e$gmflags ", showB gameFlags]] + , schemeFlags + , schemeAdditional + , [eml ["e$template_filter ", mParams Map.! "TEMPLATE"]] + , [eml ["e$feature_size ", mParams Map.! "FEATURE_SIZE"]] + , [eml ["e$mapgen ", mapgen]] + , mapgenSpecific + , concatMap teamSetup ti + , map (Ei.fromRight "" . Base64.decode) $ reverse msgs + , [em "!"] + ]) + where + keys1, keys2 :: Set.Set B.ByteString + keys1 = Set.fromList ["FEATURE_SIZE", "MAP", "MAPGEN", "MAZE_SIZE", "SEED", "TEMPLATE"] + keys2 = Set.fromList ["AMMO", "SCHEME", "SCRIPT", "THEME"] + sane = Set.null (keys1 Set.\\ Map.keysSet mParams) + && Set.null (keys2 Set.\\ Map.keysSet prms) + && (not . null . drop 41 $ scheme) + && (not . null . tail $ prms Map.! "AMMO") + && ((B.length . head . tail $ prms Map.! "AMMO") > 200) + mapGenTypes = ["+rnd+", "+maze+", "+drawn+", "+perlin+"] + scriptName = head . fromMaybe ["Normal"] $ Map.lookup "SCRIPT" prms + maybeScript = let s = scriptName in if s == "Normal" then [] else [eml ["escript Scripts/Multiplayer/", spaces2Underlining s, ".lua"]] + maybeMap = let m = mParams Map.! "MAP" in if m `elem` mapGenTypes then [] else [eml ["emap ", m]] + scheme = tail $ prms Map.! "SCHEME" + mapgen = mParams Map.! "MAPGEN" + mazeSizeMsg = eml ["e$maze_size ", mParams Map.! "MAZE_SIZE"] + mapgenSpecific = case mapgen of + "1" -> [mazeSizeMsg] + "2" -> [mazeSizeMsg] + "3" -> let d = head . fromMaybe [""] $ Map.lookup "DRAWNMAP" prms in if BW.length d <= 4 then [] else drawnMapData d + _ -> [] + gameFlags :: Word32 + gameFlags = foldl (\r (b, f) -> if b == "false" then r else r .|. f) 0 $ zip scheme gameFlagConsts + schemeFlags = map (\(v, (n, m)) -> eml [n, " ", showB $ (readInt_ v) * m]) + $ filter (\(_, (n, _)) -> not $ B.null n) + $ zip (drop (length gameFlagConsts) scheme) schemeParams + schemeAdditional = let scriptParam = B.tail $ scheme !! 42 in [eml ["e$scriptparam ", scriptParam] | not $ B.null scriptParam] + ammoStr :: B.ByteString + ammoStr = head . tail $ prms Map.! "AMMO" + ammo = let l = B.length ammoStr `div` 4; ((a, b), (c, d)) = (B.splitAt l . fst &&& B.splitAt l . snd) . B.splitAt (l * 2) $ ammoStr in + (map (\(x, y) -> eml [x, " ", y]) $ zip ["eammloadt", "eammprob", "eammdelay", "eammreinf"] [a, b, c, d]) + ++ [em "eammstore" | scheme !! 14 == "true" || scheme !! 20 == "false"] + initHealth = scheme !! 27 + teamSetup :: TeamInfo -> [B.ByteString] + teamSetup t = (++) ammo $ + eml ["eaddteam ", showB $ (1 + (readInt_ $ teamcolor t) :: Int) * 2113696, " ", teamname t] + : em "erdriven" + : eml ["efort ", teamfort t] + : take (2 * hhnum t) ( + concatMap (\(HedgehogInfo hname hhat) -> [ + eml ["eaddhh ", showB $ difficulty t, " ", initHealth, " ", hname] + , eml ["ehat ", hhat] + ]) + $ hedgehogs t + ) + infRopes = ammoStr `B.index` 7 == '9' + vamp = gameFlags .&. 0x00000200 /= 0 + infattacks = gameFlags .&. 0x00100000 /= 0 + spaces2Underlining = B.map (\c -> if c == ' ' then '_' else c) + +drawnMapData :: B.ByteString -> [B.ByteString] +drawnMapData = + L.map (\m -> eml ["edraw ", BW.pack m]) + . L.unfoldr by200 + . BL.unpack + . unpackDrawnMap + where + by200 :: [a] -> Maybe ([a], [a]) + by200 [] = Nothing + by200 m = Just $ L.splitAt 200 m + +unpackDrawnMap :: B.ByteString -> BL.ByteString +unpackDrawnMap = either + (const BL.empty) + (decompressWithoutExceptions . BL.pack . drop 4 . BW.unpack) + . Base64.decode + +compressWithLength :: BL.ByteString -> BL.ByteString +compressWithLength b = BL.drop 8 . encode . runPut $ do + put $ ((fromIntegral $ BL.length b)::Word32) + mapM_ putWord8 $ BW.unpack $ BL.toStrict $ Z.compress b + +packDrawnMap :: BL.ByteString -> B.ByteString +packDrawnMap = + Base64.encode + . BL.toStrict + . compressWithLength + +prependGhostPoints :: [(Int16, Int16)] -> B.ByteString -> B.ByteString +prependGhostPoints pts dm = packDrawnMap $ (runPut $ forM_ pts $ \(x, y) -> put x >> put y >> putWord8 99) `BL.append` unpackDrawnMap dm + +schemeParams :: [(B.ByteString, Int)] +schemeParams = [ + ("e$damagepct", 1) + , ("e$turntime", 1000) + , ("", 0) + , ("e$sd_turns", 1) + , ("e$casefreq", 1) + , ("e$minestime", 1000) + , ("e$minesnum", 1) + , ("e$minedudpct", 1) + , ("e$explosives", 1) + , ("e$airmines", 1) + , ("e$healthprob", 1) + , ("e$hcaseamount", 1) + , ("e$waterrise", 1) + , ("e$healthdec", 1) + , ("e$ropepct", 1) + , ("e$getawaytime", 1) + , ("e$worldedge", 1) + ] + + +gameFlagConsts :: [Word32] +gameFlagConsts = [ + 0x00001000 + , 0x00000010 + , 0x00000004 + , 0x00000008 + , 0x00000020 + , 0x00000040 + , 0x00000080 + , 0x00000100 + , 0x00000200 + , 0x00000400 + , 0x00000800 + , 0x00002000 + , 0x00004000 + , 0x00008000 + , 0x00010000 + , 0x00020000 + , 0x00040000 + , 0x00080000 + , 0x00100000 + , 0x00200000 + , 0x00400000 + , 0x00800000 + , 0x01000000 + , 0x02000000 + , 0x04000000 + ] + +loadReplay :: String -> IO (Maybe ([TeamInfo], [(B.ByteString, B.ByteString)], [(B.ByteString, [B.ByteString])], [B.ByteString])) +loadReplay fileName = E.handle (\(e :: SomeException) -> return Nothing) $ do + liftM (Just . read) $ readFile fileName + +convert :: String -> IO () +convert fileName = do + Just (t, c1, c2, m) <- loadReplay fileName + B.writeFile (fileName ++ ".hwd") $ replayToDemo t (Map.fromList c1) (Map.fromList c2) m + +main = do + args <- getArgs + when (length args == 1) $ (convert (head args))