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   (setf *circulate-window* nil
 181         *circulate-gc* nil
 182         *circulate-font* nil)
 183   (xlib:display-finish-output *display*))
 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     (with-grab-keyboard-and-pointer (92 93 66 67 t)
 231       (generic-mode 'circulate-mode 'exit-circulate-loop
 232                     :loop-function #'circulate-loop-function
 233                     :leave-function #'circulate-leave-function
 234                     :original-mode '(main-mode))
 235       (circulate-leave-function))))
 236
 237
 238 (defun select-next-child ()
 239   "Select the next child"
 240   (when (frame-p (current-child))
 241     (setf *circulate-orig* (frame-child (current-child))
 242           *circulate-parent* nil)
 243     (circulate-mode :child-direction +1)))
 244
 245 (defun select-previous-child ()
 246   "Select the previous child"
 247   (when (frame-p (current-child))
 248     (setf *circulate-orig* (frame-child (current-child))
 249           *circulate-parent* nil)
 250     (circulate-mode :child-direction -1)))
 251
 252
 253 (defun select-next-brother ()
 254   "Select the next brother"
 255   (setf *circulate-parent* (find-parent-frame (current-child)))
 256   (when (frame-p *circulate-parent*)
 257     (setf *circulate-orig* (frame-child *circulate-parent*)))
 258   (circulate-mode :brother-direction +1))
 259
 260 (defun select-previous-brother ()
 261   "Select the previous brother"
 262   (setf *circulate-parent* (find-parent-frame (current-child)))
 263   (when (frame-p *circulate-parent*)
 264     (setf *circulate-orig* (frame-child *circulate-parent*)))
 265   (circulate-mode :brother-direction -1))
 266
 267 (defun select-next-subchild ()
 268   "Select the next subchild"
 269   (when (and (frame-p (current-child))
 270              (frame-p (frame-selected-child (current-child))))
 271     (setf *circulate-orig* (frame-child (current-child))
 272           *circulate-parent* nil)
 273     (circulate-mode :subchild-direction +1)))
 274
 275
 276 (defun select-next-child-simple ()
 277   "Select the next child (do not enter in circulate mode)"
 278   (when (frame-p (current-child))
 279     (with-slots (child) (current-child)
 280       (setf child (rotate-list child)))
 281     (show-all-children)))
 282
 283 (defun select-previous-child-simple ()
 284   "Select the previous child (do not enter circulate mode)"
 285   (when (frame-p (current-child))
 286     (with-slots (child) (current-child)
 287       (setf child (anti-rotate-list child)))
 288     (show-all-children)))
 289
 290
 291 (defun reorder-brother-simple (reorder-fun)
 292   (unless (child-root-p (current-child))
 293     (no-focus)
 294     (select-current-frame nil)
 295     (let ((parent-frame (find-parent-frame (current-child))))
 296       (when (frame-p parent-frame)
 297         (with-slots (child) parent-frame
 298           (setf child (funcall reorder-fun child)
 299                 (current-child) (frame-selected-child parent-frame))))
 300       (show-all-children t))))
 301
 302
 303 (defun select-next-brother-simple ()
 304   "Select the next brother frame (do not enter in circulate mode)"
 305   (reorder-brother-simple #'rotate-list))
 306
 307 (defun select-previous-brother-simple ()
 308   "Select the previous brother frame (do not enter in circulate mode)"
 309   (reorder-brother-simple #'anti-rotate-list))
 310
 311
 312
 313 ;;; Spatial move functions
 314 (defun select-brother-generic-spatial-move (fun-found)
 315   "Select the nearest brother of the current child based on the fun-found function"
 316   (let ((is-root-p (child-root-p (current-child))))
 317     (when is-root-p
 318       (leave-frame)
 319       (sleep *spatial-move-delay-before*))
 320     (no-focus)
 321     (select-current-frame nil)
 322     (let ((parent-frame (find-parent-frame (current-child))))
 323       (when (frame-p parent-frame)
 324         (with-slots (child selected-pos) parent-frame
 325           (let ((found nil)
 326                 (found-dist nil))
 327             (dolist (c child)
 328               (let ((dist (funcall fun-found (current-child) c)))
 329                 (when (and dist
 330                            (not (child-equal-p (current-child) c))
 331                            (or (not found)
 332                                (and found-dist (< dist found-dist))))
 333                   (setf found c
 334                         found-dist dist))))
 335             (when found
 336               (setf (current-child) found
 337                     selected-pos 0
 338                     child (cons found (child-remove found child)))))))
 339       (show-all-children t)
 340       (when is-root-p
 341         (sleep *spatial-move-delay-after*)
 342         (enter-frame)))))
 343
 344
 345
 346 (defun select-brother-spatial-move-right ()
 347   "Select spatially the nearest brother of the current child in the right direction"
 348   (select-brother-generic-spatial-move #'(lambda (current child)
 349                                            (when (> (child-x2 child) (child-x2 current))
 350                                              (distance (child-x2 current) (middle-child-y current)
 351                                                        (child-x child) (middle-child-y child))))))
 352
 353
 354
 355 (defun select-brother-spatial-move-left ()
 356   "Select spatially the nearest brother of the current child in the left direction"
 357   (select-brother-generic-spatial-move #'(lambda (current child)
 358                                            (when (< (child-x child) (child-x current))
 359                                              (distance (child-x current) (middle-child-y current)
 360                                                        (child-x2 child) (middle-child-y child))))))
 361
 362
 363 (defun select-brother-spatial-move-down ()
 364   "Select spatially the nearest brother of the current child in the down direction"
 365   (select-brother-generic-spatial-move #'(lambda (current child)
 366                                            (when (> (child-y2 child) (child-y2 current))
 367                                              (distance (middle-child-x current) (child-y2 current)
 368                                                        (middle-child-x child) (child-y child))))))
 369
 370
 371 (defun select-brother-spatial-move-up ()
 372   "Select spatially the nearest brother of the current child in the up direction"
 373   (select-brother-generic-spatial-move #'(lambda (current child)
 374                                            (when (< (child-y child) (child-y current))
 375                                              (distance (middle-child-x current) (child-y current)
 376                                                        (middle-child-x child) (child-y2 child))))))
 377
 378