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