{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}
-- | Creation of items on the server. Types and operations that don't involve
-- server state nor our custom monads.
module Game.LambdaHack.Server.ItemRev
  ( ItemKnown(..), ItemRev, UniqueSet, buildItem, newItemKind, newItem
    -- * Item discovery types
  , DiscoveryKindRev, emptyDiscoveryKindRev, serverDiscos
    -- * The @FlavourMap@ type
  , FlavourMap, emptyFlavourMap, dungeonFlavourMap
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import           Data.Binary
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import           Data.Hashable (Hashable)
import qualified Data.HashMap.Strict as HM
import           Data.Vector.Binary ()
import qualified Data.Vector.Unboxed as U
import           GHC.Generics (Generic)

import           Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.ItemAspect as IA
import           Game.LambdaHack.Common.Kind
import           Game.LambdaHack.Common.Time
import           Game.LambdaHack.Common.Types
import           Game.LambdaHack.Content.ItemKind (ItemKind)
import qualified Game.LambdaHack.Content.ItemKind as IK
import qualified Game.LambdaHack.Core.Dice as Dice
import           Game.LambdaHack.Core.Frequency
import           Game.LambdaHack.Core.Random
import qualified Game.LambdaHack.Definition.Ability as Ability
import qualified Game.LambdaHack.Definition.Color as Color
import           Game.LambdaHack.Definition.Defs
import           Game.LambdaHack.Definition.Flavour

-- | The essential item properties, used for the @ItemRev@ hash table
-- from items to their ids, needed to assign ids to newly generated items.
-- All the other meaningul properties can be derived from them.
-- Note: item seed instead of @AspectRecord@ is not enough,
-- becaused different seeds may result in the same @AspectRecord@
-- and we don't want such items to be distinct in UI and elsewhere.
data ItemKnown = ItemKnown ItemIdentity IA.AspectRecord (Maybe FactionId)
  deriving (Int -> ItemKnown -> ShowS
[ItemKnown] -> ShowS
ItemKnown -> String
(Int -> ItemKnown -> ShowS)
-> (ItemKnown -> String)
-> ([ItemKnown] -> ShowS)
-> Show ItemKnown
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ItemKnown] -> ShowS
$cshowList :: [ItemKnown] -> ShowS
show :: ItemKnown -> String
$cshow :: ItemKnown -> String
showsPrec :: Int -> ItemKnown -> ShowS
$cshowsPrec :: Int -> ItemKnown -> ShowS
Show, ItemKnown -> ItemKnown -> Bool
(ItemKnown -> ItemKnown -> Bool)
-> (ItemKnown -> ItemKnown -> Bool) -> Eq ItemKnown
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ItemKnown -> ItemKnown -> Bool
$c/= :: ItemKnown -> ItemKnown -> Bool
== :: ItemKnown -> ItemKnown -> Bool
$c== :: ItemKnown -> ItemKnown -> Bool
Eq, (forall x. ItemKnown -> Rep ItemKnown x)
-> (forall x. Rep ItemKnown x -> ItemKnown) -> Generic ItemKnown
forall x. Rep ItemKnown x -> ItemKnown
forall x. ItemKnown -> Rep ItemKnown x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ItemKnown x -> ItemKnown
$cfrom :: forall x. ItemKnown -> Rep ItemKnown x
Generic)

instance Binary ItemKnown

instance Hashable ItemKnown

-- | Reverse item map, for item creation, to keep items and item identifiers
-- in bijection.
type ItemRev = HM.HashMap ItemKnown ItemId

type UniqueSet = ES.EnumSet (ContentId ItemKind)

-- | Build an item with the given kind and aspects.
buildItem :: COps -> IA.AspectRecord -> FlavourMap
          -> DiscoveryKindRev -> ContentId ItemKind
          -> Item
buildItem :: COps
-> AspectRecord
-> FlavourMap
-> DiscoveryKindRev
-> ContentId ItemKind
-> Item
buildItem COps{ContentData ItemKind
coitem :: COps -> ContentData ItemKind
coitem :: ContentData ItemKind
coitem} arItem :: AspectRecord
arItem (FlavourMap flavourMap :: Vector Word16
flavourMap)
          (DiscoveryKindRev discoRev :: Vector Word16
discoRev) ikChosen :: ContentId ItemKind
ikChosen =
  let jkind :: ItemIdentity
