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