module Game.LambdaHack.Server.ItemRev
( ItemRev, buildItem, newItem
, DiscoveryKindRev, serverDiscos, ItemSeedDict
, FlavourMap, emptyFlavourMap, dungeonFlavourMap
) where
import Control.Exception.Assert.Sugar
import Control.Monad
import Data.Binary
import qualified Data.EnumMap.Strict as EM
import qualified Data.HashMap.Strict as HM
import qualified Data.Ix as Ix
import Data.List
import qualified Data.Set as S
import Game.LambdaHack.Common.Flavour
import Game.LambdaHack.Common.Frequency
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Msg
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Content.ItemKind (ItemKind)
import qualified Game.LambdaHack.Content.ItemKind as IK
type DiscoveryKindRev = EM.EnumMap (Kind.Id ItemKind) ItemKindIx
type ItemSeedDict = EM.EnumMap ItemId ItemSeed
serverDiscos :: Kind.COps -> Rnd (DiscoveryKind, DiscoveryKindRev)
serverDiscos Kind.COps{coitem=Kind.Ops{obounds, ofoldrWithKey}} = do
let ixs = map toEnum $ take (Ix.rangeSize obounds) [0..]
shuffle :: Eq a => [a] -> Rnd [a]
shuffle [] = return []
shuffle l = do
x <- oneOf l
fmap (x :) $ shuffle (delete x l)
shuffled <- shuffle ixs
let f ik _ (ikMap, ikRev, ix : rest) =
(EM.insert ix ik ikMap, EM.insert ik ix ikRev, rest)
f ik _ (ikMap, _, []) =
assert `failure` "too short ixs" `twith` (ik, ikMap)
(discoS, discoRev, _) =
ofoldrWithKey f (EM.empty, EM.empty, shuffled)
return (discoS, discoRev)
buildItem :: FlavourMap -> DiscoveryKindRev -> Kind.Id ItemKind -> ItemKind -> LevelId
-> Item
buildItem (FlavourMap flavour) discoRev ikChosen kind jlid =
let jkindIx = discoRev EM.! ikChosen
jsymbol = IK.isymbol kind
jname = IK.iname kind
jflavour =
case IK.iflavour kind of
[fl] -> fl
_ -> flavour EM.! ikChosen
jfeature = IK.ifeature kind
jweight = IK.iweight kind
in Item{..}
newItem :: Kind.COps -> FlavourMap -> DiscoveryKindRev
-> Freqs ItemKind -> LevelId -> AbsDepth -> AbsDepth
-> Rnd (Maybe (ItemKnown, ItemFull, ItemSeed, GroupName ItemKind))
newItem Kind.COps{coitem=Kind.Ops{ofoldrGroup}}
flavour discoRev itemFreq jlid
ldepth@(AbsDepth ld) totalDepth@(AbsDepth depth) = do
let findInterval x1y1 [] = (x1y1, (11, 0))
findInterval x1y1 ((x, y) : rest) =
if ld * 10 <= x * depth
then (x1y1, (x, y))
else findInterval (x, y) rest
linearInterpolation dataset =
let ((x1, y1), (x2, y2)) = findInterval (0, 0) dataset
in y1 + (y2 y1) * (ld * 10 x1 * depth)
`divUp` ((x2 x1) * depth)
f itemGroup q p ik kind acc =
let rarity = linearInterpolation (IK.irarity kind)
in (q * p * rarity, ((ik, kind), itemGroup)) : acc
g (itemGroup, q) = ofoldrGroup itemGroup (f itemGroup q) []
freqDepth = concatMap g itemFreq
freq = toFreq ("newItem ('" <> tshow ld <> ")") freqDepth
if nullFreq freq then return Nothing
else do
((itemKindId, itemKind), itemGroup) <- frequency freq
itemN <- castDice ldepth totalDepth (IK.icount itemKind)
seed <- fmap toEnum random
let itemBase = buildItem flavour discoRev itemKindId itemKind jlid
itemK = max 1 itemN
itemTimer = []
itemDisco = Just ItemDisco {itemKindId, itemKind, itemAE = Just iae}
iae = seedToAspectsEffects seed itemKind ldepth totalDepth
itemFull = ItemFull {..}
return $ Just ( (jkindIx itemBase, iae)
, itemFull
, seed
, itemGroup )
newtype FlavourMap = FlavourMap (EM.EnumMap (Kind.Id ItemKind) Flavour)
deriving (Show, Binary)
emptyFlavourMap :: FlavourMap
emptyFlavourMap = FlavourMap EM.empty
rollFlavourMap :: S.Set Flavour -> Kind.Id ItemKind -> ItemKind
-> Rnd ( EM.EnumMap (Kind.Id ItemKind) Flavour
, EM.EnumMap Char (S.Set Flavour) )
-> Rnd ( EM.EnumMap (Kind.Id ItemKind) Flavour
, EM.EnumMap Char (S.Set Flavour) )
rollFlavourMap fullFlavSet key ik rnd =
let flavours = IK.iflavour ik
in if length flavours == 1
then rnd
else do
(assocs, availableMap) <- rnd
let available =
EM.findWithDefault fullFlavSet (IK.isymbol ik) availableMap
proper = S.fromList flavours `S.intersection` available
assert (not (S.null proper)
`blame` "not enough flavours for items"
`twith` (flavours, available, ik, availableMap)) $ do
flavour <- oneOf (S.toList proper)
let availableReduced = S.delete flavour available
return ( EM.insert key flavour assocs
, EM.insert (IK.isymbol ik) availableReduced availableMap)
dungeonFlavourMap :: Kind.COps -> Rnd FlavourMap
dungeonFlavourMap Kind.COps{coitem=Kind.Ops{ofoldrWithKey}} =
liftM (FlavourMap . fst) $
ofoldrWithKey (rollFlavourMap (S.fromList stdFlav))
(return (EM.empty, EM.empty))
type ItemRev = HM.HashMap ItemKnown ItemId