clfswm-internal.lisp 62.7 KB
Newer Older
1
;;; --------------------------------------------------------------------------
Philippe Brochard's avatar
Philippe Brochard committed
2
3
4
5
6
7
;;; CLFSWM - FullScreen Window Manager
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Main functions
;;; --------------------------------------------------------------------------
;;;
Philippe Brochard's avatar
Philippe Brochard committed
8
;;; (C) 2005-2013 Philippe Brochard <pbrochard@common-lisp.net>
Philippe Brochard's avatar
Philippe Brochard committed
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;;;
;;; --------------------------------------------------------------------------

(in-package :clfswm)

28
29
30
31
32
33
34
35
36
(defgeneric child-border-size (child))

(defmethod child-border-size ((child frame))
  (x-drawable-border-width (frame-window child)))

(defmethod child-border-size ((child xlib:window))
  (x-drawable-border-width child))

(defmethod child-border-size (child)
37
  (declare (ignore child))
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
  0)

(defgeneric set-child-border-size (child value))

(defmethod set-child-border-size ((child frame) value)
  (setf (x-drawable-border-width (frame-window child)) value))

(defmethod set-child-border-size ((child xlib:window) value)
  (setf (x-drawable-border-width child) value))

(defmethod set-child-border-size (child value)
  (declare (ignore child value)))

(defsetf child-border-size set-child-border-size)



Philippe Brochard's avatar
Philippe Brochard committed
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
;;; Conversion functions
;;; Float -> Pixel conversion
(defun x-fl->px (x parent)
  "Convert float X coordinate to pixel"
  (round (+ (* x (frame-rw parent)) (frame-rx parent))))

(defun y-fl->px (y parent)
  "Convert float Y coordinate to pixel"
  (round (+ (* y (frame-rh parent)) (frame-ry parent))))

(defun w-fl->px (w parent)
  "Convert float Width coordinate to pixel"
  (round (* w (frame-rw parent))))

(defun h-fl->px (h parent)
  "Convert float Height coordinate to pixel"
  (round (* h (frame-rh parent))))

;;; Pixel -> Float conversion
(defun x-px->fl (x parent)
  "Convert pixel X coordinate to float"
76
  (/ (- x (frame-rx parent) (child-border-size parent)) (frame-rw parent)))
Philippe Brochard's avatar
Philippe Brochard committed
77
78
79

(defun y-px->fl (y parent)
  "Convert pixel Y coordinate to float"
80
  (/ (- y (frame-ry parent) (child-border-size parent)) (frame-rh parent)))
Philippe Brochard's avatar
Philippe Brochard committed
81
82
83
84
85
86
87
88
89
90
91

(defun w-px->fl (w parent)
  "Convert pixel Width coordinate to float"
  (/ w (frame-rw parent)))

(defun h-px->fl (h parent)
  "Convert pixel Height coordinate to float"
  (/ h (frame-rh parent)))



92
93
(defun rect-hidden-p (rect1 rect2)
  "Return T if child-rect1 hide child-rect2"
94
95
96
  (and *show-hide-policy*
       (funcall *show-hide-policy* (child-rect-x rect1) (child-rect-x rect2))
       (funcall *show-hide-policy* (child-rect-y rect1) (child-rect-y rect2))
97
98
99
100
       (funcall *show-hide-policy* (+ (child-rect-x rect2) (child-rect-w rect2))
                (+ (child-rect-x rect1) (child-rect-w rect1)))
       (funcall *show-hide-policy* (+ (child-rect-y rect2) (child-rect-h rect2))
                (+ (child-rect-y rect1) (child-rect-h rect1)))))
101
102
103



Philippe Brochard's avatar
Philippe Brochard committed
104
105
106
107
108
109
110
111
112
113
(defgeneric frame-p (frame))
(defmethod frame-p ((frame frame))
  (declare (ignore frame))
  t)
(defmethod frame-p (frame)
  (declare (ignore frame))
  nil)



114
;;; in-*: Find if point (x,y) is in frame, window or child
115
116
117
118
(defun in-rect (x y xr yr wr hr)
  (and (<= xr x (+ xr wr))
       (<= yr y (+ yr hr))))

119
120
(defun in-frame (frame x y)
  (and (frame-p frame)
121
       (in-rect x y (frame-rx frame) (frame-ry frame) (frame-rw frame) (frame-rh frame))))
122
123
124

(defun in-window (window x y)
  (and (xlib:window-p window)
125
126
127
       (in-rect x y
                (x-drawable-x window) (x-drawable-y window)
                (x-drawable-width window) (x-drawable-height window))))
128

129

130
131
132
133
134
135
136
137
138
139
140
(defgeneric in-child (child x y))

(defmethod in-child ((child frame) x y)
  (in-frame child x y))
