X.L.AvoidFloats, like avoidStruts but for floats

Ignore-this: 3722d7787dd2429313f92f85f3ae1251
Checks for floating windows within the layout area and finds a maximum area
rectangle within that does not overlap with any of the floating windows.
This rectangle is used for all non-floating windows.

This new functionality introduced problems with the recommended configuration
of one of my other modules (X.A.FloatSnap.) A new and more reliable method of
distinguishing between clicks and drags where therefore introduced in the new
module X.A.AfterDrag.

This does not break any prior use of FloatSnap, but will require changes in
configuration if used together with AvoidFloats. (This is mentioned in the
docs for AvoidFloats and I recommend using the new configuration method even if
AvoidFloats is not in use.)

darcs-hash:20150306171702-3948e-a8b8c75ba49306a33d87c9414117f8a49c536dbf.gz

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