From 5289cd22b024060faf3f7e150fb4ca7300344d71 Mon Sep 17 00:00:00 2001 From: "anton.pirogov" Date: Thu, 12 Mar 2015 15:52:20 +0100 Subject: Improved BinarySpacePartition, added Equalize,Balance and FocusParent and mouse resize support Ignore-this: 31b5d7bf38e5b391df266906deb5e382 darcs-hash:20150312145220-8e960-c72823501fda2fa7a60ec99e5eecb01c5e2f200c.gz --- XMonad/Layout/BinarySpacePartition.hs | 543 ++++++++++++++++++++++++++-------- 1 file changed, 425 insertions(+), 118 deletions(-) diff --git a/XMonad/Layout/BinarySpacePartition.hs b/XMonad/Layout/BinarySpacePartition.hs index 2fbf13d..e5e7dbb 100644 --- a/XMonad/Layout/BinarySpacePartition.hs +++ b/XMonad/Layout/BinarySpacePartition.hs @@ -2,7 +2,8 @@ ----------------------------------------------------------------------------- -- | -- Module : XMonad.Layout.BinarySpacePartition --- Copyright : (c) 2013 Ben Weitzman +-- Copyright : (c) 2013 Ben Weitzman +-- 2015 Anton Pirogov -- License : BSD3-style (see LICENSE) -- -- Maintainer : Ben Weitzman @@ -14,22 +15,35 @@ ----------------------------------------------------------------------------- module XMonad.Layout.BinarySpacePartition ( - -- * Usage - -- $usage - emptyBSP - , Rotate(..) - , Swap(..) - , ResizeDirectional(..) - , Direction2D(..) - ) where + -- * Usage + -- $usage + emptyBSP + , Rotate(..) + , Swap(..) + , ResizeDirectional(..) + , TreeRotate(..) + , TreeBalance(..) + , FocusParent(..) + , Direction2D(..) + ) where import XMonad import qualified XMonad.StackSet as W import XMonad.Util.Stack hiding (Zipper) import XMonad.Util.Types + +-- for mouse resizing +import XMonad.Layout.WindowArranger (WindowArrangerMsg(SetGeometry)) +-- for "focus parent" node border +import XMonad.Util.XUtils + import qualified Data.Map as M -import Data.List ((\\)) +import qualified Data.Set as S +import Data.List ((\\), elemIndex, foldl') +import Data.Maybe (fromMaybe, isNothing, isJust, mapMaybe, catMaybes) +import Control.Applicative import Control.Monad +import Data.Ratio ((%)) -- $usage -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: @@ -40,7 +54,13 @@ import Control.Monad -- -- > myLayout = emptyBSP ||| etc .. -- --- It will be helpful to add the following key bindings +-- It may be a good idea to use "XMonad.Actions.Navigation2D" to move between the windows. +-- +-- This layout responds to SetGeometry and is compatible with e.g. "XMonad.Actions.MouseResize" +-- or "XMonad.Layout.BorderResize". You should probably try both to decide which is better for you, +-- if you want to be able to resize the splits with the mouse. +-- +-- If you don't want to use the mouse, add the following key bindings to resize the splits with the keyboard: -- -- > , ((modm .|. altMask, xK_l ), sendMessage $ ExpandTowards R) -- > , ((modm .|. altMask, xK_h ), sendMessage $ ExpandTowards L) @@ -52,6 +72,7 @@ import Control.Monad -- > , ((modm .|. altMask .|. ctrlMask , xK_k ), sendMessage $ ShrinkFrom U) -- > , ((modm, xK_r ), sendMessage Rotate) -- > , ((modm, xK_s ), sendMessage Swap) +-- > , ((modm, xK_n ), sendMessage FocusParent) -- -- Here's an alternative key mapping, this time using additionalKeysP, -- arrow keys, and slightly different behavior when resizing windows @@ -67,22 +88,39 @@ import Control.Monad -- > , ("M-s", sendMessage $ BSP.Swap) -- > , ("M-M1-s", sendMessage $ Rotate) ] -- +-- If you have many windows open and the layout begins to look too hard to manage, you can 'Balance' +-- the layout, so that the current splittings are discarded and windows are tiled freshly in a way that +-- the split depth is minimized. You can combine this with 'Equalize', which does not change your tree, +-- but tunes the split ratios in a way that each window gets the same amount of space: +-- +-- > , ((myModMask, xK_a), sendMessage Balance) +-- > , ((myModMask .|. shiftMask, xK_a), sendMessage Equalize) +-- --- |Message for rotating a split in the BSP. Keep in mind that this does not change the order --- of the windows, it will just turn a horizontal split into a verticial one and vice versa -data Rotate = Rotate deriving Typeable -instance Message Rotate +-- |Message for rotating the binary tree around the parent node of the window to the left or right +data TreeRotate = RotateL | RotateR deriving Typeable +instance Message TreeRotate + +-- |Message to balance the tree in some way (Balance retiles the windows, Equalize changes ratios) +data TreeBalance = Balance | Equalize deriving Typeable +instance Message TreeBalance -- |Message for resizing one of the cells in the BSP data ResizeDirectional = ExpandTowards Direction2D | ShrinkFrom Direction2D | MoveSplit Direction2D deriving Typeable instance Message ResizeDirectional --- |Message for swapping the left child of a split with the right child of split. --- Keep in mind that it does not change the order of windows and will seem to have bizarre effects --- if you are not expecting them. +-- |Message for rotating a split (horizontal/vertical) in the BSP +data Rotate = Rotate deriving Typeable +instance Message Rotate + +-- |Message for swapping the left child of a split with the right child of split data Swap = Swap deriving Typeable instance Message Swap +-- |Message to select the parent node instead of the leaf +data FocusParent = FocusParent deriving Typeable +instance Message FocusParent + data Axis = Horizontal | Vertical deriving (Show, Read, Eq) oppositeDirection :: Direction2D -> Direction2D @@ -124,15 +162,24 @@ increaseRatio (Split d r) delta = Split d (min 0.9 (max 0.1 (r + delta))) resizeDiff :: Rational resizeDiff = 0.05 -data Tree a = Leaf | Node { value :: a + +data Tree a = Leaf Int | Node { value :: a , left :: Tree a , right :: Tree a } deriving (Show, Read, Eq) numLeaves :: Tree a -> Int -numLeaves Leaf = 1 +numLeaves (Leaf _) = 1 numLeaves (Node _ l r) = numLeaves l + numLeaves r +-- right or left rotation of a (sub)tree, no effect if rotation not possible +rotTree dir (Leaf n) = (Leaf n) +rotTree R n@(Node _ (Leaf _) _) = n +rotTree L n@(Node _ _ (Leaf _)) = n +rotTree R (Node sp (Node sp2 l2 r2) r) = Node sp2 l2 (Node sp r2 r) +rotTree L (Node sp l (Node sp2 l2 r2)) = Node sp2 (Node sp l l2) r2 + + data Crumb a = LeftCrumb a (Tree a) | RightCrumb a (Tree a) deriving (Show, Read, Eq) swapCrumb :: Crumb a -> Crumb a @@ -153,11 +200,11 @@ toZipper :: Tree a -> Zipper a toZipper t = (t, []) goLeft :: Zipper a -> Maybe (Zipper a) -goLeft (Leaf, _) = Nothing +goLeft (Leaf _, _) = Nothing goLeft (Node x l r, bs) = Just (l, LeftCrumb x r:bs) goRight :: Zipper a -> Maybe (Zipper a) -goRight (Leaf, _) = Nothing +goRight (Leaf _, _) = Nothing goRight (Node x l r, bs) = Just (r, RightCrumb x l:bs) goUp :: Zipper a -> Maybe (Zipper a) @@ -170,8 +217,16 @@ goSibling (_, []) = Nothing goSibling z@(_, LeftCrumb _ _:_) = Just z >>= goUp >>= goRight goSibling z@(_, RightCrumb _ _:_) = Just z >>= goUp >>= goLeft +top :: Zipper a -> Zipper a +top z = case goUp z of + Nothing -> z + Just z' -> top z' + +toTree :: Zipper a -> Tree a +toTree = fst . top + goToNthLeaf :: Int -> Zipper a -> Maybe (Zipper a) -goToNthLeaf _ z@(Leaf, _) = Just z +goToNthLeaf _ z@(Leaf _, _) = Just z goToNthLeaf n z@(t, _) = if numLeaves (left t) > n then do z' <- goLeft z @@ -179,26 +234,31 @@ goToNthLeaf n z@(t, _) = else do z' <- goRight z goToNthLeaf (n - (numLeaves . left $ t)) z' +goToFocusedLocation :: (Int,Int,[Window]) -> Zipper a -> Maybe (Zipper a) +goToFocusedLocation (l,n,_) z = goToNthLeaf l z >>= goUpN n + where goUpN 0 b = return b + goUpN n b = goUp b >>= goUpN (n-1) + splitCurrentLeaf :: Zipper Split -> Maybe (Zipper Split) -splitCurrentLeaf (Leaf, []) = Just (Node (Split Vertical 0.5) Leaf Leaf, []) -splitCurrentLeaf (Leaf, crumb:cs) = Just (Node (Split (oppositeAxis . axis . parentVal $ crumb) 0.5) Leaf Leaf, crumb:cs) +splitCurrentLeaf (Leaf _, []) = Just (Node (Split Vertical 0.5) (Leaf 0) (Leaf 0), []) +splitCurrentLeaf (Leaf _, crumb:cs) = Just (Node (Split (oppositeAxis . axis . parentVal $ crumb) 0.5) (Leaf 0) (Leaf 0), crumb:cs) splitCurrentLeaf _ = Nothing removeCurrentLeaf :: Zipper a -> Maybe (Zipper a) -removeCurrentLeaf (Leaf, []) = Nothing -removeCurrentLeaf (Leaf, LeftCrumb _ r:cs) = Just (r, cs) -removeCurrentLeaf (Leaf, RightCrumb _ l:cs) = Just (l, cs) +removeCurrentLeaf (Leaf _, []) = Nothing +removeCurrentLeaf (Leaf _, LeftCrumb _ r:cs) = Just (r, cs) +removeCurrentLeaf (Leaf _, RightCrumb _ l:cs) = Just (l, cs) removeCurrentLeaf _ = Nothing -rotateCurrentLeaf :: Zipper Split -> Maybe (Zipper Split) -rotateCurrentLeaf (Leaf, []) = Just (Leaf, []) -rotateCurrentLeaf (Leaf, c:cs) = Just (Leaf, modifyParentVal oppositeSplit c:cs) -rotateCurrentLeaf _ = Nothing +rotateCurrent :: Zipper Split -> Maybe (Zipper Split) +rotateCurrent l@(Leaf _, []) = Just l +rotateCurrent (n, c:cs) = Just (n, modifyParentVal oppositeSplit c:cs) +rotateCurrent _ = Nothing -swapCurrentLeaf :: Zipper a -> Maybe (Zipper a) -swapCurrentLeaf (Leaf, []) = Just (Leaf, []) -swapCurrentLeaf (Leaf, c:cs) = Just (Leaf, swapCrumb c:cs) -swapCurrentLeaf _ = Nothing +swapCurrent :: Zipper a -> Maybe (Zipper a) +swapCurrent l@(Leaf _, []) = Just l +swapCurrent (n, c:cs) = Just (n, swapCrumb c:cs) +swapCurrent _ = Nothing isAllTheWay :: Direction2D -> Zipper Split -> Bool isAllTheWay _ (_, []) = True @@ -210,11 +270,11 @@ isAllTheWay D (_, LeftCrumb s _:_) | axis s == Horizontal = False isAllTheWay U (_, RightCrumb s _:_) | axis s == Horizontal = False -isAllTheWay dir z = maybe False id $ goUp z >>= Just . isAllTheWay dir +isAllTheWay dir z = fromMaybe False $ goUp z >>= Just . isAllTheWay dir expandTreeTowards :: Direction2D -> Zipper Split -> Maybe (Zipper Split) expandTreeTowards _ z@(_, []) = Just z -expandTreeTowards dir z +expandTreeTowards dir z | isAllTheWay dir z = shrinkTreeFrom (oppositeDirection dir) z expandTreeTowards R (t, LeftCrumb s r:cs) | axis s == Vertical = Just (t, LeftCrumb (increaseRatio s resizeDiff) r:cs) @@ -239,7 +299,7 @@ shrinkTreeFrom U z@(_, RightCrumb s _:_) shrinkTreeFrom dir z = goUp z >>= shrinkTreeFrom dir -- Direction2D refers to which direction the divider should move. -autoSizeTree :: Direction2D -> Zipper Split -> Maybe (Zipper Split) +autoSizeTree :: Direction2D -> Zipper Split -> Maybe (Zipper Split) autoSizeTree _ z@(_, []) = Just z autoSizeTree d z = Just z >>= getSplit (toAxis d) >>= resizeTree d @@ -247,28 +307,28 @@ autoSizeTree d z = -- resizing once found the correct split. YOU MUST FIND THE RIGHT SPLIT FIRST. resizeTree :: Direction2D -> Zipper Split -> Maybe (Zipper Split) resizeTree _ z@(_, []) = Just z -resizeTree R z@(_, LeftCrumb _ _:_) = +resizeTree R z@(_, LeftCrumb _ _:_) = Just z >>= expandTreeTowards R -resizeTree L z@(_, LeftCrumb _ _:_) = +resizeTree L z@(_, LeftCrumb _ _:_) = Just z >>= shrinkTreeFrom R -resizeTree U z@(_, LeftCrumb _ _:_) = +resizeTree U z@(_, LeftCrumb _ _:_) = Just z >>= shrinkTreeFrom D -resizeTree D z@(_, LeftCrumb _ _:_) = +resizeTree D z@(_, LeftCrumb _ _:_) = Just z >>= expandTreeTowards D -resizeTree R z@(_, RightCrumb _ _:_) = +resizeTree R z@(_, RightCrumb _ _:_) = Just z >>= shrinkTreeFrom L -resizeTree L z@(_, RightCrumb _ _:_) = +resizeTree L z@(_, RightCrumb _ _:_) = Just z >>= expandTreeTowards L -resizeTree U z@(_, RightCrumb _ _:_) = +resizeTree U z@(_, RightCrumb _ _:_) = Just z >>= expandTreeTowards U -resizeTree D z@(_, RightCrumb _ _:_) = +resizeTree D z@(_, RightCrumb _ _:_) = Just z >>= shrinkTreeFrom U getSplit :: Axis -> Zipper Split -> Maybe (Zipper Split) getSplit _ (_, []) = Nothing getSplit d z = do let fs = findSplit d z - if fs == Nothing + if isNothing fs then findClosest d z else fs @@ -278,124 +338,371 @@ findClosest d z@(_, LeftCrumb s _:_) | axis s == d = Just z findClosest d z@(_, RightCrumb s _:_) | axis s == d = Just z -findClosest d z = goUp z >>= findClosest d +findClosest d z = goUp z >>= findClosest d findSplit :: Axis -> Zipper Split -> Maybe (Zipper Split) findSplit _ (_, []) = Nothing findSplit d z@(_, LeftCrumb s _:_) | axis s == d = Just z -findSplit d z = goUp z >>= findSplit d - -top :: Zipper a -> Zipper a -top z = case goUp z of - Nothing -> z - Just z' -> top z' - -toTree :: Zipper a -> Tree a -toTree = fst . top - -index :: W.Stack a -> Int -index s = case toIndex (Just s) of - (_, Nothing) -> 0 - (_, Just int) -> int - -data BinarySpacePartition a = BinarySpacePartition { getTree :: Maybe (Tree Split) } deriving (Show, Read) +findSplit d z = goUp z >>= findSplit d + +resizeSplit :: Direction2D -> (Rational,Rational) -> Zipper Split -> Maybe (Zipper Split) +resizeSplit _ _ z@(_, []) = Just z +resizeSplit dir (xsc,ysc) z = case goToBorder dir z of + Nothing -> Just z + Just (t, crumb) -> Just $ case dir of + R -> (t{value=sp{ratio=scaleRatio (ratio sp) xsc}}, crumb) + D -> (t{value=sp{ratio=scaleRatio (ratio sp) ysc}}, crumb) + L -> (t{value=sp{ratio=1-scaleRatio (1-ratio sp) xsc}}, crumb) + U -> (t{value=sp{ratio=1-scaleRatio (1-ratio sp) ysc}}, crumb) + where sp = value t + scaleRatio r fac = min 0.9 $ max 0.1 $ r*fac + +-- starting from a leaf, go to node representing a border of the according window +goToBorder :: Direction2D -> Zipper Split -> Maybe (Zipper Split) +goToBorder L z@(_, RightCrumb (Split Vertical _) l:cs) = goUp z +goToBorder L z = goUp z >>= goToBorder L +goToBorder R z@(_, LeftCrumb (Split Vertical _) r:cs) = goUp z +goToBorder R z = goUp z >>= goToBorder R +goToBorder U z@(_, RightCrumb (Split Horizontal _) l:cs) = goUp z +goToBorder U z = goUp z >>= goToBorder U +goToBorder D z@(_, LeftCrumb (Split Horizontal _) r:cs) = goUp z +goToBorder D z = goUp z >>= goToBorder D + + +data BinarySpacePartition a = BinarySpacePartition { getOldRects :: [(Window,Rectangle)] + , getFocusedNode :: (Int,Int,[Window]) -- leaf, steps up,deco + , getTree :: Maybe (Tree Split) } deriving (Show, Read) -- | an empty BinarySpacePartition to use as a default for adding windows to. emptyBSP :: BinarySpacePartition a -emptyBSP = BinarySpacePartition Nothing +emptyBSP = BinarySpacePartition [] ((-1),0,[]) Nothing makeBSP :: Tree Split -> BinarySpacePartition a -makeBSP = BinarySpacePartition . Just +makeBSP = BinarySpacePartition [] ((-1),0,[]) . Just makeZipper :: BinarySpacePartition a -> Maybe (Zipper Split) -makeZipper (BinarySpacePartition Nothing) = Nothing -makeZipper (BinarySpacePartition (Just t)) = Just . toZipper $ t +makeZipper (BinarySpacePartition _ _ Nothing) = Nothing +makeZipper (BinarySpacePartition _ _ (Just t)) = Just . toZipper $ t size :: BinarySpacePartition a -> Int size = maybe 0 numLeaves . getTree zipperToBinarySpacePartition :: Maybe (Zipper Split) -> BinarySpacePartition b -zipperToBinarySpacePartition Nothing = BinarySpacePartition Nothing -zipperToBinarySpacePartition (Just z) = BinarySpacePartition . Just . toTree . top $ z +zipperToBinarySpacePartition Nothing = emptyBSP +zipperToBinarySpacePartition (Just z) = BinarySpacePartition [] ((-1),0,[]) . Just . toTree . top $ z rectangles :: BinarySpacePartition a -> Rectangle -> [Rectangle] -rectangles (BinarySpacePartition Nothing) _ = [] -rectangles (BinarySpacePartition (Just Leaf)) rootRect = [rootRect] -rectangles (BinarySpacePartition (Just node)) rootRect = +rectangles (BinarySpacePartition _ _ Nothing) _ = [] +rectangles (BinarySpacePartition _ _ (Just (Leaf _))) rootRect = [rootRect] +rectangles (BinarySpacePartition _ _ (Just node)) rootRect = rectangles (makeBSP . left $ node) leftBox ++ rectangles (makeBSP . right $ node) rightBox where (leftBox, rightBox) = split (axis info) (ratio info) rootRect info = value node +getNodeRect :: BinarySpacePartition a -> Rectangle -> (Int,Int) -> Rectangle +getNodeRect b r (l,n) = fromMaybe (Rectangle 0 0 1 1) + $ (makeZipper b >>= goToFocusedLocation (l,n,[]) >>= getRect []) + where getRect ls z@(n, []) = Just $ foldl (\r' (s,f) -> f $ split' s r') r ls + getRect ls z@(n, LeftCrumb s t:cs) = goUp z >>= getRect ((s,fst):ls) + getRect ls z@(n, RightCrumb s t:cs) = goUp z >>= getRect ((s,snd):ls) + split' s = split (axis s) (ratio s) + doToNth :: (Zipper Split -> Maybe (Zipper Split)) -> BinarySpacePartition a -> Int -> BinarySpacePartition a -doToNth f b n = zipperToBinarySpacePartition $ makeZipper b >>= goToNthLeaf n >>= f +doToNth f b n = zipperToBinarySpacePartition $ makeZipper b >>= goToFocusedLocation (getFocusedNode b) >>= f splitNth :: BinarySpacePartition a -> Int -> BinarySpacePartition a -splitNth (BinarySpacePartition Nothing) _ = makeBSP Leaf +splitNth (BinarySpacePartition _ _ Nothing) _ = makeBSP (Leaf 0) splitNth b n = doToNth splitCurrentLeaf b n removeNth :: BinarySpacePartition a -> Int -> BinarySpacePartition a -removeNth (BinarySpacePartition Nothing) _ = emptyBSP -removeNth (BinarySpacePartition (Just Leaf)) _ = emptyBSP +removeNth (BinarySpacePartition _ _ Nothing) _ = emptyBSP +removeNth (BinarySpacePartition _ _ (Just (Leaf _))) _ = emptyBSP removeNth b n = doToNth removeCurrentLeaf b n rotateNth :: BinarySpacePartition a -> Int -> BinarySpacePartition a -rotateNth (BinarySpacePartition Nothing) _ = emptyBSP -rotateNth b@(BinarySpacePartition (Just Leaf)) _ = b -rotateNth b n = doToNth rotateCurrentLeaf b n +rotateNth (BinarySpacePartition _ _ Nothing) _ = emptyBSP +rotateNth b@(BinarySpacePartition _ _ (Just (Leaf _))) _ = b +rotateNth b n = doToNth rotateCurrent b n swapNth :: BinarySpacePartition a -> Int -> BinarySpacePartition a -swapNth (BinarySpacePartition Nothing) _ = emptyBSP -swapNth b@(BinarySpacePartition (Just Leaf)) _ = b -swapNth b n = doToNth swapCurrentLeaf b n +swapNth (BinarySpacePartition _ _ Nothing) _ = emptyBSP +swapNth b@(BinarySpacePartition _ _ (Just (Leaf _))) _ = b +swapNth b n = doToNth swapCurrent b n growNthTowards :: Direction2D -> BinarySpacePartition a -> Int -> BinarySpacePartition a -growNthTowards _ (BinarySpacePartition Nothing) _ = emptyBSP -growNthTowards _ b@(BinarySpacePartition (Just Leaf)) _ = b +growNthTowards _ (BinarySpacePartition _ _ Nothing) _ = emptyBSP +growNthTowards _ b@(BinarySpacePartition _ _ (Just (Leaf _))) _ = b growNthTowards dir b n = doToNth (expandTreeTowards dir) b n shrinkNthFrom :: Direction2D -> BinarySpacePartition a -> Int -> BinarySpacePartition a -shrinkNthFrom _ (BinarySpacePartition Nothing) _ = emptyBSP -shrinkNthFrom _ b@(BinarySpacePartition (Just Leaf)) _ = b +shrinkNthFrom _ (BinarySpacePartition _ _ Nothing) _ = emptyBSP +shrinkNthFrom _ b@(BinarySpacePartition _ _ (Just (Leaf _))) _ = b shrinkNthFrom dir b n = doToNth (shrinkTreeFrom dir) b n -autoSizeNth :: Direction2D -> BinarySpacePartition a -> Int -> BinarySpacePartition a -autoSizeNth _ (BinarySpacePartition Nothing) _ = emptyBSP -autoSizeNth _ b@(BinarySpacePartition (Just Leaf)) _ = b -autoSizeNth dir b n = doToNth (autoSizeTree dir) b n - -instance LayoutClass BinarySpacePartition a where - doLayout b r s = return (zip ws rs, layout b) where - ws = W.integrate s - layout bsp - | l == count = Just bsp - | l > count = layout $ splitNth bsp n - | otherwise = layout $ removeNth bsp n - where count = size bsp - - l = length ws - n = index s - rs = case layout b of - Nothing -> rectangles b r - Just bsp' -> rectangles bsp' r - handleMessage b m = - do ms <- (W.stack . W.workspace . W.current) `fmap` gets windowset - fs <- (M.keys . W.floating) `fmap` gets windowset - return $ ms >>= unfloat fs >>= handleMesg - where handleMesg s = msum [fmap (`rotate` s) (fromMessage m) - ,fmap (`resize` s) (fromMessage m) - ,fmap (`swap` s) (fromMessage m) +autoSizeNth :: Direction2D -> BinarySpacePartition a -> Int -> BinarySpacePartition a +autoSizeNth _ (BinarySpacePartition _ _ Nothing) _ = emptyBSP +autoSizeNth _ b@(BinarySpacePartition _ _ (Just (Leaf _))) _ = b +autoSizeNth dir b n = doToNth (autoSizeTree dir) b n + +resizeSplitNth :: Direction2D -> (Rational,Rational) -> BinarySpacePartition a -> Int -> BinarySpacePartition a +resizeSplitNth _ _ (BinarySpacePartition _ _ Nothing) _ = emptyBSP +resizeSplitNth _ _ b@(BinarySpacePartition _ _ (Just (Leaf _))) _ = b +resizeSplitNth dir sc b n = doToNth (resizeSplit dir sc) b n + +-- rotate tree left or right around parent of nth leaf +rotateTreeNth :: Direction2D -> BinarySpacePartition a -> Int -> BinarySpacePartition a +rotateTreeNth _ (BinarySpacePartition _ _ Nothing) _ = emptyBSP +rotateTreeNth U b _ = b +rotateTreeNth D b _ = b +rotateTreeNth dir b@(BinarySpacePartition _ _ (Just t)) n = + doToNth (\t -> case goUp t of + Nothing -> Just t + Just (t, c) -> Just (rotTree dir t, c)) b n + +-- set the split ratios so that all windows have the same size, without changing tree itself +equalizeTree :: BinarySpacePartition a -> BinarySpacePartition a +equalizeTree (BinarySpacePartition _ _ Nothing) = emptyBSP +equalizeTree (BinarySpacePartition olr foc (Just t)) = BinarySpacePartition olr foc $ Just $ eql t + where eql (Leaf n) = Leaf n + eql n@(Node s l r) = Node s{ratio=fromIntegral (numLeaves l) % fromIntegral (numLeaves n)} + (eql l) (eql r) + +-- generate a symmetrical balanced tree for n leaves +balancedTree :: Int -> BinarySpacePartition a +balancedTree n = numerateLeaves $ BinarySpacePartition [] ((-1),0,[]) $ Just $ balanced n + where balanced 1 = Leaf 0 + balanced 2 = Node (Split Horizontal 0.5) (Leaf 0) (Leaf 0) + balanced n = Node (Split Horizontal 0.5) (balanced (n`div`2)) (balanced (n-n`div`2)) + +-- attempt to rotate splits optimally in order choose more quad-like rects +optimizeOrientation :: Rectangle -> BinarySpacePartition a -> BinarySpacePartition a +optimizeOrientation r (BinarySpacePartition _ _ Nothing) = emptyBSP +optimizeOrientation r (BinarySpacePartition olr foc (Just t)) = BinarySpacePartition olr foc $ Just $ opt t r + where opt (Leaf v) rect = (Leaf v) + opt (Node sp l r) rect = Node sp' (opt l lrect) (opt r rrect) + where (Rectangle _ _ w1 h1,Rectangle _ _ w2 h2) = split (axis sp) (ratio sp) rect + (Rectangle _ _ w3 h3,Rectangle _ _ w4 h4) = split (axis $ oppositeSplit sp) (ratio sp) rect + f w h = if w > h then w'/h' else h'/w' where (w',h') = (fromIntegral w, fromIntegral h) + wratio = min (f w1 h1) (f w2 h2) + wratio' = min (f w3 h3) (f w4 h4) + sp' = if wratio [Int] +flattenLeaves (BinarySpacePartition _ _ Nothing) = [] +flattenLeaves (BinarySpacePartition _ _ (Just t)) = flatten t + where flatten (Leaf n) = [n] + flatten (Node _ l r) = flatten l++flatten r + +-- we do this before an action to look afterwards which leaves moved where +numerateLeaves :: BinarySpacePartition a -> BinarySpacePartition a +numerateLeaves b@(BinarySpacePartition _ _ Nothing) = b +numerateLeaves b@(BinarySpacePartition olr foc (Just t)) = BinarySpacePartition olr foc . Just . snd $ numerate 0 t + where numerate n (Leaf _) = (n+1, Leaf n) + numerate n (Node s l r) = (n'', Node s nl nr) + where (n', nl) = numerate n l + (n'', nr) = numerate n' r + +-- returns index of focused window or 0 for empty stack +index :: W.Stack a -> Int +index s = case toIndex (Just s) of + (_, Nothing) -> 0 + (_, Just int) -> int + +--move windows to new positions according to tree transformations, keeping focus on originally focused window +--CAREFUL here! introduce a bug here and have fun debugging as your windows start to disappear or explode +adjustStack :: Maybe (W.Stack Window) --original stack + -> Maybe (W.Stack Window) --stack without floating windows + -> [Window] --just floating windows of this WS + -> Maybe (BinarySpacePartition Window) -- Tree with numbered leaves telling what to move where + -> Maybe (W.Stack Window) --resulting stack +adjustStack orig Nothing _ _ = orig --no new stack -> no changes +adjustStack orig _ _ Nothing = orig --empty tree -> no changes +adjustStack orig s fw (Just b) = + if length ls tree incomplete, no changes + else fromIndex ws' fid' + where ws' = (mapMaybe ((flip M.lookup) wsmap) ls)++fw + fid' = fromMaybe 0 $ elemIndex focused ws' + wsmap = M.fromList $ zip [0..] ws -- map: old index in list -> window + ls = flattenLeaves b -- get new index ordering from tree + (ws,fid) = toIndex s + focused = ws !! (fromMaybe 0 $ fid) + +--replace the window stack of the managed workspace with our modified stack +replaceStack :: Maybe (W.Stack Window) -> X () +replaceStack s = do + st <- get + let wset = windowset st + cur = W.current wset + wsp = W.workspace cur + put st{windowset=wset{W.current=cur{W.workspace=wsp{W.stack=s}}}} + +replaceFloating :: M.Map Window W.RationalRect -> X () +replaceFloating wsm = do + st <- get + let wset = windowset st + put st{windowset=wset{W.floating=wsm}} + +-- some helpers to filter windows +getFloating = (M.keys . W.floating) <$> gets windowset -- all floating windows +getStackSet = (W.stack . W.workspace . W.current) <$> gets windowset -- windows on this WS (with floating) +withoutFloating fs = maybe Nothing (unfloat fs) +isFloating w = getFloating >>= (\fs -> return $ w `elem` fs) +getScreenRect = (screenRect . W.screenDetail . W.current) <$> gets windowset + +-- ignore messages if current focus is on floating window, otherwise return stack without floating +unfloat :: [Window] -> W.Stack Window -> Maybe (W.Stack Window) +unfloat fs s = if W.focus s `elem` fs + then Nothing + else Just $ s{W.up = W.up s \\ fs, W.down = W.down s \\ fs} + +instance LayoutClass BinarySpacePartition Window where + doLayout b r s = do + let b' = layout b + b'' <- if size b /= size b' then clearBorder b' else updateBorder r b' + -- when (getFocusedNode b/= getFocusedNode b'') $ debug $ show $ getFocusedNode b'' + + let rs = rectangles b'' r + wrs = zip ws rs + return (wrs, Just b''{getOldRects=wrs,getFocusedNode=getFocusedNode b''}) + where + ws = W.integrate s + l = length ws + n = index s + layout bsp + | l == count = bsp + | l > count = layout $ splitNth bsp n + | otherwise = layout $ removeNth bsp n + where count = size bsp + + handleMessage b_orig m + | Just FocusParent <- fromMessage m = focusParent b + | Just msg@(SetGeometry _) <- fromMessage m = handleResize b msg >>= return . updateNodeFocus + | otherwise = do + ws <- getStackSet + fs <- getFloating + r <- getScreenRect + let lws = withoutFloating fs ws -- tiled windows on WS + lfs = (maybe [] W.integrate ws) \\ (maybe [] W.integrate lws) -- untiled windows on WS + b' = lws >>= handleMesg r -- transform tree (concerns only tiled windows) + ws' = adjustStack ws lws lfs b' -- apply transformation to window stack, reintegrate floating wins + replaceStack ws' + return $ updateNodeFocus b' + where handleMesg r s = msum [fmap (`rotate` s) (fromMessage m) + ,fmap (`resize` s) (fromMessage m) + ,fmap (`swap` s) (fromMessage m) + ,fmap (`rotateTr` s) (fromMessage m) + ,fmap (balanceTr r) (fromMessage m) ] - unfloat fs s = if W.focus s `elem` fs - then Nothing - else Just (s { W.up = W.up s \\ fs - , W.down = W.down s \\ fs }) + + updateNodeFocus = maybe Nothing (\bsp -> Just $ bsp{getFocusedNode=clr $ getFocusedNode b_orig}) + where clr (_,_,ws) = ((-1),0,ws) + + b = numerateLeaves b_orig + rotate Rotate s = rotateNth b $ index s swap Swap s = swapNth b $ index s resize (ExpandTowards dir) s = growNthTowards dir b $ index s resize (ShrinkFrom dir) s = shrinkNthFrom dir b $ index s resize (MoveSplit dir) s = autoSizeNth dir b $ index s + rotateTr RotateL s = rotateTreeNth L b $ index s + rotateTr RotateR s = rotateTreeNth R b $ index s + balanceTr r Equalize = equalizeTree b + balanceTr r Balance = optimizeOrientation r $ balancedTree (size b) description _ = "BSP" +-- React to SetGeometry message to work with BorderResize/MouseResize +handleResize :: BinarySpacePartition Window -> WindowArrangerMsg -> X (Maybe (BinarySpacePartition Window)) +handleResize b (SetGeometry newrect@(Rectangle x y w h)) = do + ws <- getStackSet + fs <- getFloating + case W.focus <$> ws of + Nothing -> return Nothing + Just win -> do + isfloat <- isFloating win + (_,_,_,_,_,mx,my,_) <- withDisplay (\d -> (io $ queryPointer d win)) + let oldrect@(Rectangle ox oy ow oh) = fromMaybe (Rectangle 0 0 0 0) $ lookup win $ getOldRects b + let (xsc,ysc) = (fi w % fi ow, fi h % fi oh) + (xsc',ysc') = (rough xsc, rough ysc) + dirs = changedDirs oldrect newrect (fi mx,fi my) + n = elemIndex win $ maybe [] W.integrate $ withoutFloating fs ws + -- unless (isNothing dir) $ debug $ + -- show (fi x-fi ox,fi y-fi oy) ++ show (fi w-fi ow,fi h-fi oh) + -- ++ show dir ++ " " ++ show win ++ " " ++ show (mx,my) + return $ case n of + Just n' -> Just $ foldl' (\b' d -> resizeSplitNth d (xsc',ysc') b' n') b dirs + Nothing -> Nothing --focused window is floating -> ignore + + where rough v = min 1.5 $ max 0.75 v -- extreme scale factors are forbidden + +-- find out which borders have been pulled. We need the old and new rects and the mouse coordinates +changedDirs :: Rectangle -> Rectangle -> (Int,Int) -> [Direction2D] +changedDirs (Rectangle ox oy ow oh) (Rectangle x y w h) (mx,my) = catMaybes [lr, ud] + where lr = if ow==w then Nothing + else Just (if fi mx > (fi ow)/2 then R else L) + ud = if oh==h then Nothing + else Just (if fi my > (fi oh)/2 then D else U) + +-- move focus to next higher parent node of current focused leaf if possible, cyclic +focusParent :: BinarySpacePartition a -> X (Maybe (BinarySpacePartition a)) +focusParent b = do + foc <- maybe 0 index <$> (withoutFloating <$> getFloating <*> getStackSet) + let (l,n,d) = getFocusedNode b + return . Just $ if foc/= l then b{getFocusedNode=(foc,1,d)} + else b{getFocusedNode=upFocus (l,n,d)} + -- debug $ "Focus Parent: "++(maybe "" (show.getFocusedNode) ret) + where upFocus (l,n,d) + | canFocus (l,n+1,d) = (l,n+1,d) + | otherwise = (l,0,d) + canFocus (l,n,d) = isJust $ makeZipper b >>= goToFocusedLocation (l,n+1,d) + +-- "focus parent" border helpers + +updateBorder :: Rectangle -> BinarySpacePartition a -> X (BinarySpacePartition a) +updateBorder r b = do + foc <- maybe 0 index <$> (withoutFloating <$> getFloating <*> getStackSet) + let (l,n,ws) = getFocusedNode b + removeBorder ws + if n==0 || foc/=l then return $ b{getFocusedNode=(foc,0,[])} + else createBorder (getNodeRect b r (l,n)) Nothing >>= (\ws -> return $ b{getFocusedNode=(l,n,ws)}) + +clearBorder :: BinarySpacePartition a -> X (BinarySpacePartition a) +clearBorder b = do + let (_,_,ws) = getFocusedNode b + removeBorder ws + return b{getFocusedNode=((-1),0,[])} + +-- create a window for each border line, show, add into stack and set floating +createBorder r@(Rectangle wx wy ww wh) c = do + bw <- asks (borderWidth.config) + bc <- case c of + Nothing -> asks (focusedBorderColor.config) + Just s -> return s + let rects = [ Rectangle wx wy ww (fi bw) + , Rectangle wx wy (fi bw) wh + , Rectangle wx (wy+fi wh-fi bw) ww (fi bw) + , Rectangle (wx+fi ww-fi bw) wy (fi bw) wh + ] + ws <- mapM (\r -> createNewWindow r Nothing bc False) rects + showWindows ws + maybe Nothing (\s -> Just s{W.down=W.down s ++ ws}) <$> getStackSet >>= replaceStack + M.union (M.fromList $ zip ws $ map toRR rects) . W.floating . windowset <$> get >>= replaceFloating + modify (\s -> s{mapped=mapped s `S.union` S.fromList ws}) + + -- show <$> mapM isClient ws >>= debug + return ws + where toRR (Rectangle x y w h) = W.RationalRect (fi x) (fi y) (fi w) (fi h) + +-- remove border line windows from stack + floating, kill +removeBorder ws = do + modify (\s -> s{mapped = mapped s `S.difference` S.fromList ws}) + flip (foldl (flip M.delete)) ws . W.floating . windowset <$> get >>= replaceFloating + maybe Nothing (\s -> Just s{W.down=W.down s \\ ws}) <$> getStackSet >>= replaceStack + deleteWindows ws + +debug str = spawn $ "echo \""++str++"\" >> /tmp/xdebug" + -- cgit v1.2.3