content: {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  -- | Representation of dice scaled with current level depth.
  module Game.LambdaHack.Core.Dice
    ( -- * Frequency distribution for casting dice scaled with level depth
      Dice, AbsDepth(..), castDice, d, dL, z, zL, intToDice, minDice, maxDice
    , infsupDice, supDice, infDice, meanDice, reduceDice
      -- * Dice for rolling a pair of integer parameters representing coordinates.
    , DiceXY(..), supDiceXY, infDiceXY
    ) where
  
  import Prelude ()
  
  import Game.LambdaHack.Core.Prelude
  
  import Data.Binary
  
  -- | Multiple dice rolls, some scaled with current level depth, in which case
  -- the sum of all rolls is scaled in proportion to current depth
  -- divided by maximal dungeon depth.
  --
  -- The simple dice should have positive number of rolls and number of sides.
  --
  -- The @Num@ instance doesn't have @abs@ nor @signum@ defined,
  -- because the functions for computing infimum, supremum and mean dice
  -- results would be too costly.
  data Dice =
      DiceI Int
    | DiceD Int Int
    | DiceDL Int Int
    | DiceZ Int Int
    | DiceZL Int Int
    | DicePlus Dice Dice
    | DiceTimes Dice Dice
    | DiceNegate Dice
    | DiceMin Dice Dice
    | DiceMax Dice Dice
    deriving Eq
  
  instance Show Dice where
    show = stripOuterParens . showDiceWithParens
  
  stripOuterParens :: String -> String
  stripOuterParens s@('(' : rest) = case uncons $ reverse rest of
    Just (')', middle) -> reverse middle
    _ -> s
  stripOuterParens s = s
  
  showDiceWithParens :: Dice -> String
  showDiceWithParens = sh
   where
    sh 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) -> wrapInParens $ sh d1 ++ "-" ++ sh d2
      DicePlus (DiceNegate d1) d2 -> wrapInParens $ "-" ++ sh d1 ++ "+" ++ sh d2
      DicePlus d1 (DicePlus d2 d3) -> sh $ DicePlus (DicePlus d1 d2) d3
      DicePlus (DicePlus d1 d2) d3 ->
        wrapInParens $ stripOuterParens (sh $ DicePlus d1 d2) ++ "+" ++ sh d3
      DicePlus d1 d2 -> wrapInParens $ sh d1 ++ "+" ++ sh d2
      DiceTimes d1 d2 -> wrapInParens $ sh d1 ++ "*" ++ sh d2
      DiceNegate d1 -> wrapInParens $ "-" ++ sh d1
      DiceMin d1 d2 -> wrapInParens $ "min" ++ sh d1 ++ sh d2
      DiceMax d1 d2 -> wrapInParens $ "max" ++ sh d1 ++ sh d2
  
  wrapInParens :: String -> String
  wrapInParens "" = ""
  wrapInParens t = "(" <> t <> ")"
  
  instance Num Dice where
    d1 + d2 = DicePlus d1 d2
    d1 * d2 = DiceTimes d1 d2
    d1 - d2 = d1 + DiceNegate d2
    negate = DiceNegate
    abs = undefined  -- very costly to compute mean exactly
    signum = undefined  -- very costly to compute mean exactly
    fromInteger n = DiceI (fromInteger n)
  
  -- | Absolute depth in the dungeon. When used for the maximum depth
  -- of the whole dungeon, this can be different than dungeon size,
  -- e.g., when the dungeon is branched, and it can even be different
  -- than the length of the longest branch, if levels at some depths are missing.
  newtype AbsDepth = AbsDepth Int
    deriving (Show, Eq, Ord, Binary)
  
  -- | Cast dice scaled with current level depth. When scaling, we round up,
  -- so that the value of @1 `dL` 1@ is @1@ even at the lowest level,
  -- but so is the value of @1 `dL` depth@.
  --
  -- The implementation calls RNG as many times as there are dice rolls,
  -- which is costly, so content should prefer to cast fewer dice
  -- and then multiply them by a constant. If rounded results are not desired
  -- (often they are, to limit the number of distinct item varieties
  -- in inventory), another dice may be added to the result.
  --
  -- A different possible implementation, with dice represented as @Frequency@,
  -- makes only one RNG call per dice, but due to lists lengths proportional
  -- to the maximal value of the dice, it's is intractable for 1000d1000
  -- and problematic already for 100d100.
  castDice :: forall m. Monad m
           => ((Int, Int) -> m Int)
           -> AbsDepth -> AbsDepth -> Dice -> m Int
  {-# INLINE castDice #-}
  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 = if start == k then return $! n * k else 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 1 lvlDepth) `divUp` max 1 maxDepth
        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
          DiceMin d1 d2 -> do
            k1 <- castD d1
            k2 <- castD d2
            return $! min k1 k2
          DiceMax d1 d2 -> do
            k1 <- castD d1
            k2 <- castD d2
            return $! max k1 k2
    castD dice
  
  -- | A die, rolled the given number of times. E.g., @1 `d` 2@ rolls 2-sided
  -- die one time.
  d :: Int -> Int -> Dice
  d n k = assert (n > 0 && k > 0 `blame` "die must be positive" `swith` (n, k))
          $ DiceD n k
  
  -- | A die rolled the given number of times,
  -- with the result scaled with dungeon level depth.
  dL :: Int -> Int -> Dice
  dL n k = assert (n > 0 && k > 0 `blame` "die must be positive" `swith` (n, k))
           $ DiceDL n k
  
  -- | A die, starting from zero, ending at one less than second argument,
  -- rolled the given number of times. E.g., @1 `z` 1@ always rolls zero.
  z :: Int -> Int -> Dice
  z n k = assert (n > 0 && k > 0 `blame` "die must be positive" `swith` (n, k))
          $ DiceZ n k
  
  -- | A die, starting from zero, ending at one less than second argument,
  -- rolled the given number of times,
  -- with the result scaled with dungeon level depth.
  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
  
  minDice :: Dice -> Dice -> Dice
  minDice = DiceMin
  
  maxDice :: Dice -> Dice -> Dice
  maxDice = DiceMax
  
  -- | Minimal and maximal possible value of the dice.
  --
  -- @divUp@ in the implementation corresponds to @ceiling@,
  -- applied to results of @meanDice@ elsewhere in the code,
  -- and prevents treating 1d1-power effects (on shallow levels) as null effects.
  infsupDice :: Dice -> (Int, Int)
  infsupDice dice1 = case dice1 of
    DiceI k -> (k, k)
    DiceD n k -> (n, n * k)
    DiceDL n k -> (1, n * k)  -- bottom and top level considered
    DiceZ n k -> (0, n * (k - 1))
    DiceZL n k -> (0, n * (k - 1))  -- bottom and top level considered
    DicePlus d1 d2 ->
      let (infD1, supD1) = infsupDice d1
          (infD2, supD2) = infsupDice d2
      in (infD1 + infD2, supD1 + supD2)
    DiceTimes (DiceI k) d2 ->
      let (infD2, supD2) = infsupDice d2
      in if k >= 0 then (k * infD2, k * supD2) else (k * supD2, k * infD2)
    DiceTimes d1 (DiceI k) ->
      let (infD1, supD1) = infsupDice d1
      in if k >= 0 then (infD1 * k, supD1 * k) else (supD1 * k, infD1 * k)
    -- Multiplication other than the two cases above is unlikely, but here it is.
    DiceTimes d1 d2 ->
      let (infD1, supD1) = infsupDice d1
          (infD2, supD2) = infsupDice d2
          options = [infD1 * infD2, infD1 * supD2, supD1 * supD2, supD1 * infD2]
      in (minimum options, maximum options)
    DiceNegate d1 ->
      let (infD1, supD1) = infsupDice d1
      in (negate supD1, negate infD1)
    DiceMin d1 d2 ->
      let (infD1, supD1) = infsupDice d1
          (infD2, supD2) = infsupDice d2
      in (min infD1 infD2, min supD1 supD2)
    DiceMax d1 d2 ->
      let (infD1, supD1) = infsupDice d1
          (infD2, supD2) = infsupDice d2
      in (max infD1 infD2, max supD1 supD2)
  
  -- | Maximal value of dice. The scaled part taken assuming median level.
  supDice :: Dice -> Int
  supDice = snd . infsupDice
  
  -- | Minimal value of dice. The scaled part taken assuming median level.
  infDice :: Dice -> Int
  infDice = fst . infsupDice
  
  -- | Mean value of dice. The scaled part taken assuming median level,
  -- but not taking into account rounding up, and so too low, especially
  -- for dice small compared to depth. To fix this, depth would need
  -- to be taken as argument.
  meanDice :: Dice -> Double
  meanDice dice1 = case dice1 of
    DiceI k -> intToDouble k
    DiceD n k -> intToDouble (n * (k + 1)) / 2
    DiceDL n k -> intToDouble (n * (k + 1)) / 4
    DiceZ n k -> intToDouble (n * k) / 2
    DiceZL n k -> intToDouble (n * k) / 4
    DicePlus d1 d2 -> meanDice d1 + meanDice d2
    DiceTimes d1 d2 -> meanDice d1 * meanDice d2  -- I hope this is that simple
    DiceNegate d1 -> negate $ meanDice d1
    DiceMin d1 d2 -> min (meanDice d1) (meanDice d2)
      -- crude approximation, only exact if the distributions disjoint
    DiceMax d1 d2 -> max (meanDice d1) (meanDice d2)  -- crude approximation
  
  reduceDice :: Dice -> Maybe Int
  reduceDice d1 =
    let (infD1, supD1) = infsupDice d1
    in if infD1 == supD1 then Just infD1 else Nothing
  
  -- | Dice for rolling a pair of integer parameters pertaining to,
  -- respectively, the X and Y cartesian 2D coordinates.
  data DiceXY = DiceXY Dice Dice
    deriving Show
  
  -- | Maximal value of DiceXY.
  supDiceXY :: DiceXY -> (Int, Int)
  supDiceXY (DiceXY x y) = (supDice x, supDice y)
  
  -- | Minimal value of DiceXY.
  infDiceXY :: DiceXY -> (Int, Int)
  infDiceXY (DiceXY x y) = (infDice x, infDice y)
  