jkind = case AspectRecord -> Maybe (GroupName ItemKind)
IA.aHideAs AspectRecord
arItem of
        Just grp :: GroupName ItemKind
grp ->
          let kindHidden :: ContentId ItemKind
kindHidden = ContentData ItemKind -> GroupName ItemKind -> ContentId ItemKind
forall a. Show a => ContentData a -> GroupName a -> ContentId a
ouniqGroup ContentData ItemKind
coitem GroupName ItemKind
grp
          in ItemKindIx -> ContentId ItemKind -> ItemIdentity
IdentityCovered
               (Int -> ItemKindIx
forall a. Enum a => Int -> a
toEnum (Int -> ItemKindIx) -> Int -> ItemKindIx
forall a b. (a -> b) -> a -> b
$ Word16 -> Int
forall a. Enum a => a -> Int
fromEnum (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ Vector Word16
discoRev Vector Word16 -> Int -> Word16
forall a. Unbox a => Vector a -> Int -> a
U.! ContentId ItemKind -> Int
forall k. ContentId k -> Int
contentIdIndex ContentId ItemKind
ikChosen)
               ContentId ItemKind
kindHidden
        Nothing -> ContentId ItemKind -> ItemIdentity
IdentityObvious ContentId ItemKind
ikChosen
      jfid :: Maybe a
jfid     = Maybe a
forall a. Maybe a
Nothing  -- the default
      jflavour :: Flavour
jflavour = Int -> Flavour
forall a. Enum a => Int -> a
toEnum (Int -> Flavour) -> Int -> Flavour
forall a b. (a -> b) -> a -> b
$ Word16 -> Int
forall a. Enum a => a -> Int
fromEnum (Word16 -> Int) -> Word16 -> Int
forall a b. (a -> b) -> a -> b
$ Vector Word16
flavourMap Vector Word16 -> Int -> Word16
forall a. Unbox a => Vector a -> Int -> a
U.! ContentId ItemKind -> Int
forall k. ContentId k -> Int
contentIdIndex ContentId ItemKind
ikChosen
  in $WItem :: ItemIdentity -> Maybe FactionId -> Flavour -> Item
Item{..}

-- | Roll an item kind based on given @Freqs@ and kind rarities
newItemKind :: COps -> UniqueSet -> Freqs ItemKind
            -> Dice.AbsDepth -> Dice.AbsDepth -> Int
            -> Frequency (ContentId IK.ItemKind, ItemKind)
newItemKind :: COps
-> UniqueSet
-> Freqs ItemKind
-> AbsDepth
-> AbsDepth
-> Int
-> Frequency (ContentId ItemKind, ItemKind)
newItemKind COps{ContentData ItemKind
coitem :: ContentData ItemKind
coitem :: COps -> ContentData ItemKind
coitem, ItemSpeedup
coItemSpeedup :: COps -> ItemSpeedup
coItemSpeedup :: ItemSpeedup
coItemSpeedup} uniqueSet :: UniqueSet
uniqueSet itemFreq :: Freqs ItemKind
itemFreq
            (Dice.AbsDepth ldepth :: Int
ldepth) (Dice.AbsDepth totalDepth :: Int
totalDepth) lvlSpawned :: Int
lvlSpawned =
  -- Effective generation depth of actors (not items) increases with spawns.
  -- Up to 10 spawns, no effect. With 20 spawns, depth + 5, and then
  -- each 10 spawns adds 5 depth. Capped by @totalDepth@, to ensure variety.
  let numSpawnedCoeff :: Int
numSpawnedCoeff = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
lvlSpawned Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- 5
      -- The first 10 spawns are of the nominal level.
      ldSpawned :: Int
ldSpawned = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
totalDepth (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
ldepth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numSpawnedCoeff
      f :: Int
-> [(Int, (ContentId ItemKind, ItemKind))]
-> Int
-> ContentId ItemKind
-> ItemKind
-> [(Int, (ContentId ItemKind, ItemKind))]
f _ acc :: [(Int, (ContentId ItemKind, ItemKind))]
acc _ ik :: ContentId ItemKind
ik _ | ContentId ItemKind
ik ContentId ItemKind -> UniqueSet -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
`ES.member` UniqueSet
uniqueSet = [(Int, (ContentId ItemKind, ItemKind))]
acc
      f !Int
q ![(Int, (ContentId ItemKind, ItemKind))]
acc !Int
p !ContentId ItemKind
ik !ItemKind
kind =
        -- Don't consider lvlSpawned for uniques, except those that have
        -- @Unique@ under @Odds@.
        let ld :: Int
ld = if Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Unique
                    (AspectRecord -> Bool) -> AspectRecord -> Bool
forall a b. (a -> b) -> a -> b
$ KindMean -> AspectRecord
IA.kmMean (KindMean -> AspectRecord) -> KindMean -> AspectRecord
forall a b. (a -> b) -> a -> b
$ ContentId ItemKind -> ItemSpeedup -> KindMean
getKindMean ContentId ItemKind
ik ItemSpeedup
coItemSpeedup
                 then Int
ldepth
                 else Int
ldSpawned
            rarity :: Int
rarity = Int -> Int -> Rarity -> Int
linearInterpolation Int
ld Int
totalDepth (ItemKind -> Rarity
IK.irarity ItemKind
kind)
            !fr :: Int
fr = Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
rarity
        in (Int
fr, (ContentId ItemKind
ik, ItemKind
kind)) (Int, (ContentId ItemKind, ItemKind))
-> [(Int, (ContentId ItemKind, ItemKind))]
-> [(Int, (ContentId ItemKind, ItemKind))]
forall a. a -> [a] -> [a]
: [(Int, (ContentId ItemKind, ItemKind))]
acc
      g :: (GroupName ItemKind, Int)
-> [(Int, (ContentId ItemKind, ItemKind))]
g (!GroupName ItemKind
itemGroup, !Int
q) = ContentData ItemKind
-> GroupName ItemKind
-> ([(Int, (ContentId ItemKind, ItemKind))]
    -> Int
    -> ContentId ItemKind
    -> ItemKind
    -> [(Int, (ContentId ItemKind, ItemKind))])
-> [(Int, (ContentId ItemKind, ItemKind))]
-> [(Int, (ContentId ItemKind, ItemKind))]
forall a b.
ContentData a
-> GroupName a -> (b -> Int -> ContentId a -> a -> b) -> b -> b
ofoldlGroup' ContentData ItemKind
coitem GroupName ItemKind
itemGroup (Int
-> [(Int, (ContentId ItemKind, ItemKind))]
-> Int
-> ContentId ItemKind
-> ItemKind
-> [(Int, (ContentId ItemKind, ItemKind))]
f Int
q) []
      freqDepth :: [(Int, (ContentId ItemKind, ItemKind))]
freqDepth = ((GroupName ItemKind, Int)
 -> [(Int, (ContentId ItemKind, ItemKind))])
-> Freqs ItemKind -> [(Int, (ContentId ItemKind, ItemKind))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (GroupName ItemKind, Int)
-> [(Int, (ContentId ItemKind, ItemKind))]
g Freqs ItemKind
itemFreq
  in Text
-> [(Int, (ContentId ItemKind, ItemKind))]
-> Frequency (ContentId ItemKind, ItemKind)
forall a. Text -> [(Int, a)] -> Frequency a
toFreq "newItemKind" [(Int, (ContentId ItemKind, ItemKind))]
freqDepth

-- | Given item kind frequency, roll item kind, generate item aspects
-- based on level and put together the full item data set.
newItem :: COps -> Frequency (ContentId IK.ItemKind, ItemKind)
        -> FlavourMap -> DiscoveryKindRev
        -> Dice.AbsDepth -> Dice.AbsDepth
        -> Rnd (Maybe (ItemKnown, ItemFullKit))
newItem :: COps
-> Frequency (ContentId ItemKind, ItemKind)
-> FlavourMap
-> DiscoveryKindRev
-> AbsDepth
-> AbsDepth
-> Rnd (Maybe (ItemKnown, ItemFullKit))
newItem cops :: COps
cops freq :: Frequency (ContentId ItemKind, ItemKind)
freq flavourMap :: FlavourMap
flavourMap discoRev :: DiscoveryKindRev
discoRev levelDepth :: AbsDepth
levelDepth totalDepth :: AbsDepth
totalDepth =
  if Frequency (ContentId ItemKind, ItemKind) -> Bool
forall a. Frequency a -> Bool
nullFreq Frequency (ContentId ItemKind, ItemKind)
freq then Maybe (ItemKnown, ItemFullKit)
-> Rnd (Maybe (ItemKnown, ItemFullKit))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ItemKnown, ItemFullKit)
forall a. Maybe a
Nothing
  else do
    (itemKindId :: ContentId ItemKind
itemKindId, itemKind :: ItemKind
itemKind) <- Frequency (ContentId ItemKind, ItemKind)
-> Rnd (ContentId ItemKind, ItemKind)
forall a. Show a => Frequency a -> Rnd a
frequency Frequency (ContentId ItemKind, ItemKind)
freq
    -- Number of new items/actors unaffected by number of spawned actors.
    Int
itemN <- AbsDepth -> AbsDepth -> Dice -> Rnd Int
castDice AbsDepth
levelDepth AbsDepth
totalDepth (ItemKind -> Dice
IK.icount ItemKind
itemKind)
    AspectRecord
arItem <-
      [Aspect] -> AbsDepth -> AbsDepth -> Rnd AspectRecord
IA.rollAspectRecord (ItemKind -> [Aspect]
IK.iaspects ItemKind
itemKind) AbsDepth
levelDepth AbsDepth
totalDepth
    let itemBase :: Item
itemBase = COps
-> AspectRecord
-> FlavourMap
-> DiscoveryKindRev
-> ContentId ItemKind
-> Item
buildItem COps
cops AspectRecord
arItem FlavourMap
flavourMap DiscoveryKindRev
discoRev ContentId ItemKind
itemKindId
        itemIdentity :: ItemIdentity
itemIdentity = Item -> ItemIdentity
jkind Item
itemBase
        itemK :: Int
itemK = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 1 Int
itemN
        itemTimer :: [Time]
itemTimer = [Time
timeZero | Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Periodic AspectRecord
arItem]
          -- delay first discharge of single organs
        itemSuspect :: Bool
itemSuspect = Bool
False
        -- Bonuses on items/actors unaffected by number of spawned actors.
    let itemDisco :: ItemDisco
itemDisco = AspectRecord -> ItemDisco
ItemDiscoFull AspectRecord
arItem
        itemFull :: ItemFull
itemFull = $WItemFull :: Item
-> ContentId ItemKind -> ItemKind -> ItemDisco -> Bool -> ItemFull
ItemFull {..}
    Maybe (ItemKnown, ItemFullKit)
-> Rnd (Maybe (ItemKnown, ItemFullKit))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ItemKnown, ItemFullKit)
 -> Rnd (Maybe (ItemKnown, ItemFullKit)))
