src/clfswm-expose-mode.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Expose functions - An expose like.
   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 *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 (defun expose-draw-letter ()
  52   (dolist (lwin *expose-windows-list*)
  53     (destructuring-bind (window gc string child letter) lwin
  54       (declare (ignore child))
  55       (clear-pixmap-buffer window gc)
  56       (xlib:with-gcontext (gc :foreground (get-color (if (substring-equal *query-string* letter)
  57                                                          *expose-foreground-letter*
  58                                                          *expose-foreground-letter-nok*))
  59                               :background (get-color (if (string-equal *query-string* letter)
  60                                                          *expose-background-letter-match*
  61                                                          *expose-background*)))
  62         (xlib:draw-image-glyphs *pixmap-buffer* gc
  63                                 (xlib:max-char-width *expose-font*)
  64                                 (+ (xlib:font-ascent *expose-font*) (xlib:font-descent *expose-font*))
  65                                 letter))
  66       (xlib:draw-glyphs *pixmap-buffer* gc
  67                         (xlib:max-char-width *expose-font*)
  68                         (+ (* 2 (xlib:font-ascent *expose-font*)) (xlib:font-descent *expose-font*) 1)
  69                         string)
  70       (copy-pixmap-buffer window gc))))
  71
  72 (defun expose-create-window (child n)
  73   (with-current-child (child)
  74     (let* ((string (format nil "~A"
  75                            (if *expose-show-window-title*
  76                                (ensure-printable (child-fullname child))
  77                                "")))
  78            (width (if *expose-show-window-title*
  79                       (min (* (xlib:max-char-width *expose-font*) (+ (length string) 2))
  80                            (- (child-width child) 4))
  81                       (* (xlib:max-char-width *expose-font*) 3)))
  82            (height (* (xlib:font-ascent *expose-font*) 3)))
  83       (with-placement (*expose-mode-placement* x y width height)
  84         (let* ((window (xlib:create-window :parent *root*
  85                                            :x x   :y y
  86                                            :width width   :height height
  87                                            :background (get-color *expose-background*)
  88                                            :border-width *border-size*
  89                                            :border (get-color *expose-border*)
  90                                            :colormap (xlib:screen-default-colormap *screen*)
  91                                            :event-mask '(:exposure :key-press)))
  92                (gc (xlib:create-gcontext :drawable window
  93                                          :foreground (get-color *expose-foreground*)
  94                                          :background (get-color *expose-background*)
  95                                          :font *expose-font*
  96                                          :line-style :solid)))
  97           (setf (window-transparency window) *expose-transparency*)
  98           (map-window window)
  99           (push (list window gc string child (number->letter n)) *expose-windows-list*))))))
 100
 101
 102
 103
 104 (defun expose-query-key-press-hook (code state)
 105   (declare (ignore code state))
 106   (expose-draw-letter)
 107   (when (and *expose-direct-select* (<= (length *expose-windows-list*) 26))
 108     (leave-query-mode :return)))
 109
 110 (defun expose-query-button-press-hook (code state x y)
 111   (declare (ignore state))
 112   (when (= code 1)
 113     (setf *expose-selected-child* (find-child-under-mouse x y)))
 114   (leave-query-mode :click))
 115
 116
 117 (defun expose-init ()
 118   (setf *expose-font* (xlib:open-font *display* *expose-font-string*)
 119         *expose-windows-list* nil
 120         *expose-selected-child* nil
 121         *query-string* "")
 122   (xlib:warp-pointer *root* (truncate (/ (xlib:screen-width *screen*) 2))
 123                      (truncate (/ (xlib:screen-height *screen*) 2)))
 124   (add-hook *query-key-press-hook* 'expose-query-key-press-hook)
 125   (add-hook *query-button-press-hook* 'expose-query-button-press-hook))
 126
 127 (defun expose-present-windows ()
 128   (with-all-root-child (root)
 129     (with-all-frames (root frame)
 130       (setf (frame-data-slot frame :old-layout) (frame-layout frame)
 131             (frame-layout frame) #'tile-space-layout)))
 132   (show-all-children t))
 133
 134 (defun expose-mode-display-accel-windows ()
 135   (let ((n -1))
 136     (with-all-root-child (root)
 137       (with-all-children-reversed (root child)
 138         (if (or (frame-p child)
 139                 (managed-window-p child (find-parent-frame child *root-frame*)))
 140             (expose-create-window child (incf n))
 141             (hide-child child))))
 142     (setf *expose-windows-list* (nreverse *expose-windows-list*))
 143     (expose-draw-letter)))
 144
 145 (defun expose-find-child-from-letters (letters)
 146   (fourth (find letters *expose-windows-list* :test #'string-equal :key #'fifth)))
 147
 148 (defun expose-select-child ()
 149   (let ((*query-mode-placement* *expose-query-placement*))
 150     (multiple-value-bind (letters return)
 151         (query-string "Which child ?")
 152       (let ((child (case return
 153                      (:return (expose-find-child-from-letters letters))
 154                      (:click *expose-selected-child*))))
 155         (when (find-child-in-all-root child)
 156           child)))))
 157
 158 (defun expose-restore-windows ()
 159   (remove-hook *query-key-press-hook* 'expose-query-key-press-hook)
 160   (remove-hook *query-button-press-hook* 'expose-query-button-press-hook)
 161   (dolist (lwin *expose-windows-list*)
 162     (awhen (first lwin)
 163       (xlib:destroy-window it))
 164     (awhen (second lwin)
 165       (xlib:free-gcontext it)))
 166   (when *expose-font*
 167     (xlib:close-font *expose-font*))
 168   (setf *expose-windows-list* nil)
 169   (with-all-root-child (root)
 170     (with-all-frames (root frame)
 171       (setf (frame-layout frame) (frame-data-slot frame :old-layout)
 172             (frame-data-slot frame :old-layout) nil))))
 173
 174 (defun expose-focus-child (child)
 175   (let ((parent (typecase child
 176                   (xlib:window (find-parent-frame child))
 177                   (frame child))))
 178     (when (and child parent)
 179       (change-root (find-root parent) parent)
 180       (setf (current-child) child)
 181       (focus-all-children child parent t))))
 182
 183 (defun expose-do-main ()
 184   (stop-button-event)
 185   (expose-init)
 186   (expose-present-windows)
 187   (expose-mode-display-accel-windows)
 188   (let ((child (expose-select-child)))
 189     (expose-restore-windows)
 190     child))
 191
 192 (defun expose-windows-mode ()
 193   "Present all windows in currents roots (An expose like)"
 194   (awhen (expose-do-main)
 195     (expose-focus-child it))
 196   (show-all-children)
 197   t)
 198
 199
 200 (defun expose-all-windows-mode ()
 201   "Present all windows in all frames (An expose like)"
 202   (let ((child nil))
 203     (with-saved-root-list ()
 204       (dolist (root (get-root-list))
 205         (change-root root (root-original root)))
 206       (setf child (expose-do-main)))
 207     (when child
 208       (expose-focus-child child)))
 209   (show-all-children)
 210   t)
 211
 212
 213