1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Main functions
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2010 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 ;;; --------------------------------------------------------------------------
30 ;;; Conversion functions
31 ;;; Float -> Pixel conversion
32 (defun x-fl->px
(x parent
)
33 "Convert float X coordinate to pixel"
34 (round (+ (* x
(frame-rw parent
)) (frame-rx parent
))))
36 (defun y-fl->px
(y parent
)
37 "Convert float Y coordinate to pixel"
38 (round (+ (* y
(frame-rh parent
)) (frame-ry parent
))))
40 (defun w-fl->px
(w parent
)
41 "Convert float Width coordinate to pixel"
42 (round (* w
(frame-rw parent
))))
44 (defun h-fl->px
(h parent
)
45 "Convert float Height coordinate to pixel"
46 (round (* h
(frame-rh parent
))))
48 ;;; Pixel -> Float conversion
49 (defun x-px->fl
(x parent
)
50 "Convert pixel X coordinate to float"
51 (/ (- x
(frame-rx parent
)) (frame-rw parent
)))
53 (defun y-px->fl
(y parent
)
54 "Convert pixel Y coordinate to float"
55 (/ (- y
(frame-ry parent
)) (frame-rh parent
)))
57 (defun w-px->fl
(w parent
)
58 "Convert pixel Width coordinate to float"
59 (/ w
(frame-rw parent
)))
61 (defun h-px->fl
(h parent
)
62 "Convert pixel Height coordinate to float"
63 (/ h
(frame-rh parent
)))
67 (defgeneric frame-p
(frame))
68 (defmethod frame-p ((frame frame
))
69 (declare (ignore frame
))
71 (defmethod frame-p (frame)
72 (declare (ignore frame
))
77 ;;; in-*: Find if point (x,y) is in frame, window or child
78 (defun in-frame (frame x y
)
80 (<= (frame-rx frame
) x
(+ (frame-rx frame
) (frame-rw frame
)))
81 (<= (frame-ry frame
) y
(+ (frame-ry frame
) (frame-rh frame
)))))
83 (defun in-window (window x y
)
84 (and (xlib:window-p window
)
85 (<= (xlib:drawable-x window
) x
(+ (xlib:drawable-x window
) (xlib:drawable-width window
)))
86 (<= (xlib:drawable-y window
) y
(+ (xlib:drawable-y window
) (xlib:drawable-height window
)))))
88 (defgeneric in-child
(child x y
))
90 (defmethod in-child ((child frame
) x y
)
92 (defmethod in-child ((child xlib
:window
) x y
)
93 (in-window child x y
))
94 (defmethod in-child (child x y
)
95 (declare (ignore child x y
))
101 (defun frame-selected-child (frame)
102 (when (frame-p frame
)
103 (with-slots (child selected-pos
) frame
104 (let ((len (length child
)))
105 (cond ((minusp selected-pos
) (setf selected-pos
0))
106 ((>= selected-pos len
) (setf selected-pos
(max (1- len
) 0)))))
107 (nth selected-pos child
))))
113 (defgeneric child-equal-p
(child-1 child-2
))
115 (defmethod child-equal-p ((child-1 xlib
:window
) (child-2 xlib
:window
))
116 (xlib:window-equal child-1 child-2
))
118 (defmethod child-equal-p ((child-1 frame
) (child-2 frame
))
119 (equal child-1 child-2
))
121 (defmethod child-equal-p (child-1 child-2
)
122 (declare (ignore child-1 child-2
))
126 (declaim (inline child-member child-remove child-position
))
128 (defun child-member (child list
)
129 (member child list
:test
#'child-equal-p
))
131 (defun child-remove (child list
)
132 (remove child list
:test
#'child-equal-p
))
134 (defun child-position (child list
)
135 (position child list
:test
#'child-equal-p
))
139 ;;; Frame data manipulation functions
140 (defun frame-data-slot (frame slot
)
141 "Return the value associated to data slot"
142 (when (frame-p frame
)
143 (second (assoc slot
(frame-data frame
)))))
145 (defun set-frame-data-slot (frame slot value
)
146 "Set the value associated to data slot"
147 (when (frame-p frame
)
148 (with-slots (data) frame
149 (setf data
(remove (assoc slot data
) data
))
150 (push (list slot value
) data
))
153 (defsetf frame-data-slot set-frame-data-slot
)
156 (defun remove-frame-data-slot (frame slot
)
157 "Remove a slot in frame data slots"
158 (when (frame-p frame
)
159 (with-slots (data) frame
160 (setf data
(remove (assoc slot data
) data
)))))
164 (defun managed-window-p (window frame
)
165 "Return t only if window is managed by frame"
167 (with-slots ((managed forced-managed-window
)
168 (unmanaged forced-unmanaged-window
)) frame
169 (and (xlib:window-p window
)
170 (not (child-member window unmanaged
))
171 (not (member (xlib:wm-name window
) unmanaged
:test
#'string-equal-p
))
172 (or (member :all
(frame-managed-type frame
))
173 (member (window-type window
) (frame-managed-type frame
))
174 (child-member window managed
)
175 (member (xlib:wm-name window
) managed
:test
#'string-equal-p
))))
179 (defun never-managed-window-p (window)
180 (when (xlib:window-p window
)
181 (dolist (type *never-managed-window-list
*)
182 (when (funcall (first type
) window
)
183 (return (values t
(second type
)))))))
187 (defgeneric child-name
(child))
189 (defmethod child-name ((child xlib
:window
))
190 (xlib:wm-name child
))
192 (defmethod child-name ((child frame
))
195 (defmethod child-name (child)
196 (declare (ignore child
))
200 (defgeneric set-child-name
(child name
))
202 (defmethod set-child-name ((child xlib
:window
) name
)
203 (setf (xlib:wm-name child
) name
))
205 (defmethod set-child-name ((child frame
) name
)
206 (setf (frame-name child
) name
))
208 (defmethod set-child-name (child name
)
209 (declare (ignore child name
)))
211 (defsetf child-name set-child-name
)
216 (defgeneric child-fullname
(child))
218 (defmethod child-fullname ((child xlib
:window
))
219 (format nil
"~A (~A)" (or (xlib:wm-name child
) "?") (or (xlib:get-wm-class child
) "?")))
221 (defmethod child-fullname ((child frame
))
222 (aif (frame-name child
)
223 (format nil
"~A (Frame ~A)" it
(frame-number child
))
224 (format nil
"Frame ~A" (frame-number child
))))
226 (defmethod child-fullname (child)
227 (declare (ignore child
))
231 (defgeneric child-x
(child))
232 (defmethod child-x ((child xlib
:window
))
233 (xlib:drawable-x child
))
234 (defmethod child-x ((child frame
))
237 (defgeneric child-y
(child))
238 (defmethod child-y ((child xlib
:window
))
239 (xlib:drawable-y child
))
240 (defmethod child-y ((child frame
))
243 (defgeneric child-width
(child))
244 (defmethod child-width ((child xlib
:window
))
245 (xlib:drawable-width child
))
246 (defmethod child-width ((child frame
))
249 (defgeneric child-height
(child))
250 (defmethod child-height ((child xlib
:window
))
251 (xlib:drawable-height child
))
252 (defmethod child-height ((child frame
))
259 (defgeneric rename-child
(child name
))
261 (defmethod rename-child ((child frame
) name
)
262 (setf (frame-name child
) name
)
263 (display-frame-info child
))
265 (defmethod rename-child ((child xlib
:window
) name
)
266 (setf (xlib:wm-name child
) name
))
268 (defmethod rename-child (child name
)
269 (declare (ignore child name
)))
272 (defun is-in-current-child-p (child)
273 (and (frame-p *current-child
*)
274 (child-member child
(frame-child *current-child
*))))
278 ;; (with-all-children (*root-frame* child) (typecase child (xlib:window (print child)) (frame (print (frame-number child)))))
279 (defmacro with-all-children
((root child
) &body body
)
281 (sub-child (gensym)))
283 (labels ((,rec
(,child
)
285 (when (frame-p ,child
)
286 (dolist (,sub-child
(reverse (frame-child ,child
)))
287 (,rec
,sub-child
)))))
291 ;; (with-all-children (*root-frame* child) (typecase child (xlib:window (print child)) (frame (print (frame-number child)))))
292 (defmacro with-all-children-reversed
((root child
) &body body
)
294 (sub-child (gensym)))
296 (labels ((,rec
(,child
)
298 (when (frame-p ,child
)
299 (dolist (,sub-child
(frame-child ,child
))
300 (,rec
,sub-child
)))))
304 ;; (with-all-frames (*root-frame* frame) (print (frame-number frame)))
305 (defmacro with-all-frames
((root frame
) &body body
)
309 (labels ((,rec
(,frame
)
310 (when (frame-p ,frame
)
312 (dolist (,child
(reverse (frame-child ,frame
)))
317 ;; (with-all-windows (*root-frame* window) (print window))
318 (defmacro with-all-windows
((root window
) &body body
)
322 (labels ((,rec
(,window
)
323 (when (xlib:window-p
,window
)
325 (when (frame-p ,window
)
326 (dolist (,child
(reverse (frame-child ,window
)))
332 ;; (with-all-frames-windows (*root-frame* child) (print child) (print (frame-number child)))
333 (defmacro with-all-windows-frames
((root child
) body-window body-frame
)
335 (sub-child (gensym)))
337 (labels ((,rec
(,child
)
339 (xlib:window
,body-window
)
341 (dolist (,sub-child
(reverse (frame-child ,child
)))
342 (,rec
,sub-child
))))))
345 (defmacro with-all-windows-frames-and-parent
((root child parent
) body-window body-frame
)
347 (sub-child (gensym)))
349 (labels ((,rec
(,child
,parent
)
351 (xlib:window
,body-window
)
353 (dolist (,sub-child
(reverse (frame-child ,child
)))
354 (,rec
,sub-child
,child
))))))
359 (defun frame-find-free-number ()
360 (let ((all-numbers nil
))
361 (with-all-frames (*root-frame
* frame
)
362 (pushnew (frame-number frame
) all-numbers
))
363 (find-free-number all-numbers
)))
366 (defun create-frame (&rest args
&key
(number (frame-find-free-number)) &allow-other-keys
)
367 (let* ((window (xlib:create-window
:parent
*root
*
372 :background
(get-color *frame-background
*)
373 :colormap
(xlib:screen-default-colormap
*screen
*)
375 :border
(get-color *color-selected
*)
376 :event-mask
'(:exposure
:button-press
:button-release
:pointer-motion
:enter-window
)))
377 (gc (xlib:create-gcontext
:drawable window
378 :foreground
(get-color *frame-foreground
*)
379 :background
(get-color *frame-background
*)
381 :line-style
:solid
)))
382 (apply #'make-instance
'frame
:number number
:window window
:gc gc args
)))
388 (defun add-frame (frame parent
)
389 (push frame
(frame-child parent
))
393 (defun place-frame (frame parent prx pry prw prh
)
394 "Place a frame from real (pixel) coordinates"
395 (when (and (frame-p frame
) (frame-p parent
))
396 (with-slots (window x y w h
) frame
397 (setf (xlib:drawable-x window
) prx
398 (xlib:drawable-y window
) pry
399 (xlib:drawable-width window
) prw
400 (xlib:drawable-height window
) prh
401 x
(x-px->fl prx parent
)
402 y
(y-px->fl pry parent
)
403 w
(w-px->fl prw parent
)
404 h
(h-px->fl prh parent
))
405 (xlib:display-finish-output
*display
*))))
407 (defun fixe-real-size (frame parent
)
408 "Fixe real (pixel) coordinates in float coordinates"
409 (when (frame-p frame
)
410 (with-slots (x y w h rx ry rw rh
) frame
411 (setf x
(x-px->fl rx parent
)
412 y
(y-px->fl ry parent
)
413 w
(w-px->fl rw parent
)
414 h
(h-px->fl rh parent
)))))
416 (defun fixe-real-size-current-child ()
417 "Fixe real (pixel) coordinates in float coordinates for children in the current child"
418 (when (frame-p *current-child
*)
419 (dolist (child (frame-child *current-child
*))
420 (fixe-real-size child
*current-child
*))))
425 (defun find-child (to-find root
)
426 "Find to-find in root or in its children"
427 (with-all-children (root child
)
428 (when (child-equal-p child to-find
)
429 (return-from find-child t
))))
433 (defmacro with-find-in-all-frames
(test &optional return-value
)
436 (with-all-frames (root frame
)
439 (return-from return-block
(or ,return-value frame
))
441 (or ,return-value ret
))))
443 (defun find-parent-frame (to-find &optional
(root *root-frame
*) first-foundp
)
444 "Return the parent frame of to-find"
445 (with-find-in-all-frames
446 (child-member to-find
(frame-child frame
))))
448 (defun find-frame-window (window &optional
(root *root-frame
*) first-foundp
)
449 "Return the frame with the window window"
450 (with-find-in-all-frames
451 (xlib:window-equal window
(frame-window frame
))))
453 (defun find-frame-by-name (name &optional
(root *root-frame
*) first-foundp
)
454 "Find a frame from its name"
456 (with-find-in-all-frames
457 (string-equal name
(frame-name frame
)))))
459 (defun find-frame-by-number (number &optional
(root *root-frame
*) first-foundp
)
460 "Find a frame from its number"
461 (when (numberp number
)
462 (with-find-in-all-frames
463 (= number
(frame-number frame
)))))
466 (defun find-child-in-parent (child base
)
467 "Return t if child is in base or in its parents"
469 (when (child-equal-p child base
)
470 (return-from find-child-in-parent t
))
471 (let ((parent (find-parent-frame base
)))
479 (defun get-all-windows (&optional
(root *root-frame
*))
480 "Return all windows in root and in its children"
482 (with-all-windows (root window
)
487 (defun get-hidden-windows ()
488 "Return all hiddens windows"
489 (let ((all-windows (get-all-windows))
490 (hidden-windows (remove-if-not #'window-hidden-p
491 (copy-list (xlib:query-tree
*root
*)))))
492 (set-difference hidden-windows all-windows
)))
496 ;;; Current window utilities
497 (defun get-current-window ()
498 (typecase *current-child
*
499 (xlib:window
*current-child
*)
500 (frame (frame-selected-child *current-child
*))))
502 (defmacro with-current-window
(&body body
)
503 "Bind 'window' to the current window"
504 `(let ((window (get-current-window)))
505 (when (xlib:window-p window
)
512 (defun display-frame-info (frame)
513 (let ((dy (+ (xlib:max-char-ascent
*default-font
*) (xlib:max-char-descent
*default-font
*))))
514 (with-slots (name number gc window child hidden-children
) frame
515 (setf (xlib:gcontext-background gc
) (get-color *frame-background
*)
516 (xlib:window-background window
) (get-color *frame-background
*))
517 (clear-pixmap-buffer window gc
)
518 (setf (xlib:gcontext-foreground gc
) (get-color (if (and (child-equal-p frame
*current-root
*)
519 (child-equal-p frame
*current-child
*))
520 *frame-foreground-root
* *frame-foreground
*)))
521 (xlib:draw-glyphs
*pixmap-buffer
* gc
5 dy
522 (format nil
"Frame: ~A~A"
524 (if name
(format nil
" - ~A" name
) "")))
526 (when (child-equal-p frame
*current-root
*)
527 (xlib:draw-glyphs
*pixmap-buffer
* gc
5 (incf pos dy
)
528 (format nil
" ~A hidden windows" (length (get-hidden-windows))))
529 (when *child-selection
*
530 (xlib:draw-glyphs
*pixmap-buffer
* gc
5 (incf pos dy
)
531 (with-output-to-string (str)
532 (format str
" Selection: ")
533 (dolist (child *child-selection
*)
535 (xlib:window
(format str
" ~A " (xlib:wm-name child
)))
536 (frame (format str
" frame:~A[~A] " (frame-number child
)
537 (aif (frame-name child
) it
"")))))))))
539 (xlib:draw-glyphs
*pixmap-buffer
* gc
5 (incf pos dy
)
540 (format nil
" ~A" (ensure-printable (child-fullname ch
)))))
541 (setf (xlib:gcontext-foreground gc
) (get-color *frame-foreground-hidden
*))
542 (dolist (ch hidden-children
)
543 (xlib:draw-glyphs
*pixmap-buffer
* gc
5 (incf pos dy
)
544 (format nil
" ~A - hidden" (ensure-printable (child-fullname ch
))))))
545 (copy-pixmap-buffer window gc
))))
548 (defun display-all-frame-info (&optional
(root *current-root
*))
549 (with-all-frames (root frame
)
550 (display-frame-info frame
)))
556 (defun get-parent-layout (child parent
)
558 (aif (frame-layout parent
)
559 (funcall it child parent
)
560 (no-layout child parent
))
561 (get-fullscreen-size)))
565 (defgeneric adapt-child-to-parent
(child parent
))
567 (defmethod adapt-child-to-parent ((window xlib
:window
) parent
)
568 (when (managed-window-p window parent
)
569 (multiple-value-bind (nx ny nw nh
)
570 (get-parent-layout window parent
)
571 (setf nw
(max nw
1) nh
(max nh
1))
572 (let ((change (or (/= (xlib:drawable-x window
) nx
)
573 (/= (xlib:drawable-y window
) ny
)
574 (/= (xlib:drawable-width window
) nw
)
575 (/= (xlib:drawable-height window
) nh
))))
576 (setf (xlib:drawable-x window
) nx
577 (xlib:drawable-y window
) ny
578 (xlib:drawable-width window
) nw
579 (xlib:drawable-height window
) nh
)
580 (xlib:display-finish-output
*display
*)
584 (defmethod adapt-child-to-parent ((frame frame
) parent
)
585 (multiple-value-bind (nx ny nw nh
)
586 (get-parent-layout frame parent
)
587 (with-slots (rx ry rw rh window
) frame
591 (let ((change (or (/= (xlib:drawable-x window
) rx
)
592 (/= (xlib:drawable-y window
) ry
)
593 (/= (xlib:drawable-width window
) rw
)
594 (/= (xlib:drawable-height window
) rh
))))
595 (setf (xlib:drawable-x window
) rx
596 (xlib:drawable-y window
) ry
597 (xlib:drawable-width window
) rw
598 (xlib:drawable-height window
) rh
)
599 (xlib:display-finish-output
*display
*)
602 (defmethod adapt-child-to-parent (child parent
)
603 (declare (ignore child parent
))
607 (defgeneric set-child-stack-order
(window child
)
608 (:documentation
"Raise window if child is NIL else put window just below child"))
610 (defmethod set-child-stack-order (window (child xlib
:window
))
611 (lower-window window child
))
613 (defmethod set-child-stack-order (window (child frame
))
614 (lower-window window
(frame-window child
)))
616 (defmethod set-child-stack-order (window child
)
617 (declare (ignore child
))
618 (raise-window window
)
619 (xlib:display-finish-output
*display
*))
623 (defgeneric show-child
(child parent previous
))
625 (defmethod show-child ((frame frame
) parent previous
)
626 (declare (ignore parent
))
627 (with-slots (window show-window-p
) frame
629 (when (or *show-root-frame-p
* (not (child-equal-p frame
*current-root
*)))
631 (set-child-stack-order window previous
)
632 (display-frame-info frame
))
633 (hide-window window
))))
637 (defun hide-unmanaged-window-p (parent)
638 (let ((action (frame-data-slot parent
:unmanaged-window-action
)))
642 (t *hide-unmanaged-window
*))))
645 (defmethod show-child ((window xlib
:window
) parent previous
)
646 (if (or (managed-window-p window parent
)
647 (child-equal-p window
*current-child
*)
648 (not (hide-unmanaged-window-p parent
))
649 (child-equal-p parent
*current-child
*))
652 (set-child-stack-order window previous
))
653 (hide-window window
)))
655 (defmethod show-child (child parent raise-p
)
656 (declare (ignore child parent raise-p
))
660 (defgeneric hide-child
(child))
662 (defmethod hide-child ((frame frame
))
663 (with-slots (window) frame
664 (xlib:unmap-window window
)))
666 (defmethod hide-child ((window xlib
:window
))
667 (hide-window window
))
669 (defmethod hide-child (child)
670 (declare (ignore child
))
676 (defgeneric child-coordinates
(child))
678 (defmethod child-coordinates ((frame frame
))
679 (values (frame-rx frame
)
681 (+ (frame-rx frame
) (frame-rw frame
))
682 (+ (frame-ry frame
) (frame-rh frame
))))
684 (defmethod child-coordinates ((window xlib
:window
))
685 (values (xlib:drawable-x window
)
686 (xlib:drawable-y window
)
687 (+ (xlib:drawable-x window
) (xlib:drawable-width window
))
688 (+ (xlib:drawable-y window
) (xlib:drawable-height window
))))
690 (defmethod child-coordinates (child)
691 (declare (ignore child
))
696 (defgeneric select-child
(child selected
))
698 (defmethod select-child ((frame frame
) selected
)
699 (when (and (frame-p frame
) (frame-window frame
))
700 (setf (xlib:window-border
(frame-window frame
))
701 (get-color (cond ((equal selected
:maybe
) *color-maybe-selected
*)
702 ((equal selected nil
) *color-unselected
*)
703 (selected *color-selected
*))))))
705 (defmethod select-child ((window xlib
:window
) selected
)
706 (setf (xlib:window-border window
)
707 (get-color (cond ((equal selected
:maybe
) *color-maybe-selected
*)
708 ((equal selected nil
) *color-unselected
*)
709 (selected *color-selected
*)))))
711 (defmethod select-child (child selected
)
712 (declare (ignore child selected
))
715 (defun select-current-frame (selected)
716 (select-child *current-child
* selected
))
718 (defun unselect-all-frames ()
719 (with-all-children (*current-root
* child
)
720 (select-child child nil
)))
724 (defun set-focus-to-current-child ()
725 (labels ((rec (child)
727 (xlib:window
(focus-window child
))
728 (frame (rec (frame-selected-child child
))))))
730 (rec *current-child
*)))
734 (defun show-all-children (&optional
(from-root-from nil
))
735 "Show all children from *current-root*. When from-root-from is true
736 Display all children from root frame and hide those not in *current-root*"
737 (let ((geometry-change nil
)
739 (labels ((rec (child parent selected-p in-current-root
)
740 (let ((child-current-root-p (child-equal-p child
*current-root
*)))
741 (when (or in-current-root child-current-root-p
)
742 (when (adapt-child-to-parent child
(if child-current-root-p nil parent
))
743 (setf geometry-change t
))
744 (select-child child
(cond ((child-equal-p child
*current-child
*) t
)
747 (when (frame-p child
)
748 (let ((selected-child (frame-selected-child child
)))
749 (dolist (sub-child (frame-child child
))
751 (and selected-p
(child-equal-p sub-child selected-child
))
752 (or in-current-root child-current-root-p
)))))
753 (if (or in-current-root child-current-root-p
)
754 (show-child child parent previous
)
756 (setf previous child
))))
757 (rec (if from-root-from
*root-frame
* *current-root
*)
758 nil t
(child-equal-p *current-root
* *root-frame
*))
759 (set-focus-to-current-child)
767 (defun hide-all-children (root)
768 "Hide all root children"
770 (dolist (child (frame-child root
))
773 (defun hide-all (root)
774 "Hide root and all its children"
776 (hide-all-children root
))
782 (defun focus-child (child parent
)
783 "Focus child - Return true if something has change"
784 (when (and (frame-p parent
)
785 (child-member child
(frame-child parent
)))
786 (when (not (child-equal-p child
(frame-selected-child parent
)))
787 (with-slots ((parent-child child
) selected-pos
) parent
788 (setf parent-child
(nth-insert selected-pos child
(child-remove child parent-child
))))
791 (defun focus-child-rec (child parent
)
792 "Focus child and its parents - Return true if something has change"
794 (labels ((rec (child parent
)
795 (when (focus-child child parent
)
798 (rec parent
(find-parent-frame parent
)))))
803 (defun set-current-child-generic (child)
804 (unless (child-equal-p *current-child
* child
)
805 (setf *current-child
* child
)
808 (defgeneric set-current-child
(child parent window-parent
))
810 (defmethod set-current-child ((child xlib
:window
) parent window-parent
)
811 (set-current-child-generic (if window-parent parent child
)))
813 (defmethod set-current-child ((child frame
) parent window-parent
)
814 (declare (ignore parent window-parent
))
815 (set-current-child-generic child
))
817 (defmethod set-current-child (child parent window-parent
)
818 (declare (ignore child parent window-parent
))
822 (defun set-current-root (parent window-parent
)
823 "Set current root if parent is not in current root"
824 (when (and window-parent
(not (find-child parent
*current-root
*)))
825 (setf *current-root
* parent
)))
828 (defun focus-all-children (child parent
&optional
(window-parent t
))
829 "Focus child and its parents -
830 For window: set current child to window or its parent according to window-parent"
831 (let ((new-focus (focus-child-rec child parent
))
832 (new-current-child (set-current-child child parent window-parent
))
833 (new-root (set-current-root parent window-parent
)))
834 (or new-focus new-current-child new-root
)))
839 (defun select-next-level ()
840 "Select the next level in frame"
841 (select-current-frame :maybe
)
842 (when (frame-p *current-child
*)
843 (awhen (frame-selected-child *current-child
*)
844 (setf *current-child
* it
)))
847 (defun select-previous-level ()
848 "Select the previous level in frame"
849 (unless (child-equal-p *current-child
* *current-root
*)
850 (select-current-frame :maybe
)
851 (awhen (find-parent-frame *current-child
*)
852 (setf *current-child
* it
))
853 (show-all-children)))
857 (defun enter-frame ()
858 "Enter in the selected frame - ie make it the root frame"
859 (hide-all *current-root
*)
860 (setf *current-root
* *current-child
*)
863 (defun leave-frame ()
864 "Leave the selected frame - ie make its parent the root frame"
865 (hide-all *current-root
*)
866 (awhen (find-parent-frame *current-root
*)
868 (setf *current-root
* it
)))
872 ;;; Other actions (select-next-child, select-next-brother...) are in
873 ;;; clfswm-circulate-mode.lisp
877 (defun frame-lower-child ()
878 "Lower the child in the current frame"
879 (when (frame-p *current-child
*)
880 (with-slots (child selected-pos
) *current-child
*
881 (unless (>= selected-pos
(length child
))
882 (when (nth (1+ selected-pos
) child
)
883 (rotatef (nth selected-pos child
)
884 (nth (1+ selected-pos
) child
)))
885 (incf selected-pos
)))
886 (show-all-children)))
889 (defun frame-raise-child ()
890 "Raise the child in the current frame"
891 (when (frame-p *current-child
*)
892 (with-slots (child selected-pos
) *current-child
*
893 (unless (< selected-pos
1)
894 (when (nth (1- selected-pos
) child
)
895 (rotatef (nth selected-pos child
)
896 (nth (1- selected-pos
) child
)))
897 (decf selected-pos
)))
898 (show-all-children)))
901 (defun frame-select-next-child ()
902 "Select the next child in the current frame"
903 (when (frame-p *current-child
*)
904 (with-slots (child selected-pos
) *current-child
*
905 (unless (>= selected-pos
(length child
))
906 (incf selected-pos
)))
907 (show-all-children)))
910 (defun frame-select-previous-child ()
911 "Select the previous child in the current frame"
912 (when (frame-p *current-child
*)
913 (with-slots (child selected-pos
) *current-child
*
914 (unless (< selected-pos
1)
915 (decf selected-pos
)))
916 (show-all-children)))
920 (defun switch-to-root-frame (&key
(show-later nil
))
921 "Switch to the root frame"
922 (hide-all *current-root
*)
923 (setf *current-root
* *root-frame
*)
925 (show-all-children)))
927 (defun switch-and-select-root-frame (&key
(show-later nil
))
928 "Switch and select the root frame"
929 (hide-all *current-root
*)
930 (setf *current-root
* *root-frame
*)
931 (setf *current-child
* *current-root
*)
933 (show-all-children)))
936 (defun toggle-show-root-frame ()
937 "Show/Hide the root frame"
938 (setf *show-root-frame-p
* (not *show-root-frame-p
*))
942 (defun remove-child-in-frame (child frame
)
943 "Remove the child in frame"
944 (when (frame-p frame
)
945 (setf (frame-child frame
) (child-remove child
(frame-child frame
)))))
947 (defun remove-child-in-frames (child root
)
948 "Remove child in the frame root and in all its children"
949 (with-all-frames (root frame
)
950 (remove-child-in-frame child frame
)))
953 (defun remove-child-in-all-frames (child)
954 "Remove child in all frames from *root-frame*"
955 (when (child-equal-p child
*current-root
*)
956 (setf *current-root
* (find-parent-frame child
)))
957 (when (child-equal-p child
*current-child
*)
958 (setf *current-child
* *current-root
*))
959 (remove-child-in-frames child
*root-frame
*))
962 (defun delete-child-in-frames (child root
)
963 "Delete child in the frame root and in all its children
964 Warning:frame window and gc are freeed."
965 (with-all-frames (root frame
)
966 (remove-child-in-frame child frame
)
967 (unless (find-frame-window (frame-window frame
))
968 (awhen (frame-gc frame
) (xlib:free-gcontext it
) (setf it nil
))
969 (awhen (frame-window frame
) (xlib:destroy-window it
) (setf it nil
))))
970 (when (xlib:window-p child
)
971 (netwm-remove-in-client-list child
)))
974 (defun delete-child-in-all-frames (child)
975 "Delete child in all frames from *root-frame*"
976 (when (child-equal-p child
*current-root
*)
977 (setf *current-root
* (find-parent-frame child
)))
978 (when (child-equal-p child
*current-child
*)
979 (setf *current-child
* *current-root
*))
980 (delete-child-in-frames child
*root-frame
*))
983 (defun delete-child-and-children-in-frames (child root
&optional
(close-methode 'delete-window
))
984 "Delete child and its children in the frame root and in all its children
985 Warning:frame window and gc are freeed."
986 (when (and (frame-p child
) (frame-child child
))
987 (dolist (ch (frame-child child
))
988 (delete-child-and-children-in-frames ch root close-methode
)))
989 (delete-child-in-frames child root
)
990 (when (xlib:window-p child
)
991 (funcall close-methode child
)))
993 (defun delete-child-and-children-in-all-frames (child &optional
(close-methode 'delete-window
))
994 "Delete child and its children in all frames from *root-frame*"
995 (when (child-equal-p child
*current-root
*)
996 (setf *current-root
* (find-parent-frame child
)))
997 (when (child-equal-p child
*current-child
*)
998 (setf *current-child
* *current-root
*))
999 (delete-child-and-children-in-frames child
*root-frame
* close-methode
))
1003 (defun place-window-from-hints (window)
1004 "Place a window from its hints"
1005 (let* ((hints (xlib:wm-normal-hints window
))
1006 (min-width (or (and hints
(xlib:wm-size-hints-min-width hints
)) 0))
1007 (min-height (or (and hints
(xlib:wm-size-hints-min-height hints
)) 0))
1008 (max-width (or (and hints
(xlib:wm-size-hints-max-width hints
)) (xlib:drawable-width
*root
*)))
1009 (max-height (or (and hints
(xlib:wm-size-hints-max-height hints
)) (xlib:drawable-height
*root
*)))
1010 (rwidth (or (and hints
(or (xlib:wm-size-hints-width hints
) (xlib:wm-size-hints-base-width hints
)))
1011 (xlib:drawable-width window
)))
1012 (rheight (or (and hints
(or (xlib:wm-size-hints-height hints
) (xlib:wm-size-hints-base-height hints
)))
1013 (xlib:drawable-height window
))))
1014 (setf (xlib:drawable-width window
) (min (max min-width rwidth
*default-window-width
*) max-width
)
1015 (xlib:drawable-height window
) (min (max min-height rheight
*default-window-height
*) max-height
))
1016 (setf (xlib:drawable-x window
) (truncate (/ (- (xlib:screen-width
*screen
*) (+ (xlib:drawable-width window
) 2)) 2))
1017 (xlib:drawable-y window
) (truncate (/ (- (xlib:screen-height
*screen
*) (+ (xlib:drawable-height window
) 2)) 2)))
1018 (xlib:display-finish-output
*display
*)))
1022 (defun do-all-frames-nw-hook (window)
1023 "Call nw-hook of each frame."
1024 (catch 'nw-hook-loop
1026 (with-all-frames (*root-frame
* frame
)
1027 (awhen (frame-nw-hook frame
)
1028 (setf found
(call-hook it
(list frame window
)))))
1033 (defun process-new-window (window)
1034 "When a new window is created (or when we are scanning initial
1035 windows), this function dresses the window up and gets it ready to be
1037 (setf (xlib:window-event-mask window
) *window-events
*)
1038 (set-window-state window
+normal-state
+)
1039 (setf (xlib:drawable-border-width window
) (case (window-type window
)
1044 (grab-all-buttons window
)
1045 (unless (never-managed-window-p window
)
1046 (unless (do-all-frames-nw-hook window
)
1047 (call-hook *default-nw-hook
* (list *root-frame
* window
))))
1048 (netwm-add-in-client-list window
))
1053 (defun hide-existing-windows (screen)
1054 "Hide all existing windows in screen"
1055 (dolist (win (xlib:query-tree
(xlib:screen-root screen
)))
1058 (defun process-existing-windows (screen)
1059 "Windows present when clfswm starts up must be absorbed by clfswm."
1060 (setf *in-process-existing-windows
* t
)
1062 (all-windows (get-all-windows)))
1063 (dolist (win (xlib:query-tree
(xlib:screen-root screen
)))
1064 (unless (child-member win all-windows
)
1065 (let ((map-state (xlib:window-map-state win
))
1066 (wm-state (window-state win
)))
1067 (unless (or (eql (xlib:window-override-redirect win
) :on
)
1068 (eql win
*no-focus-window
*))
1069 (when (or (eql map-state
:viewable
)
1070 (eql wm-state
+iconic-state
+))
1071 (format t
"Processing ~S: type=~A ~S~%" (xlib:wm-name win
) (window-type win
) win
)
1073 (process-new-window win
)
1076 (pushnew (xlib:window-id win
) id-list
))))))
1077 (netwm-set-client-list id-list
))
1078 (setf *in-process-existing-windows
* nil
))
1081 ;;; Child order manipulation functions
1082 (defun put-child-on-top (child parent
)
1083 "Put the child on top of its parent children"
1084 (when (frame-p parent
)
1085 (setf (frame-child parent
) (cons child
(child-remove child
(frame-child parent
)))
1086 (frame-selected-pos parent
) 0)))
1088 (defun put-child-on-bottom (child parent
)
1089 "Put the child at the bottom of its parent children"
1090 (when (frame-p parent
)
1091 (setf (frame-child parent
) (append (child-remove child
(frame-child parent
)) (list child
))
1092 (frame-selected-pos parent
) 0)))