-> Maybe (ItemKnown, ItemFullKit)
-> Rnd (Maybe (ItemKnown, ItemFullKit))
forall a b. (a -> b) -> a -> b
$ (ItemKnown, ItemFullKit) -> Maybe (ItemKnown, ItemFullKit)
forall a. a -> Maybe a
Just ( ItemIdentity -> AspectRecord -> Maybe FactionId -> ItemKnown
ItemKnown ItemIdentity
itemIdentity AspectRecord
arItem (Item -> Maybe FactionId
jfid Item
itemBase)
                  , (ItemFull
itemFull, (Int
itemK, [Time]
itemTimer)) )

-- | The reverse map to @DiscoveryKind@, needed for item creation.
-- This is total and never changes, hence implemented as vector.
-- Morally, it's indexed by @ContentId ItemKind@ and elements are @ItemKindIx@.
newtype DiscoveryKindRev = DiscoveryKindRev (U.Vector Word16)
  deriving (Int -> DiscoveryKindRev -> ShowS
[DiscoveryKindRev] -> ShowS
DiscoveryKindRev -> String
(Int -> DiscoveryKindRev -> ShowS)
-> (DiscoveryKindRev -> String)
-> ([DiscoveryKindRev] -> ShowS)
-> Show DiscoveryKindRev
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DiscoveryKindRev] -> ShowS
$cshowList :: [DiscoveryKindRev] -> ShowS
show :: DiscoveryKindRev -> String
$cshow :: DiscoveryKindRev -> String
showsPrec :: Int -> DiscoveryKindRev -> ShowS
$cshowsPrec :: Int -> DiscoveryKindRev -> ShowS
Show, Get DiscoveryKindRev
[DiscoveryKindRev] -> Put
DiscoveryKindRev -> Put
(DiscoveryKindRev -> Put)
-> Get DiscoveryKindRev
-> ([DiscoveryKindRev] -> Put)
-> Binary DiscoveryKindRev
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [DiscoveryKindRev] -> Put
$cputList :: [DiscoveryKindRev] -> Put
get :: Get DiscoveryKindRev
$cget :: Get DiscoveryKindRev
put :: DiscoveryKindRev -> Put
$cput :: DiscoveryKindRev -> Put
Binary)

