src/clfswm-layout.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Layout functions
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2011 Philippe Brochard <hocwp@free.fr>
   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 ;;; --------------------------------------------------------------------------
  25
  26 (in-package :clfswm)
  27
  28
  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.
  39
  40
  41
  42 (defparameter *layout-current-key* (1- (char-code #\a)))
  43
  44
  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)))
  51
  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)))
  56
  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))
  62
  63
  64 (defun get-managed-child (parent)
  65   "Return only the windows that are managed for tiling"
  66   (when (frame-p parent)
  67     (remove-if #'(lambda (x)
  68                    (and (xlib:window-p x) (not (managed-window-p x parent))))
  69                (frame-child parent))))
  70
  71
  72 (defun next-layout-key ()
  73   (code-char (incf *layout-current-key*)))
  74
  75
  76 (defun register-layout (layout)
  77   (add-menu-key 'frame-layout-menu (next-layout-key) layout))
  78
  79
  80 (defun register-layout-sub-menu (name doc layout-list)
  81   (add-sub-menu 'frame-layout-menu (next-layout-key) name doc)
  82   (loop :for item :in layout-list
  83      :for i :from 0
  84      :do (typecase item
  85            (cons (add-menu-key name (first item) (second item)))
  86            (string (add-menu-comment name item))
  87            (t (add-menu-key name (number->char i) item)))))
  88
  89
  90
  91
  92 (defun layout-ask-size (msg slot &optional (min 80))
  93   (when (frame-p (current-child))
  94     (let ((new-size (/ (or (query-number msg (* (frame-data-slot (current-child) slot) 100)) min) 100)))
  95       (setf (frame-data-slot (current-child) slot) (max (min new-size 0.99) 0.01)))))
  96
  97 (defun adjust-layout-size (slot inc)
  98   (when (frame-p (current-child))
  99     (setf (frame-data-slot (current-child) slot)
 100           (max (min (+ (frame-data-slot (current-child) slot) inc) 0.99) 0.01))))
 101
 102 (defun inc-tile-layout-size ()
 103   "Increase the tile layout size"
 104   (adjust-layout-size :tile-size 0.05)
 105   (show-all-children))
 106
 107 (defun dec-tile-layout-size ()
 108   "Decrease the tile layout size"
 109   (adjust-layout-size :tile-size -0.05)
 110   (show-all-children))
 111
 112 (defun inc-slow-tile-layout-size ()
 113   "Increase slowly the tile layout size"
 114   (adjust-layout-size :tile-size 0.01)
 115   (show-all-children))
 116
 117 (defun dec-slow-tile-layout-size ()
 118   "Decrease slowly the tile layout size"
 119   (adjust-layout-size :tile-size -0.01)
 120   (show-all-children))
 121
 122
 123
 124
 125 (defun fast-layout-switch ()
 126   "Switch between two layouts"
 127   (when (frame-p (current-child))
 128     (with-slots (layout) (current-child)
 129       (let* ((layout-list (frame-data-slot (current-child) :fast-layout))
 130              (first-layout (ensure-function (first layout-list)))
 131              (second-layout (ensure-function (second layout-list))))
 132         (setf layout (if (eql layout first-layout)
 133                          second-layout
 134                          first-layout))
 135         (leave-second-mode)))))
 136
 137
 138 (defun push-in-fast-layout-list ()
 139   "Push the current layout in the fast layout list"
 140   (when (frame-p (current-child))
 141     (setf (frame-data-slot (current-child) :fast-layout)
 142           (list (frame-layout (current-child))
 143                 (first (frame-data-slot (current-child) :fast-layout))))
 144     (leave-second-mode)))
 145
 146
 147
 148 (register-layout-sub-menu 'frame-fast-layout-menu "Frame fast layout menu"
 149                           '(("s" fast-layout-switch)
 150                             ("p" push-in-fast-layout-list)))
 151
 152
 153 ;;; No layout
 154 (defgeneric no-layout (child parent)
 155   (:documentation "No layout: Maximize windows in their frame - Leave frames to their original size"))
 156
 157 (defmethod no-layout ((child xlib:window) parent)
 158   (with-slots (rx ry rw rh) parent
 159     (values (adj-border-xy rx child)
 160             (adj-border-xy ry child)
 161             (adj-border-wh rw child)
 162             (adj-border-wh rh child))))
 163
 164 (defmethod no-layout ((child frame) parent)
 165   (values (adj-border-xy (x-fl->px (frame-x child) parent) child)
 166           (adj-border-xy (y-fl->px (frame-y child) parent) child)
 167           (adj-border-wh (w-fl->px (frame-w child) parent) child)
 168           (adj-border-wh (h-fl->px (frame-h child) parent) child)))
 169
 170
 171
 172 (defun set-no-layout ()
 173   "No layout: Maximize windows in their frame - Leave frames to their original size"
 174   (set-layout #'no-layout))
 175
 176 (register-layout 'set-no-layout)
 177
 178 ;;; No layout remember size
 179 (defun set-no-layout-remember-size ()
 180   "No layout: Maximize windows in their frame - Leave frames to their actual size"
 181   (fixe-real-size-current-child)
 182   (set-no-layout))
 183
 184 (register-layout 'set-no-layout-remember-size)
 185
 186
 187
 188 ;;; Maximize layout
 189 (defgeneric maximize-layout (child parent)
 190   (:documentation "Maximize layout: Maximize windows and frames in their parent frame"))
 191
 192 (defmethod maximize-layout (child parent)
 193   (with-slots (rx ry rw rh) parent
 194     (values (adj-border-xy rx child)
 195             (adj-border-xy ry child)
 196             (adj-border-wh rw child)
 197             (adj-border-wh rh child))))
 198
 199
 200 (defun set-maximize-layout ()
 201   "Maximize layout: Maximize windows and frames in their parent frame"
 202   (set-layout #'maximize-layout))
 203
 204 (register-layout 'set-maximize-layout)
 205
 206
 207
 208
 209 ;;; Tile layout
 210 (defun tile-layout-ask-keep-position ()
 211   (when (frame-p (current-child))
 212     (if (query-yes-or-no "Keep frame children positions?")
 213         (setf (frame-data-slot (current-child) :tile-layout-keep-position) :yes)
 214         (remove-frame-data-slot (current-child) :tile-layout-keep-position))))
 215
 216
 217
 218 (labels ((set-managed ()
 219            (setf (frame-data-slot (current-child) :layout-managed-children)
 220                  (copy-list (get-managed-child (current-child))))))
 221   (defun set-layout-managed-children ()
 222     (when (frame-p (current-child))
 223       (set-managed)
 224       (tile-layout-ask-keep-position)))
 225
 226
 227   (defun update-layout-managed-children-position ()
 228     "Update layout managed children position"
 229     (when (frame-p (current-child))
 230       (set-managed)
 231       (leave-second-mode))))
 232
 233
 234
 235 (defun update-layout-managed-children-keep-position (child parent)
 236   (declare (ignore child))
 237   (let ((managed-children (frame-data-slot parent :layout-managed-children))
 238         (managed-in-parent (get-managed-child parent)))
 239     (dolist (ch managed-in-parent)
 240       (unless (child-member ch managed-children)
 241         (setf managed-children (append managed-children (list ch)))))
 242     (setf managed-children (remove-if-not (lambda (x)
 243                                             (child-member x managed-in-parent))
 244                                           managed-children))
 245     (setf (frame-data-slot parent :layout-managed-children) managed-children)
 246     managed-children))
 247
 248 (defun update-layout-managed-children (child parent)
 249   (if (eql (frame-data-slot parent :tile-layout-keep-position) :yes)
 250       (update-layout-managed-children-keep-position child parent)
 251       (get-managed-child parent)))
 252
 253
 254
 255 (defgeneric tile-layout (child parent)
 256   (:documentation "Tile child in its frame (vertical)"))
 257
 258 (defmethod tile-layout (child parent)
 259   (let* ((managed-children (update-layout-managed-children child parent))
 260          (pos (child-position child managed-children))
 261          (len (length managed-children))
 262          (nx (ceiling (sqrt len)))
 263          (ny  (ceiling (/ len nx)))
 264          (dx (/ (frame-rw parent) nx))
 265          (dy (/ (frame-rh parent) ny))
 266          (dpos (- (* nx ny) len))
 267          (width dx))
 268     (when (plusp dpos)
 269       (if (zerop pos)
 270           (setf width (* dx (1+ dpos)))
 271           (incf pos dpos)))
 272     (values (round (adj-border-xy (+ (frame-rx parent) (truncate (* (mod pos nx) dx))) child))
 273             (round (adj-border-xy (+ (frame-ry parent) (truncate (* (truncate (/ pos nx)) dy))) child))
 274             (round (adj-border-wh width child))
 275             (round (adj-border-wh dy child)))))
 276
 277 (defun set-tile-layout ()
 278   "Tile child in its frame (vertical)"
 279   (set-layout-managed-children)
 280   (set-layout #'tile-layout))
 281
 282
 283
 284 ;; Horizontal tiling layout
 285 (defgeneric tile-horizontal-layout (child parent)
 286   (:documentation "Tile child in its frame (horizontal)"))
 287
 288 (defmethod tile-horizontal-layout (child parent)
 289   (let* ((managed-children (update-layout-managed-children child parent))
 290          (pos (child-position child managed-children))
 291          (len (length managed-children))
 292          (ny (ceiling (sqrt len)))
 293          (nx (ceiling (/ len ny)))
 294          (dx (/ (frame-rw parent) nx))
 295          (dy (/ (frame-rh parent) ny))
 296          (dpos (- (* nx ny) len))
 297          (height dy))
 298     (when (plusp dpos)
 299       (if (zerop pos)
 300           (setf height (* dy (1+ dpos)))
 301           (incf pos dpos)))
 302     (values (round (adj-border-xy (+ (frame-rx parent) (truncate (* (truncate (/ pos ny)) dx))) child))
 303             (round (adj-border-xy (+ (frame-ry parent) (truncate (* (mod pos ny) dy))) child))
 304             (round (adj-border-wh dx child))
 305             (round (adj-border-wh height child)))))
 306
 307 (defun set-tile-horizontal-layout ()
 308   "Tile child in its frame (horizontal)"
 309   (set-layout-managed-children)
 310   (set-layout #'tile-horizontal-layout))
 311
 312
 313
 314
 315 ;; Mix tile layout : automatic choose between vertical/horizontal
 316 (defgeneric tile-layout-mix (child parent)
 317   (:documentation "Tile child in its frame (mix: automatic choose between vertical/horizontal)"))
 318
 319 (defmethod tile-layout-mix (child parent)
 320   (let* ((managed-children (update-layout-managed-children child parent))
 321          (pos (child-position child managed-children))
 322          (len (length managed-children))
 323          (d1 (ceiling (sqrt len)))
 324          (d2  (ceiling (/ len d1)))
 325          (nx (if (> (frame-rw parent) (frame-rh parent)) d1 d2))
 326          (ny (if (> (frame-rw parent) (frame-rh parent)) d2 d1))
 327          (dx (/ (frame-rw parent) nx))
 328          (dy (/ (frame-rh parent) ny))
 329          (dpos (- (* nx ny) len))
 330          (width dx))
 331     (when (plusp dpos)
 332       (if (zerop pos)
 333           (setf width (* dx (1+ dpos)))
 334           (incf pos dpos)))
 335     (values (round (adj-border-xy (+ (frame-rx parent)
 336                                      (truncate (* (mod pos nx) dx))) child))
 337             (round (adj-border-xy (+ (frame-ry parent)
 338                                      (truncate (* (truncate (/ pos nx)) dy))) child))
 339             (round (adj-border-wh width child))
 340             (round (adj-border-wh dy child)))))
 341
 342
 343 (defun set-tile-layout-mix ()
 344   "Tile child in its frame (mix: automatic choose between vertical/horizontal)"
 345   (set-layout-managed-children)
 346   (set-layout #'tile-layout-mix))
 347
 348
 349 ;; One column layout
 350 (defgeneric one-column-layout (child parent)
 351   (:documentation "One column layout"))
 352
 353 (defmethod one-column-layout (child parent)
 354   (let* ((managed-children (update-layout-managed-children child parent))
 355          (pos (child-position child managed-children))
 356          (len (length managed-children))
 357          (dy (/ (frame-rh parent) len)))
 358     (values (round (adj-border-xy (frame-rx parent) child))
 359             (round (adj-border-xy (+ (frame-ry parent) (*  pos dy)) child))
 360             (round (adj-border-wh (frame-rw parent) child))
 361             (round (adj-border-wh dy child)))))
 362
 363 (defun set-one-column-layout ()
 364   "One column layout"
 365   (set-layout-managed-children)
 366   (set-layout #'one-column-layout))
 367
 368
 369 ;; One line layout
 370 (defgeneric one-line-layout (child parent)
 371   (:documentation "One line layout"))
 372
 373 (defmethod one-line-layout (child parent)
 374   (let* ((managed-children (update-layout-managed-children child parent))
 375          (pos (child-position child managed-children))
 376          (len (length managed-children))
 377          (dx (/ (frame-rw parent) len)))
 378     (values (round (adj-border-xy (+ (frame-rx parent) (*  pos dx)) child))
 379             (round (adj-border-xy (frame-ry parent) child))
 380             (round (adj-border-wh dx child))
 381             (round (adj-border-wh (frame-rh parent) child)))))
 382
 383 (defun set-one-line-layout ()
 384   "One line layout"
 385   (set-layout-managed-children)
 386   (set-layout #'one-line-layout))
 387
 388
 389
 390
 391
 392 ;;; Space layout
 393 (defun tile-space-layout (child parent)
 394   "Tile Space: tile child in its frame leaving spaces between them"
 395   (with-slots (rx ry rw rh) parent
 396     (let* ((managed-children (update-layout-managed-children child parent))
 397            (pos (child-position child managed-children))
 398            (len (length managed-children))
 399            (d1 (ceiling (sqrt len)))
 400            (d2 (ceiling (/ len d1)))
 401            (cols (if (> rw rh) d1 d2))
 402            (rows (if (> rw rh) d2 d1))
 403            (col (mod pos cols))
 404            (row (floor pos cols))
 405            (space-percent (or (frame-data-slot parent :tile-space-size) 0.05))
 406            (col-space-total (* rw space-percent))
 407            (row-space-total (* rh space-percent))
 408            (col-space (floor col-space-total (1+ cols)))
 409            (row-space (floor row-space-total (1+ rows)))
 410            (child-width (floor (- rw col-space-total) cols))
 411            (child-height (floor (- rh row-space-total) rows))
 412            )
 413       (values (round (adj-border-xy (+ rx col-space
 414                                        (* (+ col-space child-width) col)) child))
 415               (round (adj-border-xy (+ ry row-space
 416                                (* (+ row-space child-height) row)) child))
 417               (round (adj-border-wh child-width child))
 418               (round (adj-border-wh child-height child))))))
 419
 420
 421 (defun set-tile-space-layout ()
 422   "Tile Space: tile child in its frame leaving spaces between them"
 423   (layout-ask-size "Space size in percent (%)" :tile-space-size 0.01)
 424   (set-layout-managed-children)
 425   (set-layout #'tile-space-layout))
 426
 427
 428
 429 (register-layout-sub-menu 'frame-tile-layout-menu "Frame tile layout menu"
 430                           '(("v" set-tile-layout)
 431                             ("h" set-tile-horizontal-layout)
 432                             ("m" set-tile-layout-mix)
 433                             ("c" set-one-column-layout)
 434                             ("l" set-one-line-layout)
 435                             ("s" set-tile-space-layout)))
 436
 437
 438
 439 ;;; Tile Left
 440 (defun tile-left-layout (child parent)
 441   "Tile Left: main child on left and others on right"
 442   (with-slots (rx ry rw rh) parent
 443     (let* ((managed-children (update-layout-managed-children child parent))
 444            (pos (child-position child managed-children))
 445            (len (max (1- (length managed-children)) 1))
 446            (dy (/ rh len))
 447            (size (or (frame-data-slot parent :tile-size) 0.8)))
 448       (if (> (length managed-children) 1)
 449           (if (= pos 0)
 450               (values (adj-border-xy rx child)
 451                       (adj-border-xy ry child)
 452                       (adj-border-wh (round (* rw size)) child)
 453                       (adj-border-wh rh child))
 454               (values (adj-border-xy (round (+ rx (* rw size))) child)
 455                       (adj-border-xy (round (+ ry (* dy (1- pos)))) child)
 456                       (adj-border-wh (round (* rw (- 1 size))) child)
 457                       (adj-border-wh (round dy) child)))
 458           (no-layout child parent)))))
 459
 460
 461 (defun set-tile-left-layout ()
 462   "Tile Left: main child on left and others on right"
 463   (layout-ask-size "Tile size in percent (%)" :tile-size)
 464   (set-layout-managed-children)
 465   (set-layout #'tile-left-layout))
 466
 467
 468
 469 ;;; Tile right
 470 (defun tile-right-layout (child parent)
 471   "Tile Right: main child on right and others on left"
 472   (with-slots (rx ry rw rh) parent
 473     (let* ((managed-children (update-layout-managed-children child parent))
 474            (pos (child-position child managed-children))
 475            (len (max (1- (length managed-children)) 1))
 476            (dy (/ rh len))
 477            (size (or (frame-data-slot parent :tile-size) 0.8)))
 478       (if (> (length managed-children) 1)
 479           (if (= pos 0)
 480               (values (adj-border-xy (round (+ rx (* rw (- 1 size)))) child)
 481                       (adj-border-xy ry child)
 482                       (adj-border-wh (round (* rw size)) child)
 483                       (adj-border-wh rh child))
 484               (values (adj-border-xy rx child)
 485                       (adj-border-xy (round (+ ry (* dy (1- pos)))) child)
 486                       (adj-border-wh (round (* rw (- 1 size))) child)
 487                       (adj-border-wh (round dy) child)))
 488           (no-layout child parent)))))
 489
 490
 491 (defun set-tile-right-layout ()
 492   "Tile Right: main child on right and others on left"
 493   (layout-ask-size "Tile size in percent (%)" :tile-size)
 494   (set-layout-managed-children)
 495   (set-layout #'tile-right-layout))
 496
 497
 498
 499
 500
 501
 502 ;;; Tile Top
 503 (defun tile-top-layout (child parent)
 504   "Tile Top: main child on top and others on bottom"
 505   (with-slots (rx ry rw rh) parent
 506     (let* ((managed-children (update-layout-managed-children child parent))
 507            (pos (child-position child managed-children))
 508            (len (max (1- (length managed-children)) 1))
 509            (dx (/ rw len))
 510            (size (or (frame-data-slot parent :tile-size) 0.8)))
 511       (if (> (length managed-children) 1)
 512           (if (= pos 0)
 513               (values (adj-border-xy rx child)
 514                       (adj-border-xy ry child)
 515                       (adj-border-wh rw child)
 516                       (adj-border-wh (round (* rh size)) child))
 517               (values (adj-border-xy (round (+ rx (* dx (1- pos)))) child)
 518                       (adj-border-xy (round (+ ry (* rh size))) child)
 519                       (adj-border-wh (round dx) child)
 520                       (adj-border-wh (round (* rh (- 1 size))) child)))
 521           (no-layout child parent)))))
 522
 523
 524 (defun set-tile-top-layout ()
 525   "Tile Top: main child on top and others on bottom"
 526   (layout-ask-size "Tile size in percent (%)" :tile-size)
 527   (set-layout-managed-children)
 528   (set-layout #'tile-top-layout))
 529
 530
 531
 532
 533 ;;; Tile Bottom
 534 (defun tile-bottom-layout (child parent)
 535   "Tile Bottom: main child on bottom and others on top"
 536   (with-slots (rx ry rw rh) parent
 537     (let* ((managed-children (update-layout-managed-children child parent))
 538            (pos (child-position child managed-children))
 539            (len (max (1- (length managed-children)) 1))
 540            (dx (/ rw len))
 541            (size (or (frame-data-slot parent :tile-size) 0.8)))
 542       (if (> (length managed-children) 1)
 543           (if (= pos 0)
 544               (values (adj-border-xy rx child)
 545                       (adj-border-xy (round (+ ry (* rh (- 1 size)))) child)
 546                       (adj-border-wh rw child)
 547                       (adj-border-wh (round (* rh size)) child))
 548               (values (adj-border-xy (round (+ rx (* dx (1- pos)))) child)
 549                       (adj-border-xy ry child)
 550                       (adj-border-wh (round dx) child)
 551                       (adj-border-wh (round (* rh (- 1 size))) child)))
 552           (no-layout child parent)))))
 553
 554
 555
 556 (defun set-tile-bottom-layout ()
 557   "Tile Bottom: main child on bottom and others on top"
 558   (layout-ask-size "Tile size in percent (%)" :tile-size)
 559   (set-layout-managed-children)
 560   (set-layout #'tile-bottom-layout))
 561
 562
 563 (register-layout-sub-menu 'frame-tile-dir-layout-menu "Tile in one direction layout menu"
 564                           '(("l" set-tile-left-layout)
 565                             ("r" set-tile-right-layout)
 566                             ("t" set-tile-top-layout)
 567                             ("b" set-tile-bottom-layout)))
 568
 569
 570
 571
 572
 573
 574 ;;; Left and space layout: like left layout but leave a space on the left
 575 (defun layout-ask-space (msg slot &optional (default 100))
 576   (when (frame-p (current-child))
 577     (let ((new-space (or (query-number msg (or (frame-data-slot (current-child) slot) default)) default)))
 578       (setf (frame-data-slot (current-child) slot) new-space))))
 579
 580
 581 (defun tile-left-space-layout (child parent)
 582   "Tile Left Space: main child on left and others on right. Leave some space (in pixels) on the left."
 583   (with-slots (rx ry rw rh) parent
 584     (let* ((managed-children (update-layout-managed-children child parent))
 585            (pos (child-position child managed-children))
 586            (len (max (1- (length managed-children)) 1))
 587            (dy (/ rh len))
 588            (size (or (frame-data-slot parent :tile-size) 0.8))
 589            (space (or (frame-data-slot parent :tile-left-space) 100)))
 590       (if (> (length managed-children) 1)
 591           (if (= pos 0)
 592               (values (adj-border-xy (+ rx space) child)
 593                       (adj-border-xy ry child)
 594                       (adj-border-wh (- (round (* rw size)) space) child)
 595                       (adj-border-wh rh child))
 596               (values (adj-border-xy (round (+ rx (* rw size))) child)
 597                       (adj-border-xy (round (+ ry (* dy (1- pos)))) child)
 598                       (adj-border-wh (round (* rw (- 1 size))) child)
 599                       (adj-border-wh (round dy) child)))
 600           (multiple-value-bind (rnx rny rnw rnh)
 601               (no-layout child parent)
 602             (values (+ rnx space)
 603                     rny
 604                     (- rnw space)
 605                     rnh))))))
 606
 607
 608 (defun set-tile-left-space-layout ()
 609   "Tile Left Space: main child on left and others on right. Leave some space on the left."
 610   (layout-ask-size "Tile size in percent (%)" :tile-size)
 611   (layout-ask-space "Tile space (in pixels)" :tile-left-space)
 612   (set-layout-managed-children)
 613   (set-layout #'tile-left-space-layout))
 614
 615 (register-layout-sub-menu 'frame-tile-space-layout-menu "Tile with some space on one side menu"
 616                           '(set-tile-left-space-layout))
 617
 618
 619
 620
 621 ;;; Main windows layout - A possible GIMP layout
 622 ;;;   The windows in the main list are tiled on the frame
 623 ;;;   others windows are on one side of the frame.
 624 (defun main-window-right-layout (child parent)
 625   "Main window right: Main windows on the right. Others on the left."
 626   (with-slots (rx ry rw rh) parent
 627     (let* ((main-windows (frame-data-slot parent :main-window-list))
 628            (len (length main-windows))
 629            (size (or (frame-data-slot parent :tile-size) 0.8)))
 630       (if (zerop len)
 631           (no-layout child parent)
 632           (if (child-member child main-windows)
 633               (let* ((dy (/ rh len))
 634                      (pos (child-position child main-windows)))
 635                 (values (adj-border-xy (round (+ rx (* rw (- 1 size)))) child)
 636                         (adj-border-xy (round (+ ry (* dy pos))) child)
 637                         (adj-border-wh (round (* rw size)) child)
 638                         (adj-border-wh (round dy) child)))
 639               (values (adj-border-xy rx child)
 640                       (adj-border-xy ry child)
 641                       (adj-border-wh (round (* rw (- 1 size))) child)
 642                       (adj-border-wh rh child)))))))
 643
 644 (defun set-main-window-right-layout ()
 645   "Main window right: Main windows on the right. Others on the left."
 646   (layout-ask-size "Split size in percent (%)" :tile-size)
 647   (set-layout #'main-window-right-layout))
 648
 649
 650
 651
 652 (defun main-window-left-layout (child parent)
 653   "Main window left: Main windows on the left. Others on the right."
 654   (with-slots (rx ry rw rh) parent
 655     (let* ((main-windows (frame-data-slot parent :main-window-list))
 656            (len (length main-windows))
 657            (size (or (frame-data-slot parent :tile-size) 0.8)))
 658       (if (zerop len)
 659           (no-layout child parent)
 660           (if (child-member child main-windows)
 661               (let* ((dy (/ rh len))
 662                      (pos (child-position child main-windows)))
 663                 (values (adj-border-xy rx child)
 664                         (adj-border-xy (round (+ ry (* dy pos))) child)
 665                         (adj-border-wh (round (* rw size)) child)
 666                         (adj-border-wh (round dy) child)))
 667               (values (adj-border-xy (round (+ rx (* rw size))) child)
 668                       (adj-border-xy ry child)
 669                       (adj-border-wh (round (* rw (- 1 size))) child)
 670                       (adj-border-wh rh child)))))))
 671
 672 (defun set-main-window-left-layout ()
 673   "Main window left: Main windows on the left. Others on the right."
 674   (layout-ask-size "Split size in percent (%)" :tile-size)
 675   (set-layout #'main-window-left-layout))
 676
 677
 678
 679 (defun main-window-top-layout (child parent)
 680   "Main window top: Main windows on the top. Others on the bottom."
 681   (with-slots (rx ry rw rh) parent
 682     (let* ((main-windows (frame-data-slot parent :main-window-list))
 683            (len (length main-windows))
 684            (size (or (frame-data-slot parent :tile-size) 0.8)))
 685       (if (zerop len)
 686           (no-layout child parent)
 687           (if (child-member child main-windows)
 688               (let* ((dx (/ rw len))
 689                      (pos (child-position child main-windows)))
 690                 (values (adj-border-xy (round (+ rx (* dx pos))) child)
 691                         (adj-border-xy ry child)
 692                         (adj-border-wh (round dx) child)
 693                         (adj-border-wh (round (* rh size)) child)))
 694               (values (adj-border-xy rx child)
 695                       (adj-border-xy (round (+ ry (* rh size))) child)
 696                       (adj-border-wh rw child)
 697                       (adj-border-wh (round (* rh (- 1 size))) child)))))))
 698
 699 (defun set-main-window-top-layout ()
 700   "Main window top: Main windows on the top. Others on the bottom."
 701   (layout-ask-size "Split size in percent (%)" :tile-size)
 702   (set-layout #'main-window-top-layout))
 703
 704
 705
 706 (defun main-window-bottom-layout (child parent)
 707   "Main window bottom: Main windows on the bottom. Others on the top."
 708   (with-slots (rx ry rw rh) parent
 709     (let* ((main-windows (frame-data-slot parent :main-window-list))
 710            (len (length main-windows))
 711            (size (or (frame-data-slot parent :tile-size) 0.8)))
 712       (if (zerop len)
 713           (no-layout child parent)
 714           (if (child-member child main-windows)
 715               (let* ((dx (/ rw len))
 716                      (pos (child-position child main-windows)))
 717                 (values (adj-border-xy (round (+ rx (* dx pos))) child)
 718                         (adj-border-xy (round (+ ry (* rh (- 1 size)))) child)
 719                         (adj-border-wh (round dx) child)
 720                         (adj-border-wh (round (* rh size)) child)))
 721               (values (adj-border-xy rx child)
 722                       (adj-border-xy ry child)
 723                       (adj-border-wh rw child)
 724                       (adj-border-wh (round (* rh (- 1 size))) child)))))))
 725
 726 (defun set-main-window-bottom-layout ()
 727   "Main window bottom: Main windows on the bottom. Others on the top."
 728   (layout-ask-size "Split size in percent (%)" :tile-size)
 729   (set-layout #'main-window-bottom-layout))
 730
 731
 732
 733
 734
 735 (defun add-in-main-window-list ()
 736   "Add the current window in the main window list"
 737   (when (frame-p (current-child))
 738     (with-current-window
 739       (when (child-member window (get-managed-child (current-child)))
 740         (pushnew window (frame-data-slot (current-child) :main-window-list)))))
 741   (leave-second-mode))
 742
 743
 744 (defun remove-in-main-window-list ()
 745   "Remove the current window from the main window list"
 746   (when (frame-p (current-child))
 747     (with-current-window
 748       (when (child-member window (get-managed-child (current-child)))
 749         (setf (frame-data-slot (current-child) :main-window-list)
 750               (child-remove window (frame-data-slot (current-child) :main-window-list))))))
 751   (leave-second-mode))
 752
 753 (defun clear-main-window-list ()
 754   "Clear the main window list"
 755   (when (frame-p (current-child))
 756     (setf (frame-data-slot (current-child) :main-window-list) nil))
 757   (leave-second-mode))
 758
 759
 760
 761
 762 (register-layout-sub-menu 'frame-main-window-layout-menu "Main window layout menu"
 763                           '(("r" set-main-window-right-layout)
 764                             ("l" set-main-window-left-layout)
 765                             ("t" set-main-window-top-layout)
 766                             ("b" set-main-window-bottom-layout)
 767                             "-=- Actions on main windows list -=-"
 768                             ("a" add-in-main-window-list)
 769                             ("v" remove-in-main-window-list)
 770                             ("c" clear-main-window-list)))
 771
 772
 773 ;;; GIMP layout specifics functions
 774 ;;;
 775 (defconfig *gimp-layout-notify-window-delay* 30 'gimp-layout
 776            "Time to display the GIMP layout notify window help")
 777
 778
 779 (defun select-next/previous-child-no-main-window (fun-rotate)
 780   "Select the next/previous child - Skip windows in main window list"
 781   (when (frame-p (current-child))
 782     (with-slots (child) (current-child)
 783       (let* ((main-windows (frame-data-slot (current-child) :main-window-list))
 784              (to-skip? (not (= (length main-windows)
 785                                (length child)))))
 786         (labels ((rec ()
 787                    (setf child (funcall fun-rotate child))
 788                    (when (and to-skip?
 789                               (child-member (frame-selected-child (current-child)) main-windows))
 790                      (rec))))
 791           (unselect-all-frames)
 792           (rec)
 793           (show-all-children))))))
 794
 795
 796 (defun select-next-child-no-main-window ()
 797   "Select the next child - Skip windows in main window list"
 798   (select-next/previous-child-no-main-window #'rotate-list))
 799
 800 (defun select-previous-child-no-main-window ()
 801   "Select the previous child - Skip windows in main window list"
 802   (select-next/previous-child-no-main-window #'anti-rotate-list))
 803
 804
 805 (defun mouse-click-to-focus-and-move-no-main-window (window root-x root-y)
 806   "Move and focus the current frame or focus the current window parent.
 807 Or do actions on corners - Skip windows in main window list"
 808   (unless (do-corner-action root-x root-y *corner-main-mode-left-button*)
 809     (if (and (frame-p (current-child))
 810              (child-member window (frame-data-slot (current-child) :main-window-list)))
 811         (replay-button-event)
 812         (mouse-click-to-focus-generic root-x root-y #'move-frame))))
 813
 814
 815
 816 (let ((help-text-list `(("-=- Help on The GIMP layout -=-" ,*info-color-title*)
 817                         ""
 818                         "The GIMP layout is a main-window-layout with a sloppy focus policy."
 819                         "You can change the main windows direction with the layout menu."
 820                         ""
 821                         "Press Alt+F8 to add a window to the main windows list."
 822                         "Press Alt+F9 to remove a window from the main windows list."
 823                         "Press Alt+F10 to clear the main windows list."
 824                         ""
 825                         "You can select a main window with the right mouse button."
 826                         ""
 827                         "Use the layout menu to restore the previous layout and keybinding.")))
 828   (defun help-on-gimp-layout ()
 829     "Help on the GIMP layout"
 830     (info-mode help-text-list)
 831     (leave-second-mode))
 832
 833   (defun set-gimp-layout ()
 834     "The GIMP Layout"
 835     (when (frame-p (current-child))
 836       ;; Note: There is no need to ungrab/grab keys because this
 837       ;; is done when leaving the second mode.
 838       (define-main-key ("F8" :mod-1) 'add-in-main-window-list)
 839       (define-main-key ("F9" :mod-1) 'remove-in-main-window-list)
 840       (define-main-key ("F10" :mod-1) 'clear-main-window-list)
 841       (define-main-key ("Tab" :mod-1) 'select-next-child-no-main-window)
 842       (define-main-key ("Tab" :mod-1 :shift) 'select-previous-child-no-main-window)
 843       (define-main-mouse (1) 'mouse-click-to-focus-and-move-no-main-window)
 844       (setf (frame-data-slot (current-child) :focus-policy-save)
 845             (frame-focus-policy (current-child)))
 846       (setf (frame-focus-policy (current-child)) :sloppy)
 847       (setf (frame-data-slot (current-child) :layout-save)
 848             (frame-layout (current-child)))
 849       (open-notify-window help-text-list)
 850       (add-timer *gimp-layout-notify-window-delay* #'close-notify-window)
 851       ;; Set the default layout and leave the second mode.
 852       (set-main-window-right-layout))))
 853
 854
 855 (defun set-previous-layout ()
 856   "Restore the previous layout"
 857   (undefine-main-key ("F8" :mod-1))
 858   (undefine-main-key ("F9" :mod-1))
 859   (undefine-main-key ("F10" :mod-1))
 860   (define-main-key ("Tab" :mod-1) 'select-next-child)
 861   (define-main-key ("Tab" :mod-1 :shift) 'select-previous-child)
 862   (define-main-mouse (1) 'mouse-click-to-focus-and-move)
 863   (setf (frame-focus-policy (current-child))
 864         (frame-data-slot (current-child) :focus-policy-save))
 865   (setf (frame-layout (current-child))
 866         (frame-data-slot (current-child) :layout-save))
 867   (leave-second-mode))
 868
 869
 870
 871
 872 (register-layout-sub-menu 'frame-gimp-layout-menu "The GIMP layout menu"
 873                           '(("g" set-gimp-layout)
 874                             ("p" set-previous-layout)
 875                             ("h" help-on-gimp-layout)
 876                             "-=- Main window layout -=-"
 877                             ("r" set-main-window-right-layout)
 878                             ("l" set-main-window-left-layout)
 879                             ("t" set-main-window-top-layout)
 880                             ("b" set-main-window-bottom-layout)
 881                             "-=- Actions on main windows list -=-"
 882                             ("a" add-in-main-window-list)
 883                             ("v" remove-in-main-window-list)
 884                             ("c" clear-main-window-list)))
 885
 886