{-# 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 = Int -> Int -> Bool -> l a -> ModifiedLayout AvoidFloats l a
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 = AvoidFloats a -> l a -> ModifiedLayout AvoidFloats l a
forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (Maybe ((Map a RationalRect, Rectangle), Rectangle)
-> Set a -> Int -> Int -> Bool -> AvoidFloats a
forall a.
Maybe ((Map a RationalRect, Rectangle), Rectangle)
-> Set a -> Int -> Int -> Bool -> AvoidFloats a
AvoidFloats Maybe ((Map a RationalRect, Rectangle), Rectangle)
forall a. Maybe a
Nothing Set a
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)
Int -> ReadS (AvoidFloats a)
ReadS [AvoidFloats a]
(Int -> ReadS (AvoidFloats a))
-> ReadS [AvoidFloats a]
-> ReadPrec (AvoidFloats a)
-> ReadPrec [AvoidFloats a]
-> Read (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
$creadsPrec :: forall a. (Ord a, Read a) => Int -> ReadS (AvoidFloats a)
readsPrec :: Int -> ReadS (AvoidFloats a)
$creadList :: forall a. (Ord a, Read a) => ReadS [AvoidFloats a]
readList :: ReadS [AvoidFloats a]
$creadPrec :: forall a. (Ord a, Read a) => ReadPrec (AvoidFloats a)
readPrec :: ReadPrec (AvoidFloats a)
$creadListPrec :: forall a. (Ord a, Read a) => ReadPrec [AvoidFloats a]
readListPrec :: ReadPrec [AvoidFloats a]
Read, Int -> AvoidFloats a -> ShowS
[AvoidFloats a] -> ShowS
AvoidFloats a -> String
(Int -> AvoidFloats a -> ShowS)
-> (AvoidFloats a -> String)
-> ([AvoidFloats a] -> ShowS)
-> Show (AvoidFloats a)
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
$cshowsPrec :: forall a. Show a => Int -> AvoidFloats a -> ShowS
showsPrec :: Int -> AvoidFloats a -> ShowS
$cshow :: forall a. Show a => AvoidFloats a -> String
show :: AvoidFloats a -> String
$cshowList :: forall a. Show a => [AvoidFloats a] -> ShowS
showList :: [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 = (Display
 -> X (([(Window, Rectangle)], Maybe (l Window)),
       Maybe (AvoidFloats Window)))
-> X (([(Window, Rectangle)], Maybe (l Window)),
      Maybe (AvoidFloats Window))
forall a. (Display -> X a) -> X a
withDisplay ((Display
  -> X (([(Window, Rectangle)], Maybe (l Window)),
        Maybe (AvoidFloats Window)))
 -> X (([(Window, Rectangle)], Maybe (l Window)),
       Maybe (AvoidFloats Window)))
-> (Display
    -> X (([(Window, Rectangle)], Maybe (l Window)),
          Maybe (AvoidFloats Window)))
-> X (([(Window, Rectangle)], Maybe (l Window)),
      Maybe (AvoidFloats Window))
forall a b. (a -> b) -> a -> b
$ \Display
d -> do
        Map Window RationalRect
floating <- (XState -> Map Window RationalRect) -> X (Map Window RationalRect)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState -> Map Window RationalRect)
 -> X (Map Window RationalRect))
-> (XState -> Map Window RationalRect)
-> X (Map Window RationalRect)
forall a b. (a -> b) -> a -> b
$ StackSet String (Layout Window) Window ScreenId ScreenDetail
-> Map Window RationalRect
forall i l a sid sd. StackSet i l a sid sd -> Map a RationalRect
W.floating (StackSet String (Layout Window) Window ScreenId ScreenDetail
 -> Map Window RationalRect)
-> (XState
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Map Window RationalRect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
windowset
        case AvoidFloats Window
-> Maybe ((Map Window RationalRect, Rectangle), Rectangle)
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 (Map Window RationalRect, Rectangle)
-> (Map Window RationalRect, Rectangle) -> Bool
forall a. Eq a => a -> a -> Bool
== (Map Window RationalRect
floating,Rectangle
r) -> (, Maybe (AvoidFloats Window)
forall a. Maybe a
Nothing) (([(Window, Rectangle)], Maybe (l Window))
 -> (([(Window, Rectangle)], Maybe (l Window)),
     Maybe (AvoidFloats Window)))
-> X ([(Window, Rectangle)], Maybe (l Window))
-> X (([(Window, Rectangle)], Maybe (l Window)),
      Maybe (AvoidFloats Window))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Workspace String (l Window) Window
-> Rectangle -> X ([(Window, Rectangle)], Maybe (l Window))
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 <- IO [Rectangle] -> X [Rectangle]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [Rectangle] -> X [Rectangle])
-> IO [Rectangle] -> X [Rectangle]
forall a b. (a -> b) -> a -> b
$ (WindowAttributes -> Rectangle)
-> [WindowAttributes] -> [Rectangle]
forall a b. (a -> b) -> [a] -> [b]
map WindowAttributes -> Rectangle
toRect ([WindowAttributes] -> [Rectangle])
-> IO [WindowAttributes] -> IO [Rectangle]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Window -> IO WindowAttributes)
-> [Window] -> IO [WindowAttributes]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Display -> Window -> IO WindowAttributes
getWindowAttributes Display
d) ((Window -> Bool) -> [Window] -> [Window]
forall a. (a -> Bool) -> [a] -> [a]
filter Window -> Bool
shouldAvoid ([Window] -> [Window]) -> [Window] -> [Window]
forall a b. (a -> b) -> a -> b
$ Map Window RationalRect -> [Window]
forall k a. Map k a -> [k]
M.keys Map Window RationalRect
floating)
                    let mer :: Rectangle
