src/clfswm-util.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Utility
   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 ;;; Configuration file
  30 (defun xdg-config-home ()
  31   (aif (getenv "XDG_CONFIG_HOME")
  32        (pathname-directory (concatenate 'string it "/"))
  33        (append (pathname-directory (user-homedir-pathname)) '(".config"))))
  34
  35
  36 (let ((saved-conf-name nil))
  37   (defun conf-file-name (&optional alternate-name)
  38     (unless (and saved-conf-name (not alternate-name))
  39       (let* ((user-conf (probe-file (merge-pathnames (user-homedir-pathname) #p".clfswmrc")))
  40              (etc-conf (probe-file #p"/etc/clfswmrc"))
  41              (config-user-conf (probe-file (make-pathname :directory (append (xdg-config-home) '("clfswm"))
  42                                                           :name "clfswmrc")))
  43              (alternate-conf (and alternate-name (probe-file alternate-name))))
  44         (setf saved-conf-name (or alternate-conf config-user-conf user-conf etc-conf))))
  45     (print saved-conf-name)
  46     saved-conf-name))
  47
  48
  49
  50
  51 (defun load-contrib (file)
  52   "Load a file in the contrib directory"
  53   (let ((truename (merge-pathnames file *contrib-dir*)))
  54     (format t "Loading contribution file: ~A~%" truename)
  55     (when (probe-file truename)
  56       (load truename :verbose nil))))
  57
  58
  59 (defun reload-clfswm ()
  60   "Reload clfswm"
  61   (format t "~&-*- Reloading CLFSWM -*-~%")
  62   (asdf:oos 'asdf:load-op :clfswm)
  63   (reset-clfswm))
  64
  65
  66
  67 (defun query-yes-or-no (formatter &rest args)
  68   (let ((rep (query-string (apply #'format nil formatter args) "" '("Yes" "No"))))
  69     (or (string= rep "")
  70         (char= (char rep 0) #\y)
  71         (char= (char rep 0) #\Y))))
  72
  73
  74
  75 (defun banish-pointer ()
  76   "Move the pointer to the lower right corner of the screen"
  77   (with-placement (*banish-pointer-placement* x y)
  78     (xlib:warp-pointer *root* x y)))
  79
  80
  81
  82
  83 ;;; Root functions utility
  84 (defun select-generic-root (fun restart-menu)
  85   (no-focus)
  86   (let* ((current-root (find-root (current-child)))
  87          (parent (find-parent-frame (root-original current-root))))
  88     (when parent
  89       (setf (frame-child parent) (funcall fun (frame-child parent)))
  90       (let ((new-root (find-root (frame-selected-child parent))))
  91         (setf (current-child) (aif (root-current-child new-root)
  92                                    it
  93                                    (frame-selected-child parent))))))
  94   (show-all-children t)
  95   (if restart-menu
  96       (open-menu (find-menu 'root-menu))
  97       (leave-second-mode)))
  98
  99 (defun select-next-root ()
 100   "Select the next root"
 101   (select-generic-root #'rotate-list nil))
 102
 103 (defun select-previous-root ()
 104   "Select the previous root"
 105   (select-generic-root #'anti-rotate-list nil))
 106
 107
 108 (defun select-next-root-restart-menu ()
 109   "Select the next root"
 110   (select-generic-root #'rotate-list t))
 111
 112 (defun select-previous-root-restart-menu ()
 113   "Select the previous root"
 114   (select-generic-root #'anti-rotate-list t))
 115
 116
 117 (defun rotate-root-geometry-generic (fun restart-menu)
 118   (no-focus)
 119   (funcall fun)
 120   (show-all-children t)
 121   (if restart-menu
 122       (open-menu (find-menu 'root-menu))
 123       (leave-second-mode)))
 124
 125
 126 (defun rotate-root-geometry-next ()
 127   "Rotate root geometry to next root"
 128   (rotate-root-geometry-generic #'rotate-root-geometry nil))
 129
 130 (defun rotate-root-geometry-previous ()
 131   "Rotate root geometry to previous root"
 132   (rotate-root-geometry-generic #'anti-rotate-root-geometry nil))
 133
 134 (defun rotate-root-geometry-next-restart-menu ()
 135   "Rotate root geometry to next root"
 136   (rotate-root-geometry-generic #'rotate-root-geometry t))
 137
 138 (defun rotate-root-geometry-previous-restart-menu ()
 139   "Rotate root geometry to previous root"
 140   (rotate-root-geometry-generic #'anti-rotate-root-geometry t))
 141
 142
 143
 144 (defun exchange-root-geometry-with-mouse ()
 145   "Exchange two root geometry pointed with the mouse"
 146   (open-notify-window '("Select the first root to exchange"))
 147   (wait-no-key-or-button-press)
 148   (wait-mouse-button-release)
 149   (close-notify-window)
 150   (multiple-value-bind (x1 y1) (xlib:query-pointer *root*)
 151     (open-notify-window '("Select the second root to exchange"))
 152     (wait-no-key-or-button-press)
 153     (wait-mouse-button-release)
 154     (close-notify-window)
 155     (multiple-value-bind (x2 y2) (xlib:query-pointer *root*)
 156       (exchange-root-geometry (find-root-by-coordinates x1 y1)
 157                               (find-root-by-coordinates x2 y2))))
 158   (show-all-children)
 159   (leave-second-mode))
 160
 161 (defun change-current-root-geometry ()
 162   "Change the current root geometry"
 163   (let* ((root (find-root (current-child)))
 164          (x (query-number "New root X position" (root-x root)))
 165          (y (query-number "New root Y position" (root-y root)))
 166          (w (query-number "New root width" (root-w root)))
 167          (h (query-number "New root height" (root-h root))))
 168     (setf (root-x root) x  (root-y root) y
 169           (root-w root) w  (root-h root) h)
 170     (show-all-children)
 171     (leave-second-mode)))
 172
 173
 174
 175 (defun display-all-frame-info ()
 176   (with-all-frames (*root-frame* frame)
 177     (display-frame-info frame)))
 178
 179 (defun display-all-root-frame-info ()
 180   (with-all-root-child (root)
 181     (display-frame-info root)))
 182
 183
 184
 185 (defun place-window-from-hints (window)
 186   "Place a window from its hints"
 187   (let* ((hints (xlib:wm-normal-hints window))
 188          (min-width (or (and hints (xlib:wm-size-hints-min-width hints)) 0))
 189          (min-height (or (and hints (xlib:wm-size-hints-min-height hints)) 0))
 190          (max-width (or (and hints (xlib:wm-size-hints-max-width hints)) (x-drawable-width *root*)))
 191          (max-height (or (and hints (xlib:wm-size-hints-max-height hints)) (x-drawable-height *root*)))
 192          (rwidth (or (and hints (or (xlib:wm-size-hints-width hints) (xlib:wm-size-hints-base-width hints)))
 193                      (x-drawable-width window)))
 194          (rheight (or (and hints (or (xlib:wm-size-hints-height hints) (xlib:wm-size-hints-base-height hints)))
 195                       (x-drawable-height window))))
 196     (setf (x-drawable-width window) (min (max min-width rwidth *default-window-width*) max-width)
 197           (x-drawable-height window) (min (max min-height rheight *default-window-height*) max-height))
 198     (with-placement (*unmanaged-window-placement* x y (x-drawable-width window) (x-drawable-height window))
 199       (setf (x-drawable-x window) x
 200             (x-drawable-y window) y))
 201     (xlib:display-finish-output *display*)))
 202
 203
 204 (defun rename-current-child ()
 205   "Rename the current child"
 206   (let ((name (query-string (format nil "New child name: (last: ~A)" (child-name (current-child)))
 207                             (child-name (current-child)))))
 208     (rename-child (current-child) name)
 209     (leave-second-mode)))
 210
 211
 212 (defun ask-child-transparency (msg child)
 213   (let ((trans (query-number (format nil "New ~A transparency: (last: ~A)"
 214                                      msg
 215                                      (* 100 (child-transparency child)))
 216                              (* 100 (child-transparency child)))))
 217     (when (numberp trans)
 218       (setf (child-transparency child) (float (/ trans 100))))))
 219
 220 (defun set-current-child-transparency ()
 221   "Set the current child transparency"
 222   (ask-child-transparency "child" (current-child))
 223   (leave-second-mode))
 224
 225
 226 (defun ask-child-border-size (msg child)
 227   (let ((size (query-number (format nil "New ~A border size: (last: ~A)"
 228                                     msg
 229                                     (child-border-size child))
 230                             (child-border-size child))))
 231     (when (numberp size)
 232       (setf (child-border-size child) size))))
 233
 234
 235 (defun set-current-child-border-size ()
 236   "Set the current child border size"
 237   (ask-child-border-size "child" (current-child))
 238   (leave-second-mode))
 239
 240
 241 (defun renumber-current-frame ()
 242   "Renumber the current frame"
 243   (when (frame-p (current-child))
 244     (let ((number (query-number (format nil "New child number: (last: ~A)" (frame-number (current-child)))
 245                                 (frame-number (current-child)))))
 246       (setf (frame-number (current-child)) number)
 247       (leave-second-mode))))
 248
 249
 250
 251
 252 (defun add-default-frame ()
 253   "Add a default frame in the current frame"
 254   (when (frame-p (current-child))
 255     (let ((name (query-string "Frame name")))
 256       (push (create-frame :name name) (frame-child (current-child)))))
 257   (leave-second-mode))
 258
 259 (defun add-frame-in-parent-frame ()
 260   "Add a frame in the parent frame (and reorganize parent frame)"
 261   (let ((parent (find-parent-frame (current-child))))
 262     (when (and parent (not (child-original-root-p (current-child))))
 263       (let ((new-frame (create-frame)))
 264         (pushnew new-frame (frame-child parent))
 265         (awhen (child-root-p (current-child))
 266           (change-root it parent))
 267         (setf (current-child) parent)
 268         (set-layout-once #'tile-space-layout)
 269         (setf (current-child) new-frame)
 270         (leave-second-mode)))))
 271
 272
 273
 274
 275 (defun add-placed-frame ()
 276   "Add a placed frame in the current frame"
 277   (when (frame-p (current-child))
 278     (let ((name (query-string "Frame name"))
 279           (x (/ (query-number "Frame x in percent (%)") 100))
 280           (y (/ (query-number "Frame y in percent (%)") 100))
 281           (w (/ (query-number "Frame width in percent (%)" 100) 100))
 282           (h (/ (query-number "Frame height in percent (%)" 100) 100)))
 283       (push (create-frame :name name :x x :y y :w w :h h)
 284             (frame-child (current-child)))))
 285   (leave-second-mode))
 286
 287
 288
 289 (defun delete-focus-window-generic (close-fun)
 290   (with-focus-window (window)
 291     (when (child-equal-p window (current-child))
 292       (setf (current-child) (find-current-root)))
 293     (delete-child-and-children-in-all-frames window close-fun)))
 294
 295 (defun delete-focus-window ()
 296   "Close focus window: Delete the focus window in all frames and workspaces"
 297   (delete-focus-window-generic 'delete-window))
 298
 299 (defun destroy-focus-window ()
 300   "Kill focus window: Destroy the focus window in all frames and workspaces"
 301   (delete-focus-window-generic 'destroy-window))
 302
 303 (defun remove-focus-window ()
 304   "Remove the focus window from the current frame"
 305   (with-focus-window (window)
 306     (setf (current-child) (find-current-root))
 307     (hide-child window)
 308     (remove-child-in-frame window (find-parent-frame window))
 309     (show-all-children)))
 310
 311
 312 (defun unhide-all-windows-in-current-child ()
 313   "Unhide all hidden windows into the current child"
 314   (dolist (window (get-hidden-windows))
 315     (unhide-window window)
 316     (process-new-window window)
 317     (map-window window))
 318   (show-all-children))
 319
 320
 321
 322
 323 (defun find-window-under-mouse (x y)
 324   "Return the child window under the mouse"
 325   (let ((win *root*))
 326     (with-all-root-child (root)
 327       (with-all-windows-frames-and-parent (root child parent)
 328         (when (and (or (managed-window-p child parent) (child-equal-p parent (current-child)))
 329                    (not (window-hidden-p child))
 330                    (in-window child x y))
 331           (setf win child))
 332         (when (in-frame child x y)
 333           (setf win (frame-window child)))))
 334     win))
 335
 336
 337
 338
 339 (defun find-child-under-mouse-in-never-managed-windows (x y)
 340   "Return the child under mouse from never managed windows"
 341   (let ((ret nil))
 342     (dolist (win (xlib:query-tree *root*))
 343       (unless (window-hidden-p win)
 344         (multiple-value-bind (never-managed raise)
 345             (never-managed-window-p win)
 346           (when (and never-managed raise (in-window win x y))
 347             (setf ret win)))))
 348     ret))
 349
 350
 351 (defun find-child-under-mouse-in-child-tree (x y &optional first-foundp)
 352   "Return the child under the mouse"
 353   (let ((ret nil))
 354     (with-all-root-child (root)
 355       (with-all-windows-frames (root child)
 356         (when (and (not (window-hidden-p child))
 357                    (in-window child x y))
 358           (if first-foundp
 359               (return-from find-child-under-mouse-in-child-tree child)
 360               (setf ret child)))
 361         (when (in-frame child x y)
 362           (if first-foundp
 363               (return-from find-child-under-mouse-in-child-tree child)
 364               (setf ret child)))))
 365     ret))
 366
 367
 368
 369 (defun find-child-under-mouse (x y &optional first-foundp also-never-managed)
 370   "Return the child under the mouse"
 371   (or (and also-never-managed
 372            (find-child-under-mouse-in-never-managed-windows x y))
 373       (find-child-under-mouse-in-child-tree x y first-foundp)))
 374
 375
 376
 377
 378
 379 ;;; Selection functions
 380 (defun clear-selection ()
 381   "Clear the current selection"
 382   (setf *child-selection* nil)
 383   (display-all-root-frame-info))
 384
 385 (defun copy-current-child ()
 386   "Copy the current child to the selection"
 387   (pushnew (current-child) *child-selection*)
 388   (display-all-root-frame-info))
 389
 390
 391 (defun cut-current-child (&optional (show-now t))
 392   "Cut the current child to the selection"
 393   (unless (child-root-p (current-child))
 394     (let ((parent (find-parent-frame (current-child))))
 395       (hide-all (current-child))
 396       (copy-current-child)
 397       (remove-child-in-frame (current-child) (find-parent-frame (current-child) (find-current-root)))
 398       (when parent
 399         (setf (current-child) parent))
 400       (when show-now
 401         (show-all-children t))
 402       (current-child))))
 403
 404 (defun remove-current-child ()
 405   "Remove the current child from its parent frame"
 406   (unless (child-root-p (current-child))
 407     (let ((parent (find-parent-frame (current-child))))
 408       (hide-all (current-child))
 409       (remove-child-in-frame (current-child) (find-parent-frame (current-child) (find-current-root)))
 410       (when parent
 411         (setf (current-child) parent))
 412       (show-all-children t)
 413       (leave-second-mode))))
 414
 415 (defun delete-current-child ()
 416   "Delete the current child and its children in all frames"
 417   (unless (child-root-p (current-child))
 418     (hide-all (current-child))
 419     (delete-child-and-children-in-all-frames (current-child))
 420     (show-all-children t)
 421     (leave-second-mode)))
 422
 423
 424 (defun paste-selection-no-clear ()
 425   "Paste the selection in the current frame - Do not clear the selection after paste"
 426   (when (frame-p (current-child))
 427     (dolist (child *child-selection*)
 428       (unless (find-child-in-parent child (current-child))
 429         (pushnew child (frame-child (current-child)) :test #'child-equal-p)))
 430     (show-all-children)))
 431
 432 (defun paste-selection ()
 433   "Paste the selection in the current frame"
 434   (when (frame-p (current-child))
 435     (paste-selection-no-clear)
 436     (setf *child-selection* nil)
 437     (display-all-root-frame-info)))
 438
 439
 440 (defun copy-focus-window ()
 441   "Copy the focus window to the selection"
 442   (with-focus-window (window)
 443     (with-current-child (window)
 444       (copy-current-child))))
 445
 446
 447 (defun cut-focus-window ()
 448   "Cut the focus window to the selection"
 449   (with-focus-window (window)
 450     (setf (current-child) (with-current-child (window)
 451                             (cut-current-child nil)))
 452     (show-all-children t)))
 453
 454
 455
 456
 457
 458
 459 ;;; Maximize function
 460 (defun frame-toggle-maximize ()
 461   "Maximize/Unmaximize the current frame in its parent frame"
 462   (when (frame-p (current-child))
 463     (let ((unmaximized-coords (frame-data-slot (current-child) :unmaximized-coords)))
 464       (if unmaximized-coords
 465           (with-slots (x y w h) (current-child)
 466             (destructuring-bind (nx ny nw nh) unmaximized-coords
 467               (setf (frame-data-slot (current-child) :unmaximized-coords) nil
 468                     x nx y ny w nw h nh)))
 469           (with-slots (x y w h) (current-child)
 470             (setf (frame-data-slot (current-child) :unmaximized-coords)
 471                   (list x y w h)
 472                   x 0 y 0 w 1 h 1))))
 473     (show-all-children)
 474     (leave-second-mode)))
 475
 476
 477
 478
 479
 480
 481
 482
 483
 484 ;;; CONFIG - Identify mode
 485 (defun identify-key ()
 486   "Identify a key"
 487   (let* ((done nil)
 488          (font (xlib:open-font *display* *identify-font-string*))
 489          (window (xlib:create-window :parent *root*
 490                                      :x 0 :y 0
 491                                      :width (- (xlib:screen-width *screen*) (* *border-size* 2))
 492                                      :height (* 5 (+ (xlib:max-char-ascent font) (xlib:max-char-descent font)))
 493                                      :background (get-color *identify-background*)
 494                                      :border-width *border-size*
 495                                      :border (get-color *identify-border*)
 496                                      :colormap (xlib:screen-default-colormap *screen*)
 497                                      :event-mask '(:exposure)))
 498          (gc (xlib:create-gcontext :drawable window
 499                                    :foreground (get-color *identify-foreground*)
 500                                    :background (get-color *identify-background*)
 501                                    :font font
 502                                    :line-style :solid)))
 503     (setf (window-transparency window) *identify-transparency*)
 504     (labels ((print-doc (msg hash-table-key pos code state)
 505                (let ((function (find-key-from-code hash-table-key code state)))
 506                  (when (and function (fboundp (first function)))
 507                    (xlib:draw-glyphs *pixmap-buffer* gc 10 (+ (* pos (+ (xlib:max-char-ascent font) (xlib:max-char-descent font))) 5)
 508                                      (format nil "~A ~A" msg (documentation (first function) 'function))))))
 509              (print-key (code state keysym key modifiers)
 510                (clear-pixmap-buffer window gc)
 511                (setf (xlib:gcontext-foreground gc) (get-color *identify-foreground*))
 512                (xlib:draw-glyphs *pixmap-buffer* gc 5 (+ (xlib:max-char-ascent font) 5)
 513                                  (format nil "Press a key to identify. Press 'q' to stop the identify loop."))
 514                (when code
 515                  (xlib:draw-glyphs *pixmap-buffer* gc 10 (+ (* 2 (+ (xlib:max-char-ascent font) (xlib:max-char-descent font))) 5)
 516                                    (format nil "Code=~A  KeySym=~S  Key=~S  Modifiers=~A"
 517                                            code keysym key modifiers))
 518                  (print-doc "Main mode  : " *main-keys* 3 code state)
 519                  (print-doc "Second mode: " *second-keys* 4 code state))
 520                (copy-pixmap-buffer window gc))
 521              (handle-identify-key (&rest event-slots &key root code state &allow-other-keys)
 522                (declare (ignore event-slots root))
 523                (let* ((modifiers (state->modifiers state))
 524                       (key (keycode->char code state))
 525                       (keysym (keysym->keysym-name (keycode->keysym code modifiers))))
 526                  (setf done (and (equal key #\q) (equal modifiers *default-modifiers*)))
 527                  (dbg code keysym key modifiers)
 528                  (print-key code state keysym key modifiers)
 529                  (force-output)))
 530              (handle-identify (&rest event-slots &key display event-key &allow-other-keys)
 531                (declare (ignore display))
 532                (case event-key
 533                  (:key-press (apply #'handle-identify-key event-slots) t)
 534                  (:exposure (print-key nil nil nil nil nil)))
 535                t))
 536       (xgrab-pointer *root* 92 93)
 537       (map-window window)
 538       (format t "~&Press 'q' to stop the identify loop~%")
 539       (print-key nil nil nil nil nil)
 540       (force-output)
 541       (unwind-protect
 542            (loop until done do
 543                 (when (xlib:event-listen *display* *loop-timeout*)
 544                   (xlib:process-event *display* :handler #'handle-identify))
 545                 (xlib:display-finish-output *display*))
 546         (xlib:destroy-window window)
 547         (xlib:close-font font)
 548         (xgrab-pointer *root* 66 67)))))
 549
 550
 551
 552
 553
 554
 555 (let ((all-symbols (collect-all-symbols)))
 556   (defun eval-from-query-string ()
 557     "Eval a lisp form from the query input"
 558     (let ((form (query-string (format nil "Eval Lisp <~A> " (package-name *package*))
 559                               "" all-symbols))
 560             (result nil))
 561         (when (and form (not (equal form "")))
 562           (let ((printed-result
 563                  (with-output-to-string (*standard-output*)
 564                    (setf result (handler-case
 565                                     (loop for i in (multiple-value-list
 566                                                     (eval (read-from-string form)))
 567                                        collect (format nil "~S" i))
 568                                   (error (condition)
 569                                     (format nil "~A" condition)))))))
 570             (let ((ret (info-mode (expand-newline (append (ensure-list (format nil "> ~A" form))
 571                                                           (ensure-list printed-result)
 572                                                           (ensure-list result)))
 573                                   :width (- (xlib:screen-width *screen*) 2))))
 574               (when (or (search "defparameter" form :test #'string-equal)
 575                         (search "defvar" form :test #'string-equal))
 576                 (let ((elem (split-string form)))
 577                   (pushnew (string-downcase (if (string= (first elem) "(") (third elem) (second elem)))
 578                            all-symbols :test #'string=)))
 579               (when (search "in-package" form :test #'string-equal)
 580                 (let ((*notify-window-placement* 'middle-middle-root-placement))
 581                   (open-notify-window '("Collecting all symbols for Lisp REPL completion."))
 582                   (setf all-symbols (collect-all-symbols))
 583                   (close-notify-window)))
 584               (when ret
 585                 (eval-from-query-string))))))))
 586
 587
 588
 589
 590
 591 (let ((commands (command-in-path)))
 592   (defun run-program-from-query-string ()
 593     "Run a program from the query input"
 594     (multiple-value-bind (program return)
 595         (query-string "Run:" "" commands)
 596       (when (and (equal return :return) program (not (equal program "")))
 597         (setf *second-mode-leave-function* (let ((cmd (concatenate 'string "cd $HOME && " program)))
 598                                              (lambda ()
 599                                                (do-shell cmd))))
 600         (leave-second-mode)))))
 601
 602
 603
 604
 605 ;;; Frame name actions
 606 (defun ask-frame-name (msg)
 607   "Ask a frame name"
 608   (let ((all-frame-name nil))
 609     (with-all-frames (*root-frame* frame)
 610       (awhen (frame-name frame) (push it all-frame-name)))
 611     (query-string msg "" all-frame-name)))
 612
 613
 614 ;;; Focus by functions
 615 (defun focus-frame-by (frame)
 616   (when (frame-p frame)
 617     (focus-all-children frame (or (find-parent-frame frame (find-current-root))
 618                                   (find-parent-frame frame)
 619                                   *root-frame*))
 620     (show-all-children t)))
 621
 622
 623 (defun focus-frame-by-name ()
 624   "Focus a frame by name"
 625   (focus-frame-by (find-frame-by-name (ask-frame-name "Focus frame:")))
 626   (leave-second-mode))
 627
 628 (defun focus-frame-by-number ()
 629   "Focus a frame by number"
 630   (focus-frame-by (find-frame-by-number (query-number "Focus frame by number:")))
 631   (leave-second-mode))
 632
 633
 634 ;;; Open by functions
 635 (defun open-frame-by (frame)
 636   (when (frame-p frame)
 637     (push (create-frame :name (query-string "Frame name")) (frame-child frame))
 638     (show-all-children)))
 639
 640
 641
 642 (defun open-frame-by-name ()
 643   "Open a new frame in a named frame"
 644   (open-frame-by (find-frame-by-name (ask-frame-name "Open a new frame in: ")))
 645   (leave-second-mode))
 646
 647 (defun open-frame-by-number ()
 648   "Open a new frame in a numbered frame"
 649   (open-frame-by (find-frame-by-number (query-number "Open a new frame in the group numbered:")))
 650   (leave-second-mode))
 651
 652
 653 ;;; Delete by functions
 654 (defun delete-frame-by (frame)
 655   (unless (or (child-equal-p frame *root-frame*)
 656               (child-root-p frame))
 657     (when (child-equal-p frame (current-child))
 658       (setf (current-child) (find-current-root)))
 659     (remove-child-in-frame frame (find-parent-frame frame)))
 660   (show-all-children t))
 661
 662
 663 (defun delete-frame-by-name ()
 664   "Delete a frame by name"
 665   (delete-frame-by (find-frame-by-name (ask-frame-name "Delete frame: ")))
 666   (leave-second-mode))
 667
 668 (defun delete-frame-by-number ()
 669   "Delete a frame by number"
 670   (delete-frame-by (find-frame-by-number (query-number "Delete frame by number:")))
 671   (leave-second-mode))
 672
 673
 674 ;;; Move by function
 675 (defun move-child-to (child frame-dest)
 676   (when (and child (frame-p frame-dest))
 677     (remove-child-in-frame child (find-parent-frame child))
 678     (pushnew child (frame-child frame-dest))
 679     (focus-all-children child frame-dest)
 680     (show-all-children t)))
 681
 682 (defun move-current-child-by-name ()
 683   "Move current child in a named frame"
 684   (move-child-to (current-child)
 685                  (find-frame-by-name
 686                   (ask-frame-name (format nil "Move '~A' to frame: " (child-name (current-child))))))
 687   (leave-second-mode))
 688
 689 (defun move-current-child-by-number ()
 690   "Move current child in a numbered frame"
 691   (move-child-to (current-child)
 692                  (find-frame-by-number
 693                   (query-number (format nil "Move '~A' to frame numbered:" (child-name (current-child))))))
 694   (leave-second-mode))
 695
 696
 697 ;;; Copy by function
 698 (defun copy-child-to (child frame-dest)
 699   (when (and child (frame-p frame-dest))
 700     (pushnew child (frame-child frame-dest))
 701     (focus-all-children child frame-dest)
 702     (show-all-children t)))
 703
 704 (defun copy-current-child-by-name ()
 705   "Copy current child in a named frame"
 706   (copy-child-to (current-child)
 707                  (find-frame-by-name
 708                   (ask-frame-name (format nil "Copy '~A' to frame: " (child-name (current-child))))))
 709   (leave-second-mode))
 710
 711 (defun copy-current-child-by-number ()
 712   "Copy current child in a numbered frame"
 713   (copy-child-to (current-child)
 714                  (find-frame-by-number
 715                   (query-number (format nil "Copy '~A' to frame numbered:" (child-name (current-child))))))
 716   (leave-second-mode))
 717
 718
 719
 720
 721 ;;; Show frame info
 722 (defun show-all-frames-info ()
 723   "Show all frames info windows"
 724   (let ((*show-root-frame-p* t))
 725     (show-all-children)
 726     (with-all-root-child (root)
 727       (with-all-frames (root frame)
 728         (raise-window (frame-window frame))
 729         (display-frame-info frame)))))
 730
 731 (defun hide-all-frames-info ()
 732   "Hide all frames info windows"
 733   (show-all-children))
 734
 735 (defun show-all-frames-info-key ()
 736   "Show all frames info windows until a key is release"
 737   (show-all-frames-info)
 738   (wait-no-key-or-button-press)
 739   (hide-all-frames-info))
 740
 741
 742 (defun move-frame (frame parent orig-x orig-y)
 743   (when (and frame parent (not (child-root-p frame)))
 744     (hide-all-children frame)
 745     (with-slots (window) frame
 746       (move-window window orig-x orig-y #'display-frame-info (list frame))
 747       (setf (frame-x frame) (x-px->fl (x-drawable-x window) parent)
 748             (frame-y frame) (y-px->fl (x-drawable-y window) parent)))
 749     (show-all-children)))
 750
 751 (defun resize-frame (frame parent orig-x orig-y)
 752   (when (and frame parent (not (child-root-p frame)))
 753     (hide-all-children frame)
 754     (with-slots (window) frame
 755       (resize-window window orig-x orig-y #'display-frame-info (list frame))
 756       (setf (frame-w frame) (w-px->fl (anti-adj-border-wh (x-drawable-width window) frame) parent)
 757             (frame-h frame) (h-px->fl (anti-adj-border-wh (x-drawable-height window) frame) parent)))
 758     (show-all-children)))
 759
 760
 761
 762 (defun mouse-click-to-focus-generic (root-x root-y mouse-fn)
 763   "Focus the current frame or focus the current window parent
 764 mouse-fun is #'move-frame or #'resize-frame"
 765   (let* ((to-replay t)
 766          (child (find-child-under-mouse root-x root-y))
 767          (parent (find-parent-frame child))
 768          (root-p (child-root-p child)))
 769     (labels ((add-new-frame ()
 770                (when (frame-p child)
 771                  (setf parent child
 772                        child (create-frame)
 773                        mouse-fn #'resize-frame
 774                        (current-child) child)
 775                  (place-frame child parent root-x root-y 10 10)
 776                  (map-window (frame-window child))
 777                  (pushnew child (frame-child parent)))))
 778       (when (and root-p  *create-frame-on-root*)
 779         (add-new-frame))
 780       (when (and (frame-p child) (not (child-root-p child)))
 781         (funcall mouse-fn child parent root-x root-y))
 782       (when (and child parent
 783                  (focus-all-children child parent (not (child-root-p child))))
 784         (when (show-all-children)
 785           (setf to-replay nil)))
 786       (if to-replay
 787           (replay-button-event)
 788           (stop-button-event)))))
 789
 790
 791 (defun mouse-click-to-focus-and-move (window root-x root-y)
 792   "Move and focus the current frame or focus the current window parent.
 793 Or do actions on corners"
 794   (declare (ignore window))
 795   (or (do-corner-action root-x root-y *corner-main-mode-left-button*)
 796       (mouse-click-to-focus-generic root-x root-y #'move-frame)))
 797
 798 (defun mouse-click-to-focus-and-resize (window root-x root-y)
 799   "Resize and focus the current frame or focus the current window parent.
 800 Or do actions on corners"
 801   (declare (ignore window))
 802   (or (do-corner-action root-x root-y *corner-main-mode-right-button*)
 803       (mouse-click-to-focus-generic root-x root-y #'resize-frame)))
 804
 805 (defun mouse-middle-click (window root-x root-y)
 806   "Do actions on corners"
 807   (declare (ignore window))
 808   (or (do-corner-action root-x root-y *corner-main-mode-middle-button*)
 809       (replay-button-event)))
 810
 811
 812
 813
 814 (defun mouse-focus-move/resize-generic (root-x root-y mouse-fn window-parent)
 815   "Focus the current frame or focus the current window parent
 816 mouse-fun is #'move-frame or #'resize-frame.
 817 Focus child and its parents -
 818 For window: set current child to window or its parent according to window-parent"
 819   (labels ((move/resize-managed (child)
 820              (let ((parent (find-parent-frame child)))
 821                (when (and child
 822                           (frame-p child)
 823                           (child-root-p child))
 824                  (setf parent child
 825                        child (create-frame)
 826                        mouse-fn #'resize-frame)
 827                  (place-frame child parent root-x root-y 10 10)
 828                  (map-window (frame-window child))
 829                  (push child (frame-child parent)))
 830                (focus-all-children child parent window-parent)
 831                (show-all-children)
 832                (typecase child
 833                  (xlib:window
 834                   (if (managed-window-p child parent)
 835                       (funcall mouse-fn parent (find-parent-frame parent) root-x root-y)
 836                       (funcall (cond ((or (eql mouse-fn #'move-frame)
 837                                           (eql mouse-fn #'move-frame-constrained))
 838                                       #'move-window)
 839                                      ((or (eql mouse-fn #'resize-frame)
 840                                           (eql mouse-fn #'resize-frame-constrained))
 841                                       #'resize-window))
 842                                child root-x root-y)))
 843                  (frame (funcall mouse-fn child parent root-x root-y)))
 844                (show-all-children)))
 845            (move/resize-never-managed (child raise-fun)
 846              (funcall raise-fun child)
 847              (funcall (cond ((eql mouse-fn #'move-frame) #'move-window)
 848                             ((eql mouse-fn #'resize-frame) #'resize-window))
 849                       child root-x root-y)))
 850     (let ((child (find-child-under-mouse root-x root-y nil t)))
 851       (multiple-value-bind (never-managed raise-fun)
 852           (never-managed-window-p child)
 853         (if (and (xlib:window-p child) never-managed raise-fun)
 854             (move/resize-never-managed child raise-fun)
 855             (move/resize-managed child))))))
 856
 857
 858 (defun test-mouse-binding (window root-x root-y)
 859   (dbg window root-x root-y)
 860   (replay-button-event))
 861
 862
 863
 864 (defun mouse-select-next-level (window root-x root-y)
 865   "Select the next level in frame"
 866   (declare (ignore root-x root-y))
 867   (let ((frame (find-frame-window window)))
 868     (when (or frame (xlib:window-equal window *root*))
 869       (select-next-level))
 870     (replay-button-event)))
 871
 872
 873
 874 (defun mouse-select-previous-level (window root-x root-y)
 875   "Select the previous level in frame"
 876   (declare (ignore root-x root-y))
 877   (let ((frame (find-frame-window window)))
 878     (when (or frame (xlib:window-equal window *root*))
 879       (select-previous-level))
 880     (replay-button-event)))
 881
 882
 883
 884 (defun mouse-enter-frame (window root-x root-y)
 885   "Enter in the selected frame - ie make it the root frame"
 886   (declare (ignore root-x root-y))
 887   (let ((frame (find-frame-window window)))
 888     (when (or frame (xlib:window-equal window *root*))
 889       (enter-frame))
 890     (replay-button-event)))
 891
 892
 893
 894 (defun mouse-leave-frame (window root-x root-y)
 895   "Leave the selected frame - ie make its parent the root frame"
 896   (declare (ignore root-x root-y))
 897   (let ((frame (find-frame-window window)))
 898     (when (or frame (xlib:window-equal window *root*))
 899       (leave-frame))
 900     (replay-button-event)))
 901
 902
 903
 904 ;;;;;,-----
 905 ;;;;;| Various definitions
 906 ;;;;;`-----
 907
 908 (defun show-help (&optional (browser "dillo") (tempfile "/tmp/clfswm.html"))
 909   "Show current keys and buttons bindings"
 910   (ignore-errors
 911     (produce-doc-html-in-file tempfile))
 912   (sleep 1)
 913   (do-shell (format nil "~A ~A" browser tempfile)))
 914
 915
 916
 917 ;;;  Bind or jump functions
 918 (let ((key-slots (make-array 10 :initial-element nil))
 919       (current-slot 1))
 920   (defun reset-bind-or-jump-slots ()
 921     (dotimes (i 10)
 922       (setf (aref key-slots i) nil)))
 923
 924   (defun bind-on-slot (&optional (slot current-slot))
 925     "Bind current child to slot"
 926     (setf (aref key-slots slot) (current-child)))
 927
 928   (defun remove-binding-on-slot ()
 929     "Remove binding on slot"
 930     (setf (aref key-slots current-slot) nil))
 931
 932   (defun jump-to-slot ()
 933     "Jump to slot"
 934     (let ((jump-child (aref key-slots current-slot)))
 935       (when (and jump-child (find-child jump-child *root-frame*))
 936         (unless (find-child-in-all-root jump-child)
 937           (change-root (find-root jump-child) jump-child))
 938         (setf (current-child) jump-child)
 939         (focus-all-children jump-child jump-child)
 940         (show-all-children t))))
 941
 942   (defun bind-or-jump (n)
 943     "Bind or jump to a slot (a frame or a window)"
 944     (setf current-slot (- n 1))
 945     (let ((default-bind `("b" bind-on-slot
 946                               ,(format nil "Bind slot ~A on child: ~A" n (child-fullname (current-child))))))
 947       (info-mode-menu (aif (aref key-slots current-slot)
 948                            `(,default-bind
 949                                 ("BackSpace" remove-binding-on-slot
 950                                              ,(format nil "Remove slot ~A binding on child: ~A" n (child-fullname (current-child))))
 951                                 ("   -  " nil " -")
 952                               ("Tab" jump-to-slot
 953                                      ,(format nil "Jump to child: ~A" (aif (aref key-slots current-slot)
 954                                                                            (child-fullname it)
 955                                                                            "Not set - Please, bind it with 'b'")))
 956                               ("Return" jump-to-slot "Same thing")
 957                               ("space" jump-to-slot "Same thing"))
 958                            (list default-bind))))))
 959
 960
 961
 962 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 963 ;;; Useful function for the second mode ;;;
 964 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 965 (defmacro with-movement (&body body)
 966   `(when (frame-p (current-child))
 967      ,@body
 968      (show-all-children)
 969      (display-all-frame-info)
 970      (draw-second-mode-window)
 971      (open-menu (find-menu 'frame-movement-menu))))
 972
 973
 974 ;;; Pack
 975 (defun current-frame-pack-up ()
 976   "Pack the current frame up"
 977   (with-movement (pack-frame-up (current-child) (find-parent-frame (current-child) (find-current-root)))))
 978
 979 (defun current-frame-pack-down ()
 980   "Pack the current frame down"
 981   (with-movement (pack-frame-down (current-child) (find-parent-frame (current-child) (find-current-root)))))
 982
 983 (defun current-frame-pack-left ()
 984   "Pack the current frame left"
 985   (with-movement (pack-frame-left (current-child) (find-parent-frame (current-child) (find-current-root)))))
 986
 987 (defun current-frame-pack-right ()
 988   "Pack the current frame right"
 989   (with-movement (pack-frame-right (current-child) (find-parent-frame (current-child) (find-current-root)))))
 990
 991 ;;; Center
 992 (defun center-current-frame ()
 993   "Center the current frame"
 994   (with-movement (center-frame (current-child))))
 995
 996 ;;; Fill
 997 (defun current-frame-fill-up ()
 998   "Fill the current frame up"
 999   (with-movement (fill-frame-up (current-child) (find-parent-frame (current-child) (find-current-root)))))
1000
1001 (defun current-frame-fill-down ()
1002   "Fill the current frame down"
1003   (with-movement (fill-frame-down (current-child) (find-parent-frame (current-child) (find-current-root)))))
1004
1005 (defun current-frame-fill-left ()
1006   "Fill the current frame left"
1007   (with-movement (fill-frame-left (current-child) (find-parent-frame (current-child) (find-current-root)))))
1008
1009 (defun current-frame-fill-right ()
1010   "Fill the current frame right"
1011   (with-movement (fill-frame-right (current-child) (find-parent-frame (current-child) (find-current-root)))))
1012
1013 (defun current-frame-fill-all-dir ()
1014   "Fill the current frame in all directions"
1015   (with-movement
1016     (let ((parent (find-parent-frame (current-child) (find-current-root))))
1017       (fill-frame-up (current-child) parent)
1018       (fill-frame-down (current-child) parent)
1019       (fill-frame-left (current-child) parent)
1020       (fill-frame-right (current-child) parent))))
1021
1022 (defun current-frame-fill-vertical ()
1023   "Fill the current frame vertically"
1024   (with-movement
1025     (let ((parent (find-parent-frame (current-child) (find-current-root))))
1026       (fill-frame-up (current-child) parent)
1027       (fill-frame-down (current-child) parent))))
1028
1029 (defun current-frame-fill-horizontal ()
1030   "Fill the current frame horizontally"
1031   (with-movement
1032     (let ((parent (find-parent-frame (current-child) (find-current-root))))
1033       (fill-frame-left (current-child) parent)
1034       (fill-frame-right (current-child) parent))))
1035
1036
1037 ;;; Resize
1038 (defun current-frame-resize-up ()
1039   "Resize the current frame up to its half height"
1040   (with-movement (resize-half-height-up (current-child))))
1041
1042 (defun current-frame-resize-down ()
1043   "Resize the current frame down to its half height"
1044   (with-movement (resize-half-height-down (current-child))))
1045
1046 (defun current-frame-resize-left ()
1047   "Resize the current frame left to its half width"
1048   (with-movement (resize-half-width-left (current-child))))
1049
1050 (defun current-frame-resize-right ()
1051   "Resize the current frame right to its half width"
1052   (with-movement (resize-half-width-right (current-child))))
1053
1054 (defun current-frame-resize-all-dir ()
1055   "Resize down the current frame"
1056   (with-movement (resize-frame-down (current-child))))
1057
1058 (defun current-frame-resize-all-dir-minimal ()
1059   "Resize down the current frame to its minimal size"
1060   (with-movement (resize-minimal-frame (current-child))))
1061
1062
1063 ;;; Children navigation
1064 (defun with-movement-select-next-brother ()
1065   "Select the next brother frame"
1066   (with-movement (select-next-brother-simple)))
1067
1068 (defun with-movement-select-previous-brother ()
1069   "Select the previous brother frame"
1070   (with-movement (select-previous-brother-simple)))
1071
1072 (defun with-movement-select-next-level ()
1073   "Select the next level"
1074   (with-movement (select-next-level)))
1075
1076 (defun with-movement-select-previous-level ()
1077   "Select the previous levelframe"
1078   (with-movement (select-previous-level)))
1079
1080 (defun with-movement-select-next-child ()
1081   "Select the next child"
1082   (with-movement (select-next-child-simple)))
1083
1084
1085
1086 ;;; Adapt frame functions
1087 (defun adapt-current-frame-to-window-hints-generic (width-p height-p)
1088   "Adapt the current frame to the current window minimal size hints"
1089   (when (frame-p (current-child))
1090     (let ((window (first (frame-child (current-child)))))
1091       (when (xlib:window-p window)
1092         (let* ((hints (xlib:wm-normal-hints window))
1093                (min-width (and hints (xlib:wm-size-hints-min-width hints)))
1094                (min-height (and hints (xlib:wm-size-hints-min-height hints))))
1095           (when (and width-p min-width)
1096             (setf (frame-rw (current-child)) min-width))
1097           (when (and height-p min-height)
1098             (setf (frame-rh (current-child)) min-height))
1099           (fixe-real-size (current-child) (find-parent-frame (current-child)))
1100           (leave-second-mode))))))
1101
1102 (defun adapt-current-frame-to-window-hints ()
1103   "Adapt the current frame to the current window minimal size hints"
1104   (adapt-current-frame-to-window-hints-generic t t))
1105
1106 (defun adapt-current-frame-to-window-width-hint ()
1107   "Adapt the current frame to the current window minimal width hint"
1108   (adapt-current-frame-to-window-hints-generic t nil))
1109
1110 (defun adapt-current-frame-to-window-height-hint ()
1111   "Adapt the current frame to the current window minimal height hint"
1112   (adapt-current-frame-to-window-hints-generic nil t))
1113
1114
1115
1116
1117 ;;; Managed window type functions
1118 (defun current-frame-manage-window-type-generic (type-list)
1119   (when (frame-p (current-child))
1120     (setf (frame-managed-type (current-child)) type-list
1121           (frame-forced-managed-window (current-child)) nil
1122           (frame-forced-unmanaged-window (current-child)) nil))
1123   (leave-second-mode))
1124
1125
1126 (defun current-frame-manage-window-type ()
1127   "Change window types to be managed by a frame"
1128   (when (frame-p (current-child))
1129     (let* ((type-str (query-string "Managed window type: (all, normal, transient, maxsize, desktop, dock, toolbar, menu, utility, splash, dialog)"
1130                                    (format nil "~{~:(~A~) ~}" (frame-managed-type (current-child)))))
1131            (type-list (loop :for type :in (split-string type-str)
1132                          :collect (intern (string-upcase type) :keyword))))
1133       (current-frame-manage-window-type-generic type-list))))
1134
1135
1136 (defun current-frame-manage-all-window-type ()
1137   "Manage all window type"
1138   (current-frame-manage-window-type-generic '(:all)))
1139
1140 (defun current-frame-manage-only-normal-window-type ()
1141   "Manage only normal window type"
1142   (current-frame-manage-window-type-generic '(:normal)))
1143
1144 (defun current-frame-manage-no-window-type ()
1145   "Do not manage any window type"
1146   (current-frame-manage-window-type-generic nil))
1147
1148
1149
1150
1151
1152
1153
1154
1155 ;;; Force window functions
1156 (defun force-window-in-frame ()
1157   "Force the current window to move in the frame (Useful only for unmanaged windows)"
1158   (with-current-window
1159     (let ((parent (find-parent-frame window)))
1160       (setf (x-drawable-x window) (frame-rx parent)
1161             (x-drawable-y window) (frame-ry parent))
1162       (xlib:display-finish-output *display*)))
1163   (leave-second-mode))
1164
1165
1166 (defun force-window-center-in-frame ()
1167   "Force the current window to move in the center of the frame (Useful only for unmanaged windows)"
1168   (with-current-window
1169     (let ((parent (find-parent-frame window)))
1170       (setf (x-drawable-x window) (truncate (+ (frame-rx parent)
1171                                                   (/ (- (frame-rw parent)
1172                                                         (x-drawable-width window)) 2)))
1173             (x-drawable-y window) (truncate (+ (frame-ry parent)
1174                                                   (/ (- (frame-rh parent)
1175                                                         (x-drawable-height window)) 2))))
1176       (xlib:display-finish-output *display*)))
1177   (leave-second-mode))
1178
1179
1180
1181 (defun display-current-window-info ()
1182   "Display information on the current window"
1183   (with-current-window
1184     (info-mode (list (format nil "Window:       ~A" window)
1185                      (format nil "Window name:  ~A" (xlib:wm-name window))
1186                      (format nil "Window class: ~A" (xlib:get-wm-class window))
1187                      (format nil "Window type:  ~:(~A~)" (window-type window))
1188                      (format nil "Window id:    0x~X" (xlib:window-id window))
1189                      (format nil "Window transparency: ~A" (* 100 (window-transparency window))))))
1190   (leave-second-mode))
1191
1192 (defun set-current-window-transparency ()
1193   "Set the current window transparency"
1194   (with-current-window
1195       (ask-child-transparency "window" window))
1196   (leave-second-mode))
1197
1198
1199 (defun manage-current-window ()
1200   "Force to manage the current window by its parent frame"
1201   (with-current-window
1202     (let ((parent (find-parent-frame window)))
1203       (with-slots ((managed forced-managed-window)
1204                    (unmanaged forced-unmanaged-window)) parent
1205         (setf unmanaged (child-remove window unmanaged)
1206               unmanaged (remove (xlib:wm-name window) unmanaged :test #'string-equal-p))
1207         (pushnew window managed))))
1208   (leave-second-mode))
1209
1210 (defun unmanage-current-window ()
1211   "Force to not manage the current window by its parent frame"
1212   (with-current-window
1213     (let ((parent (find-parent-frame window)))
1214       (with-slots ((managed forced-managed-window)
1215                    (unmanaged forced-unmanaged-window)) parent
1216         (setf managed (child-remove window managed)
1217               managed (remove (xlib:wm-name window) managed :test #'string-equal-p))
1218         (pushnew window unmanaged))))
1219   (leave-second-mode))
1220
1221
1222
1223 ;;; Moving child with the mouse button
1224 (defun mouse-move-child-over-frame (window root-x root-y)
1225   "Move the child under the mouse cursor to another frame"
1226   (declare (ignore window))
1227   (let ((child (find-child-under-mouse root-x root-y)))
1228     (unless (child-root-p child)
1229       (hide-all child)
1230       (remove-child-in-frame child (find-parent-frame child))
1231       (wait-mouse-button-release 50 51)
1232       (multiple-value-bind (x y)
1233           (xlib:query-pointer *root*)
1234         (let ((dest (find-child-under-mouse x y)))
1235           (when (xlib:window-p dest)
1236             (setf dest (find-parent-frame dest)))
1237           (unless (child-equal-p child dest)
1238             (move-child-to child dest)
1239             (show-all-children))))))
1240   (stop-button-event))
1241
1242
1243
1244
1245 ;;; Hide/Show frame window functions
1246 (defun hide/show-frame-window (frame value)
1247   "Hide/show the frame window"
1248   (when (frame-p frame)
1249     (setf (frame-show-window-p (current-child)) value)
1250     (show-all-children))
1251   (leave-second-mode))
1252
1253
1254 (defun hide-current-frame-window ()
1255   "Hide the current frame window"
1256   (hide/show-frame-window (current-child) nil))
1257
1258 (defun show-current-frame-window ()
1259   "Show the current frame window"
1260   (hide/show-frame-window (current-child) t))
1261
1262
1263
1264 ;;; Hide/Unhide current child
1265 (defun hide-current-child ()
1266   "Hide the current child"
1267   (unless (child-root-p (current-child))
1268     (let ((parent (find-parent-frame (current-child))))
1269       (when (frame-p parent)
1270         (with-slots (child hidden-children) parent
1271           (hide-all (current-child))
1272           (setf child (child-remove (current-child) child))
1273           (pushnew (current-child) hidden-children)
1274           (setf (current-child) parent))
1275         (show-all-children)))
1276     (leave-second-mode)))
1277
1278
1279 (defun frame-unhide-child (hidden frame-src frame-dest)
1280   "Unhide a hidden child from frame-src in frame-dest"
1281   (with-slots (hidden-children) frame-src
1282     (setf hidden-children (child-remove hidden hidden-children)))
1283   (with-slots (child) frame-dest
1284     (pushnew hidden child)))
1285
1286
1287
1288 (defun unhide-a-child ()
1289   "Unhide a child in the current frame"
1290   (when (frame-p (current-child))
1291     (with-slots (child hidden-children) (current-child)
1292       (info-mode-menu (loop :for i :from 0
1293                          :for hidden :in hidden-children
1294                          :collect (list (code-char (+ (char-code #\a) i))
1295                                         (let ((lhd hidden))
1296                                           (lambda ()
1297                                             (frame-unhide-child lhd (current-child) (current-child))))
1298                                         (format nil "Unhide ~A" (child-fullname hidden))))))
1299     (show-all-children))
1300   (leave-second-mode))
1301
1302
1303 (defun unhide-all-children ()
1304   "Unhide all current frame hidden children"
1305   (when (frame-p (current-child))
1306     (with-slots (child hidden-children) (current-child)
1307       (dolist (c hidden-children)
1308         (pushnew c child))
1309       (setf hidden-children nil))
1310     (show-all-children))
1311   (leave-second-mode))
1312
1313
1314 (defun unhide-a-child-from-all-frames ()
1315   "Unhide a child from all frames in the current frame"
1316   (when (frame-p (current-child))
1317     (let ((acc nil)
1318           (keynum -1))
1319       (with-all-frames (*root-frame* frame)
1320         (when (frame-hidden-children frame)
1321           (push (format nil "~A" (child-fullname frame)) acc)
1322           (dolist (hidden (frame-hidden-children frame))
1323             (push (list (code-char (+ (char-code #\a) (incf keynum)))
1324                         (let ((lhd hidden))
1325                           (lambda ()
1326                             (frame-unhide-child lhd frame (current-child))))
1327                         (format nil "Unhide ~A" (child-fullname hidden)))
1328                   acc))))
1329       (info-mode-menu (nreverse acc)))
1330     (show-all-children))
1331   (leave-second-mode))
1332
1333
1334
1335
1336
1337 (let ((last-child nil))
1338   (defun init-last-child ()
1339     (setf last-child nil))
1340   (defun switch-to-last-child ()
1341     "Store the current child and switch to the previous one"
1342     (let ((current-child (current-child)))
1343       (when last-child
1344         (change-root (find-root last-child) last-child)
1345         (setf (current-child) last-child)
1346         (focus-all-children (current-child) (current-child))
1347         (show-all-children t))
1348       (setf last-child current-child))
1349     (leave-second-mode)))
1350
1351
1352
1353
1354
1355
1356
1357 ;;; Focus policy functions
1358 (defun set-focus-policy-generic (focus-policy)
1359   (when (frame-p (current-child))
1360     (setf (frame-focus-policy (current-child)) focus-policy))
1361   (leave-second-mode))
1362
1363
1364 (defun current-frame-set-click-focus-policy ()
1365   "Set a click focus policy for the current frame."
1366   (set-focus-policy-generic :click))
1367
1368 (defun current-frame-set-sloppy-focus-policy ()
1369   "Set a sloppy focus policy for the current frame."
1370   (set-focus-policy-generic :sloppy))
1371
1372 (defun current-frame-set-sloppy-strict-focus-policy ()
1373   "Set a (strict) sloppy focus policy only for windows in the current frame."
1374   (set-focus-policy-generic :sloppy-strict))
1375
1376 (defun current-frame-set-sloppy-select-policy ()
1377   "Set a sloppy select policy for the current frame."
1378     (set-focus-policy-generic :sloppy-select))
1379
1380
1381
1382 (defun set-focus-policy-generic-for-all (focus-policy)
1383   (with-all-frames (*root-frame* frame)
1384     (setf (frame-focus-policy frame) focus-policy))
1385   (leave-second-mode))
1386
1387
1388 (defun all-frames-set-click-focus-policy ()
1389   "Set a click focus policy for all frames."
1390   (set-focus-policy-generic-for-all :click))
1391
1392 (defun all-frames-set-sloppy-focus-policy ()
1393   "Set a sloppy focus policy for all frames."
1394   (set-focus-policy-generic-for-all :sloppy))
1395
1396 (defun all-frames-set-sloppy-strict-focus-policy ()
1397   "Set a (strict) sloppy focus policy for all frames."
1398   (set-focus-policy-generic-for-all :sloppy-strict))
1399
1400 (defun all-frames-set-sloppy-select-policy ()
1401   "Set a sloppy select policy for all frames."
1402     (set-focus-policy-generic-for-all :sloppy-select))
1403
1404
1405
1406 ;;; Ensure unique name/number functions
1407 (defun extract-number-from-name (name)
1408   (when (stringp name)
1409     (let* ((pos (1+ (or (position #\. name :from-end t) -1)))
1410            (number (parse-integer name :junk-allowed t :start pos)))
1411       (values number
1412               (if number (subseq name 0 (1- pos)) name)))))
1413
1414
1415
1416
1417 (defun ensure-unique-name ()
1418   "Ensure that all children names are unique"
1419   (with-all-children (*root-frame* child)
1420     (multiple-value-bind (num1 name1)
1421         (extract-number-from-name (child-name child))
1422       (declare (ignore num1))
1423       (when name1
1424         (let ((acc nil))
1425           (with-all-children (*root-frame* c)
1426             (unless (child-equal-p child c))
1427             (multiple-value-bind (num2 name2)
1428                 (extract-number-from-name (child-name c))
1429               (when (string-equal name1 name2)
1430                 (push num2 acc))))
1431           (dbg acc)
1432           (when (> (length acc) 1)
1433             (setf (child-name child)
1434                   (format nil "~A.~A" name1
1435                           (1+ (find-free-number (loop for i in acc when i collect (1- i)))))))))))
1436   (leave-second-mode))
1437
1438 (defun ensure-unique-number ()
1439   "Ensure that all children numbers are unique"
1440   (let ((num -1))
1441     (with-all-frames (*root-frame* frame)
1442       (setf (frame-number frame) (incf num))))
1443   (leave-second-mode))
1444
1445
1446
1447 ;;; Standard menu functions - Based on the XDG specifications
1448 (defun um-create-xdg-section-list (menu)
1449   (dolist (section *xdg-section-list*)
1450     (add-sub-menu menu :next section (format nil "~A" section) menu))
1451   (unless (find-toplevel-menu 'Utility menu)
1452     (add-sub-menu menu :next 'Utility (format nil "~A" 'Utility) menu)))
1453
1454 (defun um-find-submenu (menu section-list)
1455   (let ((acc nil))
1456     (dolist (section section-list)
1457       (awhen (find-toplevel-menu (intern (string-upcase section) :clfswm) menu)
1458         (push it acc)))
1459     (if acc
1460         acc
1461         (list (find-toplevel-menu 'Utility menu)))))
1462
1463
1464 (defun um-extract-value (line)
1465   (second (split-string line #\=)))
1466
1467
1468 (defun um-add-desktop (desktop menu)
1469   (let (name exec categories comment)
1470     (when (probe-file desktop)
1471       (with-open-file (stream desktop :direction :input)
1472         (loop for line = (read-line stream nil nil)
1473            while line
1474            do
1475            (cond ((first-position "Name=" line) (setf name (um-extract-value line)))
1476                  ((first-position "Exec=" line) (setf exec (um-extract-value line)))
1477                  ((first-position "Categories=" line) (setf categories (um-extract-value line)))
1478                  ((first-position "Comment=" line) (setf comment (um-extract-value line))))
1479            (when (and name exec categories)
1480              (let* ((sub-menu (um-find-submenu menu (split-string categories #\;)))
1481                     (fun-name (intern name :clfswm)))
1482                (setf (symbol-function fun-name) (let ((do-exec exec))
1483                                                   (lambda ()
1484                                                     (do-shell do-exec)
1485                                                     (leave-second-mode)))
1486                      (documentation fun-name 'function) (format nil "~A~A" name (if comment
1487                                                                                     (format nil " - ~A" comment)
1488                                                                                     "")))
1489                (dolist (m sub-menu)
1490                  (add-menu-key (menu-name m) :next fun-name m)))
1491              (setf name nil exec nil categories nil comment nil)))))))
1492
1493
1494 (defun update-menus (&optional (menu (make-menu :name 'main :doc "Main menu")))
1495   (um-create-xdg-section-list menu)
1496   (let ((count 0)
1497         (found (make-hash-table :test #'equal)))
1498     (dolist (dir (remove-duplicates
1499                   (split-string (or (getenv "XDG_DATA_DIRS") "/usr/local/share/:/usr/share/")
1500                                 #\:) :test #'string-equal))
1501       (dolist (desktop (directory (concatenate 'string dir "/applications/**/*.desktop")))
1502         (unless (gethash (file-namestring desktop) found)
1503           (setf (gethash (file-namestring desktop) found) t)
1504           (um-add-desktop desktop menu)
1505           (incf count))))
1506     menu))
1507
1508
1509
1510 ;;; Close/Kill focused window
1511
1512 (defun ask-close/kill-current-window ()
1513   "Close or kill the current window (ask before doing anything)"
1514   (let ((window (xlib:input-focus *display*))
1515         (*info-mode-placement* *ask-close/kill-placement*))
1516     (info-mode-menu
1517      (if (and window (not (xlib:window-equal window *no-focus-window*)))
1518          `(,(format nil "Focus window: ~A" (xlib:wm-name window))
1519             (#\s delete-focus-window "Close the focus window")
1520             (#\k destroy-focus-window "Kill the focus window")
1521             (#\x cut-focus-window)
1522             (#\c copy-focus-window)
1523             (#\v paste-selection))
1524          `(,(format nil "Focus window: None")
1525             (#\v paste-selection))))
1526     t))
1527
1528
1529
1530 ;;; Other window manager functions
1531 (defun get-proc-list ()
1532   (let ((proc (do-shell "ps x -o pid=" nil t))
1533         (proc-list nil))
1534     (loop for line = (read-line proc nil nil)
1535        while line
1536        do (push line proc-list))
1537     (dbg proc-list)
1538     proc-list))
1539
1540 (defun run-other-window-manager ()
1541   (let ((proc-start (get-proc-list)))
1542     (do-shell *other-window-manager* nil t :terminal)
1543     (let* ((proc-end (get-proc-list))
1544            (proc-diff (set-difference proc-end proc-start :test #'equal)))
1545       (dbg 'killing-sigterm proc-diff)
1546       (do-shell (format nil "kill ~{ ~A ~}  2> /dev/null" proc-diff) nil t :terminal)
1547       (dbg 'killing-sigkill proc-diff)
1548       (do-shell (format nil "kill -9 ~{ ~A ~} 2> /dev/null" proc-diff) nil t :terminal)
1549       (sleep 1))
1550     (setf *other-window-manager* nil)))
1551
1552
1553 (defun do-run-other-window-manager (window-manager)
1554   (setf *other-window-manager* window-manager)
1555   (throw 'exit-main-loop nil))
1556
1557 (defmacro def-run-other-window-manager (name &optional definition)
1558   (let ((definition (or definition name)))
1559     `(defun ,(create-symbol "run-" name) ()
1560        ,(format nil "Run ~A" definition)
1561        (do-run-other-window-manager ,(format nil "~A" name)))))
1562
1563 (def-run-other-window-manager "xterm")
1564 (def-run-other-window-manager "icewm")
1565 (def-run-other-window-manager "twm")
1566 (def-run-other-window-manager "gnome-session" "Gnome")
1567 (def-run-other-window-manager "startkde" "KDE")
1568 (def-run-other-window-manager "xfce4-session" "XFCE")
1569
1570 (defun run-lxde ()
1571   "Run LXDE"
1572   (do-run-other-window-manager "( lxsession & ); xterm -e \"echo '  /----------------------------------\\' ; echo '  |  CLFSWM Note:                    |' ; echo '  |    Close this window when done.  |' ; echo '  \\----------------------------------/'; echo; echo; $SHELL\""))
1573
1574 (defun run-xfce4 ()
1575   "Run LXDE (xterm)"
1576   (do-run-other-window-manager "( xfce4-session &) ; xterm -e \"echo '  /----------------------------------\\' ; echo '  |  CLFSWM Note:                    |' ; echo '  |    Close this window when done.  |' ; echo '  \\----------------------------------/'; echo; echo; $SHELL\""))
1577
1578
1579 (defun run-prompt-wm ()
1580   "Prompt for an other window manager"
1581   (let ((wm (query-string "Run an other window manager:" "icewm")))
1582     (do-run-other-window-manager wm)))
1583
1584
1585 ;;; Hide or show unmanaged windows utility.
1586 (defun set-hide-unmanaged-window ()
1587   "Hide unmanaged windows when frame is not selected"
1588   (when (frame-p (current-child))
1589     (setf (frame-data-slot (current-child) :unmanaged-window-action) :hide)
1590     (leave-second-mode)))
1591
1592 (defun set-show-unmanaged-window ()
1593   "Show unmanaged windows when frame is not selected"
1594   (when (frame-p (current-child))
1595     (setf (frame-data-slot (current-child) :unmanaged-window-action) :show)
1596     (leave-second-mode)))
1597
1598 (defun set-default-hide-unmanaged-window ()
1599   "Set default behaviour to hide or not unmanaged windows when frame is not selected"
1600   (when (frame-p (current-child))
1601     (setf (frame-data-slot (current-child) :unmanaged-window-action) nil)
1602     (leave-second-mode)))
1603
1604 (defun set-globally-hide-unmanaged-window ()
1605   "Hide unmanaged windows by default. This is overriden by functions above"
1606   (setf *hide-unmanaged-window* t)
1607   (leave-second-mode))
1608
1609 (defun set-globally-show-unmanaged-window ()
1610   "Show unmanaged windows by default. This is overriden by functions above"
1611   (setf *hide-unmanaged-window* nil)
1612   (leave-second-mode))
1613
1614
1615 ;;; Speed mouse movement.
1616 (let (minx miny maxx maxy history lx ly)
1617   (labels ((middle (x1 x2)
1618              (round (/ (+ x1 x2) 2)))
1619            (reset-if-moved (x y)
1620              (when (or (/= x (or lx x)) (/= y (or ly y)))
1621                (speed-mouse-reset)))
1622            (add-in-history (x y)
1623              (push (list x y) history)))
1624     (defun speed-mouse-reset ()
1625       "Reset speed mouse coordinates"
1626       (setf minx nil miny nil maxx nil maxy nil history nil lx nil ly nil))
1627     (defun speed-mouse-left ()
1628       "Speed move mouse to left"
1629       (with-x-pointer
1630         (reset-if-moved x y)
1631         (setf maxx x)
1632         (add-in-history x y)
1633         (setf lx (middle (or minx 0) maxx))
1634         (xlib:warp-pointer *root* lx y)))
1635     (defun speed-mouse-right ()
1636       "Speed move mouse to right"
1637       (with-x-pointer
1638         (reset-if-moved x y)
1639         (setf minx x)
1640         (add-in-history x y)
1641         (setf lx (middle minx (or maxx (xlib:screen-width *screen*))))
1642         (xlib:warp-pointer *root* lx y)))
1643     (defun speed-mouse-up ()
1644       "Speed move mouse to up"
1645       (with-x-pointer
1646         (reset-if-moved x y)
1647         (setf maxy y)
1648         (add-in-history x y)
1649         (setf ly (middle (or miny 0) maxy))
1650         (xlib:warp-pointer *root* x ly)))
1651     (defun speed-mouse-down ()
1652       "Speed move mouse to down"
1653       (with-x-pointer
1654         (reset-if-moved x y)
1655         (setf miny y)
1656         (add-in-history x y)
1657         (setf ly (middle miny (or maxy (xlib:screen-height *screen*))))
1658         (xlib:warp-pointer *root* x ly)))
1659     (defun speed-mouse-undo ()
1660       "Undo last speed mouse move"
1661       (when history
1662         (let ((h (pop history)))
1663           (when h
1664             (destructuring-bind (bx by) h
1665               (setf lx bx ly by
1666                     minx nil  maxx nil
1667                     miny nil  maxy nil)
1668               (xlib:warp-pointer *root* lx ly))))))
1669     (defun speed-mouse-first-history ()
1670       "Revert to the first speed move mouse"
1671       (when history
1672         (let ((h (first (last history))))
1673           (when h
1674             (setf lx (first h)
1675                   ly (second h))
1676             (xlib:warp-pointer *root* lx ly)))))))
1677
1678
1679
1680 ;;; Notify window functions
1681 (let (font
1682       window
1683       gc
1684       width height
1685       text
1686       current-child)
1687   (labels ((text-string (tx)
1688              (typecase tx
1689                (cons (first tx))
1690                (t tx)))
1691            (text-color (tx)
1692              (get-color (typecase tx
1693                           (cons (second tx))
1694                           (t *notify-window-foreground*)))))
1695     (defun is-notify-window-p (win)
1696       (when (and (xlib:window-p win) (xlib:window-p window))
1697         (xlib:window-equal win window)))
1698
1699     (defun refresh-notify-window ()
1700       (add-timer 0.1 #'refresh-notify-window :refresh-notify-window)
1701       (raise-window window)
1702       (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font))))
1703         (loop for tx in text
1704            for i from 1 do
1705              (setf (xlib:gcontext-foreground gc) (text-color tx))
1706              (xlib:draw-glyphs window gc
1707                                (truncate (/ (- width (* (xlib:max-char-width font) (length (text-string tx)))) 2))
1708                                (* text-height i 2)
1709                                (text-string tx)))))
1710
1711     (defun close-notify-window ()
1712       (erase-timer :refresh-notify-window)
1713       (setf *never-managed-window-list*
1714             (remove (list #'is-notify-window-p 'raise-window)
1715                     *never-managed-window-list* :test #'equal))
1716       (when gc
1717         (xlib:free-gcontext gc))
1718       (when window
1719         (xlib:destroy-window window))
1720       (when font
1721         (xlib:close-font font))
1722       (xlib:display-finish-output *display*)
1723       (setf window nil
1724             gc nil
1725             font nil))
1726
1727     (defun open-notify-window (text-list)
1728       (close-notify-window)
1729       (setf font (xlib:open-font *display* *notify-window-font-string*))
1730       (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font))))
1731         (setf text text-list)
1732         (setf width (* (xlib:max-char-width font) (+ (loop for tx in text-list
1733                                                         maximize (length (text-string tx))) 2))
1734               height (+ (* text-height (length text-list) 2) text-height))
1735         (with-placement (*notify-window-placement* x y width height)
1736           (setf window (xlib:create-window :parent *root*
1737                                            :x x
1738                                            :y y
1739                                            :width width
1740                                            :height height
1741                                            :background (get-color *notify-window-background*)
1742                                            :border-width *border-size*
1743                                            :border (get-color *notify-window-border*)
1744                                            :colormap (xlib:screen-default-colormap *screen*)
1745                                            :event-mask '(:exposure :key-press))
1746                 gc (xlib:create-gcontext :drawable window
1747                                          :foreground (get-color *notify-window-foreground*)
1748                                          :background (get-color *notify-window-background*)
1749                                          :font font
1750                                          :line-style :solid))
1751           (setf (window-transparency window) *notify-window-transparency*)
1752           (when (frame-p (current-child))
1753             (setf current-child (current-child)))
1754           (push (list #'is-notify-window-p 'raise-window) *never-managed-window-list*)
1755           (map-window window)
1756           (refresh-notify-window)
1757           (xlib:display-finish-output *display*))))))
1758
1759 (defun notify-message (delay &rest messages)
1760   (erase-timer :close-notify-window)
1761   (funcall #'open-notify-window messages)
1762   (add-timer delay #'close-notify-window :close-notify-window))
1763
1764
1765 (defun display-hello-window ()
1766   (notify-message *notify-window-delay*
1767                   '("Welcome to CLFSWM" "yellow")
1768                   "Press Alt+F1 for help"))
1769
1770
1771 ;;; Run or raise functions
1772 (defun run-or-raise (raisep run-fn &key (maximized nil))
1773   (let ((window (with-all-windows (*root-frame* win)
1774                   (when (funcall raisep win)
1775                     (return win)))))
1776     (if window
1777         (let ((parent (find-parent-frame window)))
1778           (setf (current-child) parent)
1779           (put-child-on-top window parent)
1780           (when maximized
1781             (change-root (find-root parent) parent))
1782           (focus-all-children window parent)
1783           (show-all-children t))
1784         (funcall run-fn))))
1785
1786 ;;; Transparency setting
1787 (defun inc-transparency (window root-x root-y)
1788   "Increment the child under mouse transparency"
1789   (declare (ignore root-x root-y))
1790   (unless *in-second-mode* (stop-button-event))
1791   (incf (child-transparency window) 0.1))
1792
1793 (defun dec-transparency (window root-x root-y)
1794   "Decrement the child under mouse transparency"
1795   (declare (ignore root-x root-y))
1796   (unless *in-second-mode* (stop-button-event))
1797   (decf (child-transparency window) 0.1))
1798
1799 (defun inc-transparency-slow (window root-x root-y)
1800   "Increment slowly the child under mouse transparency"
1801   (declare (ignore root-x root-y))
1802   (unless *in-second-mode* (stop-button-event))
1803   (incf (child-transparency window) 0.01))
1804
1805 (defun dec-transparency-slow (window root-x root-y)
1806   "Decrement slowly the child under mouse transparency"
1807   (declare (ignore root-x root-y))
1808   (unless *in-second-mode* (stop-button-event))
1809   (decf (child-transparency window) 0.01))
1810
1811
1812 (defun key-inc-transparency ()
1813   "Increment the current window transparency"
1814   (with-current-window
1815       (incf (child-transparency window) 0.1)))
1816
1817 (defun key-dec-transparency ()
1818   "Decrement the current window transparency"
1819   (with-current-window
1820       (decf (child-transparency window) 0.1)))
1821
1822
1823
1824
1825
1826 ;;; Geometry change functions
1827 (defun swap-frame-geometry ()
1828   "Swap current brother frame geometry"
1829   (when (frame-p (current-child))
1830     (let ((parent (find-parent-frame (current-child))))
1831       (when (frame-p parent)
1832         (let ((brother (second (frame-child parent))))
1833           (when (frame-p brother)
1834             (rotatef (frame-x (current-child)) (frame-x brother))
1835             (rotatef (frame-y (current-child)) (frame-y brother))
1836             (rotatef (frame-w (current-child)) (frame-w brother))
1837             (rotatef (frame-h (current-child)) (frame-h brother))
1838             (show-all-children t)
1839             (leave-second-mode)))))))
1840
1841 (defun rotate-frame-geometry-generic (fun)
1842   "(Rotate brother frame geometry"
1843   (when (frame-p (current-child))
1844     (let ((parent (find-parent-frame (current-child))))
1845       (when (frame-p parent)
1846         (let* ((child-list (funcall fun (frame-child parent)))
1847                (first (first child-list)))
1848           (dolist (child (rest child-list))
1849             (when (and (frame-p first) (frame-p child))
1850               (rotatef (frame-x first) (frame-x child))
1851               (rotatef (frame-y first) (frame-y child))
1852               (rotatef (frame-w first) (frame-w child))
1853               (rotatef (frame-h first) (frame-h child))
1854               (setf first child)))
1855           (show-all-children t))))))
1856
1857
1858 (defun rotate-frame-geometry ()
1859   "Rotate brother frame geometry"
1860   (rotate-frame-geometry-generic #'identity))
1861
1862 (defun anti-rotate-frame-geometry ()
1863   "Anti rotate brother frame geometry"
1864   (rotate-frame-geometry-generic #'reverse))
1865