{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
module Data.Random.Dice where

import Data.Random
import Data.Random.Distribution.Uniform (integralUniform)
import System.Random.Stateful

import Control.Monad
import Control.Monad.Except
import Data.Functor.Identity
import Data.Ratio
import Data.List

import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import Text.ParserCombinators.Parsec.Token
import Text.ParserCombinators.Parsec.Language
import Text.Printf

----------------------------------------------------------------
-- A simple expression language

data Expr a
    = Const   String   a
    | Plus   (Expr a) (Expr a)
    | Minus  (Expr a) (Expr a)
    | Times  (Expr a) (Expr a)
    | Divide (Expr a) (Expr a)
--    Repeat :: Expr Int -> Expr a -> Expr [a]
    deriving Int -> Expr a -> ShowS
forall a. Show a => Int -> Expr a -> ShowS
forall a. Show a => [Expr a] -> ShowS
forall a. Show a => Expr a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Expr a] -> ShowS
$cshowList :: forall a. Show a => [Expr a] -> ShowS
show :: Expr a -> [Char]
$cshow :: forall a. Show a => Expr a -> [Char]
showsPrec :: Int -> Expr a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Expr a -> ShowS
Show

instance Functor Expr where
    fmap :: forall a b. (a -> b) -> Expr a -> Expr b
