1 module RoomsAndClients( |
|
2 RoomIndex(), |
|
3 ClientIndex(), |
|
4 MRoomsAndClients(), |
|
5 IRoomsAndClients(), |
|
6 newRoomsAndClients, |
|
7 addRoom, |
|
8 addClient, |
|
9 removeRoom, |
|
10 removeClient, |
|
11 modifyRoom, |
|
12 modifyClient, |
|
13 lobbyId, |
|
14 moveClientToLobby, |
|
15 moveClientToRoom, |
|
16 clientRoomM, |
|
17 clientExists, |
|
18 client, |
|
19 room, |
|
20 client'sM, |
|
21 room'sM, |
|
22 allClientsM, |
|
23 clientsM, |
|
24 roomClientsM, |
|
25 roomClientsIndicesM, |
|
26 withRoomsAndClients, |
|
27 allRooms, |
|
28 allClients, |
|
29 clientRoom, |
|
30 showRooms, |
|
31 roomClients |
|
32 ) where |
|
33 |
|
34 |
|
35 import Store |
|
36 import Control.Monad |
|
37 |
|
38 |
|
39 data Room r = Room { |
|
40 roomClients' :: [ClientIndex], |
|
41 room' :: r |
|
42 } |
|
43 |
|
44 |
|
45 data Client c = Client { |
|
46 clientRoom' :: RoomIndex, |
|
47 client' :: c |
|
48 } |
|
49 |
|
50 |
|
51 newtype RoomIndex = RoomIndex ElemIndex |
|
52 deriving (Eq) |
|
53 newtype ClientIndex = ClientIndex ElemIndex |
|
54 deriving (Eq, Show, Read, Ord) |
|
55 |
|
56 instance Show RoomIndex where |
|
57 show (RoomIndex i) = 'r' : show i |
|
58 |
|
59 unRoomIndex :: RoomIndex -> ElemIndex |
|
60 unRoomIndex (RoomIndex r) = r |
|
61 |
|
62 unClientIndex :: ClientIndex -> ElemIndex |
|
63 unClientIndex (ClientIndex c) = c |
|
64 |
|
65 |
|
66 newtype MRoomsAndClients r c = MRoomsAndClients (MStore (Room r), MStore (Client c)) |
|
67 newtype IRoomsAndClients r c = IRoomsAndClients (IStore (Room r), IStore (Client c)) |
|
68 |
|
69 |
|
70 lobbyId :: RoomIndex |
|
71 lobbyId = RoomIndex firstIndex |
|
72 |
|
73 |
|
74 newRoomsAndClients :: r -> IO (MRoomsAndClients r c) |
|
75 newRoomsAndClients r = do |
|
76 rooms <- newStore |
|
77 clients <- newStore |
|
78 let rnc = MRoomsAndClients (rooms, clients) |
|
79 ri <- addRoom rnc r |
|
80 when (ri /= lobbyId) $ error "Empty struct inserts not at firstIndex index" |
|
81 return rnc |
|
82 |
|
83 |
|
84 roomAddClient :: ClientIndex -> Room r -> Room r |
|
85 roomAddClient cl room = let cls = cl : roomClients' room; nr = room{roomClients' = cls} in cls `seq` nr `seq` nr |
|
86 |
|
87 roomRemoveClient :: ClientIndex -> Room r -> Room r |
|
88 roomRemoveClient cl room = let cls = filter (/= cl) $ roomClients' room; nr = room{roomClients' = cls} in cls `seq` nr `seq` nr |
|
89 |
|
90 |
|
91 addRoom :: MRoomsAndClients r c -> r -> IO RoomIndex |
|
92 addRoom (MRoomsAndClients (rooms, _)) room = do |
|
93 i <- addElem rooms (Room [] room) |
|
94 return $ RoomIndex i |
|
95 |
|
96 |
|
97 addClient :: MRoomsAndClients r c -> c -> IO ClientIndex |
|
98 addClient (MRoomsAndClients (rooms, clients)) client = do |
|
99 i <- addElem clients (Client lobbyId client) |
|
100 modifyElem rooms (roomAddClient (ClientIndex i)) (unRoomIndex lobbyId) |
|
101 return $ ClientIndex i |
|
102 |
|
103 removeRoom :: MRoomsAndClients r c -> RoomIndex -> IO () |
|
104 removeRoom rnc@(MRoomsAndClients (rooms, _)) room@(RoomIndex ri) |
|
105 | room == lobbyId = error "Cannot delete lobby" |
|
106 | otherwise = do |
|
107 clIds <- liftM roomClients' $ readElem rooms ri |
|
108 forM_ clIds (moveClientToLobby rnc) |
|
109 removeElem rooms ri |
|
110 |
|
111 |
|
112 removeClient :: MRoomsAndClients r c -> ClientIndex -> IO () |
|
113 removeClient (MRoomsAndClients (rooms, clients)) cl@(ClientIndex ci) = do |
|
114 RoomIndex ri <- liftM clientRoom' $ readElem clients ci |
|
115 modifyElem rooms (roomRemoveClient cl) ri |
|
116 removeElem clients ci |
|
117 |
|
118 |
|
119 modifyRoom :: MRoomsAndClients r c -> (r -> r) -> RoomIndex -> IO () |
|
120 modifyRoom (MRoomsAndClients (rooms, _)) f (RoomIndex ri) = modifyElem rooms (\r -> r{room' = f $ room' r}) ri |
|
121 |
|
122 modifyClient :: MRoomsAndClients r c -> (c -> c) -> ClientIndex -> IO () |
|
123 modifyClient (MRoomsAndClients (_, clients)) f (ClientIndex ci) = modifyElem clients (\c -> c{client' = f $ client' c}) ci |
|
124 |
|
125 moveClientInRooms :: MRoomsAndClients r c -> RoomIndex -> RoomIndex -> ClientIndex -> IO () |
|
126 moveClientInRooms (MRoomsAndClients (rooms, clients)) (RoomIndex riFrom) rt@(RoomIndex riTo) cl@(ClientIndex ci) = do |
|
127 modifyElem rooms (roomRemoveClient cl) riFrom |
|
128 modifyElem rooms (roomAddClient cl) riTo |
|
129 modifyElem clients (\c -> c{clientRoom' = rt}) ci |
|
130 |
|
131 |
|
132 moveClientToLobby :: MRoomsAndClients r c -> ClientIndex -> IO () |
|
133 moveClientToLobby rnc ci = do |
|
134 room <- clientRoomM rnc ci |
|
135 moveClientInRooms rnc room lobbyId ci |
|
136 |
|
137 |
|
138 moveClientToRoom :: MRoomsAndClients r c -> RoomIndex -> ClientIndex -> IO () |
|
139 moveClientToRoom rnc ri ci = moveClientInRooms rnc lobbyId ri ci |
|
140 |
|
141 |
|
142 clientExists :: MRoomsAndClients r c -> ClientIndex -> IO Bool |
|
143 clientExists (MRoomsAndClients (_, clients)) (ClientIndex ci) = elemExists clients ci |
|
144 |
|
145 clientRoomM :: MRoomsAndClients r c -> ClientIndex -> IO RoomIndex |
|
146 clientRoomM (MRoomsAndClients (_, clients)) (ClientIndex ci) = liftM clientRoom' (clients `readElem` ci) |
|
147 |
|
148 client'sM :: MRoomsAndClients r c -> (c -> a) -> ClientIndex -> IO a |
|
149 client'sM (MRoomsAndClients (_, clients)) f (ClientIndex ci) = liftM (f . client') (clients `readElem` ci) |
|
150 |
|
151 room'sM :: MRoomsAndClients r c -> (r -> a) -> RoomIndex -> IO a |
|
152 room'sM (MRoomsAndClients (rooms, _)) f (RoomIndex ri) = liftM (f . room') (rooms `readElem` ri) |
|
153 |
|
154 allClientsM :: MRoomsAndClients r c -> IO [ClientIndex] |
|
155 allClientsM (MRoomsAndClients (_, clients)) = liftM (map ClientIndex) $ indicesM clients |
|
156 |
|
157 clientsM :: MRoomsAndClients r c -> IO [c] |
|
158 clientsM (MRoomsAndClients (_, clients)) = indicesM clients >>= mapM (\ci -> liftM client' $ readElem clients ci) |
|
159 |
|
160 roomClientsIndicesM :: MRoomsAndClients r c -> RoomIndex -> IO [ClientIndex] |
|
161 roomClientsIndicesM (MRoomsAndClients (rooms, clients)) (RoomIndex ri) = liftM roomClients' (rooms `readElem` ri) |
|
162 |
|
163 roomClientsM :: MRoomsAndClients r c -> RoomIndex -> IO [c] |
|
164 roomClientsM (MRoomsAndClients (rooms, clients)) (RoomIndex ri) = liftM roomClients' (rooms `readElem` ri) >>= mapM (\(ClientIndex ci) -> liftM client' $ readElem clients ci) |
|
165 |
|
166 withRoomsAndClients :: MRoomsAndClients r c -> (IRoomsAndClients r c -> a) -> IO a |
|
167 withRoomsAndClients (MRoomsAndClients (rooms, clients)) f = |
|
168 withIStore2 rooms clients (\r c -> f $ IRoomsAndClients (r, c)) |
|
169 |
|
170 ---------------------------------------- |
|
171 ----------- IRoomsAndClients ----------- |
|
172 |
|
173 showRooms :: (Show r, Show c) => IRoomsAndClients r c -> String |
|
174 showRooms rnc@(IRoomsAndClients (rooms, clients)) = concatMap showRoom (allRooms rnc) |
|
175 where |
|
176 showRoom r = unlines $ ((show r) ++ ": " ++ (show $ room' $ rooms ! (unRoomIndex r))) : (map showClient (roomClients' $ rooms ! (unRoomIndex r))) |
|
177 showClient c = " " ++ (show c) ++ ": " ++ (show $ client' $ clients ! (unClientIndex c)) |
|
178 |
|
179 |
|
180 allRooms :: IRoomsAndClients r c -> [RoomIndex] |
|
181 allRooms (IRoomsAndClients (rooms, _)) = map RoomIndex $ indices rooms |
|
182 |
|
183 allClients :: IRoomsAndClients r c -> [ClientIndex] |
|
184 allClients (IRoomsAndClients (_, clients)) = map ClientIndex $ indices clients |
|
185 |
|
186 clientRoom :: IRoomsAndClients r c -> ClientIndex -> RoomIndex |
|
187 clientRoom (IRoomsAndClients (_, clients)) (ClientIndex ci) = clientRoom' (clients ! ci) |
|
188 |
|
189 client :: IRoomsAndClients r c -> ClientIndex -> c |
|
190 client (IRoomsAndClients (_, clients)) (ClientIndex ci) = client' (clients ! ci) |
|
191 |
|
192 room :: IRoomsAndClients r c -> RoomIndex -> r |
|
193 room (IRoomsAndClients (rooms, _)) (RoomIndex ri) = room' (rooms ! ri) |
|
194 |
|
195 roomClients :: IRoomsAndClients r c -> RoomIndex -> [ClientIndex] |
|
196 roomClients (IRoomsAndClients (rooms, _)) (RoomIndex ri) = roomClients' $ (rooms ! ri) |
|