stockholm/tv/2configs/xserver/xmonad/Util/Rhombus.hs

370 lines
13 KiB
Haskell
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

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