fmap a -> b
f = forall {t} {t}.
([Char] -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> Expr t
-> t
foldExpr (\[Char]
s a
x -> forall a. [Char] -> a -> Expr a
Const [Char]
s (a -> b
f a
x)) forall a. Expr a -> Expr a -> Expr a
Plus forall a. Expr a -> Expr a -> Expr a
Minus forall a. Expr a -> Expr a -> Expr a
Times forall a. Expr a -> Expr a -> Expr a
Divide

foldExpr :: ([Char] -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> Expr t
-> t
foldExpr [Char] -> t -> t
c t -> t -> t
(+) (-) t -> t -> t
(*) t -> t -> t
(/) {-(#)-} = Expr t -> t
fold
    where
        fold :: Expr t -> t
fold (Const  [Char]
s t
a) = [Char] -> t -> t
c [Char]
s t
a
        fold (Plus   Expr t
x Expr t
y) = Expr t -> t
fold Expr t
x t -> t -> t
+ Expr t -> t
fold Expr t
y
        fold (Minus  Expr t
x Expr t
y) = Expr t -> t
fold Expr t
x t -> t -> t
- Expr t -> t
fold Expr t
y
        fold (Times  Expr t
x Expr t
y) = Expr t -> t
fold Expr t
x t -> t -> t
* Expr t -> t
fold Expr t
y
        fold (Divide Expr t
x Expr t
y) = Expr t -> t
fold Expr t
x t -> t -> t
/ Expr t -> t
fold Expr t
y
--        fold (Repeat n y) = undefined # fold y

evalExprWithDiv :: (Num a, Monad m) => (a -> a -> m a) -> Expr a -> m a
evalExprWithDiv :: forall a (m :: * -> *).
(Num a, Monad m) =>
(a -> a -> m a) -> Expr a -> m a
evalExprWithDiv a -> a -> m a
(/) = forall {t} {t}.
([Char] -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> Expr t
-> t
foldExpr (forall a b. a -> b -> a
const forall (m :: * -> *) a. Monad m => a -> m a
return) (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a. Num a => a -> a -> a
(+)) (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (-)) (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a. Num a => a -> a -> a
(*)) m a -> m a -> m a
divM -- (*)
    where
        divM :: m a -> m a -> m a
divM m a
x m a
y = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> a -> m a
(/) m a
x m a
y)

evalFractionalExpr :: (Eq a, Fractional a, MonadError String m) => Expr a -> m a
evalFractionalExpr :: forall a (m :: * -> *).
(Eq a, Fractional a, MonadError [Char] m) =>
Expr a -> m a
evalFractionalExpr = forall a (m :: * -> *).
(Num a, Monad m) =>
(a -> a -> m a) -> Expr a -> m a
evalExprWithDiv forall {a} {m :: * -> *}.
(Eq a, MonadError [Char] m, Fractional a) =>
a -> a -> m a
divM
    where
        divM :: a -> a -> m a
divM a
x a
0 = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [Char]
"Divide by zero!"
        divM a
x a
y = forall (m :: * -> *) a. Monad m => a -> m a
return (a
x forall a. Fractional a => a -> a -> a
/ a
y)

evalIntegralExpr :: (Integral a, MonadError String m) => Expr a -> m a
evalIntegralExpr :: forall a (m :: * -> *).
(Integral a, MonadError [Char] m) =>
Expr a -> m a
evalIntegralExpr = forall a (m :: * -> *).
(Num a, Monad m) =>
(a -> a -> m a) -> Expr a -> m a
evalExprWithDiv forall {a} {m :: * -> *}.
(MonadError [Char] m, Integral a) =>
a -> a -> m a
divM
    where
        divM :: a -> a -> m a
divM a
x a
0 = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [Char]
"Divide by zero!"
        divM a
x a
y = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Integral a => a -> a -> a
div a
x a
y)

----------------------------------------------------------------
-- Commuting Expr with an arbitrary Monad m

commute :: (Expr a -> Expr a -> b) -> Expr (m a) -> Expr (m a) -> m b
commute Expr a -> Expr a -> b
con Expr (m a)
x Expr (m a)
y = do
    Expr a
x <- forall (m :: * -> *) a. Monad m => Expr (m a) -> m (Expr a)
runExpr Expr (m a)
x
    Expr a
y <- forall (m :: * -> *) a. Monad m => Expr (m a) -> m (Expr a)
runExpr Expr (m a)
y
    forall (m :: * -> *) a. Monad m => a -> m a
return (Expr a -> Expr a -> b
con Expr a
x Expr a
y)

runExpr :: Monad m => Expr (m a) -> m (Expr a)
runExpr :: forall (m :: * -> *) a. Monad m => Expr (m a) -> m (Expr a)
runExpr (Const  [Char]
s m a
x) = m a
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Char] -> a -> Expr a
Const [Char]
s
runExpr (Plus   Expr (m a)
x Expr (m a)
y) = forall {m :: * -> *} {a} {a} {b}.
Monad m =>
(Expr a -> Expr a -> b) -> Expr (m a) -> Expr (m a) -> m b
commute forall a. Expr a -> Expr a -> Expr a
Plus   Expr (m a)
x Expr (m a)
y
runExpr (Minus  Expr (m a)
x Expr (m a)
y) = forall {m :: * -> *} {a} {a} {b}.
Monad m =>
(Expr a -> Expr a -> b) -> Expr (m a) -> Expr (m a) -> m b
commute forall a. Expr a -> Expr a -> Expr a
Minus  Expr (m a)
x Expr (m a)
y
runExpr (Times  Expr (m a)
x Expr (m a)
y) = forall {m :: * -> *} {a} {a} {b}.
Monad m =>
(Expr a -> Expr a -> b) -> Expr (m a) -> Expr (m a) -> m b
commute forall a. Expr a -> Expr a -> Expr a
Times  Expr (m a)
x Expr (m a)
y
runExpr (Divide Expr (m a)
x Expr (m a)
y) = forall {m :: * -> *} {a} {a} {b}.
Monad m =>
(Expr a -> Expr a -> b) -> Expr (m a) -> Expr (m a) -> m b
commute forall a. Expr a -> Expr a -> Expr a
Divide Expr (m a)
x Expr (m a)
y
-- runExpr (Repeat x y) = commute Repeat x y

----------------------------------------------------------------
-- Pretty-printing 'Expr's

fmtIntegralExpr :: (Show a, Integral a) => Expr a -> String
fmtIntegralExpr :: forall a. (Show a, Integral a) => Expr a -> [Char]
fmtIntegralExpr (Const [Char]
_ a
e) = forall a. Show a => a -> [Char]
show a
e
fmtIntegralExpr Expr a
e =
    Bool -> ShowS -> ShowS
showParen Bool
True (forall a. ([Char] -> a -> Int -> ShowS) -> Expr a -> Int -> ShowS
fmtExprPrec forall {a} {p}. Show a => [Char] -> a -> p -> ShowS
showScalarConst Expr a
e Int
0)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" => "
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => ExceptT [Char] Identity a -> ShowS
showError (forall a (m :: * -> *).
(Integral a, MonadError [Char] m) =>
Expr a -> m a
evalIntegralExpr Expr a
e)
    forall a b. (a -> b) -> a -> b
$ [Char]
""

fmtIntegralListExpr :: (Show a, Integral a) => Expr [a] -> String
fmtIntegralListExpr :: forall a. (Show a, Integral a) => Expr [a] -> [Char]
fmtIntegralListExpr (Const [Char]
_ []) = [Char]
"0"
fmtIntegralListExpr (Const [Char]
_ [a
e]) = forall a. Show a => a -> [Char]
show a
e
fmtIntegralListExpr Expr [a]
e =
    Bool -> ShowS -> ShowS
showParen Bool
True (forall a. ([Char] -> a -> Int -> ShowS) -> Expr a -> Int -> ShowS
fmtExprPrec forall {a} {p}. Show a => [Char] -> a -> p -> ShowS
showListConst Expr [a]
e Int
0)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" => "
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => ExceptT [Char] Identity a -> ShowS
showError (forall a (m :: * -> *).
(Integral a, MonadError [Char] m) =>
Expr a -> m a
evalIntegralExpr (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum Expr [a]
e))
    forall a b. (a -> b) -> a -> b
$ [Char]
""

fmtSimple :: (Integral a, Show a) => Expr [a] -> String
fmtSimple :: forall a. (Integral a, Show a) => Expr [a] -> [Char]
fmtSimple (Const [Char]
_ []) = [Char]
"0"
fmtSimple (Const [Char]
_ [a
e]) = forall a. Show a => a -> [Char]
show a
e
fmtSimple Expr [a]
e =
    Bool -> ShowS -> ShowS
showParen Bool
False (forall a. ([Char] -> a -> Int -> ShowS) -> Expr a -> Int -> ShowS
fmtExprPrec forall a. Show a => [Char] -> [a] -> Int -> ShowS
showSimpleListConst Expr [a]
e Int
0)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" => "
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => ExceptT [Char] Identity a -> ShowS
showError (forall a (m :: * -> *).
(Integral a, MonadError [Char] m) =>
Expr a -> m a
evalIntegralExpr (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum Expr [a]
e))
    forall a b. (a -> b) -> a -> b
$ [Char]
""

fmtSimpleRational :: Expr [Integer] -> String
fmtSimpleRational :: Expr [Integer] -> [Char]
fmtSimpleRational (Const [Char]
_ []) = [Char]
"0"
fmtSimpleRational (Const [Char]
_ [Integer
e]) = forall a. Show a => a -> [Char]
show Integer
e
fmtSimpleRational Expr [Integer]
e =
    Bool -> ShowS -> ShowS
showParen Bool
False (forall a. ([Char] -> a -> Int -> ShowS) -> Expr a -> Int -> ShowS
fmtExprPrec forall a. Show a => [Char] -> [a] -> Int -> ShowS
showSimpleListConst Expr [Integer]
e Int
0)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" => "
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t}. (t -> ShowS) -> ExceptT [Char] Identity t -> ShowS
showErrorWith Ratio Integer -> ShowS
showRationalWithDouble (forall a (m :: * -> *).
(Eq a, Fractional a, MonadError [Char] m) =>
Expr a -> m a
evalFractionalExpr (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => Integer -> a
fromIntegerforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum) Expr [Integer]
e))
    forall a b. (a -> b) -> a -> b
