From fb4db25ff8edc495c47fadb2626747df08c22cdc Mon Sep 17 00:00:00 2001 From: Mikolaj Date: Wed, 23 Mar 2011 22:23:20 +0100 Subject: [PATCH] simplify color management even more --- LambdaHack.cabal | 2 +- src/Attr.hs | 74 ++++++++++++++++++++++++++++ src/Display/Curses.hs | 111 ++++++++++++++---------------------------- src/Display/Gtk.hs | 83 ++++--------------------------- src/Display/Vty.hs | 37 +++++++++----- src/Display2.hs | 17 ++++--- src/Item.hs | 30 ++++++------ src/Level.hs | 36 +++++++------- src/LevelState.hs | 4 +- src/Monster.hs | 32 ++++++------ src/StrategyState.hs | 1 - 11 files changed, 204 insertions(+), 223 deletions(-) create mode 100644 src/Attr.hs diff --git a/LambdaHack.cabal b/LambdaHack.cabal index be679af3e..90f95ad06 100644 --- a/LambdaHack.cabal +++ b/LambdaHack.cabal @@ -24,7 +24,7 @@ flag vty executable LambdaHack main-is: LambdaHack.hs hs-source-dirs:src - other-modules: Action, Actions, Command, Config, ConfigDefault, + other-modules: Attr, Action, Actions, Command, Config, ConfigDefault, Display, Display2, Dungeon, DungeonState, File, FOV, FOV.Common, FOV.Digital, FOV.Permissive, FOV.Shadow, Frequency, Geometry, Grammar, diff --git a/src/Attr.hs b/src/Attr.hs new file mode 100644 index 000000000..a8c58864c --- /dev/null +++ b/src/Attr.hs @@ -0,0 +1,74 @@ +module Attr where + +import qualified Data.Binary + +data Color = + Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + | BrBlack + | BrRed + | BrGreen + | BrYellow + | BrBlue + | BrMagenta + | BrCyan + | BrWhite + deriving (Show, Eq, Ord, Enum, Bounded) + +instance Data.Binary.Binary Color where + put c = Data.Binary.putWord8 $ toEnum $ fromEnum c + get = do + c <- Data.Binary.getWord8 + return $ toEnum $ fromEnum c + +defBG, defFG :: Color +defBG = Black +defFG = White + +isBright :: Color -> Bool +isBright c = fromEnum c > 7 + +-- Mimics the Linux console; good old retro feel and more useful than xterm. +colorToRGB :: Color -> String +colorToRGB Black = "#000000" +colorToRGB Red = "#AA0000" +colorToRGB Green = "#00AA00" +colorToRGB Yellow = "#AA5500" +colorToRGB Blue = "#0000AA" +colorToRGB Magenta = "#AA00AA" +colorToRGB Cyan = "#00AAAA" +colorToRGB White = "#AAAAAA" +colorToRGB BrBlack = "#555555" +colorToRGB BrRed = "#FF5555" +colorToRGB BrGreen = "#55FF55" +colorToRGB BrYellow = "#FFFF55" +colorToRGB BrBlue = "#5555FF" +colorToRGB BrMagenta = "#FF55FF" +colorToRGB BrCyan = "#55FFFF" +colorToRGB BrWhite = "#FFFFFF" + +-- Human-readable names, for item descriptions. L +-- Lots of licentia poetica, since the colors are artificial and rarely seen. +colorToName :: Color -> String +colorToName Black = "black" +colorToName Red = "apple red" +colorToName Green = "forest green" +colorToName Yellow = "brown" +colorToName Blue = "ultramarine" +colorToName Magenta = "purple" +colorToName Cyan = "cyan" +colorToName White = "silver gray" +colorToName BrBlack = "charcoal" +colorToName BrRed = "coral red" +colorToName BrGreen = "emerald green" +colorToName BrYellow = "yellow" +colorToName BrBlue = "royal blue" +colorToName BrMagenta = "magenta" +colorToName BrCyan = "aquamarine" +colorToName BrWhite = "white" diff --git a/src/Display/Curses.hs b/src/Display/Curses.hs index b76b4ff80..6565a4274 100644 --- a/src/Display/Curses.hs +++ b/src/Display/Curses.hs @@ -1,10 +1,6 @@ module Display.Curses (displayId, startup, shutdown, - display, nextEvent, setBG, setFG, attr, Session, - black, red, green, yellow, blue, magenta, cyan, white, - bright_black, bright_red, bright_green, bright_yellow, - bright_blue, bright_magenta, bright_cyan, bright_white, - Display.Curses.Attr, AttrColor) where + display, nextEvent, setBG, setFG, attr, Session) where import UI.HSCurses.Curses as C hiding (setBold) import qualified UI.HSCurses.CursesHelper as C @@ -17,13 +13,14 @@ import Data.Maybe import Geometry import Keys as K +import qualified Attr displayId = "curses" data Session = Session { win :: Window, - styles :: Map (AttrColor, AttrColor) C.CursesStyle } + styles :: Map (Attr.Color, Attr.Color) C.CursesStyle } startup :: (Session -> IO ()) -> IO () startup k = @@ -32,7 +29,8 @@ startup k = cursSet CursorInvisible let s = [ ((f,b), C.Style (toFColor f) (toBColor b)) | f <- [minBound..maxBound], - b <- [Black, White, Blue, Magenta ] ] -- no more possible (4*16) + -- No more color combinations possible: 16*4, 64 is max. + b <- [Attr.Black, Attr.White, Attr.Blue, Attr.Magenta ] ] nr <- colorPairs when (nr < L.length s) $ C.end >> @@ -50,8 +48,8 @@ display ((y0,x0),(y1,x1)) (Session { win = w, styles = s }) f msg status = do -- let defaultStyle = C.defaultCursesStyle -- Terminals with white background require this and more: - let defaultStyle = s ! (White, Black) - canonical (c, d) = (fromMaybe White c, fromMaybe Black d) + let defaultStyle = s ! (Attr.defFG, Attr.defBG) + canonical (c, d) = (fromMaybe Attr.defFG c, fromMaybe Attr.defBG d) C.erase mvWAddStr w 0 0 msg sequence_ [ let (a,c) = f (y,x) in C.setStyle (findWithDefault defaultStyle (canonical a) s) >> mvWAddStr w (y+1) x [c] @@ -104,74 +102,37 @@ nextEvent session = e <- C.getKey refresh maybe (nextEvent session) return (keyTranslate e) -type Attr = (Maybe AttrColor, Maybe AttrColor) +type Attr = (Maybe Attr.Color, Maybe Attr.Color) setFG c (_, b) = (Just c, b) setBG c (f, _) = (f, Just c) attr = (Nothing, Nothing) -data AttrColor = - Black - | Red - | Green - | Yellow - | Blue - | Magenta - | Cyan - | White - | BrBlack - | BrRed - | BrGreen - | BrYellow - | BrBlue - | BrMagenta - | BrCyan - | BrWhite - deriving (Show, Eq, Ord, Enum, Bounded) - -toFColor :: AttrColor -> C.ForegroundColor -toFColor Black = C.BlackF -toFColor Red = C.DarkRedF -toFColor Green = C.DarkGreenF -toFColor Yellow = C.BrownF -toFColor Blue = C.DarkBlueF -toFColor Magenta = C.PurpleF -toFColor Cyan = C.DarkCyanF -toFColor White = C.WhiteF -toFColor BrBlack = C.GreyF -toFColor BrRed = C.RedF -toFColor BrGreen = C.GreenF -toFColor BrYellow = C.YellowF -toFColor BrBlue = C.BlueF -toFColor BrMagenta = C.MagentaF -toFColor BrCyan = C.CyanF -toFColor BrWhite = C.BrightWhiteF - -toBColor :: AttrColor -> C.BackgroundColor -toBColor Black = C.BlackB -toBColor Red = C.DarkRedB -toBColor Green = C.DarkGreenB -toBColor Yellow = C.BrownB -toBColor Blue = C.DarkBlueB -toBColor Magenta = C.PurpleB -toBColor Cyan = C.DarkCyanB -toBColor White = C.WhiteB -toBColor _ = C.BlackB -- a limitation of curses - -black = Black -red = Red -green = Green -yellow = Yellow -blue = Blue -magenta = Magenta -cyan = Cyan -white = White - -bright_black = BrBlack -bright_red = BrRed -bright_green = BrGreen -bright_yellow = BrYellow -bright_blue = BrBlue -bright_magenta = BrMagenta -bright_cyan = BrCyan -bright_white = BrWhite +toFColor :: Attr.Color -> C.ForegroundColor +toFColor Attr.Black = C.BlackF +toFColor Attr.Red = C.DarkRedF +toFColor Attr.Green = C.DarkGreenF +toFColor Attr.Yellow = C.BrownF +toFColor Attr.Blue = C.DarkBlueF +toFColor Attr.Magenta = C.PurpleF +toFColor Attr.Cyan = C.DarkCyanF +toFColor Attr.White = C.WhiteF +toFColor Attr.BrBlack = C.GreyF +toFColor Attr.BrRed = C.RedF +toFColor Attr.BrGreen = C.GreenF +toFColor Attr.BrYellow = C.YellowF +toFColor Attr.BrBlue = C.BlueF +toFColor Attr.BrMagenta = C.MagentaF +toFColor Attr.BrCyan = C.CyanF +toFColor Attr.BrWhite = C.BrightWhiteF + +toBColor :: Attr.Color -> C.BackgroundColor +toBColor Attr.Black = C.BlackB +toBColor Attr.Red = C.DarkRedB +toBColor Attr.Green = C.DarkGreenB +toBColor Attr.Yellow = C.BrownB +toBColor Attr.Blue = C.DarkBlueB +toBColor Attr.Magenta = C.PurpleB +toBColor Attr.Cyan = C.DarkCyanB +toBColor Attr.White = C.WhiteB +toBColor _ = C.BlackB -- a limitation of curses diff --git a/src/Display/Gtk.hs b/src/Display/Gtk.hs index 39c0bc101..e0f3326cb 100644 --- a/src/Display/Gtk.hs +++ b/src/Display/Gtk.hs @@ -1,10 +1,6 @@ module Display.Gtk (displayId, startup, shutdown, - display, nextEvent, setBG, setFG, attr, Session, - black, red, green, yellow, blue, magenta, cyan, white, - bright_black, bright_red, bright_green, bright_yellow, - bright_blue, bright_magenta, bright_cyan, bright_white, - Attr, AttrColor) where + display, nextEvent, setBG, setFG, attr, Session) where import qualified Data.Binary import Control.Monad @@ -17,6 +13,7 @@ import Data.Map as M import Geometry import Keys as K +import qualified Attr displayId = "gtk" @@ -40,7 +37,7 @@ startup k = tt <- textTagNew Nothing textTagTableAdd ttt tt doAttr tt c - return (c,tt)) + return (c, tt)) [ x | c <- [minBound .. maxBound], x <- [FG c, BG c]] -- text buffer @@ -81,8 +78,8 @@ startup k = return True _ -> return False) - let black = Color minBound minBound minBound - white = Color 0xAAAA 0xAAAA 0xAAAA -- White, see below + let black = Color minBound minBound minBound -- Attr.defBG == Attr.Black + white = Color 0xAAAA 0xAAAA 0xAAAA -- Attr.defFG == Attr.White widgetModifyBase tv StateNormal black widgetModifyText tv StateNormal white @@ -182,8 +179,8 @@ nextEvent session = type Attr = [AttrKey] data AttrKey = - FG AttrColor - | BG AttrColor + FG Attr.Color + | BG Attr.Color deriving (Eq, Ord) setBG c = (BG c :) @@ -191,67 +188,5 @@ setFG c = (FG c :) attr = [] doAttr :: TextTag -> AttrKey -> IO () -doAttr tt (FG color) = set tt [ textTagForeground := colorToRGB color ] -doAttr tt (BG color) = set tt [ textTagBackground := colorToRGB color ] - -data AttrColor = -- TODO: move and use in vty, too - Black - | Red - | Green - | Yellow - | Blue - | Magenta - | Cyan - | White - | BrBlack - | BrRed - | BrGreen - | BrYellow - | BrBlue - | BrMagenta - | BrCyan - | BrWhite - deriving (Show, Eq, Ord, Enum, Bounded) - -instance Data.Binary.Binary AttrColor where - put c = Data.Binary.putWord8 $ toEnum $ fromEnum c - get = do - c <- Data.Binary.getWord8 - return $ toEnum $ fromEnum c - --- Mimics the Linux console; good old retro feel and more useful than xterm. -colorToRGB :: AttrColor -> String -colorToRGB Black = "#000000" -colorToRGB Red = "#AA0000" -colorToRGB Green = "#00AA00" -colorToRGB Yellow = "#AA5500" -colorToRGB Blue = "#0000AA" -colorToRGB Magenta = "#AA00AA" -colorToRGB Cyan = "#00AAAA" -colorToRGB White = "#AAAAAA" -colorToRGB BrBlack = "#555555" -colorToRGB BrRed = "#FF5555" -colorToRGB BrGreen = "#55FF55" -colorToRGB BrYellow = "#FFFF55" -colorToRGB BrBlue = "#5555FF" -colorToRGB BrMagenta = "#FF55FF" -colorToRGB BrCyan = "#55FFFF" -colorToRGB BrWhite = "#FFFFFF" - -black = Black -red = Red -green = Green -yellow = Yellow -blue = Blue -magenta = Magenta -cyan = Cyan -white = White - -bright_black = BrBlack -bright_red = BrRed -bright_green = BrGreen -bright_yellow = BrYellow -bright_blue = BrBlue -bright_magenta = BrMagenta -bright_cyan = BrCyan -bright_white = BrWhite +doAttr tt (FG color) = set tt [ textTagForeground := Attr.colorToRGB color ] +doAttr tt (BG color) = set tt [ textTagBackground := Attr.colorToRGB color ] diff --git a/src/Display/Vty.hs b/src/Display/Vty.hs index 6411438c2..1439e80d8 100644 --- a/src/Display/Vty.hs +++ b/src/Display/Vty.hs @@ -1,10 +1,6 @@ module Display.Vty (displayId, startup, shutdown, - display, nextEvent, setBG, setFG, attr, Session, - black, red, green, yellow, blue, magenta, cyan, white, - bright_black, bright_red, bright_green, bright_yellow, - bright_blue, bright_magenta, bright_cyan, bright_white, - Attr, AttrColor) where + display, nextEvent, setBG, setFG, attr, Session) where import Graphics.Vty as V import Data.List as L @@ -13,6 +9,7 @@ import qualified Data.ByteString as BS import Geometry import Keys as K +import qualified Attr displayId = "vty" @@ -67,13 +64,27 @@ nextEvent session = -- A hack to get bright colors via the bold attribute. Depending on terminal -- settings this is needed or not and the characters really get bold or not. -- HCurses does this by default, but vty refuses to get crazy. -isBright c = c `elem` [bright_black, bright_red, bright_green, bright_yellow, - bright_blue, bright_magenta, bright_cyan, bright_white] -hack c a = if isBright c then with_style a bold else a -setFG c a = hack c $ with_fore_color a c -setBG c a = hack c $ with_back_color a c +hack c a = if Attr.isBright c then with_style a bold else a +setFG c a = hack c $ with_fore_color a (aToc c) +setBG c a = hack c $ with_back_color a (aToc c) -attr = def_attr { attr_fore_color = SetTo white, - attr_back_color = SetTo black } +attr = def_attr { attr_fore_color = SetTo (aToc Attr.defFG), + attr_back_color = SetTo (aToc Attr.defBG) } -type AttrColor = Color +aToc :: Attr.Color -> Color +aToc Attr.Black = black +aToc Attr.Red = red +aToc Attr.Green = green +aToc Attr.Yellow = yellow +aToc Attr.Blue = blue +aToc Attr.Magenta = magenta +aToc Attr.Cyan = cyan +aToc Attr.White = white +aToc Attr.BrBlack = bright_black +aToc Attr.BrRed = bright_red +aToc Attr.BrGreen = bright_green +aToc Attr.BrYellow = bright_yellow +aToc Attr.BrBlue = bright_blue +aToc Attr.BrMagenta = bright_magenta +aToc Attr.BrCyan = bright_cyan +aToc Attr.BrWhite = bright_white diff --git a/src/Display2.hs b/src/Display2.hs index be68cfd57..b1f288431 100644 --- a/src/Display2.hs +++ b/src/Display2.hs @@ -10,6 +10,7 @@ import Control.Monad.State hiding (State) -- for MonadIO, seems to be portable b import Message import Display +import qualified Attr import State import Geometry import Level @@ -163,8 +164,8 @@ displayLevel session per 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 + if vis then setBG Attr.Blue + else if rea then setBG Attr.Magenta else id else \ vis rea -> id (n,over) = stringByLocation (sy+1) overlay -- n is the number of overlay screens @@ -179,21 +180,21 @@ displayLevel session per rea = S.member loc reachable (rv,ra) = case L.find (\ m -> loc == mloc m) (hs ++ ms) of _ | sTer > 0 -> viewTerrain sTer False (tterrain tile) - Just m | sOmn || vis -> (nsymbol (mtype m), if mloc m == ploc then black else (ncolor (mtype m))) + Just m | sOmn || vis -> (nsymbol (mtype m), if mloc m == ploc then Attr.defBG else (ncolor (mtype m))) _ | sSml && sml >= 0 -> viewSmell sml | otherwise -> viewTile vis tile assocs (vision, ra2) = if ctargeting (scursor state) && loc == clocation (scursor state) - then (setBG white, - if ra == white then black else ra) - else if ra == black - then (setBG white, ra) + then (setBG Attr.defFG, + if ra == Attr.defFG then Attr.defBG else ra) + else if ra == Attr.defBG + then (setBG Attr.defFG, ra) else (lVision vis rea, ra) in case over (loc `shift` ((sy+1) * n, 0)) of Just c -> (attr, c) - _ -> (vision . (if ra2 == white then id else setFG ra2) $ attr, rv)) + _ -> (vision . (if ra2 == Attr.defFG then id else setFG ra2) $ attr, rv)) msg (take 40 (levelName nm ++ repeat ' ') ++ take 10 ("$: " ++ show gold ++ repeat ' ') ++ diff --git a/src/Item.hs b/src/Item.hs index ec05aeb6c..b0a4b62a9 100644 --- a/src/Item.hs +++ b/src/Item.hs @@ -11,7 +11,7 @@ import Data.Char import Data.Function import Control.Monad -import qualified Display +import qualified Attr import Geometry import Random @@ -201,22 +201,22 @@ letterLabel :: Maybe Char -> String letterLabel Nothing = " " letterLabel (Just c) = c : " - " -viewItem :: ItemType -> Assocs -> (Char, Display.AttrColor) +viewItem :: ItemType -> Assocs -> (Char, Attr.Color) viewItem i a = viewItem' i (M.lookup i a) where - wh = Display.white - viewItem' (Sword {}) _ = (')', wh) - viewItem' Dart _ = (')', wh) - viewItem' Ring _ = ('=', wh) - viewItem' Scroll _ = ('?', wh) - viewItem' (Potion {}) (Just Clear) = ('!', Display.bright_blue) - viewItem' (Potion {}) (Just White) = ('!', Display.bright_cyan) - viewItem' (Potion {}) _ = ('!', wh) - viewItem' Wand _ = ('/', wh) - viewItem' Gold _ = ('$', Display.bright_yellow) - viewItem' Gem _ = ('*', Display.bright_magenta) - viewItem' Amulet _ = ('"', wh) - viewItem' _ _ = ('~', wh) + def = Attr.defFG + viewItem' (Sword {}) _ = (')', def) + viewItem' Dart _ = (')', def) + viewItem' Ring _ = ('=', def) + viewItem' Scroll _ = ('?', def) + viewItem' (Potion {}) (Just Clear) = ('!', Attr.BrBlue) + viewItem' (Potion {}) (Just White) = ('!', Attr.BrCyan) + viewItem' (Potion {}) _ = ('!', def) + viewItem' Wand _ = ('/', def) + viewItem' Gold _ = ('$', Attr.BrYellow) + viewItem' Gem _ = ('*', Attr.BrMagenta) + viewItem' Amulet _ = ('"', def) + viewItem' _ _ = ('~', def) -- | Adds an item to a list of items, joining equal items. -- Also returns the joined item. diff --git a/src/Level.hs b/src/Level.hs index 4b1684f72..a6c8b65c8 100644 --- a/src/Level.hs +++ b/src/Level.hs @@ -17,7 +17,7 @@ import Geometry import Movable import Item import Random -import qualified Display +import qualified Attr -- | Names of the dungeon levels are represented using a -- custom data structure. @@ -506,7 +506,7 @@ lookTerrain (Door _ (Just _)) = "A wall." -- secret lookTerrain (Wall _ ) = "A wall." lookTerrain _ = "" -wh = Display.white +def = Attr.defFG -- | The parameter "n" is the level of evolution: -- -- 0: final @@ -516,42 +516,42 @@ wh = Display.white -- 4: only rooms -- -- The Bool indicates whether the loc is currently visible. -viewTerrain :: Int -> Bool -> Terrain -> (Char, Display.AttrColor) -viewTerrain n b Rock = (' ', wh) +viewTerrain :: Int -> Bool -> Terrain -> (Char, Attr.Color) +viewTerrain n b Rock = (' ', def) viewTerrain n b (Opening d) - | n <= 3 = ('.', wh) + | n <= 3 = ('.', def) | otherwise = viewTerrain 0 b (Wall d) -viewTerrain n b (Floor Light) = ('.', wh) -viewTerrain n b (Floor Dark) = if b then ('.', wh) else (' ', wh) -viewTerrain n b Unknown = (' ', wh) +viewTerrain n b (Floor Light) = ('.', def) +viewTerrain n b (Floor Dark) = if b then ('.', def) else (' ', def) +viewTerrain n b Unknown = (' ', def) viewTerrain n b Corridor - | n <= 3 = ('#', wh) + | n <= 3 = ('#', def) | otherwise = viewTerrain 0 b Rock viewTerrain n b (Wall p) - | p == O = ('O', wh) - | p `elem` [L, R] = ('|', wh) - | otherwise = ('-', wh) + | p == O = ('O', def) + | p `elem` [L, R] = ('|', def) + | otherwise = ('-', def) viewTerrain n b (Stairs _ Up _) - | n <= 1 = ('<', wh) + | n <= 1 = ('<', def) | otherwise = viewTerrain 0 b (Floor Dark) viewTerrain n b (Stairs _ Down _) - | n <= 1 = ('>', wh) + | n <= 1 = ('>', def) | otherwise = viewTerrain 0 b (Floor Dark) viewTerrain n b (Door d (Just 0)) - | n <= 2 = ('+', Display.yellow) + | n <= 2 = ('+', Attr.Yellow) | otherwise = viewTerrain n b (Opening d) viewTerrain n b (Door d (Just _)) | n <= 2 = viewTerrain n b (Wall d) -- secret door | otherwise = viewTerrain n b (Opening d) viewTerrain n b (Door p Nothing) - | n <= 2 = (if p `elem` [L, R] then '-' else '|', Display.yellow) + | n <= 2 = (if p `elem` [L, R] then '-' else '|', Attr.Yellow) | otherwise = viewTerrain n b (Opening p) -viewSmell :: Int -> (Char, Display.AttrColor) +viewSmell :: Int -> (Char, Attr.Color) viewSmell n = let k | n > 9 = '*' | n < 0 = '-' | otherwise = head . show $ n - in (k, Display.green) + in (k, Attr.Green) -- TODO: Really scatter around, if more than one or location occupied? -- Scatter randomly or not? diff --git a/src/LevelState.hs b/src/LevelState.hs index bdd868d02..17af3c3ee 100644 --- a/src/LevelState.hs +++ b/src/LevelState.hs @@ -1,6 +1,6 @@ module LevelState where -import qualified Display +import qualified Attr import Geometry import Level import State @@ -8,7 +8,7 @@ import Item import ItemState import Grammar -viewTile :: Bool -> Tile -> Assocs -> (Char, Display.AttrColor) +viewTile :: Bool -> Tile -> Assocs -> (Char, Attr.Color) viewTile b (Tile t []) a = viewTerrain 0 b t viewTile b (Tile t (i:_)) a = viewItem (itype i) a diff --git a/src/Monster.hs b/src/Monster.hs index 383caddba..2a5eb100d 100644 --- a/src/Monster.hs +++ b/src/Monster.hs @@ -5,20 +5,20 @@ import Control.Monad import Geometry import Random -import qualified Display +import qualified Attr data MovableType = MovableType - { nhpMin :: !Int, -- ^ minimal initial hp - nhpMax :: !Int, -- ^ maximal possible and initial hp - nspeed :: !Time, -- ^ natural speed - nsymbol :: !Char, -- ^ map symbol - ncolor :: !Display.AttrColor, -- ^ map color - nname :: String, -- ^ name - nsight :: !Bool, -- ^ can it see? - nsmell :: !Bool, -- ^ can it smell? - niq :: !Int, -- ^ intelligence - nregen :: !Int, -- ^ regeneration interval - nfreq :: !Int -- ^ dungeon frequency + { nhpMin :: !Int, -- ^ minimal initial hp + nhpMax :: !Int, -- ^ maximal possible and initial hp + nspeed :: !Time, -- ^ natural speed + nsymbol :: !Char, -- ^ map symbol + ncolor :: !Attr.Color, -- ^ map color + nname :: String, -- ^ name + nsight :: !Bool, -- ^ can it see? + nsmell :: !Bool, -- ^ can it smell? + niq :: !Int, -- ^ intelligence + nregen :: !Int, -- ^ regeneration interval + nfreq :: !Int -- ^ dungeon frequency } deriving (Show, Eq) @@ -29,7 +29,7 @@ hero = MovableType nspeed = 10, nsymbol = '@', nname = "you", - ncolor = Display.bright_white, -- Heroes white, monsters colorful. + ncolor = Attr.BrWhite, -- Heroes white, monsters colorful. nsight = True, nsmell = False, niq = 13, -- Can see that secret doors under alien control. @@ -42,7 +42,7 @@ eye = MovableType nhpMax = 12, nspeed = 10, nsymbol = 'e', - ncolor = Display.bright_red, + ncolor = Attr.BrRed, nname = "the reducible eye", nsight = True, nsmell = False, @@ -55,7 +55,7 @@ fastEye = MovableType nhpMax = 6, nspeed = 4, nsymbol = 'e', - ncolor = Display.bright_blue, + ncolor = Attr.BrBlue, nname = "the super-fast eye", nsight = True, nsmell = False, @@ -68,7 +68,7 @@ nose = MovableType nhpMax = 13, nspeed = 11, nsymbol = 'n', - ncolor = Display.green, + ncolor = Attr.Green, nname = "the point-free nose", nsight = False, nsmell = True, diff --git a/src/StrategyState.hs b/src/StrategyState.hs index 1742b7ea8..4be524b14 100644 --- a/src/StrategyState.hs +++ b/src/StrategyState.hs @@ -55,7 +55,6 @@ strategy actor onlyAccessible = onlyMoves (accessible lmap me) me -- Monsters don't see doors more secret than that. Enforced when actually -- opening doors, too, so that monsters don't cheat. - -- TODO: vary the parameter per monster intelligence level. onlyOpenable = onlyMoves (openable (niq mt) lmap) me smells = L.map fst $ L.sortBy (\ (_,s1) (_,s2) -> compare s2 s1) $