    {-# 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 Full ||| ...
    --
    -- For more detailed instructions on editing the layoutHook see:
    -- "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
    -- "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.
    --   No windows are avoided by default, they need to be added using signals.
    avoidFloats
        :: l a  -- ^ Layout to modify.
        -> ModifiedLayout AvoidFloats l a
    avoidFloats = avoidFloats' 100 100 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' 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