src/clfswm-layout.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Layout functions
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2012 Philippe Brochard <pbrochard@common-lisp.net>
   9 ;;;
  10 ;;; This program is free software; you can redistribute it and/or modify
  11 ;;; it under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or
  13 ;;; (at your option) any later version.
  14 ;;;
  15 ;;; This program is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with this program; if not, write to the Free Software
  22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  23 ;;;
  24 ;;; --------------------------------------------------------------------------
  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 (defun set-layout-simple (layout)
  64   "Set the layout of the current child"
  65   (set-layout-dont-leave layout)
  66   (show-all-children))
  67
  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))))
  74
  75
  76 (defun next-layout-key ()
  77   (code-char (incf *layout-current-key*)))
  78
  79
  80 (defun register-layout (layout)
  81   (add-menu-key 'frame-layout-menu (next-layout-key) layout))
  82
  83
  84 (defun register-layout-sub-menu (name doc layout-list)
  85   (add-sub-menu 'frame-layout-menu (next-layout-key) name doc)
  86   (loop :for item :in layout-list
  87      :for i :from 0
  88      :do (typecase item
  89            (cons (add-menu-key name (first item) (second item)))
  90            (string (add-menu-comment name item))
  91            (t (add-menu-key name (number->char i) item)))))
  92
  93
  94
  95
  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)))))
 100
 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))))
 105
 106 (defun inc-tile-layout-size ()
 107   "Increase the tile layout size"
 108   (adjust-layout-size :tile-size 0.05)
 109   (show-all-children))
 110
 111 (defun dec-tile-layout-size ()
 112   "Decrease the tile layout size"
 113   (adjust-layout-size :tile-size -0.05)
 114   (show-all-children))
 115
 116 (defun inc-slow-tile-layout-size ()
 117   "Increase slowly the tile layout size"
 118   (adjust-layout-size :tile-size 0.01)
 119   (show-all-children))
 120
 121 (defun dec-slow-tile-layout-size ()
 122   "Decrease slowly the tile layout size"
 123   (adjust-layout-size :tile-size -0.01)
 124   (show-all-children))
 125
 126
 127
 128
 129 (defun fast-layout-switch ()
 130   "Switch between two layouts"
 131   (when (frame-p (current-child))
 132     (with-slots (layout) (current-child)
 133       (let* ((layout-list (frame-data-slot (current-child) :fast-layout))
 134              (first-layout (ensure-function (first layout-list)))
 135              (second-layout (ensure-function (second layout-list))))
 136         (setf layout (if (eql layout first-layout)
 137                          second-layout
 138                          first-layout))
 139         (leave-second-mode)))))
 140
 141
 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)))
 149
 150
 151
 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)))
 155
 156
 157 ;;; No layout
 158 (defgeneric no-layout (child parent)
 159   (:documentation "No layout: Maximize windows in their frame - Leave frames to their original size"))
 160
 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))))
 167
 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)))
 173
 174
 175
 176 (defun set-no-layout ()
 177   "No layout: Maximize windows in their frame - Leave frames to their original size"
 178   (set-layout #'no-layout))
 179
 180 (register-layout 'set-no-layout)
 181
 182 ;;; No layout remember size
 183 (defun set-no-layout-remember-size ()
 184   "No layout: Maximize windows in their frame - Leave frames to their actual size"
 185   (fixe-real-size-current-child)
 186   (set-no-layout))
 187
 188 (register-layout 'set-no-layout-remember-size)
 189
 190
 191
 192 ;;; Maximize layout
 193 (defgeneric maximize-layout (child parent)
 194   (:documentation "Maximize layout: Maximize windows and frames in their parent frame"))
 195
 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))))
 202
 203
 204 (defun set-maximize-layout ()
 205   "Maximize layout: Maximize windows and frames in their parent frame"
 206   (set-layout #'maximize-layout))
 207
 208 (register-layout 'set-maximize-layout)
 209
 210
 211
 212
 213 ;;; Tile layout
 214 (defun tile-layout-ask-keep-position ()
 215   (when (frame-p (current-child))
 216     (if (query-yes-or-no "Keep frame children positions?")
 217         (setf (frame-data-slot (current-child) :tile-layout-keep-position) :yes)
 218         (remove-frame-data-slot (current-child) :tile-layout-keep-position))))
 219
 220
 221
 222 (labels ((set-managed ()
 223            (setf (frame-data-slot (current-child) :layout-managed-children)
 224                  (copy-list (get-managed-child (current-child))))))
 225   (defun set-layout-managed-children ()
 226     (when (frame-p (current-child))
 227       (set-managed)
 228       (tile-layout-ask-keep-position)))
 229
 230
 231   (defun update-layout-managed-children-position ()
 232     "Update layout managed children position"
 233     (when (frame-p (current-child))
 234       (set-managed)
 235       (leave-second-mode))))
 236
 237
 238
 239 (defun update-layout-managed-children-keep-position (child parent)
 240   (declare (ignore child))
 241   (let ((managed-children (frame-data-slot parent :layout-managed-children))
 242         (managed-in-parent (get-managed-child parent)))
 243     (dolist (ch managed-in-parent)
 244       (unless (child-member ch managed-children)
 245         (setf managed-children (append managed-children (list ch)))))
 246     (setf managed-children (remove-if-not (lambda (x)
 247                                             (child-member x managed-in-parent))
 248                                           managed-children))
 249     (setf (frame-data-slot parent :layout-managed-children) managed-children)
 250     managed-children))
 251
 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)))
 256
 257
 258
 259 (defgeneric tile-layout (child parent)
 260   (:documentation "Tile child in its frame (vertical)"))
 261
 262 (defmethod tile-layout (child parent)
 263   (let* ((managed-children (update-layout-managed-children child parent))
 264          (pos (child-position child managed-children))
 265          (len (length managed-children))
 266          (nx (ceiling (sqrt len)))
 267          (ny  (ceiling (/ len nx)))
 268          (dx (/ (frame-rw parent) nx))
 269          (dy (/ (frame-rh parent) ny))
 270          (dpos (- (* nx ny) len))
 271          (width dx))
 272     (when (plusp dpos)
 273       (if (zerop pos)
 274           (setf width (* dx (1+ dpos)))
 275           (incf pos dpos)))
 276     (values (round (adj-border-xy (+ (frame-rx parent) (truncate (* (mod pos nx) dx))) parent))
 277             (round (adj-border-xy (+ (frame-ry parent) (truncate (* (truncate (/ pos nx)) dy))) parent))
 278             (round (adj-border-wh width child))
 279             (round (adj-border-wh dy child)))))
 280
 281 (defun set-tile-layout ()
 282   "Tile child in its frame (vertical)"
 283   (set-layout-managed-children)
 284   (set-layout #'tile-layout))
 285
 286
 287
 288 ;; Horizontal tiling layout
 289 (defgeneric tile-horizontal-layout (child parent)
 290   (:documentation "Tile child in its frame (horizontal)"))
 291
 292 (defmethod tile-horizontal-layout (child parent)
 293   (let* ((managed-children (update-layout-managed-children child parent))
 294          (pos (child-position child managed-children))
 295          (len (length managed-children))
 296          (ny (ceiling (sqrt len)))
 297          (nx (ceiling (/ len ny)))
 298          (dx (/ (frame-rw parent) nx))
 299          (dy (/ (frame-rh parent) ny))
 300          (dpos (- (* nx ny) len))
 301          (height dy))
 302     (when (plusp dpos)
 303       (if (zerop pos)
 304           (setf height (* dy (1+ dpos)))
 305           (incf pos dpos)))
 306     (values (round (adj-border-xy (+ (frame-rx parent) (truncate (* (truncate (/ pos ny)) dx))) parent))
 307             (round (adj-border-xy (+ (frame-ry parent) (truncate (* (mod pos ny) dy))) parent))
 308             (round (adj-border-wh dx child))
 309             (round (adj-border-wh height child)))))
 310
 311 (defun set-tile-horizontal-layout ()
 312   "Tile child in its frame (horizontal)"
 313   (set-layout-managed-children)
 314   (set-layout #'tile-horizontal-layout))
 315
 316
 317
 318
 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)"))
 322
 323 (defmethod tile-layout-mix (child parent)
 324   (let* ((managed-children (update-layout-managed-children child parent))
 325          (pos (child-position child managed-children))
 326          (len (length managed-children))
 327          (d1 (ceiling (sqrt len)))
 328          (d2  (ceiling (/ len d1)))
 329          (nx (if (> (frame-rw parent) (frame-rh parent)) d1 d2))
 330          (ny (if (> (frame-rw parent) (frame-rh parent)) d2 d1))
 331          (dx (/ (frame-rw parent) nx))
 332          (dy (/ (frame-rh parent) ny))
 333          (dpos (- (* nx ny) len))
 334          (width dx))
 335     (when (plusp dpos)
 336       (if (zerop pos)
 337           (setf width (* dx (1+ dpos)))
 338           (incf pos dpos)))
 339     (values (round (adj-border-xy (+ (frame-rx parent)
 340                                      (truncate (* (mod pos nx) dx))) parent))
 341             (round (adj-border-xy (+ (frame-ry parent)
 342                                      (truncate (* (truncate (/ pos nx)) dy))) parent))
 343             (round (adj-border-wh width child))
 344             (round (adj-border-wh dy child)))))
 345
 346
 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))
 351
 352
 353 ;; One column layout
 354 (defgeneric one-column-layout (child parent)
 355   (:documentation "One column layout"))
 356
 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)))))
 366
 367 (defun set-one-column-layout ()
 368   "One column layout"
 369   (set-layout-managed-children)
 370   (set-layout #'one-column-layout))
 371
 372
 373 ;; One line layout
 374 (defgeneric one-line-layout (child parent)
 375   (:documentation "One line layout"))
 376
 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)))))
 386
 387 (defun set-one-line-layout ()
 388   "One line layout"
 389   (set-layout-managed-children)
 390   (set-layout #'one-line-layout))
 391
 392
 393
 394
 395
 396 ;;; Space layout
 397 (defun tile-space-layout (child parent)
 398   "Tile Space: tile child in its frame leaving spaces between them"
 399   (with-slots (rx ry rw rh) parent
 400     (let* ((managed-children (update-layout-managed-children child parent))
 401            (pos (child-position child managed-children))
 402            (len (length managed-children))
 403            (d1 (ceiling (sqrt len)))
 404            (d2 (ceiling (/ len d1)))
 405            (cols (if (> rw rh) d1 d2))
 406            (rows (if (> rw rh) d2 d1))
 407            (col (mod pos cols))
 408            (row (floor pos cols))
 409            (space-percent (or (frame-data-slot parent :tile-space-size) 0.05))
 410            (col-space-total (* rw space-percent))
 411            (row-space-total (* rh space-percent))
 412            (col-space (floor col-space-total (1+ cols)))
 413            (row-space (floor row-space-total (1+ rows)))
 414            (child-width (floor (- rw col-space-total) cols))
 415            (child-height (floor (- rh row-space-total) rows))
 416            )
 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))))))
 421
 422
 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))
 428
 429
 430
 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)))
 438
 439
 440
 441 ;;; Tile Left
 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))
 448            (dy (/ rh len))
 449            (size (or (frame-data-slot parent :tile-size) 0.8)))
 450       (if (> (length managed-children) 1)
 451           (if (= pos 0)
 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)))))
 461
 462
 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))
 468
 469
 470
 471 ;;; Tile right
 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))
 478            (dy (/ rh len))
 479            (size (or (frame-data-slot parent :tile-size) 0.8)))
 480       (if (> (length managed-children) 1)
 481           (if (= pos 0)
 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)))))
 491
 492
 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))
 498
 499
 500
 501
 502
 503
 504 ;;; Tile Top
 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))
 511            (dx (/ rw len))
 512            (size (or (frame-data-slot parent :tile-size) 0.8)))
 513       (if (> (length managed-children) 1)
 514           (if (= pos 0)
 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)))))
 524
 525
 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))
 531
 532
 533
 534
 535 ;;; Tile Bottom
 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))
 542            (dx (/ rw len))
 543            (size (or (frame-data-slot parent :tile-size) 0.8)))
 544       (if (> (length managed-children) 1)
 545           (if (= pos 0)
 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)))))
 555
 556
 557
 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))
 563
 564
 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)))
 570
 571
 572
 573
 574
 575
 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))))
 581
 582
 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))
 589            (dy (/ rh len))
 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)
 593           (if (= pos 0)
 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)
 605                     rny
 606                     (- rnw space)
 607                     rnh))))))
 608
 609
 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))
 616
 617 (register-layout-sub-menu 'frame-tile-space-layout-menu "Tile with some space on one side menu"
 618                           '(set-tile-left-space-layout))
 619
 620
 621
 622
 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)))
 632       (if (zerop len)
 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)))))))
 645
 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))
 650
 651
 652
 653
 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)))
 660       (if (zerop len)
 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)))))))
 673
 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))
 678
 679
 680
 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)))
 687       (if (zerop len)
 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)))))))
 700
 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))
 705
 706
 707
 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)))
 714       (if (zerop len)
 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)))))))
 727
 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))
 732
 733
 734
 735
 736
 737 (defun add-in-main-window-list ()
 738   "Add the current window in the main window list"
 739   (when (frame-p (current-child))
 740     (with-current-window
 741       (when (child-member window (get-managed-child (current-child)))
 742         (pushnew window (frame-data-slot (current-child) :main-window-list)))))
 743   (leave-second-mode))
 744
 745
 746 (defun remove-in-main-window-list ()
 747   "Remove the current window from the main window list"
 748   (when (frame-p (current-child))
 749     (with-current-window
 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))))))
 753   (leave-second-mode))
 754
 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))
 759   (leave-second-mode))
 760
 761
 762
 763
 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)))
 773
 774
 775 ;;; GIMP layout specifics functions
 776 ;;;
 777 (defconfig *gimp-layout-notify-window-delay* 30 'gimp-layout
 778            "Time to display the GIMP layout notify window help")
 779
 780
 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)
 787                                (length child)))))
 788         (labels ((rec ()
 789                    (setf child (funcall fun-rotate child))
 790                    (when (and to-skip?
 791                               (child-member (frame-selected-child (current-child)) main-windows))
 792                      (rec))))
 793           (unselect-all-frames)
 794           (rec)
 795           (show-all-children))))))
 796
 797
 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))
 801
 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))
 805
 806
 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))))
 815
 816
 817
 818 (let ((help-text-list `(("-=- Help on The GIMP layout -=-" ,*info-color-title*)
 819                         ""
 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."
 822                         ""
 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."
 826                         ""
 827                         "You can select a main window with the right mouse button."
 828                         ""
 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)
 833     (leave-second-mode))
 834
 835   (defun set-gimp-layout ()
 836     "The 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))))
 855
 856
 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))
 869   (leave-second-mode))
 870
 871
 872
 873
 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)))
 887
 888