{-# LANGUAGE PatternGuards, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TupleSections #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.AvoidFloats
-- Description :  Avoid floats when placing tiled windows.
-- 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 XMonad.Prelude (fi, mapMaybe, maximumBy, sortOn)
import qualified XMonad.StackSet as W

import Data.Ord
import qualified Data.Map as M
import qualified Data.Set as S

-- $usage
-- You can use this module with the following in your @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 Full ||| ...
--
-- For more detailed instructions on editing the layoutHook see
-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and
-- "XMonad.Doc.Extending#Editing_the_layout_hook".
--
-- Then 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
-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.
--
-- 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.
--   No windows are avoided by default, they need to be added using signals.
avoidFloats
    :: l a  -- ^ Layout to modify.
    -> ModifiedLayout AvoidFloats l a
avoidFloats :: forall (l :: * -> *) a. l a -> ModifiedLayout AvoidFloats l a
avoidFloats = forall (l :: * -> *) a.
Int -> Int -> Bool -> l a -> ModifiedLayout AvoidFloats l a
avoidFloats' Int
100 Int
100 Bool
False

-- | 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'
    :: 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' :: forall (l :: * -> *) a.
Int -> Int -> Bool -> l a -> ModifiedLayout AvoidFloats l a
avoidFloats' Int
w Int
h Bool
act = forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (forall a.
Maybe ((Map a RationalRect, Rectangle), Rectangle)
-> Set a -> Int -> Int -> Bool -> AvoidFloats a
AvoidFloats forall a. Maybe a
Nothing forall a. Set a
S.empty Int
w Int
h Bool
act)

data AvoidFloats a = AvoidFloats
    { forall a.
AvoidFloats a -> Maybe ((Map a RationalRect, Rectangle), Rectangle)
cache :: Maybe ((M.Map a W.RationalRect, Rectangle), Rectangle)
    , forall a. AvoidFloats a -> Set a
chosen :: S.Set a
    , forall a. AvoidFloats a -> Int
minw :: Int
    , forall a. AvoidFloats a -> Int
minh :: Int
    , forall a. AvoidFloats a -> Bool
avoidAll :: Bool
    } deriving (ReadPrec [AvoidFloats a]
ReadPrec (AvoidFloats a)
ReadS [AvoidFloats a]
forall a. (Ord a, Read a) => ReadPrec [AvoidFloats a]
forall a. (Ord a, Read a) => ReadPrec (AvoidFloats a)
forall a. (Ord a, Read a) => Int -> ReadS (AvoidFloats a)
forall a. (Ord a, Read a) => ReadS [AvoidFloats a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [AvoidFloats a]
$creadListPrec :: forall a. (Ord a, Read a) => ReadPrec [AvoidFloats a]
readPrec :: ReadPrec (AvoidFloats a)
$creadPrec :: forall a. (Ord a, Read a) => ReadPrec (AvoidFloats a)
readList :: ReadS [AvoidFloats a]
$creadList :: forall a. (Ord a, Read a) => ReadS [AvoidFloats a]
readsPrec :: Int -> ReadS (AvoidFloats a)
$creadsPrec :: forall a. (Ord a, Read a) => Int -> ReadS (AvoidFloats a)
Read, Int -> AvoidFloats a -> ShowS
forall a. Show a => Int -> AvoidFloats a -> ShowS
forall a. Show a => [AvoidFloats a] -> ShowS
forall a. Show a => AvoidFloats a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AvoidFloats a] -> ShowS
$cshowList :: forall a. Show a => [AvoidFloats a] -> ShowS
show :: AvoidFloats a -> String
$cshow :: forall a. Show a => AvoidFloats a -> String
showsPrec :: Int -> AvoidFloats a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> AvoidFloats a -> ShowS
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.

-- | 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.

instance Message AvoidFloatMsg
instance Typeable a => Message (AvoidFloatItemMsg a)

instance LayoutModifier AvoidFloats Window where
    modifyLayoutWithUpdate :: forall (l :: * -> *).
LayoutClass l Window =>
AvoidFloats Window
-> Workspace String (l Window) Window
-> Rectangle
-> X (([(Window, Rectangle)], Maybe (l Window)),
      Maybe (AvoidFloats Window))
modifyLayoutWithUpdate AvoidFloats Window
lm Workspace String (l Window) Window
w Rectangle
r = forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
d -> do
        Map Window RationalRect
floating <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall i l a sid sd. StackSet i l a sid sd -> Map a RationalRect
W.floating forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset
        case forall a.
AvoidFloats a -> Maybe ((Map a RationalRect, Rectangle), Rectangle)
cache AvoidFloats Window
lm of
            Just ((Map Window RationalRect, Rectangle)
key, Rectangle
mer) | (Map Window RationalRect, Rectangle)
key forall a. Eq a => a -> a -> Bool
== (Map Window RationalRect
floating,Rectangle
r) -> (, forall a. Maybe a
Nothing) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout Workspace String (l Window) Window
w Rectangle
mer
            Maybe ((Map Window RationalRect, Rectangle), Rectangle)
_ -> do [Rectangle]
rs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map WindowAttributes -> Rectangle
toRect forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Display -> Window -> IO WindowAttributes
getWindowAttributes Display
d) (forall a. (a -> Bool) -> [a] -> [a]
filter Window -> Bool
shouldAvoid forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
M.keys Map Window RationalRect
floating)
                    let mer :: Rectangle
mer = forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Rectangle -> Int
area) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter Rectangle -> Bool
bigEnough forall a b. (a -> b) -> a -> b
$ Rectangle -> [Rectangle] -> [Rectangle]
maxEmptyRectangles Rectangle
r [Rectangle]
rs
                    (, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ AvoidFloats Window -> AvoidFloats Window
pruneWindows forall a b. (a -> b) -> a -> b
$ AvoidFloats Window
lm { cache :: Maybe ((Map Window RationalRect, Rectangle), Rectangle)
cache = forall a. a -> Maybe a
Just ((Map Window RationalRect
floating,Rectangle
r),Rectangle
mer) }) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout Workspace String (l Window) Window
w Rectangle
mer
        where
            toRect :: WindowAttributes -> Rectangle
            toRect :: WindowAttributes -> Rectangle
