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

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

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

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

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

data Expr a
    = Const   String   a
    | Plus   (Expr a) (Expr a)
    | Minus  (Expr a) (Expr a)
    | Times  (Expr a) (Expr a)
    | Divide (Expr a) (Expr a)
--    Repeat :: Expr Int -> Expr a -> Expr [a]
    deriving Int -> Expr a -> ShowS
[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
$cshowsPrec :: forall a. Show a => Int -> Expr a -> ShowS
showsPrec :: Int -> Expr a -> ShowS
$cshow :: forall a. Show a => Expr a -> [Char]
show :: Expr a -> [Char]
$cshowList :: forall a. Show a => [Expr a] -> ShowS
showList :: [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
--        fold (Repeat n y) = undefined # fold y

evalExprWithDiv :: (Num a, Monad m) => (a -> a -> m a) -> Expr a -> m a
evalExprWithDiv :: forall a (m :: * -> *).
(Num a, Monad m) =>
(a -> a -> m a) -> Expr a -> m a
evalExprWithDiv a -> a -> m a
(/) = ([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 a. 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 a. [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 a. 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 a. [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 a. 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 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 a. a -> m a
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Expr a -> m (Expr a)
forall a. a -> m 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
-- runExpr (Repeat x y) = commute Repeat x y

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

fmtIntegralExpr :: (Show a, Integral a) => Expr a -> String
fmtIntegralExpr :: forall a. (Show a, Integral a) => Expr a -> [Char]
fmtIntegralExpr (Const [Char]
_ a
e) = 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 a b. (a -> b) -> Expr a -> Expr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> a
forall a. Num a => [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 a b. (a -> b) -> Expr a -> Expr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> a
forall a. Num a => [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 a b. (a -> b) -> Expr a -> Expr b
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 a. Num a => [a] -> a
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 a. (a -> a -> a) -> [a] -> a
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

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

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 a. a -> IO a
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 g.
StatefulGen g IO =>
g -> 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 a. a -> IO a
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 a b. (a -> b) -> Expr a -> Expr b
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)))
--        return (Right (fmtIntegralListExpr ex))

summarizeRollsOver :: Num a => Int -> [a] -> [a]
summarizeRollsOver :: forall a. Num a => Int -> [a] -> [a]
summarizeRollsOver Int
n [a]
xs
    | [a] -> Bool
forall a. [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 a. Num a => [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 a. a -> RVarT Identity 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 b. Integral b => Double -> b
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 a. a -> RVarT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
ls

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

parseExpr :: (Integral a, UniformRange a) => String -> String -> Either ParseError (Expr (RVar [a]))
parseExpr :: forall a.
(Integral a, UniformRange a) =>
[Char] -> [Char] -> Either ParseError (Expr (RVar [a]))
parseExpr [Char]
src [Char]
str = 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

-- a token-lexer thing
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 a. a -> ParsecT [Char] Bool Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr (RVar [a])
e
        else [Char] -> CharParser Bool (Expr (RVar [a]))
forall a. [Char] -> ParsecT [Char] Bool Identity 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 "#" Repeat AssocRight]
                ]
            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 a. a -> ParsecT [Char] st Identity 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 a b.
ParsecT [Char] Bool Identity a
-> ParsecT [Char] Bool Identity b -> ParsecT [Char] Bool Identity b
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 a. a -> ParsecT [Char] Bool Identity 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 a. a -> ParsecT [Char] st Identity 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 a. a -> RVarT Identity 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 a. a -> ParsecT [Char] st Identity a
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 a. a -> ParsecT [Char] st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
s,Integer
n)