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' <- undefined {- run -} ncb initialState initialData Initialize
 130
 131         runner h dcb ncb initialState d'
 132
 133
 134 runner :: Handle -> DayCallback d -> NightCallback d -> ParttyState -> d -> IO ()
 135 runner h dcb ncb = fix $ \loop ps d -> do
 136         (e,ps') <- getNextUserMessage h ps
 137         d' <- case e of
 138                 Left dm  -> do (client_messages, d') <- undefined {- run -} dcb dm
 139                                undefined -- send_client_messages client_messages
 140                                return d'
 141                 Right nm -> undefined {- run -} ncb nm
 142         loop ps' d'
 143
 144 getNextUserMessage :: Handle -> ParttyState -> IO (Either DayMessage NightMessage, ParttyState)
 145 getNextUserMessage h ps = do
 146         line <- hGetLine h
 147         e <- undefined {- parseIncomingMessage -} line
 148         let ps' = undefined {- updateState -} e ps
 149         case e of
 150                 InternalMessage ue -> getNextUserMessage h ps'
 151                 DayMessage dm -> return (Left dm, ps')
 152                 NightMessage nm -> return (Right nm, ps')
 153
 154 parseIncomingMessage :: String -> IncomingMessage
 155 parseIncomingMessage = undefined
 156
 157 -- Convenience functions for accessing the state
 158
 159 whoIsHere :: (MonadReader ParttyState m) => m [Player]
 160 whoIsHere = asks psPlayers
 161
 162 gameDay :: (MonadReader ParttyState m) => m Day
 163 gameDay = asks psDay
 164
 165 -- Interaction: use “tell”
 166