Canvas Draw

Check-in [f1bd070eb0]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Added CHICKEN 5 port
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: f1bd070eb099e125d5b4293a0ef6c421bfe6938b
User & Date: murphy 2018-10-15 22:55:38
Context
2018-10-17
11:56
Added CHICKEN 5 release information check-in: f38ad2134e user: murphy tags: trunk, v1.1.2
2018-10-15
22:55
Added CHICKEN 5 port check-in: f1bd070eb0 user: murphy tags: trunk
2017-09-01
11:13
Pointed CHICKEN release-info to main repository check-in: cbf7bc5161 user: murphy tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Added chicken-5/canvas-draw-base.scm.

























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n")

(define *canvas-tag* "cdCanvas")
(define canvas? (cut tagged-pointer? <> *canvas-tag*))

(define (canvas->pointer nonnull?)
	(if nonnull?
		(lambda (canvas)
			(ensure canvas? canvas)
			canvas)
		(lambda (canvas)
			(ensure (disjoin not canvas?) canvas)
			canvas)))

(define (pointer->canvas nonnull?)
	(if nonnull?
		(lambda (canvas)
			(tag-pointer canvas *canvas-tag*))
		(lambda (canvas)
			(and canvas (tag-pointer canvas *canvas-tag*)))))

(define *context-tag* "cdContext")
(define context? (cut tagged-pointer? <> *context-tag*))

(define (context->pointer nonnull?)
	(if nonnull?
		(lambda (context)
			(ensure context? context)
			context)
		(lambda (context)
			(ensure (disjoin not context?) context)
			context)))

(define (pointer->context nonnull?)
	(if nonnull?
		(lambda (context)
			(tag-pointer context *context-tag*))
		(lambda (context)
			(and context (tag-pointer context *context-tag*)))))

(define *state-tag* "cdState")
(define state? (cut tagged-pointer? <> *state-tag*))

(define (state->pointer nonnull?)
	(if nonnull?
		(lambda (state)
			(ensure state? state)
			state)
		(lambda (state)
			(ensure (disjoin not state?) state)
			state)))

(define (pointer->state nonnull?)
	(if nonnull?
		(lambda (state)
			(tag-pointer state *state-tag*))
		(lambda (state)
			(and state (tag-pointer state *state-tag*)))))

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Canvas management

(define context-capabilities
	(letrec ([context-capabilities/raw
			      (foreign-lambda int "cdContextCaps" nonnull-context)]
	         [capabilities
	          (list
	          	(cons
	          		'flush
	          		(foreign-value "CD_CAP_FLUSH" int))
	          	(cons
	          		'clear
	          		(foreign-value "CD_CAP_CLEAR" int))
	          	(cons
	          		'play
	          		(foreign-value "CD_CAP_PLAY" int))
	          	(cons
	          		'y-axis
	          		(foreign-value "CD_CAP_YAXIS" int))
	          	(cons
	          		'clip-area
	          		(foreign-value "CD_CAP_CLIPAREA" int))
	          	(cons
	          		'clip-polygon
	          		(foreign-value "CD_CAP_CLIPPOLY" int))
	          	(cons
	          		'region
	          		(foreign-value "CD_CAP_REGION" int))
	          	(cons
	          		'rectangle
	          		(foreign-value "CD_CAP_RECT" int))
	          	(cons
	          		'chord
	          		(foreign-value "CD_CAP_CHORD" int))
	          	(cons
	          		'image/rgb
	          		(foreign-value "CD_CAP_IMAGERGB" int))
	          	(cons
	          		'image/rgba
	          		(foreign-value "CD_CAP_IMAGERGBA" int))
	          	(cons
	          		'image/map
	          		(foreign-value "CD_CAP_IMAGEMAP" int))
	          	(cons
	          		'get-image/rgb
	          		(foreign-value "CD_CAP_GETIMAGERGB" int))
	          	(cons
	          		'image/server
	          		(foreign-value "CD_CAP_IMAGESRV" int))
	          	(cons
	          		'background
	          		(foreign-value "CD_CAP_BACKGROUND" int))
	          	(cons
	          		'background-opacity
	          		(foreign-value "CD_CAP_BACKOPACITY" int))
	          	(cons
	          		'write-mode
	          		(foreign-value "CD_CAP_WRITEMODE" int))
	          	(cons
	          		'line-style
	          		(foreign-value "CD_CAP_LINESTYLE" int))
	          	(cons
	          		'line-width
	          		(foreign-value "CD_CAP_LINEWITH" int))
	          	(cons
	          		'fprimtives
	          		(foreign-value "CD_CAP_FPRIMTIVES" int))
	          	(cons
	          		'hatch
	          		(foreign-value "CD_CAP_HATCH" int))
	          	(cons
	          		'stipple
	          		(foreign-value "CD_CAP_STIPPLE" int))
	          	(cons
	          		'pattern
	          		(foreign-value "CD_CAP_PATTERN" int))
	          	(cons
	          		'font
	          		(foreign-value "CD_CAP_FONT" int))
	          	(cons
	          		'font-dimensions
	          		(foreign-value "CD_CAP_FONTDIM" int))
	          	(cons
	          		'text-size
	          		(foreign-value "CD_CAP_TEXTSIZE" int))
	          	(cons
	          		'text-orientation
	          		(foreign-value "CD_CAP_TEXTORIENTATION" int))
	          	(cons
	          		'palette
	          		(foreign-value "CD_CAP_PALETTE" int))
	          	(cons
	          		'line-cap
	          		(foreign-value "CD_CAP_LINECAP" int))
	          	(cons
	          		'line-join
	          		(foreign-value "CD_CAP_LINEJOIN" int))
	          	(cons
	          		'path
	          		(foreign-value "CD_CAP_PATH" int))
	          	(cons
	          		'bezier
	          		(foreign-value "CD_CAP_BEZIER" int)))])
	  (lambda (context)
	  	(let ([capabilities/raw (context-capabilities/raw context)])
				(filter-map
					(lambda (info)
						(let ([mask (cdr info)])
							(and (= (bitwise-and mask capabilities/raw) mask) (car info))))
					capabilities)))))

