Large refactor, introduce NightResult
authorJoachim Breitner <mail@joachim-breitner.de>
Sat, 5 Jul 2008 13:00:55 +0000 (13:00 +0000)
committerJoachim Breitner <mail@joachim-breitner.de>
Sat, 5 Jul 2008 13:00:55 +0000 (13:00 +0000)
CrowdSurfer.hs
DeafAndSilent.hs
Partty.hs

index 7841ad4..8b3ec33 100644 (file)
@@ -57,13 +57,9 @@ dcb (DayEndsIn 3) = do
 dcb e = return ()
 
 ncb :: NightCallback UserData
--- Round over, forget everything
-ncb (NightEnds) = do
+ncb (NightResult {nrScore = score }) = do
+       say $ "Got score: " ++ show score
        say $ "New Day, forget about yesterday"
        put M.empty
--- Output the score
-ncb (GotScore score) = say $ "Got score: " ++ show score
-
-ncb e = return ()
 
 main = parttyMain dcb ncb M.empty
index 18e6cd0..7f221bf 100644 (file)
@@ -1,17 +1,17 @@
 import Control.Monad.Trans
 import Control.Monad.State
-import Control.Monad.Writer
+import Control.Monad.Reader
 import System.Random
 import Partty
 
 {- 
  - Stupid player: Goes to a party it knows about for sure, otherwise guesses
  -}
-type UserData = Maybe Place
+type UserData = ()
 
 dcb :: DayCallback UserData
 dcb (DayStarts _) = do
-       mbp <- get
+       mbp <- asks psPartyPlace
        room <- case mbp of
                Nothing -> do
                        say $ "No idea where to go, guessing..."
@@ -20,16 +20,11 @@ dcb (DayStarts _) = do
                        say $ "Yay, I know where to go! (" ++ show room ++")"
                        return room
        send (Goto room)
+
 dcb e = return ()
 
 ncb :: NightCallback UserData
--- Round over, forget everything
-ncb (NightEnds) = put Nothing
--- We have the hint, remember it
-ncb (PartyHint room) = put (Just room)
--- Output the score
-ncb (GotScore score) = say $ "Got score: " ++ show score
-
-ncb e = return ()
+ncb (NightResult {nrScore = score }) = do
+       say $ "Got score: " ++ show score
 
-main = parttyMain dcb ncb Nothing
+main = parttyMain dcb ncb ()
index 7102a66..d31033d 100644 (file)
--- a/Partty.hs
+++ b/Partty.hs
@@ -8,7 +8,7 @@ module Partty
        , NightCallback
        , NightMonad
        , DayMessage(..)
-       , NightMessage(..)
+       , NightResult(..)
        , ClientMessage(..)
        , Hint(..)
        , Score(..)
@@ -47,8 +47,9 @@ data Score = NoScore | ToFew | Scored
 
 data IncomingMessage = InternalMessage InternalMessage
                      | DayMessage      DayMessage
-                     | NightMessage    NightMessage
+                     | NightMessage    NightResult   
                     | LineEater       Int ([String] -> IncomingMessage)
+                    | ComplexInput    (Handle -> IO IncomingMessage)
                     | UnknownMessage  String
        
 -- Events that we want to send to the user code and that
@@ -61,18 +62,14 @@ data DayMessage      = DayStarts Int
                     | PlayerLeave Player Place
                     deriving (Show)
 
--- Events that we want to send to the user code and that
--- can NOT be reacted upon
-data NightMessage    = Initialize
-                    | PartyHint Place
-                    | PlayerAt Player Place
-                    | NightStarts
-                    | NightEndsIn Int
-                    | NightEnds
-                     | GotScore Score
-                    | NewContact Player
-                    | LostContact Player
-                    deriving (Show)
+
+data NightResult     = NightResult
+                    { nrPartyAt :: Place
+                    , nrPlayersAt :: [(Player, Place)]
+                    , nrScore :: Score
+                    , nrNewFriends :: [Player]
+                    }
+
 -- Pure bookkeeping events
 data InternalMessage = MyPlayerId Player
                      | Welcome
