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 there frame - Leave frames to there 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 there frame - Leave frames to there 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 there frame - Leave frames to there 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 there 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 there 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   (let ((managed-children (frame-data-slot parent :layout-managed-children))
 237         (managed-in-parent (get-managed-child parent)))
 238     (dolist (ch managed-in-parent)
 239       (unless (child-member ch managed-children)
 240         (setf managed-children (append managed-children (list child)))))
 241     (setf managed-children (remove-if-not (lambda (x)
 242                                             (child-member x managed-in-parent))
 243                                           managed-children))
 244     (setf (frame-data-slot parent :layout-managed-children) managed-children)
 245     managed-children))
 246
 247 (defun update-layout-managed-children (child parent)
 248   (if (eql (frame-data-slot parent :tile-layout-keep-position) :yes)
 249       (update-layout-managed-children-keep-position child parent)
 250       (get-managed-child parent)))
 251
 252
 253
 254 (defgeneric tile-layout (child parent)
 255   (:documentation "Tile child in its frame (vertical)"))
 256
 257 (defmethod tile-layout (child parent)
 258   (let* ((managed-children (update-layout-managed-children child parent))
 259          (pos (child-position child managed-children))
 260          (len (length managed-children))
 261          (nx (ceiling (sqrt len)))
 262          (ny  (ceiling (/ len nx)))
 263          (dx (/ (frame-rw parent) nx))
 264          (dy (/ (frame-rh parent) ny))
 265          (dpos (- (* nx ny) len))
 266          (width dx))
 267     (when (plusp dpos)
 268       (if (zerop pos)
 269           (setf width (* dx (1+ dpos)))
 270           (incf pos dpos)))
 271     (values (round (adj-border-xy (+ (frame-rx parent) (truncate (* (mod pos nx) dx))) child))
 272             (round (adj-border-xy (+ (frame-ry parent) (truncate (* (truncate (/ pos nx)) dy))) child))
 273             (round (adj-border-wh width child))
 274             (round (adj-border-wh dy child)))))
 275
 276 (defun set-tile-layout ()
 277   "Tile child in its frame (vertical)"
 278   (set-layout-managed-children)
 279   (set-layout #'tile-layout))
 280
 281
 282
 283 ;; Horizontal tiling layout
 284 (defgeneric tile-horizontal-layout (child parent)
 285   (:documentation "Tile child in its frame (horizontal)"))
 286
 287 (defmethod tile-horizontal-layout (child parent)
 288   (let* ((managed-children (update-layout-managed-children child parent))
 289          (pos (child-position child managed-children))
 290          (len (length managed-children))
 291          (ny (ceiling (sqrt len)))
 292          (nx (ceiling (/ len ny)))
 293          (dx (/ (frame-rw parent) nx))
 294          (dy (/ (frame-rh parent) ny))
 295          (dpos (- (* nx ny) len))
 296          (height dy))
 297     (when (plusp dpos)
 298       (if (zerop pos)
 299           (setf height (* dy (1+ dpos)))
 300           (incf pos dpos)))
 301     (values (round (adj-border-xy (+ (frame-rx parent) (truncate (* (truncate (/ pos ny)) dx))) child))
 302             (round (adj-border-xy (+ (frame-ry parent) (truncate (* (mod pos ny) dy))) child))
 303             (round (adj-border-wh dx child))
 304             (round (adj-border-wh height child)))))
 305
 306 (defun set-tile-horizontal-layout ()
 307   "Tile child in its frame (horizontal)"
 308   (set-layout-managed-children)
 309   (set-layout #'tile-horizontal-layout))
 310
 311
 312
 313 ;; One column layout
 314 (defgeneric one-column-layout (child parent)
 315   (:documentation "One column layout"))
 316
 317 (defmethod one-column-layout (child parent)
 318   (let* ((managed-children (update-layout-managed-children child parent))
 319          (pos (child-position child managed-children))
 320          (len (length managed-children))
 321          (dy (/ (frame-rh parent) len)))
 322     (values (round (adj-border-xy (frame-rx parent) child))
 323             (round (adj-border-xy (+ (frame-ry parent) (*  pos dy)) child))
 324             (round (adj-border-wh (frame-rw parent) child))
 325             (round (adj-border-wh dy child)))))
 326
 327 (defun set-one-column-layout ()
 328   "One column layout"
 329   (set-layout-managed-children)
 330   (set-layout #'one-column-layout))
 331
 332
 333 ;; One line layout
 334 (defgeneric one-line-layout (child parent)
 335   (:documentation "One line layout"))
 336
 337 (defmethod one-line-layout (child parent)
 338   (let* ((managed-children (update-layout-managed-children child parent))
 339          (pos (child-position child managed-children))
 340          (len (length managed-children))
 341          (dx (/ (frame-rw parent) len)))
 342     (values (round (adj-border-xy (+ (frame-rx parent) (*  pos dx)) child))
 343             (round (adj-border-xy (frame-ry parent) child))
 344             (round (adj-border-wh dx child))
 345             (round (adj-border-wh (frame-rh parent) child)))))
 346
 347 (defun set-one-line-layout ()
 348   "One line layout"
 349   (set-layout-managed-children)
 350   (set-layout #'one-line-layout))
 351
 352
 353
 354
 355
 356 ;;; Space layout
 357 (defun tile-space-layout (child parent)
 358   "Tile Space: tile child in its frame leaving spaces between them"
 359   (with-slots (rx ry rw rh) parent
 360     (let* ((managed-children (update-layout-managed-children child parent))
 361            (pos (child-position child managed-children))
 362            (len (length managed-children))
 363            (n (ceiling (sqrt len)))
 364            (dx (/ rw n))
 365            (dy (/ rh (ceiling (/ len n))))
 366            (size (or (frame-data-slot parent :tile-space-size) 0.1)))
 367       (when (> size 0.5) (setf size 0.45))
 368       (values (round (adj-border-xy (+ rx (truncate (* (mod pos n) dx)) (* dx size)) child))
 369               (round (adj-border-xy (+ ry (truncate (* (truncate (/ pos n)) dy)) (* dy size)) child))
 370               (round (adj-border-wh (- dx (* dx size 2)) child))
 371               (round (adj-border-wh (- dy (* dy size 2)) child))))))
 372
 373
 374
 375
 376 (defun set-tile-space-layout ()
 377   "Tile Space: tile child in its frame leaving spaces between them"
 378   (layout-ask-size "Space size in percent (%)" :tile-space-size 0.01)
 379   (set-layout-managed-children)
 380   (set-layout #'tile-space-layout))
 381
 382
 383
 384 (register-layout-sub-menu 'frame-tile-layout-menu "Frame tile layout menu"
 385                           '(("v" set-tile-layout)
 386                             ("h" set-tile-horizontal-layout)
 387                             ("c" set-one-column-layout)
 388                             ("l" set-one-line-layout)
 389                             ("s" set-tile-space-layout)))
 390
 391
 392
 393 ;;; Tile Left
 394 (defun tile-left-layout (child parent)
 395   "Tile Left: main child on left and others on right"
 396   (with-slots (rx ry rw rh) parent
 397     (let* ((managed-children (update-layout-managed-children child parent))
 398            (pos (child-position child managed-children))
 399            (len (max (1- (length managed-children)) 1))
 400            (dy (/ rh len))
 401            (size (or (frame-data-slot parent :tile-size) 0.8)))
 402       (if (> (length managed-children) 1)
 403           (if (= pos 0)
 404               (values (adj-border-xy rx child)
 405                       (adj-border-xy ry child)
 406                       (adj-border-wh (round (* rw size)) child)
 407                       (adj-border-wh rh child))
 408               (values (adj-border-xy (round (+ rx (* rw size))) child)
 409                       (adj-border-xy (round (+ ry (* dy (1- pos)))) child)
 410                       (adj-border-wh (round (* rw (- 1 size))) child)
 411                       (adj-border-wh (round dy) child)))
 412           (no-layout child parent)))))
 413
 414
 415 (defun set-tile-left-layout ()
 416   "Tile Left: main child on left and others on right"
 417   (layout-ask-size "Tile size in percent (%)" :tile-size)
 418   (set-layout-managed-children)
 419   (set-layout #'tile-left-layout))
 420
 421
 422
 423 ;;; Tile right
 424 (defun tile-right-layout (child parent)
 425   "Tile Right: main child on right and others on left"
 426   (with-slots (rx ry rw rh) parent
 427     (let* ((managed-children (update-layout-managed-children child parent))
 428            (pos (child-position child managed-children))
 429            (len (max (1- (length managed-children)) 1))
 430            (dy (/ rh len))
 431            (size (or (frame-data-slot parent :tile-size) 0.8)))
 432       (if (> (length managed-children) 1)
 433           (if (= pos 0)
 434               (values (adj-border-xy (round (+ rx (* rw (- 1 size)))) child)
 435                       (adj-border-xy ry child)
 436                       (adj-border-wh (round (* rw size)) child)
 437                       (adj-border-wh rh child))
 438               (values (adj-border-xy rx child)
 439                       (adj-border-xy (round (+ ry (* dy (1- pos)))) child)
 440                       (adj-border-wh (round (* rw (- 1 size))) child)
 441                       (adj-border-wh (round dy) child)))
 442           (no-layout child parent)))))
 443
 444
 445 (defun set-tile-right-layout ()
 446   "Tile Right: main child on right and others on left"
 447   (layout-ask-size "Tile size in percent (%)" :tile-size)
 448   (set-layout-managed-children)
 449   (set-layout #'tile-right-layout))
 450
 451
 452
 453
 454
 455
 456 ;;; Tile Top
 457 (defun tile-top-layout (child parent)
 458   "Tile Top: main child on top and others on bottom"
 459   (with-slots (rx ry rw rh) parent
 460     (let* ((managed-children (update-layout-managed-children child parent))
 461            (pos (child-position child managed-children))
 462            (len (max (1- (length managed-children)) 1))
 463            (dx (/ rw len))
 464            (size (or (frame-data-slot parent :tile-size) 0.8)))
 465       (if (> (length managed-children) 1)
 466           (if (= pos 0)
 467               (values (adj-border-xy rx child)
 468                       (adj-border-xy ry child)
 469                       (adj-border-wh rw child)
 470                       (adj-border-wh (round (* rh size)) child))
 471               (values (adj-border-xy (round (+ rx (* dx (1- pos)))) child)
 472                       (adj-border-xy (round (+ ry (* rh size))) child)
 473                       (adj-border-wh (round dx) child)
 474                       (adj-border-wh (round (* rh (- 1 size))) child)))
 475           (no-layout child parent)))))
 476
 477
 478 (defun set-tile-top-layout ()
 479   "Tile Top: main child on top and others on bottom"
 480   (layout-ask-size "Tile size in percent (%)" :tile-size)
 481   (set-layout-managed-children)
 482   (set-layout #'tile-top-layout))
 483
 484
 485
 486
 487 ;;; Tile Bottom
 488 (defun tile-bottom-layout (child parent)
 489   "Tile Bottom: main child on bottom and others on top"
 490   (with-slots (rx ry rw rh) parent
 491     (let* ((managed-children (update-layout-managed-children child parent))
 492            (pos (child-position child managed-children))
 493            (len (max (1- (length managed-children)) 1))
 494            (dx (/ rw len))
 495            (size (or (frame-data-slot parent :tile-size) 0.8)))
 496       (if (> (length managed-children) 1)
 497           (if (= pos 0)
 498               (values (adj-border-xy rx child)
 499                       (adj-border-xy (round (+ ry (* rh (- 1 size)))) child)
 500                       (adj-border-wh rw child)
 501                       (adj-border-wh (round (* rh size)) child))
 502               (values (adj-border-xy (round (+ rx (* dx (1- pos)))) child)
 503                       (adj-border-xy ry child)
 504                       (adj-border-wh (round dx) child)
 505                       (adj-border-wh (round (* rh (- 1 size))) child)))
 506           (no-layout child parent)))))
 507
 508
 509
 510 (defun set-tile-bottom-layout ()
 511   "Tile Bottom: main child on bottom and others on top"
 512   (layout-ask-size "Tile size in percent (%)" :tile-size)
 513   (set-layout-managed-children)
 514   (set-layout #'tile-bottom-layout))
 515
 516
 517 (register-layout-sub-menu 'frame-tile-dir-layout-menu "Tile in one direction layout menu"
 518                           '(("l" set-tile-left-layout)
 519                             ("r" set-tile-right-layout)
 520                             ("t" set-tile-top-layout)
 521                             ("b" set-tile-bottom-layout)))
 522
 523
 524
 525
 526
 527
 528 ;;; Left and space layout: like left layout but leave a space on the left
 529 (defun layout-ask-space (msg slot &optional (default 100))
 530   (when (frame-p *current-child*)
 531     (let ((new-space (or (query-number msg (or (frame-data-slot *current-child* slot) default)) default)))
 532       (setf (frame-data-slot *current-child* slot) new-space))))
 533
 534
 535 (defun tile-left-space-layout (child parent)
 536   "Tile Left Space: main child on left and others on right. Leave some space (in pixels) on the left."
 537   (with-slots (rx ry rw rh) parent
 538     (let* ((managed-children (update-layout-managed-children child parent))
 539            (pos (child-position child managed-children))
 540            (len (max (1- (length managed-children)) 1))
 541            (dy (/ rh len))
 542            (size (or (frame-data-slot parent :tile-size) 0.8))
 543            (space (or (frame-data-slot parent :tile-left-space) 100)))
 544       (if (> (length managed-children) 1)
 545           (if (= pos 0)
 546               (values (adj-border-xy (+ rx space) child)
 547                       (adj-border-xy ry child)
 548                       (adj-border-wh (- (round (* rw size)) space) child)
 549                       (adj-border-wh rh child))
 550               (values (adj-border-xy (round (+ rx (* rw size))) child)
 551                       (adj-border-xy (round (+ ry (* dy (1- pos)))) child)
 552                       (adj-border-wh (round (* rw (- 1 size))) child)
 553                       (adj-border-wh (round dy) child)))
 554           (multiple-value-bind (rnx rny rnw rnh)
 555               (no-layout child parent)
 556             (values (+ rnx space)
 557                     rny
 558                     (- rnw space)
 559                     rnh))))))
 560
 561
 562 (defun set-tile-left-space-layout ()
 563   "Tile Left Space: main child on left and others on right. Leave some space on the left."
 564   (layout-ask-size "Tile size in percent (%)" :tile-size)
 565   (layout-ask-space "Tile space (in pixels)" :tile-left-space)
 566   (set-layout-managed-children)
 567   (set-layout #'tile-left-space-layout))
 568
 569 (register-layout-sub-menu 'frame-tile-space-layout-menu "Tile with some space on one side menu"
 570                           '(set-tile-left-space-layout))
 571
 572
 573
 574
 575 ;;; Main windows layout - A possible GIMP layout
 576 ;;;   The windows in the main list are tiled on the frame
 577 ;;;   others windows are on one side of the frame.
 578 (defun main-window-right-layout (child parent)
 579   "Main window right: Main windows on the right. Others on the left."
 580   (with-slots (rx ry rw rh) parent
 581     (let* ((main-windows (frame-data-slot parent :main-window-list))
 582            (len (length main-windows))
 583            (size (or (frame-data-slot parent :tile-size) 0.8)))
 584       (if (zerop len)
 585           (no-layout child parent)
 586           (if (child-member child main-windows)
 587               (let* ((dy (/ rh len))
 588                      (pos (child-position child main-windows)))
 589                 (values (adj-border-xy (round (+ rx (* rw (- 1 size)))) child)
 590                         (adj-border-xy (round (+ ry (* dy pos))) child)
 591                         (adj-border-wh (round (* rw size)) child)
 592                         (adj-border-wh (round dy) child)))
 593               (values (adj-border-xy rx child)
 594                       (adj-border-xy ry child)
 595                       (adj-border-wh (round (* rw (- 1 size))) child)
 596                       (adj-border-wh rh child)))))))
 597
 598 (defun set-main-window-right-layout ()
 599   "Main window right: Main windows on the right. Others on the left."
 600   (layout-ask-size "Split size in percent (%)" :tile-size)
 601   (set-layout #'main-window-right-layout))
 602
 603
 604
 605
 606 (defun main-window-left-layout (child parent)
 607   "Main window left: Main windows on the left. Others on the right."
 608   (with-slots (rx ry rw rh) parent
 609     (let* ((main-windows (frame-data-slot parent :main-window-list))
 610            (len (length main-windows))
 611            (size (or (frame-data-slot parent :tile-size) 0.8)))
 612       (if (zerop len)
 613           (no-layout child parent)
 614           (if (child-member child main-windows)
 615               (let* ((dy (/ rh len))
 616                      (pos (child-position child main-windows)))
 617                 (values (adj-border-xy rx child)
 618                         (adj-border-xy (round (+ ry (* dy pos))) child)
 619                         (adj-border-wh (round (* rw size)) child)
 620                         (adj-border-wh (round dy) child)))
 621               (values (adj-border-xy (round (+ rx (* rw size))) child)
 622                       (adj-border-xy ry child)
 623                       (adj-border-wh (round (* rw (- 1 size))) child)
 624                       (adj-border-wh rh child)))))))
 625
 626 (defun set-main-window-left-layout ()
 627   "Main window left: Main windows on the left. Others on the right."
 628   (layout-ask-size "Split size in percent (%)" :tile-size)
 629   (set-layout #'main-window-left-layout))
 630
 631
 632
 633 (defun main-window-top-layout (child parent)
 634   "Main window top: Main windows on the top. Others on the bottom."
 635   (with-slots (rx ry rw rh) parent
 636     (let* ((main-windows (frame-data-slot parent :main-window-list))
 637            (len (length main-windows))
 638            (size (or (frame-data-slot parent :tile-size) 0.8)))
 639       (if (zerop len)
 640           (no-layout child parent)
 641           (if (child-member child main-windows)
 642               (let* ((dx (/ rw len))
 643                      (pos (child-position child main-windows)))
 644                 (values (adj-border-xy (round (+ rx (* dx pos))) child)
 645                         (adj-border-xy ry child)
 646                         (adj-border-wh (round dx) child)
 647                         (adj-border-wh (round (* rh size)) child)))
 648               (values (adj-border-xy rx child)
 649                       (adj-border-xy (round (+ ry (* rh size))) child)
 650                       (adj-border-wh rw child)
 651                       (adj-border-wh (round (* rh (- 1 size))) child)))))))
 652
 653 (defun set-main-window-top-layout ()
 654   "Main window top: Main windows on the top. Others on the bottom."
 655   (layout-ask-size "Split size in percent (%)" :tile-size)
 656   (set-layout #'main-window-top-layout))
 657
 658
 659
 660 (defun main-window-bottom-layout (child parent)
 661   "Main window bottom: Main windows on the bottom. Others on the top."
 662   (with-slots (rx ry rw rh) parent
 663     (let* ((main-windows (frame-data-slot parent :main-window-list))
 664            (len (length main-windows))
 665            (size (or (frame-data-slot parent :tile-size) 0.8)))
 666       (if (zerop len)
 667           (no-layout child parent)
 668           (if (child-member child main-windows)
 669               (let* ((dx (/ rw len))
 670                      (pos (child-position child main-windows)))
 671                 (values (adj-border-xy (round (+ rx (* dx pos))) child)
 672                         (adj-border-xy (round (+ ry (* rh (- 1 size)))) child)
 673                         (adj-border-wh (round dx) child)
 674                         (adj-border-wh (round (* rh size)) child)))
 675               (values (adj-border-xy rx child)
 676                       (adj-border-xy ry child)
 677                       (adj-border-wh rw child)
 678                       (adj-border-wh (round (* rh (- 1 size))) child)))))))
 679
 680 (defun set-main-window-bottom-layout ()
 681   "Main window bottom: Main windows on the bottom. Others on the top."
 682   (layout-ask-size "Split size in percent (%)" :tile-size)
 683   (set-layout #'main-window-bottom-layout))
 684
 685
 686
 687
 688
 689 (defun add-in-main-window-list ()
 690   "Add the current window in the main window list"
 691   (when (frame-p *current-child*)
 692     (with-current-window
 693       (when (child-member window (get-managed-child *current-child*))
 694         (pushnew window (frame-data-slot *current-child* :main-window-list)))))
 695   (leave-second-mode))
 696
 697
 698 (defun remove-in-main-window-list ()
 699   "Remove the current window from the main window list"
 700   (when (frame-p *current-child*)
 701     (with-current-window
 702       (when (child-member window (get-managed-child *current-child*))
 703         (setf (frame-data-slot *current-child* :main-window-list)
 704               (child-remove window (frame-data-slot *current-child* :main-window-list))))))
 705   (leave-second-mode))
 706
 707 (defun clear-main-window-list ()
 708   "Clear the main window list"
 709   (when (frame-p *current-child*)
 710     (setf (frame-data-slot *current-child* :main-window-list) nil))
 711   (leave-second-mode))
 712
 713
 714
 715
 716 (register-layout-sub-menu 'frame-main-window-layout-menu "Main window layout menu"
 717                           '(("r" set-main-window-right-layout)
 718                             ("l" set-main-window-left-layout)
 719                             ("t" set-main-window-top-layout)
 720                             ("b" set-main-window-bottom-layout)
 721                             "-=- Actions on main windows list -=-"
 722                             ("a" add-in-main-window-list)
 723                             ("v" remove-in-main-window-list)
 724                             ("c" clear-main-window-list)))
 725
 726
 727 ;;; GIMP layout specifics functions
 728 ;;;
 729 (defconfig *gimp-layout-notify-window-delay* 30 'gimp-layout
 730            "Time to display the GIMP layout notify window help")
 731
 732
 733 (defun select-next/previous-child-no-main-window (fun-rotate)
 734   "Select the next/previous child - Skip windows in main window list"
 735   (when (frame-p *current-child*)
 736     (with-slots (child) *current-child*
 737       (let* ((main-windows (frame-data-slot *current-child* :main-window-list))
 738              (to-skip? (not (= (length main-windows)
 739                                (length child)))))
 740         (labels ((rec ()
 741                    (setf child (funcall fun-rotate child))
 742                    (when (and to-skip?
 743                               (child-member (frame-selected-child *current-child*) main-windows))
 744                      (rec))))
 745           (unselect-all-frames)
 746           (rec)
 747           (show-all-children))))))
 748
 749
 750 (defun select-next-child-no-main-window ()
 751   "Select the next child - Skip windows in main window list"
 752   (select-next/previous-child-no-main-window #'rotate-list))
 753
 754 (defun select-previous-child-no-main-window ()
 755   "Select the previous child - Skip windows in main window list"
 756   (select-next/previous-child-no-main-window #'anti-rotate-list))
 757
 758
 759 (defun mouse-click-to-focus-and-move-no-main-window (window root-x root-y)
 760   "Move and focus the current frame or focus the current window parent.
 761 Or do actions on corners - Skip windows in main window list"
 762   (unless (do-corner-action root-x root-y *corner-main-mode-left-button*)
 763     (if (and (frame-p *current-child*)
 764              (child-member window (frame-data-slot *current-child* :main-window-list)))
 765         (replay-button-event)
 766         (mouse-click-to-focus-generic root-x root-y #'move-frame))))
 767
 768
 769
 770 (let ((help-text-list `(("-=- Help on The GIMP layout -=-" ,*info-color-title*)
 771                         ""
 772                         "The GIMP layout is a main-window-layout with a sloppy focus policy."
 773                         "You can change the main windows direction with the layout menu."
 774                         ""
 775                         "Press Alt+F8 to add a window to the main windows list."
 776                         "Press Alt+F9 to remove a window from the main windows list."
 777                         "Press Alt+F10 to clear the main windows list."
 778                         ""
 779                         "You can select a main window with the right mouse button."
 780                         ""
 781                         "Use the layout menu to restore the previous layout and keybinding.")))
 782   (defun help-on-gimp-layout ()
 783     "Help on the GIMP layout"
 784     (info-mode help-text-list)
 785     (leave-second-mode))
 786
 787   (defun set-gimp-layout ()
 788     "The GIMP Layout"
 789     (when (frame-p *current-child*)
 790       ;; Note: There is no need to ungrab/grab keys because this
 791       ;; is done when leaving the second mode.
 792       (define-main-key ("F8" :mod-1) 'add-in-main-window-list)
 793       (define-main-key ("F9" :mod-1) 'remove-in-main-window-list)
 794       (define-main-key ("F10" :mod-1) 'clear-main-window-list)
 795       (define-main-key ("Tab" :mod-1) 'select-next-child-no-main-window)
 796       (define-main-key ("Tab" :mod-1 :shift) 'select-previous-child-no-main-window)
 797       (define-main-mouse (1) 'mouse-click-to-focus-and-move-no-main-window)
 798       (setf (frame-data-slot *current-child* :focus-policy-save)
 799             (frame-focus-policy *current-child*))
 800       (setf (frame-focus-policy *current-child*) :sloppy)
 801       (setf (frame-data-slot *current-child* :layout-save)
 802             (frame-layout *current-child*))
 803       (open-notify-window help-text-list)
 804       (add-timer *gimp-layout-notify-window-delay* #'close-notify-window)
 805       ;; Set the default layout and leave the second mode.
 806       (set-main-window-right-layout))))
 807
 808
 809 (defun set-previous-layout ()
 810   "Restore the previous layout"
 811   (undefine-main-key ("F8" :mod-1))
 812   (undefine-main-key ("F9" :mod-1))
 813   (undefine-main-key ("F10" :mod-1))
 814   (define-main-key ("Tab" :mod-1) 'select-next-child)
 815   (define-main-key ("Tab" :mod-1 :shift) 'select-previous-child)
 816   (define-main-mouse (1) 'mouse-click-to-focus-and-move)
 817   (setf (frame-focus-policy *current-child*)
 818         (frame-data-slot *current-child* :focus-policy-save))
 819   (setf (frame-layout *current-child*)
 820         (frame-data-slot *current-child* :layout-save))
 821   (leave-second-mode))
 822
 823
 824
 825
 826 (register-layout-sub-menu 'frame-gimp-layout-menu "The GIMP layout menu"
 827                           '(("g" set-gimp-layout)
 828                             ("p" set-previous-layout)
 829                             ("h" help-on-gimp-layout)
 830                             "-=- Main window layout -=-"
 831                             ("r" set-main-window-right-layout)
 832                             ("l" set-main-window-left-layout)
 833                             ("t" set-main-window-top-layout)
 834                             ("b" set-main-window-bottom-layout)
 835                             "-=- Actions on main windows list -=-"
 836                             ("a" add-in-main-window-list)
 837                             ("v" remove-in-main-window-list)
 838                             ("c" clear-main-window-list)))
 839
 840