Initial Checkin
[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 = Int
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    = NightStarts
38 -- Pure bookkeeping events
39 data InternalMessage = MyPlayerId Player
40
41
42 {- Einzusortieren:
43                      | PlayerJoined Player  -- the game
44                      | PlayerLeft Player
45                      | PlayerEnters Player Place
46                      | PlayerLeaves Player Place
47                      | GotHint Hint
48                      | PlayerList [Player]
49                      | PlayerScore [(Player, Int)]
50                      | PlayerNames [(Player, String)]
51                      | GameStarted
52                      | DayStarts
53                      | DayEndsIn Int
54                      | DayEnds
55                      | NightStarts
56                      | NightEndsIn Int
57                      | NightEnds
58                      | GameEnded
59                      | PartyHint Place
60                      | PlayerPosition Player Place -- wann bekommt man das?
61                      | GotScore Score
62                      | ActionsLeft Int
63                      | NewContact Player
64 -} 
65
66 data ClientMessage = Tell Player Hint
67                    | Goto Place
68
69 type DayCallback d   = DayMessage -> DayMonad d ()
70 type NightCallback d = NightMessage -> NightMonad d ()
71
72 data ParttyState = ParttyState
73         { psHandle      :: Handle
74         , psDay         :: Day
75         , psPlayerInfo  :: Map Player PlayerInformation
76         , psPartyHistory:: [(Day,Place)]
77         , psPlace       :: Place
78         , psPlayers     :: [Player]
79         }
80
81 type DayMonad d   = WriterT [ClientMessage] (ReaderT ParttyState (StateT d IO))
82 type NightMonad d =                          ReaderT ParttyState (StateT d IO)
83
84
85 -- Start
86
87 -- Hostname, Port, Playername, Callback
88 runPartty :: String -> Int -> String -> DayCallback d -> NightCallback d -> IO ()
89 runPartty = undefined
90
91
92 runner :: Handle -> DayCallback d -> NightCallback d -> ParttyState -> d -> IO ()
93 runner h dcb ncb = fix $ \loop ps d -> do
94         (e,ps') <- getNextUserMessage h ps
95         (client_messages, d') <- case e of
96                 Left dm  -> undefined {- run -} dcb dm
97                 Right nm -> undefined {- run -} dcb nm
98         undefined -- send_client_messages client_messages
99         loop ps' d'
100
101 getNextUserMessage :: Handle -> ParttyState -> IO (Either DayMessage NightMessage, ParttyState)
102 getNextUserMessage h ps = do
103         line <- hGetLine h
104         e <- undefined {- parseIncomingMessage -} line
105         let ps' = undefined {- updateState -} e ps
106         case e of
107                 InternalMessage ue -> getNextUserMessage h ps'
108                 DayMessage dm -> return (Left dm, ps')
109                 NightMessage nm -> return (Right nm, ps')
110
111 -- Convenience functions for accessing the state
112
113 whoIsHere :: (MonadReader ParttyState m) => m [Player]
114 whoIsHere = asks psPlayers
115
116 gameDay :: (MonadReader ParttyState m) => m Day
117 gameDay = asks psDay
118
119 -- Interaction: use “tell”
120