path: root/XMonad/Hooks/Place.hs

-----------------------------------------------------------------------------
-- |
-- 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 and "WindowArranger" 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.List (sortBy, maximumBy)
import Data.Maybe (maybe)
import Data.Monoid (Endo(..))
import Control.Monad.Trans (lift, liftIO)

-- $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 }
--
-- You can also define a key to manually trigger repositioning with 'placeFocused' by
-- adding the following to your keys definition:
--
-- > , ((modMask, 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#
--
-- 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.
placeFocused :: Placement -> X ()
placeFocused p = withFocused $ \window -> do
                   (s,r,rs,pointer) <- getNecessaryData window

                   let r'@(Rectangle x' y' _ _) = purePlaceWindow p s rs pointer r

                   fs <- getFloats
                   case elem window fs 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
                 (s,r,rs,pointer) <- Query $ lift (getNecessaryData window)

                 let (Rectangle x' y' _ _) = purePlaceWindow p s rs pointer r

                 d <- Query $ lift $ asks display
                 liftIO $ moveWindow d window x' y' 
                     -- Move window at the X level, and
                     -- hope both the standard floating
                     -- system and WindowArranger layouts
                     -- will pick it up correctly.
                     -- I'm not really satisfied with this though.

                 return $ Endo id


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





{- Querying stuff -}

getScreenRect :: X Rectangle
getScreenRect = gets $ screenRect . S.screenDetail
                     . S.current . windowset

getLayoutWindows :: X [Window]
getLayoutWindows = gets $ maybe [] S.integrate . S.stack 
                        . S.workspace . S.current . windowset

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)

getFloats :: X [Window]
getFloats = gets $ M.keys . S.floating . windowset

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: screen's rectangle, window's rectangle,
-- other windows' rectangles and pointer's coordinates.
getNecessaryData :: Window -> X (Rectangle, Rectangle, [Rectangle], (Position, Position))
getNecessaryData window
  = do s <- getScreenRect
       r <- getWindowRectangle window
                             -- The window to be place may or may not
                             -- have a border depending on whether it
                             -- is already mapped.
       
       layoutRects <- fmap (filter (/= window)) getLayoutWindows 
                      >>= mapM getWindowRectangle
       floatRects <- fmap (filter (/= window)) getFloats
                     >>= mapM getWindowRectangle
       let rs = reverse $ floatRects ++ layoutRects 
                             -- Clients inside of the layout
                             -- will be ignored first when
                             -- using smart placement.
                             -- We also reverse the list because it seems
                             -- the clients most recently added are at the front.
       pointer <- getPointer window
                        
       return (s, 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 = maximumBy 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 aready present. The first rectangles in
-- the list will be overlapped first.
findSpace :: Real a =>
             SmartRectangle a -- ^ The total available area
          -> [SmartRectangle a] -- ^ The parts aready 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 $ substractRects total rs of
      [] -> findSpace total rs' w h
      as -> as
    where largeEnough r = width r >= w && height r >= h


-- | Substracts smaller rectangles from a total rectangle
-- , returning a list of remaining rectangular areas.
substractRects :: Real a => SmartRectangle a 
               -> [SmartRectangle a] -> [SmartRectangle a]
substractRects total [] = [total]
substractRects total (r:rs) 
  = do total' <- substractRects 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