{-# 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
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 -> [Char]
(Int -> Expr a -> ShowS)
-> (Expr a -> [Char]) -> ([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 -> [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 = ([Char] -> 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}.
([Char] -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> Expr t
-> t
foldExpr (\[Char]
s a
x -> [Char] -> b -> Expr b
forall a. [Char] -> a -> Expr a
Const [Char]
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 :: ([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
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
(/) = ([Char] -> 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}.
([Char] -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> (t -> t -> t)
-> Expr t
-> t
foldExpr ((a -> m a) -> [Char] -> 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 m a
x 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)
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 = (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, MonadError [Char] m, Fractional a) =>
a -> a -> m a
divM
where
divM :: a -> a -> m a
divM a
x a
0 = [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [Char]
"Divide by zero!"
divM a
x 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)
evalIntegralExpr :: (Integral a, MonadError String m) => Expr a -> m a
evalIntegralExpr :: forall a (m :: * -> *).
(Integral a, MonadError [Char] m) =>
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 :: * -> *}.
(MonadError [Char] m, Integral a) =>
a -> a -> m a
divM
where
divM :: a -> a -> m a
divM a
x a
0 = [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [Char]
"Divide by zero!"
divM a
x 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 Expr a -> Expr a -> b
con Expr (m a)
x 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 :: forall (m :: * -> *) a. Monad m => Expr (m a) -> m (Expr a)
runExpr (Const [Char]
s 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
. [Char] -> a -> Expr a
forall a. [Char] -> a -> Expr a
Const [Char]
s
runExpr (Plus Expr (m a)
x 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 Expr (m a)
x 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 Expr (m a)
x 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 Expr (m a)
x 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 :: forall a. (Show a, Integral a) => Expr a -> [Char]
fmtIntegralExpr (Const [Char]
_ a
e) = a -> [Char]
forall a. Show a => a -> [Char]
show a
e
fmtIntegralExpr Expr a
e =
Bool -> ShowS -> ShowS
showParen Bool
True (([Char] -> a -> Int -> ShowS) -> Expr a -> Int -> ShowS
forall a. ([Char] -> a -> Int -> ShowS) -> Expr a -> Int -> ShowS
fmtExprPrec [Char] -> a -> Int -> ShowS
forall {a} {p}. Show a => [Char] -> a -> p -> ShowS
showScalarConst Expr a
e Int
0)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" => "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT [Char] Identity a -> ShowS
forall a. Show a => ExceptT [Char] Identity a -> ShowS
showError (Expr a -> ExceptT [Char] Identity a
forall a (m :: * -> *).
(Integral a, MonadError [Char] m) =>
Expr a -> m a
evalIntegralExpr Expr a
e)
ShowS -> ShowS
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]) = a -> [Char]
forall a. Show a => a -> [Char]
show a
e
fmtIntegralListExpr Expr [a]
e =
Bool -> ShowS -> ShowS
showParen Bool
True (([Char] -> [a] -> Int -> ShowS) -> Expr [a] -> Int -> ShowS
forall a. ([Char] -> a -> Int -> ShowS) -> Expr a -> Int -> ShowS
fmtExprPrec [Char] -> [a] -> Int -> ShowS
forall {a} {p}. Show a => [Char] -> a -> p -> ShowS
showListConst Expr [a]
e Int
0)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" => "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT [Char] Identity a -> ShowS
forall a. Show a => ExceptT [Char] Identity a -> ShowS
showError (Expr a -> ExceptT [Char] Identity a
forall a (m :: * -> *).
(Integral a, MonadError [Char] 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
$ [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]) = a -> [Char]
forall a. Show a => a -> [Char]
show a
e
fmtSimple Expr [a]
e =
Bool -> ShowS -> ShowS
showParen Bool
False (([Char] -> [a] -> Int -> ShowS) -> Expr [a] -> Int -> ShowS
forall a. ([Char] -> a -> Int -> ShowS) -> Expr a -> Int -> ShowS
fmtExprPrec [Char] -> [a] -> Int -> ShowS
forall a. Show a => [Char] -> [a] -> Int -> ShowS
showSimpleListConst Expr [a]
e Int
0)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" => "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT [Char] Identity a -> ShowS
forall a. Show a => ExceptT [Char] Identity a -> ShowS
showError (Expr a -> ExceptT [Char] Identity a
forall a (m :: * -> *).
(Integral a, MonadError [Char] 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
$ [Char]
""
fmtSimpleRational :: Expr [Integer] -> String
fmtSimpleRational :: Expr [Integer] -> [Char]
fmtSimpleRational (Const [Char]
_ []) = [Char]
"0"
fmtSimpleRational (Const [Char]
_ [Integer
e]) = Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
e
fmtSimpleRational Expr [Integer]
e =
Bool -> ShowS -> ShowS
showParen Bool
False (([Char] -> [Integer] -> Int -> ShowS)
-> Expr [Integer] -> Int -> ShowS
forall a. ([Char] -> a -> Int -> ShowS) -> Expr a -> Int -> ShowS
fmtExprPrec [Char] -> [Integer] -> Int -> ShowS
forall a. Show a => [Char] -> [a] -> Int -> ShowS
showSimpleListConst Expr [Integer]
e Int
0)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" => "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ratio Integer -> ShowS)
-> ExceptT [Char] Identity (Ratio Integer) -> ShowS
forall {t}. (t -> ShowS) -> ExceptT [Char] Identity t -> ShowS
showErrorWith Ratio Integer -> ShowS
showRationalWithDouble (Expr (Ratio Integer) -> ExceptT [Char] Identity (Ratio Integer)
forall a (m :: * -> *).
(Eq a, Fractional a, MonadError [Char] 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
$ [Char]
""
showScalarConst :: [Char] -> a -> p -> ShowS
showScalarConst [Char]
d a
v p
p = [Char] -> ShowS
showString [Char]
d ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
"[" 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
. [Char] -> ShowS
showString [Char]
"]"
showListConst :: [Char] -> a -> p -> ShowS
showListConst [Char]
d a
v p
p = [Char] -> ShowS
showString [Char]
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 -> 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 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
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 Char
'+') ((a -> ShowS) -> [a] -> [ShowS]
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 = (Int -> a -> ShowS) -> [Char] -> [a] -> Int -> ShowS
forall {a} {a} {p}.
(Ord a, Num a) =>
(a -> a -> ShowS) -> p -> [a] -> 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} {a} {p}.
(Ord a, Num a) =>
(a -> a -> ShowS) -> p -> [a] -> 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 => ExceptT String Identity a -> ShowS
showError :: forall a. Show a => ExceptT [Char] Identity a -> ShowS
showError = (a -> ShowS) -> ExceptT [Char] Identity a -> ShowS
forall {t}. (t -> ShowS) -> ExceptT [Char] Identity t -> ShowS
showErrorWith a -> ShowS
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 ([Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%.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
==Char
'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 a
p 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
== a
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
> a
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 Char
'/'
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 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 Integer
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 Integer
0 Ratio Integer
d
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" => "
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
== 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 = ([Char] -> 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}.
([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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
6) (Int -> ShowS
x Int
6 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" + " ShowS -> ShowS -> ShowS
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
6) (Int -> ShowS
x Int
6 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" - " ShowS -> ShowS -> ShowS
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
7) (Int -> ShowS
x Int
7 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" * " ShowS -> ShowS -> ShowS
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
7) (Int -> ShowS
x Int
7 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
" / " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
y Int
8))
Expr a
e
rollEm :: String -> IO (Either ParseError String)
rollEm :: [Char] -> IO (Either ParseError [Char])
rollEm [Char]
str = case [Char] -> [Char] -> Either ParseError (Expr (RVar [Integer]))
forall a.
(Integral a, UniformRange a) =>
[Char] -> [Char] -> Either ParseError (Expr (RVar [a]))
parseExpr [Char]
"rollEm" [Char]
str of
Left ParseError
err -> Either ParseError [Char] -> IO (Either ParseError [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseError -> Either ParseError [Char]
forall a b. a -> Either a b
Left ParseError
err)
Right Expr (RVar [Integer])
ex -> do
Expr [Integer]
ex <- do
IOGenM StdGen
g <- StdGen -> IO (IOGenM StdGen)
forall (m :: * -> *) g. MonadIO m => g -> m (IOGenM g)
newIOGenM (StdGen -> IO (IOGenM StdGen)) -> IO StdGen -> IO (IOGenM StdGen)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
IOGenM StdGen
-> RVarT Identity (Expr [Integer]) -> IO (Expr [Integer])
forall (d :: * -> *) (m :: * -> *) t g.
(Sampleable d m t, StatefulGen g m) =>
g -> d t -> m t
sampleFrom IOGenM StdGen
g (Expr (RVar [Integer]) -> RVarT Identity (Expr [Integer])
forall (m :: * -> *) a. Monad m => Expr (m a) -> m (Expr a)
runExpr Expr (RVar [Integer])
ex)
Either ParseError [Char] -> IO (Either ParseError [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Either ParseError [Char]
forall a b. b -> Either a b
Right (Expr [Integer] -> [Char]
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 Int
3) Expr [Integer]
ex)))
summarizeRollsOver :: Num a => Int -> [a] -> [a]
summarizeRollsOver :: forall a. Num a => Int -> [a] -> [a]
summarizeRollsOver Int
n [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, UniformRange a) => a -> a -> RVar [a]
roll :: forall a. (Integral a, UniformRange a) => a -> a -> RVar [a]
roll a
count a
sides
| a
count a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
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
+a
1)a -> a -> a
forall a. Integral a => a -> a -> a
`div`a
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
+a
1)a -> a -> a
forall a. Integral a => a -> a -> a
`mod`a
2)Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
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
-a
1)Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
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 :: * -> *). UniformRange a => a -> a -> RVarT m a
integralUniform a
1 a
sides)
[a] -> RVar [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
ls
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 = GenParser Char Bool (Expr (RVar [a]))
-> Bool -> [Char] -> [Char] -> Either ParseError (Expr (RVar [a]))
forall tok st a.
GenParser tok st a -> st -> [Char] -> [tok] -> Either ParseError a
runParser GenParser Char Bool (Expr (RVar [a]))
forall a.
(Integral a, UniformRange a) =>
CharParser Bool (Expr (RVar [a]))
expr Bool
False [Char]
src [Char]
str
diceLang :: TokenParser st
diceLang :: forall st. TokenParser st
diceLang = GenLanguageDef [Char] st Identity
-> GenTokenParser [Char] st Identity
forall s (m :: * -> *) u.
Stream s m Char =>
GenLanguageDef s u m -> GenTokenParser s u m
makeTokenParser
(GenLanguageDef [Char] st Identity
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
GenTokenParser [Char] Bool Identity
-> ParsecT [Char] Bool Identity ()
forall s u (m :: * -> *). GenTokenParser s u m -> ParsecT s u m ()
whiteSpace GenTokenParser [Char] Bool Identity
forall st. TokenParser st
diceLang
Expr (RVar [a])
e <- CharParser Bool (Expr (RVar [a]))
forall a.
(Integral a, UniformRange a) =>
CharParser Bool (Expr (RVar [a]))
term
ParsecT [Char] Bool Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
Bool
hasRolls <- ParsecT [Char] 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 [Char] -> CharParser Bool (Expr (RVar [a]))
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 = OperatorTable Char Bool (Expr (RVar [a]))
-> GenParser Char Bool (Expr (RVar [a]))
-> GenParser Char 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 GenParser Char Bool (Expr (RVar [a]))
forall a.
(Integral a, UniformRange a) =>
CharParser Bool (Expr (RVar [a]))
primExp
where table :: [[Operator Char st (Expr a)]]
table =
[ [[Char]
-> (Expr a -> Expr a -> Expr a)
-> Assoc
-> Operator Char st (Expr a)
forall {a} {st}.
[Char] -> (a -> a -> a) -> Assoc -> Operator Char st a
binary [Char]
"*" Expr a -> Expr a -> Expr a
forall a. Expr a -> Expr a -> Expr a
Times Assoc
AssocLeft, [Char]
-> (Expr a -> Expr a -> Expr a)
-> Assoc
-> Operator Char st (Expr a)
forall {a} {st}.
[Char] -> (a -> a -> a) -> Assoc -> Operator Char st a
binary [Char]
"/" Expr a -> Expr a -> Expr a
forall a. Expr a -> Expr a -> Expr a
Divide Assoc
AssocLeft ]
, [[Char]
-> (Expr a -> Expr a -> Expr a)
-> Assoc
-> Operator Char st (Expr a)
forall {a} {st}.
[Char] -> (a -> a -> a) -> Assoc -> Operator Char st a
binary [Char]
"+" Expr a -> Expr a -> Expr a
forall a. Expr a -> Expr a -> Expr a
Plus Assoc
AssocLeft, [Char]
-> (Expr a -> Expr a -> Expr a)
-> Assoc
-> Operator Char st (Expr a)
forall {a} {st}.
[Char] -> (a -> a -> a) -> Assoc -> Operator Char st a
binary [Char]
"-" Expr a -> Expr a -> Expr a
forall a. Expr a -> Expr a -> Expr a
Minus Assoc
AssocLeft ]
]
binary :: [Char] -> (a -> a -> a) -> Assoc -> Operator Char st a
binary [Char]
name a -> a -> a
fun 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 [Char] st Identity
-> [Char] -> ParsecT [Char] st Identity ()
forall s u (m :: * -> *).
GenTokenParser s u m -> [Char] -> ParsecT s u m ()
reservedOp GenTokenParser [Char] st Identity
forall st. TokenParser st
diceLang [Char]
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, UniformRange a) => CharParser Bool (Expr (RVar [a]))
primExp :: forall a.
(Integral a, UniformRange a) =>
CharParser Bool (Expr (RVar [a]))
primExp = GenParser Char Bool (Expr (RVar [a]))
-> GenParser Char Bool (Expr (RVar [a]))
forall tok st a. GenParser tok st a -> GenParser tok st a
try GenParser Char Bool (Expr (RVar [a]))
forall a.
(Integral a, UniformRange a) =>
CharParser Bool (Expr (RVar [a]))
dieExp GenParser Char Bool (Expr (RVar [a]))
-> GenParser Char Bool (Expr (RVar [a]))
-> GenParser Char Bool (Expr (RVar [a]))
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> GenParser Char Bool (Expr (RVar [a]))
forall a st. Num a => CharParser st (Expr (RVar [a]))
numExp GenParser Char Bool (Expr (RVar [a]))
-> GenParser Char Bool (Expr (RVar [a]))
-> GenParser Char 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 [Char] Bool Identity
-> forall a.
ParsecT [Char] Bool Identity a -> ParsecT [Char] Bool Identity a
forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
parens GenTokenParser [Char] Bool Identity
forall st. TokenParser st
diceLang GenParser Char Bool (Expr (RVar [a]))
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) <- ([Char], Integer)
-> ParsecT [Char] Bool Identity ([Char], Integer)
-> ParsecT [Char] Bool Identity ([Char], Integer)
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) ParsecT [Char] Bool Identity ([Char], Integer)
forall st. CharParser st ([Char], Integer)
number
([Char]
sStr, Integer
sides) <- Char -> ParsecT [Char] Bool Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'd' ParsecT [Char] Bool Identity Char
-> ParsecT [Char] Bool Identity ([Char], Integer)
-> ParsecT [Char] Bool Identity ([Char], Integer)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT [Char] Bool Identity ([Char], Integer)
forall st. CharParser st ([Char], Integer)
positiveNumber
Bool -> ParsecT [Char] 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 ([Char] -> RVar [a] -> Expr (RVar [a])
forall a. [Char] -> a -> Expr a
Const ([Char]
cStr [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'd' Char -> ShowS
forall a. a -> [a] -> [a]
: [Char]
sStr) (a -> a -> RVar [a]
forall a. (Integral a, UniformRange 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 :: forall a st. Num a => CharParser st (Expr (RVar [a]))
numExp = do
([Char]
str, Integer
num) <- CharParser st ([Char], Integer)
forall st. CharParser st ([Char], Integer)
number
Expr (RVar [a]) -> CharParser st (Expr (RVar [a]))
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> RVar [a] -> Expr (RVar [a])
forall a. [Char] -> a -> Expr a
Const [Char]
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 :: forall st. CharParser st ([Char], Integer)
number = do
[Char]
n <- ParsecT [Char] st Identity Char
-> ParsecT [Char] st Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT [Char] st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit ParsecT [Char] st Identity [Char]
-> [Char] -> ParsecT [Char] st Identity [Char]
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"number"
GenTokenParser [Char] st Identity -> ParsecT [Char] st Identity ()
forall s u (m :: * -> *). GenTokenParser s u m -> ParsecT s u m ()
whiteSpace GenTokenParser [Char] st Identity
forall st. TokenParser st
diceLang
([Char], Integer) -> CharParser st ([Char], Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
n, [Char] -> Integer
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) <- CharParser st ([Char], Integer)
forall st. CharParser st ([Char], Integer)
number
Bool -> ParsecT [Char] st Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
nInteger -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>Integer
0)
([Char], Integer) -> CharParser st ([Char], Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
s,Integer
n)