LambdaHack 0.1.20080412 → 0.1.20080413
raw patch · 25 files changed
+2554/−1 lines, 25 files
Files
- Actor.hs +29/−0
- Display.hs +12/−0
- Display/Curses.hs +112/−0
- Display/Gtk.hs +158/−0
- Display/Vty.hs +51/−0
- Display2.hs +110/−0
- Dungeon.hs +214/−0
- FOV.hs +67/−0
- File.hs +22/−0
- Frequency.hs +31/−0
- Geometry.hs +42/−0
- Item.hs +98/−0
- LambdaHack.cabal +10/−1
- Level.hs +412/−0
- Message.hs +28/−0
- Monster.hs +147/−0
- Perception.hs +33/−0
- README +6/−0
- Random.hs +52/−0
- Save.hs +24/−0
- State.hs +87/−0
- Strategy.hs +49/−0
- Style.hs +355/−0
- Turn.hs +393/−0
- Version.hs +12/−0
+ Actor.hs view
@@ -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"++
+ Display.hs view
@@ -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+
+ Display/Curses.hs view
@@ -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)
+ Display/Gtk.hs view
@@ -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)
+ Display/Vty.hs view
@@ -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
+ Display2.hs view
@@ -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++
+ Dungeon.hs view
@@ -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+
+ FOV.hs view
@@ -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))+
+ File.hs view
@@ -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+
+ Frequency.hs view
@@ -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)
+ Geometry.hs view
@@ -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 ]
+ Item.hs view
@@ -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"
LambdaHack.cabal view
@@ -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 <mail@andres-loeh.de> maintainer: Andres Loeh <mail@andres-loeh.de> 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 } }
+ Level.hs view
@@ -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)+
+ Message.hs view
@@ -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 +
+ Monster.hs view
@@ -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)
+ Perception.hs view
@@ -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+
+ README view
@@ -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.
+ Random.hs view
@@ -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
+ Save.hs view
@@ -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)
+ State.hs view
@@ -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)"+
+ Strategy.hs view
@@ -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
+ Style.hs view
@@ -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
+ Turn.hs view
@@ -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++
+ Version.hs view
@@ -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)"+