Merge pull request #142 from L0neGamer/fixing-rolling

Fixing rolling

Author: Bongo50

src/Tablebot/Plugins/Roll/Dice.hs

@@ -40,10 +40,10 @@
 -- vars - "var" spc1 "!"? ("l_" name spcs "=" spcs lstv | name spcs "=" spcs expr)
 -- lstv - nbse "#" base | funcBasics | lstb | name | misc
 -- lstb - "{" expr ("," expr)* "}" | "(" lstv ")"
--- expr - term ([+-] expr)? | misc
--- term - nega ([*/] term)?
+-- expr - term ([+-] term)* | misc
+-- term - nega ([*/] nega)*
 -- nega - "-" expo | expo
--- expo - func "^" expo | func
+-- expo - func ("^" func)*
 -- func - funcBasics | base
 -- base - dice | nbse | name
 -- nbse - "(" expr ")" | [0-9]+

src/Tablebot/Plugins/Roll/Dice/DiceData.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE PatternSynonyms #-}
+
 -- |
 -- Module      : Tablebot.Plugins.Roll.Dice.DiceData
 -- Description : Data structures for dice and other expressions.
@@ -45,9 +47,6 @@ data Program = Program [Statement] (Either ListValues Expr) deriving (Show)
 data ArgValue = AVExpr Expr | AVListValues ListValues
   deriving (Show)
 
--- | Alias for `MiscData` that returns a `ListValues`.
-type ListValuesMisc = MiscData ListValues
-
 -- | The type for list values.
 data ListValues
   = -- | Represents `N#B`, where N is a NumBase (numbers, parentheses) and B is a Base (numbase or dice value)
@@ -59,7 +58,7 @@ data ListValues
   | -- | A variable that has been defined elsewhere.
     LVVar Text
   | -- | A misc list values expression.
-    ListValuesMisc ListValuesMisc
+    ListValuesMisc (MiscData ListValues)
   deriving (Show)
 
 -- | The type for basic list values (that can be used as is for custom dice).
@@ -71,18 +70,49 @@ data ListValues
 data ListValuesBase = LVBParen (Paren ListValues) | LVBList [Expr]
   deriving (Show)
 
--- | Alias for `MiscData` that returns an `Expr`.
-type ExprMisc = MiscData Expr
+-- | The type for a binary operator between one or more `sub` values
+data BinOp sub typ where
+  BinOp :: Operation typ => sub -> [(typ, sub)] -> BinOp sub typ
+
+deriving instance (Show sub, Show typ) => Show (BinOp sub typ)
+
+-- | Convenience pattern for the empty list.
+pattern SingBinOp :: (Operation typ) => sub -> BinOp sub typ
+pattern SingBinOp a <-
+  BinOp a []
+  where
+    SingBinOp a = BinOp a []
+
+-- | The type class that means we can get an operation on integers from a value.
+class Operation a where
+  getOperation :: a -> (forall n. Integral n => n -> n -> n)
 
--- | The type of the top level expression. Represents one of addition,
--- subtraction, or a single term; or some misc expression statement.
-data Expr = ExprMisc ExprMisc | Add Term Expr | Sub Term Expr | NoExpr Term
+-- | The type of the top level expression.
+--
+-- Represents either a misc expression or additive operations between terms.
+data Expr = ExprMisc (MiscData Expr) | Expr (BinOp Term ExprType)
   deriving (Show)
 
--- | The type representing multiplication, division, or a single negated term.
-data Term = Multi Negation Term | Div Negation Term | NoTerm Negation
+-- | The type of the additive expression, either addition or subtraction.
+data ExprType = Add | Sub
+  deriving (Show, Eq)
+
+instance Operation ExprType where
+  getOperation Sub = (-)
+  getOperation Add = (+)
+
+-- | Represents multiplicative operations between (possible) negations.
+newtype Term = Term (BinOp Negation TermType)
   deriving (Show)
 
+-- | The type of the additive expression, either addition or subtraction.
+data TermType = Multi | Div
+  deriving (Show, Eq)
+
+instance Operation TermType where
+  getOperation Multi = (*)
+  getOperation Div = div
+
 -- | The type representing a possibly negated value.
 data Negation = Neg Expo | NoNeg Expo
   deriving (Show)
