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

Contents of /src/clx/graphics.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5