{-# LANGUAGE DeriveDataTypeable, GADTs, GeneralizedNewtypeDeriving, PackageImports, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-} module Main where import Control.Applicative((<$>)) import Control.Arrow ((***)) import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay) import Control.Concurrent.MVar -- (MVar, newEmptyMVar, readMVar, swapMVar) import qualified Control.Exception as E import Control.Monad ((<=<), forever, when) import Control.Monad.Operational import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan, dupChan, isEmptyChan) import Control.Monad.Reader import Control.Monad.State import "mtl" Control.Monad.Trans import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C import qualified Data.ByteString.UTF8 as U import Data.Data import Data.Maybe (fromJust, fromMaybe) import Data.Typeable import Data.List (intersperse) import qualified Network.Socket.ByteString as N import Data.Word(Word8) import qualified Data.Map as Map import Data.Map (Map) import Network (PortID(PortNumber), Socket, listenOn, sClose) import Network.Socket (accept) import System.Random import Text.ParserCombinators.ReadP (ReadP, choice, char, readP_to_S) import Happstack.State import Password listen :: PortID -> (Socket -> IO ()) -> IO () listen port handler = do socket <- listenOn port forever $ do (s,sa) <- accept socket forkIO $ handler s class Word8Enum a where toWord8 :: a -> Word8 fromWord8 :: Word8 -> a data Operation = Will | Wont | Do | Dont deriving (Eq, Ord, Read, Show) instance Word8Enum Operation where toWord8 Will = 251 toWord8 Wont = 252 toWord8 Do = 253 toWord8 Dont = 254 fromWord8 251 = Will fromWord8 252 = Wont fromWord8 253 = Do fromWord8 254 = Dont data Option = SuppressGoAhead | Status | Echo | TimingMark | TerminalType | WindowSize | TerminalSpeed | RemoteFlowControl | LineMode | EnvironmentVariables deriving (Eq, Ord, Read, Show) instance Word8Enum Option where toWord8 Echo = 1 toWord8 SuppressGoAhead = 3 toWord8 Status = 5 toWord8 TimingMark = 6 toWord8 TerminalType = 24 toWord8 WindowSize = 31 toWord8 TerminalSpeed = 32 toWord8 RemoteFlowControl = 33 toWord8 LineMode = 34 toWord8 EnvironmentVariables = 36 fromWord8 1 = Echo fromWord8 3 = SuppressGoAhead fromWord8 5 = Status fromWord8 6 = TimingMark fromWord8 24 = TerminalType fromWord8 31 = WindowSize fromWord8 32 = TerminalSpeed fromWord8 33 = RemoteFlowControl fromWord8 34 = LineMode fromWord8 36 = EnvironmentVariables data Command = Operation Operation Option | SubNegotiation SubNegotiation deriving (Eq, Ord, Read, Show) data SubNegotiation = WindowSizeOption Window deriving (Eq, Ord, Read, Show) data Window = Window { width1 :: Word8 , width0 :: Word8 , height1 :: Word8 , height0 :: Word8 } deriving (Eq, Ord, Read, Show) data TelnetI m a where SendIAC :: Command -> TelnetI m () SendChar :: Char -> TelnetI m () SendANSI :: ANSI -> TelnetI m () Recv :: TelnetI m (Either Command Char) ForkIO :: TelnetProgramT m () -> TelnetI m ThreadId type TelnetProgramT m a = ProgramT (TelnetI m) m a iac :: Word8 iac = 255 cmdToBs :: Command -> ByteString cmdToBs (Operation oper opt) = B.pack [ iac, toWord8 oper, toWord8 opt ] runTelnetIO :: Socket -> TelnetProgramT IO a -> IO a runTelnetIO s = eval <=< viewT where eval :: PromptT (TelnetI IO) IO a -> IO a eval (Return x) = return x eval (SendIAC cmd :>>= is) = do N.sendAll s (cmdToBs cmd) runTelnetIO s (is ()) eval (SendChar c :>>= is) = do N.sendAll s (U.fromString [c]) runTelnetIO s (is ()) eval (SendANSI ansi :>>= is) = do N.sendAll s (ansiToBs ansi) runTelnetIO s (is ()) eval (ForkIO prog :>>= is) = do tid <- forkIO (runTelnetIO s prog) runTelnetIO s (is tid) eval (Recv :>>= is) = do bs <- N.recv s 1 case B.head bs of c | c /= iac -> runTelnetIO s (is (Right (C.head bs))) | otherwise -> do bs <- N.recv s 1 case B.head bs of oper | oper >= 251 && oper <= 254 -> do bs <- N.recv s 1 case B.head bs of opt -> runTelnetIO s (is (Left (Operation (fromWord8 oper) (fromWord8 opt)))) | oper == 250 -> do bs <- N.recv s 1 case B.head bs of 31 -> do bs <- N.recv s 6 case B.unpack bs of [w1, w0, h1, h0, 255, 240] -> runTelnetIO s (is (Left (SubNegotiation (WindowSizeOption (Window w1 w0 h1 h0))))) | otherwise -> error $ "operation code not in range: " ++ show bs sendIAC :: Command -> TelnetProgramT m () sendIAC c = singleton (SendIAC c) sendChar :: Char -> TelnetProgramT m () sendChar c = singleton (SendChar c) recv :: TelnetProgramT m (Either Command Char) recv = singleton Recv -- * ANSI -- ** Cursor data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White | Normal deriving (Eq, Ord, Read, Show, Enum) data Intensity = Bright | Dim deriving (Eq, Ord, Read, Show, Enum) data Layer = Foreground | Background deriving (Eq, Ord, Read, Show, Enum) data Attribute = Clear | Intensity Intensity | Color Layer Color | Invert Bool deriving (Eq, Ord, Read, Show) data ANSI = PriorRow (Maybe Word8) | NextRow (Maybe Word8) | PriorColumn (Maybe Word8) | NextColumn (Maybe Word8) | NextLine (Maybe Word8) | PrevLine (Maybe Word8) | Attributes [Attribute] | EraseScreen | EraseCharacters (Maybe Word8) | EraseInLine EraseInLine | String ByteString | GotoRowCol Word8 Word8 | ScrollRegion Word8 Word8 | ShowCursor Bool deriving (Eq, Ord, Read, Show) data EraseInLine = ToEOL | ToBOL | EntireLine deriving (Eq, Ord, Read, Show) attributeToBs :: Attribute -> ByteString attributeToBs Clear = C.singleton '0' attributeToBs (Intensity Bright) = C.singleton '1' attributeToBs (Intensity Dim) = C.singleton '2' attributeToBs (Invert True) = C.singleton '7' attributeToBs (Invert False) = C.pack "27" attributeToBs (Color Foreground Black) = C.pack "30" attributeToBs (Color Foreground Red) = C.pack "31" attributeToBs (Color Foreground Green) = C.pack "32" attributeToBs (Color Foreground Yellow) = C.pack "33" attributeToBs (Color Foreground Blue) = C.pack "34" attributeToBs (Color Foreground Magenta) = C.pack "35" attributeToBs (Color Foreground Cyan) = C.pack "36" attributeToBs (Color Foreground White) = C.pack "37" attributeToBs (Color Foreground Normal) = C.pack "39" attributeToBs (Color Background Black) = C.pack "40" attributeToBs (Color Background Red) = C.pack "41" attributeToBs (Color Background Green) = C.pack "42" attributeToBs (Color Background Yellow) = C.pack "43" attributeToBs (Color Background Blue) = C.pack "44" attributeToBs (Color Background Magenta) = C.pack "45" attributeToBs (Color Background Cyan) = C.pack "46" attributeToBs (Color Background White) = C.pack "47" attributeToBs (Color Background Normal) = C.pack "49" attributeToStr :: Attribute -> String attributeToStr Clear = "0" attributeToStr (Intensity Bright) = "1" attributeToStr (Intensity Dim) = "2" attributeToStr (Invert True) = "7" attributeToStr (Invert False) = "27" attributeToStr (Color Foreground Black) = "30" attributeToStr (Color Foreground Red) = "31" attributeToStr (Color Foreground Green) = "32" attributeToStr (Color Foreground Yellow) = "33" attributeToStr (Color Foreground Blue) = "34" attributeToStr (Color Foreground Magenta) = "35" attributeToStr (Color Foreground Cyan) = "36" attributeToStr (Color Foreground White) = "37" attributeToStr (Color Foreground Normal) = "39" attributeToStr (Color Background Black) = "40" attributeToStr (Color Background Red) = "41" attributeToStr (Color Background Green) = "42" attributeToStr (Color Background Yellow) = "43" attributeToStr (Color Background Blue) = "44" attributeToStr (Color Background Magenta) = "45" attributeToStr (Color Background Cyan) = "46" attributeToStr (Color Background White) = "47" attributeToStr (Color Background Normal) = "49" csi :: [String] -> Char -> ByteString csi args code = C.pack ('\ESC' : '[' : (concat (intersperse ";" args)) ++ [code]) attributesToBs :: [Attribute] -> ByteString attributesToBs attrs = C.concat [ C.pack ['\ESC', '['] , C.intercalate (C.singleton ';') (map attributeToBs attrs) , C.singleton 'm' ] -- does not include CSI ansiToBs :: ANSI -> ByteString ansiToBs (PriorRow args) = csi (maybe [] (\i -> [show i]) args) 'A' ansiToBs (NextRow args) = csi (maybe [] (\i -> [show i]) args) 'B' ansiToBs (NextColumn args) = csi (maybe [] (\i -> [show i]) args) 'C' ansiToBs (PriorColumn args) = csi (maybe [] (\i -> [show i]) args) 'D' ansiToBs (NextLine args) = csi (maybe [] (\i -> [show i]) args) 'E' ansiToBs (PrevLine args) = csi (maybe [] (\i -> [show i]) args) 'F' ansiToBs (GotoRowCol row col) = csi [show row, show col] 'H' ansiToBs (EraseInLine eil) = csi (case eil of ToEOL -> ["0"] ; ToBOL -> ["1"] ; EntireLine -> ["2"]) 'J' ansiToBs (Attributes attrs) = csi (map attributeToStr attrs) 'm' ansiToBs EraseScreen = csi [show 2] 'J' ansiToBs (EraseCharacters args) = csi (maybe [] (\i -> [show i]) args) 'X' ansiToBs (ScrollRegion pt pb) = csi [show pt, show pb] 'r' ansiToBs (ShowCursor True) = csi ["?25"] 'h' ansiToBs (ShowCursor False) = csi ["?25"] 'l' ansiToBs (String bs) = bs sendANSI :: ANSI -> ProgramT (TelnetI m) n () sendANSI ansi = singleton (SendANSI ansi) text = sendANSI . String . U.fromString attributes :: [Attribute] -> TelnetProgramT m () attributes = sendANSI . Attributes color :: Layer -> Color -> Attribute color = Color invert :: Bool -> Attribute invert = Invert intensity :: Intensity -> Attribute intensity = Intensity priorRow :: ProgramT (TelnetI m) n () priorRow = sendANSI $ PriorRow Nothing priorRowN :: Word8 -> ProgramT (TelnetI m) n () priorRowN = sendANSI . PriorRow . Just priorColumn :: ProgramT (TelnetI m) n () priorColumn = sendANSI $ PriorColumn Nothing eraseScreen :: ProgramT (TelnetI m) n () eraseScreen = sendANSI EraseScreen eraseInLine :: EraseInLine -> TelnetProgramT IO () eraseInLine eil = sendANSI (EraseInLine eil) eraseCharacters n = sendANSI (EraseCharacters (Just n)) eraseCharacter = sendANSI (EraseCharacters Nothing) gotoRowCol r c = sendANSI (GotoRowCol r c) nextLine n = sendANSI (NextLine n) scrollRegion r c = sendANSI (ScrollRegion r c) hideCursor = sendANSI (ShowCursor False) showCursor = sendANSI (ShowCursor True) data EchoMode = EchoOff | EchoOn | EchoStar recvLine :: EchoMode -> TelnetProgramT IO String recvLine eMode = recv' [] where recv' acc = do c <- recvEcho eMode case c of '\DEL' -> case acc of [] -> do recv' acc _ -> do priorColumn sendChar ' ' priorColumn recv' (init acc) '\r' -> do recvEcho eMode nextLine Nothing return acc _ -> recv' (acc++[c]) -- FIXME: this drops any commands that come in recvEcho :: EchoMode -> TelnetProgramT IO Char recvEcho eMode = do c <- recv case c of (Left cmd) -> recvEcho eMode (Right '\DEL') -> return '\DEL' (Right '\r') -> return '\r' (Right '\n') -> return '\n' (Right '\NUL') -> return '\NUL' (Right c) -> do case eMode of EchoOff -> return () EchoOn -> sendChar c EchoStar -> sendChar '*' return c -- see if SampleVar is what we actually want instead of MVar reallyPutMVar mvar v = do b <- tryPutMVar mvar v when (not b) $ do tryTakeMVar mvar reallyPutMVar mvar v -- Multiplayer Dungeon Game {- The Dungeon Issues: - There is a central server which is responsible for all screen drawing. - the slowest client should not slow down the whole system - it's a realtime, multiplayer environment, so nethack like alternation and blocking is not good Drawing the playing field: For people viewing the same room, there is a lot of common elements which can be drawn because they are the same for each player. But each player also has view specific information as well. For example, the players character should be easy to distinguish from the other players. Interleaving the input/output. There is a two way channel for each player. We can send characters to their screen, and receive characters from their keyboard. receiving a character is a blocking operation. However, it need only block recieving - we should be able to send screen updates while blocking on a read. So, we can have two threads for each user, one to receive commands, and one to send commands. For state we have: - a global map of the dungeon which tracks all the character, item, and wall positions - the list of users and their stats / items - list of currently active users - list of objects and their properties Is an object position store in the map, or with the object properties? To test for collisions, it would be easiest if everything was stored in the map, because then we only have to see what is in the adjacent square, instead of checking the position of every object. -} data LetterState = LetterState { windowSize :: Maybe (Word8, Word8) , cmdStr :: String , needsRedraw :: Bool } data Item = Wall | Ground | Lambda | Space | Player String objectChar :: Item -> Char objectChar Wall = '#' objectChar Ground = '.' objectChar Space = ' ' objectChar Lambda = 'λ' objectChar (Player _) = '@' instance Show Item where show Wall = "#" show Ground = "." show Space = " " objectReadP :: ReadP Item objectReadP = choice [ char '#' >> return Wall , char '.' >> return Ground , char ' ' >> return Space , char 'λ' >> return Lambda ] instance Read Item where readsPrec _ = readP_to_S objectReadP type Pos = (Word8, Word8) type DungeonMap = Map Pos [Item] type Players = Map String Pos type Lambdas = Map String Int data DungeonState = DungeonState { s_dungeonMap :: DungeonMap , s_players :: Players , s_msgs :: [String] } data PlayerData = PlayerData { wins :: Int , password :: Password } deriving (Eq, Data, Typeable) instance Version PlayerData $(deriveSerialize ''PlayerData) newtype PlayerAssets = PlayerAssets (Map String PlayerData) deriving (Eq, Data, Typeable) instance Version PlayerAssets $(deriveSerialize ''PlayerAssets) instance Component PlayerAssets where type Dependencies PlayerAssets = End initialValue = PlayerAssets Map.empty incWins :: String -> Update PlayerAssets Int incWins player = do (PlayerAssets m) <- get let m' = Map.update updateWins player m put $ PlayerAssets $ m' return (wins $ fromJust $ Map.lookup player m') where updateWins :: PlayerData -> Maybe PlayerData updateWins pd = Just $ pd { wins = succ (wins pd) } hasLogin :: String -> Query PlayerAssets Bool hasLogin player = do (PlayerAssets m) <- ask return $ player `Map.member` m authenticate :: String -> String -> Query PlayerAssets Bool authenticate u p = do (PlayerAssets m) <- ask case Map.lookup u m of Nothing -> return False (Just playerData) -> return $ checkPassword (password playerData) p newUser :: String -> Password -> Update PlayerAssets (Maybe String) newUser username password = do (PlayerAssets m) <- get case Map.lookup username m of (Just _) -> return (Just $ username ++ " already in use. (Someone must have just taken it).") Nothing -> do let m' = Map.insert username (PlayerData { wins = 0 , password = password }) m put (PlayerAssets m') return Nothing $(mkMethods ''PlayerAssets ['incWins,'hasLogin,'authenticate,'newUser]) parseMap :: String -> DungeonMap parseMap level = parseMap' (1,1) Map.empty level where parseMap' (col, row) m "" = m parseMap' (col, row) m ('\n':rest) = parseMap' (1, succ row) m rest parseMap' (col, row) m (c :rest) = case read [c] of Space -> parseMap' (succ col, row) m rest Lambda -> parseMap' (succ col, row) (Map.insert (col, row) [Lambda, Ground] m) rest o -> parseMap' (succ col, row) (Map.insert (col, row) [o] m) rest getLogin :: TelnetProgramT IO String getLogin = do text "player name: " u <- recvLine EchoOn existing <- lift $ query $ HasLogin u case existing of True -> do p <- getPassword a <- lift $ query $ Authenticate u p case a of True -> return u False -> do text "invalid username/password" nextLine Nothing getLogin False -> do text "player does not exist. Create new? y/n: " r <- recvEcho EchoOff nextLine Nothing case r of 'y' -> do p <- getNewPassword m <- lift $ update $ NewUser u p case m of Nothing -> return u (Just err) -> do text err nextLine Nothing getLogin _ -> getLogin getPassword :: TelnetProgramT IO String getPassword = do text "password: " recvLine EchoStar getNewPassword :: TelnetProgramT IO Password getNewPassword = do text "password: " p1 <- recvLine EchoStar text "password (confirm): " p2 <- recvLine EchoStar if p1 == p2 then lift $ newPassword p1 else do text "passwords do not match." nextLine Nothing getNewPassword data Move = Join | Part | Move Direction | System String deriving Show data Direction = U | D | L | R deriving Show dungeon :: MVar String -> Chan DungeonState -> Chan (String, Move) -> TelnetProgramT IO () dungeon loginMVar pChan mChan = do sendIAC (Operation Will SuppressGoAhead) sendIAC (Operation Will Echo) sendIAC (Operation Wont LineMode) sendIAC (Operation Do WindowSize) attributes [Intensity Dim, Color Foreground White, Color Background Normal] eraseScreen mvar <- lift newEmptyMVar let state = LetterState { windowSize = Nothing , cmdStr = "" , needsRedraw = True } state' <- initLoop mvar state -- lift $ putStrLn "init finished" banner login <- getLogin eraseScreen lift $ writeChan mChan (login, Join) lift $ reallyPutMVar loginMVar login tid <- singleton (ForkIO $ dungeonAnimation login mvar pChan) inputLoop mvar state login showCursor lift $ killThread tid cleanup where cleanup = do showCursor attributes [intensity Bright, color Foreground Normal] eraseScreen gotoRowCol 1 1 initLoop mvar state = do c <- recv case c of (Left cmd@(SubNegotiation (WindowSizeOption (Window w1 w0 h1 h0)))) -> do -- lift $ print cmd let state' = state { windowSize = Just (w0, h0) } lift $ reallyPutMVar mvar state' return state' (Left cmd) -> do -- lift $ print cmd initLoop mvar state (Right c) -> do -- lift $ writeChan cChan c -- lift $ print c initLoop mvar state inputLoop mvar state login = do c <- recv case c of (Left cmd@(SubNegotiation (WindowSizeOption (Window w1 w0 h1 h0)))) -> do -- lift $ print cmd let state' = state { windowSize = Just (w0, h0) , needsRedraw = True } -- TODO: add needs erase / redraw lift $ reallyPutMVar mvar state' inputLoop mvar state' login (Left cmd) -> do -- lift $ print cmd inputLoop mvar state login (Right '\ESC') -> do inputLoop mvar (state { cmdStr = "\ESC" }) login (Right '[') | (cmdStr state) == "\ESC" -> do inputLoop mvar (state { cmdStr = "\ESC[" }) login (Right c) | (cmdStr state) == "\ESC[" -> do case c of 'A' -> lift $ writeChan mChan (login, Move U ) 'B' -> lift $ writeChan mChan (login, Move D) 'C' -> lift $ writeChan mChan (login, Move R) 'D' -> lift $ writeChan mChan (login, Move L) _ -> return () inputLoop mvar (state { cmdStr = "" }) login (Right 'q') -> do lift $ writeChan mChan (login, Part) (Right c) -> do -- lift $ writeChan cChan c -- lift $ print c inputLoop mvar state login -- blocks if the channel is empty -- on waking, or if channel is not empty, read from channel until we have gotten the last item currently available readChanLast :: Chan a -> IO a readChanLast chan = do a <- readChan chan e <- isEmptyChan chan if e then return a else readChanLast chan dungeonAnimation :: String -> MVar LetterState -> Chan DungeonState -> ProgramT (TelnetI IO) IO () dungeonAnimation player mvar pChan = do hideCursor dMVar <- lift $ newEmptyMVar forever $ animationLoop dMVar where animationLoop dMVar = do (DungeonState dmap players msgs) <- lift $ readChanLast pChan -- lift $ takeMVar dMVar let myPos = Map.lookup player players (LetterState windowSize c needsRedraw) <- lift $ readMVar mvar case windowSize of Nothing -> return () (Just (cols, rows)) -> do when needsRedraw (do eraseScreen -- this is a possible race condition lift $ reallyPutMVar mvar (LetterState windowSize c False)) let objects = Map.toAscList dmap mapM_ (\ ((col, row), obj) -> if (Just (col, row)) == myPos then do gotoRowCol row col attributes [Intensity Bright] sendChar (objectChar (head obj)) attributes [Intensity Dim] else gotoRowCol row col >> drawItem obj) objects mapM_ (\(msg, row) -> do gotoRowCol row 1 text msg eraseInLine ToEOL ) (zip msgs [16..]) drawItem (Wall:_) = sendChar '#' drawItem (Ground:_) = sendChar '.' drawItem (Lambda:_) = do attributes [ Intensity Bright , Color Foreground Yellow ] sendChar 'λ' attributes [ Intensity Dim , Color Foreground White ] drawItem (Space:_) = sendChar ' ' drawItem ((Player _):_) = sendChar '@' main :: IO () main = do pChan <- newChan mChan <- newChan level <- fmap parseMap (readFile "map.txt") forkIO $ masterLoop pChan mChan level Map.empty Map.empty [] control <- startSystemState (Proxy :: Proxy PlayerAssets) tid <- forkIO $ listen (PortNumber (toEnum 2525)) $ \s -> do pChan' <- dupChan pChan loginMVar <- newEmptyMVar runTelnetIO s (dungeon loginMVar pChan' mChan) `E.onException` (do m <- tryTakeMVar loginMVar case m of Nothing -> return () (Just l) -> writeChan mChan (l, Part) ) threadDelay (1*10^5) sClose s waitForTermination writeChan mChan ("system", System "Restarting server, sorry.") writeChan mChan ("system", System "Restarting server, sorry.") writeChan mChan ("system", System "Restarting server, sorry.") writeChan mChan ("system", System "Restarting server, sorry.") writeChan mChan ("system", System "Restarting server, sorry.") killThread tid -- this does not actually kill any open connections createCheckpoint control shutdownSystem control where masterLoop :: Chan DungeonState -> Chan (String, Move) -> DungeonMap -> Players -> Lambdas -> [String] -> IO () masterLoop pChan mChan dungeon players lambdas msgs = do let dMap' = foldr (\(player, pos) m -> Map.insert pos [Player player] m) dungeon (Map.toAscList players) writeChan pChan (DungeonState dMap' players msgs) (player, move) <- readChan mChan case move of Join -> do let pos = (3,3) players' = Map.insert player pos players -- writeChan pChan players' masterLoop pChan mChan dungeon players' lambdas (addMsg (player ++ " has joined the game.") msgs) Move d -> do let (msgs', pos) = case Map.lookup player players of Nothing -> (addMsg (player ++ " has rejoined the game.") msgs, (3,3)) (Just p) -> (msgs, p) case pos of ((col, row)) -> let newPos = case d of U -> (col , row - 1) D -> (col , row + 1) L -> (col - 1, row ) R -> (col + 1, row ) in case Map.lookup newPos dungeon of (Just [Ground]) -> do -- putStrLn "move permitted." let players' = Map.insert player newPos players -- writeChan pChan players' masterLoop pChan mChan dungeon players' lambdas msgs' (Just (Lambda:rest)) -> do -- putStrLn "move permitted." let lambdas' = Map.insertWith (+) player 1 lambdas count = fromJust $ Map.lookup player lambdas' (msg, lambdas'') <- if count >= 10 then do wins <- update $ IncWins player return (player ++ " wins this round with " ++ show count ++ " lambdas. " ++ show wins ++ (if wins == 1 then " win" else " wins") ++ " total.", Map.empty) else return (player ++ " has collected " ++ show count ++ (if count == 1 then " lambda." else " lambdas."), lambdas') let players' = Map.insert player newPos players -- writeChan pChan players' dungeon' = Map.insert newPos rest dungeon -- remove lambda dungeon'' <- genLambda dungeon' masterLoop pChan mChan dungeon'' players' lambdas'' (addMsg msg msgs') _ -> masterLoop pChan mChan dungeon players lambdas msgs' Part -> do let players' = Map.delete player players -- writeChan pChan players' masterLoop pChan mChan dungeon players' lambdas (addMsg (player ++ " has left the game.") msgs) System msg -> do masterLoop pChan mChan dungeon players lambdas (addMsg msg msgs) addMsg :: String -> [String] -> [String] addMsg msg msgs = msg : take 9 msgs genLambda :: DungeonMap -> IO DungeonMap genLambda dMap = pickLocation where (min_col, min_row) = (toInteger *** toInteger) $ fst $ Map.findMin dMap (max_col, max_row) = (toInteger *** toInteger) $ fst $ Map.findMax dMap pickLocation = do col <- randomRIO (min_col, max_col) row <- randomRIO (min_row, max_row) let pos = (fromInteger col, fromInteger row) case Map.lookup pos dMap of (Just [Ground]) -> return $ Map.insert pos [Lambda, Ground] dMap _ -> pickLocation banner = do eraseScreen showCursor gotoRowCol 6 6 attributes [Intensity Bright, Color Foreground White, Color Background Normal] text "Welcome to" gotoRowCol 8 7 attributes [Intensity Bright, Color Foreground Blue] text "The Order of the" gotoRowCol 8 1 attributes [Intensity Bright, Color Foreground Yellow] gotoRowCol 4 27 text "λλ" gotoRowCol 5 26 text "λ λ" gotoRowCol 6 30 text "λ" gotoRowCol 7 31 text "λ" gotoRowCol 8 32 text "λ" gotoRowCol 9 31 text "λ λ" gotoRowCol 10 30 text "λ λ" gotoRowCol 11 29 text "λ λ" gotoRowCol 12 28 text "λ λ" gotoRowCol 13 27 text "λ λ" attributes [Intensity Dim, Color Foreground White] gotoRowCol 14 1