{-# 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(..), NewItem(..), ItemRev, UniqueSet
  , newItemKind, newItem
    -- * Item discovery types
  , DiscoveryKindRev, emptyDiscoveryKindRev, serverDiscos
    -- * The @FlavourMap@ type
  , FlavourMap, emptyFlavourMap, dungeonFlavourMap
    -- * Important implementation parts, exposed for tests
  , rollFlavourMap
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , buildItem, keepMetaGameInformation
#endif
  ) 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 qualified Data.HashMap.Strict as HM
import           Data.Hashable (Hashable)
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.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           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 meaningful 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

data NewItem =
    NewItem  (GroupName ItemKind) ItemKnown ItemFull ItemQuant
  | NoNewItem

-- | 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} AspectRecord
arItem (FlavourMap Vector Word16
flavourMap)
          (DiscoveryKindRev Vector Word16
discoRev) ContentId ItemKind
ikChosen =
  let jkind :: ItemIdentity
jkind = case AspectRecord -> Maybe (GroupName ItemKind)
IA.aPresentAs AspectRecord
arItem of
        Just 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
               (Word16 -> ItemKindIx
toItemKindIx (Word16 -> ItemKindIx) -> Word16 -> ItemKindIx
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 c. ContentId c -> Int
contentIdIndex ContentId ItemKind
ikChosen)
               ContentId ItemKind
kindHidden
        Maybe (GroupName ItemKind)
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 c. ContentId c -> Int
contentIdIndex ContentId ItemKind
ikChosen
  in Item :: ItemIdentity -> Maybe FactionId -> Flavour -> Item
Item{Maybe FactionId
Flavour
ItemIdentity
forall a. Maybe a
jflavour :: Flavour
jfid :: Maybe FactionId
jkind :: ItemIdentity
jflavour :: Flavour
jfid :: forall a. Maybe a
jkind :: ItemIdentity
..}

-- | Roll an item kind based on given @Freqs@ and kind rarities
newItemKind :: COps -> UniqueSet -> Freqs ItemKind
            -> Dice.AbsDepth -> Dice.AbsDepth -> Int
            -> Frequency (GroupName ItemKind, ContentId IK.ItemKind, ItemKind)
newItemKind :: COps
-> UniqueSet
-> Freqs ItemKind
-> AbsDepth
-> AbsDepth
-> Int
-> Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
newItemKind COps{ContentData ItemKind
coitem :: ContentData ItemKind
coitem :: COps -> ContentData ItemKind
coitem, ItemSpeedup
coItemSpeedup :: COps -> ItemSpeedup
coItemSpeedup :: ItemSpeedup
coItemSpeedup} UniqueSet
uniqueSet Freqs ItemKind
itemFreq
            (Dice.AbsDepth Int
ldepth) (Dice.AbsDepth Int
totalDepth) Int
lvlSpawned =
  Bool
-> Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
-> Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (((GroupName ItemKind, Int) -> Bool) -> Freqs ItemKind -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(GroupName ItemKind
_, Int
n) -> Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) Freqs ItemKind
itemFreq) (Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
 -> Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind))
-> Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
-> Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
forall a b. (a -> b) -> a -> b
$
  -- 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.
  let numSpawnedCoeff :: Int