toRect WindowAttributes
wa = let b :: CInt
b = forall a b. (Integral a, Num b) => a -> b
fi forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_border_width WindowAttributes
wa
                        in Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (forall a b. (Integral a, Num b) => a -> b
fi forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_x WindowAttributes
wa) (forall a b. (Integral a, Num b) => a -> b
fi forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_y WindowAttributes
wa) (forall a b. (Integral a, Num b) => a -> b
fi forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_width WindowAttributes
wa forall a. Num a => a -> a -> a
+ CInt
2forall a. Num a => a -> a -> a
*CInt
b) (forall a b. (Integral a, Num b) => a -> b
fi forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_height WindowAttributes
wa forall a. Num a => a -> a -> a
+ CInt
2forall a. Num a => a -> a -> a
*CInt
b)

            bigEnough :: Rectangle -> Bool
            bigEnough :: Rectangle -> Bool
bigEnough Rectangle
rect = Rectangle -> Dimension
rect_width Rectangle
rect forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fi (forall a. AvoidFloats a -> Int
minw AvoidFloats Window
lm) Bool -> Bool -> Bool
&& Rectangle -> Dimension
rect_height Rectangle
rect forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fi (forall a. AvoidFloats a -> Int
minh AvoidFloats Window
lm)

            shouldAvoid :: Window -> Bool
