{-# LANGUAGE DeriveGeneric, FlexibleInstances, TypeSynonymInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Game.LambdaHack.Common.Dice
(
Dice, castDice, d, dl, z, zl, intToDice
, minmaxDice, maxDice, minDice, meanDice, reduceDice
, DiceXY(..), maxDiceXY, minDiceXY, meanDiceXY
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import Control.DeepSeq
import Data.Binary
import Data.Hashable (Hashable)
import Game.LambdaHack.Common.Misc
import GHC.Generics (Generic)
data Dice =
DiceI Int
| DiceD Int Int
| DiceDL Int Int
| DiceZ Int Int
| DiceZL Int Int
| DicePlus Dice Dice
| DiceTimes Dice Dice
| DiceNegate Dice
deriving (Eq, Ord, Generic)
instance Show Dice where
show dice1 = case dice1 of
DiceI k -> show k
DiceD n k -> show n ++ "d" ++ show k
DiceDL n k -> show n ++ "dl" ++ show k
DiceZ n k -> show n ++ "z" ++ show k
DiceZL n k -> show n ++ "zl" ++ show k
DicePlus d1 (DiceNegate d2) | simpleDice d2 -> show d1 ++ "-" ++ show d2
DicePlus d1 (DiceNegate d2) -> show d1 ++ "-" ++ "(" ++ show d2 ++ ")"
DicePlus d1 d2 -> show d1 ++ "+" ++ show d2
DiceTimes d1 d2 -> "(" ++ show d1 ++ ") * (" ++ show d2 ++ ")"
DiceNegate (DiceI k) -> "-" ++ show k
DiceNegate d1 -> "- (" ++ show d1 ++ ")"
simpleDice :: Dice -> Bool
simpleDice DiceI{} = True
simpleDice DiceD{} = True
simpleDice DiceDL{} = True
simpleDice DiceZ{} = True
simpleDice DiceZL{} = True
simpleDice _ = False
instance Hashable Dice
instance Binary Dice
instance NFData Dice
instance Num Dice where
d1 + d2 = DicePlus d1 d2
d1 * d2 = DiceTimes d1 d2
d1 - d2 = d1 + DiceNegate d2
negate = DiceNegate
abs = undefined
signum = undefined
fromInteger n = DiceI (fromInteger n)
castDice :: forall m. Monad m
=> ((Int, Int) -> m Int)
-> AbsDepth -> AbsDepth -> Dice -> m Int
castDice randomR (AbsDepth lvlDepth) (AbsDepth maxDepth) dice = do
let !_A = assert (lvlDepth >= 0 && lvlDepth <= maxDepth
`blame` "invalid depth for dice rolls"
`swith` (lvlDepth, maxDepth)) ()
castNK n start k = do
let f !acc 0 = return acc
f acc count = do
r <- randomR (start, k)
f (acc + r) (count - 1)
f 0 n
scaleL k = (k * max 0 (lvlDepth - 1)) `div` max 1 (maxDepth - 1)
castD :: Dice -> m Int
castD dice1 = case dice1 of
DiceI k -> return k
DiceD n k -> castNK n 1 k
DiceDL n k -> scaleL <$> castNK n 1 k
DiceZ n k -> castNK n 0 (k - 1)
DiceZL n k -> scaleL <$> castNK n 0 (k - 1)
DicePlus d1 d2 -> do
k1 <- castD d1
k2 <- castD d2
return $! k1 + k2
DiceTimes d1 d2 -> do
k1 <- castD d1
k2 <- castD d2
return $! k1 * k2
DiceNegate d1 -> do
k <- castD d1
return $! negate k
castD dice
d :: Int -> Int -> Dice
d n k = assert (n > 0 && k > 0 `blame` "die must be positive" `swith` (n, k))
$ DiceD n k
dl :: Int -> Int -> Dice
dl n k = assert (n > 0 && k > 0 `blame` "die must be positive" `swith` (n, k))
$ DiceDL n k
z :: Int -> Int -> Dice
z n k = assert (n > 0 && k > 0 `blame` "die must be positive" `swith` (n, k))
$ DiceZ n k
zl :: Int -> Int -> Dice
zl n k = assert (n > 0 && k > 0 `blame` "die must be positive" `swith` (n, k))
$ DiceZL n k
intToDice :: Int -> Dice
intToDice = DiceI
minmaxDice :: Dice -> (Int, Int)
minmaxDice dice1 = case dice1 of
DiceI k -> (k, k)
DiceD n k -> (n, n * k)
DiceDL n k -> (0, n * k)
DiceZ n k -> (0, n * (k - 1))
DiceZL n k -> (0, n * (k - 1))
DicePlus d1 d2 ->
let (minD1, maxD1) = minmaxDice d1
(minD2, maxD2) = minmaxDice d2
in (minD1 + minD2, maxD1 + maxD2)
DiceTimes (DiceI k) d2 ->
let (minD2, maxD2) = minmaxDice d2
in if k >= 0 then (k * minD2, k * maxD2) else (k * maxD2, k * minD2)
DiceTimes d1 (DiceI k) ->
let (minD1, maxD1) = minmaxDice d1
in if k >= 0 then (minD1 * k, maxD1 * k) else (maxD1 * k, minD1 * k)
DiceTimes d1 d2 ->
let (minD1, maxD1) = minmaxDice d1
(minD2, maxD2) = minmaxDice d2
options = [minD1 * minD2, minD1 * maxD2, maxD1 * maxD2, maxD1 * minD2]
in (minimum options, maximum options)
DiceNegate d1 ->
let (minD1, maxD1) = minmaxDice d1
in (negate maxD1, negate minD1)
maxDice :: Dice -> Int
maxDice = snd . minmaxDice
minDice :: Dice -> Int
minDice = fst . minmaxDice
meanDice :: Dice -> Double
meanDice dice1 = case dice1 of
DiceI k -> fromIntegral k
DiceD n k -> fromIntegral (n * (k + 1)) / 2
DiceDL n k -> fromIntegral (n * (k + 1)) / 4
DiceZ n k -> fromIntegral (n * k) / 2
DiceZL n k -> fromIntegral (n * k) / 4
DicePlus d1 d2 -> meanDice d1 + meanDice d2
DiceTimes d1 d2 -> meanDice d1 * meanDice d2
DiceNegate d1 -> negate $ meanDice d1
reduceDice :: Dice -> Maybe Int
reduceDice d1 =
let (minD1, maxD1) = minmaxDice d1
in if minD1 == maxD1 then Just minD1 else Nothing
data DiceXY = DiceXY Dice Dice
deriving (Show, Generic)
instance Hashable DiceXY
instance Binary DiceXY
maxDiceXY :: DiceXY -> (Int, Int)
maxDiceXY (DiceXY x y) = (maxDice x, maxDice y)
minDiceXY :: DiceXY -> (Int, Int)
minDiceXY (DiceXY x y) = (minDice x, minDice y)
meanDiceXY :: DiceXY -> (Double, Double)
meanDiceXY (DiceXY x y) = (meanDice x, meanDice y)