Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

speed up the gtk frontend

Plus a few fixes and tweaks (too low barehand damage, bright white
status line for curses, and others).
  • Loading branch information...
commit c28d014dd17206106338337c73b1e245d5544c9a 1 parent a8a3c43
@Mikolaj Mikolaj authored
View
2  src/Actions.hs
@@ -560,7 +560,7 @@ actorAttackActor source target = do
let single = sw { icount = 1 }
in itemEffectAction single source target
Nothing ->
- effectToAction (Effect.Wound (1, 3)) source target 0 ""
+ effectToAction (Effect.Wound (3, 1)) source target 0 ""
advanceTime source
-- | Resolves the result of an actor running into another.
View
4 src/Color.hs
@@ -33,6 +33,10 @@ defFG = White
isBright :: Color -> Bool
isBright c = fromEnum c > 7 -- for terminals that display bright via bold
+-- | Due to limitation of curses, only these are legal backgrounds.
+legalBG :: [Color]
+legalBG = [Black, White, Blue, Magenta]
+
-- Heavily modified Linux console colors.
colorToRGB :: Color -> String
colorToRGB Black = "#000000"
View
32 src/Display/Curses.hs
@@ -2,7 +2,7 @@ module Display.Curses
(displayId, startup, shutdown,
display, nextEvent, setBG, setFG, defaultAttr, Session) where
-import UI.HSCurses.Curses as C hiding (setBold)
+import UI.HSCurses.Curses as C hiding (setBold, Attr)
import qualified UI.HSCurses.CursesHelper as C
import Data.List as L
import Data.Map as M
@@ -12,7 +12,7 @@ import Control.Monad
import Data.Maybe
import Geometry
-import qualified Keys as K (Key(..))
+import qualified Keys as K (Key(..), keyTranslate)
import qualified Color
displayId = "curses"
@@ -27,10 +27,10 @@ startup k =
do
C.start
cursSet CursorInvisible
- let s = [ ((f,b), C.Style (toFColor f) (toBColor b))
+ let s = [ ((f, b), C.Style (toFColor f) (toBColor b))
| f <- [minBound..maxBound],
-- No more color combinations possible: 16*4, 64 is max.
- b <- [Color.Black, Color.White, Color.Blue, Color.Magenta ] ]
+ b <- Color.legalBG ]
nr <- colorPairs
when (nr < L.length s) $
C.end >>
@@ -43,30 +43,24 @@ startup k =
shutdown :: Session -> IO ()
shutdown w = C.end
-display :: Area -> Session -> (Loc -> (Display.Curses.Attr, Char)) -> String -> String -> IO ()
+display :: Area -> Session -> (Loc -> (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 and more:
+ -- Terminals with white background require this:
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]
- | x <- [x0..x1], y <- [y0..y1] ]
- mvWAddStr w (y1+2) 0 status
+ 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)
+ >> mvWAddStr w (y+1) x [c]
+ | x <- [x0..x1], y <- [y0..y1], let (a,c) = f (y,x) ]
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 ' ')
--}
keyTranslate :: C.Key -> Maybe K.Key
keyTranslate e =
@@ -135,4 +129,4 @@ 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
+toBColor _ = C.BlackB -- a limitation of curses
View
91 src/Display/Gtk.hs
@@ -12,7 +12,7 @@ import Data.IORef
import Data.Map as M
import Geometry
-import qualified Keys as K (Key(..))
+import qualified Keys as K (Key(..), keyTranslate)
import qualified Color
displayId = "gtk"
@@ -20,7 +20,7 @@ displayId = "gtk"
data Session =
Session {
schan :: Chan String,
- stags :: Map AttrKey TextTag,
+ stags :: Map Attr TextTag,
sview :: TextView }
startup :: (Session -> IO ()) -> IO ()
@@ -33,12 +33,14 @@ startup k =
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]]
+ mapM (\ ak -> do
+ tt <- textTagNew Nothing
+ 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 ]
-- text buffer
tb <- textBufferNew (Just ttt)
@@ -96,22 +98,23 @@ startup k =
shutdown _ = mainQuit
display :: Area -> Session -> (Loc -> (Attr, Char)) -> String -> String -> IO ()
-display ((y0,x0),(y1,x1)) session f msg status =
+display ((y0,x0), (y1,x1)) session f msg status =
postGUIAsync $
do
tb <- textViewGetBuffer (sview session)
- let text = unlines [ [ snd (f (y,x)) | x <- [x0..x1] ] | y <- [y0..y1] ]
+ 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) ]
+ sequence_ [ setTo tb (stags session) (y, x) (fst (f (y, x))) |
+ y <- [y0..y1], x <- [x0..x1]]
-setTo :: TextBuffer -> Map AttrKey TextTag -> Loc -> Attr -> IO ()
-setTo tb tts (ly,lx) a =
+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
+ ib <- textBufferGetIterAtLineOffset tb (ly + 1) lx
ie <- textIterCopy ib
textIterForwardChar ie
- mapM_ (\ c -> textBufferApplyTag tb (tts ! c) ib ie) a
+ textBufferApplyTag tb (tts ! a) ib ie
-- | reads until a non-dead key encountered
readUndeadChan :: Chan String -> IO String
@@ -139,55 +142,21 @@ readUndeadChan ch =
"Caps_Lock" -> True
_ -> False
-keyTranslate :: String -> Maybe K.Key
-keyTranslate "less" = Just (K.Char '<')
-keyTranslate "greater" = Just (K.Char '>')
-keyTranslate "period" = Just (K.Char '.')
-keyTranslate "colon" = Just (K.Char ':')
-keyTranslate "comma" = Just (K.Char ',')
-keyTranslate "space" = Just (K.Char ' ')
-keyTranslate "question" = Just (K.Char '?')
-keyTranslate "dollar" = Just (K.Char '$')
-keyTranslate "asterisk" = Just (K.Char '*')
-keyTranslate "KP_Multiply" = Just (K.Char '*')
-keyTranslate "slash" = Just (K.Char '/')
-keyTranslate "KP_Divide" = Just (K.Char '/')
-keyTranslate "underscore" = Just (K.Char '_')
-keyTranslate "Escape" = Just K.Esc
-keyTranslate "Return" = Just K.Return
-keyTranslate "Tab" = Just K.Tab
-keyTranslate "KP_Up" = Just K.Up
-keyTranslate "KP_Down" = Just K.Down
-keyTranslate "KP_Left" = Just K.Left
-keyTranslate "KP_Right" = Just K.Right
-keyTranslate "KP_Home" = Just K.Home
-keyTranslate "KP_End" = Just K.End
-keyTranslate "KP_Page_Up" = Just K.PgUp
-keyTranslate "KP_Page_Down" = Just K.PgDn
-keyTranslate "KP_Begin" = Just K.Begin
-keyTranslate "KP_Enter" = Just K.Return
-keyTranslate ['K','P','_',c] = Just (K.KP c)
-keyTranslate [c] = Just (K.Char c)
-keyTranslate _ = Nothing
--- keyTranslate e = Just (K.Dbg $ show e)
-
nextEvent :: Session -> IO K.Key
nextEvent session =
do
e <- readUndeadChan (schan session)
- maybe (nextEvent session) return (keyTranslate e)
-
-type Attr = [AttrKey]
+ maybe (nextEvent session) return (K.keyTranslate e)
-data AttrKey =
- FG Color.Color
- | BG Color.Color
- deriving (Eq, Ord)
+type Attr = (Maybe Color.Color, Maybe Color.Color)
-setBG c = (BG c :)
-setFG c = (FG c :)
-defaultAttr = []
+setFG c (_, b) = (Just c, b)
+setBG c (f, _) = (f, Just c)
+defaultAttr = (Nothing, Nothing)
-doAttr :: TextTag -> AttrKey -> IO ()
-doAttr tt (FG color) = set tt [ textTagForeground := Color.colorToRGB color ]
-doAttr tt (BG color) = set tt [ textTagBackground := Color.colorToRGB color ]
+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]
View
2  src/Display/Vty.hs
@@ -8,7 +8,7 @@ import Data.Char
import qualified Data.ByteString as BS
import Geometry
-import qualified Keys as K (Key(..))
+import qualified Keys as K (Key(..), keyTranslate)
import qualified Color
displayId = "vty"
View
38 src/Keys.hs
@@ -41,7 +41,7 @@ showKey Home = "<home>"
showKey (KP c) = "<KeyPad " ++ [c] ++ ">"
showKey (Dbg s) = s
--- | maps a key to the canonical key for the command it denotes
+-- | Maps a movement key to the canonical form.
canonicalKey :: Key -> Key
canonicalKey e =
case e of
@@ -63,7 +63,7 @@ canonicalKey e =
End -> Char 'b'
PgDn -> Char 'n'
Begin -> Char '.'
- k -> k
+ k -> k
-- | Configurable event handler for the direction keys. Is used to
-- handle player moves, but can also be used for directed commands
@@ -96,3 +96,37 @@ handleUDirection e h k =
Char 'B' -> h downleft
Char 'N' -> h downright
_ -> k
+
+-- | Translate key from a GTK string description to our internal key type.
+-- To be used, in particular, for the macros in the config file.
+keyTranslate :: String -> Maybe Key
+keyTranslate "less" = Just (Char '<')
+keyTranslate "greater" = Just (Char '>')
+keyTranslate "period" = Just (Char '.')
+keyTranslate "colon" = Just (Char ':')
+keyTranslate "comma" = Just (Char ',')
+keyTranslate "space" = Just (Char ' ')
+keyTranslate "question" = Just (Char '?')
+keyTranslate "dollar" = Just (Char '$')
+keyTranslate "asterisk" = Just (Char '*')
+keyTranslate "KP_Multiply" = Just (Char '*')
+keyTranslate "slash" = Just (Char '/')
+keyTranslate "KP_Divide" = Just (Char '/')
+keyTranslate "underscore" = Just (Char '_')
+keyTranslate "Escape" = Just Esc
+keyTranslate "Return" = Just Return
+keyTranslate "Tab" = Just Tab
+keyTranslate "KP_Up" = Just Up
+keyTranslate "KP_Down" = Just Down
+keyTranslate "KP_Left" = Just Left
+keyTranslate "KP_Right" = Just Right
+keyTranslate "KP_Home" = Just Home
+keyTranslate "KP_End" = Just End
+keyTranslate "KP_Page_Up" = Just PgUp
+keyTranslate "KP_Page_Down" = Just PgDn
+keyTranslate "KP_Begin" = Just Begin
+keyTranslate "KP_Enter" = Just Return
+keyTranslate ['K','P','_',c] = Just (KP c)
+keyTranslate [c] = Just (Char c)
+keyTranslate _ = Nothing
+-- keyTranslate e = Just (Dbg $ show e)
Please sign in to comment.
Something went wrong with that request. Please try again.