← Back to branch summary

~ubuntu-branches/ubuntu/natty/sawfish/natty

« back to all changes in this revision

Viewing changes to lisp/sawfish/wm/util/window-outline.jl

  • Committer: Bazaar Package Importer
  • Author(s): Luis Rodrigo Gallardo Cruz
  • Date: 2009-11-23 09:05:20 UTC
  • mfrom: (1.2.10 upstream) (3.1.5 sid)
  • Revision ID: james.westby@ubuntu.com-20091123090520-3u8sefrr4lmfsiem
Tags: 1:1.5.3-2
http://bugs.debian.org/557250
http://bugs.debian.org/556991
* Remove reference to sawMILL in 00debian.jl (Closes: #557250).
* Remove empty doc dirs and replace them with symlinks (Closes: #556991).
* Rename sawfish maintainer scripts with the binary package name.

Show diffs side-by-side

added added

removed removed

Lines of Context:
lisp/sawfish/wm/util/window-outline.jl
3
3
 
4
4
;; Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>
5
5
 
6
 
;; This file is part of sawmill.
 
6
;; This file is part of sawfish.
7
7
 
8
 
;; sawmill is free software; you can redistribute it and/or modify it
 
8
;; sawfish is free software; you can redistribute it and/or modify it
9
9
;; under the terms of the GNU General Public License as published by
10
10
;; the Free Software Foundation; either version 2, or (at your option)
11
11
;; any later version.
12
12
 
13
 
;; sawmill is distributed in the hope that it will be useful, but
 
13
;; sawfish is distributed in the hope that it will be useful, but
14
14
;; WITHOUT ANY WARRANTY; without even the implied warranty of
15
15
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
16
;; GNU General Public License for more details.
17
17
 
18
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
 
19
;; along with sawfish; see the file COPYING.  If not, write to
20
20
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
21
21
 
22
22
(define-structure sawfish.wm.util.window-outline
27
27
            autoload-window-outliner)
28
28
 
29
29
    (open rep
30
 
          rep.util.autoloader)
 
30
          rep.util.autoloader
 
31
          sawfish.wm.misc)
31
32
 
32
33
  (define-structure-alias window-outline sawfish.wm.util.window-outline)
33
34
 
94
95
      (x-fill-rectangle 'root gc (cons x y) (cons width height))
95
96
      (x-destroy-gc gc)))
96
97
 
