1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Main functions
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2005-2013 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 *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 ((old-child (current-child)))
89 (select-current-frame nil
)
90 (unless (and *circulate-orig
* *circulate-parent
*)
91 (reset-circulate-brother))
92 (let ((len (length *circulate-orig
*)))
94 (when (frame-p *circulate-parent
*)
95 (let ((elem (nth (mod (incf *circulate-hit
* direction
) len
) *circulate-orig
*)))
96 (setf (frame-child *circulate-parent
*) (cons elem
(child-remove elem
*circulate-orig
*))
97 (frame-selected-pos *circulate-parent
*) 0
98 (current-child) (frame-selected-child *circulate-parent
*))))
99 (when (and (not (child-root-p (current-child)))
100 (child-root-p old-child
))
101 (change-root (find-root old-child
) (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 (setf *circulate-window
* nil
182 *circulate-font
* nil
)
183 (xlib:display-finish-output
*display
*))
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 (setf (window-transparency *circulate-window
*) *circulate-transparency
*)
222 (map-window *circulate-window
*)
223 (draw-circulate-mode-window)
224 (when child-direction
225 (reorder-child child-direction
))
226 (when brother-direction
227 (reorder-brother brother-direction
))
228 (when subchild-direction
229 (reorder-subchild subchild-direction
))
230 (with-grab-keyboard-and-pointer (92 93 66 67 t
)
231 (generic-mode 'circulate-mode
'exit-circulate-loop
232 :loop-function
#'circulate-loop-function
233 :leave-function
#'circulate-leave-function
234 :original-mode
'(main-mode))
235 (circulate-leave-function))))
238 (defun select-next-child ()
239 "Select the next child"
240 (when (frame-p (current-child))
241 (setf *circulate-orig
* (frame-child (current-child))
242 *circulate-parent
* nil
)
243 (circulate-mode :child-direction
+1)))
245 (defun select-previous-child ()
246 "Select the previous child"
247 (when (frame-p (current-child))
248 (setf *circulate-orig
* (frame-child (current-child))
249 *circulate-parent
* nil
)
250 (circulate-mode :child-direction -
1)))
253 (defun select-next-brother ()
254 "Select the next brother"
255 (setf *circulate-parent
* (find-parent-frame (current-child)))
256 (when (frame-p *circulate-parent
*)
257 (setf *circulate-orig
* (frame-child *circulate-parent
*)))
258 (circulate-mode :brother-direction
+1))
260 (defun select-previous-brother ()
261 "Select the previous brother"
262 (setf *circulate-parent
* (find-parent-frame (current-child)))
263 (when (frame-p *circulate-parent
*)
264 (setf *circulate-orig
* (frame-child *circulate-parent
*)))
265 (circulate-mode :brother-direction -
1))
268 (defmacro with-move-current-focused-window
(() &body body
)
269 `(with-current-window
271 (move-child-to window
(if (frame-p (current-child))
273 (find-parent-frame (current-child) (find-current-root))))))
277 (defun select-next-brother-take-current ()
278 "Select the next brother and move the current focused child in it"
279 (with-move-current-focused-window ()
280 (select-next-brother)))
282 (defun select-previous-brother-take-current ()
283 "Select the previous brother and move the current focused child in it"
284 (with-move-current-focused-window ()
285 (select-previous-brother)))
289 (defun select-next-subchild ()
290 "Select the next subchild"
291 (when (and (frame-p (current-child))
292 (frame-p (frame-selected-child (current-child))))
293 (setf *circulate-orig
* (frame-child (current-child))
294 *circulate-parent
* nil
)
295 (circulate-mode :subchild-direction
+1)))
298 (defun select-next-child-simple ()
299 "Select the next child (do not enter in circulate mode)"
300 (when (frame-p (current-child))
301 (with-slots (child) (current-child)
302 (setf child
(rotate-list child
)))
303 (show-all-children)))
305 (defun select-previous-child-simple ()
306 "Select the previous child (do not enter circulate mode)"
307 (when (frame-p (current-child))
308 (with-slots (child) (current-child)
309 (setf child
(anti-rotate-list child
)))
310 (show-all-children)))
313 (defun reorder-brother-simple (reorder-fun)
314 (unless (child-root-p (current-child))
316 (select-current-frame nil
)
317 (let ((parent-frame (find-parent-frame (current-child))))
318 (when (frame-p parent-frame
)
319 (with-slots (child) parent-frame
320 (setf child
(funcall reorder-fun child
)
321 (current-child) (frame-selected-child parent-frame
))))
322 (show-all-children t
))))
325 (defun select-next-brother-simple ()
326 "Select the next brother frame (do not enter in circulate mode)"
327 (reorder-brother-simple #'rotate-list
))
329 (defun select-previous-brother-simple ()
330 "Select the previous brother frame (do not enter in circulate mode)"
331 (reorder-brother-simple #'anti-rotate-list
))
335 ;;; Spatial move functions
336 (defun select-brother-generic-spatial-move (fun-found)
337 "Select the nearest brother of the current child based on the fun-found function"
338 (let ((is-root-p (child-root-p (current-child))))
341 (sleep *spatial-move-delay-before
*))
343 (select-current-frame nil
)
344 (let ((parent-frame (find-parent-frame (current-child))))
345 (when (frame-p parent-frame
)
346 (with-slots (child selected-pos
) parent-frame
350 (let ((dist (funcall fun-found
(current-child) c
)))
352 (not (child-equal-p (current-child) c
))
354 (and found-dist
(< dist found-dist
))))
358 (setf (current-child) found
360 child
(cons found
(child-remove found child
)))))))
361 (show-all-children t
)
363 (sleep *spatial-move-delay-after
*)
368 (defun select-brother-spatial-move-right ()
369 "Select spatially the nearest brother of the current child in the right direction"
370 (select-brother-generic-spatial-move #'(lambda (current child
)
371 (when (> (child-x2 child
) (child-x2 current
))
372 (distance (child-x2 current
) (middle-child-y current
)
373 (child-x child
) (middle-child-y child
))))))
377 (defun select-brother-spatial-move-left ()
378 "Select spatially the nearest brother of the current child in the left direction"
379 (select-brother-generic-spatial-move #'(lambda (current child
)
380 (when (< (child-x child
) (child-x current
))
381 (distance (child-x current
) (middle-child-y current
)
382 (child-x2 child
) (middle-child-y child
))))))
385 (defun select-brother-spatial-move-down ()
386 "Select spatially the nearest brother of the current child in the down direction"
387 (select-brother-generic-spatial-move #'(lambda (current child
)
388 (when (> (child-y2 child
) (child-y2 current
))
389 (distance (middle-child-x current
) (child-y2 current
)
390 (middle-child-x child
) (child-y child
))))))
393 (defun select-brother-spatial-move-up ()
394 "Select spatially the nearest brother of the current child in the up direction"
395 (select-brother-generic-spatial-move #'(lambda (current child
)
396 (when (< (child-y child
) (child-y current
))
397 (distance (middle-child-x current
) (child-y current
)
398 (middle-child-x child
) (child-y2 child
))))))
401 (defun select-brother-spatial-move-right-take-current ()
402 "Select spatially the nearest brother of the current child in the right direction - move current focused child"
403 (with-move-current-focused-window ()
404 (select-brother-spatial-move-right)))
407 (defun select-brother-spatial-move-left-take-current ()
408 "Select spatially the nearest brother of the current child in the left direction - move current focused child"
409 (with-move-current-focused-window ()
410 (select-brother-spatial-move-left)))
412 (defun select-brother-spatial-move-down-take-current ()
413 "Select spatially the nearest brother of the current child in the down direction - move current focused child"
414 (with-move-current-focused-window ()
415 (select-brother-spatial-move-down)))
417 (defun select-brother-spatial-move-up-take-current ()
418 "Select spatially the nearest brother of the current child in the up direction - move current focused child"
419 (with-move-current-focused-window ()
420 (select-brother-spatial-move-up)))