shouldAvoid Window
a = forall a. AvoidFloats a -> Bool
avoidAll AvoidFloats Window
lm Bool -> Bool -> Bool
|| Window
a forall a. Ord a => a -> Set a -> Bool
`S.member` forall a. AvoidFloats a -> Set a
chosen AvoidFloats Window
lm

    pureMess :: AvoidFloats Window -> SomeMessage -> Maybe (AvoidFloats Window)
pureMess AvoidFloats Window
lm SomeMessage
m
        | Just AvoidFloatMsg
AvoidFloatToggle <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m =                                 forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ AvoidFloats Window
lm { avoidAll :: Bool
avoidAll = Bool -> Bool
not (forall a. AvoidFloats a -> Bool
avoidAll AvoidFloats Window
lm), cache :: Maybe ((Map Window RationalRect, Rectangle), Rectangle)
cache = forall a. Maybe a
Nothing }
        | Just (AvoidFloatSet Bool
s) <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m, Bool
s forall a. Eq a => a -> a -> Bool
/= forall a. AvoidFloats a -> Bool
avoidAll AvoidFloats Window
lm =              forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ AvoidFloats Window
lm { avoidAll :: Bool
avoidAll = Bool
s, cache :: Maybe ((Map Window RationalRect, Rectangle), Rectangle)
cache = forall a. Maybe a
Nothing }
        | Just AvoidFloatMsg
AvoidFloatClearItems <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m =                             forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ AvoidFloats Window
lm { chosen :: Set Window
chosen = forall a. Set a
S.empty, cache :: Maybe ((Map Window RationalRect, Rectangle), Rectangle)
cache = forall a. Maybe a
Nothing }
        | Just (AvoidFloatAddItem Window
a) <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m, Window
a forall a. Ord a => a -> Set a -> Bool
`S.notMember` forall a. AvoidFloats a -> Set a
chosen AvoidFloats Window
lm = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ AvoidFloats Window
lm { chosen :: Set Window
chosen = forall a. Ord a => a -> Set a -> Set a
S.insert Window
a (forall a. AvoidFloats a -> Set a
chosen AvoidFloats Window
lm), cache :: Maybe ((Map Window RationalRect, Rectangle), Rectangle)
cache = forall a. Maybe a
Nothing }
        | Just (AvoidFloatRemoveItem Window
a) <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m, Window
a forall a. Ord a => a -> Set a -> Bool
`S.member` forall a. AvoidFloats a -> Set a
chosen AvoidFloats Window
lm = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ AvoidFloats Window
lm { chosen :: Set Window
chosen = forall a. Ord a => a -> Set a -> Set a
S.delete Window
a (forall a. AvoidFloats a -> Set a
chosen AvoidFloats Window
lm), cache :: Maybe ((Map Window RationalRect, Rectangle), Rectangle)
cache = forall a. Maybe a
Nothing }
        | Just (AvoidFloatToggleItem Window
a) <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m =                         let op :: Window -> Set Window -> Set Window
op = if Window
a forall a. Ord a => a -> Set a -> Bool
`S.member` forall a. AvoidFloats a -> Set a
chosen AvoidFloats Window
lm then forall a. Ord a => a -> Set a -> Set a
S.delete else forall a. Ord a => a -> Set a -> Set a
S.insert
                                                                                   in forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ AvoidFloats Window
lm { chosen :: Set Window
chosen = Window -> Set Window -> Set Window
op Window
a (forall a. AvoidFloats a -> Set a
chosen AvoidFloats Window
lm), cache :: Maybe ((Map Window RationalRect, Rectangle), Rectangle)
cache = forall a. Maybe a
Nothing }
        | Bool
otherwise =                                                              forall a. Maybe a
Nothing

pruneWindows :: AvoidFloats Window -> AvoidFloats Window
pruneWindows :: AvoidFloats Window -> AvoidFloats Window
pruneWindows AvoidFloats Window
lm = case forall a.
AvoidFloats a -> Maybe ((Map a RationalRect, Rectangle), Rectangle)
cache AvoidFloats Window
lm of
    Maybe ((Map Window RationalRect, Rectangle), Rectangle)