$ [Char]
""

showScalarConst :: [Char] -> a -> p -> ShowS
showScalarConst [Char]
d  a
v  p
p = [Char] -> ShowS
showString [Char]
d forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
"[" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows a
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
"]"
showListConst :: [Char] -> a -> p -> ShowS
showListConst   [Char]
d  a
v  p
p = [Char] -> ShowS
showString [Char]
d forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows a
v

showSimpleConst :: (a -> a -> ShowS) -> p -> [a] -> a -> ShowS
showSimpleConst a -> a -> ShowS
showsPrec p
d [a
v] a
p = a -> a -> ShowS
showsPrec a
p a
v
showSimpleConst a -> a -> ShowS
showsPrec p
d  [a]
v  a
p = Bool -> ShowS -> ShowS
showParen (a
p forall a. Ord a => a -> a -> Bool
> a
0) (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (forall a. a -> [a] -> [a]
intersperse (Char -> ShowS
showChar Char
'+') (forall a b. (a -> b) -> [a] -> [b]
map (a -> a -> ShowS
showsPrec a
6) [a]
v)))

showSimpleListConst :: Show a => String -> [a] -> Int -> ShowS
showSimpleListConst :: forall a. Show a => [Char] -> [a] -> Int -> ShowS
showSimpleListConst = forall {a} {a} {p}.
(Ord a, Num a) =>
(a -> a -> ShowS) -> p -> [a] -> a -> ShowS
showSimpleConst forall a. Show a => Int -> a -> ShowS
showsPrec

