src/clfswm-util.lisp

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