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