emptyDiscoveryKindRev :: DiscoveryKindRev
emptyDiscoveryKindRev :: DiscoveryKindRev
emptyDiscoveryKindRev = Vector Word16 -> DiscoveryKindRev
DiscoveryKindRev Vector Word16
forall a. Unbox a => Vector a
U.empty

serverDiscos :: COps -> Rnd (DiscoveryKind, DiscoveryKindRev)
serverDiscos :: COps -> Rnd (DiscoveryKind, DiscoveryKindRev)
serverDiscos COps{ContentData ItemKind
coitem :: ContentData ItemKind
coitem :: COps -> ContentData ItemKind
coitem} = do
  let ixs :: [ItemKindIx]
ixs = [Int -> ItemKindIx
forall a. Enum a => Int -> a
toEnum 0..Int -> ItemKindIx
forall a. Enum a => Int -> a
toEnum (ContentData ItemKind -> Int
forall a. ContentData a -> Int
olength ContentData ItemKind
coitem Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)]
  [ItemKindIx]
shuffled <- [ItemKindIx] -> Rnd [ItemKindIx]
forall a. Eq a => [a] -> Rnd [a]
shuffle [ItemKindIx]
ixs
  let f :: (EnumMap a a, EnumMap a a, [a])
-> a -> p -> (EnumMap a a, EnumMap a a, [a])
f (!EnumMap a a
ikMap, !EnumMap a a
ikRev, (!a
ix) : rest :: [a]
rest) !a
kmKind _ =
        (a -> a -> EnumMap a a -> EnumMap a a
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert a
ix a
kmKind EnumMap a a
ikMap, a -> a -> EnumMap a a -> EnumMap a a
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert a
kmKind a
ix EnumMap a a
ikRev, [a]
rest)
      f (ikMap :: EnumMap a a
ikMap, _, []) ik :: a
ik _ =
        String -> (EnumMap a a, EnumMap a a, [a])
