Do not raise window on each event
[clfswm.git] / src / clfswm-internal.lisp
blobedc3c2b6a2018ffddfa8de2bca13b1437fdbe09f
1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
3 ;;;
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Main functions
6 ;;; --------------------------------------------------------------------------
7 ;;;
8 ;;; (C) 2005-2014 Philippe Brochard <pbrochard@common-lisp.net>
9 ;;;
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.
14 ;;;
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.
19 ;;;
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.
23 ;;;
24 ;;; --------------------------------------------------------------------------
26 (in-package :clfswm)
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))
110 nil)
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)
120 (and (frame-p frame)
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)
125 (in-rect x y
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))
138 nil)
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))
165 nil)
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))
195 value))
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"
210 (if (frame-p 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))
245 (frame-name child))
247 (defmethod child-name (child)
248 (declare (ignore child))
249 "???")
252 (defgeneric set-child-name (child name))
254 (defmethod set-child-name ((child xlib:window) name)
255 (setf (xlib:wm-name child) (ensure-printable name)))
257 (defmethod set-child-name ((child frame) name)
258 (setf (frame-name child) (ensure-printable 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))
271 (format nil "~A (~A)" (or (xlib:wm-name child) "?") (or (xlib:get-wm-class child) "?")))
273 (defmethod child-fullname ((child frame))
274 (aif (frame-name child)
275 (format nil "~A (Frame ~A)" it (frame-number child))
276 (format nil "Frame ~A" (frame-number child))))
278 (defmethod child-fullname (child)
279 (declare (ignore child))
280 "???")
283 (defgeneric child-transparency (child))
285 (defmethod child-transparency ((child xlib:window))
286 (window-transparency child))
288 (defmethod child-transparency ((child frame))
289 (window-transparency (frame-window child)))
291 (defmethod child-transparency (child)
292 (declare (ignore child))
295 (defgeneric set-child-transparency (child value))
297 (defmethod set-child-transparency ((child xlib:window) value)
298 (setf (window-transparency child) value))
300 (defmethod set-child-transparency ((child frame) value)
301 (setf (window-transparency (frame-window child)) value))
303 (defmethod set-child-transparency (child value)
304 (declare (ignore child value)))
306 (defsetf child-transparency set-child-transparency)
310 (defgeneric child-x (child))
311 (defmethod child-x ((child xlib:window))
312 (x-drawable-x child))
313 (defmethod child-x ((child frame))
314 (frame-rx child))
316 (defgeneric child-y (child))
317 (defmethod child-y ((child xlib:window))
318 (x-drawable-y child))
319 (defmethod child-y ((child frame))
320 (frame-ry child))
322 (defgeneric child-width (child))
323 (defmethod child-width ((child xlib:window))
324 (x-drawable-width child))
325 (defmethod child-width ((child frame))
326 (frame-rw child))
328 (defgeneric child-height (child))
329 (defmethod child-height ((child xlib:window))
330 (x-drawable-height child))
331 (defmethod child-height ((child frame))
332 (frame-rh child))
334 (defgeneric child-x2 (child))
335 (defmethod child-x2 ((child xlib:window))
336 (+ (x-drawable-x child) (x-drawable-width child)))
337 (defmethod child-x2 ((child frame))
338 (+ (frame-rx child) (frame-rw child)))
340 (defgeneric child-y2 (child))
341 (defmethod child-y2 ((child xlib:window))
342 (+ (x-drawable-y child) (x-drawable-height child)))
343 (defmethod child-y2 ((child frame))
344 (+ (frame-ry child) (frame-rh child)))
348 (defgeneric child-center (child))
350 (defmethod child-center ((child xlib:window))
351 (values (+ (x-drawable-x child) (/ (x-drawable-width child) 2))
352 (+ (x-drawable-y child) (/ (x-drawable-height child) 2))))
354 (defmethod child-center ((child frame))
355 (values (+ (frame-rx child) (/ (frame-rw child) 2))
356 (+ (frame-ry child) (/ (frame-rh child) 2))))
358 (defun child-distance (child1 child2)
359 (multiple-value-bind (x1 y1) (child-center child1)
360 (multiple-value-bind (x2 y2) (child-center child2)
361 (values (+ (abs (- x2 x1)) (abs (- y2 y1)))
362 (- x2 x1)
363 (- y2 y1)))))
365 (defun middle-child-x (child)
366 (+ (child-x child) (/ (child-width child) 2)))
368 (defun middle-child-y (child)
369 (+ (child-y child) (/ (child-height child) 2)))
371 (declaim (inline adj-border-xy adj-border-wh))
372 (defgeneric adj-border-xy (value child))
373 (defgeneric adj-border-wh (value child))
375 (defmethod adj-border-xy (v (child xlib:window))
376 (+ v (x-drawable-border-width child)))
378 (defmethod adj-border-xy (v (child frame))
379 (+ v (x-drawable-border-width (frame-window child))))
381 (defmethod adj-border-wh (v (child xlib:window))
382 (- v (* (x-drawable-border-width child) 2)))
384 (defmethod adj-border-wh (v (child frame))
385 (- v (* (x-drawable-border-width (frame-window child)) 2)))
388 (declaim (inline anti-adj-border-xy anti-adj-border-wh))
389 (defgeneric anti-adj-border-xy (value child))
390 (defgeneric anti-adj-border-wh (value child))
392 (defmethod anti-adj-border-xy (v (child xlib:window))
393 (- v (x-drawable-border-width child)))
395 (defmethod anti-adj-border-xy (v (child frame))
396 (- v (x-drawable-border-width (frame-window child))))
398 (defmethod anti-adj-border-wh (v (child xlib:window))
399 (+ v (* (x-drawable-border-width child) 2)))
401 (defmethod anti-adj-border-wh (v (child frame))
402 (+ v (* (x-drawable-border-width (frame-window child)) 2)))
407 (defmacro with-focus-window ((window) &body body)
408 `(let ((,window (xlib:input-focus *display*)))
409 (when (and ,window (not (xlib:window-equal ,window *no-focus-window*)))
410 ,@body)))
414 ;; (with-all-children (*root-frame* child) (typecase child (xlib:window (print child)) (frame (print (frame-number child)))))
415 (defmacro with-all-children ((root child) &body body)
416 (let ((rec (gensym))
417 (sub-child (gensym)))
418 `(block nil
419 (labels ((,rec (,child)
420 ,@body
421 (when (frame-p ,child)
422 (dolist (,sub-child (reverse (frame-child ,child)))
423 (,rec ,sub-child)))))
424 (,rec ,root)))))
427 ;; (with-all-children (*root-frame* child) (typecase child (xlib:window (print child)) (frame (print (frame-number child)))))
428 (defmacro with-all-children-reversed ((root child) &body body)
429 (let ((rec (gensym))
430 (sub-child (gensym)))
431 `(block nil
432 (labels ((,rec (,child)
433 ,@body
434 (when (frame-p ,child)
435 (dolist (,sub-child (frame-child ,child))
436 (,rec ,sub-child)))))
437 (,rec ,root)))))
443 ;; (with-all-frames (*root-frame* frame) (print (frame-number frame)))
444 (defmacro with-all-frames ((root frame) &body body)
445 (let ((rec (gensym))
446 (child (gensym)))
447 `(block nil
448 (labels ((,rec (,frame)
449 (when (frame-p ,frame)
450 ,@body
451 (dolist (,child (reverse (frame-child ,frame)))
452 (,rec ,child)))))
453 (,rec ,root)))))
456 ;; (with-all-windows (*root-frame* window) (print window))
457 (defmacro with-all-windows ((root window) &body body)
458 (let ((rec (gensym))
459 (child (gensym)))
460 `(block nil
461 (labels ((,rec (,window)
462 (when (xlib:window-p ,window)
463 ,@body)
464 (when (frame-p ,window)
465 (dolist (,child (reverse (frame-child ,window)))
466 (,rec ,child)))))
467 (,rec ,root)))))
471 ;; (with-all-frames-windows (*root-frame* child) (print child) (print (frame-number child)))
472 (defmacro with-all-windows-frames ((root child) body-window body-frame)
473 (let ((rec (gensym))
474 (sub-child (gensym)))
475 `(block nil
476 (labels ((,rec (,child)
477 (typecase ,child
478 (xlib:window ,body-window)
479 (frame ,body-frame
480 (dolist (,sub-child (reverse (frame-child ,child)))
481 (,rec ,sub-child))))))
482 (,rec ,root)))))
484 (defmacro with-all-windows-frames-and-parent ((root child parent) body-window body-frame)
485 (let ((rec (gensym))
486 (sub-child (gensym)))
487 `(block nil
488 (labels ((,rec (,child ,parent)
489 (typecase ,child
490 (xlib:window ,body-window)
491 (frame ,body-frame
492 (dolist (,sub-child (reverse (frame-child ,child)))
493 (,rec ,sub-child ,child))))))
494 (,rec ,root nil)))))
499 (defun create-frame-window ()
500 (let ((win (xlib:create-window :parent *root*
501 :x 0
502 :y 0
503 :width 200
504 :height 200
505 :background (get-color *frame-background*)
506 :colormap (xlib:screen-default-colormap *screen*)
507 :border-width *border-size*
508 :border (get-color *color-selected*)
509 :event-mask '(:exposure :button-press :button-release :pointer-motion :enter-window))))
510 (setf (window-transparency win) *frame-transparency*)
511 win))
513 (defun create-frame-gc (window)
514 (xlib:create-gcontext :drawable window
515 :foreground (get-color *frame-foreground*)
516 :background (get-color *frame-background*)
517 :font *default-font*
518 :line-style :solid))
521 (defun destroy-all-frames-window ()
522 (with-all-frames (*root-frame* frame)
523 (when (frame-gc frame)
524 (xlib:free-gcontext (frame-gc frame))
525 (setf (frame-gc frame) nil))
526 (when (frame-window frame)
527 (xlib:destroy-window (frame-window frame))
528 (setf (frame-window frame) nil))))
530 (defun create-all-frames-window ()
531 (with-all-frames (*root-frame* frame)
532 (unless (frame-window frame)
533 (setf (frame-window frame) (create-frame-window)))
534 (unless (frame-gc frame)
535 (setf (frame-gc frame) (create-frame-gc (frame-window frame)))))
536 (with-all-frames (*root-frame* frame)
537 (dolist (child (frame-child frame))
538 (handler-case
539 (dbg (child-fullname child))
540 (error (c)
541 (setf (frame-child frame) (remove child (frame-child frame) :test #'child-equal-p))
542 (dbg c child))))))
547 (defun frame-find-free-number ()
548 (let ((all-numbers nil))
549 (with-all-frames (*root-frame* frame)
550 (pushnew (frame-number frame) all-numbers))
551 (find-free-number all-numbers)))
554 (defun create-frame (&rest args &key (number (frame-find-free-number)) &allow-other-keys)
555 (let* ((window (create-frame-window))
556 (gc (create-frame-gc window)))
557 (apply #'make-instance 'frame :number number :window window :gc gc args)))
560 (defun add-frame (frame parent)
561 (push frame (frame-child parent))
562 frame)
565 (defun place-frame (frame parent prx pry prw prh)
566 "Place a frame from real (pixel) coordinates"
567 (when (and (frame-p frame) (frame-p parent))
568 (with-slots (window x y w h) frame
569 (setf (x-drawable-x window) prx
570 (x-drawable-y window) pry
571 (x-drawable-width window) prw
572 (x-drawable-height window) prh
573 x (x-px->fl prx parent)
574 y (y-px->fl pry parent)
575 w (w-px->fl prw parent)
576 h (h-px->fl prh parent))
577 (xlib:display-finish-output *display*))))
581 (defun find-child (to-find root)
582 "Find to-find in root or in its children"
583 (with-all-children (root child)
584 (when (child-equal-p child to-find)
585 (return-from find-child t))))
589 (defmacro with-find-in-all-frames (test &optional return-value)
590 `(let (ret)
591 (block return-block
592 (with-all-frames (root frame)
593 (when ,test
594 (if first-foundp
595 (return-from return-block (or ,return-value frame))
596 (setf ret frame))))
597 (or ,return-value ret))))
599 (defun find-parent-frame (to-find &optional (root *root-frame*) first-foundp)
600 "Return the parent frame of to-find"
601 (with-find-in-all-frames
602 (child-member to-find (frame-child frame))))
604 (defun find-frame-window (window &optional (root *root-frame*) first-foundp)
605 "Return the frame with the window window"
606 (with-find-in-all-frames
607 (xlib:window-equal window (frame-window frame))))
609 (defun find-frame-by-name (name &optional (root *root-frame*) first-foundp)
610 "Find a frame from its name"
611 (when name
612 (with-find-in-all-frames
613 (string-equal name (frame-name frame)))))
615 (defun find-frame-by-number (number &optional (root *root-frame*) first-foundp)
616 "Find a frame from its number"
617 (when (numberp number)
618 (with-find-in-all-frames
619 (= number (frame-number frame)))))
622 (defun find-child-in-parent (child base)
623 "Return t if child is in base or in its parents"
624 (labels ((rec (base)
625 (when (child-equal-p child base)
626 (return-from find-child-in-parent t))
627 (let ((parent (find-parent-frame base)))
628 (when parent
629 (rec parent)))))
630 (rec base)))
632 ;;; Multiple roots support (replace the old *current-root* variable)
633 (let ((root-list nil)
634 (current-child nil))
635 (defun get-root-list ()
636 root-list)
638 (let ((save-root-list nil))
639 (defun save-root-list ()
640 (setf save-root-list nil)
641 (dolist (root root-list)
642 (push (copy-root root) save-root-list)))
643 (defun restore-root-list ()
644 (setf root-list nil)
645 (dolist (root save-root-list)
646 (push (copy-root root) root-list))))
648 (defmacro with-saved-root-list (() &body body)
649 `(progn
650 (save-root-list)
651 ,@body
652 (restore-root-list)))
654 (defun reset-root-list ()
655 (setf root-list nil
656 current-child nil))
658 (defun define-as-root (child x y width height)
659 (push (make-root :child child :original child :current-child nil :x x :y y :w width :h height) root-list))
661 (defun find-root-by-coordinates (x y)
662 (dolist (root root-list)
663 (when (in-rect x y (root-x root) (root-y root) (root-w root) (root-h root))
664 (return root))))
666 (defun root (x &optional y)
667 "Return the root at coordinates (x,y) if y is not nil.
668 Otherwise, return the x nth root in root-list"
669 (if y
670 (find-root-by-coordinates x y)
671 (nth x root-list)))
673 (defun all-root-child ()
674 (loop for root in root-list
675 collect (root-child root)))
677 (defmacro with-all-root-child ((root) &body body)
678 (let ((root-symb (gensym)))
679 `(dolist (,root-symb (get-root-list))
680 (let ((,root (root-child ,root-symb)))
681 ,@body))))
683 (labels ((generic-child-root-p (child function)
684 (dolist (root root-list)
685 (when (child-equal-p child (funcall function root))
686 (return root)))))
687 (defun child-root-p (child)
688 (generic-child-root-p child #'root-child))
690 (defun child-original-root-p (child)
691 (generic-child-root-p child #'root-original)))
693 (defun change-root (old-root new-child)
694 (when (and old-root new-child)
695 (setf (root-child old-root) new-child)))
697 (defun find-root (child)
698 (aif (child-original-root-p child)
700 (awhen (find-parent-frame child)
701 (find-root it))))
703 (defun find-child-in-all-root (child)
704 (dolist (root root-list)
705 (when (find-child child (root-child root))
706 (return-from find-child-in-all-root root))))
708 (defun find-current-root ()
709 (root-child (find-root current-child)))
711 (defun exchange-root-geometry (root-1 root-2)
712 (when (and root-1 root-2)
713 (rotatef (root-x root-1) (root-x root-2))
714 (rotatef (root-y root-1) (root-y root-2))
715 (rotatef (root-w root-1) (root-w root-2))
716 (rotatef (root-h root-1) (root-h root-2))))
718 (defun rotate-root-geometry ()
719 (let* ((current (first root-list))
720 (orig-x (root-x current))
721 (orig-y (root-y current))
722 (orig-w (root-w current))
723 (orig-h (root-h current)))
724 (dolist (elem (rest root-list))
725 (setf (root-x current) (root-x elem)
726 (root-y current) (root-y elem)
727 (root-w current) (root-w elem)
728 (root-h current) (root-h elem)
729 current elem))
730 (let ((last (car (last root-list))))
731 (setf (root-x last) orig-x
732 (root-y last) orig-y
733 (root-w last) orig-w
734 (root-h last) orig-h))))
736 (defun anti-rotate-root-geometry ()
737 (setf root-list (nreverse root-list))
738 (rotate-root-geometry)
739 (setf root-list (nreverse root-list)))
741 ;;; Current child functions
742 (defun current-child ()
743 current-child)
745 (defun current-child-setter (value)
746 (when value
747 (awhen (find-root value)
748 (setf (root-current-child it) value))
749 (setf current-child value)))
751 (defmacro with-current-child ((new-child) &body body)
752 "Temporarly change the current child"
753 (let ((old-child (gensym))
754 (ret (gensym)))
755 `(let ((,old-child (current-child)))
756 (setf (current-child) ,new-child)
757 (let ((,ret (multiple-value-list (progn ,@body))))
758 (setf (current-child) ,old-child)
759 (values-list ,ret)))))
761 (defun child-is-a-current-child-p (child)
762 (find child root-list :test #'child-equal-p :key #'root-current-child)))
764 (defsetf current-child current-child-setter)
766 (defun ensure-at-least-one-root ()
767 (unless (get-root-list)
768 (let ((frame (create-frame)))
769 (add-frame frame *root-frame*)
770 (define-as-root frame 0 0 (screen-width) (screen-height))
771 (add-frame (create-frame) frame))))
778 (defun is-in-current-child-p (child)
779 (and (frame-p (current-child))
780 (child-member child (frame-child (current-child)))))
784 (defun fixe-real-size (frame parent)
785 "Fixe real (pixel) coordinates in float coordinates"
786 (when (frame-p frame)
787 (with-slots (x y w h rx ry rw rh) frame
788 (setf x (x-px->fl rx parent)
789 y (y-px->fl ry parent)
790 w (w-px->fl (anti-adj-border-wh rw parent) parent)
791 h (h-px->fl (anti-adj-border-wh rh parent) parent)))))
793 (defun fixe-real-size-current-child ()
794 "Fixe real (pixel) coordinates in float coordinates for children in the current child"
795 (when (frame-p (current-child))
796 (dolist (child (frame-child (current-child)))
797 (fixe-real-size child (current-child)))))
801 ;;; Multiple physical screen helper
802 (defun add-placed-frame-tmp (frame n) ;; For test
803 (add-frame (create-frame :x 0.01 :y 0.01 :w 0.4 :h 0.4) frame)
804 (add-frame (create-frame :x 0.55 :y 0.01 :w 0.4 :h 0.4) frame)
805 (add-frame (create-frame :x 0.03 :y 0.5 :w 0.64 :h 0.44) frame)
806 (when (plusp n)
807 (add-placed-frame-tmp (first (frame-child frame)) (1- n))))
809 (defun parse-xinerama-info (line)
810 (remove nil
811 (mapcar (lambda (string)
812 (parse-integer string :junk-allowed t))
813 (split-string (substitute #\space #\x (substitute #\space #\, line))))))
815 (defun get-connected-heads-size (&optional fake)
816 (labels ((heads-info ()
817 (if (not fake)
818 (do-shell "xdpyinfo -ext XINERAMA")
819 (progn
820 (setf *show-root-frame-p* t)
821 (do-shell "echo ' available colormap entries: 256 per subfield
822 red, green, blue masks: 0xff0000, 0xff00, 0xff
823 significant bits in color specification: 8 bits
825 XINERAMA version 1.1 opcode: 150
826 head #0: 500x300 @ 10,10
827 head #1: 480x300 @ 520,20
828 head #2: 600x250 @ 310,330'")))))
829 (when (xlib:query-extension *display* "XINERAMA")
830 (let ((output (heads-info))
831 (sizes nil))
832 (loop for line = (read-line output nil nil)
833 while line
834 do (when (search " head " line)
835 (destructuring-bind (w h x y)
836 (parse-xinerama-info line)
837 (let ((found
838 (dolist (s sizes)
839 (destructuring-bind (x1 y1 w1 h1) s
840 (when (and (>= x x1)
841 (>= y y1)
842 (<= (+ x w) (+ x1 w1))
843 (<= (+ y h) (+ y1 h1)))
844 (return t))))))
845 (unless found
846 (push (list x y w h) sizes))))))
847 sizes))))
848 ;;'((10 10 500 300) (550 50 400 400) (100 320 400 270))))))
849 ;;'((10 10 500 580) (540 50 470 500))))))
852 (let ((last-sizes nil))
853 (defun reset-last-head-size ()
854 (setf last-sizes nil))
856 (defun place-frames-from-xinerama-infos ()
857 "Place frames according to xdpyinfo/xinerama informations"
858 (let ((sizes (get-connected-heads-size))
859 (width (screen-width))
860 (height (screen-height)))
861 (labels ((update-root-geometry ()
862 (loop for size in sizes
863 for root in (get-root-list)
864 do (destructuring-bind (x y w h) size
865 (setf (root-x root) x
866 (root-y root) y
867 (root-w root) w
868 (root-h root) h)))
869 (setf last-sizes sizes)
870 :update)
871 (create-root-geometry ()
872 (reset-root-list)
873 ;; Add frames in *root-frame* until we get the same number as screen heads
874 (loop while (< (length (frame-child *root-frame*)) (length sizes))
875 do (let ((frame (create-frame)))
876 (add-frame frame *root-frame*)))
877 ;; On the opposite way: remove frames while there is more than screen heads in *root-frame*
878 (when (and sizes (> (length (frame-child *root-frame*)) (length sizes)))
879 (dotimes (i (- (length (frame-child *root-frame*)) (length sizes)))
880 (let ((deleted-child (pop (frame-child *root-frame*))))
881 (typecase deleted-child
882 (xlib:window (push deleted-child (frame-child (first (frame-child *root-frame*)))))
883 (frame (dolist (child (frame-child deleted-child))
884 (push child (frame-child (first (frame-child *root-frame*)))))))
885 (setf (frame-layout (first (frame-child *root-frame*))) 'tile-space-layout
886 (frame-data-slot (first (frame-child *root-frame*)) :tile-layout-keep-position) :yes))))
887 (loop for size in sizes
888 for frame in (frame-child *root-frame*)
889 do (destructuring-bind (x y w h) size
890 (setf (frame-x frame) (float (/ x width))
891 (frame-y frame) (float (/ y height))
892 (frame-w frame) (float (/ w width))
893 (frame-h frame) (float (/ h height)))
894 ;;(add-placed-frame-tmp frame 2) ;; For tests
895 (unless (frame-child frame)
896 (add-frame (create-frame) frame))
897 (define-as-root frame x y w h)))
898 (setf last-sizes sizes)
899 nil))
900 (format t "Screen sizes: ~A~%" sizes)
901 (if (= (length sizes) (length last-sizes))
902 (update-root-geometry)
903 (create-root-geometry))))))
907 (defun finish-configuring-root ()
908 (ensure-at-least-one-root)
909 (setf (current-child) (first (frame-child (first (frame-child *root-frame*))))))
913 (defun get-all-windows (&optional (root *root-frame*))
914 "Return all windows in root and in its children"
915 (let ((acc nil))
916 (with-all-windows (root window)
917 (push window acc))
918 acc))
920 (defun get-all-frame-windows (&optional (root *root-frame*))
921 "Return all frame windows in root and in its children"
922 (let ((acc nil))
923 (with-all-frames (root frame)
924 (push (frame-window frame) acc))
925 acc))
927 (defun get-all-frames (&optional (root *root-frame*))
928 "Return all frame in root and in its children"
929 (let ((acc nil))
930 (with-all-frames (root frame)
931 (push frame acc))
932 acc))
934 (defun get-all-children (&optional (root *root-frame*))
935 "Return a list of all children in root"
936 (let ((acc nil))
937 (with-all-children (root child)
938 (push child acc))
939 acc))
942 (defun get-hidden-windows ()
943 "Return all hiddens windows"
944 (let ((all-windows (get-all-windows))
945 (hidden-windows (remove-if-not #'window-hidden-p
946 (copy-list (xlib:query-tree *root*)))))
947 (set-difference hidden-windows all-windows)))
951 ;;; Current window utilities
952 (defun get-current-window ()
953 (typecase (current-child)
954 (xlib:window (current-child))
955 (frame (frame-selected-child (current-child)))))
957 (defmacro with-current-window (&body body)
958 "Bind 'window' to the current window"
959 `(let ((window (get-current-window)))
960 (when (xlib:window-p window)
961 ,@body)))
963 (defun get-first-window ()
964 (typecase (current-child)
965 (xlib:window (current-child))
966 (frame (or (first (frame-child (current-child)))
967 (current-child)))))
973 (defun display-frame-info (frame)
974 (when (frame-p frame)
975 (let ((dy (+ (xlib:max-char-ascent *default-font*) (xlib:max-char-descent *default-font*))))
976 (with-slots (name number gc window child hidden-children) frame
977 (setf (xlib:gcontext-background gc) (get-color *frame-background*)
978 (xlib:window-background window) (get-color *frame-background*))
979 (clear-pixmap-buffer window gc)
980 (setf (xlib:gcontext-foreground gc) (get-color (if (and (child-root-p frame)
981 (child-equal-p frame (current-child)))
982 *frame-foreground-root* *frame-foreground*)))
983 (xlib:draw-glyphs *pixmap-buffer* gc 5 dy
984 (format nil "Frame: ~A~A"
985 number
986 (if name (format nil " - ~A" name) "")))
987 (let ((pos dy))
988 (when (child-root-p frame)
989 (when *child-selection*
990 (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy)
991 (with-output-to-string (str)
992 (format str " Selection: ")
993 (dolist (child *child-selection*)
994 (typecase child
995 (xlib:window (format str " ~A " (xlib:wm-name child)))
996 (frame (format str " frame:~A[~A] " (frame-number child)
997 (aif (frame-name child) it "")))))))))
998 (dolist (ch child)
999 (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy)
1000 (format nil " ~A" (ensure-printable (child-fullname ch))))))
1001 (copy-pixmap-buffer window gc)
1002 (values t t)))))
1005 (defgeneric rename-child (child name))
1007 (defmethod rename-child ((child frame) name)
1008 (setf (frame-name child) name)
1009 (display-frame-info child))
1011 (defmethod rename-child ((child xlib:window) name)
1012 (setf (xlib:wm-name child) name))
1014 (defmethod rename-child (child name)
1015 (declare (ignore child name)))
1018 (defun get-parent-layout (child parent)
1019 (aif (child-root-p child)
1020 (values (- (root-x it) (child-border-size child)) (- (root-y it) (child-border-size child))
1021 (root-w it) (root-h it))
1022 (if (or (frame-p child) (managed-window-p child parent))
1023 (if (frame-p parent)
1024 (aif (frame-layout parent)
1025 (funcall it child parent)
1026 (no-layout child parent))
1027 (values (- (child-border-size child)) (- (child-border-size child))
1028 (screen-width)
1029 (screen-height)))
1030 (values (x-drawable-x child) (x-drawable-y child)
1031 (x-drawable-width child) (x-drawable-height child)))))
1037 (defgeneric adapt-child-to-parent (child parent))
1039 (defmethod adapt-child-to-parent ((window xlib:window) parent)
1040 (when (managed-window-p window parent)
1041 (multiple-value-bind (nx ny nw nh)
1042 (get-parent-layout window parent)
1043 (setf nw (max nw 1) nh (max nh 1))
1044 (let ((change nil))
1045 (when (or (/= (x-drawable-x window) nx)
1046 (/= (x-drawable-y window) ny))
1047 (setf change :moved))
1048 (when (or (/= (x-drawable-width window) nw)
1049 (/= (x-drawable-height window) nh))
1050 (setf change :resized))
1051 (when change
1052 (xlib:with-state (window)
1053 (setf (x-drawable-x window) nx
1054 (x-drawable-y window) ny
1055 (x-drawable-width window) nw
1056 (x-drawable-height window) nh)))
1057 change))))
1060 (defmethod adapt-child-to-parent ((frame frame) parent)
1061 (declare (ignore parent))
1062 (with-slots (rx ry rw rh window) frame
1063 (let ((change nil))
1064 (when (or (/= (x-drawable-x window) rx)
1065 (/= (x-drawable-y window) ry))
1066 (setf change :moved))
1067 (when (or (/= (x-drawable-width window) rw)
1068 (/= (x-drawable-height window) rh))
1069 (setf change :resized))
1070 (when change
1071 (xlib:with-state (window)
1072 (setf (x-drawable-x window) rx
1073 (x-drawable-y window) ry
1074 (x-drawable-width window) rw
1075 (x-drawable-height window) rh)))
1076 change)))
1078 (defmethod adapt-child-to-parent (child parent)
1079 (declare (ignore child parent))
1080 nil)
1083 (defgeneric set-child-stack-order (window child)
1084 (:documentation "Put window just below child"))
1086 (defmethod set-child-stack-order (window (child xlib:window))
1087 (lower-window window child))
1089 (defmethod set-child-stack-order (window (child frame))
1090 (lower-window window (frame-window child)))
1092 (defmethod set-child-stack-order (window child)
1093 (declare (ignore child))
1094 (unless (maxmin-size-equal-window-in-tree)
1095 (raise-window window)))
1099 (defgeneric show-child (child parent previous))
1101 (defmethod show-child ((frame frame) parent previous)
1102 (declare (ignore parent))
1103 (with-slots (window show-window-p) frame
1104 (if (and show-window-p
1105 (or *show-root-frame-p* (not (child-root-p frame))))
1106 (progn
1107 (map-window window)
1108 (set-child-stack-order window previous)
1109 (display-frame-info frame))
1110 (hide-window window))))
1114 (defun hide-unmanaged-window-p (parent)
1115 (let ((action (frame-data-slot parent :unmanaged-window-action)))
1116 (case action
1117 (:hide t)
1118 (:show nil)
1119 (t *hide-unmanaged-window*))))
1122 (defmethod show-child ((window xlib:window) parent previous)
1123 (if (or (managed-window-p window parent)
1124 (child-equal-p window (current-child))
1125 (not (hide-unmanaged-window-p parent))
1126 (child-is-a-current-child-p parent))
1127 (progn
1128 (map-window window)
1129 (set-child-stack-order window previous))
1130 (hide-window window)))
1132 (defmethod show-child (child parent raise-p)
1133 (declare (ignore child parent raise-p))
1137 (defgeneric hide-child (child))
1139 (defmethod hide-child ((frame frame))
1140 (with-slots (window) frame
1141 (xlib:unmap-window window)))
1143 (defmethod hide-child ((window xlib:window))
1144 (hide-window window))
1146 (defmethod hide-child (child)
1147 (declare (ignore child))
1151 (defgeneric select-child (child selected))
1153 (labels ((get-selected-color (child selected-p)
1154 (get-color (cond ((child-equal-p child (current-child)) *color-selected*)
1155 (selected-p *color-maybe-selected*)
1156 (t *color-unselected*)))))
1157 (defmethod select-child ((frame frame) selected-p)
1158 (when (and (frame-p frame) (frame-window frame))
1159 (setf (xlib:window-border (frame-window frame))
1160 (get-selected-color frame selected-p))))
1162 (defmethod select-child ((window xlib:window) selected-p)
1163 (setf (xlib:window-border window)
1164 (get-selected-color window selected-p)))
1166 (defmethod select-child (child selected)
1167 (declare (ignore child selected))
1168 ()))
1170 (defun select-current-frame (selected)
1171 (select-child (current-child) selected))
1173 (defun unselect-all-frames ()
1174 (with-all-children (*root-frame* child)
1175 (select-child child nil)))
1179 (defun set-focus-to-current-child ()
1180 (labels ((rec (child)
1181 (typecase child
1182 (xlib:window (focus-window child))
1183 (frame (rec (frame-selected-child child))))))
1184 (no-focus)
1185 (rec (current-child))))
1190 (defun adapt-frame-to-parent (frame parent)
1191 (multiple-value-bind (nx ny nw nh)
1192 (get-parent-layout frame parent)
1193 (with-slots (rx ry rw rh window) frame
1194 (setf rx nx ry ny
1195 rw (max nw 1)
1196 rh (max nh 1)))))
1199 (defun adapt-child-to-rect (rect)
1200 (let ((window (typecase (child-rect-child rect)
1201 (xlib:window (when (managed-window-p (child-rect-child rect) (child-rect-parent rect))
1202 (child-rect-child rect)))
1203 (frame (frame-window (child-rect-child rect))))))
1204 (when window
1205 (let ((change (or (/= (x-drawable-x window) (child-rect-x rect))
1206 (/= (x-drawable-y window) (child-rect-y rect))
1207 (/= (x-drawable-width window) (child-rect-w rect))
1208 (/= (x-drawable-height window) (child-rect-h rect)))))
1209 (when change
1210 (setf (x-drawable-width window) (child-rect-w rect)
1211 (x-drawable-height window) (child-rect-h rect)
1212 (x-drawable-x window) (child-rect-x rect)
1213 (x-drawable-y window) (child-rect-y rect)))
1214 change))))
1218 (let ((displayed-child nil))
1219 (defun get-displayed-child ()
1220 displayed-child)
1222 (defun show-all-children (&optional (from-root-frame nil))
1223 "Show all children and hide those not in a root frame"
1224 (declare (ignore from-root-frame))
1225 (let ((geometry-change nil)
1226 (hidden-child nil)
1227 (has-no-leader-list nil))
1228 (labels ((set-has-no-leader-list ()
1229 (let ((window-list nil)
1230 (leader-list nil))
1231 (with-all-windows (*root-frame* win)
1232 (let ((leader (window-leader win)))
1233 (when leader
1234 (when (member leader window-list :test (lambda (x y) (eql x (first y))))
1235 (pushnew leader leader-list))
1236 (push (list leader win) window-list))))
1237 (dolist (leader-win window-list)
1238 (unless (member leader-win leader-list :test (lambda (x y) (eql (first x) y)))
1239 (push (second leader-win) has-no-leader-list)))))
1241 (in-displayed-list (child)
1242 (member child displayed-child :test (lambda (c rect)
1243 (child-equal-p c (child-rect-child rect)))))
1245 (add-in-hidden-list (child)
1246 (pushnew child hidden-child :test #'child-equal-p))
1248 (set-geometry (child parent in-current-root child-current-root-p)
1249 (if (or in-current-root child-current-root-p)
1250 (when (frame-p child)
1251 (adapt-frame-to-parent child (if child-current-root-p nil parent)))
1252 (add-in-hidden-list child)))
1254 (recurse-on-frame-child (child in-current-root child-current-root-p selected-p)
1255 (let ((selected-child (frame-selected-child child)))
1256 (dolist (sub-child (frame-child child))
1257 (rec sub-child child
1258 (and selected-p (child-equal-p sub-child selected-child))
1259 (or in-current-root child-current-root-p)))))
1261 (hidden-child-p (rect)
1262 (when (or (frame-p (child-rect-child rect))
1263 (member (window-type (child-rect-child rect)) *show-hide-policy-type*))
1264 (dolist (r displayed-child)
1265 (when (and (rect-hidden-p r rect)
1266 (or (not (xlib:window-p (child-rect-child r)))
1267 (eq (window-type (child-rect-child r)) :normal)))
1268 (return t)))))
1270 (select-and-display (child parent selected-p)
1271 (multiple-value-bind (nx ny nw nh)
1272 (get-parent-layout child parent)
1273 (let ((rect (make-child-rect :child child :parent parent
1274 :selected-p selected-p
1275 :x nx :y ny :w nw :h nh)))
1276 (if (and *show-hide-policy* (hidden-child-p rect)
1277 (member child has-no-leader-list :test #'child-equal-p))
1278 (add-in-hidden-list child)
1279 (push rect displayed-child)))))
1281 (display-displayed-child ()
1282 (let ((previous nil))
1283 (setf displayed-child (nreverse displayed-child))
1284 (dolist (rect displayed-child)
1285 (when (adapt-child-to-rect rect)
1286 (setf geometry-change t))
1287 (select-child (child-rect-child rect) (child-rect-selected-p rect))
1288 (show-child (child-rect-child rect)
1289 (child-rect-parent rect)
1290 previous)
1291 (setf previous (child-rect-child rect)))))
1293 (rec (child parent selected-p in-current-root)
1294 (let ((child-current-root-p (child-root-p child)))
1295 (unless (in-displayed-list child)
1296 (set-geometry child parent in-current-root child-current-root-p))
1297 (when (frame-p child)
1298 (recurse-on-frame-child child in-current-root child-current-root-p selected-p))
1299 (when (and (or in-current-root child-current-root-p)
1300 (not (in-displayed-list child)))
1301 (select-and-display child parent selected-p)))))
1303 (setf displayed-child nil)
1304 (set-has-no-leader-list)
1305 (rec *root-frame* nil t (child-root-p *root-frame*))
1306 (display-displayed-child)
1307 (dolist (child hidden-child)
1308 (hide-child child))
1309 (set-focus-to-current-child)
1310 (xlib:display-finish-output *display*)
1311 geometry-change))))
1316 (defun hide-all-children (root &optional except)
1317 "Hide all root children"
1318 (when (and (frame-p root) (not (child-equal-p root except)))
1319 (dolist (child (frame-child root))
1320 (hide-all child except))))
1322 (defun hide-all (root &optional except)
1323 "Hide root and all its children"
1324 (unless (child-equal-p root except)
1325 (hide-child root))
1326 (hide-all-children root except))
1332 (defun focus-child (child parent)
1333 "Focus child - Return true if something has change"
1334 (when (and (frame-p parent)
1335 (child-member child (frame-child parent)))
1336 (when (not (child-equal-p child (frame-selected-child parent)))
1337 (with-slots ((parent-child child) selected-pos) parent
1338 (setf parent-child (nth-insert selected-pos child (child-remove child parent-child))))
1339 t)))
1341 (defun focus-child-rec (child parent)
1342 "Focus child and its parents - Return true if something has change"
1343 (let ((change nil))
1344 (labels ((rec (child parent)
1345 (when (focus-child child parent)
1346 (setf change t))
1347 (when parent
1348 (rec parent (find-parent-frame parent)))))
1349 (rec child parent))
1350 change))
1353 (defun set-current-child-generic (child)
1354 (unless (child-equal-p (current-child) child)
1355 (setf (current-child) child)
1358 (defgeneric set-current-child (child parent window-parent))
1360 (defmethod set-current-child ((child xlib:window) parent window-parent)
1361 (set-current-child-generic (if window-parent parent child)))
1363 (defmethod set-current-child ((child frame) parent window-parent)
1364 (declare (ignore parent window-parent))
1365 (set-current-child-generic child))
1367 (defmethod set-current-child (child parent window-parent)
1368 (declare (ignore child parent window-parent))
1372 (defun set-current-root (child parent window-parent)
1373 "Set current root if parent is not in current root"
1374 (let ((root (find-root child)))
1375 (when (and root window-parent
1376 (not (child-root-p child))
1377 (not (find-child parent (root-child root))))
1378 (change-root root parent)
1379 t)))
1381 (defun focus-all-children (child parent &optional (window-parent t))
1382 "Focus child and its parents -
1383 For window: set current child to window or its parent according to window-parent"
1384 (let ((new-focus (focus-child-rec child parent))
1385 (new-current-child (set-current-child child parent window-parent))
1386 (new-root (set-current-root child parent window-parent)))
1387 (or new-focus new-current-child new-root)))
1392 (defun select-next-level ()
1393 "Select the next level in frame"
1394 (select-current-frame :maybe)
1395 (when (frame-p (current-child))
1396 (awhen (frame-selected-child (current-child))
1397 (setf (current-child) it)))
1398 (show-all-children))
1400 (defun select-previous-level ()
1401 "Select the previous level in frame"
1402 (unless (child-root-p (current-child))
1403 (select-current-frame :maybe)
1404 (awhen (find-parent-frame (current-child))
1405 (setf (current-child) it))
1406 (show-all-children)))
1409 (defun enter-frame ()
1410 "Enter in the selected frame - ie make it the root frame"
1411 (let ((root (find-root (current-child))))
1412 (when (and root (not (child-equal-p (root-child root) (current-child))))
1413 (change-root root (current-child)))
1414 (show-all-children t)))
1416 (defun leave-frame ()
1417 "Leave the selected frame - ie make its parent the root frame"
1418 (let ((root (find-root (current-child))))
1419 (unless (or (child-equal-p (root-child root) *root-frame*)
1420 (child-original-root-p (root-child root)))
1421 (awhen (and root (find-parent-frame (root-child root)))
1422 (when (frame-p it)
1423 (change-root root it)))
1424 (show-all-children))))
1427 ;;; Other actions (select-next-child, select-next-brother...) are in
1428 ;;; clfswm-circulate-mode.lisp
1432 (defun frame-lower-child ()
1433 "Lower the child in the current frame"
1434 (when (frame-p (current-child))
1435 (with-slots (child selected-pos) (current-child)
1436 (unless (>= selected-pos (length child))
1437 (when (nth (1+ selected-pos) child)
1438 (rotatef (nth selected-pos child)
1439 (nth (1+ selected-pos) child)))
1440 (incf selected-pos)))
1441 (show-all-children)))
1444 (defun frame-raise-child ()
1445 "Raise the child in the current frame"
1446 (when (frame-p (current-child))
1447 (with-slots (child selected-pos) (current-child)
1448 (unless (< selected-pos 1)
1449 (when (nth (1- selected-pos) child)
1450 (rotatef (nth selected-pos child)
1451 (nth (1- selected-pos) child)))
1452 (decf selected-pos)))
1453 (show-all-children)))
1456 (defun frame-select-next-child ()
1457 "Select the next child in the current frame"
1458 (when (frame-p (current-child))
1459 (with-slots (child selected-pos) (current-child)
1460 (setf selected-pos (mod (1+ selected-pos) (max (length child) 1))))
1461 (show-all-children)))
1464 (defun frame-select-previous-child ()
1465 "Select the previous child in the current frame"
1466 (when (frame-p (current-child))
1467 (with-slots (child selected-pos) (current-child)
1468 (setf selected-pos (mod (1- selected-pos) (max (length child) 1))))
1469 (show-all-children)))
1473 (defun switch-to-root-frame (&key (show-later nil))
1474 "Switch to the root frame"
1475 (let ((root (find-root (current-child))))
1476 (when root
1477 (change-root root (root-original root)))
1478 (unless show-later
1479 (show-all-children t))))
1481 (defun switch-and-select-root-frame (&key (show-later nil))
1482 "Switch and select the root frame"
1483 (let ((root (find-root (current-child))))
1484 (when root
1485 (change-root root (root-original root))
1486 (setf (current-child) (root-original root)))
1487 (unless show-later
1488 (show-all-children t))))
1491 (defun toggle-show-root-frame ()
1492 "Show/Hide the root frame"
1493 (setf *show-root-frame-p* (not *show-root-frame-p*))
1494 (show-all-children))
1498 (defun move-child-to (child frame-dest)
1499 (when (and child (frame-p frame-dest))
1500 (remove-child-in-frame child (find-parent-frame child))
1501 (pushnew child (frame-child frame-dest) :test #'child-equal-p)
1502 (focus-all-children child frame-dest)
1503 (show-all-children t)))
1506 (defun prevent-current-*-equal-child (child)
1507 " Prevent current-root and current-child equal to child"
1508 (if (child-original-root-p child)
1510 (progn
1511 (awhen (child-root-p child)
1512 (change-root it (find-parent-frame child)))
1513 (when (child-equal-p child (current-child))
1514 (awhen (find-root child)
1515 (setf (current-child) (root-child it))))
1516 t)))
1520 (defun remove-child-in-frame (child frame)
1521 "Remove the child in frame"
1522 (when (frame-p frame)
1523 (setf (frame-child frame) (child-remove child (frame-child frame)))))
1525 (defun remove-child-in-frames (child root)
1526 "Remove child in the frame root and in all its children"
1527 (with-all-frames (root frame)
1528 (remove-child-in-frame child frame)))
1531 (defun remove-child-in-all-frames (child)
1532 "Remove child in all frames from *root-frame*"
1533 (when (prevent-current-*-equal-child child)
1534 (remove-child-in-frames child *root-frame*)))
1537 (defun delete-child-in-frames (child root &optional (close-methode 'delete-window))
1538 "Delete child in the frame root and in all its children
1539 Warning:frame window and gc are freeed."
1540 (with-all-frames (root frame)
1541 (remove-child-in-frame child frame)
1542 (unless (find-frame-window (frame-window frame))
1543 (awhen (frame-gc frame) (xlib:free-gcontext it) (setf it nil))
1544 (awhen (frame-window frame) (xlib:destroy-window it) (setf it nil))))
1545 (when (xlib:window-p child)
1546 (funcall close-methode child)
1547 (netwm-remove-in-client-list child)))
1551 (defun delete-child-in-all-frames (child &optional (close-methode 'delete-window))
1552 "Delete child in all frames from *root-frame*"
1553 (when (prevent-current-*-equal-child child)
1554 (delete-child-in-frames child *root-frame* close-methode)))
1556 (defun delete-child-and-children-in-frames (child root &optional (close-methode 'delete-window))
1557 "Delete child and its children in the frame root and in all its children
1558 Warning:frame window and gc are freeed."
1559 (when (and (frame-p child) (frame-child child))
1560 (dolist (ch (frame-child child))
1561 (delete-child-and-children-in-frames ch root close-methode)))
1562 (delete-child-in-frames child root close-methode))
1564 (defun delete-child-and-children-in-all-frames (child &optional (close-methode 'delete-window))
1565 "Delete child and its children in all frames from *root-frame*"
1566 (when (prevent-current-*-equal-child child)
1567 (when (frame-p child)
1568 (delete-child-and-children-in-frames child *root-frame* close-methode))
1569 (when (xlib:window-p child)
1570 (funcall close-methode child))
1571 (when (frame-p child)
1572 (awhen (frame-gc child) (xlib:free-gcontext it) (setf it nil))
1573 (awhen (frame-window child) (xlib:destroy-window it) (setf it nil)))))
1576 (defun clean-windows-in-all-frames ()
1577 "Remove all xlib:windows present in *root-frame* and not in the xlib tree"
1578 (let ((x-tree (xlib:query-tree *root*)))
1579 (with-all-frames (*root-frame* frame)
1580 (dolist (child (frame-child frame))
1581 (when (xlib:window-p child)
1582 (unless (member child x-tree :test #'xlib:window-equal)
1583 (when (prevent-current-*-equal-child child)
1584 (setf (frame-child frame)
1585 (child-remove child (frame-child frame))))))))))
1589 (defun do-all-frames-nw-hook (window)
1590 "Call nw-hook of each frame."
1591 (catch 'nw-hook-loop
1592 (let ((found nil))
1593 (with-all-frames (*root-frame* frame)
1594 (awhen (frame-nw-hook frame)
1595 (setf found (call-hook it frame window))))
1596 found)))
1600 (defun process-new-window (window)
1601 "When a new window is created (or when we are scanning initial
1602 windows), this function dresses the window up and gets it ready to be
1603 managed."
1604 (setf (xlib:window-event-mask window) *window-events*)
1605 (set-window-state window +normal-state+)
1606 (setf (x-drawable-border-width window) (case (window-type window)
1607 (:normal *border-size*)
1608 (:maxsize 0)
1609 (:transient *border-size*)
1610 (:dialog *border-size*)
1611 (t *border-size*)))
1612 (grab-all-buttons window)
1613 (unless (never-managed-window-p window)
1614 (unless (do-all-frames-nw-hook window)
1615 (call-hook *default-nw-hook* *root-frame* window)))
1616 (netwm-add-in-client-list window))
1621 (defun with-all-mapped-windows (screen fun)
1622 (let ((all-windows (get-all-windows)))
1623 (dolist (win (xlib:query-tree (xlib:screen-root screen)))
1624 (unless (child-member win all-windows)
1625 (let ((map-state (xlib:window-map-state win))
1626 (wm-state (window-state win)))
1627 (unless (or (eql (xlib:window-override-redirect win) :on)
1628 (eql win *no-focus-window*)
1629 (is-notify-window-p win))
1630 (when (or (eql map-state :viewable)
1631 (eql wm-state +iconic-state+))
1632 (funcall fun win))))))))
1634 (defun store-root-background ()
1635 (with-all-mapped-windows *screen* #'hide-window)
1636 (setf *background-image* (xlib:create-pixmap :width (screen-width)
1637 :height (screen-height)
1638 :depth (xlib:screen-root-depth *screen*)
1639 :drawable *root*)
1640 *background-gc* (xlib:create-gcontext :drawable *background-image*
1641 :foreground (get-color *frame-foreground*)
1642 :background (get-color *frame-background*)
1643 :font *default-font*
1644 :line-style :solid))
1645 (xlib:copy-area *root* *background-gc*
1646 0 0 (screen-width) (screen-height)
1647 *background-image* 0 0)
1648 (with-all-mapped-windows *screen* #'unhide-window))
1653 (defun hide-existing-windows (screen)
1654 "Hide all existing windows in screen"
1655 (dolist (win (xlib:query-tree (xlib:screen-root screen)))
1656 (hide-window win)))
1660 (defun process-existing-windows (screen)
1661 "Windows present when clfswm starts up must be absorbed by clfswm."
1662 (setf *in-process-existing-windows* t)
1663 (let ((id-list nil)
1664 (all-windows (get-all-windows))
1665 (all-frame-windows (get-all-frame-windows)))
1666 (dolist (win (xlib:query-tree (xlib:screen-root screen)))
1667 (unless (or (child-member win all-windows)
1668 (child-member win all-frame-windows)
1669 (child-equal-p win *no-focus-window*)
1670 (child-equal-p win *sm-window*))
1671 (let ((map-state (xlib:window-map-state win))
1672 (wm-state (window-state win)))
1673 (unless (or (eql (xlib:window-override-redirect win) :on)
1674 (eql win *no-focus-window*)
1675 (is-notify-window-p win)
1676 (never-managed-window-p win))
1677 (when (or (eql map-state :viewable)
1678 (eql wm-state +iconic-state+))
1679 (format t "Processing ~S: type=~A ~S~%" (xlib:wm-name win) (window-type win) win)
1680 (unhide-window win)
1681 (process-new-window win)
1682 (map-window win)
1683 (raise-window win)
1684 (pushnew (xlib:window-id win) id-list))))))
1685 (netwm-set-client-list id-list))
1686 (setf *in-process-existing-windows* nil))
1689 ;;; Child order manipulation functions
1690 (defun put-child-on-top (child parent)
1691 "Put the child on top of its parent children"
1692 (when (frame-p parent)
1693 (setf (frame-child parent) (cons child (child-remove child (frame-child parent)))
1694 (frame-selected-pos parent) 0)))
1696 (defun put-child-on-bottom (child parent)
1697 "Put the child at the bottom of its parent children"
1698 (when (frame-p parent)
1699 (setf (frame-child parent) (append (child-remove child (frame-child parent)) (list child))
1700 (frame-selected-pos parent) 0)))
1703 (let ((last-child nil))
1704 (defun manage-focus (window root-x root-y)
1705 (case (if (frame-p (current-child))
1706 (frame-focus-policy (current-child))
1707 *default-focus-policy*)
1708 (:sloppy (focus-window window))
1709 (:sloppy-strict (when (and (frame-p (current-child))
1710 (child-member window (frame-child (current-child))))
1711 (focus-window window)))
1712 (:sloppy-select (let* ((child (find-child-under-mouse root-x root-y))
1713 (parent (find-parent-frame child)))
1714 (unless (or (child-root-p child)
1715 (child-equal-p (typecase child
1716 (xlib:window parent)
1717 (t child))
1718 (current-child)))
1719 (focus-all-children child parent)
1720 (show-all-children))))
1721 (:sloppy-select-window (let* ((child (find-child-under-mouse root-x root-y))
1722 (parent (find-parent-frame child))
1723 (need-warp-pointer (not (or (frame-p child)
1724 (child-equal-p child (frame-selected-child parent))))))
1725 (unless (or (child-root-p child)
1726 (child-equal-p child last-child))
1727 (setf last-child child)
1728 (when (focus-all-children child parent)
1729 (show-all-children)
1730 (when (and need-warp-pointer
1731 (not (eql (frame-data-slot (current-child) :tile-layout-keep-position)
1732 :yes)))
1733 (typecase child
1734 (xlib:window (xlib:warp-pointer *root*
1735 (truncate (+ (x-drawable-x child)
1736 (/ (x-drawable-width child) 2)))
1737 (truncate (+ (x-drawable-y child)
1738 (/ (x-drawable-height child) 2)))))
1739 (frame (xlib:warp-pointer *root*
1740 (+ (frame-rx child) 10)
1741 (+ (frame-ry child) 10))))))))))))
1745 ;;; Dumping/restoring frame tree functions
1746 (defun print-frame-tree (root &optional (disp-fun #'child-fullname))
1747 (labels ((rec (child space)
1748 (print-space space)
1749 (format t "~A~%" (funcall disp-fun child))
1750 (when (frame-p child)
1751 (dolist (c (reverse (frame-child child)))
1752 (rec c (+ space 2))))))
1753 (rec root 0)))
1755 (defmethod print-object ((frame frame) stream)
1756 (format stream "~A - ~F ~F ~F ~F ~A ~A ~A ~X ~X ~A ~A ~A ~A"
1757 (child-fullname frame)
1758 (frame-x frame) (frame-y frame) (frame-w frame) (frame-h frame)
1759 (frame-layout frame) (frame-nw-hook frame)
1760 (frame-managed-type frame)
1761 (frame-forced-managed-window frame)
1762 (frame-forced-unmanaged-window frame)
1763 (frame-show-window-p frame)
1764 (frame-hidden-children frame)
1765 (frame-selected-pos frame)
1766 (frame-focus-policy frame)
1767 ;;(frame-data frame))
1771 (defun window->xid (window)
1772 (when (xlib:window-p window)
1773 (xlib:window-id window)))
1775 (defun xid->window (xid)
1776 (dolist (win (xlib:query-tree *root*))
1777 (when (equal xid (xlib:window-id win))
1778 (return-from xid->window win))))
1782 (defun copy-frame (frame &optional (window-fun #'window->xid))
1783 (labels ((handle-window-list (list)
1784 (loop for win in list
1785 collect (funcall window-fun win))))
1786 (with-slots (name number x y w h layout nw-hook managed-type
1787 forced-managed-window forced-unmanaged-window
1788 show-window-p hidden-children selected-pos
1789 focus-policy data)
1790 frame
1791 (make-instance 'frame :name name :number number
1792 :x x :y y :w w :h h
1793 :layout layout :nw-hook nw-hook
1794 :managed-type (if (consp managed-type)
1795 (copy-list managed-type)
1796 managed-type)
1797 :forced-managed-window (handle-window-list forced-managed-window)
1798 :forced-unmanaged-window (handle-window-list forced-unmanaged-window)
1799 :show-window-p show-window-p
1800 :hidden-children (handle-window-list hidden-children)
1801 :selected-pos selected-pos
1802 :focus-policy focus-policy
1803 :data (copy-tree data)))))
1805 (defun dump-frame-tree (root &optional (window-fun #'window->xid))
1806 "Return a tree of frames."
1807 (let ((new-root (copy-frame root window-fun)))
1808 (labels ((store (from root)
1809 (when (frame-p from)
1810 (dolist (c (reverse (frame-child from)))
1811 (push (if (frame-p c)
1812 (let ((new-root (copy-frame c window-fun)))
1813 (store c new-root)
1814 new-root)
1815 (funcall window-fun c))
1816 (frame-child root))))))
1817 (store root new-root)
1818 new-root)))
1820 (defun test-dump-frame-tree ()
1821 (let ((store (dump-frame-tree *root-frame*)))
1822 (print-frame-tree store
1823 #'(lambda (x)
1824 (format nil "~A" x)))
1825 (format t "~&--------------------------------------------------~2%")
1826 (print-frame-tree (dump-frame-tree store #'xid->window)
1827 #'(lambda (x)
1828 (format nil "~A" (if (frame-p x) x (child-fullname x)))))))