diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,1 @@ +Corentin Dupont diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright 2012, Corentin Dupont. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,35 @@ + +Introduction +============ + +This library is defining the language that allows you to express rules in Nomic. + +Installation +============ + +This libary is used by the package Nomyx, it should be installed through it by typing: + + cabal install Nomyx + +However, to activate online documentation, install with: + + cabal install --enable-documentation --haddock-hyperlink-source Nomyx-Language + +To install from the git repository: + + git clone git://github.com/cdupont/Nomyx-Language.git + cabal install --enable-documentation --haddock-hyperlink-source Nomyx-Language/ + +Documentation +============= + +The library comes with haddock documentation you can build +(see above). Check examples/Examples.hs to see a list of example rules. +Simply copy-paste those rules (the function name or the code) in the field "code" +on Nomyx web gui and see what happens! + +Contact +======= + +Bug-reports, questions, suggestions and patches are all welcome. + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/nomyx-language.cabal b/nomyx-language.cabal new file mode 100644 --- /dev/null +++ b/nomyx-language.cabal @@ -0,0 +1,65 @@ +name: nomyx-language +version: 1.0.0 +cabal-version: >=1.8 +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: 2012 Corentin Dupont +maintainer: Corentin Dupont +stability: Experimental +synopsis: Language to express rules for Nomic +description: A DSL to express rules in a Nomic game. See package Nomyx for a full game implementation. +category: Language +Homepage: http://www.nomyx.net +author: Corentin Dupont + +data-files: src/Nomyx/Language.hs + src/Nomyx/Language/Types.hs + src/Nomyx/Language/Rules.hs + src/Nomyx/Language/Inputs.hs + src/Nomyx/Language/Outputs.hs + src/Nomyx/Language/Variables.hs + src/Nomyx/Language/Events.hs + src/Nomyx/Language/Messages.hs + src/Nomyx/Language/Players.hs + src/Nomyx/Language/Utils.hs +data-dir: . +extra-source-files: AUTHORS README.md + +library + build-depends: DebugTraceHelpers == 0.12.*, + Boolean == 0.2.*, + base >= 4.6 && < 5, + containers == 0.5.*, + lens >= 4.7 && < 4.15, + ghc >= 7.6 && < 8.1, + mtl >= 2.1 && < 2.3, + old-locale == 1.0.*, + random == 1.1.*, + safe == 0.3.*, + time >= 1.4 && < 1.7, + text, + time-recurrence == 0.9.*, + monad-loops == 0.4.*, + imprevu == 0.1.*, + shortcut == 0.1.* + exposed-modules: Nomyx.Language + Nomyx.Language.Types + Nomyx.Language.Inputs + Nomyx.Language.Outputs + Nomyx.Language.Players + Nomyx.Language.Rules + Nomyx.Language.Messages + Nomyx.Language.Events + Nomyx.Language.Variables + Nomyx.Language.Utils + Paths_nomyx_language + exposed: True + buildable: True + hs-source-dirs: src + ghc-options: -W + +source-repository head + type: git + location: https://github.com/cdupont/nomyx-language.git + diff --git a/src/Nomyx/Language.hs b/src/Nomyx/Language.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Language.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE Trustworthy #-} + +-- | This module re-exports the elements necessary to compose a Nomyx rule. +module Nomyx.Language ( + module Nomyx.Language.Outputs, + module Nomyx.Language.Inputs, + module Nomyx.Language.Events, + module Nomyx.Language.Messages, + module Nomyx.Language.Players, + module Nomyx.Language.Variables, + module Nomyx.Language.Rules, + module Nomyx.Language.Utils, + module Nomyx.Language.Types) where + +import Nomyx.Language.Outputs -- create outputs +import Nomyx.Language.Inputs -- create inputs +import Nomyx.Language.Events -- create events +import Nomyx.Language.Messages -- inter-rule communication +import Nomyx.Language.Players -- manage players +import Nomyx.Language.Variables -- create variables +import Nomyx.Language.Rules -- manage rules +import Nomyx.Language.Types -- Nomyx Expression DSL +import Nomyx.Language.Utils -- Nomyx Utils diff --git a/src/Nomyx/Language/Events.hs b/src/Nomyx/Language/Events.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Language/Events.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} + +-- | All the building blocks to allow rules to build events. +module Nomyx.Language.Events ( + onEvent, onEvent_, onEventOnce, + delEvent, + getEvents, + getIntermediateResults, + schedule, schedule_, schedule', --schedule'_, + getCurrentTime, + oneWeek, oneDay, oneHour, oneMinute, + --timeEvent, messageEvent, victoryEvent, playerEvent, ruleEvent, + --signalEvent, inputFormSignal, + liftEvent, + victoryEvent, timeEvent, + Imprevu.EventNumber, + SomeData, + Victory(..) + ) where + +import Nomyx.Language.Types +import Imprevu (EventNumber) +import qualified Imprevu as Imp +import Data.Typeable +import Data.Time hiding (getCurrentTime) +import Data.Time.Recurrence hiding (filter) + + +-- * Events + +-- | register a callback on an event +onEvent :: (Typeable e, Show e) => Event e -> ((EventNumber, e) -> Nomex ()) -> Nomex EventNumber +onEvent = Imp.onEvent + +-- | register a callback on an event, disregard the event number +onEvent_ :: (Typeable e, Show e) => Event e -> (e -> Nomex ()) -> Nomex EventNumber +onEvent_ = Imp.onEvent_ + +-- | set an handler for an event that will be triggered only once +onEventOnce :: (Typeable e, Show e) => Event e -> (e -> Nomex ()) -> Nomex EventNumber +onEventOnce = Imp.onEventOnce + +delEvent :: EventNumber -> Nomex Bool +delEvent = Imp.delEvent + +getEvents :: Nomex [EventInfo] +getEvents = Imp.getEvents + +getIntermediateResults :: EventNumber -> Nomex (Maybe [(PlayerNumber, SomeData)]) +getIntermediateResults = Imp.getIntermediateResults + +-- | on the provided schedule, the supplied function will be called +schedule :: Schedule Freq -> (UTCTime -> Nomex ()) -> Nomex () +schedule = Imp.schedule + +schedule_ :: Schedule Freq -> Nomex () -> Nomex () +schedule_ = Imp.schedule_ + +--at each time provided, the supplied function will be called +schedule' :: [UTCTime] -> (UTCTime -> Nomex ()) -> Nomex () +schedule' = Imp.schedule' + +--schedule'_ :: [UTCTime] -> Nomex () -> Nomex () +--schedule'_ ts f = schedule' ts (const f) + +-- | get the current time as UTCTime +getCurrentTime :: Nomex UTCTime +getCurrentTime = GetCurrentTime + +-- * Individual events + +-- | Build an event firing at a specific time +timeEvent :: UTCTime -> Event UTCTime +timeEvent = Imp.timeEvent + +data Victory = Victory + deriving (Eq, Show) + +-- | Build a event firing when the victory condition is changed +victoryEvent :: Event VictoryInfo +victoryEvent = SignalEvent $ Signal Victory + +-- | Build a event firing immediatly, yelding the value of the NomexNE +liftEvent :: Nomex a -> Event a +liftEvent = Imp.liftEvent + +-- | duration +oneWeek, oneDay, oneHour, oneMinute :: NominalDiffTime +oneWeek = 7 * oneDay +oneDay = 24 * oneHour +oneHour = 60 * oneMinute +oneMinute = 60 + + + diff --git a/src/Nomyx/Language/Inputs.hs b/src/Nomyx/Language/Inputs.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Language/Inputs.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE GADTs #-} + +-- | All the building blocks to allow rules to get inputs. +-- for example, you can create a button that will display a message like this: +-- do +-- void $ onInputButton_ "Click here:" (const $ outputAll_ "Bravo!") 1 + +module Nomyx.Language.Inputs ( + inputRadio, inputText, inputCheckbox, inputButton, inputTextarea, + onInputRadio, onInputRadio_, onInputRadioOnce, + onInputText, onInputText_, onInputTextOnce, + onInputCheckbox, onInputCheckbox_, onInputCheckboxOnce, + onInputButton, onInputButton_, onInputButtonOnce, + onInputTextarea, onInputTextarea_, onInputTextareaOnce, + ) where + +import Nomyx.Language.Types +import qualified Imprevu as Imp +import Data.Typeable + +-- * Inputs + +-- ** Radio inputs + +-- | event based on a radio input choice +inputRadio :: (Enum c) => PlayerNumber -> String -> [(c, String)] -> Event c +inputRadio = Imp.inputRadio + +-- | triggers a choice input to the user. The result will be sent to the callback +onInputRadio :: (Enum a, Show a, Typeable a) => String -> [(a, String)] -> (EventNumber -> a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputRadio = Imp.onInputRadio + +-- | the same, disregard the event number +onInputRadio_ :: (Enum a, Show a, Typeable a) => String -> [(a, String)] -> (a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputRadio_ = Imp.onInputRadio_ + +-- | the same, suppress the event after first trigger +onInputRadioOnce :: (Enum a, Show a, Typeable a) => String -> [(a, String)] -> (a -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputRadioOnce = Imp.onInputRadioOnce + +-- ** Text inputs + +-- | event based on a text input +inputText :: PlayerNumber -> String -> Event String +inputText = Imp.inputText + +-- | triggers a string input to the user. The result will be sent to the callback +onInputText :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputText = Imp.onInputText + +-- | asks the player pn to answer a question, and feed the callback with this data. +onInputText_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputText_ = Imp.onInputText_ + +-- | asks the player pn to answer a question, and feed the callback with this data. +onInputTextOnce :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputTextOnce = Imp.onInputTextOnce + + +-- ** Checkbox inputs + +-- | event based on a checkbox input +inputCheckbox :: (Enum c) => PlayerNumber -> String -> [(c, String)] -> Event [c] +inputCheckbox = Imp.inputCheckbox + +onInputCheckbox :: (Enum a, Show a, Typeable a) => String -> [(a, String)] -> (EventNumber -> [a] -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputCheckbox = Imp.onInputCheckbox + +onInputCheckbox_ :: (Enum a, Show a, Typeable a) => String -> [(a, String)] -> ([a] -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputCheckbox_ = Imp.onInputCheckbox_ + +onInputCheckboxOnce :: (Enum a, Show a, Typeable a) => String -> [(a, String)] -> ([a] -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputCheckboxOnce = Imp.onInputCheckboxOnce + +-- ** Button inputs + +-- | event based on a button +inputButton :: PlayerNumber -> String -> Event () +inputButton = Imp.inputButton + +onInputButton :: String -> (EventNumber -> () -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputButton = Imp.onInputButton + +onInputButton_ :: String -> (() -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputButton_ = Imp.onInputButton_ + +onInputButtonOnce :: String -> (() -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputButtonOnce = Imp.onInputButtonOnce + + +-- ** Textarea inputs + +-- | event based on a text area +inputTextarea :: PlayerNumber -> String -> Event String +inputTextarea = Imp.inputTextarea + +onInputTextarea :: String -> (EventNumber -> String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputTextarea = Imp.onInputTextarea + +onInputTextarea_ :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputTextarea_ = Imp.onInputTextarea_ + +onInputTextareaOnce :: String -> (String -> Nomex ()) -> PlayerNumber -> Nomex EventNumber +onInputTextareaOnce = Imp.onInputTextareaOnce + + diff --git a/src/Nomyx/Language/Messages.hs b/src/Nomyx/Language/Messages.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Language/Messages.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Nomyx.Language.Messages ( + sendMessage, sendMessage_, + onMessage, onMessageOnce, + APICall(..), onAPICall, callAPI, callAPIBlocking, + Msg) + where + +import Nomyx.Language.Types +import Imprevu (APICall, Msg) +import qualified Imprevu as Imp +import Data.Typeable + +-- * Messages +-- a rule can send a simple message to another rule, and subscribe to a message. + +-- | broadcast a message that can be catched by another rule +sendMessage :: (Typeable a, Show a) => Msg a -> a -> Nomex () +sendMessage = SendMessage + +-- | send an empty message +sendMessage_ :: String -> Nomex () +sendMessage_ = Imp.sendMessage_ + +-- | subscribe on a message +onMessage :: (Typeable m, Show m, Eq m) => Msg m -> (m -> Nomex ()) -> Nomex EventNumber +onMessage = Imp.onMessage + +-- | subscribe on a message, delete it on the first call +onMessageOnce :: (Typeable m, Show m, Eq m) => Msg m -> (m -> Nomex ()) -> Nomex EventNumber +onMessageOnce = Imp.onMessageOnce + +-- * API calls +-- Nomyx Rule can register an API function with 'onAPICall' to provide services to other rules. +-- other Rules are then able to call 'callAPI' or 'callAPIBlocking' to access the services. +-- API calls between Rules are build using message passing. + +-- version with one parameters +onAPICall :: (Typeable a, Show a, Eq a, Typeable r, Show r, Eq r) => APICall a r -> (a -> Nomex r) -> Nomex EventNumber +onAPICall = Imp.onAPICall + +-- | version with one parameters +callAPI :: (Typeable a, Show a, Eq a, Typeable r, Show r, Eq r) => APICall a r -> a -> (r -> Nomex ()) -> Nomex () +callAPI = Imp.callAPI + +-- | call an API function and wait for the result. +callAPIBlocking :: (Typeable a, Show a, Eq a, Typeable r, Show r, Eq r) => APICall a r -> a -> Nomex r +callAPIBlocking = Imp.callAPIBlocking + diff --git a/src/Nomyx/Language/Outputs.hs b/src/Nomyx/Language/Outputs.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Language/Outputs.hs @@ -0,0 +1,69 @@ +-- All the building blocks to allow rules to produce outputs. +-- for example, you can display a message like this: +-- do +-- outputAll_ "hello, world!" + +module Nomyx.Language.Outputs ( + OutputNumber, + newOutput, newOutput_, + outputAll, outputAll_, + getOutput, getOutput_, + updateOutput, + delOutput, + displayVar, displayVar', + displaySimpleVar + ) where + +import Nomyx.Language.Types +import Imprevu +import Data.Typeable +import Control.Monad.State + + +-- * Outputs + +-- | outputs a message to one player, dynamic version +newOutput :: Maybe PlayerNumber -> Nomex String -> Nomex OutputNumber +newOutput = NewOutput + +-- | outputs a message to one player, static version +newOutput_ :: Maybe PlayerNumber -> String -> Nomex OutputNumber +newOutput_ ns mpn = NewOutput ns (return mpn) + +-- | output a message to all players +outputAll :: Nomex String -> Nomex OutputNumber +outputAll = newOutput Nothing + +-- | output a constant message to all players +outputAll_ :: String -> Nomex () +outputAll_ s = void $ newOutput Nothing (return s) + +-- | get an output by number +getOutput :: OutputNumber -> Nomex (Maybe String) +getOutput = GetOutput + +-- | get an output by number, partial version +getOutput_ :: OutputNumber -> Nomex String +getOutput_ on = partial "getOutput_ : Output number not existing" $ getOutput on + +-- | update an output +updateOutput :: OutputNumber -> Nomex String -> Nomex Bool +updateOutput = UpdateOutput + +-- | delete an output +delOutput :: OutputNumber -> Nomex Bool +delOutput = DelOutput + +-- | display a variable +displayVar :: (Typeable a, Show a) => Maybe PlayerNumber -> V a -> (Maybe a -> Nomex String) -> Nomex OutputNumber +displayVar mpn mv dis = newOutput mpn $ readVar mv >>= dis + +-- permanently display a variable +displayVar' :: (Typeable a, Show a) => Maybe PlayerNumber -> V a -> (a -> Nomex String) -> Nomex OutputNumber +displayVar' mpn mv dis = displayVar mpn mv dis' where + dis' Nothing = return $ "Variable " ++ (varName mv) ++ " deleted" + dis' (Just a) = (++ "\n") <$> dis a + +displaySimpleVar :: (Typeable a, Show a) => Maybe PlayerNumber -> V a -> String -> Nomex OutputNumber +displaySimpleVar mpn mv title = displayVar' mpn mv showVar where + showVar a = return $ title ++ ": " ++ (show a) ++ "\n" diff --git a/src/Nomyx/Language/Players.hs b/src/Nomyx/Language/Players.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Language/Players.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +-- | All the building blocks to allow rules to manage players. +-- for example, you can change the name of player 1 with: +-- do +-- void $ modifyPlayerName 1 ("King " ++) + +module Nomyx.Language.Players ( + PlayerNumber, + PlayerName, + PlayerInfo(..), + Player(..), + playerEvent, + playerNumber, playerName, + getPlayers, getPlayer, getPlayerName, getPlayerName', + setPlayerName, + modifyPlayerName, + getPlayersNumber, getAllPlayerNumbers, + delPlayer, + forEachPlayer, forEachPlayer_, + createValueForEachPlayer, createValueForEachPlayer_, + getValueOfPlayer, + modifyValueOfPlayer, modifyAllValues, + showPlayer, + getProposerNumber, getProposerNumber_, + setVictory, + giveVictory + ) where + +import Nomyx.Language.Types +import Imprevu.Events +import Imprevu.Variables +import Nomyx.Language.Rules +import Data.Typeable +import Data.List +import Control.Lens +import Control.Arrow +import Control.Monad + +-- * Players + +-- | get all the players +getPlayers :: Nomex [PlayerInfo] +getPlayers = GetPlayers + +-- | Get a specific player +getPlayer :: PlayerNumber -> Nomex (Maybe PlayerInfo) +getPlayer pn = do + pls <- GetPlayers + return $ find (\a -> a ^. playerNumber == pn) pls + +-- | Get the name of a player +getPlayerName :: PlayerNumber -> Nomex (Maybe PlayerName) +getPlayerName pn = do + p <- getPlayer pn + return $ _playerName <$> p + +-- | Get the name of a player, his number if not found +getPlayerName' :: PlayerNumber -> Nomex PlayerName +getPlayerName' pn = do + mp <- getPlayer pn + return $ case mp of + Just p -> _playerName p + Nothing -> "Player " ++ (show pn) + +-- | Set the name of a player +setPlayerName :: PlayerNumber -> PlayerName -> Nomex Bool +setPlayerName = SetPlayerName + +modifyPlayerName :: PlayerNumber -> (PlayerName -> PlayerName) -> Nomex Bool +modifyPlayerName pn f = do + mn <- getPlayerName pn + case mn of + Just name -> setPlayerName pn (f name) + Nothing -> return False + + +-- | Get the total number of players +getPlayersNumber :: Nomex Int +getPlayersNumber = length <$> getPlayers + +-- | Get all the players number +getAllPlayerNumbers :: Nomex [PlayerNumber] +getAllPlayerNumbers = map _playerNumber <$> getPlayers + +-- | Remove the player from the game (kick) +delPlayer :: PlayerNumber -> Nomex Bool +delPlayer = DelPlayer + + +-- | perform an action for each current players, new players and leaving players +-- returns the event numbers for arriving players and leaving players +forEachPlayer :: (PlayerNumber -> Nomex ()) -> (PlayerNumber -> Nomex ()) -> (PlayerNumber -> Nomex ()) -> Nomex (EventNumber, EventNumber) +forEachPlayer action actionWhenArrive actionWhenLeave = do + pns <- getAllPlayerNumbers + mapM_ action pns + an <- onEvent_ (playerEvent Arrive) $ actionWhenArrive . _playerNumber + ln <- onEvent_ (playerEvent Leave) $ actionWhenLeave . _playerNumber + return (an, ln) + +-- | perform the same action for each players, including new players +-- returns the event numbers for arriving players and leaving players +forEachPlayer_ :: (PlayerNumber -> Nomex ()) -> Nomex (EventNumber, EventNumber) +forEachPlayer_ action = forEachPlayer action action (\_ -> return ()) + +-- | create a value initialized for each players +--manages players joining and leaving +createValueForEachPlayer :: forall a. (Typeable a, Show a, Eq a) => a -> V [(PlayerNumber, a)] -> Nomex (EventNumber, EventNumber) +createValueForEachPlayer initialValue (V mv) = do + pns <- getAllPlayerNumbers + v <- newVar_ mv $ map (,initialValue::a) pns + forEachPlayer (const $ return ()) + (\p -> void $ modifyVar v ((p, initialValue) : )) + (\p -> void $ modifyVar v $ filter $ (/= p) . fst) + +-- | create a value initialized for each players initialized to zero +--manages players joining and leaving +createValueForEachPlayer_ :: V [(PlayerNumber, Int)] -> Nomex (EventNumber, EventNumber) +createValueForEachPlayer_ = createValueForEachPlayer 0 + +getValueOfPlayer :: forall a. (Typeable a, Show a, Eq a) => PlayerNumber -> V [(PlayerNumber, a)] -> Nomex (Maybe a) +getValueOfPlayer pn var = do + mvalue <- readVar var + return $ do + value <- mvalue + lookup pn value + +modifyValueOfPlayer :: (Eq a, Show a, Typeable a) => PlayerNumber -> V [(PlayerNumber, a)] -> (a -> a) -> Nomex Bool +modifyValueOfPlayer pn var f = modifyVar var $ map (\(a,b) -> if a == pn then (a, f b) else (a,b)) + +modifyAllValues :: (Eq a, Show a, Typeable a) => V [(PlayerNumber, a)] -> (a -> a) -> Nomex () +modifyAllValues var f = void $ modifyVar var $ map $ second f + +-- | show a player name based on his number +showPlayer :: PlayerNumber -> Nomex String +showPlayer pn = do + mn <- getPlayerName pn + case mn of + Just name -> return name + Nothing -> return ("Player " ++ show pn) + + +-- | set victory to a list of players +setVictory :: Nomex [PlayerNumber] -> Nomex () +setVictory = SetVictory + +-- | give victory to one player +giveVictory :: PlayerNumber -> Nomex () +giveVictory pn = SetVictory $ return [pn] + +-- | get the player number of the proposer of the rule +getProposerNumber :: Nomex PlayerNumber +getProposerNumber = _rProposedBy <$> getSelfRule + +getProposerNumber_ :: Nomex PlayerNumber +getProposerNumber_ = getProposerNumber + +-- | Build a event firing when a player arrives or leaves +playerEvent :: Player -> Event PlayerInfo +playerEvent p = SignalEvent $ Signal p diff --git a/src/Nomyx/Language/Rules.hs b/src/Nomyx/Language/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Language/Rules.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Basic rules building blocks. +-- for example, you can suppress rule 1 with: +--do +-- suppressRule 1 + +module Nomyx.Language.Rules ( + RuleNumber, + RuleCode, + RuleEvent(..), + RuleStatus(..), + MetaRule, + activateRule, activateRule_, + rejectRule, rejectRule_, + getRules, getActiveRules, getRule, + getRulesByNumbers, + getRuleFuncs, + addRule, addRule_, addRule', + suppressRule, suppressRule_, suppressAllRules, + proposeRule, modifyRule, + autoActivate, + activateOrRejectRule, + simulate, + metaruleVar, createMetaruleVar, addMetarule, testWithMetaRules, displayMetarules, + legal, illegal, noPlayPlayer, immutableRule, + autoDelete, + eraseAllRules, + getSelfRuleNumber, getSelfRule, + onRuleProposed, + showRule, + ruleEvent + ) where + +import Prelude hiding (foldr) +import Nomyx.Language.Types +import Nomyx.Language.Outputs +import Nomyx.Language.Utils +import Imprevu +import Control.Lens +import Control.Monad +import Data.List +import Data.Maybe + +-- * Rule management + +-- | activate a rule: change its state to Active and execute it +activateRule :: RuleNumber -> Nomex Bool +activateRule = ActivateRule + +activateRule_ :: RuleNumber -> Nomex () +activateRule_ r = activateRule r >> return () + +-- | reject a rule: change its state to Suppressed and suppresses all its environment (events, variables, inputs, victory) +-- the rule can be activated again later +rejectRule :: RuleNumber -> Nomex Bool +rejectRule = RejectRule + +rejectRule_ :: RuleNumber -> Nomex () +rejectRule_ r = void $ rejectRule r + +getRules :: Nomex [RuleInfo] +getRules = GetRules + +getActiveRules :: Nomex [RuleInfo] +getActiveRules = filter ((== Active) . _rStatus) <$> getRules + +getRule :: RuleNumber -> Nomex (Maybe RuleInfo) +getRule rn = do + rs <- GetRules + return $ find (\a -> a ^. rNumber == rn) rs + +getRulesByNumbers :: [RuleNumber] -> Nomex [RuleInfo] +getRulesByNumbers = mapMaybeM getRule + +getRuleFuncs :: Nomex [Nomex ()] +getRuleFuncs = map _rRule <$> getRules + +-- | add a rule to the game, it will have to be activated +addRule :: RuleInfo -> Nomex Bool +addRule = AddRule + +addRule_ :: RuleInfo -> Nomex () +addRule_ = void . AddRule + +-- | add a rule to the game as described by the parameters +addRule' :: RuleName -> Rule -> RuleCode -> String -> Nomex RuleNumber +addRule' name rule code desc = do + rns <- map _rNumber <$> getRules + let number = head $ [1..] \\ rns + res <- addRule $ defaultRuleInfo { _rRule = rule, _rNumber = number, _rRuleTemplate = defaultRuleTemplate {_rName = name, _rRuleCode = code, _rDescription = desc}} + return $ if res then number else error "addRule': cannot add rule" + + +suppressRule :: RuleNumber -> Nomex Bool +suppressRule = RejectRule + +suppressRule_ :: RuleNumber -> Nomex () +suppressRule_ = void . RejectRule + +suppressAllRules :: Nomex Bool +suppressAllRules = do + rs <- getRules + res <- mapM (suppressRule . _rNumber) rs + return $ and res + +modifyRule :: RuleNumber -> RuleInfo -> Nomex Bool +modifyRule = ModifyRule + +-- | propose a rule that will need to be voted on. +proposeRule :: RuleInfo -> Nomex Bool +proposeRule = ProposeRule + +-- | allows a rule to retrieve its own number (for auto-deleting for example) +getSelfRuleNumber :: Nomex RuleNumber +getSelfRuleNumber = SelfRuleNumber + +getSelfRule :: Nomex RuleInfo +getSelfRule = do + srn <- getSelfRuleNumber + [rs] <- getRulesByNumbers [srn] + return rs + +-- | activate or reject a rule +activateOrRejectRule :: RuleInfo -> Bool -> Nomex () +activateOrRejectRule r b = if b then activateRule_ (_rNumber r) else rejectRule_ (_rNumber r) + +-- | a rule can autodelete itself (generaly after having performed some actions) +autoDelete :: Nomex () +autoDelete = getSelfRuleNumber >>= suppressRule_ + +-- | All rules from player p are erased: +eraseAllRules :: PlayerNumber -> Nomex Bool +eraseAllRules p = do + rs <- getRules + let myrs = filter (\a -> a ^. rProposedBy == p) rs + res <- mapM (suppressRule . _rNumber) myrs + return $ and res + +-- | This rule will activate automatically any new rule. +autoActivate :: Nomex () +autoActivate = void $ onEvent_ (ruleEvent Proposed) (activateRule_ . _rNumber) + +-- * Meta Rules + +-- | A meta rule is a rule that can juge the legality of another rule. +type MetaRule = RuleInfo -> Nomex Bool + +-- | The meta rules are stored in a list variable +metaruleVar :: V [(String, MetaRule)] +metaruleVar = V "metarules" + +-- | create the meta rule variable +createMetaruleVar :: Nomex () +createMetaruleVar = void $ newVar' metaruleVar [] + +-- | add a new metarule to the list +addMetarule :: MetaRule -> String -> Nomex () +addMetarule mr code = void $ modifyVar metaruleVar ((code, mr):) + +-- | use the list of meta rules to juge a new rule +testWithMetaRules :: RuleInfo -> Nomex Bool +testWithMetaRules r = do + mmrs <- readVar metaruleVar + case mmrs of + Just mrs -> and <$> mapM (($r) . snd) mrs + Nothing -> return False + +displayMetarules :: Nomex () +displayMetarules = void $ displayVar Nothing metaruleVar dispAll where + dispAll mvs = return $ maybe "No meta rules" (("Meta Rules:\n" ++) . concatMap disp) mvs + disp (s, _) = s ++ "\n" + +-- | A rule will be always legal +legal :: MetaRule +legal = const $ return True + +-- | A rule will be always illegal +illegal :: MetaRule +illegal = const $ return False + + +-- | Player p cannot propose any more rules +noPlayPlayer :: PlayerNumber -> MetaRule +noPlayPlayer pn rule = return $ _rProposedBy rule /= pn + +-- | rule number rn cannot be deleted by any incoming rule +-- we simulate the execution of an incoming rule to make sure it doesn't delete the immutable rule +immutableRule :: RuleNumber -> MetaRule +immutableRule rn rule = do + immu <- getRule rn + maybe (return True) (const $ simulate (_rRule rule) (isJust <$> getRule rn)) immu + +-- | simulate the execution of rule "sim" and then run rule "test" over the result +simulate :: Nomex a -> Nomex Bool -> Nomex Bool +simulate = Simu + +-- | sets a callback called for each rule proposed +onRuleProposed :: (RuleInfo -> Nomex ()) -> Nomex () +onRuleProposed f = void $ onEvent_ (ruleEvent Proposed) f + +-- | a default rule +defaultRuleInfo :: RuleInfo +defaultRuleInfo = RuleInfo { + _rNumber = 1, + _rProposedBy = 0, + _rRule = return (), + _rStatus = Pending, + _rAssessedBy = Nothing, + _rModules = [], + _rRuleTemplate = defaultRuleTemplate} + +defaultRuleTemplate :: RuleTemplate +defaultRuleTemplate = RuleTemplate { + _rName = "", + _rDescription = "", + _rRuleCode = "", + _rAuthor = "", + _rPicture = Nothing, + _rCategory = [], + _rDeclarations = []} + +mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b] +mapMaybeM f = liftM catMaybes . mapM f + +showRule :: Show a => a -> Nomex () +showRule x = void $ NewOutput Nothing (return $ show x) + +-- | Build a event firing when an action is made on a rule +ruleEvent :: RuleEvent -> Event RuleInfo +ruleEvent re = SignalEvent $ Signal re diff --git a/src/Nomyx/Language/Types.hs b/src/Nomyx/Language/Types.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Language/Types.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | This module contains the type definitions necessary to build a Nomic rule. +module Nomyx.Language.Types ( + module Nomyx.Language.Types, + module Imprevu.Types) + where + +import Control.Lens +import Control.Monad.Except +import Data.Data (Data) +import Data.Time +import Data.Text +import Data.Typeable +import GHC.Generics +import System.Random +import Imprevu.Types +import Imprevu + +type PlayerNumber = Int +type PlayerName = String +type RuleNumber = Int +type RuleName = String +type RuleDesc = String +type RuleText = String +type RuleCode = String +type OutputNumber = Int +type InputNumber = Int + +-- * Nomyx.Types + +data Nomex a where + --Variables management + NewVar :: (Typeable a, Show a) => VarName -> a -> Nomex (Maybe (V a)) + ReadVar :: (Typeable a, Show a) => V a -> Nomex (Maybe a) + WriteVar :: (Typeable a, Show a) => V a -> a -> Nomex Bool + DelVar :: (V a) -> Nomex Bool + --Events management + OnEvent :: (Typeable e, Show e) => Event e -> ((EventNumber, e) -> Nomex ()) -> Nomex EventNumber + DelEvent :: EventNumber -> Nomex Bool + GetEvents :: Nomex [EventInfo] + SendMessage :: (Typeable a, Show a) => Msg a -> a -> Nomex () + --Rules management + ProposeRule :: RuleInfo -> Nomex Bool + ActivateRule :: RuleNumber -> Nomex Bool + RejectRule :: RuleNumber -> Nomex Bool + AddRule :: RuleInfo -> Nomex Bool + ModifyRule :: RuleNumber -> RuleInfo -> Nomex Bool + GetRules :: Nomex [RuleInfo] + SelfRuleNumber :: Nomex RuleNumber + --Players management + GetPlayers :: Nomex [PlayerInfo] + SetPlayerName :: PlayerNumber -> PlayerName -> Nomex Bool + DelPlayer :: PlayerNumber -> Nomex Bool + --Outputs + NewOutput :: Maybe PlayerNumber -> Nomex String -> Nomex OutputNumber + GetOutput :: OutputNumber -> Nomex (Maybe String) + UpdateOutput :: OutputNumber -> Nomex String -> Nomex Bool + DelOutput :: OutputNumber -> Nomex Bool + --Victory + SetVictory :: Nomex [PlayerNumber] -> Nomex () + --Mileacenous + GetCurrentTime :: Nomex UTCTime + GetRandomNumber :: Random a => (a, a) -> Nomex a + --Monadic bindings + Return :: a -> Nomex a + Bind :: Nomex a -> (a -> Nomex b) -> Nomex b + ThrowError :: String -> Nomex a + CatchError :: Nomex a -> (String -> Nomex a) -> Nomex a + Simu :: Nomex a -> Nomex Bool -> Nomex Bool + +deriving instance Typeable Nomex + +instance Typeable a => Show (Nomex a) where + show _ = "" + +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 EvMgt Nomex where + onEvent = OnEvent + delEvent = DelEvent + getEvents = GetEvents + sendMessage = SendMessage + +instance SysMgt Nomex where + getCurrentTime = GetCurrentTime + getRandomNumber = GetRandomNumber + +instance VarMgt Nomex where + newVar = NewVar + readVar = ReadVar + writeVar = WriteVar + delVar = DelVar + + +-- * Events + +type Event a = EventM Nomex a +type EventInfo = EventInfoN Nomex + +-- | Events parameters +data Player = Arrive | Leave deriving (Typeable, Show, Eq) +data RuleEvent = Proposed | Activated | Rejected | Added | Modified | Deleted deriving (Typeable, Show, Eq) + + +-- * Rule + +-- | Type of a rule function. +type Rule = Nomex () + +-- | An informationnal structure about a rule +data RuleInfo = RuleInfo { _rNumber :: RuleNumber, -- number of the rule (must be unique) + _rProposedBy :: PlayerNumber, -- player proposing the rule + _rRule :: Rule, -- function representing the rule (interpreted from rRuleCode) + _rStatus :: RuleStatus, -- status of the rule + _rAssessedBy :: Maybe RuleNumber, -- which rule accepted or rejected this rule + _rModules :: [ModuleInfo], -- list of modules containing definition (in plain text) + _rRuleTemplate :: RuleTemplate} + deriving (Typeable, Show) + + +data RuleTemplate = RuleTemplate { _rName :: RuleName, -- short name of the rule + _rDescription :: String, -- description of the rule + _rRuleCode :: RuleCode, -- code of the rule as a string + _rAuthor :: String, -- the name of the original author + _rPicture :: Maybe FilePath, -- a file name for the illustration image + _rCategory :: [String], -- categories + _rDeclarations :: [FilePath]} -- additional declarations (Haskell modules) + deriving (Typeable, Show, Read, Data, Generic) + +type Module = Text -- content of the module + +data ModuleInfo = ModuleInfo {_modPath :: FilePath, -- file name of the module + _modContent :: Module} -- content of the module + deriving (Eq, Read, Show, Typeable, Data, Generic, Ord) + +instance Eq RuleInfo where + (RuleInfo {_rNumber=r1}) == (RuleInfo {_rNumber=r2}) = r1 == r2 + +instance Ord RuleInfo where + (RuleInfo {_rNumber=r1}) <= (RuleInfo {_rNumber=r2}) = r1 <= r2 + +instance Eq RuleTemplate where + (RuleTemplate {_rName=r1}) == (RuleTemplate {_rName=r2}) = r1 == r2 + +instance Ord RuleTemplate where + (RuleTemplate {_rName=r1}) <= (RuleTemplate {_rName=r2}) = r1 <= r2 + +-- | the status of a rule. +data RuleStatus = Active -- Active rules forms the current Constitution + | Pending -- Proposed rules + | Reject -- Rejected rules + deriving (Eq, Show, Typeable) + +-- * Player + +-- | informations on players +data PlayerInfo = PlayerInfo { _playerNumber :: PlayerNumber, + _playerName :: String, + _playingAs :: Maybe PlayerNumber} + deriving (Eq, Typeable, Show) + +instance Ord PlayerInfo where + h <= g = (_playerNumber h) <= (_playerNumber g) + +-- * Victory + +data VictoryInfo = VictoryInfo { _vRuleNumber :: RuleNumber, + _vCond :: Nomex [PlayerNumber]} + deriving (Show, Typeable) + + +makeLenses ''RuleInfo +makeLenses ''RuleTemplate +makeLenses ''PlayerInfo +makeLenses ''ModuleInfo diff --git a/src/Nomyx/Language/Utils.hs b/src/Nomyx/Language/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Language/Utils.hs @@ -0,0 +1,14 @@ + +module Nomyx.Language.Utils where + +import Data.Typeable +import Control.Monad + +concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] +concatMapM f xs = liftM concat (mapM f xs) + +instance (Typeable a, Typeable b) => Show (a -> b) where + show e = '<' : (show . typeOf) e ++ ">" + +enumAll :: (Enum a, Show a, Bounded a) => [(a, String)] +enumAll = map (\a -> (a, show a)) (enumFrom minBound) diff --git a/src/Nomyx/Language/Variables.hs b/src/Nomyx/Language/Variables.hs new file mode 100644 --- /dev/null +++ b/src/Nomyx/Language/Variables.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | All the building blocks to allow rules to build variables. +-- for example, you can create a variable with: +--do +-- newVar_ "MyMoney" (0::Int) + +module Nomyx.Language.Variables ( + V(..), + newVar, newVar_, newVar', + readVar, readVar_, + writeVar, + modifyVar, + delVar, + getTempVar, + VarName, + ) where + + +import Nomyx.Language.Types +import Imprevu (V, VarName, getTempVar) +import qualified Imprevu as Imp +import Data.Typeable + +-- * Variables +-- | variable creation +newVar :: (Typeable a, Show a) => VarName -> a -> Nomex (Maybe (V a)) +newVar = Imp.newVar + +newVar_ :: (Typeable a, Show a) => VarName -> a -> Nomex (V a) +newVar_ = Imp.newVar_ + +newVar' :: (Typeable a, Show a) => V a -> a -> Nomex Bool +newVar' = Imp.newVar' + +-- | variable reading +readVar :: (Typeable a, Show a) => V a -> Nomex (Maybe a) +readVar = Imp.readVar + +readVar_ :: (Typeable a, Show a) => V a -> Nomex a +readVar_ = Imp.readVar_ + +-- | variable writing +writeVar :: (Typeable a, Show a) => V a -> a -> Nomex Bool +writeVar = Imp.writeVar + +-- | modify a variable using the provided function +modifyVar :: (Typeable a, Show a) => V a -> (a -> a) -> Nomex Bool +modifyVar = Imp.modifyVar + +-- | delete variable +delVar :: V a -> Nomex Bool +delVar = Imp.delVar +