gameServer/RoomsAndClients.hs
changeset 4588 5ef5415c4ee1
parent 4529 467ab0685890
parent 4586 4ba4f021070f
child 4647 20b982afbe6e
equal deleted inserted replaced
4529:467ab0685890 4588:5ef5415c4ee1
     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)