You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
401 lines
16 KiB
401 lines
16 KiB
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-} |
|
----------------------------------------------------------------------------- |
|
-- | |
|
-- Module : XMonad.Layout.BinarySpacePartition |
|
-- Copyright : (c) 2013 Ben Weitzman <benweitzman@gmail.com> |
|
-- License : BSD3-style (see LICENSE) |
|
-- |
|
-- Maintainer : Ben Weitzman <benweitzman@gmail.com> |
|
-- Stability : unstable |
|
-- Portability : unportable |
|
-- |
|
-- Layout where new windows will split the focused window in half, based off of BSPWM |
|
-- |
|
----------------------------------------------------------------------------- |
|
|
|
module XMonad.Layout.BinarySpacePartition ( |
|
-- * Usage |
|
-- $usage |
|
emptyBSP |
|
, Rotate(..) |
|
, Swap(..) |
|
, ResizeDirectional(..) |
|
, Direction2D(..) |
|
) where |
|
|
|
import XMonad |
|
import qualified XMonad.StackSet as W |
|
import XMonad.Util.Stack hiding (Zipper) |
|
import XMonad.Util.Types |
|
import qualified Data.Map as M |
|
import Data.List ((\\)) |
|
import Control.Monad |
|
|
|
-- $usage |
|
-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: |
|
-- |
|
-- > import XMonad.Layout.BinarySpacePartition |
|
-- |
|
-- Then add the layout, using the default BSP (BinarySpacePartition) |
|
-- |
|
-- > myLayout = emptyBSP ||| etc .. |
|
-- |
|
-- It will be helpful to add the following key bindings |
|
-- |
|
-- > , ((modm .|. altMask, xK_l ), sendMessage $ ExpandTowards R) |
|
-- > , ((modm .|. altMask, xK_h ), sendMessage $ ExpandTowards L) |
|
-- > , ((modm .|. altMask, xK_j ), sendMessage $ ExpandTowards D) |
|
-- > , ((modm .|. altMask, xK_k ), sendMessage $ ExpandTowards U) |
|
-- > , ((modm .|. altMask .|. ctrlMask , xK_l ), sendMessage $ ShrinkFrom R) |
|
-- > , ((modm .|. altMask .|. ctrlMask , xK_h ), sendMessage $ ShrinkFrom L) |
|
-- > , ((modm .|. altMask .|. ctrlMask , xK_j ), sendMessage $ ShrinkFrom D) |
|
-- > , ((modm .|. altMask .|. ctrlMask , xK_k ), sendMessage $ ShrinkFrom U) |
|
-- > , ((modm, xK_r ), sendMessage Rotate) |
|
-- > , ((modm, xK_s ), sendMessage Swap) |
|
-- |
|
-- Here's an alternative key mapping, this time using additionalKeysP, |
|
-- arrow keys, and slightly different behavior when resizing windows |
|
-- |
|
-- > , ("M-M1-<Left>", sendMessage $ ExpandTowards L) |
|
-- > , ("M-M1-<Right>", sendMessage $ ShrinkFrom L) |
|
-- > , ("M-M1-<Up>", sendMessage $ ExpandTowards U) |
|
-- > , ("M-M1-<Down>", sendMessage $ ShrinkFrom U) |
|
-- > , ("M-M1-C-<Left>", sendMessage $ ShrinkFrom R) |
|
-- > , ("M-M1-C-<Right>", sendMessage $ ExpandTowards R) |
|
-- > , ("M-M1-C-<Up>", sendMessage $ ShrinkFrom D) |
|
-- > , ("M-M1-C-<Down>", sendMessage $ ExpandTowards D) |
|
-- > , ("M-s", sendMessage $ BSP.Swap) |
|
-- > , ("M-M1-s", sendMessage $ Rotate) ] |
|
-- |
|
|
|
-- |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 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. |
|
data Swap = Swap deriving Typeable |
|
instance Message Swap |
|
|
|
data Axis = Horizontal | Vertical deriving (Show, Read, Eq) |
|
|
|
oppositeDirection :: Direction2D -> Direction2D |
|
oppositeDirection U = D |
|
oppositeDirection D = U |
|
oppositeDirection L = R |
|
oppositeDirection R = L |
|
|
|
oppositeAxis :: Axis -> Axis |
|
oppositeAxis Vertical = Horizontal |
|
oppositeAxis Horizontal = Vertical |
|
|
|
toAxis :: Direction2D -> Axis |
|
toAxis U = Horizontal |
|
toAxis D = Horizontal |
|
toAxis L = Vertical |
|
toAxis R = Vertical |
|
|
|
split :: Axis -> Rational -> Rectangle -> (Rectangle, Rectangle) |
|
split Horizontal r (Rectangle sx sy sw sh) = (r1, r2) where |
|
r1 = Rectangle sx sy sw sh' |
|
r2 = Rectangle sx (sy + fromIntegral sh') sw (sh - sh') |
|
sh' = floor $ fromIntegral sh * r |
|
split Vertical r (Rectangle sx sy sw sh) = (r1, r2) where |
|
r1 = Rectangle sx sy sw' sh |
|
r2 = Rectangle (sx + fromIntegral sw') sy (sw - sw') sh |
|
sw' = floor $ fromIntegral sw * r |
|
|
|
data Split = Split { axis :: Axis |
|
, ratio :: Rational |
|
} deriving (Show, Read, Eq) |
|
|
|
oppositeSplit :: Split -> Split |
|
oppositeSplit (Split d r) = Split (oppositeAxis d) r |
|
|
|
increaseRatio :: Split -> Rational -> Split |
|
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 |
|
, left :: Tree a |
|
, right :: Tree a |
|
} deriving (Show, Read, Eq) |
|
|
|
numLeaves :: Tree a -> Int |
|
numLeaves Leaf = 1 |
|
numLeaves (Node _ l r) = numLeaves l + numLeaves r |
|
|
|
data Crumb a = LeftCrumb a (Tree a) | RightCrumb a (Tree a) deriving (Show, Read, Eq) |
|
|
|
swapCrumb :: Crumb a -> Crumb a |
|
swapCrumb (LeftCrumb s t) = RightCrumb s t |
|
swapCrumb (RightCrumb s t) = LeftCrumb s t |
|
|
|
parentVal :: Crumb a -> a |
|
parentVal (LeftCrumb s _) = s |
|
parentVal (RightCrumb s _) = s |
|
|
|
modifyParentVal :: (a -> a) -> Crumb a -> Crumb a |
|
modifyParentVal f (LeftCrumb s t) = LeftCrumb (f s) t |
|
modifyParentVal f (RightCrumb s t) = RightCrumb (f s) t |
|
|
|
type Zipper a = (Tree a, [Crumb a]) |
|
|
|
toZipper :: Tree a -> Zipper a |
|
toZipper t = (t, []) |
|
|
|
goLeft :: Zipper a -> Maybe (Zipper a) |
|
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 (Node x l r, bs) = Just (r, RightCrumb x l:bs) |
|
|
|
goUp :: Zipper a -> Maybe (Zipper a) |
|
goUp (_, []) = Nothing |
|
goUp (t, LeftCrumb x r:cs) = Just (Node x t r, cs) |
|
goUp (t, RightCrumb x l:cs) = Just (Node x l t, cs) |
|
|
|
goSibling :: Zipper a -> Maybe (Zipper a) |
|
goSibling (_, []) = Nothing |
|
goSibling z@(_, LeftCrumb _ _:_) = Just z >>= goUp >>= goRight |
|
goSibling z@(_, RightCrumb _ _:_) = Just z >>= goUp >>= goLeft |
|
|
|
goToNthLeaf :: Int -> Zipper a -> Maybe (Zipper a) |
|
goToNthLeaf _ z@(Leaf, _) = Just z |
|
goToNthLeaf n z@(t, _) = |
|
if numLeaves (left t) > n |
|
then do z' <- goLeft z |
|
goToNthLeaf n z' |
|
else do z' <- goRight z |
|
goToNthLeaf (n - (numLeaves . left $ t)) z' |
|
|
|
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 _ = 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 _ = Nothing |
|
|
|
rotateCurrentLeaf :: Zipper Split -> Maybe (Zipper Split) |
|
rotateCurrentLeaf (Leaf, []) = Just (Leaf, []) |
|
rotateCurrentLeaf (Leaf, c:cs) = Just (Leaf, modifyParentVal oppositeSplit c:cs) |
|
rotateCurrentLeaf _ = Nothing |
|
|
|
swapCurrentLeaf :: Zipper a -> Maybe (Zipper a) |
|
swapCurrentLeaf (Leaf, []) = Just (Leaf, []) |
|
swapCurrentLeaf (Leaf, c:cs) = Just (Leaf, swapCrumb c:cs) |
|
swapCurrentLeaf _ = Nothing |
|
|
|
isAllTheWay :: Direction2D -> Zipper Split -> Bool |
|
isAllTheWay _ (_, []) = True |
|
isAllTheWay R (_, LeftCrumb s _:_) |
|
| axis s == Vertical = False |
|
isAllTheWay L (_, RightCrumb s _:_) |
|
| axis s == Vertical = False |
|
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 |
|
|
|
expandTreeTowards :: Direction2D -> Zipper Split -> Maybe (Zipper Split) |
|
expandTreeTowards _ z@(_, []) = Just 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) |
|
expandTreeTowards L (t, RightCrumb s l:cs) |
|
| axis s == Vertical = Just (t, RightCrumb (increaseRatio s (-resizeDiff)) l:cs) |
|
expandTreeTowards D (t, LeftCrumb s r:cs) |
|
| axis s == Horizontal = Just (t, LeftCrumb (increaseRatio s resizeDiff) r:cs) |
|
expandTreeTowards U (t, RightCrumb s l:cs) |
|
| axis s == Horizontal = Just (t, RightCrumb (increaseRatio s (-resizeDiff)) l:cs) |
|
expandTreeTowards dir z = goUp z >>= expandTreeTowards dir |
|
|
|
shrinkTreeFrom :: Direction2D -> Zipper Split -> Maybe (Zipper Split) |
|
shrinkTreeFrom _ z@(_, []) = Just z |
|
shrinkTreeFrom R z@(_, LeftCrumb s _:_) |
|
| axis s == Vertical = Just z >>= goSibling >>= expandTreeTowards L |
|
shrinkTreeFrom L z@(_, RightCrumb s _:_) |
|
| axis s == Vertical = Just z >>= goSibling >>= expandTreeTowards R |
|
shrinkTreeFrom D z@(_, LeftCrumb s _:_) |
|
| axis s == Horizontal = Just z >>= goSibling >>= expandTreeTowards U |
|
shrinkTreeFrom U z@(_, RightCrumb s _:_) |
|
| axis s == Horizontal = Just z >>= goSibling >>= expandTreeTowards D |
|
shrinkTreeFrom dir z = goUp z >>= shrinkTreeFrom dir |
|
|
|
-- Direction2D refers to which direction the divider should move. |
|
autoSizeTree :: Direction2D -> Zipper Split -> Maybe (Zipper Split) |
|
autoSizeTree _ z@(_, []) = Just z |
|
autoSizeTree d z = |
|
Just z >>= getSplit (toAxis d) >>= resizeTree d |
|
|
|
-- 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 _ _:_) = |
|
Just z >>= expandTreeTowards R |
|
resizeTree L z@(_, LeftCrumb _ _:_) = |
|
Just z >>= shrinkTreeFrom R |
|
resizeTree U z@(_, LeftCrumb _ _:_) = |
|
Just z >>= shrinkTreeFrom D |
|
resizeTree D z@(_, LeftCrumb _ _:_) = |
|
Just z >>= expandTreeTowards D |
|
resizeTree R z@(_, RightCrumb _ _:_) = |
|
Just z >>= shrinkTreeFrom L |
|
resizeTree L z@(_, RightCrumb _ _:_) = |
|
Just z >>= expandTreeTowards L |
|
resizeTree U z@(_, RightCrumb _ _:_) = |
|
Just z >>= expandTreeTowards U |
|
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 |
|
then findClosest d z |
|
else fs |
|
|
|
findClosest :: Axis -> Zipper Split -> Maybe (Zipper Split) |
|
findClosest _ z@(_, []) = Just z |
|
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 |
|
|
|
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) |
|
|
|
-- | an empty BinarySpacePartition to use as a default for adding windows to. |
|
emptyBSP :: BinarySpacePartition a |
|
emptyBSP = BinarySpacePartition Nothing |
|
|
|
makeBSP :: Tree Split -> BinarySpacePartition a |
|
makeBSP = BinarySpacePartition . Just |
|
|
|
makeZipper :: BinarySpacePartition a -> Maybe (Zipper Split) |
|
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 |
|
|
|
rectangles :: BinarySpacePartition a -> Rectangle -> [Rectangle] |
|
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 |
|
|
|
doToNth :: (Zipper Split -> Maybe (Zipper Split)) -> BinarySpacePartition a -> Int -> BinarySpacePartition a |
|
doToNth f b n = zipperToBinarySpacePartition $ makeZipper b >>= goToNthLeaf n >>= f |
|
|
|
splitNth :: BinarySpacePartition a -> Int -> BinarySpacePartition a |
|
splitNth (BinarySpacePartition Nothing) _ = makeBSP Leaf |
|
splitNth b n = doToNth splitCurrentLeaf b n |
|
|
|
removeNth :: BinarySpacePartition a -> Int -> BinarySpacePartition a |
|
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 |
|
|
|
swapNth :: BinarySpacePartition a -> Int -> BinarySpacePartition a |
|
swapNth (BinarySpacePartition Nothing) _ = emptyBSP |
|
swapNth b@(BinarySpacePartition (Just Leaf)) _ = b |
|
swapNth b n = doToNth swapCurrentLeaf b n |
|
|
|
growNthTowards :: Direction2D -> BinarySpacePartition a -> Int -> BinarySpacePartition a |
|
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 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) |
|
] |
|
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 }) |
|
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 |
|
|
|
description _ = "BSP" |
|
|
|
|