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