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