module Game.LambdaHack.Common.Dice
(
Dice, diceConst, diceLevel, diceScale, (|*|)
, d, z, dl, zl, intToDice
, maxDice, minDice, meanDice, reduceDice
, DiceXY(..), maxDiceXY, minDiceXY, meanDiceXY
#ifdef EXPOSE_INTERNAL
, SimpleDice
#endif
) where
import Control.Applicative
import Data.Binary
import qualified Data.Char as Char
import Data.Hashable (Hashable)
import qualified Data.IntMap.Strict as IM
import Data.Ratio
import Data.Text (Text)
import qualified Data.Text as T
import Data.Tuple
import GHC.Generics (Generic)
import Game.LambdaHack.Common.Frequency
import Game.LambdaHack.Common.Msg
type SimpleDice = Frequency Int
normalizeSimple :: SimpleDice -> SimpleDice
normalizeSimple fr = toFreq (nameFrequency fr)
$ map swap $ IM.toAscList $ IM.fromListWith (+)
$ map swap $ runFrequency fr
instance Num SimpleDice where
fr1 + fr2 = normalizeSimple $ liftA2AdditiveName "+" (+) fr1 fr2
fr1 * fr2 =
let frRes = normalizeSimple $ do
n <- fr1
sum $ replicate n fr2
nameRes =
case T.uncons $ nameFrequency fr2 of
_ | nameFrequency fr1 == "0" || nameFrequency fr2 == "0" -> "0"
Just ('d', _) | T.all Char.isDigit $ nameFrequency fr1 ->
nameFrequency fr1 <> nameFrequency fr2
_ -> nameFrequency fr1 <+> "*" <+> nameFrequency fr2
in renameFreq nameRes frRes
fr1 fr2 = normalizeSimple $ liftA2AdditiveName "-" () fr1 fr2
negate = liftAName "-" negate
abs = normalizeSimple . liftAName "abs" abs
signum = normalizeSimple . liftAName "signum" signum
fromInteger n = renameFreq (tshow n) $ pure $ fromInteger n
liftAName :: Text -> (Int -> Int) -> SimpleDice -> SimpleDice
liftAName name f fr =
let frRes = liftA f fr
nameRes = name <> " (" <> nameFrequency fr <> ")"
in renameFreq nameRes frRes
liftA2AdditiveName :: Text
-> (Int -> Int -> Int)
-> SimpleDice -> SimpleDice -> SimpleDice
liftA2AdditiveName name f fra frb =
let frRes = liftA2 f fra frb
nameRes =
if nameFrequency fra == "0" then nameFrequency frb
else if nameFrequency frb == "0" then nameFrequency fra
else nameFrequency fra <+> name <+> nameFrequency frb
in renameFreq nameRes frRes
dieSimple :: Int -> SimpleDice
dieSimple n = uniformFreq ("d" <> tshow n) [1..n]
zdieSimple :: Int -> SimpleDice
zdieSimple n = uniformFreq ("z" <> tshow n) [0..n1]
data Dice = Dice
{ diceConst :: SimpleDice
, diceLevel :: SimpleDice
, diceScale :: Int
}
deriving (Read, Eq, Ord, Generic)
instance Show Dice where
show Dice{..} = T.unpack $
let scaled = "scaled(" <> nameFrequency diceLevel <> ")"
in (if nameFrequency diceLevel == "0" then nameFrequency diceConst
else if nameFrequency diceConst == "0" then scaled
else nameFrequency diceConst <+> "+" <+> scaled)
<+> if diceScale == 1 then "" else "|*|" <+> tshow diceScale
instance Hashable Dice
instance Binary Dice
instance Num Dice where
(Dice dc1 dl1 ds1) + (Dice dc2 dl2 ds2) =
Dice (scaleFreq ds1 dc1 + scaleFreq ds2 dc2)
(scaleFreq ds1 dl1 + scaleFreq ds2 dl2)
1
(Dice dc1 dl1 ds1) * (Dice dc2 dl2 ds2) =
Dice (scaleFreq ds1 dc1 * scaleFreq ds2 dc2)
(scaleFreq ds1 dc1 * scaleFreq ds2 dl2
+ scaleFreq ds1 dl1 * scaleFreq ds2 dc2)
1
(Dice dc1 dl1 ds1) (Dice dc2 dl2 ds2) =
Dice (scaleFreq ds1 dc1 scaleFreq ds2 dc2)
(scaleFreq ds1 dl1 scaleFreq ds2 dl2)
1
negate = affectBothDice negate
abs = affectBothDice abs
signum = affectBothDice signum
fromInteger n = Dice (fromInteger n) (fromInteger 0) 1
affectBothDice :: (SimpleDice -> SimpleDice) -> Dice -> Dice
affectBothDice f (Dice dc1 dl1 ds1) = Dice (f dc1) (f dl1) ds1
d :: Int -> Dice
d n = Dice (dieSimple n) (fromInteger 0) 1
z :: Int -> Dice
z n = Dice (zdieSimple n) (fromInteger 0) 1
dl :: Int -> Dice
dl n = Dice (fromInteger 0) (dieSimple n) 1
zl :: Int -> Dice
zl n = Dice (fromInteger 0) (zdieSimple n) 1
intToDice :: Int -> Dice
intToDice = fromInteger . fromIntegral
(|*|) :: Dice -> Int -> Dice
Dice dc1 dl1 ds1 |*| s2 = Dice dc1 dl1 (ds1 * s2)
maxDice :: Dice -> Int
maxDice Dice{..} = (maxFreq diceConst + maxFreq diceLevel) * diceScale
minDice :: Dice -> Int
minDice Dice{..} = minFreq diceConst * diceScale
meanDice :: Dice -> Rational
meanDice Dice{..} = meanFreq diceConst * fromIntegral diceScale
+ meanFreq diceLevel * fromIntegral diceScale * (1%2)
reduceDice :: Dice -> Maybe Int
reduceDice de = if minDice de == maxDice de then Just (minDice de) else Nothing
data DiceXY = DiceXY !Dice !Dice
deriving (Show, Eq, Ord, 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 -> (Rational, Rational)
meanDiceXY (DiceXY x y) = (meanDice x, meanDice y)