diff --git a/Actor.hs b/Actor.hs new file mode 100644 --- /dev/null +++ b/Actor.hs @@ -0,0 +1,29 @@ +module Actor where + +import Level +import Monster + +data Actor = AMonster Int -- offset in monster list + | APlayer + deriving (Show, Eq) + +getActor :: Level -> Player -> Actor -> Monster +getActor lvl p (AMonster n) = lmonsters lvl !! n +getActor lvl p APlayer = p + +updateActor :: (Monster -> Monster) -> -- the update + (Monster -> Level -> Player -> IO a) -> -- continuation + Actor -> -- who to update + Level -> Player -> IO a -- transformed continuation +updateActor f k (AMonster n) lvl p = + let (m,ms) = updateMonster f n (lmonsters lvl) + in k m (updateMonsters lvl (const ms)) p +updateActor f k APlayer lvl p = k p lvl (f p) + +updateMonster :: (Monster -> Monster) -> Int -> [Monster] -> (Monster, [Monster]) +updateMonster f n ms = + case splitAt n ms of + (pre, x : post) -> let m = f x in (m, pre ++ [m] ++ post) + xs -> error "updateMonster" + + diff --git a/Display.hs b/Display.hs new file mode 100644 --- /dev/null +++ b/Display.hs @@ -0,0 +1,12 @@ +module Display (module D) where + +-- wrapper for selected Display frontend + +#ifdef CURSES +import Display.Curses as D +#elif GTK +import Display.Gtk as D +#else +import Display.Vty as D +#endif + diff --git a/Display/Curses.hs b/Display/Curses.hs new file mode 100644 --- /dev/null +++ b/Display/Curses.hs @@ -0,0 +1,112 @@ +module Display.Curses + (displayId, startup, shutdown, + display, nextEvent, setBG, setFG, Session, + white, black, yellow, blue, magenta, red, green, attr, Display.Curses.Attr) where + +import UI.HSCurses.Curses as C +import qualified UI.HSCurses.CursesHelper as C +import Data.List as L +import Data.Map as M +import Data.Char +import qualified Data.ByteString as BS + +import Geometry + +displayId = "curses" + +data Session = + Session + { win :: Window, + styles :: Map (Maybe AttrColor, Maybe AttrColor) C.CursesStyle } + +startup :: (Session -> IO ()) -> IO () +startup k = + do + C.start + C.startColor + cursSet CursorInvisible + nr <- colorPairs + let s = [ ((f,b), C.Style (toFColor f) (toBColor b)) + | f <- Nothing : L.map Just [minBound..maxBound], + b <- Nothing : L.map Just [minBound..maxBound] ] + let (ks, vs) = unzip (tail s) -- drop the Nothing/Nothing combo + ws <- C.convertStyles (take (nr - 1) vs) + k (Session C.stdScr (M.fromList (zip ks ws))) + +shutdown :: Session -> IO () +shutdown w = C.end + +display :: Area -> Session -> (Loc -> (Display.Curses.Attr, Char)) -> String -> String -> IO () +display ((y0,x0),(y1,x1)) (Session { win = w, styles = s }) f msg status = + do + erase + mvWAddStr w 0 0 msg + sequence_ [ let (a,c) = f (y,x) in C.setStyle (findWithDefault C.defaultCursesStyle a s) >> mvWAddStr w (y+1) x [c] + | x <- [x0..x1], y <- [y0..y1] ] + mvWAddStr w (y1+2) 0 status + refresh +{- + in V.update vty (Pic NoCursor + ((renderBS attr (BS.pack (L.map (fromIntegral . ord) (toWidth (x1-x0+1) msg)))) <-> + img <-> + (renderBS attr (BS.pack (L.map (fromIntegral . ord) (toWidth (x1-x0+1) status)))))) +-} + +{- +toWidth :: Int -> String -> String +toWidth n x = take n (x ++ repeat ' ') +-} + +nextEvent :: Session -> IO String +nextEvent session = + do + e <- C.getKey refresh + case e of + C.KeyChar '<' -> return "less" + C.KeyChar '>' -> return "greater" + C.KeyChar '.' -> return "period" + C.KeyChar ':' -> return "colon" + C.KeyChar ',' -> return "comma" + C.KeyChar ' ' -> return "space" + C.KeyChar '\ESC' -> return "Escape" + C.KeyChar c -> return [c] + C.KeyExit -> return "Escape" + _ -> nextEvent session + +type Attr = (Maybe AttrColor, Maybe AttrColor) + +attr = (Nothing, Nothing) + +data AttrColor = White | Black | Yellow | Blue | Magenta | Red | Green + deriving (Show, Eq, Ord, Enum, Bounded) + +toFColor :: Maybe AttrColor -> C.ForegroundColor +toFColor (Just White) = C.WhiteF +toFColor (Just Black) = C.BlackF +toFColor (Just Yellow) = C.BrownF +toFColor (Just Blue) = C.DarkBlueF +toFColor (Just Magenta) = C.PurpleF +toFColor (Just Red) = C.DarkRedF +toFColor (Just Green) = C.DarkGreenF +toFColor Nothing = C.DefaultF + +toBColor :: Maybe AttrColor -> C.BackgroundColor +toBColor (Just White) = C.WhiteB +toBColor (Just Black) = C.BlackB +toBColor (Just Yellow) = C.BrownB +toBColor (Just Blue) = C.DarkBlueB +toBColor (Just Magenta) = C.PurpleB +toBColor (Just Red) = C.DarkRedB +toBColor (Just Green) = C.DarkGreenB +toBColor Nothing = C.DefaultB + +white = White +black = Black +yellow = Yellow +blue = Blue +magenta = Magenta +red = Red +green = Green + +setFG c (_, b) = (Just c, b) +setBG c (f, b) = (f, Just c) diff --git a/Display/Gtk.hs b/Display/Gtk.hs new file mode 100644 --- /dev/null +++ b/Display/Gtk.hs @@ -0,0 +1,158 @@ +module Display.Gtk + (displayId, startup, shutdown, + display, nextEvent, setBG, setFG, Session, + white, black, yellow, blue, magenta, red, green, attr, Attr) where + +import Control.Monad +import Control.Concurrent +import Graphics.UI.Gtk hiding (Attr) +import Data.List as L +import Data.IORef +import Data.Map as M + +import Geometry + +displayId = "gtk" + +data Session = + Session { + schan :: Chan String, + stags :: Map AttrKey TextTag, + sview :: TextView } + +doAttr :: TextTag -> AttrKey -> IO () +doAttr tt (BG Blue) = set tt [ textTagBackground := "#0000CC" ] +doAttr tt (BG Magenta) = set tt [ textTagBackground := "#CC00CC" ] +doAttr tt (BG Green) = set tt [ textTagBackground := "#00CC00" ] +doAttr tt (BG Red) = set tt [ textTagBackground := "#CC0000" ] +doAttr tt (BG White) = set tt [ textTagBackground := "#FFFFFF" ] +doAttr tt (FG Green) = set tt [ textTagForeground := "#00FF00" ] +doAttr tt (FG Red) = set tt [ textTagForeground := "#FF0000" ] +doAttr tt (FG Blue) = set tt [ textTagForeground := "#0000FF" ] +doAttr tt (FG Yellow) = set tt [ textTagForeground := "#CCCC00" ] +doAttr tt (FG Black) = set tt [ textTagForeground := "#000000" ] +doAttr tt _ = return () + +startup :: (Session -> IO ()) -> IO () +startup k = + do + initGUI + w <- windowNew + + ttt <- textTagTableNew + -- text attributes + tts <- fmap M.fromList $ + mapM (\ c -> do + tt <- textTagNew Nothing + textTagTableAdd ttt tt + doAttr tt c + return (c,tt)) + [ x | c <- [minBound .. maxBound], x <- [FG c, BG c]] + + -- text buffer + tb <- textBufferNew (Just ttt) + textBufferSetText tb (unlines (replicate 25 (replicate 80 ' '))) + + -- create text view + tv <- textViewNewWithBuffer tb + containerAdd w tv + textViewSetEditable tv False + textViewSetCursorVisible tv False + + -- font + f <- fontDescriptionNew + fontDescriptionSetFamily f "Monospace" + widgetModifyFont tv (Just f) + currentfont <- newIORef f + onButtonPress tv (\ e -> case e of + Button { eventButton = RightButton } -> + do + fsd <- fontSelectionDialogNew "Choose font" + cf <- readIORef currentfont + -- fd <- fontDescriptionToString cf + -- fontSelectionDialogSetFontName fsd fd + fontSelectionDialogSetPreviewText fsd "+##@##-...|" + response <- dialogRun fsd + when (response == ResponseOk) $ + do + fn <- fontSelectionDialogGetFontName fsd + case fn of + Just fn' -> do + fd <- fontDescriptionFromString fn' + writeIORef currentfont fd + widgetModifyFont tv (Just fd) + Nothing -> return () + widgetDestroy fsd + return True + _ -> return False) + + let black = Color minBound minBound minBound + let white = Color maxBound maxBound maxBound + widgetModifyBase tv StateNormal black + widgetModifyText tv StateNormal white + + ec <- newChan + forkIO $ k (Session ec tts tv) + + onKeyPress tv (\ e -> writeChan ec (eventKeyName e) >> yield >> return True) + + idleAdd (yield >> return True) priorityDefaultIdle + onDestroy w mainQuit -- set quit handler + widgetShowAll w + yield + mainGUI + +shutdown _ = mainQuit + +display :: Area -> Session -> (Loc -> (Attr, Char)) -> String -> String -> IO () +display ((y0,x0),(y1,x1)) session f msg status = + do + sbuf <- textViewGetBuffer (sview session) + ttt <- textBufferGetTagTable sbuf + tb <- textBufferNew (Just ttt) + let text = unlines [ [ snd (f (y,x)) | x <- [x0..x1] ] | y <- [y0..y1] ] + textBufferSetText tb (msg ++ "\n" ++ text ++ status) + sequence_ [ setTo tb (stags session) (y,x) a | + y <- [y0..y1], x <- [x0..x1], let loc = (y,x), let (a,c) = f (y,x) ] + textViewSetBuffer (sview session) tb + +setTo :: TextBuffer -> Map AttrKey TextTag -> Loc -> Attr -> IO () +setTo tb tts (ly,lx) a = + do + ib <- textBufferGetIterAtLineOffset tb (ly+1) lx + ie <- textIterCopy ib + textIterForwardChar ie + mapM_ (\ c -> textBufferApplyTag tb (tts ! c) ib ie) a + +nextEvent :: Session -> IO String +nextEvent session = readChan (schan session) + +setBG c = (BG c :) +setFG c = (FG c :) +blue = Blue +magenta = Magenta +red = Red +yellow = Yellow +green = Green +white = White +black = Black +attr = [] + +type Attr = [AttrKey] + +data AttrKey = + FG AttrColor + | BG AttrColor + deriving (Eq, Ord) + +type Color = AttrColor + +data AttrColor = + Blue + | Magenta + | Red + | Green + | Yellow + | White + | Black + deriving (Eq, Ord, Enum, Bounded) diff --git a/Display/Vty.hs b/Display/Vty.hs new file mode 100644 --- /dev/null +++ b/Display/Vty.hs @@ -0,0 +1,51 @@ +module Display.Vty + (displayId, startup, shutdown, + display, nextEvent, setBG, setFG, Session, + white, black, yellow, blue, magenta, red, green, attr, Attr) where + +import Graphics.Vty as V +import Data.List as L +import Data.Char +import qualified Data.ByteString as BS + +import Geometry + +displayId = "vty" + +type Session = V.Vty + +startup :: (Session -> IO ()) -> IO () +startup k = + do + session <- V.mkVty + k session + +display :: Area -> Session -> (Loc -> (Attr, Char)) -> String -> String -> IO () +display ((y0,x0),(y1,x1)) vty f msg status = + let img = (foldr (<->) V.empty . + L.map (foldr (<|>) V.empty . + L.map (\ (x,y) -> let (a,c) = f (y,x) in renderChar a c))) + [ [ (x,y) | x <- [x0..x1] ] | y <- [y0..y1] ] + in V.update vty (Pic NoCursor + ((renderBS attr (BS.pack (L.map (fromIntegral . ord) (toWidth (x1-x0+1) msg)))) <-> + img <-> + (renderBS attr (BS.pack (L.map (fromIntegral . ord) (toWidth (x1-x0+1) status)))))) + +toWidth :: Int -> String -> String +toWidth n x = take n (x ++ repeat ' ') + +nextEvent :: Session -> IO String +nextEvent session = + do + e <- V.getEvent session + case e of + V.EvKey (KASCII '<') [] -> return "less" + V.EvKey (KASCII '>') [] -> return "greater" + V.EvKey (KASCII '.') [] -> return "period" + V.EvKey (KASCII ':') [] -> return "colon" + V.EvKey (KASCII ',') [] -> return "comma" + V.EvKey (KASCII ' ') [] -> return "space" + V.EvKey (KASCII c) [] -> return [c] + V.EvKey KEsc [] -> return "Escape" + V.EvKey KEnter [] -> return "Return" + _ -> nextEvent session diff --git a/Display2.hs b/Display2.hs new file mode 100644 --- /dev/null +++ b/Display2.hs @@ -0,0 +1,110 @@ +module Display2 (module Display, module Display2) where + +import Data.Set as S +import Data.List as L +import Data.Map as M + +import Message +import Display +import State +import Geometry +import Level +import Perception +import Monster + +-- | Displays a message on a blank screen. Waits for confirmation. +displayBlankConfirm :: Session -> String -> IO () +displayBlankConfirm session txt = + let x = txt ++ more + in do + display ((0,0),(0,length x - 1)) session (const (attr, ' ')) x "" + getConfirm session + +-- | Waits for a space or return. +getConfirm :: Session -> IO () +getConfirm session = + do + e <- nextEvent session + handleModifier e (getConfirm session) $ + case e of + "space" -> return () + "Return" -> return () + _ -> getConfirm session + +-- | Handler that ignores modifier events as they are +-- currently produced by the Gtk frontend. +handleModifier :: String -> IO () -> IO () -> IO () +handleModifier e h k = + case e of + "Shift_R" -> h + "Shift_L" -> h + "Control_L" -> h + "Control_R" -> h + "Super_L" -> h + "Super_R" -> h + "Menu" -> h + "Alt_L" -> h + "Alt_R" -> h + _ -> k + +-- | Configurable event handler for the direction keys. Is used to +-- handle player moves, but can also be used for directed commands +-- such as open/close. +handleDirection :: String -> ((Y,X) -> IO ()) -> IO () -> IO () +handleDirection e h k = + case e of + "k" -> h (-1,0) + "j" -> h (1,0) + "h" -> h (0,-1) + "l" -> h (0,1) + "y" -> h (-1,-1) + "u" -> h (-1,1) + "b" -> h (1,-1) + "n" -> h (1,1) + _ -> k + + +displayLevel :: Session -> Level -> Perception -> State -> Message -> IO () +displayLevel session (lvl@(Level nm sz ms smap nlmap lmeta)) + per + (state@(State { splayer = player@(Monster { mhp = php, mdir = pdir, mloc = ploc }), stime = time })) + msg = + let + reachable = preachable per + visible = pvisible per + sSml = ssensory state == Smell + sVis = ssensory state == Vision + sOmn = sdisplay state == Omniscient + sTer = case sdisplay state of Terrain n -> n; _ -> 0 + lAt = if sOmn || sTer > 0 then at else rememberAt + lVision = if sVis + then \ vis rea -> + if vis then setBG blue + else if rea then setBG magenta + else id + else \ vis rea -> id + disp msg = + display ((0,0),sz) session + (\ loc -> let tile = nlmap `lAt` loc + sml = ((smap ! loc) - time) `div` 100 + vis = S.member loc visible + rea = S.member loc reachable + (rv,ra) = case L.find (\ m -> loc == mloc m) (player:ms) of + _ | sTer > 0 -> viewTerrain sTer (tterrain tile) + Just m | sOmn || vis -> viewMonster (mtype m) + _ | sSml && sml >= 0 -> viewSmell sml + | otherwise -> viewTile tile + vision = lVision vis rea + in + (ra . vision $ + attr, rv)) + msg + (take 40 (levelName nm ++ repeat ' ') ++ take 10 ("HP: " ++ show php ++ repeat ' ') ++ + take 10 ("T: " ++ show (time `div` 10) ++ repeat ' ')) + msgs = splitMsg (snd sz) msg + perf [] = disp "" + perf [xs] = disp xs + perf (x:xs) = disp (x ++ more) >> getConfirm session >> perf xs + in perf msgs + + diff --git a/Dungeon.hs b/Dungeon.hs new file mode 100644 --- /dev/null +++ b/Dungeon.hs @@ -0,0 +1,214 @@ +module Dungeon where + +import Control.Monad + +import Data.Map as M +import Data.List as L +import Data.Ratio + +import State +import Geometry +import Level +import Monster +import Item +import Random + +type Corridor = [(Y,X)] +type Room = Area + +mkRoom :: Int -> {- border columns -} + (Y,X) -> {- minimum size -} + Area -> {- this is an area, not the room itself -} + Rnd Room {- this is the upper-left and lower-right corner of the room -} +mkRoom bd (ym,xm)((y0,x0),(y1,x1)) = + do + (ry0,rx0) <- locInArea ((y0+bd,x0+bd),(y1-bd-ym+1,x1-bd-xm+1)) + (ry1,rx1) <- locInArea ((ry0+ym-1,rx0+xm-1),(y1-bd,x1-bd)) + return ((ry0,rx0),(ry1,rx1)) + +mkCorridor :: HV -> (Loc,Loc) -> Area -> Rnd [(Y,X)] {- straight sections of the corridor -} +mkCorridor hv ((y0,x0),(y1,x1)) b = + do + (ry,rx) <- findLocInArea b (const True) + -- (ry,rx) is intermediate point the path crosses + -- hv decides whether we start in horizontal or vertical direction + case hv of + Horiz -> return [(y0,x0),(y0,rx),(y1,rx),(y1,x1)] + Vert -> return [(y0,x0),(ry,x0),(ry,x1),(y1,x1)] + +-- the condition passed to mkCorridor is tricky; there might not always +-- exist a suitable intermediate point is the rooms are allowed to be close +-- together ... +connectRooms :: Area -> Area -> Rnd [Loc] +connectRooms sa@((sy0,sx0),(sy1,sx1)) ta@((ty0,tx0),(ty1,tx1)) = + do + (sy,sx) <- locInArea sa + (ty,tx) <- locInArea ta + let xok = sx1 < tx0 - 3 + let xarea = normalizeArea ((sy,sx1+2),(ty,tx0-2)) + let yok = sy1 < ty0 - 3 + let yarea = normalizeArea ((sy1+2,sx),(ty0-2,tx)) + let xyarea = normalizeArea ((sy1+2,sx1+2),(ty0-2,tx0-2)) + (hv,area) <- if xok && yok then fmap (\ hv -> (hv,xyarea)) (binaryChoice Horiz Vert) + else if xok then return (Horiz,xarea) + else return (Vert,yarea) + mkCorridor hv ((sy,sx),(ty,tx)) area + +digCorridor :: Corridor -> LMap -> LMap +digCorridor (p1:p2:ps) l = + digCorridor (p2:ps) + (M.unionWith corridorUpdate (M.fromList [ (ps,newTile Corridor) | ps <- fromTo p1 p2 ]) l) + where + corridorUpdate _ (Tile (Wall hv) is,u) = (Tile (Opening hv) is,u) + corridorUpdate _ (Tile (Opening hv) is,u) = (Tile (Opening hv) is,u) + corridorUpdate _ (Tile Floor is,u) = (Tile Floor is,u) + corridorUpdate (x,u) _ = (x,u) +digCorridor _ l = l + +newTile :: Terrain -> (Tile, Tile) +newTile t = (Tile t [], Tile Unknown []) + +bigroom :: LevelConfig -> + LevelName -> Rnd (Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) -> Level, Loc, Loc) +bigroom (LevelConfig { levelSize = (sy,sx) }) nm = + do + let lmap = digRoom ((1,1),(sy-1,sx-1)) (emptyLMap (sy,sx)) + let smap = M.fromList [ ((y,x),-100) | y <- [0..sy], x <- [0..sx] ] + let lvl = Level nm (sy,sx) [] smap lmap "" + -- locations of the stairs + su <- findLoc lvl (const ((==Floor) . tterrain)) + sd <- findLoc lvl (\ l t -> tterrain t == Floor && distance (su,l) > 676) + return $ (\ lu ld -> + let flmap = maybe id (\ l -> M.insert su (newTile (Stairs Up l))) lu $ + maybe id (\ l -> M.insert sd (newTile (Stairs Down l))) ld $ + lmap + in Level nm (sy,sx) [] smap flmap "bigroom", su, sd) + +data LevelConfig = + LevelConfig { + levelGrid :: (Y,X), + minRoomSize :: (Y,X), + border :: Int, -- must be at least 2! + levelSize :: (Y,X), -- lower right point + extraConnects :: Int, + minStairsDistance :: Int, -- must not be too large + doorChance :: Rational, + doorOpenChance :: Rational, + doorSecretChance :: Rational, + doorSecretMax :: Int, + nrItems :: (Int,Int) + } + +defaultLevelConfig :: LevelConfig +defaultLevelConfig = + LevelConfig { + levelGrid = (3,3), -- (7,10), -- (3,3), -- (2,5) + minRoomSize = (2,2), + border = 2, + levelSize = (22,79), -- (77,231), -- (22,79), + extraConnects = 3, -- 6 + minStairsDistance = 676, + doorChance = 1%2, + doorOpenChance = 1%2, + doorSecretChance = 1%3, + doorSecretMax = 15, + nrItems = (3,7) -- range + } + +largeLevelConfig :: LevelConfig +largeLevelConfig = + defaultLevelConfig { + levelGrid = (7,10), + levelSize = (77,231), + extraConnects = 10 + } + +level :: LevelConfig -> + LevelName -> Rnd (Maybe (Maybe DungeonLoc) -> Maybe (Maybe DungeonLoc) -> Level, Loc, Loc) +level cfg nm = + do + let gs = M.toList (grid (levelGrid cfg) ((0,0),levelSize cfg)) + rs0 <- mapM (\ (i,r) -> do + r' <- mkRoom (border cfg) (minRoomSize cfg) r + return (i,r')) gs + let rooms = L.map snd rs0 + let rs = M.fromList rs0 + connects <- connectGrid (levelGrid cfg) + addedConnects <- replicateM (extraConnects cfg) (randomConnection (levelGrid cfg)) + let allConnects = L.nub (addedConnects ++ connects) + cs <- mapM + (\ (p0,p1) -> do + let r0 = rs ! p0 + r1 = rs ! p1 + connectRooms r0 r1) allConnects + let smap = M.fromList [ ((y,x),-100) | let (sy,sx) = levelSize cfg, + y <- [0..sy], x <- [0..sx] ] + let lmap :: LMap + lmap = foldr digCorridor (foldr digRoom (emptyLMap (levelSize cfg)) rooms) cs + let lvl = Level nm (levelSize cfg) [] smap lmap "" + -- convert openings into doors + dlmap <- fmap M.fromList . mapM + (\ o@((y,x),(t,r)) -> + case t of + Tile (Opening hv) _ -> + do + -- chance for doors + rb <- chance (doorChance cfg) + -- chance for a door to be open + ro <- chance (doorOpenChance cfg) + rs <- if ro then return Nothing + else do -- chance for a door to be secret + rsc <- chance (doorSecretChance cfg) + fmap Just + (if rsc then randomR (1, doorSecretMax cfg) + else return 0) + if rb + then return ((y,x),newTile (Door hv rs)) + else return o + _ -> return o) . + M.toList $ lmap + -- determine number of items, items and locations for the items + nri <- randomR (nrItems cfg) + is <- replicateM nri $ + do + l <- findLoc lvl (const ((==Floor) . tterrain)) + t <- newItem itemFrequency + return (l,t) + -- locations of the stairs + su <- findLoc lvl (const ((==Floor) . tterrain)) + sd <- findLoc lvl (\ l t -> tterrain t == Floor && distance (su,l) > minStairsDistance cfg) + let meta = show allConnects + return $ (\ lu ld -> + let flmap = maybe id (\ l -> M.insert su (newTile (Stairs Up l))) lu $ + maybe id (\ l -> M.insert sd (newTile (Stairs Down l))) ld $ + foldr (\ (l,it) f -> M.update (\ (t,r) -> Just (t { titems = it : titems t }, r)) l . f) id is $ + dlmap + in Level nm (levelSize cfg) [] smap flmap meta, su, sd) + +emptyLMap :: (Y,X) -> LMap +emptyLMap (my,mx) = M.fromList [ ((y,x),newTile Rock) | x <- [0..mx], y <- [0..my] ] + +digRoom :: Room -> LMap -> LMap +digRoom ((y0,x0),(y1,x1)) l = + let rm = M.fromList $ [ ((y,x),newTile Floor) | x <- [x0..x1], y <- [y0..y1] ] + ++ [ ((y,x),newTile (Wall Horiz)) | x <- [x0-1..x1+1], y <- [y0-1,y1+1] ] + ++ [ ((y,x),newTile (Wall Vert)) | x <- [x0-1,x1+1], y <- [y0..y1] ] + in M.unionWith const rm l + +addMonster :: Level -> Player -> Rnd Level +addMonster lvl@(Level { lmonsters = ms, lmap = lmap }) + player@(Monster { mloc = ploc }) = + do + -- TODO: remove the hardcoded chance + rc <- chance (1 % if L.null ms then 50 else 700) + if rc + then do + -- TODO: new monsters always be generated in a place that isn't + -- visible by the player (if possible -- not possible for bigrooms) + sm <- findLoc lvl (\ l t -> tterrain t == Floor && + not (l `L.elem` L.map mloc (player : ms)) && + distance (ploc, l) > 400) + m <- newMonster sm monsterFrequency + return (updateMonsters lvl (const (m : ms))) + else return lvl + diff --git a/FOV.hs b/FOV.hs new file mode 100644 --- /dev/null +++ b/FOV.hs @@ -0,0 +1,67 @@ +module FOV where + +import Data.Map as M +import Data.Set as S +import Data.List as L +import Data.Ratio +import Debug.Trace + +import Geometry +import Level + +type Interval = (Rational, Rational) +type Distance = Int +type Progress = Int + +-- The current state of a scan is kept in a variable of Maybe Rational. +-- If Just something, we're in a visible interval. If Nothing, we're in +-- a shadowed interval. +scan :: ((Distance,Progress) -> Loc) -> LMap -> Distance -> Interval -> Set Loc +scan tr l d (s,e) = + let ps = downBias (s * fromIntegral d) -- minimal progress to check + pe = upBias (e * fromIntegral d) -- maximal progress to check + st = if open (l `at` tr (d,ps)) then (Just s) -- start in light + else Nothing -- start in shadow + in + -- trace (show (d,s,e,ps,pe)) $ + S.union (S.fromList [tr (d,p) | p <- [ps..pe]]) (scan' st ps pe) + where + scan' :: Maybe Rational -> Progress -> Progress -> Set Loc + -- scan' st ps pe + -- | trace (show (st,ps,pe)) False = undefined + scan' (Just s) ps pe + | s >= e = S.empty -- empty interval + | ps > pe = scan tr l (d+1) (s,e) -- reached end, scan next + | closed (l `at` tr (d,ps)) = + let ne = (fromIntegral ps - (1%2)) / (fromIntegral d + (1%2)) + in scan tr l (d+1) (s,ne) `S.union` scan' Nothing (ps+1) pe + -- entering shadow + | otherwise = scan' (Just s) (ps+1) pe + -- continue in light + scan' Nothing ps pe + | ps > pe = S.empty -- reached end while in shadow + | open (l `at` tr (d,ps)) = + let ns = (fromIntegral ps - (1%2)) / (fromIntegral d - (1%2)) + in scan' (Just ns) (ps+1) pe + -- moving out of shadow + | otherwise = scan' Nothing (ps+1) pe + -- continue in shadow + +tr0 (oy,ox) (d,p) = (oy+d,ox+p) +tr1 (oy,ox) (d,p) = (oy+d,ox-p) +tr2 (oy,ox) (d,p) = (oy-d,ox+p) +tr3 (oy,ox) (d,p) = (oy-d,ox-p) +tr4 (oy,ox) (d,p) = (oy+p,ox+d) +tr5 (oy,ox) (d,p) = (oy+p,ox-d) +tr6 (oy,ox) (d,p) = (oy-p,ox+d) +tr7 (oy,ox) (d,p) = (oy-p,ox-d) + +fullscan loc lvl = + S.unions $ + L.map (\ tr -> scan (tr loc) lvl 0 (0,1)) [tr0,tr1,tr2,tr3,tr4,tr5,tr6,tr7] + + +downBias, upBias :: (Integral a, Integral b) => Ratio a -> b +downBias x = round (x - 1 % (denominator x * 3)) +upBias x = round (x + 1 % (denominator x * 3)) + diff --git a/File.hs b/File.hs new file mode 100644 --- /dev/null +++ b/File.hs @@ -0,0 +1,22 @@ +module File where + +import System.IO +import Data.Binary +import qualified Data.ByteString.Lazy as LBS +import Codec.Compression.Zlib as Z + +strictReadCompressedFile :: FilePath -> IO LBS.ByteString +strictReadCompressedFile f = + do + h <- openBinaryFile f ReadMode + c <- LBS.hGetContents h + let d = Z.decompress c + LBS.length d `seq` return d + +strictDecodeCompressedFile :: Binary a => FilePath -> IO a +strictDecodeCompressedFile f = fmap decode (strictReadCompressedFile f) + +encodeCompressedFile :: Binary a => FilePath -> a -> IO () +encodeCompressedFile f x = LBS.writeFile f (Z.compress (encode x)) + -- note that LBS.writeFile opens the file in binary mode + diff --git a/Frequency.hs b/Frequency.hs new file mode 100644 --- /dev/null +++ b/Frequency.hs @@ -0,0 +1,31 @@ +module Frequency where + +import Control.Monad + +newtype Frequency a = Frequency { runFrequency :: [(Int, a)] } + deriving Show + +instance Monad Frequency where + return x = Frequency [(1, x)] + m >>= f = Frequency + [(p * q, y) | (p, x) <- runFrequency m, + (q, y) <- runFrequency (f x) ] + fail "" = Frequency [] + +instance MonadPlus Frequency where + mplus (Frequency xs) (Frequency ys) = Frequency (xs ++ ys) + mzero = Frequency [] + +instance Functor Frequency where + fmap f (Frequency xs) = Frequency (map (\ (p, x) -> (p, f x)) xs) + +-- only try the second possibility if the first fails +melse :: Frequency a -> Frequency a -> Frequency a +melse (Frequency []) y = y +melse x y = x + +scale :: Int -> Frequency a -> Frequency a +scale n (Frequency xs) = Frequency (map (\ (p, x) -> (n * p, x)) xs) + +uniform :: [a] -> Frequency a +uniform xs = Frequency (map (\ x -> (1, x)) xs) diff --git a/Geometry.hs b/Geometry.hs new file mode 100644 --- /dev/null +++ b/Geometry.hs @@ -0,0 +1,42 @@ +module Geometry where + +-- | Game time in turns. (Placement in module Geometry is not ideal.) +type Time = Int + +type X = Int +type Y = Int + +type Loc = (Y,X) +type Dir = (Y,X) +type Area = ((Y,X),(Y,X)) + +towards :: (Loc,Loc) -> Dir +towards ((y0,x0),(y1,x1)) = + let dy = y1 - y0 + dx = x1 - x0 + angle = atan (fromIntegral dy / fromIntegral dx) / (pi / 2) + dir | angle <= -0.75 = (-1,0) + | angle <= -0.25 = (-1,1) + | angle <= 0.25 = (0,1) + | angle <= 0.75 = (1,1) + | angle <= 1.25 = (1,0) + | otherwise = (0,0) + in if dx >= 0 then dir else neg dir + +distance :: (Loc,Loc) -> Int +distance ((y0,x0),(y1,x1)) = (y1 - y0)^2 + (x1 - x0)^2 + +adjacent :: Loc -> Loc -> Bool +adjacent s t = distance (s,t) <= 2 + +diagonal :: Loc -> Bool +diagonal (y,x) = y*x /= 0 + +shift :: Loc -> Dir -> Loc +shift (y0,x0) (y1,x1) = (y0+y1,x0+x1) + +neg :: Dir -> Dir +neg (y,x) = (-y,-x) + +moves :: [Dir] +moves = [ (x,y) | x <- [-1..1], y <- [-1..1], x /= 0 || y /= 0 ] diff --git a/Item.hs b/Item.hs new file mode 100644 --- /dev/null +++ b/Item.hs @@ -0,0 +1,98 @@ +module Item where + +import Data.Binary +import Data.Set as S +import Data.List as L +import Data.Maybe +import Control.Monad + +import Display +import Geometry +import Random + +data Item = Item + { itype :: ItemType, + iletter :: Maybe Char } -- inventory identifier + deriving Show + +data ItemType = + Ring + | Scroll + | Potion + | Wand + | Amulet + | Gem + | Gold + deriving Show + +instance Binary Item where + put (Item itype iletter) = put itype >> put iletter + get = liftM2 Item get get + +instance Binary ItemType where + put Ring = putWord8 0 + put Scroll = putWord8 1 + put Potion = putWord8 2 + 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 -> return Potion + 3 -> return Wand + 4 -> return Amulet + 5 -> return Gem + 6 -> return Gold + +itemFrequency :: Frequency ItemType +itemFrequency = + Frequency + [ + (10, Gold), + (3, Gem), + (2, Ring), + (4, Scroll), + (2, Wand), + (1, Amulet), + (4, Potion) + ] + +-- | Generate an item. +newItem :: Frequency ItemType -> Rnd Item +newItem ftp = + do + tp <- frequency ftp + return (Item tp Nothing) + +-- | Assigns a letter to an item, for inclusion +-- in the inventory of the player. Takes a starting +-- letter. +assignLetter :: Char -> [Item] -> Maybe Char +assignLetter c is = + listToMaybe (L.filter (\x -> not (x `member` current)) candidates) + where + current = S.fromList (concatMap (maybeToList . iletter) is) + allLetters = ['a'..'z'] ++ ['A'..'Z'] + candidates = take (length allLetters) (drop (fromJust (findIndex (==c) allLetters)) (cycle allLetters)) + +viewItem :: ItemType -> (Char, Attr -> Attr) +viewItem Ring = ('=', id) +viewItem Scroll = ('?', id) +viewItem Potion = ('!', id) +viewItem Wand = ('/', id) +viewItem Gold = ('$', setFG yellow) +viewItem Gem = ('*', setFG red) +viewItem _ = ('~', id) + +objectItem :: ItemType -> String +objectItem Ring = "a ring" +objectItem Scroll = "a scroll" +objectItem Potion = "a potion" +objectItem Wand = "a wand" +objectItem Amulet = "an amulet" +objectItem Gem = "a gem" +objectItem Gold = "some gold" diff --git a/LambdaHack.cabal b/LambdaHack.cabal --- a/LambdaHack.cabal +++ b/LambdaHack.cabal @@ -1,8 +1,9 @@ cabal-version: >= 1.2 name: LambdaHack -version: 0.1.20080412 +version: 0.1.20080413 license: GPL license-file: COPYING +data-files: README author: Andres Loeh maintainer: Andres Loeh description: a small roguelike game @@ -20,17 +21,25 @@ executable LambdaHack main-is: LambdaHack.hs + other-modules: Actor, Display, Display2, Dungeon, File, + FOV, Frequency, Geometry, Item, LambdaHack, + Level, Message, Monster, Perception, Random, + Save, Setup, State, Strategy, Style, Turn, + Version build-depends: base >= 3, containers >= 0.1, binary >= 0.4, random >= 1, zlib >= 0.4, bytestring >= 0.9, directory >= 1, mtl >= 1.1 extensions: CPP if flag(curses) { + other-modules: Display.Curses build-depends: hscurses >= 1.3 cpp-options: -DCURSES extra-libraries: curses } else { if flag(gtk) { + other-modules: Display.Gtk build-depends: gtk >= 0.9.12 cpp-options: -DGTK } else { + other-modules: Display.Vty build-depends: vty >= 3 } } diff --git a/Level.hs b/Level.hs new file mode 100644 --- /dev/null +++ b/Level.hs @@ -0,0 +1,412 @@ +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) + diff --git a/Message.hs b/Message.hs new file mode 100644 --- /dev/null +++ b/Message.hs @@ -0,0 +1,28 @@ +module Message where + +import Data.List as L +import Data.Char + +type Message = String + +more :: Message +more = " --more--" + +addMsg :: Message -> Message -> Message +addMsg [] x = x +addMsg xs [] = xs +addMsg xs x = xs ++ " " ++ x + +splitMsg :: Int -> Message -> [String] +splitMsg w xs + | w <= m = [xs] -- border case, we cannot make progress + | l <= w = [xs] -- no problem, everything fits + | otherwise = let (pre, post) = splitAt (w - m) xs + (ppre, ppost) = break (`L.elem` " .,:!;") $ reverse pre + rpost = dropWhile isSpace ppost + in if L.null rpost then pre : splitMsg w post + else reverse rpost : splitMsg w (reverse ppre ++ post) + where + m = length more + l = length xs + diff --git a/Monster.hs b/Monster.hs new file mode 100644 --- /dev/null +++ b/Monster.hs @@ -0,0 +1,147 @@ +module Monster where + +import Data.Char +import Data.Binary +import Control.Monad + +import Geometry +import Display +import Item +import Random + +-- | Hit points of the player. TODO: Should not be hardcoded. +playerHP :: Int +playerHP = 20 + +-- | Time the player can be traced by monsters. TODO: Make configurable. +smellTimeout :: Time +smellTimeout = 1000 + +-- | Initial player. +defaultPlayer :: Loc -> Player +defaultPlayer ploc = + Monster Player playerHP Nothing ploc [] 'a' 10 0 + +type Player = Monster + +data Monster = Monster + { mtype :: !MonsterType, + mhp :: !Int, + mdir :: Maybe Dir, -- for monsters: the dir the monster last moved; + -- for the player: the dir the player is running + mloc :: !Loc, + mitems :: [Item], -- inventory + mletter :: !Char, -- next inventory letter + mspeed :: !Time, -- speed (i.e., delay before next action) + mtime :: !Time } -- time of next action + deriving Show + +instance Binary Monster where + put (Monster mt mhp md ml minv mletter mspeed mtime) = + do + put mt + put mhp + put md + put ml + put minv + put mletter + put mspeed + put mtime + get = do + mt <- get + mhp <- get + md <- get + ml <- get + minv <- get + mletter <- get + mspeed <- get + mtime <- get + return (Monster mt mhp md ml minv mletter mspeed mtime) + +data MonsterType = + Player + | Eye + | FastEye + | Nose + deriving (Show, Eq) + +instance Binary MonsterType where + put Player = putWord8 0 + put Eye = putWord8 1 + put FastEye = putWord8 2 + put Nose = putWord8 3 + get = do + tag <- getWord8 + case tag of + 0 -> return Player + 1 -> return Eye + 2 -> return FastEye + 3 -> return Nose + _ -> fail "no parse (MonsterType)" + +monsterFrequency :: Frequency MonsterType +monsterFrequency = + Frequency + [ + (2, Nose), + (6, Eye), + (1, FastEye) + ] + +-- | Generate monster. +newMonster :: Loc -> Frequency MonsterType -> Rnd Monster +newMonster loc ftp = + do + tp <- frequency ftp + hp <- hps tp + let s = speed tp + return (template tp hp loc s) + where + -- setting the time of new monsters to 0 makes them able to + -- move immediately after generation; this does not seem like + -- a bad idea, but it would certainly be "more correct" to set + -- the time to the creation time instead + template tp hp loc s = Monster tp hp Nothing loc [] 'a' s 0 + + hps Eye = randomR (1,3) + hps FastEye = randomR (1,3) + hps Nose = randomR (2,3) + + speed Eye = 10 + speed FastEye = 3 + speed Nose = 11 + +-- | Insert a monster in an mtime-sorted list of monsters. +-- Returns the position of the inserted monster and the new list. +insertMonster :: Monster -> [Monster] -> (Int, [Monster]) +insertMonster = insertMonster' 0 + where + insertMonster' n m [] = (n, [m]) + insertMonster' n m (m':ms) + | mtime m <= mtime m' = (n, m : m' : ms) + | otherwise = let (n', ms') = insertMonster' (n + 1) m ms + in (n', m' : ms') + + +objectMonster :: MonsterType -> String +objectMonster Player = "you" +objectMonster Eye = "the reducible eye" +objectMonster FastEye = "the super-fast eye" +objectMonster Nose = "the point-free nose" + +subjectMonster :: MonsterType -> String +subjectMonster x = let (s:r) = objectMonster x in toUpper s : r + +verbMonster :: MonsterType -> String -> String +verbMonster Player v = v +verbMonster _ v = v ++ "s" + +compoundVerbMonster :: MonsterType -> String -> String -> String +compoundVerbMonster Player v p = v ++ " " ++ p +compoundVerbMonster _ v p = v ++ "s " ++ p + +viewMonster :: MonsterType -> (Char, Attr -> Attr) +viewMonster Player = ('@', setBG white . setFG black) +viewMonster Eye = ('e', setFG red) +viewMonster FastEye = ('e', setFG blue) +viewMonster Nose = ('n', setFG green) diff --git a/Perception.hs b/Perception.hs new file mode 100644 --- /dev/null +++ b/Perception.hs @@ -0,0 +1,33 @@ +module Perception where + +import Data.Set as S + +import Geometry +import State +import Level +import Monster +import FOV + +data Perception = + Perception { preachable :: Set Loc, pvisible :: Set Loc } + +perception_ :: State -> Level -> Perception +perception_ (State { splayer = Monster { mloc = ploc } }) (Level { lmap = lmap }) = + perception ploc lmap + +perception :: Loc -> LMap -> Perception +perception ploc lmap = + let + reachable = fullscan ploc lmap + actVisible = S.filter (\ loc -> light (lmap `at` loc)) reachable + pasVisible = S.filter (\ loc -> let (x,p) = passive (lmap `at` loc) + in any (\ d -> S.member (shift loc d) actVisible) p || + (not x && adjacent loc ploc)) + -- the above "not x" prevents walls from + -- being visible from the outside when + -- adjacent + reachable + visible = S.union pasVisible actVisible + in + Perception reachable visible + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,6 @@ + +Installation via Cabal. + +There are two displays to choose from. One based on vty, +one based on gtk2hs. The gtk2hs variant is the default. +To get the other, pass -f-gtk to Setup configure. diff --git a/Random.hs b/Random.hs new file mode 100644 --- /dev/null +++ b/Random.hs @@ -0,0 +1,52 @@ +module Random (module Frequency, module Random) where + +import Data.Ratio +import qualified System.Random as R +import Control.Monad.State + +import Frequency + +type Rnd a = State R.StdGen a + +randomR :: (R.Random a) => (a, a) -> Rnd a +randomR r = State (R.randomR r) + +binaryChoice :: a -> a -> Rnd a +binaryChoice p0 p1 = + do + b <- randomR (False,True) + return (if b then p0 else p1) + +chance :: Rational -> Rnd Bool +chance r = + do + let n = numerator r + d = denominator r + k <- randomR (1,d) + return (k <= n) + +oneOf :: [a] -> Rnd a +oneOf xs = + do + r <- randomR (0, length xs - 1) + return (xs !! r) + +frequency :: Frequency a -> Rnd a +frequency (Frequency xs) = + do + r <- randomR (1, sum (map fst xs)) + return (frequency' r xs) + where + frequency' :: Int -> [(Int, a)] -> a + frequency' _ [(_, x)] = x + frequency' m ((n, x) : xs) + | m <= n = x + | otherwise = frequency' (m - n) xs + +rndToIO :: Rnd a -> IO a +rndToIO r = + do + g <- R.getStdGen + let (x,g') = runState r g + R.setStdGen g' + return x diff --git a/Save.hs b/Save.hs new file mode 100644 --- /dev/null +++ b/Save.hs @@ -0,0 +1,24 @@ +module Save where + +import System.Directory +import Control.Exception as E hiding (handle) + +import File +import Level +import State + +savefile = "LambdaHack.save" + +restoreGame :: IO (Either (Level, State) String) +restoreGame = + E.catch (do + r <- strictDecodeCompressedFile savefile + removeFile savefile + case r of + (x,y,z) -> (z :: Bool) `seq` return $ Left (x,y)) + (\ e -> case e of + _ -> return (Right $ "Restore failed: " ++ + (unwords . lines) (show e))) + +saveGame :: Level -> State -> IO () +saveGame lvl state = encodeCompressedFile savefile (lvl,state,False) diff --git a/State.hs b/State.hs new file mode 100644 --- /dev/null +++ b/State.hs @@ -0,0 +1,87 @@ +module State where + +import qualified Data.Map as M +import Control.Monad +import Data.Binary + +import Monster +import Geometry +import Level + +data State = State + { splayer :: Monster, + ssensory :: SensoryMode, + sdisplay :: DisplayMode, + stime :: Time, + sdungeon :: Dungeon + } + deriving Show + +defaultState ploc dng = + State + (defaultPlayer ploc) + Implicit Normal + 0 + dng + +updatePlayer :: State -> (Monster -> Monster) -> State +updatePlayer s f = s { splayer = f (splayer s) } + +toggleVision :: State -> State +toggleVision s = s { ssensory = if ssensory s == Vision then Implicit else Vision } + +toggleSmell :: State -> State +toggleSmell s = s { ssensory = if ssensory s == Smell then Implicit else Smell } + +toggleOmniscient :: State -> State +toggleOmniscient s = s { sdisplay = if sdisplay s == Omniscient then Normal else Omniscient } + +toggleTerrain :: State -> State +toggleTerrain s = s { sdisplay = case sdisplay s of Terrain 1 -> Normal; Terrain n -> Terrain (n-1); _ -> Terrain 4 } + +instance Binary State where + put (State player sense disp time dng) = + do + put player + put sense + put disp + put time + put dng + get = liftM5 State get get get get get + +data SensoryMode = + Implicit + | Vision + | Smell + deriving (Show, Eq) + +instance Binary SensoryMode where + put Implicit = putWord8 0 + put Vision = putWord8 1 + put Smell = putWord8 2 + get = do + tag <- getWord8 + case tag of + 0 -> return Implicit + 1 -> return Vision + 2 -> return Smell + _ -> fail "no parse (SensoryMode)" + +data DisplayMode = + Normal + | Omniscient + | Terrain Int + deriving (Show, Eq) + +instance Binary DisplayMode where + put Normal = putWord8 0 + put Omniscient = putWord8 1 + put (Terrain n) = putWord8 2 >> put n + get = do + tag <- getWord8 + case tag of + 0 -> return Normal + 1 -> return Omniscient + 2 -> liftM Terrain get + _ -> fail "no parse (DisplayMode)" + diff --git a/Strategy.hs b/Strategy.hs new file mode 100644 --- /dev/null +++ b/Strategy.hs @@ -0,0 +1,49 @@ +module Strategy where + +import Control.Monad + +import Frequency + +-- Monster strategies + +-- | A strategy is a choice of frequency tables. +newtype Strategy a = Strategy { runStrategy :: [Frequency a] } + deriving Show + +-- | Strategy is a monad. TODO: Can we write this as a monad transformer? +instance Monad Strategy where + return x = Strategy $ return (Frequency [(1, x)]) + m >>= f = Strategy $ + filter (\ (Frequency xs) -> not (null xs)) $ + [ Frequency [ (p * q, b) + | (p, a) <- runFrequency x, + y <- runStrategy (f a), + (q, b) <- runFrequency y ] + | x <- runStrategy m ] + +liftFrequency :: Frequency a -> Strategy a +liftFrequency f = Strategy [f] + +instance MonadPlus Strategy where + mzero = Strategy [] + mplus (Strategy xs) (Strategy ys) = Strategy (xs ++ ys) + +infixr 2 .| + +(.|) :: Strategy a -> Strategy a -> Strategy a +(.|) = mplus + +reject :: Strategy a +reject = mzero + +infix 3 .=> + +(.=>) :: Bool -> Strategy a -> Strategy a +p .=> m | p = m + | otherwise = mzero + +only :: (a -> Bool) -> Strategy a -> Strategy a +only p s = + do + x <- s + p x .=> return x diff --git a/Style.hs b/Style.hs new file mode 100644 --- /dev/null +++ b/Style.hs @@ -0,0 +1,355 @@ +-- +-- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation; either version 2 of +-- the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- + +-- +-- | Color manipulation +-- + +module Style where + +#include "config.h" + +import qualified Curses +import Data.ByteString (ByteString) + +import Data.Char (toLower) +import Data.Word (Word8) +import Data.Maybe (fromJust) +import Data.IORef (readIORef, writeIORef, newIORef, IORef) +import qualified Data.Map as M (fromList, empty, lookup, Map) + +import System.IO.Unsafe (unsafePerformIO) +import Control.Exception (handle) + +------------------------------------------------------------------------ + +-- | User-configurable colours +-- Each component of this structure corresponds to a fg\/bg colour pair +-- for an item in the ui +data UIStyle = UIStyle { + window :: !Style -- default window colour + , helpscreen :: !Style -- help screen + , titlebar :: !Style -- titlebar of window + , selected :: !Style -- currently playing track + , cursors :: !Style -- the scrolling cursor line + , combined :: !Style -- the style to use when the cursor is on the current track + , warnings :: !Style -- style for warnings + , blockcursor :: !Style -- style for the block cursor when typing text + , progress :: !Style -- style for the progress bar + } + +------------------------------------------------------------------------ + +-- | Colors +data Color + = RGB {-# UNPACK #-} !Word8 !Word8 !Word8 + | Default + | Reverse + deriving (Eq,Ord) + +-- | Foreground and background color pairs +data Style = Style {-# UNPACK #-} !Color !Color + deriving (Eq,Ord) + +-- | A list of such values (the representation is optimised) +data StringA + = Fast {-# UNPACK #-} !ByteString !Style + | FancyS {-# UNPACK #-} ![(ByteString,Style)] -- one line made up of segments + +------------------------------------------------------------------------ +-- +-- | Some simple colours (derivied from proxima\/src\/common\/CommonTypes.hs) +-- +-- But we don't have a light blue? +-- +black, grey, darkred, red, darkgreen, green, brown, yellow :: Color +darkblue, blue, purple, magenta, darkcyan, cyan, white, brightwhite :: Color +black = RGB 0 0 0 +grey = RGB 128 128 128 +darkred = RGB 139 0 0 +red = RGB 255 0 0 +darkgreen = RGB 0 100 0 +green = RGB 0 128 0 +brown = RGB 165 42 42 +yellow = RGB 255 255 0 +darkblue = RGB 0 0 139 +blue = RGB 0 0 255 +purple = RGB 128 0 128 +magenta = RGB 255 0 255 +darkcyan = RGB 0 139 139 +cyan = RGB 0 255 255 +white = RGB 165 165 165 +brightwhite = RGB 255 255 255 + +defaultfg, defaultbg, reversefg, reversebg :: Color +#if defined(HAVE_USE_DEFAULT_COLORS) +defaultfg = Default +defaultbg = Default +#else +defaultfg = white +defaultbg = black +#endif +reversefg = Reverse +reversebg = Reverse + +-- +-- | map strings to colors +-- +stringToColor :: String -> Maybe Color +stringToColor s = case map toLower s of + "black" -> Just black + "grey" -> Just grey + "darkred" -> Just darkred + "red" -> Just red + "darkgreen" -> Just darkgreen + "green" -> Just green + "brown" -> Just brown + "yellow" -> Just yellow + "darkblue" -> Just darkblue + "blue" -> Just blue + "purple" -> Just purple + "magenta" -> Just magenta + "darkcyan" -> Just darkcyan + "cyan" -> Just cyan + "white" -> Just white + "brightwhite" -> Just brightwhite + "default" -> Just Default + "reverse" -> Just Reverse + _ -> Nothing + +------------------------------------------------------------------------ +-- +-- | Set some colours, perform an action, and then reset the colours +-- +withStyle :: Style -> (IO ()) -> IO () +withStyle sty fn = uiAttr sty >>= setAttribute >> fn >> reset +{-# INLINE withStyle #-} + +-- +-- | manipulate the current attributes of the standard screen +-- Only set attr if it's different to the current one? +-- +setAttribute :: (Curses.Attr, Curses.Pair) -> IO () +setAttribute = uncurry Curses.attrSet +{-# INLINE setAttribute #-} + +-- +-- | Reset the screen to normal values +-- +reset :: IO () +reset = setAttribute (Curses.attr0, Curses.Pair 0) +{-# INLINE reset #-} + +-- +-- | And turn on the colours +-- +initcolours :: UIStyle -> IO () +initcolours sty = do + let ls = [helpscreen sty, warnings sty, window sty, + selected sty, titlebar sty, progress sty, + blockcursor sty, cursors sty, combined sty ] + (Style fg bg) = progress sty -- bonus style + + pairs <- initUiColors (ls ++ [Style bg bg, Style fg fg]) + writeIORef pairMap pairs + -- set the background + uiAttr (window sty) >>= \(_,p) -> Curses.bkgrndSet nullA p + +------------------------------------------------------------------------ +-- +-- | Set up the ui attributes, given a ui style record +-- +-- Returns an association list of pairs for foreground and bg colors, +-- associated with the terminal color pair that has been defined for +-- those colors. +-- +initUiColors :: [Style] -> IO PairMap +initUiColors stys = do + ls <- sequence [ uncurry fn m | m <- zip stys [1..] ] + return (M.fromList ls) + where + fn :: Style -> Int -> IO (Style, (Curses.Attr,Curses.Pair)) + fn sty p = do + let (CColor (a,fgc),CColor (b,bgc)) = style2curses sty + handle (\_ -> return ()) $ Curses.initPair (Curses.Pair p) fgc bgc + return (sty, (a `Curses.attrPlus` b, Curses.Pair p)) + +------------------------------------------------------------------------ +-- +-- | Getting from nice abstract colours to ncurses-settable values + +-- 20% of allocss occur here! But there's only 3 or 4 colours :/ +-- Every call to uiAttr +-- +uiAttr :: Style -> IO (Curses.Attr, Curses.Pair) +uiAttr sty = do + m <- readIORef pairMap + return $ lookupPair m sty +{-# INLINE uiAttr #-} + +-- | Given a curses color pair, find the Curses.Pair (i.e. the pair +-- curses thinks these colors map to) from the state +lookupPair :: PairMap -> Style -> (Curses.Attr, Curses.Pair) +lookupPair m s = case M.lookup s m of + Nothing -> (Curses.attr0, Curses.Pair 0) -- default settings + Just v -> v +{-# INLINE lookupPair #-} + +-- | Keep a map of nice style defs to underlying curses pairs, created at init time +type PairMap = M.Map Style (Curses.Attr, Curses.Pair) + +-- | map of Curses.Color pairs to ncurses terminal Pair settings +pairMap :: IORef PairMap +pairMap = unsafePerformIO $ newIORef M.empty +{-# NOINLINE pairMap #-} + +------------------------------------------------------------------------ +-- +-- Basic (ncurses) colours. +-- +defaultColor :: Curses.Color +defaultColor = fromJust $ Curses.color "default" + +cblack, cred, cgreen, cyellow, cblue, cmagenta, ccyan, cwhite :: Curses.Color +cblack = fromJust $ Curses.color "black" +cred = fromJust $ Curses.color "red" +cgreen = fromJust $ Curses.color "green" +cyellow = fromJust $ Curses.color "yellow" +cblue = fromJust $ Curses.color "blue" +cmagenta = fromJust $ Curses.color "magenta" +ccyan = fromJust $ Curses.color "cyan" +cwhite = fromJust $ Curses.color "white" + +-- +-- Combine attribute with another attribute +-- +setBoldA, setReverseA :: Curses.Attr -> Curses.Attr +setBoldA = flip Curses.setBold True +setReverseA = flip Curses.setReverse True + +-- +-- | Some attribute constants +-- +boldA, nullA, reverseA :: Curses.Attr +nullA = Curses.attr0 +boldA = setBoldA nullA +reverseA = setReverseA nullA + +------------------------------------------------------------------------ + +newtype CColor = CColor (Curses.Attr, Curses.Color) +-- +-- | Map Style rgb rgb colours to ncurses pairs +-- TODO a generic way to turn an rgb into the nearest curses color +-- +style2curses :: Style -> (CColor, CColor) +style2curses (Style fg bg) = (fgCursCol fg, bgCursCol bg) +{-# INLINE style2curses #-} + +fgCursCol :: Color -> CColor +fgCursCol c = case c of + RGB 0 0 0 -> CColor (nullA, cblack) + RGB 128 128 128 -> CColor (boldA, cblack) + RGB 139 0 0 -> CColor (nullA, cred) + RGB 255 0 0 -> CColor (boldA, cred) + RGB 0 100 0 -> CColor (nullA, cgreen) + RGB 0 128 0 -> CColor (boldA, cgreen) + RGB 165 42 42 -> CColor (nullA, cyellow) + RGB 255 255 0 -> CColor (boldA, cyellow) + RGB 0 0 139 -> CColor (nullA, cblue) + RGB 0 0 255 -> CColor (boldA, cblue) + RGB 128 0 128 -> CColor (nullA, cmagenta) + RGB 255 0 255 -> CColor (boldA, cmagenta) + RGB 0 139 139 -> CColor (nullA, ccyan) + RGB 0 255 255 -> CColor (boldA, ccyan) + RGB 165 165 165 -> CColor (nullA, cwhite) + RGB 255 255 255 -> CColor (boldA, cwhite) + Default -> CColor (nullA, defaultColor) + Reverse -> CColor (reverseA, defaultColor) + _ -> CColor (nullA, cblack) -- NB + +bgCursCol :: Color -> CColor +bgCursCol c = case c of + RGB 0 0 0 -> CColor (nullA, cblack) + RGB 128 128 128 -> CColor (nullA, cblack) + RGB 139 0 0 -> CColor (nullA, cred) + RGB 255 0 0 -> CColor (nullA, cred) + RGB 0 100 0 -> CColor (nullA, cgreen) + RGB 0 128 0 -> CColor (nullA, cgreen) + RGB 165 42 42 -> CColor (nullA, cyellow) + RGB 255 255 0 -> CColor (nullA, cyellow) + RGB 0 0 139 -> CColor (nullA, cblue) + RGB 0 0 255 -> CColor (nullA, cblue) + RGB 128 0 128 -> CColor (nullA, cmagenta) + RGB 255 0 255 -> CColor (nullA, cmagenta) + RGB 0 139 139 -> CColor (nullA, ccyan) + RGB 0 255 255 -> CColor (nullA, ccyan) + RGB 165 165 165 -> CColor (nullA, cwhite) + RGB 255 255 255 -> CColor (nullA, cwhite) + Default -> CColor (nullA, defaultColor) + Reverse -> CColor (reverseA, defaultColor) + _ -> CColor (nullA, cwhite) -- NB + +defaultSty :: Style +defaultSty = Style Default Default + +------------------------------------------------------------------------ +-- +-- Support for runtime configuration +-- We choose a simple strategy, read/showable record types, with strings +-- to represent colors +-- +-- The fields must map to UIStyle +-- +-- It is this data type that is stored in 'show' format in ~/.hmp3 +-- +data Config = Config { + hmp3_window :: (String,String) + , hmp3_helpscreen :: (String,String) + , hmp3_titlebar :: (String,String) + , hmp3_selected :: (String,String) + , hmp3_cursors :: (String,String) + , hmp3_combined :: (String,String) + , hmp3_warnings :: (String,String) + , hmp3_blockcursor :: (String,String) + , hmp3_progress :: (String,String) + } deriving (Show,Read) + +-- +-- | Read the ~/.hmp3 file, and construct a UIStyle from it, to insert +-- into +-- +buildStyle :: Config -> UIStyle +buildStyle bs = UIStyle { + window = f $ hmp3_window bs + , helpscreen = f $ hmp3_helpscreen bs + , titlebar = f $ hmp3_titlebar bs + , selected = f $ hmp3_selected bs + , cursors = f $ hmp3_cursors bs + , combined = f $ hmp3_combined bs + , warnings = f $ hmp3_warnings bs + , blockcursor = f $ hmp3_blockcursor bs + , progress = f $ hmp3_progress bs + } + + where + f (x,y) = Style (g x) (g y) + g x = case stringToColor x of + Nothing -> Default + Just y -> y diff --git a/Turn.hs b/Turn.hs new file mode 100644 --- /dev/null +++ b/Turn.hs @@ -0,0 +1,393 @@ +module Turn where + +import Data.List as L +import Data.Map as M +import Data.Set as S +import Data.Char + +import State +import Geometry +import Level +import Dungeon +import Monster +import Actor +import Perception +import Item +import Display2 +import Random +import Save +import Message +import Version +import Strategy + +-- | Perform a complete turn (i.e., monster moves etc.) +loop :: Session -> Level -> State -> String -> IO () +loop session (lvl@(Level nm sz ms smap lmap lmeta)) + (state@(State { splayer = player@(Monster { mhp = php, mloc = ploc }), stime = time })) + oldmsg = + do + -- update smap + let nsmap = M.insert ploc (time + smellTimeout) smap + -- determine player perception + let per = perception ploc lmap + -- perform monster moves + handleMonsters session (lvl { lsmell = nsmap }) state per oldmsg + +-- | Handle monster moves. The idea is that we perform moves +-- as long as there are monsters that have a move time which is +-- less than or equal to the current time. +handleMonsters :: Session -> Level -> State -> Perception -> String -> IO () +handleMonsters session lvl@(Level { lmonsters = ms }) + (state@(State { stime = time })) + per oldmsg = + -- for debugging: causes redraw of the current state for every monster move; slow! + -- displayLevel session lvl per state oldmsg >> + case ms of + [] -> -- there are no monsters, just continue + handlePlayer + (m@(Monster { mtime = mt }) : ms) + | mt > time -> -- all the monsters are not yet ready for another move, + -- so continue + handlePlayer + | mhp m <= 0 -> -- the monster dies + handleMonsters session (updateMonsters lvl (const ms)) + state per oldmsg + | otherwise -> -- monster m should move + handleMonster m session (updateMonsters lvl (const ms)) + state per oldmsg + where + nstate = state { stime = time + 1 } + + -- good place to do everything that has to be done for every *time* + -- unit; currently, that's monster generation + handlePlayer = + do + nlvl <- rndToIO (addMonster lvl (splayer nstate)) + handle session nlvl nstate per oldmsg + + +-- | Handle the move of a single monster. +handleMonster :: Monster -> Session -> Level -> State -> Perception -> String -> + IO () +handleMonster m session lvl@(Level { lmonsters = ms, lsmell = nsmap, lmap = lmap }) + (state@(State { splayer = player@(Monster { mloc = ploc }), stime = time })) + per oldmsg = + do + nl <- rndToIO (frequency (head (runStrategy (strategy m lvl state per .| wait)))) + + -- increase the monster move time and set direction + let nm = m { mtime = time + mspeed m, mdir = if nl == (0,0) then Nothing else Just nl } + let (act, nms) = insertMonster nm ms + let nlvl = updateMonsters lvl (const nms) + moveOrAttack + True + (\ nlvl np msg -> + handleMonsters session nlvl (updatePlayer state (const np)) per + (addMsg oldmsg msg)) + (handleMonsters session nlvl state per oldmsg) + nlvl player per + (AMonster act) + nl + +strategy :: Monster -> Level -> State -> Perception -> Strategy Loc +strategy m@(Monster { mtype = mt, mloc = me, mdir = mdir }) + lvl@(Level { lmonsters = ms, lsmell = nsmap, lmap = lmap }) + (state@(State { splayer = player@(Monster { mloc = ploc }), stime = time })) + per = + case mt of + Eye -> eye + FastEye -> eye + Nose -> nose + _ -> onlyAccessible moveRandomly + where + -- we check if the monster is visible by the player rather than if the + -- player is visible by the monster -- this is more efficient, but + -- won't be correct in the general situation + playerVisible = me `S.member` pvisible per + playerAdjacent = adjacent me ploc + towardsPlayer = towards (me, ploc) + onlyTowardsPlayer = only (\ x -> distance (towardsPlayer, x) <= 1) + onlyPreservesDir = only (\ x -> maybe True (\ d -> distance (neg d, x) > 1) mdir) + onlyUnoccupied = onlyMoves (unoccupied ms lmap) me + onlyAccessible = onlyMoves (accessible lmap me) me + smells = L.map fst $ + L.sortBy (\ (_,s1) (_,s2) -> compare s2 s1) $ + L.filter (\ (_,s) -> s > 0) $ + L.map (\ x -> (x, nsmap ! (me `shift` x) - time `max` 0)) moves + + eye = playerAdjacent .=> return towardsPlayer + .| (onlyUnoccupied $ onlyAccessible $ + playerVisible .=> onlyTowardsPlayer moveRandomly + .| onlyPreservesDir moveRandomly) + + nose = playerAdjacent .=> return towardsPlayer + .| (onlyAccessible $ + foldr (.|) reject (L.map return smells) + .| moveRandomly) + +onlyMoves :: (Dir -> Bool) -> Loc -> Strategy Dir -> Strategy Dir +onlyMoves p l = only (\ x -> p (l `shift` x)) + +moveRandomly :: Strategy Dir +moveRandomly = liftFrequency $ uniform moves + +wait :: Strategy Dir +wait = return (0,0) + +-- | Display current status and handle the turn of the player. +handle :: Session -> Level -> State -> Perception -> String -> IO () +handle session (lvl@(Level nm sz ms smap lmap lmeta)) + (state@(State { splayer = player@(Monster { mhp = php, mdir = pdir, mloc = ploc, mitems = pinv, mtime = ptime }), stime = time })) + per oldmsg = + do + -- check for player death + if php <= 0 + then do + displayCurrent (addMsg oldmsg ("You die ..." ++ more)) + getConfirm session + shutdown session + else -- check if the player can make another move yet + if ptime > time then handleMonsters session lvl state per oldmsg + -- NOTE: It's important to call handleMonsters here, not loop, + -- because loop does all sorts of calculations that are only + -- really necessary after the player has moved. + else do + displayCurrent oldmsg + let h = do + e <- nextEvent session + handleDirection e (move h) $ + handleDirection (L.map toLower e) run $ + handleModifier e h $ + case e of + "o" -> openclose True h + "c" -> openclose False h + "s" -> search h + + "less" -> lvlchange Up h + "greater" -> lvlchange Down h + + "comma" -> pickup h + + -- saving or ending the game + "S" -> saveGame lvl state >> shutdown session + "Q" -> shutdown session + "Escape" -> shutdown session + + -- wait + "space" -> loop session nlvl nstate "" + "period" -> loop session nlvl nstate "" + + -- look + "colon" -> displayCurrent (lookAt True nlmap ploc) >> h + + -- display modes + "V" -> handle session nlvl (toggleVision state) per oldmsg + "R" -> handle session nlvl (toggleSmell state) per oldmsg + "O" -> handle session nlvl (toggleOmniscient state) per oldmsg + "T" -> handle session nlvl (toggleTerrain state) per oldmsg + + -- meta information + "M" -> displayCurrent lmeta >> h + "v" -> displayCurrent version >> h + + s -> displayCurrent ("unknown command (" ++ s ++ ")") >> h + maybe h continueRun pdir + + where + + reachable = preachable per + visible = pvisible per + + displayCurrent = displayLevel session nlvl per state + + -- update player memory + nlmap = foldr (\ x m -> M.update (\ (t,_) -> Just (t,t)) x m) lmap (S.toList visible) + nlvl = updateLMap lvl (const nlmap) + + -- update player action time, and regenerate hitpoints + -- player HP regeneration, TODO: remove hardcoded max and time interval + nplayer = player { mtime = time + mspeed player, + mhp = if time `mod` 1500 == 0 then (php + 1) `min` playerHP else php } + nstate = updatePlayer state (const nplayer) + + -- picking up items + pickup abort = + do + -- check if something is here to pick up + let t = nlmap `at` ploc + case titems t of + [] -> displayCurrent "nothing here" >> abort + (i:rs) -> + case assignLetter (mletter nplayer) (mitems nplayer) of + Just l -> + let msg = -- (complete sentence, more adequate for monsters) + {- + subjectMonster (mtype player) ++ " " ++ + compoundVerbMonster (mtype player) "pick" "up" ++ " " ++ + objectItem (itype i) ++ "." + -} + [l] ++ " - " ++ objectItem (itype i) + nt = t { titems = rs } + plmap = M.insert ploc (nt, nt) nlmap + iplayer = nplayer { mitems = i { iletter = Just l } : mitems nplayer, + mletter = l } + in loop session (updateLMap lvl (const plmap)) + (updatePlayer nstate (const iplayer)) msg + Nothing -> displayCurrent "cannot carry anymore" >> abort + + -- open and close doors + openclose o abort = + do + displayCurrent "direction?" + e <- nextEvent session + handleDirection e (openclose' o abort) (displayCurrent "never mind" >> abort) + openclose' o abort dir = + let txt = if o then "open" else "closed" + dloc = shift ploc dir + in + case nlmap `at` dloc of + Tile d@(Door hv o') is + | secret o' -> displayCurrent "never mind" >> abort + | toOpen (not o) /= o' + -> displayCurrent ("already " ++ txt) >> abort + | not (unoccupied ms nlmap dloc) + -> displayCurrent "blocked" >> abort + | otherwise -> -- ok, we can open/close the door + let nt = Tile (Door hv (toOpen o)) is + clmap = M.insert (shift ploc dir) (nt, nt) nlmap + in loop session (updateLMap lvl (const clmap)) nstate "" + _ -> displayCurrent "never mind" >> abort + -- search for secret doors + search abort = + let searchTile (Tile (Door hv (Just n)) x,t') = Just $ (Tile (Door hv (Just (max (n - 1) 0))) x, t') + searchTile t = Just t + slmap = foldl (\ l m -> update searchTile (shift ploc m) l) nlmap moves + in loop session (updateLMap lvl (const slmap)) nstate "" + -- perform a level change + lvlchange vdir abort = + case nlmap `at` ploc of + Tile (Stairs vdir' next) is + | vdir == vdir' -> -- ok + case next of + Nothing -> -- exit dungeon + shutdown session + Just (nln, nloc) -> + -- perform level change + do + -- put back current level + -- (first put back, then get, in case we change to the same level!) + let full = putDungeonLevel lvl (sdungeon nstate) + -- get new level + (new, ndng) = getDungeonLevel nln full + lstate = nstate { sdungeon = ndng } + loop session new (updatePlayer lstate (const (player { mloc = nloc }))) "" + _ -> -- no stairs + let txt = if vdir == Up then "up" else "down" in + displayCurrent ("no stairs " ++ txt) >> abort + -- run into a direction + run dir = + do + let mplayer = nplayer { mdir = Just dir } + abort = handle session nlvl (updatePlayer state (const $ player { mdir = Nothing })) per "" + moveOrAttack + False -- attacks are disallowed while running + (\ l p -> loop session l (updatePlayer nstate (const p))) + abort + nlvl mplayer per APlayer dir + continueRun dir = + let abort = handle session nlvl (updatePlayer state (const $ player { mdir = Nothing })) per oldmsg + dloc = shift ploc dir + in case (oldmsg, nlmap `at` ploc) of + (_:_, _) -> abort + (_, Tile (Opening _) _) -> abort + (_, Tile (Door _ _) _) -> abort + (_, Tile (Stairs _ _) _) -> abort + _ + | accessible nlmap ploc dloc -> + moveOrAttack + False -- attacks are disallowed while running + (\ l p -> loop session l (updatePlayer nstate (const p))) + abort + nlvl nplayer per APlayer dir + (_, Tile Corridor _) -- direction change restricted to corridors + | otherwise -> + let ns = L.filter (\ x -> distance (neg dir,x) > 1 + && accessible nlmap ploc (ploc `shift` x)) moves + sns = L.filter (\ x -> distance (dir,x) <= 1) ns + in case ns of + [newdir] -> run newdir + _ -> case sns of + [newdir] -> run newdir + _ -> abort + _ -> abort + -- perform a player move + move abort dir = moveOrAttack + True -- attacks are allowed + (\ l p -> loop session l (updatePlayer nstate (const p))) + abort + nlvl nplayer per APlayer dir + +moveOrAttack :: Bool -> -- allow attacks? + (Level -> Player -> String -> IO a) -> -- success continuation + IO a -> -- failure continuation + Level -> -- the level + Player -> -- the player + Perception -> -- perception of the player + Actor -> -- who's moving? + Dir -> IO a +moveOrAttack allowAttacks + continue abort + nlvl@(Level { lmap = nlmap }) player per + actor dir + -- to prevent monsters from hitting themselves + | dir == (0,0) = continue nlvl player "" + -- At the moment, we check whether there is a monster before checking accessibility + -- i.e., we can attack a monster on a blocked location. For instance, + -- a monster on an open door can be attacked diagonally, and a + -- monster capable of moving through walls can be attacked from an + -- adjacent position. + | not (L.null attacked) = + if allowAttacks then + do + let damage m = case mhp m of + 1 -> m { mhp = 0, mtime = 0 } -- grant an immediate move to die + h -> m { mhp = h - 1 } + let combatVerb m + | mhp m > 0 = "hit" + | otherwise = "kill" + let combatMsg m = subjectMonster (mtype am) ++ " " ++ + verbMonster (mtype am) (combatVerb m) ++ " " ++ + objectMonster (mtype m) ++ "." + let perceivedMsg m + | mloc m `S.member` pvisible per = combatMsg m + | otherwise = "You hear some noises." + let sortmtime = sortBy (\ x y -> compare (mtime x) (mtime y)) + let updateVictims l p msg (a:r) = + updateActor damage (\ m l p -> updateVictims l p + (addMsg msg (perceivedMsg m)) r) + a l p + updateVictims l p msg [] = continue l {- (updateMonsters l sortmtime) -} p msg + updateVictims nlvl player "" attacked + else + abort + -- Perform a move. + | accessible nlmap aloc naloc = + updateActor (\ m -> m { mloc = naloc }) + (\ _ l p -> continue l p (if actor == APlayer + then lookAt False nlmap naloc else "")) + actor nlvl player + | otherwise = abort + where am :: Monster + am = getActor nlvl player actor + aloc :: Loc + aloc = mloc am + source = nlmap `at` aloc + naloc = shift aloc dir + target = nlmap `at` naloc + attackedPlayer = if mloc player == naloc then [APlayer] else [] + attackedMonsters = L.map AMonster $ + findIndices (\ m -> mloc m == naloc) (lmonsters nlvl) + attacked :: [Actor] + attacked = attackedPlayer ++ attackedMonsters + + diff --git a/Version.hs b/Version.hs new file mode 100644 --- /dev/null +++ b/Version.hs @@ -0,0 +1,12 @@ +module Version where + +import Data.Version + +-- Cabal +import qualified Paths_LambdaHack as Self (version) + +import Display + +version :: String +version = showVersion Self.version ++ " (" ++ displayId ++ " frontend)" +