{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}
module Game.LambdaHack.Common.Item
(
ItemId, Item(..)
, itemPrice, isMelee, goesIntoEqp, goesIntoInv, goesIntoSha
, AspectRecord(..), DiscoveryAspect
, emptyAspectRecord, sumAspectRecord, aspectRecordToList, meanAspect
, ItemKindIx, ItemSeed, ItemDisco(..), ItemFull(..)
, KindMean(..), DiscoveryKind, ItemIxMap, Benefit(..), DiscoveryBenefit
, itemNoDisco, itemToFull6, aspectsRandom, seedToAspect, aspectRecordFull
, ItemTimer, ItemQuant, ItemBag, ItemDict
#ifdef EXPOSE_INTERNAL
, castAspect, addMeanAspect, ceilingMeanDice
#endif
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import qualified Control.Monad.Trans.State.Strict as St
import Data.Binary
import qualified Data.EnumMap.Strict as EM
import Data.Hashable (Hashable)
import qualified Data.Ix as Ix
import GHC.Generics (Generic)
import System.Random (mkStdGen)
import qualified Game.LambdaHack.Common.Ability as Ability
import Game.LambdaHack.Common.Dice (intToDice)
import qualified Game.LambdaHack.Common.Dice as Dice
import Game.LambdaHack.Common.Flavour
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Common.Time
import qualified Game.LambdaHack.Content.ItemKind as IK
newtype ItemId = ItemId Int
deriving (Show, Eq, Ord, Enum, Binary)
data Item = Item
{ jkindIx :: ItemKindIx
, jlid :: LevelId
, jfid :: Maybe FactionId
, jsymbol :: Char
, jname :: Text
, jflavour :: Flavour
, jfeature :: [IK.Feature]
, jweight :: Int
, jdamage :: Dice.Dice
}
deriving (Show, Eq, Generic)
instance Hashable Item
instance Binary Item
itemPrice :: (Item, Int) -> Int
itemPrice (item, jcount) =
case jsymbol item of
'$' -> jcount
'*' -> jcount * 100
_ -> 0
isMelee :: Item -> Bool
isMelee item = IK.Meleeable `elem` jfeature item
goesIntoEqp :: Item -> Bool
goesIntoEqp item = IK.Equipable `elem` jfeature item
|| IK.Meleeable `elem` jfeature item
goesIntoInv :: Item -> Bool
goesIntoInv item = IK.Precious `notElem` jfeature item
&& not (goesIntoEqp item)
goesIntoSha :: Item -> Bool
goesIntoSha item = IK.Precious `elem` jfeature item
&& not (goesIntoEqp item)
data AspectRecord = AspectRecord
{ aTimeout :: Int
, aHurtMelee :: Int
, aArmorMelee :: Int
, aArmorRanged :: Int
, aMaxHP :: Int
, aMaxCalm :: Int
, aSpeed :: Int
, aSight :: Int
, aSmell :: Int
, aShine :: Int
, aNocto :: Int
, aAggression :: Int
, aSkills :: Ability.Skills
}
deriving (Show, Eq, Ord, Generic)
instance Binary AspectRecord
instance Hashable AspectRecord
type DiscoveryAspect = EM.EnumMap ItemId AspectRecord
emptyAspectRecord :: AspectRecord
emptyAspectRecord = AspectRecord
{ aTimeout = 0
, aHurtMelee = 0
, aArmorMelee = 0
, aArmorRanged = 0
, aMaxHP = 0
, aMaxCalm = 0
, aSpeed = 0
, aSight = 0
, aSmell = 0
, aShine = 0
, aNocto = 0
, aAggression = 0
, aSkills = Ability.zeroSkills
}
sumAspectRecord :: [(AspectRecord, Int)] -> AspectRecord
sumAspectRecord l = AspectRecord
{ aTimeout = 0
, aHurtMelee = sum $ mapScale aHurtMelee l
, aArmorMelee = sum $ mapScale aArmorMelee l
, aArmorRanged = sum $ mapScale aArmorRanged l
, aMaxHP = sum $ mapScale aMaxHP l
, aMaxCalm = sum $ mapScale aMaxCalm l
, aSpeed = sum $ mapScale aSpeed l
, aSight = sum $ mapScale aSight l
, aSmell = sum $ mapScale aSmell l
, aShine = sum $ mapScale aShine l
, aNocto = sum $ mapScale aNocto l
, aAggression = sum $ mapScale aAggression l
, aSkills = EM.unionsWith (+) $ mapScaleAbility l
}
where
mapScale f = map (\(ar, k) -> f ar * k)
mapScaleAbility = map (\(ar, k) -> Ability.scaleSkills k $ aSkills ar)
aspectRecordToList :: AspectRecord -> [IK.Aspect]
aspectRecordToList AspectRecord{..} =
[IK.Timeout $ intToDice aTimeout | aTimeout /= 0]
++ [IK.AddHurtMelee $ intToDice aHurtMelee | aHurtMelee /= 0]
++ [IK.AddArmorMelee $ intToDice aArmorMelee | aArmorMelee /= 0]
++ [IK.AddArmorRanged $ intToDice aArmorRanged | aArmorRanged /= 0]
++ [IK.AddMaxHP $ intToDice aMaxHP | aMaxHP /= 0]
++ [IK.AddMaxCalm $ intToDice aMaxCalm | aMaxCalm /= 0]
++ [IK.AddSpeed $ intToDice aSpeed | aSpeed /= 0]
++ [IK.AddSight $ intToDice aSight | aSight /= 0]
++ [IK.AddSmell $ intToDice aSmell | aSmell /= 0]
++ [IK.AddShine $ intToDice aShine | aShine /= 0]
++ [IK.AddNocto $ intToDice aNocto | aNocto /= 0]
++ [IK.AddAggression $ intToDice aAggression | aAggression /= 0]
++ [IK.AddAbility ab $ intToDice n | (ab, n) <- EM.assocs aSkills, n /= 0]
meanAspect :: IK.ItemKind -> AspectRecord
meanAspect kind = foldl' addMeanAspect emptyAspectRecord (IK.iaspects kind)
addMeanAspect :: AspectRecord -> IK.Aspect -> AspectRecord
addMeanAspect !ar !asp =
case asp of
IK.Timeout d ->
let n = ceilingMeanDice d
in assert (aTimeout ar == 0) $ ar {aTimeout = n}
IK.AddHurtMelee d ->
let n = ceilingMeanDice d
in ar {aHurtMelee = n + aHurtMelee ar}
IK.AddArmorMelee d ->
let n = ceilingMeanDice d
in ar {aArmorMelee = n + aArmorMelee ar}
IK.AddArmorRanged d ->
let n = ceilingMeanDice d
in ar {aArmorRanged = n + aArmorRanged ar}
IK.AddMaxHP d ->
let n = ceilingMeanDice d
in ar {aMaxHP = n + aMaxHP ar}
IK.AddMaxCalm d ->
let n = ceilingMeanDice d
in ar {aMaxCalm = n + aMaxCalm ar}
IK.AddSpeed d ->
let n = ceilingMeanDice d
in ar {aSpeed = n + aSpeed ar}
IK.AddSight d ->
let n = ceilingMeanDice d
in ar {aSight = n + aSight ar}
IK.AddSmell d ->
let n = ceilingMeanDice d
in ar {aSmell = n + aSmell ar}
IK.AddShine d ->
let n = ceilingMeanDice d
in ar {aShine = n + aShine ar}
IK.AddNocto d ->
let n = ceilingMeanDice d
in ar {aNocto = n + aNocto ar}
IK.AddAggression d ->
let n = ceilingMeanDice d
in ar {aAggression = n + aAggression ar}
IK.AddAbility ab d ->
let n = ceilingMeanDice d
in ar {aSkills = Ability.addSkills (EM.singleton ab n)
(aSkills ar)}
ceilingMeanDice :: Dice.Dice -> Int
ceilingMeanDice d = ceiling $ Dice.meanDice d
newtype ItemKindIx = ItemKindIx Int
deriving (Show, Eq, Ord, Enum, Ix.Ix, Hashable, Binary)
newtype ItemSeed = ItemSeed Int
deriving (Show, Eq, Ord, Enum, Hashable, Binary)
data ItemDisco = ItemDisco
{ itemKindId :: Kind.Id IK.ItemKind
, itemKind :: IK.ItemKind
, itemAspectMean :: AspectRecord
, itemConst :: Bool
, itemAspect :: Maybe AspectRecord
}
deriving Show
data ItemFull = ItemFull
{ itemBase :: Item
, itemK :: Int
, itemTimer :: ItemTimer
, itemDisco :: Maybe ItemDisco
}
deriving Show
data KindMean = KindMean
{ kmKind :: Kind.Id IK.ItemKind
, kmMean :: AspectRecord
, kmConst :: Bool
}
deriving (Show, Eq, Generic)
instance Binary KindMean
type DiscoveryKind = EM.EnumMap ItemKindIx KindMean
type ItemIxMap = EM.EnumMap ItemKindIx [ItemId]
data Benefit = Benefit
{ benInEqp :: ~Bool
, benPickup :: ~Double
, benApply :: ~Double
, benMelee :: ~Double
, benFling :: ~Double
}
deriving (Show, Generic)
instance Binary Benefit
type DiscoveryBenefit = EM.EnumMap ItemId Benefit
itemNoDisco :: (Item, Int) -> ItemFull
itemNoDisco (itemBase, itemK) =
ItemFull {itemBase, itemK, itemTimer = [], itemDisco=Nothing}
itemToFull6 :: Kind.COps -> DiscoveryKind -> DiscoveryAspect -> ItemId -> Item
-> ItemQuant
-> ItemFull
itemToFull6 Kind.COps{coitem=Kind.Ops{okind}}
discoKind discoAspect iid itemBase (itemK, itemTimer) =
let itemDisco = case EM.lookup (jkindIx itemBase) discoKind of
Nothing -> Nothing
Just KindMean{..} ->
Just ItemDisco{ itemKindId = kmKind
, itemKind = okind kmKind
, itemAspectMean = kmMean
, itemConst = kmConst
, itemAspect = EM.lookup iid discoAspect }
in ItemFull {..}
aspectsRandom :: IK.ItemKind -> Bool
aspectsRandom kind =
let rollM depth = foldlM' (castAspect (AbsDepth depth) (AbsDepth 10))
emptyAspectRecord (IK.iaspects kind)
gen = mkStdGen 0
(ar0, gen0) = St.runState (rollM 0) gen
(ar1, gen1) = St.runState (rollM 10) gen0
in show gen /= show gen0 || show gen /= show gen1 || ar0 /= ar1
seedToAspect :: ItemSeed -> IK.ItemKind -> AbsDepth -> AbsDepth -> AspectRecord
seedToAspect (ItemSeed itemSeed) kind ldepth totalDepth =
let rollM = foldlM' (castAspect ldepth totalDepth) emptyAspectRecord
(IK.iaspects kind)
in St.evalState rollM (mkStdGen itemSeed)
castAspect :: AbsDepth -> AbsDepth -> AspectRecord -> IK.Aspect
-> Rnd AspectRecord
castAspect !ldepth !totalDepth !ar !asp =
case asp of
IK.Timeout d -> do
n <- castDice ldepth totalDepth d
return $! assert (aTimeout ar == 0) $ ar {aTimeout = n}
IK.AddHurtMelee d -> do
n <- castDice ldepth totalDepth d
return $! ar {aHurtMelee = n + aHurtMelee ar}
IK.AddArmorMelee d -> do
n <- castDice ldepth totalDepth d
return $! ar {aArmorMelee = n + aArmorMelee ar}
IK.AddArmorRanged d -> do
n <- castDice ldepth totalDepth d
return $! ar {aArmorRanged = n + aArmorRanged ar}
IK.AddMaxHP d -> do
n <- castDice ldepth totalDepth d
return $! ar {aMaxHP = n + aMaxHP ar}
IK.AddMaxCalm d -> do
n <- castDice ldepth totalDepth d
return $! ar {aMaxCalm = n + aMaxCalm ar}
IK.AddSpeed d -> do
n <- castDice ldepth totalDepth d
return $! ar {aSpeed = n + aSpeed ar}
IK.AddSight d -> do
n <- castDice ldepth totalDepth d
return $! ar {aSight = n + aSight ar}
IK.AddSmell d -> do
n <- castDice ldepth totalDepth d
return $! ar {aSmell = n + aSmell ar}
IK.AddShine d -> do
n <- castDice ldepth totalDepth d
return $! ar {aShine = n + aShine ar}
IK.AddNocto d -> do
n <- castDice ldepth totalDepth d
return $! ar {aNocto = n + aNocto ar}
IK.AddAggression d -> do
n <- castDice ldepth totalDepth d
return $! ar {aAggression = n + aAggression ar}
IK.AddAbility ab d -> do
n <- castDice ldepth totalDepth d
return $! ar {aSkills = Ability.addSkills (EM.singleton ab n)
(aSkills ar)}
aspectRecordFull :: ItemFull -> AspectRecord
aspectRecordFull itemFull =
case itemDisco itemFull of
Just ItemDisco{itemAspect=Just aspectRecord} -> aspectRecord
Just ItemDisco{itemAspectMean} -> itemAspectMean
Nothing -> emptyAspectRecord
type ItemTimer = [Time]
type ItemQuant = (Int, ItemTimer)
type ItemBag = EM.EnumMap ItemId ItemQuant
type ItemDict = EM.EnumMap ItemId Item