src/clfswm-expose-mode.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Expose functions - An expose like.
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2010 Philippe Brochard <hocwp@free.fr>
   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 *expose-font* nil)
  29 (defparameter *expose-windows-list* nil)
  30 (defparameter *expose-selected-child* nil)
  31
  32 (defun leave-expose-mode ()
  33   "Leave the expose mode"
  34   (throw 'exit-expose-loop nil))
  35
  36 (defun valid-expose-mode ()
  37   "Valid the expose mode"
  38   (throw 'exit-expose-loop t))
  39
  40 (defun mouse-leave-expose-mode (window root-x root-y)
  41   "Leave the expose mode"
  42   (declare (ignore window root-x root-y))
  43   (throw 'exit-expose-loop nil))
  44
  45 (defun mouse-valid-expose-mode (window root-x root-y)
  46   "Valid the expose mode"
  47   (declare (ignore window root-x root-y))
  48   (throw 'exit-expose-loop t))
  49
  50
  51 (define-handler expose-mode :key-press (code state)
  52   (funcall-key-from-code *expose-keys* code state))
  53
  54 (define-handler expose-mode :button-press (code state window root-x root-y)
  55   (funcall-button-from-code *expose-mouse* code state window root-x root-y *fun-press*))
  56
  57 (define-handler expose-mode :exposure ()
  58   (expose-draw-letter))
  59
  60
  61 (add-hook *binding-hook* 'set-default-expose-keys)
  62
  63 (defun set-default-expose-keys ()
  64   (define-expose-key ("Escape") 'leave-expose-mode)
  65   (define-expose-key ("g" :control) 'leave-expose-mode)
  66   (define-expose-key ("Escape" :alt) 'leave-expose-mode)
  67   (define-expose-key ("g" :control :alt) 'leave-expose-mode)
  68   (define-expose-key ("Return") 'valid-expose-mode)
  69   (define-expose-key ("space") 'valid-expose-mode)
  70   (define-expose-key ("Tab") 'valid-expose-mode)
  71   (define-expose-key ("Right") 'speed-mouse-right)
  72   (define-expose-key ("Left") 'speed-mouse-left)
  73   (define-expose-key ("Down") 'speed-mouse-down)
  74   (define-expose-key ("Up") 'speed-mouse-up)
  75   (define-expose-key ("Left" :control) 'speed-mouse-undo)
  76   (define-expose-key ("Up" :control) 'speed-mouse-first-history)
  77   (define-expose-key ("Down" :control) 'speed-mouse-reset)
  78   (define-expose-mouse (1) 'mouse-valid-expose-mode)
  79   (define-expose-mouse (2) 'mouse-leave-expose-mode)
  80   (define-expose-mouse (3) 'mouse-leave-expose-mode))
  81
  82 (defmacro define-expose-letter-keys ()
  83   (labels ((produce-name (n)
  84              (symb "%" "expose-fun-key-" n "%")))
  85     `(progn
  86        ,@(loop for n from 0 to 25
  87             collect `(progn
  88                        (defun ,(produce-name n) ()
  89                          ,(format nil "Select child '~A' (~A)" (number->char n) n)
  90                          (let ((child (nth ,n *expose-windows-list*)))
  91                            (when child
  92                              (xlib:warp-pointer *root* (xlib:drawable-x (first child)) (xlib:drawable-y (first child)))
  93                              (setf *expose-selected-child* (fourth child))
  94                              (when *expose-valid-on-key*
  95                                (valid-expose-mode)))))
  96                        (define-expose-key (,(number->char n)) ',(produce-name n)))))))
  97
  98 (define-expose-letter-keys)
  99
 100
 101 (defun expose-draw-letter ()
 102   (loop for lwin in *expose-windows-list* do
 103        (xlib:draw-glyphs (first lwin) (second lwin)
 104                          (xlib:max-char-width *expose-font*)
 105                          (+ (xlib:font-ascent *expose-font*) (xlib:font-descent *expose-font*))
 106                          (third lwin))))
 107
 108 (defun expose-create-window (child n)
 109   (let* ((*current-child* child)
 110          (string (format nil "~A~A" (number->char n)
 111                          (if *expose-show-window-title*
 112                              (format nil " - ~A" (ensure-printable (child-fullname child)))
 113                              "")))
 114          (width (if *expose-show-window-title*
 115                     (min (* (xlib:max-char-width *expose-font*) (+ (length string) 2))
 116                          (- (child-width child) 4))
 117                     (* (xlib:max-char-width *expose-font*) 3)))
 118          (height (* (xlib:font-ascent *expose-font*) 2)))
 119     (with-placement (*expose-mode-placement* x y width height)
 120       (let* ((window (xlib:create-window :parent *root*
 121                                          :x x   :y y
 122                                          :width width   :height height
 123                                          :background (get-color *expose-background*)
 124                                          :border-width 1
 125                                          :border (get-color *expose-border*)
 126                                          :colormap (xlib:screen-default-colormap *screen*)
 127                                          :event-mask '(:exposure :key-press)))
 128              (gc (xlib:create-gcontext :drawable window
 129                                        :foreground (get-color *expose-foreground*)
 130                                        :background (get-color *expose-background*)
 131                                        :font *expose-font*
 132                                        :line-style :solid)))
 133         (map-window window)
 134         (push (list window gc string child) *expose-windows-list*)))))
 135
 136
 137
 138 (defun expose-mode-display-accel-windows ()
 139   (let ((n -1))
 140     (with-all-children-reversed (*current-root* child)
 141       (if (or (frame-p child)
 142               (managed-window-p child (find-parent-frame child *root-frame*)))
 143           (when (< n 25)
 144             (expose-create-window child (incf n)))
 145           (hide-child child))))
 146   (setf *expose-windows-list* (nreverse *expose-windows-list*))
 147   (expose-draw-letter))
 148
 149
 150 (defun expose-windows-generic (first-restore-frame &optional body body-escape)
 151   (setf *expose-font* (xlib:open-font *display* *expose-font-string*)
 152         *expose-windows-list* nil
 153         *expose-selected-child* nil)
 154   (xlib:warp-pointer *root* (truncate (/ (xlib:screen-width *screen*) 2))
 155                      (truncate (/ (xlib:screen-height *screen*) 2)))
 156   (with-all-frames (first-restore-frame frame)
 157     (setf (frame-data-slot frame :old-layout) (frame-layout frame)
 158           (frame-layout frame) #'tile-space-layout))
 159   (show-all-children)
 160   (expose-mode-display-accel-windows)
 161   (let ((grab-keyboard-p (xgrab-keyboard-p))
 162         (grab-pointer-p (xgrab-pointer-p)))
 163     (xgrab-pointer *root* 92 93)
 164     (unless grab-keyboard-p
 165       (ungrab-main-keys)
 166       (xgrab-keyboard *root*))
 167     (if (generic-mode 'expose-mode 'exit-expose-loop
 168                       :original-mode '(main-mode))
 169         (multiple-value-bind (x y) (xlib:query-pointer *root*)
 170           (let* ((child (or *expose-selected-child* (find-child-under-mouse x y)))
 171                  (parent (find-parent-frame child *root-frame*)))
 172             (when (and child parent)
 173               (pfuncall body parent)
 174               (focus-all-children child parent))))
 175         (pfuncall body-escape))
 176     (dolist (lwin *expose-windows-list*)
 177       (awhen (first lwin)
 178         (xlib:destroy-window it))
 179       (awhen (second lwin)
 180              (xlib:free-gcontext it)))
 181     (when *expose-font*
 182       (xlib:close-font *expose-font*))
 183     (setf *expose-windows-list* nil)
 184     (with-all-frames (first-restore-frame frame)
 185       (setf (frame-layout frame) (frame-data-slot frame :old-layout)
 186             (frame-data-slot frame :old-layout) nil))
 187     (show-all-children)
 188     (banish-pointer)
 189     (unless grab-keyboard-p
 190       (xungrab-keyboard)
 191       (grab-main-keys))
 192     (if grab-pointer-p
 193         (xgrab-pointer *root* 66 67)
 194         (xungrab-pointer))
 195     (wait-no-key-or-button-press))
 196   t)
 197
 198
 199 (defun expose-windows-mode ()
 200   "Present all windows in the current frame (An expose like)"
 201   (stop-button-event)
 202   (expose-windows-generic *current-root*))
 203
 204 (defun expose-all-windows-mode ()
 205   "Present all windows in all frames (An expose like)"
 206   (stop-button-event)
 207   (let ((orig-root *current-root*))
 208     (switch-to-root-frame :show-later t)
 209     (expose-windows-generic *root-frame*
 210                             (lambda (parent)
 211                               (hide-all-children *root-frame*)
 212                               (setf *current-root* parent))
 213                             (lambda ()
 214                               (hide-all-children *current-root*)
 215                               (setf *current-root* orig-root)))))
 216
 217 (defun expose-windows-current-child-mode ()
 218   "Present all windows in the current child (An expose like)"
 219   (stop-button-event)
 220   (when (frame-p *current-child*)
 221     (let ((orig-root *current-root*))
 222       (unless (child-equal-p *current-child* *current-root*)
 223         (hide-all *current-root*)
 224         (setf *current-root* *current-child*))
 225       (expose-windows-generic *current-root*)
 226       (unless (child-equal-p *current-child* orig-root)
 227         (hide-all *current-root*)
 228         (setf *current-root* orig-root))
 229       (show-all-children))))
 230
 231