    {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}
    {-# LANGUAGE ParallelListComp, PatternGuards #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module       : XMonad.Layout.LayoutHints
    -- Copyright    : (c) David Roundy <droundy@darcs.net>
    -- License      : BSD
    --
    -- Maintainer   : none
    -- Stability    : unstable
    -- Portability  : unportable
    --
    -- Make layouts respect size hints.
    -----------------------------------------------------------------------------

    module XMonad.Layout.LayoutHints
        ( -- * usage
          -- $usage
          layoutHints
        , layoutHintsWithPlacement
        , layoutHintsToCenter
        , LayoutHints
        , LayoutHintsToCenter
        , hintsEventHook
        )  where

    import XMonad(LayoutClass(runLayout), mkAdjust, Window,
                  Dimension, Position, Rectangle(Rectangle), D,
                  X, refresh, Event(..), propertyNotify, wM_NORMAL_HINTS,
                  (<&&>), io, applySizeHints, whenX, isClient, withDisplay,
                  getWindowAttributes, getWMNormalHints, WindowAttributes(..))
    import qualified XMonad.StackSet as W

    import XMonad.Layout.Decoration(isInStack)
    import XMonad.Layout.LayoutModifier(ModifiedLayout(..),
                                        LayoutModifier(modifyLayout, redoLayout, modifierDescription))
    import XMonad.Util.Types(Direction2D(..))
    import Control.Applicative((<$>))
    import Control.Arrow(Arrow((***), first, second))
    import Control.Monad(join)
    import Data.Function(on)
    import Data.List(sortBy)
    import Data.Monoid(All(..))

    import Data.Set (Set)
    import qualified Data.Set as Set

    -- $usage
    -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
    --
    -- > import XMonad.Layout.LayoutHints
    --
    -- Then edit your @layoutHook@ by adding the 'layoutHints' layout modifier
    -- to some layout:
    --
    -- > myLayout = layoutHints (Tall 1 (3/100) (1/2))  ||| Full ||| etc..
    -- > main = xmonad def { layoutHook = myLayout }
    --
    -- Or, to center the adapted window in its available area:
    --
    -- > myLayout = layoutHintsWithPlacement (0.5, 0.5) (Tall 1 (3/100) (1/2))
    -- >                   ||| Full ||| etc..
    --
    -- Or, to make a reasonable attempt to eliminate gaps between windows:
    --
    -- > myLayout = layoutHintsToCenter (Tall 1 (3/100) (1/2))
    --
    -- For more detailed instructions on editing the layoutHook see:
    --
    -- "XMonad.Doc.Extending#Editing_the_layout_hook"
    --
    -- To make XMonad reflect changes in window hints immediately, add
    -- 'hintsEventHook' to your 'handleEventHook'.
    --
    -- > myHandleEventHook = hintsEventHook <+> ...
    -- >
    -- > main = xmonad def { handleEventHook = myHandleEventHook
    -- >                   , ... }

    layoutHints :: (LayoutClass l a) => l a -> ModifiedLayout LayoutHints l a
    layoutHints = ModifiedLayout (LayoutHints (0, 0))

    -- | @layoutHintsWithPlacement (rx, ry) layout@ will adapt the sizes of a layout's
    -- windows according to their size hints, and position them inside their
    -- originally assigned area according to the @rx@ and @ry@ parameters.
    -- (0, 0) places the window at the top left, (1, 0) at the top right, (0.5, 0.5)
    -- at the center, etc.
    layoutHintsWithPlacement :: (LayoutClass l a) => (Double, Double)
                             -> l a -> ModifiedLayout LayoutHints l a
    layoutHintsWithPlacement rs = ModifiedLayout (LayoutHints rs)

    -- | @layoutHintsToCenter layout@ applies hints, sliding the window to the
    -- center of the screen and expanding its neighbors to fill the gaps. Windows
    -- are never expanded in a way that increases overlap.
    --
    -- @layoutHintsToCenter@ only makes one pass at resizing the neighbors of
    -- hinted windows, so with some layouts (ex. the arrangement with two 'Mirror'
    -- 'Tall' stacked vertically), @layoutHintsToCenter@ may leave some gaps.
    -- Simple layouts like 'Tall' are unaffected.
    layoutHintsToCenter :: (LayoutClass l a) => l a -> ModifiedLayout LayoutHintsToCenter l a
    layoutHintsToCenter = ModifiedLayout LayoutHintsToCenter

    data LayoutHints a = LayoutHints (Double, Double)
                         deriving (Read, Show)

    instance LayoutModifier LayoutHints Window where
        modifierDescription _ = "Hinted"
        redoLayout _ _ Nothing  xs = return (xs, Nothing)
        redoLayout (LayoutHints al) _ (Just s) xs
            = do xs' <- mapM (\x@(_, r) -> second (placeRectangle al r) <$> applyHint x) xs
                 return (xs', Nothing)
         where
            applyHint (w,r@(Rectangle a b c d)) = do
                adj <- mkAdjust w
                let (c',d') = adj (c,d)
                return (w, if isInStack s w then Rectangle a b c' d' else r)

    -- | @placeRectangle (rx, ry) r0 r@ will return a new rectangle with the same dimensions
    -- as @r@, but positioned inside of @r0@ as specified by the (rx, ry) parameters (see
    -- 'layoutHintsWithPlacement').
    placeRectangle :: RealFrac r => (r, r) -> Rectangle -> Rectangle -> Rectangle
    placeRectangle (rx, ry) (Rectangle x0 y0 w h) (Rectangle _ _ dx dy)
        = Rectangle (align x0 dx w rx) (align y0 dy h ry) dx dy
        where align :: RealFrac r => Position -> Dimension -> Dimension -> r -> Position
              align z0 dz d r = z0 + truncate (fromIntegral (d - dz) * r)

    fitting :: [Rectangle] -> Int
    fitting rects = sum $ do
        r <- rects
        return $ length $ filter (touching r) rects

    applyOrder :: Rectangle -> [((Window, Rectangle),t)] -> [[((Window, Rectangle),t)]]
    applyOrder root wrs = do
        -- perhaps it would just be better to take all permutations, or apply the
        -- resizing multiple times
        f <- [maximum, minimum, sum, sum . map sq]
        return $ sortBy (compare `on` (f . distance)) wrs
        where distFC = uncurry ((+) `on` sq) . pairWise (-) (center root)
              distance = map distFC . corners . snd . fst
              pairWise f (a,b) (c,d) = (f a c, f b d)
              sq = join (*)

    data LayoutHintsToCenter a = LayoutHintsToCenter deriving (Read, Show)

    instance LayoutModifier LayoutHintsToCenter Window where
        modifyLayout _ ws@(W.Workspace _ _ Nothing) r = runLayout ws r
        modifyLayout _ ws@(W.Workspace _ _ (Just st)) r = do
            (arrs,ol) <- runLayout ws r
            flip (,) ol
                . head . reverse . sortBy (compare `on` (fitting . map snd))
                . map (applyHints st r) . applyOrder r
                <$> mapM (\x -> fmap ((,) x) $ mkAdjust (fst x)) arrs

    -- apply hints to first, grow adjacent windows
    applyHints :: W.Stack Window -> Rectangle -> [((Window, Rectangle),(D -> D))] -> [(Window, Rectangle)]
    applyHints _ _ [] = []
    applyHints s root (((w,lrect@(Rectangle a b c d)),adj):xs) =
            let (c',d') = adj (c,d)
                redr = placeRectangle (centerPlacement root lrect :: (Double,Double)) lrect
                        $ if isInStack s w then Rectangle a b c' d' else lrect

                ds = (fromIntegral c - fromIntegral c',fromIntegral d - fromIntegral d')
                growOther' r = growOther ds lrect (freeDirs root lrect) r
                mapSnd f = map (first $ second f)
                next = applyHints s root $ mapSnd growOther' xs
            in (w,redr):next

    growOther :: (Position, Position) -> Rectangle -> Set Direction2D -> Rectangle -> Rectangle
    growOther ds lrect fds r
        | dirs <- flipDir <$> Set.toList (Set.intersection adj fds)
        , not $ any (uncurry opposite) $ cross dirs =
            foldr (flip grow ds) r dirs
        | otherwise = r
        where
            adj = adjacent lrect  r
            cross xs = [ (a,b) | a <- xs, b <- xs ]

            flipDir :: Direction2D -> Direction2D
            flipDir d = case d of { L -> R; U -> D; R -> L; D -> U }

            opposite :: Direction2D -> Direction2D -> Bool
            opposite x y = flipDir x == y

    -- | Leave the opposite edges where they were
    grow :: Direction2D -> (Position,Position) -> Rectangle -> Rectangle
    grow L (px,_ ) (Rectangle x y w h) = Rectangle (x-px) y (w+fromIntegral px) h
    grow U (_ ,py) (Rectangle x y w h) = Rectangle x (y-py) w (h+fromIntegral py)
    grow R (px,_ ) (Rectangle x y w h) = Rectangle x y (w+fromIntegral px) h
    grow D (_ ,py) (Rectangle x y w h) = Rectangle x y w (h+fromIntegral py)

    comparingEdges :: ([Position] -> [Position] -> Bool) -> Rectangle -> Rectangle -> Set Direction2D
    comparingEdges surrounds r1 r2 = Set.fromList $ map fst $ filter snd [ (\k -> (dir,k)) $
                any and [[dir `elem` [R,L], allEq [a,c,w,y], [b,d] `surrounds` [x,z]]
                        ,[dir `elem` [U,D], allEq [b,d,x,z], [a,c] `surrounds` [w,y]]]
        | ((a,b),(c,d)) <- edge $ corners r1
        | ((w,x),(y,z)) <- edge $ delay 2 $ corners r2
        | dir <- [U,R,D,L]]
            where edge (x:xs) = zip (x:xs) (xs ++ [x])
                  edge [] = []
                  delay n xs = drop n xs ++ take n xs
                  allEq = all (uncurry (==)) . edge

    -- | in what direction is the second window from the first that can expand if the
    -- first is shrunk, assuming that the root window is fully covered:
    --  one direction for a common edge
    --  two directions for a common corner
    adjacent :: Rectangle -> Rectangle -> Set Direction2D
    adjacent = comparingEdges (all . onClosedInterval)

    -- | True whenever two edges touch. not (Set.null $ adjacent x y) ==> touching x y
    touching :: Rectangle -> Rectangle -> Bool
    touching a b = not . Set.null $ comparingEdges c a b
        where c x y = any (onClosedInterval x) y || any (onClosedInterval y) x

    onClosedInterval :: Ord a => [a] -> a -> Bool
    onClosedInterval bds x = minimum bds <= x && maximum bds >= x

    -- | starting top left going clockwise
    corners :: Rectangle -> [(Position, Position)]
    corners (Rectangle x y w h) = [(x,y)
                                  ,(x+fromIntegral w, y)
                                  ,(x+fromIntegral w, y+fromIntegral h)
                                  ,(x, y+fromIntegral h)]

    center :: Rectangle -> (Position, Position)
    center (Rectangle x y w h) = (avg x w, avg y h)
        where avg a b = a + fromIntegral b `div` 2

    centerPlacement :: RealFrac r => Rectangle -> Rectangle -> (r, r)
    centerPlacement = centerPlacement' clamp
        where clamp n = case signum n of
                                0 -> 0.5
                                1 -> 1
                                _ -> 0

    freeDirs :: Rectangle -> Rectangle -> Set Direction2D
    freeDirs root = Set.fromList . uncurry (++) . (lr *** ud)
                  . centerPlacement' signum root
        where
            lr 1 = [L]
            lr (-1) = [R]
            lr _ = [L,R]
            ud 1 = [U]
            ud (-1) = [D]
            ud _ = [U,D]

    centerPlacement' :: (Position -> r) -> Rectangle -> Rectangle -> (r, r)
    centerPlacement' cf root assigned
        = (cf $ cx - cwx, cf $ cy - cwy)
        where (cx,cy) = center root
              (cwx,cwy) = center assigned

    -- | Event hook that refreshes the layout whenever a window changes its hints.
    hintsEventHook :: Event -> X All
    hintsEventHook (PropertyEvent { ev_event_type = t, ev_atom = a, ev_window = w })
        | t == propertyNotify && a == wM_NORMAL_HINTS = do
            whenX (isClient w <&&> hintsMismatch w) $ refresh
            return (All True)
    hintsEventHook _ = return (All True)

    -- | True if the window's current size does not satisfy its size hints.
    hintsMismatch :: Window -> X Bool
    hintsMismatch w = withDisplay $ \d -> io $ do
        wa <- getWindowAttributes d w
        sh <- getWMNormalHints d w
        let dim = (fromIntegral $ wa_width wa, fromIntegral $ wa_height wa)
        return $ dim /= applySizeHints 0 sh dim