mer = (Rectangle -> Rectangle -> Ordering) -> [Rectangle] -> Rectangle
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy ((Rectangle -> Int) -> Rectangle -> Rectangle -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Rectangle -> Int
area) ([Rectangle] -> Rectangle) -> [Rectangle] -> Rectangle
forall a b. (a -> b) -> a -> b
$ (Rectangle -> Bool) -> [Rectangle] -> [Rectangle]
forall a. (a -> Bool) -> [a] -> [a]
filter Rectangle -> Bool
bigEnough ([Rectangle] -> [Rectangle]) -> [Rectangle] -> [Rectangle]
forall a b. (a -> b) -> a -> b
$ Rectangle -> [Rectangle] -> [Rectangle]
maxEmptyRectangles Rectangle
r [Rectangle]
rs
                    (, AvoidFloats Window -> Maybe (AvoidFloats Window)
forall a. a -> Maybe a
Just (AvoidFloats Window -> Maybe (AvoidFloats Window))
-> AvoidFloats Window -> Maybe (AvoidFloats Window)
forall a b. (a -> b) -> a -> b
$ AvoidFloats Window -> AvoidFloats Window
pruneWindows (AvoidFloats Window -> AvoidFloats Window)
-> AvoidFloats Window -> AvoidFloats Window
forall a b. (a -> b) -> a -> b
$ AvoidFloats Window
lm { cache = Just ((floating,r),mer) }) (([(Window, Rectangle)], Maybe (l Window))
 -> (([(Window, Rectangle)], Maybe (l Window)),
     Maybe (AvoidFloats Window)))
-> X ([(Window, Rectangle)], Maybe (l Window))
-> X (([(Window, Rectangle)], Maybe (l Window)),
      Maybe (AvoidFloats Window))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Workspace String (l Window) Window
-> Rectangle -> X ([(Window, Rectangle)], Maybe (l Window))
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 = CInt -> CInt
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> CInt) -> CInt -> CInt
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_border_width WindowAttributes
wa
                        in Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Position) -> CInt -> Position
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_x WindowAttributes
wa) (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Position) -> CInt -> Position
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_y WindowAttributes
wa) (CInt -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Dimension) -> CInt -> Dimension
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_width WindowAttributes
wa CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
+ CInt
2CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
*CInt
b) (CInt -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Dimension) -> CInt -> Dimension
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_height WindowAttributes
wa CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
+ CInt
2CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
*CInt
b)

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

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

