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