src/clfswm-circulate-mode.lisp

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