{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Game.LambdaHack.Server.ItemRev
( ItemKnown, ItemRev, UniqueSet, buildItem, newItem
, DiscoveryKindRev, ItemSeedDict, emptyDiscoveryKindRev, serverDiscos
, FlavourMap, emptyFlavourMap, dungeonFlavourMap
) where
import Prelude ()
import Game.LambdaHack.Common.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.Vector.Binary ()
import qualified Data.Vector.Unboxed as U
import qualified Game.LambdaHack.Common.Color as Color
import Game.LambdaHack.Common.ContentData
import qualified Game.LambdaHack.Common.Dice as Dice
import Game.LambdaHack.Common.Flavour
import Game.LambdaHack.Common.Frequency
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.ItemAspect as IA
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Content.ItemKind (ItemKind)
import qualified Game.LambdaHack.Content.ItemKind as IK
type ItemKnown = (ItemIdentity, IA.AspectRecord, Maybe FactionId)
type ItemRev = HM.HashMap ItemKnown ItemId
type UniqueSet = ES.EnumSet (ContentId ItemKind)
buildItem :: COps -> FlavourMap -> DiscoveryKindRev
-> ContentId ItemKind -> ItemKind -> LevelId
-> Item
buildItem COps{coitem} (FlavourMap flavourMap) (DiscoveryKindRev discoRev)
ikChosen kind jlid =
let jkind = case IK.getHideAs kind of
Just grp ->
let kindHidden = ouniqGroup coitem grp
in IdentityCovered
(toEnum $ fromEnum $ discoRev U.! contentIdIndex ikChosen)
kindHidden
Nothing -> IdentityObvious ikChosen
jfid = Nothing
jflavour = toEnum $ fromEnum $ flavourMap U.! contentIdIndex ikChosen
in Item{..}
newItem :: COps -> FlavourMap -> DiscoveryKindRev -> UniqueSet
-> Freqs ItemKind -> Int -> LevelId -> Dice.AbsDepth -> Dice.AbsDepth
-> Rnd (Maybe (ItemKnown, ItemFullKit, IA.ItemSeed, GroupName ItemKind))
newItem cops@COps{coitem} flavourMap discoRev uniqueSet
itemFreq lvlSpawned lid
ldepth@(Dice.AbsDepth ldAbs) totalDepth@(Dice.AbsDepth depth) = do
let scaledDepth = ldAbs * 10 `div` depth
numSpawnedCoeff = lvlSpawned `div` 2
ldSpawned = max ldAbs
$ min depth
$ ldAbs + numSpawnedCoeff - scaledDepth
findInterval _ x1y1 [] = (x1y1, (11, 0))
findInterval !ld !x1y1 ((!x, !y) : rest) =
if fromIntegral ld * 10 <= x * fromIntegral depth
then (x1y1, (x, y))
else findInterval ld (x, y) rest
linearInterpolation !ld !dataset =
let ((x1, y1), (x2, y2)) = findInterval ld (0, 0) dataset
in ceiling
$ fromIntegral y1
+ fromIntegral (y2 - y1)
* (fromIntegral ld * 10 - x1 * fromIntegral depth)
/ ((x2 - x1) * fromIntegral depth)
f _ _ acc _ ik _ | ik `ES.member` uniqueSet = acc
f !itemGroup !q !acc !p !ik !kind =
let ld = if IK.Unique `elem` IK.ifeature kind then ldAbs else ldSpawned
rarity = linearInterpolation ld (IK.irarity kind)
in (q * p * rarity, ((ik, kind), itemGroup)) : acc
g (itemGroup, q) = ofoldlGroup' coitem itemGroup (f itemGroup q) []
freqDepth = concatMap g itemFreq
freq = toFreq ("newItem ('" <> tshow ldSpawned <> ")") freqDepth
if nullFreq freq then return Nothing
else do
((itemKindId, itemKind), itemGroup) <- frequency freq
itemN <- castDice ldepth totalDepth (IK.icount itemKind)
seed <- toEnum <$> random
let itemBase = buildItem cops flavourMap discoRev itemKindId itemKind lid
itemIdentity = jkind itemBase
itemK = max 1 itemN
itemTimer = [timeZero | IK.Periodic `elem` IK.ifeature itemKind]
itemSuspect = False
itemDisco = ItemDiscoFull {..}
itemAspect =
IA.seedToAspect seed (IK.iaspects itemKind) ldepth totalDepth
itemFull = ItemFull {..}
return $ Just ( (itemIdentity, itemAspect, jfid itemBase)
, (itemFull, (itemK, itemTimer))
, seed
, itemGroup )
newtype DiscoveryKindRev = DiscoveryKindRev (U.Vector Word16)
deriving (Show, Binary)
type ItemSeedDict = EM.EnumMap ItemId IA.ItemSeed
emptyDiscoveryKindRev :: DiscoveryKindRev
emptyDiscoveryKindRev = DiscoveryKindRev U.empty
serverDiscos :: COps -> Rnd (DiscoveryKind, DiscoveryKindRev)
serverDiscos COps{coitem} = do
let ixs = [toEnum 0..toEnum (olength coitem - 1)]
shuffle :: Eq a => [a] -> Rnd [a]
shuffle [] = return []
shuffle l = do
x <- oneOf l
(x :) <$> shuffle (delete x l)
shuffled <- shuffle ixs
let f (!ikMap, !ikRev, ix : rest) kmKind _ =
(EM.insert ix kmKind ikMap, EM.insert kmKind ix ikRev, rest)
f (ikMap, _, []) ik _ =
error $ "too short ixs" `showFailure` (ik, ikMap)
(discoS, discoRev, _) =
ofoldlWithKey' coitem f (EM.empty, EM.empty, shuffled)
udiscoRev = U.fromListN (olength coitem)
$ map (toEnum . fromEnum) $ EM.elems discoRev
return (discoS, DiscoveryKindRev udiscoRev)
newtype FlavourMap = FlavourMap (U.Vector Word16)
deriving (Show, Binary)
emptyFlavourMap :: FlavourMap
emptyFlavourMap = FlavourMap U.empty
stdFlav :: ES.EnumSet Flavour
stdFlav = ES.fromList [ Flavour fn bc
| fn <- [minBound..maxBound], bc <- Color.stdCol ]
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 key ik = case IK.iflavour ik of
[] -> error "empty iflavour"
[flavour] -> do
(!assocs, !availableMap) <- rnd
return ( EM.insert key flavour assocs
, availableMap)
flvs -> do
(!assocs, !availableMap) <- rnd
let available =
EM.findWithDefault stdFlav (IK.isymbol ik) availableMap
proper = ES.fromList flvs `ES.intersection` available
assert (not (ES.null proper)
`blame` "not enough flavours for items"
`swith` (flvs, available, ik, availableMap)) $ do
flavour <- oneOf $ ES.toList proper
let availableReduced = ES.delete flavour available
return ( EM.insert key flavour assocs
, EM.insert (IK.isymbol ik) availableReduced availableMap)
dungeonFlavourMap :: COps -> Rnd FlavourMap
dungeonFlavourMap COps{coitem} = do
(assocsFlav, _) <- ofoldlWithKey' coitem rollFlavourMap
(return (EM.empty, EM.empty))
let uFlav = U.fromListN (olength coitem)
$ map (toEnum . fromEnum) $ EM.elems assocsFlav
return $! FlavourMap uFlav