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