Even more messages parsed!
[darcs-mirror-haskell-partty.git] / Partty.hs
1 {-# LANGUAGE FlexibleContexts #-}
2  
3 module Partty where
4
5 import Data.Map
6 import Control.Monad.State
7 import Control.Monad.Reader
8 import Control.Monad.Writer
9 import Network
10 import System.IO
11
12 type Player = String
13 type Day = Int
14 type Place = Int
15
16 data Hint = PartyAt Place
17           | NoPartyAt Place
18           | Liar Player
19           | NoLiar Player
20      deriving (Show, Eq)
21
22 data PlayerInformation = PlayerInformation
23         { piSeen        :: [Day]
24         , piHints       :: [(Day,Hint)]
25         }
26
27 data Score = NoScore | ToFew | Scored
28                      deriving (Show, Eq)
29
30 data IncomingMessage = InternalMessage InternalMessage
31                      | DayMessage      DayMessage
32                      | NightMessage    NightMessage
33                      | UnknownMessage  String
34                      deriving (Show, Eq)
35         
36 -- Events that we want to send to the user code and that
37 -- can be reacted upon
38 data DayMessage      = DayStarts
39                      | DayEndsIn Int
40                      | DayEnds
41                      | PlayerAt Player Place
42                      deriving (Show, Eq)
43
44 -- Events that we want to send to the user code and that
45 -- can NOT be reacted upon
46 data NightMessage    = Initialize
47                      | PartyHint Place
48                      | NightStarts
49                      | NightEndsIn Int
50                      | NightEnds
51                      | GotScore Score
52                      deriving (Show, Eq)
53 -- Pure bookkeeping events
54 data InternalMessage = MyPlayerId Player
55                      | Welcome
56                      | PlayerJoined String
57                      | GameStarting
58                      | MyIdIs Player
59                      | PlayerEnter Player Place
60                      | PlayerLeave Player Place
61                      | ActionsLeft Int
62                      | Noise
63                      deriving (Show, Eq)
64
65
66 {- Einzusortieren:
67                      | PlayerJoined Player  -- the game
68                      | PlayerLeft Player
69                      | PlayerEnters Player Place
70                      | PlayerLeaves Player Place
71                      | GotHint Hint
72                      | PlayerList [Player]
73                      | PlayerScore [(Player, Int)]
74                      | PlayerNames [(Player, String)]
75                      | GameStarted
76                      | DayStarts
77                      | DayEndsIn Int
78                      | DayEnds
79                      | NightStarts
80                      | NightEndsIn Int
81                      | NightEnds
82                      | GameEnded
83                      | PartyHint Place
84                      | PlayerPosition Player Place -- wann bekommt man das?
85                      | ActionsLeft Int
86                      | NewContact Player
87 -} 
88
89 data ClientMessage = Tell Player Hint
90                    | Goto Place
91                      deriving (Show, Eq)
92
93 type DayCallback d   = DayMessage -> DayMonad d ()
94 type NightCallback d = NightMessage -> NightMonad d ()
95
96 data ParttyState = ParttyState
97         { psMyName      :: Player
98         , psDay         :: Day
99         , psPlayerInfo  :: Map Player PlayerInformation
100         , psPartyHistory:: [(Day,Place)]
101         , psPlace       :: Place
102         , psPlayers     :: [Player]
103         }
104
105 type DayMonad d   = WriterT [ClientMessage] (ReaderT ParttyState (StateT d IO))
106 type NightMonad d =                          ReaderT ParttyState (StateT d IO)
107
108
109 -- Start
110
111 -- Hostname, Port, Playername, Password, Callback
112 runPartty :: String -> Int -> String -> String -> DayCallback d -> NightCallback d -> d -> IO ()
113 runPartty host port username password dcb ncb initialData = do 
114         h <- connectTo host (PortNumber (fromIntegral port))
115         hSetBuffering h LineBuffering
116         putStrLn $ "Connected to " ++ host
117         InternalMessage Welcome <- parseIncomingMessage `liftM` hGetLine h
118         hPutStrLn h $ unwords ["login", username, password]
119         InternalMessage (PlayerJoined myName) <- parseIncomingMessage `liftM` hGetLine h
120         when (myName /= username) $ error "Server returned a different name for me"
121
122         -- login has been successful, wait for the server start event
123         fix $ \loop -> do
124                 msg <- parseIncomingMessage `liftM` hGetLine h
125                 case msg of 
126                         (InternalMessage GameStarting) -> return ()
127                         otherwise                      -> do
128                                 putStrLn "Waiting for game start..."
129                                 loop
130         
131         -- We expect two more fixed events. If the server changes, this breaks!
132         
133         InternalMessage (MyIdIs myId) <- parseIncomingMessage `liftM` hGetLine h
134         InternalMessage (PlayerEnter player startPlace) <- parseIncomingMessage `liftM` hGetLine h
135         when (player /= myId) $ error "Server did not tell us where we start"
136         putStrLn $ "Starting at " ++ show startPlace
137
138         let initialState = ParttyState
139                 { psMyName      = myId
140                 , psDay         = 0
141                 , psPlayerInfo  = empty
142                 , psPartyHistory= []
143                 , psPlace       = startPlace
144                 , psPlayers     = []
145                 }
146
147         -- The rest of the events are handled in the regular loop. Run the initial event
148         -- and call the runner
149         
150         d' <- callNightCallback ncb initialState initialData Initialize
151
152         runner h dcb ncb initialState d'
153
154 callDayCallback :: DayCallback d -> ParttyState -> d -> DayMessage -> IO ([ClientMessage], d)
155 callDayCallback dcb ps d e = do
156         flip runStateT d $
157                 flip runReaderT ps $ do
158                         execWriterT $ do
159                                 dcb e
160
161 callNightCallback :: NightCallback d -> ParttyState -> d -> NightMessage -> IO d
162 callNightCallback ncb ps d e = do
163         flip execStateT d $
164                 flip runReaderT ps $ do
165                         ncb e
166                                 
167
168 runner :: Handle -> DayCallback d -> NightCallback d -> ParttyState -> d -> IO ()
169 runner h dcb ncb = fix $ \loop ps d -> do
170         (e,ps') <- getNextUserMessage h ps
171         d' <- case e of
172                 Left dm  -> do (client_messages, d') <- callDayCallback dcb ps' d dm
173                                mapM_ (sendClientMessage h) client_messages
174                                return d'
175                 Right nm -> callNightCallback ncb ps' d nm
176         loop ps' d'
177
178 getNextUserMessage :: Handle -> ParttyState -> IO (Either DayMessage NightMessage, ParttyState)
179 getNextUserMessage h ps = do
180         line <- hGetLine h
181         let msg = parseIncomingMessage line
182         let ps' = updateState msg ps
183         case msg of
184                 InternalMessage ue -> getNextUserMessage h ps'
185                 UnknownMessage s-> do putStrLn $"Got an unknown message:\n"++s
186                                       getNextUserMessage h ps'
187                 DayMessage dm -> return (Left dm, ps')
188                 NightMessage nm -> return (Right nm, ps')
189
190 updateState :: IncomingMessage -> ParttyState -> ParttyState
191 updateState msg ps = ps -- TODO: this is a stub
192
193 parseIncomingMessage :: String -> IncomingMessage
194 parseIncomingMessage msg = case id of
195         -- Errors, no proper handling for now
196         07 -> error "Game is already in progress, try again later..."
197
198         -- Regular Messages
199         71 -> InternalMessage (Welcome)
200         20 -> InternalMessage (PlayerJoined s1)
201         70 -> InternalMessage (Noise) -- welcome
202         40 -> InternalMessage (Noise) -- waiting for at least .. players
203         41 -> InternalMessage (Noise) -- game will start in...
204         42 -> InternalMessage (GameStarting)
205         43 -> InternalMessage (MyIdIs s1)
206         22 -> InternalMessage (PlayerEnter s1 int2)
207         23 -> InternalMessage (PlayerLeave s1 int2)
208         65 -> InternalMessage (ActionsLeft int1)
209
210         50 -> DayMessage      (DayStarts)
211         51 -> DayMessage      (DayEndsIn int1)
212         52 -> DayMessage      (DayEnds)
213         61 -> DayMessage      (PlayerAt s1 int2)
214
215         53 -> NightMessage    (NightStarts)
216         54 -> NightMessage    (NightEndsIn int1)
217         55 -> NightMessage    (NightEnds)
218         62 -> NightMessage    (GotScore NoScore)
219         63 -> NightMessage    (GotScore ToFew)
220         64 -> NightMessage    (GotScore Scored)
221
222         60 -> NightMessage    (PartyHint int1)
223
224         
225         _  -> UnknownMessage msg
226         --_  -> error $ "Unkown or unparseable message:\n" ++ msg
227  where (id_s : num_params : rest) = words msg
228        id = read id_s
229        param_s = take (read num_params) rest
230        s1   = read (param_s !! 0) :: String
231        int1 = read (param_s !! 0) :: Int
232        s2   = read (param_s !! 1) :: String
233        int2 = read (param_s !! 1) :: Int
234
235 sendClientMessage :: Handle -> ClientMessage -> IO ()
236 sendClientMessage h msg = do putStrLn $ "Client says: " ++ (show msg)
237                              hPutStrLn h (toString msg)
238   where toString (Goto place)                    = unwords ["goto", show place]
239         toString (Tell player (PartyAt place))   = unwords ["party",    show player, show place]
240         toString (Tell player (NoPartyAt place)) = unwords ["no_party", show player, show place]
241         toString (Tell player (Liar other))      = unwords ["liar",     show player, show other]
242         toString (Tell player (NoLiar other))    = unwords ["recommand",show player, show other]
243
244
245 -- Convenience functions for accessing the state
246
247 whoIsHere :: (MonadReader ParttyState m) => m [Player]
248 whoIsHere = asks psPlayers
249
250 gameDay :: (MonadReader ParttyState m) => m Day
251 gameDay = asks psDay
252
253 -- Interaction:
254
255 send :: (MonadWriter [ClientMessage] m) => ClientMessage -> m ()
256 send msg = tell [msg]
257
258