LambdaHack-0.1.20080413: Level.hs
module Level where
import qualified System.Random as R
import Control.Monad
import Data.Binary
import Data.Map as M
import Data.Set as S
import Data.List as L
import Data.Ratio
import Data.Maybe
import Geometry
import Monster
import Item
import Random
import Display
-- | Names of the dungeon levels are represented using a
-- custom data structure.
data LevelName = LambdaCave Int | Exit
deriving (Show, Eq, Ord)
instance Binary LevelName where
put (LambdaCave n) = put n
get = liftM LambdaCave get
-- | Provide a textual description of a level name.
levelName :: LevelName -> String
levelName (LambdaCave n) = "The Lambda Cave " ++ show n
-- | The complete dungeon is a map from level names to levels.
-- We usually store all but the current level in this data structure.
data Dungeon = Dungeon (M.Map LevelName Level)
deriving Show
-- | Create a dungeon from a list of levels.
dungeon :: [Level] -> Dungeon
dungeon = Dungeon . M.fromList . L.map (\ l -> (lname l, l))
-- | Extract a level from a dungeon.
getDungeonLevel :: LevelName -> Dungeon -> (Level, Dungeon)
getDungeonLevel ln (Dungeon dng) = (fromJust (M.lookup ln dng), Dungeon (M.delete ln dng))
-- | Put a level into a dungeon.
putDungeonLevel :: Level -> Dungeon -> Dungeon
putDungeonLevel lvl (Dungeon dng) = Dungeon (M.insert (lname lvl) lvl dng)
instance Binary Dungeon where
put (Dungeon dng) = put (M.elems dng)
get = liftM dungeon get
-- | A dungeon location is a level together with a location on
-- that level.
type DungeonLoc = (LevelName, Loc)
data Level = Level
{ lname :: LevelName,
lsize :: (Y,X),
lmonsters :: [Monster],
lsmell :: SMap,
lmap :: LMap,
lmeta :: String }
deriving Show
updateLMap :: Level -> (LMap -> LMap) -> Level
updateLMap lvl f = lvl { lmap = f (lmap lvl) }
updateMonsters :: Level -> ([Monster] -> [Monster]) -> Level
updateMonsters lvl f = lvl { lmonsters = f (lmonsters lvl) }
instance Binary Level where
put (Level nm sz@(sy,sx) ms lsmell lmap lmeta) =
do
put nm
put sz
put ms
put [ lsmell ! (y,x) | y <- [0..sy], x <- [0..sx] ]
put [ lmap ! (y,x) | y <- [0..sy], x <- [0..sx] ]
put lmeta
get = do
nm <- get
sz@(sy,sx) <- get
ms <- get
xs <- get
let lsmell = M.fromList (zip [ (y,x) | y <- [0..sy], x <- [0..sx] ] xs)
xs <- get
let lmap = M.fromList (zip [ (y,x) | y <- [0..sy], x <- [0..sx] ] xs)
lmeta <- get
return (Level nm sz ms lsmell lmap lmeta)
type LMap = Map (Y,X) (Tile,Tile)
type SMap = Map (Y,X) Time
data Tile = Tile
{ tterrain :: Terrain,
titems :: [Item] }
deriving Show
instance Binary Tile where
put (Tile t is) = put t >> put is
get = liftM2 Tile get get
at l p = fst (findWithDefault (unknown, unknown) p l)
rememberAt l p = snd (findWithDefault (unknown, unknown) p l)
unknown :: Tile
unknown = Tile Unknown []
data Terrain = Rock
| Opening HV
| Floor
| Unknown
| Corridor
| Wall HV
| Stairs VDir (Maybe DungeonLoc)
| Door HV (Maybe Int) -- Nothing: open, Just 0: closed, otherwise secret
deriving Show
instance Binary Terrain where
put Rock = putWord8 0
put (Opening d) = putWord8 1 >> put d
put Floor = putWord8 2
put Unknown = putWord8 3
put Corridor = putWord8 4
put (Wall d) = putWord8 5 >> put d
put (Stairs d n) = putWord8 6 >> put d >> put n
put (Door d o) = putWord8 7 >> put d >> put o
get = do
tag <- getWord8
case tag of
0 -> return Rock
1 -> liftM Opening get
2 -> return Floor
3 -> return Unknown
4 -> return Corridor
5 -> liftM Wall get
6 -> liftM2 Stairs get get
7 -> liftM2 Door get get
_ -> fail "no parse (Tile)"
data HV = Horiz | Vert
deriving (Eq, Show, Bounded)
fromHV Horiz = True
fromHV Vert = False
toHV True = Horiz
toHV False = Vert
instance R.Random HV where
randomR (a,b) g = case R.randomR (fromHV a,fromHV b) g of
(b,g') -> (toHV b,g')
random g = R.randomR (minBound, maxBound) g
instance Binary HV where
put Horiz = put True
put Vert = put False
get = get >>= \ b -> if b then return Horiz else return Vert
data VDir = Up | Down
deriving (Eq, Show)
instance Binary VDir where
put Up = put True
put Down = put False
get = get >>= \ b -> if b then return Up else return Down
instance Eq Terrain where
Rock == Rock = True
Opening d == Opening d' = d == d'
Floor == Floor = True
Unknown == Unknown = True
Corridor == Corridor = True
Wall d == Wall d' = d == d'
Stairs d _ == Stairs d' _ = d == d'
Door d o == Door d' o' = d == d' && o == o'
_ == _ = False
-- | blocks moves and vision
closed :: Tile -> Bool
closed = not . open
secret :: Maybe Int -> Bool
secret (Just n) | n /= 0 = True
secret _ = False
toOpen :: Bool -> Maybe Int
toOpen True = Nothing
toOpen False = Just 0
-- | allows moves and vision
open :: Tile -> Bool
open (Tile Floor _) = True
open (Tile (Opening _) _) = True
open (Tile (Door _ o) _) = isNothing o
open (Tile Corridor _) = True
open (Tile (Stairs _ _) _) = True
open _ = False
-- | is lighted on its own
light :: Tile -> Bool
light (Tile Floor _) = True
light (Tile (Opening _) _) = True
light (Tile (Door _ Nothing) _) = True -- open doors are all visible currently
light (Tile (Stairs _ _) _) = True
light (Tile (Wall _) _) = False
light _ = False
-- | reflects light from adjacent positions;
-- exclusively passive: cannot be seen from an adjacent position in darkness
passive :: Tile -> (Bool,[(Y,X)]) -- exclusively passive?
passive (Tile (Wall Horiz) _) = (True, vert ++ [(-1,1),(1,1),(-1,-1),(1,-1)]) -- for corners
passive (Tile (Wall Vert) _) = (True, horiz)
passive (Tile (Door Horiz (Just 0)) _) = (False, vert)
passive (Tile (Door Vert (Just 0)) _) = (False, horiz)
passive (Tile (Door Horiz (Just n)) _) = (True, vert)
passive (Tile (Door Vert (Just n)) _) = (True, horiz)
passive _ = (False, [])
-- checks for the presence of monsters (and items); it does *not* check
-- if the tile is open ...
unoccupied :: [Monster] -> LMap -> Loc -> Bool
unoccupied monsters lvl loc =
all (\ m -> mloc m /= loc) monsters
-- check whether one location is accessible from the other
-- precondition: the two locations are next to each other
-- currently only implements that doors aren't accessible diagonally,
-- and that the target location has to be open
accessible :: LMap -> Loc -> Loc -> Bool
accessible lvl source target =
let dir = shift source (neg target)
src = lvl `at` source
tgt = lvl `at` target
in open tgt &&
(not (diagonal dir) ||
case (tterrain src, tterrain tgt) of
(Door _ _, _) -> False
(_, Door _ _) -> False
_ -> True)
horiz = [(0,-1),(0,1)]
vert = [(-1,0),(1,0)]
findLocInArea :: Area -> (Loc -> Bool) -> Rnd Loc
findLocInArea a@((y0,x0),(y1,x1)) p =
do
rx <- randomR (x0,x1)
ry <- randomR (y0,y1)
let loc = (ry,rx)
if p loc then return loc else findLocInArea a p
locInArea :: Area -> Rnd Loc
locInArea a = findLocInArea a (const True)
findLoc :: Level -> (Loc -> Tile -> Bool) -> Rnd Loc
findLoc l@(Level { lsize = sz, lmap = lm }) p =
do
loc <- locInArea ((0,0),sz)
if p loc (lm `at` loc) then return loc
else findLoc l p
grid :: (Y,X) -> Area -> Map (Y,X) Area
grid (ny,nx) ((y0,x0),(y1,x1)) =
let yd = y1 - y0
xd = x1 - x0
in M.fromList [ ((y,x), ((y0 + (yd * y `div` ny), x0 + (xd * x `div` nx)),
(y0 + (yd * (y + 1) `div` ny - 1), x0 + (xd * (x + 1) `div` nx - 1))))
| x <- [0..nx-1], y <- [0..ny-1] ]
connectGrid :: (Y,X) -> Rnd [((Y,X),(Y,X))]
connectGrid (ny,nx) =
do
let unconnected = S.fromList [ (y,x) | x <- [0..nx-1], y <- [0..ny-1] ]
-- candidates are neighbors that are still unconnected; we start with
-- a random choice
rx <- randomR (0,nx-1)
ry <- randomR (0,ny-1)
let candidates = S.fromList [ (ry,rx) ]
connectGrid' (ny,nx) unconnected candidates []
randomConnection :: (Y,X) -> Rnd ((Y,X),(Y,X))
randomConnection (ny,nx) =
do
rb <- randomR (False,True)
if rb then do
rx <- randomR (0,nx-2)
ry <- randomR (0,ny-1)
return (normalize ((ry,rx),(ry,rx+1)))
else do
ry <- randomR (0,ny-2)
rx <- randomR (0,nx-1)
return (normalize ((ry,rx),(ry+1,rx)))
normalize :: ((Y,X),(Y,X)) -> ((Y,X),(Y,X))
normalize (a,b) | a <= b = (a,b)
| otherwise = (b,a)
normalizeArea :: Area -> Area
normalizeArea a@((y0,x0),(y1,x1)) = ((min y0 y1, min x0 x1), (max y0 y1, max x0 x1))
connectGrid' :: (Y,X) -> Set (Y,X) -> Set (Y,X) -> [((Y,X),(Y,X))] -> Rnd [((Y,X),(Y,X))]
connectGrid' (ny,nx) unconnected candidates acc
| S.null candidates = return (L.map normalize acc)
| otherwise = do
c <- oneOf (S.toList candidates)
let ns = neighbors ((0,0),(ny-1,nx-1)) c -- potential new candidates
let nu = S.delete c unconnected -- new unconnected
let (nc,ds) = S.partition (`S.member` nu) ns
-- (new candidates, potential connections)
new <- if S.null ds then return id
else do
d <- oneOf (S.toList ds)
return ((c,d) :)
connectGrid' (ny,nx) nu
(S.delete c (candidates `S.union` nc)) (new acc)
neighbors :: Area -> {- size limitation -}
Loc -> {- location to find neighbors of -}
Set Loc
neighbors area (y,x) =
let cs = [ (y + dy, x + dx) | dy <- [-1..1], dx <- [-1..1], (dx + dy) `mod` 2 == 1 ]
in S.fromList (L.filter (`inside` area) cs)
inside :: Loc -> Area -> Bool
inside (y,x) ((y0,x0),(y1,x1)) = x1 >= x && x >= x0 && y1 >= y && y >= y0
fromTo :: Loc -> Loc -> [Loc]
fromTo (y0,x0) (y1,x1)
| y0 == y1 = L.map (\ x -> (y0,x)) (fromTo1 x0 x1)
| x0 == x1 = L.map (\ y -> (y,x0)) (fromTo1 y0 y1)
fromTo1 :: X -> X -> [X]
fromTo1 x0 x1
| x0 <= x1 = [x0..x1]
| otherwise = [x0,x0-1..x1]
viewTile :: Tile -> (Char, Attr -> Attr)
viewTile (Tile t []) = viewTerrain 0 t
viewTile (Tile t (i:_)) = viewItem (itype i)
-- | Produces a textual description of the items at a location. It's
-- probably correct to use 'at' rather than 'rememberAt' at this point,
-- although we could argue that 'rememberAt' reflects what the player can
-- perceive more correctly ...
lookAt :: Bool -> LMap -> Loc -> String
lookAt detailed lvl loc
| L.null is && detailed = lookTerrain (tterrain (lvl `at` loc))
| otherwise = isd
where
is = titems (lvl `at` loc)
isd = unwords $ L.map (objectItem . itype) $ is
-- | Produces a textual description for terrain, used if no objects
-- are present.
lookTerrain :: Terrain -> String
lookTerrain Floor = "empty floor"
lookTerrain Corridor = "empty corridor"
lookTerrain (Opening _) = "an opening"
lookTerrain (Stairs Up _) = "staircase up"
lookTerrain (Stairs Down _) = "staircase down"
lookTerrain (Door _ Nothing) = "an open door"
lookTerrain _ = ""
-- | The parameter "n" is the level of evolution:
--
-- 0: final
-- 1: stairs added
-- 2: doors added
-- 3: corridors and openings added
-- 4: only rooms
viewTerrain :: Int -> Terrain -> (Char, Attr -> Attr)
viewTerrain n Rock = (' ', id)
viewTerrain n (Opening d)
| n <= 3 = ('.', id)
| otherwise = viewTerrain 0 (Wall d)
viewTerrain n Floor = ('.', id)
viewTerrain n Unknown = (' ', id)
viewTerrain n Corridor
| n <= 3 = ('#', id)
| otherwise = viewTerrain 0 Rock
viewTerrain n (Wall Horiz) = ('-', id)
viewTerrain n (Wall Vert) = ('|', id)
viewTerrain n (Stairs Up _)
| n <= 1 = ('<', id)
| otherwise = viewTerrain 0 Floor
viewTerrain n (Stairs Down _)
| n <= 1 = ('>', id)
| otherwise = viewTerrain 0 Floor
viewTerrain n (Door d (Just 0))
| n <= 2 = ('+', setFG yellow)
| otherwise = viewTerrain n (Opening d)
viewTerrain n (Door d (Just _))
| n <= 2 = viewTerrain n (Wall d) -- secret door
| otherwise = viewTerrain n (Opening d)
viewTerrain n (Door Horiz Nothing)
| n <= 2 = ('|', setFG yellow)
| otherwise = viewTerrain n (Opening Horiz)
viewTerrain n (Door Vert Nothing)
| n <= 2 = ('-', setFG yellow)
| otherwise = viewTerrain n (Opening Vert)
viewSmell :: Int -> (Char, Attr -> Attr)
viewSmell n = let k | n > 9 = '*'
| n < 0 = '-'
| otherwise = head . show $ n
in (k, setFG black . setBG green)