author | sheepluva |
Tue, 22 Jun 2021 22:13:55 +0200 | |
changeset 15824 | d5c37e78ab83 |
parent 15499 | e0ab70a90718 |
permissions | -rw-r--r-- |
{-# 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))