├── README.md
└── XMonad
    └── Layout
        ├── .gitignore
        ├── BinarySpacePartition.hs
        └── Spacing.hs


/README.md:
--------------------------------------------------------------------------------
  1 | BinarySpacePartition
  2 | ====================
  3 | 
  4 | #### NOTICE: This layout is in the XMonadContrib darcs
  5 | So unless you are making changes or need the latest version I suggest using that. Feel free to make changes
  6 | here and or directly to xmonad contrib through darcs, I will pull down any upstream changes periodically.
  7 | 
  8 | ====================
  9 | 
 10 | BinarySpacePartition (BSP) is an XMonad Layout where new windows will split the focused window in half. 
 11 | This is based off of https://github.com/baskerville/bspwm.
 12 | 
 13 | The BSP can be manipulated to create highly configurable layouts. By default new windows split the
 14 | current window by alternating vertical and horizontal splits. Nodes of the tree can be rotated to change the
 15 | axis of the split, and the two children of a node can be swapped. 
 16 | 
 17 | The layout provides the following messages:
 18 | 
 19 | * `Rotate` which rotates a split between vertical and horizontal
 20 | * `Swap` which swaps to sibling nodes
 21 | * `ExpandTowards dir` which takes a Direction2D argument (`U`, `D`, `L`, `R`) and expands the selected window's border
 22 | in that direction
 23 | * `ExpandTowardsDelta delta dir` which takes a Rational `delta` and Direction2D argument and expands the selected window's border in that direction by `delta` of the corresponding screen dimension
 24 | * `FocusParent` to select a group of windows for an action instead of a single one for better control (sometimes without this, swap or rotate just are not possible)
 25 | * `ShrinkFrom dir` which takes a Direction2D argument and shrinks the selected window's border from that direction
 26 | * `ShrinkFromDelta delta dir` which takes a Rational `delta` and Direction2D argument and shrinks the selected window's border from that direction by `delta` of the corresponding screen dimension
 27 | * `MoveSplit dir` which takes a Direction2D argument and tries to intelligently move some border in that direction
 28 | * `MoveSplitDelta delta dir` which takes a Rational `delta` Direction2D argument and tries to intelligently move some border in that direction by `delta` of the corresponding screen dimension
 29 |   This mode seems a bitmore intuitive to some people.
 30 | 
 31 | There's also support for mouse resizing
 32 | 
 33 | To use BSP, import the module in your `~/.xmonad/xmonad.hs` file:
 34 | 
 35 | ```
 36 | import XMonad.Layout.BinarySpacePartition
 37 | ```
 38 | 
 39 | Then add the layout, using the default BSP:
 40 | 
 41 | ``` 
 42 | myLayout = emptyBSP ||| etc ..
 43 | ```
 44 | 
 45 | It will be helpful to add the following keybindings:
 46 | 
 47 | ```
 48 | , ((modm .|. altMask,               xK_l     ), sendMessage $ ExpandTowards R)
 49 | , ((modm .|. altMask,               xK_h     ), sendMessage $ ExpandTowards L)
 50 | , ((modm .|. altMask,               xK_j     ), sendMessage $ ExpandTowards D)
 51 | , ((modm .|. altMask,               xK_k     ), sendMessage $ ExpandTowards U)
 52 | , ((modm .|. altMask .|. ctrlMask , xK_l     ), sendMessage $ ShrinkFrom R)
 53 | , ((modm .|. altMask .|. ctrlMask , xK_h     ), sendMessage $ ShrinkFrom L)
 54 | , ((modm .|. altMask .|. ctrlMask , xK_j     ), sendMessage $ ShrinkFrom D)
 55 | , ((modm .|. altMask .|. ctrlMask , xK_k     ), sendMessage $ ShrinkFrom U)
 56 | , ((modm,                           xK_r     ), sendMessage Rotate)
 57 | , ((modm,                           xK_s     ), sendMessage Swap)
 58 | ```
 59 | 
 60 | Here's an alternative key mapping, this time using additionalKeysP,
 61 | arrow keys, and slightly different behavior when resizing windows
 62 | 
 63 | ```
 64 | , ("M-M1-<Left>",    sendMessage $ ExpandTowards L)
 65 | , ("M-M1-<Right>",   sendMessage $ ShrinkFrom L)
 66 | , ("M-M1-<Up>",      sendMessage $ ExpandTowards U)
 67 | , ("M-M1-<Down>",    sendMessage $ ShrinkFrom U)
 68 | , ("M-M1-C-<Left>",  sendMessage $ ShrinkFrom R)
 69 | , ("M-M1-C-<Right>", sendMessage $ ExpandTowards R)
 70 | , ("M-M1-C-<Up>",    sendMessage $ ShrinkFrom D)
 71 | , ("M-M1-C-<Down>",  sendMessage $ ExpandTowards D)
 72 | , ("M-s",            sendMessage $ Swap)
 73 | , ("M-M1-s",         sendMessage $ Rotate)
 74 | ```
 75 | 
 76 | And to use the alternate resizing mode:
 77 | 
 78 | ```
 79 | , ((myModKey .|. controlMask, xK_Left   ), sendMessage $ MoveSplit L)
 80 | ```
 81 | 
 82 | There are some more operations you might find useful:
 83 | ```
 84 | , ((myModMask .|. mod1Mask,  xK_Up),    sendMessage $ FlipH)
 85 | , ((myModMask .|. mod1Mask,  xK_Down),  sendMessage $ FlipV)
 86 | , ((myModMask .|. mod1Mask,  xK_Right), sendMessage $ RotateR)
 87 | , ((myModMask .|. mod1Mask,  xK_Left),  sendMessage $ RotateL)
 88 | , ((myModMask, xK_a), sendMessage Balance)
 89 | , ((myModMask, xK_f), sendMessage CirculateR)
 90 | , ((myModMask, xK_g), sendMessage CirculateL)
 91 | ```
 92 | 
 93 | ![gif demo](http://i.imgur.com/6VpHKAU.gif)
 94 | 
 95 | ============
 96 | 
 97 | ## Contributors:
 98 | 
 99 | [apirogov](https://github.com/apirogov)
100 | 


--------------------------------------------------------------------------------
/XMonad/Layout/.gitignore:
--------------------------------------------------------------------------------
1 | BinarySpacePartition.hs~
2 | 


--------------------------------------------------------------------------------
/XMonad/Layout/BinarySpacePartition.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE PatternGuards #-}
  2 | {-# LANGUAGE DoAndIfThenElse #-}
  3 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-}
  4 | -----------------------------------------------------------------------------
  5 | -- |
  6 | -- Module      :  XMonad.Layout.BinarySpacePartition
  7 | -- Copyright   :  (c) 2013 Ben Weitzman    <benweitzman@gmail.com>
  8 | --                    2015 Anton Pirogov   <anton.pirogov@gmail.com>
  9 | -- License     :  BSD3-style (see LICENSE)
 10 | --
 11 | -- Maintainer  :  Ben Weitzman <benweitzman@gmail.com>
 12 | -- Stability   :  unstable
 13 | -- Portability :  unportable
 14 | --
 15 | -- Layout where new windows will split the focused window in half, based off of BSPWM
 16 | --
 17 | -----------------------------------------------------------------------------
 18 | 
 19 | module XMonad.Layout.BinarySpacePartition (
 20 |   -- * Usage
 21 |   -- $usage
 22 |     emptyBSP
 23 |   , Rotate(..)
 24 |   , Swap(..)
 25 |   , ResizeDirectional(..)
 26 |   , TreeRotate(..)
 27 |   , TreeBalance(..)
 28 |   , FocusParent(..)
 29 |   , SelectMoveNode(..)
 30 |   , Direction2D(..)
 31 |   ) where
 32 | 
 33 | import XMonad
 34 | import qualified XMonad.StackSet as W
 35 | import XMonad.Util.Stack hiding (Zipper)
 36 | import XMonad.Util.Types
 37 | 
 38 | -- for mouse resizing
 39 | import XMonad.Layout.WindowArranger (WindowArrangerMsg(SetGeometry))
 40 | -- for "focus parent" node border
 41 | import XMonad.Util.XUtils
 42 | 
 43 | import qualified Data.Map as M
 44 | import qualified Data.Set as S
 45 | import Data.List ((\\), elemIndex, foldl')
 46 | import Data.Maybe (fromMaybe, isNothing, isJust, mapMaybe, catMaybes)
 47 | import Control.Applicative
 48 | import Control.Monad
 49 | import Data.Ratio ((%))
 50 | 
 51 | -- $usage
 52 | -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
 53 | --
 54 | -- > import XMonad.Layout.BinarySpacePartition
 55 | --
 56 | -- Then add the layout, using the default BSP (BinarySpacePartition)
 57 | --
 58 | -- > myLayout = emptyBSP ||| etc ..
 59 | --
 60 | -- It may be a good idea to use "XMonad.Actions.Navigation2D" to move between the windows.
 61 | --
 62 | -- This layout responds to SetGeometry and is compatible with e.g. "XMonad.Actions.MouseResize"
 63 | -- or "XMonad.Layout.BorderResize". You should probably try both to decide which is better for you,
 64 | -- if you want to be able to resize the splits with the mouse.
 65 | --
 66 | -- If you don't want to use the mouse, add the following key bindings to resize the splits with the keyboard:
 67 | --
 68 | -- > , ((modm .|. altMask,               xK_l     ), sendMessage $ ExpandTowards R)
 69 | -- > , ((modm .|. altMask,               xK_h     ), sendMessage $ ExpandTowards L)
 70 | -- > , ((modm .|. altMask,               xK_j     ), sendMessage $ ExpandTowards D)
 71 | -- > , ((modm .|. altMask,               xK_k     ), sendMessage $ ExpandTowards U)
 72 | -- > , ((modm .|. altMask .|. ctrlMask , xK_l     ), sendMessage $ ShrinkFrom R)
 73 | -- > , ((modm .|. altMask .|. ctrlMask , xK_h     ), sendMessage $ ShrinkFrom L)
 74 | -- > , ((modm .|. altMask .|. ctrlMask , xK_j     ), sendMessage $ ShrinkFrom D)
 75 | -- > , ((modm .|. altMask .|. ctrlMask , xK_k     ), sendMessage $ ShrinkFrom U)
 76 | -- > , ((modm,                           xK_r     ), sendMessage Rotate)
 77 | -- > , ((modm,                           xK_s     ), sendMessage Swap)
 78 | -- > , ((modm,                           xK_n     ), sendMessage FocusParent)
 79 | -- > , ((modm .|. ctrlMask,              xK_n     ), sendMessage SelectNode)
 80 | -- > , ((modm .|. shiftMask,             xK_n     ), sendMessage MoveNode)
 81 | --
 82 | -- Here's an alternative key mapping, this time using additionalKeysP,
 83 | -- arrow keys, and slightly different behavior when resizing windows
 84 | --
 85 | -- > , ("M-M1-<Left>",    sendMessage $ ExpandTowards L)
 86 | -- > , ("M-M1-<Right>",   sendMessage $ ShrinkFrom L)
 87 | -- > , ("M-M1-<Up>",      sendMessage $ ExpandTowards U)
 88 | -- > , ("M-M1-<Down>",    sendMessage $ ShrinkFrom U)
 89 | -- > , ("M-M1-C-<Left>",  sendMessage $ ShrinkFrom R)
 90 | -- > , ("M-M1-C-<Right>", sendMessage $ ExpandTowards R)
 91 | -- > , ("M-M1-C-<Up>",    sendMessage $ ShrinkFrom D)
 92 | -- > , ("M-M1-C-<Down>",  sendMessage $ ExpandTowards D)
 93 | -- > , ("M-s",            sendMessage $ BSP.Swap)
 94 | -- > , ("M-M1-s",         sendMessage $ Rotate) ]
 95 | --
 96 | -- If you have many windows open and the layout begins to look too hard to manage, you can 'Balance'
 97 | -- the layout, so that the current splittings are discarded and windows are tiled freshly in a way that
 98 | -- the split depth is minimized. You can combine this with 'Equalize', which does not change your tree,
 99 | -- but tunes the split ratios in a way that each window gets the same amount of space:
100 | --
101 | -- > , ((myModMask,               xK_a),     sendMessage Balance)
102 | -- > , ((myModMask .|. shiftMask, xK_a),     sendMessage Equalize)
103 | --
104 | 
105 | -- |Message for rotating the binary tree around the parent node of the window to the left or right
106 | data TreeRotate = RotateL | RotateR deriving Typeable
107 | instance Message TreeRotate
108 | 
109 | -- |Message to balance the tree in some way (Balance retiles the windows, Equalize changes ratios)
110 | data TreeBalance = Balance | Equalize deriving Typeable
111 | instance Message TreeBalance
112 | 
113 | -- |Message for resizing one of the cells in the BSP
114 | data ResizeDirectional = ExpandTowardsDelta Rational Direction2D
115 |                        | ExpandTowards Direction2D
116 |                        | ShrinkFromDelta Rational Direction2D
117 |                        | ShrinkFrom Direction2D
118 |                        | MoveSplitDelta Rational Direction2D
119 |                        | MoveSplit Direction2D deriving (Typeable)
120 | instance Message ResizeDirectional
121 | 
122 | -- |Message for rotating a split (horizontal/vertical) in the BSP
123 | data Rotate = Rotate deriving Typeable
124 | instance Message Rotate
125 | 
126 | -- |Message for swapping the left child of a split with the right child of split
127 | data Swap = Swap deriving Typeable
128 | instance Message Swap
129 | 
130 | -- |Message to cyclically select the parent node instead of the leaf
131 | data FocusParent = FocusParent deriving Typeable
132 | instance Message FocusParent
133 | 
134 | -- |Message to move nodes inside the tree
135 | data SelectMoveNode = SelectNode | MoveNode deriving Typeable
136 | instance Message SelectMoveNode
137 | 
138 | data Axis = Horizontal | Vertical deriving (Show, Read, Eq)
139 | 
140 | oppositeDirection :: Direction2D -> Direction2D
141 | oppositeDirection U = D
142 | oppositeDirection D = U
143 | oppositeDirection L = R
144 | oppositeDirection R = L
145 | 
146 | oppositeAxis :: Axis -> Axis
147 | oppositeAxis Vertical = Horizontal
148 | oppositeAxis Horizontal = Vertical
149 | 
150 | toAxis :: Direction2D -> Axis
151 | toAxis U = Horizontal
152 | toAxis D = Horizontal
153 | toAxis L = Vertical
154 | toAxis R = Vertical
155 | 
156 | split :: Axis -> Rational -> Rectangle -> (Rectangle, Rectangle)
157 | split Horizontal r (Rectangle sx sy sw sh) = (r1, r2) where
158 |     r1 = Rectangle sx sy sw sh'
159 |     r2 = Rectangle sx (sy + fromIntegral sh') sw (sh - sh')
160 |     sh' = floor $ fromIntegral sh * r
161 | split Vertical r (Rectangle sx sy sw sh) = (r1, r2) where
162 |     r1 = Rectangle sx sy sw' sh
163 |     r2 = Rectangle (sx + fromIntegral sw') sy (sw - sw') sh
164 |     sw' = floor $ fromIntegral sw * r
165 | 
166 | data Split = Split { axis :: Axis
167 |                    , ratio :: Rational
168 |                    } deriving (Show, Read, Eq)
169 | 
170 | oppositeSplit :: Split -> Split
171 | oppositeSplit (Split d r) = Split (oppositeAxis d) r
172 | 
173 | increaseRatio :: Split -> Rational -> Split
174 | increaseRatio (Split d r) delta = Split d (min 0.9 (max 0.1 (r + delta)))
175 | 
176 | resizeDiff :: Rational
177 | resizeDiff = 0.05
178 | 
179 | data Tree a = Leaf Int | Node { value :: a
180 |                           , left :: Tree a
181 |                           , right :: Tree a
182 |                           } deriving (Show, Read, Eq)
183 | 
184 | numLeaves :: Tree a -> Int
185 | numLeaves (Leaf _) = 1
186 | numLeaves (Node _ l r) = numLeaves l + numLeaves r
187 | 
188 | -- right or left rotation of a (sub)tree, no effect if rotation not possible
189 | rotTree :: Direction2D -> Tree a -> Tree a
190 | rotTree _ (Leaf n) = Leaf n
191 | rotTree R n@(Node _ (Leaf _) _) = n
192 | rotTree L n@(Node _ _ (Leaf _)) = n
193 | rotTree R (Node sp (Node sp2 l2 r2) r) = Node sp2 l2 (Node sp r2 r)
194 | rotTree L (Node sp l (Node sp2 l2 r2)) = Node sp2 (Node sp l l2) r2
195 | rotTree _ t = t
196 | 
197 | 
198 | data Crumb a = LeftCrumb a (Tree a) | RightCrumb a (Tree a) deriving (Show, Read, Eq)
199 | 
200 | swapCrumb :: Crumb a -> Crumb a
201 | swapCrumb (LeftCrumb s t) = RightCrumb s t
202 | swapCrumb (RightCrumb s t) = LeftCrumb s t
203 | 
204 | parentVal :: Crumb a -> a
205 | parentVal (LeftCrumb s _) = s
206 | parentVal (RightCrumb s _) = s
207 | 
208 | modifyParentVal :: (a -> a) -> Crumb a -> Crumb a
209 | modifyParentVal f (LeftCrumb s t) = LeftCrumb (f s) t
210 | modifyParentVal f (RightCrumb s t) = RightCrumb (f s) t
211 | 
212 | type Zipper a = (Tree a, [Crumb a])
213 | 
214 | toZipper :: Tree a -> Zipper a
215 | toZipper t = (t, [])
216 | 
217 | goLeft :: Zipper a -> Maybe (Zipper a)
218 | goLeft (Leaf _, _) = Nothing
219 | goLeft (Node x l r, bs) = Just (l, LeftCrumb x r:bs)
220 | 
221 | goRight :: Zipper a -> Maybe (Zipper a)
222 | goRight (Leaf _, _) = Nothing
223 | goRight (Node x l r, bs) = Just (r, RightCrumb x l:bs)
224 | 
225 | goUp :: Zipper a -> Maybe (Zipper a)
226 | goUp (_, []) = Nothing
227 | goUp (t, LeftCrumb x r:cs) = Just (Node x t r, cs)
228 | goUp (t, RightCrumb x l:cs) = Just (Node x l t, cs)
229 | 
230 | goSibling :: Zipper a -> Maybe (Zipper a)
231 | goSibling (_, []) = Nothing
232 | goSibling z@(_, LeftCrumb _ _:_) = Just z >>= goUp >>= goRight
233 | goSibling z@(_, RightCrumb _ _:_) = Just z >>= goUp >>= goLeft
234 | 
235 | top :: Zipper a -> Zipper a
236 | top z = case goUp z of
237 |           Nothing -> z
238 |           Just z' -> top z'
239 | 
240 | toTree :: Zipper a -> Tree a
241 | toTree = fst . top
242 | 
243 | goToNthLeaf :: Int -> Zipper a -> Maybe (Zipper a)
244 | goToNthLeaf _ z@(Leaf _, _) = Just z
245 | goToNthLeaf n z@(t, _) =
246 |   if numLeaves (left t) > n
247 |   then do z' <- goLeft z
248 |           goToNthLeaf n z'
249 |   else do z' <- goRight z
250 |           goToNthLeaf (n - (numLeaves . left $ t)) z'
251 | 
252 | toggleSplits :: Tree Split -> Tree Split
253 | toggleSplits (Leaf l) = Leaf l
254 | toggleSplits (Node s l r) = Node (oppositeSplit s) (toggleSplits l) (toggleSplits r)
255 | 
256 | splitFromRect :: Rectangle -> Split
257 | splitFromRect (Rectangle _ _ w h)
258 |   | w >= h = (Split Vertical 0.5)
259 |   | otherwise = (Split Horizontal 0.5)
260 | 
261 | splitCurrent :: Rectangle -> Zipper Split -> Maybe (Zipper Split)
262 | splitCurrent r (Leaf _, []) = Just (Node (splitFromRect r) (Leaf 0) (Leaf 0), [])
263 | splitCurrent r (Leaf _, crumb:cs) = Just (Node (splitFromRect r) (Leaf 0) (Leaf 0), crumb:cs)
264 | splitCurrent r (n, []) = Just (Node (splitFromRect r) (Leaf 0) (toggleSplits n), [])
265 | splitCurrent r (n, crumb:cs) = Just (Node (splitFromRect r) (Leaf 0) (toggleSplits n), crumb:cs)
266 | 
267 | removeCurrent :: Zipper a -> Maybe (Zipper a)
268 | removeCurrent (Leaf _, LeftCrumb _ r:cs) = Just (r, cs)
269 | removeCurrent (Leaf _, RightCrumb _ l:cs) = Just (l, cs)
270 | removeCurrent (Leaf _, []) = Nothing
271 | removeCurrent (Node _ (Leaf _) r@(Node _ _ _), cs) = Just (r, cs)
272 | removeCurrent (Node _ l@(Node _ _ _) (Leaf _), cs) = Just (l, cs)
273 | removeCurrent (Node _ (Leaf _) (Leaf _), cs) = Just (Leaf 0, cs)
274 | removeCurrent z@(Node _ _ _, _) = goLeft z >>= removeCurrent
275 | 
276 | rotateCurrent :: Zipper Split -> Maybe (Zipper Split)
277 | rotateCurrent l@(_, []) = Just l
278 | rotateCurrent (n, c:cs) = Just (n, modifyParentVal oppositeSplit c:cs)
279 | 
280 | swapCurrent :: Zipper a -> Maybe (Zipper a)
281 | swapCurrent l@(_, []) = Just l
282 | swapCurrent (n, c:cs) = Just (n, swapCrumb c:cs)
283 | 
284 | isAllTheWay :: Direction2D -> Zipper Split -> Bool
285 | isAllTheWay _ (_, []) = True
286 | isAllTheWay R (_, LeftCrumb s _:_)
287 |   | axis s == Vertical = False
288 | isAllTheWay L (_, RightCrumb s _:_)
289 |   | axis s == Vertical = False
290 | isAllTheWay D (_, LeftCrumb s _:_)
291 |   | axis s == Horizontal = False
292 | isAllTheWay U (_, RightCrumb s _:_)
293 |   | axis s == Horizontal = False
294 | isAllTheWay dir z = fromMaybe False $ goUp z >>= Just . isAllTheWay dir
295 | 
296 | expandTreeTowards :: Rational -> Direction2D -> Zipper Split -> Maybe (Zipper Split)
297 | expandTreeTowards _ _ z@(_, []) = Just z
298 | expandTreeTowards diff dir z
299 |   | isAllTheWay dir z = shrinkTreeFrom diff (oppositeDirection dir) z
300 | expandTreeTowards diff R (t, LeftCrumb s r:cs)
301 |   | axis s == Vertical = Just (t, LeftCrumb (increaseRatio s diff) r:cs)
302 | expandTreeTowards diff L (t, RightCrumb s l:cs)
303 |   | axis s == Vertical = Just (t, RightCrumb (increaseRatio s (-diff)) l:cs)
304 | expandTreeTowards diff D (t, LeftCrumb s r:cs)
305 |   | axis s == Horizontal = Just (t, LeftCrumb (increaseRatio s diff) r:cs)
306 | expandTreeTowards diff U (t, RightCrumb s l:cs)
307 |   | axis s == Horizontal = Just (t, RightCrumb (increaseRatio s (-diff)) l:cs)
308 | expandTreeTowards diff dir z = goUp z >>= expandTreeTowards diff dir
309 | 
310 | shrinkTreeFrom :: Rational -> Direction2D -> Zipper Split -> Maybe (Zipper Split)
311 | shrinkTreeFrom _ _ z@(_, []) = Just z
312 | shrinkTreeFrom diff R z@(_, LeftCrumb s _:_)
313 |   | axis s == Vertical = Just z >>= goSibling >>= expandTreeTowards diff L
314 | shrinkTreeFrom diff L z@(_, RightCrumb s _:_)
315 |   | axis s == Vertical = Just z >>= goSibling >>= expandTreeTowards diff R
316 | shrinkTreeFrom diff D z@(_, LeftCrumb s _:_)
317 |   | axis s == Horizontal = Just z >>= goSibling >>= expandTreeTowards diff U
318 | shrinkTreeFrom diff U z@(_, RightCrumb s _:_)
319 |   | axis s == Horizontal = Just z >>= goSibling >>= expandTreeTowards diff D
320 | shrinkTreeFrom diff dir z = goUp z >>= shrinkTreeFrom diff dir
321 | 
322 | -- Direction2D refers to which direction the divider should move.
323 | autoSizeTree :: Rational -> Direction2D -> Zipper Split -> Maybe (Zipper Split)
324 | autoSizeTree _ _ z@(_, []) = Just z
325 | autoSizeTree diff d z =
326 |     Just z >>= getSplit (toAxis d) >>= resizeTree diff d
327 | 
328 | -- resizing once found the correct split. YOU MUST FIND THE RIGHT SPLIT FIRST.
329 | resizeTree :: Rational -> Direction2D -> Zipper Split -> Maybe (Zipper Split)
330 | resizeTree _ _ z@(_, []) = Just z
331 | resizeTree diff R z@(_, LeftCrumb _ _:_) =
332 |   Just z >>= expandTreeTowards diff R
333 | resizeTree diff L z@(_, LeftCrumb _ _:_) =
334 |   Just z >>= shrinkTreeFrom    diff R
335 | resizeTree diff U z@(_, LeftCrumb _ _:_) =
336 |   Just z >>= shrinkTreeFrom    diff D
337 | resizeTree diff D z@(_, LeftCrumb _ _:_) =
338 |   Just z >>= expandTreeTowards diff D
339 | resizeTree diff R z@(_, RightCrumb _ _:_) =
340 |   Just z >>= shrinkTreeFrom    diff L
341 | resizeTree diff L z@(_, RightCrumb _ _:_) =
342 |   Just z >>= expandTreeTowards diff L
343 | resizeTree diff U z@(_, RightCrumb _ _:_) =
344 |   Just z >>= expandTreeTowards diff U
345 | resizeTree diff D z@(_, RightCrumb _ _:_) =
346 |   Just z >>= shrinkTreeFrom    diff U
347 | 
348 | getSplit :: Axis -> Zipper Split -> Maybe (Zipper Split)
349 | getSplit _ (_, []) = Nothing
350 | getSplit d z =
351 |  do let fs = findSplit d z
352 |     if isNothing fs
353 |       then findClosest d z
354 |       else fs
355 | 
356 | findClosest :: Axis -> Zipper Split -> Maybe (Zipper Split)
357 | findClosest _ z@(_, []) = Just z
358 | findClosest d z@(_, LeftCrumb s _:_)
359 |   | axis s == d = Just z
360 | findClosest d z@(_, RightCrumb s _:_)
361 |   | axis s == d = Just z
362 | findClosest d z = goUp z >>= findClosest d
363 | 
364 | findSplit :: Axis -> Zipper Split -> Maybe (Zipper Split)
365 | findSplit _ (_, []) = Nothing
366 | findSplit d z@(_, LeftCrumb s _:_)
367 |   | axis s == d = Just z
368 | findSplit d z = goUp z >>= findSplit d
369 | 
370 | resizeSplit :: Direction2D -> (Rational,Rational) -> Zipper Split -> Maybe (Zipper Split)
371 | resizeSplit _ _ z@(_, []) = Just z
372 | resizeSplit dir (xsc,ysc) z = case goToBorder dir z of
373 |   Nothing -> Just z
374 |   Just (t, crumb) -> Just $ case dir of
375 |     R -> (t{value=sp{ratio=scaleRatio (ratio sp) xsc}}, crumb)
376 |     D -> (t{value=sp{ratio=scaleRatio (ratio sp) ysc}}, crumb)
377 |     L -> (t{value=sp{ratio=1-scaleRatio (1-ratio sp) xsc}}, crumb)
378 |     U -> (t{value=sp{ratio=1-scaleRatio (1-ratio sp) ysc}}, crumb)
379 |     where sp = value t
380 |           scaleRatio r fac = min 0.9 $ max 0.1 $ r*fac
381 | 
382 | -- starting from a leaf, go to node representing a border of the according window
383 | goToBorder :: Direction2D -> Zipper Split -> Maybe (Zipper Split)
384 | goToBorder L z@(_, RightCrumb (Split Vertical _) _:_) = goUp z
385 | goToBorder L z = goUp z >>= goToBorder L
386 | goToBorder R z@(_, LeftCrumb  (Split Vertical _) _:_) = goUp z
387 | goToBorder R z = goUp z >>= goToBorder R
388 | goToBorder U z@(_, RightCrumb (Split Horizontal _) _:_) = goUp z
389 | goToBorder U z = goUp z >>= goToBorder U
390 | goToBorder D z@(_, LeftCrumb  (Split Horizontal _) _:_) = goUp z
391 | goToBorder D z = goUp z >>= goToBorder D
392 | 
393 | -- takes a list of indices and numerates the leaves of a given tree
394 | numerate :: [Int] -> Tree a -> Tree a
395 | numerate ns t = snd $ num ns t
396 |   where num (n:nns) (Leaf _) = (nns, Leaf n)
397 |         num [] (Leaf _) = ([], Leaf 0)
398 |         num n (Node s l r) = (n'', Node s nl nr)
399 |           where (n', nl)  = num n l
400 |                 (n'', nr) = num n' r
401 | 
402 | -- return values of leaves from left to right as list
403 | flatten :: Tree a -> [Int]
404 | flatten (Leaf n) = [n]
405 | flatten (Node _ l r) = flatten l++flatten r
406 | 
407 | -- adjust ratios to make window areas equal
408 | equalize :: Zipper Split -> Maybe (Zipper Split)
409 | equalize (t, cs) = Just (eql t, cs)
410 |   where eql (Leaf n) = Leaf n
411 |         eql n@(Node s l r) = Node s{ratio=fromIntegral (numLeaves l) % fromIntegral (numLeaves n)}
412 |                                   (eql l) (eql r)
413 | 
414 | -- generate a symmetrical balanced tree for n leaves from given tree, preserving leaf labels
415 | balancedTree :: Zipper Split -> Maybe (Zipper Split)
416 | balancedTree (t, cs) =  Just (numerate (flatten t) $ balanced (numLeaves t), cs)
417 |   where balanced 1 = Leaf 0
418 |         balanced 2 = Node (Split Horizontal 0.5) (Leaf 0) (Leaf 0)
419 |         balanced m = Node (Split Horizontal 0.5) (balanced (m`div`2)) (balanced (m-m`div`2))
420 | 
421 | -- attempt to rotate splits optimally in order choose more quad-like rects
422 | optimizeOrientation :: Rectangle -> Zipper Split -> Maybe (Zipper Split)
423 | optimizeOrientation rct (t, cs) = Just (opt t rct, cs)
424 |   where opt (Leaf v) _ = Leaf v
425 |         opt (Node sp l r) rect = Node sp' (opt l lrect) (opt r rrect)
426 |          where (Rectangle _ _ w1 h1,Rectangle _ _ w2 h2) = split (axis sp) (ratio sp) rect
427 |                (Rectangle _ _ w3 h3,Rectangle _ _ w4 h4) = split (axis $ oppositeSplit sp) (ratio sp) rect
428 |                f w h = if w > h then w'/h' else h'/w' where (w',h') = (fromIntegral w :: Double, fromIntegral h :: Double)
429 |                wratio = min (f w1 h1) (f w2 h2)
430 |                wratio' = min (f w3 h3) (f w4 h4)
431 |                sp' = if wratio<wratio' then sp else oppositeSplit sp
432 |                (lrect, rrect) = split (axis sp') (ratio sp') rect
433 | 
434 | 
435 | -- initially focused leaf, path from root to selected node, window ids of borders highlighting the selection
436 | data NodeRef = NodeRef { refLeaf :: Int, refPath :: [Direction2D], refWins :: [Window] } deriving (Show,Read,Eq)
437 | noRef = NodeRef (-1) [] []
438 | 
439 | goToNode :: NodeRef -> Zipper a -> Maybe (Zipper a)
440 | goToNode (NodeRef _ dirs _) z = foldM gofun z dirs
441 |   where gofun z' L = goLeft z'
442 |         gofun z' R = goRight z'
443 |         gofun _ _ = Nothing
444 | 
445 | toNodeRef :: Int -> Maybe (Zipper Split) -> NodeRef
446 | toNodeRef _ Nothing = noRef
447 | toNodeRef l (Just (_, cs)) = NodeRef l (reverse $ map crumbToDir cs) []
448 |   where crumbToDir (LeftCrumb _ _) = L
449 |         crumbToDir (RightCrumb _ _) = R
450 | 
451 | -- returns the leaf a noderef is leading to, if any
452 | nodeRefToLeaf :: NodeRef -> Maybe (Zipper a) -> Maybe Int
453 | nodeRefToLeaf n (Just z) = case goToNode n z of
454 |   Just (Leaf l, _) -> Just l
455 |   Just (Node _ _ _, _) -> Nothing
456 |   Nothing -> Nothing
457 | nodeRefToLeaf _ Nothing = Nothing
458 | 
459 | leafToNodeRef :: Int -> BinarySpacePartition a -> NodeRef
460 | leafToNodeRef l b = toNodeRef l (makeZipper b >>= goToNthLeaf l)
461 | 
462 | data BinarySpacePartition a = BinarySpacePartition { getOldRects :: [(Window,Rectangle)]
463 |                                                    , getFocusedNode :: NodeRef
464 |                                                    , getSelectedNode :: NodeRef
465 |                                                    , getTree :: Maybe (Tree Split) } deriving (Show, Read,Eq)
466 | 
467 | -- | an empty BinarySpacePartition to use as a default for adding windows to.
468 | emptyBSP :: BinarySpacePartition a
469 | emptyBSP = BinarySpacePartition [] noRef noRef Nothing
470 | 
471 | makeBSP :: Tree Split -> BinarySpacePartition a
472 | makeBSP = BinarySpacePartition [] noRef noRef . Just
473 | 
474 | makeZipper :: BinarySpacePartition a -> Maybe (Zipper Split)
475 | makeZipper (BinarySpacePartition _ _ _ Nothing) = Nothing
476 | makeZipper (BinarySpacePartition _ _ _ (Just t)) = Just . toZipper $ t
477 | 
478 | size :: BinarySpacePartition a -> Int
479 | size = maybe 0 numLeaves . getTree
480 | 
481 | zipperToBinarySpacePartition :: Maybe (Zipper Split) -> BinarySpacePartition b
482 | zipperToBinarySpacePartition Nothing = emptyBSP
483 | zipperToBinarySpacePartition (Just z) = BinarySpacePartition [] noRef noRef . Just . toTree . top $ z
484 | 
485 | rectangles :: BinarySpacePartition a -> Rectangle -> [Rectangle]
486 | rectangles (BinarySpacePartition _ _ _ Nothing) _ = []
487 | rectangles (BinarySpacePartition _ _ _ (Just (Leaf _))) rootRect = [rootRect]
488 | rectangles (BinarySpacePartition _ _ _ (Just node)) rootRect =
489 |     rectangles (makeBSP . left $ node) leftBox ++
490 |     rectangles (makeBSP . right $ node) rightBox
491 |     where (leftBox, rightBox) = split (axis info) (ratio info) rootRect
492 |           info = value node
493 | 
494 | getNodeRect :: BinarySpacePartition a -> Rectangle -> NodeRef -> Rectangle
495 | getNodeRect b r n = fromMaybe (Rectangle 0 0 1 1) (makeZipper b >>= goToNode n >>= getRect [])
496 |   where getRect ls (_, []) = Just $ foldl (\r' (s,f) -> f $ split' s r') r ls
497 |         getRect ls z@(_, LeftCrumb s _:_) = goUp z >>= getRect ((s,fst):ls)
498 |         getRect ls z@(_, RightCrumb s _:_) = goUp z >>= getRect ((s,snd):ls)
499 |         split' s = split (axis s) (ratio s)
500 | 
501 | doToNth :: (Zipper Split -> Maybe (Zipper Split)) -> BinarySpacePartition a -> BinarySpacePartition a
502 | doToNth f b = b{getTree=getTree $ zipperToBinarySpacePartition $ makeZipper b >>= goToNode (getFocusedNode b) >>= f}
503 | 
504 | splitNth :: Rectangle -> BinarySpacePartition a -> BinarySpacePartition a
505 | splitNth _ (BinarySpacePartition _ _ _ Nothing) = makeBSP (Leaf 0)
506 | splitNth r b =
507 |   let rects = rectangles b r
508 |       NodeRef idx _ _  = getFocusedNode b
509 |       focusedRect = if idx >= 0 && idx <= (length rects)
510 |                     then rects !! idx
511 |                     else r
512 |   in doToNth (splitCurrent focusedRect) b
513 | 
514 | removeNth :: BinarySpacePartition a -> BinarySpacePartition a
515 | removeNth (BinarySpacePartition _ _ _ Nothing) = emptyBSP
516 | removeNth (BinarySpacePartition _ _ _ (Just (Leaf _))) = emptyBSP
517 | removeNth b = doToNth removeCurrent b
518 | 
519 | rotateNth :: BinarySpacePartition a -> BinarySpacePartition a
520 | rotateNth (BinarySpacePartition _ _ _ Nothing) = emptyBSP
521 | rotateNth b@(BinarySpacePartition _ _ _ (Just (Leaf _))) = b
522 | rotateNth b = doToNth rotateCurrent b
523 | 
524 | swapNth :: BinarySpacePartition a -> BinarySpacePartition a
525 | swapNth (BinarySpacePartition _ _ _ Nothing) = emptyBSP
526 | swapNth b@(BinarySpacePartition _ _ _ (Just (Leaf _))) = b
527 | swapNth b = doToNth swapCurrent b
528 | 
529 | growNthTowards :: Rational -> Direction2D -> BinarySpacePartition a -> BinarySpacePartition a
530 | growNthTowards _ _ (BinarySpacePartition _ _ _ Nothing) = emptyBSP
531 | growNthTowards _ _ b@(BinarySpacePartition _ _ _ (Just (Leaf _))) = b
532 | growNthTowards diff dir b = doToNth (expandTreeTowards diff dir) b
533 | 
534 | shrinkNthFrom :: Rational -> Direction2D -> BinarySpacePartition a -> BinarySpacePartition a
535 | shrinkNthFrom _ _ (BinarySpacePartition _ _ _ Nothing)= emptyBSP
536 | shrinkNthFrom _ _ b@(BinarySpacePartition _ _ _ (Just (Leaf _))) = b
537 | shrinkNthFrom diff dir b = doToNth (shrinkTreeFrom diff dir) b
538 | 
539 | autoSizeNth :: Rational -> Direction2D -> BinarySpacePartition a -> BinarySpacePartition a
540 | autoSizeNth _ _ (BinarySpacePartition _ _ _ Nothing) = emptyBSP
541 | autoSizeNth _ _ b@(BinarySpacePartition _ _ _ (Just (Leaf _))) = b
542 | autoSizeNth diff dir b = doToNth (autoSizeTree diff dir) b
543 | 
544 | resizeSplitNth :: Direction2D -> (Rational,Rational) -> BinarySpacePartition a -> BinarySpacePartition a
545 | resizeSplitNth _ _ (BinarySpacePartition _ _ _ Nothing) = emptyBSP
546 | resizeSplitNth _ _ b@(BinarySpacePartition _ _ _ (Just (Leaf _))) = b
547 | resizeSplitNth dir sc b = doToNth (resizeSplit dir sc) b
548 | 
549 | -- rotate tree left or right around parent of nth leaf
550 | rotateTreeNth :: Direction2D -> BinarySpacePartition a -> BinarySpacePartition a
551 | rotateTreeNth _ (BinarySpacePartition _ _ _ Nothing) = emptyBSP
552 | rotateTreeNth U b = b
553 | rotateTreeNth D b = b
554 | rotateTreeNth dir b@(BinarySpacePartition _ _ _ (Just _)) =
555 |   doToNth (\t -> case goUp t of
556 |                 Nothing     -> Just t
557 |                 Just (t', c) -> Just (rotTree dir t', c)) b
558 | 
559 | equalizeNth :: BinarySpacePartition a -> BinarySpacePartition a
560 | equalizeNth (BinarySpacePartition _ _ _ Nothing) = emptyBSP
561 | equalizeNth b@(BinarySpacePartition _ _ _ (Just (Leaf _))) = b
562 | equalizeNth b = doToNth equalize b
563 | 
564 | rebalanceNth :: BinarySpacePartition a -> Rectangle -> BinarySpacePartition a
565 | rebalanceNth (BinarySpacePartition _ _ _ Nothing) _ = emptyBSP
566 | rebalanceNth b@(BinarySpacePartition _ _ _ (Just (Leaf _))) _ = b
567 | rebalanceNth b r = doToNth (balancedTree >=> optimizeOrientation r) b
568 | 
569 | flattenLeaves :: BinarySpacePartition a -> [Int]
570 | flattenLeaves (BinarySpacePartition _ _ _ Nothing) = []
571 | flattenLeaves (BinarySpacePartition _ _ _ (Just t)) = flatten t
572 | 
573 | -- we do this before an action to look afterwards which leaves moved where
574 | numerateLeaves :: BinarySpacePartition a -> BinarySpacePartition a
575 | numerateLeaves b@(BinarySpacePartition _ _ _ Nothing) = b
576 | numerateLeaves b@(BinarySpacePartition _ _ _ (Just t)) = b{getTree=Just $ numerate ns t}
577 |   where ns = [0..(numLeaves t-1)]
578 | 
579 | -- if there is a selected and focused node and the focused is not a part of selected,
580 | -- move selected node to be a child of focused node
581 | moveNode :: BinarySpacePartition a -> BinarySpacePartition a
582 | moveNode b@(BinarySpacePartition _ (NodeRef (-1) _ _) _ _) = b
583 | moveNode b@(BinarySpacePartition _ _ (NodeRef (-1) _ _) _) = b
584 | moveNode b@(BinarySpacePartition _ _ _ Nothing) = b
585 | moveNode b@(BinarySpacePartition _ f s (Just ot)) =
586 |   case makeZipper b >>= goToNode s of
587 |     Just (n, LeftCrumb _ t:cs)  -> b{getTree=Just $ insert n $ top (t, cs)}
588 |     Just (n, RightCrumb _ t:cs) -> b{getTree=Just $ insert n $ top (t, cs)}
589 |     _ -> b
590 |   where insert t z = case goToNode f z of
591 |           Nothing -> ot --return original tree (abort)
592 |           Just (n, c:cs) -> toTree (Node (Split (oppositeAxis . axis . parentVal $ c) 0.5) t n, c:cs)
593 |           Just (n, []) -> toTree (Node (Split Vertical 0.5) t n, [])
594 | 
595 | ------------------------------------------
596 | 
597 | -- returns index of focused window or 0 for empty stack
598 | index :: W.Stack a -> Int
599 | index s = case toIndex (Just s) of
600 |             (_, Nothing) -> 0
601 |             (_, Just int) -> int
602 | 
603 | --move windows to new positions according to tree transformations, keeping focus on originally focused window
604 | --CAREFUL here! introduce a bug here and have fun debugging as your windows start to disappear or explode
605 | adjustStack :: Maybe (W.Stack Window)  --original stack
606 |             -> Maybe (W.Stack Window)  --stack without floating windows
607 |             -> [Window]                --just floating windows of this WS
608 |             -> Maybe (BinarySpacePartition Window) -- Tree with numbered leaves telling what to move where
609 |             -> Maybe (W.Stack Window)  --resulting stack
610 | adjustStack orig Nothing _ _ = orig    --no new stack -> no changes
611 | adjustStack orig _ _ Nothing = orig    --empty tree   -> no changes
612 | adjustStack orig s fw (Just b) =
613 |  if length ls<length ws then orig      --less leaves than non-floating windows -> tree incomplete, no changes
614 |  else fromIndex ws' fid'
615 |  where ws' = mapMaybe (`M.lookup` wsmap) ls ++ fw
616 |        fid' = fromMaybe 0 $ elemIndex focused ws'
617 |        wsmap = M.fromList $ zip [0..] ws -- map: old index in list -> window
618 |        ls = flattenLeaves b              -- get new index ordering from tree
619 |        (ws,fid) = toIndex s
620 |        focused = ws !! fromMaybe 0 fid
621 | 
622 | --replace the window stack of the managed workspace with our modified stack
623 | replaceStack :: Maybe (W.Stack Window) -> X ()
624 | replaceStack s = do
625 |   st <- get
626 |   let wset = windowset st
627 |       cur  = W.current wset
628 |       wsp  = W.workspace cur
629 |   put st{windowset=wset{W.current=cur{W.workspace=wsp{W.stack=s}}}}
630 | 
631 | replaceFloating :: M.Map Window W.RationalRect -> X ()
632 | replaceFloating wsm = do
633 |   st <- get
634 |   let wset = windowset st
635 |   put st{windowset=wset{W.floating=wsm}}
636 | 
637 | -- some helpers to filter windows
638 | --
639 | getFloating :: X [Window]
640 | getFloating = (M.keys . W.floating) <$> gets windowset -- all floating windows
641 | 
642 | getStackSet :: X (Maybe (W.Stack Window))
643 | getStackSet = (W.stack . W.workspace . W.current) <$> gets windowset -- windows on this WS (with floating)
644 | 
645 | getScreenRect :: X Rectangle
646 | getScreenRect = (screenRect . W.screenDetail . W.current) <$> gets windowset
647 | 
648 | withoutFloating :: [Window] -> Maybe (W.Stack Window) -> Maybe (W.Stack Window)
649 | withoutFloating fs = maybe Nothing (unfloat fs)
650 | 
651 | -- ignore messages if current focus is on floating window, otherwise return stack without floating
652 | unfloat :: [Window] -> W.Stack Window -> Maybe (W.Stack Window)
653 | unfloat fs s = if W.focus s `elem` fs
654 |       then Nothing
655 |       else Just $ s{W.up = W.up s \\ fs, W.down = W.down s \\ fs}
656 | 
657 | instance LayoutClass BinarySpacePartition Window where
658 |   doLayout b r s = do
659 |     let b' = layout b
660 |     b'' <- updateNodeRef b' (size b/=size b') r
661 |     let rs = rectangles b'' r
662 |         wrs = zip ws rs
663 |     return (wrs, Just b''{getOldRects=wrs})
664 |     where
665 |       ws = W.integrate s
666 |       l = length ws
667 |       layout bsp
668 |         | l == sz = bsp
669 |         | l > sz = layout $ splitNth r bsp
670 |         | otherwise = layout $ removeNth bsp
671 |         where sz = size bsp
672 | 
673 |   handleMessage b_orig m
674 |    | Just msg@(SetGeometry _) <- fromMessage m = handleResize b msg
675 |    | Just FocusParent <- fromMessage m = do
676 |        let n = getFocusedNode b
677 |        let n' = toNodeRef (refLeaf n) (makeZipper b >>= goToNode n >>= goUp)
678 |        return $ Just b{getFocusedNode=n'{refWins=refWins n}}
679 |    | Just SelectNode <- fromMessage m = do
680 |        let n = getFocusedNode b
681 |        let s = getSelectedNode b
682 |        removeBorder $ refWins s
683 |        let s' = if refLeaf n == refLeaf s && refPath n == refPath s
684 |                 then noRef else n{refWins=[]}
685 |        return $ Just b{getSelectedNode=s'}
686 |    | otherwise = do
687 |        ws <- getStackSet
688 |        fs <- getFloating
689 |        r <- getScreenRect
690 |        -- removeBorder $ refWins $ getSelectedNode b
691 |        let lws = withoutFloating fs ws                                    -- tiled windows on WS
692 |            lfs = maybe [] W.integrate ws \\ maybe [] W.integrate lws      -- untiled windows on WS
693 |            b'  = handleMesg r                -- transform tree (concerns only tiled windows)
694 |            ws' = adjustStack ws lws lfs b'   -- apply transformation to window stack, reintegrate floating wins
695 |        replaceStack ws'
696 |        return b'
697 |     where handleMesg r = msum [ fmap resize        (fromMessage m)
698 |                               , fmap rotate        (fromMessage m)
699 |                               , fmap swap          (fromMessage m)
700 |                               , fmap rotateTr      (fromMessage m)
701 |                               , fmap (balanceTr r) (fromMessage m)
702 |                               , fmap move          (fromMessage m)
703 |                               ]
704 |           resize (ExpandTowardsDelta diff dir) = growNthTowards diff dir b
705 |           resize (ExpandTowards dir) = growNthTowards resizeDiff dir b
706 |           resize (ShrinkFromDelta diff dir) = shrinkNthFrom diff dir b
707 |           resize (ShrinkFrom dir) = shrinkNthFrom resizeDiff dir b
708 |           resize (MoveSplitDelta diff dir) = autoSizeNth diff dir b
709 |           resize (MoveSplit dir) = autoSizeNth resizeDiff dir b
710 |           rotate Rotate = resetFoc $ rotateNth b
711 |           swap Swap = resetFoc $ swapNth b
712 |           rotateTr RotateL = resetFoc $ rotateTreeNth L b
713 |           rotateTr RotateR = resetFoc $ rotateTreeNth R b
714 |           balanceTr _ Equalize = resetFoc $ equalizeNth b
715 |           balanceTr r Balance  = resetFoc $ rebalanceNth b r
716 |           move MoveNode = resetFoc $ moveNode b
717 |           move SelectNode = b --should not happen here, is done above, as we need X monad
718 | 
719 |           b = numerateLeaves b_orig
720 |           resetFoc bsp = bsp{getFocusedNode=(getFocusedNode bsp){refLeaf=(-1)}
721 |                             ,getSelectedNode=(getSelectedNode bsp){refLeaf=(-1)}}
722 | 
723 |   description _  = "BSP"
724 | 
725 | -- React to SetGeometry message to work with BorderResize/MouseResize
726 | handleResize :: BinarySpacePartition Window -> WindowArrangerMsg -> X (Maybe (BinarySpacePartition Window))
727 | handleResize b (SetGeometry newrect@(Rectangle _ _ w h)) = do
728 |   ws <- getStackSet
729 |   fs <- getFloating
730 |   case W.focus <$> ws of
731 |     Nothing -> return Nothing
732 |     Just win -> do
733 |       (_,_,_,_,_,mx,my,_) <- withDisplay (\d -> io $ queryPointer d win)
734 |       let oldrect@(Rectangle _ _ ow oh) = fromMaybe (Rectangle 0 0 0 0) $ lookup win $ getOldRects b
735 |       let (xsc,ysc)   = (fi w % fi ow, fi h % fi oh)
736 |           (xsc',ysc') = (rough xsc, rough ysc)
737 |           dirs = changedDirs oldrect newrect (fi mx,fi my)
738 |           n = elemIndex win $ maybe [] W.integrate $ withoutFloating fs ws
739 |       -- unless (isNothing dir) $ debug $
740 |       --       show (fi x-fi ox,fi y-fi oy) ++ show (fi w-fi ow,fi h-fi oh)
741 |       --       ++ show dir ++ " " ++ show win ++ " " ++ show (mx,my)
742 |       return $ case n of
743 |                 Just _ -> Just $ foldl' (\b' d -> resizeSplitNth d (xsc',ysc') b') b dirs
744 |                 Nothing -> Nothing --focused window is floating -> ignore
745 |   where rough v = min 1.5 $ max 0.75 v -- extreme scale factors are forbidden
746 | handleResize _ _ = return Nothing
747 | 
748 | -- find out which borders have been pulled. We need the old and new rects and the mouse coordinates
749 | changedDirs :: Rectangle -> Rectangle -> (Int,Int) -> [Direction2D]
750 | changedDirs (Rectangle _ _ ow oh) (Rectangle _ _ w h) (mx,my) = catMaybes [lr, ud]
751 |  where lr = if ow==w then Nothing
752 |             else Just (if (fi mx :: Double) >  (fi ow :: Double)/2 then R else L)
753 |        ud = if oh==h then Nothing
754 |             else Just (if (fi my :: Double) > (fi oh :: Double)/2 then D else U)
755 | 
756 | -- node focus border helpers
757 | ----------------------------
758 | updateNodeRef :: BinarySpacePartition Window -> Bool -> Rectangle -> X (BinarySpacePartition Window)
759 | updateNodeRef b force r = do
760 |     let n = getFocusedNode b
761 |     let s = getSelectedNode b
762 |     removeBorder (refWins n++refWins s)
763 |     l <- getCurrFocused
764 |     b' <- if refLeaf n /= l || refLeaf n == (-1) || force
765 |             then return b{getFocusedNode=leafToNodeRef l b}
766 |             else return b
767 |     b'' <- if force then return b'{getSelectedNode=noRef} else return b'
768 |     renderBorders r b''
769 |   where getCurrFocused = maybe 0 index <$> (withoutFloating <$> getFloating <*> getStackSet)
770 | 
771 | -- create border around focused node if necessary
772 | renderBorders :: Rectangle -> BinarySpacePartition a -> X (BinarySpacePartition a)
773 | renderBorders r b = do
774 |   let l = nodeRefToLeaf (getFocusedNode b) $ makeZipper b
775 |   wssel <- if refLeaf (getSelectedNode b)/=(-1)
776 |            then createBorder (getNodeRect b r (getSelectedNode b)) $ Just "#00ff00"
777 |            else return []
778 |   let b' = b{getSelectedNode=(getSelectedNode b){refWins=wssel}}
779 |   if refLeaf (getFocusedNode b')==(-1) || isJust l || size b'<2 then return b'
780 |     else do
781 |       ws' <- createBorder (getNodeRect b' r (getFocusedNode b')) Nothing
782 |       return b'{getFocusedNode=(getFocusedNode b'){refWins=ws'}}
783 | 
784 | -- create a window for each border line, show, add into stack and set floating
785 | createBorder :: Rectangle -> Maybe String -> X [Window]
786 | createBorder (Rectangle wx wy ww wh) c = do
787 |   bw <- asks (borderWidth.config)
788 |   bc <- case c of
789 |          Nothing -> asks (focusedBorderColor.config)
790 |          Just s -> return s
791 |   let rects = [ Rectangle wx wy ww (fi bw)
792 |               , Rectangle wx wy (fi bw) wh
793 |               , Rectangle wx (wy+fi wh-fi bw) ww (fi bw)
794 |               , Rectangle (wx+fi ww-fi bw) wy (fi bw) wh
795 |               ]
796 |   ws <- mapM (\r -> createNewWindow r Nothing bc False) rects
797 |   showWindows ws
798 |   maybe Nothing (\s -> Just s{W.down=W.down s ++ ws}) <$> getStackSet >>= replaceStack
799 |   M.union (M.fromList $ zip ws $ map toRR rects) . W.floating . windowset <$> get >>= replaceFloating
800 |   modify (\s -> s{mapped=mapped s `S.union` S.fromList ws})
801 |   -- show <$> mapM isClient ws >>= debug
802 |   return ws
803 |   where toRR (Rectangle x y w h) = W.RationalRect (fi x) (fi y) (fi w) (fi h)
804 | 
805 | -- remove border line windows from stack + floating, kill
806 | removeBorder :: [Window] -> X ()
807 | removeBorder ws = do
808 |   modify (\s -> s{mapped = mapped s `S.difference` S.fromList ws})
809 |   flip (foldl (flip M.delete)) ws . W.floating . windowset <$> get >>= replaceFloating
810 |   maybe Nothing (\s -> Just s{W.down=W.down s \\ ws}) <$> getStackSet >>= replaceStack
811 |   deleteWindows ws
812 | 


--------------------------------------------------------------------------------
/XMonad/Layout/Spacing.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-}
  2 | 
  3 | -----------------------------------------------------------------------------
  4 | -- |
  5 | -- Module      :  XMonad.Layout.Spacing
  6 | -- Copyright   :  (c) Brent Yorgey
  7 | -- License     :  BSD-style (see LICENSE)
  8 | --
  9 | -- Maintainer  :  <byorgey@gmail.com>
 10 | -- Stability   :  unstable
 11 | -- Portability :  portable
 12 | --
 13 | -- Add a configurable amount of space around windows.
 14 | -----------------------------------------------------------------------------
 15 | 
 16 | module XMonad.Layout.Spacing (
 17 |                                -- * Usage
 18 |                                -- $usage
 19 | 
 20 |                                spacing, Spacing,
 21 |                                spacingWithEdge, SpacingWithEdge,
 22 |                                smartSpacing, SmartSpacing,
 23 |                                smartSpacingWithEdge, SmartSpacingWithEdge,
 24 |                                SpacingMsg(..)
 25 |                              ) where
 26 | 
 27 | import Graphics.X11 (Rectangle(..))
 28 | import Control.Arrow (second)
 29 | import XMonad.Core (runLayout,Message,fromMessage,Typeable)
 30 | import XMonad.StackSet (up, down, Workspace(..))
 31 | import XMonad.Util.Font (fi)
 32 | 
 33 | import XMonad.Layout.LayoutModifier
 34 | 
 35 | -- $usage
 36 | -- You can use this module by importing it into your @~\/.xmonad\/xmonad.hs@ file:
 37 | --
 38 | -- > import XMonad.Layout.Spacing
 39 | --
 40 | -- and modifying your layoutHook as follows (for example):
 41 | --
 42 | -- > layoutHook = spacing 2 $ Tall 1 (3/100) (1/2)
 43 | -- >                      -- put a 2px space around every window
 44 | --
 45 | 
 46 | -- | Surround all windows by a certain number of pixels of blank space.
 47 | spacing :: Int -> l a -> ModifiedLayout Spacing l a
 48 | spacing p = ModifiedLayout (Spacing p)
 49 | 
 50 | data Spacing a = Spacing Int deriving (Show, Read)
 51 | 
 52 | -- | Message to dynamically increase/decrease/set the size of the window spacing
 53 | data SpacingMsg = SetSpacing Int | IncSpacing Int deriving (Show,Read,Eq,Typeable)
 54 | instance Message SpacingMsg
 55 | 
 56 | instance LayoutModifier Spacing a where
 57 | 
 58 |     pureModifier (Spacing p) _ _ wrs = (map (second $ shrinkRect p) wrs, Nothing)
 59 | 
 60 |     pureMess (Spacing px) m
 61 |      | Just (SetSpacing px') <- fromMessage m = Just $ Spacing (max 0 px')
 62 |      | Just (IncSpacing n)   <- fromMessage m = Just $ Spacing (max 0 (px+n))
 63 |      | otherwise = Nothing
 64 | 
 65 |     modifierDescription (Spacing p) = "Spacing " ++ show p
 66 | 
 67 | -- | Surround all windows by a certain number of pixels of blank space, and
 68 | -- additionally adds the same amount of spacing around the edge of the screen.
 69 | spacingWithEdge :: Int -> l a -> ModifiedLayout SpacingWithEdge l a
 70 | spacingWithEdge p = ModifiedLayout (SpacingWithEdge p)
 71 | 
 72 | data SpacingWithEdge a = SpacingWithEdge Int deriving (Show, Read)
 73 | 
 74 | instance LayoutModifier SpacingWithEdge a where
 75 | 
 76 |     pureModifier (SpacingWithEdge p) _ _ wrs = (map (second $ shrinkRect p) wrs, Nothing)
 77 | 
 78 |     pureMess (SpacingWithEdge px) m
 79 |      | Just (SetSpacing px') <- fromMessage m = Just $ SpacingWithEdge (max 0 px')
 80 |      | Just (IncSpacing n)   <- fromMessage m = Just $ SpacingWithEdge (max 0 (px+n))
 81 |      | otherwise = Nothing
 82 | 
 83 |     modifyLayout (SpacingWithEdge p) w r = runLayout w (shrinkRect p r)
 84 | 
 85 |     modifierDescription (SpacingWithEdge p) = "SpacingWithEdge " ++ show p
 86 | 
 87 | shrinkRect :: Int -> Rectangle -> Rectangle
 88 | shrinkRect p (Rectangle x y w h) = Rectangle (x+fi p) (y+fi p) (w-2*fi p) (h-2*fi p)
 89 | 
 90 | -- | Surrounds all windows with blank space, except when the window is the only
 91 | -- visible window on the current workspace.
 92 | smartSpacing :: Int -> l a -> ModifiedLayout SmartSpacing l a
 93 | smartSpacing p = ModifiedLayout (SmartSpacing p)
 94 | 
 95 | data SmartSpacing a = SmartSpacing Int deriving (Show, Read)
 96 | 
 97 | instance LayoutModifier SmartSpacing a where
 98 | 
 99 |     pureModifier _ _ _ [x] = ([x], Nothing)
100 |     pureModifier (SmartSpacing p) _ _ wrs = (map (second $ shrinkRect p) wrs, Nothing)
101 | 
102 |     modifierDescription (SmartSpacing p) = "SmartSpacing " ++ show p
103 | 
104 | -- | Surrounds all windows with blank space, and adds the same amount of spacing
105 | -- around the edge of the screen, except when the window is the only visible
106 | -- window on the current workspace.
107 | smartSpacingWithEdge :: Int -> l a -> ModifiedLayout SmartSpacingWithEdge l a
108 | smartSpacingWithEdge p = ModifiedLayout (SmartSpacingWithEdge p)
109 | 
110 | data SmartSpacingWithEdge a = SmartSpacingWithEdge Int deriving (Show, Read)
111 | 
112 | instance LayoutModifier SmartSpacingWithEdge a where
113 | 
114 |     pureModifier _ _ _ [x] = ([x], Nothing)
115 |     pureModifier (SmartSpacingWithEdge p) _ _ wrs = (map (second $ shrinkRect p) wrs, Nothing)
116 | 
117 |     modifyLayout (SmartSpacingWithEdge p) w r
118 |         | maybe False (\s -> null (up s) && null (down s)) (stack w) = runLayout w r
119 |         | otherwise = runLayout w (shrinkRect p r)
120 | 
121 |     modifierDescription (SmartSpacingWithEdge p) = "SmartSpacingWithEdge " ++ show p
122 | 


--------------------------------------------------------------------------------