1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Layout functions
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2005-2013 Philippe Brochard <pbrochard@common-lisp.net>
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.
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.
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.
24 ;;; --------------------------------------------------------------------------
29 ;;; CONFIG - Layout menu
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)))
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
)
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
)
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
)
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
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)
111 (defun dec-tile-layout-size ()
112 "Decrease the tile layout size"
113 (adjust-layout-size :tile-size -
0.05)
116 (defun inc-slow-tile-layout-size ()
117 "Increase slowly the tile layout size"
118 (adjust-layout-size :tile-size
0.01)
121 (defun dec-slow-tile-layout-size ()
122 "Decrease slowly the tile layout size"
123 (adjust-layout-size :tile-size -
0.01)
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
)
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
)))
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)
188 (register-layout 'set-no-layout-remember-size
)
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
)
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))
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))
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
))
249 (setf (frame-data-slot parent
:layout-managed-children
) 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
))
274 (setf width
(* dx
(1+ 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
))
304 (setf height
(* dy
(1+ 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
))
337 (setf width
(* dx
(1+ 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
))
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 ()
369 (set-layout-managed-children)
370 (set-layout #'one-column-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 ()
389 (set-layout-managed-children)
390 (set-layout #'one-line-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
))
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)
444 (values (adj-border-xy (if (> len
1)
445 (round (+ rx
(* rw other-size
)))
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
))))
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
)))
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))
485 (size (or (frame-data-slot parent
:tile-size
) 0.8)))
486 (if (> (length managed-children
) 1)
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
))
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))
515 (size (or (frame-data-slot parent
:tile-size
) 0.8)))
516 (if (> (length managed-children
) 1)
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
))
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))
548 (size (or (frame-data-slot parent
:tile-size
) 0.8)))
549 (if (> (length managed-children
) 1)
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
))
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))
579 (size (or (frame-data-slot parent
:tile-size
) 0.8)))
580 (if (> (length managed-children
) 1)
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))
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)
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
)
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)))
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)))
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)))
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)))
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))
777 (when (child-member window
(get-managed-child (current-child)))
778 (pushnew window
(frame-data-slot (current-child) :main-window-list
)))))
782 (defun remove-in-main-window-list ()
783 "Remove the current window from the main window list"
784 (when (frame-p (current-child))
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
))))))
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
))
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
)
825 (setf child
(funcall fun-rotate child
))
827 (child-member (frame-selected-child (current-child)) main-windows
))
829 (unselect-all-frames)
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 window 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
)
871 (defun set-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
))
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
)))