showSimpleRationalConst :: p -> [Ratio Integer] -> Integer -> ShowS
showSimpleRationalConst = forall {a} {a} {p}.
(Ord a, Num a) =>
(a -> a -> ShowS) -> p -> [a] -> a -> ShowS
showSimpleConst forall {a} {a}.
(Show a, Ord a, Num a, Num a, Eq a) =>
a -> Ratio a -> ShowS
showRational

showError :: Show a => ExceptT String Identity a -> ShowS
showError :: forall a. Show a => ExceptT [Char] Identity a -> ShowS
showError = forall {t}. (t -> ShowS) -> ExceptT [Char] Identity t -> ShowS
showErrorWith forall a. Show a => a -> ShowS
shows

showErrorWith :: (t -> ShowS) -> ExceptT [Char] Identity t -> ShowS
showErrorWith t -> ShowS
f (ExceptT (Identity (Left  [Char]
e))) = [Char] -> ShowS
showString [Char]
e
showErrorWith t -> ShowS
f (ExceptT (Identity (Right t
x))) = t -> ShowS
f t
x

showDouble :: Double -> ShowS
showDouble :: Double -> ShowS
showDouble Double
d = [Char] -> ShowS
showString (ShowS
trim (forall r. PrintfType r => [Char] -> r
printf [Char]
"%.04g" Double
d))
    where trim :: ShowS
trim = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
==Char
'0') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse

showRational :: a -> Ratio a -> ShowS
showRational a
p Ratio a
d
    | forall a. Ratio a -> a
denominator Ratio a
d forall a. Eq a => a -> a -> Bool
== a
1    = forall a. Show a => a -> ShowS
shows (forall a. Ratio a -> a
numerator Ratio a
d)
    | Bool
otherwise             = Bool -> ShowS -> ShowS
showParen (a
p forall a. Ord a => a -> a -> Bool
> a
7)
        ( forall a. Show a => a -> ShowS
shows (forall a. Ratio a -> a
numerator Ratio a
d)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'/'
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows (forall a. Ratio a -> a
denominator Ratio a
d)
        )

showRationalWithDouble :: Ratio Integer -> ShowS
showRationalWithDouble Ratio Integer
d
    | Bool
isInt     = forall {a} {a}.
(Show a, Ord a, Num a, Num a, Eq a) =>
a -> Ratio a -> ShowS
showRational Integer
0 Ratio Integer
d
    | Bool