Nothing -> AvoidFloats Window
lm
    Just ((Map Window RationalRect
floating,Rectangle
_),Rectangle
_) -> AvoidFloats Window
lm { chosen :: Set Window
chosen = forall a. (a -> Bool) -> Set a -> Set a
S.filter (forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map Window RationalRect
floating) (forall a. AvoidFloats a -> Set a
chosen AvoidFloats Window
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 :: Rectangle -> [Rectangle] -> [Rectangle]
maxEmptyRectangles Rectangle
br [Rectangle]
rectangles = forall a. (a -> Bool) -> [a] -> [a]
filter (\Rectangle
a -> Rectangle -> Int
area Rectangle
a forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ [Rectangle]
upAndDownEdge forall a. [a] -> [a] -> [a]
++ [Rectangle]
noneOrUpEdge forall a. [a] -> [a] -> [a]
++ [Rectangle]
downEdge
    where
        upAndDownEdge :: [Rectangle]
upAndDownEdge = Rectangle -> [Rectangle] -> [Rectangle]
findGaps Rectangle
br [Rectangle]
rectangles
        noneOrUpEdge :: [Rectangle]
noneOrUpEdge = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Rectangle -> [Rectangle] -> Rectangle -> [Rectangle]
everyLower Rectangle
br [Rectangle]
bottoms) [Rectangle]
bottoms
        downEdge :: [Rectangle]
downEdge = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Rectangle -> [Rectangle] -> Rectangle -> Maybe Rectangle
bottomEdge Rectangle
br [Rectangle]
bottoms) [Rectangle]
bottoms
        bottoms :: [Rectangle]
bottoms = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Rectangle -> Int
bottom forall a b. (a -> b) -> a -> b
$ [Rectangle] -> [Rectangle]
splitContainers [Rectangle]
rectangles

everyLower :: Rectangle -> [Rectangle] -> Rectangle -> [Rectangle]
everyLower :: Rectangle -> [Rectangle] -> Rectangle -> [Rectangle]
everyLower Rectangle
br [Rectangle]
bottoms Rectangle
r = let ([Rectangle]
rs, Int
boundLeft, Int
boundRight, [Rectangle]
boundRects) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Rectangle
-> Rectangle
-> ([Rectangle], Int, Int, [Rectangle])
-> ([Rectangle], Int, Int, [Rectangle])
everyUpper Rectangle
r) ([], Rectangle -> Int
left Rectangle
br, Rectangle -> Int
right Rectangle
br, forall a. [a] -> [a]
reverse [Rectangle]
bottoms) [Rectangle]
bottoms
                              (Int
boundLeft', Int
boundRight', [Rectangle]
_) = Int
-> Int
-> [Rectangle]
-> Rectangle
-> Int
-> (Int, Int, [Rectangle])
shrinkBounds Int
boundLeft Int
boundRight [Rectangle]
boundRects Rectangle
r (Rectangle -> Int
top Rectangle
br)
                          in Int -> Int -> Int -> Int -> Maybe Rectangle
