module Language.Nomyx.Expression where
import Data.Typeable
import Data.Ratio
import Control.Monad.State
import Data.List
import Control.Concurrent.STM
import Language.Haskell.Interpreter.Server
import Data.Time
type PlayerNumber = Int
type PlayerName = String
type RuleNumber = Int
type RuleName = String
type RuleText = String
type RuleCode = String
type EventNumber = Int
type EventName = String
type VarName = String
type GameName = String
type Code = String
data Exp a where
NewVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Exp (Maybe (V a))
DelVar :: (V a) -> Exp Bool
ReadVar :: (Typeable a, Show a, Eq a) => (V a) -> Exp (Maybe a)
WriteVar :: (Typeable a, Show a, Eq a) => (V a) -> a -> Exp Bool
OnEvent :: (Typeable e, Show e, Eq e) => Event e -> ((EventNumber, EventData e) -> Exp ()) -> Exp EventNumber
DelEvent :: EventNumber -> Exp Bool
DelAllEvents :: (Typeable e, Show e, Eq e) => Event e -> Exp ()
SendMessage :: (Typeable a, Show a, Eq a) => Event (Message a) -> a -> Exp ()
Output :: PlayerNumber -> String -> Exp ()
ProposeRule :: Rule -> Exp Bool
ActivateRule :: RuleNumber -> Exp Bool
RejectRule :: RuleNumber -> Exp Bool
AddRule :: Rule -> Exp Bool
DelRule :: RuleNumber -> Exp Bool
ModifyRule :: RuleNumber -> Rule -> Exp Bool
GetRules :: Exp [Rule]
SetVictory :: [PlayerNumber] -> Exp ()
GetPlayers :: Exp [PlayerInfo]
Const :: a -> Exp a
Bind :: Exp a -> (a -> Exp b) -> Exp b
CurrentTime :: Exp UTCTime
SelfRuleNumber :: Exp RuleNumber
deriving (Typeable)
instance Monad Exp where
return = Const
(>>=) = Bind
instance Functor Exp where
fmap f e = Bind e $ Const . f
data V a = V {varName :: String} deriving (Typeable)
data Var = forall a . (Typeable a, Show a, Eq a) =>
Var { vRuleNumber :: Int,
vName :: String,
vData :: a}
instance Show Var where
show (Var a b c) = (show a) ++ " " ++ (show b) ++ " " ++ (show c)
instance Eq Var where
Var a b c == Var d e f = (a,b,c) === (d,e,f)
type Output = (PlayerNumber, String)
data Player = Arrive | Leave deriving (Typeable, Show, Eq)
data RuleEvent = Proposed | Activated | Rejected | Added | Modified | Deleted deriving (Typeable, Show, Eq)
data Time deriving Typeable
data EvRule deriving Typeable
data Message m deriving Typeable
data InputChoice c deriving Typeable
data InputString deriving Typeable
data Victory deriving Typeable
data Event a where
Player :: Player -> Event Player
RuleEv :: RuleEvent -> Event RuleEvent
Time :: UTCTime -> Event Time
Message :: String -> Event (Message m)
InputChoice :: (Eq c, Show c) => PlayerNumber -> String -> [c] -> c -> Event (InputChoice c)
InputString :: PlayerNumber -> String -> Event InputString
Victory :: Event Victory
data EventData a where
PlayerData :: {playerData :: PlayerInfo} -> EventData Player
RuleData :: {ruleData :: Rule} -> EventData RuleEvent
TimeData :: {timeData :: UTCTime} -> EventData Time
MessageData :: (Show m) => {messageData :: m} -> EventData (Message m)
InputChoiceData :: (Show c) => {inputChoiceData :: c} -> EventData (InputChoice c)
InputStringData :: {inputStringData :: String} -> EventData InputString
VictoryData :: {victoryData :: [PlayerInfo]} -> EventData Victory
deriving instance Typeable1 EventData
deriving instance Typeable1 Event
deriving instance (Show a) => Show (Event a)
deriving instance Show Time
deriving instance (Show a) => Show (Message a)
deriving instance (Show a) => Show (InputChoice a)
deriving instance Show InputString
deriving instance Show Victory
deriving instance Eq Time
deriving instance Eq Victory
deriving instance Eq EvRule
deriving instance Eq (InputChoice a)
deriving instance Eq InputString
deriving instance Eq (Message m)
deriving instance (Eq e) => Eq (Event e)
deriving instance (Show a) => Show (EventData a)
data EventHandler where
EH :: (Typeable e, Show e, Eq e) =>
{eventNumber :: EventNumber,
ruleNumber :: RuleNumber,
event :: Event e,
handler :: (EventNumber, EventData e) -> Exp ()} -> EventHandler
instance Show EventHandler where
show (EH en rn e _) = (show en) ++ " " ++ " " ++ (show rn) ++ " (" ++ (show e) ++")"
instance Eq EventHandler where
(EH {eventNumber=e1}) == (EH {eventNumber=e2}) = e1 == e2
instance Ord EventHandler where
(EH {eventNumber=e1}) <= (EH {eventNumber=e2}) = e1 <= e2
type OneParamRule a = a -> Exp RuleResponse
type NoParamRule = Exp ()
data RuleResponse = BoolResp {boolResp :: Bool}
| MsgResp {msgResp :: Event (Message Bool)}
data RuleFunc =
RuleRule {ruleRule :: OneParamRule Rule}
| PlayerRule {playerRule :: OneParamRule PlayerInfo}
| VoidRule {voidRule :: NoParamRule} deriving (Typeable)
instance Show RuleFunc where
show _ = "RuleFunc"
data Rule = Rule { rNumber :: RuleNumber,
rName :: RuleName,
rDescription :: String,
rProposedBy :: PlayerNumber,
rRuleCode :: Code,
rRuleFunc :: RuleFunc,
rStatus :: RuleStatus,
rAssessedBy :: Maybe RuleNumber}
deriving (Typeable, Show)
instance Eq Rule where
(Rule {rNumber=r1}) == (Rule {rNumber=r2}) = r1 == r2
instance Ord Rule where
(Rule {rNumber=r1}) <= (Rule {rNumber=r2}) = r1 <= r2
data RuleStatus = Active
| Pending
| Reject
deriving (Eq, Show, Typeable)
data PlayerInfo = PlayerInfo { playerNumber :: PlayerNumber,
playerName :: String}
deriving (Eq, Typeable, Show)
data Game = Game { gameName :: GameName,
gameDesc :: String,
rules :: [Rule],
players :: [PlayerInfo],
variables :: [Var],
events :: [EventHandler],
outputs :: [Output],
victory :: [PlayerNumber],
currentTime :: UTCTime}
deriving (Typeable)
instance Show Game where
show (Game { gameName, rules, players, variables, events, outputs, victory}) =
"Game Name = " ++ (show gameName) ++ "\n Rules = " ++ (concat $ intersperse "\n " $ map show rules) ++ "\n Players = " ++ (show players) ++ "\n Variables = " ++
(show variables) ++ "\n Events = " ++ (show events) ++ "\n Outputs = " ++ (show outputs) ++ "\n Victory = " ++ (show victory)
instance Eq Game where
(Game {gameName=gn1}) == (Game {gameName=gn2}) = gn1 == gn2
instance Ord Game where
compare (Game {gameName=gn1}) (Game {gameName=gn2}) = compare gn1 gn2
(===) :: (Typeable a, Typeable b, Eq b) => a -> b -> Bool
(===) x y = cast x == Just y
replaceWith :: (a -> Bool)
-> a
-> [a]
-> [a]
replaceWith f y = map (\z -> if f z then y else z)