forall a. HasCallStack => String -> a
error (String -> (EnumMap a a, EnumMap a a, [a]))
-> String -> (EnumMap a a, EnumMap a a, [a])
forall a b. (a -> b) -> a -> b
$ "too short ixs" String -> (a, EnumMap a a) -> String
forall v. Show v => String -> v -> String
`showFailure` (a
ik, EnumMap a a
ikMap)
      (discoS :: DiscoveryKind
discoS, discoRev :: EnumMap (ContentId ItemKind) ItemKindIx
discoRev, _) =
        ContentData ItemKind
-> ((DiscoveryKind, EnumMap (ContentId ItemKind) ItemKindIx,
     [ItemKindIx])
    -> ContentId ItemKind
    -> ItemKind
    -> (DiscoveryKind, EnumMap (ContentId ItemKind) ItemKindIx,
        [ItemKindIx]))
-> (DiscoveryKind, EnumMap (ContentId ItemKind) ItemKindIx,
    [ItemKindIx])
-> (DiscoveryKind, EnumMap (ContentId ItemKind) ItemKindIx,
    [ItemKindIx])
forall a b. ContentData a -> (b -> ContentId a -> a -> b) -> b -> b
ofoldlWithKey' ContentData ItemKind
coitem (DiscoveryKind, EnumMap (ContentId ItemKind) ItemKindIx,
 [ItemKindIx])
-> ContentId ItemKind
-> ItemKind
-> (DiscoveryKind, EnumMap (ContentId ItemKind) ItemKindIx,
    [ItemKindIx])
