1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Main functions
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2011 Philippe Brochard <hocwp@free.fr>
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 *circulate-window
* nil
)
29 (defparameter *circulate-font
* nil
)
30 (defparameter *circulate-gc
* nil
)
32 (defparameter *circulate-hit
* 0)
33 (defparameter *circulate-orig
* nil
)
34 (defparameter *circulate-parent
* nil
)
36 (defun draw-circulate-mode-window ()
37 (raise-window *circulate-window
*)
38 (clear-pixmap-buffer *circulate-window
* *circulate-gc
*)
39 (let* ((text (format nil
"~A [~A]"
40 (limit-length (ensure-printable (child-name (xlib:input-focus
*display
*)))
41 *circulate-text-limite
*)
42 (limit-length (ensure-printable (child-name *current-child
*))
43 *circulate-text-limite
*)))
45 (xlib:draw-glyphs
*pixmap-buffer
* *circulate-gc
*
46 (truncate (/ (- *circulate-width
* (* (xlib:max-char-width
*circulate-font
*) len
)) 2))
47 (truncate (/ (+ *circulate-height
* (- (xlib:font-ascent
*circulate-font
*) (xlib:font-descent
*circulate-font
*))) 2))
49 (copy-pixmap-buffer *circulate-window
* *circulate-gc
*))
53 (defun leave-circulate-mode ()
54 "Leave the circulate mode"
55 (throw 'exit-circulate-loop nil
))
59 (defun reset-circulate-child ()
60 (setf *circulate-hit
* 0
61 *circulate-parent
* nil
62 *circulate-orig
* (frame-child *current-child
*)))
64 (defun reset-circulate-brother ()
65 (setf *circulate-parent
* (find-parent-frame *current-child
*)
67 (when (frame-p *circulate-parent
*)
68 (setf *circulate-orig
* (frame-child *circulate-parent
*))))
72 (defun reorder-child (direction)
74 (with-slots (child selected-pos
) *current-child
*
75 (unless *circulate-orig
*
76 (reset-circulate-child))
77 (let ((len (length *circulate-orig
*)))
79 (let ((elem (nth (mod (incf *circulate-hit
* direction
) len
) *circulate-orig
*)))
80 (setf child
(cons elem
(child-remove elem
*circulate-orig
*))
83 (draw-circulate-mode-window))))
86 (defun reorder-brother (direction)
88 (let ((frame-is-root?
(and (child-equal-p *current-root
* *current-child
*)
89 (not (child-equal-p *current-root
* *root-frame
*)))))
90 (select-current-frame nil
)
91 (unless (and *circulate-orig
* *circulate-parent
*)
92 (reset-circulate-brother))
93 (let ((len (length *circulate-orig
*)))
95 (when (frame-p *circulate-parent
*)
96 (let ((elem (nth (mod (incf *circulate-hit
* direction
) len
) *circulate-orig
*)))
97 (setf (frame-child *circulate-parent
*) (cons elem
(child-remove elem
*circulate-orig
*))
98 (frame-selected-pos *circulate-parent
*) 0
99 *current-child
* (frame-selected-child *circulate-parent
*))))
101 (setf *current-root
* *current-child
*))))
102 (show-all-children t
)
103 (draw-circulate-mode-window)))
105 (defun reorder-subchild (direction)
106 (declare (ignore direction
))
107 (when (frame-p *current-child
*)
108 (let ((selected-child (frame-selected-child *current-child
*)))
109 (when (frame-p selected-child
)
111 (with-slots (child selected-pos
) selected-child
112 (let ((elem (first (last child
))))
114 (setf child
(cons elem
(child-remove elem child
))
117 (draw-circulate-mode-window)))))))
123 (defun circulate-select-next-child ()
124 "Select the next child"
125 (when (frame-p *current-child
*)
126 (when *circulate-parent
*
127 (reset-circulate-child))
130 (defun circulate-select-previous-child ()
131 "Select the previous child"
132 (when (frame-p *current-child
*)
133 (when *circulate-parent
*
134 (reset-circulate-child))
138 (defun circulate-select-next-brother ()
139 "Select the next brother"
140 (unless *circulate-parent
*
141 (reset-circulate-brother))
142 (reorder-brother +1))
144 (defun circulate-select-previous-brother ()
145 "Select the previous borther"
146 (unless *circulate-parent
*
147 (reset-circulate-brother))
148 (reorder-brother -
1))
150 (defun circulate-select-next-subchild ()
151 "Select the next subchild"
152 (reorder-subchild +1))
156 (add-hook *binding-hook
* 'set-default-circulate-keys
)
158 (defun set-default-circulate-keys ()
159 (define-circulate-key ("Escape") 'leave-circulate-mode
)
160 (define-circulate-key ("g" :control
) 'leave-circulate-mode
)
161 (define-circulate-key ("Escape" :alt
) 'leave-circulate-mode
)
162 (define-circulate-key ("g" :control
:alt
) 'leave-circulate-mode
)
163 (define-circulate-key ("Tab" :mod-1
) 'circulate-select-next-child
)
164 (define-circulate-key ("Tab" :mod-1
:control
) 'circulate-select-next-subchild
)
165 (define-circulate-key ("Tab" :mod-1
:shift
) 'circulate-select-previous-child
)
166 (define-circulate-key ("Iso_Left_Tab" :mod-1
:shift
) 'circulate-select-previous-child
)
167 (define-circulate-key ("Right" :mod-1
) 'circulate-select-next-brother
)
168 (define-circulate-key ("Left" :mod-1
) 'circulate-select-previous-brother
)
169 (define-circulate-release-key ("Alt_L" :alt
) 'leave-circulate-mode
)
170 (define-circulate-release-key ("Alt_L") 'leave-circulate-mode
))
173 (defun circulate-leave-function ()
175 (xlib:free-gcontext
*circulate-gc
*))
176 (when *circulate-window
*
177 (xlib:destroy-window
*circulate-window
*))
178 (when *circulate-font
*
179 (xlib:close-font
*circulate-font
*))
180 (xlib:display-finish-output
*display
*)
181 (setf *circulate-window
* nil
183 *circulate-font
* nil
))
185 (defun circulate-loop-function ()
186 (unless (is-a-key-pressed-p)
187 (leave-circulate-mode)))
189 (define-handler circulate-mode
:key-press
(code state
)
190 (unless (funcall-key-from-code *circulate-keys
* code state
)
191 (setf *circulate-hit
* 0
193 *circulate-parent
* nil
)
194 (funcall-key-from-code *main-keys
* code state
)))
197 (define-handler circulate-mode
:key-release
(code state
)
198 (funcall-key-from-code *circulate-keys-release
* code state
))
202 (defun circulate-mode (&key child-direction brother-direction subchild-direction
)
203 (setf *circulate-hit
* 0)
204 (with-placement (*circulate-mode-placement
* x y
*circulate-width
* *circulate-height
*)
205 (setf *circulate-font
* (xlib:open-font
*display
* *circulate-font-string
*)
206 *circulate-window
* (xlib:create-window
:parent
*root
*
209 :width
*circulate-width
*
210 :height
*circulate-height
*
211 :background
(get-color *circulate-background
*)
212 :border-width
*border-size
*
213 :border
(get-color *circulate-border
*)
214 :colormap
(xlib:screen-default-colormap
*screen
*)
215 :event-mask
'(:exposure
:key-press
))
216 *circulate-gc
* (xlib:create-gcontext
:drawable
*circulate-window
*
217 :foreground
(get-color *circulate-foreground
*)
218 :background
(get-color *circulate-background
*)
219 :font
*circulate-font
*
221 (map-window *circulate-window
*)
222 (draw-circulate-mode-window)
223 (when child-direction
224 (reorder-child child-direction
))
225 (when brother-direction
226 (reorder-brother brother-direction
))
227 (when subchild-direction
228 (reorder-subchild subchild-direction
))
229 (let ((grab-keyboard-p (xgrab-keyboard-p))
230 (grab-pointer-p (xgrab-pointer-p)))
231 (xgrab-pointer *root
* 92 93)
232 (unless grab-keyboard-p
234 (xgrab-keyboard *root
*))
235 (generic-mode 'circulate-mode
'exit-circulate-loop
236 :loop-function
#'circulate-loop-function
237 :leave-function
#'circulate-leave-function
238 :original-mode
'(main-mode))
239 (circulate-leave-function)
240 (unless grab-keyboard-p
244 (xgrab-pointer *root
* 66 67)
245 (xungrab-pointer)))))
248 (defun select-next-child ()
249 "Select the next child"
250 (when (frame-p *current-child
*)
251 (setf *circulate-orig
* (frame-child *current-child
*)
252 *circulate-parent
* nil
)
253 (circulate-mode :child-direction
+1)))
255 (defun select-previous-child ()
256 "Select the previous child"
257 (when (frame-p *current-child
*)
258 (setf *circulate-orig
* (frame-child *current-child
*)
259 *circulate-parent
* nil
)
260 (circulate-mode :child-direction -
1)))
263 (defun select-next-brother ()
264 "Select the next brother"
265 (setf *circulate-parent
* (find-parent-frame *current-child
*))
266 (when (frame-p *circulate-parent
*)
267 (setf *circulate-orig
* (frame-child *circulate-parent
*)))
268 (circulate-mode :brother-direction
+1))
270 (defun select-previous-brother ()
271 "Select the previous brother"
272 (setf *circulate-parent
* (find-parent-frame *current-child
*))
273 (when (frame-p *circulate-parent
*)
274 (setf *circulate-orig
* (frame-child *circulate-parent
*)))
275 (circulate-mode :brother-direction -
1))
277 (defun select-next-subchild ()
278 "Select the next subchild"
279 (when (and (frame-p *current-child
*)
280 (frame-p (frame-selected-child *current-child
*)))
281 (setf *circulate-orig
* (frame-child *current-child
*)
282 *circulate-parent
* nil
)
283 (circulate-mode :subchild-direction
+1)))
286 (defun select-next-child-simple ()
287 "Select the next child (do not enter in circulate mode)"
288 (when (frame-p *current-child
*)
289 (with-slots (child) *current-child
*
290 (setf child
(rotate-list child
)))
291 (show-all-children)))
295 (defun reorder-brother-simple (reorder-fun)
296 (unless (child-equal-p *current-child
* *current-root
*)
298 (select-current-frame nil
)
299 (let ((parent-frame (find-parent-frame *current-child
*)))
300 (when (frame-p parent-frame
)
301 (with-slots (child) parent-frame
302 (setf child
(funcall reorder-fun child
)
303 *current-child
* (frame-selected-child parent-frame
))))
304 (show-all-children t
))))
307 (defun select-next-brother-simple ()
308 "Select the next brother frame (do not enter in circulate mode)"
309 (reorder-brother-simple #'rotate-list
))
311 (defun select-previous-brother-simple ()
312 "Select the previous brother frame (do not enter in circulate mode)"
313 (reorder-brother-simple #'anti-rotate-list
))
317 ;;; Spatial move functions
318 (defun select-brother-generic-spatial-move (fun-found)
319 "Select the nearest brother of the current child based on the fun-found function"
320 (let ((is-root?
(child-equal-p *current-child
* *current-root
*)))
323 (sleep *spatial-move-delay-before
*))
325 (select-current-frame nil
)
326 (let ((parent-frame (find-parent-frame *current-child
*)))
327 (when (frame-p parent-frame
)
328 (with-slots (child selected-pos
) parent-frame
332 (let ((dist (funcall fun-found
*current-child
* c
)))
334 (not (child-equal-p *current-child
* c
))
336 (and found-dist
(< dist found-dist
))))
340 (setf *current-child
* found
342 child
(cons found
(child-remove found child
)))))))
343 (show-all-children t
)
345 (sleep *spatial-move-delay-after
*)
350 (defun select-brother-spatial-move-right ()
351 "Select spatially the nearest brother of the current child in the right direction"
352 (select-brother-generic-spatial-move #'(lambda (current child
)
353 (when (> (child-x2 child
) (child-x2 current
))
354 (distance (child-x2 current
) (middle-child-y current
)
355 (child-x child
) (middle-child-y child
))))))
359 (defun select-brother-spatial-move-left ()
360 "Select spatially the nearest brother of the current child in the left direction"
361 (select-brother-generic-spatial-move #'(lambda (current child
)
362 (when (< (child-x child
) (child-x current
))
363 (distance (child-x current
) (middle-child-y current
)
364 (child-x2 child
) (middle-child-y child
))))))
367 (defun select-brother-spatial-move-down ()
368 "Select spatially the nearest brother of the current child in the down direction"
369 (select-brother-generic-spatial-move #'(lambda (current child
)
370 (when (> (child-y2 child
) (child-y2 current
))
371 (distance (middle-child-x current
) (child-y2 current
)
372 (middle-child-x child
) (child-y child
))))))
375 (defun select-brother-spatial-move-up ()
376 "Select spatially the nearest brother of the current child in the up direction"
377 (select-brother-generic-spatial-move #'(lambda (current child
)
378 (when (< (child-y child
) (child-y current
))
379 (distance (middle-child-x current
) (child-y current
)
380 (middle-child-x child
) (child-y2 child
))))))