97
 
  (define-window-outliner 'solid draw-solid-outline))
 
98
  (define-window-outliner 'solid draw-solid-outline)
 
99
 
 
100
  (define (draw-cross-outline x y width height)
 
101
    (require 'sawfish.wm.util.x)
 
102
      (let
 
103
        ((gc (x-create-root-xor-gc))
 
104
         (ul (cons x y))                      ; upper left
 
105
         (ur (cons (+ x width) y))            ; upper right
 
106
         (ll (cons x (+ y height)))           ; lower left
 
107
         (lr (cons (+ x width) (+ y height))) ; lower right
 
108
        )
 
109
      ; perimeter outline
 
110
      (x-draw-line 'root gc ul ur)
 
111
      (x-draw-line 'root gc ll lr)
 
112
      (x-draw-line 'root gc ul ll)
 
113
      (x-draw-line 'root gc ur lr)
 
114
      ; cross
 
115
      (x-draw-line 'root gc ul lr)
 
116
      (x-draw-line 'root gc ur ll)
 
117
      (x-destroy-gc gc)))
 
118
 
 
119
  (define-window-outliner 'cross draw-cross-outline)
 
120
 
 
121
  (define (draw-elliptical-outline x y width height)
 
122
    (require 'sawfish.wm.util.x)
 
123
    (let
 
124
      ((gc (x-create-root-xor-gc))
 
125
       (height-prime (inexact->exact (floor (* height 1.4142))))
 
126
       (width-prime  (inexact->exact (floor (* width 1.4142))))
 
127
      )
 
128
    ; draw the circumscribed ellipse (the outside one)
 
129
    (x-draw-arc 'root gc (cons (inexact->exact (- x (floor (/ width 4.8))))
 
130
                               (inexact->exact (- y (floor (/ height 4.8)))))
 
131
                (cons width-prime height-prime)
 
132
                (cons 0 (* 360 64)))
 
133
    ; draw the inscribed ellipse (the inside one)
 
134
    (x-draw-arc 'root gc (cons x y)
 
135
                (cons width height)
 
136
                (cons 0 (* 360 64)))
 
137
    (x-destroy-gc gc)))
 
138
 
 
139
  (define-window-outliner 'elliptical draw-elliptical-outline)
 
140
 
 
141
  (define (draw-draft-line rw gc pta ptb dim-p arrow-p)
 
142
    (require 'sawfish.wm.util.x)
 
143
    (let ((pta-x (car pta)) ; recover the components
 
144
        (pta-y (cdr pta))
 
145
        (ptb-x (car ptb))
 
146
        (ptb-y (cdr ptb))
 
147
        (delta-x (- (car ptb) (car pta))) ; figure out the difference
 
148
        (delta-y (- (cdr ptb) (cdr pta)))
 
149
        (xah 4)  ; cope with different window scales
 
150
        (yah 3)  ; to ensure arrow heads look the same
 
151
        (x-dim-offset 5) ; how far to offset the dimension from the
 
152
        (y-dim-offset 5) ; draft line
 
153
        )
 
154
    ; first off, we know we are going to draw the line, always
 
155
    (x-draw-line rw gc pta ptb)
 
156
    ; now figure out if we drawing vertically or horizontally
 
157
    (if (= pta-x ptb-x)
 
158
        (progn ; vertical
 
159
         (if dim-p
 
160
             (x-draw-string rw gc (cons (+ pta-x x-dim-offset)
 
161
                                        (+ pta-y (quotient delta-y 2))
 
162
                                        )
 
163
                            (format nil "%d" delta-y)))
 
164
         (if arrow-p
 
165
             (progn
 
166
               (x-draw-line rw gc pta (cons (+ pta-x xah) (+ pta-y yah)))
 
167
               (x-draw-line rw gc pta (cons (- pta-x xah) (+ pta-y yah)))
 
168
               (x-draw-line rw gc ptb (cons (+ ptb-x xah) (- ptb-y yah)))
 
169
               (x-draw-line rw gc ptb (cons (- ptb-x xah) (- ptb-y yah)))
 
170
              ))
 
171
         )
 
172
        (progn ; horizontal
 
173
         (if dim-p
 
174
           (x-draw-string rw gc (cons (+ pta-x (quotient delta-x 2))
 
175
                                      (- pta-y y-dim-offset)
 
176
                                      )
 
177
                            (format nil "%d" delta-x)))
 
178
         (if arrow-p
 
179
             (progn
 
180
               (x-draw-line rw gc pta (cons (+ pta-x xah) (+ pta-y yah)))
 
181
               (x-draw-line rw gc pta (cons (+ pta-x xah) (- pta-y yah)))
 
182
               (x-draw-line rw gc ptb (cons (- ptb-x xah) (+ ptb-y yah)))
 
183
               (x-draw-line rw gc ptb (cons (- ptb-x xah) (- ptb-y yah)))
 
184
               ))
 
185
        ))))
 
186
 
 
187
  (define (draw-draft-outline x y width height)
 
188
    (require 'sawfish.wm.util.x)
 
189
    (let
 
190
      ((gc (x-create-root-xor-gc))
 
191
       ; window Upper (Left Middle Right)
 
192
       (ul (cons x y))
 
193
       (um (cons (+ x (quotient width 2)) y))
 
194
       (ur (cons (+ x width) y))
 
195
 
 
196
       ; window Middle (Left Right)
 
197
       (ml (cons x           (+ y (quotient height 2))))
 
198
       (mr (cons (+ x width) (+ y (quotient height 2))))
 
199
 
 
200
       ; window Lower (Left Middle Right)
 
201
       (ll (cons x (+ y height)))
 
202
       (lm (cons (+ x (quotient width 2)) (+ y height)))
 
203
       (lr (cons (+ x width) (+ y height)))
 
204
 
 
205
       ; window Screen (Left Right Top Bottom)
 
206
       (sl (cons 0              (+ y (quotient height 2))))
 
207
       (sr (cons (screen-width) (+ y (quotient height 2))))
 
208
       (st (cons (+ x (quotient width 2)) 0))
 
209
       (sb (cons (+ x (quotient width 2)) (screen-height)))
 
210
 
 
211
       (offset 3) ; how much to offset the guidelines from the window
 
212
       )
 
213
    ; perimeter outline of window + frame
 
214
    ; is there an x-draw-retangle ?
 
215
    (x-draw-line 'root gc ul ur)
 
216
    (x-draw-line 'root gc ll lr)
 
217
    (x-draw-line 'root gc ul ll)
 
218
    (x-draw-line 'root gc ur lr)
 
219
    ; from screen left to left border
 
220
    (x-draw-line 'root gc (cons 0 y)            (cons (- x offset) y))
 
221
    (x-draw-line 'root gc (cons 0 (+ y height))
 
222
                 (cons (- x offset) (+ y height)))
 
223
    (draw-draft-line 'root gc sl ml t t)
 
224
    ; from screen top to top border
 
225
    (x-draw-line 'root gc (cons x 0) (cons x (- y offset)))
 
226
    (x-draw-line 'root gc (cons (+ x width) 0) (cons (+ x width) (- y offset)))
 
227
    (draw-draft-line 'root gc st um t t)
 
228
    ; from screen right to right border
 
229
    (x-draw-line 'root gc (cons (screen-width) y)
 
230
                 (cons (+ x width offset) y))
 
231
    (x-draw-line 'root gc (cons (screen-width) (+ y height))
 
232
                 (cons (+ x width offset) (+ y height)))
 
233
    (draw-draft-line 'root gc mr sr t t)
 
234
    ; from screen bottom to bottom border
 
235
    (x-draw-line 'root gc (cons x (screen-height))
 
236
                 (cons x (+ y height offset)))
 
237
    (x-draw-line 'root gc (cons (+ x width) (screen-height))
 
238
                 (cons (+ x width) (+ y height offset)))
 
239
    (draw-draft-line 'root gc lm sb 't 't)
 
240
    (x-destroy-gc gc)))
 
241
 
 
242
  (define-window-outliner 'draft draw-draft-outline))