module Game.LambdaHack.Server.ItemRev
( ItemRev, buildItem, newItem
, DiscoRev, 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 Data.Text (Text)
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
type DiscoRev = EM.EnumMap (Kind.Id ItemKind) ItemKindIx
type ItemSeedDict = EM.EnumMap ItemId ItemSeed
serverDiscos :: Kind.Ops ItemKind -> Rnd (Discovery, DiscoRev)
serverDiscos 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 -> DiscoRev -> Kind.Id ItemKind -> ItemKind -> LevelId
-> Item
buildItem (FlavourMap flavour) discoRev ikChosen kind jlid =
let jkindIx = discoRev EM.! ikChosen
jsymbol = isymbol kind
jname = iname kind
jflavour =
case iflavour kind of
[fl] -> fl
_ -> flavour EM.! ikChosen
jfeature = ifeature kind
jweight = iweight kind
in Item{..}
newItem :: Kind.COps -> FlavourMap -> DiscoRev
-> Freqs -> LevelId -> AbsDepth -> AbsDepth
-> Rnd (Maybe (ItemKnown, ItemFull, ItemSeed, Int, Text))
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 (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 (icount itemKind)
seed <- fmap toEnum random
let itemBase = buildItem flavour discoRev itemKindId itemKind jlid
itemK = max 1 itemN
iae = seedToAspectsEffects seed itemKind ldepth totalDepth
itemFull = ItemFull {itemBase, itemK, itemDisco = Just itemDisco}
itemDisco = ItemDisco {itemKindId, itemKind, itemAE = Just iae}
return $ Just ( (itemBase, iae)
, itemFull
, seed
, itemK
, 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 = iflavour ik
in if length flavours == 1
then rnd
else do
(assocs, availableMap) <- rnd
let available = EM.findWithDefault fullFlavSet (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 (isymbol ik) availableReduced availableMap)
dungeonFlavourMap :: Kind.Ops ItemKind -> Rnd FlavourMap
dungeonFlavourMap Kind.Ops{ofoldrWithKey} =
liftM (FlavourMap . fst) $
ofoldrWithKey (rollFlavourMap (S.fromList stdFlav))
(return (EM.empty, EM.empty))
type ItemRev = HM.HashMap ItemKnown ItemId