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

Contents of /src/clx/graphics.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (hide annotations)
Wed Jun 17 18:22:46 2009 UTC (4 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, intl-2-branch-base, GIT-CONVERSION, cross-sol-x86-merged, intl-branch-working-2010-02-11-1000, RELEASE_20b, release-20a-base, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, pre-merge-intl-branch, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, cross-sol-x86-2010-12-20, intl-branch-2010-03-18-1300, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, cross-sparc-branch-base, intl-branch-base, snapshot-2009-08, snapshot-2009-07, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, cross-sol-x86-branch, intl-2-branch
Changes since 1.6: +1 -1 lines
Merge portable-clx (2009-06-16) to main branch.  Tested by running
src/contrib/games/feebs and hemlock which works (in non-unicode
builds).
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 fgilham 1.6
21 dtc 1.5 #+cmu
22 rtoy 1.7 (ext:file-comment "$Id: graphics.lisp,v 1.7 2009/06/17 18:22:46 rtoy Rel $")
23 ram 1.1
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 fgilham 1.6 (with-buffer-output (display :length +requestsize+)
38 ram 1.1 (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 fgilham 1.6 (= (aref-card8 buffer-bbuf last-request-byte) +x-polypoint+)
45 ram 1.1 (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 fgilham 1.6 (code +x-polypoint+)
68 ram 1.1 (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 dtc 1.4 (type generalized-boolean relative-p))
84 fgilham 1.6 (with-buffer-request ((drawable-display drawable) +x-polypoint+ :gc-force gcontext)
85 ram 1.1 ((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 dtc 1.4 (type generalized-boolean relative-p))
96 ram 1.1 (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 fgilham 1.6 (with-buffer-output (display :length +requestsize+)
104 ram 1.1 (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 fgilham 1.6 (= (aref-card8 buffer-bbuf last-request-byte) +x-polysegment+)
111 ram 1.1 (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 fgilham 1.6 (code +x-polysegment+)
133 ram 1.1 (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 dtc 1.4 (type generalized-boolean relative-p fill-p)
147 ram 1.1 (type (member :complex :non-convex :convex) shape))
148     (if fill-p
149     (fill-polygon drawable gcontext points relative-p shape)
150 fgilham 1.6 (with-buffer-request ((drawable-display drawable) +x-polyline+ :gc-force gcontext)
151 ram 1.1 ((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 dtc 1.4 (type generalized-boolean relative-p)
163 ram 1.1 (type (member :complex :non-convex :convex) shape))
164 fgilham 1.6 (with-buffer-request ((drawable-display drawable) +x-fillpoly+ :gc-force gcontext)
165 ram 1.1 (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 fgilham 1.6 (with-buffer-request ((drawable-display drawable) +x-polysegment+ :gc-force gcontext)
177 ram 1.1 (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 dtc 1.4 (type generalized-boolean fill-p))
188 ram 1.1 (let ((display (drawable-display drawable))
189 fgilham 1.6 (request (if fill-p +x-polyfillrectangle+ +x-polyrectangle+)))
190 ram 1.1 (declare (type display display)
191     (type card16 request))
192     (with-display (display)
193     (force-gcontext-changes-internal gcontext)
194 fgilham 1.6 (with-buffer-output (display :length +requestsize+)
195 ram 1.1 (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 dtc 1.4 (type generalized-boolean fill-p))
241 ram 1.1 (with-buffer-request ((drawable-display drawable)
242 fgilham 1.6 (if fill-p +x-polyfillrectangle+ +x-polyrectangle+)
243 ram 1.1 :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 dtc 1.4 (type generalized-boolean fill-p))
256 ram 1.1 (let ((display (drawable-display drawable))
257 fgilham 1.6 (request (if fill-p +x-polyfillarc+ +x-polyarc+)))
258 ram 1.1 (declare (type display display)
259     (type card16 request))
260     (with-display (display)
261     (force-gcontext-changes-internal gcontext)
262 fgilham 1.6 (with-buffer-output (display :length +requestsize+)
263 ram 1.1 (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 dtc 1.4 (type generalized-boolean fill-p))
310 ram 1.1 (let* ((display (drawable-display drawable))
311     (limit (index- (buffer-size display) 12))
312     (length (length arcs))
313 fgilham 1.6 (request (if fill-p +x-polyfillarc+ +x-polyarc+)))
314 ram 1.1 (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 dtc 1.4 (type generalized-boolean fill-p))
341 ram 1.1 (let* ((display (drawable-display drawable))
342     (limit (index- (buffer-size display) 12))
343     (length (length arcs))
344 fgilham 1.6 (request (if fill-p +x-polyfillarc+ +x-polyarc+)))
345 ram 1.1 (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 dtc 1.4 (type generalized-boolean fill-p))
373 ram 1.1 (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 fgilham 1.6 (with-buffer-request ((drawable-display drawable) +x-putimage+ :gc-force gcontext)
404 ram 1.1 ((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 ram 1.3 (declare (clx-values (clx-sequence integer) depth visual-info))
436 ram 1.1 (let ((display (drawable-display drawable)))
437 fgilham 1.6 (with-buffer-request-and-reply (display +x-getimage+ nil :sizes (8 32))
438 ram 1.1 (((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 fgilham 1.6 :index +replysize+)
449 ram 1.1 depth
450     (visual-info display visual))))))

  ViewVC Help
Powered by ViewVC 1.1.5