{-# 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

----------------------------------------------------------------
-- 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
[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
--        fold (Repeat n y) = undefined # fold 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)

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

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
-- runExpr (Repeat x y) = commute Repeat x y

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

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

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

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)))
--        return (Right (fmtIntegralListExpr 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

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

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

-- a token-lexer thing
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 "#" Repeat AssocRight]
                ]
            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)