|
1 {-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} |
|
2 |
|
3 import qualified Data.ByteString.Char8 as B |
|
4 import Control.Exception as E |
|
5 import System.Environment |
|
6 import Control.Monad |
|
7 import qualified Data.Map as Map |
|
8 import Data.Word |
|
9 import Data.Int |
|
10 import qualified Codec.Binary.Base64 as Base64 |
|
11 import qualified Data.ByteString.Lazy as BL |
|
12 import qualified Data.ByteString as BW |
|
13 import qualified Codec.Compression.Zlib.Internal as ZI |
|
14 import qualified Codec.Compression.Zlib as Z |
|
15 import qualified Data.List as L |
|
16 import qualified Data.Set as Set |
|
17 import Data.Binary |
|
18 import Data.Binary.Put |
|
19 import Data.Bits |
|
20 import Control.Arrow |
|
21 import Data.Maybe |
|
22 import qualified Data.Either as Ei |
|
23 |
|
24 |
|
25 decompressWithoutExceptions :: BL.ByteString -> BL.ByteString |
|
26 decompressWithoutExceptions = BL.fromChunks . ZI.foldDecompressStreamWithInput chunk end err decomp |
|
27 where |
|
28 decomp = ZI.decompressST ZI.zlibFormat ZI.defaultDecompressParams |
|
29 chunk = (:) |
|
30 end _ = [] |
|
31 err = const $ [BW.empty] |
|
32 |
|
33 data HedgehogInfo = |
|
34 HedgehogInfo B.ByteString B.ByteString |
|
35 deriving (Show, Read) |
|
36 |
|
37 data TeamInfo = |
|
38 TeamInfo |
|
39 { |
|
40 teamowner :: !B.ByteString, |
|
41 teamname :: !B.ByteString, |
|
42 teamcolor :: !B.ByteString, |
|
43 teamgrave :: !B.ByteString, |
|
44 teamfort :: !B.ByteString, |
|
45 teamvoicepack :: !B.ByteString, |
|
46 teamflag :: !B.ByteString, |
|
47 isOwnerRegistered :: !Bool, |
|
48 difficulty :: !Int, |
|
49 hhnum :: !Int, |
|
50 hedgehogs :: ![HedgehogInfo] |
|
51 } |
|
52 deriving (Show, Read) |
|
53 |
|
54 readInt_ :: (Num a) => B.ByteString -> a |
|
55 readInt_ str = |
|
56 case B.readInt str of |
|
57 Just (i, t) | B.null t -> fromIntegral i |
|
58 _ -> 0 |
|
59 |
|
60 toEngineMsg :: B.ByteString -> B.ByteString |
|
61 toEngineMsg msg = fromIntegral (BW.length msg) `BW.cons` msg |
|
62 |
|
63 em :: B.ByteString -> B.ByteString |
|
64 em = toEngineMsg |
|
65 |
|
66 eml :: [B.ByteString] -> B.ByteString |
|
67 eml = em . B.concat |
|
68 |
|
69 showB :: (Show a) => a -> B.ByteString |
|
70 showB = B.pack . show |
|
71 |
|
72 replayToDemo :: [TeamInfo] |
|
73 -> Map.Map B.ByteString B.ByteString |
|
74 -> Map.Map B.ByteString [B.ByteString] |
|
75 -> [B.ByteString] |
|
76 -> B.ByteString |
|
77 replayToDemo ti mParams prms msgs = if not sane then "" else (B.concat $ concat [ |
|
78 [em "TD"] |
|
79 , maybeScript |
|
80 , maybeMap |
|
81 , [eml ["etheme ", head $ prms Map.! "THEME"]] |
|
82 , [eml ["eseed ", mParams Map.! "SEED"]] |
|
83 , [eml ["e$gmflags ", showB gameFlags]] |
|
84 , schemeFlags |
|
85 , schemeAdditional |
|
86 , [eml ["e$template_filter ", mParams Map.! "TEMPLATE"]] |
|
87 , [eml ["e$feature_size ", mParams Map.! "FEATURE_SIZE"]] |
|
88 , [eml ["e$mapgen ", mapgen]] |
|
89 , mapgenSpecific |
|
90 , concatMap teamSetup ti |
|
91 , map (Ei.fromRight "" . Base64.decode) $ reverse msgs |
|
92 , [em "!"] |
|
93 ]) |
|
94 where |
|
95 keys1, keys2 :: Set.Set B.ByteString |
|
96 keys1 = Set.fromList ["FEATURE_SIZE", "MAP", "MAPGEN", "MAZE_SIZE", "SEED", "TEMPLATE"] |
|
97 keys2 = Set.fromList ["AMMO", "SCHEME", "SCRIPT", "THEME"] |
|
98 sane = Set.null (keys1 Set.\\ Map.keysSet mParams) |
|
99 && Set.null (keys2 Set.\\ Map.keysSet prms) |
|
100 && (not . null . drop 41 $ scheme) |
|
101 && (not . null . tail $ prms Map.! "AMMO") |
|
102 && ((B.length . head . tail $ prms Map.! "AMMO") > 200) |
|
103 mapGenTypes = ["+rnd+", "+maze+", "+drawn+", "+perlin+"] |
|
104 scriptName = head . fromMaybe ["Normal"] $ Map.lookup "SCRIPT" prms |
|
105 maybeScript = let s = scriptName in if s == "Normal" then [] else [eml ["escript Scripts/Multiplayer/", spaces2Underlining s, ".lua"]] |
|
106 maybeMap = let m = mParams Map.! "MAP" in if m `elem` mapGenTypes then [] else [eml ["emap ", m]] |
|
107 scheme = tail $ prms Map.! "SCHEME" |
|
108 mapgen = mParams Map.! "MAPGEN" |
|
109 mazeSizeMsg = eml ["e$maze_size ", mParams Map.! "MAZE_SIZE"] |
|
110 mapgenSpecific = case mapgen of |
|
111 "1" -> [mazeSizeMsg] |
|
112 "2" -> [mazeSizeMsg] |
|
113 "3" -> let d = head . fromMaybe [""] $ Map.lookup "DRAWNMAP" prms in if BW.length d <= 4 then [] else drawnMapData d |
|
114 _ -> [] |
|
115 gameFlags :: Word32 |
|
116 gameFlags = foldl (\r (b, f) -> if b == "false" then r else r .|. f) 0 $ zip scheme gameFlagConsts |
|
117 schemeFlags = map (\(v, (n, m)) -> eml [n, " ", showB $ (readInt_ v) * m]) |
|
118 $ filter (\(_, (n, _)) -> not $ B.null n) |
|
119 $ zip (drop (length gameFlagConsts) scheme) schemeParams |
|
120 schemeAdditional = let scriptParam = B.tail $ scheme !! 42 in [eml ["e$scriptparam ", scriptParam] | not $ B.null scriptParam] |
|
121 ammoStr :: B.ByteString |
|
122 ammoStr = head . tail $ prms Map.! "AMMO" |
|
123 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 |
|
124 (map (\(x, y) -> eml [x, " ", y]) $ zip ["eammloadt", "eammprob", "eammdelay", "eammreinf"] [a, b, c, d]) |
|
125 ++ [em "eammstore" | scheme !! 14 == "true" || scheme !! 20 == "false"] |
|
126 initHealth = scheme !! 27 |
|
127 teamSetup :: TeamInfo -> [B.ByteString] |
|
128 teamSetup t = (++) ammo $ |
|
129 eml ["eaddteam <hash> ", showB $ (1 + (readInt_ $ teamcolor t) :: Int) * 2113696, " ", teamname t] |
|
130 : em "erdriven" |
|
131 : eml ["efort ", teamfort t] |
|
132 : take (2 * hhnum t) ( |
|
133 concatMap (\(HedgehogInfo hname hhat) -> [ |
|
134 eml ["eaddhh ", showB $ difficulty t, " ", initHealth, " ", hname] |
|
135 , eml ["ehat ", hhat] |
|
136 ]) |
|
137 $ hedgehogs t |
|
138 ) |
|
139 infRopes = ammoStr `B.index` 7 == '9' |
|
140 vamp = gameFlags .&. 0x00000200 /= 0 |
|
141 infattacks = gameFlags .&. 0x00100000 /= 0 |
|
142 spaces2Underlining = B.map (\c -> if c == ' ' then '_' else c) |
|
143 |
|
144 drawnMapData :: B.ByteString -> [B.ByteString] |
|
145 drawnMapData = |
|
146 L.map (\m -> eml ["edraw ", BW.pack m]) |
|
147 . L.unfoldr by200 |
|
148 . BL.unpack |
|
149 . unpackDrawnMap |
|
150 where |
|
151 by200 :: [a] -> Maybe ([a], [a]) |
|
152 by200 [] = Nothing |
|
153 by200 m = Just $ L.splitAt 200 m |
|
154 |
|
155 unpackDrawnMap :: B.ByteString -> BL.ByteString |
|
156 unpackDrawnMap = either |
|
157 (const BL.empty) |
|
158 (decompressWithoutExceptions . BL.pack . drop 4 . BW.unpack) |
|
159 . Base64.decode |
|
160 |
|
161 compressWithLength :: BL.ByteString -> BL.ByteString |
|
162 compressWithLength b = BL.drop 8 . encode . runPut $ do |
|
163 put $ ((fromIntegral $ BL.length b)::Word32) |
|
164 mapM_ putWord8 $ BW.unpack $ BL.toStrict $ Z.compress b |
|
165 |
|
166 packDrawnMap :: BL.ByteString -> B.ByteString |
|
167 packDrawnMap = |
|
168 Base64.encode |
|
169 . BL.toStrict |
|
170 . compressWithLength |
|
171 |
|
172 prependGhostPoints :: [(Int16, Int16)] -> B.ByteString -> B.ByteString |
|
173 prependGhostPoints pts dm = packDrawnMap $ (runPut $ forM_ pts $ \(x, y) -> put x >> put y >> putWord8 99) `BL.append` unpackDrawnMap dm |
|
174 |
|
175 schemeParams :: [(B.ByteString, Int)] |
|
176 schemeParams = [ |
|
177 ("e$damagepct", 1) |
|
178 , ("e$turntime", 1000) |
|
179 , ("", 0) |
|
180 , ("e$sd_turns", 1) |
|
181 , ("e$casefreq", 1) |
|
182 , ("e$minestime", 1000) |
|
183 , ("e$minesnum", 1) |
|
184 , ("e$minedudpct", 1) |
|
185 , ("e$explosives", 1) |
|
186 , ("e$airmines", 1) |
|
187 , ("e$healthprob", 1) |
|
188 , ("e$hcaseamount", 1) |
|
189 , ("e$waterrise", 1) |
|
190 , ("e$healthdec", 1) |
|
191 , ("e$ropepct", 1) |
|
192 , ("e$getawaytime", 1) |
|
193 , ("e$worldedge", 1) |
|
194 ] |
|
195 |
|
196 |
|
197 gameFlagConsts :: [Word32] |
|
198 gameFlagConsts = [ |
|
199 0x00001000 |
|
200 , 0x00000010 |
|
201 , 0x00000004 |
|
202 , 0x00000008 |
|
203 , 0x00000020 |
|
204 , 0x00000040 |
|
205 , 0x00000080 |
|
206 , 0x00000100 |
|
207 , 0x00000200 |
|
208 , 0x00000400 |
|
209 , 0x00000800 |
|
210 , 0x00002000 |
|
211 , 0x00004000 |
|
212 , 0x00008000 |
|
213 , 0x00010000 |
|
214 , 0x00020000 |
|
215 , 0x00040000 |
|
216 , 0x00080000 |
|
217 , 0x00100000 |
|
218 , 0x00200000 |
|
219 , 0x00400000 |
|
220 , 0x00800000 |
|
221 , 0x01000000 |
|
222 , 0x02000000 |
|
223 , 0x04000000 |
|
224 ] |
|
225 |
|
226 loadReplay :: String -> IO (Maybe ([TeamInfo], [(B.ByteString, B.ByteString)], [(B.ByteString, [B.ByteString])], [B.ByteString])) |
|
227 loadReplay fileName = E.handle (\(e :: SomeException) -> return Nothing) $ do |
|
228 liftM (Just . read) $ readFile fileName |
|
229 |
|
230 convert :: String -> IO () |
|
231 convert fileName = do |
|
232 Just (t, c1, c2, m) <- loadReplay fileName |
|
233 B.writeFile (fileName ++ ".hwd") $ replayToDemo t (Map.fromList c1) (Map.fromList c2) m |
|
234 |
|
235 main = do |
|
236 args <- getArgs |
|
237 when (length args == 1) $ (convert (head args)) |