Document everything exported
[darcs-mirror-haskell-partty.git] / NiceGuy.hs
1 import Control.Monad.Trans
2 import Control.Monad.State
3 import Control.Monad.Reader
4 import System.Random
5 import Partty
6
7 import qualified Data.Map as M
8 import Data.Map ((!))
9 import Data.List
10 import Data.Ord
11 import Data.Maybe
12
13 {- 
14  - Nice Guy: Spreads Hints, follows Hints
15  -}
16
17 type UserData = ([(Player,Place)])
18
19 tellThem :: Place -> [Player] -> DayMonad UserData ()
20 tellThem room = mapM_ $ \friend -> do
21                 actionsLeft <- asks psActionsLeft
22                 if actionsLeft > 0
23                  then do send (Tell friend (PartyAt room))
24                          say $ "Told " ++ show friend ++ " about the party."
25                  else do say $ "Can not tell " ++ show friend ++ " any more."
26
27 dcb :: DayCallback UserData
28 dcb (DayStarts _) = do
29         mbp <- asks psPartyPlace
30         case mbp of
31                 Nothing -> do
32                         say $ "No idea where to go, waiting for hints..."
33                 Just room -> do
34                         say $ "Yay, I know where to go! (" ++ show room ++")"
35                         send (Goto room)
36                         friends <- asks psFriends
37                         players <- asks psPlayersHere
38                         tellThem room (nub (sort (friends ++ players)))
39
40 dcb (GotHint player (PartyAt room)) = do
41         say $ "The " ++ show player ++ " told me about a party at " ++ show room ++"."
42         modify ((player,room):)
43
44 dcb (DayEndsIn 1) = do
45         mbp <- asks psPartyPlace
46         hints <- get
47         when (isNothing mbp && not (null hints)) $ do
48                 friends <- asks psFriends
49                 selected_hints <- case partition (\(p,_) -> p `elem` friends) hints of
50                   ([],bad) -> do say $ "Some hints from non-friends " ++ show bad
51                                  return bad
52                   (good,_) -> do say $ "Some hints from friends " ++ show good
53                                  return good
54                 let choices = map snd selected_hints
55                 pick <- liftIO $ randomRIO (0,length choices - 1)
56                 say $ "Choosing " ++ show (choices !! pick)
57                 send (Goto (choices !! pick))
58
59 dcb e = return ()
60
61 ncb :: NightCallback UserData
62 ncb (NightResult {nrScore = score }) = do
63         say $ "Got score: " ++ show score
64         say $ "New Day, forget about yesterday"
65         put []
66
67 main = parttyMain dcb ncb []