otherwise = forall {a} {a}.
(Show a, Ord a, Num a, Num a, Eq a) =>
a -> Ratio a -> ShowS
showRational Integer
0 Ratio Integer
d
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" => "
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> ShowS
showDouble (forall a. Fractional a => Ratio Integer -> a
fromRational Ratio Integer
d)
    where isInt :: Bool
isInt = forall a. Ratio a -> a
denominator Ratio Integer
d forall a. Eq a => a -> a -> Bool
== Integer
1

fmtExprPrec :: (String -> a -> Int -> ShowS) -> Expr a -> Int -> ShowS
fmtExprPrec :: forall a. ([Char] -> a -> Int -> ShowS) -> Expr a -> Int -> ShowS
fmtExprPrec [Char] -> a -> Int -> ShowS
showConst Expr a
e = forall {t} {t}.
([Char] -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> Expr t
-> t
foldExpr
    (\[Char]
d a
v Int
p -> [Char] -> a -> Int -> ShowS
showConst [Char]
d a
v Int
p)
    (\Int -> ShowS
x Int -> ShowS
y Int
p -> Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
>  Int
6) (Int -> ShowS
x Int
6 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" + " forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
y Int
6))
    (\Int -> ShowS
x Int -> ShowS
y Int
p -> Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
>  Int
6) (Int -> ShowS
x Int
6 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" - " forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
y Int
7))
    (\Int -> ShowS
x Int -> ShowS
y Int
p -> Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
>  Int
7) (Int -> ShowS
x Int
7 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" * " forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
y Int
7))
    (\Int -> ShowS
x Int -> ShowS
y Int
p -> Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
>  Int
7) (Int -> ShowS
x Int
7 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" / " forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
y Int
8))
    Expr a
e

----------------------------------------------------------------
-- Rolling dice

rollEm :: String -> IO (Either ParseError String)
rollEm :: [Char] -> IO (Either ParseError [Char])
rollEm [Char]
str = case forall a.
(Integral a, UniformRange a) =>
[Char] -> [Char] -> Either ParseError (Expr (RVar [a]))
parseExpr [Char]
"rollEm" [Char]
str of
    Left ParseError
err    -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left ParseError
err)
    Right Expr (RVar [Integer])
ex    -> do
        Expr [Integer]
ex <- do
          IOGenM StdGen
g <- forall (m :: * -> *) g. MonadIO m => g -> m (IOGenM g)
newIOGenM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
          forall (d :: * -> *) (m :: * -> *) t g.
(Sampleable d m t, StatefulGen g m) =>
g -> d t -> m t
sampleFrom IOGenM StdGen
g (forall (m :: * -> *) a. Monad m => Expr (m a) -> m (Expr a)
runExpr Expr (RVar [Integer])
ex)
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (Expr [Integer] -> [Char]
fmtSimpleRational (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => Int -> [a] -> [a]
summarizeRollsOver Int
3) Expr [Integer]
ex)))
--        return (Right (fmtIntegralListExpr ex))

summarizeRollsOver :: Num a => Int -> [a] -> [a]
summarizeRollsOver :: forall a. Num a => Int -> [a] -> [a]
summarizeRollsOver Int
n [a]
xs
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. Int -> [a] -> [a]
drop Int
n [a]
xs)  = [a]
xs
    | Bool
otherwise         = [forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [a]
xs]

roll :: (Integral a, UniformRange a) => a -> a -> RVar [a]
roll :: forall a. (Integral a, UniformRange a) => a -> a -> RVar [a]
roll a
count a
sides
    | a
count forall a. Ord a => a -> a -> Bool
> a
100   = do
        Double
x <- forall a. Distribution Normal a => RVar a
stdNormal :: RVar Double
        let e :: a
e = a
countforall a. Num a => a -> a -> a
*(a
sidesforall a. Num a => a -> a -> a
+a
1)forall a. Integral a => a -> a -> a
`div`a
2
            e' :: Double
e' = forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
countforall a. Num a => a -> a -> a
*(a
sidesforall a. Num a => a -> a -> a
+a
1)forall a. Integral a => a -> a -> a
`mod`a
2)forall a. Fractional a => a -> a -> a
/Double
2
            v :: Double
v = forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
sidesforall a. Num a => a -> a -> a
*a
sidesforall a. Num a => a -> a -> a
-a
1)forall a. Fractional a => a -> a -> a
/Double
12
            x' :: Double
x' = Double
e' forall a. Num a => a -> a -> a
+ Double
x forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
sqrt (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
count forall a. Num a => a -> a -> a
* Double
v)
        forall (m :: * -> *) a. Monad m => a -> m a
return [a
e forall a. Num a => a -> a -> a
+ forall a b. (RealFrac a, Integral b) => a -> b
round Double
x']
    | Bool
otherwise     = do
        [a]
ls <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
count) (forall a (m :: * -> *). UniformRange a => a -> a -> RVarT m a
integralUniform a
1 a
sides)
        forall (m :: * -> *) a. Monad m => a -> m a
return [a]
ls

----------------------------------------------------------------
-- The parser

parseExpr :: (Integral a, UniformRange a) => String -> String -> Either ParseError (Expr (RVar [a]))
parseExpr :: forall a.
(Integral a, UniformRange a) =>
[Char] -> [Char] -> Either ParseError (Expr (RVar [a]))
parseExpr [Char]
src [Char]
str = forall tok st a.
GenParser tok st a -> st -> [Char] -> [tok] -> Either ParseError a
runParser forall a.
(Integral a, UniformRange a) =>
CharParser Bool (Expr (RVar [a]))
expr Bool
False [Char]
src [Char]
str

-- a token-lexer thing
diceLang :: TokenParser st
diceLang :: forall st. TokenParser st
diceLang = forall s (m :: * -> *) u.
Stream s m Char =>
GenLanguageDef s u m -> GenTokenParser s u m
makeTokenParser
    (forall st. LanguageDef st
haskellStyle { reservedOpNames :: [[Char]]
reservedOpNames = [[Char]
"*",[Char]
"/",[Char]
"+",[Char]
"-"{-,"#"-}] })

expr :: (Integral a, UniformRange a) => CharParser Bool (Expr (RVar [a]))
expr :: forall a.
(Integral a, UniformRange a) =>
CharParser Bool (Expr (RVar [a]))
expr = do
    forall s u (m :: * -> *). GenTokenParser s u m -> ParsecT s u m ()
whiteSpace forall st. TokenParser st
diceLang
    Expr (RVar [a])
e <- forall a.
(Integral a, UniformRange a) =>
CharParser Bool (Expr (RVar [a]))
term
    forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof

    Bool
hasRolls <- forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
    if Bool
hasRolls
        then forall (m :: * -> *) a. Monad m => a -> m a
return Expr (RVar [a])
e
        else forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"no rolls in expression"

term :: (Integral a, UniformRange a) => CharParser Bool (Expr (RVar [a]))
term :: forall a.
(Integral a, UniformRange a) =>
CharParser Bool (Expr (RVar [a]))
term = forall tok st a.
OperatorTable tok st a -> GenParser tok st a -> GenParser tok st a
buildExpressionParser forall {st} {a}. [[Operator Char st (Expr a)]]
table forall a.
(Integral a, UniformRange a) =>
CharParser Bool (Expr (RVar [a]))
primExp
    where   table :: [[Operator Char st (Expr a)]]
