stockholm/tv/5pkgs/xmonad-tv/Util/Rhombus.hs

370 lines
13 KiB
Haskell
Raw Normal View History

module Util.Rhombus
( defaultRhombusConfig
, MatchMethod(..)
, rhombus
, RhombusConfig(..)
, RhombusState(..)
) where
import Control.Monad ( forM_, zipWithM_ )
import Data.Char
import Data.List
import Data.Ord
import Data.Map ( fromList )
import Data.Maybe ( isJust, fromJust )
import XMonad
import XMonad.StackSet hiding ( filter )
import XMonad.Util.Font
import XMonad.Util.Image ( drawIcon )
import XMonad.Util.XUtils
import Util.Submap
import Util.XUtils
import Util.Font
data MatchMethod = MatchInfix | MatchPrefix
data RhombusConfig = RhombusConfig
{ rc_font :: String
, rc_cellwidth :: Dimension
, rc_margin :: Dimension
, rc_matchmethod :: MatchMethod
, rc_wrap :: Bool
, rc_colors :: Bool -> Bool -> Bool -> (String, String, String)
, rc_paint :: RhombusConfig -> Display -> Pixmap -> GC -> String -> Rectangle -> Bool -> Bool -> Bool -> X ()
}
-- TODO currently xft is broken
defaultRhombusConfig = RhombusConfig "xft:Sans-8" 100 0 MatchInfix True stupidColors noPaint
where
stupidColors _ _ _ = ("red", "magenta", "yellow")
noPaint _ _ _ _ _ _ _ _ _ = return ()
data RhombusState = RhombusState
{ rs_window :: Window
, rs_search :: String
, rs_font :: XMonadFont
, rs_focus :: (Position, Position)
, rs_strings :: [String]
}
reachableCoords :: RhombusState -> [(Position, Position)]
reachableCoords RhombusState{rs_strings=xs} = take (length xs) wave
matchingReachableCoords :: RhombusConfig -> RhombusState -> [(Position, Position)]
matchingReachableCoords rc rs =
snd $ unzip
$ filter (isXOf (rc_matchmethod rc) (rs_search rs) . fst)
$ zip (rs_strings rs) (reachableCoords rs)
match :: MatchMethod -> String -> [String] -> Maybe String
match m s ws = do
let cands = filter (isXOf m s) ws
if length cands == 1
then Just $ head cands
else Nothing
rhombus :: RhombusConfig -> (String -> X ()) -> [String] -> X ()
rhombus rc viewFunc as = withGrabbedKeyboard $ do
rs <- newRhombus rc as
--redraw rc rs
showWindow (rs_window rs)
rhombusMode viewFunc rc rs
rhombusMode :: (String -> X ()) -> RhombusConfig -> RhombusState -> X ()
rhombusMode viewFunc rc rs =
case match (rc_matchmethod rc) (rs_search rs) (init $ rs_strings rs) of
Nothing -> redraw rc rs >> submapString def keys
Just i -> removeRhombus rs >> viewFunc i
where
def (ch:[]) | isPrint ch =
incSearchPushChar ch rs >>= rhombusMode viewFunc rc
def _ =
failbeep >> rhombusMode viewFunc rc rs
keys = fromList $
[ ((0 , xK_BackSpace ), incSearchPopChar rs >>= rhombusMode viewFunc rc)
, ((0 , xK_Escape ), removeRhombus rs)
, ((0 , xK_Menu ), removeRhombus rs)
, ((0 , xK_Left ), goto rc (-1, 0) rs >>= rhombusMode viewFunc rc)
, ((0 , xK_Right ), goto rc ( 1, 0) rs >>= rhombusMode viewFunc rc)
, ((0 , xK_Up ), goto rc ( 0,-1) rs >>= rhombusMode viewFunc rc)
, ((0 , xK_Down ), goto rc ( 0, 1) rs >>= rhombusMode viewFunc rc)
, ((0 , xK_Tab ), gotoNextMatch rc rs >>= rhombusMode viewFunc rc)
, ((_S , xK_Tab ), gotoPrevMatch rc rs >>= rhombusMode viewFunc rc)
, ((0 , xK_Return ), removeRhombus rs >> return (selectFocused rs) >>= viewFunc)
]
_S = shiftMask
-- TODO make failbeep configurable
failbeep = spawn "beep -l 100 -f 500"
goto :: RhombusConfig -> (Position, Position) -> RhombusState -> X RhombusState
goto RhombusConfig{rc_wrap=True} xy rs = maybe (failbeep >> return rs) return $ wrapFocus xy rs
goto RhombusConfig{rc_wrap=False} xy rs = maybe (failbeep >> return rs) return $ moveFocus xy rs
moveFocus :: (Position, Position) -> RhombusState -> Maybe RhombusState
moveFocus (dx, dy) rs@RhombusState{rs_focus=(x,y)} = do
let focus' = (x + dx, y + dy)
if elem focus' (reachableCoords rs)
then Just rs { rs_focus = focus' }
else Nothing
wrapFocus :: (Position, Position) -> RhombusState -> Maybe RhombusState
wrapFocus (0, dy) rs@RhombusState{rs_focus=focus} = do
let column = sortBy (comparing snd) $ filter ((==) (fst focus) . fst) (reachableCoords rs)
i <- elemIndex focus column
return rs { rs_focus = column `modIndex` (i + fromIntegral dy) }
wrapFocus (dx, 0) rs@RhombusState{rs_focus=focus} = do
let column = sortBy (comparing fst) $ filter ((==) (snd focus) . snd) (reachableCoords rs)
i <- elemIndex focus column
return rs { rs_focus = column `modIndex` (i + fromIntegral dx) }
wrapFocus _ _ = Nothing
gotoPrevMatch :: RhombusConfig -> RhombusState -> X RhombusState
gotoPrevMatch rc rs@RhombusState{rs_focus=focus} = do
case reverse (matchingReachableCoords rc rs) of
[] -> failbeep >> return rs
xs -> return rs
{ rs_focus = maybe (head xs)
(modIndex xs . (+1))
(focus `elemIndex` xs)
}
gotoNextMatch :: RhombusConfig -> RhombusState -> X RhombusState
gotoNextMatch rc rs@RhombusState{rs_focus=focus} = do
case matchingReachableCoords rc rs of
[] -> failbeep >> return rs
xs -> return rs
{ rs_focus = maybe (head xs)
(modIndex xs . (+1))
(focus `elemIndex` xs)
}
selectFocused :: RhombusState -> String
selectFocused rs =
-- TODO the rhombus must never "focus" something inexistent
fromJust $ lookup (rs_focus rs) $ zip wave (rs_strings rs)
incSearchPushChar :: Char -> RhombusState -> X RhombusState
incSearchPushChar c rs = return rs { rs_search = rs_search rs ++ [c] }
incSearchPopChar :: RhombusState -> X RhombusState
-- only rubout if we have at least one char
incSearchPopChar rs@RhombusState{rs_search=xs@(_:_)} =
return rs { rs_search = init xs }
incSearchPopChar rs = return rs
redraw :: RhombusConfig -> RhombusState -> X ()
redraw rc rs = do
ss <- gets windowset
let Screen _ _ (SD (Rectangle _ _ s_width s_height)) = current ss
-- TODO this let is duplicated in newRhombus
let scale x = x * cell_w `div` s_width -- TODO use bw
cell_w = rc_cellwidth rc
cell_h = scale s_height
-- txy is the top-left corner of the first (center) cell
-- XXX div and (-) are not distributive
-- we could round $ (s_* - cell_*) / 2, though...
tx = fi $ s_width `div` 2 - cell_w `div` 2
ty = fi $ s_height `div` 2 - cell_h `div` 2
margin = rc_margin rc
-- dxy are the outer cell dimensions (i.e. including the border)
dx = fi $ cell_w + 2 + margin
dy = fi $ cell_h + 2 + margin
paint = rc_paint rc
xmf = rs_font rs
tags = rs_strings rs
--currentTag = last tags
withDisplay $ \ d -> do
-- XXX we cannot use withPixmapAndGC because rc_paint is an X monad
p <- io $ createPixmap d (rs_window rs) s_width s_height (defaultDepthOfScreen $ defaultScreenOfDisplay d)
g <- io $ createGC d p
-- TODO fixme
color_black <- stringToPixel d "black"
forZipWithM_ tags (reachableCoords rs) $ \ tag oxy@(ox, oy) -> do
let focus = oxy == rs_focus rs
match = isXOf (rc_matchmethod rc) (rs_search rs) tag
current = tag == last tags
(_b_color, _bg_color, _fg_color) = rc_colors rc focus match current
--cell_x = (ox * dx) + x - fi (cell_w `div` 2)
--cell_y = (oy * dy) + y - fi (cell_h `div` 2)
cell_x = (ox * dx) + tx + 1
cell_y = (oy * dy) + ty + 1
b_color <- stringToPixel d _b_color
bg_color <- stringToPixel d _bg_color
fg_color <- stringToPixel d _fg_color
-- draw background
io $ setForeground d g bg_color
io $ fillRectangle d p g cell_x cell_y cell_w cell_h
-- draw border
io $ setForeground d g b_color
io $ drawLines d p g
[ Point (cell_x - 1) (cell_y - 1)
, Point (fi cell_w + 1) 0
, Point 0 (fi cell_h + 1)
, Point (-(fi cell_w + 1)) 0
, Point 0 (-(fi cell_h + 1))
]
coordModePrevious
-- custom draw
paint rc d p g tag (Rectangle cell_x cell_y cell_w cell_h) focus match current
-- paint text
-- TODO custom paint text?
-- TODO withCopyArea
io $ withPixmapAndGC d p s_width s_height (defaultDepthOfScreen $ defaultScreenOfDisplay d) $ \ f_pm f_gc -> do
withPixmapAndGC d f_pm s_width s_height 1 $ \ clip_mask clip_gc -> do
setForeground d clip_gc 0
setBackground d clip_gc 0
fillRectangle d clip_mask clip_gc 0 0 s_width s_height
setForeground d clip_gc 1
let r = Rectangle cell_x cell_y cell_w cell_h
printStringCentered d clip_mask xmf clip_gc r tag
setForeground d f_gc fg_color
setBackground d f_gc color_black -- TODO
printStringCentered d f_pm xmf f_gc r tag
setClipMask d f_gc clip_mask
copyArea d f_pm p f_gc 0 0 s_width s_height 0 0
io $ copyArea d p (rs_window rs) g 0 0 s_width s_height 0 0
io $ freePixmap d p
io $ freeGC d g
newRhombus :: RhombusConfig -> [String] -> X RhombusState
newRhombus rc tags = do
ss <- gets windowset
let Screen _ _ (SD (Rectangle _ _ s_width s_height)) = current ss
(_, def_win_bg, _) = rc_colors rc False True False
-- TODO this let is duplicated in redraw
let scale x = x * cell_w `div` s_width -- TODO use bw
cell_w = rc_cellwidth rc
cell_h = scale s_height
-- TODO don't delete this let but use it instead of s_{width,height}
-- (xcoords, ycoords) = unzip $ take (length tags) wave -- this is reachableCoords
-- win_width = (maximum xcoords - minimum xcoords) * dx
-- win_height = (maximum ycoords - minimum ycoords) * dy
-- txy is the top-left corner of the first (center) cell
-- XXX div and (-) are not distributive
-- we could round $ (s_* - cell_*) / 2, though...
tx = fi $ s_width `div` 2 - cell_w `div` 2
ty = fi $ s_height `div` 2 - cell_h `div` 2
margin = rc_margin rc
-- dxy are the outer cell dimensions (i.e. including the border)
dx = fi $ cell_w + 2 + margin
dy = fi $ cell_h + 2 + margin
fn <- initXMF (rc_font rc)
win <- createNewWindow (Rectangle 0 0 s_width s_height) Nothing def_win_bg True
withDisplay $ \ d ->
io $ shapeWindow d win $ \ p g ->
forZipWithM_ tags wave $ \ _ (ox, oy) ->
fillRectangle d p g (tx + ox * dx) (ty + oy * dy) (fi cell_w + 2) (fi cell_h + 2)
return $ RhombusState win "" fn (0,0) tags
removeRhombus :: RhombusState -> X ()
removeRhombus (RhombusState w _ fn _ _) = do
deleteWindow w
releaseXMF fn
wave :: [(Position, Position)]
wave = zip (0:(concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i,-i+1..(-1)]) [1..])) (concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i+1,-i+2..(-1)]) [1..])
where
wave1 = 0:(concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i,-i+1..(-1)]) [1..])
wave2 = concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i+1,-i+2..(-1)]) [1..]
commonPrefix (x:xs) (y:ys) | x == y = x:commonPrefix xs ys
commonPrefix _ _ = []
isXOf :: MatchMethod -> String -> String -> Bool
isXOf MatchInfix = isInfixOf
isXOf MatchPrefix = isPrefixOf
findXIndex :: (Eq a) => MatchMethod -> [a] -> [a] -> Maybe Int
findXIndex MatchInfix = findInfixIndex
findXIndex MatchPrefix = findPrefixIndex
findInfixIndex :: (Eq a) => [a] -> [a] -> Maybe Int
findInfixIndex needle haystack
= (\x -> if null x then Nothing else Just (fst $ head x))
. dropWhile (\(_,x) -> not $ isPrefixOf needle x)
$ zip [0..] (tails haystack)
findPrefixIndex :: (Eq a) => [a] -> [a] -> Maybe Int
findPrefixIndex needle haystack =
if isPrefixOf needle haystack
then Just 0
else Nothing
modIndex :: Integral i => [a] -> i -> a
modIndex xs i = xs `genericIndex` (i `mod` genericLength xs)
forZipWithM_ a b f = zipWithM_ f a b
withGrabbedKeyboard f = do
XConf { theRoot = root, display = d } <- ask
catchX (io (grabKeyboard d root False grabModeAsync grabModeAsync currentTime) >> f)
(return ())
io $ ungrabKeyboard d currentTime