{-# LANGUAGE CPP #-}
module Data.Random.Dice where
import Data.Random
import Data.Random.Distribution.Uniform (integralUniform)
import Control.Monad
import Control.Monad.Trans.Error
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
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)
deriving Int -> Expr a -> ShowS
[Expr a] -> ShowS
Expr a -> String
(Int -> Expr a -> ShowS)
-> (Expr a -> String) -> ([Expr a] -> ShowS) -> Show (Expr a)
forall a. Show a => Int -> Expr a -> ShowS
forall a. Show a => [Expr a] -> ShowS
forall a. Show a => Expr a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Expr a] -> ShowS
$cshowList :: forall a. Show a => [Expr a] -> ShowS
show :: Expr a -> String
$cshow :: forall a. Show a => Expr a -> String
showsPrec :: Int -> Expr a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Expr a -> ShowS
Show
instance Functor Expr where
fmap :: (a -> b) -> Expr a -> Expr b
fmap f :: a -> b
f = (String -> a -> Expr b)
-> (Expr b -> Expr b -> Expr b)
-> (Expr b -> Expr b -> Expr b)
-> (Expr b -> Expr b -> Expr b)
-> (Expr b -> Expr b -> Expr b)
-> Expr a
-> Expr b
forall t t.
(String -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> Expr t
-> t
foldExpr (\s :: String
s x :: a
x -> String -> b -> Expr b
forall a. String -> a -> Expr a
Const String
s (a -> b
f a
x)) Expr b -> Expr b -> Expr b
forall a. Expr a -> Expr a -> Expr a
Plus Expr b -> Expr b -> Expr b
forall a. Expr a -> Expr a -> Expr a
Minus Expr b -> Expr b -> Expr b
forall a. Expr a -> Expr a -> Expr a
Times Expr b -> Expr b -> Expr b
forall a. Expr a -> Expr a -> Expr a
Divide
foldExpr :: (String -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> Expr t
-> t
foldExpr c :: String -> t -> t
c + :: t -> t -> t
(+) (-) * :: t -> t -> t
(*) / :: t -> t -> t
(/) = Expr t -> t
fold
where
fold :: Expr t -> t
fold (Const s :: String
s a :: t
a) = String -> t -> t
c String
s t
a
fold (Plus x :: Expr t
x y :: Expr t
y) = Expr t -> t
fold Expr t
x t -> t -> t
+ Expr t -> t
fold Expr t
y
fold (Minus x :: Expr t
x y :: Expr t
y) = Expr t -> t
fold Expr t
x t -> t -> t
- Expr t -> t
fold Expr t
y
fold (Times x :: Expr t
x y :: Expr t
y) = Expr t -> t
fold Expr t
x t -> t -> t
* Expr t -> t
fold Expr t
y
fold (Divide x :: Expr t
x y :: Expr t
y) = Expr t -> t
fold Expr t
x t -> t -> t
/ Expr t -> t
fold Expr t
y
evalExprWithDiv :: (Num a, Monad m) => (a -> a -> m a) -> Expr a -> m a
evalExprWithDiv :: (a -> a -> m a) -> Expr a -> m a
evalExprWithDiv / :: a -> a -> m a
(/) = (String -> a -> m a)
-> (m a -> m a -> m a)
-> (m a -> m a -> m a)
-> (m a -> m a -> m a)
-> (m a -> m a -> m a)
-> Expr a
-> m a
forall t t.
(String -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> Expr t
-> t
foldExpr ((a -> m a) -> String -> a -> m a
forall a b. a -> b -> a
const a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return) ((a -> a -> a) -> m a -> m a -> m a
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> a -> a
forall a. Num a => a -> a -> a
(+)) ((a -> a -> a) -> m a -> m a -> m a
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (-)) ((a -> a -> a) -> m a -> m a -> m a
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> a -> a
forall a. Num a => a -> a -> a
(*)) m a -> m a -> m a
divM
where
divM :: m a -> m a -> m a
divM x :: m a
x y :: m a
y = m (m a) -> m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ((a -> a -> m a) -> m a -> m a -> m (m a)
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)
#if __GLASGOW_HASKELL__ < 808
evalFractionalExpr :: (Eq a, Fractional a, Monad m) => Expr a -> m a
#else
evalFractionalExpr :: (Eq a, Fractional a, MonadFail m) => Expr a -> m a
#endif
evalFractionalExpr :: Expr a -> m a
evalFractionalExpr = (a -> a -> m a) -> Expr a -> m a
forall a (m :: * -> *).
(Num a, Monad m) =>
(a -> a -> m a) -> Expr a -> m a
evalExprWithDiv a -> a -> m a
forall a (m :: * -> *).
(Eq a, MonadFail m, Fractional a) =>
a -> a -> m a
divM
where
divM :: a -> a -> m a
divM x :: a
x 0 = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Divide by zero!"
divM x :: a
x y :: a
y = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
y)
#if __GLASGOW_HASKELL__ < 808
evalIntegralExpr :: (Integral a, Monad m) => Expr a -> m a
#else
evalIntegralExpr :: (Integral a, MonadFail m) => Expr a -> m a
#endif
evalIntegralExpr :: Expr a -> m a
evalIntegralExpr = (a -> a -> m a) -> Expr a -> m a
forall a (m :: * -> *).
(Num a, Monad m) =>
(a -> a -> m a) -> Expr a -> m a
evalExprWithDiv a -> a -> m a
forall a (m :: * -> *). (MonadFail m, Integral a) => a -> a -> m a
divM
where
divM :: a -> a -> m a
divM x :: a
x 0 = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Divide by zero!"
divM x :: a
x y :: a
y = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> a -> a
forall a. Integral a => a -> a -> a
div a
x a
y)
commute :: (Expr a -> Expr a -> b) -> Expr (m a) -> Expr (m a) -> m b
commute con :: Expr a -> Expr a -> b
con x :: Expr (m a)
x y :: Expr (m a)
y = do
Expr a
x <- Expr (m a) -> m (Expr a)
forall (m :: * -> *) a. Monad m => Expr (m a) -> m (Expr a)
runExpr Expr (m a)
x
Expr a
y <- Expr (m a) -> m (Expr a)
forall (m :: * -> *) a. Monad m => Expr (m a) -> m (Expr a)
runExpr Expr (m a)
y
b -> m b
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 :: Expr (m a) -> m (Expr a)
runExpr (Const s :: String
s x :: m a
x) = m a
x m a -> (a -> m (Expr a)) -> m (Expr a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Expr a -> m (Expr a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr a -> m (Expr a)) -> (a -> Expr a) -> a -> m (Expr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a -> Expr a
forall a. String -> a -> Expr a
Const String
s
runExpr (Plus x :: Expr (m a)
x y :: Expr (m a)
y) = (Expr a -> Expr a -> Expr a)
-> Expr (m a) -> Expr (m a) -> m (Expr a)
forall (m :: * -> *) a a b.
Monad m =>
(Expr a -> Expr a -> b) -> Expr (m a) -> Expr (m a) -> m b
commute Expr a -> Expr a -> Expr a
forall a. Expr a -> Expr a -> Expr a
Plus Expr (m a)
x Expr (m a)
y
runExpr (Minus x :: Expr (m a)
x y :: Expr (m a)
y) = (Expr a -> Expr a -> Expr a)
-> Expr (m a) -> Expr (m a) -> m (Expr a)
forall (m :: * -> *) a a b.
Monad m =>
(Expr a -> Expr a -> b) -> Expr (m a) -> Expr (m a) -> m b
commute Expr a -> Expr a -> Expr a
forall a. Expr a -> Expr a -> Expr a
Minus Expr (m a)
x Expr (m a)
y
runExpr (Times x :: Expr (m a)
x y :: Expr (m a)
y) = (Expr a -> Expr a -> Expr a)
-> Expr (m a) -> Expr (m a) -> m (Expr a)
forall (m :: * -> *) a a b.
Monad m =>
(Expr a -> Expr a -> b) -> Expr (m a) -> Expr (m a) -> m b
commute Expr a -> Expr a -> Expr a
forall a. Expr a -> Expr a -> Expr a
Times Expr (m a)
x Expr (m a)
y
runExpr (Divide x :: Expr (m a)
x y :: Expr (m a)
y) = (Expr a -> Expr a -> Expr a)
-> Expr (m a) -> Expr (m a) -> m (Expr a)
forall (m :: * -> *) a a b.
Monad m =>
(Expr a -> Expr a -> b) -> Expr (m a) -> Expr (m a) -> m b
commute Expr a -> Expr a -> Expr a
forall a. Expr a -> Expr a -> Expr a
Divide Expr (m a)
x Expr (m a)
y
fmtIntegralExpr :: (Show a, Integral a) => Expr a -> String
fmtIntegralExpr :: Expr a -> String
fmtIntegralExpr (Const _ e :: a
e) = a -> String
forall a. Show a => a -> String
show a
e
fmtIntegralExpr e :: Expr a
e =
Bool -> ShowS -> ShowS
showParen Bool
True ((String -> a -> Int -> ShowS) -> Expr a -> Int -> ShowS
forall a. (String -> a -> Int -> ShowS) -> Expr a -> Int -> ShowS
fmtExprPrec String -> a -> Int -> ShowS
forall a p. Show a => String -> a -> p -> ShowS
showScalarConst Expr a
e 0)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " => "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorT String Identity a -> ShowS
forall a. Show a => ErrorT String Identity a -> ShowS
showError (Expr a -> ErrorT String Identity a
forall a (m :: * -> *). (Integral a, MonadFail m) => Expr a -> m a
evalIntegralExpr Expr a
e)
ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ""
fmtIntegralListExpr :: (Show a, Integral a) => Expr [a] -> String
fmtIntegralListExpr :: Expr [a] -> String
fmtIntegralListExpr (Const _ []) = "0"
fmtIntegralListExpr (Const _ [e :: a
e]) = a -> String
forall a. Show a => a -> String
show a
e
fmtIntegralListExpr e :: Expr [a]
e =
Bool -> ShowS -> ShowS
showParen Bool
True ((String -> [a] -> Int -> ShowS) -> Expr [a] -> Int -> ShowS
forall a. (String -> a -> Int -> ShowS) -> Expr a -> Int -> ShowS
fmtExprPrec String -> [a] -> Int -> ShowS
forall a p. Show a => String -> a -> p -> ShowS
showListConst Expr [a]
e 0)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " => "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorT String Identity a -> ShowS
forall a. Show a => ErrorT String Identity a -> ShowS
showError (Expr a -> ErrorT String Identity a
forall a (m :: * -> *). (Integral a, MonadFail m) => Expr a -> m a
evalIntegralExpr (([a] -> a) -> Expr [a] -> Expr a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum Expr [a]
e))
ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ""
fmtSimple :: (Integral a, Show a) => Expr [a] -> String
fmtSimple :: Expr [a] -> String
fmtSimple (Const _ []) = "0"
fmtSimple (Const _ [e :: a
e]) = a -> String
forall a. Show a => a -> String
show a
e
fmtSimple e :: Expr [a]
e =
Bool -> ShowS -> ShowS
showParen Bool
False ((String -> [a] -> Int -> ShowS) -> Expr [a] -> Int -> ShowS
forall a. (String -> a -> Int -> ShowS) -> Expr a -> Int -> ShowS
fmtExprPrec String -> [a] -> Int -> ShowS
forall a. Show a => String -> [a] -> Int -> ShowS
showSimpleListConst Expr [a]
e 0)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " => "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorT String Identity a -> ShowS
forall a. Show a => ErrorT String Identity a -> ShowS
showError (Expr a -> ErrorT String Identity a
forall a (m :: * -> *). (Integral a, MonadFail m) => Expr a -> m a
evalIntegralExpr (([a] -> a) -> Expr [a] -> Expr a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum Expr [a]
e))
ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ""
fmtSimpleRational :: Expr [Integer] -> String
fmtSimpleRational :: Expr [Integer] -> String
fmtSimpleRational (Const _ []) = "0"
fmtSimpleRational (Const _ [e :: Integer
e]) = Integer -> String
forall a. Show a => a -> String
show Integer
e
fmtSimpleRational e :: Expr [Integer]
e =
Bool -> ShowS -> ShowS
showParen Bool
False ((String -> [Integer] -> Int -> ShowS)
-> Expr [Integer] -> Int -> ShowS
forall a. (String -> a -> Int -> ShowS) -> Expr a -> Int -> ShowS
fmtExprPrec String -> [Integer] -> Int -> ShowS
forall a. Show a => String -> [a] -> Int -> ShowS
showSimpleListConst Expr [Integer]
e 0)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " => "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ratio Integer -> ShowS)
-> ErrorT String Identity (Ratio Integer) -> ShowS
forall t. (t -> ShowS) -> ErrorT String Identity t -> ShowS
showErrorWith Ratio Integer -> ShowS
showRationalWithDouble (Expr (Ratio Integer) -> ErrorT String Identity (Ratio Integer)
forall a (m :: * -> *).
(Eq a, Fractional a, MonadFail m) =>
Expr a -> m a
evalFractionalExpr (([Integer] -> Ratio Integer)
-> Expr [Integer] -> Expr (Ratio Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Ratio Integer
forall a. Num a => Integer -> a
fromInteger(Integer -> Ratio Integer)
-> ([Integer] -> Integer) -> [Integer] -> Ratio Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum) Expr [Integer]
e))
ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ""
showScalarConst :: String -> a -> p -> ShowS
showScalarConst d :: String
d v :: a
v p :: p
p = String -> ShowS
showString String
d ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "[" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall a. Show a => a -> ShowS
shows a
v ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "]"
showListConst :: String -> a -> p -> ShowS
showListConst d :: String
d v :: a
v p :: p
p = String -> ShowS
showString String
d ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall a. Show a => a -> ShowS
shows a
v
showSimpleConst :: (a -> t -> ShowS) -> p -> [t] -> a -> ShowS
showSimpleConst showsPrec :: a -> t -> ShowS
showsPrec d :: p
d [v :: t
v] p :: a
p = a -> t -> ShowS
showsPrec a
p t
v
showSimpleConst showsPrec :: a -> t -> ShowS
showsPrec d :: p
d v :: [t]
v p :: a
p = Bool -> ShowS -> ShowS
showParen (a
p a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> 0) ((ShowS -> ShowS -> ShowS) -> [ShowS] -> ShowS
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
intersperse (Char -> ShowS
showChar '+') ((t -> ShowS) -> [t] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map (a -> t -> ShowS
showsPrec 6) [t]
v)))
showSimpleListConst :: Show a => String -> [a] -> Int -> ShowS
showSimpleListConst :: String -> [a] -> Int -> ShowS
showSimpleListConst = (Int -> a -> ShowS) -> String -> [a] -> Int -> ShowS
forall a t p.
(Ord a, Num a) =>
(a -> t -> ShowS) -> p -> [t] -> a -> ShowS
showSimpleConst Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec
showSimpleRationalConst :: p -> [Ratio Integer] -> Integer -> ShowS
showSimpleRationalConst = (Integer -> Ratio Integer -> ShowS)
-> p -> [Ratio Integer] -> Integer -> ShowS
forall a t p.
(Ord a, Num a) =>
(a -> t -> ShowS) -> p -> [t] -> a -> ShowS
showSimpleConst Integer -> Ratio Integer -> ShowS
forall a a.
(Show a, Ord a, Num a, Num a, Eq a) =>
a -> Ratio a -> ShowS
showRational
showError :: Show a => ErrorT String Identity a -> ShowS
showError :: ErrorT String Identity a -> ShowS
showError = (a -> ShowS) -> ErrorT String Identity a -> ShowS
forall t. (t -> ShowS) -> ErrorT String Identity t -> ShowS
showErrorWith a -> ShowS
forall a. Show a => a -> ShowS
shows
showErrorWith :: (t -> ShowS) -> ErrorT String Identity t -> ShowS
showErrorWith f :: t -> ShowS
f (ErrorT (Identity (Left e :: String
e))) = String -> ShowS
showString String
e
showErrorWith f :: t -> ShowS
f (ErrorT (Identity (Right x :: t
x))) = t -> ShowS
f t
x
showDouble :: Double -> ShowS
showDouble :: Double -> ShowS
showDouble d :: Double
d = String -> ShowS
showString (ShowS
trim (String -> Double -> String
forall r. PrintfType r => String -> r
printf "%.04g" Double
d))
where trim :: ShowS
trim = ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='0') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse
showRational :: a -> Ratio a -> ShowS
showRational p :: a
p d :: Ratio a
d
| Ratio a -> a
forall a. Ratio a -> a
denominator Ratio a
d a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== 1 = a -> ShowS
forall a. Show a => a -> ShowS
shows (Ratio a -> a
forall a. Ratio a -> a
numerator Ratio a
d)
| Bool
otherwise = Bool -> ShowS -> ShowS
showParen (a
p a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> 7)
( a -> ShowS
forall a. Show a => a -> ShowS
shows (Ratio a -> a
forall a. Ratio a -> a
numerator Ratio a
d)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar '/'
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall a. Show a => a -> ShowS
shows (Ratio a -> a
forall a. Ratio a -> a
denominator Ratio a
d)
)
showRationalWithDouble :: Ratio Integer -> ShowS
showRationalWithDouble d :: Ratio Integer
d
| Bool
isInt = Integer -> Ratio Integer -> ShowS
forall a a.
(Show a, Ord a, Num a, Num a, Eq a) =>
a -> Ratio a -> ShowS
showRational 0 Ratio Integer
d
| Bool
otherwise = Integer -> Ratio Integer -> ShowS
forall a a.
(Show a, Ord a, Num a, Num a, Eq a) =>
a -> Ratio a -> ShowS
showRational 0 Ratio Integer
d
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " => "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> ShowS
showDouble (Ratio Integer -> Double
forall a. Fractional a => Ratio Integer -> a
fromRational Ratio Integer
d)
where isInt :: Bool
isInt = Ratio Integer -> Integer
forall a. Ratio a -> a
denominator Ratio Integer
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 1
fmtExprPrec :: (String -> a -> Int -> ShowS) -> Expr a -> Int -> ShowS
fmtExprPrec :: (String -> a -> Int -> ShowS) -> Expr a -> Int -> ShowS
fmtExprPrec showConst :: String -> a -> Int -> ShowS
showConst e :: Expr a
e = (String -> a -> Int -> ShowS)
-> ((Int -> ShowS) -> (Int -> ShowS) -> Int -> ShowS)
-> ((Int -> ShowS) -> (Int -> ShowS) -> Int -> ShowS)
-> ((Int -> ShowS) -> (Int -> ShowS) -> Int -> ShowS)
-> ((Int -> ShowS) -> (Int -> ShowS) -> Int -> ShowS)
-> Expr a
-> Int
-> ShowS
forall t t.
(String -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> Expr t
-> t
foldExpr
(\d :: String
d v :: a
v p :: Int
p -> String -> a -> Int -> ShowS
showConst String
d a
v Int
p)
(\x :: Int -> ShowS
x y :: Int -> ShowS
y p :: Int
p -> Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 6) (Int -> ShowS
x 6 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " + " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
y 6))
(\x :: Int -> ShowS
x y :: Int -> ShowS
y p :: Int
p -> Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 6) (Int -> ShowS
x 6 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " - " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
y 7))
(\x :: Int -> ShowS
x y :: Int -> ShowS
y p :: Int
p -> Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 7) (Int -> ShowS
x 7 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " * " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
y 7))
(\x :: Int -> ShowS
x y :: Int -> ShowS
y p :: Int
p -> Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 7) (Int -> ShowS
x 7 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " / " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
y 8))
Expr a
e
rollEm :: String -> IO (Either ParseError String)
rollEm :: String -> IO (Either ParseError String)
rollEm str :: String
str = case String -> String -> Either ParseError (Expr (RVar [Integer]))
forall a.
Integral a =>
String -> String -> Either ParseError (Expr (RVar [a]))
parseExpr "rollEm" String
str of
Left err :: ParseError
err -> Either ParseError String -> IO (Either ParseError String)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseError -> Either ParseError String
forall a b. a -> Either a b
Left ParseError
err)
Right ex :: Expr (RVar [Integer])
ex -> do
Expr [Integer]
ex <- RVarT Identity (Expr [Integer]) -> IO (Expr [Integer])
forall (d :: * -> *) (m :: * -> *) t.
(Sampleable d m t, MonadRandom m) =>
d t -> m t
sample (RVarT Identity (Expr [Integer]) -> IO (Expr [Integer]))
-> RVarT Identity (Expr [Integer]) -> IO (Expr [Integer])
forall a b. (a -> b) -> a -> b
$ Expr (RVar [Integer]) -> RVarT Identity (Expr [Integer])
forall (m :: * -> *) a. Monad m => Expr (m a) -> m (Expr a)
runExpr Expr (RVar [Integer])
ex :: IO (Expr [Integer])
Either ParseError String -> IO (Either ParseError String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either ParseError String
forall a b. b -> Either a b
Right (Expr [Integer] -> String
fmtSimpleRational (([Integer] -> [Integer]) -> Expr [Integer] -> Expr [Integer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> [Integer] -> [Integer]
forall a. Num a => Int -> [a] -> [a]
summarizeRollsOver 3) Expr [Integer]
ex)))
summarizeRollsOver :: Num a => Int -> [a] -> [a]
summarizeRollsOver :: Int -> [a] -> [a]
summarizeRollsOver n :: Int
n xs :: [a]
xs
| [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
n [a]
xs) = [a]
xs
| Bool
otherwise = [[a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [a]
xs]
roll :: (Integral a) => a -> a -> RVar [a]
roll :: a -> a -> RVar [a]
roll count :: a
count sides :: a
sides
| a
count a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> 100 = do
Double
x <- RVar Double
forall a. Distribution Normal a => RVar a
stdNormal :: RVar Double
let e :: a
e = a
counta -> a -> a
forall a. Num a => a -> a -> a
*(a
sidesa -> a -> a
forall a. Num a => a -> a -> a
+1)a -> a -> a
forall a. Integral a => a -> a -> a
`div`2
e' :: Double
e' = a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
counta -> a -> a
forall a. Num a => a -> a -> a
*(a
sidesa -> a -> a
forall a. Num a => a -> a -> a
+1)a -> a -> a
forall a. Integral a => a -> a -> a
`mod`2)Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/2
v :: Double
v = a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
sidesa -> a -> a
forall a. Num a => a -> a -> a
*a
sidesa -> a -> a
forall a. Num a => a -> a -> a
-1)Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/12
x' :: Double
x' = Double
e' Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sqrt (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
count Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
v)
[a] -> RVar [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a
e a -> a -> a
forall a. Num a => a -> a -> a
+ Double -> a
forall a b. (RealFrac a, Integral b) => a -> b
round Double
x']
| Bool
otherwise = do
[a]
ls <- Int -> RVarT Identity a -> RVar [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
count) (a -> a -> RVarT Identity a
forall a (m :: * -> *). Integral a => a -> a -> RVarT m a
integralUniform 1 a
sides)
[a] -> RVar [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
ls
parseExpr :: (Integral a) => String -> String -> Either ParseError (Expr (RVar [a]))
parseExpr :: String -> String -> Either ParseError (Expr (RVar [a]))
parseExpr src :: String
src str :: String
str = GenParser Char Bool (Expr (RVar [a]))
-> Bool -> String -> String -> Either ParseError (Expr (RVar [a]))
forall tok st a.
GenParser tok st a -> st -> String -> [tok] -> Either ParseError a
runParser GenParser Char Bool (Expr (RVar [a]))
forall a. Integral a => CharParser Bool (Expr (RVar [a]))
expr Bool
False String
src String
str
diceLang :: TokenParser st
diceLang :: TokenParser st
diceLang = GenLanguageDef String st Identity -> TokenParser st
forall s (m :: * -> *) u.
Stream s m Char =>
GenLanguageDef s u m -> GenTokenParser s u m
makeTokenParser
(GenLanguageDef String st Identity
forall st. LanguageDef st
haskellStyle { reservedOpNames :: [String]
reservedOpNames = ["*","/","+","-"] })
expr :: (Integral a) => CharParser Bool (Expr (RVar [a]))
expr :: CharParser Bool (Expr (RVar [a]))
expr = do
GenTokenParser String Bool Identity
-> ParsecT String Bool Identity ()
forall s u (m :: * -> *). GenTokenParser s u m -> ParsecT s u m ()
whiteSpace GenTokenParser String Bool Identity
forall st. TokenParser st
diceLang
Expr (RVar [a])
e <- CharParser Bool (Expr (RVar [a]))
forall a. Integral a => CharParser Bool (Expr (RVar [a]))
term
ParsecT String Bool Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
Bool
hasRolls <- ParsecT String Bool Identity Bool
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
if Bool
hasRolls
then Expr (RVar [a]) -> CharParser Bool (Expr (RVar [a]))
forall (m :: * -> *) a. Monad m => a -> m a
return Expr (RVar [a])
e
else String -> CharParser Bool (Expr (RVar [a]))
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "no rolls in expression"
term :: (Integral a) => CharParser Bool (Expr (RVar [a]))
term :: CharParser Bool (Expr (RVar [a]))
term = OperatorTable Char Bool (Expr (RVar [a]))
-> CharParser Bool (Expr (RVar [a]))
-> CharParser Bool (Expr (RVar [a]))
forall tok st a.
OperatorTable tok st a -> GenParser tok st a -> GenParser tok st a
buildExpressionParser OperatorTable Char Bool (Expr (RVar [a]))
forall st a. [[Operator Char st (Expr a)]]
table CharParser Bool (Expr (RVar [a]))
forall a. Integral a => CharParser Bool (Expr (RVar [a]))
primExp
where table :: [[Operator Char st (Expr a)]]
table =
[ [String
-> (Expr a -> Expr a -> Expr a)
-> Assoc
-> Operator Char st (Expr a)
forall a st. String -> (a -> a -> a) -> Assoc -> Operator Char st a
binary "*" Expr a -> Expr a -> Expr a
forall a. Expr a -> Expr a -> Expr a
Times Assoc
AssocLeft, String
-> (Expr a -> Expr a -> Expr a)
-> Assoc
-> Operator Char st (Expr a)
forall a st. String -> (a -> a -> a) -> Assoc -> Operator Char st a
binary "/" Expr a -> Expr a -> Expr a
forall a. Expr a -> Expr a -> Expr a
Divide Assoc
AssocLeft ]
, [String
-> (Expr a -> Expr a -> Expr a)
-> Assoc
-> Operator Char st (Expr a)
forall a st. String -> (a -> a -> a) -> Assoc -> Operator Char st a
binary "+" Expr a -> Expr a -> Expr a
forall a. Expr a -> Expr a -> Expr a
Plus Assoc
AssocLeft, String
-> (Expr a -> Expr a -> Expr a)
-> Assoc
-> Operator Char st (Expr a)
forall a st. String -> (a -> a -> a) -> Assoc -> Operator Char st a
binary "-" Expr a -> Expr a -> Expr a
forall a. Expr a -> Expr a -> Expr a
Minus Assoc
AssocLeft ]
]
binary :: String -> (a -> a -> a) -> Assoc -> Operator Char st a
binary name :: String
name fun :: a -> a -> a
fun assoc :: Assoc
assoc = GenParser Char st (a -> a -> a) -> Assoc -> Operator Char st a
forall tok st a.
GenParser tok st (a -> a -> a) -> Assoc -> Operator tok st a
Infix (do{ GenTokenParser String st Identity
-> String -> ParsecT String st Identity ()
forall s u (m :: * -> *).
GenTokenParser s u m -> String -> ParsecT s u m ()
reservedOp GenTokenParser String st Identity
forall st. TokenParser st
diceLang String
name; (a -> a -> a) -> GenParser Char st (a -> a -> a)
forall (m :: * -> *) a. Monad m => a -> m a
return a -> a -> a
fun }) Assoc
assoc
primExp :: (Integral a) => CharParser Bool (Expr (RVar [a]))
primExp :: CharParser Bool (Expr (RVar [a]))
primExp = CharParser Bool (Expr (RVar [a]))
-> CharParser Bool (Expr (RVar [a]))
forall tok st a. GenParser tok st a -> GenParser tok st a
try CharParser Bool (Expr (RVar [a]))
forall a. Integral a => CharParser Bool (Expr (RVar [a]))
dieExp CharParser Bool (Expr (RVar [a]))
-> CharParser Bool (Expr (RVar [a]))
-> CharParser Bool (Expr (RVar [a]))
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> CharParser Bool (Expr (RVar [a]))
forall a st. Num a => CharParser st (Expr (RVar [a]))
numExp CharParser Bool (Expr (RVar [a]))
-> CharParser Bool (Expr (RVar [a]))
-> CharParser Bool (Expr (RVar [a]))
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> GenTokenParser String Bool Identity
-> CharParser Bool (Expr (RVar [a]))
-> CharParser Bool (Expr (RVar [a]))
forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
parens GenTokenParser String Bool Identity
forall st. TokenParser st
diceLang CharParser Bool (Expr (RVar [a]))
forall a. Integral a => CharParser Bool (Expr (RVar [a]))
term
dieExp :: (Integral a) => CharParser Bool (Expr (RVar [a]))
dieExp :: CharParser Bool (Expr (RVar [a]))
dieExp = do
(cStr :: String
cStr, count :: Integer
count) <- (String, Integer)
-> ParsecT String Bool Identity (String, Integer)
-> ParsecT String Bool Identity (String, Integer)
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option ("", 1) ParsecT String Bool Identity (String, Integer)
forall st. CharParser st (String, Integer)
number
(sStr :: String
sStr, sides :: Integer
sides) <- Char -> ParsecT String Bool Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char 'd' ParsecT String Bool Identity Char
-> ParsecT String Bool Identity (String, Integer)
-> ParsecT String Bool Identity (String, Integer)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String Bool Identity (String, Integer)
forall st. CharParser st (String, Integer)
positiveNumber
Bool -> ParsecT String Bool Identity ()
forall (m :: * -> *) u s. Monad m => u -> ParsecT s u m ()
setState Bool
True
Expr (RVar [a]) -> CharParser Bool (Expr (RVar [a]))
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> RVar [a] -> Expr (RVar [a])
forall a. String -> a -> Expr a
Const (String
cStr String -> ShowS
forall a. [a] -> [a] -> [a]
++ 'd' Char -> ShowS
forall a. a -> [a] -> [a]
: String
sStr) (a -> a -> RVar [a]
forall a. Integral a => a -> a -> RVar [a]
roll (Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
count) (Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
sides)))
numExp :: Num a => CharParser st (Expr (RVar [a]))
numExp :: CharParser st (Expr (RVar [a]))
numExp = do
(str :: String
str, num :: Integer
num) <- CharParser st (String, Integer)
forall st. CharParser st (String, Integer)
number
Expr (RVar [a]) -> CharParser st (Expr (RVar [a]))
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> RVar [a] -> Expr (RVar [a])
forall a. String -> a -> Expr a
Const String
str ([a] -> RVar [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
num]))
number :: CharParser st (String, Integer)
number :: CharParser st (String, Integer)
number = do
String
n <- ParsecT String st Identity Char
-> ParsecT String st Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit ParsecT String st Identity String
-> String -> ParsecT String st Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> "number"
GenTokenParser String st Identity -> ParsecT String st Identity ()
forall s u (m :: * -> *). GenTokenParser s u m -> ParsecT s u m ()
whiteSpace GenTokenParser String st Identity
forall st. TokenParser st
diceLang
(String, Integer) -> CharParser st (String, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
n, String -> Integer
forall a. Read a => String -> a
read String
n)
positiveNumber :: CharParser st (String, Integer)
positiveNumber :: CharParser st (String, Integer)
positiveNumber = do
(s :: String
s,n :: Integer
n) <- CharParser st (String, Integer)
forall st. CharParser st (String, Integer)
number
Bool -> ParsecT String st Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
nInteger -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>0)
(String, Integer) -> CharParser st (String, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
s,Integer
n)