pruneWindows :: AvoidFloats Window -> AvoidFloats Window
pruneWindows :: AvoidFloats Window -> AvoidFloats Window
pruneWindows AvoidFloats Window
lm = case AvoidFloats Window
-> Maybe ((Map Window RationalRect, Rectangle), Rectangle)
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 = S.filter (`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 :: Rectangle -> [Rectangle] -> [Rectangle]
maxEmptyRectangles Rectangle
br [Rectangle]
rectangles = (Rectangle -> Bool) -> [Rectangle] -> [Rectangle]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Rectangle
a -> Rectangle -> Int
area Rectangle
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) ([Rectangle] -> [Rectangle]) -> [Rectangle] -> [Rectangle]
forall a b. (a -> b) -> a -> b
$ [Rectangle]
upAndDownEdge [Rectangle] -> [Rectangle] -> [Rectangle]
forall a. [a] -> [a] -> [a]
++ [Rectangle]
noneOrUpEdge [Rectangle] -> [Rectangle] -> [Rectangle]
forall a. [a] -> [a] -> [a]
++ [Rectangle]
downEdge
    where
        upAndDownEdge :: [Rectangle]
upAndDownEdge = Rectangle -> [Rectangle] -> [Rectangle]
findGaps Rectangle
br [Rectangle]
rectangles
        noneOrUpEdge :: [Rectangle]
noneOrUpEdge = (Rectangle -> [Rectangle]) -> [Rectangle] -> [Rectangle]
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 = (Rectangle -> Maybe Rectangle) -> [Rectangle] -> [Rectangle]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Rectangle -> [Rectangle] -> Rectangle -> Maybe Rectangle
bottomEdge Rectangle
br [Rectangle]
bottoms) [Rectangle]
bottoms
        bottoms :: [Rectangle]
bottoms = (Rectangle -> Int) -> [Rectangle] -> [Rectangle]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Rectangle -> Int
bottom ([Rectangle] -> [Rectangle]) -> [Rectangle] -> [Rectangle]
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) = (Rectangle
 -> ([Rectangle], Int, Int, [Rectangle])
 -> ([Rectangle], Int, Int, [Rectangle]))
-> ([Rectangle], Int, Int, [Rectangle])
-> [Rectangle]
-> ([Rectangle], Int, Int, [Rectangle])
forall a b. (a -> b -> b) -> b -> [a] -> b
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, [Rectangle] -> [Rectangle]
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) Maybe Rectangle -> [Rectangle] -> [Rectangle]
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
rMaybe Rectangle -> [Rectangle] -> [Rectangle]
forall 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') = (Rectangle -> Bool) -> [Rectangle] -> ([Rectangle], [Rectangle])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\Rectangle
a -> Rectangle -> Int
bottom Rectangle
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
upperLimit) [Rectangle]
boundRects
        (Int
boundLeft', Int
boundRight') = (Rectangle -> (Int, Int) -> (Int, Int))
-> (Int, Int) -> [Rectangle] -> (Int, Int)
forall a b. (a -> b -> b) -> b -> [a] -> b
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) ([Rectangle] -> (Int, Int)) -> [Rectangle] -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ (Rectangle -> Bool) -> [Rectangle] -> [Rectangle]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Rectangle
a -> Rectangle -> Int
top Rectangle
a Int -> Int -> Bool
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Rectangle -> Int
right Rectangle
mr = (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
boundLeft (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Rectangle -> Int
right Rectangle
r, Int
boundRight)
    | Rectangle -> Int
left Rectangle
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Rectangle -> Int
left Rectangle
mr = (Int
boundLeft, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
boundRight (Int -> Int) -> Int -> Int
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 = (Rectangle -> Bool) -> [Rectangle] -> [Rectangle]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Rectangle
a -> Rectangle -> Int
bottom Rectangle
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Rectangle -> Int
bottom Rectangle
a Bool -> Bool -> Bool
&& Rectangle -> Int
top Rectangle
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Rectangle -> Int
bottom Rectangle
br) [Rectangle]
bottoms
                              boundLeft :: Int
boundLeft = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Rectangle -> Int
left Rectangle
br Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Rectangle -> Int
right Rectangle
r) ((Rectangle -> Int) -> [Rectangle] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Rectangle -> Int
right [Rectangle]
rs)
                              boundRight :: Int
boundRight = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Rectangle -> Int
right Rectangle
br Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Rectangle -> Int
left Rectangle
r) ((Rectangle -> Int) -> [Rectangle] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Rectangle -> Int
left [Rectangle]
rs)
                          in if (Rectangle -> Bool) -> [Rectangle] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Rectangle
a -> Rectangle -> Int
left Rectangle
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Rectangle -> Int
left Rectangle
r Bool -> Bool -> Bool
&& Rectangle -> Int
right Rectangle
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Rectangle -> Int
right Rectangle
a) [Rectangle]
rs
                             then Maybe Rectangle
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' [] ([Rectangle] -> [Rectangle]) -> [Rectangle] -> [Rectangle]
forall a b. (a -> b) -> a -> b
$ (Rectangle -> Dimension) -> [Rectangle] -> [Rectangle]
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
rRectangle -> [Rectangle] -> [Rectangle]
forall a. a -> [a] -> [a]
:[Rectangle]
res) ([Rectangle] -> [Rectangle]) -> [Rectangle] -> [Rectangle]
forall a b. (a -> b) -> a -> b
$ (Rectangle -> [Rectangle]) -> [Rectangle] -> [Rectangle]
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Rectangle -> Int
left Rectangle
r Bool -> Bool -> Bool
|| Rectangle -> Int
right Rectangle
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Rectangle -> Int
right Rectangle
guide = [Rectangle
r]
            | Bool
otherwise = let w0 :: Dimension
w0 = Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Position
rect_x Rectangle
guide Position -> Position -> Position
forall a. Num a => a -> a -> a
- Rectangle -> Position
rect_x Rectangle
r) Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+ (Rectangle -> Dimension
rect_width Rectangle
guide Dimension -> Dimension -> Dimension
forall a. Integral a => a -> a -> a
`div` Dimension
2)
                              w1 :: Dimension
w1 = Rectangle -> Dimension
rect_width Rectangle
r Dimension -> Dimension -> Dimension
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 Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
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) = (Rectangle -> ([Rectangle], Int) -> ([Rectangle], Int))
-> ([Rectangle], Int) -> [Rectangle] -> ([Rectangle], Int)
forall a b. (a -> b -> b) -> b -> [a] -> b
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) ([Rectangle] -> ([Rectangle], Int))
-> [Rectangle] -> ([Rectangle], Int)
forall a b. (a -> b) -> a -> b
$ (Rectangle -> Down Int) -> [Rectangle] -> [Rectangle]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int -> Down Int
forall a. a -> Down a
Down (Int -> Down Int) -> (Rectangle -> Int) -> Rectangle -> Down Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rectangle -> Int
left) ([Rectangle] -> [Rectangle]) -> [Rectangle] -> [Rectangle]
forall a b. (a -> b) -> a -> b
$ (Rectangle -> Bool) -> [Rectangle] -> [Rectangle]
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
lastgapMaybe Rectangle -> [Rectangle] -> [Rectangle]
forall 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
gapMaybe Rectangle -> [Rectangle] -> [Rectangle]
forall a. Maybe a -> [a] -> [a]
?:[Rectangle]
gaps, Int -> Int -> Int
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Rectangle -> Int
right Rectangle
br Bool -> Bool -> Bool
&& Rectangle -> Int
left Rectangle
br Int -> Int -> Bool
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
xa -> [a] -> [a]
forall 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 = Position -> Int
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Position
rect_x Rectangle
r)
right :: Rectangle -> Int
right Rectangle
r = Position -> Int
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Position
rect_x Rectangle
r) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Dimension -> Int
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width Rectangle
r)
top :: Rectangle -> Int
top Rectangle
r = Position -> Int
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Position
rect_y Rectangle
r)
bottom :: Rectangle -> Int
bottom Rectangle
r = Position -> Int
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Position
rect_y Rectangle
r) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Dimension -> Int
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_height Rectangle
r)
area :: Rectangle -> Int
area Rectangle
r = Dimension -> Int
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width Rectangle
r Dimension -> Dimension -> Dimension
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 (Int -> Position
forall a b. (Integral a, Num b) => a -> b
fi Int
l) (Int -> Position
forall a b. (Integral a, Num b) => a -> b
fi Int
t) (Int -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (Int -> Dimension) -> Int -> Dimension
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
l) (Int -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (Int -> Dimension) -> Int -> Dimension
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
bInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
t)
                 in if Rectangle -> Int
area Rectangle
rect Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                    then Rectangle -> Maybe Rectangle
forall a. a -> Maybe a
Just Rectangle
rect
                    else Maybe Rectangle
forall a. Maybe a
Nothing