numSpawnedCoeff = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
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` Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
5
      ldSpawned :: Int
ldSpawned = Int
ldepth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numSpawnedCoeff
      f :: GroupName ItemKind
-> Int
-> [(Int, (GroupName ItemKind, ContentId ItemKind, ItemKind))]
-> Int
-> ContentId ItemKind
-> ItemKind
-> [(Int, (GroupName ItemKind, ContentId ItemKind, ItemKind))]
f GroupName ItemKind
_ Int
_ [(Int, (GroupName ItemKind, ContentId ItemKind, ItemKind))]
acc Int
_ ContentId ItemKind
ik ItemKind
_ | ContentId ItemKind
ik ContentId ItemKind -> UniqueSet -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
`ES.member` UniqueSet
uniqueSet = [(Int, (GroupName ItemKind, ContentId ItemKind, ItemKind))]
acc
      f !GroupName ItemKind
itemGroup !Int
q ![(Int, (GroupName ItemKind, 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, (GroupName ItemKind
itemGroup, ContentId ItemKind
ik, ItemKind
kind)) (Int, (GroupName ItemKind, ContentId ItemKind, ItemKind))
-> [(Int, (GroupName ItemKind, ContentId ItemKind, ItemKind))]
-> [(Int, (GroupName ItemKind, ContentId ItemKind, ItemKind))]
forall a. a -> [a] -> [a]
: [(Int, (GroupName ItemKind, ContentId ItemKind, ItemKind))]
acc
      g :: (GroupName ItemKind, Int)
-> [(Int, (GroupName ItemKind, ContentId ItemKind, ItemKind))]
g (!GroupName ItemKind
itemGroup, !Int
q) = ContentData ItemKind
-> GroupName ItemKind
-> ([(Int, (GroupName ItemKind, ContentId ItemKind, ItemKind))]
    -> Int
    -> ContentId ItemKind
    -> ItemKind
    -> [(Int, (GroupName ItemKind, ContentId ItemKind, ItemKind))])
-> [(Int, (GroupName ItemKind, ContentId ItemKind, ItemKind))]
-> [(Int, (GroupName ItemKind, 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 (GroupName ItemKind
-> Int
-> [(Int, (GroupName ItemKind, ContentId ItemKind, ItemKind))]
-> Int
-> ContentId ItemKind
-> ItemKind
-> [(Int, (GroupName ItemKind, ContentId ItemKind, ItemKind))]
f GroupName ItemKind
itemGroup Int
q) []
      freqDepth :: [(Int, (GroupName ItemKind, ContentId ItemKind, ItemKind))]
freqDepth = ((GroupName ItemKind, Int)
 -> [(Int, (GroupName ItemKind, ContentId ItemKind, ItemKind))])
-> Freqs ItemKind
-> [(Int, (GroupName ItemKind, ContentId ItemKind, ItemKind))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (GroupName ItemKind, Int)
-> [(Int, (GroupName ItemKind, ContentId ItemKind, ItemKind))]
g Freqs ItemKind
itemFreq
  in Text
-> [(Int, (GroupName ItemKind, ContentId ItemKind, ItemKind))]
-> Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
forall a. Text -> [(Int, a)] -> Frequency a
toFreq Text
"newItemKind" [(Int, (GroupName ItemKind, 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 (GroupName ItemKind, ContentId IK.ItemKind, ItemKind)
        -> FlavourMap -> DiscoveryKindRev
        -> Dice.AbsDepth -> Dice.AbsDepth
        -> Rnd NewItem
newItem :: COps
-> Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
-> FlavourMap
-> DiscoveryKindRev
-> AbsDepth
-> AbsDepth
-> Rnd NewItem
newItem COps
cops Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
freq FlavourMap
flavourMap DiscoveryKindRev
discoRev AbsDepth
levelDepth AbsDepth
totalDepth =
  if Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
-> Bool
forall a. Frequency a -> Bool
nullFreq Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
freq
  then NewItem -> Rnd NewItem
forall (m :: * -> *) a. Monad m => a -> m a
return NewItem
NoNewItem  -- e.g., rare tile has a unique embed, only first time
  else do
    (GroupName ItemKind
itemGroup, ContentId ItemKind
itemKindId, ItemKind
itemKind) <- Frequency (GroupName ItemKind, ContentId ItemKind, ItemKind)
-> Rnd (GroupName ItemKind, ContentId ItemKind, ItemKind)
forall a. Show a => Frequency a -> Rnd a
frequency Frequency (GroupName ItemKind, 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 Int
1 Int
itemN
        !itemTimer :: [ItemTimer]
itemTimer = [ItemTimer
itemTimerZero | Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Periodic AspectRecord
arItem]
          -- enable optimization in @applyPeriodicLevel@
        itemSuspect :: Bool
itemSuspect = Bool
False
        -- Bonuses on items/actors unaffected by number of spawned actors.
        itemDisco :: ItemDisco
itemDisco = AspectRecord -> ItemDisco
ItemDiscoFull AspectRecord
arItem
        itemFull :: ItemFull
itemFull = ItemFull :: Item
-> ContentId ItemKind -> ItemKind -> ItemDisco -> Bool -> ItemFull
ItemFull {Bool
ContentId ItemKind
ItemKind
ItemDisco
Item
itemSuspect :: Bool
itemDisco :: ItemDisco
itemKind :: ItemKind
itemKindId :: ContentId ItemKind
itemBase :: Item
itemDisco :: ItemDisco
itemSuspect :: Bool
itemBase :: Item
itemKind :: ItemKind
itemKindId :: ContentId ItemKind
..}
        itemKnown :: ItemKnown
itemKnown = ItemIdentity -> AspectRecord -> Maybe FactionId -> ItemKnown
ItemKnown ItemIdentity
itemIdentity AspectRecord
arItem (Item -> Maybe FactionId
jfid Item
itemBase)
        itemQuant :: ItemQuant
itemQuant = if Int
itemK Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& [ItemTimer] -> Bool
forall a. [a] -> Bool
null [ItemTimer]
itemTimer
                    then ItemQuant
quantSingle
                    else (Int
itemK, [ItemTimer]
itemTimer)
    NewItem -> Rnd NewItem
forall (m :: * -> *) a. Monad m => a -> m a
return (NewItem -> Rnd NewItem) -> NewItem -> Rnd NewItem
forall a b. (a -> b) -> a -> b
$! GroupName ItemKind -> ItemKnown -> ItemFull -> ItemQuant -> NewItem
NewItem GroupName ItemKind
itemGroup ItemKnown
itemKnown ItemFull
itemFull ItemQuant
itemQuant

-- | 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 -> DiscoveryKindRev
             -> Rnd (DiscoveryKind, DiscoveryKindRev)
serverDiscos :: COps -> DiscoveryKindRev -> Rnd (DiscoveryKind, DiscoveryKindRev)
serverDiscos COps{ContentData ItemKind
coitem :: ContentData ItemKind
coitem :: COps -> ContentData ItemKind
coitem} (DiscoveryKindRev Vector Word16
discoRevFromPreviousGame) = do
  let ixs :: [Word16]
ixs = [Word16
0..Int -> Word16
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
- Int
1)]
  [Word16]
shuffled <-
    if Vector Word16 -> Bool
forall a. Unbox a => Vector a -> Bool
U.null Vector Word16
discoRevFromPreviousGame
    then [Word16] -> Rnd [Word16]
forall a. Eq a => [a] -> Rnd [a]
shuffle [Word16]
ixs
    else Vector Word16 -> Int -> [Word16] -> Rnd [Word16]
shuffleExcept (ContentData ItemKind -> Vector Word16 -> Vector Word16
keepMetaGameInformation ContentData ItemKind
coitem Vector Word16
discoRevFromPreviousGame)
                       (ContentData ItemKind -> Int
forall a. ContentData a -> Int
olength ContentData ItemKind
coitem)
                       [Word16]
ixs
  let 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]
shuffled
      f :: ContentId ItemKind -> Word16 -> (ItemKindIx, ContentId ItemKind)
      f :: ContentId ItemKind -> Word16 -> (ItemKindIx, ContentId ItemKind)
f ContentId ItemKind
ik Word16
ikx = (Word16 -> ItemKindIx
toItemKindIx Word16
ikx, ContentId ItemKind
ik)
      -- Not @fromDistinctAscList@, because it's the reverse map.
      discoS :: DiscoveryKind
discoS = [(ItemKindIx, ContentId ItemKind)] -> DiscoveryKind
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromList ([(ItemKindIx, ContentId ItemKind)] -> DiscoveryKind)
-> [(ItemKindIx, ContentId ItemKind)] -> DiscoveryKind
forall a b. (a -> b) -> a -> b
$ (ContentId ItemKind -> Word16 -> (ItemKindIx, ContentId ItemKind))
-> [ContentId ItemKind]
-> [Word16]
-> [(ItemKindIx, ContentId ItemKind)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ContentId ItemKind -> Word16 -> (ItemKindIx, ContentId ItemKind)
f [Int -> ContentId ItemKind
forall a. Enum a => Int -> a
toEnum Int
0 ..] ([Word16] -> [(ItemKindIx, ContentId ItemKind)])
-> [Word16] -> [(ItemKindIx, ContentId ItemKind)]
forall a b. (a -> b) -> a -> b
$ Vector Word16 -> [Word16]
forall a. Unbox a => Vector a -> [a]
U.toList Vector Word16
udiscoRev
  (DiscoveryKind, DiscoveryKindRev)
-> Rnd (DiscoveryKind, DiscoveryKindRev)
forall (m :: * -> *) a. Monad m => a -> m a
return (DiscoveryKind
discoS, Vector Word16 -> DiscoveryKindRev
DiscoveryKindRev Vector Word16
udiscoRev)

-- | Keep in a vector the information that is retained from playthrough
-- to playthrough. The information being, e.g., @ItemKindIx@ or @Flavour@.
-- The information is morally indexed by @ContentId ItemKind@ and its @Enum@
-- instance fits in @Word16@.
keepMetaGameInformation :: ContentData ItemKind
                        -> U.Vector Word16
                        -> U.Vector Word16
keepMetaGameInformation :: ContentData ItemKind -> Vector Word16 -> Vector Word16
keepMetaGameInformation ContentData ItemKind
coitem Vector Word16
informationFromPreviousGame =
  let inMetaGame :: ContentId ItemKind -> Bool
      inMetaGame :: ContentId ItemKind -> Bool
inMetaGame ContentId ItemKind
kindId =
        Flag -> Aspect
IK.SetFlag Flag
Ability.MetaGame Aspect -> [Aspect] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ItemKind -> [Aspect]
IK.iaspects (ContentData ItemKind -> ContentId ItemKind -> ItemKind
forall a. ContentData a -> ContentId a -> a
okind ContentData ItemKind
coitem ContentId ItemKind
kindId)
      keepMeta :: Int -> Word16 -> Word16
      keepMeta :: Int -> Word16 -> Word16
keepMeta Int
i Word16
ix = if ContentId ItemKind -> Bool
inMetaGame (Int -> ContentId ItemKind
forall a. Enum a => Int -> a
toEnum Int
i)
                      then Word16
ix
                      else Word16
invalidInformationCode
  in (Int -> Word16 -> Word16) -> Vector Word16 -> Vector Word16
forall a b.
(Unbox a, Unbox b) =>
(Int -> a -> b) -> Vector a -> Vector b
U.imap Int -> Word16 -> Word16
keepMeta Vector Word16
informationFromPreviousGame

-- | 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

-- | Assigns flavours to item kinds. Assures no flavor is repeated for the same
-- symbol, except for items with only one permitted flavour.
rollFlavourMap
  :: U.Vector Word16
  -> Rnd ( EM.EnumMap (ContentId ItemKind) Flavour
         , EM.EnumMap (ContentSymbol ItemKind) (ES.EnumSet Flavour) )
  -> ContentId ItemKind -> ItemKind
  -> Rnd ( EM.EnumMap (ContentId ItemKind) Flavour
         , EM.EnumMap (ContentSymbol ItemKind) (ES.EnumSet Flavour) )
rollFlavourMap :: Vector Word16
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
-> ContentId ItemKind
-> ItemKind
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
rollFlavourMap Vector Word16
uFlavMeta !Rnd
  (EnumMap (ContentId ItemKind) Flavour,
   EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
rnd !ContentId ItemKind
key !ItemKind
ik = case ItemKind -> [Flavour]
IK.iflavour ItemKind
ik of
  [] -> String
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
forall a. (?callStack::CallStack) => String -> a
error String
"empty iflavour"
  [Flavour
flavour] -> do
    (!EnumMap (ContentId ItemKind) Flavour
assocs, !EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
availableMap) <- Rnd
  (EnumMap (ContentId ItemKind) Flavour,
   EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
rnd
    (EnumMap (ContentId ItemKind) Flavour,
 EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap (ContentSymbol ItemKind) (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 (ContentSymbol ItemKind) (EnumSet Flavour)
availableMap )
  [Flavour]
flvs -> do
    (!EnumMap (ContentId ItemKind) Flavour
assocs, !EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
availableMap) <- Rnd
  (EnumMap (ContentId ItemKind) Flavour,
   EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
rnd
    let a0 :: Word16
a0 = Vector Word16
uFlavMeta Vector Word16 -> Int -> Word16
forall a. Unbox a => Vector a -> Int -> a
U.! Int -> Int
forall a. Enum a => Int -> a
toEnum (ContentId ItemKind -> Int
forall a. Enum a => a -> Int
fromEnum ContentId ItemKind
key)
    if Word16
a0 Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
invalidInformationCode then do
      if [Flavour] -> Int
forall a. [a] -> Int
length [Flavour]
flvs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
6 then do  -- too few to even attempt unique assignment
        Flavour
flavour <- [Flavour] -> Rnd Flavour
forall a. [a] -> Rnd a
oneOf [Flavour]
flvs
        (EnumMap (ContentId ItemKind) Flavour,
 EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap (ContentSymbol ItemKind) (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 (ContentSymbol ItemKind) (EnumSet Flavour)
availableMap )
      else do
        let available :: EnumSet Flavour
available = EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
availableMap EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
-> ContentSymbol ItemKind -> EnumSet Flavour
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemKind -> ContentSymbol ItemKind
IK.isymbol ItemKind
ik
            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 (ContentSymbol ItemKind) (EnumSet Flavour))
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
forall a. (?callStack::CallStack) => 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 (ContentSymbol ItemKind) (EnumSet Flavour)))
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"not enough flavours for items"
                String
-> ([Flavour], EnumSet Flavour, ItemKind,
    EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
-> (String,
    ([Flavour], EnumSet Flavour, ItemKind,
     EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)))
forall v. String -> v -> (String, v)
`swith` ([Flavour]
flvs, EnumSet Flavour
available, ItemKind
ik, EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
availableMap)) (Rnd
   (EnumMap (ContentId ItemKind) Flavour,
    EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
 -> Rnd
      (EnumMap (ContentId ItemKind) Flavour,
       EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)))
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap (ContentSymbol ItemKind) (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.elems 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 (ContentSymbol ItemKind) (EnumSet Flavour))
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap (ContentSymbol ItemKind) (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
                 , ContentSymbol ItemKind
-> EnumSet Flavour
-> EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
-> EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert (ItemKind -> ContentSymbol ItemKind
IK.isymbol ItemKind
ik) EnumSet Flavour
availableReduced EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
availableMap )
    else (EnumMap (ContentId ItemKind) Flavour,
 EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap (ContentSymbol ItemKind) (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 (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
a0) EnumMap (ContentId ItemKind) Flavour
assocs
                , EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
availableMap )

-- | Randomly chooses flavour for all item kinds for this game.
dungeonFlavourMap :: COps -> FlavourMap -> Rnd FlavourMap
dungeonFlavourMap :: COps -> FlavourMap -> Rnd FlavourMap
dungeonFlavourMap COps{ContentData ItemKind
coitem :: ContentData ItemKind
coitem :: COps -> ContentData ItemKind
coitem} (FlavourMap Vector Word16
flavourMapFromPreviousGame) = do
  let uFlavMeta :: Vector Word16
uFlavMeta = if Vector Word16 -> Bool
forall a. Unbox a => Vector a -> Bool
U.null Vector Word16
flavourMapFromPreviousGame
                  then Int -> Word16 -> Vector Word16
forall a. Unbox a => Int -> a -> Vector a
U.replicate (ContentData ItemKind -> Int
forall a. ContentData a -> Int
olength ContentData ItemKind
coitem) Word16
invalidInformationCode
                  else ContentData ItemKind -> Vector Word16 -> Vector Word16
keepMetaGameInformation ContentData ItemKind
coitem Vector Word16
flavourMapFromPreviousGame
      flavToAvailable :: EM.EnumMap Char (ES.EnumSet Flavour) -> Int -> Word16
                      -> EM.EnumMap Char (ES.EnumSet Flavour)
      flavToAvailable :: EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
-> Int
-> Word16
-> EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
flavToAvailable EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
em Int
i Word16
fl =
        let ik :: ItemKind
ik = ContentData ItemKind -> ContentId ItemKind -> ItemKind
forall a. ContentData a -> ContentId a -> a
okind ContentData ItemKind
coitem (Int -> ContentId ItemKind
forall a. Enum a => Int -> a
toEnum Int
i)
            setBase :: EnumSet Flavour
setBase = EnumSet Flavour
-> ContentSymbol ItemKind
-> EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
-> EnumSet Flavour
forall k a. Enum k => a -> k -> EnumMap k a -> a
EM.findWithDefault ([Flavour] -> EnumSet Flavour
forall k. Enum k => [k] -> EnumSet k
ES.fromList [Flavour]
stdFlavList)
                                         (ItemKind -> ContentSymbol ItemKind
IK.isymbol ItemKind
ik)
                                         EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
em
            setMeta :: EnumSet Flavour
setMeta = if Word16
fl Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
invalidInformationCode
                      then EnumSet Flavour
setBase
                      else Flavour -> EnumSet Flavour -> EnumSet Flavour
forall k. Enum k => k -> EnumSet k -> EnumSet k
ES.delete (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
fl) EnumSet Flavour
setBase
        in ContentSymbol ItemKind
-> EnumSet Flavour
-> EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
-> EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert (ItemKind -> ContentSymbol ItemKind
IK.isymbol ItemKind
ik) EnumSet Flavour
setMeta EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
em
      availableMap :: EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
availableMap = (EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
 -> Int
 -> Word16
 -> EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
-> EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
-> Vector Word16
-> EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
forall b a. Unbox b => (a -> Int -> b -> a) -> a -> Vector b -> a
U.ifoldl' EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
-> Int
-> Word16
-> EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
flavToAvailable EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
forall k a. EnumMap k a
EM.empty Vector Word16
uFlavMeta
  (EnumMap (ContentId ItemKind) Flavour
assocsFlav, EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
_) <- ContentData ItemKind
-> (Rnd
      (EnumMap (ContentId ItemKind) Flavour,
       EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
    -> ContentId ItemKind
    -> ItemKind
    -> Rnd
         (EnumMap (ContentId ItemKind) Flavour,
          EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)))
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
forall a b. ContentData a -> (b -> ContentId a -> a -> b) -> b -> b
ofoldlWithKey' ContentData ItemKind
coitem (Vector Word16
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
-> ContentId ItemKind
-> ItemKind
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
rollFlavourMap Vector Word16
uFlavMeta)
                                    ((EnumMap (ContentId ItemKind) Flavour,
 EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
-> Rnd
     (EnumMap (ContentId ItemKind) Flavour,
      EnumMap (ContentSymbol ItemKind) (EnumSet Flavour))
forall (m :: * -> *) a. Monad m => a -> m a
return (EnumMap (ContentId ItemKind) Flavour
forall k a. EnumMap k a
EM.empty, EnumMap (ContentSymbol ItemKind) (EnumSet Flavour)
availableMap))
  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