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) -- | Chance that a new monster is generated. Currently depends on the -- number of monsters already present, and on the level. In the future, -- the strength of the character and the strength of the monsters present -- could further influence the chance, and the chance could also affect -- which monster is generated. monsterGenChance :: LevelName -> [Monster] -> Rnd Bool monsterGenChance (LambdaCave n) [] = chance $ 1%50 monsterGenChance (LambdaCave n) _ = chance $ 1%((1000 - (fromIntegral n * 50)) `max` 300) monsterGenChance _ _ = return False 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 Pos | Floor DL | Unknown | Corridor | Wall Pos | Stairs DL VDir (Maybe DungeonLoc) | Door Pos (Maybe Int) -- Nothing: open, Just 0: closed, otherwise secret deriving Show instance Binary Terrain 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 (Tile)" data DL = Dark | Light deriving (Eq, Show, Bounded) -- | All the wall types that are possible: -- -- * 'UL': upper left -- -- * 'U': upper -- -- * 'UR': upper right -- -- * 'L': left -- -- * 'R': right -- -- * 'DL': lower left -- -- * 'D': lower -- -- * 'DR': lower right -- -- 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 deriving (Eq, Show, Bounded) instance Binary Pos where put UL = putWord8 0 put U = putWord8 1 put UR = putWord8 2 put L = putWord8 3 put R = putWord8 4 put DL = putWord8 5 put D = putWord8 6 put DR = putWord8 7 get = do tag <- getWord8 case tag of 0 -> return UL 1 -> return U 2 -> return UR 3 -> return L 4 -> return R 5 -> return DL 6 -> return D 7 -> return DR 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 instance Binary DL where put Dark = put False put Light = put True get = get >>= \ b -> if b then return Light else return Dark 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 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 -- | blocks moves and vision closed :: Tile -> Bool closed = not . open floor :: Tile -> Bool floor (Tile { tterrain = Floor _ }) = True floor _ = False secret :: Maybe Int -> Bool secret (Just n) | n /= 0 = True secret _ = False toOpen :: Bool -> Maybe Int toOpen True = Nothing toOpen False = Just 0 fromDL :: DL -> Bool fromDL Dark = False fromDL Light = True toDL :: Bool -> DL toDL False = Dark toDL True = Light -- | 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 l) _) = fromDL l light (Tile (Stairs l _ _) _) = fromDL l light _ = False -- | 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 :: Tile -> [Dir] passive (Tile (Wall p) _) = posToDir p passive (Tile (Opening _) _) = moves passive (Tile (Door p Nothing) _) = moves passive (Tile (Door p (Just 0)) _) = moves -- doors can be seen from all sides passive (Tile (Door p (Just n)) _) = posToDir p -- secret doors are like walls passive (Tile (Stairs _ _ _) _) = moves passive _ = [] -- | Perceptible is similar to passive, but describes which tiles can -- be seen from which adjacent fields in the dark. perceptible :: Tile -> [Dir] perceptible (Tile Rock _) = [] perceptible p = case passive p of [] -> moves ds -> ds -- | Maps wall types 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] -- 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) 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 :: Bool -> Tile -> Assocs -> (Char, Attr -> Attr) viewTile b (Tile t []) a = viewTerrain 0 b t viewTile b (Tile t (i:_)) a = viewItem (itype i) a -- | 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 ... -- -- The "detailed" variant is for use with an explicit look command. lookAt :: Bool -> Assocs -> Discoveries -> LMap -> Loc -> String lookAt detailed a d lvl loc | detailed = lookTerrain (tterrain (lvl `at` loc)) ++ " " ++ isd | otherwise = isd where is = titems (lvl `at` loc) isd = case is of [] -> "" [i] -> "You see " ++ objectItem a d (icount i) (itype i) ++ "." [i,j] -> "You see " ++ objectItem a d (icount i) (itype i) ++ " and " ++ objectItem a d (icount j) (itype j) ++ "." _ -> "There are several objects here" ++ if detailed then ":" else "." -- | Produces a textual description for terrain, used if no objects -- are present. lookTerrain :: Terrain -> 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 _ = "" -- | 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 -> (Char, Attr -> Attr) viewTerrain n b Rock = (' ', id) viewTerrain n b (Opening d) | n <= 3 = ('.', id) | otherwise = viewTerrain 0 b (Wall d) viewTerrain n b (Floor Light) = ('.', id) viewTerrain n b (Floor Dark) = if b then ('.', id) else (' ', id) viewTerrain n b Unknown = (' ', id) viewTerrain n b Corridor | n <= 3 = ('#', id) | otherwise = viewTerrain 0 b Rock viewTerrain n b (Wall p) | p `elem` [L, R] = ('|', id) | otherwise = ('-', id) viewTerrain n b (Stairs _ Up _) | n <= 1 = ('<', id) | otherwise = viewTerrain 0 b (Floor Dark) viewTerrain n b (Stairs _ Down _) | n <= 1 = ('>', id) | otherwise = viewTerrain 0 b (Floor Dark) viewTerrain n b (Door d (Just 0)) | n <= 2 = ('+', setFG yellow) | otherwise = viewTerrain n b (Opening d) viewTerrain n b (Door d (Just _)) | n <= 2 = viewTerrain n b (Wall d) -- secret door | otherwise = viewTerrain n b (Opening d) viewTerrain n b (Door p Nothing) | n <= 2 = (if p `elem` [L, R] then '-' else '|', setFG yellow) | otherwise = viewTerrain n b (Opening p) viewSmell :: Int -> (Char, Attr -> Attr) viewSmell n = let k | n > 9 = '*' | n < 0 = '-' | otherwise = head . show $ n in (k, setFG black . setBG green)