    -----------------------------------------------------------------------------
    -- |
    -- Module      :  XMonad.Hooks.Place
    -- Copyright   :  Quentin Moser <quentin.moser@unifr.ch>
    -- License     :  BSD-style (see LICENSE)
    --
    -- Maintainer  :  Quentin Moser <quentin.moser@unifr.ch>
    -- Stability   :  unstable
    -- Portability :  unportable
    --
    -- Automatic placement of floating windows.
    --
    -----------------------------------------------------------------------------

    module XMonad.Hooks.Place   ( -- * Usage
                                  -- $usage

                                  -- * Placement actions
                                  placeFocused
                                , placeHook

                                  -- * Placement policies
                                  -- $placements
                                , Placement
                                , smart
                                , simpleSmart
                                , fixed
                                , underMouse
                                , inBounds
                                , withGaps

                                  -- * Others
                                , purePlaceWindow ) where

    import XMonad
    import qualified XMonad.StackSet as S

    import XMonad.Layout.WindowArranger
    import XMonad.Actions.FloatKeys

    import qualified Data.Map as M
    import Data.Ratio ((%))
    import Data.List (sortBy, minimumBy, partition)
    import Data.Maybe (maybe, fromMaybe, catMaybes)
    import Data.Monoid (Endo(..))
    import Control.Monad (guard, join)
    import Control.Monad.Trans (lift)

    -- $usage
    -- This module provides a 'ManageHook' that automatically places
    -- floating windows at appropriate positions on the screen, as well
    -- as an 'X' action to manually trigger repositioning.
    --
    -- You can use this module by including the following in your @~\/.xmonad\/xmonad.hs@:
    --
    -- > import XMonad.Hooks.Place
    --
    -- and adding 'placeHook' to your 'manageHook', for example:
    --
    -- > main = xmonad $ defaultConfig { manageHook = placeHook simpleSmart
    -- >                                              <+> manageHook defaultConfig }
    --
    -- Note that 'placeHook' should be applied after most other hooks, especially hooks
    -- such as 'doFloat' and 'doShift'. Since hooks combined with '<+>' are applied from
    -- right to left, this means that 'placeHook' should be the /first/ hook in your chain.
    --
    -- You can also define a key to manually trigger repositioning with 'placeFocused' by
    -- adding the following to your keys definition:
    --
    -- > , ((modm, xK_w), placeFocused simpleSmart)
    --
    -- Both 'placeHook' and 'placeFocused' take a 'Placement' parameter, which specifies
    -- the placement policy to use (smart, under the mouse, fixed position, etc.). See
    -- 'Placement' for a list of available policies.

    {- Placement policies -}

    -- $placements
    -- Placement policies determine how windows will be placed by 'placeFocused' and 'placeHook'.
    --
    -- A few examples:
    --
    -- * Basic smart placement
    --
    -- > myPlacement = simpleSmart
    --
    -- * Under the mouse (pointer at the top-left corner), but constrained
    --   inside of the screen area
    --
    -- > myPlacement = inBounds (underMouse (0, 0))
    --
    -- * Smart placement with a preference for putting windows near
    -- the center of the screen, and with 16px gaps at the top and bottom
    -- of the screen where no window will be placed
    --
    -- > myPlacement = withGaps (16,0,16,0) (smart (0.5,0.5))

    -- | The type of placement policies
    data Placement = Smart (Rational, Rational)
                   | Fixed (Rational, Rational)
                   | UnderMouse (Rational, Rational)
                   | Bounds (Dimension, Dimension, Dimension, Dimension) Placement
                     deriving (Show, Read, Eq)

    -- | Try to place windows with as little overlap as possible
    smart :: (Rational, Rational) -- ^ Where the window should be placed inside
                                  -- the available area. See 'fixed'.
          -> Placement
    smart = Smart

    simpleSmart :: Placement
    simpleSmart = inBounds $ smart (0,0)

    -- | Place windows at a fixed position
    fixed :: (Rational, Rational) -- ^ Where windows should go.
                                  --
                                  --     * (0,0) -> top left of the screen
                                  --
                                  --     * (1,0) -> top right of the screen
                                  --
                                  --     * etc
          -> Placement
    fixed = Fixed

    -- | Place windows under the mouse
    underMouse :: (Rational, Rational) -- ^ Where the pointer should be relative to
                                       -- the window's frame; see 'fixed'.
               -> Placement
    underMouse = UnderMouse

    -- | Apply the given placement policy, constraining the
    -- placed windows inside the screen boundaries.
    inBounds :: Placement -> Placement
    inBounds = Bounds (0,0,0,0)

    -- | Same as 'inBounds', but allows specifying gaps along the screen's edges
    withGaps :: (Dimension, Dimension, Dimension, Dimension)
             -- ^ top, right, bottom and left gaps
             -> Placement -> Placement
    withGaps = Bounds

    {- Placement functions -}

    -- | Repositions the focused window according to a placement policy. Works for
    -- both \"real\" floating windows and windows in a 'WindowArranger'-based
    -- layout.
    placeFocused :: Placement -> X ()
    placeFocused p = withFocused $ \window -> do
                       info <- gets $ screenInfo . S.current . windowset
                       floats <- gets $ M.keys . S.floating . windowset

                       r'@(Rectangle x' y' _ _) <- placeWindow p window info floats

                         -- use X.A.FloatKeys if the window is floating, send
                         -- a WindowArranger message otherwise.
                       case elem window floats of
                         True -> keysMoveWindowTo (x', y') (0, 0) window
                         False -> sendMessage $ SetGeometry r'

    -- | Hook to automatically place windows when they are created.
    placeHook :: Placement -> ManageHook
    placeHook p = do window <- ask
                     r <- Query $ lift $ getWindowRectangle window
                     allRs <- Query $ lift $ getAllRectangles
                     pointer <- Query $ lift $ getPointer window

                     return $ Endo $ \theWS -> fromMaybe theWS $
                       do let currentRect = screenRect $ S.screenDetail $ S.current theWS
                              floats = M.keys $ S.floating theWS

                          guard(window `elem` floats )

                            -- Look for the workspace(s) on which the window is to be
                            -- spawned. Each of them also needs an associated screen
                            -- rectangle; for hidden workspaces, we use the current
                            -- workspace's screen.
                          let infos = filter ((window `elem`) . stackContents . S.stack . fst)
                                         $ [screenInfo $ S.current theWS]
                                            ++ (map screenInfo $ S.visible theWS)
                                            ++ zip (S.hidden theWS) (repeat currentRect)

                          guard(not $ null infos)

                          let (workspace, screen) = head infos
                              rs = catMaybes $ map (flip M.lookup allRs)
                                   $ organizeClients workspace window floats
                              r' = purePlaceWindow p screen rs pointer r
                              newRect = r2rr screen r'
                              newFloats = M.insert window newRect (S.floating theWS)

                          return $ theWS { S.floating = newFloats }

    placeWindow :: Placement -> Window
                -> (S.Workspace WorkspaceId (Layout Window) Window, Rectangle)
                     -- ^ The workspace with reference to which the window should be placed,
                     -- and the screen's geometry.
                -> [Window]
                     -- ^ The list of floating windows.
                -> X Rectangle
    placeWindow p window (ws, s) floats
      = do (r, rs, pointer) <- getNecessaryData window ws floats
           return $ purePlaceWindow p s rs pointer r

    -- | Compute the new position of a window according to a placement policy.
    purePlaceWindow :: Placement -- ^ The placement strategy
                    -> Rectangle -- ^ The screen
                    -> [Rectangle] -- ^ The other visible windows
                    -> (Position, Position) -- ^ The pointer's position.
                    -> Rectangle -- ^ The window to be placed
                    -> Rectangle
    purePlaceWindow (Bounds (t,r,b,l) p') (Rectangle sx sy sw sh) rs p w
      = let s' = (Rectangle (sx + fi l) (sy + fi t) (sw - l - r) (sh - t - b))
        in checkBounds s' $ purePlaceWindow p' s' rs p w

    purePlaceWindow (Fixed ratios) s _ _ w = placeRatio ratios s w

    purePlaceWindow (UnderMouse (rx, ry)) _ _ (px, py) (Rectangle _ _ w h)
      = Rectangle (px - truncate (rx * fi w)) (py - truncate (ry * fi h)) w h

    purePlaceWindow (Smart ratios) s rs _ w
      = placeSmart ratios s rs (rect_width w) (rect_height w)

    -- | Helper: Places a Rectangle at a fixed position indicated by two Rationals
    -- inside another,
    placeRatio :: (Rational, Rational) -> Rectangle -> Rectangle -> Rectangle
    placeRatio (rx, ry) (Rectangle x1 y1 w1 h1) (Rectangle _ _ w2 h2)
      = Rectangle (scale rx x1 (x1 + fi w1 - fi w2))
                  (scale ry y1 (y1 + fi h1 - fi h2))
                  w2 h2

    -- | Helper: Ensures its second parameter is contained inside the first
    -- by possibly moving it.
    checkBounds :: Rectangle -> Rectangle -> Rectangle
    checkBounds (Rectangle x1 y1 w1 h1) (Rectangle x2 y2 w2 h2)
      = Rectangle (max x1 (min (x1 + fi w1 - fi w2) x2))
                  (max y1 (min (y1 + fi h1 - fi h2) y2))
                  w2 h2

    {- Utilities -}

    scale :: (RealFrac a, Integral b) => a -> b -> b -> b
    scale r n1 n2 = truncate $ r * fi n2 + (1 - r) * fi n1

    fi :: (Integral a, Num b) => a -> b
    fi = fromIntegral

    r2rr :: Rectangle -> Rectangle -> S.RationalRect
    r2rr (Rectangle x0 y0 w0 h0) (Rectangle x y w h)
      = S.RationalRect ((fi x-fi x0) % fi w0)
                       ((fi y-fi y0) % fi h0)
                       (fi w % fi w0)
                       (fi h % fi h0)

    {- Querying stuff -}

    stackContents :: Maybe (S.Stack w) -> [w]
    stackContents = maybe [] S.integrate

    screenInfo :: S.Screen i l a sid ScreenDetail -> (S.Workspace i l a, Rectangle)
    screenInfo (S.Screen { S.workspace = ws, S.screenDetail = (SD s)}) = (ws, s)

    getWindowRectangle :: Window -> X Rectangle
    getWindowRectangle window
      = do d <- asks display
           (_, x, y, w, h, _, _) <- io $ getGeometry d window

             -- We can't use the border width returned by
             -- getGeometry because it will be 0 if the
             -- window isn't mapped yet.
           b <- asks $ borderWidth . config

           return $ Rectangle x y (w + 2*b) (h + 2*b)

    getAllRectangles :: X (M.Map Window Rectangle)
    getAllRectangles = do ws <- gets windowset
                          let allWindows = join $ map (stackContents . S.stack)
                                             $ (S.workspace . S.current) ws
                                             : (map S.workspace . S.visible) ws
                                             ++ S.hidden ws
                          allRects <- mapM getWindowRectangle allWindows

                          return $ M.fromList $ zip allWindows allRects

    organizeClients :: S.Workspace a b Window -> Window -> [Window] -> [Window]
    organizeClients ws w floats
      = let (floatCs, layoutCs) = partition (`elem` floats) $ filter (/= w)
                                  $ stackContents $ S.stack ws
        in reverse layoutCs ++ reverse floatCs
          -- About the ordering: the smart algorithm will overlap windows
          -- starting ith the head of the list. So:
          --  - we put the non-floating windows first since they'll
          --    probably be below the floating ones,
          --  - we reverse the lists, since the newer/more important
          --    windows are usually near the head.

    getPointer :: Window -> X (Position, Position)
    getPointer window = do d <- asks display
                           (_,_,_,x,y,_,_,_) <- io $ queryPointer d window
                           return (fi x,fi y)

    -- | Return values are, in order: window's rectangle,
    -- other windows' rectangles and pointer's coordinates.
    getNecessaryData :: Window
                     -> S.Workspace WorkspaceId (Layout Window) Window
                     -> [Window]
                     -> X (Rectangle, [Rectangle], (Position, Position))
    getNecessaryData window ws floats
      = do r <- getWindowRectangle window

           rs <- return (organizeClients ws window floats)
                 >>= mapM getWindowRectangle

           pointer <- getPointer window

           return (r, rs, pointer)

    {- Smart placement algorithm -}

    -- | Alternate representation for rectangles.
    data SmartRectangle a = SR
      { sr_x0, sr_y0 :: a -- ^ Top left coordinates, inclusive
      , sr_x1, sr_y1 :: a -- ^ Bottom right coorsinates, exclusive
      } deriving (Show, Eq)

    r2sr :: Rectangle -> SmartRectangle Position
    r2sr (Rectangle x y w h) = SR x y (x + fi w) (y + fi h)

    sr2r :: SmartRectangle Position -> Rectangle
    sr2r (SR x0 y0 x1 y1) = Rectangle x0 y0 (fi $ x1 - x0) (fi $ y1 - y0)

    width :: Num a => SmartRectangle a -> a
    width r = sr_x1 r - sr_x0 r

    height :: Num a => SmartRectangle a -> a
    height r = sr_y1 r - sr_y0 r

    isEmpty :: Real a => SmartRectangle a -> Bool
    isEmpty r = (width r <= 0) || (height r <= 0)

    contains :: Real a => SmartRectangle a -> SmartRectangle a -> Bool
    contains r1 r2 = sr_x0 r1 <= sr_x0 r2
                     && sr_y0 r1 <= sr_y0 r2
                     && sr_x1 r1 >= sr_x1 r2
                     && sr_y1 r1 >= sr_y1 r2

    -- | Main placement function
    placeSmart :: (Rational, Rational) -- ^ point of the screen where windows
                                       -- should be placed first, if possible.
               -> Rectangle -- ^ screen
               -> [Rectangle] -- ^ other clients
               -> Dimension -- ^ width
               -> Dimension -- ^ height
               -> Rectangle
    placeSmart (rx, ry) s@(Rectangle sx sy sw sh) rs w h
      = let free = map sr2r $ findSpace (r2sr s) (map r2sr rs) (fi w) (fi h)
        in position free (scale rx sx (sx + fi sw - fi w))
                         (scale ry sy (sy + fi sh - fi h))
                         w h

    -- | Second part of the algorithm:
    -- Chooses the best position in which to place a window,
    -- according to a list of free areas and an ideal position for
    -- the top-left corner.
    -- We can't use semi-open surfaces for this, so we go back to
    -- X11 Rectangles/Positions/etc instead.
    position :: [Rectangle] -- ^ Free areas
             -> Position -> Position -- ^ Ideal coordinates
             -> Dimension -> Dimension -- ^ Width and height of the window
             -> Rectangle
    position rs x y w h = minimumBy distanceOrder $ map closest rs
      where distanceOrder r1 r2
              = compare (distance (rect_x r1,rect_y r1) (x,y) :: Dimension)
                        (distance (rect_x r2,rect_y r2) (x,y) :: Dimension)
            distance (x1,y1) (x2,y2) = truncate $ (sqrt :: Double -> Double)
                                       $ fi $ (x1 - x2)^(2::Int)
                                            + (y1 - y2)^(2::Int)
            closest r = checkBounds r (Rectangle x y w h)

    -- | First part of the algorithm:
    -- Tries to find an area in which to place a new
    -- rectangle so that it overlaps as little as possible with
    -- other rectangles already present. The first rectangles in
    -- the list will be overlapped first.
    findSpace :: Real a =>
                 SmartRectangle a -- ^ The total available area
              -> [SmartRectangle a] -- ^ The parts already in use
              -> a -- ^ Width of the rectangle to place
              -> a -- ^ Height of the rectangle to place
              -> [SmartRectangle a]
    findSpace total [] _ _ = [total]
    findSpace total rs@(_:rs') w h
      = case filter largeEnough $ cleanup $ subtractRects total rs of
          [] -> findSpace total rs' w h
          as -> as
        where largeEnough r = width r >= w && height r >= h

    -- | Subtracts smaller rectangles from a total rectangle
    -- , returning a list of remaining rectangular areas.
    subtractRects :: Real a => SmartRectangle a
                   -> [SmartRectangle a] -> [SmartRectangle a]
    subtractRects total [] = [total]
    subtractRects total (r:rs)
      = do total' <- subtractRects total rs
           filter (not . isEmpty)
                    [ total' {sr_y1 = min (sr_y1 total') (sr_y0 r)} -- Above
                    , total' {sr_x0 = max (sr_x0 total') (sr_x1 r)} -- Right
                    , total' {sr_y0 = max (sr_y0 total') (sr_y1 r)} -- Below
                    , total' {sr_x1 = min (sr_x1 total') (sr_x0 r)} -- Left
                    ]

    -- | "Nubs" a list of rectangles, dropping all those that are
    -- already contained in another rectangle of the list.
    cleanup :: Real a => [SmartRectangle a] -> [SmartRectangle a]
    cleanup rs = foldr dropIfContained [] $ sortBy sizeOrder rs

    sizeOrder :: Real a => SmartRectangle a -> SmartRectangle a -> Ordering
    sizeOrder r1 r2 | w1 < w2 = LT
                    | w1 == w2 && h1 < h2 = LT
                    | w1 == w2 && h1 == h2 = EQ
                    | otherwise = GT
                    where w1 = width r1
                          w2 = width r2
                          h1 = height r1
                          h2 = height r2

    dropIfContained :: Real a => SmartRectangle a
                    -> [SmartRectangle a] -> [SmartRectangle a]
    dropIfContained r rs  = if any (`contains` r) rs
                            then rs
                            else r:rs