table =
                [ [forall {a} {st}.
[Char] -> (a -> a -> a) -> Assoc -> Operator Char st a
binary [Char]
"*" forall a. Expr a -> Expr a -> Expr a
Times Assoc
AssocLeft, forall {a} {st}.
[Char] -> (a -> a -> a) -> Assoc -> Operator Char st a
binary [Char]
"/" forall a. Expr a -> Expr a -> Expr a
Divide Assoc
AssocLeft ]
                , [forall {a} {st}.
[Char] -> (a -> a -> a) -> Assoc -> Operator Char st a
binary [Char]
"+" forall a. Expr a -> Expr a -> Expr a
Plus  Assoc
AssocLeft, forall {a} {st}.
[Char] -> (a -> a -> a) -> Assoc -> Operator Char st a
binary [Char]
"-" forall a. Expr a -> Expr a -> Expr a
Minus  Assoc
AssocLeft ]
--                , [binary "#" Repeat AssocRight]
                ]
            binary :: [Char] -> (a -> a -> a) -> Assoc -> Operator Char st a
binary [Char]
name a -> a -> a
fun Assoc
assoc = forall tok st a.
GenParser tok st (a -> a -> a) -> Assoc -> Operator tok st a
Infix (do{ forall s u (m :: * -> *).
GenTokenParser s u m -> [Char] -> ParsecT s u m ()
reservedOp forall st. TokenParser st
diceLang [Char]
name; forall (m :: * -> *) a. Monad m => a -> m a
return a -> a -> a
fun }) Assoc
assoc

primExp :: (Integral a, UniformRange a) => CharParser Bool (Expr (RVar [a]))
primExp :: forall a.
(Integral a, UniformRange a) =>
CharParser Bool (Expr (RVar [a]))
primExp = forall tok st a. GenParser tok st a -> GenParser tok st a
try forall a.
(Integral a, UniformRange a) =>
CharParser Bool (Expr (RVar [a]))
dieExp forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall a st. Num a => CharParser st (Expr (RVar [a]))
numExp forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
parens forall st. TokenParser st
diceLang forall a.
(Integral a, UniformRange a) =>
CharParser Bool (Expr (RVar [a]))
term

dieExp :: (Integral a, UniformRange a) => CharParser Bool (Expr (RVar [a]))
dieExp :: forall a.
(Integral a, UniformRange a) =>
CharParser Bool (Expr (RVar [a]))
dieExp = do
    ([Char]
cStr, Integer
count) <- forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option ([Char]
"", Integer
1) forall st. CharParser st ([Char], Integer)
number
    ([Char]
sStr, Integer
sides) <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'd' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall st. CharParser st ([Char], Integer)
positiveNumber
    forall (m :: * -> *) u s. Monad m => u -> ParsecT s u m ()
setState Bool
True
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [Char] -> a -> Expr a
Const ([Char]
cStr forall a. [a] -> [a] -> [a]
++ Char
'd' forall a. a -> [a] -> [a]
: [Char]
sStr) (forall a. (Integral a, UniformRange a) => a -> a -> RVar [a]
roll (forall a. Num a => Integer -> a
fromInteger Integer
count) (forall a. Num a => Integer -> a
fromInteger Integer
sides)))

numExp :: Num a => CharParser st (Expr (RVar [a]))
numExp :: forall a st. Num a => CharParser st (Expr (RVar [a]))
numExp = do
    ([Char]
str, Integer
num) <- forall st. CharParser st ([Char], Integer)
number
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [Char] -> a -> Expr a
Const [Char]
str (forall (m :: * -> *) a. Monad m => a -> m a
return [forall a. Num a => Integer -> a
fromInteger Integer
num]))

number :: CharParser st (String, Integer)
number :: forall st. CharParser st ([Char], Integer)
number = do
    [Char]
n <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"number"
    forall s u (m :: * -> *). GenTokenParser s u m -> ParsecT s u m ()
whiteSpace forall st. TokenParser st
diceLang
    forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
n, forall a. Read a => [Char] -> a
read [Char]
n)

positiveNumber :: CharParser st (String, Integer)
positiveNumber :: forall st. CharParser st ([Char], Integer)
positiveNumber = do
    ([Char]
s,Integer
n) <- forall st. CharParser st ([Char], Integer)
number
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
nforall a. Ord a => a -> a -> Bool
>Integer
0)
    forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
s,Integer
n)