LambdaHack-0.1.20090606: 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 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
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
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
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
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),
(30, Gem),
(20, Ring),
(40, Scroll),
(20, Wand),
(10, Amulet),
(30, Potion PotionWater),
(10, Potion PotionHealing)
]
itemQuantity :: Int -> ItemType -> Rnd Int
itemQuantity n Gold = (2 * n) *~ d 8
itemQuantity _ _ = return 1
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
nr <- itemQuantity n tp
return (Item nr tp (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' 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 (\ j -> itype i == itype j) 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)
-- | 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
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")
objectItem :: Assocs -> Discoveries -> Int -> ItemType -> String
objectItem _ _ n Ring = makeObject n id "ring"
objectItem _ _ n Scroll = makeObject n id "scroll"
objectItem a d n (Potion t) = makeObject n (identified a d (Potion t)) "potion"
objectItem _ _ n Wand = makeObject n id "wand"
objectItem _ _ n Amulet = makeObject n id "amulet"
objectItem _ _ n Gem = makeObject n id "gem"
objectItem _ _ n Gold = makeObject n id "gold piece"
identified :: Assocs -> Discoveries -> ItemType -> String -> String
identified a d i
| i `S.member` d = case i of
Potion t -> potionType t
_ -> ("really strange " ++)
| otherwise = case M.lookup i a of
Just ap -> appearance ap
_ -> ("really strange " ++)