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