diff options
Diffstat (limited to 'XMonad/Layout/AvoidFloats.hs')
| -rw-r--r-- | XMonad/Layout/AvoidFloats.hs | 239 |
1 files changed, 239 insertions, 0 deletions
diff --git a/XMonad/Layout/AvoidFloats.hs b/XMonad/Layout/AvoidFloats.hs new file mode 100644 index 0000000..2451580 --- /dev/null +++ b/XMonad/Layout/AvoidFloats.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE PatternGuards, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, ParallelListComp, DeriveDataTypeable #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.AvoidFloats +-- Copyright : (c) 2014 Anders Engstrom <ankaan@gmail.com> +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : (c) Anders Engstrom <ankaan@gmail.com> +-- Stability : unstable +-- Portability : unportable +-- +-- Find a maximum empty rectangle around floating windows and use that area +-- to display non-floating windows. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.AvoidFloats ( + -- * Usage + -- $usage + avoidFloats, + avoidFloats', + AvoidFloatMsg(..), + AvoidFloatItemMsg(..), + ) where + +import XMonad +import XMonad.Layout.LayoutModifier +import qualified XMonad.StackSet as W + +import Data.List +import Data.Ord +import Data.Maybe +import qualified Data.Map as M +import qualified Data.Set as S + +-- $usage +-- You can use this module with the following in your ~\/.xmonad\/xmonad.hs file: +-- +-- > import XMonad.Layout.AvoidFloats +-- +-- and modify the layouts to call avoidFloats on the layouts where you want the +-- non-floating windows to not be behind floating windows. +-- +-- > layoutHook = ... ||| avoidFloats True Full ||| ... +-- +-- For more detailed instructions on editing the layoutHook see: +-- "XMonad.Doc.Extending#Editing_the_layout_hook" +-- +-- Then optionally add appropriate key bindings, for example: +-- +-- > ,((modm .|. shiftMask, xK_b), sendMessage AvoidFloatToggle) +-- > ,((modm .|. controlMask, xK_b), withFocused $ sendMessage . AvoidFloatToggleItem) +-- > ,((modm .|. shiftMask .|. controlMask, xK_b), sendMessage (AvoidFloatSet False) >> sendMessage AvoidFloatClearItems) +-- +-- For detailed instructions on editing your key bindings, see +-- "XMonad.Doc.Extending#Editing_key_bindings". +-- +-- Note that this module is incompatible with an old way of configuring +-- "XMonad.Actions.FloatSnap". If you are having problems, please update your +-- configuration. + +-- | Avoid floating windows unless the resulting area for windows would be too small. +-- In that case, use the whole screen as if this layout modifier wasn't there. +avoidFloats + :: Bool -- ^ If floating windows should be avoided by default. + -> l a -- ^ Layout to modify. + -> ModifiedLayout AvoidFloats l a +avoidFloats act = avoidFloats' 100 100 act + +-- | Avoid floating windows unless the resulting area for windows would be too small. +-- In that case, use the whole screen as if this layout modifier wasn't used. +avoidFloats' + :: Int -- ^ Minimum width of the area used for non-floating windows. + -> Int -- ^ Minimum height of the area used for non-floating windows. + -> Bool -- ^ If floating windows should be avoided by default. + -> l a -- ^ Layout to modify. + -> ModifiedLayout AvoidFloats l a +avoidFloats' w h act = ModifiedLayout (AvoidFloats Nothing S.empty w h act) + +data AvoidFloats a = AvoidFloats + { cache :: Maybe ((M.Map a W.RationalRect, Rectangle), Rectangle) + , chosen :: S.Set a + , minw :: Int + , minh :: Int + , avoidAll :: Bool + } deriving (Read, Show) + +-- | Change the state of the whole avoid float layout modifier. +data AvoidFloatMsg + = AvoidFloatToggle -- ^ Toggle between avoiding all or only selected. + | AvoidFloatSet Bool -- ^ Set if all all floating windows should be avoided. + | AvoidFloatClearItems -- ^ Clear the set of windows to specifically avoid. + deriving (Typeable) + + +-- | Change the state of the avoid float layout modifier conserning a specific window. +data AvoidFloatItemMsg a + = AvoidFloatAddItem a -- ^ Add a window to always avoid. + | AvoidFloatRemoveItem a -- ^ Stop always avoiding selected window. + | AvoidFloatToggleItem a -- ^ Toggle between always avoiding selected window. + deriving (Typeable) + +instance Message AvoidFloatMsg +instance Typeable a => Message (AvoidFloatItemMsg a) + +instance LayoutModifier AvoidFloats Window where + modifyLayoutWithUpdate lm w r = withDisplay $ \d -> do + floating <- gets $ W.floating . windowset + case cache lm of + Just (key, mer) | key == (floating,r) -> flip (,) Nothing `fmap` runLayout w mer + _ -> do rs <- io $ map toRect `fmap` mapM (getWindowAttributes d) (filter shouldAvoid $ M.keys floating) + let mer = maximumBy (comparing area) $ filter bigEnough $ maxEmptyRectangles r rs + flip (,) (Just $ pruneWindows $ lm { cache = Just ((floating,r),mer) }) `fmap` runLayout w mer + where + toRect :: WindowAttributes -> Rectangle + toRect wa = let b = fi $ wa_border_width wa + in Rectangle (fi $ wa_x wa) (fi $ wa_y wa) (fi $ wa_width wa + 2*b) (fi $ wa_height wa + 2*b) + + bigEnough :: Rectangle -> Bool + bigEnough rect = rect_width rect >= fi (minw lm) && rect_height rect >= fi (minh lm) + + shouldAvoid a = avoidAll lm || a `S.member` chosen lm + + pureMess lm m + | Just (AvoidFloatToggle) <- fromMessage m = Just $ lm { avoidAll = not (avoidAll lm), cache = Nothing } + | Just (AvoidFloatSet s) <- fromMessage m, s /= avoidAll lm = Just $ lm { avoidAll = s, cache = Nothing } + | Just (AvoidFloatClearItems) <- fromMessage m = Just $ lm { chosen = S.empty, cache = Nothing } + | Just (AvoidFloatAddItem a) <- fromMessage m, a `S.notMember` chosen lm = Just $ lm { chosen = S.insert a (chosen lm), cache = Nothing } + | Just (AvoidFloatRemoveItem a) <- fromMessage m, a `S.member` chosen lm = Just $ lm { chosen = S.delete a (chosen lm), cache = Nothing } + | Just (AvoidFloatToggleItem a) <- fromMessage m = let op = if a `S.member` chosen lm then S.delete else S.insert + in Just $ lm { chosen = op a (chosen lm), cache = Nothing } + | otherwise = Nothing + +pruneWindows :: AvoidFloats Window -> AvoidFloats Window +pruneWindows lm = case cache lm of + Nothing -> lm + Just ((floating,_),_) -> lm { chosen = S.filter (flip M.member floating) (chosen lm) } + +-- | Find all maximum empty rectangles (MERs) that are axis aligned. This is +-- done in O(n^2) time using a modified version of the algoprithm MERAlg 1 +-- described in \"On the maximum empty rectangle problem\" by A. Naamad, D.T. +-- Lee and W.-L HSU. Published in Discrete Applied Mathematics 8 (1984.) +maxEmptyRectangles :: Rectangle -> [Rectangle] -> [Rectangle] +maxEmptyRectangles br rectangles = filter (\a -> area a > 0) $ upAndDownEdge ++ noneOrUpEdge ++ downEdge + where + upAndDownEdge = findGaps br rectangles + noneOrUpEdge = concat $ map (everyLower br bottoms) bottoms + downEdge = concat $ map maybeToList $ map (bottomEdge br bottoms) bottoms + bottoms = sortBy (comparing bottom) $ splitContainers rectangles + +everyLower :: Rectangle -> [Rectangle] -> Rectangle -> [Rectangle] +everyLower br bottoms r = let (rs, boundLeft, boundRight, boundRects) = foldr (everyUpper r) ([], left br, right br, reverse bottoms) bottoms + (boundLeft', boundRight', _) = shrinkBounds boundLeft boundRight boundRects r (top br) + in mkRect boundLeft' boundRight' (top br) (top r) ?: rs + +everyUpper + :: Rectangle -- ^ The current rectangle where the top edge is used. + -> Rectangle -- ^ The current rectangle where the bottom edge is used. + -> ([Rectangle],Int,Int,[Rectangle]) -- ^ List of MERs found so far, left bound, right bound and list of rectangles used for bounds. + -> ([Rectangle],Int,Int,[Rectangle]) +everyUpper lower upper (rs, boundLeft, boundRight, boundRects) = (r?:rs, boundLeft', boundRight', boundRects') + where + r = mkRect boundLeft' boundRight' (bottom upper) (top lower) + (boundLeft', boundRight', boundRects') = shrinkBounds boundLeft boundRight boundRects lower (bottom upper) + +shrinkBounds :: Int -> Int -> [Rectangle] -> Rectangle -> Int -> (Int, Int, [Rectangle]) +shrinkBounds boundLeft boundRight boundRects lower upperLimit = (boundLeft', boundRight', boundRects') + where + (shrinkers, boundRects') = span (\a -> bottom a > upperLimit) boundRects + (boundLeft', boundRight') = foldr (shrinkBounds' lower) (boundLeft, boundRight) $ filter (\a -> top a < top lower) shrinkers + +shrinkBounds' :: Rectangle -> Rectangle -> (Int, Int) -> (Int, Int) +shrinkBounds' mr r (boundLeft, boundRight) + | right r < right mr = (max boundLeft $ right r, boundRight) + | left r > left mr = (boundLeft, min boundRight $ left r) + | otherwise = (right r, left r) -- r is horizontally covering all of mr; make sure the area of this rectangle will always be 0. + +bottomEdge :: Rectangle -> [Rectangle] -> Rectangle -> Maybe Rectangle +bottomEdge br bottoms r = let rs = filter (\a -> bottom r < bottom a && top a < bottom br) bottoms + boundLeft = maximum $ left br : (filter (< right r) $ map right rs) + boundRight = minimum $ right br : (filter (> left r) $ map left rs) + in if any (\a -> left a <= left r && right r <= right a) rs + then Nothing + else mkRect boundLeft boundRight (bottom r) (bottom br) + +-- | Split rectangles that horizontally fully contains another rectangle +-- without sharing either the left or right side. +splitContainers :: [Rectangle] -> [Rectangle] +splitContainers rects = splitContainers' [] $ sortBy (comparing rect_width) rects + where + splitContainers' :: [Rectangle] -> [Rectangle] -> [Rectangle] + splitContainers' res [] = res + splitContainers' res (r:rs) = splitContainers' (r:res) $ concat $ map (doSplit r) rs + + doSplit :: Rectangle -> Rectangle -> [Rectangle] + doSplit guide r + | left guide <= left r || right r <= right guide = [r] + | otherwise = let w0 = fi (rect_x guide - rect_x r) + (rect_width guide `div` 2) + w1 = rect_width r - w0 + in [ Rectangle (rect_x r) (rect_y r) w0 (rect_height r) + , Rectangle (rect_x r + fi w0) (rect_y r) w1 (rect_height r) + ] + +-- | Find all horizontal gaps that are left empty from top to bottom of screen. +findGaps + :: Rectangle -- ^ Bounding rectangle. + -> [Rectangle] -- ^ List of all rectangles that can cover areas in the bounding rectangle. + -> [Rectangle] +findGaps br rs = let (gaps,end) = foldr findGaps' ([], left br) $ sortBy (flip $ comparing left) $ filter inBounds rs + lastgap = mkRect end (right br) (top br) (bottom br) + in lastgap?:gaps + where + findGaps' :: Rectangle -> ([Rectangle], Int) -> ([Rectangle], Int) + findGaps' r (gaps, end) = let gap = mkRect end (left r) (top br) (bottom br) + in (gap?:gaps, max end (right r)) + + inBounds :: Rectangle -> Bool + inBounds r = left r < right br && left br < right r + +fi :: (Integral a, Num b) => a -> b +fi x = fromIntegral x + +(?:) :: Maybe a -> [a] -> [a] +Just x ?: xs = x:xs +_ ?: xs = xs + +left, right, top, bottom, area :: Rectangle -> Int +left r = fi (rect_x r) +right r = fi (rect_x r) + fi (rect_width r) +top r = fi (rect_y r) +bottom r = fi (rect_y r) + fi (rect_height r) +area r = fi (rect_width r * rect_height r) + +mkRect :: Int -> Int -> Int -> Int -> Maybe Rectangle +mkRect l r t b = let rect = Rectangle (fi l) (fi t) (fi $ max 0 $ r-l) (fi $ max 0 $ b-t) + in if area rect > 0 + then Just rect + else Nothing |