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
*)
48 (xlib:font-descent
*circulate-font
*))) 2))
50 (copy-pixmap-buffer *circulate-window
* *circulate-gc
*))
54 (defun leave-circulate-mode ()
55 "Leave the circulate mode"
56 (throw 'exit-circulate-loop nil
))
60 (defun reset-circulate-child ()
61 (setf *circulate-hit
* 0
62 *circulate-parent
* nil
63 *circulate-orig
* (frame-child (current-child))))
65 (defun reset-circulate-brother ()
66 (setf *circulate-parent
* (find-parent-frame (current-child))
68 (when (frame-p *circulate-parent
*)
69 (setf *circulate-orig
* (frame-child *circulate-parent
*))))
73 (defun reorder-child (direction)
75 (with-slots (child selected-pos
) (current-child)
76 (unless *circulate-orig
*
77 (reset-circulate-child))
78 (let ((len (length *circulate-orig
*)))
80 (let ((elem (nth (mod (incf *circulate-hit
* direction
) len
) *circulate-orig
*)))
81 (setf child
(cons elem
(child-remove elem
*circulate-orig
*))
84 (draw-circulate-mode-window))))
87 (defun reorder-brother (direction)
89 (let ((old-child (current-child)))
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
*))))
100 (when (and (not (child-root-p (current-child)))
101 (child-root-p old-child
))
102 (change-root (find-root old-child
) (current-child)))))
103 (show-all-children t
)
104 (draw-circulate-mode-window)))
106 (defun reorder-subchild (direction)
107 (declare (ignore direction
))
108 (when (frame-p (current-child))
109 (let ((selected-child (frame-selected-child (current-child))))
110 (when (frame-p selected-child
)
112 (with-slots (child selected-pos
) selected-child
113 (let ((elem (first (last child
))))
115 (setf child
(cons elem
(child-remove elem child
))
118 (draw-circulate-mode-window)))))))
124 (defun circulate-select-next-child ()
125 "Select the next child"
126 (when (frame-p (current-child))
127 (when *circulate-parent
*
128 (reset-circulate-child))
131 (defun circulate-select-previous-child ()
132 "Select the previous child"
133 (when (frame-p (current-child))
134 (when *circulate-parent
*
135 (reset-circulate-child))
139 (defun circulate-select-next-brother ()
140 "Select the next brother"
141 (unless *circulate-parent
*
142 (reset-circulate-brother))
143 (reorder-brother +1))
145 (defun circulate-select-previous-brother ()
146 "Select the previous borther"
147 (unless *circulate-parent
*
148 (reset-circulate-brother))
149 (reorder-brother -
1))
151 (defun circulate-select-next-subchild ()
152 "Select the next subchild"
153 (reorder-subchild +1))
157 (add-hook *binding-hook
* 'set-default-circulate-keys
)
159 (defun set-default-circulate-keys ()
160 (define-circulate-key ("Escape") 'leave-circulate-mode
)
161 (define-circulate-key ("g" :control
) 'leave-circulate-mode
)
162 (define-circulate-key ("Escape" :alt
) 'leave-circulate-mode
)
163 (define-circulate-key ("g" :control
:alt
) 'leave-circulate-mode
)
164 (define-circulate-key ("Tab" :mod-1
) 'circulate-select-next-child
)
165 (define-circulate-key ("Tab" :mod-1
:control
) 'circulate-select-next-subchild
)
166 (define-circulate-key ("Tab" :mod-1
:shift
) 'circulate-select-previous-child
)
167 (define-circulate-key ("Iso_Left_Tab" :mod-1
:shift
) 'circulate-select-previous-child
)
168 (define-circulate-key ("Right" :mod-1
) 'circulate-select-next-brother
)
169 (define-circulate-key ("Left" :mod-1
) 'circulate-select-previous-brother
)
170 (define-circulate-release-key ("Alt_L" :alt
) 'leave-circulate-mode
)
171 (define-circulate-release-key ("Alt_L") 'leave-circulate-mode
))
174 (defun circulate-leave-function ()
176 (xlib:free-gcontext
*circulate-gc
*))
177 (when *circulate-window
*
178 (xlib:destroy-window
*circulate-window
*))
179 (when *circulate-font
*
180 (xlib:close-font
*circulate-font
*))
181 (setf *circulate-window
* nil
183 *circulate-font
* nil
)
184 (xlib:display-finish-output
*display
*))
186 (defun circulate-loop-function ()
187 (unless (is-a-key-pressed-p)
188 (leave-circulate-mode)))
190 (define-handler circulate-mode
:key-press
(code state
)
191 (unless (funcall-key-from-code *circulate-keys
* code state
)
192 (setf *circulate-hit
* 0
194 *circulate-parent
* nil
)
195 (funcall-key-from-code *main-keys
* code state
)))
198 (define-handler circulate-mode
:key-release
(code state
)
199 (funcall-key-from-code *circulate-keys-release
* code state
))
203 (defun circulate-mode (&key child-direction brother-direction subchild-direction
)
204 (setf *circulate-hit
* 0)
205 (with-placement (*circulate-mode-placement
* x y
*circulate-width
* *circulate-height
*)
206 (setf *circulate-font
* (xlib:open-font
*display
* *circulate-font-string
*)
207 *circulate-window
* (xlib:create-window
:parent
*root
*
210 :width
*circulate-width
*
211 :height
*circulate-height
*
212 :background
(get-color *circulate-background
*)
213 :border-width
*border-size
*
214 :border
(get-color *circulate-border
*)
215 :colormap
(xlib:screen-default-colormap
*screen
*)
216 :event-mask
'(:exposure
:key-press
))
217 *circulate-gc
* (xlib:create-gcontext
:drawable
*circulate-window
*
218 :foreground
(get-color *circulate-foreground
*)
219 :background
(get-color *circulate-background
*)
220 :font
*circulate-font
*
222 (setf (window-transparency *circulate-window
*) *circulate-transparency
*)
223 (map-window *circulate-window
*)
224 (draw-circulate-mode-window)
225 (when child-direction
226 (reorder-child child-direction
))
227 (when brother-direction
228 (reorder-brother brother-direction
))
229 (when subchild-direction
230 (reorder-subchild subchild-direction
))
231 (with-grab-keyboard-and-pointer (92 93 66 67 t
)
232 (generic-mode 'circulate-mode
'exit-circulate-loop
233 :loop-function
#'circulate-loop-function
234 :leave-function
#'circulate-leave-function
235 :original-mode
'(main-mode))
236 (circulate-leave-function))))
239 (defun select-next-child ()
240 "Select the next child"
241 (when (frame-p (current-child))
242 (setf *circulate-orig
* (frame-child (current-child))
243 *circulate-parent
* nil
)
244 (circulate-mode :child-direction
+1)))
246 (defun select-previous-child ()
247 "Select the previous child"
248 (when (frame-p (current-child))
249 (setf *circulate-orig
* (frame-child (current-child))
250 *circulate-parent
* nil
)
251 (circulate-mode :child-direction -
1)))
254 (defun select-next-brother ()
255 "Select the next brother"
256 (setf *circulate-parent
* (find-parent-frame (current-child)))
257 (when (frame-p *circulate-parent
*)
258 (setf *circulate-orig
* (frame-child *circulate-parent
*)))
259 (circulate-mode :brother-direction
+1))
261 (defun select-previous-brother ()
262 "Select the previous brother"
263 (setf *circulate-parent
* (find-parent-frame (current-child)))
264 (when (frame-p *circulate-parent
*)
265 (setf *circulate-orig
* (frame-child *circulate-parent
*)))
266 (circulate-mode :brother-direction -
1))
269 (defmacro with-move-current-focused-window
(() &body body
)
270 `(with-current-window
272 (move-child-to window
(if (frame-p (current-child))
274 (find-parent-frame (current-child) (find-current-root))))))
278 (defun select-next-brother-take-current ()
279 "Select the next brother and move the current focused child in it"
280 (with-move-current-focused-window ()
281 (select-next-brother)))
283 (defun select-previous-brother-take-current ()
284 "Select the previous brother and move the current focused child in it"
285 (with-move-current-focused-window ()
286 (select-previous-brother)))
290 (defun select-next-subchild ()
291 "Select the next subchild"
292 (when (and (frame-p (current-child))
293 (frame-p (frame-selected-child (current-child))))
294 (setf *circulate-orig
* (frame-child (current-child))
295 *circulate-parent
* nil
)
296 (circulate-mode :subchild-direction
+1)))
299 (defun select-next-child-simple ()
300 "Select the next child (do not enter in circulate mode)"
301 (when (frame-p (current-child))
302 (with-slots (child) (current-child)
303 (setf child
(rotate-list child
)))
304 (show-all-children)))
306 (defun select-previous-child-simple ()
307 "Select the previous child (do not enter circulate mode)"
308 (when (frame-p (current-child))
309 (with-slots (child) (current-child)
310 (setf child
(anti-rotate-list child
)))
311 (show-all-children)))
314 (defun reorder-brother-simple (reorder-fun)
315 (let ((is-root-p (child-root-p (current-child))))
318 (sleep *spatial-move-delay-before
*))
320 (select-current-frame nil
)
321 (let ((parent-frame (find-parent-frame (current-child))))
322 (when (frame-p parent-frame
)
323 (with-slots (child) parent-frame
324 (setf child
(funcall reorder-fun child
)
325 (current-child) (frame-selected-child parent-frame
))))
326 (show-all-children t
)
328 (sleep *spatial-move-delay-after
*)
332 (defun select-next-brother-simple ()
333 "Select the next brother frame (do not enter in circulate mode)"
334 (reorder-brother-simple #'rotate-list
))
336 (defun select-previous-brother-simple ()
337 "Select the previous brother frame (do not enter in circulate mode)"
338 (reorder-brother-simple #'anti-rotate-list
))
342 ;;; Spatial move functions
343 (defun select-brother-generic-spatial-move (fun-found)
344 "Select the nearest brother of the current child based on the fun-found function"
345 (let ((is-root-p (child-root-p (current-child))))
348 (sleep *spatial-move-delay-before
*))
350 (select-current-frame nil
)
351 (let ((parent-frame (find-parent-frame (current-child))))
352 (when (frame-p parent-frame
)
353 (with-slots (child selected-pos
) parent-frame
357 (let ((dist (funcall fun-found
(current-child) c
)))
359 (not (child-equal-p (current-child) c
))
361 (and found-dist
(< dist found-dist
))))
365 (setf (current-child) found
367 child
(cons found
(child-remove found child
)))))))
368 (show-all-children t
)
370 (sleep *spatial-move-delay-after
*)
375 (defun select-brother-spatial-move-right ()
376 "Select spatially the nearest brother of the current child in the right direction"
377 (select-brother-generic-spatial-move #'(lambda (current child
)
378 (when (> (child-x2 child
) (child-x2 current
))
379 (distance (child-x2 current
) (middle-child-y current
)
380 (child-x child
) (middle-child-y child
))))))
384 (defun select-brother-spatial-move-left ()
385 "Select spatially the nearest brother of the current child in the left direction"
386 (select-brother-generic-spatial-move #'(lambda (current child
)
387 (when (< (child-x child
) (child-x current
))
388 (distance (child-x current
) (middle-child-y current
)
389 (child-x2 child
) (middle-child-y child
))))))
392 (defun select-brother-spatial-move-down ()
393 "Select spatially the nearest brother of the current child in the down direction"
394 (select-brother-generic-spatial-move #'(lambda (current child
)
395 (when (> (child-y2 child
) (child-y2 current
))
396 (distance (middle-child-x current
) (child-y2 current
)
397 (middle-child-x child
) (child-y child
))))))
400 (defun select-brother-spatial-move-up ()
401 "Select spatially the nearest brother of the current child in the up direction"
402 (select-brother-generic-spatial-move #'(lambda (current child
)
403 (when (< (child-y child
) (child-y current
))
404 (distance (middle-child-x current
) (child-y current
)
405 (middle-child-x child
) (child-y2 child
))))))
408 (defun select-brother-spatial-move-right-take-current ()
409 "Select spatially the nearest brother of the current child in the right direction - move current focused child"
410 (with-move-current-focused-window ()
411 (select-brother-spatial-move-right)))
414 (defun select-brother-spatial-move-left-take-current ()
415 "Select spatially the nearest brother of the current child in the left direction - move current focused child"
416 (with-move-current-focused-window ()
417 (select-brother-spatial-move-left)))
419 (defun select-brother-spatial-move-down-take-current ()
420 "Select spatially the nearest brother of the current child in the down direction - move current focused child"
421 (with-move-current-focused-window ()
422 (select-brother-spatial-move-down)))
424 (defun select-brother-spatial-move-up-take-current ()
425 "Select spatially the nearest brother of the current child in the up direction - move current focused child"
426 (with-move-current-focused-window ()
427 (select-brother-spatial-move-up)))