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