@@ -181,11 +211,14 @@ class Converter a b where
 instance Converter ListValuesBase ListValues where
   promote = LVBase
 
+instance (Converter a sub, Operation typ) => Converter a (BinOp sub typ) where
+  promote = SingBinOp . promote
+
 instance (Converter a Term) => Converter a Expr where
-  promote = NoExpr . promote
+  promote = Expr . promote
 
 instance (Converter a Negation) => Converter a Term where
-  promote = NoTerm . promote
+  promote = Term . promote
 
 instance (Converter a Expo) => Converter a Negation where
   promote = NoNeg . promote

src/Tablebot/Plugins/Roll/Dice/DiceEval.hs

@@ -205,21 +205,21 @@ instance IOEvalList ListValuesBase where
     return (vs, Nothing)
   evalShowL' (LVBParen (Paren lv)) = evalShowL lv
 
-instance IOEvalList ListValuesMisc where
+instance IOEvalList (MiscData ListValues) where
   evalShowL' (MiscVar l) = evalShowL l
   evalShowL' (MiscIf l) = evalShowL l
 
 -- | This type class gives a function which evaluates the value to an integer
 -- and a string.
-class IOEval a where
+class ParseShow a => IOEval a where
   -- | Evaluate the given item to an integer, a string representation of the
   -- value, and the number of RNG calls it took. If the `a` value is a dice
   -- value, the values of the dice should be displayed. This function adds
   -- the current location to the exception callstack.