@@ -86,6 +83,14 @@ data InternalMessage = MyPlayerId Player
                     | ScoreList [(Player, Int)]
                     | NameList [(Player, String)]
                     | Noise
+                     | PartyHint Place
+                    | PlayerAt Player Place
+                    | NightStarts
+                    | NightEndsIn Int
+                    | NightEnds
+                     | GotScore Score
+                    | NewContact Player
+                    | LostContact Player
                     deriving (Show)
 
 data ClientMessage = Tell Player Hint
@@ -93,7 +98,7 @@ data ClientMessage = Tell Player Hint
                     deriving (Show)
 
 type DayCallback d   = DayMessage -> DayMonad d ()
-type NightCallback d = NightMessage -> NightMonad d ()
+type NightCallback d = NightResult -> NightMonad d ()
 
 data PlayerInformation = PlayerInformation
        { piSeen        :: [Day]
@@ -110,6 +115,7 @@ data ParttyState = ParttyState
        , psPlayers     :: [Player]
        , psPlayersHere :: [Player]
        , psActionsLeft :: Int
+       , psPartyPlace  :: Maybe Place
        }
 
 type DayMonad d   = WriterT [ClientMessage] (ReaderT ParttyState (StateT d IO))
@@ -126,7 +132,7 @@ parttyMain dcb ncb d = do
 
 -- Hostname, Port, Playername, Password, Callback
 runPartty :: String -> Int -> String -> String -> DayCallback d -> NightCallback d -> d -> IO ()
-runPartty host port username password dcb ncb initialData = do 
+runPartty host port username password dcb ncb d = do 
        h <- connectTo host (PortNumber (fromIntegral port))
        hSetBuffering h LineBuffering
        putStrLn $ "[" ++ username ++ "] Connected to " ++ host
@@ -161,14 +167,13 @@ runPartty host port username password dcb ncb initialData = do
                , psPlayers     = []
                , psPlayersHere = []
                , psActionsLeft = 0
+               , psPartyPlace  = Nothing
                }
 
        -- The rest of the events are handled in the regular loop. Run the initial event
        -- and call the runner
        
-       d' <- callNightCallback ncb initialState initialData Initialize
-
-       runner h dcb ncb initialState d'
+       runner h dcb ncb initialState d
 
 callDayCallback :: DayCallback d -> ParttyState -> d -> DayMessage -> IO ([ClientMessage], d)
 callDayCallback dcb ps d e = do
@@ -177,7 +182,7 @@ callDayCallback dcb ps d e = do
                        execWriterT $ do
                                dcb e
 
-callNightCallback :: NightCallback d -> ParttyState -> d -> NightMessage -> IO d
+callNightCallback :: NightCallback d -> ParttyState -> d -> NightResult -> IO d
 callNightCallback ncb ps d e = do
        flip execStateT d $
                flip runReaderT ps $ do
@@ -196,7 +201,7 @@ runner h dcb ncb = fix $ \loop ps d -> do
                               return (d',ps')
        loop ps'' d'
 
-getNextUserMessage :: Handle -> ParttyState -> IO (Either DayMessage NightMessage, ParttyState)
+getNextUserMessage :: Handle -> ParttyState -> IO (Either DayMessage NightResult, ParttyState)
 getNextUserMessage h ps = do
        msg <- getNextMessage h
        let ps' = updateState msg ps
@@ -215,8 +220,9 @@ getNextMessage h = do
        --putStrLn line
        let msg = parseIncomingMessage line
        case msg of
-               LineEater n f -> f `liftM` sequence (replicate n (hGetLine h))
-               msg           -> return msg
+               LineEater n f  -> f `liftM` sequence (replicate n (hGetLine h))
+               ComplexInput f -> f h
+               msg            -> return msg
 
 parseIncomingMessage :: String -> IncomingMessage
 parseIncomingMessage msg = case id of
