From 237f39aad4c22026f581f7e80b121b3b54eafb83 Mon Sep 17 00:00:00 2001 From: Clemens Fruhwirth Date: Fri, 7 Nov 2008 12:51:14 +0100 Subject: Initial version of GridSelect.hs with a lot room for improvement/cleanups darcs-hash:20081107115114-ed0c4-000ce76dd7160a7b5157a1bef463b213f8062705.gz --- XMonad/Actions/GridSelect.hs | 246 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 246 insertions(+) create mode 100644 XMonad/Actions/GridSelect.hs (limited to 'XMonad/Actions/GridSelect.hs') diff --git a/XMonad/Actions/GridSelect.hs b/XMonad/Actions/GridSelect.hs new file mode 100644 index 0000000..c73aaae --- /dev/null +++ b/XMonad/Actions/GridSelect.hs @@ -0,0 +1,246 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.GridSelect +-- Copyright : Clemens Fruhwirth +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Clemens Fruhwirth +-- Stability : unstable +-- Portability : unportable +-- +-- GridSelect displays a 2D grid of windows to navigate with cursor +-- keys and to select with return. +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.GridSelect where +import Data.Maybe +import Data.Bits +import Control.Monad.State +import Control.Arrow +import Data.List as L +import XMonad +import XMonad.Util.Font +import XMonad.Prompt (mkUnmanagedWindow) +import XMonad.StackSet as W +import XMonad.Layout.Decoration +import XMonad.Util.NamedWindows +import Text.Printf + +data GSConfig = GSConfig { + gs_cellheight :: Integer, + gs_cellwidth :: Integer, + gs_cellpadding :: Integer, + gs_colorizer :: Window -> Bool -> X (String, String), + gs_font :: String +} + +type TwoDPosition = (Integer, Integer) + +data TwoDState = TwoDState { td_curpos :: TwoDPosition, + td_windowmap :: [(TwoDPosition,(String,Window))], + td_gsconfig :: GSConfig, + td_font :: XMonadFont, + td_paneX :: Integer, + td_paneY :: Integer } + + +type TwoD a = StateT TwoDState X a + +diamondLayer :: (Enum b', Num b') => b' -> [(b', b')] +-- FIXME remove nub +diamondLayer n = let ul = [ (x,n-x) | x <- [0..n] ] + in nub $ ul ++ (map (negate *** id) ul) ++ + (map (negate *** negate) ul) ++ + (map (id *** negate) ul) + +diamond :: (Enum a, Num a) => [(a, a)] +diamond = concatMap diamondLayer [0..] + + +-- FIXME this function returns a list an infinite list with finite +-- elements, so going beyond the last proper element causes a never +-- ending computation. + +diamondRestrict :: (Enum t, Num t, Ord t) => t -> t -> [(t, t)] +diamondRestrict x y = L.filter f diamond + where f (x',y') = (x' <= x) && + (x' >= -x) && + (y' <= y) && + (y' >= -y) + +tupadd :: (Num t1, Num t) => (t, t1) -> (t, t1) -> (t, t1) +tupadd (a,b) (c,d) = (a+c,b+d) +tupmul :: (Num t1, Num t) => (t, t1) -> (t, t1) -> (t, t1) +tupmul (a,b) (c,d) = (a*c,b*d) + +-- shrinkWhile should be exported from Decoration.hs +shrinkWhile :: Monad m => (String -> [String]) -> (String -> m Bool) -> String -> m String +shrinkWhile sh p x = sw $ sh x + where sw [n] = return n + sw [] = return "" + sw (n:ns) = do + cond <- p n + if cond + then sw ns + else return n + +drawWinBox :: Display -> Window -> XMonadFont -> (String, String) -> Integer -> Integer -> String -> Integer -> Integer -> Integer -> X () +drawWinBox dpy win font (fg,bg) ch cw text x y cp = do + gc <- liftIO $ createGC dpy win + bordergc <- liftIO $ createGC dpy win + liftIO $ do + Just fgcolor <- initColor dpy fg + Just bgcolor <- initColor dpy bg + Just bordercolor <- initColor dpy borderColor + setForeground dpy gc fgcolor + setBackground dpy gc bgcolor + setForeground dpy bordergc bordercolor + fillRectangle dpy win gc (fromInteger x) (fromInteger y) (fromInteger cw) (fromInteger ch) + drawRectangle dpy win bordergc (fromInteger x) (fromInteger y) (fromInteger cw) (fromInteger ch) + stext <- shrinkWhile (shrinkIt shrinkText) + (\n -> do size <- liftIO $ textWidthXMF dpy font n + return $ size > (fromInteger (cw-(2*cp)))) + text + printStringXMF dpy win font gc bg fg (fromInteger (x+cp)) (fromInteger (y+(div ch 2))) stext + liftIO $ freeGC dpy gc + liftIO $ freeGC dpy bordergc + +updateWindows :: Display -> Window -> TwoD () +updateWindows dpy win = do + (TwoDState curpos windowList gsconfig font paneX paneY) <- get + let cellwidth = gs_cellwidth gsconfig + cellheight = gs_cellheight gsconfig + paneX' = div (paneX-cellwidth) 2 + paneY' = div (paneY-cellheight) 2 + updateWindow (pos@(x,y),(text, clientwindow)) = lift $ do + colors <- (gs_colorizer gsconfig) clientwindow (pos == curpos) + drawWinBox dpy win font + colors + (gs_cellheight gsconfig) + (gs_cellwidth gsconfig) text + (paneX'+x*cellwidth) + (paneY'+y*cellheight) + (gs_cellpadding gsconfig) + mapM updateWindow windowList + return () + +eventLoop :: Display -> Window -> TwoD (Maybe Window) +eventLoop d win = do + (keysym,string,event) <- liftIO $ allocaXEvent $ \e -> do + nextEvent d e + ev <- getEvent e + (ks,s) <- if ev_event_type ev == keyPress + then lookupString $ asKeyEvent e + else return (Nothing, "") + return (ks,s,ev) + handle d win (fromMaybe xK_VoidSymbol keysym,string) event + +handle :: Display + -> Window + -> (KeySym, String) + -> Event + -> StateT TwoDState X (Maybe Window) +handle d win (ks,_) (KeyEvent {ev_event_type = t}) + | t == keyPress && ks == xK_Escape = return Nothing + | t == keyPress && ks == xK_Left = diffAndRefresh (-1,0) + | t == keyPress && ks == xK_Right = diffAndRefresh (1,0) + | t == keyPress && ks == xK_Down = diffAndRefresh (0,1) + | t == keyPress && ks == xK_Up = diffAndRefresh (0,-1) + | t == keyPress && ks == xK_Return = do + (TwoDState pos win' _ _ _ _) <- get + return $ fmap (snd . snd) $ find ((== pos) . fst) win' + where diffAndRefresh diff = do + (TwoDState pos windowlist gsconfig font paneX paneY) <- get + put $ TwoDState (pos `tupadd` diff) windowlist gsconfig font paneX paneY + updateWindows d win + eventLoop d win + +handle d win _ _ = do + updateWindows d win + eventLoop d win + +-- FIXME probably move that into Utils? +-- Conversion scheme as in http://en.wikipedia.org/wiki/HSV_color_space +hsv2rgb :: Fractional a => (Integer,a,a) -> (a,a,a) +hsv2rgb (h,s,v) = + let hi = (div h 60) `mod` 6 :: Integer + f = (((fromInteger h)/60) - (fromInteger hi)) :: Fractional a => a + q = v * (1-f) + p = v * (1-s) + t = v * (1-(1-f)*s) + in case hi of + 0 -> (v,t,p) + 1 -> (q,v,p) + 2 -> (p,v,t) + 3 -> (p,q,v) + 4 -> (t,p,v) + 5 -> (v,p,q) + _ -> error "The world is ending. x mod a >= a." + +default_colorizer :: Window -> Bool -> X (String, String) +default_colorizer w active = do + classname <- runQuery className w + let seed x = toInteger (sum $ map ((*x).fromEnum) classname) :: Integer + (r,g,b) = hsv2rgb ((seed 83) `mod` 360, + (fromInteger ((seed 191) `mod` 1000))/2500+0.4, + (fromInteger ((seed 121) `mod` 1000))/2500+0.4) + if active + then return ("#faff69", "black") + else return ("#" ++ concat (map (twodigitHex.(round :: Double -> Integer).(*256)) [r, g, b] ), "white") + where + twodigitHex :: Integer -> String + twodigitHex a = printf "%02x" a + +gridselect :: GSConfig -> X (Maybe Window) +gridselect gsconfig = + withDisplay $ \dpy -> do + rootw <- liftIO $ rootWindow dpy (defaultScreen dpy) + s <- gets $ screenRect . W.screenDetail . W.current . windowset + windowList <- windowMap + win <- liftIO $ mkUnmanagedWindow dpy (defaultScreenOfDisplay dpy) rootw + (rect_x s) (rect_y s) (rect_width s) (rect_height s) + liftIO $ mapWindow dpy win + liftIO $ selectInput dpy win (exposureMask .|. keyPressMask) + status <- io $ grabKeyboard dpy win True grabModeAsync grabModeAsync currentTime + font <- initXMF (gs_font gsconfig) + let screenWidth = toInteger $ rect_width s; + screenHeight = toInteger $ rect_height s; + selectedWindow <- if (status == grabSuccess) then + do + let restrictX = floor $ ((fromInteger screenWidth)/(fromInteger $ gs_cellwidth gsconfig)-1)/2 ; + restrictY = floor $ ((fromInteger screenHeight)/(fromInteger $ gs_cellheight gsconfig)-1)/2 ; + selectedWindow <- evalStateT (do updateWindows dpy win; eventLoop dpy win) + (TwoDState (0,0) + (zipWith (,) (diamondRestrict restrictX restrictY) windowList) + gsconfig + font + screenWidth + screenHeight) + return selectedWindow + else + return Nothing + liftIO $ do + unmapWindow dpy win + destroyWindow dpy win + sync dpy False + releaseXMF font + return selectedWindow + + +windowMap :: X [(String,Window)] +windowMap = do + ws <- gets windowset + wins <- mapM keyValuePair (W.allWindows ws) + return wins + where keyValuePair w = flip (,) w `fmap` decorateName' w + +decorateName' :: Window -> X String +decorateName' w = do + fmap show $ getName w + +defaultGSConfig :: GSConfig +defaultGSConfig = GSConfig 50 130 10 default_colorizer "xft:Sans-8" + +borderColor :: [Char] +borderColor = "white" -- cgit v1.2.3