src/clfswm-circulate-mode.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Main functions
   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 (defparameter *circulate-window* nil)
  29 (defparameter *circulate-font* nil)
  30 (defparameter *circulate-gc* nil)
  31
  32 (defparameter *circulate-hit* 0)
  33 (defparameter *circulate-orig* nil)
  34 (defparameter *circulate-parent* nil)
  35
  36 (defun draw-circulate-mode-window ()
  37   (raise-window *circulate-window*)
  38   (clear-pixmap-buffer *circulate-window* *circulate-gc*)
  39   (let* ((text (format nil "~A [~A]"
  40                        (limit-length (ensure-printable (child-name (xlib:input-focus *display*)))
  41                                      *circulate-text-limite*)
  42                        (limit-length (ensure-printable (child-name (current-child)))
  43                                      *circulate-text-limite*)))
  44          (len (length text)))
  45     (xlib:draw-glyphs *pixmap-buffer* *circulate-gc*
  46                       (truncate (/ (- *circulate-width* (* (xlib:max-char-width *circulate-font*) len)) 2))
  47                       (truncate (/ (+ *circulate-height* (- (xlib:font-ascent *circulate-font*)
  48                                                             (xlib:font-descent *circulate-font*))) 2))
  49                       text))
  50   (copy-pixmap-buffer *circulate-window* *circulate-gc*))
  51
  52
  53
  54 (defun leave-circulate-mode ()
  55   "Leave the circulate mode"
  56   (throw 'exit-circulate-loop nil))
  57
  58
  59
  60 (defun reset-circulate-child ()
  61   (setf *circulate-hit* 0
  62         *circulate-parent* nil
  63         *circulate-orig* (frame-child (current-child))))
  64
  65 (defun reset-circulate-brother ()
  66   (setf *circulate-parent* (find-parent-frame (current-child))
  67         *circulate-hit* 0)
  68   (when (frame-p *circulate-parent*)
  69     (setf *circulate-orig* (frame-child *circulate-parent*))))
  70
  71
  72
  73 (defun reorder-child (direction)
  74   (no-focus)
  75   (with-slots (child selected-pos) (current-child)
  76     (unless *circulate-orig*
  77       (reset-circulate-child))
  78     (let ((len (length *circulate-orig*)))
  79       (when (plusp len)
  80         (let ((elem (nth (mod (incf *circulate-hit* direction) len) *circulate-orig*)))
  81           (setf child (cons elem (child-remove elem *circulate-orig*))
  82                 selected-pos 0)))
  83       (show-all-children)
  84       (draw-circulate-mode-window))))
  85
  86
  87 (defun reorder-brother (direction)
  88   (no-focus)
  89   (let ((old-child (current-child)))
  90     (select-current-frame nil)
  91     (unless (and *circulate-orig* *circulate-parent*)
  92       (reset-circulate-brother))
  93     (let ((len (length *circulate-orig*)))
  94       (when (plusp len)
  95         (when (frame-p *circulate-parent*)
  96           (let ((elem (nth (mod (incf *circulate-hit* direction) len) *circulate-orig*)))
  97             (setf (frame-child *circulate-parent*) (cons elem (child-remove elem *circulate-orig*))
  98                   (frame-selected-pos *circulate-parent*) 0
  99                   (current-child) (frame-selected-child *circulate-parent*))))
 100         (when (and (not (child-root-p (current-child)))
 101                    (child-root-p old-child))
 102           (change-root (find-root old-child) (current-child)))))
 103     (show-all-children t)
 104     (draw-circulate-mode-window)))
 105
 106 (defun reorder-subchild (direction)
 107   (declare (ignore direction))
 108   (when (frame-p (current-child))
 109     (let ((selected-child (frame-selected-child (current-child))))
 110       (when (frame-p selected-child)
 111         (no-focus)
 112         (with-slots (child selected-pos) selected-child
 113           (let ((elem (first (last child))))
 114             (when elem
 115               (setf child (cons elem (child-remove elem child))
 116                     selected-pos 0))
 117             (show-all-children)
 118             (draw-circulate-mode-window)))))))
 119
 120
 121
 122
 123
 124 (defun circulate-select-next-child ()
 125   "Select the next child"
 126   (when (frame-p (current-child))
 127     (when *circulate-parent*
 128       (reset-circulate-child))
 129     (reorder-child +1)))
 130
 131 (defun circulate-select-previous-child ()
 132   "Select the previous child"
 133   (when (frame-p (current-child))
 134     (when *circulate-parent*
 135       (reset-circulate-child))
 136     (reorder-child -1)))
 137
 138
 139 (defun circulate-select-next-brother ()
 140   "Select the next brother"
 141   (unless *circulate-parent*
 142     (reset-circulate-brother))
 143   (reorder-brother +1))
 144
 145 (defun circulate-select-previous-brother ()
 146   "Select the previous borther"
 147   (unless *circulate-parent*
 148     (reset-circulate-brother))
 149   (reorder-brother -1))
 150
 151 (defun circulate-select-next-subchild ()
 152   "Select the next subchild"
 153   (reorder-subchild +1))
 154
 155
 156
 157 (add-hook *binding-hook* 'set-default-circulate-keys)
 158
 159 (defun set-default-circulate-keys ()
 160   (define-circulate-key ("Escape") 'leave-circulate-mode)
 161   (define-circulate-key ("g" :control) 'leave-circulate-mode)
 162   (define-circulate-key ("Escape" :alt) 'leave-circulate-mode)
 163   (define-circulate-key ("g" :control :alt) 'leave-circulate-mode)
 164   (define-circulate-key ("Tab" :mod-1) 'circulate-select-next-child)
 165   (define-circulate-key ("Tab" :mod-1 :control) 'circulate-select-next-subchild)
 166   (define-circulate-key ("Tab" :mod-1 :shift) 'circulate-select-previous-child)
 167   (define-circulate-key ("Iso_Left_Tab" :mod-1 :shift) 'circulate-select-previous-child)
 168   (define-circulate-key ("Right" :mod-1) 'circulate-select-next-brother)
 169   (define-circulate-key ("Left" :mod-1) 'circulate-select-previous-brother)
 170   (define-circulate-release-key ("Alt_L" :alt) 'leave-circulate-mode)
 171   (define-circulate-release-key ("Alt_L") 'leave-circulate-mode))
 172
 173
 174 (defun circulate-leave-function ()
 175   (when *circulate-gc*
 176     (xlib:free-gcontext *circulate-gc*))
 177   (when *circulate-window*
 178     (xlib:destroy-window *circulate-window*))
 179   (when *circulate-font*
 180     (xlib:close-font *circulate-font*))
 181   (setf *circulate-window* nil
 182         *circulate-gc* nil
 183         *circulate-font* nil)
 184   (xlib:display-finish-output *display*))
 185
 186 (defun circulate-loop-function ()
 187   (unless (is-a-key-pressed-p)
 188     (leave-circulate-mode)))
 189
 190 (define-handler circulate-mode :key-press (code state)
 191   (unless (funcall-key-from-code *circulate-keys* code state)
 192     (setf *circulate-hit* 0
 193           *circulate-orig* nil
 194           *circulate-parent* nil)
 195     (funcall-key-from-code *main-keys* code state)))
 196
 197
 198 (define-handler circulate-mode :key-release (code state)
 199   (funcall-key-from-code *circulate-keys-release* code state))
 200
 201
 202
 203 (defun circulate-mode (&key child-direction brother-direction subchild-direction)
 204   (setf *circulate-hit* 0)
 205   (with-placement (*circulate-mode-placement* x y *circulate-width* *circulate-height*)
 206     (setf *circulate-font* (xlib:open-font *display* *circulate-font-string*)
 207           *circulate-window* (xlib:create-window :parent *root*
 208                                                  :x x
 209                                                  :y y
 210                                                  :width *circulate-width*
 211                                                  :height *circulate-height*
 212                                                  :background (get-color *circulate-background*)
 213                                                  :border-width *border-size*
 214                                                  :border (get-color *circulate-border*)
 215                                                  :colormap (xlib:screen-default-colormap *screen*)
 216                                                  :event-mask '(:exposure :key-press))
 217           *circulate-gc* (xlib:create-gcontext :drawable *circulate-window*
 218                                                :foreground (get-color *circulate-foreground*)
 219                                                :background (get-color *circulate-background*)
 220                                                :font *circulate-font*
 221                                                :line-style :solid))
 222     (setf (window-transparency *circulate-window*) *circulate-transparency*)
 223     (map-window *circulate-window*)
 224     (draw-circulate-mode-window)
 225     (when child-direction
 226       (reorder-child child-direction))
 227     (when brother-direction
 228       (reorder-brother brother-direction))
 229     (when subchild-direction
 230       (reorder-subchild subchild-direction))
 231     (with-grab-keyboard-and-pointer (92 93 66 67 t)
 232       (generic-mode 'circulate-mode 'exit-circulate-loop
 233                     :loop-function #'circulate-loop-function
 234                     :leave-function #'circulate-leave-function
 235                     :original-mode '(main-mode))
 236       (circulate-leave-function))))
 237
 238
 239 (defun select-next-child ()
 240   "Select the next child"
 241   (when (frame-p (current-child))
 242     (setf *circulate-orig* (frame-child (current-child))
 243           *circulate-parent* nil)
 244     (circulate-mode :child-direction +1)))
 245
 246 (defun select-previous-child ()
 247   "Select the previous child"
 248   (when (frame-p (current-child))
 249     (setf *circulate-orig* (frame-child (current-child))
 250           *circulate-parent* nil)
 251     (circulate-mode :child-direction -1)))
 252
 253
 254 (defun select-next-brother ()
 255   "Select the next brother"
 256   (setf *circulate-parent* (find-parent-frame (current-child)))
 257   (when (frame-p *circulate-parent*)
 258     (setf *circulate-orig* (frame-child *circulate-parent*)))
 259   (circulate-mode :brother-direction +1))
 260
 261 (defun select-previous-brother ()
 262   "Select the previous brother"
 263   (setf *circulate-parent* (find-parent-frame (current-child)))
 264   (when (frame-p *circulate-parent*)
 265     (setf *circulate-orig* (frame-child *circulate-parent*)))
 266   (circulate-mode :brother-direction -1))
 267
 268
 269 (defmacro with-move-current-focused-window (() &body body)
 270   `(with-current-window
 271      ,@body
 272      (move-child-to window (if (frame-p (current-child))
 273                                (current-child)
 274                                (find-parent-frame (current-child) (find-current-root))))))
 275
 276
 277
 278 (defun select-next-brother-take-current ()
 279   "Select the next brother and move the current focused child in it"
 280   (with-move-current-focused-window ()
 281     (select-next-brother)))
 282
 283 (defun select-previous-brother-take-current ()
 284   "Select the previous brother and move the current focused child in it"
 285   (with-move-current-focused-window ()
 286     (select-previous-brother)))
 287
 288
 289
 290 (defun select-next-subchild ()
 291   "Select the next subchild"
 292   (when (and (frame-p (current-child))
 293              (frame-p (frame-selected-child (current-child))))
 294     (setf *circulate-orig* (frame-child (current-child))
 295           *circulate-parent* nil)
 296     (circulate-mode :subchild-direction +1)))
 297
 298
 299 (defun select-next-child-simple ()
 300   "Select the next child (do not enter in circulate mode)"
 301   (when (frame-p (current-child))
 302     (with-slots (child) (current-child)
 303       (setf child (rotate-list child)))
 304     (show-all-children)))
 305
 306 (defun select-previous-child-simple ()
 307   "Select the previous child (do not enter circulate mode)"
 308   (when (frame-p (current-child))
 309     (with-slots (child) (current-child)
 310       (setf child (anti-rotate-list child)))
 311     (show-all-children)))
 312
 313
 314 (defun reorder-brother-simple (reorder-fun)
 315   (let ((is-root-p (child-root-p (current-child))))
 316     (when is-root-p
 317       (leave-frame)
 318       (sleep *spatial-move-delay-before*))
 319     (no-focus)
 320     (select-current-frame nil)
 321     (let ((parent-frame (find-parent-frame (current-child))))
 322       (when (frame-p parent-frame)
 323         (with-slots (child) parent-frame
 324           (setf child (funcall reorder-fun child)
 325                 (current-child) (frame-selected-child parent-frame))))
 326       (show-all-children t)
 327       (when is-root-p
 328         (sleep *spatial-move-delay-after*)
 329         (enter-frame)))))
 330
 331
 332 (defun select-next-brother-simple ()
 333   "Select the next brother frame (do not enter in circulate mode)"
 334   (reorder-brother-simple #'rotate-list))
 335
 336 (defun select-previous-brother-simple ()
 337   "Select the previous brother frame (do not enter in circulate mode)"
 338   (reorder-brother-simple #'anti-rotate-list))
 339
 340
 341
 342 ;;; Spatial move functions
 343 (defun select-brother-generic-spatial-move (fun-found)
 344   "Select the nearest brother of the current child based on the fun-found function"
 345   (let ((is-root-p (child-root-p (current-child))))
 346     (when is-root-p
 347       (leave-frame)
 348       (sleep *spatial-move-delay-before*))
 349     (no-focus)
 350     (select-current-frame nil)
 351     (let ((parent-frame (find-parent-frame (current-child))))
 352       (when (frame-p parent-frame)
 353         (with-slots (child selected-pos) parent-frame
 354           (let ((found nil)
 355                 (found-dist nil))
 356             (dolist (c child)
 357               (let ((dist (funcall fun-found (current-child) c)))
 358                 (when (and dist
 359                            (not (child-equal-p (current-child) c))
 360                            (or (not found)
 361                                (and found-dist (< dist found-dist))))
 362                   (setf found c
 363                         found-dist dist))))
 364             (when found
 365               (setf (current-child) found
 366                     selected-pos 0
 367                     child (cons found (child-remove found child)))))))
 368       (show-all-children t)
 369       (when is-root-p
 370         (sleep *spatial-move-delay-after*)
 371         (enter-frame)))))
 372
 373
 374
 375 (defun select-brother-spatial-move-right ()
 376   "Select spatially the nearest brother of the current child in the right direction"
 377   (select-brother-generic-spatial-move #'(lambda (current child)
 378                                            (when (> (child-x2 child) (child-x2 current))
 379                                              (distance (child-x2 current) (middle-child-y current)
 380                                                        (child-x child) (middle-child-y child))))))
 381
 382
 383
 384 (defun select-brother-spatial-move-left ()
 385   "Select spatially the nearest brother of the current child in the left direction"
 386   (select-brother-generic-spatial-move #'(lambda (current child)
 387                                            (when (< (child-x child) (child-x current))
 388                                              (distance (child-x current) (middle-child-y current)
 389                                                        (child-x2 child) (middle-child-y child))))))
 390
 391
 392 (defun select-brother-spatial-move-down ()
 393   "Select spatially the nearest brother of the current child in the down direction"
 394   (select-brother-generic-spatial-move #'(lambda (current child)
 395                                            (when (> (child-y2 child) (child-y2 current))
 396                                              (distance (middle-child-x current) (child-y2 current)
 397                                                        (middle-child-x child) (child-y child))))))
 398
 399
 400 (defun select-brother-spatial-move-up ()
 401   "Select spatially the nearest brother of the current child in the up direction"
 402   (select-brother-generic-spatial-move #'(lambda (current child)
 403                                            (when (< (child-y child) (child-y current))
 404                                              (distance (middle-child-x current) (child-y current)
 405                                                        (middle-child-x child) (child-y2 child))))))
 406
 407
 408 (defun select-brother-spatial-move-right-take-current ()
 409   "Select spatially the nearest brother of the current child in the right direction - move current focused child"
 410   (with-move-current-focused-window ()
 411     (select-brother-spatial-move-right)))
 412
 413
 414 (defun select-brother-spatial-move-left-take-current ()
 415   "Select spatially the nearest brother of the current child in the left direction - move current focused child"
 416   (with-move-current-focused-window ()
 417     (select-brother-spatial-move-left)))
 418
 419 (defun select-brother-spatial-move-down-take-current ()
 420   "Select spatially the nearest brother of the current child in the down direction - move current focused child"
 421   (with-move-current-focused-window ()
 422     (select-brother-spatial-move-down)))
 423
 424 (defun select-brother-spatial-move-up-take-current ()
 425   "Select spatially the nearest brother of the current child in the up direction - move current focused child"
 426   (with-move-current-focused-window ()
 427     (select-brother-spatial-move-up)))