@@ -258,23 +264,24 @@ parseIncomingMessage msg = case id of
        25 -> DayMessage      (if int2 == 0 then GotHint s1 (Liar      s3)
                                            else GotHint s1 (NoLiar    s3) )
 
-       53 -> NightMessage    (NightStarts)
-       54 -> NightMessage    (NightEndsIn int1)
-       55 -> NightMessage    (NightEnds)
+        53 -> ComplexInput    parseNight
+
+       -- 53 -> NightMessage    (NightStarts)
+       54 -> InternalMessage (NightEndsIn int1)
+       55 -> InternalMessage (NightEnds)
 
-       61 -> NightMessage    (PlayerAt s1 int2)
-       62 -> NightMessage    (GotScore NoScore)
-       63 -> NightMessage    (GotScore ToFew)
-       64 -> NightMessage    (GotScore Scored)
-       66 -> NightMessage    (NewContact s1)
-       67 -> NightMessage    (LostContact s1)
+       61 -> InternalMessage (PlayerAt s1 int2)
+       62 -> InternalMessage (GotScore NoScore)
+       63 -> InternalMessage (GotScore ToFew)
+       64 -> InternalMessage (GotScore Scored)
+       66 -> InternalMessage (NewContact s1)
+       67 -> InternalMessage (LostContact s1)
 
-       60 -> NightMessage    (PartyHint int1)
+       60 -> InternalMessage (PartyHint int1)
 
        30 -> LineEater int1 (\l -> InternalMessage (PlayerList (map parsePlayer l)))
        32 -> LineEater int1 (\l -> InternalMessage (ScoreList  (map parseScore l)))
        34 -> LineEater int1 (\l -> InternalMessage (NameList   (map parseName l)))
-
        
        --_  -> UnknownMessage msg
        _  -> error $ "Unkown or unparseable message:\n" ++ msg
@@ -293,6 +300,37 @@ parseIncomingMessage msg = case id of
        parseScore str = (read (words str !! 2), read (words str !! 2))
        parseName str = (read (words str !! 2), read (words str !! 2))
 
+
+parseNight :: Handle -> IO IncomingMessage
+parseNight h = do
+       (InternalMessage (PartyHint partyAt)) <- getNextMessage h
+       (playerpos, score) <- fix (\loop playerpos -> do
+               msg <- getNextMessage h
+               case msg of
+                       (InternalMessage (PlayerAt player place)) ->
+                               loop $ (player,place): playerpos
+                       (InternalMessage (GotScore score)) ->
+                               return (playerpos, score)
+                       _ -> error $ "Unexpected event at night"
+               ) []
+       friends <- fix (\loop friends -> do
+               msg <- getNextMessage h
+               case msg of
+                       (InternalMessage (NewContact friend)) ->
+                               loop $ friend : friends
+                       (InternalMessage Noise) ->
+                               loop $ friends
+                       (InternalMessage (NightEnds)) ->
+                               return friends
+                       _ -> error $ "Unexpected event at night"
+               ) []
+       return $ NightMessage $ NightResult
+               { nrPartyAt = partyAt 
+               , nrPlayersAt = playerpos
+               , nrScore = score
+               , nrNewFriends = friends
+               }
+
 sendClientMessage :: Handle -> ClientMessage -> IO ()
 sendClientMessage h msg = do putStrLn $ "       sending " ++ (show msg)
                              hPutStrLn h (toString msg)
@@ -334,6 +372,12 @@ updateState (InternalMessage (ActionsLeft n)) ps =
 updateState (InternalMessage (MyIdIs myId)) ps = 
        ps {psMyName = myId}
 
+updateState (InternalMessage (PartyHint partyAt)) ps =
+       ps {psPartyPlace = Just partyAt}
+
+updateState (NightMessage _) ps =
+       ps {psPartyPlace = Nothing}
+
 updateState msg ps = ps -- TODO: this is a stub
 
 updateStateC :: ClientMessage -> ParttyState -> ParttyState