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