(define use-context+
	(make-parameter #f))

(define make-canvas/ptr
	(foreign-lambda* canvas ([nonnull-context context] [bool plus] [c-pointer data])
		"cdUseContextPlus(plus);\n"
		"C_return(cdCreateCanvas(context, data));"))

(define make-canvas/string
	(foreign-lambda* canvas ([nonnull-context context] [bool plus] [c-string data])
		"cdUseContextPlus(plus);\n"
		"C_return(cdCreateCanvas(context, (void *)data));"))

(define canvas-kill!
	(foreign-lambda void "cdKillCanvas" nonnull-canvas))

(define canvas-activate!
	(foreign-lambda void "cdCanvasActivate" nonnull-canvas))

(define canvas-deactivate!
	(foreign-lambda void "cdCanvasDeactivate" nonnull-canvas))

(define (make-canvas context data)
	(let ([make-canvas/data (if (string? data) make-canvas/string make-canvas/ptr)])
		(cond
			[(make-canvas/data context (use-context+) data)
			 => (cut set-finalizer! <> canvas-kill!)]
			[else
			 (error 'make-canvas "failed to create canvas")])))

(define call-with-canvas
	(case-lambda
		[(canvas proc)
		 (dynamic-wind
		 	 (cut canvas-activate! canvas)
		 	 (cut proc canvas)
		 	 (cut canvas-deactivate! canvas))]
		[(context data proc)
		 (let* ([make-canvas/data (if (string? data) make-canvas/string make-canvas/ptr)]
		 		    [canvas (make-canvas/data context (use-context+) data)])
		 	 (unless canvas (error 'call-with-canvas "failed to create canvas"))
			 (dynamic-wind
			 	 (cut canvas-activate! canvas)
			 	 (cut proc canvas)
			 	 (lambda ()
			 	 	 (when canvas
						 (canvas-kill! canvas)
						 (set! canvas #f)))))]))

(define canvas-context
	(foreign-lambda nonnull-context "cdCanvasGetContext" nonnull-canvas))

(define canvas-simulate!
	(letrec ([canvas-simulate/raw!
	          (foreign-lambda int "cdCanvasSimulate" nonnull-canvas int)]
	         [flags
	          (list
	          	(cons
	          		'line
	          		(foreign-value "CD_SIM_LINE" int))
	          	(cons
	          		'rectangle
	          		(foreign-value "CD_SIM_RECT" int))
	          	(cons
	          		'box
	          		(foreign-value "CD_SIM_BOX" int))
	          	(cons
	          		'arc
	          		(foreign-value "CD_SIM_ARC" int))
	          	(cons
	          		'sector
	          		(foreign-value "CD_SIM_SECTOR" int))
	          	(cons
	          		'chord
	          		(foreign-value "CD_SIM_CHORD" int))
	          	(cons
	          		'polyline
	          		(foreign-value "CD_SIM_POLYLINE" int))
	          	(cons
	          		'polygon
	          		(foreign-value "CD_SIM_POLYGON" int))
	          	(cons
	          		'text
	          		(foreign-value "CD_SIM_TEXT" int))
	          	(cons
	          		'all
	          		(foreign-value "CD_SIM_ALL" int))
	          	(cons
	          		'lines
	          		(foreign-value "CD_SIM_LINES" int))
	          	(cons
	          		'fills
	          		(foreign-value "CD_SIM_FILLS" int)))])
	  (lambda (canvas flags-in)
	  	(let ([flags-out
	  	       (canvas-simulate/raw!
	  	       	 canvas
	  	       	 (fold
	  	       	 	 bitwise-ior 0
	  	       	 	 (map
	  	       	 	 	 (lambda (flag)
	  	       	 	 	 	 (cond
	  	       	 	 	 	 	 [(assq flag flags) => cdr]
	  	       	 	 	 	 	 [else (error 'canvas-simulate! "unknown flag" flag)]))
	  	       	 	 	 flags-in)))])
	  	  (filter-map
	  	  	(lambda (info)
	  	  		(let ([mask (cdr info)])
							(and (= (bitwise-and mask flags-out) mask) (car info))))
	  	  	flags)))))

(define (name->string name)
	(cond
		[(symbol? name)
		 (string-upcase (string-translate (symbol->string name) #\- #\_))]
		[else
		 name]))

(define canvas-attribute-set!
	(letrec ([canvas-attribute-set/raw! (foreign-lambda void "cdCanvasSetAttribute" nonnull-canvas nonnull-c-string c-string)])
		(lambda (canvas name value)
			(canvas-attribute-set/raw! canvas (name->string name) value))))

(define canvas-attribute
	(letrec ([canvas-attribute/raw (foreign-lambda c-string "cdCanvasGetAttribute" nonnull-canvas nonnull-c-string)])
		(getter-with-setter
			(lambda (canvas name)
				(canvas-attribute/raw canvas (name->string name)))
			canvas-attribute-set!)))

(define canvas-state-set!
	(foreign-lambda void "cdCanvasRestoreState" nonnull-canvas nonnull-state))

(define canvas-state
	(letrec ([save-state (foreign-lambda nonnull-state "cdCanvasSaveState" nonnull-canvas)]
	         [release-state! (foreign-lambda void "cdReleaseState" nonnull-state)])
		(getter-with-setter
			(lambda (canvas)
				(set-finalizer! (save-state canvas) release-state!))
			canvas-state-set!)))

(define canvas-clear!
	(foreign-lambda void "cdCanvasClear" nonnull-canvas))

(define canvas-flush
	(foreign-lambda void "cdCanvasFlush" nonnull-canvas))

;; }}}

;; {{{ Coordinate system

(define canvas-size
	(letrec ([canvas-size/raw (foreign-lambda void "cdCanvasGetSize" nonnull-canvas (c-pointer int) (c-pointer int) (c-pointer double) (c-pointer double))])
		(lambda (canvas)
			(let-location ([width/px int 0] [height/px int 0]
			               [width/mm double 0] [height/mm double 0])
			  (canvas-size/raw
			  	canvas
			  	(location width/px) (location height/px)
			  	(location width/mm) (location height/mm))
			  (values
			  	width/px height/px
			  	width/mm height/mm)))))

(define canvas-mm->px
	(letrec ([canvas-mm->px/raw (foreign-lambda void "cdCanvasMM2Pixel" nonnull-canvas double double (c-pointer int) (c-pointer int))])
		(lambda (canvas x/mm y/mm)
			(let-location ([x/px int 0] [y/px int 0])
				(canvas-mm->px/raw canvas x/mm y/mm (location x/px) (location y/px))
				(values x/px y/px)))))

(define canvas-px->mm
	(letrec ([canvas-mm->px/raw (foreign-lambda void "cdCanvasPixel2MM" nonnull-canvas int int (c-pointer double) (c-pointer double))])
		(lambda (canvas x/px y/px)
			(let-location ([x/mm double +nan.0] [y/mm double +nan.0])
				(canvas-mm->px/raw canvas x/px y/px (location x/mm) (location y/mm))
				(values x/mm y/mm)))))

(define canvas-origin-set!
	(foreign-lambda void "cdCanvasOrigin" nonnull-canvas int int))

(define canvas-origin
	(letrec ([canvas-origin/raw (foreign-lambda void "cdCanvasGetOrigin" nonnull-canvas (c-pointer int) (c-pointer int))])
		(lambda (canvas)
			(let-location ([x int 0] [y int 0])
				(canvas-origin/raw canvas (location x) (location y))
				(values x y)))))

(define (transform->f64vector proc)
	(let ([v (make-f64vector 6)])
		(let-values ([(dx dy) (proc 0 0)])
			(f64vector-set! v 4 dx)
			(f64vector-set! v 5 dy)
			(let-values ([(x y) (proc 1 0)])
				(f64vector-set! v 0 (- x dx))
				(f64vector-set! v 1 (- y dy)))
			(let-values ([(x y) (proc 0 1)])
				(f64vector-set! v 2 (- x dx))
				(f64vector-set! v 3 (- y dy))))
		v))

(define ((f64vector->transform v) x y)
	(values
		(+ (* (f64vector-ref v 0) x) (* (f64vector-ref v 2) y) (f64vector-ref v 4))
		(+ (* (f64vector-ref v 1) x) (* (f64vector-ref v 3) y) (f64vector-ref v 5))))

(define canvas-transform-set!
	(letrec ([canvas-transform-set/raw! (foreign-lambda void "cdCanvasTransform" nonnull-canvas f64vector)])
		(lambda (canvas proc)
			(canvas-transform-set/raw! canvas (and proc (transform->f64vector proc))))))

(define canvas-transform
	(letrec ([canvas-transform/raw
	          (foreign-lambda* bool ([nonnull-canvas canvas] [nonnull-f64vector v])
	          	"double *w = cdCanvasGetTransform(canvas);\n"
	          	"if (w) memcpy(v, w, 6 * sizeof(double));\n"
	          	"C_return(w);")])
		(getter-with-setter
			(lambda (canvas)
				(let ([v (make-f64vector 6)])
					(and (canvas-transform/raw canvas v) (f64vector->transform v))))
			canvas-transform-set!)))

(define canvas-transform-compose!
	(letrec ([canvas-transform-compose/raw! (foreign-lambda void "cdCanvasTransformMultiply" nonnull-canvas nonnull-f64vector)])
		(lambda (canvas proc)
			(canvas-transform-compose/raw! canvas (transform->f64vector proc)))))

(define canvas-transform-translate!
	(foreign-lambda void "cdCanvasTransformTranslate" nonnull-canvas double double))

(define canvas-transform-scale!
	(foreign-lambda void "cdCanvasTransformScale" nonnull-canvas double double))

(define canvas-transform-rotate!
	(foreign-lambda void "cdCanvasTransformRotate" nonnull-canvas double))

;; }}}

;; {{{ General attributes

(define canvas-foreground-set!
	(foreign-lambda void "cdCanvasSetForeground" nonnull-canvas unsigned-long))

(define canvas-foreground
	(getter-with-setter
		(foreign-lambda* unsigned-long ([nonnull-canvas canvas])
			"C_return(cdCanvasForeground(canvas, CD_QUERY));")
		canvas-foreground-set!))

(define canvas-background-set!
	(foreign-lambda void "cdCanvasSetBackground" nonnull-canvas unsigned-long))

(define canvas-background
	(getter-with-setter
		(foreign-lambda* unsigned-long ([nonnull-canvas canvas])
			"C_return(cdCanvasBackground(canvas, CD_QUERY));")
		canvas-background-set!))

(define-values (canvas-write-mode canvas-write-mode-set!)
	(letrec ([write-modes
	          (list
	          	(cons
	          		'replace
	          		(foreign-value "CD_REPLACE" int))
	          	(cons
	          		'xor
	          		(foreign-value "CD_XOR" int))
	          	(cons
	          		'not-xor
	          		(foreign-value "CD_NOT_XOR" int)))]
	         [canvas-write-mode-set/raw!
	          (foreign-lambda void "cdCanvasWriteMode" nonnull-canvas int)]
	         [canvas-write-mode-set!
	          (lambda (canvas write-mode)
	          	(canvas-write-mode-set/raw!
	          		canvas
	          		(cond
	          			[(assq write-mode write-modes) => cdr]
	          			[else (error 'canvas-write-mode-set! "unknown write mode" write-mode)])))]
	         [canvas-write-mode/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasWriteMode(canvas, CD_QUERY));")]
	         [canvas-write-mode
	          (lambda (canvas)
	          	(let ([write-mode (canvas-write-mode/raw canvas)])
	          		(cond
	          			[(rassoc write-mode write-modes) => car]
	          			[else (error 'canvas-write-mode "unknown write mode" write-mode)])))])
	  (values
	  	(getter-with-setter canvas-write-mode canvas-write-mode-set!)
	  	canvas-write-mode-set!)))

;; }}}

;; {{{ Clipping

(define-values (canvas-clip-mode canvas-clip-mode-set!)
	(letrec ([clip-modes
	          (list
	          	(cons
	          		'area
	          		(foreign-value "CD_CLIPAREA" int))
	          	(cons
	          		'polygon
	          		(foreign-value "CD_CLIPPOLYGON" int))
	          	(cons
	          		'region
	          		(foreign-value "CD_CLIPREGION" int))
	          	(cons
	          		#f
	          		(foreign-value "CD_CLIPOFF" int)))]
	         [canvas-clip-mode-set/raw!
	          (foreign-lambda void "cdCanvasClip" nonnull-canvas int)]
	         [canvas-clip-mode-set!
	          (lambda (canvas clip-mode)
	          	(canvas-clip-mode-set/raw!
	          		canvas
	          		(cond
	          			[(assq clip-mode clip-modes) => cdr]
	          			[else (error 'canvas-clip-mode-set! "unknown clip mode" clip-mode)])))]
	         [canvas-clip-mode/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasClip(canvas, CD_QUERY));")]
	         [canvas-clip-mode
	          (lambda (canvas)
	          	(let ([clip-mode (canvas-clip-mode/raw canvas)])
	          		(cond
	          			[(rassoc clip-mode clip-modes) => car]
	          			[else (error 'canvas-write-mode "unknown clip mode" clip-mode)])))])
	  (values
	  	(getter-with-setter canvas-clip-mode canvas-clip-mode-set!)
	  	canvas-clip-mode-set!)))

(define canvas-clip-area-set!
	(foreign-lambda void "cdfCanvasClipArea" nonnull-canvas double double double double))

(define canvas-clip-area
	(letrec ([canvas-clip-area/raw (foreign-lambda void "cdfCanvasGetClipArea" nonnull-canvas (c-pointer double) (c-pointer double) (c-pointer double) (c-pointer double))])
		(lambda (canvas)
			(let-location ([x0 double 0] [x1 double 0] [y0 double 0] [y1 double 0])
				(canvas-clip-area/raw canvas (location x0) (location x1) (location y0) (location y1))
				(values x0 x1 y0 y1)))))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-cgm.scm.





































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdcgm.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:cgm
	(foreign-value "CD_CGM" nonnull-context))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-client.scm.













































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdirgb.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:image
	(foreign-value "CD_IMAGERGB" nonnull-context))

(define context:double-buffer
	(foreign-value "CD_DBUFFERRGB" nonnull-context))

;; }}}

;; {{{ Auxiliary functions

(define canvas-image-put/rgb!
	(letrec ([canvas-image-set/rgb/raw!
	          (foreign-lambda* void ([nonnull-canvas canvas] [int dst_x] [int dst_y]
	                                 [int src_width] [int src_height] [nonnull-blob data]
	                                 [int dst_width] [int dst_height]
	                                 [int src_x0] [int src_x1] [int src_y0] [int src_y1])
	            "const int nchans = 3;\n"
	          	"unsigned char chans[nchans][src_width * src_height];\n"
	          	"int i;\n"
	          	"\n"
	          	"for (i = 0; i < nchans * src_width * src_height; ++i)\n"
	          	"	chans[i % nchans][i / nchans] = data[i];\n"
	          	"\n"
	          	"cdCanvasPutImageRectRGB(\n"
	          	"	canvas, src_width, src_height,\n"
	          	"	chans[0], chans[1], chans[2],\n"
	          	"	dst_x, dst_y, dst_width, dst_height,"
	          	"	src_x0, src_x1, src_y0, src_y1"
	          	");")])
	  (lambda (canvas dst-x dst-y src-width src-height data
	           #!key [width 0] [height 0] [x0 0] [x1 0] [y0 0] [y1 0])
	  	(unless (= (blob-size data) (* 3 src-width src-height))
	  		(error 'canvas-image-set/rgb! "bad image size" (blob-size data) (* 3 src-width src-height)))
	  	(canvas-image-set/rgb/raw!
	  		canvas dst-x dst-y src-width src-height data
	  		width height x0 x1 y0 y1))))

(define canvas-image-put/rgba!
	(letrec ([canvas-image-set/rgba/raw!
	          (foreign-lambda* void ([nonnull-canvas canvas] [int dst_x] [int dst_y]
	                                 [int src_width] [int src_height] [nonnull-blob data]
	                                 [int dst_width] [int dst_height]
	                                 [int src_x0] [int src_x1] [int src_y0] [int src_y1])
	            "const int nchans = 4;\n"
	          	"unsigned char chans[nchans][src_width * src_height];\n"
	          	"int i;\n"
	          	"\n"
	          	"for (i = 0; i < nchans * src_width * src_height; ++i)\n"
	          	"	chans[i % nchans][i / nchans] = data[i];\n"
	          	"\n"
	          	"cdCanvasPutImageRectRGBA(\n"
	          	"	canvas, src_width, src_height,\n"
	          	"	chans[0], chans[1], chans[2], chans[3],\n"
	          	"	dst_x, dst_y, dst_width, dst_height,"
	          	"	src_x0, src_x1, src_y0, src_y1"
	          	");")])
	  (lambda (canvas dst-x dst-y src-width src-height data
	           #!key [width 0] [height 0] [x0 0] [x1 0] [y0 0] [y1 0])
	  	(unless (= (blob-size data) (* 4 src-width src-height))
	  		(error 'canvas-image-set/rgba! "bad image size" (blob-size data) (* 4 src-width src-height)))
	  	(canvas-image-set/rgba/raw!
	  		canvas dst-x dst-y src-width src-height data
	  		width height x0 x1 y0 y1))))

(define canvas-image/rgb
	(getter-with-setter
		(letrec ([canvas-image/rgb/raw
							(foreign-lambda* void ([nonnull-canvas canvas] [int x] [int y]
							                       [int width] [int height]  [nonnull-blob data])
							  "const int nchans = 3;\n"
							  "unsigned char chans[nchans][width * height];\n"
							  "int i;\n"
							  "\n"
							  "cdCanvasGetImageRGB(\n"
							  "	canvas,\n"
							  "	chans[0], chans[1], chans[2],\n"
							  "	x, y, width, height\n"
							  ");\n"
							  "\n"
							  "for (i = 0; i < nchans * width * height; ++i)\n"
							  "	data[i] = chans[i % nchans][i / nchans];\n")])
			(lambda (canvas x y width height)
				(let ([data (make-blob (* 3 width height))])
					(canvas-image/rgb/raw canvas x y width height data)
					data)))
		canvas-image-put/rgb!))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-clipboard.scm.





































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdclipbd.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:clipboard
	(foreign-value "CD_CLIPBOARD" nonnull-context))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-debug.scm.





































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cddebug.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:debug
	(foreign-value "CD_DEBUG" nonnull-context))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-dgn.scm.





































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cddgn.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:dgn
	(foreign-value "CD_DGN" nonnull-context))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-dxf.scm.





































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cddxf.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:dxf
	(foreign-value "CD_DXF" nonnull-context))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-emf.scm.





































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdemf.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:emf
	(foreign-value "CD_EMF" nonnull-context))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-gl.scm.





































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdgl.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:gl
	(foreign-value "CD_GL" nonnull-context))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-iup.scm.



































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdiup.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:iup
	(foreign-value "CD_IUP" nonnull-context))

;; }}}

;; {{{ Auxiliary functions

(define (make-canvas-action proc)
	(let ([canvas #f])
		(lambda (handle x y)
			(unless canvas (set! canvas (make-canvas context:iup handle)))
			(call-with-canvas canvas (cut proc <> x y)))))

(define (make-cells-draw-cb proc)
	(let ([wrap (pointer->canvas #t)])
		(lambda (handle i j x-min x-max y-min y-max canvas)
			(call-with-canvas (wrap canvas) (cut proc handle i j x-min x-max y-min y-max <>)))))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-metafile.scm.





































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdmf.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:metafile
	(foreign-value "CD_METAFILE" nonnull-context))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-native.scm.

















































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdnative.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:native-window
	(foreign-value "CD_NATIVEWINDOW" nonnull-context))

;; }}}

;; {{{ Auxiliary functions

(define screen-size
	(letrec ([screen-size/raw (foreign-lambda void "cdGetScreenSize" (c-pointer int) (c-pointer int) (c-pointer double) (c-pointer double))])
		(lambda ()
			(let-location ([width/px int 0] [height/px int 0]
			               [width/mm double 0] [height/mm double 0])
			  (screen-size/raw
			  	(location width/px) (location height/px)
			  	(location width/mm) (location height/mm))
			  (values
			  	width/px height/px
			  	width/mm height/mm)))))

;; }}}

;; {{{ Library initialization

(foreign-code "cdInitContextPlus();")

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-pdf.scm.





































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdpdf.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:pdf
	(foreign-value "CD_PDF" nonnull-context))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-picture.scm.





































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdpicture.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:picture
	(foreign-value "CD_PICTURE" nonnull-context))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-play.scm.



















































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context content playback

(define canvas-play/ptr!
	(foreign-lambda int "cdCanvasPlay" nonnull-canvas nonnull-context int int int int c-pointer))

(define canvas-play/string!
	(foreign-lambda int "cdCanvasPlay" nonnull-canvas nonnull-context int int int int c-string))

(define (canvas-play! canvas context x0 x1 y0 y1 data)
	(let ([canvas-play/data! (if (string? data) canvas-play/string! canvas-play/ptr!)])
		(unless (zero? (canvas-play/data! canvas context x0 x1 y0 y1 data))
			(error 'canvas-play! "failed to replay graphics"))))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-primitives.scm.



















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Point drawing functions

(define canvas-pixel!
	(letrec ([canvas-pixel/raw!
	          (foreign-lambda void "cdCanvasPixel" nonnull-canvas int int unsigned-long)])
	  (lambda (canvas x y #!optional [color (canvas-foreground canvas)])
	  	(canvas-pixel/raw! canvas x y color))))

(define canvas-mark!
	(foreign-lambda void "cdCanvasMark" nonnull-canvas int int))

(define-values (canvas-mark-type canvas-mark-type-set!)
	(letrec ([mark-types
	          (list
	          	(cons
	          		'+
	          		(foreign-value "CD_PLUS" int))
	          	(cons
	          		'plus
	          		(foreign-value "CD_PLUS" int))
	          	(cons
	          		'*
	          		(foreign-value "CD_STAR" int))
	          	(cons
	          		'star
	          		(foreign-value "CD_STAR" int))
	          	(cons
	          		'0
	          		(foreign-value "CD_CIRCLE" int))
	          	(cons
	          		'circle
	          		(foreign-value "CD_CIRCLE" int))
	          	(cons
	          		'O
	          		(foreign-value "CD_HOLLOW_CIRCLE" int))
	          	(cons
	          		'hollow-circle
	          		(foreign-value "CD_HOLLOW_CIRCLE" int))
	          	(cons
	          		'X
	          		(foreign-value "CD_X" int))
	          	(cons
	          		'x
	          		(foreign-value "CD_X" int))
	          	(cons
	          		'box
	          		(foreign-value "CD_BOX" int))
	          	(cons
	          		'hollow-box
	          		(foreign-value "CD_HOLLOW_BOX" int))
	          	(cons
	          		'diamond
	          		(foreign-value "CD_DIAMOND" int))
	          	(cons
	          		'hollow-diamond
	          		(foreign-value "CD_HOLLOW_DIAMOND" int)))]
	         [canvas-mark-type-set/raw!
	          (foreign-lambda void "cdCanvasMarkType" nonnull-canvas int)]
	         [canvas-mark-type-set!
	          (lambda (canvas mark-type)
							(canvas-mark-type-set/raw!
								canvas
								(cond
									[(assq mark-type mark-types) => cdr]
									[else (error 'canvas-mark-type-set! "unknown mark type" mark-type)])))]
	         [canvas-mark-type/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasMarkType(canvas, CD_QUERY));")]
	         [canvas-mark-type
	          (lambda (canvas)
	          	(let ([mark-type (canvas-mark-type/raw canvas)])
								(cond
									[(rassoc mark-type mark-types) => car]
									[else (error 'canvas-mark-type "unknown mark type" mark-type)])))])
	  (values
	  	(getter-with-setter canvas-mark-type canvas-mark-type-set!)
	  	canvas-mark-type-set!)))

(define canvas-mark-size-set!
	(foreign-lambda void "cdCanvasMarkSize" nonnull-canvas int))

(define canvas-mark-size
	(getter-with-setter
		(foreign-lambda* int ([nonnull-canvas canvas])
			"C_return(cdCanvasMarkSize(canvas, CD_QUERY));")
		canvas-mark-size-set!))

;; }}}

;; {{{ Line functions

(define canvas-line!
	(foreign-lambda void "cdfCanvasLine" nonnull-canvas double double double double))

(define canvas-rectangle!
	(foreign-lambda void "cdfCanvasRect" nonnull-canvas double double double double))

(define canvas-arc!
	(foreign-lambda void "cdfCanvasArc" nonnull-canvas double double double double double double))

(define-values (canvas-line-style canvas-line-style-set!)
	(letrec ([line-styles
	          (list
	          	(cons
	          		'continuous
	          		(foreign-value "CD_CONTINUOUS" int))
	          	(cons
	          		'dashed
	          		(foreign-value "CD_DASHED" int))
	          	(cons
	          		'dotted
	          		(foreign-value "CD_DOTTED" int))
	          	(cons
	          		'dash-dotted
	          		(foreign-value "CD_DASH_DOT" int))
	          	(cons
	          		'dash-dot-dotted
	          		(foreign-value "CD_DASH_DOT_DOT" int))
	          	(cons
	          		'custom
	          		(foreign-value "CD_CUSTOM" int)))]
	         [canvas-line-style-set/raw!
	          (foreign-lambda void "cdCanvasLineStyle" nonnull-canvas int)]
	         [canvas-line-style-dashes-set/raw!
	          (foreign-lambda void "cdCanvasLineStyleDashes" nonnull-canvas nonnull-s32vector int)]
	         [canvas-line-style-set!
	          (lambda (canvas line-style)
	          	(cond
	          		[(and (pair? line-style) (eq? (car line-style) 'custom))
	          		 (let ([dashes (list->s32vector (cdr line-style))])
	          		 	 (canvas-line-style-dashes-set/raw! canvas dashes (s32vector-length dashes))
	          		 	 (canvas-line-style-set/raw! canvas (cdr (assq 'custom line-styles))))]
	          		[else
	          		 (canvas-line-style-set/raw!
	          		 	 canvas
	          		 	 (cond
	          		 	 	 [(assq line-style line-styles) => cdr]
	          		 	 	 [else (error 'canvas-line-style-set! "unknown line style" line-style)]))]))]
	         [canvas-line-style/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasLineStyle(canvas, CD_QUERY));")]
	         [canvas-line-style
	          (lambda (canvas)
	          	(let ([line-style (canvas-line-style/raw canvas)])
	          		(cond
									[(rassoc line-style line-styles) => car]
									[else (error 'canvas-line-style "unknown line style" line-style)])))])
	  (values
	  	(getter-with-setter canvas-line-style canvas-line-style-set!)
	  	canvas-line-style-set!)))

(define canvas-line-width-set!
	(foreign-lambda int "cdCanvasLineWidth" nonnull-canvas int))

(define canvas-line-width
	(getter-with-setter
		(foreign-lambda* int ([nonnull-canvas canvas])
			"C_return(cdCanvasLineWidth(canvas, CD_QUERY));")
		canvas-line-width-set!))

(define-values (canvas-line-join canvas-line-join-set!)
	(letrec ([line-joins
	          (list
	          	(cons
	          		'miter
	          		(foreign-value "CD_MITER" int))
	          	(cons
	          		'bevel
	          		(foreign-value "CD_BEVEL" int))
	          	(cons
	          		'round
	          		(foreign-value "CD_ROUND" int)))]
	         [canvas-line-join-set/raw!
	          (foreign-lambda void "cdCanvasLineJoin" nonnull-canvas int)]
	         [canvas-line-join-set!
	          (lambda (canvas line-join)
							(canvas-line-join-set/raw!
								canvas
								(cond
									[(assq line-join line-joins) => cdr]
									[else (error 'canvas-line-join-set! "unknown line join" line-join)])))]
	         [canvas-line-join/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasLineJoin(canvas, CD_QUERY));")]
	         [canvas-line-join
	          (lambda (canvas)
	          	(let ([line-join (canvas-line-join/raw canvas)])
	          		(cond
									[(rassoc line-join line-joins) => car]
									[else (error 'canvas-line-join "unknown line join" line-join)])))])
		(values
			(getter-with-setter canvas-line-join canvas-line-join-set!)
			canvas-line-join-set!)))

(define-values (canvas-line-cap canvas-line-cap-set!)
	(letrec ([line-caps
	          (list
	          	(cons
	          		'flat
	          		(foreign-value "CD_CAPFLAT" int))
	          	(cons
	          		'square
	          		(foreign-value "CD_CAPSQUARE" int))
	          	(cons
	          		'round
	          		(foreign-value "CD_CAPROUND" int)))]
	         [canvas-line-cap-set/raw!
	          (foreign-lambda void "cdCanvasLineCap" nonnull-canvas int)]
	         [canvas-line-cap-set!
	          (lambda (canvas line-cap)
							(canvas-line-cap-set/raw!
								canvas
								(cond
									[(assq line-cap line-caps) => cdr]
									[else (error 'canvas-line-cap-set! "unknown line cap" line-cap)])))]
	         [canvas-line-cap/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasLineCap(canvas, CD_QUERY));")]
	         [canvas-line-cap
	          (lambda (canvas)
	          	(let ([line-cap (canvas-line-cap/raw canvas)])
								(cond
									[(rassoc line-cap line-caps) => car]
									[else (error 'canvas-line-cap "unknown line cap" line-cap)])))])
		(values
			(getter-with-setter canvas-line-cap canvas-line-cap-set!)
			canvas-line-cap-set!)))

;; }}}

;; {{{ Filled area functions

(define canvas-box!
	(foreign-lambda void "cdfCanvasBox" nonnull-canvas double double double double))

(define canvas-sector!
	(foreign-lambda void "cdfCanvasSector" nonnull-canvas double double double double double double))

(define canvas-chord!
	(foreign-lambda void "cdfCanvasChord" nonnull-canvas double double double double double double))

(define-values (canvas-background-opacity canvas-background-opacity-set!)
	(letrec ([opacities
	          (list
	          	(cons
	          		'opaque
	          		(foreign-value "CD_OPAQUE" int))
	          	(cons
	          		'transparent
	          		(foreign-value "CD_TRANSPARENT" int)))]
	         [canvas-background-opacity-set/raw!
	          (foreign-lambda void "cdCanvasBackOpacity" nonnull-canvas int)]
	         [canvas-background-opacity-set!
	          (lambda (canvas opacity)
							(canvas-background-opacity-set/raw!
								canvas
								(cond
									[(assq opacity opacities) => cdr]
									[else (error 'canvas-background-opacity-set! "unknown line cap" opacity)])))]
	         [canvas-background-opacity/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasBackOpacity(canvas, CD_QUERY));")]
	         [canvas-background-opacity
	          (lambda (canvas)
	          	(let ([opacity (canvas-background-opacity/raw canvas)])
	          		(cond
									[(rassoc opacity opacities) => car]
									[else (error 'canvas-background-opacity "unknown opacity" opacity)])))])
		(values
			(getter-with-setter canvas-background-opacity canvas-background-opacity-set!)
			canvas-background-opacity-set!)))

(define-values (canvas-fill-mode canvas-fill-mode-set!)
	(letrec ([fill-modes
	          (list
	          	(cons
	          		'even-odd
	          		(foreign-value "CD_EVENODD" int))
	          	(cons
	          		'winding
	          		(foreign-value "CD_WINDING" int)))]
	         [canvas-fill-mode-set/raw!
	          (foreign-lambda void "cdCanvasFillMode" nonnull-canvas int)]
	         [canvas-fill-mode-set!
	          (lambda (canvas fill-mode)
							(canvas-fill-mode-set/raw!
								canvas
								(cond
									[(assq fill-mode fill-modes) => cdr]
									[else (error 'canvas-fill-mode-set! "unknown fill mode" fill-mode)])))]
	         [canvas-fill-mode/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasFillMode(canvas, CD_QUERY));")]
	         [canvas-fill-mode
	          (lambda (canvas)
	          	(let ([fill-mode (canvas-fill-mode/raw canvas)])
								(cond
									[(rassoc fill-mode fill-modes) => car]
									[else (error 'canvas-fill-mode "unknown fill mode" fill-mode)])))])
		(values
			(getter-with-setter canvas-fill-mode canvas-fill-mode-set!)
			canvas-fill-mode-set!)))

(define-values (canvas-interior-style canvas-interior-style-set!)
	(letrec ([interior-styles
	          (list
	          	(cons
	          		'solid
	          		(foreign-value "CD_SOLID" int))
	          	(cons
	          		'hollow
	          		(foreign-value "CD_HOLLOW" int))
	          	(cons
	          		'hatch
	          		(foreign-value "CD_HATCH" int))
	          	(cons
	          		'stipple
	          		(foreign-value "CD_STIPPLE" int))
	          	(cons
	          		'pattern
	          		(foreign-value "CD_PATTERN" int)))]
	         [hatch-styles
	          (list
	          	(cons
	          		'horizontal
	          		(foreign-value "CD_HORIZONTAL" int))
	          	(cons
	          		'vertical
	          		(foreign-value "CD_VERTICAL" int))
	          	(cons
	          		'forward-diagonal
	          		(foreign-value "CD_FDIAGONAL" int))
	          	(cons
	          		'backward-diagonal
	          		(foreign-value "CD_BDIAGONAL" int))
	          	(cons
	          		'cross
	          		(foreign-value "CD_CROSS" int))
	          	(cons
	          		'diagonal-cross
	          		(foreign-value "CD_DIAGCROSS" int)))]
	         [canvas-hatch-style-set/raw!
	          (foreign-lambda int "cdCanvasHatch" nonnull-canvas int)]
	         [canvas-hatch-style/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasHatch(canvas, CD_QUERY));")]
	         [canvas-stipple-set/raw!
	          (foreign-lambda* void ([nonnull-canvas canvas] [int width] [int height] [nonnull-blob data])
	          	"unsigned char mask[width * height];\n"
	          	"int i, j;\n"
	          	"\n"
	          	"for (j = 0; j < height; ++j) {\n"
	          	"	for (i = 0; i < width; ++i) {\n"
	          	"		const int ofs = (j * width) + i;\n"
	          	"		mask[ofs] = (data[ofs / 8] >> (ofs % 8)) & 1;\n"
	          	"	}\n"
	          	"}\n"
	          	"cdCanvasStipple(canvas, width, height, mask);\n")]
	         [canvas-stipple/raw
	          (foreign-lambda* void ([nonnull-canvas canvas] [(c-pointer int) pwidth] [(c-pointer int) pheight] [blob data])
	          	"unsigned char *mask = cdCanvasGetStipple(canvas, pwidth, pheight);\n"
	          	"\n"
	          	"if (data) {\n"
	          	"	int width = *pwidth, height = *pheight;\n"
	          	"	int i, j;\n"
	          	"	\n"
	          	"	for (j = 0; j < height; ++j) {\n"
	          	"		for (i = 0; i < width; ++i) {\n"
	          	"			const int ofs = (j * width) + i;\n"
	          	"			const int vofs = ofs / 8, bofs = ofs % 8;\n"
	          	"			const unsigned char bit = mask[ofs] & 1;\n"
	          	"			\n"
	          	"			if (bofs > 0)\n"
	          	"				data[vofs] |= bit << bofs;\n"
	          	"			else\n"
	          	"				data[vofs] = bit;\n"
	          	"		}\n"
	          	"	}\n"
	          	"}\n")]
	         [canvas-pattern-set/rgb/raw!
	          (foreign-lambda* void ([nonnull-canvas canvas] [int width] [int height] [nonnull-blob data])
	          	"long color[width * height];\n"
	          	"int i, j;\n"
	          	"\n"
	          	"for (j = 0; j < height; ++j) {\n"
	          	"	for (i = 0; i < width; ++i, data += 3) {\n"
	          	"		color[(j * width) + i] =\n"
	          	"			(data[0] << 16) | (data[1] << 8) | (data[2]);\n"
	          	"	}\n"
	          	"}\n"
	          	"cdCanvasPattern(canvas, width, height, color);\n")]
	         [canvas-pattern-set/rgba/raw!
	          (foreign-lambda* void ([nonnull-canvas canvas] [int width] [int height] [nonnull-blob data])
	          	"long color[width * height];\n"
	          	"int i, j;\n"
	          	"\n"
	          	"for (j = 0; j < height; ++j) {\n"
	          	"	for (i = 0; i < width; ++i, data += 4) {\n"
	          	"		color[(j * width) + i] =\n"
	          	"			((0xff - data[3]) << 24) | (data[0] << 16) | (data[1] << 8) | (data[2]);\n"
	          	"	}\n"
	          	"}\n"
	          	"cdCanvasPattern(canvas, width, height, color);\n")]
	         [canvas-pattern/rgba/raw
	          (foreign-lambda* void ([nonnull-canvas canvas] [(c-pointer int) pwidth] [(c-pointer int) pheight] [blob data])
	          	"long *color = cdCanvasGetPattern(canvas, pwidth, pheight);\n"
	          	"\n"
	          	"if (data) {\n"
	          	"	int width = *pwidth, height = *pheight;\n"
	          	"	int i, j;\n"
	          	"	\n"
	          	"	for (j = 0; j < height; ++j) {\n"
	          	"		for (i = 0; i < width; ++i, data += 4) {\n"
	          	"			long c = color[(j * width) + i];\n"
	          	"			data[3] = 0xff - ((c >> 24) & 0xff);\n"
	          	"			data[0] = (c >> 16) & 0xff;\n"
	          	"			data[1] = (c >> 8) & 0xff;\n"
	          	"			data[2] = c & 0xff;\n"
	          	"		}\n"
	          	"	}\n"
	          	"}\n")]
	         [canvas-interior-style-set/raw!
	          (foreign-lambda void "cdCanvasInteriorStyle" nonnull-canvas int)]
	         [canvas-interior-style-set!
	          (lambda (canvas interior-style)
							(case (and (pair? interior-style) (car interior-style))
								[(hatch)
								 (let ([hatch-style (cadr interior-style)])
									 (canvas-hatch-style-set/raw!
										 canvas
										 (cond
										 	 [(assq hatch-style hatch-styles) => cdr]
										 	 [else (error 'canvas-interior-style-set! "unknown hatch style" hatch-style)]))
									 (canvas-interior-style-set/raw! canvas (cdr (assq 'hatch interior-styles))))]
								[(stipple)
								 (let ([width (cadr interior-style)]
											 [height (caddr interior-style)]
											 [data (cadddr interior-style)])
									 (unless (= (blob-size data) (ceiling (/ (* width height) 8)))
										 (error 'canvas-interior-style-set! "bad stipple data length" (blob-size data) (ceiling (/ (* width height) 8))))
									 (canvas-stipple-set/raw! canvas width height data)
									 (canvas-interior-style-set/raw! canvas (cdr (assq 'stipple interior-styles))))]
								[(pattern/rgb)
								 (let ([width (cadr interior-style)]
											 [height (caddr interior-style)]
											 [data (cadddr interior-style)])
									 (unless (= (blob-size data) (* 3 width height))
										 (error 'canvas-interior-style-set! "bad pattern data length" (blob-size data) (* 3 width height)))
									 (canvas-pattern-set/rgb/raw! canvas width height data)
									 (canvas-interior-style-set/raw! canvas (cdr (assq 'pattern interior-styles))))]
								[(pattern/rgba)
								 (let ([width (cadr interior-style)]
											 [height (caddr interior-style)]
											 [data (cadddr interior-style)])
									 (unless (= (blob-size data) (* 4 width height))
										 (error 'canvas-interior-style-set! "bad pattern data length" (blob-size data) (* 4 width height)))
									 (canvas-pattern-set/rgba/raw! canvas width height data)
									 (canvas-interior-style-set/raw! canvas (cdr (assq 'pattern interior-styles))))]
								[else
								 (canvas-interior-style-set/raw!
									 canvas
									 (cond
									 	 [(assq interior-style interior-styles) => cdr]
									 	 [else (error 'canvas-interior-style-set! "unknown interior style" interior-style)]))]))]
	         [canvas-interior-style/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasInteriorStyle(canvas, CD_QUERY));")]
	         [canvas-interior-style
	          (lambda (canvas)
	          	(let* ([interior-style (canvas-interior-style/raw canvas)]
	          	       [interior-style
	          	       (cond
	          	       	 [(rassoc interior-style interior-styles) => car]
	          	       	 [else (error 'canvas-interior-style "unknown interior style" interior-style)])])
								(case interior-style
									[(hatch)
									 (let ([hatch-style (canvas-hatch-style/raw canvas)])
										 (list
											 'hatch
											 (cond
												 [(rassoc hatch-style hatch-styles) => car]
												 [else (error 'canvas-interior-style "unknown hatch style" hatch-style)])))]
									[(stipple)
									 (let-location ([width int 0] [height int 0])
									 	 (canvas-stipple/raw canvas (location width) (location height) #f)
										 (let ([data (make-blob (inexact->exact (ceiling (/ (* width height) 8))))])
											 (canvas-stipple/raw canvas (location width) (location height) data)
											 (list 'stipple width height data)))]
									[(pattern)
									 (let-location ([width int 0] [height int 0])
									 	 (canvas-pattern/rgba/raw canvas (location width) (location height) #f)
										 (let ([data (make-blob (* 4 width height))])
											 (canvas-pattern/rgba/raw canvas (location width) (location height) data)
											 (list 'pattern/rgba width height data)))]
									[else
									 interior-style])))])
		(values
			(getter-with-setter canvas-interior-style canvas-interior-style-set!)
			canvas-interior-style-set!)))

;; }}}

;; {{{ Text functions

(define canvas-text!
	(foreign-lambda void "cdfCanvasText" nonnull-canvas double double nonnull-c-string))

(define canvas-font-set!
	(foreign-lambda c-string "cdCanvasNativeFont" nonnull-canvas nonnull-c-string))

(define canvas-font
	(getter-with-setter
		(foreign-lambda* c-string ([nonnull-canvas canvas])
			"C_return(cdCanvasNativeFont(canvas, NULL));")
		canvas-font-set!))

(define-values (canvas-text-alignment canvas-text-alignment-set!)
	(letrec ([alignments
	          (list
	          	(cons
	          		'north
	          		(foreign-value "CD_NORTH" int))
	          	(cons
	          		'south
	          		(foreign-value "CD_SOUTH" int))
	          	(cons
	          		'east
	          		(foreign-value "CD_EAST" int))
	          	(cons
	          		'west
	          		(foreign-value "CD_WEST" int))
	          	(cons
	          		'north-east
	          		(foreign-value "CD_NORTH_EAST" int))
	          	(cons
	          		'north-west
	          		(foreign-value "CD_NORTH_WEST" int))
	          	(cons
	          		'south-east
	          		(foreign-value "CD_SOUTH_EAST" int))
	          	(cons
	          		'south-west
	          		(foreign-value "CD_SOUTH_WEST" int))
	          	(cons
	          		'center
	          		(foreign-value "CD_CENTER" int))
	          	(cons
	          		'base-left
	          		(foreign-value "CD_BASE_LEFT" int))
	          	(cons
	          		'base-center
	          		(foreign-value "CD_BASE_CENTER" int))
	          	(cons
	          		'base-right
	          		(foreign-value "CD_BASE_RIGHT" int)))]
	         [canvas-text-alignment-set/raw!
	          (foreign-lambda void "cdCanvasTextAlignment" nonnull-canvas int)]
	         [canvas-text-alignment-set!
	          (lambda (canvas alignment)
							(canvas-text-alignment-set/raw!
								canvas
								(cond
									[(assq alignment alignments) => cdr]
									[else (error 'canvas-text-alignment-set! "unknown alignment" alignment)])))]
	         [canvas-text-alignment/raw
	          (foreign-lambda* int ([nonnull-canvas canvas])
	          	"C_return(cdCanvasTextAlignment(canvas, CD_QUERY));")]
	         [canvas-text-alignment
	          (lambda (canvas)
	          	(let ([alignment (canvas-text-alignment/raw canvas)])
								(cond
									[(rassoc alignment alignments) => car]
									[else (error 'canvas-text-alignment "unknown alignment" alignment)])))])
		(values
			(getter-with-setter canvas-text-alignment canvas-text-alignment-set!)
			canvas-text-alignment-set!)))

(define canvas-text-orientation-set!
	(foreign-lambda void "cdCanvasTextOrientation" nonnull-canvas double))

(define canvas-text-orientation
	(getter-with-setter
		(foreign-lambda* double ([nonnull-canvas canvas])
			"C_return(cdCanvasTextOrientation(canvas, CD_QUERY));")
		canvas-text-orientation-set!))

(define canvas-font-dimensions
	(letrec ([canvas-font-dimensions/raw
	          (foreign-lambda void "cdCanvasGetFontDim" nonnull-canvas (c-pointer int) (c-pointer int) (c-pointer int) (c-pointer int))])
	  (lambda (canvas)
	  	(let-location ([max-width int 0]
	  	               [height int 0]
	  	               [ascent int 0]
	  	               [descent int 0])
	  	  (canvas-font-dimensions/raw canvas (location max-width) (location height) (location ascent) (location descent))
	  	  (values max-width height ascent descent)))))

(define canvas-text-size
	(letrec ([canvas-text-size/raw
	          (foreign-lambda void "cdCanvasGetTextSize" nonnull-canvas nonnull-c-string (c-pointer int) (c-pointer int))])
	  (lambda (canvas text)
	  	(let-location ([width int 0] [height int 0])
	  		(canvas-text-size/raw canvas text (location width) (location height))
	  		(values width height)))))

(define canvas-text-box
	(letrec ([canvas-text-box/raw
	          (foreign-lambda void "cdCanvasGetTextBox" nonnull-canvas int int nonnull-c-string (c-pointer int) (c-pointer int) (c-pointer int) (c-pointer int))])
	  (lambda (canvas x y text)
	  	(let-location ([x0 int 0] [x1 int 0]
	  	               [y0 int 0] [y1 int 0])
	  	  (canvas-text-box/raw canvas x y text (location x0) (location x1) (location y0) (location y1))
	  	  (values x0 x1 y0 y1)))))

;; }}}

;; {{{ Vertex functions

(define call-with-canvas-in-mode
	(letrec ([canvas-modes
	          (list
	          	(cons
	          		'open-lines
	          		(foreign-value "CD_OPEN_LINES" int))
	          	(cons
	          		'closed-lines
	          		(foreign-value "CD_CLOSED_LINES" int))
	          	(cons
	          		'fill
	          		(foreign-value "CD_FILL" int))
	          	(cons
	          		'clip
	          		(foreign-value "CD_CLIP" int))
	          	(cons
	          		'bezier
	          		(foreign-value "CD_BEZIER" int))
	          	(cons
	          		'region
	          		(foreign-value "CD_REGION" int))
	          	(cons
	          		'path
	          		(foreign-value "CD_PATH" int)))]
	         [canvas-begin
	          (foreign-lambda void "cdCanvasBegin" nonnull-canvas int)]
	         [canvas-end
	          (foreign-lambda void "cdCanvasEnd" nonnull-canvas)])
	  (lambda (canvas canvas-mode proc)
	  	(let ([canvas-mode
	  	       (cond
	  	       	 [(assq canvas-mode canvas-modes) => cdr]
	  	       	 [else (error 'with-canvas-mode "unknown canvas mode" canvas-mode)])])
				(dynamic-wind
					(cut canvas-begin canvas canvas-mode)
					(cut proc canvas)
					(cut canvas-end canvas))))))

(define canvas-path-set!
	(letrec ([path-actions
	          (list
	          	(cons
	          		'new
	          		(foreign-value "CD_PATH_NEW" int))
	          	(cons
	          		'move-to
	          		(foreign-value "CD_PATH_MOVETO" int))
	          	(cons
	          		'line-to
	          		(foreign-value "CD_PATH_LINETO" int))
	          	(cons
	          		'arc
	          		(foreign-value "CD_PATH_ARC" int))
	          	(cons
	          		'curve-to
	          		(foreign-value "CD_PATH_CURVETO" int))
	          	(cons
	          		'close
	          		(foreign-value "CD_PATH_CLOSE" int))
	          	(cons
	          		'fill
	          		(foreign-value "CD_PATH_FILL" int))
	          	(cons
	          		'stroke
	          		(foreign-value "CD_PATH_STROKE" int))
	          	(cons
	          		'fill+stroke
	          		(foreign-value "CD_PATH_FILLSTROKE" int))
	          	(cons
	          		'clip
	          		(foreign-value "CD_PATH_CLIP" int)))]
	         [canvas-path-set/raw!
	          (foreign-lambda void "cdCanvasPathSet" nonnull-canvas int)])
	  (lambda (canvas path-action)
	  	(canvas-path-set/raw!
	  		canvas
	  		(cond
	  			[(assq path-action path-actions) => cdr]
	  			[else (error 'canvas-path-set! "unknown path action" path-action)])))))

(define canvas-vertex!
	(foreign-lambda void "cdfCanvasVertex" nonnull-canvas double double))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-printer.scm.





































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdprint.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:printer
	(foreign-value "CD_PRINTER" nonnull-context))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-ps.scm.





































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdps.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:ps
	(foreign-value "CD_PS" nonnull-context))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-server.scm.













































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdimage.h>\n"
	"#include <cddbuf.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:image
	(foreign-value "CD_IMAGE" nonnull-context))

(define context:double-buffer
	(foreign-value "CD_DBUFFER" nonnull-context))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-svg.scm.





































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdsvg.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:svg
	(foreign-value "CD_SVG" nonnull-context))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-types.scm.



















































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
(define-foreign-type canvas (c-pointer "cdCanvas")
	(canvas->pointer #f)
	(pointer->canvas #f))

(define-foreign-type nonnull-canvas (nonnull-c-pointer "cdCanvas")
	(canvas->pointer #t)
	(pointer->canvas #t))

(define-foreign-type context (c-pointer "cdContext")
	(context->pointer #f)
	(pointer->context #f))

(define-foreign-type nonnull-context (nonnull-c-pointer "cdContext")
	(context->pointer #t)
	(pointer->context #t))

(define-foreign-type state (c-pointer "cdState")
	(state->pointer #f)
	(pointer->state #f))

(define-foreign-type nonnull-state (nonnull-c-pointer "cdState")
	(state->pointer #t)
	(pointer->state #t))

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw-wmf.scm.





































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
;; {{{ Data types

(foreign-declare
	"#include <cd.h>\n"
	"#include <cdwmf.h>\n")

(include "canvas-draw-types.scm")

;; }}}

;; {{{ Context types

(define context:wmf
	(foreign-value "CD_WMF" nonnull-context))

;; }}}

;; vim: set ai et ts=2 sts=2 sw=2: ;;

Added chicken-5/canvas-draw.egg.























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
((category graphics)
 (synopsis "Bindings to the CD graphics library")
 (author "Thomas Chust")
 (license "BSD")
 (version "1.1.2")
 (dependencies
   srfi-1 srfi-13
   miscmacros)
 (components
   (extension canvas-draw
     (modules 
       canvas-draw
       canvas-draw-base canvas-draw-primitives canvas-draw-play
       canvas-draw-picture canvas-draw-client
       canvas-draw-ps canvas-draw-svg canvas-draw-metafile
       canvas-draw-cgm canvas-draw-dgn canvas-draw-dxf
       canvas-draw-emf canvas-draw-wmf
       canvas-draw-iup
       canvas-draw-gl
       canvas-draw-native canvas-draw-server
       canvas-draw-clipboard canvas-draw-printer
       canvas-draw-pdf)
     (source-dependencies
       "canvas-draw-types.scm"
       "canvas-draw-base.scm" "canvas-draw-primitives.scm" "canvas-draw-play.scm"
       "canvas-draw-picture.scm" "canvas-draw-client.scm"
       "canvas-draw-ps.scm" "canvas-draw-svg.scm" "canvas-draw-metafile.scm"
       "canvas-draw-cgm.scm" "canvas-draw-dgn.scm" "canvas-draw-dxf.scm"
       "canvas-draw-emf.scm" "canvas-draw-wmf.scm"
       "canvas-draw-iup.scm"
       "canvas-draw-gl.scm"
       "canvas-draw-native.scm" "canvas-draw-server.scm"
       "canvas-draw-clipboard.scm" "canvas-draw-printer.scm"
       "canvas-draw-pdf.scm"
       "canvas-draw-debug.scm")
     (link-options
       "-L" "-lcd"
       "-L" "-liupcd"
       "-L" "-lcdgl"
       "-L" "-lcdcontextplus"
       "-L" "-lcdpdf"))))

;; vim: set ai et ts=2 sts=2 sw=2 ft=scheme: ;;

Added chicken-5/canvas-draw.scm.























































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
(module canvas-draw-base
	(canvas? canvas->pointer pointer->canvas
	 context? context->pointer pointer->context
	 state? state->pointer pointer->state
	 context-capabilities
	 use-context+ make-canvas call-with-canvas
	 canvas-context
	 canvas-simulate!
	 canvas-attribute canvas-attribute-set!
	 canvas-state canvas-state-set!
	 canvas-clear! canvas-flush
	 canvas-size
	 canvas-mm->px canvas-px->mm
	 canvas-origin canvas-origin-set!
	 canvas-transform canvas-transform-set!
	 canvas-transform-compose!
	 canvas-transform-translate!
	 canvas-transform-scale!
	 canvas-transform-rotate!
	 canvas-foreground canvas-foreground-set!
	 canvas-background canvas-background-set!
	 canvas-write-mode canvas-write-mode-set!
	 canvas-clip-mode canvas-clip-mode-set!
	 canvas-clip-area canvas-clip-area-set!)
	(import
		scheme
    (chicken base)
    (chicken string)
    (chicken bitwise)
    (chicken gc)
    (chicken memory)
    (chicken foreign)
		srfi-1 srfi-4 srfi-13
    miscmacros)
	(include "canvas-draw-base.scm"))

(module canvas-draw-primitives
	(canvas-pixel!
	 canvas-mark!
	 canvas-mark-type canvas-mark-type-set!
	 canvas-mark-size canvas-mark-size-set!
	 canvas-line! canvas-rectangle! canvas-arc!
	 canvas-line-style canvas-line-style-set!
	 canvas-line-width canvas-line-width-set!
	 canvas-line-join canvas-line-join-set!
	 canvas-line-cap canvas-line-cap-set!
	 canvas-box! canvas-sector! canvas-chord!
	 canvas-background-opacity canvas-background-opacity-set!
	 canvas-fill-mode canvas-fill-mode-set!
	 canvas-interior-style canvas-interior-style-set!
	 canvas-text!
	 canvas-font canvas-font-set!
	 canvas-text-alignment canvas-text-alignment-set!
	 canvas-text-orientation canvas-text-orientation-set!
	 canvas-font-dimensions canvas-text-size canvas-text-box
	 call-with-canvas-in-mode canvas-path-set!
	 canvas-vertex!)
	(import
    scheme
    (chicken base)
    (chicken blob)
    (chicken foreign)
    srfi-4
    canvas-draw-base)
	(include "canvas-draw-primitives.scm"))

(module canvas-draw-play
	(canvas-play!)
	(import
    scheme
    (chicken base)
    (chicken foreign)
    canvas-draw-base)
	(include "canvas-draw-play.scm"))

(module canvas-draw-picture
	(context:picture)
	(import
    scheme
    (chicken base)
    (chicken foreign)
    canvas-draw-base)
	(include "canvas-draw-picture.scm"))

(module canvas-draw-client
	(context:image context:double-buffer
	 canvas-image/rgb canvas-image-put/rgb! canvas-image-put/rgba!)
	(import
    scheme
    (chicken base)
    (chicken blob)
    (chicken foreign)
    canvas-draw-base)
	(include "canvas-draw-client.scm"))

(module canvas-draw-ps
	(context:ps)
	(import
    scheme
    (chicken base)
    (chicken foreign)
    canvas-draw-base)
	(include "canvas-draw-ps.scm"))

(module canvas-draw-svg
	(context:svg)
	(import
    scheme
    (chicken base)
    (chicken foreign)
    canvas-draw-base)
	(include "canvas-draw-svg.scm"))

(module canvas-draw-metafile
	(context:metafile)
	(import
    scheme
    (chicken base)
    (chicken foreign)
    canvas-draw-base)
	(include "canvas-draw-metafile.scm"))

(module canvas-draw-cgm
	(context:cgm)
	(import
    scheme
    (chicken base)
    (chicken foreign)
    canvas-draw-base)
	(include "canvas-draw-cgm.scm"))

(module canvas-draw-dgn
	(context:dgn)
	(import
    scheme
    (chicken base)
    (chicken foreign)
    canvas-draw-base)
	(include "canvas-draw-dgn.scm"))

(module canvas-draw-dxf
	(context:dxf)
	(import
    scheme
    (chicken base)
    (chicken foreign)
    canvas-draw-base)
	(include "canvas-draw-dxf.scm"))

(module canvas-draw-emf
	(context:emf)
	(import
    scheme
    (chicken base)
    (chicken foreign)
    canvas-draw-base)
	(include "canvas-draw-emf.scm"))

(module canvas-draw-wmf
	(context:wmf)
	(import
    scheme
    (chicken base)
    (chicken foreign)
    canvas-draw-base)
	(include "canvas-draw-wmf.scm"))

(cond-expand
 [disable-canvas-draw-iup]
 [else
	(module canvas-draw-iup
		(context:iup make-canvas-action make-cells-draw-cb)
    (import
      scheme
      (chicken base)
      (chicken foreign)
      canvas-draw-base)
		(include "canvas-draw-iup.scm"))])

(cond-expand
 [disable-canvas-draw-gl]
 [else
	(module canvas-draw-gl
		(context:gl)
    (import
      scheme
      (chicken base)
      (chicken foreign)
      canvas-draw-base)
		(include "canvas-draw-gl.scm"))])

(cond-expand
 [disable-canvas-draw-native]
 [else
	(module canvas-draw-native
		(context:native-window
		 screen-size)
    (import
      scheme
      (chicken base)
      (chicken foreign)
      canvas-draw-base)
		(include "canvas-draw-native.scm"))
	(module canvas-draw-server
		(context:image context:double-buffer)
    (import
      scheme
      (chicken base)
      (chicken foreign)
      canvas-draw-base)
		(include "canvas-draw-server.scm"))
	(module canvas-draw-clipboard
		(context:clipboard)
    (import
      scheme
      (chicken base)
      (chicken foreign)
      canvas-draw-base)
		(include "canvas-draw-clipboard.scm"))
	(module canvas-draw-printer
		(context:printer)
    (import
      scheme
      (chicken base)
      (chicken foreign)
      canvas-draw-base)
		(include "canvas-draw-printer.scm"))])

(cond-expand
 [disable-canvas-draw-pdf]
 [else
	(module canvas-draw-pdf
		(context:pdf)
    (import
      scheme
      (chicken base)
      (chicken foreign)
      canvas-draw-base)
		(include "canvas-draw-pdf.scm"))])

(cond-expand
 [enable-canvas-draw-debug
	(module canvas-draw-debug
		(context:debug)
    (import
      scheme
      (chicken base)
      (chicken foreign)
      canvas-draw-base)
		(include "canvas-draw-debug.scm"))]
 [else])

(module canvas-draw
	()
	(import
    scheme
    (chicken base)
    (chicken module))
	(reexport
		(except canvas-draw-base
		        canvas->pointer pointer->canvas
		        context->pointer pointer->context
		        state->pointer pointer->state)
		canvas-draw-primitives
		canvas-draw-play))

;; vim: set ai et ts=2 sts=2 sw=2: ;;