wm.lisp 30.3 KB
Newer Older
1
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
hatchond's avatar
hatchond committed
2
;;; $Id: wm.lisp,v 1.13 2003/06/11 18:29:23 hatchond 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
37
  ((children :initarg :children :accessor decoration-children)
   (active-p :initform nil :accessor decoration-active-p)
   (time :initform 0 :accessor decoration-precedent-time :allocation :class)
   (wm-size-hints :initarg :wm-size-hints :reader decoration-wm-size-hints)
38
39
40
41
42
43
   (frame-style :initarg :frame-style :accessor decoration-frame-style)
   (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+
49
  '(:substructure-notify :visibility-change :enter-window :owner-grab-button))
james's avatar
james committed
50
51

(defmethod get-child ((master decoration) label &key window)
52
53
  (let ((widget (getf (decoration-children master) label)))
    (if (and widget window) (widget-window widget) widget)))
james's avatar
james committed
54
55

(defmethod decoration-min-width ((master decoration))
56
57
  (with-slots (hmargin) (decoration-frame-style master)
    (+ hmargin (aref (slot-value master 'wm-size-hints) 0))))
james's avatar
james committed
58
(defmethod decoration-min-height ((master decoration))
59
60
  (with-slots (vmargin) (decoration-frame-style master)
    (+ vmargin (aref (slot-value master 'wm-size-hints) 1))))
james's avatar
james committed
61
(defmethod decoration-max-width ((master decoration))
62
63
  (with-slots (hmargin) (decoration-frame-style master)
    (+ hmargin (aref (slot-value master 'wm-size-hints) 2))))
james's avatar
james committed
64
(defmethod decoration-max-height ((master decoration))
65
66
67
68
69
70
71
72
  (with-slots (vmargin) (decoration-frame-style master)
    (+ vmargin (aref (slot-value master 'wm-size-hints) 3))))
(defmethod decoration-base-width ((master decoration))
  (with-slots (hmargin) (decoration-frame-style master)
    (+ hmargin (aref (slot-value master 'wm-size-hints) 6))))
(defmethod decoration-base-height ((master decoration))
  (with-slots (vmargin) (decoration-frame-style master)
    (+ vmargin (aref (slot-value master 'wm-size-hints) 7))))
james's avatar
james committed
73
74
75
(defmethod decoration-inc-sizes ((master decoration))
  (with-slots (wm-size-hints) master
    (values (aref wm-size-hints 4) (aref wm-size-hints 5))))
76

james's avatar
james committed
77
78
79
80
(defmethod decoration-wm-hints ((master decoration))
  (with-slots (wm-size-hints) master
    (values (decoration-min-width master) (decoration-min-height master)
	    (decoration-max-width master) (decoration-max-height master)
81
82
	    (aref wm-size-hints 4) (aref wm-size-hints 5)
	    (decoration-base-width master) (decoration-base-height master))))
james's avatar
james committed
83
84

(defmethod focused-p ((master decoration))
85
  (focused-p (get-child master :application)))
hatchond's avatar
hatchond committed
86
87
88
89

(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
90

hatchond's avatar
hatchond committed
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
(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))
  "shade/un-shade an application that is decorated"
  (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)
	    (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.
	    (with-slots (vmargin hmargin) frame-style
	      (if (title-bar-horizontal-p master)
		  (setf (xlib:drawable-height window) vmargin)
		  (setf (xlib:drawable-width window) hmargin)))
	    (xlib:unmap-window app-win)
	    (pushnew :_net_wm_state_shaded netwm-prop)
	    (pushnew :_net_wm_state_hidden netwm-prop)
	    (incf gnome-prop 32))) ; add win_state_shaded
      (setf (netwm:net-wm-state app-win) netwm-prop
	    (gnome:win-state app-win) gnome-prop))))

125
126
127
128
129
130
131
132
133
134
135
136
137
(defmethod (setf decoration-frame-style) :after (frame-style (master decoration))
  (with-slots (window children) master
    (with-slots (left-margin top-margin hmargin vmargin) frame-style
      (with-event-mask (window)
	(loop with app = nil and icon = nil
	      for (key val) on children by #'cddr
	      do (case key
		   (:application (setf app val))
		   (:icon (setf icon val))
		   (t (when (typep val 'edge)		    
			(xlib:destroy-window (widget-window val)))
		      (remove-widget val)))
	      finally (setf children (list :application app :icon icon)))
hatchond's avatar
hatchond committed
138
139
140
141
142
	(let* ((application (getf children :application))
	       (app-win (widget-window application))
	       (width (+ (xlib:drawable-width app-win) hmargin))
	       (height (+ (xlib:drawable-height app-win) vmargin)))
	  (setf (window-position app-win) (values left-margin top-margin)
143
144
145
		(drawable-sizes window) (values width height))
	  (make-edges master)
	  (make-corner master width height)
hatchond's avatar
hatchond committed
146
	  (make-title-bar master (wm-name app-win))
147
	  (update-edges-geometry master)
hatchond's avatar
hatchond committed
148
149
150
151
	  (xlib:map-subwindows window)
	  (cond ((shaded-p application) (shade master))
		((application-iconic-p application)
		 (xlib:unmap-window app-win))))))))
152

hatchond's avatar
hatchond committed
153
154
155
156
157
(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
158

159
160
161
162
163
164
165
(defmethod dispatch-repaint ((master decoration) 
			     &key (focus (focused-p master)))
  (declare (optimize (speed 3) (safety 1)))
  (let ((name (theme-name (root-decoration-theme *root*))))
    (declare (type string name))
    (mapc #'(lambda (k) (repaint (get-child master k) name focus))
	  (style-parts-to-redraw-on-focus (decoration-frame-style master)))))
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
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229

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

(defun make-menu-button (master parent-window)
  (with-slots (children frame-style gcontext) master
    (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+)
		     :gcontext gcontext
		     :x (if horizontal-p 0 (ash (- tw width) -1))
		     :y (if horizontal-p (ash (- th height) -1) 0)))))))))

(defun make-buttons-bar (master parent-window)
  (with-slots (children frame-style gcontext) master
    (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
				    :event-mask +push-button-mask+
				    :gcontext gcontext))
	       (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)
  (with-slots (children frame-style gcontext) master
    (let* ((title-pos (style-title-bar-position frame-style))
	   (horizontal-p (case title-pos ((:top :bottom) t)))
hatchond's avatar
hatchond committed
230
231
232
233
	   (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))
234
235
236
237
238
239
240
241
	   (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
hatchond's avatar
hatchond committed
242
	    (create-button 'title-bar :parent parent-window :master master
243
244
245
246
247
			   :width 1 :height 1
			   :x (if horizontal-p mbw 0)
			   :y (if horizontal-p 0 bch)
			   :gcontext gcontext :event-mask +push-button-mask+
			   :background (aref pixmaps 0) :item name)
hatchond's avatar
hatchond committed
248
	    (slot-value title 'parent) parent-window
249
	    (getf children :title-bar) title
hatchond's avatar
hatchond committed
250
251
	    (xlib:window-background parent-window) :parent-relative
	    (xlib:window-event-mask parent-window) nil)
252
253
254
      (if horizontal-p 
	  (setf (slot-value title 'hmargin) (+ bcw mbw))
	  (setf (slot-value title 'vmargin) (+ bch mbh)))
hatchond's avatar
hatchond committed
255
      (xlib:map-subwindows parent-window)
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
      title)))

(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)
  (with-slots (children window frame-style gcontext) master
    (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
272
	    for cursor in +side-cursors+
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
	    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)
				    :gcontext gcontext :cursor cursor))))))

(defun make-corner (master width height)
  (with-slots (children window frame-style gcontext) master
    (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
297
	  for cursor in +corner-cursors+
298
299
300
301
302
	  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
303
	  for (x . y) in '((0 . 0) (nil . 0) (0 . nil) (nil . nil))
304
	  when (frame-item-exist-p frame-style child)
james's avatar
james committed
305
306
	  do (setf (getf children child)
		   (create-button type
307
308
309
				  :parent window :master master
				  :background bkgrd :item hilighted
				  :event-mask event-mask
james's avatar
james committed
310
				  :gravity gravity
311
312
313
				  :x (or x (- width w))
				  :y (or y (- height h))
				  :width w :height h
james's avatar
james committed
314
315
316
				  :gcontext gcontext :cursor cursor)))))

(defun update-edges-geometry (master)
hatchond's avatar
hatchond committed
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
  (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)))
  (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))))))
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380

(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))))
hatchond's avatar
hatchond committed
381
      (values (vector min-w min-h max-w max-h inc-w inc-h base-w base-h) g))))
382
383
384
385
386

(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
387
      (multiple-value-bind (wm-sizes gravity) 
388
389
390
391
	  (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
392
			    :parent (xlib:drawable-root application-window)
393
394
			    :width (+ width hmargin)
			    :height (+ height vmargin)
james's avatar
james committed
395
396
			    :background :parent-relative
			    :event-mask +decoration-event-mask+
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
			    :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
			     :gcontext *gcontext*
			     :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)
	    master))))))

(defun decore-application (window application &key (map t))
  (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
423
424
425
426
427
    (with-slots (icon) application
      (setf (getf (decoration-children master) :icon) icon
	    (slot-value icon 'master) master
	    (slot-value application 'master) master
	    (xlib:drawable-border-width window) 0))
    (with-event-mask (master-window)
      (xlib:map-subwindows master-window))
    (with-event-mask (master-window (when map +decoration-event-mask+))
428
429
430
431
      (xlib:reparent-window window master-window left-margin top-margin))
    (when map (xlib:map-window window))
    master))

hatchond's avatar
hatchond committed
432
433
434
435
436
437
438
439
440
441
442
443
444
445
(defun maximize-window (application button-code)
  (with-slots ((app-window window) initial-geometry full-geometry master)
      application
    (when (shaded-p master) (shade master))
    (let* ((new-sizes)
	   (m-window (if master (widget-window master) app-window))
	   (prop (netwm:net-wm-state app-window))
	   (fullscreen-p (member :_net_wm_state_fullscreen prop))
	   (vert-p (member :_net_wm_state_maximized_vert prop))
	   (horz-p (member :_net_wm_state_maximized_horz prop))	   
	   (wm-size-hints (if master
			      (slot-value master 'wm-size-hints)
			      (recompute-wm-normal-hints app-window 0 0))))
      (multiple-value-bind (x y) (window-position m-window)
446
	(multiple-value-bind (w h) (drawable-sizes app-window)
hatchond's avatar
hatchond committed
447
448
449
	  (unless (or horz-p vert-p)
	    (if fullscreen-p
		(setf initial-geometry (copy-geometry full-geometry))
450
		(setf (geometry initial-geometry) (values x y w h))))
hatchond's avatar
hatchond committed
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
	  (symbol-macrolet ((ix (geometry-x initial-geometry))
			    (iy (geometry-y initial-geometry)) 
			    (iw (geometry-w initial-geometry))
			    (ih (geometry-h initial-geometry))
			    (maxw (aref wm-size-hints 2))
			    (maxh (aref wm-size-hints 3)))
	    (case button-code
	      ;; Unmaximize or Maximize in both directions
	      (1 (if (or horz-p vert-p)
		     (setf new-sizes (copy-geometry initial-geometry)
			   horz-p t vert-p t)
		     (setf new-sizes (make-geometry :w maxw :h maxh))))
	      ;; Unmaximize or Maximize Vertically
	      (2 (if vert-p
		     (setf new-sizes (make-geometry :x x :y iy :w w :h ih))
		     (setf new-sizes (make-geometry :x x :w w :h maxh))))
	      ;; Unmaximize or Maximize Horizontally
	      (3 (if horz-p
		     (setf new-sizes (make-geometry :x ix :y y :w iw :h h))
		     (setf new-sizes (make-geometry :y y :w maxw :h h))))))))
      (unless (= 3 button-code)
	(if vert-p 
	    (setf prop (delete :_net_wm_state_maximized_vert prop))
	    (pushnew :_net_wm_state_maximized_vert prop)))
      (unless (= 2 button-code)
	(if horz-p
	    (setf prop (delete :_net_wm_state_maximized_horz prop))
	    (pushnew :_net_wm_state_maximized_horz prop)))
      (if fullscreen-p
	  (setf full-geometry new-sizes)
	  (setf (window-position m-window) (geometry-coordinates new-sizes)
482
		(drawable-sizes app-window) (geometry-sizes new-sizes)))
hatchond's avatar
hatchond committed
483
484
      (setf (netwm:net-wm-state app-window) prop))))

james's avatar
james committed
485
486
487
488
489
;;;; Focus management. According to ICCCM

(defgeneric set-focus (input-model window timestamp))

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

(defmethod set-focus ((input-model (eql :locally-active)) window timestamp)
hatchond's avatar
hatchond committed
493
494
495
  (when (eql (xlib:window-map-state window) :viewable)
    (send-wm-protocols-client-message window :wm_take_focus (or timestamp 0))
    (xlib:set-input-focus *display* window :parent)))
james's avatar
james committed
496
497
498

(defmethod set-focus ((input-model (eql :passive)) window timestamp)
  (declare (ignorable timestamp))
hatchond's avatar
hatchond committed
499
500
  (when (eql (xlib:window-map-state window) :viewable)
    (xlib:set-input-focus *display* window :parent)))
james's avatar
james committed
501
502
503

(defmethod set-focus ((input-model (eql :no-input)) window timestamp)
  (declare (ignorable window timestamp))
504
505
506
507
508
509
510
511
  (xlib:set-input-focus *display* :pointer-root :pointer-root)
  (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
512
(defgeneric menu-3-process (event widget &rest rest))
513
514

(defmethod menu-3-process (event widget &rest rest)
515
516
517
  (declare (ignorable rest))
  (event-process event widget)
  nil)
518

hatchond's avatar
hatchond committed
519
(defmethod menu-3-process ((event pointer-event) (w base-widget) &rest rest)
520
  (declare (ignore rest))
hatchond's avatar
hatchond committed
521
522
  (xlib:ungrab-pointer *display*)
  t)
523
524
525
526

(defmethod menu-3-process ((ev motion-notify) (master decoration) &key key)
  (when (decoration-active-p master)
    (cond ((eql key :resize)
hatchond's avatar
hatchond committed
527
528
	   (with-slots (root-x root-y) ev
	     (find-corner root-x root-y (widget-window master)))
529
530
531
532
533
534
535
536
537
538
539
540
541
	   (event-process ev (get-child master :bottom-right)))
	  ((eql key :move) (event-process ev (get-child master :title-bar))))
    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
542
543
  nil)

544
545
546
547
548
549
550
551
552
553
554
555
556
(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)))
    (:resize (event-process ev (get-child master :bottom-right)))
    (:move (event-process ev (get-child master :title-bar))))
  (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
557
	    for widget = (lookup-widget (event-event-window event))
558
559
560
	    until (menu-3-process event widget :key action)))))

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

hatchond's avatar
hatchond committed
562
(defun raise-window (window)
563
  (lambda ()
james's avatar
james committed
564
    (case (first (wm-state window))
hatchond's avatar
hatchond committed
565
566
567
      (1 (let ((scr (gnome-desktop-num window)))
	   (unless (eq (current-desk) scr)
	     (change-vscreen *root* :n scr))))
hatchond's avatar
hatchond committed
568
      (3 (uniconify (slot-value (lookup-widget window) 'icon))))
hatchond's avatar
hatchond committed
569
    (put-on-top (lookup-widget window))))
james's avatar
james committed
570

571
572
(defun make-menu-button-menu (master)
  (let ((appli (get-child master :application))
hatchond's avatar
hatchond committed
573
	(nb-vscreen (netwm:net-number-of-desktops *root-window*))
574
	(menu))
hatchond's avatar
hatchond committed
575
    (with-slots (window) appli      
576
      (macrolet ((add (pair) `(push ,pair menu)))
hatchond's avatar
hatchond committed
577
	(labels ((%send-message% (n)
578
579
580
581
		   (let ((message (make-event :client-message
					      :type :_net_wm_desktop
					      :data (vector n))))
		     (lambda () (event-process message appli))))
hatchond's avatar
hatchond committed
582
		 (%sendTO% ()
583
		   (loop with names = (workspace-names *root-window*)
hatchond's avatar
hatchond committed
584
585
			 for i from 0 below nb-vscreen
			 for s = (or (pop names) (format nil "workspace ~D" i))
586
			 unless (= i (current-desk))
hatchond's avatar
hatchond committed
587
588
589
590
591
592
593
			 collect (cons s (%send-message% i))))
		 (%maximize% ()
		   (let ((p (netwm:net-wm-state window)))
		     (if (or (member :_net_wm_state_maximized_vert p)
			     (member :_net_wm_state_maximized_horz p))
			 "Un-maximize" "Maximize")))
		 (%shade% () (if (shaded-p appli) "Un-shade" "Shade")))
594
595
596
	  (add (cons "Iconify" (lambda () (iconify appli))))
	  (add (cons "Destroy" (lambda () (kill-client-window window))))
	  (add (cons "Close  " (lambda () (close-widget appli))))
hatchond's avatar
hatchond committed
597
598
599
600
601
602
	  (add (cons (%shade%)  (lambda () (shade master))))
	  (add (cons (%maximize%) (lambda () (maximize-window appli 1))))
	  (if (= (or (gnome-desktop-num window) -1) +any-desktop+)
	      (add (cons "Un-pin" (%send-message% (current-desk))))
	      (add (cons "Pin   " (%send-message% +any-desktop+))))
	  (add (cons "Send to" (%sendTO%))))))
603
604
    (apply #'make-pop-up *root* menu)))

hatchond's avatar
hatchond committed
605
606
(defun make-desk-entries (index)
  (loop for win in (get-screen-content index :iconify-p t)
607
608
	for state = (= 1 (first (wm-state win)))
	collect (cons (format nil "~:[[ ~A ]~;~A~]" state (wm-name win))
hatchond's avatar
hatchond committed
609
610
611
612
613
614
615
616
617
618
619
620
		      (raise-window win))))

(defun make-running-menu (root)
  (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))
	collect (cons name (make-desk-entries i)) into entries
	finally (return (apply #'make-pop-up root entries))))

;; This is for updating the root properties
;; win_client_list, net_client_list(_stacking).
621
(defun update-lists (app state root)
hatchond's avatar
hatchond committed
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
  (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)
  (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)
  (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)
  (let ((scr-num (current-desk))
	(application (create-application window nil))
	(win-workspace (or (gnome-desktop-num window) +any-desktop+))
	(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*)
		 (xlib:unmap-window window))))
	  ((or (= win-workspace scr-num) stick-p)
	   (decore-application window application))
	  (t (with-event-mask (*root-window*)
	       (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
680

681
;;;; The main loop.
james's avatar
james committed
682
683
684
685
686
687

(defun eclipse-internal-loop ()
  (let ((exit 0)
	(time))

    ;; Sets the root window pop-up menu
688
    (nconc *menu-1-items* (acons "Exit" (lambda () (setf exit 1)) '()))
james's avatar
james committed
689
690
691
692
693
694
695
696
697
698
    (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
699
700
701
	     (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
702
703
	       (or
		(eql (xlib:window-override-redirect window) :ON)
hatchond's avatar
hatchond committed
704
705
706
707
708
		(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
709
710
711

      (xlib:with-event-queue (*display*)
	(mapc #'(lambda (window)
hatchond's avatar
hatchond committed
712
		  (unless (ignore-errors (ignorable-window-p window))
james's avatar
james committed
713
714
715
716
717
718
719
720
721
722
		    (xlib:queue-event *display*
				      :map-request
				      :event-window *root-window*
				      :window window)))
	      (xlib:query-tree *root-window*))))

    ;; Main loop
    (loop
      (catch 'general-error
	(handler-bind ((end-of-file #'handle-end-of-file-condition)
hatchond's avatar
hatchond committed
723
724
		       (already-handled-xerror 
		       #'handle-already-handled-xerror-condition)
hatchond's avatar
hatchond committed
725
		       (error #'handle-general-error-condition))
james's avatar
james committed
726
727
728
	  (let ((event (get-next-event *display* :discard-p t :timeout 2)))
	    (when event
	      (with-slots (event-window) event
hatchond's avatar
hatchond committed
729
		(event-process event (lookup-widget event-window)))))
james's avatar
james committed
730
731
	  (when pt:preprogrammed-tasks (pt:execute-preprogrammed-tasks))
	  (case exit
732
733
734
	    (1 (when *close-display-p*
		 (loop for val being each hash-value in *widget-table*
		       do (close-widget val)))
james's avatar
james committed
735
736
737
	       (setf time 10 exit 2))
	    (2 (return))))))
    (format t "Main loop exited~%")))