forall a a p.
(Enum a, Enum a, Show a, Show a) =>
(EnumMap a a, EnumMap a a, [a])
-> a -> p -> (EnumMap a a, EnumMap a a, [a])
f (DiscoveryKind
forall k a. EnumMap k a
EM.empty, EnumMap (ContentId ItemKind) ItemKindIx
forall k a. EnumMap k a
EM.empty, [ItemKindIx]
shuffled)
      udiscoRev :: Vector Word16
udiscoRev = Int -> [Word16] -> Vector Word16
forall a. Unbox a => Int -> [a] -> Vector a
U.fromListN (ContentData ItemKind -> Int
forall a. ContentData a -> Int
olength ContentData ItemKind
coitem)
                  ([Word16] -> Vector Word16) -> [Word16] -> Vector Word16
forall a b. (a -> b) -> a -> b
$ (ItemKindIx -> Word16) -> [ItemKindIx] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word16
forall a. Enum a => Int -> a
toEnum (Int -> Word16) -> (ItemKindIx -> Int) -> ItemKindIx -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ItemKindIx -> Int
forall a. Enum a => a -> Int
fromEnum) ([ItemKindIx] -> [Word16]) -> [ItemKindIx] -> [Word16]
forall a b. (a -> b) -> a -> b
$ EnumMap (ContentId ItemKind) ItemKindIx -> [ItemKindIx]
forall k a. EnumMap k a -> [a]
EM.elems EnumMap (ContentId ItemKind) ItemKindIx
discoRev
  (DiscoveryKind, DiscoveryKindRev)
-> Rnd (DiscoveryKind, DiscoveryKindRev)
forall (m :: * -> *) a. Monad m => a -> m a
return (DiscoveryKind
discoS, Vector Word16 -> DiscoveryKindRev
DiscoveryKindRev Vector Word16
udiscoRev)

-- | Flavours assigned by the server to item kinds, in this particular game.
-- This is total and never changes, hence implemented as vector.
-- Morally, it's indexed by @ContentId ItemKind@ and elements are @Flavour@.
newtype FlavourMap = FlavourMap (U.Vector Word16)
  deriving (Int -> FlavourMap -> ShowS
[FlavourMap] -> ShowS
FlavourMap -> String
(Int -> FlavourMap -> ShowS)
-> (FlavourMap -> String)
-> ([FlavourMap] -> ShowS)
-> Show FlavourMap
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FlavourMap] -> ShowS
$cshowList :: [FlavourMap] -> ShowS
show :: FlavourMap -> String
$cshow :: FlavourMap -> String
showsPrec :: Int -> FlavourMap -> ShowS
$cshowsPrec :: Int -> FlavourMap -> ShowS
Show, Get FlavourMap
[FlavourMap] -> Put
FlavourMap -> Put
(FlavourMap -> Put)
-> Get FlavourMap -> ([FlavourMap] -> Put) -> Binary FlavourMap
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [FlavourMap] -> Put
$cputList :: [FlavourMap] -> Put
get :: Get FlavourMap
$cget :: Get FlavourMap
put :: FlavourMap -> Put
$cput :: FlavourMap -> Put
Binary)

emptyFlavourMap :: FlavourMap
emptyFlavourMap :: FlavourMap
emptyFlavourMap = Vector Word16 -> FlavourMap
FlavourMap Vector Word16
forall a. Unbox a => Vector a
U.empty

stdFlav :: ES.EnumSet Flavour
stdFlav :: EnumSet Flavour
stdFlav = [Flavour] -> EnumSet Flavour
forall k. Enum k => [k] -> EnumSet k
ES.fromList [ FancyName -> Color -> Flavour
Flavour FancyName
fn Color
bc
                      | FancyName
fn <- [FancyName
forall a. Bounded a => a
minBound..FancyName
forall a. Bounded a => a
maxBound], Color
bc <- [Color]
Color.stdCol ]

-- | Assigns flavours to item kinds. Assures no flavor is repeated for the same
-- symbol, except for items with only one permitted flavour.
rollFlavourMap :: Rnd ( EM.EnumMap (ContentId ItemKind) Flavour
                      , EM.EnumMap Char (ES.EnumSet Flavour) )
               -> ContentId ItemKind -> ItemKind
               -> Rnd ( EM.EnumMap (ContentId ItemKind) Flavour
                      , EM.EnumMap Char (ES.EnumSet Flavour) )
