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 (defgeneric child-border-size
(child))
30 (defmethod child-border-size ((child frame
))
31 (x-drawable-border-width (frame-window child
)))
33 (defmethod child-border-size ((child xlib
:window
))
34 (x-drawable-border-width child
))
36 (defmethod child-border-size (child)
37 (declare (ignore child
))
40 (defgeneric set-child-border-size
(child value
))
42 (defmethod set-child-border-size ((child frame
) value
)
43 (setf (x-drawable-border-width (frame-window child
)) value
))
45 (defmethod set-child-border-size ((child xlib
:window
) value
)
46 (setf (x-drawable-border-width child
) value
))
48 (defmethod set-child-border-size (child value
)
49 (declare (ignore child value
)))
51 (defsetf child-border-size set-child-border-size
)
55 ;;; Conversion functions
56 ;;; Float -> Pixel conversion
57 (defun x-fl->px
(x parent
)
58 "Convert float X coordinate to pixel"
59 (round (+ (* x
(frame-rw parent
)) (frame-rx parent
))))
61 (defun y-fl->px
(y parent
)
62 "Convert float Y coordinate to pixel"
63 (round (+ (* y
(frame-rh parent
)) (frame-ry parent
))))
65 (defun w-fl->px
(w parent
)
66 "Convert float Width coordinate to pixel"
67 (round (* w
(frame-rw parent
))))
69 (defun h-fl->px
(h parent
)
70 "Convert float Height coordinate to pixel"
71 (round (* h
(frame-rh parent
))))
73 ;;; Pixel -> Float conversion
74 (defun x-px->fl
(x parent
)
75 "Convert pixel X coordinate to float"
76 (/ (- x
(frame-rx parent
) (child-border-size parent
)) (frame-rw parent
)))
78 (defun y-px->fl
(y parent
)
79 "Convert pixel Y coordinate to float"
80 (/ (- y
(frame-ry parent
) (child-border-size parent
)) (frame-rh parent
)))
82 (defun w-px->fl
(w parent
)
83 "Convert pixel Width coordinate to float"
84 (/ w
(frame-rw parent
)))
86 (defun h-px->fl
(h parent
)
87 "Convert pixel Height coordinate to float"
88 (/ h
(frame-rh parent
)))
92 (defun rect-hidden-p (rect1 rect2
)
93 "Return T if child-rect1 hide child-rect2"
94 (and *show-hide-policy
*
95 (funcall *show-hide-policy
* (child-rect-x rect1
) (child-rect-x rect2
))
96 (funcall *show-hide-policy
* (child-rect-y rect1
) (child-rect-y rect2
))
97 (funcall *show-hide-policy
* (+ (child-rect-x rect2
) (child-rect-w rect2
))
98 (+ (child-rect-x rect1
) (child-rect-w rect1
)))
99 (funcall *show-hide-policy
* (+ (child-rect-y rect2
) (child-rect-h rect2
))
100 (+ (child-rect-y rect1
) (child-rect-h rect1
)))))
104 (defgeneric frame-p
(frame))
105 (defmethod frame-p ((frame frame
))
106 (declare (ignore frame
))
108 (defmethod frame-p (frame)
109 (declare (ignore frame
))
114 ;;; in-*: Find if point (x,y) is in frame, window or child
115 (defun in-rect (x y xr yr wr hr
)
116 (and (<= xr x
(+ xr wr
))
117 (<= yr y
(+ yr hr
))))
119 (defun in-frame (frame x y
)
121 (in-rect x y
(frame-rx frame
) (frame-ry frame
) (frame-rw frame
) (frame-rh frame
))))
123 (defun in-window (window x y
)
124 (and (xlib:window-p window
)
126 (x-drawable-x window
) (x-drawable-y window
)
127 (x-drawable-width window
) (x-drawable-height window
))))
130 (defgeneric in-child
(child x y
))
132 (defmethod in-child ((child frame
) x y
)
133 (in-frame child x y
))
134 (defmethod in-child ((child xlib
:window
) x y
)
135 (in-window child x y
))
136 (defmethod in-child (child x y
)
137 (declare (ignore child x y
))
143 (defun frame-selected-child (frame)
144 (when (frame-p frame
)
145 (with-slots (child selected-pos
) frame
146 (let ((len (length child
)))
147 (cond ((minusp selected-pos
) (setf selected-pos
0))
148 ((>= selected-pos len
) (setf selected-pos
(max (1- len
) 0)))))
149 (nth selected-pos child
))))
155 (defgeneric child-equal-p
(child-1 child-2
))
157 (defmethod child-equal-p ((child-1 xlib
:window
) (child-2 xlib
:window
))
158 (xlib:window-equal child-1 child-2
))
160 (defmethod child-equal-p ((child-1 frame
) (child-2 frame
))
161 (equal child-1 child-2
))
163 (defmethod child-equal-p (child-1 child-2
)
164 (declare (ignore child-1 child-2
))
170 (declaim (inline child-member child-remove child-position
))
172 (defun child-member (child list
)
173 (member child list
:test
#'child-equal-p
))
175 (defun child-remove (child list
)
176 (remove child list
:test
#'child-equal-p
))
178 (defun child-position (child list
)
179 (position child list
:test
#'child-equal-p
))
183 ;;; Frame data manipulation functions
184 (defun frame-data-slot (frame slot
)
185 "Return the value associated to data slot"
186 (when (frame-p frame
)
187 (second (assoc slot
(frame-data frame
)))))
189 (defun set-frame-data-slot (frame slot value
)
190 "Set the value associated to data slot"
191 (when (frame-p frame
)
192 (with-slots (data) frame
193 (setf data
(remove (assoc slot data
) data
))
194 (push (list slot value
) data
))
197 (defsetf frame-data-slot set-frame-data-slot
)
200 (defun remove-frame-data-slot (frame slot
)
201 "Remove a slot in frame data slots"
202 (when (frame-p frame
)
203 (with-slots (data) frame
204 (setf data
(remove (assoc slot data
) data
)))))
208 (defun managed-window-p (window frame
)
209 "Return t only if window is managed by frame"
211 (with-slots ((managed forced-managed-window
)
212 (unmanaged forced-unmanaged-window
)) frame
213 (and (xlib:window-p window
)
214 (not (child-member window unmanaged
))
215 (not (member (xlib:wm-name window
) unmanaged
:test
#'string-equal-p
))
216 (or (member :all
(frame-managed-type frame
))
217 (member (window-type window
) (frame-managed-type frame
))
218 (child-member window managed
)
219 (member (xlib:wm-name window
) managed
:test
#'string-equal-p
))))
223 (defun add-in-never-managed-window-list (value)
224 (pushnew value
*never-managed-window-list
* :test
#'equal
))
226 (defun never-managed-window-p (window)
227 (when (xlib:window-p window
)
228 (dolist (type *never-managed-window-list
*)
229 (when (funcall (first type
) window
)
230 (return (values t
(second type
)))))))
233 (defun never-managed-window-and-handled-p (window)
234 (multiple-value-bind (never-managed handle
)
235 (never-managed-window-p window
)
236 (and never-managed handle
)))
239 (defgeneric child-name
(child))
241 (defmethod child-name ((child xlib
:window
))
242 (ensure-printable (xlib:wm-name child
)))
244 (defmethod child-name ((child frame
))
247 (defmethod child-name (child)
248 (declare (ignore child
))
252 (defgeneric set-child-name
(child name
))
254 (defmethod set-child-name ((child xlib
:window
) name
)
255 (setf (xlib:wm-name child
) name
))
257 (defmethod set-child-name ((child frame
) name
)
258 (setf (frame-name child
) name
))
260 (defmethod set-child-name (child name
)
261 (declare (ignore child name
)))
263 (defsetf child-name set-child-name
)
268 (defgeneric child-fullname
(child))
270 (defmethod child-fullname ((child xlib
:window
))
272 (format nil
"~A (~A)" (or (xlib:wm-name child
) "?") (or (xlib:get-wm-class child
) "?"))))
274 (defmethod child-fullname ((child frame
))
276 (aif (frame-name child
)
277 (format nil
"~A (Frame ~A)" it
(frame-number child
))
278 (format nil
"Frame ~A" (frame-number child
)))))
280 (defmethod child-fullname (child)
281 (declare (ignore child
))
285 (defgeneric child-transparency
(child))
287 (defmethod child-transparency ((child xlib
:window
))
288 (window-transparency child
))
290 (defmethod child-transparency ((child frame
))
291 (window-transparency (frame-window child
)))
293 (defmethod child-transparency (child)
294 (declare (ignore child
))
297 (defgeneric set-child-transparency
(child value
))
299 (defmethod set-child-transparency ((child xlib
:window
) value
)
300 (setf (window-transparency child
) value
))
302 (defmethod set-child-transparency ((child frame
) value
)
303 (setf (window-transparency (frame-window child
)) value
))
305 (defmethod set-child-transparency (child value
)
306 (declare (ignore child value
)))
308 (defsetf child-transparency set-child-transparency
)
312 (defgeneric child-x
(child))
313 (defmethod child-x ((child xlib
:window
))
314 (x-drawable-x child
))
315 (defmethod child-x ((child frame
))
318 (defgeneric child-y
(child))
319 (defmethod child-y ((child xlib
:window
))
320 (x-drawable-y child
))
321 (defmethod child-y ((child frame
))
324 (defgeneric child-width
(child))
325 (defmethod child-width ((child xlib
:window
))
326 (x-drawable-width child
))
327 (defmethod child-width ((child frame
))
330 (defgeneric child-height
(child))
331 (defmethod child-height ((child xlib
:window
))
332 (x-drawable-height child
))
333 (defmethod child-height ((child frame
))
336 (defgeneric child-x2
(child))
337 (defmethod child-x2 ((child xlib
:window
))
338 (+ (x-drawable-x child
) (x-drawable-width child
)))
339 (defmethod child-x2 ((child frame
))
340 (+ (frame-rx child
) (frame-rw child
)))
342 (defgeneric child-y2
(child))
343 (defmethod child-y2 ((child xlib
:window
))
344 (+ (x-drawable-y child
) (x-drawable-height child
)))
345 (defmethod child-y2 ((child frame
))
346 (+ (frame-ry child
) (frame-rh child
)))
350 (defgeneric child-center
(child))
352 (defmethod child-center ((child xlib
:window
))
353 (values (+ (x-drawable-x child
) (/ (x-drawable-width child
) 2))
354 (+ (x-drawable-y child
) (/ (x-drawable-height child
) 2))))
356 (defmethod child-center ((child frame
))
357 (values (+ (frame-rx child
) (/ (frame-rw child
) 2))
358 (+ (frame-ry child
) (/ (frame-rh child
) 2))))
360 (defun child-distance (child1 child2
)
361 (multiple-value-bind (x1 y1
) (child-center child1
)
362 (multiple-value-bind (x2 y2
) (child-center child2
)
363 (values (+ (abs (- x2 x1
)) (abs (- y2 y1
)))
367 (defun middle-child-x (child)
368 (+ (child-x child
) (/ (child-width child
) 2)))
370 (defun middle-child-y (child)
371 (+ (child-y child
) (/ (child-height child
) 2)))
373 (declaim (inline adj-border-xy adj-border-wh
))
374 (defgeneric adj-border-xy
(value child
))
375 (defgeneric adj-border-wh
(value child
))
377 (defmethod adj-border-xy (v (child xlib
:window
))
378 (+ v
(x-drawable-border-width child
)))
380 (defmethod adj-border-xy (v (child frame
))
381 (+ v
(x-drawable-border-width (frame-window child
))))
383 (defmethod adj-border-wh (v (child xlib
:window
))
384 (- v
(* (x-drawable-border-width child
) 2)))
386 (defmethod adj-border-wh (v (child frame
))
387 (- v
(* (x-drawable-border-width (frame-window child
)) 2)))
390 (declaim (inline anti-adj-border-xy anti-adj-border-wh
))
391 (defgeneric anti-adj-border-xy
(value child
))
392 (defgeneric anti-adj-border-wh
(value child
))
394 (defmethod anti-adj-border-xy (v (child xlib
:window
))
395 (- v
(x-drawable-border-width child
)))
397 (defmethod anti-adj-border-xy (v (child frame
))
398 (- v
(x-drawable-border-width (frame-window child
))))
400 (defmethod anti-adj-border-wh (v (child xlib
:window
))
401 (+ v
(* (x-drawable-border-width child
) 2)))
403 (defmethod anti-adj-border-wh (v (child frame
))
404 (+ v
(* (x-drawable-border-width (frame-window child
)) 2)))
409 (defmacro with-focus-window
((window) &body body
)
410 `(let ((,window
(xlib:input-focus
*display
*)))
411 (when (and ,window
(not (xlib:window-equal
,window
*no-focus-window
*)))
416 ;; (with-all-children (*root-frame* child) (typecase child (xlib:window (print child)) (frame (print (frame-number child)))))
417 (defmacro with-all-children
((root child
) &body body
)
419 (sub-child (gensym)))
421 (labels ((,rec
(,child
)
423 (when (frame-p ,child
)
424 (dolist (,sub-child
(reverse (frame-child ,child
)))
425 (,rec
,sub-child
)))))
429 ;; (with-all-children (*root-frame* child) (typecase child (xlib:window (print child)) (frame (print (frame-number child)))))
430 (defmacro with-all-children-reversed
((root child
) &body body
)
432 (sub-child (gensym)))
434 (labels ((,rec
(,child
)
436 (when (frame-p ,child
)
437 (dolist (,sub-child
(frame-child ,child
))
438 (,rec
,sub-child
)))))
445 ;; (with-all-frames (*root-frame* frame) (print (frame-number frame)))
446 (defmacro with-all-frames
((root frame
) &body body
)
450 (labels ((,rec
(,frame
)
451 (when (frame-p ,frame
)
453 (dolist (,child
(reverse (frame-child ,frame
)))
458 ;; (with-all-windows (*root-frame* window) (print window))
459 (defmacro with-all-windows
((root window
) &body body
)
463 (labels ((,rec
(,window
)
464 (when (xlib:window-p
,window
)
466 (when (frame-p ,window
)
467 (dolist (,child
(reverse (frame-child ,window
)))
473 ;; (with-all-frames-windows (*root-frame* child) (print child) (print (frame-number child)))
474 (defmacro with-all-windows-frames
((root child
) body-window body-frame
)
476 (sub-child (gensym)))
478 (labels ((,rec
(,child
)
480 (xlib:window
,body-window
)
482 (dolist (,sub-child
(reverse (frame-child ,child
)))
483 (,rec
,sub-child
))))))
486 (defmacro with-all-windows-frames-and-parent
((root child parent
) body-window body-frame
)
488 (sub-child (gensym)))
490 (labels ((,rec
(,child
,parent
)
492 (xlib:window
,body-window
)
494 (dolist (,sub-child
(reverse (frame-child ,child
)))
495 (,rec
,sub-child
,child
))))))
501 (defun create-frame-window ()
502 (let ((win (xlib:create-window
:parent
*root
*
507 :background
(get-color *frame-background
*)
508 :colormap
(xlib:screen-default-colormap
*screen
*)
509 :border-width
*border-size
*
510 :border
(get-color *color-selected
*)
511 :event-mask
'(:exposure
:button-press
:button-release
:pointer-motion
:enter-window
))))
512 (setf (window-transparency win
) *frame-transparency
*)
515 (defun create-frame-gc (window)
516 (xlib:create-gcontext
:drawable window
517 :foreground
(get-color *frame-foreground
*)
518 :background
(get-color *frame-background
*)
523 (defun destroy-all-frames-window ()
524 (with-all-frames (*root-frame
* frame
)
525 (when (frame-gc frame
)
526 (xlib:free-gcontext
(frame-gc frame
))
527 (setf (frame-gc frame
) nil
))
528 (when (frame-window frame
)
529 (xlib:destroy-window
(frame-window frame
))
530 (setf (frame-window frame
) nil
))))
532 (defun create-all-frames-window ()
533 (with-all-frames (*root-frame
* frame
)
534 (unless (frame-window frame
)
535 (setf (frame-window frame
) (create-frame-window)))
536 (unless (frame-gc frame
)
537 (setf (frame-gc frame
) (create-frame-gc (frame-window frame
)))))
538 (with-all-frames (*root-frame
* frame
)
539 (dolist (child (frame-child frame
))
541 (dbg (child-fullname child
))
543 (setf (frame-child frame
) (remove child
(frame-child frame
) :test
#'child-equal-p
))
549 (defun frame-find-free-number ()
550 (let ((all-numbers nil
))
551 (with-all-frames (*root-frame
* frame
)
552 (pushnew (frame-number frame
) all-numbers
))
553 (find-free-number all-numbers
)))
556 (defun create-frame (&rest args
&key
(number (frame-find-free-number)) &allow-other-keys
)
557 (let* ((window (create-frame-window))
558 (gc (create-frame-gc window
)))
559 (apply #'make-instance
'frame
:number number
:window window
:gc gc args
)))
562 (defun add-frame (frame parent
)
563 (push frame
(frame-child parent
))
567 (defun place-frame (frame parent prx pry prw prh
)
568 "Place a frame from real (pixel) coordinates"
569 (when (and (frame-p frame
) (frame-p parent
))
570 (with-slots (window x y w h
) frame
571 (setf (x-drawable-x window
) prx
572 (x-drawable-y window
) pry
573 (x-drawable-width window
) prw
574 (x-drawable-height window
) prh
575 x
(x-px->fl prx parent
)
576 y
(y-px->fl pry parent
)
577 w
(w-px->fl prw parent
)
578 h
(h-px->fl prh parent
))
579 (xlib:display-finish-output
*display
*))))
583 (defun find-child (to-find root
)
584 "Find to-find in root or in its children"
585 (with-all-children (root child
)
586 (when (child-equal-p child to-find
)
587 (return-from find-child t
))))
591 (defmacro with-find-in-all-frames
(test &optional return-value
)
594 (with-all-frames (root frame
)
597 (return-from return-block
(or ,return-value frame
))
599 (or ,return-value ret
))))
601 (defun find-parent-frame (to-find &optional
(root *root-frame
*) first-foundp
)
602 "Return the parent frame of to-find"
603 (with-find-in-all-frames
604 (child-member to-find
(frame-child frame
))))
606 (defun find-frame-window (window &optional
(root *root-frame
*) first-foundp
)
607 "Return the frame with the window window"
608 (with-find-in-all-frames
609 (xlib:window-equal window
(frame-window frame
))))
611 (defun find-frame-by-name (name &optional
(root *root-frame
*) first-foundp
)
612 "Find a frame from its name"
614 (with-find-in-all-frames
615 (string-equal name
(frame-name frame
)))))
617 (defun find-frame-by-number (number &optional
(root *root-frame
*) first-foundp
)
618 "Find a frame from its number"
619 (when (numberp number
)
620 (with-find-in-all-frames
621 (= number
(frame-number frame
)))))
624 (defun find-child-in-parent (child base
)
625 "Return t if child is in base or in its parents"
627 (when (child-equal-p child base
)
628 (return-from find-child-in-parent t
))
629 (let ((parent (find-parent-frame base
)))
634 ;;; Multiple roots support (replace the old *current-root* variable)
635 (let ((root-list nil
)
637 (defun get-root-list ()
640 (let ((save-root-list nil
))
641 (defun save-root-list ()
642 (setf save-root-list nil
)
643 (dolist (root root-list
)
644 (push (copy-root root
) save-root-list
)))
645 (defun restore-root-list ()
647 (dolist (root save-root-list
)
648 (push (copy-root root
) root-list
))))
650 (defmacro with-saved-root-list
(() &body body
)
654 (restore-root-list)))
656 (defun reset-root-list ()
660 (defun define-as-root (child x y width height
)
661 (push (make-root :child child
:original child
:current-child nil
:x x
:y y
:w width
:h height
) root-list
))
663 (defun find-root-by-coordinates (x y
)
664 (dolist (root root-list
)
665 (when (in-rect x y
(root-x root
) (root-y root
) (root-w root
) (root-h root
))
668 (defun root (x &optional y
)
669 "Return the root at coordinates (x,y) if y is not nil.
670 Otherwise, return the x nth root in root-list"
672 (find-root-by-coordinates x y
)
675 (defun all-root-child ()
676 (loop for root in root-list
677 collect
(root-child root
)))
679 (defmacro with-all-root-child
((root) &body body
)
680 (let ((root-symb (gensym)))
681 `(dolist (,root-symb
(get-root-list))
682 (let ((,root
(root-child ,root-symb
)))
685 (labels ((generic-child-root-p (child function
)
686 (dolist (root root-list
)
687 (when (child-equal-p child
(funcall function root
))
689 (defun child-root-p (child)
690 (generic-child-root-p child
#'root-child
))
692 (defun child-original-root-p (child)
693 (generic-child-root-p child
#'root-original
)))
695 (defun change-root (old-root new-child
)
696 (when (and old-root new-child
)
697 (setf (root-child old-root
) new-child
)))
699 (defun find-root (child)
700 (aif (child-original-root-p child
)
702 (awhen (find-parent-frame child
)
705 (defun find-child-in-all-root (child)
706 (dolist (root root-list
)
707 (when (find-child child
(root-child root
))
708 (return-from find-child-in-all-root root
))))
710 (defun find-current-root ()
711 (root-child (find-root current-child
)))
713 (defun exchange-root-geometry (root-1 root-2
)
714 (when (and root-1 root-2
)
715 (rotatef (root-x root-1
) (root-x root-2
))
716 (rotatef (root-y root-1
) (root-y root-2
))
717 (rotatef (root-w root-1
) (root-w root-2
))
718 (rotatef (root-h root-1
) (root-h root-2
))))
720 (defun rotate-root-geometry ()
721 (let* ((current (first root-list
))
722 (orig-x (root-x current
))
723 (orig-y (root-y current
))
724 (orig-w (root-w current
))
725 (orig-h (root-h current
)))
726 (dolist (elem (rest root-list
))
727 (setf (root-x current
) (root-x elem
)
728 (root-y current
) (root-y elem
)
729 (root-w current
) (root-w elem
)
730 (root-h current
) (root-h elem
)
732 (let ((last (car (last root-list
))))
733 (setf (root-x last
) orig-x
736 (root-h last
) orig-h
))))
738 (defun anti-rotate-root-geometry ()
739 (setf root-list
(nreverse root-list
))
740 (rotate-root-geometry)
741 (setf root-list
(nreverse root-list
)))
743 ;;; Current child functions
744 (defun current-child ()
747 (defun current-child-setter (value)
749 (awhen (find-root value
)
750 (setf (root-current-child it
) value
))
751 (setf current-child value
)))
753 (defmacro with-current-child
((new-child) &body body
)
754 "Temporarly change the current child"
755 (let ((old-child (gensym))
757 `(let ((,old-child
(current-child)))
758 (setf (current-child) ,new-child
)
759 (let ((,ret
(multiple-value-list (progn ,@body
))))
760 (setf (current-child) ,old-child
)
761 (values-list ,ret
)))))
763 (defun child-is-a-current-child-p (child)
764 (find child root-list
:test
#'child-equal-p
:key
#'root-current-child
)))
766 (defsetf current-child current-child-setter
)
768 (defun ensure-at-least-one-root ()
769 (unless (get-root-list)
770 (let ((frame (create-frame)))
771 (add-frame frame
*root-frame
*)
772 (define-as-root frame
0 0 (screen-width) (screen-height))
773 (add-frame (create-frame) frame
))))
780 (defun is-in-current-child-p (child)
781 (and (frame-p (current-child))
782 (child-member child
(frame-child (current-child)))))
786 (defun fixe-real-size (frame parent
)
787 "Fixe real (pixel) coordinates in float coordinates"
788 (when (frame-p frame
)
789 (with-slots (x y w h rx ry rw rh
) frame
790 (setf x
(x-px->fl rx parent
)
791 y
(y-px->fl ry parent
)
792 w
(w-px->fl
(anti-adj-border-wh rw parent
) parent
)
793 h
(h-px->fl
(anti-adj-border-wh rh parent
) parent
)))))
795 (defun fixe-real-size-current-child ()
796 "Fixe real (pixel) coordinates in float coordinates for children in the current child"
797 (when (frame-p (current-child))
798 (dolist (child (frame-child (current-child)))
799 (fixe-real-size child
(current-child)))))
803 ;;; Multiple physical screen helper
804 (defun add-placed-frame-tmp (frame n
) ;; For test
805 (add-frame (create-frame :x
0.01 :y
0.01 :w
0.4 :h
0.4) frame
)
806 (add-frame (create-frame :x
0.55 :y
0.01 :w
0.4 :h
0.4) frame
)
807 (add-frame (create-frame :x
0.03 :y
0.5 :w
0.64 :h
0.44) frame
)
809 (add-placed-frame-tmp (first (frame-child frame
)) (1- n
))))
811 (defun parse-xinerama-info (line)
813 (mapcar (lambda (string)
814 (parse-integer string
:junk-allowed t
))
815 (split-string (substitute #\space
#\x
(substitute #\space
#\
, line
))))))
817 (defun get-connected-heads-size (&optional fake
)
818 (labels ((heads-info ()
820 (do-shell "xdpyinfo -ext XINERAMA")
822 (setf *show-root-frame-p
* t
)
823 (do-shell "echo ' available colormap entries: 256 per subfield
824 red, green, blue masks: 0xff0000, 0xff00, 0xff
825 significant bits in color specification: 8 bits
827 XINERAMA version 1.1 opcode: 150
828 head #0: 500x300 @ 10,10
829 head #1: 480x300 @ 520,20
830 head #2: 600x250 @ 310,330'")))))
831 (when (xlib:query-extension
*display
* "XINERAMA")
832 (let ((output (heads-info))
834 (loop for line
= (read-line output nil nil
)
836 do
(when (search " head " line
)
837 (destructuring-bind (w h x y
)
838 (parse-xinerama-info line
)
841 (destructuring-bind (x1 y1 w1 h1
) s
844 (<= (+ x w
) (+ x1 w1
))
845 (<= (+ y h
) (+ y1 h1
)))
848 (push (list x y w h
) sizes
))))))
850 ;;'((10 10 500 300) (550 50 400 400) (100 320 400 270))))))
851 ;;'((10 10 500 580) (540 50 470 500))))))
854 (let ((last-sizes nil
))
855 (defun reset-last-head-size ()
856 (setf last-sizes nil
))
858 (defun place-frames-from-xinerama-infos ()
859 "Place frames according to xdpyinfo/xinerama informations"
860 (let ((sizes (get-connected-heads-size))
861 (width (screen-width))
862 (height (screen-height)))
863 (labels ((update-root-geometry ()
864 (loop for size in sizes
865 for root in
(get-root-list)
866 do
(destructuring-bind (x y w h
) size
867 (setf (root-x root
) x
871 (setf last-sizes sizes
)
873 (create-root-geometry ()
875 ;; Add frames in *root-frame* until we get the same number as screen heads
876 (loop while
(< (length (frame-child *root-frame
*)) (length sizes
))
877 do
(let ((frame (create-frame)))
878 (add-frame frame
*root-frame
*)))
879 ;; On the opposite way: remove frames while there is more than screen heads in *root-frame*
880 (when (and sizes
(> (length (frame-child *root-frame
*)) (length sizes
)))
881 (dotimes (i (- (length (frame-child *root-frame
*)) (length sizes
)))
882 (let ((deleted-child (pop (frame-child *root-frame
*))))
883 (typecase deleted-child
884 (xlib:window
(push deleted-child
(frame-child (first (frame-child *root-frame
*)))))
885 (frame (dolist (child (frame-child deleted-child
))
886 (push child
(frame-child (first (frame-child *root-frame
*)))))))
887 (setf (frame-layout (first (frame-child *root-frame
*))) 'tile-space-layout
888 (frame-data-slot (first (frame-child *root-frame
*)) :tile-layout-keep-position
) :yes
))))
889 (loop for size in sizes
890 for frame in
(frame-child *root-frame
*)
891 do
(destructuring-bind (x y w h
) size
892 (setf (frame-x frame
) (float (/ x width
))
893 (frame-y frame
) (float (/ y height
))
894 (frame-w frame
) (float (/ w width
))
895 (frame-h frame
) (float (/ h height
)))
896 ;;(add-placed-frame-tmp frame 2) ;; For tests
897 (unless (frame-child frame
)
898 (add-frame (create-frame) frame
))
899 (define-as-root frame x y w h
)))
900 (setf last-sizes sizes
)
902 (format t
"Screen sizes: ~A~%" sizes
)
903 (if (= (length sizes
) (length last-sizes
))
904 (update-root-geometry)
905 (create-root-geometry))))))
909 (defun finish-configuring-root ()
910 (ensure-at-least-one-root)
911 (setf (current-child) (first (frame-child (first (frame-child *root-frame
*))))))
915 (defun get-all-windows (&optional
(root *root-frame
*))
916 "Return all windows in root and in its children"
918 (with-all-windows (root window
)
922 (defun get-all-frame-windows (&optional
(root *root-frame
*))
923 "Return all frame windows in root and in its children"
925 (with-all-frames (root frame
)
926 (push (frame-window frame
) acc
))
929 (defun get-all-frames (&optional
(root *root-frame
*))
930 "Return all frame in root and in its children"
932 (with-all-frames (root frame
)
936 (defun get-all-children (&optional
(root *root-frame
*))
937 "Return a list of all children in root"
939 (with-all-children (root child
)
944 (defun get-hidden-windows ()
945 "Return all hiddens windows"
946 (let ((all-windows (get-all-windows))
947 (hidden-windows (remove-if-not #'window-hidden-p
948 (copy-list (xlib:query-tree
*root
*)))))
949 (set-difference hidden-windows all-windows
)))
953 ;;; Current window utilities
954 (defun get-current-window ()
955 (typecase (current-child)
956 (xlib:window
(current-child))
957 (frame (frame-selected-child (current-child)))))
959 (defmacro with-current-window
(&body body
)
960 "Bind 'window' to the current window"
961 `(let ((window (get-current-window)))
962 (when (xlib:window-p window
)
965 (defun get-first-window ()
966 (typecase (current-child)
967 (xlib:window
(current-child))
968 (frame (or (first (frame-child (current-child)))
975 (defun display-frame-info (frame)
976 (when (frame-p frame
)
977 (let ((dy (+ (xlib:max-char-ascent
*default-font
*) (xlib:max-char-descent
*default-font
*))))
978 (with-slots (name number gc window child hidden-children
) frame
979 (setf (xlib:gcontext-background gc
) (get-color *frame-background
*)
980 (xlib:window-background window
) (get-color *frame-background
*))
981 (clear-pixmap-buffer window gc
)
982 (setf (xlib:gcontext-foreground gc
) (get-color (if (and (child-root-p frame
)
983 (child-equal-p frame
(current-child)))
984 *frame-foreground-root
* *frame-foreground
*)))
985 (xlib:draw-glyphs
*pixmap-buffer
* gc
5 dy
986 (format nil
"Frame: ~A~A"
988 (if name
(format nil
" - ~A" name
) "")))
990 (when (child-root-p frame
)
991 (when *child-selection
*
992 (xlib:draw-glyphs
*pixmap-buffer
* gc
5 (incf pos dy
)
993 (with-output-to-string (str)
994 (format str
" Selection: ")
995 (dolist (child *child-selection
*)
997 (xlib:window
(format str
" ~A " (xlib:wm-name child
)))
998 (frame (format str
" frame:~A[~A] " (frame-number child
)
999 (aif (frame-name child
) it
"")))))))))
1001 (xlib:draw-glyphs
*pixmap-buffer
* gc
5 (incf pos dy
)
1002 (format nil
" ~A" (ensure-printable (child-fullname ch
))))))
1003 (copy-pixmap-buffer window gc
)
1007 (defgeneric rename-child
(child name
))
1009 (defmethod rename-child ((child frame
) name
)
1010 (setf (frame-name child
) name
)
1011 (display-frame-info child
))
1013 (defmethod rename-child ((child xlib
:window
) name
)
1014 (setf (xlib:wm-name child
) name
))
1016 (defmethod rename-child (child name
)
1017 (declare (ignore child name
)))
1020 (defun get-parent-layout (child parent
)
1021 (aif (child-root-p child
)
1022 (values (- (root-x it
) (child-border-size child
)) (- (root-y it
) (child-border-size child
))
1023 (root-w it
) (root-h it
))
1024 (if (or (frame-p child
) (managed-window-p child parent
))
1025 (if (frame-p parent
)
1026 (aif (frame-layout parent
)
1027 (funcall it child parent
)
1028 (no-layout child parent
))
1029 (values (- (child-border-size child
)) (- (child-border-size child
))
1032 (values (x-drawable-x child
) (x-drawable-y child
)
1033 (x-drawable-width child
) (x-drawable-height child
)))))
1039 (defgeneric adapt-child-to-parent
(child parent
))
1041 (defmethod adapt-child-to-parent ((window xlib
:window
) parent
)
1042 (when (managed-window-p window parent
)
1043 (multiple-value-bind (nx ny nw nh
)
1044 (get-parent-layout window parent
)
1045 (setf nw
(max nw
1) nh
(max nh
1))
1047 (when (or (/= (x-drawable-x window
) nx
)
1048 (/= (x-drawable-y window
) ny
))
1049 (setf change
:moved
))
1050 (when (or (/= (x-drawable-width window
) nw
)
1051 (/= (x-drawable-height window
) nh
))
1052 (setf change
:resized
))
1054 (xlib:with-state
(window)
1055 (setf (x-drawable-x window
) nx
1056 (x-drawable-y window
) ny
1057 (x-drawable-width window
) nw
1058 (x-drawable-height window
) nh
)))
1062 (defmethod adapt-child-to-parent ((frame frame
) parent
)
1063 (declare (ignore parent
))
1064 (with-slots (rx ry rw rh window
) frame
1066 (when (or (/= (x-drawable-x window
) rx
)
1067 (/= (x-drawable-y window
) ry
))
1068 (setf change
:moved
))
1069 (when (or (/= (x-drawable-width window
) rw
)
1070 (/= (x-drawable-height window
) rh
))
1071 (setf change
:resized
))
1073 (xlib:with-state
(window)
1074 (setf (x-drawable-x window
) rx
1075 (x-drawable-y window
) ry
1076 (x-drawable-width window
) rw
1077 (x-drawable-height window
) rh
)))
1080 (defmethod adapt-child-to-parent (child parent
)
1081 (declare (ignore child parent
))
1085 (defgeneric set-child-stack-order
(window child
)
1086 (:documentation
"Put window just below child"))
1088 (defmethod set-child-stack-order (window (child xlib
:window
))
1089 (lower-window window child
))
1091 (defmethod set-child-stack-order (window (child frame
))
1092 (lower-window window
(frame-window child
)))
1094 (defmethod set-child-stack-order (window child
)
1095 (declare (ignore child
))
1096 (unless (maxmin-size-equal-window-in-tree)
1097 (raise-window window
)))
1101 (defgeneric show-child
(child parent previous
))
1103 (defmethod show-child ((frame frame
) parent previous
)
1104 (declare (ignore parent
))
1105 (with-slots (window show-window-p
) frame
1106 (if (and show-window-p
1107 (or *show-root-frame-p
* (not (child-root-p frame
))))
1110 (set-child-stack-order window previous
)
1111 (display-frame-info frame
))
1112 (hide-window window
))))
1116 (defun hide-unmanaged-window-p (parent)
1117 (let ((action (frame-data-slot parent
:unmanaged-window-action
)))
1121 (t *hide-unmanaged-window
*))))
1124 (defmethod show-child ((window xlib
:window
) parent previous
)
1125 (if (or (managed-window-p window parent
)
1126 (child-equal-p window
(current-child))
1127 (not (hide-unmanaged-window-p parent
))
1128 (child-is-a-current-child-p parent
))
1131 (set-child-stack-order window previous
))
1132 (hide-window window
)))
1134 (defmethod show-child (child parent raise-p
)
1135 (declare (ignore child parent raise-p
))
1139 (defgeneric hide-child
(child))
1141 (defmethod hide-child ((frame frame
))
1142 (with-slots (window) frame
1143 (xlib:unmap-window window
)))
1145 (defmethod hide-child ((window xlib
:window
))
1146 (hide-window window
))
1148 (defmethod hide-child (child)
1149 (declare (ignore child
))
1153 (defgeneric select-child
(child selected
))
1155 (labels ((get-selected-color (child selected-p
)
1156 (get-color (cond ((child-equal-p child
(current-child)) *color-selected
*)
1157 (selected-p *color-maybe-selected
*)
1158 (t *color-unselected
*)))))
1159 (defmethod select-child ((frame frame
) selected-p
)
1160 (when (and (frame-p frame
) (frame-window frame
))
1161 (setf (xlib:window-border
(frame-window frame
))
1162 (get-selected-color frame selected-p
))))
1164 (defmethod select-child ((window xlib
:window
) selected-p
)
1165 (setf (xlib:window-border window
)
1166 (get-selected-color window selected-p
)))
1168 (defmethod select-child (child selected
)
1169 (declare (ignore child selected
))
1172 (defun select-current-frame (selected)
1173 (select-child (current-child) selected
))
1175 (defun unselect-all-frames ()
1176 (with-all-children (*root-frame
* child
)
1177 (select-child child nil
)))
1181 (defun set-focus-to-current-child ()
1182 (labels ((rec (child)
1184 (xlib:window
(focus-window child
))
1185 (frame (rec (frame-selected-child child
))))))
1187 (rec (current-child))))
1192 (defun adapt-frame-to-parent (frame parent
)
1193 (multiple-value-bind (nx ny nw nh
)
1194 (get-parent-layout frame parent
)
1195 (with-slots (rx ry rw rh window
) frame
1201 (defun adapt-child-to-rect (rect)
1202 (let ((window (typecase (child-rect-child rect
)
1203 (xlib:window
(when (managed-window-p (child-rect-child rect
) (child-rect-parent rect
))
1204 (child-rect-child rect
)))
1205 (frame (frame-window (child-rect-child rect
))))))
1207 (let ((change (or (/= (x-drawable-x window
) (child-rect-x rect
))
1208 (/= (x-drawable-y window
) (child-rect-y rect
))
1209 (/= (x-drawable-width window
) (child-rect-w rect
))
1210 (/= (x-drawable-height window
) (child-rect-h rect
)))))
1212 (setf (x-drawable-width window
) (child-rect-w rect
)
1213 (x-drawable-height window
) (child-rect-h rect
)
1214 (x-drawable-x window
) (child-rect-x rect
)
1215 (x-drawable-y window
) (child-rect-y rect
)))
1220 (let ((displayed-child nil
))
1221 (defun get-displayed-child ()
1224 (defun show-all-children (&optional
(from-root-frame nil
))
1225 "Show all children and hide those not in a root frame"
1226 (declare (ignore from-root-frame
))
1227 (let ((geometry-change nil
)
1229 (has-no-leader-list nil
))
1230 (labels ((set-has-no-leader-list ()
1231 (let ((window-list nil
)
1233 (with-all-windows (*root-frame
* win
)
1234 (let ((leader (window-leader win
)))
1236 (when (member leader window-list
:test
(lambda (x y
) (eql x
(first y
))))
1237 (pushnew leader leader-list
))
1238 (push (list leader win
) window-list
))))
1239 (dolist (leader-win window-list
)
1240 (unless (member leader-win leader-list
:test
(lambda (x y
) (eql (first x
) y
)))
1241 (push (second leader-win
) has-no-leader-list
)))))
1243 (in-displayed-list (child)
1244 (member child displayed-child
:test
(lambda (c rect
)
1245 (child-equal-p c
(child-rect-child rect
)))))
1247 (add-in-hidden-list (child)
1248 (pushnew child hidden-child
:test
#'child-equal-p
))
1250 (set-geometry (child parent in-current-root child-current-root-p
)
1251 (if (or in-current-root child-current-root-p
)
1252 (when (frame-p child
)
1253 (adapt-frame-to-parent child
(if child-current-root-p nil parent
)))
1254 (add-in-hidden-list child
)))
1256 (recurse-on-frame-child (child in-current-root child-current-root-p selected-p
)
1257 (let ((selected-child (frame-selected-child child
)))
1258 (dolist (sub-child (frame-child child
))
1259 (rec sub-child child
1260 (and selected-p
(child-equal-p sub-child selected-child
))
1261 (or in-current-root child-current-root-p
)))))
1263 (hidden-child-p (rect)
1264 (when (or (frame-p (child-rect-child rect
))
1265 (member (window-type (child-rect-child rect
)) *show-hide-policy-type
*))
1266 (dolist (r displayed-child
)
1267 (when (and (rect-hidden-p r rect
)
1268 (or (not (xlib:window-p
(child-rect-child r
)))
1269 (eq (window-type (child-rect-child r
)) :normal
)))
1272 (select-and-display (child parent selected-p
)
1273 (multiple-value-bind (nx ny nw nh
)
1274 (get-parent-layout child parent
)
1275 (let ((rect (make-child-rect :child child
:parent parent
1276 :selected-p selected-p
1277 :x nx
:y ny
:w nw
:h nh
)))
1278 (if (and *show-hide-policy
* (hidden-child-p rect
)
1279 (member child has-no-leader-list
:test
#'child-equal-p
))
1280 (add-in-hidden-list child
)
1281 (push rect displayed-child
)))))
1283 (display-displayed-child ()
1284 (let ((previous nil
))
1285 (setf displayed-child
(nreverse displayed-child
))
1286 (dolist (rect displayed-child
)
1287 (when (adapt-child-to-rect rect
)
1288 (setf geometry-change t
))
1289 (select-child (child-rect-child rect
) (child-rect-selected-p rect
))
1290 (show-child (child-rect-child rect
)
1291 (child-rect-parent rect
)
1293 (setf previous
(child-rect-child rect
)))))
1295 (rec (child parent selected-p in-current-root
)
1296 (let ((child-current-root-p (child-root-p child
)))
1297 (unless (in-displayed-list child
)
1298 (set-geometry child parent in-current-root child-current-root-p
))
1299 (when (frame-p child
)
1300 (recurse-on-frame-child child in-current-root child-current-root-p selected-p
))
1301 (when (and (or in-current-root child-current-root-p
)
1302 (not (in-displayed-list child
)))
1303 (select-and-display child parent selected-p
)))))
1305 (setf displayed-child nil
)
1306 (set-has-no-leader-list)
1307 (rec *root-frame
* nil t
(child-root-p *root-frame
*))
1308 (display-displayed-child)
1309 (dolist (child hidden-child
)
1311 (set-focus-to-current-child)
1312 (xlib:display-finish-output
*display
*)
1318 (defun hide-all-children (root &optional except
)
1319 "Hide all root children"
1320 (when (and (frame-p root
) (not (child-equal-p root except
)))
1321 (dolist (child (frame-child root
))
1322 (hide-all child except
))))
1324 (defun hide-all (root &optional except
)
1325 "Hide root and all its children"
1326 (unless (child-equal-p root except
)
1328 (hide-all-children root except
))
1334 (defun focus-child (child parent
)
1335 "Focus child - Return true if something has change"
1336 (when (and (frame-p parent
)
1337 (child-member child
(frame-child parent
)))
1338 (when (not (child-equal-p child
(frame-selected-child parent
)))
1339 (with-slots ((parent-child child
) selected-pos
) parent
1340 (setf parent-child
(nth-insert selected-pos child
(child-remove child parent-child
))))
1343 (defun focus-child-rec (child parent
)
1344 "Focus child and its parents - Return true if something has change"
1346 (labels ((rec (child parent
)
1347 (when (focus-child child parent
)
1350 (rec parent
(find-parent-frame parent
)))))
1355 (defun set-current-child-generic (child)
1356 (unless (child-equal-p (current-child) child
)
1357 (setf (current-child) child
)
1360 (defgeneric set-current-child
(child parent window-parent
))
1362 (defmethod set-current-child ((child xlib
:window
) parent window-parent
)
1363 (set-current-child-generic (if window-parent parent child
)))
1365 (defmethod set-current-child ((child frame
) parent window-parent
)
1366 (declare (ignore parent window-parent
))
1367 (set-current-child-generic child
))
1369 (defmethod set-current-child (child parent window-parent
)
1370 (declare (ignore child parent window-parent
))
1374 (defun set-current-root (child parent window-parent
)
1375 "Set current root if parent is not in current root"
1376 (let ((root (find-root child
)))
1377 (when (and root window-parent
1378 (not (child-root-p child
))
1379 (not (find-child parent
(root-child root
))))
1380 (change-root root parent
)
1383 (defun focus-all-children (child parent
&optional
(window-parent t
))
1384 "Focus child and its parents -
1385 For window: set current child to window or its parent according to window-parent"
1386 (let ((new-focus (focus-child-rec child parent
))
1387 (new-current-child (set-current-child child parent window-parent
))
1388 (new-root (set-current-root child parent window-parent
)))
1389 (or new-focus new-current-child new-root
)))
1394 (defun select-next-level ()
1395 "Select the next level in frame"
1396 (select-current-frame :maybe
)
1397 (when (frame-p (current-child))
1398 (awhen (frame-selected-child (current-child))
1399 (setf (current-child) it
)))
1400 (show-all-children))
1402 (defun select-previous-level ()
1403 "Select the previous level in frame"
1404 (unless (child-root-p (current-child))
1405 (select-current-frame :maybe
)
1406 (awhen (find-parent-frame (current-child))
1407 (setf (current-child) it
))
1408 (show-all-children)))
1411 (defun enter-frame ()
1412 "Enter in the selected frame - ie make it the root frame"
1413 (let ((root (find-root (current-child))))
1414 (when (and root
(not (child-equal-p (root-child root
) (current-child))))
1415 (change-root root
(current-child)))
1416 (show-all-children t
)))
1418 (defun leave-frame ()
1419 "Leave the selected frame - ie make its parent the root frame"
1420 (let ((root (find-root (current-child))))
1421 (unless (or (child-equal-p (root-child root
) *root-frame
*)
1422 (child-original-root-p (root-child root
)))
1423 (awhen (and root
(find-parent-frame (root-child root
)))
1425 (change-root root it
)))
1426 (show-all-children))))
1429 ;;; Other actions (select-next-child, select-next-brother...) are in
1430 ;;; clfswm-circulate-mode.lisp
1434 (defun frame-lower-child ()
1435 "Lower the child in the current frame"
1436 (when (frame-p (current-child))
1437 (with-slots (child selected-pos
) (current-child)
1438 (unless (>= selected-pos
(length child
))
1439 (when (nth (1+ selected-pos
) child
)
1440 (rotatef (nth selected-pos child
)
1441 (nth (1+ selected-pos
) child
)))
1442 (incf selected-pos
)))
1443 (show-all-children)))
1446 (defun frame-raise-child ()
1447 "Raise the child in the current frame"
1448 (when (frame-p (current-child))
1449 (with-slots (child selected-pos
) (current-child)
1450 (unless (< selected-pos
1)
1451 (when (nth (1- selected-pos
) child
)
1452 (rotatef (nth selected-pos child
)
1453 (nth (1- selected-pos
) child
)))
1454 (decf selected-pos
)))
1455 (show-all-children)))
1458 (defun frame-select-next-child ()
1459 "Select the next child in the current frame"
1460 (when (frame-p (current-child))
1461 (with-slots (child selected-pos
) (current-child)
1462 (setf selected-pos
(mod (1+ selected-pos
) (max (length child
) 1))))
1463 (show-all-children)))
1466 (defun frame-select-previous-child ()
1467 "Select the previous child in the current frame"
1468 (when (frame-p (current-child))
1469 (with-slots (child selected-pos
) (current-child)
1470 (setf selected-pos
(mod (1- selected-pos
) (max (length child
) 1))))
1471 (show-all-children)))
1475 (defun switch-to-root-frame (&key
(show-later nil
))
1476 "Switch to the root frame"
1477 (let ((root (find-root (current-child))))
1479 (change-root root
(root-original root
)))
1481 (show-all-children t
))))
1483 (defun switch-and-select-root-frame (&key
(show-later nil
))
1484 "Switch and select the root frame"
1485 (let ((root (find-root (current-child))))
1487 (change-root root
(root-original root
))
1488 (setf (current-child) (root-original root
)))
1490 (show-all-children t
))))
1493 (defun toggle-show-root-frame ()
1494 "Show/Hide the root frame"
1495 (setf *show-root-frame-p
* (not *show-root-frame-p
*))
1496 (show-all-children))
1500 (defun move-child-to (child frame-dest
)
1501 (when (and child
(frame-p frame-dest
))
1502 (remove-child-in-frame child
(find-parent-frame child
))
1503 (pushnew child
(frame-child frame-dest
) :test
#'child-equal-p
)
1504 (focus-all-children child frame-dest
)
1505 (show-all-children t
)))
1508 (defun prevent-current-*-equal-child
(child)
1509 " Prevent current-root and current-child equal to child"
1510 (if (child-original-root-p child
)
1513 (awhen (child-root-p child
)
1514 (change-root it
(find-parent-frame child
)))
1515 (when (child-equal-p child
(current-child))
1516 (awhen (find-root child
)
1517 (setf (current-child) (root-child it
))))
1522 (defun remove-child-in-frame (child frame
)
1523 "Remove the child in frame"
1524 (when (frame-p frame
)
1525 (setf (frame-child frame
) (child-remove child
(frame-child frame
)))))
1527 (defun remove-child-in-frames (child root
)
1528 "Remove child in the frame root and in all its children"
1529 (with-all-frames (root frame
)
1530 (remove-child-in-frame child frame
)))
1533 (defun remove-child-in-all-frames (child)
1534 "Remove child in all frames from *root-frame*"
1535 (when (prevent-current-*-equal-child child
)
1536 (remove-child-in-frames child
*root-frame
*)))
1539 (defun delete-child-in-frames (child root
&optional
(close-methode 'delete-window
))
1540 "Delete child in the frame root and in all its children
1541 Warning:frame window and gc are freeed."
1542 (with-all-frames (root frame
)
1543 (remove-child-in-frame child frame
)
1544 (unless (find-frame-window (frame-window frame
))
1545 (awhen (frame-gc frame
) (xlib:free-gcontext it
) (setf it nil
))
1546 (awhen (frame-window frame
) (xlib:destroy-window it
) (setf it nil
))))
1547 (when (xlib:window-p child
)
1548 (funcall close-methode child
)
1549 (netwm-remove-in-client-list child
)))
1553 (defun delete-child-in-all-frames (child &optional
(close-methode 'delete-window
))
1554 "Delete child in all frames from *root-frame*"
1555 (when (prevent-current-*-equal-child child
)
1556 (delete-child-in-frames child
*root-frame
* close-methode
)))
1558 (defun delete-child-and-children-in-frames (child root
&optional
(close-methode 'delete-window
))
1559 "Delete child and its children in the frame root and in all its children
1560 Warning:frame window and gc are freeed."
1561 (when (and (frame-p child
) (frame-child child
))
1562 (dolist (ch (frame-child child
))
1563 (delete-child-and-children-in-frames ch root close-methode
)))
1564 (delete-child-in-frames child root close-methode
))
1566 (defun delete-child-and-children-in-all-frames (child &optional
(close-methode 'delete-window
))
1567 "Delete child and its children in all frames from *root-frame*"
1568 (when (prevent-current-*-equal-child child
)
1569 (when (frame-p child
)
1570 (delete-child-and-children-in-frames child
*root-frame
* close-methode
))
1571 (when (xlib:window-p child
)
1572 (funcall close-methode child
))))
1575 (defun clean-windows-in-all-frames ()
1576 "Remove all xlib:windows present in *root-frame* and not in the xlib tree"
1577 (let ((x-tree (xlib:query-tree
*root
*)))
1578 (with-all-frames (*root-frame
* frame
)
1579 (dolist (child (frame-child frame
))
1580 (when (xlib:window-p child
)
1581 (unless (member child x-tree
:test
#'xlib
:window-equal
)
1582 (when (prevent-current-*-equal-child child
)
1583 (setf (frame-child frame
)
1584 (child-remove child
(frame-child frame
))))))))))
1588 (defun do-all-frames-nw-hook (window)
1589 "Call nw-hook of each frame."
1590 (catch 'nw-hook-loop
1592 (with-all-frames (*root-frame
* frame
)
1593 (awhen (frame-nw-hook frame
)
1594 (setf found
(call-hook it frame window
))))
1599 (defun process-new-window (window)
1600 "When a new window is created (or when we are scanning initial
1601 windows), this function dresses the window up and gets it ready to be
1603 (setf (xlib:window-event-mask window
) *window-events
*)
1604 (set-window-state window
+normal-state
+)
1605 (setf (x-drawable-border-width window
) (case (window-type window
)
1606 (:normal
*border-size
*)
1608 (:transient
*border-size
*)
1609 (:dialog
*border-size
*)
1611 (grab-all-buttons window
)
1612 (unless (never-managed-window-p window
)
1613 (unless (do-all-frames-nw-hook window
)
1614 (call-hook *default-nw-hook
* *root-frame
* window
)))
1615 (netwm-add-in-client-list window
))
1620 (defun with-all-mapped-windows (screen fun
)
1621 (let ((all-windows (get-all-windows)))
1622 (dolist (win (xlib:query-tree
(xlib:screen-root screen
)))
1623 (unless (child-member win all-windows
)
1624 (let ((map-state (xlib:window-map-state win
))
1625 (wm-state (window-state win
)))
1626 (unless (or (eql (xlib:window-override-redirect win
) :on
)
1627 (eql win
*no-focus-window
*)
1628 (is-notify-window-p win
))
1629 (when (or (eql map-state
:viewable
)
1630 (eql wm-state
+iconic-state
+))
1631 (funcall fun win
))))))))
1633 (defun store-root-background ()
1634 (with-all-mapped-windows *screen
* #'hide-window
)
1635 (setf *background-image
* (xlib:create-pixmap
:width
(screen-width)
1636 :height
(screen-height)
1637 :depth
(xlib:screen-root-depth
*screen
*)
1639 *background-gc
* (xlib:create-gcontext
:drawable
*background-image
*
1640 :foreground
(get-color *frame-foreground
*)
1641 :background
(get-color *frame-background
*)
1642 :font
*default-font
*
1643 :line-style
:solid
))
1644 (xlib:copy-area
*root
* *background-gc
*
1645 0 0 (screen-width) (screen-height)
1646 *background-image
* 0 0)
1647 (with-all-mapped-windows *screen
* #'unhide-window
))
1652 (defun hide-existing-windows (screen)
1653 "Hide all existing windows in screen"
1654 (dolist (win (xlib:query-tree
(xlib:screen-root screen
)))
1659 (defun process-existing-windows (screen)
1660 "Windows present when clfswm starts up must be absorbed by clfswm."
1661 (setf *in-process-existing-windows
* t
)
1663 (all-windows (get-all-windows))
1664 (all-frame-windows (get-all-frame-windows)))
1665 (dolist (win (xlib:query-tree
(xlib:screen-root screen
)))
1666 (unless (or (child-member win all-windows
)
1667 (child-member win all-frame-windows
))
1668 (let ((map-state (xlib:window-map-state win
))
1669 (wm-state (window-state win
)))
1670 (unless (or (eql (xlib:window-override-redirect win
) :on
)
1671 (eql win
*no-focus-window
*)
1672 (is-notify-window-p win
)
1673 (never-managed-window-p win
))
1674 (when (or (eql map-state
:viewable
)
1675 (eql wm-state
+iconic-state
+))
1676 (format t
"Processing ~S: type=~A ~S~%" (xlib:wm-name win
) (window-type win
) win
)
1678 (process-new-window win
)
1681 (pushnew (xlib:window-id win
) id-list
))))))
1682 (netwm-set-client-list id-list
))
1683 (setf *in-process-existing-windows
* nil
))
1686 ;;; Child order manipulation functions
1687 (defun put-child-on-top (child parent
)
1688 "Put the child on top of its parent children"
1689 (when (frame-p parent
)
1690 (setf (frame-child parent
) (cons child
(child-remove child
(frame-child parent
)))
1691 (frame-selected-pos parent
) 0)))
1693 (defun put-child-on-bottom (child parent
)
1694 "Put the child at the bottom of its parent children"
1695 (when (frame-p parent
)
1696 (setf (frame-child parent
) (append (child-remove child
(frame-child parent
)) (list child
))
1697 (frame-selected-pos parent
) 0)))
1700 (let ((last-child nil
))
1701 (defun manage-focus (window root-x root-y
)
1702 (case (if (frame-p (current-child))
1703 (frame-focus-policy (current-child))
1704 *default-focus-policy
*)
1705 (:sloppy
(focus-window window
))
1706 (:sloppy-strict
(when (and (frame-p (current-child))
1707 (child-member window
(frame-child (current-child))))
1708 (focus-window window
)))
1709 (:sloppy-select
(let* ((child (find-child-under-mouse root-x root-y
))
1710 (parent (find-parent-frame child
)))
1711 (unless (or (child-root-p child
)
1712 (child-equal-p (typecase child
1713 (xlib:window parent
)
1716 (focus-all-children child parent
)
1717 (show-all-children))))
1718 (:sloppy-select-window
(let* ((child (find-child-under-mouse root-x root-y
))
1719 (parent (find-parent-frame child
))
1720 (need-warp-pointer (not (or (frame-p child
)
1721 (child-equal-p child
(frame-selected-child parent
))))))
1722 (unless (or (child-root-p child
)
1723 (child-equal-p child last-child
))
1724 (setf last-child child
)
1725 (when (focus-all-children child parent
)
1727 (when (and need-warp-pointer
1728 (not (eql (frame-data-slot (current-child) :tile-layout-keep-position
)
1731 (xlib:window
(xlib:warp-pointer
*root
*
1732 (truncate (+ (x-drawable-x child
)
1733 (/ (x-drawable-width child
) 2)))
1734 (truncate (+ (x-drawable-y child
)
1735 (/ (x-drawable-height child
) 2)))))
1736 (frame (xlib:warp-pointer
*root
*
1737 (+ (frame-rx child
) 10)
1738 (+ (frame-ry child
) 10))))))))))))
1742 ;;; Dumping/restoring frame tree functions
1743 (defun print-frame-tree (root &optional
(disp-fun #'child-fullname
))
1744 (labels ((rec (child space
)
1746 (format t
"~A~%" (funcall disp-fun child
))
1747 (when (frame-p child
)
1748 (dolist (c (reverse (frame-child child
)))
1749 (rec c
(+ space
2))))))
1752 (defmethod print-object ((frame frame
) stream
)
1753 (format stream
"~A - ~F ~F ~F ~F ~A ~A ~A ~X ~X ~A ~A ~A ~A"
1754 (child-fullname frame
)
1755 (frame-x frame
) (frame-y frame
) (frame-w frame
) (frame-h frame
)
1756 (frame-layout frame
) (frame-nw-hook frame
)
1757 (frame-managed-type frame
)
1758 (frame-forced-managed-window frame
)
1759 (frame-forced-unmanaged-window frame
)
1760 (frame-show-window-p frame
)
1761 (frame-hidden-children frame
)
1762 (frame-selected-pos frame
)
1763 (frame-focus-policy frame
)
1764 ;;(frame-data frame))
1768 (defun window->xid
(window)
1769 (when (xlib:window-p window
)
1770 (xlib:window-id window
)))
1772 (defun xid->window
(xid)
1773 (dolist (win (xlib:query-tree
*root
*))
1774 (when (equal xid
(xlib:window-id win
))
1775 (return-from xid-
>window win
))))
1779 (defun copy-frame (frame &optional
(window-fun #'window-
>xid
))
1780 (labels ((handle-window-list (list)
1781 (loop for win in list
1782 collect
(funcall window-fun win
))))
1783 (with-slots (name number x y w h layout nw-hook managed-type
1784 forced-managed-window forced-unmanaged-window
1785 show-window-p hidden-children selected-pos
1788 (make-instance 'frame
:name name
:number number
1790 :layout layout
:nw-hook nw-hook
1791 :managed-type
(if (consp managed-type
)
1792 (copy-list managed-type
)
1794 :forced-managed-window
(handle-window-list forced-managed-window
)
1795 :forced-unmanaged-window
(handle-window-list forced-unmanaged-window
)
1796 :show-window-p show-window-p
1797 :hidden-children
(handle-window-list hidden-children
)
1798 :selected-pos selected-pos
1799 :focus-policy focus-policy
1800 :data
(copy-tree data
)))))
1802 (defun dump-frame-tree (root &optional
(window-fun #'window-
>xid
))
1803 "Return a tree of frames."
1804 (let ((new-root (copy-frame root window-fun
)))
1805 (labels ((store (from root
)
1806 (when (frame-p from
)
1807 (dolist (c (reverse (frame-child from
)))
1808 (push (if (frame-p c
)
1809 (let ((new-root (copy-frame c window-fun
)))
1812 (funcall window-fun c
))
1813 (frame-child root
))))))
1814 (store root new-root
)
1817 (defun test-dump-frame-tree ()
1818 (let ((store (dump-frame-tree *root-frame
*)))
1819 (print-frame-tree store
1821 (format nil
"~A" x
)))
1822 (format t
"~&--------------------------------------------------~2%")
1823 (print-frame-tree (dump-frame-tree store
#'xid-
>window
)
1825 (format nil
"~A" (if (frame-p x
) x
(child-fullname x
)))))))