tools/replay2hwd.hs
changeset 15499 e0ab70a90718
--- /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 <hash> ", 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))