1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Layout functions
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2012 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
))
431 (register-layout-sub-menu 'frame-tile-layout-menu
"Frame tile layout menu"
432 '(("v" set-tile-layout
)
433 ("h" set-tile-horizontal-layout
)
434 ("m" set-tile-layout-mix
)
435 ("c" set-one-column-layout
)
436 ("l" set-one-line-layout
)
437 ("s" set-tile-space-layout
)))
442 (defun tile-left-layout (child parent
)
443 "Tile Left: main child on left and others on right"
444 (with-slots (rx ry rw rh
) parent
445 (let* ((managed-children (update-layout-managed-children child parent
))
446 (pos (child-position child managed-children
))
447 (len (max (1- (length managed-children
)) 1))
449 (size (or (frame-data-slot parent
:tile-size
) 0.8)))
450 (if (> (length managed-children
) 1)
452 (values (adj-border-xy rx parent
)
453 (adj-border-xy ry parent
)
454 (adj-border-wh (round (* rw size
)) child
)
455 (adj-border-wh rh child
))
456 (values (adj-border-xy (round (+ rx
(* rw size
))) parent
)
457 (adj-border-xy (round (+ ry
(* dy
(1- pos
)))) parent
)
458 (adj-border-wh (round (* rw
(- 1 size
))) child
)
459 (adj-border-wh (round dy
) child
)))
460 (no-layout child parent
)))))
463 (defun set-tile-left-layout ()
464 "Tile Left: main child on left and others on right"
465 (layout-ask-size "Tile size in percent (%)" :tile-size
)
466 (set-layout-managed-children)
467 (set-layout #'tile-left-layout
))
472 (defun tile-right-layout (child parent
)
473 "Tile Right: main child on right and others on left"
474 (with-slots (rx ry rw rh
) parent
475 (let* ((managed-children (update-layout-managed-children child parent
))
476 (pos (child-position child managed-children
))
477 (len (max (1- (length managed-children
)) 1))
479 (size (or (frame-data-slot parent
:tile-size
) 0.8)))
480 (if (> (length managed-children
) 1)
482 (values (adj-border-xy (round (+ rx
(* rw
(- 1 size
)))) parent
)
483 (adj-border-xy ry parent
)
484 (adj-border-wh (round (* rw size
)) child
)
485 (adj-border-wh rh child
))
486 (values (adj-border-xy rx parent
)
487 (adj-border-xy (round (+ ry
(* dy
(1- pos
)))) parent
)
488 (adj-border-wh (round (* rw
(- 1 size
))) child
)
489 (adj-border-wh (round dy
) child
)))
490 (no-layout child parent
)))))
493 (defun set-tile-right-layout ()
494 "Tile Right: main child on right and others on left"
495 (layout-ask-size "Tile size in percent (%)" :tile-size
)
496 (set-layout-managed-children)
497 (set-layout #'tile-right-layout
))
505 (defun tile-top-layout (child parent
)
506 "Tile Top: main child on top and others on bottom"
507 (with-slots (rx ry rw rh
) parent
508 (let* ((managed-children (update-layout-managed-children child parent
))
509 (pos (child-position child managed-children
))
510 (len (max (1- (length managed-children
)) 1))
512 (size (or (frame-data-slot parent
:tile-size
) 0.8)))
513 (if (> (length managed-children
) 1)
515 (values (adj-border-xy rx parent
)
516 (adj-border-xy ry parent
)
517 (adj-border-wh rw child
)
518 (adj-border-wh (round (* rh size
)) child
))
519 (values (adj-border-xy (round (+ rx
(* dx
(1- pos
)))) parent
)
520 (adj-border-xy (round (+ ry
(* rh size
))) parent
)
521 (adj-border-wh (round dx
) child
)
522 (adj-border-wh (round (* rh
(- 1 size
))) child
)))
523 (no-layout child parent
)))))
526 (defun set-tile-top-layout ()
527 "Tile Top: main child on top and others on bottom"
528 (layout-ask-size "Tile size in percent (%)" :tile-size
)
529 (set-layout-managed-children)
530 (set-layout #'tile-top-layout
))
536 (defun tile-bottom-layout (child parent
)
537 "Tile Bottom: main child on bottom and others on top"
538 (with-slots (rx ry rw rh
) parent
539 (let* ((managed-children (update-layout-managed-children child parent
))
540 (pos (child-position child managed-children
))
541 (len (max (1- (length managed-children
)) 1))
543 (size (or (frame-data-slot parent
:tile-size
) 0.8)))
544 (if (> (length managed-children
) 1)
546 (values (adj-border-xy rx parent
)
547 (adj-border-xy (round (+ ry
(* rh
(- 1 size
)))) parent
)
548 (adj-border-wh rw child
)
549 (adj-border-wh (round (* rh size
)) child
))
550 (values (adj-border-xy (round (+ rx
(* dx
(1- pos
)))) parent
)
551 (adj-border-xy ry parent
)
552 (adj-border-wh (round dx
) child
)
553 (adj-border-wh (round (* rh
(- 1 size
))) child
)))
554 (no-layout child parent
)))))
558 (defun set-tile-bottom-layout ()
559 "Tile Bottom: main child on bottom and others on top"
560 (layout-ask-size "Tile size in percent (%)" :tile-size
)
561 (set-layout-managed-children)
562 (set-layout #'tile-bottom-layout
))
565 (register-layout-sub-menu 'frame-tile-dir-layout-menu
"Tile in one direction layout menu"
566 '(("l" set-tile-left-layout
)
567 ("r" set-tile-right-layout
)
568 ("t" set-tile-top-layout
)
569 ("b" set-tile-bottom-layout
)))
576 ;;; Left and space layout: like left layout but leave a space on the left
577 (defun layout-ask-space (msg slot
&optional
(default 100))
578 (when (frame-p (current-child))
579 (let ((new-space (or (query-number msg
(or (frame-data-slot (current-child) slot
) default
)) default
)))
580 (setf (frame-data-slot (current-child) slot
) new-space
))))
583 (defun tile-left-space-layout (child parent
)
584 "Tile Left Space: main child on left and others on right. Leave some space (in pixels) on the left."
585 (with-slots (rx ry rw rh
) parent
586 (let* ((managed-children (update-layout-managed-children child parent
))
587 (pos (child-position child managed-children
))
588 (len (max (1- (length managed-children
)) 1))
590 (size (or (frame-data-slot parent
:tile-size
) 0.8))
591 (space (or (frame-data-slot parent
:tile-left-space
) 100)))
592 (if (> (length managed-children
) 1)
594 (values (adj-border-xy (+ rx space
) parent
)
595 (adj-border-xy ry parent
)
596 (adj-border-wh (- (round (* rw size
)) space
) child
)
597 (adj-border-wh rh child
))
598 (values (adj-border-xy (round (+ rx
(* rw size
))) parent
)
599 (adj-border-xy (round (+ ry
(* dy
(1- pos
)))) parent
)
600 (adj-border-wh (round (* rw
(- 1 size
))) child
)
601 (adj-border-wh (round dy
) child
)))
602 (multiple-value-bind (rnx rny rnw rnh
)
603 (no-layout child parent
)
604 (values (+ rnx space
)
610 (defun set-tile-left-space-layout ()
611 "Tile Left Space: main child on left and others on right. Leave some space on the left."
612 (layout-ask-size "Tile size in percent (%)" :tile-size
)
613 (layout-ask-space "Tile space (in pixels)" :tile-left-space
)
614 (set-layout-managed-children)
615 (set-layout #'tile-left-space-layout
))
617 (register-layout-sub-menu 'frame-tile-space-layout-menu
"Tile with some space on one side menu"
618 '(set-tile-left-space-layout))
623 ;;; Main windows layout - A possible GIMP layout
624 ;;; The windows in the main list are tiled on the frame
625 ;;; others windows are on one side of the frame.
626 (defun main-window-right-layout (child parent
)
627 "Main window right: Main windows on the right. Others on the left."
628 (with-slots (rx ry rw rh
) parent
629 (let* ((main-windows (frame-data-slot parent
:main-window-list
))
630 (len (length main-windows
))
631 (size (or (frame-data-slot parent
:tile-size
) 0.8)))
633 (no-layout child parent
)
634 (if (child-member child main-windows
)
635 (let* ((dy (/ rh len
))
636 (pos (child-position child main-windows
)))
637 (values (adj-border-xy (round (+ rx
(* rw
(- 1 size
)))) parent
)
638 (adj-border-xy (round (+ ry
(* dy pos
))) parent
)
639 (adj-border-wh (round (* rw size
)) child
)
640 (adj-border-wh (round dy
) child
)))
641 (values (adj-border-xy rx parent
)
642 (adj-border-xy ry parent
)
643 (adj-border-wh (round (* rw
(- 1 size
))) child
)
644 (adj-border-wh rh child
)))))))
646 (defun set-main-window-right-layout ()
647 "Main window right: Main windows on the right. Others on the left."
648 (layout-ask-size "Split size in percent (%)" :tile-size
)
649 (set-layout #'main-window-right-layout
))
654 (defun main-window-left-layout (child parent
)
655 "Main window left: Main windows on the left. Others on the right."
656 (with-slots (rx ry rw rh
) parent
657 (let* ((main-windows (frame-data-slot parent
:main-window-list
))
658 (len (length main-windows
))
659 (size (or (frame-data-slot parent
:tile-size
) 0.8)))
661 (no-layout child parent
)
662 (if (child-member child main-windows
)
663 (let* ((dy (/ rh len
))
664 (pos (child-position child main-windows
)))
665 (values (adj-border-xy rx parent
)
666 (adj-border-xy (round (+ ry
(* dy pos
))) parent
)
667 (adj-border-wh (round (* rw size
)) child
)
668 (adj-border-wh (round dy
) child
)))
669 (values (adj-border-xy (round (+ rx
(* rw size
))) parent
)
670 (adj-border-xy ry parent
)
671 (adj-border-wh (round (* rw
(- 1 size
))) child
)
672 (adj-border-wh rh child
)))))))
674 (defun set-main-window-left-layout ()
675 "Main window left: Main windows on the left. Others on the right."
676 (layout-ask-size "Split size in percent (%)" :tile-size
)
677 (set-layout #'main-window-left-layout
))
681 (defun main-window-top-layout (child parent
)
682 "Main window top: Main windows on the top. Others on the bottom."
683 (with-slots (rx ry rw rh
) parent
684 (let* ((main-windows (frame-data-slot parent
:main-window-list
))
685 (len (length main-windows
))
686 (size (or (frame-data-slot parent
:tile-size
) 0.8)))
688 (no-layout child parent
)
689 (if (child-member child main-windows
)
690 (let* ((dx (/ rw len
))
691 (pos (child-position child main-windows
)))
692 (values (adj-border-xy (round (+ rx
(* dx pos
))) parent
)
693 (adj-border-xy ry parent
)
694 (adj-border-wh (round dx
) child
)
695 (adj-border-wh (round (* rh size
)) child
)))
696 (values (adj-border-xy rx parent
)
697 (adj-border-xy (round (+ ry
(* rh size
))) parent
)
698 (adj-border-wh rw child
)
699 (adj-border-wh (round (* rh
(- 1 size
))) child
)))))))
701 (defun set-main-window-top-layout ()
702 "Main window top: Main windows on the top. Others on the bottom."
703 (layout-ask-size "Split size in percent (%)" :tile-size
)
704 (set-layout #'main-window-top-layout
))
708 (defun main-window-bottom-layout (child parent
)
709 "Main window bottom: Main windows on the bottom. Others on the top."
710 (with-slots (rx ry rw rh
) parent
711 (let* ((main-windows (frame-data-slot parent
:main-window-list
))
712 (len (length main-windows
))
713 (size (or (frame-data-slot parent
:tile-size
) 0.8)))
715 (no-layout child parent
)
716 (if (child-member child main-windows
)
717 (let* ((dx (/ rw len
))
718 (pos (child-position child main-windows
)))
719 (values (adj-border-xy (round (+ rx
(* dx pos
))) parent
)
720 (adj-border-xy (round (+ ry
(* rh
(- 1 size
)))) parent
)
721 (adj-border-wh (round dx
) child
)
722 (adj-border-wh (round (* rh size
)) child
)))
723 (values (adj-border-xy rx parent
)
724 (adj-border-xy ry parent
)
725 (adj-border-wh rw child
)
726 (adj-border-wh (round (* rh
(- 1 size
))) child
)))))))
728 (defun set-main-window-bottom-layout ()
729 "Main window bottom: Main windows on the bottom. Others on the top."
730 (layout-ask-size "Split size in percent (%)" :tile-size
)
731 (set-layout #'main-window-bottom-layout
))
737 (defun add-in-main-window-list ()
738 "Add the current window in the main window list"
739 (when (frame-p (current-child))
741 (when (child-member window
(get-managed-child (current-child)))
742 (pushnew window
(frame-data-slot (current-child) :main-window-list
)))))
746 (defun remove-in-main-window-list ()
747 "Remove the current window from the main window list"
748 (when (frame-p (current-child))
750 (when (child-member window
(get-managed-child (current-child)))
751 (setf (frame-data-slot (current-child) :main-window-list
)
752 (child-remove window
(frame-data-slot (current-child) :main-window-list
))))))
755 (defun clear-main-window-list ()
756 "Clear the main window list"
757 (when (frame-p (current-child))
758 (setf (frame-data-slot (current-child) :main-window-list
) nil
))
764 (register-layout-sub-menu 'frame-main-window-layout-menu
"Main window layout menu"
765 '(("r" set-main-window-right-layout
)
766 ("l" set-main-window-left-layout
)
767 ("t" set-main-window-top-layout
)
768 ("b" set-main-window-bottom-layout
)
769 "-=- Actions on main windows list -=-"
770 ("a" add-in-main-window-list
)
771 ("v" remove-in-main-window-list
)
772 ("c" clear-main-window-list
)))
775 ;;; GIMP layout specifics functions
777 (defconfig *gimp-layout-notify-window-delay
* 30 'gimp-layout
778 "Time to display the GIMP layout notify window help")
781 (defun select-next/previous-child-no-main-window
(fun-rotate)
782 "Select the next/previous child - Skip windows in main window list"
783 (when (frame-p (current-child))
784 (with-slots (child) (current-child)
785 (let* ((main-windows (frame-data-slot (current-child) :main-window-list
))
786 (to-skip?
(not (= (length main-windows
)
789 (setf child
(funcall fun-rotate child
))
791 (child-member (frame-selected-child (current-child)) main-windows
))
793 (unselect-all-frames)
795 (show-all-children))))))
798 (defun select-next-child-no-main-window ()
799 "Select the next child - Skip windows in main window list"
800 (select-next/previous-child-no-main-window
#'rotate-list
))
802 (defun select-previous-child-no-main-window ()
803 "Select the previous child - Skip windows in main window list"
804 (select-next/previous-child-no-main-window
#'anti-rotate-list
))
807 (defun mouse-click-to-focus-and-move-no-main-window (window root-x root-y
)
808 "Move and focus the current frame or focus the current window parent.
809 Or do actions on corners - Skip windows in main window list"
810 (unless (do-corner-action root-x root-y
*corner-main-mode-left-button
*)
811 (if (and (frame-p (current-child))
812 (child-member window
(frame-data-slot (current-child) :main-window-list
)))
813 (replay-button-event)
814 (mouse-click-to-focus-generic root-x root-y
#'move-frame
))))
818 (let ((help-text-list `(("-=- Help on The GIMP layout -=-" ,*info-color-title
*)
820 "The GIMP layout is a main-window-layout with a sloppy focus policy."
821 "You can change the main windows direction with the layout menu."
823 "Press Alt+F8 to add a window to the main windows list."
824 "Press Alt+F9 to remove a window from the main windows list."
825 "Press Alt+F10 to clear the main windows list."
827 "You can select a main window with the right mouse button."
829 "Use the layout menu to restore the previous layout and keybinding.")))
830 (defun help-on-gimp-layout ()
831 "Help on the GIMP layout"
832 (info-mode help-text-list
)
835 (defun set-gimp-layout ()
837 (when (frame-p (current-child))
838 ;; Note: There is no need to ungrab/grab keys because this
839 ;; is done when leaving the second mode.
840 (define-main-key ("F8" :mod-1
) 'add-in-main-window-list
)
841 (define-main-key ("F9" :mod-1
) 'remove-in-main-window-list
)
842 (define-main-key ("F10" :mod-1
) 'clear-main-window-list
)
843 (define-main-key ("Tab" :mod-1
) 'select-next-child-no-main-window
)
844 (define-main-key ("Tab" :mod-1
:shift
) 'select-previous-child-no-main-window
)
845 (define-main-mouse (1) 'mouse-click-to-focus-and-move-no-main-window
)
846 (setf (frame-data-slot (current-child) :focus-policy-save
)
847 (frame-focus-policy (current-child)))
848 (setf (frame-focus-policy (current-child)) :sloppy
)
849 (setf (frame-data-slot (current-child) :layout-save
)
850 (frame-layout (current-child)))
851 (open-notify-window help-text-list
)
852 (add-timer *gimp-layout-notify-window-delay
* #'close-notify-window
)
853 ;; Set the default layout and leave the second mode.
854 (set-main-window-right-layout))))
857 (defun set-previous-layout ()
858 "Restore the previous layout"
859 (undefine-main-key ("F8" :mod-1
))
860 (undefine-main-key ("F9" :mod-1
))
861 (undefine-main-key ("F10" :mod-1
))
862 (define-main-key ("Tab" :mod-1
) 'select-next-child
)
863 (define-main-key ("Tab" :mod-1
:shift
) 'select-previous-child
)
864 (define-main-mouse (1) 'mouse-click-to-focus-and-move
)
865 (setf (frame-focus-policy (current-child))
866 (frame-data-slot (current-child) :focus-policy-save
))
867 (setf (frame-layout (current-child))
868 (frame-data-slot (current-child) :layout-save
))
874 (register-layout-sub-menu 'frame-gimp-layout-menu
"The GIMP layout menu"
875 '(("g" set-gimp-layout
)
876 ("p" set-previous-layout
)
877 ("h" help-on-gimp-layout
)
878 "-=- Main window layout -=-"
879 ("r" set-main-window-right-layout
)
880 ("l" set-main-window-left-layout
)
881 ("t" set-main-window-top-layout
)
882 ("b" set-main-window-bottom-layout
)
883 "-=- Actions on main windows list -=-"
884 ("a" add-in-main-window-list
)
885 ("v" remove-in-main-window-list
)
886 ("c" clear-main-window-list
)))