author | Wuzzy <Wuzzy2@mail.ru> |
Thu, 03 Jan 2019 19:46:48 +0100 | |
changeset 14535 | 5ac181cb2396 |
parent 11046 | 47a8c19ecb60 |
permissions | -rw-r--r-- |
10460
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10216
diff
changeset
|
1 |
{- |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10216
diff
changeset
|
2 |
* Hedgewars, a free turn based strategy game |
11046 | 3 |
* Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com> |
10460
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10216
diff
changeset
|
4 |
* |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10216
diff
changeset
|
5 |
* This program is free software; you can redistribute it and/or modify |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10216
diff
changeset
|
6 |
* it under the terms of the GNU General Public License as published by |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10216
diff
changeset
|
7 |
* the Free Software Foundation; version 2 of the License |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10216
diff
changeset
|
8 |
* |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10216
diff
changeset
|
9 |
* This program is distributed in the hope that it will be useful, |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10216
diff
changeset
|
10 |
* but WITHOUT ANY WARRANTY; without even the implied warranty of |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10216
diff
changeset
|
11 |
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10216
diff
changeset
|
12 |
* GNU General Public License for more details. |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10216
diff
changeset
|
13 |
* |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10216
diff
changeset
|
14 |
* You should have received a copy of the GNU General Public License |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10216
diff
changeset
|
15 |
* along with this program; if not, write to the Free Software |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10216
diff
changeset
|
16 |
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10216
diff
changeset
|
17 |
\-} |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10216
diff
changeset
|
18 |
|
6805
097289be7200
Add more strictness in hope it will help with space leak
unc0rr
parents:
4932
diff
changeset
|
19 |
{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-} |
097289be7200
Add more strictness in hope it will help with space leak
unc0rr
parents:
4932
diff
changeset
|
20 |
|
4905 | 21 |
module RoomsAndClients( |
22 |
RoomIndex(), |
|
23 |
ClientIndex(), |
|
24 |
MRoomsAndClients(), |
|
25 |
IRoomsAndClients(), |
|
26 |
newRoomsAndClients, |
|
27 |
addRoom, |
|
28 |
addClient, |
|
29 |
removeRoom, |
|
30 |
removeClient, |
|
31 |
modifyRoom, |
|
32 |
modifyClient, |
|
33 |
lobbyId, |
|
34 |
moveClientToLobby, |
|
35 |
moveClientToRoom, |
|
36 |
clientRoomM, |
|
37 |
clientExists, |
|
38 |
client, |
|
39 |
room, |
|
40 |
client'sM, |
|
41 |
room'sM, |
|
42 |
allClientsM, |
|
10216 | 43 |
allRoomsM, |
4905 | 44 |
clientsM, |
8452 | 45 |
roomsM, |
4905 | 46 |
roomClientsM, |
47 |
roomClientsIndicesM, |
|
48 |
withRoomsAndClients, |
|
49 |
allRooms, |
|
50 |
allClients, |
|
51 |
clientRoom, |
|
52 |
showRooms, |
|
53 |
roomClients |
|
54 |
) where |
|
55 |
||
56 |
||
57 |
import Store |
|
58 |
import Control.Monad |
|
6805
097289be7200
Add more strictness in hope it will help with space leak
unc0rr
parents:
4932
diff
changeset
|
59 |
import Control.DeepSeq |
4905 | 60 |
|
61 |
||
62 |
data Room r = Room { |
|
6805
097289be7200
Add more strictness in hope it will help with space leak
unc0rr
parents:
4932
diff
changeset
|
63 |
roomClients' :: ![ClientIndex], |
097289be7200
Add more strictness in hope it will help with space leak
unc0rr
parents:
4932
diff
changeset
|
64 |
room' :: !r |
4905 | 65 |
} |
66 |
||
67 |
||
68 |
data Client c = Client { |
|
6805
097289be7200
Add more strictness in hope it will help with space leak
unc0rr
parents:
4932
diff
changeset
|
69 |
clientRoom' :: !RoomIndex, |
097289be7200
Add more strictness in hope it will help with space leak
unc0rr
parents:
4932
diff
changeset
|
70 |
client' :: !c |
4905 | 71 |
} |
72 |
||
73 |
||
74 |
newtype RoomIndex = RoomIndex ElemIndex |
|
6805
097289be7200
Add more strictness in hope it will help with space leak
unc0rr
parents:
4932
diff
changeset
|
75 |
deriving (Eq, NFData) |
4905 | 76 |
newtype ClientIndex = ClientIndex ElemIndex |
6805
097289be7200
Add more strictness in hope it will help with space leak
unc0rr
parents:
4932
diff
changeset
|
77 |
deriving (Eq, Show, Read, Ord, NFData) |
4905 | 78 |
|
79 |
instance Show RoomIndex where |
|
80 |
show (RoomIndex i) = 'r' : show i |
|
81 |
||
82 |
unRoomIndex :: RoomIndex -> ElemIndex |
|
83 |
unRoomIndex (RoomIndex r) = r |
|
84 |
||
85 |
unClientIndex :: ClientIndex -> ElemIndex |
|
86 |
unClientIndex (ClientIndex c) = c |
|
87 |
||
88 |
||
89 |
newtype MRoomsAndClients r c = MRoomsAndClients (MStore (Room r), MStore (Client c)) |
|
90 |
newtype IRoomsAndClients r c = IRoomsAndClients (IStore (Room r), IStore (Client c)) |
|
91 |
||
92 |
||
93 |
lobbyId :: RoomIndex |
|
94 |
lobbyId = RoomIndex firstIndex |
|
95 |
||
96 |
||
97 |
newRoomsAndClients :: r -> IO (MRoomsAndClients r c) |
|
98 |
newRoomsAndClients r = do |
|
99 |
rooms <- newStore |
|
100 |
clients <- newStore |
|
101 |
let rnc = MRoomsAndClients (rooms, clients) |
|
102 |
ri <- addRoom rnc r |
|
103 |
when (ri /= lobbyId) $ error "Empty struct inserts not at firstIndex index" |
|
104 |
return rnc |
|
105 |
||
106 |
||
107 |
roomAddClient :: ClientIndex -> Room r -> Room r |
|
6805
097289be7200
Add more strictness in hope it will help with space leak
unc0rr
parents:
4932
diff
changeset
|
108 |
roomAddClient cl rm = let cls = cl : roomClients' rm; nr = rm{roomClients' = cls} in cls `deepseq` nr |
4905 | 109 |
|
110 |
roomRemoveClient :: ClientIndex -> Room r -> Room r |
|
6805
097289be7200
Add more strictness in hope it will help with space leak
unc0rr
parents:
4932
diff
changeset
|
111 |
roomRemoveClient cl rm = let cls = filter (/= cl) $ roomClients' rm; nr = rm{roomClients' = cls} in cls `deepseq` nr |
4905 | 112 |
|
113 |
||
114 |
addRoom :: MRoomsAndClients r c -> r -> IO RoomIndex |
|
4932 | 115 |
addRoom (MRoomsAndClients (rooms, _)) rm = do |
116 |
i <- addElem rooms (Room [] rm) |
|
4905 | 117 |
return $ RoomIndex i |
118 |
||
119 |
||
120 |
addClient :: MRoomsAndClients r c -> c -> IO ClientIndex |
|
4932 | 121 |
addClient (MRoomsAndClients (rooms, clients)) cl = do |
122 |
i <- addElem clients (Client lobbyId cl) |
|
4905 | 123 |
modifyElem rooms (roomAddClient (ClientIndex i)) (unRoomIndex lobbyId) |
124 |
return $ ClientIndex i |
|
125 |
||
126 |
removeRoom :: MRoomsAndClients r c -> RoomIndex -> IO () |
|
4932 | 127 |
removeRoom rnc@(MRoomsAndClients (rooms, _)) rm@(RoomIndex ri) |
128 |
| rm == lobbyId = error "Cannot delete lobby" |
|
4905 | 129 |
| otherwise = do |
130 |
clIds <- liftM roomClients' $ readElem rooms ri |
|
131 |
forM_ clIds (moveClientToLobby rnc) |
|
132 |
removeElem rooms ri |
|
133 |
||
134 |
||
135 |
removeClient :: MRoomsAndClients r c -> ClientIndex -> IO () |
|
136 |
removeClient (MRoomsAndClients (rooms, clients)) cl@(ClientIndex ci) = do |
|
137 |
RoomIndex ri <- liftM clientRoom' $ readElem clients ci |
|
138 |
modifyElem rooms (roomRemoveClient cl) ri |
|
139 |
removeElem clients ci |
|
140 |
||
141 |
||
142 |
modifyRoom :: MRoomsAndClients r c -> (r -> r) -> RoomIndex -> IO () |
|
143 |
modifyRoom (MRoomsAndClients (rooms, _)) f (RoomIndex ri) = modifyElem rooms (\r -> r{room' = f $ room' r}) ri |
|
144 |
||
145 |
modifyClient :: MRoomsAndClients r c -> (c -> c) -> ClientIndex -> IO () |
|
146 |
modifyClient (MRoomsAndClients (_, clients)) f (ClientIndex ci) = modifyElem clients (\c -> c{client' = f $ client' c}) ci |
|
147 |
||
148 |
moveClientInRooms :: MRoomsAndClients r c -> RoomIndex -> RoomIndex -> ClientIndex -> IO () |
|
149 |
moveClientInRooms (MRoomsAndClients (rooms, clients)) (RoomIndex riFrom) rt@(RoomIndex riTo) cl@(ClientIndex ci) = do |
|
150 |
modifyElem rooms (roomRemoveClient cl) riFrom |
|
151 |
modifyElem rooms (roomAddClient cl) riTo |
|
152 |
modifyElem clients (\c -> c{clientRoom' = rt}) ci |
|
153 |
||
154 |
||
155 |
moveClientToLobby :: MRoomsAndClients r c -> ClientIndex -> IO () |
|
156 |
moveClientToLobby rnc ci = do |
|
4932 | 157 |
rm <- clientRoomM rnc ci |
158 |
moveClientInRooms rnc rm lobbyId ci |
|
4905 | 159 |
|
160 |
||
161 |
moveClientToRoom :: MRoomsAndClients r c -> RoomIndex -> ClientIndex -> IO () |
|
4932 | 162 |
moveClientToRoom rnc = moveClientInRooms rnc lobbyId |
4905 | 163 |
|
164 |
||
165 |
clientExists :: MRoomsAndClients r c -> ClientIndex -> IO Bool |
|
166 |
clientExists (MRoomsAndClients (_, clients)) (ClientIndex ci) = elemExists clients ci |
|
167 |
||
168 |
clientRoomM :: MRoomsAndClients r c -> ClientIndex -> IO RoomIndex |
|
169 |
clientRoomM (MRoomsAndClients (_, clients)) (ClientIndex ci) = liftM clientRoom' (clients `readElem` ci) |
|
170 |
||
171 |
client'sM :: MRoomsAndClients r c -> (c -> a) -> ClientIndex -> IO a |
|
172 |
client'sM (MRoomsAndClients (_, clients)) f (ClientIndex ci) = liftM (f . client') (clients `readElem` ci) |
|
173 |
||
174 |
room'sM :: MRoomsAndClients r c -> (r -> a) -> RoomIndex -> IO a |
|
175 |
room'sM (MRoomsAndClients (rooms, _)) f (RoomIndex ri) = liftM (f . room') (rooms `readElem` ri) |
|
176 |
||
177 |
allClientsM :: MRoomsAndClients r c -> IO [ClientIndex] |
|
178 |
allClientsM (MRoomsAndClients (_, clients)) = liftM (map ClientIndex) $ indicesM clients |
|
179 |
||
10215 | 180 |
allRoomsM :: MRoomsAndClients r c -> IO [RoomIndex] |
181 |
allRoomsM (MRoomsAndClients (rooms, _)) = liftM (map RoomIndex) $ indicesM rooms |
|
182 |
||
4905 | 183 |
clientsM :: MRoomsAndClients r c -> IO [c] |
4932 | 184 |
clientsM (MRoomsAndClients (_, clients)) = indicesM clients >>= mapM (liftM client' . readElem clients) |
4905 | 185 |
|
8452 | 186 |
roomsM :: MRoomsAndClients r c -> IO [r] |
187 |
roomsM (MRoomsAndClients (rooms, _)) = indicesM rooms >>= mapM (liftM room' . readElem rooms) |
|
188 |
||
4905 | 189 |
roomClientsIndicesM :: MRoomsAndClients r c -> RoomIndex -> IO [ClientIndex] |
4932 | 190 |
roomClientsIndicesM (MRoomsAndClients (rooms, _)) (RoomIndex ri) = liftM roomClients' (rooms `readElem` ri) |
4905 | 191 |
|
192 |
roomClientsM :: MRoomsAndClients r c -> RoomIndex -> IO [c] |
|
193 |
roomClientsM (MRoomsAndClients (rooms, clients)) (RoomIndex ri) = liftM roomClients' (rooms `readElem` ri) >>= mapM (\(ClientIndex ci) -> liftM client' $ readElem clients ci) |
|
194 |
||
195 |
withRoomsAndClients :: MRoomsAndClients r c -> (IRoomsAndClients r c -> a) -> IO a |
|
196 |
withRoomsAndClients (MRoomsAndClients (rooms, clients)) f = |
|
197 |
withIStore2 rooms clients (\r c -> f $ IRoomsAndClients (r, c)) |
|
198 |
||
199 |
---------------------------------------- |
|
200 |
----------- IRoomsAndClients ----------- |
|
201 |
||
202 |
showRooms :: (Show r, Show c) => IRoomsAndClients r c -> String |
|
203 |
showRooms rnc@(IRoomsAndClients (rooms, clients)) = concatMap showRoom (allRooms rnc) |
|
204 |
where |
|
4932 | 205 |
showRoom r = unlines $ (show r ++ ": " ++ (show . room' $ rooms ! unRoomIndex r)) : map showClient (roomClients' $ rooms ! unRoomIndex r) |
206 |
showClient c = " " ++ show c ++ ": " ++ (show . client' $ clients ! unClientIndex c) |
|
4905 | 207 |
|
208 |
||
209 |
allRooms :: IRoomsAndClients r c -> [RoomIndex] |
|
210 |
allRooms (IRoomsAndClients (rooms, _)) = map RoomIndex $ indices rooms |
|
211 |
||
212 |
allClients :: IRoomsAndClients r c -> [ClientIndex] |
|
213 |
allClients (IRoomsAndClients (_, clients)) = map ClientIndex $ indices clients |
|
214 |
||
215 |
clientRoom :: IRoomsAndClients r c -> ClientIndex -> RoomIndex |
|
216 |
clientRoom (IRoomsAndClients (_, clients)) (ClientIndex ci) = clientRoom' (clients ! ci) |
|
217 |
||
218 |
client :: IRoomsAndClients r c -> ClientIndex -> c |
|
219 |
client (IRoomsAndClients (_, clients)) (ClientIndex ci) = client' (clients ! ci) |
|
220 |
||
221 |
room :: IRoomsAndClients r c -> RoomIndex -> r |
|
222 |
room (IRoomsAndClients (rooms, _)) (RoomIndex ri) = room' (rooms ! ri) |
|
223 |
||
224 |
roomClients :: IRoomsAndClients r c -> RoomIndex -> [ClientIndex] |
|
4932 | 225 |
roomClients (IRoomsAndClients (rooms, _)) (RoomIndex ri) = roomClients' (rooms ! ri) |