gameServer/HWProtoLobbyState.hs
author unc0rr
Fri, 20 Feb 2009 14:12:16 +0000
changeset 1812 3d4692e825e7
parent 1811 1b9e33623b7e
child 1813 cfe1481e0247
permissions -rw-r--r--
'Reduce quality' patch by nemo + my addition to save some CPU time (don't even create visual gears)

module HWProtoLobbyState where

import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import Maybe
import Data.List
--------------------------------------
import CoreTypes
import Actions
import Utils

answerAllTeams teams = concatMap toAnswer teams
	where
		toAnswer team =
			[AnswerThisClient $ teamToNet team,
			AnswerThisClient ["TEAM_COLOR", teamname team, teamcolor team],
			AnswerThisClient ["HH_NUM", teamname team, show $ hhnum team]]

handleCmd_lobby :: CmdHandler

handleCmd_lobby clID clients rooms ["LIST"] =
	[AnswerThisClient ("ROOMS" : roomsInfoList)]
	where
		roomsInfoList = concatMap roomInfo $ sameProtoRooms
		sameProtoRooms = filter (\r -> (roomProto r == protocol) && (not $ isRestrictedJoins r)) roomsList
		roomsList = IntMap.elems rooms
		protocol = clientProto client
		client = clients IntMap.! clID
		roomInfo room = [
				name room,
				(show $ playersIn room) ++ "(" ++ (show $ length $ teams room) ++ ")",
				show $ gameinprogress room
				]

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

handleCmd_lobby clID clients rooms ["CREATE", newRoom, roomPassword] =
	if haveSameRoom then
		[Warning "Room exists"]
	else
		[RoomRemoveThisClient, -- leave lobby
		AddRoom newRoom roomPassword,
		AnswerThisClient ["NOT_READY", clientNick]
		]
	where
		clientNick = nick $ clients IntMap.! clID
		haveSameRoom = isJust $ find (\room -> newRoom == name room) $ IntMap.elems rooms

handleCmd_lobby clID clients rooms ["CREATE", newRoom] =
	handleCmd_lobby clID clients rooms ["CREATE", newRoom, ""]

handleCmd_lobby clID clients rooms ["JOIN", roomName, roomPassword] =
	if noSuchRoom then
		[Warning "No such room"]
	else if isRestrictedJoins jRoom then
		[Warning "Joining restricted"]
	else if roomPassword /= password jRoom then
		[Warning "Wrong password"]
	else
		[RoomRemoveThisClient, -- leave lobby
		RoomAddThisClient rID] -- join room
		++ answerNicks
		++ answerReady
		++ [AnswerThisRoom ["NOT_READY", nick client]]
		++ answerFullConfig jRoom
		++ answerTeams
--		++ watchRound)
	where
		noSuchRoom = isNothing mbRoom
		mbRoom = find (\r -> roomName == name r && roomProto r == clientProto client) $ IntMap.elems rooms 
		jRoom = fromJust mbRoom
		rID = roomUID jRoom
		client = clients IntMap.! clID
		roomClientsIDs = IntSet.elems $ playersIDs jRoom
		answerNicks = if playersIn jRoom /= 0 then
					[AnswerThisClient $ ["JOINED"] ++ (map (\clID -> nick $ clients IntMap.! clID) $ roomClientsIDs)]
				else
					[]
		answerReady =
			map (\c -> AnswerThisClient [if isReady c then "READY" else "NOT_READY", nick c]) $
			map (\clID -> clients IntMap.! clID) roomClientsIDs

		toAnswer (paramName, paramStrs) = AnswerThisClient $ "CFG" : paramName : paramStrs
		answerFullConfig room = map toAnswer (Map.toList $ params room)
{-
		watchRound = if (roomProto clRoom < 20) || (not $ gameinprogress clRoom) then
					[]
				else
					(answerClientOnly  ["RUN_GAME"]) ++
					answerClientOnly ("GAMEMSG" : toEngineMsg "e$spectate 1" : (toList $ roundMsgs clRoom)) -}
		answerTeams = if gameinprogress jRoom then
				answerAllTeams (teamsAtStart jRoom)
			else
				answerAllTeams (teams jRoom)


handleCmd_lobby client clients rooms ["JOIN", roomName] =
	handleCmd_lobby client clients rooms ["JOIN", roomName, ""]

handleCmd_lobby clID _ _ _ = [ProtocolError "Incorrect command (state: in lobby)"]