rollFlavourMap :: Rnd
  (EnumMap (ContentId ItemKind) Flavour,
   EnumMap Char (EnumSet Flavour))
-> ContentId ItemKind
-> ItemKind
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap Char (EnumSet Flavour))
rollFlavourMap !Rnd
  (EnumMap (ContentId ItemKind) Flavour,
   EnumMap Char (EnumSet Flavour))
rnd !ContentId ItemKind
key !ItemKind
ik = case ItemKind -> [Flavour]
IK.iflavour ItemKind
ik of
  [] -> String
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap Char (EnumSet Flavour))
forall a. HasCallStack => String -> a
error "empty iflavour"
  [flavour :: Flavour
flavour] -> do
    (!EnumMap (ContentId ItemKind) Flavour
assocs, !EnumMap Char (EnumSet Flavour)
availableMap) <- Rnd
  (EnumMap (ContentId ItemKind) Flavour,
   EnumMap Char (EnumSet Flavour))
rnd
    (EnumMap (ContentId ItemKind) Flavour,
 EnumMap Char (EnumSet Flavour))
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap Char (EnumSet Flavour))
forall (m :: * -> *) a. Monad m => a -> m a
return ( ContentId ItemKind
-> Flavour
-> EnumMap (ContentId ItemKind) Flavour
-> EnumMap (ContentId ItemKind) Flavour
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert ContentId ItemKind
key Flavour
flavour EnumMap (ContentId ItemKind) Flavour
assocs
           , EnumMap Char (EnumSet Flavour)
availableMap)
  flvs :: [Flavour]
flvs -> do
    (!EnumMap (ContentId ItemKind) Flavour
assocs, !EnumMap Char (EnumSet Flavour)
availableMap) <- Rnd
  (EnumMap (ContentId ItemKind) Flavour,
   EnumMap Char (EnumSet Flavour))
rnd
    let available :: EnumSet Flavour
available =
          EnumSet Flavour
-> Char -> EnumMap Char (EnumSet Flavour) -> EnumSet Flavour
forall k a. Enum k => a -> k -> EnumMap k a -> a
EM.findWithDefault EnumSet Flavour
stdFlav (ItemKind -> Char
IK.isymbol ItemKind
ik) EnumMap Char (EnumSet Flavour)
availableMap
        proper :: EnumSet Flavour
proper = [Flavour] -> EnumSet Flavour
forall k. Enum k => [k] -> EnumSet k
ES.fromList [Flavour]
flvs EnumSet Flavour -> EnumSet Flavour -> EnumSet Flavour
forall k. EnumSet k -> EnumSet k -> EnumSet k
`ES.intersection` EnumSet Flavour
available
    Bool
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap Char (EnumSet Flavour))
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap Char (EnumSet Flavour))
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (EnumSet Flavour -> Bool
forall k. EnumSet k -> Bool
ES.null EnumSet Flavour
proper)
            Bool
