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