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