LambdaHack-0.1.20110918: src/Terrain.hs
module Terrain where
import Control.Monad
import Data.Binary
import Data.Maybe
import qualified Color
import Geometry
-- TODO: let terrain kinds be defined in a config file. Group them
-- and assign frequency so that they can be used for dungeon building.
-- Goal: Have 2 tileset configs, one small, Rouge/Nethack style,
-- the other big, Angband/UFO style. The problem is that the Rogue walls
-- are very complex, while Angband style is much simpler, and I love KISS. Hmmm.
data Terrain a =
Rock
| Opening Pos
| Floor DL
| Unknown
| Corridor
| Wall Pos
| Stairs DL VDir (Maybe a)
| Door Pos (Maybe Int) -- Nothing: open, Just 0: closed, otherwise secret
deriving Show
instance Binary VDir where
put = putWord8 . fromIntegral . fromEnum
get = liftM (toEnum . fromIntegral) getWord8
instance Binary a => Binary (Terrain a) where
put Rock = putWord8 0
put (Opening p) = putWord8 1 >> put p
put (Floor dl) = putWord8 2 >> put dl
put Unknown = putWord8 3
put Corridor = putWord8 4
put (Wall p) = putWord8 5 >> put p
put (Stairs dl d n) = putWord8 6 >> put dl >> put d >> put n
put (Door p o) = putWord8 7 >> put p >> put o
get = do
tag <- getWord8
case tag of
0 -> return Rock
1 -> liftM Opening get
2 -> liftM Floor get
3 -> return Unknown
4 -> return Corridor
5 -> liftM Wall get
6 -> liftM3 Stairs get get get
7 -> liftM2 Door get get
_ -> fail "no parse (Terrain)"
instance Eq a => Eq (Terrain a) where
Rock == Rock = True
Opening d == Opening d' = d == d'
Floor l == Floor l' = l == l'
Unknown == Unknown = True
Corridor == Corridor = True
Wall p == Wall p' = p == p'
Stairs dl d t == Stairs dl' d' t' = dl == dl' && d == d' && t == t'
Door p o == Door p' o' = p == p' && o == o'
_ == _ = False
data DL = Dark | Light
deriving (Eq, Show, Enum, Bounded)
instance Binary DL where
put = putWord8 . fromIntegral . fromEnum
get = liftM (toEnum . fromIntegral) getWord8
-- | All the wall kinds that are possible:
--
-- * 'UL': upper left
--
-- * 'U': upper
--
-- * 'UR': upper right
--
-- * 'L': left
--
-- * 'R': right
--
-- * 'DL': lower left
--
-- * 'D': lower
--
-- * 'DR': lower right
--
-- * 'O': a pillar
--
-- I am tempted to add even more (T-pieces and crossings),
-- but currently, we don't need them.
data Pos = UL | U | UR | L | R | DL | D | DR | O
deriving (Eq, Show, Enum, Bounded)
instance Binary Pos where
put = putWord8 . fromIntegral . fromEnum
get = liftM (toEnum . fromIntegral) getWord8
isFloor :: Terrain a -> Bool
isFloor (Floor _) = True
isFloor _ = False
isWall :: Terrain a -> Bool
isWall (Wall _) = True
isWall _ = False
isRock :: Terrain a -> Bool
isRock Rock = True
isRock _ = False
isUnknown :: Terrain a -> Bool
isUnknown Unknown = True
isUnknown _ = False
-- | allows moves and vision
isOpen :: Terrain a -> Bool
isOpen (Floor {}) = True
isOpen (Opening {}) = True
isOpen (Door _ o) = isNothing o
isOpen Corridor = True
isOpen (Stairs {}) = True
isOpen _ = False
fromDL :: DL -> Bool
fromDL Dark = False
fromDL Light = True
toDL :: Bool -> DL
toDL False = Dark
toDL True = Light
-- | is lighted on its own
isAlight :: Terrain a -> Bool
isAlight (Floor l) = fromDL l
isAlight (Stairs l _ _) = fromDL l
isAlight _ = False
-- | can be lighted by sourrounding tiles
reflects :: Terrain a -> Bool
reflects (Opening _) = True
reflects (Wall _) = True
reflects (Door _ _) = True
reflects _ = False
-- | Maps wall kinds to lists of expected floor positions.
posToDir :: Pos -> [Dir]
posToDir UL = [downright]
posToDir U = [down]
posToDir UR = [downleft]
posToDir L = [right]
posToDir R = [left]
posToDir DL = [upright]
posToDir D = [up]
posToDir DR = [upleft]
posToDir O = moves
-- | Passive tiles reflect light from some other (usually adjacent)
-- positions. This function returns the offsets from which light is
-- reflected. Not all passively lighted tiles reflect from all directions.
-- Walls, for instance, cannot usually be seen from the outside.
passive :: Terrain a -> [Dir]
passive (Wall p) = posToDir p
passive (Opening _) = moves
passive (Door p Nothing) = moves
passive (Door p (Just 0)) = moves -- doors can be seen from all sides
passive (Door p (Just n)) = posToDir p -- secret doors are like walls
passive (Stairs _ _ _) = moves
passive _ = []
-- | Perceptible is similar to passive, but describes which tiles can
-- be seen from which adjacent fields in the dark.
perceptible :: Terrain a -> [Dir]
perceptible Rock = []
perceptible p = case passive p of
[] -> moves
ds -> ds
-- | Produces a textual description for terrain, used if no objects
-- are present.
lookTerrain :: Terrain a -> String
lookTerrain (Floor _) = "Floor."
lookTerrain Corridor = "Corridor."
lookTerrain (Opening _) = "An opening."
lookTerrain (Stairs _ Up _) = "A staircase up."
lookTerrain (Stairs _ Down _) = "A staircase down."
lookTerrain (Door _ Nothing) = "An open door."
lookTerrain (Door _ (Just 0)) = "A closed door."
lookTerrain (Door _ (Just _)) = "A wall." -- secret
lookTerrain (Wall _ ) = "A wall."
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
--
-- The Bool indicates whether the loc is currently visible.
viewTerrain :: Int -> Bool -> Terrain a -> (Char, Color.Color)
viewTerrain n b t =
let def = if b then Color.BrWhite else Color.defFG
defDark = if b then Color.BrYellow else Color.BrBlack
defDoor = if b then Color.Yellow else Color.BrBlack
in case t of
Rock -> (' ', def)
(Opening d)
| n <= 3 -> ('.', def)
| otherwise -> viewTerrain 0 b (Wall d)
(Floor d) -> ('.', if d == Light then def else defDark)
Unknown -> (' ', def)
Corridor
| n <= 3 -> ('#', if b then Color.BrWhite else Color.defFG)
| otherwise -> viewTerrain 0 b Rock
(Wall p)
| p == O -> ('O', def)
| p `elem` [L, R] -> ('|', def)
| otherwise -> ('-', def)
(Stairs d p _)
| n <= 1 -> (if p == Up then '<' else '>',
if d == Light then def else defDark)
| otherwise -> viewTerrain 0 b (Floor Dark)
(Door p (Just 0))
| n <= 2 -> ('+', defDoor)
| otherwise -> viewTerrain n b (Opening p)
(Door p (Just _))
| n <= 2 -> viewTerrain n b (Wall p) -- secret door
| otherwise -> viewTerrain n b (Opening p)
(Door p Nothing)
| n <= 2 -> (if p `elem` [L, R] then '-' else '|', defDoor)
| otherwise -> viewTerrain n b (Opening p)