/[cmucl]/src/clx/graphics.lisp
ViewVC logotype

Contents of /src/clx/graphics.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3.2.2 - (show annotations)
Tue May 23 16:36:00 2000 UTC (13 years, 11 months ago) by pw
Branch: RELENG_18
CVS Tags: RELEASE_18d, RELEASE_18c
Changes since 1.3.2.1: +3 -0 lines
This set of revisions brings the RELENG_18 branch up to HEAD in preparation
for an 18c release.
1 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
2
3 ;;; CLX drawing requests
4
5 ;;;
6 ;;; TEXAS INSTRUMENTS INCORPORATED
7 ;;; P.O. BOX 2909
8 ;;; AUSTIN, TEXAS 78769
9 ;;;
10 ;;; Copyright (C) 1987 Texas Instruments Incorporated.
11 ;;;
12 ;;; Permission is granted to any individual or institution to use, copy, modify,
13 ;;; and distribute this software, provided that this complete copyright and
14 ;;; permission notice is maintained, intact, in all copies and supporting
15 ;;; documentation.
16 ;;;
17 ;;; Texas Instruments Incorporated provides this software "as is" without
18 ;;; express or implied warranty.
19 ;;;
20 #+cmu
21 (ext:file-comment
22 "$Header: /tiger/var/lib/cvsroots/cmucl/src/clx/graphics.lisp,v 1.3.2.2 2000/05/23 16:36:00 pw Exp $")
23
24 (in-package :xlib)
25
26 (defvar *inhibit-appending* nil)
27
28 (defun draw-point (drawable gcontext x y)
29 ;; Should be clever about appending to existing buffered protocol request.
30 (declare (type drawable drawable)
31 (type gcontext gcontext)
32 (type int16 x y))
33 (let ((display (drawable-display drawable)))
34 (declare (type display display))
35 (with-display (display)
36 (force-gcontext-changes-internal gcontext)
37 (with-buffer-output (display :length *requestsize*)
38 (let* ((last-request-byte (display-last-request display))
39 (current-boffset buffer-boffset))
40 ;; To append or not append, that is the question
41 (if (and (not *inhibit-appending*)
42 last-request-byte
43 ;; Same request?
44 (= (aref-card8 buffer-bbuf last-request-byte) *x-polypoint*)
45 (progn ;; Set buffer pointers to last request
46 (set-buffer-offset last-request-byte)
47 ;; same drawable and gcontext?
48 (or (compare-request (4)
49 (data 0)
50 (drawable drawable)
51 (gcontext gcontext))
52 (progn ;; If failed, reset buffer pointers
53 (set-buffer-offset current-boffset)
54 nil))))
55 ;; Append request
56 (progn
57 ;; Set new request length
58 (card16-put 2 (index+ 1 (index-ash (index- current-boffset last-request-byte)
59 -2)))
60 (set-buffer-offset current-boffset)
61 (put-items (0) ; Insert new point
62 (int16 x y))
63 (setf (display-boffset display) (index+ buffer-boffset 4)))
64 ;; New Request
65 (progn
66 (put-items (4)
67 (code *x-polypoint*)
68 (data 0) ;; Relative-p false
69 (length 4)
70 (drawable drawable)
71 (gcontext gcontext)
72 (int16 x y))
73 (buffer-new-request-number display)
74 (setf (buffer-last-request display) buffer-boffset)
75 (setf (display-boffset display) (index+ buffer-boffset 16)))))))
76 (display-invoke-after-function display)))
77
78
79 (defun draw-points (drawable gcontext points &optional relative-p)
80 (declare (type drawable drawable)
81 (type gcontext gcontext)
82 (type sequence points) ;(repeat-seq (integer x) (integer y))
83 (type generalized-boolean relative-p))
84 (with-buffer-request ((drawable-display drawable) *x-polypoint* :gc-force gcontext)
85 ((data boolean) relative-p)
86 (drawable drawable)
87 (gcontext gcontext)
88 ((sequence :format int16) points)))
89
90 (defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p)
91 ;; Should be clever about appending to existing buffered protocol request.
92 (declare (type drawable drawable)
93 (type gcontext gcontext)
94 (type int16 x1 y1 x2 y2)
95 (type generalized-boolean relative-p))
96 (let ((display (drawable-display drawable)))
97 (declare (type display display))
98 (when relative-p
99 (incf x2 x1)
100 (incf y2 y1))
101 (with-display (display)
102 (force-gcontext-changes-internal gcontext)
103 (with-buffer-output (display :length *requestsize*)
104 (let* ((last-request-byte (display-last-request display))
105 (current-boffset buffer-boffset))
106 ;; To append or not append, that is the question
107 (if (and (not *inhibit-appending*)
108 last-request-byte
109 ;; Same request?
110 (= (aref-card8 buffer-bbuf last-request-byte) *x-polysegment*)
111 (progn ;; Set buffer pointers to last request
112 (set-buffer-offset last-request-byte)
113 ;; same drawable and gcontext?
114 (or (compare-request (4)
115 (drawable drawable)
116 (gcontext gcontext))
117 (progn ;; If failed, reset buffer pointers
118 (set-buffer-offset current-boffset)
119 nil))))
120 ;; Append request
121 (progn
122 ;; Set new request length
123 (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte)
124 -2)))
125 (set-buffer-offset current-boffset)
126 (put-items (0) ; Insert new point
127 (int16 x1 y1 x2 y2))
128 (setf (display-boffset display) (index+ buffer-boffset 8)))
129 ;; New Request
130 (progn
131 (put-items (4)
132 (code *x-polysegment*)
133 (length 5)
134 (drawable drawable)
135 (gcontext gcontext)
136 (int16 x1 y1 x2 y2))
137 (buffer-new-request-number display)
138 (setf (buffer-last-request display) buffer-boffset)
139 (setf (display-boffset display) (index+ buffer-boffset 20)))))))
140 (display-invoke-after-function display)))
141
142 (defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex))
143 (declare (type drawable drawable)
144 (type gcontext gcontext)
145 (type sequence points) ;(repeat-seq (integer x) (integer y))
146 (type generalized-boolean relative-p fill-p)
147 (type (member :complex :non-convex :convex) shape))
148 (if fill-p
149 (fill-polygon drawable gcontext points relative-p shape)
150 (with-buffer-request ((drawable-display drawable) *x-polyline* :gc-force gcontext)
151 ((data boolean) relative-p)
152 (drawable drawable)
153 (gcontext gcontext)
154 ((sequence :format int16) points))))
155
156 ;; Internal function called from DRAW-LINES
157 (defun fill-polygon (drawable gcontext points relative-p shape)
158 ;; This is clever about appending to previous requests. Should it be?
159 (declare (type drawable drawable)
160 (type gcontext gcontext)
161 (type sequence points) ;(repeat-seq (integer x) (integer y))
162 (type generalized-boolean relative-p)
163 (type (member :complex :non-convex :convex) shape))
164 (with-buffer-request ((drawable-display drawable) *x-fillpoly* :gc-force gcontext)
165 (drawable drawable)
166 (gcontext gcontext)
167 ((member8 :complex :non-convex :convex) shape)
168 (boolean relative-p)
169 ((sequence :format int16) points)))
170
171 (defun draw-segments (drawable gcontext segments)
172 (declare (type drawable drawable)
173 (type gcontext gcontext)
174 ;; (repeat-seq (integer x1) (integer y1) (integer x2) (integer y2)))
175 (type sequence segments))
176 (with-buffer-request ((drawable-display drawable) *x-polysegment* :gc-force gcontext)
177 (drawable drawable)
178 (gcontext gcontext)
179 ((sequence :format int16) segments)))
180
181 (defun draw-rectangle (drawable gcontext x y width height &optional fill-p)
182 ;; Should be clever about appending to existing buffered protocol request.
183 (declare (type drawable drawable)
184 (type gcontext gcontext)
185 (type int16 x y)
186 (type card16 width height)
187 (type generalized-boolean fill-p))
188 (let ((display (drawable-display drawable))
189 (request (if fill-p *x-polyfillrectangle* *x-polyrectangle*)))
190 (declare (type display display)
191 (type card16 request))
192 (with-display (display)
193 (force-gcontext-changes-internal gcontext)
194 (with-buffer-output (display :length *requestsize*)
195 (let* ((last-request-byte (display-last-request display))
196 (current-boffset buffer-boffset))
197 ;; To append or not append, that is the question
198 (if (and (not *inhibit-appending*)
199 last-request-byte
200 ;; Same request?
201 (= (aref-card8 buffer-bbuf last-request-byte) request)
202 (progn ;; Set buffer pointers to last request
203 (set-buffer-offset last-request-byte)
204 ;; same drawable and gcontext?
205 (or (compare-request (4)
206 (drawable drawable)
207 (gcontext gcontext))
208 (progn ;; If failed, reset buffer pointers
209 (set-buffer-offset current-boffset)
210 nil))))
211 ;; Append request
212 (progn
213 ;; Set new request length
214 (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte)
215 -2)))
216 (set-buffer-offset current-boffset)
217 (put-items (0) ; Insert new point
218 (int16 x y)
219 (card16 width height))
220 (setf (display-boffset display) (index+ buffer-boffset 8)))
221 ;; New Request
222 (progn
223 (put-items (4)
224 (code request)
225 (length 5)
226 (drawable drawable)
227 (gcontext gcontext)
228 (int16 x y)
229 (card16 width height))
230 (buffer-new-request-number display)
231 (setf (buffer-last-request display) buffer-boffset)
232 (setf (display-boffset display) (index+ buffer-boffset 20)))))))
233 (display-invoke-after-function display)))
234
235 (defun draw-rectangles (drawable gcontext rectangles &optional fill-p)
236 (declare (type drawable drawable)
237 (type gcontext gcontext)
238 ;; (repeat-seq (integer x) (integer y) (integer width) (integer height)))
239 (type sequence rectangles)
240 (type generalized-boolean fill-p))
241 (with-buffer-request ((drawable-display drawable)
242 (if fill-p *x-polyfillrectangle* *x-polyrectangle*)
243 :gc-force gcontext)
244 (drawable drawable)
245 (gcontext gcontext)
246 ((sequence :format int16) rectangles)))
247
248 (defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p)
249 ;; Should be clever about appending to existing buffered protocol request.
250 (declare (type drawable drawable)
251 (type gcontext gcontext)
252 (type int16 x y)
253 (type card16 width height)
254 (type angle angle1 angle2)
255 (type generalized-boolean fill-p))
256 (let ((display (drawable-display drawable))
257 (request (if fill-p *x-polyfillarc* *x-polyarc*)))
258 (declare (type display display)
259 (type card16 request))
260 (with-display (display)
261 (force-gcontext-changes-internal gcontext)
262 (with-buffer-output (display :length *requestsize*)
263 (let* ((last-request-byte (display-last-request display))
264 (current-boffset buffer-boffset))
265 ;; To append or not append, that is the question
266 (if (and (not *inhibit-appending*)
267 last-request-byte
268 ;; Same request?
269 (= (aref-card8 buffer-bbuf last-request-byte) request)
270 (progn ;; Set buffer pointers to last request
271 (set-buffer-offset last-request-byte)
272 ;; same drawable and gcontext?
273 (or (compare-request (4)
274 (drawable drawable)
275 (gcontext gcontext))
276 (progn ;; If failed, reset buffer pointers
277 (set-buffer-offset current-boffset)
278 nil))))
279 ;; Append request
280 (progn
281 ;; Set new request length
282 (card16-put 2 (index+ 3 (index-ash (index- current-boffset last-request-byte)
283 -2)))
284 (set-buffer-offset current-boffset)
285 (put-items (0) ; Insert new point
286 (int16 x y)
287 (card16 width height)
288 (angle angle1 angle2))
289 (setf (display-boffset display) (index+ buffer-boffset 12)))
290 ;; New Request
291 (progn
292 (put-items (4)
293 (code request)
294 (length 6)
295 (drawable drawable)
296 (gcontext gcontext)
297 (int16 x y)
298 (card16 width height)
299 (angle angle1 angle2))
300 (buffer-new-request-number display)
301 (setf (buffer-last-request display) buffer-boffset)
302 (setf (display-boffset display) (index+ buffer-boffset 24)))))))
303 (display-invoke-after-function display)))
304
305 (defun draw-arcs-list (drawable gcontext arcs &optional fill-p)
306 (declare (type drawable drawable)
307 (type gcontext gcontext)
308 (type list arcs)
309 (type generalized-boolean fill-p))
310 (let* ((display (drawable-display drawable))
311 (limit (index- (buffer-size display) 12))
312 (length (length arcs))
313 (request (if fill-p *x-polyfillarc* *x-polyarc*)))
314 (with-buffer-request ((drawable-display drawable) request :gc-force gcontext)
315 (drawable drawable)
316 (gcontext gcontext)
317 (progn
318 (card16-put 2 (index+ (index-ash length -1) 3)) ; Set request length (in words)
319 (set-buffer-offset (index+ buffer-boffset 12)) ; Position to start of data
320 (do ((arc arcs))
321 ((endp arc)
322 (setf (buffer-boffset display) buffer-boffset))
323 ;; Make sure there's room
324 (when (index>= buffer-boffset limit)
325 (setf (buffer-boffset display) buffer-boffset)
326 (buffer-flush display)
327 (set-buffer-offset (buffer-boffset display)))
328 (int16-put 0 (pop arc))
329 (int16-put 2 (pop arc))
330 (card16-put 4 (pop arc))
331 (card16-put 6 (pop arc))
332 (angle-put 8 (pop arc))
333 (angle-put 10 (pop arc))
334 (set-buffer-offset (index+ buffer-boffset 12)))))))
335
336 (defun draw-arcs-vector (drawable gcontext arcs &optional fill-p)
337 (declare (type drawable drawable)
338 (type gcontext gcontext)
339 (type vector arcs)
340 (type generalized-boolean fill-p))
341 (let* ((display (drawable-display drawable))
342 (limit (index- (buffer-size display) 12))
343 (length (length arcs))
344 (request (if fill-p *x-polyfillarc* *x-polyarc*)))
345 (with-buffer-request ((drawable-display drawable) request :gc-force gcontext)
346 (drawable drawable)
347 (gcontext gcontext)
348 (progn
349 (card16-put 2 (index+ (index-ash length -1) 3)) ; Set request length (in words)
350 (set-buffer-offset (index+ buffer-boffset 12)) ; Position to start of data
351 (do ((n 0 (index+ n 6))
352 (length (length arcs)))
353 ((index>= n length)
354 (setf (buffer-boffset display) buffer-boffset))
355 ;; Make sure there's room
356 (when (index>= buffer-boffset limit)
357 (setf (buffer-boffset display) buffer-boffset)
358 (buffer-flush display)
359 (set-buffer-offset (buffer-boffset display)))
360 (int16-put 0 (aref arcs (index+ n 0)))
361 (int16-put 2 (aref arcs (index+ n 1)))
362 (card16-put 4 (aref arcs (index+ n 2)))
363 (card16-put 6 (aref arcs (index+ n 3)))
364 (angle-put 8 (aref arcs (index+ n 4)))
365 (angle-put 10 (aref arcs (index+ n 5)))
366 (set-buffer-offset (index+ buffer-boffset 12)))))))
367
368 (defun draw-arcs (drawable gcontext arcs &optional fill-p)
369 (declare (type drawable drawable)
370 (type gcontext gcontext)
371 (type sequence arcs)
372 (type generalized-boolean fill-p))
373 (etypecase arcs
374 (list (draw-arcs-list drawable gcontext arcs fill-p))
375 (vector (draw-arcs-vector drawable gcontext arcs fill-p))))
376
377 ;; The following image routines are bare minimum. It may be useful to define
378 ;; some form of "image" object to hide representation details and format
379 ;; conversions. It also may be useful to provide stream-oriented interfaces
380 ;; for reading and writing the data.
381
382 (defun put-raw-image (drawable gcontext data &key
383 (start 0)
384 (depth (required-arg depth))
385 (x (required-arg x))
386 (y (required-arg y))
387 (width (required-arg width))
388 (height (required-arg height))
389 (left-pad 0)
390 (format (required-arg format)))
391 ;; Data must be a sequence of 8-bit quantities, already in the appropriate format
392 ;; for transmission; the caller is responsible for all byte and bit swapping and
393 ;; compaction. Start is the starting index in data; the end is computed from the
394 ;; other arguments.
395 (declare (type drawable drawable)
396 (type gcontext gcontext)
397 (type sequence data) ; Sequence of integers
398 (type array-index start)
399 (type card8 depth left-pad) ;; required
400 (type int16 x y) ;; required
401 (type card16 width height) ;; required
402 (type (member :bitmap :xy-pixmap :z-pixmap) format))
403 (with-buffer-request ((drawable-display drawable) *x-putimage* :gc-force gcontext)
404 ((data (member :bitmap :xy-pixmap :z-pixmap)) format)
405 (drawable drawable)
406 (gcontext gcontext)
407 (card16 width height)
408 (int16 x y)
409 (card8 left-pad depth)
410 (pad16 nil)
411 ((sequence :format card8 :start start) data)))
412
413 (defun get-raw-image (drawable &key
414 data
415 (start 0)
416 (x (required-arg x))
417 (y (required-arg y))
418 (width (required-arg width))
419 (height (required-arg height))
420 (plane-mask #xffffffff)
421 (format (required-arg format))
422 (result-type '(vector card8)))
423 ;; If data is given, it is modified in place (and returned), otherwise a new sequence
424 ;; is created and returned, with a size computed from the other arguments and the
425 ;; returned depth. The sequence is filled with 8-bit quantities, in transmission
426 ;; format; the caller is responsible for any byte and bit swapping and compaction
427 ;; required for further local use.
428 (declare (type drawable drawable)
429 (type (or null sequence) data) ;; sequence of integers
430 (type int16 x y) ;; required
431 (type card16 width height) ;; required
432 (type array-index start)
433 (type pixel plane-mask)
434 (type (member :xy-pixmap :z-pixmap) format))
435 (declare (clx-values (clx-sequence integer) depth visual-info))
436 (let ((display (drawable-display drawable)))
437 (with-buffer-request-and-reply (display *x-getimage* nil :sizes (8 32))
438 (((data (member error :xy-pixmap :z-pixmap)) format)
439 (drawable drawable)
440 (int16 x y)
441 (card16 width height)
442 (card32 plane-mask))
443 (let ((depth (card8-get 1))
444 (length (* 4 (card32-get 4)))
445 (visual (resource-id-get 8)))
446 (values (sequence-get :result-type result-type :format card8
447 :length length :start start :data data
448 :index *replysize*)
449 depth
450 (visual-info display visual))))))

  ViewVC Help
Powered by ViewVC 1.1.5