{-

 * Hedgewars, a free turn based strategy game

 * Copyright (c) 2004-2014 Andrey Korotaev <unC0Rr@gmail.com>

 *

 * This program is free software; you can redistribute it and/or modify

 * it under the terms of the GNU General Public License as published by

 * the Free Software Foundation; version 2 of the License

 *

 * This program is distributed in the hope that it will be useful,

 * but WITHOUT ANY WARRANTY; without even the implied warranty of

 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

 * GNU General Public License for more details.

 *

 * You should have received a copy of the GNU General Public License

 * along with this program; if not, write to the Free Software

 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

 \-}

{-# LANGUAGE OverloadedStrings #-}

module EngineInteraction(replayToDemo, checkNetCmd, toEngineMsg, drawnMapData) where

import qualified Data.Set as Set

import Control.Monad

import qualified Codec.Binary.Base64 as Base64

import qualified Data.ByteString.Char8 as B

import qualified Data.ByteString as BW

import qualified Data.ByteString.Lazy as BL

import qualified Data.Map as Map

import qualified Data.List as L

import Data.Word

import Data.Bits

import Control.Arrow

import Data.Maybe

-------------

import CoreTypes

import Utils

{-

    this is snippet from http://stackoverflow.com/questions/10043102/how-to-catch-the-decompress-ioerror

    because standard 'catch' doesn't seem to catch decompression errors for some reason

-}

import qualified Codec.Compression.Zlib.Internal as Z

decompressWithoutExceptions :: BL.ByteString -> Either String BL.ByteString

decompressWithoutExceptions = finalise

                            . Z.foldDecompressStream cons nil err

                            . Z.decompressWithErrors Z.zlibFormat Z.defaultDecompressParams

  where err _ msg = Left msg

        nil = Right []

        cons chunk = right (chunk :)

        finalise = right BL.fromChunks

{- end snippet  -}

toEngineMsg :: B.ByteString -> B.ByteString

toEngineMsg msg = B.pack $ Base64.encode (fromIntegral (BW.length msg) : BW.unpack msg)

{-fromEngineMsg :: B.ByteString -> Maybe B.ByteString

fromEngineMsg msg = liftM BW.pack (Base64.decode (B.unpack msg) >>= removeLength)

    where

        removeLength (x:xs) = if length xs == fromIntegral x then Just xs else Nothing

        removeLength _ = Nothing-}

em :: B.ByteString -> B.ByteString

em = toEngineMsg

eml :: [B.ByteString] -> B.ByteString

eml = em . B.concat

splitMessages :: B.ByteString -> [B.ByteString]

splitMessages = L.unfoldr (\b -> if B.null b then Nothing else Just $ B.splitAt (1 + fromIntegral (BW.head b)) b)

checkNetCmd :: B.ByteString -> (B.ByteString, B.ByteString, Maybe (Maybe B.ByteString))

checkNetCmd msg = check decoded

    where

        decoded = liftM (splitMessages . BW.pack) $ Base64.decode $ B.unpack msg

        check Nothing = (B.empty, B.empty, Nothing)

        check (Just msgs) = let (a, b) = (filter isLegal msgs, filter isNonEmpty a) in (encode a, encode b, lft a)

        encode = B.pack . Base64.encode . BW.unpack . B.concat

        isLegal m = (B.length m > 1) && (flip Set.member legalMessages . B.head . B.tail $ m)

        lft = foldr l Nothing

        l m n = let m' = B.head $ B.tail m; tst = flip Set.member in

                      if not $ tst timedMessages m' then n

                        else if '+' /= m' then Just Nothing else Just . Just . B.pack . Base64.encode . BW.unpack $ m

        isNonEmpty = (/=) '+' . B.head . B.tail

        legalMessages = Set.fromList $ "M#+LlRrUuDdZzAaSjJ,sNpPwtgfhbc12345" ++ slotMessages

        slotMessages = "\128\129\130\131\132\133\134\135\136\137\138"

        timedMessages = Set.fromList $ "+LlRrUuDdZzAaSjJ,NpPwtgfc12345" ++ slotMessages

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 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$mapgen ", mapgen]]

        , mapgenSpecific

        , concatMap teamSetup ti

        , msgs

        , [em "!"]

        ]

    where

        keys1, keys2 :: Set.Set B.ByteString

        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 40 $ scheme)

            && (not . null . tail $ prms Map.! "AMMO")

        mapGenTypes = ["+rnd+", "+maze+", "+drawn+"]

        maybeScript = let s = head . fromMaybe ["Normal"] $ Map.lookup "SCRIPT" prms in if s == "Normal" then [] else [eml ["escript Scripts/Multiplayer/", 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"

        mapgenSpecific = case mapgen of

            "1" -> [eml ["e$maze_size ", mParams Map.! "MAZE_SIZE"]]

            "2" -> 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 !! 41 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

                        )

drawnMapData :: B.ByteString -> [B.ByteString]

drawnMapData =

          L.map (\m -> eml ["edraw ", BW.pack m])

        . L.unfoldr by200

        . BL.unpack

        . either (const BL.empty) id

        . decompressWithoutExceptions

        . BL.pack

        . L.drop 4

        . fromMaybe []

        . Base64.decode

        . B.unpack

    where

        by200 :: [a] -> Maybe ([a], [a])

        by200 [] = Nothing

        by200 m = Just $ L.splitAt 200 m

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$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

        ]