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