1 module RoomsAndClients(

     2     RoomIndex(),

     3     ClientIndex(),

     4     MRoomsAndClients(),

     5     IRoomsAndClients(),

     6     newRoomsAndClients,

     7     addRoom,

     8     addClient,

     9     removeRoom,

    10     removeClient,

    11     lobbyId,

    12     moveClientToLobby,

    13     moveClientToRoom,

    14     clientRoom,

    15     client,

    16     allClients,

    17     withRoomsAndClients,

    18     showRooms

    19     ) where

    20 

    21 

    22 import Store

    23 import Control.Monad

    24 

    25 

    26 data Room r = Room {

    27     roomClients' :: [ClientIndex],

    28     room' :: r

    29     }

    30 

    31 

    32 data Client c = Client {

    33     clientRoom' :: RoomIndex,

    34     client' :: c

    35     }

    36 

    37 

    38 newtype RoomIndex = RoomIndex ElemIndex

    39     deriving (Eq)

    40 newtype ClientIndex = ClientIndex ElemIndex

    41     deriving (Eq)

    42 

    43 instance Show RoomIndex where

    44     show (RoomIndex i) = 'r' : show i

    45 instance Show ClientIndex where

    46     show (ClientIndex i) = 'c' : show i

    47 

    48 unRoomIndex :: RoomIndex -> ElemIndex

    49 unRoomIndex (RoomIndex r) = r

    50 

    51 unClientIndex :: ClientIndex -> ElemIndex

    52 unClientIndex (ClientIndex c) = c

    53 

    54 

    55 newtype MRoomsAndClients r c = MRoomsAndClients (MStore (Room r), MStore (Client c))

    56 newtype IRoomsAndClients r c = IRoomsAndClients (IStore (Room r), IStore (Client c))

    57 

    58 

    59 lobbyId :: RoomIndex

    60 lobbyId = RoomIndex firstIndex

    61 

    62 

    63 newRoomsAndClients :: r -> IO (MRoomsAndClients r c)

    64 newRoomsAndClients r = do

    65     rooms <- newStore

    66     clients <- newStore

    67     let rnc = MRoomsAndClients (rooms, clients)

    68     ri <- addRoom rnc r

    69     when (ri /= lobbyId) $ error "Empty struct inserts not at firstIndex index"

    70     return rnc

    71 

    72 

    73 roomAddClient :: ClientIndex -> Room r -> Room r

    74 roomAddClient cl room = room{roomClients' = cl : roomClients' room}

    75 

    76 roomRemoveClient :: ClientIndex -> Room r -> Room r

    77 roomRemoveClient cl room = room{roomClients' = filter (/= cl) $ roomClients' room}

    78 

    79     

    80 addRoom :: MRoomsAndClients r c -> r -> IO RoomIndex

    81 addRoom (MRoomsAndClients (rooms, _)) room = do

    82     i <- addElem rooms (Room  [] room)

    83     return $ RoomIndex i

    84 

    85 

    86 addClient :: MRoomsAndClients r c -> c -> IO ClientIndex

    87 addClient (MRoomsAndClients (rooms, clients)) client = do

    88     i <- addElem clients (Client lobbyId client)

    89     modifyElem rooms (roomAddClient (ClientIndex i)) rid

    90     return $ ClientIndex i

    91     where

    92         rid = (\(RoomIndex i) -> i) lobbyId

    93 

    94 removeRoom :: MRoomsAndClients r c -> RoomIndex -> IO ()

    95 removeRoom rnc@(MRoomsAndClients (rooms, _)) room@(RoomIndex ri) 

    96     | room == lobbyId = error "Cannot delete lobby"

    97     | otherwise = do

    98         clIds <- liftM roomClients' $ readElem rooms ri

    99         forM_ clIds (moveClientToLobby rnc)

   100         removeElem rooms ri

   101 

   102 

   103 removeClient :: MRoomsAndClients r c -> ClientIndex -> IO ()

   104 removeClient (MRoomsAndClients (rooms, clients)) cl@(ClientIndex ci) = do

   105     RoomIndex ri <- liftM clientRoom' $ readElem clients ci

   106     modifyElem rooms (roomRemoveClient cl) ri

   107     removeElem clients ci

   108 

   109 

   110 moveClientInRooms :: MRoomsAndClients r c -> RoomIndex -> RoomIndex -> ClientIndex -> IO ()

   111 moveClientInRooms (MRoomsAndClients (rooms, clients)) (RoomIndex riFrom) rt@(RoomIndex riTo) cl@(ClientIndex ci) = do

   112     modifyElem rooms (roomRemoveClient cl) riFrom

   113     modifyElem rooms (roomAddClient cl) riTo

   114     modifyElem clients (\c -> c{clientRoom' = rt}) ci

   115 

   116 

   117 moveClientToLobby :: MRoomsAndClients r c -> ClientIndex -> IO ()

   118 moveClientToLobby rnc ci = do

   119     room <- clientRoomM rnc ci

   120     moveClientInRooms rnc room lobbyId ci

   121 

   122 

   123 moveClientToRoom :: MRoomsAndClients r c -> RoomIndex -> ClientIndex -> IO ()

   124 moveClientToRoom rnc ri ci = moveClientInRooms rnc lobbyId ri ci

   125 

   126 

   127 clientRoomM :: MRoomsAndClients r c -> ClientIndex -> IO RoomIndex

   128 clientRoomM (MRoomsAndClients (_, clients)) (ClientIndex ci) = liftM clientRoom' (clients `readElem` ci)

   129 

   130 

   131 withRoomsAndClients :: MRoomsAndClients r c -> (IRoomsAndClients r c -> a) -> IO a

   132 withRoomsAndClients (MRoomsAndClients (rooms, clients)) f =

   133     withIStore2 rooms clients (\r c -> f $ IRoomsAndClients (r, c))

   134 

   135 ----------------------------------------

   136 ----------- IRoomsAndClients -----------

   137 

   138 showRooms :: (Show r, Show c) => IRoomsAndClients r c -> String

   139 showRooms rnc@(IRoomsAndClients (rooms, clients)) = concatMap showRoom (allRooms rnc)

   140     where

   141     showRoom r = unlines $ ((show r) ++ ": " ++ (show $ room' $ rooms ! (unRoomIndex r))) : (map showClient (roomClients' $ rooms ! (unRoomIndex r)))

   142     showClient c = "    " ++ (show c) ++ ": " ++ (show $ client' $ clients ! (unClientIndex c))

   143 

   144 

   145 allRooms :: IRoomsAndClients r c -> [RoomIndex]

   146 allRooms (IRoomsAndClients (rooms, _)) = map RoomIndex $ indices rooms

   147 

   148 allClients :: IRoomsAndClients r c -> [ClientIndex]

   149 allClients (IRoomsAndClients (_, clients)) = map ClientIndex $ indices clients

   150 

   151 

   152 clientRoom :: ClientIndex -> IRoomsAndClients r c -> RoomIndex

   153 clientRoom (ClientIndex ci) (IRoomsAndClients (_, clients)) = clientRoom' (clients ! ci)

   154 

   155 client :: IRoomsAndClients r c -> ClientIndex -> c

   156 client (IRoomsAndClients (_, clients)) (ClientIndex ci) = client' (clients ! ci)