Move mouse pointer only when needed on :sloppy-select-window focus policy
[clfswm.git] / src / clfswm-layout.lisp
blobef1ce7367bc1213369077fe1f417c79feec3acf8
1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
3 ;;;
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Layout functions
6 ;;; --------------------------------------------------------------------------
7 ;;;
8 ;;; (C) 2012 Philippe Brochard <pbrochard@common-lisp.net>
9 ;;;
10 ;;; This program is free software; you can redistribute it and/or modify
11 ;;; it under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 3 of the License, or
13 ;;; (at your option) any later version.
14 ;;;
15 ;;; This program is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
19 ;;;
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with this program; if not, write to the Free Software
22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
23 ;;;
24 ;;; --------------------------------------------------------------------------
26 (in-package :clfswm)
29 ;;; CONFIG - Layout menu
30 ;;;
31 ;;; To add a new layout:
32 ;;; 1- define your own layout: a method returning the real size of the
33 ;;; child in screen size (integer) as 4 values (rx, ry, rw, rh).
34 ;;; This method can use the float size of the child (x, y ,w , h).
35 ;;; It can be specialized for xlib:window or frame
36 ;;; 2- Define a setter function for your layout
37 ;;; 3- Register your new layout with register-layout or create
38 ;;; a sub menu for it with register-layout-sub-menu.
42 (defparameter *layout-current-key* (1- (char-code #\a)))
45 ;;; Generic functions
46 (defun set-layout (layout)
47 "Set the layout of the current child"
48 (when (frame-p (current-child))
49 (setf (frame-layout (current-child)) layout)
50 (leave-second-mode)))
52 (defun set-layout-dont-leave (layout)
53 "Set the layout of the current child"
54 (when (frame-p (current-child))
55 (setf (frame-layout (current-child)) layout)))
57 (defun set-layout-once (layout-name)
58 (set-layout-dont-leave layout-name)
59 (show-all-children)
60 (fixe-real-size-current-child)
61 (set-layout-dont-leave #'no-layout))
63 (defun set-layout-simple (layout)
64 "Set the layout of the current child"
65 (set-layout-dont-leave layout)
66 (show-all-children))
68 (defun get-managed-child (parent)
69 "Return only the windows that are managed for tiling"
70 (when (frame-p parent)
71 (remove-if #'(lambda (x)
72 (and (xlib:window-p x) (not (managed-window-p x parent))))
73 (frame-child parent))))
76 (defun next-layout-key ()
77 (code-char (incf *layout-current-key*)))
80 (defun register-layout (layout)
81 (add-menu-key 'frame-layout-menu (next-layout-key) layout))
84 (defun register-layout-sub-menu (name doc layout-list)
85 (add-sub-menu 'frame-layout-menu (next-layout-key) name doc)
86 (loop :for item :in layout-list
87 :for i :from 0
88 :do (typecase item
89 (cons (add-menu-key name (first item) (second item)))
90 (string (add-menu-comment name item))
91 (t (add-menu-key name (number->char i) item)))))
96 (defun layout-ask-size (msg slot &optional (min 80))
97 (when (frame-p (current-child))
98 (let ((new-size (/ (or (query-number msg (* (frame-data-slot (current-child) slot) 100)) min) 100)))
99 (setf (frame-data-slot (current-child) slot) (max (min new-size 0.99) 0.01)))))
101 (defun adjust-layout-size (slot inc)
102 (when (frame-p (current-child))
103 (setf (frame-data-slot (current-child) slot)
104 (max (min (+ (frame-data-slot (current-child) slot) inc) 0.99) 0.01))))
106 (defun inc-tile-layout-size ()
107 "Increase the tile layout size"
108 (adjust-layout-size :tile-size 0.05)
109 (show-all-children))
111 (defun dec-tile-layout-size ()
112 "Decrease the tile layout size"
113 (adjust-layout-size :tile-size -0.05)
114 (show-all-children))
116 (defun inc-slow-tile-layout-size ()
117 "Increase slowly the tile layout size"
118 (adjust-layout-size :tile-size 0.01)
119 (show-all-children))
121 (defun dec-slow-tile-layout-size ()
122 "Decrease slowly the tile layout size"
123 (adjust-layout-size :tile-size -0.01)
124 (show-all-children))
129 (defun fast-layout-switch ()
130 "Switch between two layouts"
131 (when (frame-p (current-child))
132 (with-slots (layout) (current-child)
133 (let* ((layout-list (frame-data-slot (current-child) :fast-layout))
134 (first-layout (ensure-function (first layout-list)))
135 (second-layout (ensure-function (second layout-list))))
136 (setf layout (if (eql layout first-layout)
137 second-layout
138 first-layout))
139 (leave-second-mode)))))
142 (defun push-in-fast-layout-list ()
143 "Push the current layout in the fast layout list"
144 (when (frame-p (current-child))
145 (setf (frame-data-slot (current-child) :fast-layout)
146 (list (frame-layout (current-child))
147 (first (frame-data-slot (current-child) :fast-layout))))
148 (leave-second-mode)))
152 (register-layout-sub-menu 'frame-fast-layout-menu "Frame fast layout menu"
153 '(("s" fast-layout-switch)
154 ("p" push-in-fast-layout-list)))
157 ;;; No layout
158 (defgeneric no-layout (child parent)
159 (:documentation "No layout: Maximize windows in their frame - Leave frames to their original size"))
161 (defmethod no-layout ((child xlib:window) parent)
162 (with-slots (rx ry rw rh) parent
163 (values (adj-border-xy rx parent)
164 (adj-border-xy ry parent)
165 (adj-border-wh rw child)
166 (adj-border-wh rh child))))
168 (defmethod no-layout ((child frame) parent)
169 (values (adj-border-xy (x-fl->px (frame-x child) parent) parent)
170 (adj-border-xy (y-fl->px (frame-y child) parent) parent)
171 (adj-border-wh (w-fl->px (frame-w child) parent) child)
172 (adj-border-wh (h-fl->px (frame-h child) parent) child)))
176 (defun set-no-layout ()
177 "No layout: Maximize windows in their frame - Leave frames to their original size"
178 (set-layout #'no-layout))
180 (register-layout 'set-no-layout)
182 ;;; No layout remember size
183 (defun set-no-layout-remember-size ()
184 "No layout: Maximize windows in their frame - Leave frames to their actual size"
185 (fixe-real-size-current-child)
186 (set-no-layout))
188 (register-layout 'set-no-layout-remember-size)
192 ;;; Maximize layout
193 (defgeneric maximize-layout (child parent)
194 (:documentation "Maximize layout: Maximize windows and frames in their parent frame"))
196 (defmethod maximize-layout (child parent)
197 (with-slots (rx ry rw rh) parent
198 (values (adj-border-xy rx parent)
199 (adj-border-xy ry parent)
200 (adj-border-wh rw child)
201 (adj-border-wh rh child))))
204 (defun set-maximize-layout ()
205 "Maximize layout: Maximize windows and frames in their parent frame"
206 (set-layout #'maximize-layout))
208 (register-layout 'set-maximize-layout)
213 ;;; Tile layout
214 (defun tile-layout-ask-keep-position ()
215 (when (frame-p (current-child))
216 (if (query-yes-or-no "Keep frame children positions?")
217 (setf (frame-data-slot (current-child) :tile-layout-keep-position) :yes)
218 (remove-frame-data-slot (current-child) :tile-layout-keep-position))))
222 (labels ((set-managed ()
223 (setf (frame-data-slot (current-child) :layout-managed-children)
224 (copy-list (get-managed-child (current-child))))))
225 (defun set-layout-managed-children ()
226 (when (frame-p (current-child))
227 (set-managed)
228 (tile-layout-ask-keep-position)))
231 (defun update-layout-managed-children-position ()
232 "Update layout managed children position"
233 (when (frame-p (current-child))
234 (set-managed)
235 (leave-second-mode))))
239 (defun update-layout-managed-children-keep-position (child parent)
240 (declare (ignore child))
241 (let ((managed-children (frame-data-slot parent :layout-managed-children))
242 (managed-in-parent (get-managed-child parent)))
243 (dolist (ch managed-in-parent)
244 (unless (child-member ch managed-children)
245 (setf managed-children (append managed-children (list ch)))))
246 (setf managed-children (remove-if-not (lambda (x)
247 (child-member x managed-in-parent))
248 managed-children))
249 (setf (frame-data-slot parent :layout-managed-children) managed-children)
250 managed-children))
252 (defun update-layout-managed-children (child parent)
253 (if (eql (frame-data-slot parent :tile-layout-keep-position) :yes)
254 (update-layout-managed-children-keep-position child parent)
255 (get-managed-child parent)))
259 (defgeneric tile-layout (child parent)
260 (:documentation "Tile child in its frame (vertical)"))
262 (defmethod tile-layout (child parent)
263 (let* ((managed-children (update-layout-managed-children child parent))
264 (pos (child-position child managed-children))
265 (len (length managed-children))
266 (nx (ceiling (sqrt len)))
267 (ny (ceiling (/ len nx)))
268 (dx (/ (frame-rw parent) nx))
269 (dy (/ (frame-rh parent) ny))
270 (dpos (- (* nx ny) len))
271 (width dx))
272 (when (plusp dpos)
273 (if (zerop pos)
274 (setf width (* dx (1+ dpos)))
275 (incf pos dpos)))
276 (values (round (adj-border-xy (+ (frame-rx parent) (truncate (* (mod pos nx) dx))) parent))
277 (round (adj-border-xy (+ (frame-ry parent) (truncate (* (truncate (/ pos nx)) dy))) parent))
278 (round (adj-border-wh width child))
279 (round (adj-border-wh dy child)))))
281 (defun set-tile-layout ()
282 "Tile child in its frame (vertical)"
283 (set-layout-managed-children)
284 (set-layout #'tile-layout))
288 ;; Horizontal tiling layout
289 (defgeneric tile-horizontal-layout (child parent)
290 (:documentation "Tile child in its frame (horizontal)"))
292 (defmethod tile-horizontal-layout (child parent)
293 (let* ((managed-children (update-layout-managed-children child parent))
294 (pos (child-position child managed-children))
295 (len (length managed-children))
296 (ny (ceiling (sqrt len)))
297 (nx (ceiling (/ len ny)))
298 (dx (/ (frame-rw parent) nx))
299 (dy (/ (frame-rh parent) ny))
300 (dpos (- (* nx ny) len))
301 (height dy))
302 (when (plusp dpos)
303 (if (zerop pos)
304 (setf height (* dy (1+ dpos)))
305 (incf pos dpos)))
306 (values (round (adj-border-xy (+ (frame-rx parent) (truncate (* (truncate (/ pos ny)) dx))) parent))
307 (round (adj-border-xy (+ (frame-ry parent) (truncate (* (mod pos ny) dy))) parent))
308 (round (adj-border-wh dx child))
309 (round (adj-border-wh height child)))))
311 (defun set-tile-horizontal-layout ()
312 "Tile child in its frame (horizontal)"
313 (set-layout-managed-children)
314 (set-layout #'tile-horizontal-layout))
319 ;; Mix tile layout : automatic choose between vertical/horizontal
320 (defgeneric tile-layout-mix (child parent)
321 (:documentation "Tile child in its frame (mix: automatic choose between vertical/horizontal)"))
323 (defmethod tile-layout-mix (child parent)
324 (let* ((managed-children (update-layout-managed-children child parent))
325 (pos (child-position child managed-children))
326 (len (length managed-children))
327 (d1 (ceiling (sqrt len)))
328 (d2 (ceiling (/ len d1)))
329 (nx (if (> (frame-rw parent) (frame-rh parent)) d1 d2))
330 (ny (if (> (frame-rw parent) (frame-rh parent)) d2 d1))
331 (dx (/ (frame-rw parent) nx))
332 (dy (/ (frame-rh parent) ny))
333 (dpos (- (* nx ny) len))
334 (width dx))
335 (when (plusp dpos)
336 (if (zerop pos)
337 (setf width (* dx (1+ dpos)))
338 (incf pos dpos)))
339 (values (round (adj-border-xy (+ (frame-rx parent)
340 (truncate (* (mod pos nx) dx))) parent))
341 (round (adj-border-xy (+ (frame-ry parent)
342 (truncate (* (truncate (/ pos nx)) dy))) parent))
343 (round (adj-border-wh width child))
344 (round (adj-border-wh dy child)))))
347 (defun set-tile-layout-mix ()
348 "Tile child in its frame (mix: automatic choose between vertical/horizontal)"
349 (set-layout-managed-children)
350 (set-layout #'tile-layout-mix))
353 ;; One column layout
354 (defgeneric one-column-layout (child parent)
355 (:documentation "One column layout"))
357 (defmethod one-column-layout (child parent)
358 (let* ((managed-children (update-layout-managed-children child parent))
359 (pos (child-position child managed-children))
360 (len (length managed-children))
361 (dy (/ (frame-rh parent) len)))
362 (values (round (adj-border-xy (frame-rx parent) parent))
363 (round (adj-border-xy (+ (frame-ry parent) (* pos dy)) parent))
364 (round (adj-border-wh (frame-rw parent) child))
365 (round (adj-border-wh dy child)))))
367 (defun set-one-column-layout ()
368 "One column layout"
369 (set-layout-managed-children)
370 (set-layout #'one-column-layout))
373 ;; One line layout
374 (defgeneric one-line-layout (child parent)
375 (:documentation "One line layout"))
377 (defmethod one-line-layout (child parent)
378 (let* ((managed-children (update-layout-managed-children child parent))
379 (pos (child-position child managed-children))
380 (len (length managed-children))
381 (dx (/ (frame-rw parent) len)))
382 (values (round (adj-border-xy (+ (frame-rx parent) (* pos dx)) parent))
383 (round (adj-border-xy (frame-ry parent) parent))
384 (round (adj-border-wh dx child))
385 (round (adj-border-wh (frame-rh parent) child)))))
387 (defun set-one-line-layout ()
388 "One line layout"
389 (set-layout-managed-children)
390 (set-layout #'one-line-layout))
396 ;;; Space layout
397 (defun tile-space-layout (child parent)
398 "Tile Space: tile child in its frame leaving spaces between them"
399 (with-slots (rx ry rw rh) parent
400 (let* ((managed-children (update-layout-managed-children child parent))
401 (pos (child-position child managed-children))
402 (len (length managed-children))
403 (d1 (ceiling (sqrt len)))
404 (d2 (ceiling (/ len d1)))
405 (cols (if (> rw rh) d1 d2))
406 (rows (if (> rw rh) d2 d1))
407 (col (mod pos cols))
408 (row (floor pos cols))
409 (space-percent (or (frame-data-slot parent :tile-space-size) 0.05))
410 (col-space-total (* rw space-percent))
411 (row-space-total (* rh space-percent))
412 (col-space (floor col-space-total (1+ cols)))
413 (row-space (floor row-space-total (1+ rows)))
414 (child-width (floor (- rw col-space-total) cols))
415 (child-height (floor (- rh row-space-total) rows))
417 (values (round (adj-border-xy (+ rx col-space (* (+ col-space child-width) col)) parent))
418 (round (adj-border-xy (+ ry row-space (* (+ row-space child-height) row)) parent))
419 (round (adj-border-wh child-width child))
420 (round (adj-border-wh child-height child))))))
423 (defun set-tile-space-layout ()
424 "Tile Space: tile child in its frame leaving spaces between them"
425 (layout-ask-size "Space size in percent (%)" :tile-space-size 0.01)
426 (set-layout-managed-children)
427 (set-layout #'tile-space-layout))
433 (defun three-columns-layout (child parent)
434 "Three Colums: main child in the middle, others on the two sides."
435 (with-slots (rx ry rw rh) parent
436 (let* ((managed-children (update-layout-managed-children child parent))
437 (pos (child-position child managed-children))
438 (len (max (1- (length managed-children)) 1))
439 (dy (round (/ rh (max (truncate (/ (+ (if (oddp pos) 1 0) len) 2)) 1))))
440 (size (or (frame-data-slot parent :tile-size) 0.75))
441 (other-size (if (> len 1) (/ (- 1 size) 2) (- 1 size))))
442 (if (> (length managed-children) 1)
443 (if (= pos 0)
444 (values (adj-border-xy (if (> len 1)
445 (round (+ rx (* rw other-size)))
446 rx) parent)
447 (adj-border-xy ry parent)
448 (adj-border-wh (round (* rw size)) child)
449 (adj-border-wh rh child))
450 (values (adj-border-xy (if (oddp pos)
451 (round (+ rx (* rw (if (> len 1) (+ size other-size) size))))
452 rx) parent)
453 (adj-border-xy (round (+ ry (* dy (truncate (/ (1- pos) 2))))) parent)
454 (adj-border-wh (round (* rw other-size)) parent)
455 (adj-border-wh dy parent)))
456 (no-layout child parent)))))
458 (defun set-three-columns-layout ()
459 "Three Columns: main child in the middle, others on the two sides."
460 (layout-ask-size "Tile size in percent (%)" :tile-size)
461 (set-layout-managed-children)
462 (set-layout #'three-columns-layout))
466 (register-layout-sub-menu 'frame-tile-layout-menu "Frame tile layout menu"
467 '(("v" set-tile-layout)
468 ("h" set-tile-horizontal-layout)
469 ("m" set-tile-layout-mix)
470 ("c" set-one-column-layout)
471 ("l" set-one-line-layout)
472 ("s" set-tile-space-layout)
473 ("t" set-three-columns-layout)))
477 ;;; Tile Left
478 (defun tile-left-layout (child parent)
479 "Tile Left: main child on left and others on right"
480 (with-slots (rx ry rw rh) parent
481 (let* ((managed-children (update-layout-managed-children child parent))
482 (pos (child-position child managed-children))
483 (len (max (1- (length managed-children)) 1))
484 (dy (/ rh len))
485 (size (or (frame-data-slot parent :tile-size) 0.8)))
486 (if (> (length managed-children) 1)
487 (if (= pos 0)
488 (values (adj-border-xy rx parent)
489 (adj-border-xy ry parent)
490 (adj-border-wh (round (* rw size)) child)
491 (adj-border-wh rh child))
492 (values (adj-border-xy (round (+ rx (* rw size))) parent)
493 (adj-border-xy (round (+ ry (* dy (1- pos)))) parent)
494 (adj-border-wh (round (* rw (- 1 size))) child)
495 (adj-border-wh (round dy) child)))
496 (no-layout child parent)))))
499 (defun set-tile-left-layout ()
500 "Tile Left: main child on left and others on right"
501 (layout-ask-size "Tile size in percent (%)" :tile-size)
502 (set-layout-managed-children)
503 (set-layout #'tile-left-layout))
507 ;;; Tile right
508 (defun tile-right-layout (child parent)
509 "Tile Right: main child on right and others on left"
510 (with-slots (rx ry rw rh) parent
511 (let* ((managed-children (update-layout-managed-children child parent))
512 (pos (child-position child managed-children))
513 (len (max (1- (length managed-children)) 1))
514 (dy (/ rh len))
515 (size (or (frame-data-slot parent :tile-size) 0.8)))
516 (if (> (length managed-children) 1)
517 (if (= pos 0)
518 (values (adj-border-xy (round (+ rx (* rw (- 1 size)))) parent)
519 (adj-border-xy ry parent)
520 (adj-border-wh (round (* rw size)) child)
521 (adj-border-wh rh child))
522 (values (adj-border-xy rx parent)
523 (adj-border-xy (round (+ ry (* dy (1- pos)))) parent)
524 (adj-border-wh (round (* rw (- 1 size))) child)
525 (adj-border-wh (round dy) child)))
526 (no-layout child parent)))))
529 (defun set-tile-right-layout ()
530 "Tile Right: main child on right and others on left"
531 (layout-ask-size "Tile size in percent (%)" :tile-size)
532 (set-layout-managed-children)
533 (set-layout #'tile-right-layout))
540 ;;; Tile Top
541 (defun tile-top-layout (child parent)
542 "Tile Top: main child on top and others on bottom"
543 (with-slots (rx ry rw rh) parent
544 (let* ((managed-children (update-layout-managed-children child parent))
545 (pos (child-position child managed-children))
546 (len (max (1- (length managed-children)) 1))
547 (dx (/ rw len))
548 (size (or (frame-data-slot parent :tile-size) 0.8)))
549 (if (> (length managed-children) 1)
550 (if (= pos 0)
551 (values (adj-border-xy rx parent)
552 (adj-border-xy ry parent)
553 (adj-border-wh rw child)
554 (adj-border-wh (round (* rh size)) child))
555 (values (adj-border-xy (round (+ rx (* dx (1- pos)))) parent)
556 (adj-border-xy (round (+ ry (* rh size))) parent)
557 (adj-border-wh (round dx) child)
558 (adj-border-wh (round (* rh (- 1 size))) child)))
559 (no-layout child parent)))))
562 (defun set-tile-top-layout ()
563 "Tile Top: main child on top and others on bottom"
564 (layout-ask-size "Tile size in percent (%)" :tile-size)
565 (set-layout-managed-children)
566 (set-layout #'tile-top-layout))
571 ;;; Tile Bottom
572 (defun tile-bottom-layout (child parent)
573 "Tile Bottom: main child on bottom and others on top"
574 (with-slots (rx ry rw rh) parent
575 (let* ((managed-children (update-layout-managed-children child parent))
576 (pos (child-position child managed-children))
577 (len (max (1- (length managed-children)) 1))
578 (dx (/ rw len))
579 (size (or (frame-data-slot parent :tile-size) 0.8)))
580 (if (> (length managed-children) 1)
581 (if (= pos 0)
582 (values (adj-border-xy rx parent)
583 (adj-border-xy (round (+ ry (* rh (- 1 size)))) parent)
584 (adj-border-wh rw child)
585 (adj-border-wh (round (* rh size)) child))
586 (values (adj-border-xy (round (+ rx (* dx (1- pos)))) parent)
587 (adj-border-xy ry parent)
588 (adj-border-wh (round dx) child)
589 (adj-border-wh (round (* rh (- 1 size))) child)))
590 (no-layout child parent)))))
594 (defun set-tile-bottom-layout ()
595 "Tile Bottom: main child on bottom and others on top"
596 (layout-ask-size "Tile size in percent (%)" :tile-size)
597 (set-layout-managed-children)
598 (set-layout #'tile-bottom-layout))
601 (register-layout-sub-menu 'frame-tile-dir-layout-menu "Tile in one direction layout menu"
602 '(("l" set-tile-left-layout)
603 ("r" set-tile-right-layout)
604 ("t" set-tile-top-layout)
605 ("b" set-tile-bottom-layout)))
612 ;;; Left and space layout: like left layout but leave a space on the left
613 (defun layout-ask-space (msg slot &optional (default 100))
614 (when (frame-p (current-child))
615 (let ((new-space (or (query-number msg (or (frame-data-slot (current-child) slot) default)) default)))
616 (setf (frame-data-slot (current-child) slot) new-space))))
619 (defun tile-left-space-layout (child parent)
620 "Tile Left Space: main child on left and others on right. Leave some space (in pixels) on the left."
621 (with-slots (rx ry rw rh) parent
622 (let* ((managed-children (update-layout-managed-children child parent))
623 (pos (child-position child managed-children))
624 (len (max (1- (length managed-children)) 1))
625 (dy (/ rh len))
626 (size (or (frame-data-slot parent :tile-size) 0.8))
627 (space (or (frame-data-slot parent :tile-left-space) 100)))
628 (if (> (length managed-children) 1)
629 (if (= pos 0)
630 (values (adj-border-xy (+ rx space) parent)
631 (adj-border-xy ry parent)
632 (adj-border-wh (- (round (* rw size)) space) child)
633 (adj-border-wh rh child))
634 (values (adj-border-xy (round (+ rx (* rw size))) parent)
635 (adj-border-xy (round (+ ry (* dy (1- pos)))) parent)
636 (adj-border-wh (round (* rw (- 1 size))) child)
637 (adj-border-wh (round dy) child)))
638 (multiple-value-bind (rnx rny rnw rnh)
639 (no-layout child parent)
640 (values (+ rnx space)
642 (- rnw space)
643 rnh))))))
646 (defun set-tile-left-space-layout ()
647 "Tile Left Space: main child on left and others on right. Leave some space on the left."
648 (layout-ask-size "Tile size in percent (%)" :tile-size)
649 (layout-ask-space "Tile space (in pixels)" :tile-left-space)
650 (set-layout-managed-children)
651 (set-layout #'tile-left-space-layout))
653 (register-layout-sub-menu 'frame-tile-space-layout-menu "Tile with some space on one side menu"
654 '(set-tile-left-space-layout))
659 ;;; Main windows layout - A possible GIMP layout
660 ;;; The windows in the main list are tiled on the frame
661 ;;; others windows are on one side of the frame.
662 (defun main-window-right-layout (child parent)
663 "Main window right: Main windows on the right. Others on the left."
664 (with-slots (rx ry rw rh) parent
665 (let* ((main-windows (frame-data-slot parent :main-window-list))
666 (len (length main-windows))
667 (size (or (frame-data-slot parent :tile-size) 0.8)))
668 (if (zerop len)
669 (no-layout child parent)
670 (if (child-member child main-windows)
671 (let* ((dy (/ rh len))
672 (pos (child-position child main-windows)))
673 (values (adj-border-xy (round (+ rx (* rw (- 1 size)))) parent)
674 (adj-border-xy (round (+ ry (* dy pos))) parent)
675 (adj-border-wh (round (* rw size)) child)
676 (adj-border-wh (round dy) child)))
677 (values (adj-border-xy rx parent)
678 (adj-border-xy ry parent)
679 (adj-border-wh (round (* rw (- 1 size))) child)
680 (adj-border-wh rh child)))))))
682 (defun set-main-window-right-layout ()
683 "Main window right: Main windows on the right. Others on the left."
684 (layout-ask-size "Split size in percent (%)" :tile-size)
685 (set-layout #'main-window-right-layout))
690 (defun main-window-left-layout (child parent)
691 "Main window left: Main windows on the left. Others on the right."
692 (with-slots (rx ry rw rh) parent
693 (let* ((main-windows (frame-data-slot parent :main-window-list))
694 (len (length main-windows))
695 (size (or (frame-data-slot parent :tile-size) 0.8)))
696 (if (zerop len)
697 (no-layout child parent)
698 (if (child-member child main-windows)
699 (let* ((dy (/ rh len))
700 (pos (child-position child main-windows)))
701 (values (adj-border-xy rx parent)
702 (adj-border-xy (round (+ ry (* dy pos))) parent)
703 (adj-border-wh (round (* rw size)) child)
704 (adj-border-wh (round dy) child)))
705 (values (adj-border-xy (round (+ rx (* rw size))) parent)
706 (adj-border-xy ry parent)
707 (adj-border-wh (round (* rw (- 1 size))) child)
708 (adj-border-wh rh child)))))))
710 (defun set-main-window-left-layout ()
711 "Main window left: Main windows on the left. Others on the right."
712 (layout-ask-size "Split size in percent (%)" :tile-size)
713 (set-layout #'main-window-left-layout))
717 (defun main-window-top-layout (child parent)
718 "Main window top: Main windows on the top. Others on the bottom."
719 (with-slots (rx ry rw rh) parent
720 (let* ((main-windows (frame-data-slot parent :main-window-list))
721 (len (length main-windows))
722 (size (or (frame-data-slot parent :tile-size) 0.8)))
723 (if (zerop len)
724 (no-layout child parent)
725 (if (child-member child main-windows)
726 (let* ((dx (/ rw len))
727 (pos (child-position child main-windows)))
728 (values (adj-border-xy (round (+ rx (* dx pos))) parent)
729 (adj-border-xy ry parent)
730 (adj-border-wh (round dx) child)
731 (adj-border-wh (round (* rh size)) child)))
732 (values (adj-border-xy rx parent)
733 (adj-border-xy (round (+ ry (* rh size))) parent)
734 (adj-border-wh rw child)
735 (adj-border-wh (round (* rh (- 1 size))) child)))))))
737 (defun set-main-window-top-layout ()
738 "Main window top: Main windows on the top. Others on the bottom."
739 (layout-ask-size "Split size in percent (%)" :tile-size)
740 (set-layout #'main-window-top-layout))
744 (defun main-window-bottom-layout (child parent)
745 "Main window bottom: Main windows on the bottom. Others on the top."
746 (with-slots (rx ry rw rh) parent
747 (let* ((main-windows (frame-data-slot parent :main-window-list))
748 (len (length main-windows))
749 (size (or (frame-data-slot parent :tile-size) 0.8)))
750 (if (zerop len)
751 (no-layout child parent)
752 (if (child-member child main-windows)
753 (let* ((dx (/ rw len))
754 (pos (child-position child main-windows)))
755 (values (adj-border-xy (round (+ rx (* dx pos))) parent)
756 (adj-border-xy (round (+ ry (* rh (- 1 size)))) parent)
757 (adj-border-wh (round dx) child)
758 (adj-border-wh (round (* rh size)) child)))
759 (values (adj-border-xy rx parent)
760 (adj-border-xy ry parent)
761 (adj-border-wh rw child)
762 (adj-border-wh (round (* rh (- 1 size))) child)))))))
764 (defun set-main-window-bottom-layout ()
765 "Main window bottom: Main windows on the bottom. Others on the top."
766 (layout-ask-size "Split size in percent (%)" :tile-size)
767 (set-layout #'main-window-bottom-layout))
773 (defun add-in-main-window-list ()
774 "Add the current window in the main window list"
775 (when (frame-p (current-child))
776 (with-current-window
777 (when (child-member window (get-managed-child (current-child)))
778 (pushnew window (frame-data-slot (current-child) :main-window-list)))))
779 (leave-second-mode))
782 (defun remove-in-main-window-list ()
783 "Remove the current window from the main window list"
784 (when (frame-p (current-child))
785 (with-current-window
786 (when (child-member window (get-managed-child (current-child)))
787 (setf (frame-data-slot (current-child) :main-window-list)
788 (child-remove window (frame-data-slot (current-child) :main-window-list))))))
789 (leave-second-mode))
791 (defun clear-main-window-list ()
792 "Clear the main window list"
793 (when (frame-p (current-child))
794 (setf (frame-data-slot (current-child) :main-window-list) nil))
795 (leave-second-mode))
800 (register-layout-sub-menu 'frame-main-window-layout-menu "Main window layout menu"
801 '(("r" set-main-window-right-layout)
802 ("l" set-main-window-left-layout)
803 ("t" set-main-window-top-layout)
804 ("b" set-main-window-bottom-layout)
805 "-=- Actions on main windows list -=-"
806 ("a" add-in-main-window-list)
807 ("v" remove-in-main-window-list)
808 ("c" clear-main-window-list)))
811 ;;; GIMP layout specifics functions
813 (defconfig *gimp-layout-notify-window-delay* 30 'gimp-layout
814 "Time to display the GIMP layout notify window help")
817 (defun select-next/previous-child-no-main-window (fun-rotate)
818 "Select the next/previous child - Skip windows in main window list"
819 (when (frame-p (current-child))
820 (with-slots (child) (current-child)
821 (let* ((main-windows (frame-data-slot (current-child) :main-window-list))
822 (to-skip? (not (= (length main-windows)
823 (length child)))))
824 (labels ((rec ()
825 (setf child (funcall fun-rotate child))
826 (when (and to-skip?
827 (child-member (frame-selected-child (current-child)) main-windows))
828 (rec))))
829 (unselect-all-frames)
830 (rec)
831 (show-all-children))))))
834 (defun select-next-child-no-main-window ()
835 "Select the next child - Skip windows in main window list"
836 (select-next/previous-child-no-main-window #'rotate-list))
838 (defun select-previous-child-no-main-window ()
839 "Select the previous child - Skip windows in main window list"
840 (select-next/previous-child-no-main-window #'anti-rotate-list))
843 (defun mouse-click-to-focus-and-move-no-main-window (window root-x root-y)
844 "Move and focus the current frame or focus the current window parent.
845 Or do actions on corners - Skip windows in main window list"
846 (unless (do-corner-action root-x root-y *corner-main-mode-left-button*)
847 (if (and (frame-p (current-child))
848 (child-member window (frame-data-slot (current-child) :main-window-list)))
849 (replay-button-event)
850 (mouse-click-to-focus-generic root-x root-y #'move-frame))))
854 (let ((help-text-list `(("-=- Help on The GIMP layout -=-" ,*info-color-title*)
856 "The GIMP layout is a main-window-layout with a sloppy focus policy."
857 "You can change the main windows direction with the layout menu."
859 "Press Alt+F8 to add a window to the main windows list."
860 "Press Alt+F9 to remove a window from the main windows list."
861 "Press Alt+F10 to clear the main windows list."
863 "You can select a main window with the right mouse button."
865 "Use the layout menu to restore the previous layout and keybinding.")))
866 (defun help-on-gimp-layout ()
867 "Help on the GIMP layout"
868 (info-mode help-text-list)
869 (leave-second-mode))
871 (defun set-gimp-layout ()
872 "The GIMP Layout"
873 (when (frame-p (current-child))
874 ;; Note: There is no need to ungrab/grab keys because this
875 ;; is done when leaving the second mode.
876 (define-main-key ("F8" :mod-1) 'add-in-main-window-list)
877 (define-main-key ("F9" :mod-1) 'remove-in-main-window-list)
878 (define-main-key ("F10" :mod-1) 'clear-main-window-list)
879 (define-main-key ("Tab" :mod-1) 'select-next-child-no-main-window)
880 (define-main-key ("Tab" :mod-1 :shift) 'select-previous-child-no-main-window)
881 (define-main-mouse (1) 'mouse-click-to-focus-and-move-no-main-window)
882 (setf (frame-data-slot (current-child) :focus-policy-save)
883 (frame-focus-policy (current-child)))
884 (setf (frame-focus-policy (current-child)) :sloppy)
885 (setf (frame-data-slot (current-child) :layout-save)
886 (frame-layout (current-child)))
887 (open-notify-window help-text-list)
888 (add-timer *gimp-layout-notify-window-delay* #'close-notify-window)
889 ;; Set the default layout and leave the second mode.
890 (set-main-window-right-layout))))
893 (defun set-previous-layout ()
894 "Restore the previous layout"
895 (undefine-main-key ("F8" :mod-1))
896 (undefine-main-key ("F9" :mod-1))
897 (undefine-main-key ("F10" :mod-1))
898 (define-main-key ("Tab" :mod-1) 'select-next-child)
899 (define-main-key ("Tab" :mod-1 :shift) 'select-previous-child)
900 (define-main-mouse (1) 'mouse-click-to-focus-and-move)
901 (setf (frame-focus-policy (current-child))
902 (frame-data-slot (current-child) :focus-policy-save))
903 (setf (frame-layout (current-child))
904 (frame-data-slot (current-child) :layout-save))
905 (leave-second-mode))
910 (register-layout-sub-menu 'frame-gimp-layout-menu "The GIMP layout menu"
911 '(("g" set-gimp-layout)
912 ("p" set-previous-layout)
913 ("h" help-on-gimp-layout)
914 "-=- Main window layout -=-"
915 ("r" set-main-window-right-layout)
916 ("l" set-main-window-left-layout)
917 ("t" set-main-window-top-layout)
918 ("b" set-main-window-bottom-layout)
919 "-=- Actions on main windows list -=-"
920 ("a" add-in-main-window-list)
921 ("v" remove-in-main-window-list)
922 ("c" clear-main-window-list)))