Document everything exported
[darcs-mirror-haskell-partty.git] / Partty.hs
1 {-# LANGUAGE FlexibleContexts #-}
2
3 -- © 2008 Joachim Breitner
4
5 -- | This module provides a versatile framework to write contestant in the party
6 --   programming game introduced at the GPN7 in Karlsruhe by dividuum.
7 --
8 --   It uses a callback pattern, that is it runs /\"most of the time\"/ and user code will
9 --   only be called upon certain events.
10  
11 module Partty
12         ( -- * Invoking Partty
13           runPartty
14         , parttyMain
15           -- * Interaction Hooks
16         , DayCallback
17         , DayMonad
18         , NightCallback
19         , NightMonad
20           -- * Message types
21         , DayMessage(..)
22         , NightResult(..)
23         , ClientMessage(..)
24           -- * State
25         , ParttyState(..)
26           -- * Type synonyms and helpers
27         , Player
28         , Day
29         , Place
30         , Hint(..)
31         , Score(..)
32
33           -- * Reacting 
34         , send
35           
36           -- * Convenience IO
37         , say
38
39           -- * Gathering game statistics
40         , statsMain
41         )
42 where
43
44 import qualified Data.Map as M
45 import Data.Map (Map)
46 import Data.List
47 import Data.Maybe
48 import Control.Monad.State
49 import Control.Monad.Reader
50 import Control.Monad.Writer
51 import Network
52 import System.IO
53 import System.Environment
54
55 type Player = String
56 type Day = Int
57 type Place = Int
58
59 -- | A 'Hint' is a message that can be sent or received. It is either
60 data Hint = PartyAt Place                               -- ^ A statement where the party will be
61           | NoPartyAt Place                             -- ^ A statement where no party will be
62           | Liar Player                                 -- ^ A claim that someone is a liar
63           | NoLiar Player                               -- ^ A claim of trustworthiness
64      deriving (Show)
65
66 -- | A 'Score' gives information about the success of a party
67 data Score = NoScore                                    -- ^ You were not at the party
68            | ToFew                                      -- ^ There were not enough people at the party
69            | Scored                                     -- ^ The party was great
70                      deriving (Show)
71
72 data IncomingMessage = InternalMessage InternalMessage
73                      | DayMessage      DayMessage
74                      | NightMessage    NightResult   
75                      | ComplexInput    (Handle -> ParttyState -> IO (IncomingMessage, ParttyState))
76
77 instance Show IncomingMessage where
78         show (InternalMessage m) = "InternalMessage ("++ show m ++")"
79         show (DayMessage m)      = "DayMessage ("++ show m ++")"
80         show (NightMessage m)    = "NightMessage ("++ show m ++")"
81         show (ComplexInput _)    = "<ComplexInput>"
82
83 -- | A 'DayMessage' is recevied by the server and given to the user via the 'DayCallback',
84 --   so it can be reacted upon. It can be one of these:
85 data DayMessage      = DayStarts Int                    -- ^ The day (with a number) starts
86                      | DayEndsIn Int                    -- ^ The day finishes in so many seconds
87                      | DayEnds                          -- ^ The day ends
88                      | GotHint Player Hint              -- ^ A 'Hint' was recevied by this 'Player'
89                      | PlayerEnter Player Place         -- ^ A 'Player' (maybe you) has entered 'Place'
90                      | PlayerLeave Player Place         -- ^ A 'Player' (maybe you) has left 'Place'
91                      deriving (Show)
92
93
94 -- | A 'NightMessage' is given to the 'NightCallback' after each night has ended. It carries 
95 --   these pieces of information:
96 data NightResult     = NightResult
97                      { nrDay :: Day                     -- ^ The number of the day
98                      , nrPartyAt :: Place               -- ^ Where the party was
99                      , nrPlayersAt :: [(Player, Place)] -- ^ Where the players were
100                      , nrScore :: Score                 -- ^ Your score
101                      }
102                      deriving (Show)
103
104 -- Pure bookkeeping events
105 data InternalMessage = MyPlayerId Player
106                      | Welcome
107                      | PlayerJoined String
108                      | PlayerLeft String
109                      | GameStarting
110                      | GameEnds
111                      | MyIdIs Player
112                      | ActionsLeft Int
113                      | PlayerList [Player]
114                      | ScoreList [(Player, Int)]
115                      | NameList [(Player, String)]
116                      | Noise
117                      | PartyHint Place
118                      | PlayerAt Player Place
119                      | NightStarts
120                      | NightEnds
121                      | GotScore Score
122                      | NewContact Player
123                      | LostContact Player
124                      deriving (Show)
125
126 -- | A 'ClientMessage' is what you can send to the server. It is one of:
127 data ClientMessage = Tell Player Hint                   -- ^ Giving a 'Hint' to a 'Player'
128                    | Goto Place                         -- ^ Go to 'Place'
129                      deriving (Show)
130
131 -- | The 'ParttyState' contains all information that this module has obtained about the game.
132 data ParttyState = ParttyState
133         { psMyName      :: Player                       -- ^ The current player id
134         , psLoginName   :: String                       -- ^ The loginname
135         , psDay         :: Day                          -- ^ The current day
136         , psHistory     :: [NightResult]                -- ^ The results of the previous days
137         , psHintHistory :: [(Day, Player, Hint)]        -- ^ All hints received by players, and when
138         , psPlace       :: Place                        -- ^ Where we are
139         , psPlayers     :: [String]                     -- ^ The login names of all present players
140         , psPlayersHere :: [Player]                     -- ^ Who is were we are
141         , psActionsLeft :: Int                          -- ^ How many actions are left before the callback
142         , psPartyPlace  :: Maybe Place                  -- ^ If we know where the party is today, this is 'Just' the 'Place'
143         , psFriends     :: [Player]                     -- ^ People we have partied with
144         }
145
146 -- | The 'DayCallback' type alias refers to the argument of 'runPartty'. It is a function
147 --   that takes an incoming 'DayMessage' and reacts on it, using the 'DayMonad'.
148 type DayCallback d   = DayMessage -> DayMonad d ()
149
150 -- | The 'NightCallback' type alias refers to the argument of 'runPartty'. It is a function
151 --   that takes the 'NightResult' that is emitted after each day and reacts on it, using the
152 --   'NightMonad'.
153 type NightCallback d = NightResult -> NightMonad d ()
154
155
156 -- | The 'DayMonad' is where the day callback runs in. Besides direct IO, which can be used using
157 --   the 'liftIO' function, it provides:
158 --    
159 --   * A 'MonadWriter' interface to send a 'ClientMessage' to the server. This should be used
160 --     with the 'send' function.
161 --
162 --   * A 'MonadReader' 'ParttyState' interface to query the state of the game. To access this,
163 --     use the standard 'ask' or 'asks' functions.
164 --
165 --   * A 'StateT' monad containing the custom user state. To query and modify this, use the
166 --     standard 'get', 'put' and 'modify' functions.
167 type DayMonad d   = WriterT [ClientMessage] (ReaderT ParttyState (StateT d IO))
168
169 -- | The 'NightMonad' is where the night callbacks run in. It provides the same featuers as the 
170 --   'DayMonad', only that you can not send a 'ClientMessage'.
171 type NightMonad d =                          ReaderT ParttyState (StateT d IO)
172
173
174 -- Start
175
176 -- | The 'parttyMain' is a small wrapper around 'runPartty' which reads the 
177 --   hostname, the port, the username and the password from the command line.
178 --   The other arguments are the same as for 'runPartty'.
179
180 parttyMain :: DayCallback d
181         -> NightCallback d
182         -> d
183         -> IO ()
184 parttyMain dcb ncb d = do
185         [host,port_s,username,password] <- getArgs
186         runPartty host (read port_s) username password dcb ncb d
187
188 -- | The 'runPartty' function is the main entry point in Partty. It tries to connect to the
189 --   server, logs in, and begins to call the callbacks ('DayCallback' and 'NightCallback') with
190 --   the appropriate messages.
191
192 runPartty :: String             -- ^ Hostname
193         -> Int                  -- ^ Port
194         -> String               -- ^ Username
195         -> String               -- ^ Password
196         -> DayCallback d        -- ^ The callback for day events
197         -> NightCallback d      -- ^ The callback for the night result
198         -> d                    -- ^ The initial user state to be kept
199         -> IO ()
200 runPartty host port username password dcb ncb d = do 
201         h <- connectTo host (PortNumber (fromIntegral port))
202         hSetBuffering h LineBuffering
203         putStrLn $ "[" ++ username ++ "] Connected to " ++ host
204         InternalMessage Welcome <- parseIncomingMessage `liftM` hGetLine h
205         hPutStrLn h $ unwords ["login", username, password]
206         InternalMessage (PlayerJoined myName) <- parseIncomingMessage `liftM` hGetLine h
207         when (myName /= username) $ error "Server returned a different name for me"
208
209         -- login has been successful, wait for the server start event
210         fix $ \loop -> do
211                 msg <- parseIncomingMessage `liftM` hGetLine h
212                 case msg of 
213                         (InternalMessage GameStarting) -> return ()
214                         otherwise                      -> do
215                                 putStrLn $ "[" ++ username ++ "] Waiting for game start..."
216                                 loop
217         
218         -- We expect two more fixed events. If the server changes, this breaks!
219         
220         InternalMessage (MyIdIs myId) <- parseIncomingMessage `liftM` hGetLine h
221         DayMessage (PlayerEnter player startPlace) <- parseIncomingMessage `liftM` hGetLine h
222         when (player /= myId) $ error "Server did not tell us where we start"
223         putStrLn $ "[" ++ username ++ "] Starting at " ++ show startPlace
224
225         let initialState = ParttyState
226                 { psMyName      = myId
227                 , psLoginName   = username
228                 , psDay         = 0
229                 , psHistory     = []
230                 , psHintHistory = []
231                 , psPlace       = startPlace
232                 , psPlayers     = []
233                 , psPlayersHere = []
234                 , psActionsLeft = 0
235                 , psPartyPlace  = Nothing
236                 , psFriends     = []
237                 }
238
239         -- The rest of the events are handled in the regular loop. Run the initial event
240         -- and call the runner
241         
242         runner h dcb ncb initialState d
243
244 callDayCallback :: DayCallback d -> ParttyState -> d -> DayMessage -> IO ([ClientMessage], d)
245 callDayCallback dcb ps d e = do
246         flip runStateT d $
247                 flip runReaderT ps $ do
248                         execWriterT $ do
249                                 dcb e
250
251 callNightCallback :: NightCallback d -> ParttyState -> d -> NightResult -> IO d
252 callNightCallback ncb ps d e = do
253         flip execStateT d $
254                 flip runReaderT ps $ do
255                         ncb e
256                                 
257
258 runner :: Handle -> DayCallback d -> NightCallback d -> ParttyState -> d -> IO ()
259 runner h dcb ncb = fix $ \loop ps d -> do
260         (e,ps') <- getNextUserMessage h ps 
261         (d',ps'') <- case e of
262                 Left dm  -> do (client_messages, d') <- callDayCallback dcb ps' d dm
263                                mapM_ (sendClientMessage h) $ take (psActionsLeft ps') client_messages
264                                let ps'' = foldr updateStateC ps' client_messages
265                                return (d',ps'')
266                 Right nm -> do d' <- callNightCallback ncb ps' d nm
267                                return (d',ps')
268         loop ps'' d'
269
270 getNextUserMessage :: Handle -> ParttyState -> IO (Either DayMessage NightResult, ParttyState)
271 getNextUserMessage h ps = do
272         (msg, ps) <- getNextMessage h ps
273         case msg of
274                 InternalMessage ue -> getNextUserMessage h ps
275                 DayMessage dm      -> return (Left dm, ps)
276                 NightMessage nm    -> return (Right nm, ps)
277
278 -- Message parsing
279
280 getNextMessage :: Handle -> ParttyState -> IO (IncomingMessage, ParttyState)
281 getNextMessage h ps = do
282         line <- hGetLine h
283         --putStrLn line
284         let msg = parseIncomingMessage line
285         case msg of
286                 ComplexInput f -> do (msg, ps) <- f h ps
287                                      return (msg, updateState msg ps)
288                 msg            ->    return (msg, updateState msg ps)
289
290 parseIncomingMessage :: String -> IncomingMessage
291 parseIncomingMessage msg = case id of
292         -- Errors, no proper handling for now
293         1  -> error "Invalid place parameter."
294         2  -> error "Invalid player parameter."
295         3  -> error "Login needed."
296         4  -> error "Cannot be used at night."
297         5  -> error "No actions left."
298         6  -> error "logged in twice."
299         7  -> error "Cannot login. Game is already running."
300         8  -> error "Invalid username/password."
301         9  -> error "Numeric value required."
302         10 -> error "Unknown command."
303         11 -> error "Invalid parameters."
304         -- 12 -> error "<playerid> is unreachable."
305         12 -> InternalMessage (Noise) -- happens too often
306
307         -- Regular Messages
308         71 -> InternalMessage (Welcome)
309         20 -> InternalMessage (PlayerJoined s1)
310         21 -> InternalMessage (PlayerLeft s1)
311         70 -> InternalMessage (Noise) -- welcome
312         40 -> InternalMessage (Noise) -- waiting for at least .. players
313         41 -> InternalMessage (Noise) -- game will start in...
314         42 -> InternalMessage (GameStarting)
315         56 -> InternalMessage (GameEnds)
316         43 -> InternalMessage (MyIdIs s1)
317         65 -> InternalMessage (ActionsLeft int1)
318
319         50 -> DayMessage      (DayStarts int1)
320         51 -> DayMessage      (DayEndsIn int1)
321         52 -> DayMessage      (DayEnds)
322
323         22 -> DayMessage      (PlayerEnter s1 int2)
324         23 -> DayMessage      (PlayerLeave s1 int2)
325
326         24 -> DayMessage      (if int2 == 0 then GotHint s1 (NoPartyAt int3)
327                                             else GotHint s1 (PartyAt   int3) )
328         25 -> DayMessage      (if int2 == 0 then GotHint s1 (Liar      s3)
329                                             else GotHint s1 (NoLiar    s3) )
330
331         53 -> ComplexInput    parseNight
332
333         -- 53 -> NightMessage    (NightStarts)
334         54 -> InternalMessage Noise
335         55 -> InternalMessage (NightEnds)
336
337         61 -> InternalMessage (PlayerAt s1 int2)
338         62 -> InternalMessage (GotScore NoScore)
339         63 -> InternalMessage (GotScore ToFew)
340         64 -> InternalMessage (GotScore Scored)
341         66 -> InternalMessage (NewContact s1)
342         67 -> InternalMessage (LostContact s1)
343
344         60 -> InternalMessage (PartyHint int1)
345
346         30 -> lineEater int1 (\l -> InternalMessage (PlayerList (map parsePlayer l)))
347         32 -> lineEater int1 (\l -> InternalMessage (ScoreList  (map parseScore l)))
348         34 -> lineEater int1 (\l -> InternalMessage (NameList   (map parseName l)))
349         
350         _  -> error $ "Unkown or unparseable message:\n" ++ msg
351  where (id_s : num_params : rest) = words msg
352        id = read id_s
353        param_s = take (read num_params) rest
354        -- This works thanks to laziness:
355        s1   = read (param_s !! 0) :: String
356        int1 = read (param_s !! 0) :: Int
357        s2   = read (param_s !! 1) :: String
358        int2 = read (param_s !! 1) :: Int
359        s3   = read (param_s !! 2) :: String
360        int3 = read (param_s !! 2) :: Int
361
362        parsePlayer str = read (words str !! 2)
363        parseScore str  = (read (words str !! 2), read (words str !! 3))
364        parseName str   = (read (words str !! 2), read (words str !! 3))
365
366        lineEater :: Int -> ([String] -> IncomingMessage) -> IncomingMessage
367        lineEater n f = ComplexInput $ \h ps -> do lines <- sequence (replicate n (hGetLine h))
368                                                   return (f lines, ps)
369
370
371 parseNight :: Handle -> ParttyState -> IO (IncomingMessage, ParttyState)
372 parseNight h ps = do
373         (InternalMessage (PartyHint partyAt), ps) <- getNextMessage h ps
374         (ps, playerpos, score) <- fix (\loop ps playerpos -> do
375                 (msg, ps) <- getNextMessage h ps
376                 case msg of
377                         (InternalMessage (PlayerAt player place)) ->
378                                 loop ps $ (player,place): playerpos
379                         (InternalMessage (GotScore score)) ->
380                                 return (ps, playerpos, score)
381                         m ->    loop ps playerpos
382                 ) ps []
383         ps <- fix (\loop ps -> do
384                 (msg,ps) <- getNextMessage h ps
385                 case msg of
386                         (InternalMessage (NightEnds)) -> return ps
387                         m                             -> loop ps
388                 ) ps
389         return (NightMessage (NightResult
390                         { nrDay = psDay ps
391                         , nrPartyAt = partyAt 
392                         , nrPlayersAt = playerpos
393                         , nrScore = score
394                         }
395                 ), ps)
396
397 sendClientMessage :: Handle -> ClientMessage -> IO ()
398 sendClientMessage h msg = do --putStrLn $ "       sending " ++ (show msg)
399                              hPutStrLn h (toString msg)
400   where toString (Goto place)                    = unwords ["goto",     show place]
401         toString (Tell player (PartyAt place))   = unwords ["party",    player, show place]
402         toString (Tell player (NoPartyAt place)) = unwords ["no_party", player, show place]
403         toString (Tell player (Liar other))      = unwords ["liar",     player, other]
404         toString (Tell player (NoLiar other))    = unwords ["recommand",player, other]
405
406 -- Bookkeeping
407
408 updateState :: IncomingMessage -> ParttyState -> ParttyState
409
410 updateState (DayMessage (DayStarts num)) ps =
411         ps {psDay = num}
412
413 updateState (DayMessage (PlayerLeave player place) ) ps =
414         if (player == psMyName ps)
415         then ps {psPlayersHere = []}
416         else ps {psPlayersHere = filter (/= player) (psPlayersHere ps) }
417
418 updateState (DayMessage (PlayerEnter player place) ) ps =
419         if (player == psMyName ps)
420         then ps {psPlace = place}
421         else ps {psPlayersHere = player :  psPlayersHere ps}
422
423 updateState (DayMessage (GotHint player hint) ) ps = 
424         ps { psHintHistory = (psDay ps, player, hint) : psHintHistory ps }
425
426 updateState (InternalMessage (PlayerList players) ) ps =
427         ps {psPlayers = players}
428
429 updateState (InternalMessage (PlayerJoined player) ) ps =
430         ps {psPlayers = player :  psPlayers ps}
431
432 updateState (InternalMessage (PlayerLeft player) ) ps =
433         ps {psPlayers = filter (/= player) (psPlayers ps) }
434
435 updateState (InternalMessage (ActionsLeft n)) ps =
436         ps {psActionsLeft = n }
437
438 updateState (InternalMessage (MyIdIs myId)) ps = 
439         ps {psMyName = myId}
440
441 updateState (InternalMessage (PartyHint partyAt)) ps =
442         ps {psPartyPlace = Just partyAt}
443
444 updateState (InternalMessage (NewContact friend)) ps =
445         ps { psFriends = friend : psFriends ps }
446
447 updateState (InternalMessage (LostContact friend)) ps =
448         ps { psFriends = filter (/= friend) (psFriends ps) }
449
450 updateState (NightMessage result) ps =
451         ps { psPartyPlace = Nothing
452            , psHistory = result : psHistory ps
453            }
454
455 updateState (InternalMessage GameStarting) ps =
456         ps { psHistory = []
457            , psFriends = []
458            , psHintHistory = []
459            }
460
461 updateState msg ps = ps -- TODO: this is a stub
462
463 updateStateC :: ClientMessage -> ParttyState -> ParttyState
464 updateStateC _ ps = ps {psActionsLeft = psActionsLeft ps - 1}
465
466 -- Convenience functions for accessing the state
467
468 whoIsHere :: (MonadReader ParttyState m) => m [Player]
469 whoIsHere = asks psPlayers
470
471 gameDay :: (MonadReader ParttyState m) => m Day
472 gameDay = asks psDay
473
474 -- Interaction:
475
476 -- | The 'send' function can be used in the 'DayMonad' to send a 'ClientMessage' to the server.
477 --   Note that all messages will be sent when the callback returns.
478 send :: (MonadWriter [ClientMessage] m) => ClientMessage -> m ()
479 send msg = tell [msg]
480
481 -- Output
482 --
483 -- | Convenvience alternative to @'liftIO' $ 'putStrLn'@. It also prepends the username to the output.
484 say :: (MonadIO m, MonadReader ParttyState m) => String -> m ()
485 say s = do 
486         name <- asks psLoginName
487         liftIO $ putStrLn $ "[" ++ name ++ "] " ++ s
488
489 -- | Since the server does not keep permanent statistics, this will log in to the hostname and
490 --   port, with the username and password, all given on the command line, do nothing in the game
491 --   but record the events. It will output to the given file a @[[('String','Int')]]@ datum which
492 --   lists for all games (in reverse order) the players and their score.
493 statsMain  :: FilePath -> IO ()
494 statsMain file = do
495         [host,port_s,username,password] <- getArgs
496
497         h <- connectTo host (PortNumber (fromIntegral (read port_s)))
498         hSetBuffering h LineBuffering
499         putStrLn $ "[" ++ username ++ "] Connected to " ++ host
500         InternalMessage Welcome <- parseIncomingMessage `liftM` hGetLine h
501         hPutStrLn h $ unwords ["login", username, password]
502         InternalMessage (PlayerJoined myName) <- parseIncomingMessage `liftM` hGetLine h
503
504
505         lastStats_s <- readFile file
506         when (lastStats_s == lastStats_s) $ return ()
507         
508         let lastStats = read lastStats_s
509
510         putStrLn $ "Read " ++ show (length lastStats) ++ " old stat games"
511         
512         putStrLn "Starting to collect stats..."
513
514         let dummyState = ParttyState
515                 { psMyName      = "0"
516                 , psLoginName   = username
517                 , psDay         = 0
518                 , psHistory     = []
519                 , psHintHistory = []
520                 , psPlace       = 1
521                 , psPlayers     = []
522                 , psPlayersHere = []
523                 , psActionsLeft = 0
524                 , psPartyPlace  = Nothing
525                 , psFriends     = []
526                 }
527         fix (\loop -> do (msg,_) <- getNextMessage h dummyState
528                          case msg of 
529                           (InternalMessage (GameStarting)) -> return ()
530                           otherwise                        -> loop
531                          )
532
533         fix (\loop score -> do
534             this <- fix (\loop players points -> do
535                         (msg,_) <- getNextMessage h dummyState
536                         case msg of 
537                          (InternalMessage (NameList l)) -> loop l points
538                          (InternalMessage (ScoreList l))-> loop players l
539                          (InternalMessage (GameStarting))-> return $ merge players points
540                          otherwise                      -> loop players points
541                         ) undefined undefined
542             let next = this : score
543             putStrLn $ "Score: " ++ show this
544             putStrLn "Writing score..."
545             writeFile file (show next)
546             loop next
547             ) lastStats
548
549  where merge player scores = map (
550                 \(p1,n) -> (n, fromJust (lookup p1 scores))
551                 ) player
552