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