wm.lisp 32.5 KB
Newer Older
1
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
Iban Hatchondo's avatar
Iban Hatchondo committed
2
;;; $Id: wm.lisp,v 1.30 2004/01/13 13:50:38 ihatchondo Exp $
3
;;;
james's avatar
james committed
4
5
6
7
8
9
10
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
;;; Copyright (C) 2000
;;;          Julien BONINFANTE,
;;;          Aymeric LACORTE,
;;;          Jocelyn FRECHOT
;;; contact : hatchond@yahoo.fr
11
;;;
james's avatar
james committed
12
13
14
;;; 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.
15
;;;
james's avatar
james committed
16
17
18
19
;;; 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.
20
;;;
james's avatar
james committed
21
22
23
24
;;; 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.

25
;; usefull for having a quick and short garbage collection.
james's avatar
james committed
26
27
28
#+:cmu (setf extensions:*bytes-consed-between-gcs* 400000
	     extensions:*gc-verbose* nil)

29
(in-package :ECLIPSE-INTERNALS)
james's avatar
james committed
30
31
32

;;;; Decoration

33
(defclass decoration (base-widget)
james's avatar
james committed
34
35
36
  ((children :initarg :children :accessor decoration-children)
   (active-p :initform nil :accessor decoration-active-p)
   (wm-size-hints :initarg :wm-size-hints :reader decoration-wm-size-hints)
37
   (frame-style :initarg :frame-style :accessor decoration-frame-style)
Iban Hatchondo's avatar
Iban Hatchondo committed
38
   (old-frame-style :initform nil)
39
40
41
42
43
   (application-gravity 
     :initarg :application-gravity
     :initform :north-west
     :accessor decoration-application-gravity)
   ))
james's avatar
james committed
44