mkRect Int
boundLeft' Int
boundRight' (Rectangle -> Int
top Rectangle
br) (Rectangle -> Int
top Rectangle
r) forall a. Maybe a -> [a] -> [a]
?: [Rectangle]
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 :: Rectangle
-> Rectangle
-> ([Rectangle], Int, Int, [Rectangle])
-> ([Rectangle], Int, Int, [Rectangle])
everyUpper Rectangle
lower Rectangle
upper ([Rectangle]
rs, Int
boundLeft, Int
boundRight, [Rectangle]
boundRects) = (Maybe Rectangle
rforall a. Maybe a -> [a] -> [a]
?:[Rectangle]
rs, Int
boundLeft', Int
boundRight', [Rectangle]
boundRects')
    where
        r :: Maybe Rectangle
r = Int -> Int -> Int -> Int -> Maybe Rectangle
mkRect Int
boundLeft' Int
boundRight' (Rectangle -> Int
bottom Rectangle
upper) (Rectangle -> Int
top Rectangle
lower)
        (Int
boundLeft', Int
boundRight', [Rectangle]
boundRects') = Int
-> Int
-> [Rectangle]
-> Rectangle
-> Int
-> (Int, Int, [Rectangle])
shrinkBounds Int
boundLeft Int
boundRight [Rectangle]
boundRects Rectangle
lower (Rectangle -> Int
bottom Rectangle
upper)

shrinkBounds :: Int -> Int -> [Rectangle] -> Rectangle -> Int -> (Int, Int, [Rectangle])
shrinkBounds :: Int
-> Int
-> [Rectangle]
-> Rectangle
-> Int
-> (Int, Int, [Rectangle])
shrinkBounds Int
boundLeft Int
boundRight [Rectangle]
boundRects Rectangle
lower Int
upperLimit = (Int
boundLeft', Int
boundRight', [Rectangle]
boundRects')
    where
        ([Rectangle]
shrinkers, [Rectangle]
boundRects') = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\Rectangle
a -> Rectangle -> Int
bottom Rectangle
a forall a. Ord a => a -> a -> Bool
> Int
upperLimit) [Rectangle]
boundRects
        (Int
boundLeft', Int
boundRight') = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Rectangle -> Rectangle -> (Int, Int) -> (Int, Int)
shrinkBounds' Rectangle
lower) (Int
boundLeft, Int
boundRight) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\Rectangle
a -> Rectangle -> Int
top Rectangle
a forall a. Ord a => a -> a -> Bool
< Rectangle -> Int
top Rectangle
lower) [Rectangle]
shrinkers

shrinkBounds' :: Rectangle -> Rectangle -> (Int, Int) -> (Int, Int)
shrinkBounds' :: Rectangle -> Rectangle -> (Int, Int) -> (Int, Int)
shrinkBounds' Rectangle
mr Rectangle
r (Int
boundLeft, Int
boundRight)
    | Rectangle -> Int
right Rectangle
r forall a. Ord a => a -> a -> Bool
< Rectangle -> Int
right Rectangle
mr = (forall a. Ord a => a -> a -> a
max Int
boundLeft forall a b. (a -> b) -> a -> b
$ Rectangle -> Int
right Rectangle
r, Int
boundRight)
    | Rectangle -> Int
left Rectangle
r forall a. Ord a => a -> a -> Bool
> Rectangle -> Int
left Rectangle
mr = (Int
boundLeft, forall a. Ord a => a -> a -> a
min Int
boundRight forall a b. (a -> b) -> a -> b
$ Rectangle -> Int
left Rectangle
r)
    | Bool
otherwise = (Rectangle -> Int
right Rectangle
r, Rectangle -> Int
left Rectangle
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 :: Rectangle -> [Rectangle] -> Rectangle -> Maybe Rectangle
bottomEdge Rectangle
br [Rectangle]
bottoms Rectangle
r = let rs :: [Rectangle]
rs = forall a. (a -> Bool) -> [a] -> [a]
filter (\Rectangle
a -> Rectangle -> Int
bottom Rectangle
r forall a. Ord a => a -> a -> Bool
< Rectangle -> Int
bottom Rectangle
a Bool -> Bool -> Bool
&& Rectangle -> Int
top Rectangle
a forall a. Ord a => a -> a -> Bool
< Rectangle -> Int
bottom Rectangle
br) [Rectangle]
bottoms
                              boundLeft :: Int
boundLeft = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ Rectangle -> Int
left Rectangle
br forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> a -> Bool
< Rectangle -> Int
right Rectangle
r) (forall a b. (a -> b) -> [a] -> [b]
map Rectangle -> Int
right [Rectangle]
rs)
                              boundRight :: Int
boundRight = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum forall a b. (a -> b) -> a -> b
$ Rectangle -> Int
right Rectangle
br forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> a -> Bool
> Rectangle -> Int
left Rectangle
r) (forall a b. (a -> b) -> [a] -> [b]
map Rectangle -> Int
left [Rectangle]
rs)
                          in if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Rectangle
