1
;;; $Id: shrink-yank.jl,v 1.10 2008/06/23 11:39:07 thk Exp $
2
;;; shrink windows to fit or yank them free.
3
;; Copyright 2000, 2001, 2003, 2005 by Timo Korvola <tkorvola@iki.fi>
6
;; This package provides functions to shrink or yank a window in the
7
;; four cardinal directions. Shrinking resizes the window by moving one
8
;; of its edges and yanking moves the window to meet the following condition:
9
;; - if the window was partially (or in case of yanking even entirely) outside
10
;; the screen it will be entirely on the screen,
11
;; - otherwise, if the window intersected with other windows it will intersect
12
;; with one window less,
13
;; - otherwise the window will not be moved or resized.
15
;; If the window reaches its minimum size before this condition can be
16
;; satisfied the window is resized to the minimum size instead. There
17
;; is also a minimum size constraint `shrink-window-minimum', which
18
;; applies to all windows. However, it is measured in pixels and
19
;; windows may actually become smaller than the specified value due to
22
;; If the window would have to be yanked off the screen to satisfy the
23
;; condition `yank-window-minimum-visible' pixels will be left visible instead.
25
(define-structure sawfish.wm.commands.shrink-yank ()
29
sawfish.wm.commands.grow-pack
32
sawfish.wm.state.maximize
33
sawfish.wm.state.iconify
39
(define-structure-alias shrink-yank sawfish.wm.commands.shrink-yank)
41
(defgroup shrink-yank "Shrinking and Yanking of windows" :group misc)
43
(defcustom shrink-window-minimum-size 10
44
"The minimum height or width to which a window may be shrunk."
46
:group (misc shrink-yank))
48
(defcustom yank-window-minimum-visible 10
49
"The minimum amount of window left visible, if yanked over the edge."
51
:group (misc shrink-yank))
55
(define (shrink-window-left window)
56
"Shrinks WINDOW by moving the right edge to the left until it intersects
57
with one window less than before."
58
(shrink-window window 'left))
60
(define (shrink-window-right window)
61
"Shrinks WINDOW by moving the left edge to the right until it intersects
62
with one window less than before."
63
(shrink-window window 'right))
65
(define (shrink-window-up window)
66
"Shrinks WINDOW by moving the lower edge upwards until it intersects
67
with one window less than before."
68
(shrink-window window 'up))
70
(define (shrink-window-down window)
71
"Shrinks WINDOW by moving the upper edge downwards until it intersects
72
with one window less than before."
73
(shrink-window window 'down))
75
(define (yank-window-left window)
76
"Yanks WINDOW to the left until it inserts with one window less than before."
77
(yank-window window 'left))
79
(define (yank-window-right window)
80
"Yanks WINDOW to the right until it inserts with one window less than before."
81
(yank-window window 'right))
83
(define (yank-window-up window)
84
"Yanks WINDOW upwards until it inserts with one window less than before."
85
(yank-window window 'up))
87
(define (yank-window-down window)
88
"Yanks WINDOW downwards until it inserts with one window less than before."
89
(yank-window window 'down))
92
(define-command 'shrink-window-left shrink-window-left #:spec "%W")
93
(define-command 'shrink-window-right shrink-window-right #:spec "%W")
94
(define-command 'shrink-window-up shrink-window-up #:spec "%W")
95
(define-command 'shrink-window-down shrink-window-down #:spec "%W")
96
(define-command 'yank-window-left yank-window-left #:spec "%W")
97
(define-command 'yank-window-right yank-window-right #:spec "%W")
98
(define-command 'yank-window-up yank-window-up #:spec "%W")
99
(define-command 'yank-window-down yank-window-down #:spec "%W")
103
(define (window-frame-rect window)
104
"Returns the rectangle (left top right bottom) describing the frame
105
dimensions of WINDOW."
106
(let* ((wpos (window-position window))
107
(wdim (window-frame-dimensions window))
110
(list wleft wtop (+ wleft (car wdim)) (+ wtop (cdr wdim)))))
112
;; I can never remember these!
116
(define bottom cadddr)
118
(define (maybe-warp-pointer window old-rect direction maybe)
119
(define (scale x x0 x1 x0new x1new)
120
(round (/ (+ (* (- x x0) x1new)
123
(define (truncate-rect r)
124
(list (max (left r) 0)
126
(min (right r) (screen-width))
127
(min (bottom r) (screen-height))))
128
(case pack-warp-pointer
129
((always) (warp-cursor-to-window window))
132
(let* ((owr (truncate-rect old-rect))
133
(nwr (truncate-rect (window-frame-rect window)))
134
(ppos (query-pointer))
139
(setq xpos (scale xpos (left owr) (right owr)
140
(left nwr) (right nwr))))
142
(setq ypos (scale ypos (top owr) (bottom owr)
143
(top nwr) (bottom nwr)))))
144
(warp-cursor xpos ypos))))))
146
;; Return the coordinate of the window intersection to shink or yank to.
147
;; This will do for both shrinking and yanking although the
148
;; requirements are slightly different: e.g., a window that
149
;; completely surrounds the active window is irrelevant for shrinking.
150
(define (find-least-intersection window wr direction yank)
151
(let* ((isect-coord (if yank
154
((right) (screen-width))
155
((down) (screen-height)))
160
((down) (bottom wr)))))
161
(isect-check (case direction
164
(and (< isect-coord (left xr) (right wr))
165
(setq isect-coord (left xr)))))
168
(and (< isect-coord (top xr) (bottom wr))
169
(setq isect-coord (top xr)))))
172
(and (< (left wr) (right xr) isect-coord)
173
(setq isect-coord (right xr)))))
176
(and (< (top wr) (bottom xr) isect-coord)
177
(setq isect-coord (bottom xr))))))))
178
;; If the window is partially (shrink or yank) or entirely (yank only)
179
;; outside the screen return the screen edge.
180
(cond ((and (eq direction 'left)
181
(< isect-coord (screen-width) (right wr)))
183
((and (eq direction 'right) (< (left wr) 0 isect-coord))
185
((and (eq direction 'up)
186
(< isect-coord (screen-height) (bottom wr)))
188
((and (eq direction 'down) (< (top wr) 0 isect-coord))
193
(and (not (eql x window))
194
(not (window-iconified-p x))
195
(window-appears-in-workspace-p x current-workspace)
196
(let ((xr (window-frame-rect x)))
197
(and (positivep (rect-2d-overlap* wr xr))
201
(and win isect-coord))))))
203
(define (shrink-window window direction)
204
"Shrinks WINDOW by moving the edge opposite to DIRECTION (left, right,
205
up or down) towards DIRECTION until it intersects with one window less than
207
(let* ((wr (window-frame-rect window))
208
(isect-coord (find-least-intersection window wr direction nil))
211
(wdim (window-dimensions window))
213
(nheight (cdr wdim)))
214
(when (and isect-coord
215
(let ((max-shrinkage (- (case direction
216
((left right) nwidth)
218
shrink-window-minimum-size)))
219
(when (positivep max-shrinkage)
221
((left) (setq nwidth (- nwidth
225
((up) (setq nheight (- nheight
229
((right) (setq nwidth (- nwidth
233
((down) (setq nheight (- nheight
237
(let ((tem (cons nwidth nheight)))
238
(maximize-truncate-dims window tem)
239
(setq nwidth (car tem)
242
((right) (setq nleft (+ nleft (- (car wdim) nwidth))))
243
((down) (setq ntop (+ ntop (- (cdr wdim) nheight)))))
244
(let ((pointerw (query-pointer-window)))
245
(move-resize-window-to window nleft ntop nwidth nheight)
246
(maybe-warp-pointer window wr direction (eql window pointerw))))))
248
(define (yank-window window direction)
249
"Moves WINDOW towards DIRECTION (left, right, up or down) until
250
WINDOW intersects with one window less than before."
251
(let* ((wr (window-frame-rect window))
252
(isect-coord (find-least-intersection window wr direction t))
257
((left) (let ((max-move (- (right wr)
258
yank-window-minimum-visible)))
259
(when (positivep max-move)
262
(- (right wr) isect-coord)))))))
263
((up) (let ((max-move (- (bottom wr)
264
yank-window-minimum-visible)))
265
(when (positivep max-move)
268
(- (bottom wr) isect-coord)))))))
269
((right) (let ((max-pos (- (screen-width)
270
yank-window-minimum-visible)))
271
(when (< (left wr) max-pos)
272
(setq nleft (min max-pos isect-coord)))))
273
((down) (let ((max-pos (- (screen-height)
274
yank-window-minimum-visible)))
275
(when (< (top wr) max-pos)
276
(setq ntop (min max-pos isect-coord))))))
277
(let ((pointerw (query-pointer-window)))
278
(move-window-to window nleft ntop)
279
(maybe-warp-pointer window wr
280
direction (eql window pointerw)))))))
added
removed
lisp/sawfish/wm/commands/shrink-yank.jl
