gameServer/HWProtoInRoomState.hs
author koda
Sun, 26 Dec 2010 19:30:51 +0100
changeset 4701 7ed88cfc99b1
parent 4568 f85243bf890e
child 4681 f2c30204a3fd
permissions -rw-r--r--
restore showing a bigger icon for themes

module HWProtoInRoomState where

import qualified Data.Foldable as Foldable
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import Data.Sequence(Seq, (|>), (><), fromList, empty)
import Data.List
import Data.Maybe
--------------------------------------
import CoreTypes
import Actions
import Utils


handleCmd_inRoom :: CmdHandler

handleCmd_inRoom clID clients _ ["CHAT", msg] =
    [AnswerOthersInRoom ["CHAT", clientNick, msg]]
    where
        clientNick = nick $ clients IntMap.! clID

handleCmd_inRoom clID clients rooms ["PART"] =
    [RoomRemoveThisClient "part"]
    where
        client = clients IntMap.! clID


handleCmd_inRoom clID clients rooms ("CFG" : paramName : paramStrs)
    | null paramStrs = [ProtocolError "Empty config entry"]
    | isMaster client =
        [ModifyRoom (\r -> r{params = Map.insert paramName paramStrs (params r)}),
        AnswerOthersInRoom ("CFG" : paramName : paramStrs)]
    | otherwise = [ProtocolError "Not room master"]
    where
        client = clients IntMap.! clID

handleCmd_inRoom clID clients rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : flag : difStr : hhsInfo)
    | length hhsInfo == 15 && clientProto client < 30 = handleCmd_inRoom clID clients rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : " " : flag : difStr : hhsInfo)
    | length hhsInfo /= 16 = [ProtocolError "Corrupted hedgehogs info"]
    | length (teams room) == 6 = [Warning "too many teams"]
    | canAddNumber <= 0 = [Warning "too many hedgehogs"]
    | isJust findTeam = [Warning "There's already a team with same name in the list"]
    | gameinprogress room = [Warning "round in progress"]
    | isRestrictedTeams room = [Warning "restricted"]
    | otherwise =
        [ModifyRoom (\r -> r{teams = teams r ++ [newTeam]}),
        ModifyClient (\c -> c{teamsInGame = teamsInGame c + 1, clientClan = color}),
        AnswerThisClient ["TEAM_ACCEPTED", name],
        AnswerOthersInRoom $ teamToNet (clientProto client) newTeam,
        AnswerOthersInRoom ["TEAM_COLOR", name, color]
        ]
    where
        client = clients IntMap.! clID
        room = rooms IntMap.! (roomID client)
        canAddNumber = 48 - (sum . map hhnum $ teams room)
        findTeam = find (\t -> name == teamname t) $ teams room
        newTeam = (TeamInfo clID (nick client) name color grave fort voicepack flag difficulty newTeamHHNum (hhsList hhsInfo))
        difficulty = fromMaybe 0 (maybeRead difStr :: Maybe Int)
        hhsList [] = []
        hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs
        newTeamHHNum = min 4 canAddNumber

handleCmd_inRoom clID clients rooms ["REMOVE_TEAM", teamName]
    | noSuchTeam = [Warning "REMOVE_TEAM: no such team"]
    | nick client /= teamowner team = [ProtocolError "Not team owner!"]
    | otherwise =
            [RemoveTeam teamName,
            ModifyClient (\c -> c{teamsInGame = teamsInGame c - 1, clientClan = if teamsInGame client == 1 then undefined else anotherTeamClan})
            ]
    where
        client = clients IntMap.! clID
        room = rooms IntMap.! (roomID client)
        noSuchTeam = isNothing findTeam
        team = fromJust findTeam
        findTeam = find (\t -> teamName == teamname t) $ teams room
        anotherTeamClan = teamcolor $ fromJust $ find (\t -> teamownerId t == clID) $ teams room


handleCmd_inRoom clID clients rooms ["HH_NUM", teamName, numberStr]
    | not $ isMaster client = [ProtocolError "Not room master"]
    | hhNumber < 1 || hhNumber > 8 || noSuchTeam || hhNumber > (canAddNumber + (hhnum team)) = []
    | otherwise =
        [ModifyRoom $ modifyTeam team{hhnum = hhNumber},
        AnswerOthersInRoom ["HH_NUM", teamName, show hhNumber]]
    where
        client = clients IntMap.! clID
        room = rooms IntMap.! (roomID client)
        hhNumber = fromMaybe 0 (maybeRead numberStr :: Maybe Int)
        noSuchTeam = isNothing findTeam
        team = fromJust findTeam
        findTeam = find (\t -> teamName == teamname t) $ teams room
        canAddNumber = 48 - (sum . map hhnum $ teams room)