a -> Rectangle -> Int
left Rectangle
a forall a. Ord a => a -> a -> Bool
<= Rectangle -> Int
left Rectangle
r Bool -> Bool -> Bool
&& Rectangle -> Int
right Rectangle
r forall a. Ord a => a -> a -> Bool
<= Rectangle -> Int
right Rectangle
a) [Rectangle]
rs
                             then forall a. Maybe a
Nothing
                             else Int -> Int -> Int -> Int -> Maybe Rectangle
mkRect Int
boundLeft Int
boundRight (Rectangle -> Int
bottom Rectangle
r) (Rectangle -> Int
bottom Rectangle
br)

-- | Split rectangles that horizontally fully contains another rectangle
--   without sharing either the left or right side.
splitContainers :: [Rectangle] -> [Rectangle]
splitContainers :: [Rectangle] -> [Rectangle]
splitContainers [Rectangle]
rects = [Rectangle] -> [Rectangle] -> [Rectangle]
splitContainers' [] forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Rectangle -> Dimension
rect_width [Rectangle]
rects
    where
        splitContainers' :: [Rectangle] -> [Rectangle] -> [Rectangle]
        splitContainers' :: [Rectangle] -> [Rectangle] -> [Rectangle]
splitContainers' [Rectangle]
res [] = [Rectangle]
res
        splitContainers' [Rectangle]
res (Rectangle
r:[Rectangle]
rs) = [Rectangle] -> [Rectangle] -> [Rectangle]
splitContainers' (Rectangle
rforall a. a -> [a] -> [a]
:[Rectangle]
res) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Rectangle -> Rectangle -> [Rectangle]
doSplit Rectangle
r) [Rectangle]
rs

        doSplit :: Rectangle -> Rectangle -> [Rectangle]
        doSplit :: Rectangle -> Rectangle -> [Rectangle]
doSplit Rectangle
guide Rectangle
r
            | Rectangle -> Int
left Rectangle
guide forall a. Ord a => a -> a -> Bool
<= Rectangle -> Int
left Rectangle
r Bool -> Bool -> Bool
|| Rectangle -> Int
right Rectangle
r forall a. Ord a => a -> a -> Bool
<= Rectangle -> Int
right Rectangle
guide = [Rectangle
r]
            | Bool
otherwise = let w0 :: Dimension
w0 = forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Position
rect_x Rectangle
guide forall a. Num a => a -> a -> a
- Rectangle -> Position
rect_x Rectangle
r) forall a. Num a => a -> a -> a
+ (Rectangle -> Dimension
rect_width Rectangle
guide forall a. Integral a => a -> a -> a
`div` Dimension
2)
                              w1 :: Dimension
