1
;; viewport.jl -- virtual desktops
2
;; $Id: viewport.jl,v 1.42 2001/12/05 01:04:52 federico Exp $
4
;; Copyright (C) 1999 John Harper <john@dcs.warwick.ac.uk>
6
;; This file is part of sawmill.
8
;; sawmill is free software; you can redistribute it and/or modify it
9
;; under the terms of the GNU General Public License as published by
10
;; the Free Software Foundation; either version 2, or (at your option)
13
;; sawmill is distributed in the hope that it will be useful, but
14
;; WITHOUT ANY WARRANTY; without even the implied warranty of
15
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16
;; GNU General Public License for more details.
18
;; You should have received a copy of the GNU General Public License
19
;; along with sawmill; see the file COPYING. If not, write to
20
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
22
(define-structure sawfish.wm.viewport
27
select-workspace-and-viewport
29
move-viewport-to-window
30
window-outside-workspace-p
31
window-outside-viewport-p
32
move-window-to-current-viewport
36
window-absolute-position)
46
sawfish.wm.session.init)
48
;; Virtual workspaces are implemented by moving windows in and out of
49
;; the screen dimensions. E.g. moving to the left moves all windows one
50
;; screen-width to the right.
52
(defvar viewport-dimensions '(1 . 1)
53
"Size of each virtual workspace.")
55
(defcustom uniconify-to-current-viewport t
56
"Windows uniconify to the current viewport."
58
:group (min-max iconify))
61
;;; raw viewport handling
63
(defvar viewport-x-offset 0)
64
(defvar viewport-y-offset 0)
66
(define (set-viewport x y)
67
;; move W to its new position
68
(define (move-window w)
69
(unless (window-get w 'sticky-viewport)
70
(let ((pos (window-position w)))
71
(move-window-to w (- (+ (car pos) viewport-x-offset) x)
72
(- (+ (cdr pos) viewport-y-offset) y)))))
74
(unless (and (= viewport-x-offset x) (= viewport-y-offset y))
75
(let loop ((rest (stacking-order))
80
;; First move all windows not on the old viewport, and
81
;; move in top-to-bottom order..
82
(mapc move-window (nreverse outside))
83
;; ..then move away the windows on the old viewport,
84
;; in bottom-to-top order
85
(mapc move-window inside)))
87
((window-outside-viewport-p (car rest))
88
(loop (cdr rest) inside (cons (car rest) outside)))
90
(t (loop (cdr rest) (cons (car rest) inside) outside))))
92
(setq viewport-x-offset x)
93
(setq viewport-y-offset y)
94
(call-hook 'viewport-moved-hook)))
96
(define (viewport-before-exiting)
97
(set-screen-viewport 0 0))
99
(add-hook 'before-exit-hook viewport-before-exiting t)
102
;; screen sized viewport handling
104
(define (screen-viewport)
105
(cons (quotient viewport-x-offset (screen-width))
106
(quotient viewport-y-offset (screen-height))))
108
;; returns t if it actually moved the viewport
109
(define (set-screen-viewport col row)
110
(when (and (>= col 0) (< col (car viewport-dimensions))
111
(>= row 0) (< row (cdr viewport-dimensions)))
112
(set-viewport (* col (screen-width))
113
(* row (screen-height)))
116
(define (select-workspace-and-viewport space col row)
117
(select-workspace space nil (lambda ()
118
(set-screen-viewport col row))))
120
;; returns t if it actually moved the viewport
121
(define (move-viewport right down)
122
(let ((port (screen-viewport)))
123
(set-screen-viewport (+ (car port) right)
124
(+ (cdr port) down))))
126
(define (move-viewport-to-window window)
127
(when (window-outside-viewport-p window)
128
(let ((pos (window-position window)))
129
(rplaca pos (+ (car pos) viewport-x-offset))
130
(rplacd pos (+ (cdr pos) viewport-y-offset))
131
(set-screen-viewport (quotient (car pos) (screen-width))
132
(quotient (cdr pos) (screen-height))))))
134
(define (window-outside-workspace-p window)
135
(let ((pos (window-position window))
136
(dims (window-frame-dimensions window))
137
(left (- viewport-x-offset))
138
(right (- (* (car viewport-dimensions) (screen-width))
140
(top (- viewport-y-offset))
141
(bottom (- (* (cdr viewport-dimensions) (screen-height))
143
(or (>= (car pos) right)
144
(>= (cdr pos) bottom)
145
(<= (+ (car pos) (car dims)) left)
146
(<= (+ (cdr pos) (cdr dims)) top))))
148
(define (window-outside-viewport-p window)
149
(let ((pos (window-position window))
150
(dims (window-frame-dimensions window)))
151
(or (<= (+ (car pos) (car dims)) 0)
152
(<= (+ (cdr pos) (cdr dims)) 0)
153
(>= (car pos) (screen-width))
154
(>= (cdr pos) (screen-height)))))
156
(define (move-window-to-current-viewport window)
157
(when (and (window-outside-viewport-p window)
158
(not (window-get window 'sticky-viewport)))
159
(let ((pos (window-position window)))
160
(move-window-to window (mod (car pos) (screen-width))
161
(mod (cdr pos) (screen-height))))))
163
(define (set-window-viewport window col row)
164
(unless (window-get window 'sticky-viewport)
165
(let ((pos (window-position window)))
166
(setq col (max 0 (min (1- (car viewport-dimensions)) col)))
167
(setq row (max 0 (min (1- (cdr viewport-dimensions)) row)))
168
(setq col (+ (* col (screen-width)) (mod (car pos) (screen-width))))
169
(setq row (+ (* row (screen-height)) (mod (cdr pos) (screen-height))))
171
window (- col viewport-x-offset) (- row viewport-y-offset)))))
173
(define (move-window-viewport window col row)
174
(let ((pos (window-position window)))
175
(set-window-viewport window
176
(+ (quotient (+ (car pos) viewport-x-offset)
178
(+ (quotient (+ (cdr pos) viewport-y-offset)
179
(screen-height)) row))))
181
(define (window-viewport w)
182
(let ((position (window-position w)))
183
(cons (quotient (+ (car position) viewport-x-offset) (screen-width))
184
(quotient (+ (cdr position) viewport-y-offset) (screen-height)))))
186
(define (window-absolute-position w)
187
(let ((position (window-position w)))
188
(if (window-outside-viewport-p w)
189
(cons (mod (+ (car position) viewport-x-offset) (screen-width))
190
(mod (+ (cdr position) viewport-y-offset) (screen-height)))
193
(define (viewport-size-changed)
194
(let ((port (screen-viewport)))
195
(set-screen-viewport (min (car port) (1- (car viewport-dimensions)))
196
(min (cdr port) (1- (cdr viewport-dimensions))))
197
(map-windows (lambda (w)
198
(when (window-outside-workspace-p w)
199
(move-window-to-current-viewport w))))
200
(call-hook 'viewport-resized-hook)))
205
(define (activate-viewport x y)
206
"Select the specified viewport."
207
(set-screen-viewport (1- x) (1- y)))
209
(define-command 'activate-viewport activate-viewport
211
#:type `(and (labelled ,(_ "Column:") (number 1))
212
(labelled ,(_ "Row:") (number 1))))
214
(define (activate-viewport-column x)
215
"Select the specified viewport column."
216
(set-screen-viewport (1- x) (cdr (screen-viewport))))
218
(define-command 'activate-viewport-column activate-viewport-column
220
#:type `(and (labelled ,(_ "Column:") (number 1))))
222
(define (activate-viewport-row y)
223
"Select the specified viewport row."
224
(set-screen-viewport (car (screen-viewport)) (1- y)))
226
(define-command 'activate-viewport-row activate-viewport-row
228
#:type `(and (labelled ,(_ "Row:") (number 1))))
230
(define (move-window-to-viewport x y)
231
"Move the current window to the specified viewport."
232
(move-window-viewport (current-event-window) (1- x) (1- y)))
234
(define-command 'move-window-to-viewport move-window-to-viewport
236
#:type '(and (labelled "X:" (number 1)) (labelled "Y:" (number 1))))
238
(define (move-viewport-right)
239
"Move the viewport one screen to the right."
242
(define (move-viewport-left)
243
"Move the viewport one screen to the left."
244
(move-viewport -1 0))
246
(define (move-viewport-down)
247
"Move the viewport one screen down."
250
(define (move-viewport-up)
251
"Move the viewport one screen up."
252
(move-viewport 0 -1))
254
;; Moves the window by the specified offsets and then flips to the
255
;; viewport that is relative those offsets to the current viewport.
256
(define (move-window-to-viewport-and-move-viewport window col row)
257
(require 'sawfish.wm.util.stacking)
258
(let ((sticky-viewport (window-get window 'sticky-viewport)))
259
(window-put window 'sticky-viewport t)
261
(raise-window* window)
262
(move-viewport col row))
263
(unless sticky-viewport
264
(window-put window 'sticky-viewport nil))))
266
(define (move-window-left w)
267
"Move the window to the viewport on the left, and switch to that viewport."
268
(move-window-to-viewport-and-move-viewport w -1 0))
270
(define (move-window-right w)
271
"Move the window to the viewport on the right, and switch to that viewport."
272
(move-window-to-viewport-and-move-viewport w 1 0))
274
(define (move-window-down w)
275
"Move the window to the viewport below, and switch to that viewport."
276
(move-window-to-viewport-and-move-viewport w 0 1))
278
(define (move-window-up w)
279
"Move the window to the viewport above, and switch to that viewport."
280
(move-window-to-viewport-and-move-viewport w 0 -1))
282
(define-command 'move-viewport-right move-viewport-right)
283
(define-command 'move-viewport-left move-viewport-left)
284
(define-command 'move-viewport-up move-viewport-up)
285
(define-command 'move-viewport-down move-viewport-down)
286
(define-command 'move-window-right move-window-right #:spec "%W")
287
(define-command 'move-window-left move-window-left #:spec "%W")
288
(define-command 'move-window-up move-window-up #:spec "%W")
289
(define-command 'move-window-down move-window-down #:spec "%W")
292
;;; session management, config
294
(define (viewport-saved-state w)
295
(let ((position (window-position w)))
296
(when (window-get w 'sticky-viewport)
297
(rplaca position (mod (car position) (screen-width)))
298
(rplacd position (mod (cdr position) (screen-height))))
299
`((position . ,(window-absolute-position w))
300
(viewport . ,(window-viewport w)))))
302
(define (viewport-load-state w alist)
303
(let ((position (cdr (assq 'position alist)))
304
(viewport (cdr (assq 'viewport alist))))
306
(if (or (not viewport) (window-get w 'sticky-viewport))
307
(move-window-to w (car position) (cdr position))
308
(move-window-to w (+ (* (car viewport) (screen-width))
310
(+ (* (cdr viewport) (screen-height))
312
(when (window-outside-workspace-p w)
313
(move-window-to-current-viewport w)))
314
(window-put w 'placed t))))
316
(sm-add-saved-properties 'sticky-viewport)
317
(add-hook 'sm-window-save-functions viewport-saved-state)
318
(add-hook 'sm-restore-window-hook viewport-load-state)
320
(define (viewport-window-uniconified w)
321
(when uniconify-to-current-viewport
322
(move-window-to-current-viewport w)))
324
(add-hook 'workspace-geometry-changed
326
(setq viewport-dimensions (cdr workspace-geometry))
327
(viewport-size-changed)))
329
(add-hook 'uniconify-window-hook viewport-window-uniconified))
added
removed
lisp/sawfish/wm/viewport.jl
