diff --git a/app/Main.hs b/app/Main.hs index de2cf5a6..27b2c99a 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -16,7 +16,7 @@ main :: IO () main = forever $ do loadEnv dToken <- pack <$> getEnv "DISCORD_TOKEN" - unless (encodeUtf8 dToken =~ "^[A-Za-z0-9_-]{24}[.][A-Za-z0-9_-]{6}[.][A-Za-z0-9_-]{27}$") $ + unless (encodeUtf8 dToken =~ ("^[A-Za-z0-9_-]{24}[.][A-Za-z0-9_-]{6}[.][A-Za-z0-9_-]{27}$" :: String)) $ die "Invalid token format. Please check it is a bot token" prefix <- pack . fromMaybe "!" <$> lookupEnv "PREFIX" dbpath <- getEnv "SQLITE_FILENAME" diff --git a/docs/Roll.md b/docs/Roll.md index 54bd1047..1b5c6127 100644 --- a/docs/Roll.md +++ b/docs/Roll.md @@ -4,6 +4,8 @@ The roll command has a staggering amount of flexibility, as well as additional f Below are listed the current full capabilities of the bot for rolling dice and evaluation expressions. All operations (currently) result in integers or a list. A list of functions is available in the [functions section](#Functions). +You can also generate statistics of an expression. See the [Statistics](#Statistics) section for more information. + ## Basic Operators - Addition @@ -62,6 +64,8 @@ As well as simple expressions, basic list expressions can be formed. You can for As an addendum to custom dice, if a list value is bracketed then it can be used in custom dice. For example, `5d(4#4d6)` rolls five dice, whose sides are determined by rolling 4d6 4 times. Do note that laziness still applies here, meaning that the RNG cap can be very quickly reached. +Lists are limited to 50 items long currently (which is configurable). + ## Functions Here are all the functions, what they take, and what they return. @@ -70,6 +74,8 @@ Here are all the functions, what they take, and what they return. - abs (integer) - the absolute value of an integer - fact (integer < 50) - the factorial of an integer - id (integer) - the integer +- max (integer, integer) - get the maximum item between two items +- min (integer, integer) - get the minimum item between two items - maximum (list) - get the maximum item in a list - minimum (list) - get the minimum item in a list - mod (two integers, second /= 0) - get the modulo of two integers @@ -83,3 +89,31 @@ Here are all the functions, what they take, and what they return. - reverse (list) - reverse the list - sort (list) - sort the list in ascending order - take (integer, list) - take the first `n` values from a list, where `n` is the integer given +- between (integer, integer) - generate a list between the two given integers (inclusive) +- concat (list, list) - concatenate two lists together + +# Statistics + +As well as generating values, statistics based off of expressions can be found. There is a total time limit of 10 seconds for this command, with 5 seconds given to calculations and 5 seconds given to generating the bar chart. + +To get these statistics, calling the `roll` command with the `stats` subcommand will generate the requested statistics. The expression given has to return an integer. + +The bot will give the mean, the standard deviation, and the top ten most common values of the distribution, as well as graphing the entire distribution. + +For example, the result of calling `roll stats 2d20kh1` (roll two twenty sided dice and keep the higher die) can be seen below. + +!["The results of asking for stats of 2d20kh1 (roll two twenty sided dice and keep the highest one). The ten most common rolls are 20 to 11. The mean is 13.825. The standard deviation is about 4.7. The bar chart has values on each integer from 1 to 20, with the height of each bar increasing linearly."](./resources/dicestats_2d20kh1.jpg "the result of asking for stats of 2d20kh1") + +(above: The results of asking for stats of 2d20kh1 (roll two twenty sided dice and keep the highest one). The ten most common rolls are 20 to 11. The mean is 13.825. The standard deviation is about 4.7. The bar chart has values on each integer from 1 to 20, with the height of each bar increasing linearly.) + +Currently, the statistics generation supports all valid expressions. + +If invalid states occur (such as with division by zero, negative exponents, or infinite rerolls) the bot will alert the user only if the entire distribution becomes empty. For example, in `1d20rr<(21-d{0,1})`, half of the time infinite rerolls will occur. In this case, these invalid cases are ignored, as they can never be actually rolled, and the only value output is `20`. If the expression given is instead `1/0`, the entire distribution will be empty, as there is no valid output from this expression. + +As well as statistics for a given expression, multiple expressions can be shown in the same instance. + +For example, the result of calling `roll stats 2d20kh1 4d6dl1` is as follows. + +!["The results of asking for stats of 2d20kh1 and 4d6dl1 (roll two twenty sided dice and keep the highest one, and roll four dice with six sides, and drop the lowest value of each). The most common rolls for each expression are 20 to 16, and 13, 12, 14, 11, and 15. The means are about 13.8 and 12.2. The standard deviation are about 4.7 and 2.8. The bar chart has blue values on each integer from 1 to 20, with the height of each bar increasing linearly, and green values that form a weighted bell curve centered on 13."](./resources/dicestats_2d20kh1_4d6dl1.jpg "the result of asking for stats of 2d20kh1 and 4d6dl1") + +(above: The results of asking for stats of 2d20kh1 and 4d6dl1 (roll two twenty sided dice and keep the highest one, and roll four dice with six sides, and drop the lowest value of each). The most common rolls for each expression are 20 to 16, and 13, 12, 14, 11, and 15. The means are about 13.8 and 12.2. The standard deviation are about 4.7 and 2.8. The bar chart has blue values on each integer from 1 to 20, with the height of each bar increasing linearly, and green values that form a weighted bell curve centered on 13.) diff --git a/docs/resources/dicestats_2d20kh1.jpg b/docs/resources/dicestats_2d20kh1.jpg new file mode 100755 index 00000000..85eefe42 Binary files /dev/null and b/docs/resources/dicestats_2d20kh1.jpg differ diff --git a/docs/resources/dicestats_2d20kh1_4d6dl1.jpg b/docs/resources/dicestats_2d20kh1_4d6dl1.jpg new file mode 100755 index 00000000..f3219414 Binary files /dev/null and b/docs/resources/dicestats_2d20kh1_4d6dl1.jpg differ diff --git a/package.yaml b/package.yaml index ba831b5e..1ce76393 100644 --- a/package.yaml +++ b/package.yaml @@ -57,14 +57,20 @@ dependencies: - safe - edit-distance - unliftio +- Chart +- Chart-diagrams +- diagrams-core +- diagrams-lib +- diagrams-rasterific +- JuicyPixels - split - regex-pcre +- distribution library: source-dirs: src default-extensions: - OverloadedStrings - - ImportQualifiedPost - LambdaCase - EmptyDataDecls - FlexibleContexts @@ -88,6 +94,7 @@ library: - ScopedTypeVariables - TypeOperators - RankNTypes + - BangPatterns ghc-options: - -Wall diff --git a/src/Tablebot/Internal/Handler/Command.hs b/src/Tablebot/Internal/Handler/Command.hs index 910bb46e..4e7575ce 100644 --- a/src/Tablebot/Internal/Handler/Command.hs +++ b/src/Tablebot/Internal/Handler/Command.hs @@ -68,30 +68,9 @@ parseCommands cs m prefix = case parse (parser cs) "" (messageText m) of parser cs' = do _ <- chunk prefix - res <- parser' cs' - case res of - Nothing -> fail "No command with that name was found!" - Just p -> return p - parser' :: [CompiledCommand] -> Parser (Maybe (Message -> CompiledDatabaseDiscord ())) - parser' cs' = - do - -- 1. Parse the command name (fails if no such command exists). - res <- choice (map matchCommand cs') <|> return Nothing - case res of - Nothing -> return Nothing - Just (command, subcommands) -> - do - -- 2. Try to get a subcommand. - maybeComm <- parser' subcommands - case maybeComm of - -- 2.1. If there's a subcommand, use that. - Just pars -> return (Just pars) - -- 2.2. Otherwise, use the main command. - Nothing -> Just <$> command - matchCommand :: CompiledCommand -> Parser (Maybe (Parser (Message -> CompiledDatabaseDiscord ()), [CompiledCommand])) - matchCommand c = do - try (chunk (commandName c) *> (skipSpace1 <|> eof)) - return (Just (commandParser c, commandSubcommands c)) + choice (map toErroringParser cs') "No command with that name was found!" + toErroringParser :: CompiledCommand -> Parser (Message -> CompiledDatabaseDiscord ()) + toErroringParser c = try (chunk $ commandName c) *> (skipSpace1 <|> eof) *> (try (choice $ map toErroringParser $ commandSubcommands c) <|> commandParser c) data ReadableError = UnknownError | KnownError String [String] deriving (Show, Eq, Ord) @@ -136,7 +115,7 @@ makeReadable (TrivialError i _ good) = getLabel :: [ErrorItem (Token Text)] -> (Maybe String, [String]) getLabel [] = (Nothing, []) getLabel ((Tokens nel) : xs) = (Nothing, [NE.toList nel]) <> getLabel xs - getLabel ((Label ls) : xs) = (Just (NE.toList ls), []) <> getLabel xs + getLabel ((Label ls) : xs) = (Just (NE.toList ls <> "\n"), []) <> getLabel xs getLabel (EndOfInput : xs) = (Nothing, ["no more input"]) <> getLabel xs makeReadable e = (mapParseError (const UnknownError) e, Nothing) diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceData.hs b/src/Tablebot/Plugins/Roll/Dice/DiceData.hs index 0f7dece1..76c94efa 100644 --- a/src/Tablebot/Plugins/Roll/Dice/DiceData.hs +++ b/src/Tablebot/Plugins/Roll/Dice/DiceData.hs @@ -22,10 +22,21 @@ data ArgValue = AVExpr Expr | AVListValues ListValues deriving (Show) -- | The type for list values. -data ListValues = MultipleValues NumBase Base | LVFunc (FuncInfoBase IO [Integer]) [ArgValue] | LVBase ListValuesBase +data ListValues + = -- | Represents `N#B`, where N is a NumBase (numbers, parentheses) and B is a Base (numbase or dice value) + MultipleValues NumBase Base + | -- | Represents a function call with the given arguments + LVFunc (FuncInfoBase [Integer]) [ArgValue] + | -- | A base ListValues value - parentheses or a list of expressions + LVBase ListValuesBase deriving (Show) -- | The type for basic list values (that can be used as is for custom dice). +-- +-- A basic list value can be understood as one that is indivisible, and/or +-- atomic. They represent either a list value in parentheses, or a list of +-- expressions. Effectively what this is used for is so that these can be used +-- as dice side values. data ListValuesBase = LVBParen (Paren ListValues) | LVBList [Expr] deriving (Show) @@ -47,7 +58,7 @@ data Expo = Expo Func Expo | NoExpo Func deriving (Show) -- | The type representing a single function application, or a base item. -data Func = Func (FuncInfo IO) [ArgValue] | NoFunc Base +data Func = Func FuncInfo [ArgValue] | NoFunc Base deriving (Show) -- | The type representing an integer value or an expression in brackets. diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs b/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs index 74cf08e4..d4a1b300 100644 --- a/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs +++ b/src/Tablebot/Plugins/Roll/Dice/DiceEval.hs @@ -8,7 +8,7 @@ -- -- Functions, type classes, and other utilities to evaluate dice values and -- expressions. -module Tablebot.Plugins.Roll.Dice.DiceEval (PrettyShow (prettyShow), evalList, evalInteger) where +module Tablebot.Plugins.Roll.Dice.DiceEval (PrettyShow (prettyShow), evalList, evalInteger, evaluationException, propagateException) where import Control.Monad (when) import Control.Monad.Exception (MonadException) @@ -37,6 +37,9 @@ newtype RNGCount = RNGCount {getRNGCount :: Integer} deriving (Eq, Ord) maximumRNG :: RNGCount maximumRNG = RNGCount 150 +maximumListLength :: Integer +maximumListLength = 50 + -- | Increment the rngcount by 1. incRNGCount :: RNGCount -> RNGCount incRNGCount (RNGCount i) = RNGCount (i + 1) @@ -136,7 +139,9 @@ class IOEvalList a where -- displayed. This function adds the current location to the exception -- callstack. evalShowL :: PrettyShow a => RNGCount -> a -> IO ([(Integer, Text)], Maybe Text, RNGCount) - evalShowL rngCount a = propagateException (prettyShow a) (evalShowL' rngCount a) + evalShowL rngCount a = do + (is, mt, rngCount') <- propagateException (prettyShow a) (evalShowL' rngCount a) + return (genericTake maximumListLength is, mt, rngCount') evalShowL' :: PrettyShow a => RNGCount -> a -> IO ([(Integer, Text)], Maybe Text, RNGCount) @@ -359,7 +364,7 @@ instance IOEval Func where evalShow' rngCount (NoFunc b) = evalShow rngCount b -- | Evaluate a function when given a list of parameters -evaluateFunction :: RNGCount -> FuncInfoBase IO j -> [ArgValue] -> IO (j, Text, RNGCount) +evaluateFunction :: RNGCount -> FuncInfoBase j -> [ArgValue] -> IO (j, Text, RNGCount) evaluateFunction rngCount fi exprs = do (exprs', rngCount') <- evalShowList'' (\r a -> evalArgValue r a >>= \(i, r') -> return (i, "", r')) rngCount exprs f <- funcInfoFunc fi (fst <$> exprs') diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceFunctions.hs b/src/Tablebot/Plugins/Roll/Dice/DiceFunctions.hs index d0c80295..b24dbd8b 100644 --- a/src/Tablebot/Plugins/Roll/Dice/DiceFunctions.hs +++ b/src/Tablebot/Plugins/Roll/Dice/DiceFunctions.hs @@ -36,20 +36,22 @@ factorialLimit = 50 -- | Mapping from function names to the functions themselves for integer -- functions. -integerFunctions :: MonadException m => Map Text (FuncInfo m) +integerFunctions :: Map Text FuncInfo integerFunctions = M.fromList $ fmap (\fi -> (funcInfoName fi, fi)) integerFunctions' -- | The names of the integer functions currently supported. integerFunctionsList :: [Text] -integerFunctionsList = M.keys (integerFunctions @IO) +integerFunctionsList = M.keys integerFunctions -- | The base details of the integer functions, containing all the information -- for each function that returns an integer. -integerFunctions' :: MonadException m => [FuncInfo m] +integerFunctions' :: [FuncInfo] integerFunctions' = funcInfoIndex : constructFuncInfo "length" (genericLength @Integer @Integer) : constructFuncInfo "sum" (sum @[] @Integer) : + constructFuncInfo "max" (max @Integer) : + constructFuncInfo "min" (min @Integer) : constructFuncInfo "maximum" (maximum @[] @Integer) : constructFuncInfo "minimum" (minimum @[] @Integer) : constructFuncInfo' "mod" (mod @Integer) (Nothing, Nothing, (== 0)) : @@ -63,23 +65,27 @@ integerFunctions' = | otherwise = n * fact (n - 1) -- | Mapping from function names to the functions themselves for list functions. -listFunctions :: MonadException m => Map Text (FuncInfoBase m [Integer]) +listFunctions :: Map Text (FuncInfoBase [Integer]) listFunctions = M.fromList $ fmap (\fi -> (funcInfoName fi, fi)) listFunctions' -- | The names of the list functions currently supported. listFunctionsList :: [Text] -listFunctionsList = M.keys (listFunctions @IO) +listFunctionsList = M.keys listFunctions -- | The base details of the list functions, containing all the information for -- each function that returns an integer. -listFunctions' :: MonadException m => [FuncInfoBase m [Integer]] +listFunctions' :: [FuncInfoBase [Integer]] listFunctions' = - constructFuncInfo @[Integer] "drop" (genericDrop @Integer) : + constructFuncInfo "concat" (++) : + constructFuncInfo "between" between : + constructFuncInfo "drop" (genericDrop @Integer) : constructFuncInfo "take" (genericTake @Integer) : (uncurry constructFuncInfo <$> [("sort", sort), ("reverse", reverse)]) + where + between i i' = let (mi, ma, rev) = (min i i', max i i', if i > i' then reverse else id) in rev [mi .. ma] -- | The `FuncInfo` of the function that indexes into a list. -funcInfoIndex :: FuncInfo m +funcInfoIndex :: FuncInfo funcInfoIndex = FuncInfo "index" [ATInteger, ATIntegerList] ATInteger fiIndex where fiIndex (LIInteger i : [LIList is]) @@ -89,20 +95,20 @@ funcInfoIndex = FuncInfo "index" [ATInteger, ATIntegerList] ATInteger fiIndex -- | A data structure to contain the information about a given function, -- including types, the function name, and the function itself. -data FuncInfoBase m j = FuncInfo {funcInfoName :: Text, funcInfoParameters :: [ArgType], funcReturnType :: ArgType, funcInfoFunc :: MonadException m => [ListInteger] -> m j} +data FuncInfoBase j = FuncInfo {funcInfoName :: Text, funcInfoParameters :: [ArgType], funcReturnType :: ArgType, funcInfoFunc :: forall m. (MonadException m) => [ListInteger] -> m j} -type FuncInfo m = FuncInfoBase m Integer +type FuncInfo = FuncInfoBase Integer -instance Show (FuncInfoBase m j) where +instance Show (FuncInfoBase j) where show (FuncInfo fin ft frt _) = "FuncInfo " <> unpack fin <> " " <> show ft <> " " <> show frt -- | A simple way to construct a function that returns a value j, and has no -- constraints on the given values. -constructFuncInfo :: forall j f m. (MonadException m, ApplyFunc m f, Returns f ~ j) => Text -> f -> FuncInfoBase m j +constructFuncInfo :: forall j f. (ApplyFunc f, Returns f ~ j) => Text -> f -> FuncInfoBase j constructFuncInfo s f = constructFuncInfo' s f (Nothing, Nothing, const False) -- | Construct a function info when given optional constraints. -constructFuncInfo' :: forall j f m. (MonadException m, ApplyFunc m f, Returns f ~ j) => Text -> f -> (Maybe Integer, Maybe Integer, Integer -> Bool) -> FuncInfoBase m j +constructFuncInfo' :: forall j f. (ApplyFunc f, Returns f ~ j) => Text -> f -> (Maybe Integer, Maybe Integer, Integer -> Bool) -> FuncInfoBase j constructFuncInfo' s f bs = FuncInfo s params (last types) (applyFunc f (fromIntegral (length params)) bs) where types = getTypes f @@ -144,12 +150,16 @@ instance ArgCount f => ArgCount ([Integer] -> f) where -- -- If the number of inputs is incorrect or the value given out of the range, an -- exception is thrown. -class ArgCount f => ApplyFunc m f where +class ArgCount f => ApplyFunc f where -- | Takes a function, the number of arguments in the function overall, bounds -- on integer values to the function, and a list of `ListInteger`s (which are -- either a list of integers or an integer), and returns a wrapped `j` value, -- which is a value that the function originally returns. - applyFunc :: (MonadException m, Returns f ~ j) => f -> Integer -> (Maybe Integer, Maybe Integer, Integer -> Bool) -> [ListInteger] -> m j + -- + -- The bounds represent the exclusive lower bound, the exclusive upper bound, + -- and an arbitrary function which results in an exception when it is true; + -- say, with division when you want to deny just 0 as a value. + applyFunc :: forall m j. (MonadException m, Returns f ~ j) => f -> Integer -> (Maybe Integer, Maybe Integer, Integer -> Bool) -> [ListInteger] -> m j -- | Check whether a given value is within the given bounds. checkBounds :: (MonadException m) => Integer -> (Maybe Integer, Maybe Integer, Integer -> Bool) -> m Integer @@ -159,22 +169,34 @@ checkBounds i (ml, mh, bs) | bs i = throwBot $ EvaluationException ("invalid value for function: `" <> show i ++ "`") [] | otherwise = return i -instance {-# OVERLAPPING #-} ApplyFunc m Integer where +-- This is one of two base cases for applyFunc. This is the case where the +-- return value is an integer. As it is the return value, no arguments are +-- accepted. +instance {-# OVERLAPPING #-} ApplyFunc Integer where applyFunc f _ _ [] = return f applyFunc _ args _ _ = throwBot $ EvaluationException ("incorrect number of arguments to function. expected " <> show args <> ", got more than that") [] -instance {-# OVERLAPPING #-} ApplyFunc m [Integer] where +-- This is one of two base cases for applyFunc. This is the case where the +-- return value is a list of integers. As it is the return value, no arguments +-- are accepted. +instance {-# OVERLAPPING #-} ApplyFunc [Integer] where applyFunc f _ _ [] = return f applyFunc _ args _ _ = throwBot $ EvaluationException ("incorrect number of arguments to function. expected " <> show args <> ", got more than that") [] -instance {-# OVERLAPPABLE #-} (ApplyFunc m f) => ApplyFunc m (Integer -> f) where +-- This is one of two recursive cases for applyFunc. This is the case where the +-- argument value is an integer. If there are no arguments or the argument is +-- of the wrong type, an exception is thrown. +instance {-# OVERLAPPABLE #-} (ApplyFunc f) => ApplyFunc (Integer -> f) where applyFunc f args _ [] = throwBot $ EvaluationException ("incorrect number of arguments to function. got " <> show dif <> ", expected " <> show args) [] where dif = args - getArgs f applyFunc f args bs ((LIInteger x) : xs) = checkBounds x bs >>= \x' -> applyFunc (f x') args bs xs applyFunc _ _ _ (_ : _) = throwBot $ EvaluationException "incorrect type given to function. expected an integer, got a list" [] -instance {-# OVERLAPPABLE #-} (ApplyFunc m f) => ApplyFunc m ([Integer] -> f) where +-- This is one of two recursive cases for applyFunc. This is the case where the +-- argument value is a list of integers. If there are no arguments or the +-- argument is of the wrong type, an exception is thrown. +instance {-# OVERLAPPABLE #-} (ApplyFunc f) => ApplyFunc ([Integer] -> f) where applyFunc f args _ [] = throwBot $ EvaluationException ("incorrect number of arguments to function. got " <> show dif <> ", expected " <> show args) [] where dif = args - getArgs f diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceParsing.hs b/src/Tablebot/Plugins/Roll/Dice/DiceParsing.hs index 977aa876..2560528c 100644 --- a/src/Tablebot/Plugins/Roll/Dice/DiceParsing.hs +++ b/src/Tablebot/Plugins/Roll/Dice/DiceParsing.hs @@ -13,11 +13,11 @@ module Tablebot.Plugins.Roll.Dice.DiceParsing () where import Data.Functor (($>), (<&>)) +import Data.List (sortBy) import Data.List.NonEmpty as NE (fromList) import Data.Map as M (Map, findWithDefault, keys, map, (!)) -import Data.Maybe (fromMaybe) import Data.Set as S (Set, fromList, map) -import Data.Text (Text, singleton, unpack) +import qualified Data.Text as T import Tablebot.Plugins.Roll.Dice.DiceData import Tablebot.Plugins.Roll.Dice.DiceFunctions ( ArgType (..), @@ -26,27 +26,26 @@ import Tablebot.Plugins.Roll.Dice.DiceFunctions listFunctions, ) import Tablebot.Utility.Parser (integer, parseCommaSeparated1, skipSpace) -import Tablebot.Utility.SmartParser (CanParse (..)) +import Tablebot.Utility.SmartParser (CanParse (..), ()) import Tablebot.Utility.Types (Parser) import Text.Megaparsec (MonadParsec (try), choice, failure, optional, (), (<|>)) import Text.Megaparsec.Char (char, string) import Text.Megaparsec.Error (ErrorItem (Tokens)) -- | An easier way to handle failure in parsers. -failure' :: Text -> Set Text -> Parser a -failure' s ss = failure (Just $ Tokens $ NE.fromList $ unpack s) (S.map (Tokens . NE.fromList . unpack) ss) +failure' :: T.Text -> Set T.Text -> Parser a +failure' s ss = failure (Just $ Tokens $ NE.fromList $ T.unpack s) (S.map (Tokens . NE.fromList . T.unpack) ss) instance CanParse ListValues where pars = do - try (LVBase <$> pars) - <|> try - ( do - nb <- pars - _ <- char '#' - MultipleValues nb <$> pars - ) - <|> functionParser (listFunctions @IO) LVFunc + LVBase <$> pars + <|> functionParser listFunctions LVFunc + <|> ( do + nb <- pars + _ <- char '#' + MultipleValues nb <$> pars + ) instance CanParse ListValuesBase where pars = do @@ -54,10 +53,13 @@ instance CanParse ListValuesBase where <$> ( try (char '{' *> skipSpace) *> parseCommaSeparated1 pars <* skipSpace - <* char '}' + <* (char '}' "could not find closing brace for list") ) - <|> LVBParen + <|> LVBParen . unnest <$> pars + where + unnest (Paren (LVBase (LVBParen e))) = e + unnest e = e -- | Helper function to try to parse the second part of a binary operator. binOpParseHelp :: (CanParse a) => Char -> (a -> a) -> Parser a @@ -74,19 +76,21 @@ instance CanParse Term where binOpParseHelp '*' (Multi t) <|> binOpParseHelp '/' (Div t) <|> (return . NoTerm) t instance CanParse Func where - pars = try (functionParser (integerFunctions @IO) Func) <|> NoFunc <$> pars + pars = functionParser integerFunctions Func <|> NoFunc <$> pars -- | A generic function parser that takes a mapping from function names to -- functions, the main way to contruct the function data type `e`, and a -- constructor for `e` that takes only one value, `a` (which has its own, -- previously defined parser). -functionParser :: M.Map Text (FuncInfoBase m j) -> (FuncInfoBase m j -> [ArgValue] -> e) -> Parser e +functionParser :: M.Map T.Text (FuncInfoBase j) -> (FuncInfoBase j -> [ArgValue] -> e) -> Parser e functionParser m mainCons = do - fi <- try (choice (string <$> M.keys m) >>= \t -> return (m M.! t)) "could not find function" + fi <- try (choice (string <$> functionNames) >>= \t -> return (m M.! t)) "could not find function" let ft = funcInfoParameters fi - es <- skipSpace *> string "(" *> skipSpace *> parseArgValues ft <* skipSpace <* (try (string ")") "expected only " ++ show (length ft) ++ " arguments, got more") + es <- skipSpace *> string "(" *> skipSpace *> parseArgValues ft <* skipSpace <* (string ")" "could not find closing bracket on function call") return $ mainCons fi es + where + functionNames = sortBy (\a b -> compare (T.length b) (T.length a)) $ M.keys m instance CanParse Negation where pars = @@ -100,45 +104,50 @@ instance CanParse Expo where instance CanParse NumBase where pars = - try (NBParen . unnest <$> pars) - <|> Value <$> integer + (NBParen . unnest <$> pars) + <|> Value <$> integer "could not parse integer" where - unnest (Paren (NoExpr (NoTerm (NoNeg (NoExpo (NoFunc (NBase (NBParen (Paren e))))))))) = Paren e + unnest (Paren (NoExpr (NoTerm (NoNeg (NoExpo (NoFunc (NBase (NBParen e)))))))) = e unnest e = e instance (CanParse a) => CanParse (Paren a) where - pars = char '(' *> skipSpace *> (Paren <$> pars) <* skipSpace <* char ')' + pars = try (char '(') *> skipSpace *> (Paren <$> pars) <* skipSpace <* char ')' instance CanParse Base where - pars = try (DiceBase <$> pars) <|> try (NBase <$> pars) + pars = + ( do + nb <- try pars + (DiceBase <$> parseDice nb) + <|> return (NBase nb) + ) + <|> DiceBase <$> parseDice (Value 1) instance CanParse Die where pars = do - _ <- char 'd' + _ <- try (char 'd') "could not find 'd' for die" lazyFunc <- (try (char '!') $> LazyDie) <|> return id - try - ( lazyFunc . CustomDie - <$> pars - ) - <|> lazyFunc . Die - <$> pars + lazyFunc + <$> ( (CustomDie . LVBParen <$> try pars <|> Die . NBParen <$> pars) + <|> ( (CustomDie <$> pars "could not parse list values for die") + <|> (Die <$> pars "could not parse base number for die") + ) + ) -instance CanParse Dice where - pars = do - t <- optional $ try (pars :: Parser NumBase) - bd <- parseDice' - let t' = NBase $ fromMaybe (Value 1) t - return $ bd t' +-- | Given a `NumBase` (the value on the front of a set of dice), construct a +-- set of dice. +parseDice :: NumBase -> Parser Dice +parseDice nb = parseDice' <*> return (NBase nb) -- | Helper for parsing Dice, where as many `Dice` as possible are parsed and a -- function that takes a `Base` value and returns a `Dice` value is returned. -- This `Base` value is meant to be first value that `Dice` have. parseDice' :: Parser (Base -> Dice) parseDice' = do - d <- pars :: Parser Die + d <- (pars :: Parser Die) mdor <- parseDieOpRecur + ( do - bd <- try parseDice' + bd <- try parseDice' "trying to recurse dice failed" return (\b -> bd (DiceBase $ Dice b d mdor)) ) <|> return (\b -> Dice b d mdor) @@ -147,24 +156,23 @@ parseDice' = do parseAdvancedOrdering :: Parser AdvancedOrdering parseAdvancedOrdering = (try (choice opts) "could not parse an ordering") >>= matchO where - matchO :: Text -> Parser AdvancedOrdering matchO s = M.findWithDefault (failure' s (S.fromList opts')) s (M.map return $ fst advancedOrderingMapping) - opts' = M.keys $ fst advancedOrderingMapping + opts' = sortBy (\a b -> compare (T.length b) (T.length a)) $ M.keys $ fst advancedOrderingMapping opts = fmap string opts' -- | Parse a `LowHighWhere`, which is an `h` followed by an integer. parseLowHigh :: Parser LowHighWhere -parseLowHigh = (try (choice @[] $ char <$> "lhw") "could not parse high, low or where") >>= helper +parseLowHigh = ((choice @[] $ char <$> "lhw") "could not parse high, low or where") >>= helper where helper 'h' = High <$> pars helper 'l' = Low <$> pars helper 'w' = parseAdvancedOrdering >>= \o -> pars <&> Where o - helper c = failure' (singleton c) (S.fromList ["h", "l", "w"]) + helper c = failure' (T.singleton c) (S.fromList ["h", "l", "w"]) -- | Parse a bunch of die options into, possibly, a DieOpRecur. parseDieOpRecur :: Parser (Maybe DieOpRecur) parseDieOpRecur = do - dopo <- optional (try parseDieOpOption) + dopo <- optional parseDieOpOption maybe (return Nothing) (\dopo' -> Just . DieOpRecur dopo' <$> parseDieOpRecur) dopo -- | Parse a single die option. @@ -173,17 +181,22 @@ parseDieOpOption = do lazyFunc <- (try (char '!') $> DieOpOptionLazy) <|> return id ( ( (try (string "ro") *> parseAdvancedOrdering >>= \o -> Reroll True o <$> pars) <|> (try (string "rr") *> parseAdvancedOrdering >>= \o -> Reroll False o <$> pars) - <|> ((try (char 'k') *> parseLowHigh) <&> DieOpOptionKD Keep) - <|> ((try (char 'd') *> parseLowHigh) <&> DieOpOptionKD Drop) + <|> ( ( ((try (char 'k') *> parseLowHigh) <&> DieOpOptionKD Keep) + <|> ((try (char 'd') *> parseLowHigh) <&> DieOpOptionKD Drop) + ) + "could not parse keep/drop" + ) ) <&> lazyFunc ) "could not parse dieOpOption - expecting one of the options described in the doc (call `help roll` to access)" +-- | Parse a single `ArgType` into an `ArgValue`. parseArgValue :: ArgType -> Parser ArgValue -parseArgValue ATIntegerList = AVListValues <$> try pars "could not parse a list value from the argument" -parseArgValue ATInteger = AVExpr <$> try pars "could not parse an integer from the argument" +parseArgValue ATIntegerList = AVListValues <$> pars "could not parse a list value from the argument" +parseArgValue ATInteger = AVExpr <$> pars "could not parse an integer from the argument" +-- | Parse a list of comma separated arguments. parseArgValues :: [ArgType] -> Parser [ArgValue] parseArgValues [] = return [] parseArgValues [at] = (: []) <$> parseArgValue at diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceStats.hs b/src/Tablebot/Plugins/Roll/Dice/DiceStats.hs new file mode 100644 index 00000000..fba5dbbb --- /dev/null +++ b/src/Tablebot/Plugins/Roll/Dice/DiceStats.hs @@ -0,0 +1,246 @@ +-- | +-- Module : Tablebot.Plugins.Roll.Dice.DiceStats +-- Description : Get statistics on particular expressions. +-- License : MIT +-- Maintainer : tagarople@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- This plugin generates statistics based on the values of dice in given +-- expressions. +module Tablebot.Plugins.Roll.Dice.DiceStats (rangeExpr, rangeListValues, getStats) where + +import Control.Monad +import Control.Monad.Exception +import Data.Bifunctor (Bifunctor (first)) +import Data.Distribution hiding (Distribution, Experiment, fromList) +import qualified Data.Distribution as D +import Data.List +import Tablebot.Plugins.Roll.Dice.DiceData +import Tablebot.Plugins.Roll.Dice.DiceEval +import Tablebot.Plugins.Roll.Dice.DiceFunctions +import Tablebot.Plugins.Roll.Dice.DiceStatsBase (Distribution) +import Tablebot.Utility.Exception (catchBot) + +-- | Alias for an experiment of integers. +-- +-- Where a distribution is a concrete mapping between values and probabilities, +-- an Experiment is more a monadic representation of a Distribution, effectively +-- deferring calculation to the end. +-- +-- I'm not sure if it's more efficient but it certainly makes composing things +-- a lot easier +type Experiment = D.Experiment Integer + +-- | Convenient alias for a experiments of lists of integers. +type ExperimentList = D.Experiment [Integer] + +-- | Get the most common values, the mean, and the standard deviation of a given +-- distribution. +getStats :: Distribution -> ([Integer], Double, Double) +getStats d = (modalOrder, expectation d, standardDeviation d) + where + vals = toList d + modalOrder = fst <$> sortBy (\(_, r) (_, r') -> compare r' r) vals + +-- | Convenience wrapper which gets the range of the given values then applies +-- the function to the resultant distributions. +combineRangesBinOp :: (MonadException m, Range a, Range b, PrettyShow a, PrettyShow b) => (Integer -> Integer -> Integer) -> a -> b -> m Experiment +combineRangesBinOp f a b = do + d <- range a + d' <- range b + return $ f <$> d <*> d' + +rangeExpr :: (MonadException m) => Expr -> m Distribution +rangeExpr e = do + ex <- range e + return $ run ex + +rangeListValues :: (MonadException m) => ListValues -> m [Distribution] +rangeListValues lv = do + lve <- rangeList lv + let lvd = run lve + lvd' = toList lvd + return $ D.fromList <$> zip' lvd' + where + head' [] = [] + head' (x : _) = [x] + getHeads xs = (\(xs', p) -> (,p) <$> head' xs') =<< xs + getTails xs = first tail <$> xs + zip' xs = getHeads xs : zip' (getTails xs) + +-- | Type class to get the overall range of a value. +-- +-- A `Data.Distribution.Distribution` is a map of values to probabilities, and +-- has a variety of functions that operate on them. +-- +-- An `Data.Distribution.Experiment` is a monadic form of this. +class Range a where + -- | Try and get the `Experiment` of the given value, throwing a + -- `MonadException` on failure. + range :: (MonadException m, PrettyShow a) => a -> m Experiment + range a = propagateException (prettyShow a) (range' a) + + range' :: (MonadException m, PrettyShow a) => a -> m Experiment + +instance Range Expr where + range' (NoExpr t) = range t + range' (Add t e) = combineRangesBinOp (+) t e + range' (Sub t e) = combineRangesBinOp (-) t e + +instance Range Term where + range' (NoTerm t) = range t + range' (Multi t e) = combineRangesBinOp (*) t e + range' (Div t e) = do + d <- range t + d' <- range e + -- If 0 is always the denominator, the distribution will be empty. + return $ div <$> d <*> from (assuming (/= 0) (run d')) + +instance Range Negation where + range' (Neg t) = fmap negate <$> range t + range' (NoNeg t) = range t + +instance Range Expo where + range' (NoExpo t) = range t + range' (Expo t e) = do + d <- range t + d' <- range e + -- if the exponent is always negative, the distribution will be empty + return $ (^) <$> d <*> from (assuming (>= 0) (run d')) + +instance Range Func where + range' (NoFunc t) = range t + range' (Func fi avs) = rangeFunction fi avs + +instance Range NumBase where + range' (Value i) = return $ return i + range' (NBParen (Paren e)) = range e + +instance Range Base where + range' (NBase nb) = range nb + range' (DiceBase d) = range d + +instance Range Die where + range' (LazyDie d) = range d + range' (Die nb) = do + nbr <- range nb + return $ + do + nbV <- nbr + from $ uniform [1 .. nbV] + range' (CustomDie lv) = do + dievs <- rangeList lv + return $ dievs >>= from . uniform + +instance Range Dice where + range' (Dice b d mdor) = do + b' <- range b + d' <- range d + let e = do + diecount <- b' + getDiceExperiment diecount (run d') + res <- rangeDiceExperiment d' mdor e + return $ sum <$> res + +-- | Get the distribution of values from a given number of (identically +-- distributed) values and the distribution of that value. +getDiceExperiment :: Integer -> Distribution -> ExperimentList +getDiceExperiment i = replicateM (fromInteger i) . from + +-- | Go through each operator on dice and modify the `Experiment` representing +-- all possible collections of rolls, returning the `Experiment` produced on +-- finding `Nothing`. +rangeDiceExperiment :: (MonadException m) => Experiment -> Maybe DieOpRecur -> ExperimentList -> m ExperimentList +rangeDiceExperiment _ Nothing is = return is +rangeDiceExperiment die (Just (DieOpRecur doo mdor)) is = rangeDieOpExperiment die doo is >>= rangeDiceExperiment die mdor + +-- | Perform one dice operation on the given `Experiment`, possibly returning +-- a modified experiment representing the distribution of dice rolls. +rangeDieOpExperiment :: MonadException m => Experiment -> DieOpOption -> ExperimentList -> m ExperimentList +rangeDieOpExperiment die (DieOpOptionLazy o) is = rangeDieOpExperiment die o is +rangeDieOpExperiment _ (DieOpOptionKD kd lhw) is = rangeDieOpExperimentKD kd lhw is +rangeDieOpExperiment die (Reroll rro cond lim) is = do + limd <- range lim + return $ do + limit <- limd + let newDie = mkNewDie limit + rolls <- is + let (count, cutdownRolls) = countTriggers limit rolls + if count == 0 + then return cutdownRolls + else (cutdownRolls ++) <$> getDiceExperiment count (run newDie) + where + mkNewDie limitValue + | rro = die + | otherwise = from $ assuming (\i -> not $ applyCompare cond i limitValue) (run die) + countTriggers limitValue = foldr (\i (c, xs') -> if applyCompare cond i limitValue then (c + 1, xs') else (c, i : xs')) (0, []) + +-- | Perform a keep/drop operation on the `Experiment` of dice rolls. +rangeDieOpExperimentKD :: (MonadException m) => KeepDrop -> LowHighWhere -> ExperimentList -> m ExperimentList +rangeDieOpExperimentKD kd (Where cond nb) is = do + nbDis <- range nb + return $ do + wherelimit <- nbDis + filter (\i -> keepDrop $ applyCompare cond i wherelimit) <$> is + where + keepDrop + | kd == Keep = id + | otherwise = not +rangeDieOpExperimentKD kd lhw is = do + let nb = getValueLowHigh lhw + case nb of + Nothing -> whereException + Just nb' -> do + nbd <- range nb' + return $ do + kdlh <- nbd + getKeep kdlh . sortBy' <$> is + where + -- the below exception should never trigger - it is a hold over. it is + -- present so that this thing type checks nicely. + whereException = evaluationException "keep/drop where is unsupported" [] + order l l' = if isLow lhw then compare l l' else compare l' l + sortBy' = sortBy order + getKeep = if kd == Keep then genericTake else genericDrop + +-- | Type class to get the overall range of a list of values. +-- +-- Only used within `DiceStats` as I have no interest in producing statistics on +-- lists +class RangeList a where + -- | Try and get the `DistributionList` of the given value, throwing a + -- `MonadException` on failure. + rangeList :: (MonadException m, PrettyShow a) => a -> m ExperimentList + rangeList a = propagateException (prettyShow a) (rangeList' a) + + rangeList' :: (MonadException m, PrettyShow a) => a -> m ExperimentList + +instance RangeList ListValuesBase where + rangeList' (LVBList es) = do + exprs <- mapM range es + return $ sequence exprs + rangeList' (LVBParen (Paren lv)) = rangeList lv + +instance RangeList ListValues where + rangeList' (LVBase lvb) = rangeList lvb + rangeList' (MultipleValues nb b) = do + nbd <- range nb + bd <- range b + return $ + do + valNum <- nbd + getDiceExperiment valNum (run bd) + rangeList' (LVFunc fi avs) = rangeFunction fi avs + +rangeArgValue :: MonadException m => ArgValue -> m (D.Experiment ListInteger) +rangeArgValue (AVExpr e) = (LIInteger <$>) <$> range e +rangeArgValue (AVListValues lv) = (LIList <$>) <$> rangeList lv + +rangeFunction :: (MonadException m, Ord j) => FuncInfoBase j -> [ArgValue] -> m (D.Experiment j) +rangeFunction fi exprs = do + exprs' <- mapM rangeArgValue exprs + let params = first (funcInfoFunc fi) <$> toList (run $ sequence exprs') + from . D.fromList <$> foldAndIgnoreErrors params + where + foldAndIgnoreErrors = foldr (\(mv, p) mb -> mb >>= \b -> catchBot ((: []) . (,p) <$> mv) (const (return [])) >>= \v -> return (v ++ b)) (return []) diff --git a/src/Tablebot/Plugins/Roll/Dice/DiceStatsBase.hs b/src/Tablebot/Plugins/Roll/Dice/DiceStatsBase.hs new file mode 100644 index 00000000..266458eb --- /dev/null +++ b/src/Tablebot/Plugins/Roll/Dice/DiceStatsBase.hs @@ -0,0 +1,138 @@ +-- | +-- Module : Tablebot.Plugins.Roll.Dice.DiceStatsBase +-- Description : The basics for dice stats +-- License : MIT +-- Maintainer : tagarople@gmail.com +-- Stability : experimental +-- Portability : POSIX +-- +-- The basics for dice stats. Functions for creating and manipulating +-- `Distribution`s. +module Tablebot.Plugins.Roll.Dice.DiceStatsBase + ( Distribution, + distributionByteString, + ) +where + +import Codec.Picture (PngSavable (encodePng)) +import Data.Bifunctor +import qualified Data.ByteString.Lazy as B +import qualified Data.Distribution as D +import Data.List (genericLength) +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Text as T +import Diagrams (Diagram, dims2D, renderDia) +import Diagrams.Backend.Rasterific +import Graphics.Rendering.Chart.Axis.Int +import Graphics.Rendering.Chart.Backend.Diagrams (defaultEnv, runBackendR) +import Graphics.Rendering.Chart.Backend.Types +import Graphics.Rendering.Chart.Easy +import Tablebot.Plugins.Roll.Dice.DiceEval (evaluationException) + +-- | A wrapper type for mapping values to their probabilities. +type Distribution = D.Distribution Integer + +-- | Default x and y values for the output chart. +diagramX, diagramY :: Double +(diagramX, diagramY) = (1400.0, 400.0) + +-- | Get the ByteString representation of the given distribution, setting the +-- string as its title. +distributionByteString :: [(Distribution, T.Text)] -> IO B.ByteString +distributionByteString d = encodePng . renderDia Rasterific opts <$> distributionDiagram d + where + opts = RasterificOptions (dims2D diagramX diagramY) + +-- | Get the Diagram representation of the given distribution, setting the +-- string as its title. +distributionDiagram :: [(Distribution, T.Text)] -> IO (Diagram B) +distributionDiagram d = do + if null d + then evaluationException "empty distribution" [] + else do + defEnv <- defaultEnv (AlignmentFns id id) diagramX diagramY + return . fst $ runBackendR defEnv r + where + r = distributionRenderable d + +-- | Get the Renderable representation of the given distribution, setting the +-- string as its title. +distributionRenderable :: [(Distribution, T.Text)] -> Renderable () +distributionRenderable d = toRenderable $ do + layout_title .= T.unpack (title' d) + layout_x_axis . laxis_title .= "value" + layout_y_axis . laxis_title .= "probability (%)" + layout_x_axis . laxis_generate .= scaledIntAxis' r + layout_y_axis . laxis_override .= \ad@AxisData {_axis_labels = axisLabels} -> ad {_axis_labels = (second (\s -> if '.' `elem` s then s else s ++ ".0") <$>) <$> axisLabels} + layout_all_font_styles .= defFontStyle + pb <- (bars @Integer @Double) (barNames d) pts + let pb' = pb {_plot_bars_spacing = BarsFixGap 10 5} + plot $ return $ plotBars pb' + where + removeNullMap m + | M.null m = M.singleton 0 0 + | otherwise = m + ds = removeNullMap . D.toMap . fst <$> d + allIntegers = let s = S.unions $ M.keysSet <$> ds in [S.findMin s .. S.findMax s] + insertEmpty k = M.insertWith (\_ a -> a) k 0 + ds' = M.unionsWith (++) $ M.map (: []) <$> (applyAll (insertEmpty <$> allIntegers) <$> ds) + pts = second (fromRational . (* 100) <$>) <$> M.toList ds' + r = (fst $ M.findMin ds', fst $ M.findMax ds') + applyAll [] = id + applyAll (f : fs) = f . applyAll fs + defFontStyle = def {_font_size = 2 * _font_size def} + barNames [_] = [""] + barNames xs = T.unpack . snd <$> xs + title' [(_, t)] = t + title' xs = "Range of " <> T.intercalate ", " (snd <$> xs) + +-- | Custom scaling function due to some difficulties for drawing charts. +-- +-- Using +-- https://hackage.haskell.org/package/Chart-1.9.3/docs/src/Graphics.Rendering.Chart.Axis.Int.html#scaledIntAxis +-- for pointers. +scaledIntAxis' :: (Integer, Integer) -> AxisFn Integer +scaledIntAxis' r@(minI, maxI) _ = makeAxis (_la_labelf lap) ((minI - 1) : (maxI + 1) : labelvs, tickvs, gridvs) + where + lap = defaultIntAxis + labelvs = stepsInt' (fromIntegral $ _la_nLabels lap) r + tickvs = + stepsInt' + (fromIntegral $ _la_nTicks lap) + ( fromIntegral $ minimum labelvs, + fromIntegral $ maximum labelvs + ) + gridvs = labelvs + +-- | Taken and modified from +-- https://hackage.haskell.org/package/Chart-1.9.3/docs/src/Graphics.Rendering.Chart.Axis.Int.html#stepsInt +stepsInt' :: Integer -> (Integer, Integer) -> [Integer] +stepsInt' nSteps range = bestSize (goodness alt0) alt0 alts + where + bestSize n a (a' : as) = + let n' = goodness a' + in if n' < n then bestSize n' a' as else a + bestSize _ _ [] = [] + + goodness vs = abs (genericLength vs - nSteps) + + (alt0 : alts) = map (`steps` range) sampleSteps' + + -- throw away sampleSteps that are definitely too small as + -- they takes a long time to process + sampleSteps' = + let rangeMag = (snd range - fst range) + + (s1, s2) = span (< (rangeMag `div` nSteps)) sampleSteps + in (reverse . take 5 . reverse) s1 ++ s2 + + -- generate all possible step sizes + sampleSteps = [1, 2, 5] ++ sampleSteps1 + sampleSteps1 = [10, 20, 25, 50] ++ map (* 10) sampleSteps1 + + steps :: Integer -> (Integer, Integer) -> [Integer] + steps size' (minV, maxV) = takeWhile (< b) [a, a + size' ..] ++ [b] + where + a = floor @Double (fromIntegral minV / fromIntegral size') * size' + b = ceiling @Double (fromIntegral maxV / fromIntegral size') * size' diff --git a/src/Tablebot/Plugins/Roll/Plugin.hs b/src/Tablebot/Plugins/Roll/Plugin.hs index 3bc84493..7d49b0a7 100644 --- a/src/Tablebot/Plugins/Roll/Plugin.hs +++ b/src/Tablebot/Plugins/Roll/Plugin.hs @@ -9,19 +9,27 @@ -- A command that outputs the result of rolling the input dice. module Tablebot.Plugins.Roll.Plugin (rollPlugin) where -import Control.Monad.Writer (MonadIO (liftIO)) +import Control.Monad.Writer (MonadIO (liftIO), void) import Data.Bifunctor (Bifunctor (first)) +import Data.ByteString.Lazy (toStrict) +import Data.Distribution (isValid) import Data.Maybe (fromMaybe) import Data.Text (Text, intercalate, pack, replicate, unpack) import qualified Data.Text as T -import Discord.Types (Message (messageAuthor)) +import Discord (restCall) +import Discord.Internal.Rest.Channel (ChannelRequest (CreateMessageDetailed), MessageDetailedOpts (MessageDetailedOpts)) +import Discord.Types (Message (messageAuthor, messageChannel)) +import System.Timeout (timeout) import Tablebot.Plugins.Roll.Dice import Tablebot.Plugins.Roll.Dice.DiceData +import Tablebot.Plugins.Roll.Dice.DiceStats (getStats, rangeExpr) +import Tablebot.Plugins.Roll.Dice.DiceStatsBase (distributionByteString) import Tablebot.Utility -import Tablebot.Utility.Discord (sendMessage, toMention) -import Tablebot.Utility.Parser (inlineCommandHelper) -import Tablebot.Utility.SmartParser (PComm (parseComm), Quoted (Qu), pars) -import Text.Megaparsec (MonadParsec (try), choice, ()) +import Tablebot.Utility.Discord (Format (Code), formatText, sendMessage, toMention) +import Tablebot.Utility.Exception (BotException (EvaluationException), throwBot) +import Tablebot.Utility.Parser (inlineCommandHelper, skipSpace) +import Tablebot.Utility.SmartParser (PComm (parseComm), Quoted (Qu), WithError (WErr), pars) +import Text.Megaparsec import Text.RawString.QQ (r) -- | The basic execution function for rolling dice. Both the expression and message are @@ -54,16 +62,33 @@ rollDice' e' t m = do rollDiceParser :: Parser (Message -> DatabaseDiscord ()) rollDiceParser = choice (try <$> options) where + -- Just the value is given to the command, no quote. + justEither :: WithError "Incorrect expression/list value. Please check the expression" (Either ListValues Expr) -> Message -> DatabaseDiscord () + justEither (WErr x) = rollDice' (Just x) Nothing + -- Nothing is given to the command, a default case. + nothingAtAll :: WithError "Expected eof" () -> Message -> DatabaseDiscord () + nothingAtAll (WErr _) = rollDice' Nothing Nothing + -- Both the value and the quote are present. + bothVals :: WithError "Incorrect format. Please check the expression and quote" (Either ListValues Expr, Quoted Text) -> Message -> DatabaseDiscord () + bothVals (WErr (x, y)) = rollDice' (Just x) (Just y) + -- Just the quote is given to the command. + justText :: WithError "Incorrect quote. Please check the quote format" (Quoted Text) -> Message -> DatabaseDiscord () + justText (WErr x) = rollDice' Nothing (Just x) options = - [ parseComm (\lv -> rollDice' (Just lv) Nothing), - parseComm (rollDice' Nothing Nothing), - try (parseComm (\lv qt -> rollDice' (Just lv) (Just qt))) "", - try (parseComm (rollDice' Nothing . Just)) "" + [ parseComm justEither, + parseComm nothingAtAll, + parseComm bothVals, + parseComm justText ] -- | Basic command for rolling dice. rollDice :: Command -rollDice = Command "roll" rollDiceParser [] +rollDice = Command "roll" rollDiceParser [statsCommand] + +-- where +-- rollDiceParser = parseComm rollDiceParser' +-- rollDiceParser' :: WithError "Incorrect rolling format. Please check your expression and quote is of the correct format" (Maybe (Either ListValues Expr), Maybe (Quoted Text)) -> Message -> DatabaseDiscord () +-- rollDiceParser' (WErr (x, y)) = rollDice' x y -- | Rolling dice inline. rollDiceInline :: InlineCommand @@ -77,7 +102,7 @@ rollHelp = ["r"] "roll dice and do maths" rollHelpText - [] + [statsHelp] None -- | A large chunk of help text for the roll command. @@ -89,13 +114,13 @@ Given an expression, evaluate the expression. Can roll inline using |] ++ "`[|to roll|]`." ++ [r| Can use `r` instead of `roll`. -This supports addition, subtraction, multiplication, integer division, exponentiation, parentheses, dice of arbitrary size, dice with custom sides, rerolling dice once on a condition, rerolling dice indefinitely on a condition, keeping or dropping the highest or lowest dice, keeping or dropping dice based on a condition, operating on lists, and using functions like |] +This supports addition, subtraction, multiplication, integer division, exponentiation, parentheses, dice of arbitrary size, dice with custom sides, rerolling dice once on a condition, rerolling dice indefinitely on a condition, keeping or dropping the highest or lowest dice, keeping or dropping dice based on a condition, operating on lists (which have a maximum, configurable size of 50), and using functions like |] ++ unpack (intercalate ", " integerFunctionsList) ++ [r| (which return integers), or functions like |] ++ unpack (intercalate ", " listFunctionsList) ++ [r| (which return lists). -To see a full list of uses and options, please go to . +To see a full list of uses, options and limitations, please go to . *Usage:* - `roll 1d20` -> rolls a twenty sided die and returns the outcome @@ -130,6 +155,76 @@ gencharHelp = [] None +-- | The command to get the statistics for an expression and display the +-- results. +statsCommand :: Command +statsCommand = Command "stats" statsCommandParser [] + where + oneSecond = 1000000 + statsCommandParser :: Parser (Message -> DatabaseDiscord ()) + statsCommandParser = do + firstE <- pars + restEs <- many (skipSpace *> pars) <* eof + return $ statsCommand' (firstE : restEs) + statsCommand' :: [Expr] -> Message -> DatabaseDiscord () + statsCommand' es m = do + mrange' <- liftIO $ timeout (oneSecond * 5) $ mapM (\e -> rangeExpr e >>= \re -> re `seq` return (re, prettyShow e)) es + case mrange' of + Nothing -> throwBot (EvaluationException "Timed out calculating statistics" []) + (Just range') -> do + mimage <- liftIO $ timeout (oneSecond * 5) (distributionByteString range' >>= \res -> res `seq` return res) + case mimage of + Nothing -> do + sendMessage m (msg range') + throwBot (EvaluationException "Timed out displaying statistics." []) + (Just image) -> do + liftDiscord $ + void $ + restCall + ( CreateMessageDetailed (messageChannel m) (MessageDetailedOpts (msg range') False Nothing (Just (T.unwords (snd <$> range') <> ".png", toStrict image)) Nothing Nothing) + ) + where + msg [(d, t)] = + if (not . isValid) d + then "The distribution was empty." + else + let (modalOrder, mean, std) = getStats d + in ( "Here are the statistics for your dice (" + <> formatText Code t + <> ").\n Ten most common totals: " + <> T.pack (show (take 10 modalOrder)) + <> "\n Mean: " + <> roundShow mean + <> "\n Standard deviation: " + <> roundShow std + ) + msg dts = + let (modalOrders, means, stds) = unzip3 $ getStats . fst <$> dts + in ( "Here are the statistics for your dice (" + <> intercalate ", " (formatText Code . snd <$> dts) + <> ").\n Most common totals (capped to ten total): " + <> T.pack (show (take (div 10 (length modalOrders)) <$> modalOrders)) + <> "\n Means: " + <> intercalate ", " (roundShow <$> means) + <> "\n Standard deviations: " + <> intercalate ", " (roundShow <$> stds) + ) + roundShow :: Double -> Text + roundShow d = T.pack $ show $ fromInteger (round (d * 10 ** precision)) / 10 ** precision + where + precision = 5 :: Double + +-- | Help page for dice stats. +statsHelp :: HelpPage +statsHelp = + HelpPage + "stats" + [] + "calculate and display statistics for expressions." + "**Roll Stats**\nCan be used to display statistics for expressions of dice.\n\n*Usage:* `roll stats 2d20kh1`, `roll stats 4d6rr=1dl1+5`, `roll stats 3d6dl1+6 4d6dl1`" + [] + None + -- | @rollPlugin@ assembles the command into a plugin. rollPlugin :: Plugin rollPlugin = diff --git a/src/Tablebot/Utility/Exception.hs b/src/Tablebot/Utility/Exception.hs index 2c4549f3..deb957b2 100644 --- a/src/Tablebot/Utility/Exception.hs +++ b/src/Tablebot/Utility/Exception.hs @@ -113,7 +113,7 @@ errorInfo (IndexOutOfBoundsException index (a, b)) = "IndexOutOfBoundsException" $ "Index value of " ++ show index ++ " is not in the valid range [" ++ show a ++ ", " ++ show b ++ "]." errorInfo (RandomException msg') = ErrorInfo "RandomException" msg' -errorInfo (EvaluationException msg' locs) = ErrorInfo "EvaluationException" $ msg' ++ ".\nException evaluation stack:\n" ++ str +errorInfo (EvaluationException msg' locs) = ErrorInfo "EvaluationException" $ msg' ++ if null locs then "" else ".\nException evaluation stack:\n" ++ str where l = length locs ls = reverse $ take 3 locs diff --git a/src/Tablebot/Utility/Parser.hs b/src/Tablebot/Utility/Parser.hs index e4754806..5bf874cf 100644 --- a/src/Tablebot/Utility/Parser.hs +++ b/src/Tablebot/Utility/Parser.hs @@ -82,10 +82,6 @@ word = some letter nonSpaceWord :: Parser String nonSpaceWord = some notSpace --- | @number@ parses any whole, non-negative number. -number :: Parser Int -number = read <$> some digit - -- | @untilEnd@ gets all of the characters up to the end of the input. untilEnd :: Parser String untilEnd = manyTill anySingle eof @@ -193,10 +189,14 @@ inlineCommandHelper open close p action = -- | Parse 0 or more comma separated values. parseCommaSeparated :: Parser a -> Parser [a] parseCommaSeparated p = do - f <- optional $ try p - maybe (return []) (\first' -> (first' :) <$> many (try (skipSpace *> char ',' *> skipSpace) *> p)) f + first <- optional $ try p + case first of + Nothing -> return [] + Just first' -> (first' :) <$> many (try (skipSpace *> char ',' *> skipSpace) *> p) -- | Parse 1 or more comma separated values. parseCommaSeparated1 :: Parser a -> Parser [a] parseCommaSeparated1 p = do - p >>= (\first' -> (first' :) <$> many (try (skipSpace *> char ',' *> skipSpace) *> p)) + first <- p + others <- many (try (skipSpace *> char ',' *> skipSpace) *> p) + return (first : others) diff --git a/src/Tablebot/Utility/SmartParser.hs b/src/Tablebot/Utility/SmartParser.hs index 7501e8ad..bcaf6b5f 100644 --- a/src/Tablebot/Utility/SmartParser.hs +++ b/src/Tablebot/Utility/SmartParser.hs @@ -23,6 +23,20 @@ import Tablebot.Utility.Parser import Tablebot.Utility.Types (EnvDatabaseDiscord, Parser) import Text.Megaparsec +-- | Custom infix operator to replace the error of a failing parser (regardless +-- of parser position) with a user given error message. +-- +-- Has some effects on other error parsing. Use if you want the error you give +-- to be the one that is reported (unless this is used at a higher level.) +-- +-- Overwrites/overpowers WithError errors. +() :: Parser a -> String -> Parser a +() p s = do + r <- observing p + case r of + Left _ -> fail s + Right a -> return a + -- | @PComm@ defines function types that we can automatically turn into parsers -- by composing a parser per input of the function provided. -- For example, @Int -> Maybe Text -> Message -> DatabaseDiscord s ()@ builds a @@ -89,46 +103,36 @@ instance {-# OVERLAPPABLE #-} CanParse a => CanParse [a] where -- A parser for @Either a b@ attempts to parse @a@, and if that fails then -- attempts to parse @b@. instance (CanParse a, CanParse b) => CanParse (Either a b) where - pars = (Left <$> pars @a) <|> (Right <$> pars @b) + pars = (Left <$> try (pars @a)) <|> (Right <$> pars @b) -- TODO: automate creation of tuple instances using TemplateHaskell instance (CanParse a, CanParse b) => CanParse (a, b) where pars = do - x <- pars @a - skipSpace1 + x <- parsThenMoveToNext @a y <- pars @b return (x, y) instance (CanParse a, CanParse b, CanParse c) => CanParse (a, b, c) where pars = do - x <- pars @a - skipSpace1 - y <- pars @b - skipSpace1 + x <- parsThenMoveToNext @a + y <- parsThenMoveToNext @b z <- pars @c return (x, y, z) instance (CanParse a, CanParse b, CanParse c, CanParse d) => CanParse (a, b, c, d) where pars = do - x <- pars @a - skipSpace1 - y <- pars @b - skipSpace1 - z <- pars @c - skipSpace1 + x <- parsThenMoveToNext @a + y <- parsThenMoveToNext @b + z <- parsThenMoveToNext @c w <- pars @d return (x, y, z, w) instance (CanParse a, CanParse b, CanParse c, CanParse d, CanParse e) => CanParse (a, b, c, d, e) where pars = do - x <- pars @a - skipSpace1 - y <- pars @b - skipSpace1 - z <- pars @c - skipSpace1 - w <- pars @d - skipSpace1 + x <- parsThenMoveToNext @a + y <- parsThenMoveToNext @b + z <- parsThenMoveToNext @c + w <- parsThenMoveToNext @d v <- pars @e return (x, y, z, w, v) diff --git a/stack.yaml b/stack.yaml index 7cc38305..08e82a73 100644 --- a/stack.yaml +++ b/stack.yaml @@ -39,6 +39,8 @@ packages: # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # +# allow-newer: true + extra-deps: - discord-haskell-1.10.0 - emoji-0.1.0.2 @@ -51,6 +53,21 @@ extra-deps: - duckling-0.2.0.0 - dependent-sum-0.7.1.0 - constraints-extras-0.3.1.0 +- Chart-diagrams-1.9.3 +- SVGFonts-1.7.0.1 +- diagrams-core-1.5.0 +- diagrams-lib-1.4.5.1 +- diagrams-postscript-1.5.1 +- diagrams-svg-1.4.3.1 +- svg-builder-0.1.1 +- active-0.2.0.15 +- dual-tree-0.2.3.0 +- monoid-extras-0.6.1 +- statestack-0.3 +- diagrams-rasterific-1.4.2.2 +# - distribution-1.1.1.1 +- git: https://github.com/L0neGamer/haskell-distribution.git + commit: 569d6452e4bffedb2c0d3795885fccdb22a4d29d # Override default flag values for local packages and extra-deps # flags: {}