module Game.LambdaHack.Item
(
Item(..), newItem, viewItem, itemPrice
, strongestSearch, strongestSword, strongestRegen
, joinItem, removeItemByLetter, equalItemIdentity, removeItemByIdentity
, assignLetter
, letterLabel, cmpLetterMaybe, maxLetter, letterRange
, FlavourMap, getFlavour, dungeonFlavourMap
, Discoveries
) where
import Data.Binary
import qualified Data.Set as S
import qualified Data.List as L
import qualified Data.Map as M
import Data.Maybe
import Data.Char
import Data.Function
import Data.Ord
import Control.Monad
import Game.LambdaHack.Utils.Assert
import Game.LambdaHack.Random
import Game.LambdaHack.Content.ItemKind
import Game.LambdaHack.Content.RuleKind
import qualified Game.LambdaHack.Color as Color
import Game.LambdaHack.Flavour
import qualified Game.LambdaHack.Kind as Kind
import Game.LambdaHack.Effect
data Item = Item
{ jkind :: !(Kind.Id ItemKind)
, jpower :: !Int
, jletter :: Maybe Char
, jcount :: !Int
}
deriving Show
instance Binary Item where
put (Item ik ip il ic ) =
put ik >> put ip >> put il >> put ic
get = liftM4 Item get get get get
newItem :: Kind.Ops ItemKind -> Int -> Int -> Rnd Item
newItem cops@Kind.Ops{opick, okind} lvl depth = do
ikChosen <- opick "dng" (const True)
let kind = okind ikChosen
count <- rollDeep lvl depth (icount kind)
if count == 0
then newItem cops lvl depth
else do
power <- rollDeep lvl depth (ipower kind)
return $ Item ikChosen power (itemLetter kind) count
viewItem :: Kind.Ops ItemKind -> Kind.Id ItemKind -> FlavourMap
-> (Char, Color.Color)
viewItem cops@Kind.Ops{osymbol} ik assocs =
(osymbol ik, flavourToColor $ getFlavour cops assocs ik)
itemPrice :: Kind.Ops ItemKind -> Item -> Int
itemPrice Kind.Ops{osymbol} i =
case osymbol (jkind i) of
'$' -> jcount i
'*' -> jcount i * 100
_ -> 0
type Discoveries = S.Set (Kind.Id ItemKind)
type FlavourMap = M.Map (Kind.Id ItemKind) Flavour
rollFlavourMap :: Kind.Id ItemKind -> ItemKind
-> Rnd (FlavourMap, S.Set Flavour)
-> Rnd (FlavourMap, S.Set Flavour)
rollFlavourMap key ik rnd =
let flavours = iflavour ik
in if L.length flavours == 1
then rnd
else do
(assocs, available) <- rnd
let proper = S.fromList flavours `S.intersection` available
flavour <- oneOf (S.toList proper)
return (M.insert key flavour assocs, S.delete flavour available)
dungeonFlavourMap :: Kind.Ops ItemKind -> Rnd FlavourMap
dungeonFlavourMap Kind.Ops{ofoldrWithKey} =
liftM fst $
ofoldrWithKey rollFlavourMap (return (M.empty, S.fromList stdFlav))
getFlavour :: Kind.Ops ItemKind -> FlavourMap -> Kind.Id ItemKind -> Flavour
getFlavour Kind.Ops{okind} assocs ik =
let kind = okind ik
in case iflavour kind of
[] -> assert `failure` (assocs, ik, kind)
[f] -> f
_:_ -> assocs M.! ik
itemLetter :: ItemKind -> Maybe Char
itemLetter ik = if isymbol ik == '$' then Just '$' else Nothing
assignLetter :: Maybe Char -> Char -> [Item] -> Maybe Char
assignLetter r c is =
case r of
Just l | l `elem` allowed -> Just l
_ -> listToMaybe free
where
current = S.fromList (mapMaybe jletter is)
allLetters = ['a'..'z'] ++ ['A'..'Z']
candidates = take (length allLetters) $
drop (fromJust (L.findIndex (== c) allLetters)) $
cycle allLetters
free = L.filter (\x -> not (x `S.member` current)) candidates
allowed = '$' : free
cmpLetter :: Char -> Char -> Ordering
cmpLetter x y = compare (isUpper x, toLower x) (isUpper y, toLower y)
cmpLetterMaybe :: Maybe Char -> Maybe Char -> Ordering
cmpLetterMaybe Nothing Nothing = EQ
cmpLetterMaybe Nothing (Just _) = GT
cmpLetterMaybe (Just _) Nothing = LT
cmpLetterMaybe (Just l) (Just l') = cmpLetter l l'
maxBy :: (a -> a -> Ordering) -> a -> a -> a
maxBy cmp x y = case cmp x y of
LT -> y
_ -> x
maxLetter :: Char -> Char -> Char
maxLetter = maxBy cmpLetter
mergeLetter :: Maybe Char -> Maybe Char -> Maybe Char
mergeLetter = mplus
letterRange :: [Char] -> String
letterRange ls =
sectionBy (L.sortBy cmpLetter ls) Nothing
where
succLetter c d = ord d ord c == 1
sectionBy [] Nothing = ""
sectionBy [] (Just (c,d)) = finish (c,d)
sectionBy (x:xs) Nothing = sectionBy xs (Just (x,x))
sectionBy (x:xs) (Just (c,d))
| succLetter d x = sectionBy xs (Just (c,x))
| otherwise = finish (c,d) ++ sectionBy xs (Just (x,x))
finish (c,d) | c == d = [c]
| succLetter c d = [c,d]
| otherwise = [c,'-',d]
letterLabel :: Maybe Char -> String
letterLabel Nothing = " "
letterLabel (Just c) = c : " - "
joinItem :: Item -> [Item] -> (Item, [Item])
joinItem i is =
case findItem (equalItemIdentity i) is of
Nothing -> (i, i : is)
Just (j,js) -> let n = i { jcount = jcount i + jcount j,
jletter = mergeLetter (jletter j) (jletter i) }
in (n, n : js)
removeItemBy :: (Item -> Item -> Bool) -> Item -> [Item] -> [Item]
removeItemBy eq i = concatMap $ \ x ->
if eq i x
then let remaining = jcount x jcount i
in if remaining > 0
then [x { jcount = remaining }]
else []
else [x]
equalItemIdentity :: Item -> Item -> Bool
equalItemIdentity i1 i2 = jpower i1 == jpower i2 && jkind i1 == jkind i2
removeItemByIdentity :: Item -> [Item] -> [Item]
removeItemByIdentity = removeItemBy equalItemIdentity
equalItemLetter :: Item -> Item -> Bool
equalItemLetter = (==) `on` jletter
removeItemByLetter :: Item -> [Item] -> [Item]
removeItemByLetter = removeItemBy equalItemLetter
findItem :: (Item -> Bool) -> [Item] -> Maybe (Item, [Item])
findItem p =
findItem' []
where
findItem' _ [] = Nothing
findItem' acc (i:is)
| p i = Just (i, reverse acc ++ is)
| otherwise = findItem' (i:acc) is
strongestItem :: [Item] -> (Item -> Bool) -> Maybe Item
strongestItem is p =
let cmp = comparing jpower
igs = L.filter p is
in case igs of
[] -> Nothing
_ -> Just $ L.maximumBy cmp igs
strongestSearch :: Kind.Ops ItemKind -> [Item] -> Maybe Item
strongestSearch Kind.Ops{okind} bitems =
strongestItem bitems $ \ i -> (ieffect $ okind $ jkind i) == Searching
strongestSword :: Kind.COps -> [Item] -> Maybe Item
strongestSword Kind.COps{coitem=Kind.Ops{osymbol}, corule} bitems =
strongestItem bitems $ \ i -> (osymbol $ jkind i)
`elem` (ritemMelee $ Kind.stdRuleset corule)
strongestRegen :: Kind.Ops ItemKind -> [Item] -> Maybe Item
strongestRegen Kind.Ops{okind} bitems =
strongestItem bitems $ \ i -> (ieffect $ okind $ jkind i) == Regeneration