hatchond's avatar
hatchond committed
45
46
47
(defun decoration-p (widget)
  (typep widget 'decoration))

james's avatar
james committed
48
(defconstant +decoration-event-mask+
Iban Hatchondo's avatar
Iban Hatchondo committed
49
50
  '(:substructure-redirect :substructure-notify
    :visibility-change :enter-window :owner-grab-button))
james's avatar
james committed
51
52

(defmethod get-child ((master decoration) label &key window)
Iban Hatchondo's avatar
Iban Hatchondo committed
53
54
  "Return the child widget/window labeled `label' or nil if no such
  child exists. label is a keyword."
55
56
  (let ((widget (getf (decoration-children master) label)))
    (if (and widget window) (widget-window widget) widget)))
james's avatar
james committed
57
58

(defmethod decoration-wm-hints ((master decoration))
Iban Hatchondo's avatar
Iban Hatchondo committed
59
60
61
62
63
64
65
  "return as a multiple value: minw minh maxw maxh incw inch basew baseh."
  (with-slots (frame-style (wmsh wm-size-hints)) master
    (with-slots ((hm hmargin) (vm vmargin)) frame-style
      (values (+ hm (aref wmsh 0)) (+ vm (aref wmsh 1))
	      (+ hm (aref wmsh 2)) (+ vm (aref wmsh 3))
	      (aref wmsh 4) (aref wmsh 5)
	      (+ hm (aref wmsh 6)) (+ vm (aref wmsh 7))))))
james's avatar
james committed
66
67

(defmethod focused-p ((master decoration))
68
  (focused-p (get-child master :application)))
hatchond's avatar
hatchond committed
69
70
71
72

(defmethod focus-widget ((master decoration) timestamp)
  (with-slots (window input-model) (get-child master :application)
    (set-focus input-model window timestamp)))
james's avatar
james committed
73

hatchond's avatar
hatchond committed
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
(defmethod shaded-p ((widget decoration))
  (with-slots (window) (get-child widget :application)
    (member :_net_wm_state_shaded (netwm:net-wm-state window))))

(defmethod shade ((master decoration))
  (with-slots (window frame-style) master
    (let* ((app-win (get-child master :application :window t))
	   (netwm-prop (netwm:net-wm-state app-win))
	   (gnome-prop (or (gnome:win-state app-win :result-type t) 0))
	   (shaded-p (member :_net_wm_state_shaded netwm-prop)))
      (setf gnome-prop (logand gnome-prop #x3DF)) ; supress :win_state_shaded
      (if shaded-p
	  (with-event-mask (window) 
	    ;; unshade.
	    (xlib:map-window app-win)
Iban Hatchondo's avatar
Iban Hatchondo committed
89
	    (xlib:map-window window)
hatchond's avatar
hatchond committed
90
91
92
93
94
95
96
	    (resize-from (get-child master :application))
	    (setf netwm-prop (remove :_net_wm_state_shaded netwm-prop))
	    (setf netwm-prop (remove :_net_wm_state_hidden netwm-prop))
	    (unless (stick-p app-win)
	      (setf (window-desktop-num app-win) (current-desk))))
	  (with-event-mask (window)	    
	    ;; shade.
97
	    (with-slots ((vm vmargin) (hm hmargin)) frame-style
hatchond's avatar
hatchond committed
98
	      (if (title-bar-horizontal-p master)
99
100
		  (unless (= 0 vm) (setf (xlib:drawable-height window) vm))
		  (unless (= 0 hm) (setf (xlib:drawable-width window) hm))))
hatchond's avatar
hatchond committed
101
102
103
	    (xlib:unmap-window app-win)
	    (pushnew :_net_wm_state_shaded netwm-prop)
	    (pushnew :_net_wm_state_hidden netwm-prop)
104
	    (incf gnome-prop 32)))	; add win_state_shaded
hatchond's avatar
hatchond committed
105
106
107
      (setf (netwm:net-wm-state app-win) netwm-prop
	    (gnome:win-state app-win) gnome-prop))))

108
(defmethod (setf decoration-frame-style) :after (frame-style (master decoration))
109
110
  (with-slots (window children wm-size-hints) master
    (with-slots (left-margin top-margin (hm hmargin) (vm vmargin)) frame-style
111
      (with-event-mask (window)
hatchond's avatar
hatchond committed
112
	(let* ((application (getf children :application))
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
	       (icon (slot-value application 'icon))
	       (app-win (slot-value application 'window)))
	  (loop for (key val) on children by #'cddr
		unless (or (eq key :application) (eq key :icon))
		do (when (typep val 'edge)
		     (xlib:destroy-window (widget-window val)))
		   (remove-widget val))
	  (setf children (list :application application :icon icon)
		wm-size-hints (recompute-wm-normal-hints app-win hm vm))
	  (let ((width (+ (xlib:drawable-width app-win) hm))
		(height (+ (xlib:drawable-height app-win) vm)))
	    (setf (window-position app-win) (values left-margin top-margin)
		  (drawable-sizes window) (values width height))
	    (make-edges master)
	    (make-corner master width height)
	    (make-title-bar master (wm-name app-win))
	    (update-edges-geometry master)
	    (xlib:map-subwindows window))
131
132
	  (cond ((shaded-p application)
		 (if (title-bar-horizontal-p master)
133
134
		     (unless (= 0 vm) (setf (xlib:drawable-height window) vm))
		     (unless (= 0 hm) (setf (xlib:drawable-width window) hm)))
135
		 (xlib:unmap-window app-win))
hatchond's avatar
hatchond committed
136
137
		((application-iconic-p application)
		 (xlib:unmap-window app-win))))))))
138

139
140
141
(defmethod close-widget ((widget decoration))
  (close-widget (get-child widget :application)))

hatchond's avatar
hatchond committed
142
143
144
145
146
(defmethod put-on-top ((widget decoration))
  (put-on-top (get-child widget :application)))

(defmethod put-on-bottom ((widget decoration))
  (put-on-bottom (get-child widget :application)))
james's avatar
james committed
147

148
149
150
(defmethod dispatch-repaint ((master decoration) 
			     &key (focus (focused-p master)))
  (declare (optimize (speed 3) (safety 1)))
151
  (with-slots (parts-to-redraw-on-focus name) (decoration-frame-style master)
152
153
    (declare (type string name))
    (mapc #'(lambda (k) (repaint (get-child master k) name focus))
154
	  parts-to-redraw-on-focus)))
155
156
157
158

(defun title-bar-horizontal-p (master)
  (eq :horizontal (style-title-bar-direction (decoration-frame-style master))))

Iban Hatchondo's avatar
Iban Hatchondo committed
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
(defun recompute-wm-normal-hints (window hmargin vmargin)
  (let ((hints (or (ignore-errors (xlib:wm-normal-hints window))
		   (xlib:make-wm-size-hints)))
	(max-ww (screen-width))
	(max-hh (screen-height)))
    (symbol-macrolet ((min-w (xlib:wm-size-hints-min-width hints))
		      (min-h (xlib:wm-size-hints-min-height hints))
		      (max-w (xlib:wm-size-hints-max-width hints))
		      (max-h (xlib:wm-size-hints-max-height hints))
		      (inc-w (xlib:wm-size-hints-width-inc hints))
		      (inc-h (xlib:wm-size-hints-height-inc hints))
		      (base-w (xlib:wm-size-hints-base-width hints))
		      (base-h (xlib:wm-size-hints-base-height hints))
		      (g (xlib:wm-size-hints-win-gravity hints)))
       (unless (eq g :static)
	 (decf max-ww hmargin)
	 (decf max-hh vmargin))
       (setf min-w (max (or (or min-w base-w) 1) 1)
	     min-h (max (or (or min-h base-h) 1) 1)
	     base-w (max (or (or base-w min-w) 1) 1)
	     base-h (max (or (or base-h min-h) 1) 1)
	     inc-w (or inc-w 1) 
	     inc-h (or inc-h 1))
      (setf max-ww (- max-ww (mod (- max-ww base-w) inc-w))
	    max-hh (- max-hh (mod (- max-hh base-h) inc-h)))
      (unless (and max-w (<= min-w max-w max-ww)) (setf max-w max-ww))
      (unless (and max-h (<= min-h max-h max-hh)) (setf max-h max-hh))
      (setf min-w (min min-w max-w)
	    min-h (min min-h max-h)
	    base-w (min base-w max-w)
	    base-h (min base-h max-h))
      (multiple-value-bind (w h) (drawable-sizes window)
	(unless (<= min-w w max-w) 
	  (setf (xlib:drawable-width window) (min (max min-w w) max-w)))
	(unless (<= min-h h max-h) 
	  (setf (xlib:drawable-height window) (min (max min-h h) max-h))))
      (values (vector min-w min-h max-w max-h inc-w inc-h base-w base-h) g))))

;;;; Decoration creation tools.

199
(defun make-menu-button (master parent-window)
200
  (with-slots (children frame-style) master
201
202
203
204
205
206
207
208
209
210
211
212
213
    (when (frame-item-exist-p frame-style :menu-button)
      (let ((pixmaps (frame-item-pixmaps frame-style :menu-button))
	    (horizontal-p (title-bar-horizontal-p master)))
	(multiple-value-bind (width height) (drawable-sizes (aref pixmaps 0))
	  (multiple-value-bind (tw th) (drawable-sizes parent-window)
	    (setf (getf children :menu-button)
		  (create-button 
		     'menu-button
		     :parent parent-window :master master
		     :background (aref pixmaps 0) 
		     :item (aref pixmaps 1)
		     :width width :height height
		     :event-mask '(:owner-grab-button . #.+push-button-mask+)
214
215
		     :y (if horizontal-p (ash (- th height) -1) (- th height))
		     :x (if horizontal-p 0 (ash (- tw width) -1))))))))))
216
217

(defun make-buttons-bar (master parent-window)
218
  (with-slots (children frame-style) master
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
    (flet ((make-container (horizontal-p)
	     (xlib:create-window 
	        :parent parent-window
		:x 0 :y 0 :width 1 :height 1 
		:background :parent-relative 
		:gravity (if horizontal-p :north-east :north-west))))
      (loop initially (when (zerop (style-nb-buttons frame-style)) (return))
	    with horizontal-p = (title-bar-horizontal-p master)
	    with container = (make-container horizontal-p)
	    and (x y width height) = '(0 0 0 0)
	    for type in '(iconify-button maximize-button close-button)
	    for child in '(:icon-b :maximize :close)
	    for pixmaps = (frame-item-pixmaps frame-style child)
	    for bkgrd = (aref pixmaps 0)
	    when (frame-item-exist-p frame-style child)
	    do (multiple-value-setq (width height) (drawable-sizes bkgrd))
	       (setf (getf children child)
		     (create-button type
				    :parent container :master master
				    :background bkgrd :item (aref pixmaps 1)
				    :x x :y y :width width :height height
240
				    :event-mask +push-button-mask+))
241
242
243
244
245
246
247
248
249
250
251
252
253
	       (if horizontal-p (incf x width) (incf y height))
	    finally 
	      (multiple-value-bind (w h) (drawable-sizes parent-window)
		(if (zerop x) (incf x width) (incf y height))
		(setf (drawable-sizes container) (values x y)
		      (window-position container)
		      (if horizontal-p
			  (values (- w x) (ash (- h y) -1))
			  (values (ash (- w x) -1) 0)))
		(xlib:map-subwindows container)
		(return container))))))	    

(defun make-title-bar (master name)
254
  (with-slots (children frame-style) master
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
    (unless (eq :none (style-title-bar-position frame-style))
      (let* ((title-pos (style-title-bar-position frame-style))
	     (horizontal-p (case title-pos ((:top :bottom) t)))
	     (parent-widget (getf children title-pos))
	     (parent-window (widget-window parent-widget))
	     (button-container (make-buttons-bar master parent-window))
	     (menu-button (make-menu-button master parent-window))
	     (pixmaps (frame-item-pixmaps frame-style title-pos))
	     (bcw 0) (bch 0) (mbw 0) (mbh 0) (title))
	(when button-container
	  (multiple-value-setq (bcw bch) (drawable-sizes button-container)))
	(when menu-button
	  (multiple-value-setq (mbw mbh)
	    (drawable-sizes (widget-window menu-button))))
	(setf title
	      (create-button 'title-bar :parent parent-window :master master
			     :width 1 :height 1
			     :x (if horizontal-p mbw 0)
			     :y (if horizontal-p 0 bch)
274
			     :event-mask +push-button-mask+
275
276
277
278
279
280
281
282
283
284
			     :background (aref pixmaps 0) :item name)
	      (slot-value title 'parent) parent-window
	      (getf children :title-bar) title
	      (xlib:window-background parent-window) :parent-relative
	      (xlib:window-event-mask parent-window) nil)
	(if horizontal-p 
	    (setf (slot-value title 'hmargin) (+ bcw mbw))
	    (setf (slot-value title 'vmargin) (+ bch mbh)))
	(xlib:map-subwindows parent-window)
	title))))
285
286
287
288
289
290
291
292
293
294

(defun edge-position (style edge-key w h)
  (with-slots (top-left-w top-left-h top-right-h bottom-left-w) style
    (case edge-key
      (:top (values top-left-w 0))
      (:right (values (- w (frame-item-width style :right)) top-right-h))
      (:bottom (values bottom-left-w (- h (frame-item-height style :bottom))))
      (:left (values 0 top-left-h)))))

(defun make-edges (master)
295
  (with-slots (children window frame-style) master
296
297
298
299
    (multiple-value-bind (width height) (drawable-sizes window)
      (loop for type in '(right left top bottom)
	    for child in '(:right :left :top :bottom)
	    for gravity in '(:north-east :north-west :north-west :south-west)
hatchond's avatar
hatchond committed
300
	    for cursor in +side-cursors+
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
	    for pixmaps = (frame-item-pixmaps frame-style child)
	    for background = (aref pixmaps 0)
	    for hilighted = (aref pixmaps 1)
	    for event-mask = (if hilighted +std-button-mask+ +edge-event-mask+)
	    for (x y) = (multiple-value-list 
			   (edge-position frame-style child width height))
	    when (frame-item-exist-p frame-style child)
	    do (setf (getf children child)
		     (create-button type
				    :parent window :master master
				    :gravity gravity
				    :background background
				    :item hilighted 
				    :event-mask event-mask
				    :x x :y y
				    :width (pixmap-width background)
				    :height (pixmap-height background)
318
				    :cursor cursor))))))
319
320

(defun make-corner (master width height)
321
  (with-slots (children window frame-style) master
322
323
324
    (loop for type in '(top-left top-right bottom-left bottom-right)
	  for gravity in '(:north-west :north-east :south-west :south-east)
	  for child in '(:top-left :top-right :bottom-left :bottom-right)
hatchond's avatar
hatchond committed
325
	  for cursor in +corner-cursors+
326
327
328
329
330
	  for pixmaps = (frame-item-pixmaps frame-style child)
	  for bkgrd = (aref pixmaps 0)
	  for hilighted = (aref pixmaps 1)
	  for event-mask = (if hilighted +std-button-mask+ +edge-event-mask+)
	  for (w h) = (and bkgrd (multiple-value-list (drawable-sizes bkgrd)))
james's avatar
james committed
331
	  for (x . y) in '((0 . 0) (nil . 0) (0 . nil) (nil . nil))
332
	  when (frame-item-exist-p frame-style child)
james's avatar
james committed
333
334
	  do (setf (getf children child)
		   (create-button type
335
336
337
				  :parent window :master master
				  :background bkgrd :item hilighted
				  :event-mask event-mask
james's avatar
james committed
338
				  :gravity gravity
339
340
341
				  :x (or x (- width w))
				  :y (or y (- height h))
				  :width w :height h
342
				  :cursor cursor)))))
james's avatar
james committed
343

Iban Hatchondo's avatar
Iban Hatchondo committed
344
345
;; Public.

james's avatar
james committed
346
(defun update-edges-geometry (master)
hatchond's avatar
hatchond committed
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
  (declare (optimize (speed 3) (safety 0))
	   (inline update-edges-geometry))
  (macrolet
      ((update (edge size &rest frame-style-slots-size)
	 `(when ,edge
	    (setf (,(intern (format nil "DRAWABLE-~a" (symbol-name size)) :xlib)
		   (widget-window ,edge))
	          (with-slots (,@frame-style-slots-size) frame-style
		    (declare (type xlib:card16 ,@frame-style-slots-size))
		    (- ,size ,@frame-style-slots-size))))))
    (with-slots (frame-style window) master
      (multiple-value-bind (width height) (drawable-sizes window)
	(declare (type xlib:card16 width height))
	(update (get-child master :top) width top-left-w top-right-w)
	(update (get-child master :left) height top-left-h bottom-left-h)
	(update (get-child master :right) height top-right-h bottom-right-h)
	(update (get-child master :bottom) width bottom-left-w bottom-right-w)
	(update-title-bar-sizes (get-child master :title-bar))))))

(defun update-title-bar-sizes (title-bar)
  (declare (optimize (speed 3) (safety 0)))
368
369
370
371
372
373
374
  (when title-bar
    (with-slots (parent vmargin hmargin window) title-bar
      (declare (type xlib:card16 hmargin vmargin))
      (multiple-value-bind (width height) (drawable-sizes parent)
	(declare (type xlib:card16 width height))
	(setf (drawable-sizes window)
	      (values (- width hmargin) (- height vmargin)))))))
375
376
377
378
379

(defun make-decoration (application-window application)
  (let* ((theme (root-decoration-theme *root*))
	 (style (find-decoration-frame-style theme application-window)))
    (with-slots (hmargin vmargin left-margin top-margin) style
hatchond's avatar
hatchond committed
380
      (multiple-value-bind (wm-sizes gravity) 
381
382
383
384
	  (recompute-wm-normal-hints application-window hmargin vmargin)
	(multiple-value-bind (x y width height) 
	    (window-geometry application-window)
	  (let* ((window (xlib:create-window
hatchond's avatar
hatchond committed
385
			    :parent (xlib:drawable-root application-window)
386
387
			    :width (+ width hmargin)
			    :height (+ height vmargin)
james's avatar
james committed
388
389
			    :background :parent-relative
			    :event-mask +decoration-event-mask+
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
			    :x (max 0 (- x left-margin))
			    :y (max 0 (- y top-margin))
			    :do-not-propagate-mask 
			    '(:button-press :button-release)))
		 (master (make-instance 
			     'decoration
			     :window window
			     :frame-style style
			     :children (list :application application)
			     :application-gravity gravity
			     :wm-size-hints wm-sizes)))
	    (make-edges master)
	    (make-corner master (+ width hmargin) (+ height vmargin))
	    (make-title-bar master (wm-name application-window))
	    (update-edges-geometry master)
Iban Hatchondo's avatar
Iban Hatchondo committed
405
406
407
408
	    (with-slots (icon) application
	      (setf (getf (decoration-children master) :icon) icon
		    (slot-value icon 'master) master
		    (slot-value application 'master) master
409
		    (xlib:drawable-border-width application-window) 0))
410
411
412
	    master))))))

(defun decore-application (window application &key (map t))
Iban Hatchondo's avatar
Iban Hatchondo committed
413
414
415
  "Decore an application and map the resulting decoration as indicated
  by the :map keyword argument. (default value is T).
  Return the newly created decoration."
416
417
418
419
  (let* ((master (make-decoration window application))
	 (master-window (widget-window master))
	 (left-margin (style-left-margin (decoration-frame-style master)))
	 (top-margin (style-top-margin (decoration-frame-style master))))
james's avatar
james committed
420
421
422
    (with-event-mask (master-window)
      (xlib:map-subwindows master-window))
    (with-event-mask (master-window (when map +decoration-event-mask+))
423
424
425
426
      (xlib:reparent-window window master-window left-margin top-margin))
    (when map (xlib:map-window window))
    master))

Iban Hatchondo's avatar
Iban Hatchondo committed
427
428
;;;; Maximization tools.

Iban Hatchondo's avatar
Iban Hatchondo committed
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
(defun find-max-geometry (application direction fill-p &key x y w h)
  (multiple-value-bind (ulx uly lrx lry)
      (find-largest-empty-area 
          application 
	  :area-include-me-p (or (/= 1 direction) fill-p)
	  :panels-only-p (not fill-p)
	  :direction (case direction (2 :vertical) (3 :horizontal) (t :both)))
    (with-slots (window master) application
      (with-slots ((hm hmargin) (vm vmargin))
	  (if master (decoration-frame-style master)
	      (theme-default-style (lookup-theme "no-decoration")))
	(symbol-macrolet ((minw (aref wmsh 0)) (minh (aref wmsh 1))
			  (maxw (aref wmsh 2)) (maxh (aref wmsh 3))
			  (incw (aref wmsh 4)) (inch (aref wmsh 5))
			  (basew (aref wmsh 6)) (baseh (aref wmsh 7)))
	  (let* ((wmsh (recompute-wm-normal-hints window hm vm))
		 (ww (or w (check-size (- lrx ulx hm) basew incw minw maxw)))
		 (hh (or h (check-size (- lry uly vm) baseh inch minh maxh))))
	    (when (> (+ ww hm) (- lrx ulx)) (decf ww incw))
	    (when (> (+ hh vm) (- lry uly)) (decf hh inch))
	    (make-geometry :w ww :h hh :x (or x ulx) :y (or y uly))))))))

(defun compute-max-geometry
    (application x y w h direction fill-p vert-p horz-p)
  (symbol-macrolet 
	((ix (geometry-x initial-geometry)) (iy (geometry-y initial-geometry))
	 (iw (geometry-w initial-geometry)) (ih (geometry-h initial-geometry)))
    (with-slots (initial-geometry) application
      (case direction
	;; Unmaximize or Maximize in both directions
	(1 (if (or horz-p vert-p)
	       (copy-geometry initial-geometry)
	       (find-max-geometry application direction fill-p)))
	;; Unmaximize or Maximize Vertically
	(2 (if vert-p
	       (make-geometry :x x :y iy :w w :h ih)
	       (find-max-geometry application direction fill-p :x x :w w)))
	;; Unmaximize or Maximize Horizontally
	(3 (if horz-p
	       (make-geometry :x ix :y y :w iw :h h)
	       (find-max-geometry application direction fill-p :y y :h h)))))))

Iban Hatchondo's avatar
Iban Hatchondo committed
471
472
;; Public.

Iban Hatchondo's avatar
Iban Hatchondo committed
473
(defun maximize-window (application code &key (fill-p *maximize-fill*))
hatchond's avatar
hatchond committed
474
475
476
  (with-slots ((app-window window) initial-geometry full-geometry master)
      application
    (when (shaded-p master) (shade master))
Iban Hatchondo's avatar
Iban Hatchondo committed
477
    (let* ((new-g)
hatchond's avatar
hatchond committed
478
479
480
	   (m-window (if master (widget-window master) app-window))
	   (prop (netwm:net-wm-state app-window))
	   (fullscreen-p (member :_net_wm_state_fullscreen prop))
Iban Hatchondo's avatar
Iban Hatchondo committed
481
482
	   (vert-p (car (member :_net_wm_state_maximized_vert prop)))
	   (horz-p (car (member :_net_wm_state_maximized_horz prop))))
hatchond's avatar
hatchond committed
483
      (multiple-value-bind (x y) (window-position m-window)
484
	(multiple-value-bind (w h) (drawable-sizes app-window)
hatchond's avatar
hatchond committed
485
486
487
	  (unless (or horz-p vert-p)
	    (if fullscreen-p
		(setf initial-geometry (copy-geometry full-geometry))
488
		(setf (geometry initial-geometry) (values x y w h))))
Iban Hatchondo's avatar
Iban Hatchondo committed
489
490
491
492
493
	  (setf new-g (compute-max-geometry
		          application x y w h code fill-p vert-p horz-p))))
      (when (and (= 1 code) (or horz-p vert-p))
	(setf (values horz-p vert-p) (values t t)))
      (unless (= 3 code)
hatchond's avatar
hatchond committed
494
495
496
	(if vert-p 
	    (setf prop (delete :_net_wm_state_maximized_vert prop))
	    (pushnew :_net_wm_state_maximized_vert prop)))
Iban Hatchondo's avatar
Iban Hatchondo committed
497
      (unless (= 2 code)
hatchond's avatar
hatchond committed
498
499
500
501
	(if horz-p
	    (setf prop (delete :_net_wm_state_maximized_horz prop))
	    (pushnew :_net_wm_state_maximized_horz prop)))
      (if fullscreen-p
Iban Hatchondo's avatar
Iban Hatchondo committed
502
503
504
	  (setf full-geometry new-g)
	  (setf (window-position m-window) (geometry-coordinates new-g)
		(drawable-sizes app-window) (geometry-sizes new-g)))
hatchond's avatar
hatchond committed
505
506
      (setf (netwm:net-wm-state app-window) prop))))

james's avatar
james committed
507
508
;;;; Focus management. According to ICCCM

509
(defgeneric set-focus (input-model window timestamp)
510
511
512
513
  (:documentation 
   "Set focus to the given window according to the input model.
   Input model can be :globally-active :locally-active :passive :no-input.
   For more information on the input-model sementic see ICCCM 4.1.7"))
james's avatar
james committed
514
515

(defmethod set-focus ((input-model (eql :globally-active)) window timestamp)
hatchond's avatar
hatchond committed
516
  (send-wm-protocols-client-message window :wm_take_focus (or timestamp 0)))
james's avatar
james committed
517
518

(defmethod set-focus ((input-model (eql :locally-active)) window timestamp)
hatchond's avatar
hatchond committed
519
  (when (eql (xlib:window-map-state window) :viewable)
520
521
    (xlib:set-input-focus *display* window :pointer-root)
    (send-wm-protocols-client-message window :wm_take_focus (or timestamp 0))))
james's avatar
james committed
522
523
524

(defmethod set-focus ((input-model (eql :passive)) window timestamp)
  (declare (ignorable timestamp))
hatchond's avatar
hatchond committed
525
  (when (eql (xlib:window-map-state window) :viewable)
526
    (xlib:set-input-focus *display* window :pointer-root)))
james's avatar
james committed
527
528
529

(defmethod set-focus ((input-model (eql :no-input)) window timestamp)
  (declare (ignorable window timestamp))
530
531
532
533
534
535
536
  (values))

;; Next is methods for menu-3 who permit to manage any window :
;;  choose an action in the menu and click on a window
;;  to perform this action.

;; protocol for treating events
hatchond's avatar
hatchond committed
537
(defgeneric menu-3-process (event widget &rest rest))
538
539

(defmethod menu-3-process (event widget &rest rest)
540
541
542
  (declare (ignorable rest))
  (event-process event widget)
  nil)
543

hatchond's avatar
hatchond committed
544
(defmethod menu-3-process ((event pointer-event) (w base-widget) &rest rest)
545
  (declare (ignore rest))
hatchond's avatar
hatchond committed
546
547
  (xlib:ungrab-pointer *display*)
  t)
548
549
550
551

(defmethod menu-3-process ((ev motion-notify) (master decoration) &key key)
  (when (decoration-active-p master)
    (cond ((eql key :resize)
552
553
554
555
556
	   (activate-move-resize
	       master *root* 'resize-status *resize-mode* *verbose-resize*))
	  ((eql key :move)
	   (activate-move-resize
	       master *root* 'move-status *move-mode* *verbose-move*)))
557
558
559
560
561
562
563
564
565
566
567
    t))

(defmethod menu-3-process ((event enter-notify) (master decoration) &rest rest)
  (declare (ignore rest))
  (with-slots (window) master
    (xlib:grab-pointer window +pointer-event-mask+ :cursor *cursor-2*))
  nil)

(defmethod menu-3-process ((event leave-notify) (master decoration) &rest rest)
  (declare (ignore rest))
  (xlib:ungrab-pointer *display*)
james's avatar
james committed
568
569
  nil)

570
571
572
573
(defmethod menu-3-process ((ev button-press) (master decoration) &key key)
  (case key
    (:kill (kill-client-window (get-child master :application :window t)))
    (:close (close-widget (get-child master :application)))
574
575
    (:resize (initialize-resize master nil ev))
    (:move (initialize-move master ev)))
576
577
578
579
580
581
582
  (when (or (eq key :close) (eq key :kill)) (xlib:ungrab-pointer *display*)))

(defun define-menu-3 (action)
  (lambda ()
    (with-root-cursor (*cursor-2*)
      (destroy-substructure (slot-value *root* 'menu3))
      (loop for event = (get-next-event *display* :force-output-p t)
hatchond's avatar
hatchond committed
583
	    for widget = (lookup-widget (event-event-window event))
584
585
586
	    until (menu-3-process event widget :key action)))))

;;;; Misc.
james's avatar
james committed
587

588
589
(defun make-desktop-menu (root callback-maker &key realize)
  "Realize a root pop-up menu with as many entry as existing desktop. It attach
590
591
592
593
594
  to each entry a callback realized with the given `callback-maker' function.
  The callback-maker function should be a function of one argument of type
  integer that will be the index of the desktop entry. It may return a lambda
  or sub menu entries. If :realize is nil (the default value) it returns the
  menu entries otherwise a pop-up-menu object is return."
hatchond's avatar
hatchond committed
595
596
597
598
  (loop with root-window = (widget-window root)
	with names = (workspace-names root-window)
	for i from 0 below (number-of-virtual-screens root-window)
	for name = (or (pop names) (format nil "workspace ~D" i))
599
600
601
602
603
604
	collect (cons name (funcall callback-maker i)) into entries
	finally
	  (return (if realize (apply #'make-pop-up root entries) entries))))

(defun make-running-menu (root)
  "Realize the root pop-up menu that shows all applications ordered by desktop."
605
606
607
608
609
610
611
  (labels
      ((raise (window index)
	 (lambda ()
	   (case (first (wm-state window))
	     (1 (change-vscreen root :n index))
	     (3 (uniconify (slot-value (lookup-widget window) 'icon))))
	   (put-on-top (lookup-widget window))))
612
613
       (make-desktop-entries (i)
	 (loop for w in (screen-content i :iconify-p t)
614
	       for state = (= 1 (first (wm-state w)))
615
616
617
618
	       for name = (format nil "~:[[ ~A ]~;~A~]" state (wm-name w))
	       collect (cons name (raise w i)) into entries
	       finally
	        (return (or entries (lambda () (change-vscreen root :n i)))))))
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
    (make-desktop-menu root #'make-desktop-entries :realize t)))

(defun make-menu-button-menu (master)
  (let* ((app (get-child master :application))
	 (appw (widget-window app))
	 (net-wm-state (netwm:net-wm-state appw))
	 (client-message (make-event :client-message :type :_net_wm_desktop))
	 (shade-str (if (shaded-p app) "Un-shade" "Shade"))
	 (max-str (if (or (member :_net_wm_state_maximized_vert net-wm-state)
			  (member :_net_wm_state_maximized_horz net-wm-state))
		      "Un-maximize" "Maximize")))
    (flet ((send-message (n)
	     (lambda ()
	       (setf (slot-value client-message 'data) (vector n))
	       (event-process client-message app))))
      (make-pop-up
          *root*
	  (cons "Send to" (make-desktop-menu *root* #'send-message))
	  (if (stick-p appw)
	      (cons "Un-pin" (send-message (current-desk)))
	      (cons "Pin   " (send-message +any-desktop+)))
	  (cons max-str (lambda () (maximize-window app 1)))
	  (cons shade-str (lambda () (shade master)))
	  (cons "Close  " (lambda () (close-widget app)))
	  (cons "Destroy" (lambda () (kill-client-window appw)))
	  (cons "Iconify" (lambda () (iconify app)))))))
hatchond's avatar
hatchond committed
645

646
(defun update-lists (app state root)
647
  "Update root properties win_client_list, net_client_list(_stacking), 
648
  by adjoining or removing the given application depending of state."
hatchond's avatar
hatchond committed
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
  (with-slots ((appw window) iconic-p) app
    (with-slots ((rw window) client-list) root
      (case (if (and (= state 3) (not iconic-p)) 0 state)
	(0 (remhash appw client-list)
	   (setf (netwm:net-client-list-stacking rw :mode :remove) appw
		 (gnome:win-client-list rw :mode :remove) appw
		 (netwm:net-client-list rw :mode :remove) appw))
	(1 (let ((up2date (gethash appw client-list)))
	     (setf (gethash appw client-list) appw)
	     (update-client-list-stacking root)
	     (unless up2date
	       (setf (netwm:net-client-list rw :mode :append) appw))
	     (if (member :win_hints_skip_winlist (gnome:win-hints appw))
		 (setf (gnome:win-client-list rw :mode :remove) appw)
	         (unless up2date
		   (setf (gnome:win-client-list rw :mode :append) appw)))))))))

(defun update-client-list-stacking (root)
667
  "Recompute ans set the root property net_client_list_stacking."
hatchond's avatar
hatchond committed
668
669
670
671
672
673
  (with-slots (window client-list) root
    (loop for win in (query-application-tree window)
	  when (gethash win client-list) collect win into wins
	  finally (setf (netwm:net-client-list-stacking window) wins))))

(defun window-not-decorable-p (window)
Iban Hatchondo's avatar
Iban Hatchondo committed
674
675
676
677
  "Return T if a window `should' not be decorated. Typically splash screen, 
  a desktop (e.g. nautilus) or a dock (e.g. gnome panels) will be assumed as
  non-decorable windows. Such as windows holding the motif_wm_hints with the
  flag `no decoration at all'."
hatchond's avatar
hatchond committed
678
679
680
681
682
683
684
  (let ((netwm-type (netwm:net-wm-window-type window)))
    (or (eql (motif-wm-decoration window) :OFF)
	(member :_net_wm_window_type_splash netwm-type)
	(member :_net_wm_window_type_desktop netwm-type)
	(member :_net_wm_window_type_dock netwm-type))))

(defun procede-decoration (window)
Iban Hatchondo's avatar
Iban Hatchondo committed
685
  "Decore, if necessary, add/update properties, map or not, etc a window."
hatchond's avatar
hatchond committed
686
687
  (let ((scr-num (current-desk))
	(application (create-application window nil))
hatchond's avatar
hatchond committed
688
	(win-workspace (or (window-desktop-num window) +any-desktop+))
hatchond's avatar
hatchond committed
689
690
691
692
693
694
695
696
697
698
699
700
701
	(stick-p (stick-p window))
	(netwm-type (netwm:net-wm-window-type window)))
    (xlib:add-to-save-set window)
    (unless (or stick-p
		(< -1 win-workspace (number-of-virtual-screens *root-window*)))
      (setf win-workspace scr-num))
    (setf (window-desktop-num window) win-workspace)
    (cond ((or (window-not-decorable-p window)
	       (member :_net_wm_state_fulscreen (netwm:net-wm-state window)))
	   (setf (wm-state window) 1)
	   (if (or (= win-workspace scr-num) stick-p)
	       (xlib:map-window window)
	       (with-event-mask (*root-window*)
702
	   	 (xlib:unmap-window window))))
hatchond's avatar
hatchond committed
703
704
705
	  ((or (= win-workspace scr-num) stick-p)
	   (decore-application window application))
	  (t (with-event-mask (*root-window*)
Iban Hatchondo's avatar
Iban Hatchondo committed
706
	       (xlib:unmap-window window)
hatchond's avatar
hatchond committed
707
708
709
710
711
712
713
	       (decore-application window application :map nil)	       
	       (setf (wm-state window) 1)
	       (update-lists application 1 *root*))))
    (unless (member :_net_wm_window_type_desktop netwm-type)
      (with-slots (wants-focus-p input-model) application
	(unless (eq input-model :no-input)	      
	  (setf wants-focus-p *focus-new-mapped-window*))))))
james's avatar
james committed
714

715
;;;; The main loop.
james's avatar
james committed
716

Iban Hatchondo's avatar
Iban Hatchondo committed
717
718
719
720
(define-condition exit-eclipse (error)
  ((close-application-p
     :initform nil :initarg :close-application-p
     :type boolean :reader close-application-p)))
Iban Hatchondo's avatar
Iban Hatchondo committed
721

james's avatar
james committed
722
(defun eclipse-internal-loop ()
Iban Hatchondo's avatar
Iban Hatchondo committed
723
  (let* ((exit 0) time)
james's avatar
james committed
724
725

    ;; Sets the root window pop-up menu
726
727
    (when *menu-1-exit-p*
      (nconc *menu-1-items* (acons "Exit" (lambda () (setf exit 1)) '())))
james's avatar
james committed
728
729
730
731
732
733
734
735
736
737
    (with-slots (menu1 menu3) *root*
      (setf menu1 (apply #'make-pop-up *root* *menu-1-items*)
	    menu3 (make-pop-up *root*
			       (cons "Move" (define-menu-3 :move))
			       (cons "Resize" (define-menu-3 :resize))
			       (cons "Close" (define-menu-3 :close))
			       (cons "Kill" (define-menu-3 :kill)))))

    ;; Queue events for dressing windows already displayed at start time.
    (flet ((ignorable-window-p (window)
hatchond's avatar
hatchond committed
738
739
740
	     (let* ((wmh (xlib:get-property window :WM_HINTS))
		    (initial-state (and wmh (logbitp 1 (car wmh)) (third wmh)))
		    (wm-state (car (wm-state window))))
james's avatar
james committed
741
742
	       (or
		(eql (xlib:window-override-redirect window) :ON)
hatchond's avatar
hatchond committed
743
744
745
746
747
		(when (or (eq initial-state 0) (eq wm-state 0))
		  (xlib:unmap-window window)
		  t)
		(and (not wm-state)
		     (eq (xlib:window-map-state window) :unmapped))))))
james's avatar
james committed
748
749
750

      (xlib:with-event-queue (*display*)
	(mapc #'(lambda (window)
hatchond's avatar
hatchond committed
751
		  (unless (ignore-errors (ignorable-window-p window))
james's avatar
james committed
752
753
754
755
756
757
758
759
760
		    (xlib:queue-event *display*
				      :map-request
				      :event-window *root-window*
				      :window window)))
	      (xlib:query-tree *root-window*))))

    ;; Main loop
    (loop
      (catch 'general-error
Iban Hatchondo's avatar
Iban Hatchondo committed
761
762
763
764
765
766
	(handler-case
	    (let ((event (get-next-event *display* :discard-p t :timeout 2)))
	      (when event
		(with-slots (event-window) event
		  (event-process event (lookup-widget event-window))))
	      (when pt:preprogrammed-tasks (pt:execute-preprogrammed-tasks))
767
768
	      (with-slots (sm-conn) *root*
		(when sm-conn (handle-session-manager-request sm-conn *root*)))
Iban Hatchondo's avatar
Iban Hatchondo committed
769
	      (case exit
Iban Hatchondo's avatar
Iban Hatchondo committed
770
771
772
773
		(1 (loop for val being each hash-value in *widget-table*
			 when (application-p val) 
			   if *close-display-p* do (close-widget val)
			   else do (undecore-application val))
Iban Hatchondo's avatar
Iban Hatchondo committed
774
		   (setf time 10 exit 2))
Iban Hatchondo's avatar
Iban Hatchondo committed
775
776
777
778
779
780
781
782
783
		(2 (when (root-sm-conn *root*)
		     (close-sm-connection *root* :exit-p nil))
		   (xlib:display-finish-output *display*)
		   (setf (xlib:window-event-mask *root-window*) '())
		   (xlib:destroy-window (root-manager *root*))
		   (xlib:display-finish-output *display*)
		   (return))))
	  (exit-eclipse (c)
	    (setf *close-display-p* (close-application-p c) exit 1))
Iban Hatchondo's avatar
Iban Hatchondo committed
784
785
786
787
	  (end-of-file (c) (handle-end-of-file-condition c))
	  (already-handled-xerror () nil)
	  (error (c) (handle-error-condition c)))))
    (format t "~%Main loop exited~%")))