-  evalShow :: (ParseShow a) => a -> ProgramStateM (Integer, Text)
+  evalShow :: a -> ProgramStateM (Integer, Text)
   evalShow a = propagateException (parseShow a) (evalShow' a)
 
-  evalShow' :: (ParseShow a) => a -> ProgramStateM (Integer, Text)
+  evalShow' :: a -> ProgramStateM (Integer, Text)
 
 instance IOEval Base where
   evalShow' (NBase nb) = evalShow nb
@@ -384,32 +384,35 @@ evalDieOpHelpKD kd lh is = do
 --- Pure evaluation functions for non-dice calculations
 -- Was previously its own type class that wouldn't work for evaluating Base values.
 
--- | Utility function to evaluate a binary operator.
-binOpHelp :: (IOEval a, IOEval b, ParseShow a, ParseShow b) => a -> b -> Text -> (Integer -> Integer -> Integer) -> ProgramStateM (Integer, Text)
-binOpHelp a b opS op = do
-  (a', a's) <- evalShow a
-  (b', b's) <- evalShow b
-  return (op a' b', a's <> " " <> opS <> " " <> b's)
-
-instance IOEval ExprMisc where
+instance IOEval (MiscData Expr) where
   evalShow' (MiscVar l) = evalShow l
   evalShow' (MiscIf l) = evalShow l
 
+instance (IOEval sub, Operation typ, ParseShow typ) => IOEval (BinOp sub typ) where
+  evalShow' (BinOp a tas) = foldl' foldel (evalShow a) tas
+    where
+      foldel at (typ, b) = do
+        (a', t) <- at
+        (b', t') <- evalShow b
+        return (getOperation typ a' b', t <> " " <> parseShow typ <> " " <> t')
+
 instance IOEval Expr where
-  evalShow' (NoExpr t) = evalShow t
   evalShow' (ExprMisc e) = evalShow e
-  evalShow' (Add t e) = binOpHelp t e "+" (+)
-  evalShow' (Sub t e) = binOpHelp t e "-" (-)
+  evalShow' (Expr e) = evalShow e
 
 instance IOEval Term where
-  evalShow' (NoTerm f) = evalShow f
-  evalShow' (Multi f t) = binOpHelp f t "*" (*)
-  evalShow' (Div f t) = do
-    (f', f's) <- evalShow f
-    (t', t's) <- evalShow t
-    if t' == 0
-      then evaluationException "division by zero" [parseShow t]
-      else return (div f' t', f's <> " / " <> t's)
+  evalShow' (Term (BinOp a tas)) = foldl' foldel (evalShow a) tas
+    where
+      foldel at (Div, b) = do
+        (a', t) <- at
+        (b', t') <- evalShow b
+        if b' == 0
+          then evaluationException "division by zero" [parseShow b]
+          else return (getOperation Div a' b', t <> " " <> parseShow Div <> " " <> t')
+      foldel at (typ, b) = do
+        (a', t) <- at
+        (b', t') <- evalShow b
+        return (getOperation typ a' b', t <> " " <> parseShow typ <> " " <> t')
 
 instance IOEval Func where
   evalShow' (Func s exprs) = evaluateFunction s exprs

src/Tablebot/Plugins/Roll/Dice/DiceParsing.hs

@@ -29,7 +29,7 @@ import Tablebot.Plugins.Roll.Dice.DiceFunctions
 import Tablebot.Utility.Parser
 import Tablebot.Utility.SmartParser (CanParse (..), (<??>))
 import Tablebot.Utility.Types (Parser)
-import Text.Megaparsec (MonadParsec (try), choice, failure, optional, some, (<?>), (<|>))
+import Text.Megaparsec (MonadParsec (try), choice, failure, many, optional, some, (<?>), (<|>))
 import Text.Megaparsec.Char (char, string)
 import Text.Megaparsec.Error (ErrorItem (Tokens))
 
@@ -127,18 +127,29 @@ instance (CanParse b) => CanParse (If b) where
 instance (CanParse a) => CanParse (MiscData a) where
   pars = (MiscVar <$> pars) <|> (MiscIf <$> pars)
 
+instance (CanParse sub, CanParse typ, Operation typ) => CanParse (BinOp sub typ) where
+  pars = do
+    a <- pars
+    tas <- many parseTas
+    return $ BinOp a tas
+    where
+      parseTas = try $ do
+        t <- skipSpace *> pars
+        a' <- skipSpace *> pars
+        return (t, a')
+
+instance CanParse ExprType where
+  pars = try (char '+' $> Add) <|> try (char '-' $> Sub)
+
 instance CanParse Expr where
   pars =
-    (ExprMisc <$> pars)
-      <|> ( do
-              t <- pars
-              binOpParseHelp '+' (Add t) <|> binOpParseHelp '-' (Sub t) <|> (return . NoExpr) t
-          )
+    (ExprMisc <$> pars) <|> (Expr <$> pars)
+
+instance CanParse TermType where
+  pars = try (char '*' $> Multi) <|> try (char '/' $> Div)
 
 instance CanParse Term where
-  pars = do
-    t <- pars
-    binOpParseHelp '*' (Multi t) <|> binOpParseHelp '/' (Div t) <|> (return . NoTerm) t
+  pars = Term <$> pars
 
 instance CanParse Func where
   pars = functionParser integerFunctions Func <|> NoFunc <$> pars
@@ -176,7 +187,7 @@ instance CanParse NumBase where
       <|> Value
       <$> integer <??> "could not parse integer"
     where
-      unnest (Paren (NoExpr (NoTerm (NoNeg (NoExpo (NoFunc (NBase (NBParen e)))))))) = e
+      unnest (Paren (Expr (SingBinOp (Term (SingBinOp (NoNeg (NoExpo (NoFunc (NBase (NBParen e)))))))))) = e
       unnest e = e
 
 instance (CanParse a) => CanParse (Paren a) where
@@ -282,7 +293,7 @@ instance ParseShow ArgValue where
 instance ParseShow ListValues where
   parseShow (LVBase e) = parseShow e
   parseShow (MultipleValues nb b) = parseShow nb <> "#" <> parseShow b
-  parseShow (LVFunc s n) = funcInfoName s <> "(" <> T.intercalate "," (parseShow <$> n) <> ")"
+  parseShow (LVFunc s n) = funcInfoName s <> "(" <> T.intercalate ", " (parseShow <$> n) <> ")"
   parseShow (LVVar t) = t
   parseShow (ListValuesMisc l) = parseShow l
 
@@ -294,19 +305,26 @@ instance (ParseShow a) => ParseShow (MiscData a) where
   parseShow (MiscVar l) = parseShow l
   parseShow (MiscIf l) = parseShow l
 
+instance (ParseShow sub, ParseShow typ) => ParseShow (BinOp sub typ) where
+  parseShow (BinOp a tas) = parseShow a <> T.concat (fmap (\(t, a') -> " " <> parseShow t <> " " <> parseShow a') tas)
+
+instance ParseShow ExprType where
+  parseShow Add = "+"
+  parseShow Sub = "-"
+
+instance ParseShow TermType where
+  parseShow Multi = "*"
+  parseShow Div = "/"
+
 instance ParseShow Expr where
-  parseShow (Add t e) = parseShow t <> " + " <> parseShow e
-  parseShow (Sub t e) = parseShow t <> " - " <> parseShow e
-  parseShow (NoExpr t) = parseShow t
+  parseShow (Expr e) = parseShow e
   parseShow (ExprMisc e) = parseShow e
 
 instance ParseShow Term where
-  parseShow (Multi f t) = parseShow f <> " * " <> parseShow t
-  parseShow (Div f t) = parseShow f <> " / " <> parseShow t
-  parseShow (NoTerm f) = parseShow f
+  parseShow (Term f) = parseShow f
 
 instance ParseShow Func where
-  parseShow (Func s n) = funcInfoName s <> "(" <> T.intercalate "," (parseShow <$> n) <> ")"
+  parseShow (Func s n) = funcInfoName s <> "(" <> T.intercalate ", " (parseShow <$> n) <> ")"
   parseShow (NoFunc b) = parseShow b
 
 instance ParseShow Negation where

src/Tablebot/Plugins/Roll/Dice/DiceStats.hs

@@ -44,14 +44,6 @@ getStats d = (modalOrder, expectation d, standardDeviation d)
     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, ParseShow a, ParseShow 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
@@ -114,20 +106,30 @@ instance (RangeList a) => RangeList (Var a) where
   rangeList' (Var _ a) = rangeList a
   rangeList' (VarLazy _ a) = rangeList a
 
+instance (ParseShow typ, Range sub) => Range (BinOp sub typ) where
+  range' (BinOp a tas) = foldl' foldel (range a) tas
+    where
+      foldel at (typ, b) = do
+        a' <- at
+        b' <- range b
+        return $ getOperation typ <$> a' <*> b'
+
 instance Range Expr where
-  range' (NoExpr t) = range t
-  range' (Add t e) = combineRangesBinOp (+) t e
-  range' (Sub t e) = combineRangesBinOp (-) t e
+  range' (Expr e) = range e
   range' (ExprMisc t) = range t
 
 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'))
+  range' (Term (BinOp a tas)) = foldl' foldel (range a) tas
+    where
+      foldel at (Div, b) = do
+        a' <- at
+        b' <- range b
+        -- If 0 is always the denominator, the distribution will be empty.
+        return $ getOperation Div <$> a' <*> from (assuming (/= 0) (run b'))
+      foldel at (typ, b) = do
+        a' <- at
+        b' <- range b
+        return $ getOperation typ <$> a' <*> b'
 
 instance Range Negation where
   range' (Neg t) = fmap negate <$> range t

src/Tablebot/Plugins/Roll/Plugin.hs

@@ -204,7 +204,7 @@ genchar = Command "genchar" (snd $ head rpgSystems') (toCommand <$> rpgSystems')
 rpgSystems :: [(Text, ListValues)]
 rpgSystems =
   [ ("dnd", MultipleValues (Value 6) (DiceBase (Dice (NBase (Value 4)) (Die (Value 6)) (Just (DieOpRecur (DieOpOptionKD Drop (Low (Value 1))) Nothing))))),
-    ("wfrp", MultipleValues (Value 8) (NBase (NBParen (Paren (Add (promote (Value 20)) (promote (Die (Value 10))))))))
+    ("wfrp", MultipleValues (Value 8) (NBase (NBParen (Paren (Expr (BinOp (promote (Value 20)) [(Add, promote (Die (Value 10)))]))))))
   ]
 
 -- | Small help page for gen char.