(defmethod in-child ((child xlib:window) x y)
  (in-window child x y))
(defmethod in-child (child x y)
  (declare (ignore child x y))
  nil)


141
142
143
144
145
146
147
148
149
150
151
152
153


(defun frame-selected-child (frame)
  (when (frame-p frame)
    (with-slots (child selected-pos) frame
      (let ((len (length child)))
	(cond ((minusp selected-pos) (setf selected-pos 0))
	      ((>= selected-pos len) (setf selected-pos (max (1- len) 0)))))
      (nth selected-pos child))))




154
155
156
157
158
159
160
161
162
163
164
165
166
167

(defgeneric child-equal-p (child-1 child-2))

(defmethod child-equal-p ((child-1 xlib:window) (child-2 xlib:window))
  (xlib:window-equal child-1 child-2))

(defmethod child-equal-p ((child-1 frame) (child-2 frame))
  (equal child-1 child-2))

(defmethod child-equal-p (child-1 child-2)
  (declare (ignore child-1 child-2))
  nil)


168
169


170
(declaim (inline child-member child-remove child-position))
171
172
173
174
175
176
177

(defun child-member (child list)
  (member child list :test #'child-equal-p))

(defun child-remove (child list)
  (remove child list :test #'child-equal-p))

178
179
(defun child-position (child list)
  (position child list :test #'child-equal-p))
180
181
182



Philippe Brochard's avatar
Philippe Brochard committed
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
;;; Frame data manipulation functions
(defun frame-data-slot (frame slot)
  "Return the value associated to data slot"
  (when (frame-p frame)
    (second (assoc slot (frame-data frame)))))

(defun set-frame-data-slot (frame slot value)
  "Set the value associated to data slot"
  (when (frame-p frame)
    (with-slots (data) frame
      (setf data (remove (assoc slot data) data))
      (push (list slot value) data))
    value))

(defsetf frame-data-slot set-frame-data-slot)


200
201
202
203
204
205
206
207
(defun remove-frame-data-slot (frame slot)
  "Remove a slot in frame data slots"
  (when (frame-p frame)
    (with-slots (data) frame
      (setf data (remove (assoc slot data) data)))))



Philippe Brochard's avatar
Philippe Brochard committed
208
209
(defun managed-window-p (window frame)
  "Return t only if window is managed by frame"
210
211
212
  (if (frame-p frame)
      (with-slots ((managed forced-managed-window)
		   (unmanaged forced-unmanaged-window)) frame
213
214
	(and (xlib:window-p window)
	     (not (child-member window unmanaged))
215
216
217
218
219
	     (not (member (xlib:wm-name window) unmanaged :test #'string-equal-p))
	     (or (member :all (frame-managed-type frame))
		 (member (window-type window) (frame-managed-type frame))
		 (child-member window managed)
		 (member (xlib:wm-name window) managed :test #'string-equal-p))))
220
      t))
Philippe Brochard's avatar
Philippe Brochard committed
221
222


223
224
225
(defun add-in-never-managed-window-list (value)
  (pushnew value *never-managed-window-list* :test #'equal))

226
(defun never-managed-window-p (window)
227
228
  (when (xlib:window-p window)
    (dolist (type *never-managed-window-list*)
229
230
231
      (when (funcall (first type) window)
	(return (values t (second type)))))))

232

233
234
235
236
237
(defun never-managed-window-and-handled-p (window)
  (multiple-value-bind (never-managed handle)
      (never-managed-window-p window)
    (and never-managed handle)))

Philippe Brochard's avatar
Philippe Brochard committed
238
239
240
241

(defgeneric child-name (child))

(defmethod child-name ((child xlib:window))
242
  (ensure-printable (xlib:wm-name child)))
Philippe Brochard's avatar
Philippe Brochard committed
243
244
245
246
247
248
249
250
251

(defmethod child-name ((child frame))
  (frame-name child))

(defmethod child-name (child)
  (declare (ignore child))
  "???")


252
253
254
(defgeneric set-child-name (child name))

(defmethod set-child-name ((child xlib:window) name)
255
  (setf (xlib:wm-name child) (ensure-printable name)))
256
257

(defmethod set-child-name ((child frame) name)
258
  (setf (frame-name child) (ensure-printable name)))
259
260
261
262
263
264
265
266
267

(defmethod set-child-name (child name)
  (declare (ignore child name)))

(defsetf child-name set-child-name)




Philippe Brochard's avatar
Philippe Brochard committed
268
269
270
(defgeneric child-fullname (child))

(defmethod child-fullname ((child xlib:window))
271
  (format nil "~A (~A)" (or (xlib:wm-name child) "?") (or (xlib:get-wm-class child) "?")))
Philippe Brochard's avatar
Philippe Brochard committed
272
273

(defmethod child-fullname ((child frame))
274
275
276
  (aif (frame-name child)
       (format nil "~A (Frame ~A)" it (frame-number child))
       (format nil "Frame ~A" (frame-number child))))
Philippe Brochard's avatar
Philippe Brochard committed
277
278
279
280
281
282

(defmethod child-fullname (child)
  (declare (ignore child))
  "???")


283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
(defgeneric child-transparency (child))

(defmethod child-transparency ((child xlib:window))
  (window-transparency child))

(defmethod child-transparency ((child frame))
  (window-transparency (frame-window child)))

(defmethod child-transparency (child)
  (declare (ignore child))
  1)

(defgeneric set-child-transparency (child value))

(defmethod set-child-transparency ((child xlib:window) value)
  (setf (window-transparency child) value))

(defmethod set-child-transparency ((child frame) value)
  (setf (window-transparency (frame-window child)) value))

(defmethod set-child-transparency (child value)
  (declare (ignore child value)))

(defsetf child-transparency set-child-transparency)



310
311
(defgeneric child-x (child))
(defmethod child-x ((child xlib:window))
312
  (x-drawable-x child))
313
314
315
316
317
(defmethod child-x ((child frame))
  (frame-rx child))

(defgeneric child-y (child))
(defmethod child-y ((child xlib:window))
318
  (x-drawable-y child))
319
320
321
322
323
(defmethod child-y ((child frame))
  (frame-ry child))

(defgeneric child-width (child))
(defmethod child-width ((child xlib:window))
324
  (x-drawable-width child))
325
326
327
328
329
(defmethod child-width ((child frame))
  (frame-rw child))

(defgeneric child-height (child))
(defmethod child-height ((child xlib:window))
330
  (x-drawable-height child))
331
332
333
(defmethod child-height ((child frame))
  (frame-rh child))

334
335
(defgeneric child-x2 (child))
(defmethod child-x2 ((child xlib:window))
336
  (+ (x-drawable-x child) (x-drawable-width child)))
337
338
339
340
341
(defmethod child-x2 ((child frame))
  (+ (frame-rx child) (frame-rw child)))

(defgeneric child-y2 (child))
(defmethod child-y2 ((child xlib:window))
342
  (+ (x-drawable-y child) (x-drawable-height child)))
343
344
345
346
347
348
349
350
(defmethod child-y2 ((child frame))
  (+ (frame-ry child) (frame-rh child)))



(defgeneric child-center (child))

(defmethod child-center ((child xlib:window))
351
352
  (values (+ (x-drawable-x child) (/ (x-drawable-width child) 2))
          (+ (x-drawable-y child) (/ (x-drawable-height child) 2))))
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370

(defmethod child-center ((child frame))
  (values (+ (frame-rx child) (/ (frame-rw child) 2))
          (+ (frame-ry child) (/ (frame-rh child) 2))))

(defun child-distance (child1 child2)
  (multiple-value-bind (x1 y1) (child-center child1)
    (multiple-value-bind (x2 y2) (child-center child2)
      (values (+ (abs (- x2 x1)) (abs (- y2 y1)))
              (- x2 x1)
              (- y2 y1)))))

(defun middle-child-x (child)
  (+ (child-x child) (/ (child-width child) 2)))

(defun middle-child-y (child)
  (+ (child-y child) (/ (child-height child) 2)))

371
372
373
374
375
(declaim (inline adj-border-xy adj-border-wh))
(defgeneric adj-border-xy (value child))
(defgeneric adj-border-wh (value child))

(defmethod adj-border-xy (v (child xlib:window))
376
  (+ v (x-drawable-border-width child)))
377
378

(defmethod adj-border-xy (v (child frame))
379
  (+ v (x-drawable-border-width (frame-window child))))
380
381

(defmethod adj-border-wh (v (child xlib:window))
382
  (- v (* (x-drawable-border-width child) 2)))
383
384

(defmethod adj-border-wh (v (child frame))
385
  (- v (* (x-drawable-border-width (frame-window child)) 2)))
386
387
388
389
390
391
392


(declaim (inline anti-adj-border-xy anti-adj-border-wh))
(defgeneric anti-adj-border-xy (value child))
(defgeneric anti-adj-border-wh (value child))

(defmethod anti-adj-border-xy (v (child xlib:window))
393
  (- v (x-drawable-border-width child)))
394
395

(defmethod anti-adj-border-xy (v (child frame))
396
  (- v (x-drawable-border-width (frame-window child))))
397
398

(defmethod anti-adj-border-wh (v (child xlib:window))
399
  (+ v (* (x-drawable-border-width child) 2)))
400
401

(defmethod anti-adj-border-wh (v (child frame))
402
  (+ v (* (x-drawable-border-width (frame-window child)) 2)))
403

404
405
406



407
408
409
410
(defmacro with-focus-window ((window) &body body)
  `(let ((,window (xlib:input-focus *display*)))
     (when (and ,window (not (xlib:window-equal ,window *no-focus-window*)))
       ,@body)))
Philippe Brochard's avatar
Philippe Brochard committed
411
412
413
414
415
416
417



;; (with-all-children (*root-frame* child) (typecase child (xlib:window (print child)) (frame (print (frame-number child)))))
(defmacro with-all-children ((root child) &body body)
  (let ((rec (gensym))
	(sub-child (gensym)))
418
419
420
421
422
423
424
    `(block nil
       (labels ((,rec (,child)
		  ,@body
		  (when (frame-p ,child)
		    (dolist (,sub-child (reverse (frame-child ,child)))
		      (,rec ,sub-child)))))
	 (,rec ,root)))))
Philippe Brochard's avatar
Philippe Brochard committed
425
426


427
428
429
430
;; (with-all-children (*root-frame* child) (typecase child (xlib:window (print child)) (frame (print (frame-number child)))))
(defmacro with-all-children-reversed ((root child) &body body)
  (let ((rec (gensym))
	(sub-child (gensym)))
431
432
433
434
435
436
437
    `(block nil
       (labels ((,rec (,child)
		  ,@body
		  (when (frame-p ,child)
		    (dolist (,sub-child (frame-child ,child))
		      (,rec ,sub-child)))))
	 (,rec ,root)))))
438
439


440
441
442



Philippe Brochard's avatar
Philippe Brochard committed
443
444
445
446
;; (with-all-frames (*root-frame* frame) (print (frame-number frame)))
(defmacro with-all-frames ((root frame) &body body)
  (let ((rec (gensym))
	(child (gensym)))
447
448
449
450
451
452
453
    `(block nil
       (labels ((,rec (,frame)
		  (when (frame-p ,frame)
		    ,@body
		    (dolist (,child (reverse (frame-child ,frame)))
		      (,rec ,child)))))
	 (,rec ,root)))))
Philippe Brochard's avatar
Philippe Brochard committed
454
455
456
457
458
459


;; (with-all-windows (*root-frame* window) (print window))
(defmacro with-all-windows ((root window) &body body)
  (let ((rec (gensym))
	(child (gensym)))
460
461
462
463
464
465
466
467
    `(block nil
       (labels ((,rec (,window)
		  (when (xlib:window-p ,window)
		    ,@body)
		  (when (frame-p ,window)
		    (dolist (,child (reverse (frame-child ,window)))
		      (,rec ,child)))))
	 (,rec ,root)))))
Philippe Brochard's avatar
Philippe Brochard committed
468
469
470
471
472
473
474



;; (with-all-frames-windows (*root-frame* child) (print child) (print (frame-number child)))
(defmacro with-all-windows-frames ((root child) body-window body-frame)
  (let ((rec (gensym))
	(sub-child (gensym)))
475
476
477
478
479
480
481
482
    `(block nil
       (labels ((,rec (,child)
		  (typecase ,child
		    (xlib:window ,body-window)
		    (frame ,body-frame
			   (dolist (,sub-child (reverse (frame-child ,child)))
			     (,rec ,sub-child))))))
	 (,rec ,root)))))
Philippe Brochard's avatar
Philippe Brochard committed
483

484
485
486
(defmacro with-all-windows-frames-and-parent ((root child parent) body-window body-frame)
  (let ((rec (gensym))
	(sub-child (gensym)))
487
488
489
490
491
492
493
494
    `(block nil
       (labels ((,rec (,child ,parent)
		  (typecase ,child
		    (xlib:window ,body-window)
		    (frame ,body-frame
			   (dolist (,sub-child (reverse (frame-child ,child)))
			     (,rec ,sub-child ,child))))))
	 (,rec ,root nil)))))
495

Philippe Brochard's avatar
Philippe Brochard committed
496
497


498

499
(defun create-frame-window ()
500
501
502
503
504
505
506
507
508
509
510
511
  (let ((win (xlib:create-window :parent *root*
                                 :x 0
                                 :y 0
                                 :width 200
                                 :height 200
                                 :background (get-color *frame-background*)
                                 :colormap (xlib:screen-default-colormap *screen*)
                                 :border-width *border-size*
                                 :border (get-color *color-selected*)
                                 :event-mask '(:exposure :button-press :button-release :pointer-motion :enter-window))))
    (setf (window-transparency win) *frame-transparency*)
    win))
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546

(defun create-frame-gc (window)
  (xlib:create-gcontext :drawable window
                        :foreground (get-color *frame-foreground*)
                        :background (get-color *frame-background*)
                        :font *default-font*
                        :line-style :solid))


(defun destroy-all-frames-window ()
  (with-all-frames (*root-frame* frame)
    (when (frame-gc frame)
      (xlib:free-gcontext (frame-gc frame))
      (setf (frame-gc frame) nil))
    (when (frame-window frame)
      (xlib:destroy-window (frame-window frame))
      (setf (frame-window frame) nil))))

(defun create-all-frames-window ()
  (with-all-frames (*root-frame* frame)
    (unless (frame-window frame)
      (setf (frame-window frame) (create-frame-window)))
    (unless (frame-gc frame)
      (setf (frame-gc frame) (create-frame-gc (frame-window frame)))))
  (with-all-frames (*root-frame* frame)
    (dolist (child (frame-child frame))
      (handler-case
          (dbg (child-fullname child))
        (error (c)
          (setf (frame-child frame) (remove child (frame-child frame) :test #'child-equal-p))
          (dbg c child))))))




Philippe Brochard's avatar
Philippe Brochard committed
547
548
549
550
551
552
553
554
(defun frame-find-free-number ()
  (let ((all-numbers nil))
    (with-all-frames (*root-frame* frame)
      (pushnew (frame-number frame) all-numbers))
    (find-free-number all-numbers)))


(defun create-frame (&rest args &key (number (frame-find-free-number)) &allow-other-keys)
555
556
  (let* ((window (create-frame-window))
	 (gc (create-frame-gc window)))
Philippe Brochard's avatar
Philippe Brochard committed
557
558
559
560
561
562
563
564
565
566
    (apply #'make-instance 'frame :number number :window window :gc gc args)))


(defun add-frame (frame parent)
  (push frame (frame-child parent))
  frame)


(defun place-frame (frame parent prx pry prw prh)
  "Place a frame from real (pixel) coordinates"
567
568
  (when (and (frame-p frame) (frame-p parent))
    (with-slots (window x y w h) frame
569
570
571
572
      (setf (x-drawable-x window) prx
	    (x-drawable-y window) pry
	    (x-drawable-width window) prw
	    (x-drawable-height window) prh
573
574
575
	    x (x-px->fl prx parent)
	    y (y-px->fl pry parent)
	    w (w-px->fl prw parent)
576
577
	    h (h-px->fl prh parent))
      (xlib:display-finish-output *display*))))
Philippe Brochard's avatar
Philippe Brochard committed
578
579
580
581
582
583



(defun find-child (to-find root)
  "Find to-find in root or in its children"
  (with-all-children (root child)
584
    (when (child-equal-p child to-find)
Philippe Brochard's avatar
Philippe Brochard committed
585
586
587
588
      (return-from find-child t))))



589
590
591
592
593
594
595
596
597
(defmacro with-find-in-all-frames (test &optional return-value)
  `(let (ret)
     (block return-block
       (with-all-frames (root frame)
	 (when ,test
	   (if first-foundp
	       (return-from return-block (or ,return-value frame))
	       (setf ret frame))))
       (or ,return-value ret))))
598

599
600
601
(defun find-parent-frame  (to-find &optional (root *root-frame*) first-foundp)
  "Return the parent frame of to-find"
  (with-find-in-all-frames
602
      (child-member to-find (frame-child frame))))
Philippe Brochard's avatar
Philippe Brochard committed
603

604
(defun find-frame-window (window &optional (root *root-frame*) first-foundp)
Philippe Brochard's avatar
Philippe Brochard committed
605
  "Return the frame with the window window"
606
607
  (with-find-in-all-frames
      (xlib:window-equal window (frame-window frame))))
Philippe Brochard's avatar
Philippe Brochard committed
608

609
(defun find-frame-by-name (name &optional (root *root-frame*) first-foundp)
Philippe Brochard's avatar
Philippe Brochard committed
610
611
  "Find a frame from its name"
  (when name
612
613
    (with-find-in-all-frames
	(string-equal name (frame-name frame)))))
Philippe Brochard's avatar
Philippe Brochard committed
614

615
(defun find-frame-by-number (number &optional (root *root-frame*) first-foundp)
Philippe Brochard's avatar
Philippe Brochard committed
616
617
  "Find a frame from its number"
  (when (numberp number)
618
619
    (with-find-in-all-frames
	(= number (frame-number frame)))))
Philippe Brochard's avatar
Philippe Brochard committed
620
621


622
623
624
(defun find-child-in-parent (child base)
  "Return t if child is in base or in its parents"
  (labels ((rec (base)
625
	     (when (child-equal-p child base)
626
627
628
629
630
631
	       (return-from find-child-in-parent t))
	     (let ((parent (find-parent-frame base)))
	       (when parent
		 (rec parent)))))
    (rec base)))

632
;;; Multiple roots support (replace the old *current-root* variable)
633
634
(let ((root-list nil)
      (current-child nil))
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
  (defun get-root-list ()
    root-list)

  (let ((save-root-list nil))
    (defun save-root-list ()
      (setf save-root-list nil)
      (dolist (root root-list)
        (push (copy-root root) save-root-list)))
    (defun restore-root-list ()
      (setf root-list nil)
      (dolist (root save-root-list)
        (push (copy-root root) root-list))))

  (defmacro with-saved-root-list (() &body body)
    `(progn
       (save-root-list)
       ,@body
       (restore-root-list)))

654
655
656
657
  (defun reset-root-list ()
    (setf root-list nil
          current-child nil))

658
  (defun define-as-root (child x y width height)
659
660
661
662
663
664
    (push (make-root :child child :original child :current-child nil :x x :y y :w width :h height) root-list))

  (defun find-root-by-coordinates (x y)
    (dolist (root root-list)
      (when (in-rect x y (root-x root) (root-y root) (root-w root) (root-h root))
        (return root))))
665

666
667
668
669
670
671
672
  (defun root (x &optional y)
    "Return the root at coordinates (x,y) if y is not nil.
     Otherwise, return the x nth root in root-list"
    (if y
        (find-root-by-coordinates x y)
        (nth x root-list)))

673
674
  (defun all-root-child ()
    (loop for root in root-list
675
       collect (root-child root)))
676

677
678
679
680
681
682
  (defmacro with-all-root-child ((root) &body body)
    (let ((root-symb (gensym)))
      `(dolist (,root-symb (get-root-list))
         (let ((,root (root-child ,root-symb)))
           ,@body))))

683
684
685
686
687
688
  (labels ((generic-child-root-p (child function)
             (dolist (root root-list)
               (when (child-equal-p child (funcall function root))
                 (return root)))))
    (defun child-root-p (child)
      (generic-child-root-p child #'root-child))
689

690
691
692
693
694
695
    (defun child-original-root-p (child)
      (generic-child-root-p child #'root-original)))

  (defun change-root (old-root new-child)
    (when (and old-root new-child)
      (setf (root-child old-root) new-child)))
696
697

  (defun find-root (child)
698
    (aif (child-original-root-p child)
699
700
         it
         (awhen (find-parent-frame child)
701
           (find-root it))))
702
703
704

  (defun find-child-in-all-root (child)
    (dolist (root root-list)
705
      (when (find-child child (root-child root))
706
707
708
        (return-from find-child-in-all-root root))))

  (defun find-current-root ()
709
    (root-child (find-root current-child)))
710

711
  (defun exchange-root-geometry (root-1 root-2)
Philippe Brochard's avatar
Philippe Brochard committed
712
713
714
715
716
    (when (and root-1 root-2)
      (rotatef (root-x root-1) (root-x root-2))
      (rotatef (root-y root-1) (root-y root-2))
      (rotatef (root-w root-1) (root-w root-2))
      (rotatef (root-h root-1) (root-h root-2))))
717

718
  (defun rotate-root-geometry ()
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
    (let* ((current (first root-list))
           (orig-x (root-x current))
           (orig-y (root-y current))
           (orig-w (root-w current))
           (orig-h (root-h current)))
      (dolist (elem (rest root-list))
        (setf (root-x current) (root-x elem)
              (root-y current) (root-y elem)
              (root-w current) (root-w elem)
              (root-h current) (root-h elem)
              current elem))
      (let ((last (car (last root-list))))
        (setf (root-x last) orig-x
              (root-y last) orig-y
              (root-w last) orig-w
              (root-h last) orig-h))))
735

736
737
738
739
740
  (defun anti-rotate-root-geometry ()
    (setf root-list (nreverse root-list))
    (rotate-root-geometry)
    (setf root-list (nreverse root-list)))

741
  ;;; Current child functions
742
743
744
745
  (defun current-child ()
    current-child)

  (defun current-child-setter (value)
746
747
748
749
    (when value
      (awhen (find-root value)
        (setf (root-current-child it) value))
      (setf current-child value)))
750
751
752
753
754
755
756
757
758

  (defmacro with-current-child ((new-child) &body body)
    "Temporarly change the current child"
    (let ((old-child (gensym))
          (ret (gensym)))
      `(let ((,old-child (current-child)))
         (setf (current-child) ,new-child)
         (let ((,ret (multiple-value-list (progn ,@body))))
           (setf (current-child) ,old-child)
759
760
761
762
           (values-list ,ret)))))

  (defun child-is-a-current-child-p (child)
    (find child root-list :test #'child-equal-p :key #'root-current-child)))
763
764
765

(defsetf current-child current-child-setter)

766
767
768
769
(defun ensure-at-least-one-root ()
  (unless (get-root-list)
    (let ((frame (create-frame)))
      (add-frame frame *root-frame*)
770
      (define-as-root frame 0 0 (screen-width) (screen-height))
771
772
773
774
775
776
      (add-frame (create-frame) frame))))





777

778
779
780
781
782
(defun is-in-current-child-p (child)
  (and (frame-p (current-child))
       (child-member child (frame-child (current-child)))))


783

784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
(defun fixe-real-size (frame parent)
  "Fixe real (pixel) coordinates in float coordinates"
  (when (frame-p frame)
    (with-slots (x y w h rx ry rw rh) frame
      (setf x (x-px->fl rx parent)
	    y (y-px->fl ry parent)
	    w (w-px->fl (anti-adj-border-wh rw parent) parent)
	    h (h-px->fl (anti-adj-border-wh rh parent) parent)))))

(defun fixe-real-size-current-child ()
  "Fixe real (pixel) coordinates in float coordinates for children in the current child"
  (when (frame-p (current-child))
    (dolist (child (frame-child (current-child)))
      (fixe-real-size child (current-child)))))


800
801

;;; Multiple physical screen helper
802
(defun add-placed-frame-tmp (frame n)   ;; For test
803
804
805
806
807
808
  (add-frame (create-frame :x 0.01 :y 0.01 :w 0.4 :h 0.4) frame)
  (add-frame (create-frame :x 0.55 :y 0.01 :w 0.4 :h 0.4) frame)
  (add-frame (create-frame :x 0.03 :y 0.5 :w 0.64 :h 0.44) frame)
  (when (plusp n)
    (add-placed-frame-tmp (first (frame-child frame)) (1- n))))

809
810
811
812
813
814
(defun parse-xinerama-info (line)
  (remove nil
          (mapcar (lambda (string)
                    (parse-integer string :junk-allowed t))
                  (split-string (substitute #\space #\x (substitute #\space #\, line))))))

815
(defun get-connected-heads-size (&optional fake)
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
  (labels ((heads-info ()
             (if (not fake)
                 (do-shell "xdpyinfo -ext XINERAMA")
                 (progn
                   (setf *show-root-frame-p* t)
                   (do-shell "echo '    available colormap entries:    256 per subfield
    red, green, blue masks:    0xff0000, 0xff00, 0xff
    significant bits in color specification:    8 bits

XINERAMA version 1.1 opcode: 150
  head #0: 500x300 @ 10,10
  head #1: 480x300 @ 520,20
  head #2: 600x250 @ 310,330'")))))
    (when (xlib:query-extension *display* "XINERAMA")
      (let ((output (heads-info))
            (sizes nil))
        (loop for line = (read-line output nil nil)
           while line
           do (when (search " head " line)
                (destructuring-bind (w h x y)
                    (parse-xinerama-info line)
837
838
                  (let ((found
                         (dolist (s sizes)
839
840
841
842
843
                           (destructuring-bind (x1 y1 w1 h1) s
                             (when (and (>= x x1)
                                        (>= y y1)
                                        (<= (+ x w) (+ x1 w1))
                                        (<= (+ y h) (+ y1 h1)))
844
845
846
847
848
849
                               (return t))))))
                    (unless found
                      (push (list x y w h) sizes))))))
        sizes))))
;;'((10 10 500 300) (550 50 400 400) (100 320 400 270))))))
;;'((10 10 500 580) (540 50 470 500))))))
850
851


852
(let ((last-sizes nil))
853
854
855
  (defun reset-last-head-size ()
    (setf last-sizes nil))

856
857
  (defun place-frames-from-xinerama-infos ()
    "Place frames according to xdpyinfo/xinerama informations"
Philippe Brochard's avatar
Philippe Brochard committed
858
    (let ((sizes (get-connected-heads-size))
859
860
          (width (screen-width))
          (height (screen-height)))
861
862
863
864
865
866
867
      (labels ((update-root-geometry ()
                 (loop for size in sizes
                    for root in (get-root-list)
                    do (destructuring-bind (x y w h) size
                         (setf (root-x root) x
                               (root-y root) y
                               (root-w root) w
868
869
870
                               (root-h root) h)))
                 (setf last-sizes sizes)
                 :update)
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
               (create-root-geometry ()
                 (reset-root-list)
                 ;; Add frames in *root-frame* until we get the same number as screen heads
                 (loop while (< (length (frame-child *root-frame*)) (length sizes))
                    do (let ((frame (create-frame)))
                         (add-frame frame *root-frame*)))
                 ;; On the opposite way: remove frames while there is more than screen heads in *root-frame*
                 (when (and sizes (> (length (frame-child *root-frame*)) (length sizes)))
                   (dotimes (i (- (length (frame-child *root-frame*)) (length sizes)))
                     (let ((deleted-child (pop (frame-child *root-frame*))))
                       (typecase deleted-child
                         (xlib:window (push deleted-child (frame-child (first (frame-child *root-frame*)))))
                         (frame (dolist (child (frame-child deleted-child))
                                  (push child (frame-child (first (frame-child *root-frame*)))))))
                       (setf (frame-layout (first (frame-child *root-frame*))) 'tile-space-layout
                             (frame-data-slot (first (frame-child *root-frame*)) :tile-layout-keep-position) :yes))))
                 (loop for size in sizes
                    for frame in (frame-child *root-frame*)
                    do (destructuring-bind (x y w h) size
                         (setf (frame-x frame) (float (/ x width))
                               (frame-y frame) (float (/ y height))
                               (frame-w frame) (float (/ w width))
                               (frame-h frame) (float (/ h height)))
                         ;;(add-placed-frame-tmp frame 2)  ;; For tests
                         (unless (frame-child frame)
                           (add-frame (create-frame) frame))
897
898
899
                         (define-as-root frame x y w h)))
                 (setf last-sizes sizes)
                 nil))
900
901
902
        (format t "Screen sizes: ~A~%" sizes)
        (if (= (length sizes) (length last-sizes))
            (update-root-geometry)
903
            (create-root-geometry))))))
904

905

906

907
908
909
(defun finish-configuring-root ()
  (ensure-at-least-one-root)
  (setf (current-child) (first (frame-child (first (frame-child *root-frame*))))))
910

Philippe Brochard's avatar
Philippe Brochard committed
911
912
913
914
915
916
917
918
919


(defun get-all-windows (&optional (root *root-frame*))
  "Return all windows in root and in its children"
  (let ((acc nil))
    (with-all-windows (root window)
      (push window acc))
    acc))

920
921
922
923
924
925
926
(defun get-all-frame-windows (&optional (root *root-frame*))
  "Return all frame windows in root and in its children"
  (let ((acc nil))
    (with-all-frames (root frame)
      (push (frame-window frame) acc))
    acc))

927
928
929
930
931
932
933
934
935
936
937
938
939
940
(defun get-all-frames (&optional (root *root-frame*))
  "Return all frame in root and in its children"
  (let ((acc nil))
    (with-all-frames (root frame)
      (push frame acc))
    acc))

(defun get-all-children (&optional (root *root-frame*))
  "Return a list of all children in root"
  (let ((acc nil))
    (with-all-children (root child)
      (push child acc))
    acc))

Philippe Brochard's avatar
Philippe Brochard committed
941
942
943
944
945
946
947
948
949
950

(defun get-hidden-windows ()
  "Return all hiddens windows"
  (let ((all-windows (get-all-windows))
	(hidden-windows (remove-if-not #'window-hidden-p
				       (copy-list (xlib:query-tree *root*)))))
    (set-difference hidden-windows all-windows)))



951
952
;;; Current window utilities
(defun get-current-window ()
953
954
955
  (typecase (current-child)
    (xlib:window  (current-child))
    (frame (frame-selected-child (current-child)))))
956
957
958
959
960
961
962

(defmacro with-current-window (&body body)
  "Bind 'window' to the current window"
  `(let ((window (get-current-window)))
      (when (xlib:window-p window)
	,@body)))

963
(defun get-first-window ()
964
965
966
967
  (typecase (current-child)
    (xlib:window  (current-child))
    (frame (or (first (frame-child (current-child)))
               (current-child)))))
968

969
970
971
972




Philippe Brochard's avatar
Philippe Brochard committed
973
(defun display-frame-info (frame)
974
975
976
977
978
979
  (when (frame-p frame)
    (let ((dy (+ (xlib:max-char-ascent *default-font*) (xlib:max-char-descent *default-font*))))
      (with-slots (name number gc window child hidden-children) frame
        (setf (xlib:gcontext-background gc) (get-color *frame-background*)
              (xlib:window-background window) (get-color *frame-background*))
        (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
983
984
985
986
987
                                                           *frame-foreground-root* *frame-foreground*)))
        (xlib:draw-glyphs *pixmap-buffer* gc 5 dy
                          (format nil "Frame: ~A~A"
                                  number
                                  (if name  (format nil " - ~A" name) "")))
        (let ((pos dy))
988
          (when (child-root-p frame)
989
990
991
992
993
994
995
996
997
998
999
            (when *child-selection*
              (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy)
                                (with-output-to-string (str)
                                  (format str "  Selection: ")
                                  (dolist (child *child-selection*)
                                    (typecase child
                                      (xlib:window (format str "  ~A " (xlib:wm-name child)))
                                      (frame (format str "  frame:~A[~A] " (frame-number child)
                                                     (aif (frame-name child) it "")))))))))
          (dolist (ch child)
            (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy)
1000
                              (format nil "  ~A" (ensure-printable (child-fullname ch))))))
For faster browsing, not all history is shown. View entire blame