w1 = Rectangle -> Dimension
rect_width Rectangle
r forall a. Num a => a -> a -> a
- Dimension
w0
                          in  [ Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (Rectangle -> Position
rect_x Rectangle
r)          (Rectangle -> Position
rect_y Rectangle
r) Dimension
w0 (Rectangle -> Dimension
rect_height Rectangle
r)
                              , Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (Rectangle -> Position
rect_x Rectangle
r forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi Dimension
w0)  (Rectangle -> Position
rect_y Rectangle
r) Dimension
w1 (Rectangle -> Dimension
rect_height Rectangle
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 :: Rectangle -> [Rectangle] -> [Rectangle]
findGaps Rectangle
br [Rectangle]
rs = let ([Rectangle]
gaps,Int
end) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Rectangle -> ([Rectangle], Int) -> ([Rectangle], Int)
findGaps' ([], Rectangle -> Int
left Rectangle
br) forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (forall a. a -> Down a
Down forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rectangle -> Int
left) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter Rectangle -> Bool
inBounds [Rectangle]
rs
                     lastgap :: Maybe Rectangle
lastgap = Int -> Int -> Int -> Int -> Maybe Rectangle
mkRect Int
end (Rectangle -> Int
right Rectangle
br) (Rectangle -> Int
top Rectangle
br) (Rectangle -> Int
bottom Rectangle
br)
                 in Maybe Rectangle
lastgapforall a. Maybe a -> [a] -> [a]
?:[Rectangle]
gaps
    where
        findGaps' :: Rectangle -> ([Rectangle], Int) -> ([Rectangle], Int)
        findGaps' :: Rectangle -> ([Rectangle], Int) -> ([Rectangle], Int)
findGaps' Rectangle
r ([Rectangle]
gaps, Int
end) = let gap :: Maybe Rectangle
gap = Int -> Int -> Int -> Int -> Maybe Rectangle
mkRect Int
end (Rectangle -> Int
left Rectangle
r) (Rectangle -> Int
top Rectangle
br) (Rectangle -> Int
bottom Rectangle
br)
                                  in (Maybe Rectangle
gapforall a. Maybe a -> [a] -> [a]
?:[Rectangle]
gaps, forall a. Ord a => a -> a -> a
max Int
end (Rectangle -> Int
right Rectangle
r))

        inBounds :: Rectangle -> Bool
        inBounds :: Rectangle -> Bool
inBounds Rectangle
r = Rectangle -> Int
left Rectangle
r forall a. Ord a => a -> a -> Bool
< Rectangle -> Int
right Rectangle
br Bool -> Bool -> Bool
&& Rectangle -> Int
left Rectangle
br forall a. Ord a => a -> a -> Bool
< Rectangle -> Int
right Rectangle
r

(?:) :: Maybe a -> [a] -> [a]
Just a
x ?: :: forall a. Maybe a -> [a] -> [a]
?: [a]
xs = a
xforall a. a -> [a] -> [a]
:[a]
xs
Maybe a
_ ?: [a]
xs = [a]
xs

left, right, top, bottom, area :: Rectangle -> Int
left :: Rectangle -> Int
left Rectangle
r = forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Position
rect_x Rectangle
r)
right :: Rectangle -> Int
right Rectangle
r = forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Position
rect_x Rectangle
r) forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width Rectangle
r)
top :: Rectangle -> Int
top Rectangle
r = forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Position
rect_y Rectangle
r)
bottom :: Rectangle -> Int
bottom Rectangle
r = forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Position
rect_y Rectangle
r) forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_height Rectangle
r)
area :: Rectangle -> Int
area Rectangle
r = forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width Rectangle
r forall a. Num a => a -> a -> a
* Rectangle -> Dimension
rect_height Rectangle
r)

mkRect :: Int -> Int -> Int -> Int -> Maybe Rectangle
mkRect :: Int -> Int -> Int -> Int -> Maybe Rectangle
mkRect Int
l Int
r Int
t Int
b = let rect :: Rectangle
rect = Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (forall a b. (Integral a, Num b) => a -> b
fi Int
l) (forall a b. (Integral a, Num b) => a -> b
fi Int
t) (forall a b. (Integral a, Num b) => a -> b
fi forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max Int
0 forall a b. (a -> b) -> a -> b
$ Int
rforall a. Num a => a -> a -> a
-Int
l) (forall a b. (Integral a, Num b) => a -> b
fi forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max Int
0 forall a b. (a -> b) -> a -> b
$ Int
bforall a. Num a => a -> a -> a
-Int
t)
                 in if Rectangle -> Int
area Rectangle
rect forall a. Ord a => a -> a -> Bool
> Int
0
                    then forall a. a -> Maybe a
Just Rectangle
rect
                    else forall a. Maybe a
Nothing