summaryrefslogtreecommitdiffstats
path: root/tv/2configs/xserver/xmonad-tv/Util/Rhombus.hs
diff options
context:
space:
mode:
authortv <tv@shackspace.de>2015-10-24 22:31:10 +0200
committertv <tv@shackspace.de>2015-10-24 22:31:10 +0200
commit0306ec4294f6d825ca65c7b0c98a80a3bced8fdf (patch)
treeeb9e3772407963c25a4d6bd8125b3a2a72bb29ca /tv/2configs/xserver/xmonad-tv/Util/Rhombus.hs
parentb2deab26bd52a994003cafc33872b6c084cdd716 (diff)
tv: lol display-manager
Diffstat (limited to 'tv/2configs/xserver/xmonad-tv/Util/Rhombus.hs')
-rw-r--r--tv/2configs/xserver/xmonad-tv/Util/Rhombus.hs370
1 files changed, 0 insertions, 370 deletions
diff --git a/tv/2configs/xserver/xmonad-tv/Util/Rhombus.hs b/tv/2configs/xserver/xmonad-tv/Util/Rhombus.hs
deleted file mode 100644
index 5f43cb28a..000000000
--- a/tv/2configs/xserver/xmonad-tv/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