src/clfswm-expose-mode.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Expose functions - An expose like.
   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 *expose-font* nil)
  29 (defparameter *expose-selected-child* nil)
  30
  31 (defstruct expose-child number child key window gc string)
  32
  33 (defun leave-expose-mode ()
  34   "Leave the expose mode"
  35   (throw 'exit-expose-loop nil))
  36
  37 (defun valid-expose-mode ()
  38   "Valid the expose mode"
  39   (throw 'exit-expose-loop t))
  40
  41 (defun mouse-leave-expose-mode (window root-x root-y)
  42   "Leave the expose mode"
  43   (declare (ignore window root-x root-y))
  44   (throw 'exit-expose-loop nil))
  45
  46 (defun mouse-valid-expose-mode (window root-x root-y)
  47   "Valid the expose mode"
  48   (declare (ignore window root-x root-y))
  49   (throw 'exit-expose-loop t))
  50
  51
  52 (defun expose-associate-keys ()
  53   (let* ((all nil)
  54          (new nil)
  55          (all-numbers (loop for ec in *expose-child-list*
  56                          collect (expose-child-number ec))))
  57     (with-all-children-reversed (*root-frame* child)
  58       (unless (child-equal-p child *root-frame*)
  59         (push child all)
  60         (unless (member child *expose-child-list* :test #'child-equal-p :key #'expose-child-child)
  61           (let ((number (find-free-number all-numbers)))
  62             (push (make-expose-child :child child :number number :key (number->letter number)) new)
  63             (push number all-numbers)))))
  64     (append (remove-if-not (lambda (x) (member x all :test #'child-equal-p)) *expose-child-list*
  65                            :key #'expose-child-child)
  66             (nreverse new))))
  67
  68
  69
  70
  71
  72 (defun expose-draw-letter ()
  73   (dolist (ex-child *expose-child-list*)
  74     (let ((window (expose-child-window ex-child))
  75           (gc (expose-child-gc ex-child)))
  76       (when (and window gc)
  77         (clear-pixmap-buffer window gc)
  78         (xlib:with-gcontext (gc :foreground (get-color (if (substring-equal *query-string* (expose-child-key ex-child))
  79                                                            *expose-foreground-letter*
  80                                                            *expose-foreground-letter-nok*))
  81                                 :background (get-color (if (string-equal *query-string* (expose-child-key ex-child))
  82                                                            *expose-background-letter-match*
  83                                                            *expose-background*)))
  84           (xlib:draw-image-glyphs *pixmap-buffer* gc
  85                                   (xlib:max-char-width *expose-font*)
  86                                   (+ (xlib:font-ascent *expose-font*) (xlib:font-descent *expose-font*))
  87                                   (expose-child-key ex-child)))
  88         (xlib:draw-glyphs *pixmap-buffer* gc
  89                           (xlib:max-char-width *expose-font*)
  90                           (+ (* 2 (xlib:font-ascent *expose-font*)) (xlib:font-descent *expose-font*) 1)
  91                           (expose-child-string ex-child))
  92         (copy-pixmap-buffer window gc)))))
  93
  94
  95 (defun expose-create-window (ex-child)
  96   (let ((child (expose-child-child ex-child)))
  97     (with-current-child (child)
  98       (let* ((string (format nil "~A"
  99                              (if *expose-show-window-title*
 100                                  (ensure-printable (child-fullname child))
 101                                  "")))
 102              (width (if *expose-show-window-title*
 103                         (min (* (xlib:max-char-width *expose-font*) (+ (length string) 2))
 104                              (- (child-width child) 4))
 105                         (* (xlib:max-char-width *expose-font*) 3)))
 106              (height (* (xlib:font-ascent *expose-font*) 3)))
 107         (with-placement (*expose-mode-placement* x y width height)
 108           (let* ((window (xlib:create-window :parent *root*
 109                                              :x x   :y y
 110                                              :width width   :height height
 111                                              :background (get-color *expose-background*)
 112                                              :border-width *border-size*
 113                                              :border (get-color *expose-border*)
 114                                              :colormap (xlib:screen-default-colormap *screen*)
 115                                              :event-mask '(:exposure :key-press)))
 116                  (gc (xlib:create-gcontext :drawable window
 117                                            :foreground (get-color *expose-foreground*)
 118                                            :background (get-color *expose-background*)
 119                                            :font *expose-font*
 120                                            :line-style :solid)))
 121             (setf (window-transparency window) *expose-transparency*)
 122             (map-window window)
 123             (setf (expose-child-window ex-child) window
 124                   (expose-child-gc ex-child) gc
 125                   (expose-child-string ex-child) string)))))))
 126
 127
 128
 129
 130 (defun expose-query-key-press-hook (code state)
 131   (declare (ignore code state))
 132   (expose-draw-letter)
 133   (let ((two-letters-key (dolist (child *expose-child-list*)
 134                            (when (> (length (expose-child-key child)) 1)
 135                              (return t)))))
 136     (when (and *expose-direct-select* (not two-letters-key))
 137       (leave-query-mode :return))))
 138
 139 (defun expose-query-button-press-hook (code state x y)
 140   (declare (ignore state))
 141   (when (= code 1)
 142     (setf *expose-selected-child*
 143           (find (find-child-under-mouse x y) *expose-child-list* :test #'child-equal-p :key #'expose-child-child)))
 144   (leave-query-mode :click))
 145
 146
 147 (defun expose-init ()
 148   (setf *expose-font* (xlib:open-font *display* *expose-font-string*)
 149         *expose-child-list* (expose-associate-keys)
 150         *expose-selected-child* nil
 151         *query-string* "")
 152   (xlib:warp-pointer *root* (truncate (/ (screen-width) 2))
 153                      (truncate (/ (screen-height) 2)))
 154   (add-hook *query-key-press-hook* 'expose-query-key-press-hook)
 155   (add-hook *query-button-press-hook* 'expose-query-button-press-hook))
 156
 157 (defun expose-present-windows ()
 158   (dolist (ex-child *expose-child-list*)
 159     (let ((child (expose-child-child ex-child)))
 160       (when (frame-p child)
 161         (setf (frame-data-slot child :old-layout) (frame-layout child)
 162               (frame-layout child) #'tile-space-layout))))
 163   (show-all-children t))
 164
 165 (defun expose-unpresent-windows ()
 166   (dolist (ex-child *expose-child-list*)
 167     (let ((child (expose-child-child ex-child)))
 168       (when (frame-p child)
 169         (setf (frame-layout child) (frame-data-slot child :old-layout)
 170               (frame-data-slot child :old-layout) nil)))))
 171
 172 (defun expose-mode-display-accel-windows ()
 173   (let ((all-hidden-windows (get-hidden-windows)))
 174         (with-all-root-child (root)
 175           (with-all-children-reversed (root child)
 176                 (let ((ex-child (find child *expose-child-list* :test #'child-equal-p :key #'expose-child-child)))
 177                   (when ex-child
 178                         (if (or (frame-p (expose-child-child ex-child))
 179                                         (managed-window-p (expose-child-child ex-child)
 180                                                                           (find-parent-frame (expose-child-child ex-child) *root-frame*)))
 181                                 (unless (child-member (expose-child-child ex-child) all-hidden-windows)
 182                                   (expose-create-window ex-child))
 183                                 (hide-child (expose-child-child ex-child)))))))
 184         (expose-draw-letter)))
 185
 186
 187 (defun expose-find-child-from-letters (letters)
 188   (find letters *expose-child-list* :test #'string-equal :key #'expose-child-key))
 189
 190 (defun expose-select-child ()
 191   (let ((*query-mode-placement* *expose-query-placement*))
 192     (multiple-value-bind (letters return)
 193         (query-string "Which child ?")
 194       (let ((ex-child (case return
 195                         (:return (expose-find-child-from-letters letters))
 196                         (:click *expose-selected-child*))))
 197         (when ex-child
 198           (expose-child-child ex-child))))))
 199
 200
 201 (defun expose-restore-windows (&optional (present-window t))
 202   (remove-hook *query-key-press-hook* 'expose-query-key-press-hook)
 203   (remove-hook *query-button-press-hook* 'expose-query-button-press-hook)
 204   (dolist (ex-child *expose-child-list*)
 205     (awhen (expose-child-gc ex-child)
 206       (xlib:free-gcontext it))
 207     (awhen (expose-child-window ex-child)
 208       (xlib:destroy-window it))
 209     (setf (expose-child-gc ex-child) nil
 210           (expose-child-window ex-child) nil))
 211   (when *expose-font*
 212     (xlib:close-font *expose-font*))
 213   (when present-window
 214         (expose-unpresent-windows)))
 215
 216 (defun expose-focus-child (child)
 217   (let ((parent (typecase child
 218                   (xlib:window (find-parent-frame child))
 219                   (frame child))))
 220     (when (and child parent)
 221           (change-root (find-root parent) parent)
 222       (setf (current-child) child)
 223       (focus-all-children child parent t))))
 224
 225 (defun expose-do-main (&optional (present-window t))
 226   (stop-button-event)
 227   (expose-init)
 228   (when present-window
 229         (expose-present-windows))
 230   (expose-mode-display-accel-windows)
 231   (let ((child (expose-select-child)))
 232         (expose-restore-windows present-window)
 233         child))
 234
 235
 236 (defun expose-windows-mode ()
 237   "Present all windows in currents roots (An expose like)"
 238   (awhen (expose-do-main)
 239     (expose-focus-child it))
 240   (show-all-children)
 241   t)
 242
 243
 244 (defun expose-all-windows-mode ()
 245   "Present all windows in all frames (An expose like)"
 246   (let ((child nil))
 247     (with-saved-root-list ()
 248       (dolist (root (get-root-list))
 249         (change-root root (root-original root)))
 250       (setf child (expose-do-main)))
 251     (when child
 252       (expose-focus-child child)))
 253   (show-all-children)
 254   t)
 255
 256 (defun expose-current-child-mode ()
 257   "Present all windows in currents roots (An expose like)"
 258   (with-saved-root-list ()
 259         (awhen (expose-do-main nil)
 260           (expose-focus-child it)))
 261   (show-all-children)
 262   t)