Permalink
Browse files

simplify the frontend interface even more

  • Loading branch information...
Mikolaj committed Apr 5, 2011
1 parent 810d6ee commit e0ef25f048b9c21a055a7ebe76cb795a67ebcb71
Showing with 55 additions and 65 deletions.
  1. +4 −0 src/Color.hs
  2. +7 −11 src/Display.hs
  3. +7 −15 src/Display/Curses.hs
  4. +21 −28 src/Display/Gtk.hs
  5. +16 −11 src/Display/Vty.hs
View
@@ -30,6 +30,10 @@ defBG, defFG :: Color
defBG = Black
defFG = White
+type Attr = (Color.Color, Color.Color)
+defaultAttr :: Attr
+defaultAttr = (Color.defFG, Color.defBG)
+
isBright :: Color -> Bool
isBright c = fromEnum c > 7 -- for terminals that display bright via bold
View
@@ -60,7 +60,7 @@ nextCommand session =
displayBlankConfirm :: Session -> String -> IO Bool
displayBlankConfirm session txt =
let x = txt ++ more
- doBlank = const (D.defaultAttr, ' ')
+ doBlank = const (Color.defaultAttr, ' ')
in do
display ((0, 0), normalLevelSize) session doBlank x ""
getConfirm session
@@ -173,23 +173,19 @@ displayLevel
bg = if ctargeting cursor && loc == clocation cursor
then Color.defFG -- highlight targeting cursor
else sVisBG vis rea -- FOV debug
- reverseVideo = (Color.defBG, Color.defFG)
+ reverseVideo = (snd Color.defaultAttr, fst Color.defaultAttr)
optVisually (fg, bg) =
if fg == Color.defBG
then reverseVideo
else if bg == Color.defFG && fg == Color.defFG
then reverseVideo
else (fg, bg)
- optComputationally (fg, 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 = if blackAndWhite
- then const D.defaultAttr
- else optComputationally . optVisually $ (fg, bg)
+ a = if blackAndWhite
+ then Color.defaultAttr
+ else optVisually (fg, bg)
in case over (loc `shift` ((sy+1) * n, 0)) of
- Just c -> (D.defaultAttr, c)
- _ -> (set D.defaultAttr, char)
+ Just c -> (Color.defaultAttr, c)
+ _ -> (a, char)
status =
take 30 (levelName ln ++ repeat ' ') ++
take 10 ("T: " ++ show (time `div` 10) ++ repeat ' ') ++
View
@@ -1,15 +1,13 @@
module Display.Curses
- (displayId, startup, shutdown,
- display, nextEvent, setBG, setFG, defaultAttr, Session) where
+ (displayId, startup, shutdown, display, nextEvent, Session) where
-import UI.HSCurses.Curses as C hiding (setBold, Attr)
+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 Control.Monad
-import Data.Maybe
import Geometry
import qualified Keys as K (K.Key(..))
@@ -43,20 +41,20 @@ startup k =
shutdown :: Session -> IO ()
shutdown w = C.end
-display :: Area -> Session -> (Loc -> (Attr, Char)) -> String -> String -> IO ()
+display :: Area -> Session -> (Loc -> (Color.Attr, Char)) -> String -> String
+ -> IO ()
display ((y0,x0),(y1,x1)) (Session { win = w, styles = s }) f msg status =
do
-- let defaultStyle = C.defaultCursesStyle
-- Terminals with white background require this:
- let defaultStyle = s ! (Color.defFG, Color.defBG)
- canonical (c, d) = (fromMaybe Color.defFG c, fromMaybe Color.defBG d)
+ let defaultStyle = s ! Color.defaultAttr
C.erase
C.setStyle defaultStyle
mvWAddStr w 0 0 (toWidth (x1 - x0 + 1) msg) -- TODO: bytestring as in vty?
mvWAddStr w (y1+2) 0 (toWidth (x1 - x0 + 1) status)
- sequence_ [ C.setStyle (findWithDefault defaultStyle (canonical a) s)
+ sequence_ [ C.setStyle (findWithDefault defaultStyle a s)
>> mvWAddStr w (y+1) x [c]
- | x <- [x0..x1], y <- [y0..y1], let (a,c) = f (y,x) ]
+ | x <- [x0..x1], y <- [y0..y1], let (a, c) = f (y, x) ]
refresh
toWidth :: Int -> String -> String
@@ -98,12 +96,6 @@ nextEvent session =
-- Unknown _ -> nextEvent session
-- k -> return k
-type Attr = (Maybe Color.Color, Maybe Color.Color)
-
-setFG c (_, b) = (Just c, b)
-setBG c (f, _) = (f, Just c)
-defaultAttr = (Nothing, Nothing)
-
toFColor :: Color.Color -> C.ForegroundColor
toFColor Color.Black = C.BlackF
toFColor Color.Red = C.DarkRedF
View
@@ -1,12 +1,11 @@
module Display.Gtk
- (displayId, startup, shutdown,
- display, nextEvent, setBG, setFG, defaultAttr, Session) where
+ (displayId, startup, shutdown, display, nextEvent, Session) where
import qualified Data.Binary
import Control.Monad
import Control.Concurrent
import Graphics.UI.Gtk.Gdk.Events -- TODO: replace, deprecated
-import Graphics.UI.Gtk hiding (Attr)
+import Graphics.UI.Gtk
import Data.List as L
import Data.IORef
import Data.Map as M
@@ -20,7 +19,7 @@ displayId = "gtk"
data Session =
Session {
schan :: Chan String,
- stags :: Map Attr TextTag,
+ stags :: Map Color.Attr TextTag,
sview :: TextView }
startup :: (Session -> IO ()) -> IO ()
@@ -38,9 +37,7 @@ startup k =
textTagTableAdd ttt tt
doAttr tt ak
return (ak, tt))
- [ (f, b) |
- f <- Nothing : L.map Just [minBound..maxBound],
- b <- Nothing : L.map Just Color.legalBG ]
+ [ (f, b) | f <- [minBound..maxBound], b <- Color.legalBG ]
-- text buffer
tb <- textBufferNew (Just ttt)
@@ -97,7 +94,8 @@ startup k =
shutdown _ = mainQuit
-display :: Area -> Session -> (Loc -> (Attr, Char)) -> String -> String -> IO ()
+display :: Area -> Session -> (Loc -> (Color.Attr, Char)) -> String -> String
+ -> IO ()
display ((y0,x0), (y1,x1)) session f msg status =
postGUIAsync $
do
@@ -107,14 +105,14 @@ display ((y0,x0), (y1,x1)) session f msg status =
sequence_ [ setTo tb (stags session) (y, x) (fst (f (y, x))) |
y <- [y0..y1], x <- [x0..x1]]
-setTo :: TextBuffer -> Map Attr TextTag -> Loc -> Attr -> IO ()
-setTo _ _ _ (Nothing, Nothing) = return ()
-setTo tb tts (ly, lx) a =
- do
- ib <- textBufferGetIterAtLineOffset tb (ly + 1) lx
- ie <- textIterCopy ib
- textIterForwardChar ie
- textBufferApplyTag tb (tts ! a) ib ie
+setTo :: TextBuffer -> Map Color.Attr TextTag -> Loc -> Color.Attr -> IO ()
+setTo tb tts (ly, lx) a
+ | a == Color.defaultAttr = return ()
+ | otherwise = do
+ ib <- textBufferGetIterAtLineOffset tb (ly + 1) lx
+ ie <- textIterCopy ib
+ textIterForwardChar ie
+ textBufferApplyTag tb (tts ! a) ib ie
-- | reads until a non-dead key encountered
readUndeadChan :: Chan String -> IO String
@@ -148,15 +146,10 @@ nextEvent session =
e <- readUndeadChan (schan session)
return (K.keyTranslate e)
-type Attr = (Maybe Color.Color, Maybe Color.Color)
-
-setFG c (_, b) = (Just c, b)
-setBG c (f, _) = (f, Just c)
-defaultAttr = (Nothing, Nothing)
-
-doAttr :: TextTag -> Attr -> IO ()
-doAttr tt (Nothing, Nothing) = return ()
-doAttr tt (Just fg, Nothing) = set tt [textTagForeground := Color.colorToRGB fg]
-doAttr tt (Nothing, Just bg) = set tt [textTagBackground := Color.colorToRGB bg]
-doAttr tt (Just fg, Just bg) = set tt [textTagForeground := Color.colorToRGB fg,
- textTagBackground := Color.colorToRGB bg]
+doAttr :: TextTag -> Color.Attr -> IO ()
+doAttr tt (fg, bg)
+ | (fg, bg) == Color.defaultAttr = return ()
+ | fg == Color.defFG = set tt [textTagBackground := Color.colorToRGB bg]
+ | bg == Color.defBG = set tt [textTagForeground := Color.colorToRGB fg]
+ | otherwise = set tt [textTagForeground := Color.colorToRGB fg,
+ textTagBackground := Color.colorToRGB bg]
View
@@ -1,6 +1,5 @@
module Display.Vty
- (displayId, startup, shutdown,
- display, nextEvent, setBG, setFG, defaultAttr, Session) where
+ (displayId, startup, shutdown, display, nextEvent, Session) where
import Graphics.Vty as V
import Data.List as L
@@ -18,17 +17,19 @@ type Session = V.Vty
startup :: (Session -> IO ()) -> IO ()
startup k = V.mkVty >>= k
-display :: Area -> Session -> (Loc -> (Attr, Char)) -> String -> String -> IO ()
+display :: Area -> Session -> (Loc -> (Color.Attr, Char)) -> String -> String
+ -> IO ()
display ((y0,x0),(y1,x1)) vty f msg status =
let img = (foldr (<->) V.empty_image .
L.map (foldr (<|>) V.empty_image .
- L.map (\ (x,y) -> let (a,c) = f (y,x) in char a c)))
+ L.map (\ (x,y) -> let (a, c) = f (y, x)
+ in char (setAttr a) c)))
[ [ (x,y) | x <- [x0..x1] ] | y <- [y0..y1] ]
in V.update vty (pic_for_image
- (utf8_bytestring defaultAttr
+ (utf8_bytestring (setAttr Color.defaultAttr)
(BS.pack (L.map (fromIntegral . ord) (toWidth (x1 - x0 + 1) msg))) <->
img <->
- utf8_bytestring defaultAttr
+ utf8_bytestring (setAttr Color.defaultAttr)
(BS.pack (L.map (fromIntegral . ord) (toWidth (x1 - x0 + 1) status)))))
toWidth :: Int -> String -> String
@@ -65,12 +66,16 @@ 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 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)
+hack c a = if Color.isBright c then with_style a bold else a
-defaultAttr = def_attr { attr_fore_color = SetTo (aToc Color.defFG),
- attr_back_color = SetTo (aToc Color.defBG) }
+setAttr (fg, bg) =
+-- This optimization breaks display for white background terminals:
+-- if (fg, bg) == Color.defaultAttr
+-- then def_attr
+-- else
+ hack fg $ hack bg $
+ def_attr { attr_fore_color = SetTo (aToc fg),
+ attr_back_color = SetTo (aToc bg) }
aToc :: Color.Color -> Color
aToc Color.Black = black

0 comments on commit e0ef25f

Please sign in to comment.