author | smxx |
Fri, 07 May 2010 13:04:01 +0000 | |
changeset 3446 | 1be74e601960 |
parent 3436 | 288fcbdb77b6 |
child 3458 | 11cd56019f00 |
permissions | -rw-r--r-- |
3425 | 1 |
module RoomsAndClients( |
2 |
RoomIndex(), |
|
3 |
ClientIndex(), |
|
4 |
MRoomsAndClients(), |
|
5 |
IRoomsAndClients(), |
|
6 |
newRoomsAndClients, |
|
7 |
addRoom, |
|
8 |
addClient, |
|
9 |
removeRoom, |
|
10 |
removeClient, |
|
3436
288fcbdb77b6
Make server build again (it's still useless though)
unc0rr
parents:
3435
diff
changeset
|
11 |
modifyRoom, |
288fcbdb77b6
Make server build again (it's still useless though)
unc0rr
parents:
3435
diff
changeset
|
12 |
modifyClient, |
3425 | 13 |
lobbyId, |
14 |
moveClientToLobby, |
|
15 |
moveClientToRoom, |
|
16 |
clientRoom, |
|
3436
288fcbdb77b6
Make server build again (it's still useless though)
unc0rr
parents:
3435
diff
changeset
|
17 |
clientRoomM, |
3425 | 18 |
client, |
19 |
allClients, |
|
20 |
withRoomsAndClients, |
|
3435 | 21 |
showRooms, |
22 |
roomClients |
|
3425 | 23 |
) where |
24 |
||
25 |
||
26 |
import Store |
|
27 |
import Control.Monad |
|
28 |
||
29 |
||
30 |
data Room r = Room { |
|
31 |
roomClients' :: [ClientIndex], |
|
32 |
room' :: r |
|
33 |
} |
|
34 |
||
35 |
||
36 |
data Client c = Client { |
|
37 |
clientRoom' :: RoomIndex, |
|
38 |
client' :: c |
|
39 |
} |
|
40 |
||
41 |
||
42 |
newtype RoomIndex = RoomIndex ElemIndex |
|
43 |
deriving (Eq) |
|
44 |
newtype ClientIndex = ClientIndex ElemIndex |
|
3435 | 45 |
deriving (Eq, Show, Read) |
3425 | 46 |
|
47 |
instance Show RoomIndex where |
|
48 |
show (RoomIndex i) = 'r' : show i |
|
49 |
||
50 |
unRoomIndex :: RoomIndex -> ElemIndex |
|
51 |
unRoomIndex (RoomIndex r) = r |
|
52 |
||
53 |
unClientIndex :: ClientIndex -> ElemIndex |
|
54 |
unClientIndex (ClientIndex c) = c |
|
55 |
||
56 |
||
57 |
newtype MRoomsAndClients r c = MRoomsAndClients (MStore (Room r), MStore (Client c)) |
|
58 |
newtype IRoomsAndClients r c = IRoomsAndClients (IStore (Room r), IStore (Client c)) |
|
59 |
||
60 |
||
61 |
lobbyId :: RoomIndex |
|
62 |
lobbyId = RoomIndex firstIndex |
|
63 |
||
64 |
||
65 |
newRoomsAndClients :: r -> IO (MRoomsAndClients r c) |
|
66 |
newRoomsAndClients r = do |
|
67 |
rooms <- newStore |
|
68 |
clients <- newStore |
|
69 |
let rnc = MRoomsAndClients (rooms, clients) |
|
70 |
ri <- addRoom rnc r |
|
71 |
when (ri /= lobbyId) $ error "Empty struct inserts not at firstIndex index" |
|
72 |
return rnc |
|
73 |
||
74 |
||
75 |
roomAddClient :: ClientIndex -> Room r -> Room r |
|
76 |
roomAddClient cl room = room{roomClients' = cl : roomClients' room} |
|
77 |
||
78 |
roomRemoveClient :: ClientIndex -> Room r -> Room r |
|
79 |
roomRemoveClient cl room = room{roomClients' = filter (/= cl) $ roomClients' room} |
|
80 |
||
3435 | 81 |
|
3425 | 82 |
addRoom :: MRoomsAndClients r c -> r -> IO RoomIndex |
83 |
addRoom (MRoomsAndClients (rooms, _)) room = do |
|
84 |
i <- addElem rooms (Room [] room) |
|
85 |
return $ RoomIndex i |
|
86 |
||
87 |
||
88 |
addClient :: MRoomsAndClients r c -> c -> IO ClientIndex |
|
89 |
addClient (MRoomsAndClients (rooms, clients)) client = do |
|
90 |
i <- addElem clients (Client lobbyId client) |
|
91 |
modifyElem rooms (roomAddClient (ClientIndex i)) rid |
|
92 |
return $ ClientIndex i |
|
93 |
where |
|
94 |
rid = (\(RoomIndex i) -> i) lobbyId |
|
95 |
||
96 |
removeRoom :: MRoomsAndClients r c -> RoomIndex -> IO () |
|
97 |
removeRoom rnc@(MRoomsAndClients (rooms, _)) room@(RoomIndex ri) |
|
98 |
| room == lobbyId = error "Cannot delete lobby" |
|
99 |
| otherwise = do |
|
100 |
clIds <- liftM roomClients' $ readElem rooms ri |
|
101 |
forM_ clIds (moveClientToLobby rnc) |
|
102 |
removeElem rooms ri |
|
103 |
||
104 |
||
105 |
removeClient :: MRoomsAndClients r c -> ClientIndex -> IO () |
|
106 |
removeClient (MRoomsAndClients (rooms, clients)) cl@(ClientIndex ci) = do |
|
107 |
RoomIndex ri <- liftM clientRoom' $ readElem clients ci |
|
108 |
modifyElem rooms (roomRemoveClient cl) ri |
|
109 |
removeElem clients ci |
|
110 |
||
111 |
||
3436
288fcbdb77b6
Make server build again (it's still useless though)
unc0rr
parents:
3435
diff
changeset
|
112 |
modifyRoom :: MRoomsAndClients r c -> (r -> r) -> RoomIndex -> IO () |
288fcbdb77b6
Make server build again (it's still useless though)
unc0rr
parents:
3435
diff
changeset
|
113 |
modifyRoom (MRoomsAndClients (rooms, _)) f (RoomIndex ri) = modifyElem rooms (\r -> r{room' = f $ room' r}) ri |
288fcbdb77b6
Make server build again (it's still useless though)
unc0rr
parents:
3435
diff
changeset
|
114 |
|
288fcbdb77b6
Make server build again (it's still useless though)
unc0rr
parents:
3435
diff
changeset
|
115 |
modifyClient :: MRoomsAndClients r c -> (c -> c) -> ClientIndex -> IO () |
288fcbdb77b6
Make server build again (it's still useless though)
unc0rr
parents:
3435
diff
changeset
|
116 |
modifyClient (MRoomsAndClients (_, clients)) f (ClientIndex ci) = modifyElem clients (\c -> c{client' = f $ client' c}) ci |
288fcbdb77b6
Make server build again (it's still useless though)
unc0rr
parents:
3435
diff
changeset
|
117 |
|
3425 | 118 |
moveClientInRooms :: MRoomsAndClients r c -> RoomIndex -> RoomIndex -> ClientIndex -> IO () |
119 |
moveClientInRooms (MRoomsAndClients (rooms, clients)) (RoomIndex riFrom) rt@(RoomIndex riTo) cl@(ClientIndex ci) = do |
|
120 |
modifyElem rooms (roomRemoveClient cl) riFrom |
|
121 |
modifyElem rooms (roomAddClient cl) riTo |
|
122 |
modifyElem clients (\c -> c{clientRoom' = rt}) ci |
|
123 |
||
124 |
||
125 |
moveClientToLobby :: MRoomsAndClients r c -> ClientIndex -> IO () |
|
126 |
moveClientToLobby rnc ci = do |
|
127 |
room <- clientRoomM rnc ci |
|
128 |
moveClientInRooms rnc room lobbyId ci |
|
129 |
||
130 |
||
131 |
moveClientToRoom :: MRoomsAndClients r c -> RoomIndex -> ClientIndex -> IO () |
|
132 |
moveClientToRoom rnc ri ci = moveClientInRooms rnc lobbyId ri ci |
|
133 |
||
134 |
||
135 |
clientRoomM :: MRoomsAndClients r c -> ClientIndex -> IO RoomIndex |
|
136 |
clientRoomM (MRoomsAndClients (_, clients)) (ClientIndex ci) = liftM clientRoom' (clients `readElem` ci) |
|
137 |
||
138 |
||
139 |
withRoomsAndClients :: MRoomsAndClients r c -> (IRoomsAndClients r c -> a) -> IO a |
|
140 |
withRoomsAndClients (MRoomsAndClients (rooms, clients)) f = |
|
141 |
withIStore2 rooms clients (\r c -> f $ IRoomsAndClients (r, c)) |
|
142 |
||
143 |
---------------------------------------- |
|
144 |
----------- IRoomsAndClients ----------- |
|
145 |
||
146 |
showRooms :: (Show r, Show c) => IRoomsAndClients r c -> String |
|
147 |
showRooms rnc@(IRoomsAndClients (rooms, clients)) = concatMap showRoom (allRooms rnc) |
|
148 |
where |
|
149 |
showRoom r = unlines $ ((show r) ++ ": " ++ (show $ room' $ rooms ! (unRoomIndex r))) : (map showClient (roomClients' $ rooms ! (unRoomIndex r))) |
|
150 |
showClient c = " " ++ (show c) ++ ": " ++ (show $ client' $ clients ! (unClientIndex c)) |
|
151 |
||
152 |
||
153 |
allRooms :: IRoomsAndClients r c -> [RoomIndex] |
|
154 |
allRooms (IRoomsAndClients (rooms, _)) = map RoomIndex $ indices rooms |
|
155 |
||
156 |
allClients :: IRoomsAndClients r c -> [ClientIndex] |
|
157 |
allClients (IRoomsAndClients (_, clients)) = map ClientIndex $ indices clients |
|
158 |
||
159 |
||
3435 | 160 |
clientRoom :: IRoomsAndClients r c -> ClientIndex -> RoomIndex |
161 |
clientRoom (IRoomsAndClients (_, clients)) (ClientIndex ci) = clientRoom' (clients ! ci) |
|
3425 | 162 |
|
163 |
client :: IRoomsAndClients r c -> ClientIndex -> c |
|
164 |
client (IRoomsAndClients (_, clients)) (ClientIndex ci) = client' (clients ! ci) |
|
3435 | 165 |
|
166 |
roomClients :: IRoomsAndClients r c -> RoomIndex -> [ClientIndex] |
|
167 |
roomClients (IRoomsAndClients (rooms, _)) (RoomIndex ri) = roomClients' $ (rooms ! ri) |