Monad Voodo for alling the event handlers
[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         
32 -- Events that we want to send to the user code and that
33 -- can be reacted upon
34 data DayMessage      = DayStarts
35 -- Events that we want to send to the user code and that
36 -- can NOT be reacted upon
37 data NightMessage    = Initialize
38                      | NightStarts
39 -- Pure bookkeeping events
40 data InternalMessage = MyPlayerId Player
41                      | Welcome
42                      | PlayerJoined String
43                      | GameStarting
44                      | MyIdIs Player
45                      | PlayerEnter Player Place
46
47
48 {- Einzusortieren:
49                      | PlayerJoined Player  -- the game
50                      | PlayerLeft Player
51                      | PlayerEnters Player Place
52                      | PlayerLeaves Player Place
53                      | GotHint Hint
54                      | PlayerList [Player]
55                      | PlayerScore [(Player, Int)]
56                      | PlayerNames [(Player, String)]
57                      | GameStarted
58                      | DayStarts
59                      | DayEndsIn Int
60                      | DayEnds
61                      | NightStarts
62                      | NightEndsIn Int
63                      | NightEnds
64                      | GameEnded
65                      | PartyHint Place
66                      | PlayerPosition Player Place -- wann bekommt man das?
67                      | GotScore Score
68                      | ActionsLeft Int
69                      | NewContact Player
70 -} 
71
72 data ClientMessage = Tell Player Hint
73                    | Goto Place
74
75 type DayCallback d   = DayMessage -> DayMonad d ()
76 type NightCallback d = NightMessage -> NightMonad d ()
77
78 data ParttyState = ParttyState
79         { psMyName      :: Player
80         , psDay         :: Day
81         , psPlayerInfo  :: Map Player PlayerInformation
82         , psPartyHistory:: [(Day,Place)]
83         , psPlace       :: Place
84         , psPlayers     :: [Player]
85         }
86
87 type DayMonad d   = WriterT [ClientMessage] (ReaderT ParttyState (StateT d IO))
88 type NightMonad d =                          ReaderT ParttyState (StateT d IO)
89
90
91 -- Start
92
93 -- Hostname, Port, Playername, Password, Callback
94 runPartty :: String -> Int -> String -> String -> DayCallback d -> NightCallback d -> d -> IO ()
95 runPartty host port username password dcb ncb initialData = do 
96         h <- connectTo host (PortNumber (fromIntegral port))
97         InternalMessage Welcome <- parseIncomingMessage `liftM` hGetLine h
98         hPutStrLn h $ unwords ["login", username, password]
99         InternalMessage (PlayerJoined myName) <- parseIncomingMessage `liftM` hGetLine h
100         when (myName /= username) $ error "Server returned a different name for me"
101
102         -- login has been successful, wait for the server start event
103         fix $ \loop -> do
104                 msg <- parseIncomingMessage `liftM` hGetLine h
105                 case msg of 
106                         (InternalMessage GameStarting) -> return ()
107                         otherwise                      -> do
108                                 putStrLn "Waiting for game start..."
109                                 loop
110         
111         -- We expect two more fixed events. If the server changes, this breaks!
112         
113         InternalMessage (MyIdIs myId) <- parseIncomingMessage `liftM` hGetLine h
114         InternalMessage (PlayerEnter player startPlace) <- parseIncomingMessage `liftM` hGetLine h
115         when (player /= myId) $ error "Server did not tell us where we start"
116
117         let initialState = ParttyState
118                 { psMyName      = myId
119                 , psDay         = 0
120                 , psPlayerInfo  = empty
121                 , psPartyHistory= []
122                 , psPlace       = startPlace
123                 , psPlayers     = []
124                 }
125
126         -- The rest of the events are handled in the regular loop. Run the initial event
127         -- and call the runner
128         
129         d' <- callNightCallback ncb initialState initialData Initialize
130
131         runner h dcb ncb initialState d'
132
133 callDayCallback :: DayCallback d -> ParttyState -> d -> DayMessage -> IO ([ClientMessage], d)
134 callDayCallback dcb ps d e = do
135         flip runStateT d $
136                 flip runReaderT ps $ do
137                         execWriterT $ do
138                                 dcb e
139
140 callNightCallback :: NightCallback d -> ParttyState -> d -> NightMessage -> IO d
141 callNightCallback ncb ps d e = do
142         flip execStateT d $
143                 flip runReaderT ps $ do
144                         ncb e
145                                 
146
147 runner :: Handle -> DayCallback d -> NightCallback d -> ParttyState -> d -> IO ()
148 runner h dcb ncb = fix $ \loop ps d -> do
149         (e,ps') <- getNextUserMessage h ps
150         d' <- case e of
151                 Left dm  -> do (client_messages, d') <- callDayCallback dcb ps' d dm
152                                undefined -- send_client_messages client_messages
153                                return d'
154                 Right nm -> callNightCallback ncb ps' d nm
155         loop ps' d'
156
157 getNextUserMessage :: Handle -> ParttyState -> IO (Either DayMessage NightMessage, ParttyState)
158 getNextUserMessage h ps = do
159         line <- hGetLine h
160         e <- undefined {- parseIncomingMessage -} line
161         let ps' = undefined {- updateState -} e ps
162         case e of
163                 InternalMessage ue -> getNextUserMessage h ps'
164                 DayMessage dm -> return (Left dm, ps')
165                 NightMessage nm -> return (Right nm, ps')
166
167 parseIncomingMessage :: String -> IncomingMessage
168 parseIncomingMessage = undefined
169
170 -- Convenience functions for accessing the state
171
172 whoIsHere :: (MonadReader ParttyState m) => m [Player]
173 whoIsHere = asks psPlayers
174
175 gameDay :: (MonadReader ParttyState m) => m Day
176 gameDay = asks psDay
177
178 -- Interaction: use “tell”
179