diff options
Diffstat (limited to 'tv/2configs/xserver/xmonad-tv/Util/Rhombus.hs')
| -rw-r--r-- | tv/2configs/xserver/xmonad-tv/Util/Rhombus.hs | 370 |
1 files changed, 370 insertions, 0 deletions
diff --git a/tv/2configs/xserver/xmonad-tv/Util/Rhombus.hs b/tv/2configs/xserver/xmonad-tv/Util/Rhombus.hs new file mode 100644 index 000000000..5f43cb28a --- /dev/null +++ b/tv/2configs/xserver/xmonad-tv/Util/Rhombus.hs @@ -0,0 +1,370 @@ +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.Debunk +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 |