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

Contents of /src/clx/graphics.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5