Skip to content
Browse files

rename Attr.hs to Color.hs

  • Loading branch information...
1 parent d700b77 commit 0e2905afafa63af1d8f82141ee8c89041c11c2d2 @Mikolaj Mikolaj committed
Showing with 94 additions and 93 deletions.
  1. +1 −1 LambdaHack.cabal
  2. +1 −1 src/{Attr.hs → Color.hs}
  3. +14 −13 src/Display.hs
  4. +32 −32 src/Display/Curses.hs
  5. +7 −7 src/Display/Gtk.hs
  6. +21 −21 src/Display/Vty.hs
  7. +2 −2 src/Item.hs
  8. +2 −2 src/ItemKind.hs
  9. +2 −2 src/LevelState.hs
  10. +6 −6 src/MovableKind.hs
  11. +6 −6 src/Terrain.hs
View
2 LambdaHack.cabal
@@ -24,7 +24,7 @@ flag vty
executable LambdaHack
main-is: LambdaHack.hs
hs-source-dirs:src
- other-modules: Attr, Action, Actions, Command, Config, ConfigDefault,
+ other-modules: Action, Actions, Color, Command, Config, ConfigDefault,
Display, Dungeon, DungeonState, File,
FOV, FOV.Common, FOV.Digital, FOV.Permissive, FOV.Shadow,
Frequency, Geometry, GeometryRnd, Grammar,
View
2 src/Attr.hs → src/Color.hs
@@ -1,4 +1,4 @@
-module Attr where
+module Color where
import Control.Monad
import qualified Data.Binary as Binary
View
27 src/Display.hs
@@ -23,7 +23,7 @@ import Control.Monad.State hiding (State) -- for MonadIO, seems to be portable b
import Data.Maybe
import Message
-import qualified Attr
+import qualified Color
import State
import Geometry
import Level
@@ -133,11 +133,11 @@ displayLevel
lAt = if sOmn || sTer > 0 then at else rememberAt
sVisBG = if sVis
then \ vis rea -> if vis
- then Attr.Blue
+ then Color.Blue
else if rea
- then Attr.Magenta
- else Attr.defBG
- else \ vis rea -> Attr.defBG
+ then Color.Magenta
+ else Color.defBG
+ else \ vis rea -> Color.defBG
gItem = findItem (\ i -> iletter i == Just '$') pitems
gold = maybe 0 (icount . fst) gItem
hs = levelHeroList state
@@ -147,34 +147,35 @@ displayLevel
sml = ((smap ! loc) - time) `div` 100
viewMovable loc (Movable { mkind = mk })
| loc == ploc && ln == creturnLn cursor =
- (nsymbol mk, Attr.defBG) -- highlight player
+ (nsymbol mk, Color.defBG) -- highlight player
| otherwise = (nsymbol mk, ncolor mk)
viewSmell :: Int -> Char
viewSmell n
| n > 9 = '*'
| n < 0 = '-'
| otherwise = Char.intToDigit n
+ rainbow loc = toEnum (1 + snd loc `mod` 14)
(char, fg) =
case L.find (\ m -> loc == mloc m) (hs ++ ms) of
_ | sTer > 0 -> Terrain.viewTerrain sTer False (tterrain tile)
Just m | sOmn || vis -> viewMovable loc m
- _ | sSml && sml >= 0 -> (viewSmell sml, Attr.Green)
+ _ | sSml && sml >= 0 -> (viewSmell sml, rainbow loc)
| otherwise -> viewTile vis tile assocs
vis = S.member loc visible
rea = S.member loc reachable
bg = if ctargeting cursor && loc == clocation cursor
- then Attr.defFG -- highlight targeting cursor
+ then Color.defFG -- highlight targeting cursor
else sVisBG vis rea -- FOV debug
- reverseVideo = (Attr.defBG, Attr.defFG)
+ reverseVideo = (Color.defBG, Color.defFG)
optVisually (fg, bg) =
- if fg == Attr.defBG
+ if fg == Color.defBG
then reverseVideo
- else if bg == Attr.defFG && fg == Attr.defFG
+ else if bg == Color.defFG && fg == Color.defFG
then reverseVideo
else (fg, bg)
optComputationally (fg, bg) =
- let fgSet = if fg == Attr.defFG then id else D.setFG fg
- bgSet = if bg == Attr.defBG then id else D.setBG bg
+ let fgSet = if fg == Color.defFG then id else D.setFG fg
+ bgSet = if bg == Color.defBG then id else D.setBG bg
in fgSet . bgSet
set = optComputationally . optVisually $ (fg, bg)
in case over (loc `shift` ((sy+1) * n, 0)) of
View
64 src/Display/Curses.hs
@@ -13,14 +13,14 @@ import Data.Maybe
import Geometry
import qualified Keys as K (Key(..))
-import qualified Attr
+import qualified Color
displayId = "curses"
data Session =
Session
{ win :: Window,
- styles :: Map (Attr.Color, Attr.Color) C.CursesStyle }
+ styles :: Map (Color.Color, Color.Color) C.CursesStyle }
startup :: (Session -> IO ()) -> IO ()
startup k =
@@ -30,7 +30,7 @@ startup k =
let s = [ ((f,b), C.Style (toFColor f) (toBColor b))
| f <- [minBound..maxBound],
-- No more color combinations possible: 16*4, 64 is max.
- b <- [Attr.Black, Attr.White, Attr.Blue, Attr.Magenta ] ]
+ b <- [Color.Black, Color.White, Color.Blue, Color.Magenta ] ]
nr <- colorPairs
when (nr < L.length s) $
C.end >>
@@ -48,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 ! (Attr.defFG, Attr.defBG)
- canonical (c, d) = (fromMaybe Attr.defFG c, fromMaybe Attr.defBG d)
+ let defaultStyle = s ! (Color.defFG, Color.defBG)
+ canonical (c, d) = (fromMaybe Color.defFG c, fromMaybe Color.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]
@@ -102,37 +102,37 @@ nextEvent session =
e <- C.getKey refresh
maybe (nextEvent session) return (keyTranslate e)
-type Attr = (Maybe Attr.Color, Maybe Attr.Color)
+type Attr = (Maybe Color.Color, Maybe Color.Color)
setFG c (_, b) = (Just c, b)
setBG c (f, _) = (f, Just c)
defaultAttr = (Nothing, Nothing)
-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
+toFColor :: Color.Color -> C.ForegroundColor
+toFColor Color.Black = C.BlackF
+toFColor Color.Red = C.DarkRedF
+toFColor Color.Green = C.DarkGreenF
+toFColor Color.Yellow = C.BrownF
+toFColor Color.Blue = C.DarkBlueF
+toFColor Color.Magenta = C.PurpleF
+toFColor Color.Cyan = C.DarkCyanF
+toFColor Color.White = C.WhiteF
+toFColor Color.BrBlack = C.GreyF
+toFColor Color.BrRed = C.RedF
+toFColor Color.BrGreen = C.GreenF
+toFColor Color.BrYellow = C.YellowF
+toFColor Color.BrBlue = C.BlueF
+toFColor Color.BrMagenta = C.MagentaF
+toFColor Color.BrCyan = C.CyanF
+toFColor Color.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 :: Color.Color -> C.BackgroundColor
+toBColor Color.Black = C.BlackB
+toBColor Color.Red = C.DarkRedB
+toBColor Color.Green = C.DarkGreenB
+toBColor Color.Yellow = C.BrownB
+toBColor Color.Blue = C.DarkBlueB
+toBColor Color.Magenta = C.PurpleB
+toBColor Color.Cyan = C.DarkCyanB
+toBColor Color.White = C.WhiteB
toBColor _ = C.BlackB -- a limitation of curses
View
14 src/Display/Gtk.hs
@@ -13,7 +13,7 @@ import Data.Map as M
import Geometry
import qualified Keys as K (Key(..))
-import qualified Attr
+import qualified Color
displayId = "gtk"
@@ -78,8 +78,8 @@ startup k =
return True
_ -> return False)
- let black = Color minBound minBound minBound -- Attr.defBG == Attr.Black
- white = Color 0xAAAA 0xAAAA 0xAAAA -- Attr.defFG == Attr.White
+ let black = Color minBound minBound minBound -- Color.defBG == Color.Black
+ white = Color 0xAAAA 0xAAAA 0xAAAA -- Color.defFG == Color.White
widgetModifyBase tv StateNormal black
widgetModifyText tv StateNormal white
@@ -179,8 +179,8 @@ nextEvent session =
type Attr = [AttrKey]
data AttrKey =
- FG Attr.Color
- | BG Attr.Color
+ FG Color.Color
+ | BG Color.Color
deriving (Eq, Ord)
setBG c = (BG c :)
@@ -188,5 +188,5 @@ setFG c = (FG c :)
defaultAttr = []
doAttr :: TextTag -> AttrKey -> IO ()
-doAttr tt (FG color) = set tt [ textTagForeground := Attr.colorToRGB color ]
-doAttr tt (BG color) = set tt [ textTagBackground := Attr.colorToRGB color ]
+doAttr tt (FG color) = set tt [ textTagForeground := Color.colorToRGB color ]
+doAttr tt (BG color) = set tt [ textTagBackground := Color.colorToRGB color ]
View
42 src/Display/Vty.hs
@@ -9,7 +9,7 @@ import qualified Data.ByteString as BS
import Geometry
import qualified Keys as K (Key(..))
-import qualified Attr
+import qualified Color
displayId = "vty"
@@ -66,27 +66,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.
-hack c a = if Attr.isBright c then with_style a bold else a
+hack c a = if Color.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)
-defaultAttr = def_attr { attr_fore_color = SetTo (aToc Attr.defFG),
- attr_back_color = SetTo (aToc Attr.defBG) }
+defaultAttr = def_attr { attr_fore_color = SetTo (aToc Color.defFG),
+ attr_back_color = SetTo (aToc Color.defBG) }
-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
+aToc :: Color.Color -> Color
+aToc Color.Black = black
+aToc Color.Red = red
+aToc Color.Green = green
+aToc Color.Yellow = yellow
+aToc Color.Blue = blue
+aToc Color.Magenta = magenta
+aToc Color.Cyan = cyan
+aToc Color.White = white
+aToc Color.BrBlack = bright_black
+aToc Color.BrRed = bright_red
+aToc Color.BrGreen = bright_green
+aToc Color.BrYellow = bright_yellow
+aToc Color.BrBlue = bright_blue
+aToc Color.BrMagenta = bright_magenta
+aToc Color.BrCyan = bright_cyan
+aToc Color.BrWhite = bright_white
View
4 src/Item.hs
@@ -11,7 +11,7 @@ import Control.Monad
import Random
import ItemKind
-import Attr
+import qualified Color
data Item = Item
{ ikind :: !Int,
@@ -56,7 +56,7 @@ getFlavour assocs ik =
then head (jflavour kind)
else assocs IM.! ik
-viewItem :: Int -> Assocs -> (Char, Attr.Color)
+viewItem :: Int -> Assocs -> (Char, Color.Color)
viewItem ik assocs = (jsymbol (getIK ik), getFlavour assocs ik)
-- Not really satisfactory. Should be configurable, not hardcoded.
View
4 src/ItemKind.hs
@@ -4,7 +4,7 @@ import Data.Binary
import qualified Data.List as L
import qualified Data.IntMap as IM
-import Attr
+import Color
data ItemKind = ItemKind
{ jsymbol :: !Char
@@ -20,7 +20,7 @@ data ItemKind = ItemKind
-- a + b * lvl + roll(c + d * lvl)
type Roll = (Word8, Word8, Word8, Word8)
-type Flavour = Attr.Color -- the simplest possible; add "speckled", etc. later
+type Flavour = Color -- the simplest possible; add "speckled", etc. later
data Effect =
NoEffect
View
4 src/LevelState.hs
@@ -1,6 +1,6 @@
module LevelState where
-import qualified Attr
+import qualified Color
import Geometry
import Level
import State
@@ -8,7 +8,7 @@ import Item
import Grammar
import qualified Terrain
-viewTile :: Bool -> Tile -> Assocs -> (Char, Attr.Color)
+viewTile :: Bool -> Tile -> Assocs -> (Char, Color.Color)
viewTile b (Tile t []) a = Terrain.viewTerrain 0 b t
viewTile b (Tile t (i:_)) a = Item.viewItem (ikind i) a
View
12 src/MovableKind.hs
@@ -5,7 +5,7 @@ import Control.Monad
import Geometry
import Random
-import qualified Attr
+import qualified Color
-- | Monster properties that are changing rarely and permanently.
data MovableKind = MovableKind
@@ -13,7 +13,7 @@ data MovableKind = MovableKind
nhpMax :: !Int, -- ^ maximal possible and initial hp
nspeed :: !Time, -- ^ natural speed
nsymbol :: !Char, -- ^ map symbol
- ncolor :: !Attr.Color, -- ^ map color
+ ncolor :: !Color.Color, -- ^ map color
nname :: String, -- ^ name
nsight :: !Bool, -- ^ can it see?
nsmell :: !Bool, -- ^ can it smell?
@@ -62,7 +62,7 @@ hero = MovableKind
nspeed = 10,
nsymbol = '@',
nname = "you",
- ncolor = Attr.BrWhite, -- Heroes white, monsters colorful.
+ ncolor = Color.BrWhite, -- Heroes white, monsters colorful.
nsight = True,
nsmell = False,
niq = 13, -- Can see that secret doors under alien control.
@@ -75,7 +75,7 @@ eye = MovableKind
nhpMax = 12,
nspeed = 10,
nsymbol = 'e',
- ncolor = Attr.BrRed,
+ ncolor = Color.BrRed,
nname = "the reducible eye",
nsight = True,
nsmell = False,
@@ -88,7 +88,7 @@ fastEye = MovableKind
nhpMax = 6,
nspeed = 4,
nsymbol = 'e',
- ncolor = Attr.BrBlue,
+ ncolor = Color.BrBlue,
nname = "the super-fast eye",
nsight = True,
nsmell = False,
@@ -101,7 +101,7 @@ nose = MovableKind
nhpMax = 13,
nspeed = 11,
nsymbol = 'n',
- ncolor = Attr.Green,
+ ncolor = Color.Green,
nname = "the point-free nose",
nsight = False,
nsmell = True,
View
12 src/Terrain.hs
@@ -5,7 +5,7 @@ import Control.Monad
import Data.Binary
import Data.Maybe
-import qualified Attr
+import qualified Color
import Geometry
-- TODO: let terrain kinds be defined in a config file. Group them
@@ -192,11 +192,11 @@ lookTerrain _ = ""
-- 4: only rooms
--
-- The Bool indicates whether the loc is currently visible.
-viewTerrain :: Int -> Bool -> Terrain a -> (Char, Attr.Color)
+viewTerrain :: Int -> Bool -> Terrain a -> (Char, Color.Color)
viewTerrain n b t =
- let def = if b then Attr.BrWhite else Attr.defFG
- defDark = if b then Attr.BrYellow else Attr.BrBlack
- defDoor = if b then Attr.Yellow else Attr.BrBlack
+ let def = if b then Color.BrWhite else Color.defFG
+ defDark = if b then Color.BrYellow else Color.BrBlack
+ defDoor = if b then Color.Yellow else Color.BrBlack
in case t of
Rock -> (' ', def)
(Opening d)
@@ -205,7 +205,7 @@ viewTerrain n b t =
(Floor d) -> ('.', if d == Light then def else defDark)
Unknown -> (' ', def)
Corridor
- | n <= 3 -> ('#', if b then Attr.BrWhite else Attr.defFG)
+ | n <= 3 -> ('#', if b then Color.BrWhite else Color.defFG)
| otherwise -> viewTerrain 0 b Rock
(Wall p)
| p == O -> ('O', def)

0 comments on commit 0e2905a

Please sign in to comment.
Something went wrong with that request. Please try again.