1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Expose functions - An expose like.
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2005-2015 Philippe Brochard <pbrochard@common-lisp.net>
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.
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.
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.
24 ;;; --------------------------------------------------------------------------
28 (defparameter *expose-font
* nil
)
29 (defparameter *expose-selected-child
* nil
)
31 (defstruct expose-child number child key window gc string
)
33 (defun leave-expose-mode ()
34 "Leave the expose mode"
35 (throw 'exit-expose-loop nil
))
37 (defun valid-expose-mode ()
38 "Valid the expose mode"
39 (throw 'exit-expose-loop t
))
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
))
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
))
52 (defun expose-associate-keys ()
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
*)
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
)
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
)))
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
)))))
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
))
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
*
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
*)
120 :line-style
:solid
)))
121 (setf (window-transparency window
) *expose-transparency
*)
123 (setf (expose-child-window ex-child
) window
124 (expose-child-gc ex-child
) gc
125 (expose-child-string ex-child
) string
)))))))
130 (defun expose-query-key-press-hook (code state
)
131 (declare (ignore code state
))
133 (let ((two-letters-key (dolist (child *expose-child-list
*)
134 (when (> (length (expose-child-key child
)) 1)
136 (when (and *expose-direct-select
* (not two-letters-key
))
137 (leave-query-mode :return
))))
139 (defun expose-query-button-press-hook (code state x y
)
140 (declare (ignore state
))
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
))
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
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
))
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
))
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
)))))
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
)))
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)))
187 (defun expose-find-child-from-letters (letters)
188 (find letters
*expose-child-list
* :test
#'string-equal
:key
#'expose-child-key
))
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
*))))
198 (expose-child-child ex-child
))))))
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
))
212 (xlib:close-font
*expose-font
*))
214 (expose-unpresent-windows)))
216 (defun expose-focus-child (child)
217 (let ((parent (typecase child
218 (xlib:window
(find-parent-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
))))
225 (defun expose-do-main (&optional
(present-window t
))
229 (expose-present-windows))
230 (expose-mode-display-accel-windows)
231 (let ((child (expose-select-child)))
232 (expose-restore-windows present-window
)
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
))
244 (defun expose-all-windows-mode ()
245 "Present all windows in all frames (An expose like)"
247 (with-saved-root-list ()
248 (dolist (root (get-root-list))
249 (change-root root
(root-original root
)))
250 (setf child
(expose-do-main)))
252 (expose-focus-child child
)))
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
)))