src/clfswm-util.lisp

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