A ResizableTile-like layout that can be resized using the mouse.

Ignore-this: 8941ecfb0e5653663db29e9f195e23f2
All separations between windows can be dragged to modify the layout.
Keyboard commands can also be used to achieve the same effect.

darcs-hash:20090930121105-594c5-b950c74d30248aa223aeea25bb29b331c11fa594.gz

1 files changed, 279 insertions, 0 deletions

diff --git a/XMonad/Layout/MouseResizableTile.hs b/XMonad/Layout/MouseResizableTile.hs
new file mode 100644
index 0000000..20cd830
--- /dev/null
+++ b/XMonad/Layout/MouseResizableTile.hs
@@ -0,0 +1,279 @@
+{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable
+----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Layout.MouseResizableTile
+-- Copyright   :  (c) Jan Vornberger 2009
+-- License     :  BSD3-style (see LICENSE)
+--
+-- Maintainer  :  jan.vornberger@informatik.uni-oldenburg.de
+-- Stability   :  unstable
+-- Portability :  not portable
+--
+-- A layout in the spirit of XMonad.Layout.ResizableTile, but with the option
+-- to use the mouse to adjust the layout.
+--
+-----------------------------------------------------------------------------
+
+module XMonad.Layout.MouseResizableTile (
+                                    -- * Usage
+                                    -- $usage
+                                    mouseResizableTile,
+                                    mouseResizableTileMirrored,
+                                    MRTMessage (ShrinkSlave, ExpandSlave)
+                                   ) where
+
+import XMonad hiding (tile, splitVertically, splitHorizontallyBy)
+import qualified XMonad.StackSet as W
+import XMonad.Util.XUtils
+
+-- $usage
+-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
+--
+-- > import XMonad.Layout.MouseResizableTile
+--
+-- Then edit your @layoutHook@ by adding the MouseResizableTile layout.
+-- Either in its normal form or the mirrored version. (The mirror layout modifier
+-- will not work correctly here because of the use of the mouse.)
+--
+-- > myLayouts = mouseResizableTile ||| etc..
+-- > main = xmonad defaultConfig { layoutHook = myLayouts }
+-- or
+-- > myLayouts = mouseResizableTileMirrored ||| etc..
+-- > main = xmonad defaultConfig { layoutHook = myLayouts }
+--
+-- For more detailed instructions on editing the layoutHook see:
+--
+-- "XMonad.Doc.Extending#Editing_the_layout_hook"
+--
+-- You may also want to add the following key bindings:
+--
+-- > , ((modMask x,               xK_u), sendMessage ShrinkSlave) -- %! Shrink a slave area
+-- > , ((modMask x,               xK_i), sendMessage ExpandSlave) -- %! Expand a slave area
+--
+-- For detailed instruction on editing the key binding see:
+--
+-- "XMonad.Doc.Extending#Editing_key_bindings".
+
+data MRTMessage = SetMasterFraction Rational
+                    | SetLeftSlaveFraction Int Rational
+                    | SetRightSlaveFraction Int Rational
+                    | ShrinkSlave
+                    | ExpandSlave
+                    deriving Typeable
+instance Message MRTMessage
+
+data DraggerInfo = MasterDragger Position Rational
+                    | LeftSlaveDragger Position Rational Int
+                    | RightSlaveDragger Position Rational Int
+                    deriving (Show, Read)
+type DraggerWithRect = (Rectangle, Glyph, DraggerInfo)
+type DraggerWithWin = (Window, DraggerInfo)
+
+data MouseResizableTile a = MRT { nmaster :: Int,
+                                    masterFrac :: Rational,
+                                    leftFracs :: [Rational],
+                                    rightFracs :: [Rational],
+                                    draggers :: [DraggerWithWin],
+                                    focusPos :: Int,
+                                    numWindows :: Int,
+                                    isMirrored :: Bool
+                                } deriving (Show, Read)
+
+mrtFraction :: Rational
+mrtFraction = 0.5
+mrtDelta :: Rational
+mrtDelta = 0.03
+mrtDraggerOffset :: Position
+mrtDraggerOffset = 3
+mrtDraggerSize :: Dimension
+mrtDraggerSize = 6
+mrtHDoubleArrow :: Glyph
+mrtHDoubleArrow = 108
+mrtVDoubleArrow :: Glyph
+mrtVDoubleArrow = 116
+
+mouseResizableTile :: MouseResizableTile a
+mouseResizableTile = MRT 1 mrtFraction [] [] [] 0 0 False
+
+mouseResizableTileMirrored :: MouseResizableTile a
+mouseResizableTileMirrored= MRT 1 mrtFraction [] [] [] 0 0 True
+
+instance LayoutClass MouseResizableTile a where
+    doLayout state sr (W.Stack w l r) =
+        let wins = reverse l ++ w : r
+            num = length wins
+            sr' = mirrorAdjust sr (mirrorRect sr)
+            (rects, preparedDraggers) = tile (nmaster state) (masterFrac state)
+                                            ((leftFracs state) ++ repeat mrtFraction)
+                                            ((rightFracs state) ++ repeat mrtFraction) sr' num
+            rects' = map (mirrorAdjust id mirrorRect . sanitizeRectangle sr') rects
+        in do
+            mapM_ deleteDragger $ draggers state
+            newDraggers <- mapM (createDragger sr . adjustForMirror (isMirrored state)) preparedDraggers
+            return (zip wins rects', Just $ state { draggers = newDraggers,
+                                                    focusPos = length l,
+                                                    numWindows = length wins })
+        where
+            mirrorAdjust a b = if (isMirrored state)
+                                then b
+                                else a
+
+    handleMessage state m
+        | Just (IncMasterN d) <- fromMessage m =
+            return $ Just $ state { nmaster = max 0 (nmaster state + d) }
+        | Just (Shrink) <- fromMessage m =
+            return $ Just $ state { masterFrac = max 0 (masterFrac state - mrtDelta) }
+        | Just (Expand) <- fromMessage m =
+            return $ Just $ state { masterFrac = min 1 (masterFrac state + mrtDelta) }
+        | Just ShrinkSlave <- fromMessage m =
+            return $ Just $ modifySlave state (-mrtDelta)
+        | Just ExpandSlave <- fromMessage m =
+            return $ Just $ modifySlave state mrtDelta
+        | Just (SetMasterFraction f) <- fromMessage m =
+            return $ Just $ state { masterFrac = max 0 (min 1 f) }
+        | Just (SetLeftSlaveFraction pos f) <- fromMessage m =
+            return $ Just $ state { leftFracs = replaceAtPos (leftFracs state) pos (max 0 (min 1 f)) }
+        | Just (SetRightSlaveFraction pos f) <- fromMessage m =
+            return $ Just $ state { rightFracs = replaceAtPos (rightFracs state) pos (max 0 (min 1 f)) }
+
+        | Just e <- fromMessage m :: Maybe Event = handleResize (draggers state) (isMirrored state) e >> return Nothing
+        | Just Hide             <- fromMessage m = releaseResources >> return (Just $ state { draggers = [] })
+        | Just ReleaseResources <- fromMessage m = releaseResources >> return (Just $ state { draggers = [] })
+        where releaseResources = mapM_ deleteDragger $ draggers state
+    handleMessage _ _ = return Nothing
+
+    description _ = "MouseResizableTile"
+
+adjustForMirror :: Bool -> DraggerWithRect -> DraggerWithRect
+adjustForMirror False dragger = dragger
+adjustForMirror True (draggerRect, draggerCursor, draggerInfo) =
+        (mirrorRect draggerRect, draggerCursor', draggerInfo)
+    where
+        draggerCursor' = if (draggerCursor == mrtHDoubleArrow)
+                            then mrtVDoubleArrow
+                            else mrtHDoubleArrow
+
+modifySlave :: MouseResizableTile a -> Rational-> MouseResizableTile a
+modifySlave state delta =
+    let pos = focusPos state
+        num = numWindows state
+        nmaster' = nmaster state
+        leftFracs' = leftFracs state
+        rightFracs' = rightFracs state
+        draggersLeft = nmaster' - 1
+        draggersRight = (num - nmaster') - 1
+    in if pos < nmaster'
+        then if draggersLeft > 0
+                then let draggerPos = min (draggersLeft - 1) pos
+                         oldFraction = (leftFracs' ++ repeat mrtFraction) !! draggerPos
+                     in state { leftFracs = replaceAtPos leftFracs' draggerPos
+                                            (max 0 (min 1 (oldFraction + delta))) }
+                else state
+        else if draggersRight > 0
+                then let draggerPos = min (draggersRight - 1) (pos - nmaster')
+                         oldFraction = (rightFracs' ++ repeat mrtFraction) !! draggerPos
+                     in state { rightFracs = replaceAtPos rightFracs' draggerPos
+                                            (max 0 (min 1 (oldFraction + delta))) }
+                else state
+
+replaceAtPos :: (Num t) => [Rational] -> t -> Rational -> [Rational]
+replaceAtPos [] 0 x' = [x']
+replaceAtPos [] pos x' = mrtFraction : replaceAtPos [] (pos - 1) x'
+replaceAtPos (_:xs) 0 x' = x' : xs
+replaceAtPos (x:xs) pos x' = x : replaceAtPos xs (pos -1 ) x'
+
+sanitizeRectangle :: Rectangle -> Rectangle -> Rectangle
+sanitizeRectangle (Rectangle sx sy swh sht) (Rectangle x y wh ht) =
+    (Rectangle (within 0 (sx + fromIntegral swh) x) (within 0 (sy + fromIntegral sht) y)
+                (within 1 swh wh) (within 1 sht ht))
+
+within :: (Ord a) => a -> a -> a -> a
+within low high a = max low $ min high a
+
+tile :: Int -> Rational -> [Rational] -> [Rational] -> Rectangle -> Int -> ([Rectangle], [DraggerWithRect])
+tile nmaster' masterFrac' leftFracs' rightFracs' sr num
+    | num <= nmaster'       = splitVertically (take (num - 1) leftFracs') sr True 0
+    | nmaster' == 0         = splitVertically (take (num - 1) rightFracs') sr False 0
+    | otherwise             = (leftRects ++ rightRects, [masterDragger] ++ leftDraggers ++ rightDraggers)
+    where ((sr1, sr2), masterDragger) = splitHorizontallyBy masterFrac' sr
+          (leftRects, leftDraggers) = splitVertically (take (nmaster' - 1) leftFracs') sr1 True 0
+          (rightRects, rightDraggers) = splitVertically (take (num - nmaster' - 1) rightFracs') sr2 False 0
+
+splitVertically :: RealFrac r => [r] -> Rectangle -> Bool -> Int -> ([Rectangle], [DraggerWithRect])
+splitVertically [] r _ _ = ([r], [])
+splitVertically (f:fx) (Rectangle sx sy sw sh) isLeft num =
+    let nextRect = Rectangle sx sy sw (smallh - (div mrtDraggerSize 2))
+        (otherRects, otherDragger) = splitVertically fx
+                                        (Rectangle sx (sy + fromIntegral smallh + mrtDraggerOffset)
+                                                    sw (sh - smallh - (div mrtDraggerSize 2)))
+                                        isLeft (num + 1)
+        draggerRect = Rectangle sx (sy + fromIntegral smallh - mrtDraggerOffset) sw mrtDraggerSize
+        draggerInfo = if isLeft
+                        then LeftSlaveDragger sy (fromIntegral sh) num
+                        else RightSlaveDragger sy (fromIntegral sh) num
+        nextDragger = (draggerRect, mrtVDoubleArrow, draggerInfo)
+    in (nextRect : otherRects, nextDragger : otherDragger)
+  where smallh = floor $ fromIntegral sh * f
+
+splitHorizontallyBy :: RealFrac r => r -> Rectangle -> ((Rectangle, Rectangle), DraggerWithRect)
+splitHorizontallyBy f (Rectangle sx sy sw sh) = ((leftHalf, rightHalf), (draggerRect, mrtHDoubleArrow, draggerInfo))
+  where leftw = floor $ fromIntegral sw * f
+        leftHalf = Rectangle sx sy (leftw - (div mrtDraggerSize 2)) sh
+        rightHalf = Rectangle (sx + fromIntegral leftw + mrtDraggerOffset) sy
+                                (sw - fromIntegral leftw - (div mrtDraggerSize 2)) sh
+        draggerRect = Rectangle (sx + fromIntegral leftw - mrtDraggerOffset) sy mrtDraggerSize sh
+        draggerInfo = MasterDragger sx (fromIntegral sw)
+
+createDragger :: Rectangle -> DraggerWithRect -> X DraggerWithWin
+createDragger sr (draggerRect, draggerCursor, draggerInfo) = do
+        draggerWin <- createInputWindow draggerCursor $ sanitizeRectangle sr draggerRect
+        return (draggerWin, draggerInfo)
+
+deleteDragger :: DraggerWithWin -> X ()
+deleteDragger (draggerWin, _) = deleteWindow draggerWin
+
+
+handleResize :: [DraggerWithWin] -> Bool -> Event -> X ()
+handleResize draggers' isM ButtonEvent { ev_window = ew, ev_event_type = et }
+    | et == buttonPress = do
+        case (lookup ew draggers') of
+            Just (MasterDragger lowerBound range) -> do
+                mouseDrag (\x y -> do
+                             let axis = chooseAxis isM x y
+                                 fraction = fromIntegral (axis - lowerBound) / range
+                             sendMessage (SetMasterFraction fraction)) (return ())
+            Just (LeftSlaveDragger lowerBound range num) -> do
+                mouseDrag (\x y -> do
+                             let axis = chooseAxis isM y x
+                                 fraction = fromIntegral (axis - lowerBound) / range
+                             sendMessage (SetLeftSlaveFraction num fraction)) (return ())
+            Just (RightSlaveDragger lowerBound range num) -> do
+                mouseDrag (\x y -> do
+                             let axis = chooseAxis isM y x
+                                 fraction = fromIntegral (axis - lowerBound) / range
+                             sendMessage (SetRightSlaveFraction num fraction)) (return ())
+            Nothing -> return ()
+    where
+        chooseAxis isM' axis1 axis2 = if isM' then axis2 else axis1
+handleResize _ _ _ = return ()
+
+createInputWindow :: Glyph -> Rectangle -> X Window
+createInputWindow cursorGlyph r = withDisplay $ \d -> do
+    win <- mkInputWindow d r
+    io $ selectInput d win (exposureMask .|. buttonPressMask)
+    cursor <- io $ createFontCursor d cursorGlyph
+    io $ defineCursor d win cursor
+    io $ freeCursor d cursor
+    showWindow win
+    return win
+
+mkInputWindow :: Display -> Rectangle -> X Window
+mkInputWindow d (Rectangle x y w h) = do
+  rw <- asks theRoot
+  let screen   = defaultScreenOfDisplay d
+      visual   = defaultVisualOfScreen screen
+      attrmask = cWOverrideRedirect
+  io $ allocaSetWindowAttributes $
+         \attributes -> do
+           set_override_redirect attributes True
+           createWindow d rw x y w h 0 0 inputOnly visual attrmask attributes