1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Expose functions - An expose like.
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2012 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-windows-list
* nil
)
30 (defparameter *expose-selected-child
* nil
)
32 (defun leave-expose-mode ()
33 "Leave the expose mode"
34 (throw 'exit-expose-loop nil
))
36 (defun valid-expose-mode ()
37 "Valid the expose mode"
38 (throw 'exit-expose-loop t
))
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
))
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
))
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
*))
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)
70 (copy-pixmap-buffer window gc
))))
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
))
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
*
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
*)
97 (setf (window-transparency window
) *expose-transparency
*)
99 (push (list window gc string child
(number->letter n
)) *expose-windows-list
*))))))
104 (defun expose-query-key-press-hook (code state
)
105 (declare (ignore code state
))
107 (when (and *expose-direct-select
* (<= (length *expose-windows-list
*) 26))
108 (leave-query-mode :return
)))
110 (defun expose-query-button-press-hook (code state x y
)
111 (declare (ignore state
))
113 (setf *expose-selected-child
* (find-child-under-mouse x y
)))
114 (leave-query-mode :click
))
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
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
))
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
))
134 (defun expose-mode-display-accel-windows ()
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)))
145 (defun expose-find-child-from-letters (letters)
146 (fourth (find letters
*expose-windows-list
* :test
#'string-equal
:key
#'fifth
)))
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
)
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
*)
163 (xlib:destroy-window it
))
165 (xlib:free-gcontext it
)))
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
))))
174 (defun expose-focus-child (child)
175 (let ((parent (typecase child
176 (xlib:window
(find-parent-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
))))
183 (defun expose-do-main ()
186 (expose-present-windows)
187 (expose-mode-display-accel-windows)
188 (let ((child (expose-select-child)))
189 (expose-restore-windows)
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
))
200 (defun expose-all-windows-mode ()
201 "Present all windows in all frames (An expose like)"
203 (with-saved-root-list ()
204 (dolist (root (get-root-list))
205 (change-root root
(root-original root
)))
206 (setf child
(expose-do-main)))
208 (expose-focus-child child
)))