/[eclipse]/eclipse/move-resize.lisp
ViewVC logotype

Contents of /eclipse/move-resize.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.20 - (show annotations)
Tue Nov 17 09:32:27 2009 UTC (4 years, 5 months ago) by ihatchondo
Branch: MAIN
CVS Tags: HEAD
Changes since 1.19: +3 -3 lines
Fix: cosmetic.
1 ;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
2 ;;; $Id: move-resize.lisp,v 1.20 2009/11/17 09:32:27 ihatchondo Exp $
3 ;;;
4 ;;; ECLIPSE. The Common Lisp Window Manager.
5 ;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
6 ;;; contact : hatchond@yahoo.fr
7 ;;;
8 ;;; This program is free software; you can redistribute it and/or
9 ;;; modify it under the terms of the GNU General Public License
10 ;;; as published by the Free Software Foundation.
11 ;;;
12 ;;; This program is distributed in the hope that it will be useful,
13 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;;; GNU General Public License for more details.
16 ;;;
17 ;;; You should have received a copy of the GNU General Public License
18 ;;; along with this program; if not, write to the Free Software
19 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
20
21 (in-package :ECLIPSE-INTERNALS)
22
23 ;;;; Functions for displaying window sizes/positions in a box-button window.
24
25 (defparameter *geometry-info-box* nil)
26
27 (deftypedparameter (signed-byte 16) *delta-x* 0)
28 (deftypedparameter (signed-byte 16) *delta-y* 0)
29
30 (defun undraw-geometry-info-box ()
31 (when *geometry-info-box*
32 (xlib:unmap-window (widget-window *geometry-info-box*))))
33
34 (defun initialize-geometry-info-box (parent-window)
35 (unless *geometry-info-box*
36 (setf *geometry-info-box* (create-message-box nil :parent parent-window)))
37 (with-slots (window) *geometry-info-box*
38 (xlib:map-window window)
39 (setf (xlib:window-priority window) :above)))
40
41 (defun display-infos (message)
42 "Display the given message in the geometry-info-box window."
43 (declare (optimize (speed 3) (safety 0)))
44 (setf (button-item-to-draw *geometry-info-box*) message)
45 (repaint *geometry-info-box* nil nil))
46
47 (defun display-coordinates (x y)
48 "Display the given coordinates in the geometry-info-box window."
49 (declare (optimize (speed 3) (safety 0)))
50 (declare (type (signed-byte 16) x y))
51 (display-infos (format nil "~:[+~;~]~D ~:[+~;~]~D" (< x 0) x (< y 0) y)))
52
53 (defun display-geometry (width height)
54 "Display the given width and height in the geometry-info-box window."
55 (declare (optimize (speed 3) ))
56 (display-infos (format nil "~D x ~D" width height)))
57
58 ;;;; A master "clone" for resize and move.
59
60 (defparameter *clone* nil)
61
62 (defun initialize-clone (parent-window)
63 (let ((win (xlib:create-window
64 :parent parent-window :x 0 :y 0 :width 100 :height 100)))
65 (setf *clone* (make-decoration win (create-application win nil)))))
66
67 (defun update-*clone* (x y w h decoration-frame-style &optional wm-hints)
68 (with-slots (window wm-size-hints frame-style) *clone*
69 (setf wm-size-hints wm-hints
70 frame-style decoration-frame-style
71 (drawable-sizes window) (values w h)
72 (window-position window) (values x y))))
73
74 (defun draw-window-grid (window gctxt dest-window)
75 "Draw a 3x3 grid representing the future window geometry on the dest-window."
76 (declare (optimize (speed 3) (safety 0)))
77 (multiple-value-bind (x y width height) (window-geometry window)
78 (declare (type (signed-byte 16) x y))
79 (declare (type (unsigned-byte 16) width height))
80 (decf width) (decf height)
81 (xlib:with-gcontext
82 (gctxt :function boole-xor :subwindow-mode :include-inferiors)
83 (xlib:draw-rectangle dest-window gctxt x y width height)
84 (let ((w (round width 3))
85 (h (round height 3)))
86 (declare (type (unsigned-byte 16) w h))
87 (xlib:draw-segments
88 dest-window gctxt
89 (list x (+ h y) (+ x width) (+ h y)
90 x (+ y (* 2 h)) (+ x width) (+ y (* 2 h))
91 (+ x w) y (+ w x) (+ y height)
92 (+ x (* 2 w)) y (+ x (* 2 w)) (+ y height)))))))
93
94 (defun activate-move-resize (widget root status mode verbose-p)
95 "Sets some internal values for the future move or resize animations."
96 (with-slots (resize-status move-status current-active-widget window) root
97 (with-slots ((widget-window window) gcontext active-p) widget
98 (when (and active-p (not (or resize-status move-status)))
99 (or *clone* (initialize-clone window))
100 (update-clone widget)
101 (grab-root-pointer)
102 (setf (slot-value root status) t
103 current-active-widget widget)
104 (when verbose-p
105 (initialize-geometry-info-box window)
106 (multiple-value-bind (x y w h) (window-geometry widget-window)
107 (if (and (eq status 'resize-status) (decoration-p widget))
108 (multiple-value-bind (a b c d iw ih bw bh)
109 (decoration-wm-hints widget)
110 (declare (ignore a b c d))
111 (display-geometry (/ (- w bw) iw) (/ (- h bh) ih)))
112 (display-coordinates x y))))
113 (when (eq mode :box)
114 (xlib:grab-server *display*)
115 (draw-window-grid widget-window gcontext window))))))
116
117 (defgeneric update-clone (widget)
118 (:documentation "Re-initialize a widget clone for move/resize animations."))
119
120 (defmethod update-clone ((application application))
121 (multiple-value-bind (x y w h) (window-geometry (widget-window application))
122 (update-*clone*
123 x y w h (theme-default-style (lookup-theme "no-decoration")))))
124
125 (defmethod update-clone ((master decoration))
126 (multiple-value-bind (x y w h) (window-geometry (widget-window master))
127 (with-slots (frame-style wm-size-hints) master
128 (update-*clone* x y w h frame-style wm-size-hints))))
129
130 ;;;; Resize.
131
132 (defparameter *card-point* :se)
133
134 (defgeneric resize-from (widget)
135 (:documentation "Resize a decoration or an application depending on widget"))
136
137 (defun initialize-resize (master edge pointer-event)
138 "Initialize the internal hooks for the resize process."
139 (setf (window-priority (widget-window master)) :above)
140 (if (base-widget-p edge)
141 (where-is-pointer edge)
142 (with-slots (root-x root-y) pointer-event
143 (find-corner root-x root-y (widget-window master))))
144 (let ((prop (netwm:net-wm-state (get-child master :application :window t))))
145 (when (member :_net_wm_state_maximized_vert prop)
146 (case *card-point*
147 ((:ne :se) (setf *card-point* :east))
148 ((:nw :sw) (setf *card-point* :west))
149 ((:north :south) (setf *card-point* nil))))
150 (when (member :_net_wm_state_maximized_horz prop)
151 (case *card-point*
152 ((:ne :nw) (setf *card-point* :north))
153 ((:se :sw) (setf *card-point* :south))
154 ((:east :west) (setf *card-point* nil))))
155 (setf (decoration-active-p master) (if *card-point* t nil))))
156
157 (defun where-is-pointer (widget)
158 "Initialize internal anchor when resize is activated from one
159 of the edge of the decoration."
160 (declare (optimize (speed 3) (safety 0)))
161 (setf (values *delta-x* *delta-y*) (values 0 0)
162 *card-point* (typecase widget
163 (top :north)
164 (top-left :nw)
165 (left :west)
166 (bottom-left :sw)
167 (bottom :south)
168 (bottom-right :se)
169 (right :east)
170 (top-right :ne)
171 (t :se))))
172
173 (defun find-corner (root-x root-y window)
174 "Initialize internal anchor when resize is activated from one
175 of the edge of the decoration."
176 (multiple-value-bind (x y width height) (window-geometry window)
177 (let ((corners '#(#.'#(:nw :north :nw :west) #.'#(:north :ne :east :ne)
178 #.'#(:se :east :se :south) #.'#(:west :sw :south :sw))))
179 (declare (type (simple-array (simple-array keyword (4)) (4)) corners))
180 (labels ((find-c (x y rx ry w h)
181 (if (<= x rx (+ x (floor w 2)))
182 (if (<= y ry (+ y (floor h 2))) 0 3)
183 (if (<= y ry (+ y (floor h 2))) 1 2)))
184 (get-card (x y rx ry w h)
185 (let ((corner (find-c x y rx ry w h)))
186 (setf w (floor w 2))
187 (setf h (floor h 2))
188 (when (or (= corner 1) (= corner 2)) (incf x w))
189 (when (or (= corner 2) (= corner 3)) (incf y h))
190 (aref (aref corners corner) (find-c x y rx ry w h)))))
191 (setf *card-point* (get-card x y root-x root-y width height))
192 (when (member *card-point* '(:ne :east :se)) (incf x width))
193 (when (member *card-point* '(:se :south :sw)) (incf y height))
194 (setf *delta-x* (- root-x x)
195 *delta-y* (- root-y y))))))
196
197 (defun check-size (size base inc min-size max-size)
198 "If the given size respects all the given constraints, then returns size.
199 Otherwise returns the nearest satisfying size."
200 (declare (optimize (speed 3) (safety 0)))
201 (declare (type xlib:card16 size base inc min-size max-size))
202 (if (< min-size size max-size)
203 (let ((k (mod (- size base) inc)))
204 (declare (type xlib:card16 k))
205 (if (= k 0) size (+ inc (- size k))))
206 (max min-size (min size max-size))))
207
208 (defun resize-internal (master motion-notify-event verbose-p)
209 (declare (optimize (speed 3) (safety 0)))
210 (declare (inline check-size))
211 (let* ((master-win (widget-window master))
212 (root-x (event-root-x motion-notify-event))
213 (root-y (event-root-y motion-notify-event)))
214 (declare (type xlib:int16 root-x root-y))
215 (decf root-x *delta-x*)
216 (decf root-y *delta-y*)
217 (multiple-value-bind (x y width height) (window-geometry master-win)
218 (declare (type xlib:int16 x y))
219 (declare (type xlib:card16 width height))
220 (multiple-value-bind (tmp-width tmp-height new-x new-y)
221 (ecase *card-point*
222 (:north (values width (+ height (- y root-y)) x root-y))
223 (:ne (values (- root-x x) (+ height (- y root-y)) x root-y))
224 (:east (values (- root-x x) height x y))
225 (:se (values (- root-x x) (- root-y y) x y))
226 (:south (values width (- root-y y) x y))
227 (:sw (values (+ width (- x root-x)) (- root-y y) root-x y))
228 (:west (values (+ width (- x root-x)) height root-x y))
229 (:nw (values (+ width (- x root-x)) (+ height (- y root-y))
230 root-x root-y)))
231 (declare (type xlib:int16 new-x new-y))
232 (declare (type xlib:card16 tmp-width tmp-height))
233 (multiple-value-bind (minw minh maxw maxh incw inch basew baseh)
234 (decoration-wm-hints master)
235 (declare (type xlib:card16 minw minh maxw maxh incw inch basew baseh))
236 (let ((new-width (check-size tmp-width basew incw minw maxw))
237 (new-height (check-size tmp-height baseh inch minh maxh)))
238 (declare (type xlib:card16 new-width new-height))
239 (when verbose-p
240 (display-geometry (/ (- new-width basew) incw)
241 (/ (- new-height baseh) inch)))
242 (case *card-point*
243 ((:north :ne) (incf new-y (- tmp-height new-height)))
244 ((:west :sw) (incf new-x (- tmp-width new-width)))
245 (:nw (incf new-y (- tmp-height new-height))
246 (incf new-x (- tmp-width new-width))))
247 (xlib:with-state (master-win)
248 (setf (window-position master-win) (values new-x new-y))
249 (setf (drawable-sizes master-win)
250 (values new-width new-height)))))))))
251
252 (defun finish-resize (master &optional verbose-p mode)
253 "Ends the resize work. (undraw grid, geometry infos, ...)"
254 ;; Finish the resize process:
255 ;; called when button-release on root and root-resize-status is not nil.
256 (with-slots (window gcontext) master
257 (when (and (decoration-active-p master) (eql mode :box))
258 (draw-window-grid
259 (widget-window *clone*) gcontext (xlib:drawable-root window))
260 (multiple-value-bind (x y w h)
261 (window-geometry (widget-window *clone*))
262 (setf (window-position window) (values x y)
263 (drawable-sizes window) (values w h))
264 (resize-from master))))
265 (when verbose-p (undraw-geometry-info-box))
266 (setf *card-point* nil))
267
268 (defmethod resize-from ((master decoration))
269 (declare (optimize (speed 3) (safety 0)))
270 (with-slots (window frame-style) master
271 (let ((hmargin (style-hmargin frame-style))
272 (vmargin (style-vmargin frame-style)))
273 (declare (type (unsigned-byte 16) hmargin vmargin))
274 (multiple-value-bind (w h) (drawable-sizes window)
275 (declare (type xlib:card16 w h))
276 (setf (drawable-sizes (get-child master :application :window t))
277 (values (- w hmargin) (- h vmargin)))))))
278
279 (defmethod resize-from ((application application))
280 (declare (optimize (speed 3) (safety 0)))
281 (with-slots (window master) application
282 (let ((hmargin (style-hmargin (decoration-frame-style master)))
283 (vmargin (style-vmargin (decoration-frame-style master))))
284 (declare (type (unsigned-byte 16) hmargin vmargin))
285 (multiple-value-bind (w h) (drawable-sizes window)
286 (declare (type xlib:card16 w h))
287 (setf (drawable-sizes (widget-window master))
288 (values (+ w hmargin) (+ h vmargin)))))))
289
290 (defmethod resize
291 ((master decoration) (event motion-notify) &optional verbose-p mode)
292 (declare (optimize (speed 3) (safety 0)))
293 (declare (inline update-edges-geometry resize-internal))
294 (if (eql mode :opaque)
295 (with-event-mask ((slot-value master 'window))
296 (resize-internal master event verbose-p)
297 (update-edges-geometry master)
298 (resize-from master))
299 (with-slots (window gcontext) *clone*
300 (let ((root-window (xlib:drawable-root window)))
301 (draw-window-grid window gcontext root-window)
302 (resize-internal *clone* event verbose-p)
303 (draw-window-grid window gcontext root-window)))))
304
305 ;;;; Move.
306
307 (defvar *screen-windows* nil)
308
309 (defgeneric initialize-move (widget event)
310 (:documentation "Initialize internal values for animating the future widget
311 movements."))
312
313 (defgeneric finalize-move (widget)
314 (:documentation "Finalize (send synthetic configure-notify ..."))
315
316 (defun region-intersect-region-p (x y w h x2 y2 w2 h2)
317 "Returns true if the rectangular regions, described by the two four-uple
318 `x y w h', have a not empty intersection."
319 (declare (optimize (speed 3) (safety 0)))
320 (declare (type (signed-byte 16) x y x2 y2))
321 (declare (type (unsigned-byte 16) w h w2 h2))
322 (and (<= x (+ x2 w2)) (<= x2 (+ x w)) (<= y (+ y2 h2)) (<= y2 (+ y h))))
323
324 (defun region-intersect-window-in-screen (x y w h &rest windows-to-skip)
325 "Returns a window list that has an intersection with the given region
326 (defines by the four-uple `x y w h'). The windows-to-skip argument is
327 a list of window that should not be used."
328 (declare (optimize (speed 3) (safety 0)))
329 (declare (type (signed-byte 16) x y))
330 (declare (type (unsigned-byte 16) w h))
331 (declare (inline region-intersect-region-p))
332 (loop for win in *screen-windows*
333 for widget = (lookup-widget win)
334 for master = (when widget (application-master widget))
335 when master do (setf win (widget-window master)) end
336 when (and (or widget master)
337 (not (member win windows-to-skip :test #'xlib:window-equal))
338 (multiple-value-bind (x2 y2 w2 h2) (window-geometry win)
339 (declare (type (signed-byte 16) x2 y2))
340 (declare (type (unsigned-byte 16) w2 h2))
341 (region-intersect-region-p x y w h x2 y2 w2 h2)))
342 collect win))
343
344 (defun perform-dock (window x y)
345 "Returns the new coordinates of the window if it needs do be docked on
346 one or two window present on that desktop. Otherwise x and y will be
347 returned. Arguments x, y represent the hypotheticals future coordinates."
348 (declare (optimize (speed 3) (safety 0)))
349 (declare (type (signed-byte 16) x y))
350 (multiple-value-bind (x1 y1 w1 h1) (window-geometry window)
351 (declare (type (signed-byte 16) x1 y1))
352 (declare (type (unsigned-byte 16) w1 h1))
353 (loop with x-already-set-p and y-already-set-p
354 for win in (region-intersect-window-in-screen x y w1 h1 window)
355 do (multiple-value-bind (x2 y2 w2 h2) (window-geometry win)
356 (declare (type (signed-byte 16) x2 y2))
357 (declare (type (unsigned-byte 16) w2 h2))
358 (unless x-already-set-p
359 (cond ((and (<= (+ x1 w1) x2) (<= -40 (- x2 x w1) 0))
360 (setf x (- x2 w1)) (setf x-already-set-p t))
361 ((and (>= x1 (+ x2 w2)) (<= -40 (- x x2 w2) 0))
362 (setf x (+ x2 w2)) (setf x-already-set-p t))))
363 (unless y-already-set-p
364 (cond ((and (>= y1 (+ y2 h2)) (<= -40 (- y y2 h2) 0))
365 (setf y (+ y2 h2)) (setf y-already-set-p t))
366 ((and (<= (+ y1 h1) y2) (<= -40 (- y2 y h1) 0))
367 (setf y (- y2 h1)) (setf y-already-set-p t)))))
368 when (and x-already-set-p y-already-set-p) do (loop-finish)
369 finally (return (values x y)))))
370
371 (defun perform-root-dock (window x y)
372 "Returns the new coordinates of the window if it needs do be docked
373 on the root window. Otherwise x and y will be returned.
374 Arguments x, y represent the hypotheticals future coordinates."
375 (declare (optimize (speed 3) (safety 0)))
376 (declare (type (signed-byte 16) x y))
377 (multiple-value-bind (x1 y1 w1 h1) (window-geometry window)
378 (declare (type (signed-byte 16) x1 y1))
379 (declare (type (unsigned-byte 16) w1 h1))
380 (and (>= x1 0) (< -40 x 0) (setf x 0))
381 (and (>= y1 0) (< -40 y 0) (setf y 0))
382 (let ((scr-w (screen-width)) (scr-h (screen-height)))
383 (declare (type (unsigned-byte 16) scr-w scr-h))
384 (and (>= (- scr-w x1 w1) 0) (< -40 (- scr-w x w1) 0)
385 (setf x (- scr-w w1)))
386 (and (>= (- scr-h y1 h1) 0) (< -40 (- scr-h y h1) 0)
387 (setf y (- scr-h h1)))))
388 (values x y))
389
390 (defun move-widget (widget event &optional verbose-p mode)
391 (declare (optimize (speed 3) (safety 0)))
392 (with-slots (window active-p gcontext) widget
393 (when active-p
394 (let ((new-x (- (the (signed-byte 16) (event-root-x event)) *delta-x*))
395 (new-y (- (the (signed-byte 16) (event-root-y event)) *delta-y*)))
396 (declare (type (signed-byte 16) new-x new-y))
397 (let ((aux (if (eq mode :box) (widget-window *clone*) window)))
398 (declare (inline perform-dock perform-root-dock))
399 (when *standard-window-edge-resistant-p*
400 (multiple-value-setq (new-x new-y)
401 (perform-dock aux new-x new-y)))
402 (when *screen-edge-resistant-p*
403 (multiple-value-setq (new-x new-y)
404 (perform-root-dock aux new-x new-y))))
405 (when verbose-p (display-coordinates new-x new-y))
406 (if (and (or (decoration-p widget) (application-p widget))
407 (eql mode :box))
408 (with-slots (window) *clone*
409 (let ((root-window (xlib:drawable-root window)))
410 (draw-window-grid window gcontext root-window)
411 (setf (window-position window) (values new-x new-y))
412 (draw-window-grid window gcontext root-window)))
413 (setf (window-position window) (values new-x new-y)))))))
414
415 (defun finish-move (widget &optional verbose-p mode)
416 "Ends the move work (undraw grid, geometry infos, ...)."
417 (with-slots ((widget-window window) active-p) widget
418 (when (eql mode :box)
419 (with-slots (window gcontext) *clone*
420 (draw-window-grid window gcontext (xlib:drawable-root window))
421 (setf (window-position widget-window) (window-position window))))
422 (setf active-p nil)
423 (when verbose-p (undraw-geometry-info-box)))
424 (setf *screen-windows* nil)
425 (finalize-move widget))
426
427 (defmethod initialize-move ((widget base-widget) (event button-press))
428 (with-slots (window active-p) widget
429 (setf (window-priority window) :above)
430 (unless (widget-position-fix-p widget)
431 (setf active-p t
432 *delta-x* (- (event-root-x event) (xlib:drawable-x window))
433 *delta-y* (- (event-root-y event) (xlib:drawable-y window))
434 *screen-windows* (screen-content (current-desk)
435 :skip-dock nil
436 :skip-taskbar nil)))))
437
438 (defmethod finalize-move ((master decoration))
439 (when (get-child master :title-bar)
440 (with-slots (armed active-p) (get-child master :title-bar)
441 (setf armed nil active-p nil)))
442 (send-configuration-notify (get-child master :application :window t)))
443
444 (defmethod finalize-move ((application application))
445 (send-configuration-notify (widget-window application)))

  ViewVC Help
Powered by ViewVC 1.1.5