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