Artifact
a398b8328d3370f893d185c7b4a4e3ec2c88ed63:
0000: 28 72 65 71 75 69 72 65 2d 6c 69 62 72 61 72 79 (require-library
0010: 20 6c 6f 6c 65 76 65 6c 20 64 61 74 61 2d 73 74 lolevel data-st
0020: 72 75 63 74 75 72 65 73 20 73 72 66 69 2d 31 20 ructures srfi-1
0030: 73 72 66 69 2d 34 20 73 72 66 69 2d 31 33 29 0a srfi-4 srfi-13).
0040: 0a 28 6d 6f 64 75 6c 65 20 63 61 6e 76 61 73 2d .(module canvas-
0050: 64 72 61 77 2d 62 61 73 65 0a 09 28 63 61 6e 76 draw-base..(canv
0060: 61 73 3f 20 63 61 6e 76 61 73 2d 3e 70 6f 69 6e as? canvas->poin
0070: 74 65 72 20 70 6f 69 6e 74 65 72 2d 3e 63 61 6e ter pointer->can
0080: 76 61 73 0a 09 20 63 6f 6e 74 65 78 74 3f 20 63 vas.. context? c
0090: 6f 6e 74 65 78 74 2d 3e 70 6f 69 6e 74 65 72 20 ontext->pointer
00a0: 70 6f 69 6e 74 65 72 2d 3e 63 6f 6e 74 65 78 74 pointer->context
00b0: 0a 09 20 73 74 61 74 65 3f 20 73 74 61 74 65 2d .. state? state-
00c0: 3e 70 6f 69 6e 74 65 72 20 70 6f 69 6e 74 65 72 >pointer pointer
00d0: 2d 3e 73 74 61 74 65 0a 09 20 63 6f 6e 74 65 78 ->state.. contex
00e0: 74 2d 63 61 70 61 62 69 6c 69 74 69 65 73 0a 09 t-capabilities..
00f0: 20 75 73 65 2d 63 6f 6e 74 65 78 74 2b 20 6d 61 use-context+ ma
0100: 6b 65 2d 63 61 6e 76 61 73 20 63 61 6c 6c 2d 77 ke-canvas call-w
0110: 69 74 68 2d 63 61 6e 76 61 73 0a 09 20 63 61 6e ith-canvas.. can
0120: 76 61 73 2d 63 6f 6e 74 65 78 74 0a 09 20 63 61 vas-context.. ca
0130: 6e 76 61 73 2d 73 69 6d 75 6c 61 74 65 21 0a 09 nvas-simulate!..
0140: 20 63 61 6e 76 61 73 2d 61 74 74 72 69 62 75 74 canvas-attribut
0150: 65 20 63 61 6e 76 61 73 2d 61 74 74 72 69 62 75 e canvas-attribu
0160: 74 65 2d 73 65 74 21 0a 09 20 63 61 6e 76 61 73 te-set!.. canvas
0170: 2d 73 74 61 74 65 20 63 61 6e 76 61 73 2d 73 74 -state canvas-st
0180: 61 74 65 2d 73 65 74 21 0a 09 20 63 61 6e 76 61 ate-set!.. canva
0190: 73 2d 63 6c 65 61 72 21 20 63 61 6e 76 61 73 2d s-clear! canvas-
01a0: 66 6c 75 73 68 0a 09 20 63 61 6e 76 61 73 2d 73 flush.. canvas-s
01b0: 69 7a 65 0a 09 20 63 61 6e 76 61 73 2d 6d 6d 2d ize.. canvas-mm-
01c0: 3e 70 78 20 63 61 6e 76 61 73 2d 70 78 2d 3e 6d >px canvas-px->m
01d0: 6d 0a 09 20 63 61 6e 76 61 73 2d 6f 72 69 67 69 m.. canvas-origi
01e0: 6e 20 63 61 6e 76 61 73 2d 6f 72 69 67 69 6e 2d n canvas-origin-
01f0: 73 65 74 21 0a 09 20 63 61 6e 76 61 73 2d 74 72 set!.. canvas-tr
0200: 61 6e 73 66 6f 72 6d 20 63 61 6e 76 61 73 2d 74 ansform canvas-t
0210: 72 61 6e 73 66 6f 72 6d 2d 73 65 74 21 0a 09 20 ransform-set!..
0220: 63 61 6e 76 61 73 2d 74 72 61 6e 73 66 6f 72 6d canvas-transform
0230: 2d 63 6f 6d 70 6f 73 65 21 0a 09 20 63 61 6e 76 -compose!.. canv
0240: 61 73 2d 74 72 61 6e 73 66 6f 72 6d 2d 74 72 61 as-transform-tra
0250: 6e 73 6c 61 74 65 21 0a 09 20 63 61 6e 76 61 73 nslate!.. canvas
0260: 2d 74 72 61 6e 73 66 6f 72 6d 2d 73 63 61 6c 65 -transform-scale
0270: 21 0a 09 20 63 61 6e 76 61 73 2d 74 72 61 6e 73 !.. canvas-trans
0280: 66 6f 72 6d 2d 72 6f 74 61 74 65 21 0a 09 20 63 form-rotate!.. c
0290: 61 6e 76 61 73 2d 66 6f 72 65 67 72 6f 75 6e 64 anvas-foreground
02a0: 20 63 61 6e 76 61 73 2d 66 6f 72 65 67 72 6f 75 canvas-foregrou
02b0: 6e 64 2d 73 65 74 21 0a 09 20 63 61 6e 76 61 73 nd-set!.. canvas
02c0: 2d 62 61 63 6b 67 72 6f 75 6e 64 20 63 61 6e 76 -background canv
02d0: 61 73 2d 62 61 63 6b 67 72 6f 75 6e 64 2d 73 65 as-background-se
02e0: 74 21 0a 09 20 63 61 6e 76 61 73 2d 77 72 69 74 t!.. canvas-writ
02f0: 65 2d 6d 6f 64 65 20 63 61 6e 76 61 73 2d 77 72 e-mode canvas-wr
0300: 69 74 65 2d 6d 6f 64 65 2d 73 65 74 21 0a 09 20 ite-mode-set!..
0310: 63 61 6e 76 61 73 2d 63 6c 69 70 2d 6d 6f 64 65 canvas-clip-mode
0320: 20 63 61 6e 76 61 73 2d 63 6c 69 70 2d 6d 6f 64 canvas-clip-mod
0330: 65 2d 73 65 74 21 0a 09 20 63 61 6e 76 61 73 2d e-set!.. canvas-
0340: 63 6c 69 70 2d 61 72 65 61 20 63 61 6e 76 61 73 clip-area canvas
0350: 2d 63 6c 69 70 2d 61 72 65 61 2d 73 65 74 21 29 -clip-area-set!)
0360: 0a 09 28 69 6d 70 6f 72 74 0a 09 09 73 63 68 65 ..(import...sche
0370: 6d 65 20 63 68 69 63 6b 65 6e 20 66 6f 72 65 69 me chicken forei
0380: 67 6e 0a 09 09 6c 6f 6c 65 76 65 6c 20 64 61 74 gn...lolevel dat
0390: 61 2d 73 74 72 75 63 74 75 72 65 73 20 73 72 66 a-structures srf
03a0: 69 2d 31 20 73 72 66 69 2d 34 20 73 72 66 69 2d i-1 srfi-4 srfi-
03b0: 31 33 29 0a 0a 3b 3b 20 7b 7b 7b 20 44 61 74 61 13)..;; {{{ Data
03c0: 20 74 79 70 65 73 0a 0a 28 66 6f 72 65 69 67 6e types..(foreign
03d0: 2d 64 65 63 6c 61 72 65 0a 09 22 23 69 6e 63 6c -declare.."#incl
03e0: 75 64 65 20 3c 63 64 2e 68 3e 5c 6e 22 29 0a 0a ude <cd.h>\n")..
03f0: 28 64 65 66 69 6e 65 20 2a 63 61 6e 76 61 73 2d (define *canvas-
0400: 74 61 67 2a 20 22 63 64 43 61 6e 76 61 73 22 29 tag* "cdCanvas")
0410: 0a 28 64 65 66 69 6e 65 20 63 61 6e 76 61 73 3f .(define canvas?
0420: 20 28 63 75 74 20 74 61 67 67 65 64 2d 70 6f 69 (cut tagged-poi
0430: 6e 74 65 72 3f 20 3c 3e 20 2a 63 61 6e 76 61 73 nter? <> *canvas
0440: 2d 74 61 67 2a 29 29 0a 0a 28 64 65 66 69 6e 65 -tag*))..(define
0450: 20 28 63 61 6e 76 61 73 2d 3e 70 6f 69 6e 74 65 (canvas->pointe
0460: 72 20 6e 6f 6e 6e 75 6c 6c 3f 29 0a 09 28 69 66 r nonnull?)..(if
0470: 20 6e 6f 6e 6e 75 6c 6c 3f 0a 09 09 28 6c 61 6d nonnull?...(lam
0480: 62 64 61 20 28 63 61 6e 76 61 73 29 0a 09 09 09 bda (canvas)....
0490: 28 65 6e 73 75 72 65 20 63 61 6e 76 61 73 3f 20 (ensure canvas?
04a0: 63 61 6e 76 61 73 29 0a 09 09 09 63 61 6e 76 61 canvas)....canva
04b0: 73 29 0a 09 09 28 6c 61 6d 62 64 61 20 28 63 61 s)...(lambda (ca
04c0: 6e 76 61 73 29 0a 09 09 09 28 65 6e 73 75 72 65 nvas)....(ensure
04d0: 20 28 64 69 73 6a 6f 69 6e 20 6e 6f 74 20 63 61 (disjoin not ca
04e0: 6e 76 61 73 3f 29 20 63 61 6e 76 61 73 29 0a 09 nvas?) canvas)..
04f0: 09 09 63 61 6e 76 61 73 29 29 29 0a 0a 28 64 65 ..canvas)))..(de
0500: 66 69 6e 65 20 28 70 6f 69 6e 74 65 72 2d 3e 63 fine (pointer->c
0510: 61 6e 76 61 73 20 6e 6f 6e 6e 75 6c 6c 3f 29 0a anvas nonnull?).
0520: 09 28 69 66 20 6e 6f 6e 6e 75 6c 6c 3f 0a 09 09 .(if nonnull?...
0530: 28 6c 61 6d 62 64 61 20 28 63 61 6e 76 61 73 29 (lambda (canvas)
0540: 0a 09 09 09 28 74 61 67 2d 70 6f 69 6e 74 65 72 ....(tag-pointer
0550: 20 63 61 6e 76 61 73 20 2a 63 61 6e 76 61 73 2d canvas *canvas-
0560: 74 61 67 2a 29 29 0a 09 09 28 6c 61 6d 62 64 61 tag*))...(lambda
0570: 20 28 63 61 6e 76 61 73 29 0a 09 09 09 28 61 6e (canvas)....(an
0580: 64 20 63 61 6e 76 61 73 20 28 74 61 67 2d 70 6f d canvas (tag-po
0590: 69 6e 74 65 72 20 63 61 6e 76 61 73 20 2a 63 61 inter canvas *ca
05a0: 6e 76 61 73 2d 74 61 67 2a 29 29 29 29 29 0a 0a nvas-tag*)))))..
05b0: 28 64 65 66 69 6e 65 20 2a 63 6f 6e 74 65 78 74 (define *context
05c0: 2d 74 61 67 2a 20 22 63 64 43 6f 6e 74 65 78 74 -tag* "cdContext
05d0: 22 29 0a 28 64 65 66 69 6e 65 20 63 6f 6e 74 65 ").(define conte
05e0: 78 74 3f 20 28 63 75 74 20 74 61 67 67 65 64 2d xt? (cut tagged-
05f0: 70 6f 69 6e 74 65 72 3f 20 3c 3e 20 2a 63 6f 6e pointer? <> *con
0600: 74 65 78 74 2d 74 61 67 2a 29 29 0a 0a 28 64 65 text-tag*))..(de
0610: 66 69 6e 65 20 28 63 6f 6e 74 65 78 74 2d 3e 70 fine (context->p
0620: 6f 69 6e 74 65 72 20 6e 6f 6e 6e 75 6c 6c 3f 29 ointer nonnull?)
0630: 0a 09 28 69 66 20 6e 6f 6e 6e 75 6c 6c 3f 0a 09 ..(if nonnull?..
0640: 09 28 6c 61 6d 62 64 61 20 28 63 6f 6e 74 65 78 .(lambda (contex
0650: 74 29 0a 09 09 09 28 65 6e 73 75 72 65 20 63 6f t)....(ensure co
0660: 6e 74 65 78 74 3f 20 63 6f 6e 74 65 78 74 29 0a ntext? context).
0670: 09 09 09 63 6f 6e 74 65 78 74 29 0a 09 09 28 6c ...context)...(l
0680: 61 6d 62 64 61 20 28 63 6f 6e 74 65 78 74 29 0a ambda (context).
0690: 09 09 09 28 65 6e 73 75 72 65 20 28 64 69 73 6a ...(ensure (disj
06a0: 6f 69 6e 20 6e 6f 74 20 63 6f 6e 74 65 78 74 3f oin not context?
06b0: 29 20 63 6f 6e 74 65 78 74 29 0a 09 09 09 63 6f ) context)....co
06c0: 6e 74 65 78 74 29 29 29 0a 0a 28 64 65 66 69 6e ntext)))..(defin
06d0: 65 20 28 70 6f 69 6e 74 65 72 2d 3e 63 6f 6e 74 e (pointer->cont
06e0: 65 78 74 20 6e 6f 6e 6e 75 6c 6c 3f 29 0a 09 28 ext nonnull?)..(
06f0: 69 66 20 6e 6f 6e 6e 75 6c 6c 3f 0a 09 09 28 6c if nonnull?...(l
0700: 61 6d 62 64 61 20 28 63 6f 6e 74 65 78 74 29 0a ambda (context).
0710: 09 09 09 28 74 61 67 2d 70 6f 69 6e 74 65 72 20 ...(tag-pointer
0720: 63 6f 6e 74 65 78 74 20 2a 63 6f 6e 74 65 78 74 context *context
0730: 2d 74 61 67 2a 29 29 0a 09 09 28 6c 61 6d 62 64 -tag*))...(lambd
0740: 61 20 28 63 6f 6e 74 65 78 74 29 0a 09 09 09 28 a (context)....(
0750: 61 6e 64 20 63 6f 6e 74 65 78 74 20 28 74 61 67 and context (tag
0760: 2d 70 6f 69 6e 74 65 72 20 63 6f 6e 74 65 78 74 -pointer context
0770: 20 2a 63 6f 6e 74 65 78 74 2d 74 61 67 2a 29 29 *context-tag*))
0780: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 73 74 )))..(define *st
0790: 61 74 65 2d 74 61 67 2a 20 22 63 64 53 74 61 74 ate-tag* "cdStat
07a0: 65 22 29 0a 28 64 65 66 69 6e 65 20 73 74 61 74 e").(define stat
07b0: 65 3f 20 28 63 75 74 20 74 61 67 67 65 64 2d 70 e? (cut tagged-p
07c0: 6f 69 6e 74 65 72 3f 20 3c 3e 20 2a 73 74 61 74 ointer? <> *stat
07d0: 65 2d 74 61 67 2a 29 29 0a 0a 28 64 65 66 69 6e e-tag*))..(defin
07e0: 65 20 28 73 74 61 74 65 2d 3e 70 6f 69 6e 74 65 e (state->pointe
07f0: 72 20 6e 6f 6e 6e 75 6c 6c 3f 29 0a 09 28 69 66 r nonnull?)..(if
0800: 20 6e 6f 6e 6e 75 6c 6c 3f 0a 09 09 28 6c 61 6d nonnull?...(lam
0810: 62 64 61 20 28 73 74 61 74 65 29 0a 09 09 09 28 bda (state)....(
0820: 65 6e 73 75 72 65 20 73 74 61 74 65 3f 20 73 74 ensure state? st
0830: 61 74 65 29 0a 09 09 09 73 74 61 74 65 29 0a 09 ate)....state)..
0840: 09 28 6c 61 6d 62 64 61 20 28 73 74 61 74 65 29 .(lambda (state)
0850: 0a 09 09 09 28 65 6e 73 75 72 65 20 28 64 69 73 ....(ensure (dis
0860: 6a 6f 69 6e 20 6e 6f 74 20 73 74 61 74 65 3f 29 join not state?)
0870: 20 73 74 61 74 65 29 0a 09 09 09 73 74 61 74 65 state)....state
0880: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 6f )))..(define (po
0890: 69 6e 74 65 72 2d 3e 73 74 61 74 65 20 6e 6f 6e inter->state non
08a0: 6e 75 6c 6c 3f 29 0a 09 28 69 66 20 6e 6f 6e 6e null?)..(if nonn
08b0: 75 6c 6c 3f 0a 09 09 28 6c 61 6d 62 64 61 20 28 ull?...(lambda (
08c0: 73 74 61 74 65 29 0a 09 09 09 28 74 61 67 2d 70 state)....(tag-p
08d0: 6f 69 6e 74 65 72 20 73 74 61 74 65 20 2a 73 74 ointer state *st
08e0: 61 74 65 2d 74 61 67 2a 29 29 0a 09 09 28 6c 61 ate-tag*))...(la
08f0: 6d 62 64 61 20 28 73 74 61 74 65 29 0a 09 09 09 mbda (state)....
0900: 28 61 6e 64 20 73 74 61 74 65 20 28 74 61 67 2d (and state (tag-
0910: 70 6f 69 6e 74 65 72 20 73 74 61 74 65 20 2a 73 pointer state *s
0920: 74 61 74 65 2d 74 61 67 2a 29 29 29 29 29 0a 0a tate-tag*)))))..
0930: 28 69 6e 63 6c 75 64 65 20 22 63 61 6e 76 61 73 (include "canvas
0940: 2d 64 72 61 77 2d 74 79 70 65 73 2e 73 63 6d 22 -draw-types.scm"
0950: 29 0a 0a 3b 3b 20 7d 7d 7d 0a 0a 3b 3b 20 7b 7b )..;; }}}..;; {{
0960: 7b 20 43 61 6e 76 61 73 20 6d 61 6e 61 67 65 6d { Canvas managem
0970: 65 6e 74 0a 0a 28 64 65 66 69 6e 65 20 63 6f 6e ent..(define con
0980: 74 65 78 74 2d 63 61 70 61 62 69 6c 69 74 69 65 text-capabilitie
0990: 73 0a 09 28 6c 65 74 72 65 63 20 28 5b 63 6f 6e s..(letrec ([con
09a0: 74 65 78 74 2d 63 61 70 61 62 69 6c 69 74 69 65 text-capabilitie
09b0: 73 2f 72 61 77 0a 09 09 09 20 20 20 20 20 20 28 s/raw.... (
09c0: 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 69 foreign-lambda i
09d0: 6e 74 20 22 63 64 43 6f 6e 74 65 78 74 43 61 70 nt "cdContextCap
09e0: 73 22 20 6e 6f 6e 6e 75 6c 6c 2d 63 6f 6e 74 65 s" nonnull-conte
09f0: 78 74 29 5d 0a 09 20 20 20 20 20 20 20 20 20 5b xt)].. [
0a00: 63 61 70 61 62 69 6c 69 74 69 65 73 0a 09 20 20 capabilities..
0a10: 20 20 20 20 20 20 20 20 28 6c 69 73 74 0a 09 20 (list..
0a20: 20 20 20 20 20 20 20 20 20 09 28 63 6f 6e 73 0a .(cons.
0a30: 09 20 20 20 20 20 20 20 20 20 20 09 09 27 66 6c . ..'fl
0a40: 75 73 68 0a 09 20 20 20 20 20 20 20 20 20 20 09 ush.. .
0a50: 09 28 66 6f 72 65 69 67 6e 2d 76 61 6c 75 65 20 .(foreign-value
0a60: 22 43 44 5f 43 41 50 5f 46 4c 55 53 48 22 20 69 "CD_CAP_FLUSH" i
0a70: 6e 74 29 29 0a 09 20 20 20 20 20 20 20 20 20 20 nt))..
0a80: 09 28 63 6f 6e 73 0a 09 20 20 20 20 20 20 20 20 .(cons..
0a90: 20 20 09 09 27 63 6c 65 61 72 0a 09 20 20 20 20 ..'clear..
0aa0: 20 20 20 20 20 20 09 09 28 66 6f 72 65 69 67 6e ..(foreign
0ab0: 2d 76 61 6c 75 65 20 22 43 44 5f 43 41 50 5f 43 -value "CD_CAP_C
0ac0: 4c 45 41 52 22 20 69 6e 74 29 29 0a 09 20 20 20 LEAR" int))..
0ad0: 20 20 20 20 20 20 20 09 28 63 6f 6e 73 0a 09 20 .(cons..
0ae0: 20 20 20 20 20 20 20 20 20 09 09 27 70 6c 61 79 ..'play
0af0: 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 28 66 .. ..(f
0b00: 6f 72 65 69 67 6e 2d 76 61 6c 75 65 20 22 43 44 oreign-value "CD
0b10: 5f 43 41 50 5f 50 4c 41 59 22 20 69 6e 74 29 29 _CAP_PLAY" int))
0b20: 0a 09 20 20 20 20 20 20 20 20 20 20 09 28 63 6f .. .(co
0b30: 6e 73 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 ns.. ..
0b40: 27 79 2d 61 78 69 73 0a 09 20 20 20 20 20 20 20 'y-axis..
0b50: 20 20 20 09 09 28 66 6f 72 65 69 67 6e 2d 76 61 ..(foreign-va
0b60: 6c 75 65 20 22 43 44 5f 43 41 50 5f 59 41 58 49 lue "CD_CAP_YAXI
0b70: 53 22 20 69 6e 74 29 29 0a 09 20 20 20 20 20 20 S" int))..
0b80: 20 20 20 20 09 28 63 6f 6e 73 0a 09 20 20 20 20 .(cons..
0b90: 20 20 20 20 20 20 09 09 27 63 6c 69 70 2d 61 72 ..'clip-ar
0ba0: 65 61 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 ea.. ..
0bb0: 28 66 6f 72 65 69 67 6e 2d 76 61 6c 75 65 20 22 (foreign-value "
0bc0: 43 44 5f 43 41 50 5f 43 4c 49 50 41 52 45 41 22 CD_CAP_CLIPAREA"
0bd0: 20 69 6e 74 29 29 0a 09 20 20 20 20 20 20 20 20 int))..
0be0: 20 20 09 28 63 6f 6e 73 0a 09 20 20 20 20 20 20 .(cons..
0bf0: 20 20 20 20 09 09 27 63 6c 69 70 2d 70 6f 6c 79 ..'clip-poly
0c00: 67 6f 6e 0a 09 20 20 20 20 20 20 20 20 20 20 09 gon.. .
0c10: 09 28 66 6f 72 65 69 67 6e 2d 76 61 6c 75 65 20 .(foreign-value
0c20: 22 43 44 5f 43 41 50 5f 43 4c 49 50 50 4f 4c 59 "CD_CAP_CLIPPOLY
0c30: 22 20 69 6e 74 29 29 0a 09 20 20 20 20 20 20 20 " int))..
0c40: 20 20 20 09 28 63 6f 6e 73 0a 09 20 20 20 20 20 .(cons..
0c50: 20 20 20 20 20 09 09 27 72 65 67 69 6f 6e 0a 09 ..'region..
0c60: 20 20 20 20 20 20 20 20 20 20 09 09 28 66 6f 72 ..(for
0c70: 65 69 67 6e 2d 76 61 6c 75 65 20 22 43 44 5f 43 eign-value "CD_C
0c80: 41 50 5f 52 45 47 49 4f 4e 22 20 69 6e 74 29 29 AP_REGION" int))
0c90: 0a 09 20 20 20 20 20 20 20 20 20 20 09 28 63 6f .. .(co
0ca0: 6e 73 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 ns.. ..
0cb0: 27 72 65 63 74 61 6e 67 6c 65 0a 09 20 20 20 20 'rectangle..
0cc0: 20 20 20 20 20 20 09 09 28 66 6f 72 65 69 67 6e ..(foreign
0cd0: 2d 76 61 6c 75 65 20 22 43 44 5f 43 41 50 5f 52 -value "CD_CAP_R
0ce0: 45 43 54 22 20 69 6e 74 29 29 0a 09 20 20 20 20 ECT" int))..
0cf0: 20 20 20 20 20 20 09 28 63 6f 6e 73 0a 09 20 20 .(cons..
0d00: 20 20 20 20 20 20 20 20 09 09 27 63 68 6f 72 64 ..'chord
0d10: 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 28 66 .. ..(f
0d20: 6f 72 65 69 67 6e 2d 76 61 6c 75 65 20 22 43 44 oreign-value "CD
0d30: 5f 43 41 50 5f 43 48 4f 52 44 22 20 69 6e 74 29 _CAP_CHORD" int)
0d40: 29 0a 09 20 20 20 20 20 20 20 20 20 20 09 28 63 ).. .(c
0d50: 6f 6e 73 0a 09 20 20 20 20 20 20 20 20 20 20 09 ons.. .
0d60: 09 27 69 6d 61 67 65 2f 72 67 62 0a 09 20 20 20 .'image/rgb..
0d70: 20 20 20 20 20 20 20 09 09 28 66 6f 72 65 69 67 ..(foreig
0d80: 6e 2d 76 61 6c 75 65 20 22 43 44 5f 43 41 50 5f n-value "CD_CAP_
0d90: 49 4d 41 47 45 52 47 42 22 20 69 6e 74 29 29 0a IMAGERGB" int)).
0da0: 09 20 20 20 20 20 20 20 20 20 20 09 28 63 6f 6e . .(con
0db0: 73 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 27 s.. ..'
0dc0: 69 6d 61 67 65 2f 72 67 62 61 0a 09 20 20 20 20 image/rgba..
0dd0: 20 20 20 20 20 20 09 09 28 66 6f 72 65 69 67 6e ..(foreign
0de0: 2d 76 61 6c 75 65 20 22 43 44 5f 43 41 50 5f 49 -value "CD_CAP_I
0df0: 4d 41 47 45 52 47 42 41 22 20 69 6e 74 29 29 0a MAGERGBA" int)).
0e00: 09 20 20 20 20 20 20 20 20 20 20 09 28 63 6f 6e . .(con
0e10: 73 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 27 s.. ..'
0e20: 69 6d 61 67 65 2f 6d 61 70 0a 09 20 20 20 20 20 image/map..
0e30: 20 20 20 20 20 09 09 28 66 6f 72 65 69 67 6e 2d ..(foreign-
0e40: 76 61 6c 75 65 20 22 43 44 5f 43 41 50 5f 49 4d value "CD_CAP_IM
0e50: 41 47 45 4d 41 50 22 20 69 6e 74 29 29 0a 09 20 AGEMAP" int))..
0e60: 20 20 20 20 20 20 20 20 20 09 28 63 6f 6e 73 0a .(cons.
0e70: 09 20 20 20 20 20 20 20 20 20 20 09 09 27 67 65 . ..'ge
0e80: 74 2d 69 6d 61 67 65 2f 72 67 62 0a 09 20 20 20 t-image/rgb..
0e90: 20 20 20 20 20 20 20 09 09 28 66 6f 72 65 69 67 ..(foreig
0ea0: 6e 2d 76 61 6c 75 65 20 22 43 44 5f 43 41 50 5f n-value "CD_CAP_
0eb0: 47 45 54 49 4d 41 47 45 52 47 42 22 20 69 6e 74 GETIMAGERGB" int
0ec0: 29 29 0a 09 20 20 20 20 20 20 20 20 20 20 09 28 )).. .(
0ed0: 63 6f 6e 73 0a 09 20 20 20 20 20 20 20 20 20 20 cons..
0ee0: 09 09 27 69 6d 61 67 65 2f 73 65 72 76 65 72 0a ..'image/server.
0ef0: 09 20 20 20 20 20 20 20 20 20 20 09 09 28 66 6f . ..(fo
0f00: 72 65 69 67 6e 2d 76 61 6c 75 65 20 22 43 44 5f reign-value "CD_
0f10: 43 41 50 5f 49 4d 41 47 45 53 52 56 22 20 69 6e CAP_IMAGESRV" in
0f20: 74 29 29 0a 09 20 20 20 20 20 20 20 20 20 20 09 t)).. .
0f30: 28 63 6f 6e 73 0a 09 20 20 20 20 20 20 20 20 20 (cons..
0f40: 20 09 09 27 62 61 63 6b 67 72 6f 75 6e 64 0a 09 ..'background..
0f50: 20 20 20 20 20 20 20 20 20 20 09 09 28 66 6f 72 ..(for
0f60: 65 69 67 6e 2d 76 61 6c 75 65 20 22 43 44 5f 43 eign-value "CD_C
0f70: 41 50 5f 42 41 43 4b 47 52 4f 55 4e 44 22 20 69 AP_BACKGROUND" i
0f80: 6e 74 29 29 0a 09 20 20 20 20 20 20 20 20 20 20 nt))..
0f90: 09 28 63 6f 6e 73 0a 09 20 20 20 20 20 20 20 20 .(cons..
0fa0: 20 20 09 09 27 62 61 63 6b 67 72 6f 75 6e 64 2d ..'background-
0fb0: 6f 70 61 63 69 74 79 0a 09 20 20 20 20 20 20 20 opacity..
0fc0: 20 20 20 09 09 28 66 6f 72 65 69 67 6e 2d 76 61 ..(foreign-va
0fd0: 6c 75 65 20 22 43 44 5f 43 41 50 5f 42 41 43 4b lue "CD_CAP_BACK
0fe0: 4f 50 41 43 49 54 59 22 20 69 6e 74 29 29 0a 09 OPACITY" int))..
0ff0: 20 20 20 20 20 20 20 20 20 20 09 28 63 6f 6e 73 .(cons
1000: 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 27 77 .. ..'w
1010: 72 69 74 65 2d 6d 6f 64 65 0a 09 20 20 20 20 20 rite-mode..
1020: 20 20 20 20 20 09 09 28 66 6f 72 65 69 67 6e 2d ..(foreign-
1030: 76 61 6c 75 65 20 22 43 44 5f 43 41 50 5f 57 52 value "CD_CAP_WR
1040: 49 54 45 4d 4f 44 45 22 20 69 6e 74 29 29 0a 09 ITEMODE" int))..
1050: 20 20 20 20 20 20 20 20 20 20 09 28 63 6f 6e 73 .(cons
1060: 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 27 6c .. ..'l
1070: 69 6e 65 2d 73 74 79 6c 65 0a 09 20 20 20 20 20 ine-style..
1080: 20 20 20 20 20 09 09 28 66 6f 72 65 69 67 6e 2d ..(foreign-
1090: 76 61 6c 75 65 20 22 43 44 5f 43 41 50 5f 4c 49 value "CD_CAP_LI
10a0: 4e 45 53 54 59 4c 45 22 20 69 6e 74 29 29 0a 09 NESTYLE" int))..
10b0: 20 20 20 20 20 20 20 20 20 20 09 28 63 6f 6e 73 .(cons
10c0: 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 27 6c .. ..'l
10d0: 69 6e 65 2d 77 69 64 74 68 0a 09 20 20 20 20 20 ine-width..
10e0: 20 20 20 20 20 09 09 28 66 6f 72 65 69 67 6e 2d ..(foreign-
10f0: 76 61 6c 75 65 20 22 43 44 5f 43 41 50 5f 4c 49 value "CD_CAP_LI
1100: 4e 45 57 49 54 48 22 20 69 6e 74 29 29 0a 09 20 NEWITH" int))..
1110: 20 20 20 20 20 20 20 20 20 09 28 63 6f 6e 73 0a .(cons.
1120: 09 20 20 20 20 20 20 20 20 20 20 09 09 27 66 70 . ..'fp
1130: 72 69 6d 74 69 76 65 73 0a 09 20 20 20 20 20 20 rimtives..
1140: 20 20 20 20 09 09 28 66 6f 72 65 69 67 6e 2d 76 ..(foreign-v
1150: 61 6c 75 65 20 22 43 44 5f 43 41 50 5f 46 50 52 alue "CD_CAP_FPR
1160: 49 4d 54 49 56 45 53 22 20 69 6e 74 29 29 0a 09 IMTIVES" int))..
1170: 20 20 20 20 20 20 20 20 20 20 09 28 63 6f 6e 73 .(cons
1180: 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 27 68 .. ..'h
1190: 61 74 63 68 0a 09 20 20 20 20 20 20 20 20 20 20 atch..
11a0: 09 09 28 66 6f 72 65 69 67 6e 2d 76 61 6c 75 65 ..(foreign-value
11b0: 20 22 43 44 5f 43 41 50 5f 48 41 54 43 48 22 20 "CD_CAP_HATCH"
11c0: 69 6e 74 29 29 0a 09 20 20 20 20 20 20 20 20 20 int))..
11d0: 20 09 28 63 6f 6e 73 0a 09 20 20 20 20 20 20 20 .(cons..
11e0: 20 20 20 09 09 27 73 74 69 70 70 6c 65 0a 09 20 ..'stipple..
11f0: 20 20 20 20 20 20 20 20 20 09 09 28 66 6f 72 65 ..(fore
1200: 69 67 6e 2d 76 61 6c 75 65 20 22 43 44 5f 43 41 ign-value "CD_CA
1210: 50 5f 53 54 49 50 50 4c 45 22 20 69 6e 74 29 29 P_STIPPLE" int))
1220: 0a 09 20 20 20 20 20 20 20 20 20 20 09 28 63 6f .. .(co
1230: 6e 73 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 ns.. ..
1240: 27 70 61 74 74 65 72 6e 0a 09 20 20 20 20 20 20 'pattern..
1250: 20 20 20 20 09 09 28 66 6f 72 65 69 67 6e 2d 76 ..(foreign-v
1260: 61 6c 75 65 20 22 43 44 5f 43 41 50 5f 50 41 54 alue "CD_CAP_PAT
1270: 54 45 52 4e 22 20 69 6e 74 29 29 0a 09 20 20 20 TERN" int))..
1280: 20 20 20 20 20 20 20 09 28 63 6f 6e 73 0a 09 20 .(cons..
1290: 20 20 20 20 20 20 20 20 20 09 09 27 66 6f 6e 74 ..'font
12a0: 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 28 66 .. ..(f
12b0: 6f 72 65 69 67 6e 2d 76 61 6c 75 65 20 22 43 44 oreign-value "CD
12c0: 5f 43 41 50 5f 46 4f 4e 54 22 20 69 6e 74 29 29 _CAP_FONT" int))
12d0: 0a 09 20 20 20 20 20 20 20 20 20 20 09 28 63 6f .. .(co
12e0: 6e 73 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 ns.. ..
12f0: 27 66 6f 6e 74 2d 64 69 6d 65 6e 73 69 6f 6e 73 'font-dimensions
1300: 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 28 66 .. ..(f
1310: 6f 72 65 69 67 6e 2d 76 61 6c 75 65 20 22 43 44 oreign-value "CD
1320: 5f 43 41 50 5f 46 4f 4e 54 44 49 4d 22 20 69 6e _CAP_FONTDIM" in
1330: 74 29 29 0a 09 20 20 20 20 20 20 20 20 20 20 09 t)).. .
1340: 28 63 6f 6e 73 0a 09 20 20 20 20 20 20 20 20 20 (cons..
1350: 20 09 09 27 74 65 78 74 2d 73 69 7a 65 0a 09 20 ..'text-size..
1360: 20 20 20 20 20 20 20 20 20 09 09 28 66 6f 72 65 ..(fore
1370: 69 67 6e 2d 76 61 6c 75 65 20 22 43 44 5f 43 41 ign-value "CD_CA
1380: 50 5f 54 45 58 54 53 49 5a 45 22 20 69 6e 74 29 P_TEXTSIZE" int)
1390: 29 0a 09 20 20 20 20 20 20 20 20 20 20 09 28 63 ).. .(c
13a0: 6f 6e 73 0a 09 20 20 20 20 20 20 20 20 20 20 09 ons.. .
13b0: 09 27 74 65 78 74 2d 6f 72 69 65 6e 74 61 74 69 .'text-orientati
13c0: 6f 6e 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 on.. ..
13d0: 28 66 6f 72 65 69 67 6e 2d 76 61 6c 75 65 20 22 (foreign-value "
13e0: 43 44 5f 43 41 50 5f 54 45 58 54 4f 52 49 45 4e CD_CAP_TEXTORIEN
13f0: 54 41 54 49 4f 4e 22 20 69 6e 74 29 29 0a 09 20 TATION" int))..
1400: 20 20 20 20 20 20 20 20 20 09 28 63 6f 6e 73 0a .(cons.
1410: 09 20 20 20 20 20 20 20 20 20 20 09 09 27 70 61 . ..'pa
1420: 6c 65 74 74 65 0a 09 20 20 20 20 20 20 20 20 20 lette..
1430: 20 09 09 28 66 6f 72 65 69 67 6e 2d 76 61 6c 75 ..(foreign-valu
1440: 65 20 22 43 44 5f 43 41 50 5f 50 41 4c 45 54 54 e "CD_CAP_PALETT
1450: 45 22 20 69 6e 74 29 29 0a 09 20 20 20 20 20 20 E" int))..
1460: 20 20 20 20 09 28 63 6f 6e 73 0a 09 20 20 20 20 .(cons..
1470: 20 20 20 20 20 20 09 09 27 6c 69 6e 65 2d 63 61 ..'line-ca
1480: 70 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 28 p.. ..(
1490: 66 6f 72 65 69 67 6e 2d 76 61 6c 75 65 20 22 43 foreign-value "C
14a0: 44 5f 43 41 50 5f 4c 49 4e 45 43 41 50 22 20 69 D_CAP_LINECAP" i
14b0: 6e 74 29 29 0a 09 20 20 20 20 20 20 20 20 20 20 nt))..
14c0: 09 28 63 6f 6e 73 0a 09 20 20 20 20 20 20 20 20 .(cons..
14d0: 20 20 09 09 27 6c 69 6e 65 2d 6a 6f 69 6e 0a 09 ..'line-join..
14e0: 20 20 20 20 20 20 20 20 20 20 09 09 28 66 6f 72 ..(for
14f0: 65 69 67 6e 2d 76 61 6c 75 65 20 22 43 44 5f 43 eign-value "CD_C
1500: 41 50 5f 4c 49 4e 45 4a 4f 49 4e 22 20 69 6e 74 AP_LINEJOIN" int
1510: 29 29 0a 09 20 20 20 20 20 20 20 20 20 20 09 28 )).. .(
1520: 63 6f 6e 73 0a 09 20 20 20 20 20 20 20 20 20 20 cons..
1530: 09 09 27 70 61 74 68 0a 09 20 20 20 20 20 20 20 ..'path..
1540: 20 20 20 09 09 28 66 6f 72 65 69 67 6e 2d 76 61 ..(foreign-va
1550: 6c 75 65 20 22 43 44 5f 43 41 50 5f 50 41 54 48 lue "CD_CAP_PATH
1560: 22 20 69 6e 74 29 29 0a 09 20 20 20 20 20 20 20 " int))..
1570: 20 20 20 09 28 63 6f 6e 73 0a 09 20 20 20 20 20 .(cons..
1580: 20 20 20 20 20 09 09 27 62 65 7a 69 65 72 0a 09 ..'bezier..
1590: 20 20 20 20 20 20 20 20 20 20 09 09 28 66 6f 72 ..(for
15a0: 65 69 67 6e 2d 76 61 6c 75 65 20 22 43 44 5f 43 eign-value "CD_C
15b0: 41 50 5f 42 45 5a 49 45 52 22 20 69 6e 74 29 29 AP_BEZIER" int))
15c0: 29 5d 29 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 )]).. (lambda (
15d0: 63 6f 6e 74 65 78 74 29 0a 09 20 20 09 28 6c 65 context).. .(le
15e0: 74 20 28 5b 63 61 70 61 62 69 6c 69 74 69 65 73 t ([capabilities
15f0: 2f 72 61 77 20 28 63 6f 6e 74 65 78 74 2d 63 61 /raw (context-ca
1600: 70 61 62 69 6c 69 74 69 65 73 2f 72 61 77 20 63 pabilities/raw c
1610: 6f 6e 74 65 78 74 29 5d 29 0a 09 09 09 09 28 66 ontext)]).....(f
1620: 69 6c 74 65 72 2d 6d 61 70 0a 09 09 09 09 09 28 ilter-map......(
1630: 6c 61 6d 62 64 61 20 28 69 6e 66 6f 29 0a 09 09 lambda (info)...
1640: 09 09 09 09 28 6c 65 74 20 28 5b 6d 61 73 6b 20 ....(let ([mask
1650: 28 63 64 72 20 69 6e 66 6f 29 5d 29 0a 09 09 09 (cdr info)])....
1660: 09 09 09 09 28 61 6e 64 20 28 3d 20 28 62 69 74 ....(and (= (bit
1670: 77 69 73 65 2d 61 6e 64 20 6d 61 73 6b 20 63 61 wise-and mask ca
1680: 70 61 62 69 6c 69 74 69 65 73 2f 72 61 77 29 20 pabilities/raw)
1690: 6d 61 73 6b 29 20 28 63 61 72 20 69 6e 66 6f 29 mask) (car info)
16a0: 29 29 29 0a 09 09 09 09 09 63 61 70 61 62 69 6c )))......capabil
16b0: 69 74 69 65 73 29 29 29 29 29 0a 0a 28 64 65 66 ities)))))..(def
16c0: 69 6e 65 20 75 73 65 2d 63 6f 6e 74 65 78 74 2b ine use-context+
16d0: 0a 09 28 6d 61 6b 65 2d 70 61 72 61 6d 65 74 65 ..(make-paramete
16e0: 72 20 23 66 29 29 0a 0a 28 64 65 66 69 6e 65 20 r #f))..(define
16f0: 6d 61 6b 65 2d 63 61 6e 76 61 73 2f 70 74 72 0a make-canvas/ptr.
1700: 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 .(foreign-lambda
1710: 2a 20 63 61 6e 76 61 73 20 28 5b 6e 6f 6e 6e 75 * canvas ([nonnu
1720: 6c 6c 2d 63 6f 6e 74 65 78 74 20 63 6f 6e 74 65 ll-context conte
1730: 78 74 5d 20 5b 62 6f 6f 6c 20 70 6c 75 73 5d 20 xt] [bool plus]
1740: 5b 63 2d 70 6f 69 6e 74 65 72 20 64 61 74 61 5d [c-pointer data]
1750: 29 0a 09 09 22 63 64 55 73 65 43 6f 6e 74 65 78 )..."cdUseContex
1760: 74 50 6c 75 73 28 70 6c 75 73 29 3b 5c 6e 22 0a tPlus(plus);\n".
1770: 09 09 22 43 5f 72 65 74 75 72 6e 28 63 64 43 72 .."C_return(cdCr
1780: 65 61 74 65 43 61 6e 76 61 73 28 63 6f 6e 74 65 eateCanvas(conte
1790: 78 74 2c 20 64 61 74 61 29 29 3b 22 29 29 0a 0a xt, data));"))..
17a0: 28 64 65 66 69 6e 65 20 6d 61 6b 65 2d 63 61 6e (define make-can
17b0: 76 61 73 2f 73 74 72 69 6e 67 0a 09 28 66 6f 72 vas/string..(for
17c0: 65 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 63 61 6e eign-lambda* can
17d0: 76 61 73 20 28 5b 6e 6f 6e 6e 75 6c 6c 2d 63 6f vas ([nonnull-co
17e0: 6e 74 65 78 74 20 63 6f 6e 74 65 78 74 5d 20 5b ntext context] [
17f0: 62 6f 6f 6c 20 70 6c 75 73 5d 20 5b 63 2d 73 74 bool plus] [c-st
1800: 72 69 6e 67 20 64 61 74 61 5d 29 0a 09 09 22 63 ring data])..."c
1810: 64 55 73 65 43 6f 6e 74 65 78 74 50 6c 75 73 28 dUseContextPlus(
1820: 70 6c 75 73 29 3b 5c 6e 22 0a 09 09 22 43 5f 72 plus);\n"..."C_r
1830: 65 74 75 72 6e 28 63 64 43 72 65 61 74 65 43 61 eturn(cdCreateCa
1840: 6e 76 61 73 28 63 6f 6e 74 65 78 74 2c 20 28 76 nvas(context, (v
1850: 6f 69 64 20 2a 29 64 61 74 61 29 29 3b 22 29 29 oid *)data));"))
1860: 0a 0a 28 64 65 66 69 6e 65 20 63 61 6e 76 61 73 ..(define canvas
1870: 2d 6b 69 6c 6c 21 0a 09 28 66 6f 72 65 69 67 6e -kill!..(foreign
1880: 2d 6c 61 6d 62 64 61 20 76 6f 69 64 20 22 63 64 -lambda void "cd
1890: 4b 69 6c 6c 43 61 6e 76 61 73 22 20 6e 6f 6e 6e KillCanvas" nonn
18a0: 75 6c 6c 2d 63 61 6e 76 61 73 29 29 0a 0a 28 64 ull-canvas))..(d
18b0: 65 66 69 6e 65 20 63 61 6e 76 61 73 2d 61 63 74 efine canvas-act
18c0: 69 76 61 74 65 21 0a 09 28 66 6f 72 65 69 67 6e ivate!..(foreign
18d0: 2d 6c 61 6d 62 64 61 20 76 6f 69 64 20 22 63 64 -lambda void "cd
18e0: 43 61 6e 76 61 73 41 63 74 69 76 61 74 65 22 20 CanvasActivate"
18f0: 6e 6f 6e 6e 75 6c 6c 2d 63 61 6e 76 61 73 29 29 nonnull-canvas))
1900: 0a 0a 28 64 65 66 69 6e 65 20 63 61 6e 76 61 73 ..(define canvas
1910: 2d 64 65 61 63 74 69 76 61 74 65 21 0a 09 28 66 -deactivate!..(f
1920: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 76 6f oreign-lambda vo
1930: 69 64 20 22 63 64 43 61 6e 76 61 73 44 65 61 63 id "cdCanvasDeac
1940: 74 69 76 61 74 65 22 20 6e 6f 6e 6e 75 6c 6c 2d tivate" nonnull-
1950: 63 61 6e 76 61 73 29 29 0a 0a 28 64 65 66 69 6e canvas))..(defin
1960: 65 20 28 6d 61 6b 65 2d 63 61 6e 76 61 73 20 63 e (make-canvas c
1970: 6f 6e 74 65 78 74 20 64 61 74 61 29 0a 09 28 6c ontext data)..(l
1980: 65 74 20 28 5b 6d 61 6b 65 2d 63 61 6e 76 61 73 et ([make-canvas
1990: 2f 64 61 74 61 20 28 69 66 20 28 73 74 72 69 6e /data (if (strin
19a0: 67 3f 20 64 61 74 61 29 20 6d 61 6b 65 2d 63 61 g? data) make-ca
19b0: 6e 76 61 73 2f 73 74 72 69 6e 67 20 6d 61 6b 65 nvas/string make
19c0: 2d 63 61 6e 76 61 73 2f 70 74 72 29 5d 29 0a 09 -canvas/ptr)])..
19d0: 09 28 63 6f 6e 64 0a 09 09 09 5b 28 6d 61 6b 65 .(cond....[(make
19e0: 2d 63 61 6e 76 61 73 2f 64 61 74 61 20 63 6f 6e -canvas/data con
19f0: 74 65 78 74 20 28 75 73 65 2d 63 6f 6e 74 65 78 text (use-contex
1a00: 74 2b 29 20 64 61 74 61 29 0a 09 09 09 20 3d 3e t+) data).... =>
1a10: 20 28 63 75 74 20 73 65 74 2d 66 69 6e 61 6c 69 (cut set-finali
1a20: 7a 65 72 21 20 3c 3e 20 63 61 6e 76 61 73 2d 6b zer! <> canvas-k
1a30: 69 6c 6c 21 29 5d 0a 09 09 09 5b 65 6c 73 65 0a ill!)]....[else.
1a40: 09 09 09 20 28 65 72 72 6f 72 20 27 6d 61 6b 65 ... (error 'make
1a50: 2d 63 61 6e 76 61 73 20 22 66 61 69 6c 65 64 20 -canvas "failed
1a60: 74 6f 20 63 72 65 61 74 65 20 63 61 6e 76 61 73 to create canvas
1a70: 22 29 5d 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ")])))..(define
1a80: 63 61 6c 6c 2d 77 69 74 68 2d 63 61 6e 76 61 73 call-with-canvas
1a90: 0a 09 28 63 61 73 65 2d 6c 61 6d 62 64 61 0a 09 ..(case-lambda..
1aa0: 09 5b 28 63 61 6e 76 61 73 20 70 72 6f 63 29 0a .[(canvas proc).
1ab0: 09 09 20 28 64 79 6e 61 6d 69 63 2d 77 69 6e 64 .. (dynamic-wind
1ac0: 0a 09 09 20 09 20 28 63 75 74 20 63 61 6e 76 61 ... . (cut canva
1ad0: 73 2d 61 63 74 69 76 61 74 65 21 20 63 61 6e 76 s-activate! canv
1ae0: 61 73 29 0a 09 09 20 09 20 28 63 75 74 20 70 72 as)... . (cut pr
1af0: 6f 63 20 63 61 6e 76 61 73 29 0a 09 09 20 09 20 oc canvas)... .
1b00: 28 63 75 74 20 63 61 6e 76 61 73 2d 64 65 61 63 (cut canvas-deac
1b10: 74 69 76 61 74 65 21 20 63 61 6e 76 61 73 29 29 tivate! canvas))
1b20: 5d 0a 09 09 5b 28 63 6f 6e 74 65 78 74 20 64 61 ]...[(context da
1b30: 74 61 20 70 72 6f 63 29 0a 09 09 20 28 6c 65 74 ta proc)... (let
1b40: 2a 20 28 5b 6d 61 6b 65 2d 63 61 6e 76 61 73 2f * ([make-canvas/
1b50: 64 61 74 61 20 28 69 66 20 28 73 74 72 69 6e 67 data (if (string
1b60: 3f 20 64 61 74 61 29 20 6d 61 6b 65 2d 63 61 6e ? data) make-can
1b70: 76 61 73 2f 73 74 72 69 6e 67 20 6d 61 6b 65 2d vas/string make-
1b80: 63 61 6e 76 61 73 2f 70 74 72 29 5d 0a 09 09 20 canvas/ptr)]...
1b90: 09 09 20 20 20 20 5b 63 61 6e 76 61 73 20 28 6d .. [canvas (m
1ba0: 61 6b 65 2d 63 61 6e 76 61 73 2f 64 61 74 61 20 ake-canvas/data
1bb0: 63 6f 6e 74 65 78 74 20 28 75 73 65 2d 63 6f 6e context (use-con
1bc0: 74 65 78 74 2b 29 20 64 61 74 61 29 5d 29 0a 09 text+) data)])..
1bd0: 09 20 09 20 28 75 6e 6c 65 73 73 20 63 61 6e 76 . . (unless canv
1be0: 61 73 20 28 65 72 72 6f 72 20 27 63 61 6c 6c 2d as (error 'call-
1bf0: 77 69 74 68 2d 63 61 6e 76 61 73 20 22 66 61 69 with-canvas "fai
1c00: 6c 65 64 20 74 6f 20 63 72 65 61 74 65 20 63 61 led to create ca
1c10: 6e 76 61 73 22 29 29 0a 09 09 09 20 28 64 79 6e nvas")).... (dyn
1c20: 61 6d 69 63 2d 77 69 6e 64 0a 09 09 09 20 09 20 amic-wind.... .
1c30: 28 63 75 74 20 63 61 6e 76 61 73 2d 61 63 74 69 (cut canvas-acti
1c40: 76 61 74 65 21 20 63 61 6e 76 61 73 29 0a 09 09 vate! canvas)...
1c50: 09 20 09 20 28 63 75 74 20 70 72 6f 63 20 63 61 . . (cut proc ca
1c60: 6e 76 61 73 29 0a 09 09 09 20 09 20 28 6c 61 6d nvas).... . (lam
1c70: 62 64 61 20 28 29 0a 09 09 09 20 09 20 09 20 28 bda ().... . . (
1c80: 77 68 65 6e 20 63 61 6e 76 61 73 0a 09 09 09 09 when canvas.....
1c90: 09 09 20 28 63 61 6e 76 61 73 2d 6b 69 6c 6c 21 .. (canvas-kill!
1ca0: 20 63 61 6e 76 61 73 29 0a 09 09 09 09 09 09 20 canvas).......
1cb0: 28 73 65 74 21 20 63 61 6e 76 61 73 20 23 66 29 (set! canvas #f)
1cc0: 29 29 29 29 5d 29 29 0a 0a 28 64 65 66 69 6e 65 ))))]))..(define
1cd0: 20 63 61 6e 76 61 73 2d 63 6f 6e 74 65 78 74 0a canvas-context.
1ce0: 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 .(foreign-lambda
1cf0: 20 6e 6f 6e 6e 75 6c 6c 2d 63 6f 6e 74 65 78 74 nonnull-context
1d00: 20 22 63 64 43 61 6e 76 61 73 47 65 74 43 6f 6e "cdCanvasGetCon
1d10: 74 65 78 74 22 20 6e 6f 6e 6e 75 6c 6c 2d 63 61 text" nonnull-ca
1d20: 6e 76 61 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 nvas))..(define
1d30: 63 61 6e 76 61 73 2d 73 69 6d 75 6c 61 74 65 21 canvas-simulate!
1d40: 0a 09 28 6c 65 74 72 65 63 20 28 5b 63 61 6e 76 ..(letrec ([canv
1d50: 61 73 2d 73 69 6d 75 6c 61 74 65 2f 72 61 77 21 as-simulate/raw!
1d60: 0a 09 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 .. (for
1d70: 65 69 67 6e 2d 6c 61 6d 62 64 61 20 69 6e 74 20 eign-lambda int
1d80: 22 63 64 43 61 6e 76 61 73 53 69 6d 75 6c 61 74 "cdCanvasSimulat
1d90: 65 22 20 6e 6f 6e 6e 75 6c 6c 2d 63 61 6e 76 61 e" nonnull-canva
1da0: 73 20 69 6e 74 29 5d 0a 09 20 20 20 20 20 20 20 s int)]..
1db0: 20 20 5b 66 6c 61 67 73 0a 09 20 20 20 20 20 20 [flags..
1dc0: 20 20 20 20 28 6c 69 73 74 0a 09 20 20 20 20 20 (list..
1dd0: 20 20 20 20 20 09 28 63 6f 6e 73 0a 09 20 20 20 .(cons..
1de0: 20 20 20 20 20 20 20 09 09 27 6c 69 6e 65 0a 09 ..'line..
1df0: 20 20 20 20 20 20 20 20 20 20 09 09 28 66 6f 72 ..(for
1e00: 65 69 67 6e 2d 76 61 6c 75 65 20 22 43 44 5f 53 eign-value "CD_S
1e10: 49 4d 5f 4c 49 4e 45 22 20 69 6e 74 29 29 0a 09 IM_LINE" int))..
1e20: 20 20 20 20 20 20 20 20 20 20 09 28 63 6f 6e 73 .(cons
1e30: 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 27 72 .. ..'r
1e40: 65 63 74 61 6e 67 6c 65 0a 09 20 20 20 20 20 20 ectangle..
1e50: 20 20 20 20 09 09 28 66 6f 72 65 69 67 6e 2d 76 ..(foreign-v
1e60: 61 6c 75 65 20 22 43 44 5f 53 49 4d 5f 52 45 43 alue "CD_SIM_REC
1e70: 54 22 20 69 6e 74 29 29 0a 09 20 20 20 20 20 20 T" int))..
1e80: 20 20 20 20 09 28 63 6f 6e 73 0a 09 20 20 20 20 .(cons..
1e90: 20 20 20 20 20 20 09 09 27 62 6f 78 0a 09 20 20 ..'box..
1ea0: 20 20 20 20 20 20 20 20 09 09 28 66 6f 72 65 69 ..(forei
1eb0: 67 6e 2d 76 61 6c 75 65 20 22 43 44 5f 53 49 4d gn-value "CD_SIM
1ec0: 5f 42 4f 58 22 20 69 6e 74 29 29 0a 09 20 20 20 _BOX" int))..
1ed0: 20 20 20 20 20 20 20 09 28 63 6f 6e 73 0a 09 20 .(cons..
1ee0: 20 20 20 20 20 20 20 20 20 09 09 27 61 72 63 0a ..'arc.
1ef0: 09 20 20 20 20 20 20 20 20 20 20 09 09 28 66 6f . ..(fo
1f00: 72 65 69 67 6e 2d 76 61 6c 75 65 20 22 43 44 5f reign-value "CD_
1f10: 53 49 4d 5f 41 52 43 22 20 69 6e 74 29 29 0a 09 SIM_ARC" int))..
1f20: 20 20 20 20 20 20 20 20 20 20 09 28 63 6f 6e 73 .(cons
1f30: 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 27 73 .. ..'s
1f40: 65 63 74 6f 72 0a 09 20 20 20 20 20 20 20 20 20 ector..
1f50: 20 09 09 28 66 6f 72 65 69 67 6e 2d 76 61 6c 75 ..(foreign-valu
1f60: 65 20 22 43 44 5f 53 49 4d 5f 53 45 43 54 4f 52 e "CD_SIM_SECTOR
1f70: 22 20 69 6e 74 29 29 0a 09 20 20 20 20 20 20 20 " int))..
1f80: 20 20 20 09 28 63 6f 6e 73 0a 09 20 20 20 20 20 .(cons..
1f90: 20 20 20 20 20 09 09 27 63 68 6f 72 64 0a 09 20 ..'chord..
1fa0: 20 20 20 20 20 20 20 20 20 09 09 28 66 6f 72 65 ..(fore
1fb0: 69 67 6e 2d 76 61 6c 75 65 20 22 43 44 5f 53 49 ign-value "CD_SI
1fc0: 4d 5f 43 48 4f 52 44 22 20 69 6e 74 29 29 0a 09 M_CHORD" int))..
1fd0: 20 20 20 20 20 20 20 20 20 20 09 28 63 6f 6e 73 .(cons
1fe0: 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 27 70 .. ..'p
1ff0: 6f 6c 79 6c 69 6e 65 0a 09 20 20 20 20 20 20 20 olyline..
2000: 20 20 20 09 09 28 66 6f 72 65 69 67 6e 2d 76 61 ..(foreign-va
2010: 6c 75 65 20 22 43 44 5f 53 49 4d 5f 50 4f 4c 59 lue "CD_SIM_POLY
2020: 4c 49 4e 45 22 20 69 6e 74 29 29 0a 09 20 20 20 LINE" int))..
2030: 20 20 20 20 20 20 20 09 28 63 6f 6e 73 0a 09 20 .(cons..
2040: 20 20 20 20 20 20 20 20 20 09 09 27 70 6f 6c 79 ..'poly
2050: 67 6f 6e 0a 09 20 20 20 20 20 20 20 20 20 20 09 gon.. .
2060: 09 28 66 6f 72 65 69 67 6e 2d 76 61 6c 75 65 20 .(foreign-value
2070: 22 43 44 5f 53 49 4d 5f 50 4f 4c 59 47 4f 4e 22 "CD_SIM_POLYGON"
2080: 20 69 6e 74 29 29 0a 09 20 20 20 20 20 20 20 20 int))..
2090: 20 20 09 28 63 6f 6e 73 0a 09 20 20 20 20 20 20 .(cons..
20a0: 20 20 20 20 09 09 27 74 65 78 74 0a 09 20 20 20 ..'text..
20b0: 20 20 20 20 20 20 20 09 09 28 66 6f 72 65 69 67 ..(foreig
20c0: 6e 2d 76 61 6c 75 65 20 22 43 44 5f 53 49 4d 5f n-value "CD_SIM_
20d0: 54 45 58 54 22 20 69 6e 74 29 29 0a 09 20 20 20 TEXT" int))..
20e0: 20 20 20 20 20 20 20 09 28 63 6f 6e 73 0a 09 20 .(cons..
20f0: 20 20 20 20 20 20 20 20 20 09 09 27 61 6c 6c 0a ..'all.
2100: 09 20 20 20 20 20 20 20 20 20 20 09 09 28 66 6f . ..(fo
2110: 72 65 69 67 6e 2d 76 61 6c 75 65 20 22 43 44 5f reign-value "CD_
2120: 53 49 4d 5f 41 4c 4c 22 20 69 6e 74 29 29 0a 09 SIM_ALL" int))..
2130: 20 20 20 20 20 20 20 20 20 20 09 28 63 6f 6e 73 .(cons
2140: 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 27 6c .. ..'l
2150: 69 6e 65 73 0a 09 20 20 20 20 20 20 20 20 20 20 ines..
2160: 09 09 28 66 6f 72 65 69 67 6e 2d 76 61 6c 75 65 ..(foreign-value
2170: 20 22 43 44 5f 53 49 4d 5f 4c 49 4e 45 53 22 20 "CD_SIM_LINES"
2180: 69 6e 74 29 29 0a 09 20 20 20 20 20 20 20 20 20 int))..
2190: 20 09 28 63 6f 6e 73 0a 09 20 20 20 20 20 20 20 .(cons..
21a0: 20 20 20 09 09 27 66 69 6c 6c 73 0a 09 20 20 20 ..'fills..
21b0: 20 20 20 20 20 20 20 09 09 28 66 6f 72 65 69 67 ..(foreig
21c0: 6e 2d 76 61 6c 75 65 20 22 43 44 5f 53 49 4d 5f n-value "CD_SIM_
21d0: 46 49 4c 4c 53 22 20 69 6e 74 29 29 29 5d 29 0a FILLS" int)))]).
21e0: 09 20 20 28 6c 61 6d 62 64 61 20 28 63 61 6e 76 . (lambda (canv
21f0: 61 73 20 66 6c 61 67 73 2d 69 6e 29 0a 09 20 20 as flags-in)..
2200: 09 28 6c 65 74 20 28 5b 66 6c 61 67 73 2d 6f 75 .(let ([flags-ou
2210: 74 0a 09 20 20 09 20 20 20 20 20 20 20 28 63 61 t.. . (ca
2220: 6e 76 61 73 2d 73 69 6d 75 6c 61 74 65 2f 72 61 nvas-simulate/ra
2230: 77 21 0a 09 20 20 09 20 20 20 20 20 20 20 09 20 w!.. . .
2240: 63 61 6e 76 61 73 0a 09 20 20 09 20 20 20 20 20 canvas.. .
2250: 20 20 09 20 28 66 6f 6c 64 0a 09 20 20 09 20 20 . (fold.. .
2260: 20 20 20 20 20 09 20 09 20 62 69 74 77 69 73 65 . . bitwise
2270: 2d 69 6f 72 20 30 0a 09 20 20 09 20 20 20 20 20 -ior 0.. .
2280: 20 20 09 20 09 20 28 6d 61 70 0a 09 20 20 09 20 . . (map.. .
2290: 20 20 20 20 20 20 09 20 09 20 09 20 28 6c 61 6d . . . (lam
22a0: 62 64 61 20 28 66 6c 61 67 29 0a 09 20 20 09 20 bda (flag).. .
22b0: 20 20 20 20 20 20 09 20 09 20 09 20 09 20 28 63 . . . . (c
22c0: 6f 6e 64 0a 09 20 20 09 20 20 20 20 20 20 20 09 ond.. . .
22d0: 20 09 20 09 20 09 20 09 20 5b 28 61 73 73 71 20 . . . . [(assq
22e0: 66 6c 61 67 20 66 6c 61 67 73 29 20 3d 3e 20 63 flag flags) => c
22f0: 64 72 5d 0a 09 20 20 09 20 20 20 20 20 20 20 09 dr].. . .
2300: 20 09 20 09 20 09 20 09 20 5b 65 6c 73 65 20 28 . . . . [else (
2310: 65 72 72 6f 72 20 27 63 61 6e 76 61 73 2d 73 69 error 'canvas-si
2320: 6d 75 6c 61 74 65 21 20 22 75 6e 6b 6e 6f 77 6e mulate! "unknown
2330: 20 66 6c 61 67 22 20 66 6c 61 67 29 5d 29 29 0a flag" flag)])).
2340: 09 20 20 09 20 20 20 20 20 20 20 09 20 09 20 09 . . . . .
2350: 20 66 6c 61 67 73 2d 69 6e 29 29 29 5d 29 0a 09 flags-in)))])..
2360: 20 20 09 20 20 28 66 69 6c 74 65 72 2d 6d 61 70 . (filter-map
2370: 0a 09 20 20 09 20 20 09 28 6c 61 6d 62 64 61 20 .. . .(lambda
2380: 28 69 6e 66 6f 29 0a 09 20 20 09 20 20 09 09 28 (info).. . ..(
2390: 6c 65 74 20 28 5b 6d 61 73 6b 20 28 63 64 72 20 let ([mask (cdr
23a0: 69 6e 66 6f 29 5d 29 0a 09 09 09 09 09 09 09 28 info)])........(
23b0: 61 6e 64 20 28 3d 20 28 62 69 74 77 69 73 65 2d and (= (bitwise-
23c0: 61 6e 64 20 6d 61 73 6b 20 66 6c 61 67 73 2d 6f and mask flags-o
23d0: 75 74 29 20 6d 61 73 6b 29 20 28 63 61 72 20 69 ut) mask) (car i
23e0: 6e 66 6f 29 29 29 29 0a 09 20 20 09 20 20 09 66 nfo)))).. . .f
23f0: 6c 61 67 73 29 29 29 29 29 0a 0a 28 64 65 66 69 lags)))))..(defi
2400: 6e 65 20 28 6e 61 6d 65 2d 3e 73 74 72 69 6e 67 ne (name->string
2410: 20 6e 61 6d 65 29 0a 09 28 63 6f 6e 64 0a 09 09 name)..(cond...
2420: 5b 28 73 79 6d 62 6f 6c 3f 20 6e 61 6d 65 29 0a [(symbol? name).
2430: 09 09 20 28 73 74 72 69 6e 67 2d 75 70 63 61 73 .. (string-upcas
2440: 65 20 28 73 74 72 69 6e 67 2d 74 72 61 6e 73 6c e (string-transl
2450: 61 74 65 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 ate (symbol->str
2460: 69 6e 67 20 6e 61 6d 65 29 20 23 5c 2d 20 23 5c ing name) #\- #\
2470: 5f 29 29 5d 0a 09 09 5b 65 6c 73 65 0a 09 09 20 _))]...[else...
2480: 6e 61 6d 65 5d 29 29 0a 0a 28 64 65 66 69 6e 65 name]))..(define
2490: 20 63 61 6e 76 61 73 2d 61 74 74 72 69 62 75 74 canvas-attribut
24a0: 65 2d 73 65 74 21 0a 09 28 6c 65 74 72 65 63 20 e-set!..(letrec
24b0: 28 5b 63 61 6e 76 61 73 2d 61 74 74 72 69 62 75 ([canvas-attribu
24c0: 74 65 2d 73 65 74 2f 72 61 77 21 20 28 66 6f 72 te-set/raw! (for
24d0: 65 69 67 6e 2d 6c 61 6d 62 64 61 20 76 6f 69 64 eign-lambda void
24e0: 20 22 63 64 43 61 6e 76 61 73 53 65 74 41 74 74 "cdCanvasSetAtt
24f0: 72 69 62 75 74 65 22 20 6e 6f 6e 6e 75 6c 6c 2d ribute" nonnull-
2500: 63 61 6e 76 61 73 20 6e 6f 6e 6e 75 6c 6c 2d 63 canvas nonnull-c
2510: 2d 73 74 72 69 6e 67 20 63 2d 73 74 72 69 6e 67 -string c-string
2520: 29 5d 29 0a 09 09 28 6c 61 6d 62 64 61 20 28 63 )])...(lambda (c
2530: 61 6e 76 61 73 20 6e 61 6d 65 20 76 61 6c 75 65 anvas name value
2540: 29 0a 09 09 09 28 63 61 6e 76 61 73 2d 61 74 74 )....(canvas-att
2550: 72 69 62 75 74 65 2d 73 65 74 2f 72 61 77 21 20 ribute-set/raw!
2560: 63 61 6e 76 61 73 20 28 6e 61 6d 65 2d 3e 73 74 canvas (name->st
2570: 72 69 6e 67 20 6e 61 6d 65 29 20 76 61 6c 75 65 ring name) value
2580: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 61 ))))..(define ca
2590: 6e 76 61 73 2d 61 74 74 72 69 62 75 74 65 0a 09 nvas-attribute..
25a0: 28 6c 65 74 72 65 63 20 28 5b 63 61 6e 76 61 73 (letrec ([canvas
25b0: 2d 61 74 74 72 69 62 75 74 65 2f 72 61 77 20 28 -attribute/raw (
25c0: 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 63 foreign-lambda c
25d0: 2d 73 74 72 69 6e 67 20 22 63 64 43 61 6e 76 61 -string "cdCanva
25e0: 73 47 65 74 41 74 74 72 69 62 75 74 65 22 20 6e sGetAttribute" n
25f0: 6f 6e 6e 75 6c 6c 2d 63 61 6e 76 61 73 20 6e 6f onnull-canvas no
2600: 6e 6e 75 6c 6c 2d 63 2d 73 74 72 69 6e 67 29 5d nnull-c-string)]
2610: 29 0a 09 09 28 67 65 74 74 65 72 2d 77 69 74 68 )...(getter-with
2620: 2d 73 65 74 74 65 72 0a 09 09 09 28 6c 61 6d 62 -setter....(lamb
2630: 64 61 20 28 63 61 6e 76 61 73 20 6e 61 6d 65 29 da (canvas name)
2640: 0a 09 09 09 09 28 63 61 6e 76 61 73 2d 61 74 74 .....(canvas-att
2650: 72 69 62 75 74 65 2f 72 61 77 20 63 61 6e 76 61 ribute/raw canva
2660: 73 20 28 6e 61 6d 65 2d 3e 73 74 72 69 6e 67 20 s (name->string
2670: 6e 61 6d 65 29 29 29 0a 09 09 09 63 61 6e 76 61 name)))....canva
2680: 73 2d 61 74 74 72 69 62 75 74 65 2d 73 65 74 21 s-attribute-set!
2690: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 61 6e )))..(define can
26a0: 76 61 73 2d 73 74 61 74 65 2d 73 65 74 21 0a 09 vas-state-set!..
26b0: 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 (foreign-lambda
26c0: 76 6f 69 64 20 22 63 64 43 61 6e 76 61 73 52 65 void "cdCanvasRe
26d0: 73 74 6f 72 65 53 74 61 74 65 22 20 6e 6f 6e 6e storeState" nonn
26e0: 75 6c 6c 2d 63 61 6e 76 61 73 20 6e 6f 6e 6e 75 ull-canvas nonnu
26f0: 6c 6c 2d 73 74 61 74 65 29 29 0a 0a 28 64 65 66 ll-state))..(def
2700: 69 6e 65 20 63 61 6e 76 61 73 2d 73 74 61 74 65 ine canvas-state
2710: 0a 09 28 6c 65 74 72 65 63 20 28 5b 73 61 76 65 ..(letrec ([save
2720: 2d 73 74 61 74 65 20 28 66 6f 72 65 69 67 6e 2d -state (foreign-
2730: 6c 61 6d 62 64 61 20 6e 6f 6e 6e 75 6c 6c 2d 73 lambda nonnull-s
2740: 74 61 74 65 20 22 63 64 43 61 6e 76 61 73 53 61 tate "cdCanvasSa
2750: 76 65 53 74 61 74 65 22 20 6e 6f 6e 6e 75 6c 6c veState" nonnull
2760: 2d 63 61 6e 76 61 73 29 5d 0a 09 20 20 20 20 20 -canvas)]..
2770: 20 20 20 20 5b 72 65 6c 65 61 73 65 2d 73 74 61 [release-sta
2780: 74 65 21 20 28 66 6f 72 65 69 67 6e 2d 6c 61 6d te! (foreign-lam
2790: 62 64 61 20 76 6f 69 64 20 22 63 64 52 65 6c 65 bda void "cdRele
27a0: 61 73 65 53 74 61 74 65 22 20 6e 6f 6e 6e 75 6c aseState" nonnul
27b0: 6c 2d 73 74 61 74 65 29 5d 29 0a 09 09 28 67 65 l-state)])...(ge
27c0: 74 74 65 72 2d 77 69 74 68 2d 73 65 74 74 65 72 tter-with-setter
27d0: 0a 09 09 09 28 6c 61 6d 62 64 61 20 28 63 61 6e ....(lambda (can
27e0: 76 61 73 29 0a 09 09 09 09 28 73 65 74 2d 66 69 vas).....(set-fi
27f0: 6e 61 6c 69 7a 65 72 21 20 28 73 61 76 65 2d 73 nalizer! (save-s
2800: 74 61 74 65 20 63 61 6e 76 61 73 29 20 72 65 6c tate canvas) rel
2810: 65 61 73 65 2d 73 74 61 74 65 21 29 29 0a 09 09 ease-state!))...
2820: 09 63 61 6e 76 61 73 2d 73 74 61 74 65 2d 73 65 .canvas-state-se
2830: 74 21 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 t!)))..(define c
2840: 61 6e 76 61 73 2d 63 6c 65 61 72 21 0a 09 28 66 anvas-clear!..(f
2850: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 76 6f oreign-lambda vo
2860: 69 64 20 22 63 64 43 61 6e 76 61 73 43 6c 65 61 id "cdCanvasClea
2870: 72 22 20 6e 6f 6e 6e 75 6c 6c 2d 63 61 6e 76 61 r" nonnull-canva
2880: 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 61 6e s))..(define can
2890: 76 61 73 2d 66 6c 75 73 68 0a 09 28 66 6f 72 65 vas-flush..(fore
28a0: 69 67 6e 2d 6c 61 6d 62 64 61 20 76 6f 69 64 20 ign-lambda void
28b0: 22 63 64 43 61 6e 76 61 73 46 6c 75 73 68 22 20 "cdCanvasFlush"
28c0: 6e 6f 6e 6e 75 6c 6c 2d 63 61 6e 76 61 73 29 29 nonnull-canvas))
28d0: 0a 0a 3b 3b 20 7d 7d 7d 0a 0a 3b 3b 20 7b 7b 7b ..;; }}}..;; {{{
28e0: 20 43 6f 6f 72 64 69 6e 61 74 65 20 73 79 73 74 Coordinate syst
28f0: 65 6d 0a 0a 28 64 65 66 69 6e 65 20 63 61 6e 76 em..(define canv
2900: 61 73 2d 73 69 7a 65 0a 09 28 6c 65 74 72 65 63 as-size..(letrec
2910: 20 28 5b 63 61 6e 76 61 73 2d 73 69 7a 65 2f 72 ([canvas-size/r
2920: 61 77 20 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 aw (foreign-lamb
2930: 64 61 20 76 6f 69 64 20 22 63 64 43 61 6e 76 61 da void "cdCanva
2940: 73 47 65 74 53 69 7a 65 22 20 6e 6f 6e 6e 75 6c sGetSize" nonnul
2950: 6c 2d 63 61 6e 76 61 73 20 28 63 2d 70 6f 69 6e l-canvas (c-poin
2960: 74 65 72 20 69 6e 74 29 20 28 63 2d 70 6f 69 6e ter int) (c-poin
2970: 74 65 72 20 69 6e 74 29 20 28 63 2d 70 6f 69 6e ter int) (c-poin
2980: 74 65 72 20 64 6f 75 62 6c 65 29 20 28 63 2d 70 ter double) (c-p
2990: 6f 69 6e 74 65 72 20 64 6f 75 62 6c 65 29 29 5d ointer double))]
29a0: 29 0a 09 09 28 6c 61 6d 62 64 61 20 28 63 61 6e )...(lambda (can
29b0: 76 61 73 29 0a 09 09 09 28 6c 65 74 2d 6c 6f 63 vas)....(let-loc
29c0: 61 74 69 6f 6e 20 28 5b 77 69 64 74 68 2f 70 78 ation ([width/px
29d0: 20 69 6e 74 20 30 5d 20 5b 68 65 69 67 68 74 2f int 0] [height/
29e0: 70 78 20 69 6e 74 20 30 5d 0a 09 09 09 20 20 20 px int 0]....
29f0: 20 20 20 20 20 20 20 20 20 20 20 20 5b 77 69 64 [wid
2a00: 74 68 2f 6d 6d 20 64 6f 75 62 6c 65 20 30 5d 20 th/mm double 0]
2a10: 5b 68 65 69 67 68 74 2f 6d 6d 20 64 6f 75 62 6c [height/mm doubl
2a20: 65 20 30 5d 29 0a 09 09 09 20 20 28 63 61 6e 76 e 0]).... (canv
2a30: 61 73 2d 73 69 7a 65 2f 72 61 77 0a 09 09 09 20 as-size/raw....
2a40: 20 09 63 61 6e 76 61 73 0a 09 09 09 20 20 09 28 .canvas.... .(
2a50: 6c 6f 63 61 74 69 6f 6e 20 77 69 64 74 68 2f 70 location width/p
2a60: 78 29 20 28 6c 6f 63 61 74 69 6f 6e 20 68 65 69 x) (location hei
2a70: 67 68 74 2f 70 78 29 0a 09 09 09 20 20 09 28 6c ght/px).... .(l
2a80: 6f 63 61 74 69 6f 6e 20 77 69 64 74 68 2f 6d 6d ocation width/mm
2a90: 29 20 28 6c 6f 63 61 74 69 6f 6e 20 68 65 69 67 ) (location heig
2aa0: 68 74 2f 6d 6d 29 29 0a 09 09 09 20 20 28 76 61 ht/mm)).... (va
2ab0: 6c 75 65 73 0a 09 09 09 20 20 09 77 69 64 74 68 lues.... .width
2ac0: 2f 70 78 20 68 65 69 67 68 74 2f 70 78 0a 09 09 /px height/px...
2ad0: 09 20 20 09 77 69 64 74 68 2f 6d 6d 20 68 65 69 . .width/mm hei
2ae0: 67 68 74 2f 6d 6d 29 29 29 29 29 0a 0a 28 64 65 ght/mm)))))..(de
2af0: 66 69 6e 65 20 63 61 6e 76 61 73 2d 6d 6d 2d 3e fine canvas-mm->
2b00: 70 78 0a 09 28 6c 65 74 72 65 63 20 28 5b 63 61 px..(letrec ([ca
2b10: 6e 76 61 73 2d 6d 6d 2d 3e 70 78 2f 72 61 77 20 nvas-mm->px/raw
2b20: 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 (foreign-lambda
2b30: 76 6f 69 64 20 22 63 64 43 61 6e 76 61 73 4d 4d void "cdCanvasMM
2b40: 32 50 69 78 65 6c 22 20 6e 6f 6e 6e 75 6c 6c 2d 2Pixel" nonnull-
2b50: 63 61 6e 76 61 73 20 64 6f 75 62 6c 65 20 64 6f canvas double do
2b60: 75 62 6c 65 20 28 63 2d 70 6f 69 6e 74 65 72 20 uble (c-pointer
2b70: 69 6e 74 29 20 28 63 2d 70 6f 69 6e 74 65 72 20 int) (c-pointer
2b80: 69 6e 74 29 29 5d 29 0a 09 09 28 6c 61 6d 62 64 int))])...(lambd
2b90: 61 20 28 63 61 6e 76 61 73 20 78 2f 6d 6d 20 79 a (canvas x/mm y
2ba0: 2f 6d 6d 29 0a 09 09 09 28 6c 65 74 2d 6c 6f 63 /mm)....(let-loc
2bb0: 61 74 69 6f 6e 20 28 5b 78 2f 70 78 20 69 6e 74 ation ([x/px int
2bc0: 20 30 5d 20 5b 79 2f 70 78 20 69 6e 74 20 30 5d 0] [y/px int 0]
2bd0: 29 0a 09 09 09 09 28 63 61 6e 76 61 73 2d 6d 6d ).....(canvas-mm
2be0: 2d 3e 70 78 2f 72 61 77 20 63 61 6e 76 61 73 20 ->px/raw canvas
2bf0: 78 2f 6d 6d 20 79 2f 6d 6d 20 28 6c 6f 63 61 74 x/mm y/mm (locat
2c00: 69 6f 6e 20 78 2f 70 78 29 20 28 6c 6f 63 61 74 ion x/px) (locat
2c10: 69 6f 6e 20 79 2f 70 78 29 29 0a 09 09 09 09 28 ion y/px)).....(
2c20: 76 61 6c 75 65 73 20 78 2f 70 78 20 79 2f 70 78 values x/px y/px
2c30: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 )))))..(define c
2c40: 61 6e 76 61 73 2d 70 78 2d 3e 6d 6d 0a 09 28 6c anvas-px->mm..(l
2c50: 65 74 72 65 63 20 28 5b 63 61 6e 76 61 73 2d 6d etrec ([canvas-m
2c60: 6d 2d 3e 70 78 2f 72 61 77 20 28 66 6f 72 65 69 m->px/raw (forei
2c70: 67 6e 2d 6c 61 6d 62 64 61 20 76 6f 69 64 20 22 gn-lambda void "
2c80: 63 64 43 61 6e 76 61 73 50 69 78 65 6c 32 4d 4d cdCanvasPixel2MM
2c90: 22 20 6e 6f 6e 6e 75 6c 6c 2d 63 61 6e 76 61 73 " nonnull-canvas
2ca0: 20 69 6e 74 20 69 6e 74 20 28 63 2d 70 6f 69 6e int int (c-poin
2cb0: 74 65 72 20 64 6f 75 62 6c 65 29 20 28 63 2d 70 ter double) (c-p
2cc0: 6f 69 6e 74 65 72 20 64 6f 75 62 6c 65 29 29 5d ointer double))]
2cd0: 29 0a 09 09 28 6c 61 6d 62 64 61 20 28 63 61 6e )...(lambda (can
2ce0: 76 61 73 20 78 2f 70 78 20 79 2f 70 78 29 0a 09 vas x/px y/px)..
2cf0: 09 09 28 6c 65 74 2d 6c 6f 63 61 74 69 6f 6e 20 ..(let-location
2d00: 28 5b 78 2f 6d 6d 20 64 6f 75 62 6c 65 20 2b 6e ([x/mm double +n
2d10: 61 6e 2e 30 5d 20 5b 79 2f 6d 6d 20 64 6f 75 62 an.0] [y/mm doub
2d20: 6c 65 20 2b 6e 61 6e 2e 30 5d 29 0a 09 09 09 09 le +nan.0]).....
2d30: 28 63 61 6e 76 61 73 2d 6d 6d 2d 3e 70 78 2f 72 (canvas-mm->px/r
2d40: 61 77 20 63 61 6e 76 61 73 20 78 2f 70 78 20 79 aw canvas x/px y
2d50: 2f 70 78 20 28 6c 6f 63 61 74 69 6f 6e 20 78 2f /px (location x/
2d60: 6d 6d 29 20 28 6c 6f 63 61 74 69 6f 6e 20 79 2f mm) (location y/
2d70: 6d 6d 29 29 0a 09 09 09 09 28 76 61 6c 75 65 73 mm)).....(values
2d80: 20 78 2f 6d 6d 20 79 2f 6d 6d 29 29 29 29 29 0a x/mm y/mm))))).
2d90: 0a 28 64 65 66 69 6e 65 20 63 61 6e 76 61 73 2d .(define canvas-
2da0: 6f 72 69 67 69 6e 2d 73 65 74 21 0a 09 28 66 6f origin-set!..(fo
2db0: 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 76 6f 69 reign-lambda voi
2dc0: 64 20 22 63 64 43 61 6e 76 61 73 4f 72 69 67 69 d "cdCanvasOrigi
2dd0: 6e 22 20 6e 6f 6e 6e 75 6c 6c 2d 63 61 6e 76 61 n" nonnull-canva
2de0: 73 20 69 6e 74 20 69 6e 74 29 29 0a 0a 28 64 65 s int int))..(de
2df0: 66 69 6e 65 20 63 61 6e 76 61 73 2d 6f 72 69 67 fine canvas-orig
2e00: 69 6e 0a 09 28 6c 65 74 72 65 63 20 28 5b 63 61 in..(letrec ([ca
2e10: 6e 76 61 73 2d 6f 72 69 67 69 6e 2f 72 61 77 20 nvas-origin/raw
2e20: 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 (foreign-lambda
2e30: 76 6f 69 64 20 22 63 64 43 61 6e 76 61 73 47 65 void "cdCanvasGe
2e40: 74 4f 72 69 67 69 6e 22 20 6e 6f 6e 6e 75 6c 6c tOrigin" nonnull
2e50: 2d 63 61 6e 76 61 73 20 28 63 2d 70 6f 69 6e 74 -canvas (c-point
2e60: 65 72 20 69 6e 74 29 20 28 63 2d 70 6f 69 6e 74 er int) (c-point
2e70: 65 72 20 69 6e 74 29 29 5d 29 0a 09 09 28 6c 61 er int))])...(la
2e80: 6d 62 64 61 20 28 63 61 6e 76 61 73 29 0a 09 09 mbda (canvas)...
2e90: 09 28 6c 65 74 2d 6c 6f 63 61 74 69 6f 6e 20 28 .(let-location (
2ea0: 5b 78 20 69 6e 74 20 30 5d 20 5b 79 20 69 6e 74 [x int 0] [y int
2eb0: 20 30 5d 29 0a 09 09 09 09 28 63 61 6e 76 61 73 0]).....(canvas
2ec0: 2d 6f 72 69 67 69 6e 2f 72 61 77 20 63 61 6e 76 -origin/raw canv
2ed0: 61 73 20 28 6c 6f 63 61 74 69 6f 6e 20 78 29 20 as (location x)
2ee0: 28 6c 6f 63 61 74 69 6f 6e 20 79 29 29 0a 09 09 (location y))...
2ef0: 09 09 28 76 61 6c 75 65 73 20 78 20 79 29 29 29 ..(values x y)))
2f00: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 72 61 ))..(define (tra
2f10: 6e 73 66 6f 72 6d 2d 3e 66 36 34 76 65 63 74 6f nsform->f64vecto
2f20: 72 20 70 72 6f 63 29 0a 09 28 6c 65 74 20 28 5b r proc)..(let ([
2f30: 76 20 28 6d 61 6b 65 2d 66 36 34 76 65 63 74 6f v (make-f64vecto
2f40: 72 20 36 29 5d 29 0a 09 09 28 6c 65 74 2d 76 61 r 6)])...(let-va
2f50: 6c 75 65 73 20 28 5b 28 64 78 20 64 79 29 20 28 lues ([(dx dy) (
2f60: 70 72 6f 63 20 30 20 30 29 5d 29 0a 09 09 09 28 proc 0 0)])....(
2f70: 66 36 34 76 65 63 74 6f 72 2d 73 65 74 21 20 76 f64vector-set! v
2f80: 20 34 20 64 78 29 0a 09 09 09 28 66 36 34 76 65 4 dx)....(f64ve
2f90: 63 74 6f 72 2d 73 65 74 21 20 76 20 35 20 64 79 ctor-set! v 5 dy
2fa0: 29 0a 09 09 09 28 6c 65 74 2d 76 61 6c 75 65 73 )....(let-values
2fb0: 20 28 5b 28 78 20 79 29 20 28 70 72 6f 63 20 31 ([(x y) (proc 1
2fc0: 20 30 29 5d 29 0a 09 09 09 09 28 66 36 34 76 65 0)]).....(f64ve
2fd0: 63 74 6f 72 2d 73 65 74 21 20 76 20 30 20 28 2d ctor-set! v 0 (-
2fe0: 20 78 20 64 78 29 29 0a 09 09 09 09 28 66 36 34 x dx)).....(f64
2ff0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 20 31 20 vector-set! v 1
3000: 28 2d 20 79 20 64 79 29 29 29 0a 09 09 09 28 6c (- y dy)))....(l
3010: 65 74 2d 76 61 6c 75 65 73 20 28 5b 28 78 20 79 et-values ([(x y
3020: 29 20 28 70 72 6f 63 20 30 20 31 29 5d 29 0a 09 ) (proc 0 1)])..
3030: 09 09 09 28 66 36 34 76 65 63 74 6f 72 2d 73 65 ...(f64vector-se
3040: 74 21 20 76 20 32 20 28 2d 20 78 20 64 78 29 29 t! v 2 (- x dx))
3050: 0a 09 09 09 09 28 66 36 34 76 65 63 74 6f 72 2d .....(f64vector-
3060: 73 65 74 21 20 76 20 33 20 28 2d 20 79 20 64 79 set! v 3 (- y dy
3070: 29 29 29 29 0a 09 09 76 29 29 0a 0a 28 64 65 66 ))))...v))..(def
3080: 69 6e 65 20 28 28 66 36 34 76 65 63 74 6f 72 2d ine ((f64vector-
3090: 3e 74 72 61 6e 73 66 6f 72 6d 20 76 29 20 78 20 >transform v) x
30a0: 79 29 0a 09 28 76 61 6c 75 65 73 0a 09 09 28 2b y)..(values...(+
30b0: 20 28 2a 20 28 66 36 34 76 65 63 74 6f 72 2d 72 (* (f64vector-r
30c0: 65 66 20 76 20 30 29 20 78 29 20 28 2a 20 28 66 ef v 0) x) (* (f
30d0: 36 34 76 65 63 74 6f 72 2d 72 65 66 20 76 20 32 64vector-ref v 2
30e0: 29 20 79 29 20 28 66 36 34 76 65 63 74 6f 72 2d ) y) (f64vector-
30f0: 72 65 66 20 76 20 34 29 29 0a 09 09 28 2b 20 28 ref v 4))...(+ (
3100: 2a 20 28 66 36 34 76 65 63 74 6f 72 2d 72 65 66 * (f64vector-ref
3110: 20 76 20 31 29 20 78 29 20 28 2a 20 28 66 36 34 v 1) x) (* (f64
3120: 76 65 63 74 6f 72 2d 72 65 66 20 76 20 33 29 20 vector-ref v 3)
3130: 79 29 20 28 66 36 34 76 65 63 74 6f 72 2d 72 65 y) (f64vector-re
3140: 66 20 76 20 35 29 29 29 29 0a 0a 28 64 65 66 69 f v 5))))..(defi
3150: 6e 65 20 63 61 6e 76 61 73 2d 74 72 61 6e 73 66 ne canvas-transf
3160: 6f 72 6d 2d 73 65 74 21 0a 09 28 6c 65 74 72 65 orm-set!..(letre
3170: 63 20 28 5b 63 61 6e 76 61 73 2d 74 72 61 6e 73 c ([canvas-trans
3180: 66 6f 72 6d 2d 73 65 74 2f 72 61 77 21 20 28 66 form-set/raw! (f
3190: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 76 6f oreign-lambda vo
31a0: 69 64 20 22 63 64 43 61 6e 76 61 73 54 72 61 6e id "cdCanvasTran
31b0: 73 66 6f 72 6d 22 20 6e 6f 6e 6e 75 6c 6c 2d 63 sform" nonnull-c
31c0: 61 6e 76 61 73 20 66 36 34 76 65 63 74 6f 72 29 anvas f64vector)
31d0: 5d 29 0a 09 09 28 6c 61 6d 62 64 61 20 28 63 61 ])...(lambda (ca
31e0: 6e 76 61 73 20 70 72 6f 63 29 0a 09 09 09 28 63 nvas proc)....(c
31f0: 61 6e 76 61 73 2d 74 72 61 6e 73 66 6f 72 6d 2d anvas-transform-
3200: 73 65 74 2f 72 61 77 21 20 63 61 6e 76 61 73 20 set/raw! canvas
3210: 28 61 6e 64 20 70 72 6f 63 20 28 74 72 61 6e 73 (and proc (trans
3220: 66 6f 72 6d 2d 3e 66 36 34 76 65 63 74 6f 72 20 form->f64vector
3230: 70 72 6f 63 29 29 29 29 29 29 0a 0a 28 64 65 66 proc))))))..(def
3240: 69 6e 65 20 63 61 6e 76 61 73 2d 74 72 61 6e 73 ine canvas-trans
3250: 66 6f 72 6d 0a 09 28 6c 65 74 72 65 63 20 28 5b form..(letrec ([
3260: 63 61 6e 76 61 73 2d 74 72 61 6e 73 66 6f 72 6d canvas-transform
3270: 2f 72 61 77 0a 09 20 20 20 20 20 20 20 20 20 20 /raw..
3280: 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 2a (foreign-lambda*
3290: 20 62 6f 6f 6c 20 28 5b 6e 6f 6e 6e 75 6c 6c 2d bool ([nonnull-
32a0: 63 61 6e 76 61 73 20 63 61 6e 76 61 73 5d 20 5b canvas canvas] [
32b0: 6e 6f 6e 6e 75 6c 6c 2d 66 36 34 76 65 63 74 6f nonnull-f64vecto
32c0: 72 20 76 5d 29 0a 09 20 20 20 20 20 20 20 20 20 r v])..
32d0: 20 09 22 64 6f 75 62 6c 65 20 2a 77 20 3d 20 63 ."double *w = c
32e0: 64 43 61 6e 76 61 73 47 65 74 54 72 61 6e 73 66 dCanvasGetTransf
32f0: 6f 72 6d 28 63 61 6e 76 61 73 29 3b 5c 6e 22 0a orm(canvas);\n".
3300: 09 20 20 20 20 20 20 20 20 20 20 09 22 69 66 20 . ."if
3310: 28 77 29 20 6d 65 6d 63 70 79 28 76 2c 20 77 2c (w) memcpy(v, w,
3320: 20 36 20 2a 20 73 69 7a 65 6f 66 28 64 6f 75 62 6 * sizeof(doub
3330: 6c 65 29 29 3b 5c 6e 22 0a 09 20 20 20 20 20 20 le));\n"..
3340: 20 20 20 20 09 22 43 5f 72 65 74 75 72 6e 28 77 ."C_return(w
3350: 29 3b 22 29 5d 29 0a 09 09 28 67 65 74 74 65 72 );")])...(getter
3360: 2d 77 69 74 68 2d 73 65 74 74 65 72 0a 09 09 09 -with-setter....
3370: 28 6c 61 6d 62 64 61 20 28 63 61 6e 76 61 73 29 (lambda (canvas)
3380: 0a 09 09 09 09 28 6c 65 74 20 28 5b 76 20 28 6d .....(let ([v (m
3390: 61 6b 65 2d 66 36 34 76 65 63 74 6f 72 20 36 29 ake-f64vector 6)
33a0: 5d 29 0a 09 09 09 09 09 28 61 6e 64 20 28 63 61 ])......(and (ca
33b0: 6e 76 61 73 2d 74 72 61 6e 73 66 6f 72 6d 2f 72 nvas-transform/r
33c0: 61 77 20 63 61 6e 76 61 73 20 76 29 20 28 66 36 aw canvas v) (f6
33d0: 34 76 65 63 74 6f 72 2d 3e 74 72 61 6e 73 66 6f 4vector->transfo
33e0: 72 6d 20 76 29 29 29 29 0a 09 09 09 63 61 6e 76 rm v))))....canv
33f0: 61 73 2d 74 72 61 6e 73 66 6f 72 6d 2d 73 65 74 as-transform-set
3400: 21 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 61 !)))..(define ca
3410: 6e 76 61 73 2d 74 72 61 6e 73 66 6f 72 6d 2d 63 nvas-transform-c
3420: 6f 6d 70 6f 73 65 21 0a 09 28 6c 65 74 72 65 63 ompose!..(letrec
3430: 20 28 5b 63 61 6e 76 61 73 2d 74 72 61 6e 73 66 ([canvas-transf
3440: 6f 72 6d 2d 63 6f 6d 70 6f 73 65 2f 72 61 77 21 orm-compose/raw!
3450: 20 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 (foreign-lambda
3460: 20 76 6f 69 64 20 22 63 64 43 61 6e 76 61 73 54 void "cdCanvasT
3470: 72 61 6e 73 66 6f 72 6d 4d 75 6c 74 69 70 6c 79 ransformMultiply
3480: 22 20 6e 6f 6e 6e 75 6c 6c 2d 63 61 6e 76 61 73 " nonnull-canvas
3490: 20 6e 6f 6e 6e 75 6c 6c 2d 66 36 34 76 65 63 74 nonnull-f64vect
34a0: 6f 72 29 5d 29 0a 09 09 28 6c 61 6d 62 64 61 20 or)])...(lambda
34b0: 28 63 61 6e 76 61 73 20 70 72 6f 63 29 0a 09 09 (canvas proc)...
34c0: 09 28 63 61 6e 76 61 73 2d 74 72 61 6e 73 66 6f .(canvas-transfo
34d0: 72 6d 2d 63 6f 6d 70 6f 73 65 2f 72 61 77 21 20 rm-compose/raw!
34e0: 63 61 6e 76 61 73 20 28 74 72 61 6e 73 66 6f 72 canvas (transfor
34f0: 6d 2d 3e 66 36 34 76 65 63 74 6f 72 20 70 72 6f m->f64vector pro
3500: 63 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 c)))))..(define
3510: 63 61 6e 76 61 73 2d 74 72 61 6e 73 66 6f 72 6d canvas-transform
3520: 2d 74 72 61 6e 73 6c 61 74 65 21 0a 09 28 66 6f -translate!..(fo
3530: 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 76 6f 69 reign-lambda voi
3540: 64 20 22 63 64 43 61 6e 76 61 73 54 72 61 6e 73 d "cdCanvasTrans
3550: 66 6f 72 6d 54 72 61 6e 73 6c 61 74 65 22 20 6e formTranslate" n
3560: 6f 6e 6e 75 6c 6c 2d 63 61 6e 76 61 73 20 64 6f onnull-canvas do
3570: 75 62 6c 65 20 64 6f 75 62 6c 65 29 29 0a 0a 28 uble double))..(
3580: 64 65 66 69 6e 65 20 63 61 6e 76 61 73 2d 74 72 define canvas-tr
3590: 61 6e 73 66 6f 72 6d 2d 73 63 61 6c 65 21 0a 09 ansform-scale!..
35a0: 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 (foreign-lambda
35b0: 76 6f 69 64 20 22 63 64 43 61 6e 76 61 73 54 72 void "cdCanvasTr
35c0: 61 6e 73 66 6f 72 6d 53 63 61 6c 65 22 20 6e 6f ansformScale" no
35d0: 6e 6e 75 6c 6c 2d 63 61 6e 76 61 73 20 64 6f 75 nnull-canvas dou
35e0: 62 6c 65 20 64 6f 75 62 6c 65 29 29 0a 0a 28 64 ble double))..(d
35f0: 65 66 69 6e 65 20 63 61 6e 76 61 73 2d 74 72 61 efine canvas-tra
3600: 6e 73 66 6f 72 6d 2d 72 6f 74 61 74 65 21 0a 09 nsform-rotate!..
3610: 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 (foreign-lambda
3620: 76 6f 69 64 20 22 63 64 43 61 6e 76 61 73 54 72 void "cdCanvasTr
3630: 61 6e 73 66 6f 72 6d 52 6f 74 61 74 65 22 20 6e ansformRotate" n
3640: 6f 6e 6e 75 6c 6c 2d 63 61 6e 76 61 73 20 64 6f onnull-canvas do
3650: 75 62 6c 65 29 29 0a 0a 3b 3b 20 7d 7d 7d 0a 0a uble))..;; }}}..
3660: 3b 3b 20 7b 7b 7b 20 47 65 6e 65 72 61 6c 20 61 ;; {{{ General a
3670: 74 74 72 69 62 75 74 65 73 0a 0a 28 64 65 66 69 ttributes..(defi
3680: 6e 65 20 63 61 6e 76 61 73 2d 66 6f 72 65 67 72 ne canvas-foregr
3690: 6f 75 6e 64 2d 73 65 74 21 0a 09 28 66 6f 72 65 ound-set!..(fore
36a0: 69 67 6e 2d 6c 61 6d 62 64 61 20 76 6f 69 64 20 ign-lambda void
36b0: 22 63 64 43 61 6e 76 61 73 53 65 74 46 6f 72 65 "cdCanvasSetFore
36c0: 67 72 6f 75 6e 64 22 20 6e 6f 6e 6e 75 6c 6c 2d ground" nonnull-
36d0: 63 61 6e 76 61 73 20 75 6e 73 69 67 6e 65 64 2d canvas unsigned-
36e0: 6c 6f 6e 67 29 29 0a 0a 28 64 65 66 69 6e 65 20 long))..(define
36f0: 63 61 6e 76 61 73 2d 66 6f 72 65 67 72 6f 75 6e canvas-foregroun
3700: 64 0a 09 28 67 65 74 74 65 72 2d 77 69 74 68 2d d..(getter-with-
3710: 73 65 74 74 65 72 0a 09 09 28 66 6f 72 65 69 67 setter...(foreig
3720: 6e 2d 6c 61 6d 62 64 61 2a 20 75 6e 73 69 67 6e n-lambda* unsign
3730: 65 64 2d 6c 6f 6e 67 20 28 5b 6e 6f 6e 6e 75 6c ed-long ([nonnul
3740: 6c 2d 63 61 6e 76 61 73 20 63 61 6e 76 61 73 5d l-canvas canvas]
3750: 29 0a 09 09 09 22 43 5f 72 65 74 75 72 6e 28 63 )...."C_return(c
3760: 64 43 61 6e 76 61 73 46 6f 72 65 67 72 6f 75 6e dCanvasForegroun
3770: 64 28 63 61 6e 76 61 73 2c 20 43 44 5f 51 55 45 d(canvas, CD_QUE
3780: 52 59 29 29 3b 22 29 0a 09 09 63 61 6e 76 61 73 RY));")...canvas
3790: 2d 66 6f 72 65 67 72 6f 75 6e 64 2d 73 65 74 21 -foreground-set!
37a0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 61 6e 76 ))..(define canv
37b0: 61 73 2d 62 61 63 6b 67 72 6f 75 6e 64 2d 73 65 as-background-se
37c0: 74 21 0a 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d t!..(foreign-lam
37d0: 62 64 61 20 76 6f 69 64 20 22 63 64 43 61 6e 76 bda void "cdCanv
37e0: 61 73 53 65 74 42 61 63 6b 67 72 6f 75 6e 64 22 asSetBackground"
37f0: 20 6e 6f 6e 6e 75 6c 6c 2d 63 61 6e 76 61 73 20 nonnull-canvas
3800: 75 6e 73 69 67 6e 65 64 2d 6c 6f 6e 67 29 29 0a unsigned-long)).
3810: 0a 28 64 65 66 69 6e 65 20 63 61 6e 76 61 73 2d .(define canvas-
3820: 62 61 63 6b 67 72 6f 75 6e 64 0a 09 28 67 65 74 background..(get
3830: 74 65 72 2d 77 69 74 68 2d 73 65 74 74 65 72 0a ter-with-setter.
3840: 09 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 ..(foreign-lambd
3850: 61 2a 20 75 6e 73 69 67 6e 65 64 2d 6c 6f 6e 67 a* unsigned-long
3860: 20 28 5b 6e 6f 6e 6e 75 6c 6c 2d 63 61 6e 76 61 ([nonnull-canva
3870: 73 20 63 61 6e 76 61 73 5d 29 0a 09 09 09 22 43 s canvas])...."C
3880: 5f 72 65 74 75 72 6e 28 63 64 43 61 6e 76 61 73 _return(cdCanvas
3890: 42 61 63 6b 67 72 6f 75 6e 64 28 63 61 6e 76 61 Background(canva
38a0: 73 2c 20 43 44 5f 51 55 45 52 59 29 29 3b 22 29 s, CD_QUERY));")
38b0: 0a 09 09 63 61 6e 76 61 73 2d 62 61 63 6b 67 72 ...canvas-backgr
38c0: 6f 75 6e 64 2d 73 65 74 21 29 29 0a 0a 28 64 65 ound-set!))..(de
38d0: 66 69 6e 65 2d 76 61 6c 75 65 73 20 28 63 61 6e fine-values (can
38e0: 76 61 73 2d 77 72 69 74 65 2d 6d 6f 64 65 20 63 vas-write-mode c
38f0: 61 6e 76 61 73 2d 77 72 69 74 65 2d 6d 6f 64 65 anvas-write-mode
3900: 2d 73 65 74 21 29 0a 09 28 6c 65 74 72 65 63 20 -set!)..(letrec
3910: 28 5b 77 72 69 74 65 2d 6d 6f 64 65 73 0a 09 20 ([write-modes..
3920: 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 0a 09 (list..
3930: 20 20 20 20 20 20 20 20 20 20 09 28 63 6f 6e 73 .(cons
3940: 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 27 72 .. ..'r
3950: 65 70 6c 61 63 65 0a 09 20 20 20 20 20 20 20 20 eplace..
3960: 20 20 09 09 28 66 6f 72 65 69 67 6e 2d 76 61 6c ..(foreign-val
3970: 75 65 20 22 43 44 5f 52 45 50 4c 41 43 45 22 20 ue "CD_REPLACE"
3980: 69 6e 74 29 29 0a 09 20 20 20 20 20 20 20 20 20 int))..
3990: 20 09 28 63 6f 6e 73 0a 09 20 20 20 20 20 20 20 .(cons..
39a0: 20 20 20 09 09 27 78 6f 72 0a 09 20 20 20 20 20 ..'xor..
39b0: 20 20 20 20 20 09 09 28 66 6f 72 65 69 67 6e 2d ..(foreign-
39c0: 76 61 6c 75 65 20 22 43 44 5f 58 4f 52 22 20 69 value "CD_XOR" i
39d0: 6e 74 29 29 0a 09 20 20 20 20 20 20 20 20 20 20 nt))..
39e0: 09 28 63 6f 6e 73 0a 09 20 20 20 20 20 20 20 20 .(cons..
39f0: 20 20 09 09 27 6e 6f 74 2d 78 6f 72 0a 09 20 20 ..'not-xor..
3a00: 20 20 20 20 20 20 20 20 09 09 28 66 6f 72 65 69 ..(forei
3a10: 67 6e 2d 76 61 6c 75 65 20 22 43 44 5f 4e 4f 54 gn-value "CD_NOT
3a20: 5f 58 4f 52 22 20 69 6e 74 29 29 29 5d 0a 09 20 _XOR" int)))]..
3a30: 20 20 20 20 20 20 20 20 5b 63 61 6e 76 61 73 2d [canvas-
3a40: 77 72 69 74 65 2d 6d 6f 64 65 2d 73 65 74 2f 72 write-mode-set/r
3a50: 61 77 21 0a 09 20 20 20 20 20 20 20 20 20 20 28 aw!.. (
3a60: 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 76 foreign-lambda v
3a70: 6f 69 64 20 22 63 64 43 61 6e 76 61 73 57 72 69 oid "cdCanvasWri
3a80: 74 65 4d 6f 64 65 22 20 6e 6f 6e 6e 75 6c 6c 2d teMode" nonnull-
3a90: 63 61 6e 76 61 73 20 69 6e 74 29 5d 0a 09 20 20 canvas int)]..
3aa0: 20 20 20 20 20 20 20 5b 63 61 6e 76 61 73 2d 77 [canvas-w
3ab0: 72 69 74 65 2d 6d 6f 64 65 2d 73 65 74 21 0a 09 rite-mode-set!..
3ac0: 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 (lambd
3ad0: 61 20 28 63 61 6e 76 61 73 20 77 72 69 74 65 2d a (canvas write-
3ae0: 6d 6f 64 65 29 0a 09 20 20 20 20 20 20 20 20 20 mode)..
3af0: 20 09 28 63 61 6e 76 61 73 2d 77 72 69 74 65 2d .(canvas-write-
3b00: 6d 6f 64 65 2d 73 65 74 2f 72 61 77 21 0a 09 20 mode-set/raw!..
3b10: 20 20 20 20 20 20 20 20 20 09 09 63 61 6e 76 61 ..canva
3b20: 73 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 28 s.. ..(
3b30: 63 6f 6e 64 0a 09 20 20 20 20 20 20 20 20 20 20 cond..
3b40: 09 09 09 5b 28 61 73 73 71 20 77 72 69 74 65 2d ...[(assq write-
3b50: 6d 6f 64 65 20 77 72 69 74 65 2d 6d 6f 64 65 73 mode write-modes
3b60: 29 20 3d 3e 20 63 64 72 5d 0a 09 20 20 20 20 20 ) => cdr]..
3b70: 20 20 20 20 20 09 09 09 5b 65 6c 73 65 20 28 65 ...[else (e
3b80: 72 72 6f 72 20 27 63 61 6e 76 61 73 2d 77 72 69 rror 'canvas-wri
3b90: 74 65 2d 6d 6f 64 65 2d 73 65 74 21 20 22 75 6e te-mode-set! "un
3ba0: 6b 6e 6f 77 6e 20 77 72 69 74 65 20 6d 6f 64 65 known write mode
3bb0: 22 20 77 72 69 74 65 2d 6d 6f 64 65 29 5d 29 29 " write-mode)]))
3bc0: 29 5d 0a 09 20 20 20 20 20 20 20 20 20 5b 63 61 )].. [ca
3bd0: 6e 76 61 73 2d 77 72 69 74 65 2d 6d 6f 64 65 2f nvas-write-mode/
3be0: 72 61 77 0a 09 20 20 20 20 20 20 20 20 20 20 28 raw.. (
3bf0: 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 foreign-lambda*
3c00: 69 6e 74 20 28 5b 6e 6f 6e 6e 75 6c 6c 2d 63 61 int ([nonnull-ca
3c10: 6e 76 61 73 20 63 61 6e 76 61 73 5d 29 0a 09 20 nvas canvas])..
3c20: 20 20 20 20 20 20 20 20 20 09 22 43 5f 72 65 74 ."C_ret
3c30: 75 72 6e 28 63 64 43 61 6e 76 61 73 57 72 69 74 urn(cdCanvasWrit
3c40: 65 4d 6f 64 65 28 63 61 6e 76 61 73 2c 20 43 44 eMode(canvas, CD
3c50: 5f 51 55 45 52 59 29 29 3b 22 29 5d 0a 09 20 20 _QUERY));")]..
3c60: 20 20 20 20 20 20 20 5b 63 61 6e 76 61 73 2d 77 [canvas-w
3c70: 72 69 74 65 2d 6d 6f 64 65 0a 09 20 20 20 20 20 rite-mode..
3c80: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 63 61 (lambda (ca
3c90: 6e 76 61 73 29 0a 09 20 20 20 20 20 20 20 20 20 nvas)..
3ca0: 20 09 28 6c 65 74 20 28 5b 77 72 69 74 65 2d 6d .(let ([write-m
3cb0: 6f 64 65 20 28 63 61 6e 76 61 73 2d 77 72 69 74 ode (canvas-writ
3cc0: 65 2d 6d 6f 64 65 2f 72 61 77 20 63 61 6e 76 61 e-mode/raw canva
3cd0: 73 29 5d 29 0a 09 20 20 20 20 20 20 20 20 20 20 s)])..
3ce0: 09 09 28 63 6f 6e 64 0a 09 20 20 20 20 20 20 20 ..(cond..
3cf0: 20 20 20 09 09 09 5b 28 72 61 73 73 6f 63 20 77 ...[(rassoc w
3d00: 72 69 74 65 2d 6d 6f 64 65 20 77 72 69 74 65 2d rite-mode write-
3d10: 6d 6f 64 65 73 29 20 3d 3e 20 63 61 72 5d 0a 09 modes) => car]..
3d20: 20 20 20 20 20 20 20 20 20 20 09 09 09 5b 65 6c ...[el
3d30: 73 65 20 28 65 72 72 6f 72 20 27 63 61 6e 76 61 se (error 'canva
3d40: 73 2d 77 72 69 74 65 2d 6d 6f 64 65 20 22 75 6e s-write-mode "un
3d50: 6b 6e 6f 77 6e 20 77 72 69 74 65 20 6d 6f 64 65 known write mode
3d60: 22 20 77 72 69 74 65 2d 6d 6f 64 65 29 5d 29 29 " write-mode)]))
3d70: 29 5d 29 0a 09 20 20 28 76 61 6c 75 65 73 0a 09 )]).. (values..
3d80: 20 20 09 28 67 65 74 74 65 72 2d 77 69 74 68 2d .(getter-with-
3d90: 73 65 74 74 65 72 20 63 61 6e 76 61 73 2d 77 72 setter canvas-wr
3da0: 69 74 65 2d 6d 6f 64 65 20 63 61 6e 76 61 73 2d ite-mode canvas-
3db0: 77 72 69 74 65 2d 6d 6f 64 65 2d 73 65 74 21 29 write-mode-set!)
3dc0: 0a 09 20 20 09 63 61 6e 76 61 73 2d 77 72 69 74 .. .canvas-writ
3dd0: 65 2d 6d 6f 64 65 2d 73 65 74 21 29 29 29 0a 0a e-mode-set!)))..
3de0: 3b 3b 20 7d 7d 7d 0a 0a 3b 3b 20 7b 7b 7b 20 43 ;; }}}..;; {{{ C
3df0: 6c 69 70 70 69 6e 67 0a 0a 28 64 65 66 69 6e 65 lipping..(define
3e00: 2d 76 61 6c 75 65 73 20 28 63 61 6e 76 61 73 2d -values (canvas-
3e10: 63 6c 69 70 2d 6d 6f 64 65 20 63 61 6e 76 61 73 clip-mode canvas
3e20: 2d 63 6c 69 70 2d 6d 6f 64 65 2d 73 65 74 21 29 -clip-mode-set!)
3e30: 0a 09 28 6c 65 74 72 65 63 20 28 5b 63 6c 69 70 ..(letrec ([clip
3e40: 2d 6d 6f 64 65 73 0a 09 20 20 20 20 20 20 20 20 -modes..
3e50: 20 20 28 6c 69 73 74 0a 09 20 20 20 20 20 20 20 (list..
3e60: 20 20 20 09 28 63 6f 6e 73 0a 09 20 20 20 20 20 .(cons..
3e70: 20 20 20 20 20 09 09 27 61 72 65 61 0a 09 20 20 ..'area..
3e80: 20 20 20 20 20 20 20 20 09 09 28 66 6f 72 65 69 ..(forei
3e90: 67 6e 2d 76 61 6c 75 65 20 22 43 44 5f 43 4c 49 gn-value "CD_CLI
3ea0: 50 41 52 45 41 22 20 69 6e 74 29 29 0a 09 20 20 PAREA" int))..
3eb0: 20 20 20 20 20 20 20 20 09 28 63 6f 6e 73 0a 09 .(cons..
3ec0: 20 20 20 20 20 20 20 20 20 20 09 09 27 70 6f 6c ..'pol
3ed0: 79 67 6f 6e 0a 09 20 20 20 20 20 20 20 20 20 20 ygon..
3ee0: 09 09 28 66 6f 72 65 69 67 6e 2d 76 61 6c 75 65 ..(foreign-value
3ef0: 20 22 43 44 5f 43 4c 49 50 50 4f 4c 59 47 4f 4e "CD_CLIPPOLYGON
3f00: 22 20 69 6e 74 29 29 0a 09 20 20 20 20 20 20 20 " int))..
3f10: 20 20 20 09 28 63 6f 6e 73 0a 09 20 20 20 20 20 .(cons..
3f20: 20 20 20 20 20 09 09 27 72 65 67 69 6f 6e 0a 09 ..'region..
3f30: 20 20 20 20 20 20 20 20 20 20 09 09 28 66 6f 72 ..(for
3f40: 65 69 67 6e 2d 76 61 6c 75 65 20 22 43 44 5f 43 eign-value "CD_C
3f50: 4c 49 50 52 45 47 49 4f 4e 22 20 69 6e 74 29 29 LIPREGION" int))
3f60: 0a 09 20 20 20 20 20 20 20 20 20 20 09 28 63 6f .. .(co
3f70: 6e 73 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 ns.. ..
3f80: 23 66 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 #f.. ..
3f90: 28 66 6f 72 65 69 67 6e 2d 76 61 6c 75 65 20 22 (foreign-value "
3fa0: 43 44 5f 43 4c 49 50 4f 46 46 22 20 69 6e 74 29 CD_CLIPOFF" int)
3fb0: 29 29 5d 0a 09 20 20 20 20 20 20 20 20 20 5b 63 ))].. [c
3fc0: 61 6e 76 61 73 2d 63 6c 69 70 2d 6d 6f 64 65 2d anvas-clip-mode-
3fd0: 73 65 74 2f 72 61 77 21 0a 09 20 20 20 20 20 20 set/raw!..
3fe0: 20 20 20 20 28 66 6f 72 65 69 67 6e 2d 6c 61 6d (foreign-lam
3ff0: 62 64 61 20 76 6f 69 64 20 22 63 64 43 61 6e 76 bda void "cdCanv
4000: 61 73 43 6c 69 70 22 20 6e 6f 6e 6e 75 6c 6c 2d asClip" nonnull-
4010: 63 61 6e 76 61 73 20 69 6e 74 29 5d 0a 09 20 20 canvas int)]..
4020: 20 20 20 20 20 20 20 5b 63 61 6e 76 61 73 2d 63 [canvas-c
4030: 6c 69 70 2d 6d 6f 64 65 2d 73 65 74 21 0a 09 20 lip-mode-set!..
4040: 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 (lambda
4050: 20 28 63 61 6e 76 61 73 20 63 6c 69 70 2d 6d 6f (canvas clip-mo
4060: 64 65 29 0a 09 20 20 20 20 20 20 20 20 20 20 09 de).. .
4070: 28 63 61 6e 76 61 73 2d 63 6c 69 70 2d 6d 6f 64 (canvas-clip-mod
4080: 65 2d 73 65 74 2f 72 61 77 21 0a 09 20 20 20 20 e-set/raw!..
4090: 20 20 20 20 20 20 09 09 63 61 6e 76 61 73 0a 09 ..canvas..
40a0: 20 20 20 20 20 20 20 20 20 20 09 09 28 63 6f 6e ..(con
40b0: 64 0a 09 20 20 20 20 20 20 20 20 20 20 09 09 09 d.. ...
40c0: 5b 28 61 73 73 71 20 63 6c 69 70 2d 6d 6f 64 65 [(assq clip-mode
40d0: 20 63 6c 69 70 2d 6d 6f 64 65 73 29 20 3d 3e 20 clip-modes) =>
40e0: 63 64 72 5d 0a 09 20 20 20 20 20 20 20 20 20 20 cdr]..
40f0: 09 09 09 5b 65 6c 73 65 20 28 65 72 72 6f 72 20 ...[else (error
4100: 27 63 61 6e 76 61 73 2d 63 6c 69 70 2d 6d 6f 64 'canvas-clip-mod
4110: 65 2d 73 65 74 21 20 22 75 6e 6b 6e 6f 77 6e 20 e-set! "unknown
4120: 63 6c 69 70 20 6d 6f 64 65 22 20 63 6c 69 70 2d clip mode" clip-
4130: 6d 6f 64 65 29 5d 29 29 29 5d 0a 09 20 20 20 20 mode)])))]..
4140: 20 20 20 20 20 5b 63 61 6e 76 61 73 2d 63 6c 69 [canvas-cli
4150: 70 2d 6d 6f 64 65 2f 72 61 77 0a 09 20 20 20 20 p-mode/raw..
4160: 20 20 20 20 20 20 28 66 6f 72 65 69 67 6e 2d 6c (foreign-l
4170: 61 6d 62 64 61 2a 20 69 6e 74 20 28 5b 6e 6f 6e ambda* int ([non
4180: 6e 75 6c 6c 2d 63 61 6e 76 61 73 20 63 61 6e 76 null-canvas canv
4190: 61 73 5d 29 0a 09 20 20 20 20 20 20 20 20 20 20 as])..
41a0: 09 22 43 5f 72 65 74 75 72 6e 28 63 64 43 61 6e ."C_return(cdCan
41b0: 76 61 73 43 6c 69 70 28 63 61 6e 76 61 73 2c 20 vasClip(canvas,
41c0: 43 44 5f 51 55 45 52 59 29 29 3b 22 29 5d 0a 09 CD_QUERY));")]..
41d0: 20 20 20 20 20 20 20 20 20 5b 63 61 6e 76 61 73 [canvas
41e0: 2d 63 6c 69 70 2d 6d 6f 64 65 0a 09 20 20 20 20 -clip-mode..
41f0: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 63 (lambda (c
4200: 61 6e 76 61 73 29 0a 09 20 20 20 20 20 20 20 20 anvas)..
4210: 20 20 09 28 6c 65 74 20 28 5b 63 6c 69 70 2d 6d .(let ([clip-m
4220: 6f 64 65 20 28 63 61 6e 76 61 73 2d 63 6c 69 70 ode (canvas-clip
4230: 2d 6d 6f 64 65 2f 72 61 77 20 63 61 6e 76 61 73 -mode/raw canvas
4240: 29 5d 29 0a 09 20 20 20 20 20 20 20 20 20 20 09 )]).. .
4250: 09 28 63 6f 6e 64 0a 09 20 20 20 20 20 20 20 20 .(cond..
4260: 20 20 09 09 09 5b 28 72 61 73 73 6f 63 20 63 6c ...[(rassoc cl
4270: 69 70 2d 6d 6f 64 65 20 63 6c 69 70 2d 6d 6f 64 ip-mode clip-mod
4280: 65 73 29 20 3d 3e 20 63 61 72 5d 0a 09 20 20 20 es) => car]..
4290: 20 20 20 20 20 20 20 09 09 09 5b 65 6c 73 65 20 ...[else
42a0: 28 65 72 72 6f 72 20 27 63 61 6e 76 61 73 2d 77 (error 'canvas-w
42b0: 72 69 74 65 2d 6d 6f 64 65 20 22 75 6e 6b 6e 6f rite-mode "unkno
42c0: 77 6e 20 63 6c 69 70 20 6d 6f 64 65 22 20 63 6c wn clip mode" cl
42d0: 69 70 2d 6d 6f 64 65 29 5d 29 29 29 5d 29 0a 09 ip-mode)])))])..
42e0: 20 20 28 76 61 6c 75 65 73 0a 09 20 20 09 28 67 (values.. .(g
42f0: 65 74 74 65 72 2d 77 69 74 68 2d 73 65 74 74 65 etter-with-sette
4300: 72 20 63 61 6e 76 61 73 2d 63 6c 69 70 2d 6d 6f r canvas-clip-mo
4310: 64 65 20 63 61 6e 76 61 73 2d 63 6c 69 70 2d 6d de canvas-clip-m
4320: 6f 64 65 2d 73 65 74 21 29 0a 09 20 20 09 63 61 ode-set!).. .ca
4330: 6e 76 61 73 2d 63 6c 69 70 2d 6d 6f 64 65 2d 73 nvas-clip-mode-s
4340: 65 74 21 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 et!)))..(define
4350: 63 61 6e 76 61 73 2d 63 6c 69 70 2d 61 72 65 61 canvas-clip-area
4360: 2d 73 65 74 21 0a 09 28 66 6f 72 65 69 67 6e 2d -set!..(foreign-
4370: 6c 61 6d 62 64 61 20 76 6f 69 64 20 22 63 64 66 lambda void "cdf
4380: 43 61 6e 76 61 73 43 6c 69 70 41 72 65 61 22 20 CanvasClipArea"
4390: 6e 6f 6e 6e 75 6c 6c 2d 63 61 6e 76 61 73 20 64 nonnull-canvas d
43a0: 6f 75 62 6c 65 20 64 6f 75 62 6c 65 20 64 6f 75 ouble double dou
43b0: 62 6c 65 20 64 6f 75 62 6c 65 29 29 0a 0a 28 64 ble double))..(d
43c0: 65 66 69 6e 65 20 63 61 6e 76 61 73 2d 63 6c 69 efine canvas-cli
43d0: 70 2d 61 72 65 61 0a 09 28 6c 65 74 72 65 63 20 p-area..(letrec
43e0: 28 5b 63 61 6e 76 61 73 2d 63 6c 69 70 2d 61 72 ([canvas-clip-ar
43f0: 65 61 2f 72 61 77 20 28 66 6f 72 65 69 67 6e 2d ea/raw (foreign-
4400: 6c 61 6d 62 64 61 20 76 6f 69 64 20 22 63 64 66 lambda void "cdf
4410: 43 61 6e 76 61 73 47 65 74 43 6c 69 70 41 72 65 CanvasGetClipAre
4420: 61 22 20 6e 6f 6e 6e 75 6c 6c 2d 63 61 6e 76 61 a" nonnull-canva
4430: 73 20 28 63 2d 70 6f 69 6e 74 65 72 20 64 6f 75 s (c-pointer dou
4440: 62 6c 65 29 20 28 63 2d 70 6f 69 6e 74 65 72 20 ble) (c-pointer
4450: 64 6f 75 62 6c 65 29 20 28 63 2d 70 6f 69 6e 74 double) (c-point
4460: 65 72 20 64 6f 75 62 6c 65 29 20 28 63 2d 70 6f er double) (c-po
4470: 69 6e 74 65 72 20 64 6f 75 62 6c 65 29 29 5d 29 inter double))])
4480: 0a 09 09 28 6c 61 6d 62 64 61 20 28 63 61 6e 76 ...(lambda (canv
4490: 61 73 29 0a 09 09 09 28 6c 65 74 2d 6c 6f 63 61 as)....(let-loca
44a0: 74 69 6f 6e 20 28 5b 78 30 20 64 6f 75 62 6c 65 tion ([x0 double
44b0: 20 30 5d 20 5b 78 31 20 64 6f 75 62 6c 65 20 30 0] [x1 double 0
44c0: 5d 20 5b 79 30 20 64 6f 75 62 6c 65 20 30 5d 20 ] [y0 double 0]
44d0: 5b 79 31 20 64 6f 75 62 6c 65 20 30 5d 29 0a 09 [y1 double 0])..
44e0: 09 09 09 28 63 61 6e 76 61 73 2d 63 6c 69 70 2d ...(canvas-clip-
44f0: 61 72 65 61 2f 72 61 77 20 63 61 6e 76 61 73 20 area/raw canvas
4500: 28 6c 6f 63 61 74 69 6f 6e 20 78 30 29 20 28 6c (location x0) (l
4510: 6f 63 61 74 69 6f 6e 20 78 31 29 20 28 6c 6f 63 ocation x1) (loc
4520: 61 74 69 6f 6e 20 79 30 29 20 28 6c 6f 63 61 74 ation y0) (locat
4530: 69 6f 6e 20 79 31 29 29 0a 09 09 09 09 28 76 61 ion y1)).....(va
4540: 6c 75 65 73 20 78 30 20 78 31 20 79 30 20 79 31 lues x0 x1 y0 y1
4550: 29 29 29 29 29 0a 0a 3b 3b 20 7d 7d 7d 0a 0a 29 )))))..;; }}}..)
4560: 0a .