module Language.Nomyx.Expression where
import Data.Typeable
import Data.Time
import Control.Applicative hiding (Const)
import Data.Lens.Template
import Data.Data (Data)
import GHC.Read (readListPrecDefault, readListDefault, Read(..), lexP, parens)
import qualified Text.ParserCombinators.ReadPrec as ReadPrec (prec)
import Text.Read.Lex (Lexeme(..))
import Text.ParserCombinators.ReadPrec (reset)
import GHC.Show (showList__)
import Control.Monad.Error
import Language.Nomyx.Utils ((===))
import Data.List (intersperse)
type PlayerNumber = Int
type PlayerName = String
type RuleNumber = Int
type RuleName = String
type RuleDesc = String
type RuleText = String
type RuleCode = String
type EventNumber = Int
type EventName = String
type VarName = String
type GameName = String
type Code = String
data Nomex a where
NewVar :: (Typeable a, Show a, Eq a) => VarName -> a -> Nomex (Maybe (V a))
ReadVar :: (Typeable a, Show a, Eq a) => (V a) -> Nomex (Maybe a)
WriteVar :: (Typeable a, Show a, Eq a) => (V a) -> a -> Nomex Bool
DelVar :: (V a) -> Nomex Bool
OnEvent :: (Typeable e, Show e, Eq e) => Event e -> ((EventNumber, EventData e) -> Nomex ()) -> Nomex EventNumber
DelEvent :: EventNumber -> Nomex Bool
DelAllEvents :: (Typeable e, Show e, Eq e) => Event e -> Nomex ()
SendMessage :: (Typeable a, Show a, Eq a) => Event (Message a) -> a -> Nomex ()
ProposeRule :: Rule -> Nomex Bool
ActivateRule :: RuleNumber -> Nomex Bool
RejectRule :: RuleNumber -> Nomex Bool
AddRule :: Rule -> Nomex Bool
DelRule :: RuleNumber -> Nomex Bool
ModifyRule :: RuleNumber -> Rule -> Nomex Bool
GetRules :: Nomex [Rule]
GetPlayers :: Nomex [PlayerInfo]
SetPlayerName:: PlayerNumber -> PlayerName -> Nomex Bool
DelPlayer :: PlayerNumber -> Nomex Bool
--Mileacenous
SetVictory :: [PlayerNumber] -> Nomex ()
Output :: PlayerNumber -> String -> Nomex ()
CurrentTime :: Nomex UTCTime
SelfRuleNumber :: Nomex RuleNumber
Return :: a -> Nomex a
Bind :: Nomex a -> (a -> Nomex b) -> Nomex b
ThrowError :: String -> Nomex a
CatchError :: Nomex a -> (String -> Nomex a) -> Nomex a
deriving (Typeable)
instance Monad Nomex where
return = Return
(>>=) = Bind
instance Functor Nomex where
fmap f e = Bind e $ Return . f
instance Applicative Nomex where
pure = Return
f <*> a = do
f' <- f
a' <- a
return $ f' a'
instance MonadError String Nomex where
throwError = ThrowError
catchError = CatchError
instance Show a => Show (Nomex a) where
show _ = "Nomex"
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)
type Id a = a
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 a) => Show (EventData a)
deriving instance (Show a) => Show (Message a)
deriving instance (Show a) => Show (InputChoice a)
deriving instance Show Time
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)
data EventStatus = EvActive | EvDeleted deriving (Eq, Show)
data EventHandler where
EH :: (Typeable e, Show e, Eq e) =>
{_eventNumber :: EventNumber,
_ruleNumber :: RuleNumber,
event :: Event e,
handler :: (EventNumber, EventData e) -> Nomex (),
_evStatus :: EventStatus} -> EventHandler
instance Show EventHandler where
show (EH en rn e _ _) = (show en) ++ " " ++ (show rn) ++ " (" ++ (show e) ++"),\n"
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 Msg a = Event (Message a)
type MsgData a = EventData (Message a)
type RuleFunc = Nomex RuleResp
data RuleResp =
Void
| Meta (Rule -> Nomex BoolResp)
deriving (Typeable)
data BoolResp = BoolResp Bool
| MsgResp (Msg Bool)
instance Show RuleResp where
show _ = "RuleResp"
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 SubmitRule = SubmitRule RuleName RuleDesc RuleCode deriving (Show, Read, Eq, Ord, Data, Typeable)
data PlayerInfo = PlayerInfo { _playerNumber :: PlayerNumber,
_playerName :: String}
deriving (Eq, Typeable, Show)
data Game = Game { _gameName :: GameName,
_gameDesc :: GameDesc,
_rules :: [Rule],
_players :: [PlayerInfo],
_variables :: [Var],
_events :: [EventHandler],
_outputs :: [Output],
_victory :: [PlayerNumber],
_currentTime :: UTCTime
}
deriving (Typeable)
data GameDesc = GameDesc { _desc :: String, _agora :: String} deriving (Eq, Show, Read, Ord)
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
instance Read Game where
readPrec = parens $ ReadPrec.prec 11 $ do
Ident "Game" <- lexP;
Punc "{" <- lexP;
Ident "_gameName" <- lexP;
Punc "=" <- lexP;
a1 <- reset readPrec;
Punc "," <- lexP;
Ident "_gameDesc" <- lexP;
Punc "=" <- lexP;
a2 <- reset readPrec;
Punc "," <- lexP;
Ident "_currentTime" <- lexP;
Punc "=" <- lexP;
a3 <- reset readPrec;
Punc "}" <- lexP;
return $ Game a1 a2 [] [] [] [] [] [] a3
readList = readListDefault
readListPrec = readListPrecDefault
instance Show Game where
showsPrec p(Game b1 b2 _ _ _ _ _ _ b3) = showParen (p >= 11) $
showString "Game {" .
showString "_gameName = " .
showsPrec 0 b1 .
showString ", " .
showString "_gameDesc = " .
showsPrec 0 b2 .
showString ", " .
showString "_currentTime = " .
showsPrec 0 b3 .
showString "}"
showList = showList__ (showsPrec 0)
displayGame :: Game -> String
displayGame (Game { _gameName, _rules, _players, _variables, _events, _outputs, _victory, _currentTime}) =
"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) ++ "\n currentTime = " ++ (show _currentTime) ++ "\n"
$( makeLenses [''Game, ''GameDesc, ''Rule, ''PlayerInfo, ''EventHandler, ''Var] )