← Back to branch summary

~ubuntu-branches/ubuntu/lucid/sawfish/lucid-updates

« back to all changes in this revision

Viewing changes to lisp/sawfish/wm/commands/viewport-extras.jl

  • Committer: Bazaar Package Importer
  • Author(s): Christian Marillat
  • Date: 2002-01-20 17:42:28 UTC
  • Revision ID: james.westby@ubuntu.com-20020120174228-4q1ydztbkvfq1ht2
Tags: upstream-1.0.1.20020116
Import upstream version 1.0.1.20020116

Show diffs side-by-side

added added

removed removed

Lines of Context:
lisp/sawfish/wm/commands/viewport-extras.jl
 
1
#| viewport-extras.jl -- extra viewport commands
 
2
 
 
3
   $Id: viewport-extras.jl,v 1.1 2000/12/06 21:33:28 jsh Exp $
 
4
 
 
5
   Contributed by: Dams Nad� <anvil@amin.unice.fr>
 
6
|#
 
7
 
 
8
(define-structure sawfish.wm.commands.viewport-extras ()
 
9
 
 
10
    (open rep
 
11
          sawfish.wm.viewport
 
12
          sawfish.wm.commands)
 
13
 
 
14
  ;; Returns (cons next-x next-y) from current screen-viewport
 
15
  (define (next-coords)
 
16
    (let* ((port (screen-viewport))
 
17
           (x (car port))
 
18
           (y (cdr port))
 
19
           (xmax (- (car viewport-dimensions) 1))
 
20
           (ymax (- (cdr viewport-dimensions) 1)))
 
21
      (cond ((not (= x xmax)) (cons (+ 1 x) y))
 
22
            ((= y ymax) (cons 0 0))
 
23
            (t (cons 0 (+ y 1))))))
 
24
 
 
25
  ;; Returns (cons prev-x prev-y) from current screen-viewport
 
26
  (define (previous-coords)
 
27
    (let* ((port (screen-viewport))
 
28
           (x (car port))
 
29
           (y (cdr port))
 
30
           (xmax (- (car viewport-dimensions) 1))
 
31
           (ymax (- (cdr viewport-dimensions) 1)))
 
32
      (cond ((not (= 0 x)) (cons (- x 1) y))
 
33
            ((= y 0) (cons xmax ymax))
 
34
            (t (cons xmax (- y 1))))))
 
35
 
 
36
  ;; Move window & screen-viewport
 
37
  (define (set-window-and-viewport w x y)
 
38
    (set-window-viewport w x y)
 
39
    (set-screen-viewport x y))
 
40
 
 
41
  (define (move-viewport-next)
 
42
    "Move to the next viewport."
 
43
    (let ((nextcoords (next-coords)))
 
44
      (set-screen-viewport (car nextcoords) (cdr nextcoords))))
 
45
 
 
46
  (define (move-viewport-previous)
 
47
    "Move to the previous viewport."
 
48
    (let ((prevcoords (previous-coords)))
 
49
      (set-screen-viewport (car prevcoords) (cdr prevcoords))))
 
50
 
 
51
  (define (move-window-next w)
 
52
    "Move the window to the next viewport."
 
53
    (let ((nexts (next-coords)))
 
54
      (set-window-and-viewport w (car nexts) (cdr nexts))))
 
55
 
 
56
  (define (move-window-previous w)
 
57
    "Move the window to the previous viewport."
 
58
    (let ((prevs (previous-coords)))
 
59
      (set-window-and-viewport w (car prevs) (cdr prevs))))
 
60
 
 
61
  ;;###autoload
 
62
  (define-command 'move-viewport-next move-viewport-next)
 
63
  (define-command 'move-viewport-previous move-viewport-previous)
 
64
  (define-command 'move-window-previous move-window-previous #:spec "%W")
 
65
  (define-command 'move-window-next move-window-next #:spec "%W"))