LambdaHack-0.1.20110117: src/Item.hs
module Item where
import Data.Binary
import Data.Map as M
import Data.Set as S
import Data.List as L
import Data.Maybe
import Data.Char
import Data.Function
import Control.Monad
import Display
import Geometry
import Random
data Item = Item
{ icount :: Int,
itype :: ItemType,
iletter :: Maybe Char } -- inventory identifier
deriving Show
data ItemType =
Ring
| Scroll
| Potion PotionType
| Wand
| Amulet
| Gem
| Gold
| Sword Int
deriving (Eq, Ord, Show)
data PotionType =
PotionWater
| PotionHealing
deriving (Eq, Ord, Show)
data Appearance =
Clear
| White
deriving (Eq, Show)
type Assocs = M.Map ItemType Appearance
type Discoveries = S.Set ItemType
equalItemType :: Item -> Item -> Bool
equalItemType = (==) `on` itype
equalItemLetter :: Item -> Item -> Bool
equalItemLetter = (==) `on` iletter
potionType :: PotionType -> String -> String
potionType PotionWater s = s ++ " of water"
potionType PotionHealing s = s ++ " of healing"
appearance :: Appearance -> String -> String
appearance Clear s = "clear " ++ s
appearance White s = "white " ++ s
instance Binary Item where
put (Item icount itype iletter) = put icount >> put itype >> put iletter
get = liftM3 Item get get get
instance Binary ItemType where
put Ring = putWord8 0
put Scroll = putWord8 1
put (Potion t) = putWord8 2 >> put t
put Wand = putWord8 3
put Amulet = putWord8 4
put Gem = putWord8 5
put Gold = putWord8 6
put (Sword i) = putWord8 7 >> put i
get = do
tag <- getWord8
case tag of
0 -> return Ring
1 -> return Scroll
2 -> liftM Potion get
3 -> return Wand
4 -> return Amulet
5 -> return Gem
6 -> return Gold
7 -> liftM Sword get
instance Binary PotionType where
put PotionWater = putWord8 0
put PotionHealing = putWord8 1
get = do
tag <- getWord8
case tag of
0 -> return PotionWater
1 -> return PotionHealing
instance Binary Appearance where
put Clear = putWord8 0
put White = putWord8 1
get = do
tag <- getWord8
case tag of
0 -> return Clear
1 -> return White
itemFrequency :: Frequency ItemType
itemFrequency =
Frequency
[
(100, Gold),
(70, Sword (-1)),
(30, Gem),
(20, Ring),
(30, Scroll),
(10, Wand),
(10, Amulet),
(30, Potion PotionWater),
(20, Potion PotionHealing)
]
itemQuantity :: Int -> ItemType -> Rnd Int
itemQuantity n Gold = (2 * n) *~ d 8
itemQuantity _ _ = return 1
itemStrength :: Int -> ItemType -> Rnd ItemType
itemStrength n (Sword _) =
do
r <- d (2 + n `div` 2)
return $ Sword $ (n + 1) `div` 3 + r
itemStrength _ tp = return tp
itemLetter :: ItemType -> Maybe Char
itemLetter Gold = Just '$'
itemLetter _ = Nothing
-- | Generate an item.
newItem :: Int -> Frequency ItemType -> Rnd Item
newItem n ftp =
do
tp <- frequency ftp
item <- itemStrength n tp
nr <- itemQuantity n tp
return (Item nr item (itemLetter tp))
-- | Assigns a letter to an item, for inclusion
-- in the inventory of the player. Takes a remembered
-- letter and a starting letter.
assignLetter :: Maybe Char -> Char -> [Item] -> Maybe Char
assignLetter r c is =
case r of
Just l | l `L.elem` allowed -> Just l
_ -> listToMaybe free
where
current = S.fromList (concatMap (maybeToList . iletter) 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)
cmpLetter' :: Maybe Char -> Maybe Char -> Ordering
cmpLetter' Nothing Nothing = EQ
cmpLetter' Nothing (Just _) = GT
cmpLetter' (Just _) Nothing = LT
cmpLetter' (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 = maxBy cmpLetter
mergeLetter :: Maybe Char -> Maybe Char -> Maybe Char
mergeLetter = mplus
letterRange :: [Char] -> String
letterRange xs = sectionBy (sortBy cmpLetter xs) 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 : " - "
viewItem :: ItemType -> Assocs -> (Char, Attr -> Attr)
viewItem i a = viewItem' i (M.lookup i a)
where
viewItem' (Sword {}) _ = (')', id)
viewItem' Ring _ = ('=', id)
viewItem' Scroll _ = ('?', id)
viewItem' (Potion {}) (Just Clear) = ('!', setBold . setFG blue)
viewItem' (Potion {}) (Just White) = ('!', setBold . setFG white)
viewItem' (Potion {}) _ = ('!', id)
viewItem' Wand _ = ('/', id)
viewItem' Gold _ = ('$', setBold . setFG yellow)
viewItem' Gem _ = ('*', setFG red)
viewItem' Amulet _ = ('"', id)
viewItem' _ _ = ('~', id)
-- | Adds an item to a list of items, joining equal items.
-- Also returns the joined item.
joinItem :: Item -> [Item] -> (Item,[Item])
joinItem i is = case findItem (equalItemType i) is of
Nothing -> (i, i : is)
Just (j,js) -> let n = i { icount = icount i + icount j,
iletter = mergeLetter (iletter j) (iletter i) }
in (n, n : js)
-- | Removes an item from a list of items. Takes an equality function (i.e., by letter or
-- by type) as an argument.
removeItemBy :: (Item -> Item -> Bool) -> Item -> [Item] -> [Item]
removeItemBy eq i = concatMap $ \ x ->
if eq i x
then let remaining = icount x - icount i
in if remaining > 0
then [x { icount = remaining }]
else []
else [x]
removeItemByLetter = removeItemBy equalItemLetter
removeItemByType = removeItemBy equalItemType
-- | Finds an item in a list of items.
findItem :: (Item -> Bool) -> [Item] -> Maybe (Item, [Item])
findItem p is = findItem' [] is
where
findItem' acc [] = Nothing
findItem' acc (i:is)
| p i = Just (i, reverse acc ++ is)
| otherwise = findItem' (i:acc) is
strongestSword :: [Item] -> Int
strongestSword l =
let aux acc (Item { itype = Sword i }) = max acc i
aux acc _ = acc
in foldl aux 0 l
makeObject :: Int -> (String -> String) -> String -> String
makeObject 1 adj obj = let b = adj obj
in case b of
(c:_) | c `elem` "aeio" -> "an " ++ b
_ -> "a " ++ b
makeObject n adj obj = show n ++ " " ++ adj (obj ++ "s")