handleCmd_inRoom clID clients rooms ["TEAM_COLOR", teamName, newColor]
    | not $ isMaster client = [ProtocolError "Not room master"]
    | noSuchTeam = []
    | otherwise = [ModifyRoom $ modifyTeam team{teamcolor = newColor},
            AnswerOthersInRoom ["TEAM_COLOR", teamName, newColor],
            ModifyClient2 (teamownerId team) (\c -> c{clientClan = newColor})]
    where
        noSuchTeam = isNothing findTeam
        team = fromJust findTeam
        findTeam = find (\t -> teamName == teamname t) $ teams room
        client = clients IntMap.! clID
        room = rooms IntMap.! (roomID client)


handleCmd_inRoom clID clients rooms ["TOGGLE_READY"] =
    [ModifyClient (\c -> c{isReady = not $ isReady client}),
    ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady client then -1 else 1)}),
    AnswerThisRoom [if isReady client then "NOT_READY" else "READY", nick client]]
    where
        client = clients IntMap.! clID


handleCmd_inRoom clID clients rooms ["START_GAME"] =
    if isMaster client && (playersIn room == readyPlayers room) && (not . gameinprogress) room then
        if enoughClans then
            [ModifyRoom
                    (\r -> r{
                        gameinprogress = True,
                        roundMsgs = empty,
                        leftTeams = [],
                        teamsAtStart = teams r}
                    ),
            AnswerThisRoom ["RUN_GAME"]]
        else
            [Warning "Less than two clans!"]
    else
        []
    where
        client = clients IntMap.! clID
        room = rooms IntMap.! (roomID client)
        enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams room


handleCmd_inRoom clID clients rooms ["EM", msg] =
    if (teamsInGame client > 0) && isLegal then
        (AnswerOthersInRoom ["EM", msg]) : [ModifyRoom (\r -> r{roundMsgs = roundMsgs r |> msg}) | not isKeepAlive]
    else
        []
    where
        client = clients IntMap.! clID
        (isLegal, isKeepAlive) = checkNetCmd msg

handleCmd_inRoom clID clients rooms ["ROUNDFINISHED"] =
    if isMaster client then
        [ModifyRoom
                (\r -> r{
                    gameinprogress = False,
                    readyPlayers = 0,
                    roundMsgs = empty,
                    leftTeams = [],
                    teamsAtStart = []}
                ),
        UnreadyRoomClients
        ] ++ answerRemovedTeams
    else
        []
    where
        client = clients IntMap.! clID
        room = rooms IntMap.! (roomID client)
        answerRemovedTeams = map (\t -> AnswerThisRoom ["REMOVE_TEAM", t]) $ leftTeams room


handleCmd_inRoom clID clients _ ["TOGGLE_RESTRICT_JOINS"]
    | isMaster client = [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})]
    | otherwise = [ProtocolError "Not room master"]
    where
        client = clients IntMap.! clID


handleCmd_inRoom clID clients _ ["TOGGLE_RESTRICT_TEAMS"]
    | isMaster client = [ModifyRoom (\r -> r{isRestrictedTeams = not $ isRestrictedTeams r})]
    | otherwise = [ProtocolError "Not room master"]
    where
        client = clients IntMap.! clID

handleCmd_inRoom clID clients rooms ["KICK", kickNick] =
    [KickRoomClient kickID | isMaster client && not noSuchClient && (kickID /= clID) && (roomID client == roomID kickClient)]
    where
        client = clients IntMap.! clID
        maybeClient = Foldable.find (\cl -> kickNick == nick cl) clients
        noSuchClient = isNothing maybeClient
        kickClient = fromJust maybeClient
        kickID = clientUID kickClient


handleCmd_inRoom clID clients _ ["TEAMCHAT", msg] =
    [AnswerSameClan ["EM", engineMsg]]
    where
        client = clients IntMap.! clID
        engineMsg = toEngineMsg $ 'b' : ((nick client) ++ "(team): " ++ msg ++ "\x20\x20")

handleCmd_inRoom clID _ _ _ = [ProtocolError "Incorrect command (state: in room)"]