-> (String,
    ([Flavour], EnumSet Flavour, ItemKind,
     EnumMap Char (EnumSet Flavour)))
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` "not enough flavours for items"
            String
-> ([Flavour], EnumSet Flavour, ItemKind,
    EnumMap Char (EnumSet Flavour))
-> (String,
    ([Flavour], EnumSet Flavour, ItemKind,
     EnumMap Char (EnumSet Flavour)))
forall v. String -> v -> (String, v)
`swith` ([Flavour]
flvs, EnumSet Flavour
available, ItemKind
ik, EnumMap Char (EnumSet Flavour)
availableMap)) (Rnd
   (EnumMap (ContentId ItemKind) Flavour,
    EnumMap Char (EnumSet Flavour))
 -> Rnd
      (EnumMap (ContentId ItemKind) Flavour,
       EnumMap Char (EnumSet Flavour)))
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap Char (EnumSet Flavour))
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap Char (EnumSet Flavour))
forall a b. (a -> b) -> a -> b
$ do
      Flavour
flavour <- [Flavour] -> Rnd Flavour
forall a. [a] -> Rnd a
oneOf ([Flavour] -> Rnd Flavour) -> [Flavour] -> Rnd Flavour
forall a b. (a -> b) -> a -> b
$ EnumSet Flavour -> [Flavour]
forall k. Enum k => EnumSet k -> [k]
ES.toList EnumSet Flavour
proper
      let availableReduced :: EnumSet Flavour
availableReduced = Flavour -> EnumSet Flavour -> EnumSet Flavour
forall k. Enum k => k -> EnumSet k -> EnumSet k
ES.delete Flavour
flavour EnumSet Flavour
available
      (EnumMap (ContentId ItemKind) Flavour,
 EnumMap Char (EnumSet Flavour))
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap Char (EnumSet Flavour))
forall (m :: * -> *) a. Monad m => a -> m a
return ( ContentId ItemKind
-> Flavour
-> EnumMap (ContentId ItemKind) Flavour
-> EnumMap (ContentId ItemKind) Flavour
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert ContentId ItemKind
key Flavour
flavour EnumMap (ContentId ItemKind) Flavour
assocs
             , Char
-> EnumSet Flavour
-> EnumMap Char (EnumSet Flavour)
-> EnumMap Char (EnumSet Flavour)
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert (ItemKind -> Char
IK.isymbol ItemKind
ik) EnumSet Flavour
availableReduced EnumMap Char (EnumSet Flavour)
availableMap)

-- | Randomly chooses flavour for all item kinds for this game.
dungeonFlavourMap :: COps -> Rnd FlavourMap
dungeonFlavourMap :: COps -> Rnd FlavourMap
dungeonFlavourMap COps{ContentData ItemKind
coitem :: ContentData ItemKind
coitem :: COps -> ContentData ItemKind
coitem} = do
  (assocsFlav :: EnumMap (ContentId ItemKind) Flavour
assocsFlav, _) <- ContentData ItemKind
-> (Rnd
      (EnumMap (ContentId ItemKind) Flavour,
       EnumMap Char (EnumSet Flavour))
    -> ContentId ItemKind
    -> ItemKind
    -> Rnd
         (EnumMap (ContentId ItemKind) Flavour,
          EnumMap Char (EnumSet Flavour)))
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap Char (EnumSet Flavour))
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap Char (EnumSet Flavour))
forall a b. ContentData a -> (b -> ContentId a -> a -> b) -> b -> b
ofoldlWithKey' ContentData ItemKind
coitem Rnd
  (EnumMap (ContentId ItemKind) Flavour,
   EnumMap Char (EnumSet Flavour))
-> ContentId ItemKind
-> ItemKind
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap Char (EnumSet Flavour))
rollFlavourMap
                                    ((EnumMap (ContentId ItemKind) Flavour,
 EnumMap Char (EnumSet Flavour))
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap Char (EnumSet Flavour))
forall (m :: * -> *) a. Monad m => a -> m a
return (EnumMap (ContentId ItemKind) Flavour
forall k a. EnumMap k a
EM.empty, EnumMap Char (EnumSet Flavour)
forall k a. EnumMap k a
EM.empty))
  let uFlav :: Vector Word16
uFlav = Int -> [Word16] -> Vector Word16
forall a. Unbox a => Int -> [a] -> Vector a
U.fromListN (ContentData ItemKind -> Int
forall a. ContentData a -> Int
olength ContentData ItemKind
coitem)
              ([Word16] -> Vector Word16) -> [Word16] -> Vector Word16
forall a b. (a -> b) -> a -> b
$ (Flavour -> Word16) -> [Flavour] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word16
forall a. Enum a => Int -> a
toEnum (Int -> Word16) -> (Flavour -> Int) -> Flavour -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flavour -> Int
forall a. Enum a => a -> Int
fromEnum) ([Flavour] -> [Word16]) -> [Flavour] -> [Word16]
forall a b. (a -> b) -> a -> b
$ EnumMap (ContentId ItemKind) Flavour -> [Flavour]
forall k a. EnumMap k a -> [a]
EM.elems EnumMap (ContentId ItemKind) Flavour
assocsFlav
  FlavourMap -> Rnd FlavourMap
forall (m :: * -> *) a. Monad m => a -> m a
return (FlavourMap -> Rnd FlavourMap) -> FlavourMap -> Rnd FlavourMap
forall a b. (a -> b) -> a -> b
$! Vector Word16 -> FlavourMap
FlavourMap Vector Word16
uFlav