Artifact
90a071f77daa2e97eb1576112d98d411484c62b3:
0000: 23 6c 61 6e 67 20 72 61 63 6b 65 74 0a 28 72 65 #lang racket.(re
0010: 71 75 69 72 65 0a 20 73 72 66 69 2f 32 0a 20 73 quire. srfi/2. s
0020: 72 66 69 2f 31 37 0a 20 73 72 66 69 2f 32 36 0a rfi/17. srfi/26.
0030: 20 66 66 69 2f 75 6e 73 61 66 65 0a 20 66 66 69 ffi/unsafe. ffi
0040: 2f 75 6e 73 61 66 65 2f 63 76 65 63 74 6f 72 0a /unsafe/cvector.
0050: 20 66 66 69 2f 75 6e 73 61 66 65 2f 61 6c 6c 6f ffi/unsafe/allo
0060: 63 0a 20 66 66 69 2f 75 6e 73 61 66 65 2f 61 74 c. ffi/unsafe/at
0070: 6f 6d 69 63 29 0a 0a 28 64 65 66 69 6e 65 20 6c omic)..(define l
0080: 69 62 63 64 0a 20 20 28 63 61 73 65 20 28 73 79 ibcd. (case (sy
0090: 73 74 65 6d 2d 74 79 70 65 20 27 6f 73 29 0a 20 stem-type 'os).
00a0: 20 20 20 5b 28 77 69 6e 64 6f 77 73 29 0a 20 20 [(windows).
00b0: 20 20 20 28 66 66 69 2d 6c 69 62 20 22 63 64 22 (ffi-lib "cd"
00c0: 29 5d 0a 20 20 20 20 5b 65 6c 73 65 0a 20 20 20 )]. [else.
00d0: 20 20 28 66 66 69 2d 6c 69 62 20 22 6c 69 62 63 (ffi-lib "libc
00e0: 64 22 29 5d 29 29 0a 0a 3b 3b 20 7b 7b 7b 20 44 d")]))..;; {{{ D
00f0: 61 74 61 20 74 79 70 65 73 0a 0a 28 64 65 66 69 ata types..(defi
0100: 6e 65 2d 63 70 6f 69 6e 74 65 72 2d 74 79 70 65 ne-cpointer-type
0110: 20 5f 63 61 6e 76 61 73 29 0a 0a 28 64 65 66 69 _canvas)..(defi
0120: 6e 65 2d 63 70 6f 69 6e 74 65 72 2d 74 79 70 65 ne-cpointer-type
0130: 20 5f 63 6f 6e 74 65 78 74 29 0a 0a 28 64 65 66 _context)..(def
0140: 69 6e 65 2d 63 70 6f 69 6e 74 65 72 2d 74 79 70 ine-cpointer-typ
0150: 65 20 5f 73 74 61 74 65 29 0a 0a 28 70 72 6f 76 e _state)..(prov
0160: 69 64 65 0a 20 5f 63 61 6e 76 61 73 20 5f 63 61 ide. _canvas _ca
0170: 6e 76 61 73 2f 6e 75 6c 6c 20 63 61 6e 76 61 73 nvas/null canvas
0180: 3f 0a 20 5f 63 6f 6e 74 65 78 74 20 5f 63 6f 6e ?. _context _con
0190: 74 65 78 74 2f 6e 75 6c 6c 20 63 6f 6e 74 65 78 text/null contex
01a0: 74 3f 0a 20 5f 73 74 61 74 65 20 5f 73 74 61 74 t?. _state _stat
01b0: 65 2f 6e 75 6c 6c 20 73 74 61 74 65 3f 29 0a 0a e/null state?)..
01c0: 3b 3b 20 7d 7d 7d 0a 0a 3b 3b 20 7b 7b 7b 20 43 ;; }}}..;; {{{ C
01d0: 61 6e 76 61 73 20 6d 61 6e 61 67 65 6d 65 6e 74 anvas management
01e0: 0a 0a 28 64 65 66 69 6e 65 20 5f 63 61 70 61 62 ..(define _capab
01f0: 69 6c 69 74 79 2d 6d 61 73 6b 0a 20 20 28 5f 62 ility-mask. (_b
0200: 69 74 6d 61 73 6b 0a 20 20 20 27 28 66 6c 75 73 itmask. '(flus
0210: 68 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3d h =
0220: 20 23 78 30 30 30 30 30 30 30 31 0a 20 20 20 20 #x00000001.
0230: 20 63 6c 65 61 72 20 20 20 20 20 20 20 20 20 20 clear
0240: 20 20 20 20 3d 20 23 78 30 30 30 30 30 30 30 32 = #x00000002
0250: 0a 20 20 20 20 20 70 6c 61 79 20 20 20 20 20 20 . play
0260: 20 20 20 20 20 20 20 20 20 3d 20 23 78 30 30 30 = #x000
0270: 30 30 30 30 34 0a 20 20 20 20 20 79 2d 61 78 69 00004. y-axi
0280: 73 20 20 20 20 20 20 20 20 20 20 20 20 20 3d 20 s =
0290: 23 78 30 30 30 30 30 30 30 38 0a 20 20 20 20 20 #x00000008.
02a0: 63 6c 69 70 2d 61 72 65 61 20 20 20 20 20 20 20 clip-area
02b0: 20 20 20 3d 20 23 78 30 30 30 30 30 30 31 30 0a = #x00000010.
02c0: 20 20 20 20 20 63 6c 69 70 2d 70 6f 6c 79 67 6f clip-polygo
02d0: 6e 20 20 20 20 20 20 20 3d 20 23 78 30 30 30 30 n = #x0000
02e0: 30 30 32 30 0a 20 20 20 20 20 72 65 67 69 6f 6e 0020. region
02f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3d 20 23 = #
0300: 78 30 30 30 30 30 30 34 30 0a 20 20 20 20 20 72 x00000040. r
0310: 65 63 74 61 6e 67 6c 65 20 20 20 20 20 20 20 20 ectangle
0320: 20 20 3d 20 23 78 30 30 30 30 30 30 38 30 0a 20 = #x00000080.
0330: 20 20 20 20 63 68 6f 72 64 20 20 20 20 20 20 20 chord
0340: 20 20 20 20 20 20 20 3d 20 23 78 30 30 30 30 30 = #x00000
0350: 31 30 30 0a 20 20 20 20 20 69 6d 61 67 65 2f 72 100. image/r
0360: 67 62 20 20 20 20 20 20 20 20 20 20 3d 20 23 78 gb = #x
0370: 30 30 30 30 30 32 30 30 0a 20 20 20 20 20 69 6d 00000200. im
0380: 61 67 65 2f 72 67 62 61 20 20 20 20 20 20 20 20 age/rgba
0390: 20 3d 20 23 78 30 30 30 30 30 34 30 30 0a 20 20 = #x00000400.
03a0: 20 20 20 69 6d 61 67 65 2f 6d 61 70 20 20 20 20 image/map
03b0: 20 20 20 20 20 20 3d 20 23 78 30 30 30 30 30 38 = #x000008
03c0: 30 30 0a 20 20 20 20 20 67 65 74 2d 69 6d 61 67 00. get-imag
03d0: 65 2f 72 67 62 20 20 20 20 20 20 3d 20 23 78 30 e/rgb = #x0
03e0: 30 30 30 31 30 30 30 0a 20 20 20 20 20 69 6d 61 0001000. ima
03f0: 67 65 2f 73 65 72 76 65 72 20 20 20 20 20 20 20 ge/server
0400: 3d 20 23 78 30 30 30 30 32 30 30 30 0a 20 20 20 = #x00002000.
0410: 20 20 62 61 63 6b 67 72 6f 75 6e 64 20 20 20 20 background
0420: 20 20 20 20 20 3d 20 23 78 30 30 30 30 34 30 30 = #x0000400
0430: 30 0a 20 20 20 20 20 62 61 63 6b 67 72 6f 75 6e 0. backgroun
0440: 64 2d 6f 70 61 63 69 74 79 20 3d 20 23 78 30 30 d-opacity = #x00
0450: 30 30 38 30 30 30 0a 20 20 20 20 20 77 72 69 74 008000. writ
0460: 65 2d 6d 6f 64 65 20 20 20 20 20 20 20 20 20 3d e-mode =
0470: 20 23 78 30 30 30 31 30 30 30 30 0a 20 20 20 20 #x00010000.
0480: 20 6c 69 6e 65 2d 73 74 79 6c 65 20 20 20 20 20 line-style
0490: 20 20 20 20 3d 20 23 78 30 30 30 32 30 30 30 30 = #x00020000
04a0: 0a 20 20 20 20 20 6c 69 6e 65 2d 77 69 64 74 68 . line-width
04b0: 20 20 20 20 20 20 20 20 20 3d 20 23 78 30 30 30 = #x000
04c0: 34 30 30 30 30 0a 20 20 20 20 20 66 70 72 69 6d 40000. fprim
04d0: 69 74 69 76 65 73 20 20 20 20 20 20 20 20 3d 20 itives =
04e0: 23 78 30 30 30 38 30 30 30 30 0a 20 20 20 20 20 #x00080000.
04f0: 68 61 74 63 68 20 20 20 20 20 20 20 20 20 20 20 hatch
0500: 20 20 20 3d 20 23 78 30 30 31 30 30 30 30 30 0a = #x00100000.
0510: 20 20 20 20 20 73 74 69 70 70 6c 65 20 20 20 20 stipple
0520: 20 20 20 20 20 20 20 20 3d 20 23 78 30 30 32 30 = #x0020
0530: 30 30 30 30 0a 20 20 20 20 20 70 61 74 74 65 72 0000. patter
0540: 6e 20 20 20 20 20 20 20 20 20 20 20 20 3d 20 23 n = #
0550: 78 30 30 34 30 30 30 30 30 0a 20 20 20 20 20 66 x00400000. f
0560: 6f 6e 74 20 20 20 20 20 20 20 20 20 20 20 20 20 ont
0570: 20 20 3d 20 23 78 30 30 38 30 30 30 30 30 0a 20 = #x00800000.
0580: 20 20 20 20 66 6f 6e 74 2d 64 69 6d 65 6e 73 69 font-dimensi
0590: 6f 6e 73 20 20 20 20 3d 20 23 78 30 31 30 30 30 ons = #x01000
05a0: 30 30 30 0a 20 20 20 20 20 74 65 78 74 2d 73 69 000. text-si
05b0: 7a 65 20 20 20 20 20 20 20 20 20 20 3d 20 23 78 ze = #x
05c0: 30 32 30 30 30 30 30 30 0a 20 20 20 20 20 74 65 02000000. te
05d0: 78 74 2d 6f 72 69 65 6e 74 61 74 69 6f 6e 20 20 xt-orientation
05e0: 20 3d 20 23 78 30 34 30 30 30 30 30 30 0a 20 20 = #x04000000.
05f0: 20 20 20 70 61 6c 65 74 74 65 20 20 20 20 20 20 palette
0600: 20 20 20 20 20 20 3d 20 23 78 30 38 30 30 30 30 = #x080000
0610: 30 30 0a 20 20 20 20 20 6c 69 6e 65 2d 63 61 70 00. line-cap
0620: 20 20 20 20 20 20 20 20 20 20 20 3d 20 23 78 31 = #x1
0630: 30 30 30 30 30 30 30 0a 20 20 20 20 20 6c 69 6e 0000000. lin
0640: 65 2d 6a 6f 69 6e 20 20 20 20 20 20 20 20 20 20 e-join
0650: 3d 20 23 78 32 30 30 30 30 30 30 30 0a 20 20 20 = #x20000000.
0660: 20 20 70 61 74 68 20 20 20 20 20 20 20 20 20 20 path
0670: 20 20 20 20 20 3d 20 23 78 34 30 30 30 30 30 30 = #x4000000
0680: 30 0a 20 20 20 20 20 62 65 7a 69 65 72 20 20 20 0. bezier
0690: 20 20 20 20 20 20 20 20 20 20 3d 20 23 78 38 30 = #x80
06a0: 30 30 30 30 30 30 29 0a 20 20 20 5f 69 6e 74 29 000000). _int)
06b0: 29 0a 0a 28 64 65 66 69 6e 65 20 63 6f 6e 74 65 )..(define conte
06c0: 78 74 2d 63 61 70 61 62 69 6c 69 74 69 65 73 0a xt-capabilities.
06d0: 20 20 28 67 65 74 2d 66 66 69 2d 6f 62 6a 0a 20 (get-ffi-obj.
06e0: 20 20 22 63 64 43 6f 6e 74 65 78 74 43 61 70 73 "cdContextCaps
06f0: 22 20 6c 69 62 63 64 0a 20 20 20 28 5f 66 75 6e " libcd. (_fun
0700: 20 5b 63 6f 6e 74 65 78 74 20 3a 20 5f 63 6f 6e [context : _con
0710: 74 65 78 74 5d 20 2d 3e 20 5b 63 61 70 61 62 69 text] -> [capabi
0720: 6c 69 74 69 65 73 20 3a 20 5f 63 61 70 61 62 69 lities : _capabi
0730: 6c 69 74 79 2d 6d 61 73 6b 5d 29 29 29 0a 0a 28 lity-mask])))..(
0740: 64 65 66 69 6e 65 20 75 73 65 2d 63 6f 6e 74 65 define use-conte
0750: 78 74 2b 0a 20 20 28 6d 61 6b 65 2d 70 61 72 61 xt+. (make-para
0760: 6d 65 74 65 72 20 23 66 29 29 0a 0a 28 64 65 66 meter #f))..(def
0770: 69 6e 65 20 75 73 65 2d 63 6f 6e 74 65 78 74 2b ine use-context+
0780: 21 0a 20 20 28 67 65 74 2d 66 66 69 2d 6f 62 6a !. (get-ffi-obj
0790: 0a 20 20 20 22 63 64 55 73 65 43 6f 6e 74 65 78 . "cdUseContex
07a0: 74 50 6c 75 73 22 20 6c 69 62 63 64 0a 20 20 20 tPlus" libcd.
07b0: 28 5f 66 75 6e 20 5b 70 6c 75 73 3f 20 3a 20 5f (_fun [plus? : _
07c0: 62 6f 6f 6c 20 3d 20 28 75 73 65 2d 63 6f 6e 74 bool = (use-cont
07d0: 65 78 74 2b 29 5d 20 2d 3e 20 5f 76 6f 69 64 29 ext+)] -> _void)
07e0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 6d 61 6b 65 ))..(define make
07f0: 2d 63 61 6e 76 61 73 2f 70 74 72 0a 20 20 28 67 -canvas/ptr. (g
0800: 65 74 2d 66 66 69 2d 6f 62 6a 0a 20 20 20 22 63 et-ffi-obj. "c
0810: 64 43 72 65 61 74 65 43 61 6e 76 61 73 22 20 6c dCreateCanvas" l
0820: 69 62 63 64 0a 20 20 20 28 5f 66 75 6e 20 5b 63 ibcd. (_fun [c
0830: 6f 6e 74 65 78 74 20 3a 20 5f 63 6f 6e 74 65 78 ontext : _contex
0840: 74 5d 20 5b 64 61 74 61 20 3a 20 5f 70 6f 69 6e t] [data : _poin
0850: 74 65 72 5d 20 2d 3e 20 5b 63 61 6e 76 61 73 20 ter] -> [canvas
0860: 3a 20 5f 63 61 6e 76 61 73 2f 6e 75 6c 6c 5d 29 : _canvas/null])
0870: 29 29 0a 0a 28 64 65 66 69 6e 65 20 6d 61 6b 65 ))..(define make
0880: 2d 63 61 6e 76 61 73 2f 73 74 72 69 6e 67 0a 20 -canvas/string.
0890: 20 28 67 65 74 2d 66 66 69 2d 6f 62 6a 0a 20 20 (get-ffi-obj.
08a0: 20 22 63 64 43 72 65 61 74 65 43 61 6e 76 61 73 "cdCreateCanvas
08b0: 22 20 6c 69 62 63 64 0a 20 20 20 28 5f 66 75 6e " libcd. (_fun
08c0: 20 5b 63 6f 6e 74 65 78 74 20 3a 20 5f 63 6f 6e [context : _con
08d0: 74 65 78 74 5d 20 5b 64 61 74 61 20 3a 20 5f 73 text] [data : _s
08e0: 74 72 69 6e 67 2f 75 74 66 2d 38 5d 20 2d 3e 20 tring/utf-8] ->
08f0: 5b 63 61 6e 76 61 73 20 3a 20 5f 63 61 6e 76 61 [canvas : _canva
0900: 73 2f 6e 75 6c 6c 5d 29 29 29 0a 0a 28 64 65 66 s/null])))..(def
0910: 69 6e 65 20 63 61 6e 76 61 73 2d 6b 69 6c 6c 0a ine canvas-kill.
0920: 20 20 28 28 64 65 61 6c 6c 6f 63 61 74 6f 72 29 ((deallocator)
0930: 0a 20 20 20 28 67 65 74 2d 66 66 69 2d 6f 62 6a . (get-ffi-obj
0940: 0a 20 20 20 20 22 63 64 4b 69 6c 6c 43 61 6e 76 . "cdKillCanv
0950: 61 73 22 20 6c 69 62 63 64 0a 20 20 20 20 28 5f as" libcd. (_
0960: 66 75 6e 20 5b 63 61 6e 76 61 73 20 3a 20 5f 63 fun [canvas : _c
0970: 61 6e 76 61 73 5d 20 2d 3e 20 5f 76 6f 69 64 29 anvas] -> _void)
0980: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 61 6e )))..(define can
0990: 76 61 73 2d 61 63 74 69 76 61 74 65 21 0a 20 20 vas-activate!.
09a0: 28 67 65 74 2d 66 66 69 2d 6f 62 6a 0a 20 20 20 (get-ffi-obj.
09b0: 22 63 64 43 61 6e 76 61 73 41 63 74 69 76 61 74 "cdCanvasActivat
09c0: 65 22 20 6c 69 62 63 64 0a 20 20 20 28 5f 66 75 e" libcd. (_fu
09d0: 6e 20 5b 63 61 6e 76 61 73 20 3a 20 5f 63 61 6e n [canvas : _can
09e0: 76 61 73 5d 20 2d 3e 20 5f 76 6f 69 64 29 29 29 vas] -> _void)))
09f0: 0a 0a 28 64 65 66 69 6e 65 20 63 61 6e 76 61 73 ..(define canvas
0a00: 2d 64 65 61 63 74 69 76 61 74 65 21 0a 20 20 28 -deactivate!. (
0a10: 67 65 74 2d 66 66 69 2d 6f 62 6a 0a 20 20 20 22 get-ffi-obj. "
0a20: 63 64 43 61 6e 76 61 73 44 65 61 63 74 69 76 61 cdCanvasDeactiva
0a30: 74 65 22 20 6c 69 62 63 64 0a 20 20 20 28 5f 66 te" libcd. (_f
0a40: 75 6e 20 5b 63 61 6e 76 61 73 20 3a 20 5f 63 61 un [canvas : _ca
0a50: 6e 76 61 73 5d 20 2d 3e 20 5f 76 6f 69 64 29 29 nvas] -> _void))
0a60: 29 0a 0a 28 64 65 66 69 6e 65 20 6d 61 6b 65 2d )..(define make-
0a70: 63 61 6e 76 61 73 0a 20 20 28 28 61 6c 6c 6f 63 canvas. ((alloc
0a80: 61 74 6f 72 20 63 61 6e 76 61 73 2d 6b 69 6c 6c ator canvas-kill
0a90: 29 0a 20 20 20 28 ce bb 20 28 63 6f 6e 74 65 78 ). (λ (contex
0aa0: 74 20 64 61 74 61 29 0a 20 20 20 20 20 28 6c 65 t data). (le
0ab0: 74 20 28 5b 6d 61 6b 65 2d 63 61 6e 76 61 73 2f t ([make-canvas/
0ac0: 64 61 74 61 20 28 69 66 20 28 73 74 72 69 6e 67 data (if (string
0ad0: 3f 20 64 61 74 61 29 20 6d 61 6b 65 2d 63 61 6e ? data) make-can
0ae0: 76 61 73 2f 73 74 72 69 6e 67 20 6d 61 6b 65 2d vas/string make-
0af0: 63 61 6e 76 61 73 2f 70 74 72 29 5d 29 0a 20 20 canvas/ptr)]).
0b00: 20 20 20 20 20 28 75 73 65 2d 63 6f 6e 74 65 78 (use-contex
0b10: 74 2b 21 29 0a 20 20 20 20 20 20 20 28 63 6f 6e t+!). (con
0b20: 64 0a 20 20 20 20 20 20 20 20 20 5b 28 6d 61 6b d. [(mak
0b30: 65 2d 63 61 6e 76 61 73 2f 64 61 74 61 20 63 6f e-canvas/data co
0b40: 6e 74 65 78 74 20 64 61 74 61 29 20 3d 3e 20 76 ntext data) => v
0b50: 61 6c 75 65 73 5d 0a 20 20 20 20 20 20 20 20 20 alues].
0b60: 5b 65 6c 73 65 20 28 65 72 72 6f 72 20 27 6d 61 [else (error 'ma
0b70: 6b 65 2d 63 61 6e 76 61 73 20 22 66 61 69 6c 65 ke-canvas "faile
0b80: 64 20 74 6f 20 63 72 65 61 74 65 20 63 61 6e 76 d to create canv
0b90: 61 73 22 29 5d 29 29 29 29 29 0a 0a 28 64 65 66 as")])))))..(def
0ba0: 69 6e 65 20 63 61 6c 6c 2d 77 69 74 68 2d 63 61 ine call-with-ca
0bb0: 6e 76 61 73 0a 20 20 28 63 61 73 65 2d 6c 61 6d nvas. (case-lam
0bc0: 62 64 61 0a 20 20 20 20 5b 28 63 61 6e 76 61 73 bda. [(canvas
0bd0: 20 70 72 6f 63 29 0a 20 20 20 20 20 28 64 79 6e proc). (dyn
0be0: 61 6d 69 63 2d 77 69 6e 64 0a 20 20 20 20 20 20 amic-wind.
0bf0: 28 63 75 74 20 63 61 6e 76 61 73 2d 61 63 74 69 (cut canvas-acti
0c00: 76 61 74 65 21 20 63 61 6e 76 61 73 29 0a 20 20 vate! canvas).
0c10: 20 20 20 20 28 63 75 74 20 70 72 6f 63 20 63 61 (cut proc ca
0c20: 6e 76 61 73 29 0a 20 20 20 20 20 20 28 63 75 74 nvas). (cut
0c30: 20 63 61 6e 76 61 73 2d 64 65 61 63 74 69 76 61 canvas-deactiva
0c40: 74 65 21 20 63 61 6e 76 61 73 29 29 5d 0a 20 20 te! canvas))].
0c50: 20 20 5b 28 63 6f 6e 74 65 78 74 20 64 61 74 61 [(context data
0c60: 20 70 72 6f 63 29 0a 20 20 20 20 20 28 6c 65 74 proc). (let
0c70: 2a 20 28 5b 6d 61 6b 65 2d 63 61 6e 76 61 73 2f * ([make-canvas/
0c80: 64 61 74 61 0a 20 20 20 20 20 20 20 20 20 20 20 data.
0c90: 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 64 (if (string? d
0ca0: 61 74 61 29 20 6d 61 6b 65 2d 63 61 6e 76 61 73 ata) make-canvas
0cb0: 2f 73 74 72 69 6e 67 20 6d 61 6b 65 2d 63 61 6e /string make-can
0cc0: 76 61 73 2f 70 74 72 29 5d 0a 20 20 20 20 20 20 vas/ptr)].
0cd0: 20 20 20 20 20 20 5b 63 61 6e 76 61 73 0a 20 20 [canvas.
0ce0: 20 20 20 20 20 20 20 20 20 20 20 28 63 61 6c 6c (call
0cf0: 2d 61 73 2d 61 74 6f 6d 69 63 0a 20 20 20 20 20 -as-atomic.
0d00: 20 20 20 20 20 20 20 20 20 28 ce bb 20 28 29 0a (λ ().
0d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0d20: 28 75 73 65 2d 63 6f 6e 74 65 78 74 2b 21 29 0a (use-context+!).
0d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0d40: 28 6d 61 6b 65 2d 63 61 6e 76 61 73 2f 64 61 74 (make-canvas/dat
0d50: 61 20 63 6f 6e 74 65 78 74 20 64 61 74 61 29 29 a context data))
0d60: 29 5d 29 0a 20 20 20 20 20 20 20 28 75 6e 6c 65 )]). (unle
0d70: 73 73 20 63 61 6e 76 61 73 20 28 65 72 72 6f 72 ss canvas (error
0d80: 20 27 63 61 6c 6c 2d 77 69 74 68 2d 63 61 6e 76 'call-with-canv
0d90: 61 73 20 22 66 61 69 6c 65 64 20 74 6f 20 63 72 as "failed to cr
0da0: 65 61 74 65 20 63 61 6e 76 61 73 22 29 29 0a 20 eate canvas")).
0db0: 20 20 20 20 20 20 28 64 79 6e 61 6d 69 63 2d 77 (dynamic-w
0dc0: 69 6e 64 0a 20 20 20 20 20 20 20 20 28 63 75 74 ind. (cut
0dd0: 20 63 61 6e 76 61 73 2d 61 63 74 69 76 61 74 65 canvas-activate
0de0: 21 20 63 61 6e 76 61 73 29 0a 20 20 20 20 20 20 ! canvas).
0df0: 20 20 28 63 75 74 20 70 72 6f 63 20 63 61 6e 76 (cut proc canv
0e00: 61 73 29 0a 20 20 20 20 20 20 20 20 28 ce bb 20 as). (λ
0e10: 28 29 0a 20 20 20 20 20 20 20 20 20 20 28 77 68 (). (wh
0e20: 65 6e 20 63 61 6e 76 61 73 0a 20 20 20 20 20 20 en canvas.
0e30: 20 20 20 20 20 20 28 63 61 6e 76 61 73 2d 6b 69 (canvas-ki
0e40: 6c 6c 20 63 61 6e 76 61 73 29 0a 20 20 20 20 20 ll canvas).
0e50: 20 20 20 20 20 20 20 28 73 65 74 21 20 63 61 6e (set! can
0e60: 76 61 73 20 23 66 29 29 29 29 29 5d 29 29 0a 0a vas #f)))))]))..
0e70: 28 64 65 66 69 6e 65 20 63 61 6e 76 61 73 2d 63 (define canvas-c
0e80: 6f 6e 74 65 78 74 0a 20 20 28 67 65 74 2d 66 66 ontext. (get-ff
0e90: 69 2d 6f 62 6a 0a 20 20 20 22 63 64 43 61 6e 76 i-obj. "cdCanv
0ea0: 61 73 47 65 74 43 6f 6e 74 65 78 74 22 20 6c 69 asGetContext" li
0eb0: 62 63 64 0a 20 20 20 28 5f 66 75 6e 20 5b 63 61 bcd. (_fun [ca
0ec0: 6e 76 61 73 20 3a 20 5f 63 61 6e 76 61 73 5d 20 nvas : _canvas]
0ed0: 2d 3e 20 5b 63 6f 6e 74 65 78 74 20 3a 20 5f 63 -> [context : _c
0ee0: 6f 6e 74 65 78 74 5d 29 29 29 0a 0a 28 64 65 66 ontext])))..(def
0ef0: 69 6e 65 20 5f 73 69 6d 75 6c 61 74 69 6f 6e 2d ine _simulation-
0f00: 6d 61 73 6b 0a 20 20 28 5f 62 69 74 6d 61 73 6b mask. (_bitmask
0f10: 0a 20 20 20 27 28 6e 6f 6e 65 20 20 20 20 20 20 . '(none
0f20: 3d 20 23 78 30 30 30 30 0a 20 20 20 20 20 6c 69 = #x0000. li
0f30: 6e 65 20 20 20 20 20 20 3d 20 23 78 30 30 30 31 ne = #x0001
0f40: 0a 20 20 20 20 20 72 65 63 74 61 6e 67 6c 65 20 . rectangle
0f50: 3d 20 23 78 30 30 30 32 0a 20 20 20 20 20 62 6f = #x0002. bo
0f60: 78 20 20 20 20 20 20 20 3d 20 23 78 30 30 30 34 x = #x0004
0f70: 0a 20 20 20 20 20 61 72 63 20 20 20 20 20 20 20 . arc
0f80: 3d 20 23 78 30 30 30 38 0a 20 20 20 20 20 73 65 = #x0008. se
0f90: 63 74 6f 72 20 20 20 20 3d 20 23 78 30 30 31 30 ctor = #x0010
0fa0: 0a 20 20 20 20 20 63 68 6f 72 64 20 20 20 20 20 . chord
0fb0: 3d 20 23 78 30 30 32 30 0a 20 20 20 20 20 70 6f = #x0020. po
0fc0: 6c 79 6c 69 6e 65 20 20 3d 20 23 78 30 30 34 30 lyline = #x0040
0fd0: 0a 20 20 20 20 20 70 6f 6c 79 67 6f 6e 20 20 20 . polygon
0fe0: 3d 20 23 78 30 30 38 30 0a 20 20 20 20 20 74 65 = #x0080. te
0ff0: 78 74 20 20 20 20 20 20 3d 20 23 78 30 31 30 30 xt = #x0100
1000: 0a 20 20 20 20 20 61 6c 6c 20 20 20 20 20 20 20 . all
1010: 3d 20 23 78 46 46 46 46 0a 20 20 20 20 20 6c 69 = #xFFFF. li
1020: 6e 65 73 20 20 20 20 20 3d 20 23 78 30 30 34 42 nes = #x004B
1030: 0a 20 20 20 20 20 66 69 6c 6c 73 20 20 20 20 20 . fills
1040: 3d 20 23 78 30 30 42 34 29 0a 20 20 20 5f 69 6e = #x00B4). _in
1050: 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 61 6e t))..(define can
1060: 76 61 73 2d 73 69 6d 75 6c 61 74 65 21 0a 20 20 vas-simulate!.
1070: 28 67 65 74 2d 66 66 69 2d 6f 62 6a 0a 20 20 20 (get-ffi-obj.
1080: 22 63 64 43 61 6e 76 61 73 53 69 6d 75 6c 61 74 "cdCanvasSimulat
1090: 65 22 20 6c 69 62 63 64 0a 20 20 20 28 5f 66 75 e" libcd. (_fu
10a0: 6e 20 5b 63 61 6e 76 61 73 20 3a 20 5f 63 61 6e n [canvas : _can
10b0: 76 61 73 5d 20 5b 73 69 6d 75 6c 61 74 65 20 3a vas] [simulate :
10c0: 20 5f 73 69 6d 75 6c 61 74 69 6f 6e 2d 6d 61 73 _simulation-mas
10d0: 6b 5d 20 2d 3e 20 5b 73 69 6d 75 6c 61 74 65 20 k] -> [simulate
10e0: 3a 20 5f 73 69 6d 75 6c 61 74 69 6f 6e 2d 6d 61 : _simulation-ma
10f0: 73 6b 5d 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 sk])))..(define
1100: 5f 6e 61 6d 65 0a 20 20 28 6d 61 6b 65 2d 63 74 _name. (make-ct
1110: 79 70 65 0a 20 20 20 5f 73 74 72 69 6e 67 2f 75 ype. _string/u
1120: 74 66 2d 38 0a 20 20 20 28 ce bb 20 28 6e 61 6d tf-8. (λ (nam
1130: 65 29 0a 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 e). (cond.
1140: 20 20 20 20 20 5b 28 73 79 6d 62 6f 6c 3f 20 6e [(symbol? n
1150: 61 6d 65 29 0a 20 20 20 20 20 20 20 20 28 73 74 ame). (st
1160: 72 69 6e 67 2d 75 70 63 61 73 65 20 28 72 65 67 ring-upcase (reg
1170: 65 78 70 2d 72 65 70 6c 61 63 65 2a 20 23 72 78 exp-replace* #rx
1180: 22 2d 22 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 "-" (symbol->str
1190: 69 6e 67 20 6e 61 6d 65 29 20 22 5f 22 29 29 5d ing name) "_"))]
11a0: 0a 20 20 20 20 20 20 20 5b 65 6c 73 65 0a 20 20 . [else.
11b0: 20 20 20 20 20 20 6e 61 6d 65 5d 29 29 0a 20 20 name])).
11c0: 20 23 66 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 #f))..(define c
11d0: 61 6e 76 61 73 2d 61 74 74 72 69 62 75 74 65 2d anvas-attribute-
11e0: 73 65 74 21 0a 20 20 28 67 65 74 2d 66 66 69 2d set!. (get-ffi-
11f0: 6f 62 6a 0a 20 20 20 22 63 64 43 61 6e 76 61 73 obj. "cdCanvas
1200: 53 65 74 41 74 74 72 69 62 75 74 65 22 20 6c 69 SetAttribute" li
1210: 62 63 64 0a 20 20 20 28 5f 66 75 6e 20 5b 63 61 bcd. (_fun [ca
1220: 6e 76 61 73 20 3a 20 5f 63 61 6e 76 61 73 5d 20 nvas : _canvas]
1230: 5b 6e 61 6d 65 20 3a 20 5f 6e 61 6d 65 5d 20 5b [name : _name] [
1240: 76 61 6c 75 65 20 3a 20 5f 73 74 72 69 6e 67 2f value : _string/
1250: 75 74 66 2d 38 5d 20 2d 3e 20 5f 76 6f 69 64 29 utf-8] -> _void)
1260: 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 61 6e 76 ))..(define canv
1270: 61 73 2d 61 74 74 72 69 62 75 74 65 0a 20 20 28 as-attribute. (
1280: 67 65 74 74 65 72 2d 77 69 74 68 2d 73 65 74 74 getter-with-sett
1290: 65 72 0a 20 20 20 28 67 65 74 2d 66 66 69 2d 6f er. (get-ffi-o
12a0: 62 6a 0a 20 20 20 20 22 63 64 43 61 6e 76 61 73 bj. "cdCanvas
12b0: 47 65 74 41 74 74 72 69 62 75 74 65 22 20 6c 69 GetAttribute" li
12c0: 62 63 64 0a 20 20 20 20 28 5f 66 75 6e 20 5b 63 bcd. (_fun [c
12d0: 61 6e 76 61 73 20 3a 20 5f 63 61 6e 76 61 73 5d anvas : _canvas]
12e0: 20 5b 6e 61 6d 65 20 3a 20 5f 6e 61 6d 65 5d 20 [name : _name]
12f0: 2d 3e 20 5b 76 61 6c 75 65 20 3a 20 5f 73 74 72 -> [value : _str
1300: 69 6e 67 2f 75 74 66 2d 38 5d 29 29 0a 20 20 20 ing/utf-8])).
1310: 63 61 6e 76 61 73 2d 61 74 74 72 69 62 75 74 65 canvas-attribute
1320: 2d 73 65 74 21 29 29 0a 0a 28 64 65 66 69 6e 65 -set!))..(define
1330: 20 63 61 6e 76 61 73 2d 73 74 61 74 65 2d 73 65 canvas-state-se
1340: 74 21 0a 20 20 28 67 65 74 2d 66 66 69 2d 6f 62 t!. (get-ffi-ob
1350: 6a 0a 20 20 20 22 63 64 43 61 6e 76 61 73 52 65 j. "cdCanvasRe
1360: 73 74 6f 72 65 53 74 61 74 65 22 20 6c 69 62 63 storeState" libc
1370: 64 0a 20 20 20 28 5f 66 75 6e 20 5b 63 61 6e 76 d. (_fun [canv
1380: 61 73 20 3a 20 5f 63 61 6e 76 61 73 5d 20 5b 73 as : _canvas] [s
1390: 74 61 74 65 20 3a 20 5f 73 74 61 74 65 5d 20 2d tate : _state] -
13a0: 3e 20 5f 76 6f 69 64 29 29 29 0a 0a 28 64 65 66 > _void)))..(def
13b0: 69 6e 65 20 73 74 61 74 65 2d 72 65 6c 65 61 73 ine state-releas
13c0: 65 0a 20 20 28 28 64 65 61 6c 6c 6f 63 61 74 6f e. ((deallocato
13d0: 72 29 0a 20 20 20 28 67 65 74 2d 66 66 69 2d 6f r). (get-ffi-o
13e0: 62 6a 0a 20 20 20 20 22 63 64 52 65 6c 65 61 73 bj. "cdReleas
13f0: 65 53 74 61 74 65 22 20 6c 69 62 63 64 0a 20 20 eState" libcd.
1400: 20 20 28 5f 66 75 6e 20 5b 73 74 61 74 65 20 3a (_fun [state :
1410: 20 5f 73 74 61 74 65 5d 20 2d 3e 20 5f 76 6f 69 _state] -> _voi
1420: 64 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 d))))..(define c
1430: 61 6e 76 61 73 2d 73 74 61 74 65 0a 20 20 28 67 anvas-state. (g
1440: 65 74 74 65 72 2d 77 69 74 68 2d 73 65 74 74 65 etter-with-sette
1450: 72 0a 20 20 20 28 28 61 6c 6c 6f 63 61 74 6f 72 r. ((allocator
1460: 20 73 74 61 74 65 2d 72 65 6c 65 61 73 65 29 0a state-release).
1470: 20 20 20 20 28 67 65 74 2d 66 66 69 2d 6f 62 6a (get-ffi-obj
1480: 0a 20 20 20 20 20 22 63 64 43 61 6e 76 61 73 53 . "cdCanvasS
1490: 61 76 65 53 74 61 74 65 22 20 6c 69 62 63 64 0a aveState" libcd.
14a0: 20 20 20 20 20 28 5f 66 75 6e 20 5b 63 61 6e 76 (_fun [canv
14b0: 61 73 20 3a 20 5f 63 61 6e 76 61 73 5d 20 2d 3e as : _canvas] ->
14c0: 20 5b 73 74 61 74 65 20 3a 20 5f 73 74 61 74 65 [state : _state
14d0: 5d 29 29 29 0a 20 20 20 63 61 6e 76 61 73 2d 73 ]))). canvas-s
14e0: 74 61 74 65 2d 73 65 74 21 29 29 0a 0a 28 64 65 tate-set!))..(de
14f0: 66 69 6e 65 20 63 61 6e 76 61 73 2d 63 6c 65 61 fine canvas-clea
1500: 72 21 0a 20 20 28 67 65 74 2d 66 66 69 2d 6f 62 r!. (get-ffi-ob
1510: 6a 0a 20 20 20 22 63 64 43 61 6e 76 61 73 43 6c j. "cdCanvasCl
1520: 65 61 72 22 20 6c 69 62 63 64 0a 20 20 20 28 5f ear" libcd. (_
1530: 66 75 6e 20 5b 63 61 6e 76 61 73 20 3a 20 5f 63 fun [canvas : _c
1540: 61 6e 76 61 73 5d 20 2d 3e 20 5f 76 6f 69 64 29 anvas] -> _void)
1550: 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 61 6e 76 ))..(define canv
1560: 61 73 2d 66 6c 75 73 68 0a 20 20 28 67 65 74 2d as-flush. (get-
1570: 66 66 69 2d 6f 62 6a 0a 20 20 20 22 63 64 43 61 ffi-obj. "cdCa
1580: 6e 76 61 73 46 6c 75 73 68 22 20 6c 69 62 63 64 nvasFlush" libcd
1590: 0a 20 20 20 28 5f 66 75 6e 20 5b 63 61 6e 76 61 . (_fun [canva
15a0: 73 20 3a 20 5f 63 61 6e 76 61 73 5d 20 2d 3e 20 s : _canvas] ->
15b0: 5f 76 6f 69 64 29 29 29 0a 0a 28 70 72 6f 76 69 _void)))..(provi
15c0: 64 65 0a 20 63 6f 6e 74 65 78 74 2d 63 61 70 61 de. context-capa
15d0: 62 69 6c 69 74 69 65 73 0a 20 75 73 65 2d 63 6f bilities. use-co
15e0: 6e 74 65 78 74 2b 20 6d 61 6b 65 2d 63 61 6e 76 ntext+ make-canv
15f0: 61 73 20 63 61 6c 6c 2d 77 69 74 68 2d 63 61 6e as call-with-can
1600: 76 61 73 0a 20 63 61 6e 76 61 73 2d 63 6f 6e 74 vas. canvas-cont
1610: 65 78 74 0a 20 63 61 6e 76 61 73 2d 73 69 6d 75 ext. canvas-simu
1620: 6c 61 74 65 21 0a 20 63 61 6e 76 61 73 2d 61 74 late!. canvas-at
1630: 74 72 69 62 75 74 65 20 63 61 6e 76 61 73 2d 61 tribute canvas-a
1640: 74 74 72 69 62 75 74 65 2d 73 65 74 21 0a 20 63 ttribute-set!. c
1650: 61 6e 76 61 73 2d 73 74 61 74 65 20 63 61 6e 76 anvas-state canv
1660: 61 73 2d 73 74 61 74 65 2d 73 65 74 21 0a 20 63 as-state-set!. c
1670: 61 6e 76 61 73 2d 63 6c 65 61 72 21 20 63 61 6e anvas-clear! can
1680: 76 61 73 2d 66 6c 75 73 68 29 0a 0a 3b 3b 20 7d vas-flush)..;; }
1690: 7d 7d 0a 0a 3b 3b 20 7b 7b 7b 20 43 6f 6f 72 64 }}..;; {{{ Coord
16a0: 69 6e 61 74 65 20 73 79 73 74 65 6d 0a 0a 28 64 inate system..(d
16b0: 65 66 69 6e 65 20 63 61 6e 76 61 73 2d 73 69 7a efine canvas-siz
16c0: 65 0a 20 20 28 67 65 74 2d 66 66 69 2d 6f 62 6a e. (get-ffi-obj
16d0: 0a 20 20 20 22 63 64 43 61 6e 76 61 73 47 65 74 . "cdCanvasGet
16e0: 53 69 7a 65 22 20 6c 69 62 63 64 0a 20 20 20 28 Size" libcd. (
16f0: 5f 66 75 6e 20 5b 63 61 6e 76 61 73 20 3a 20 5f _fun [canvas : _
1700: 63 61 6e 76 61 73 5d 0a 20 20 20 20 20 20 20 20 canvas].
1710: 20 5b 77 69 64 74 68 2f 70 78 20 3a 20 28 5f 70 [width/px : (_p
1720: 74 72 20 6f 20 5f 69 6e 74 29 5d 20 5b 68 65 69 tr o _int)] [hei
1730: 67 68 74 2f 70 78 20 3a 20 28 5f 70 74 72 20 6f ght/px : (_ptr o
1740: 20 5f 69 6e 74 29 5d 0a 20 20 20 20 20 20 20 20 _int)].
1750: 20 5b 77 69 64 74 68 2f 6d 6d 20 3a 20 28 5f 70 [width/mm : (_p
1760: 74 72 20 6f 20 5f 64 6f 75 62 6c 65 29 5d 20 5b tr o _double)] [
1770: 68 65 69 67 68 74 2f 6d 6d 20 3a 20 28 5f 70 74 height/mm : (_pt
1780: 72 20 6f 20 5f 64 6f 75 62 6c 65 29 5d 0a 20 20 r o _double)].
1790: 20 20 20 20 20 20 20 2d 3e 20 5f 76 6f 69 64 0a -> _void.
17a0: 20 20 20 20 20 20 20 20 20 2d 3e 20 28 76 61 6c -> (val
17b0: 75 65 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 ues.
17c0: 20 77 69 64 74 68 2f 70 78 20 68 65 69 67 68 74 width/px height
17d0: 2f 70 78 0a 20 20 20 20 20 20 20 20 20 20 20 20 /px.
17e0: 20 77 69 64 74 68 2f 6d 6d 20 68 65 69 67 68 74 width/mm height
17f0: 2f 6d 6d 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 /mm))))..(define
1800: 20 63 61 6e 76 61 73 2d 6d 6d 2d 3e 70 78 0a 20 canvas-mm->px.
1810: 20 28 67 65 74 2d 66 66 69 2d 6f 62 6a 0a 20 20 (get-ffi-obj.
1820: 20 22 63 64 43 61 6e 76 61 73 4d 4d 32 50 69 78 "cdCanvasMM2Pix
1830: 65 6c 22 20 6c 69 62 63 64 0a 20 20 20 28 5f 66 el" libcd. (_f
1840: 75 6e 20 5b 63 61 6e 76 61 73 20 3a 20 5f 63 61 un [canvas : _ca
1850: 6e 76 61 73 5d 0a 20 20 20 20 20 20 20 20 20 5b nvas]. [
1860: 78 2f 6d 6d 20 3a 20 5f 64 6f 75 62 6c 65 2a 5d x/mm : _double*]
1870: 20 5b 79 2f 6d 6d 20 3a 20 5f 64 6f 75 62 6c 65 [y/mm : _double
1880: 2a 5d 0a 20 20 20 20 20 20 20 20 20 5b 78 2f 70 *]. [x/p
1890: 78 20 3a 20 28 5f 70 74 72 20 6f 20 5f 69 6e 74 x : (_ptr o _int
18a0: 29 5d 20 5b 79 2f 70 78 20 3a 20 28 5f 70 74 72 )] [y/px : (_ptr
18b0: 20 6f 20 5f 69 6e 74 29 5d 0a 20 20 20 20 20 20 o _int)].
18c0: 20 20 20 2d 3e 20 5f 76 6f 69 64 0a 20 20 20 20 -> _void.
18d0: 20 20 20 20 20 2d 3e 20 28 76 61 6c 75 65 73 20 -> (values
18e0: 78 2f 70 78 20 79 2f 70 78 29 29 29 29 0a 0a 28 x/px y/px))))..(
18f0: 64 65 66 69 6e 65 20 63 61 6e 76 61 73 2d 70 78 define canvas-px
1900: 2d 3e 6d 6d 0a 20 20 28 67 65 74 2d 66 66 69 2d ->mm. (get-ffi-
1910: 6f 62 6a 0a 20 20 20 22 63 64 43 61 6e 76 61 73 obj. "cdCanvas
1920: 50 69 78 65 6c 32 4d 4d 22 20 6c 69 62 63 64 0a Pixel2MM" libcd.
1930: 20 20 20 28 5f 66 75 6e 20 5b 63 61 6e 76 61 73 (_fun [canvas
1940: 20 3a 20 5f 63 61 6e 76 61 73 5d 0a 20 20 20 20 : _canvas].
1950: 20 20 20 20 20 5b 78 2f 70 78 20 3a 20 5f 69 6e [x/px : _in
1960: 74 5d 20 5b 79 2f 70 78 20 3a 20 5f 69 6e 74 5d t] [y/px : _int]
1970: 0a 20 20 20 20 20 20 20 20 20 5b 78 2f 6d 6d 20 . [x/mm
1980: 3a 20 28 5f 70 74 72 20 6f 20 5f 64 6f 75 62 6c : (_ptr o _doubl
1990: 65 29 5d 20 5b 79 2f 6d 6d 20 3a 20 28 5f 70 74 e)] [y/mm : (_pt
19a0: 72 20 6f 20 5f 64 6f 75 62 6c 65 29 5d 0a 20 20 r o _double)].
19b0: 20 20 20 20 20 20 20 2d 3e 20 5f 76 6f 69 64 0a -> _void.
19c0: 20 20 20 20 20 20 20 20 20 2d 3e 20 28 76 61 6c -> (val
19d0: 75 65 73 20 78 2f 6d 6d 20 79 2f 6d 6d 29 29 29 ues x/mm y/mm)))
19e0: 29 0a 0a 28 64 65 66 69 6e 65 20 63 61 6e 76 61 )..(define canva
19f0: 73 2d 6f 72 69 67 69 6e 2d 73 65 74 21 0a 20 20 s-origin-set!.
1a00: 28 67 65 74 2d 66 66 69 2d 6f 62 6a 0a 20 20 20 (get-ffi-obj.
1a10: 22 63 64 43 61 6e 76 61 73 4f 72 69 67 69 6e 22 "cdCanvasOrigin"
1a20: 20 6c 69 62 63 64 0a 20 20 20 28 5f 66 75 6e 20 libcd. (_fun
1a30: 5b 63 61 6e 76 61 73 20 3a 20 5f 63 61 6e 76 61 [canvas : _canva
1a40: 73 5d 20 5b 78 20 3a 20 5f 69 6e 74 5d 20 5b 79 s] [x : _int] [y
1a50: 20 3a 20 5f 69 6e 74 5d 20 2d 3e 20 5f 76 6f 69 : _int] -> _voi
1a60: 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 61 d)))..(define ca
1a70: 6e 76 61 73 2d 6f 72 69 67 69 6e 0a 20 20 28 67 nvas-origin. (g
1a80: 65 74 2d 66 66 69 2d 6f 62 6a 0a 20 20 20 22 63 et-ffi-obj. "c
1a90: 64 43 61 6e 76 61 73 47 65 74 4f 72 69 67 69 6e dCanvasGetOrigin
1aa0: 22 20 6c 69 62 63 64 0a 20 20 20 28 5f 66 75 6e " libcd. (_fun
1ab0: 20 5b 63 61 6e 76 61 73 20 3a 20 5f 63 61 6e 76 [canvas : _canv
1ac0: 61 73 5d 20 5b 78 20 3a 20 28 5f 70 74 72 20 6f as] [x : (_ptr o
1ad0: 20 5f 69 6e 74 29 5d 20 5b 79 20 3a 20 28 5f 70 _int)] [y : (_p
1ae0: 74 72 20 6f 20 5f 69 6e 74 29 5d 0a 20 20 20 20 tr o _int)].
1af0: 20 20 20 20 20 2d 3e 20 5f 76 6f 69 64 0a 20 20 -> _void.
1b00: 20 20 20 20 20 20 20 2d 3e 20 28 76 61 6c 75 65 -> (value
1b10: 73 20 78 20 79 29 29 29 29 0a 0a 28 64 65 66 69 s x y))))..(defi
1b20: 6e 65 20 5f 74 72 61 6e 73 66 6f 72 6d 0a 20 20 ne _transform.
1b30: 28 6d 61 6b 65 2d 63 74 79 70 65 0a 20 20 20 5f (make-ctype. _
1b40: 67 63 70 6f 69 6e 74 65 72 0a 20 20 20 28 ce bb gcpointer. (λ
1b50: 20 28 70 72 6f 63 29 0a 20 20 20 20 20 28 61 6e (proc). (an
1b60: 64 0a 20 20 20 20 20 20 70 72 6f 63 0a 20 20 20 d. proc.
1b70: 20 20 20 28 6c 65 74 2a 20 28 5b 76 20 28 6d 61 (let* ([v (ma
1b80: 6b 65 2d 63 76 65 63 74 6f 72 20 5f 64 6f 75 62 ke-cvector _doub
1b90: 6c 65 2a 20 36 29 5d 29 0a 20 20 20 20 20 20 20 le* 6)]).
1ba0: 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 5b 28 (let-values ([(
1bb0: 64 78 20 64 79 29 20 28 70 72 6f 63 20 30 20 30 dx dy) (proc 0 0
1bc0: 29 5d 29 0a 20 20 20 20 20 20 20 20 20 20 28 63 )]). (c
1bd0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 20 34 20 vector-set! v 4
1be0: 64 78 29 0a 20 20 20 20 20 20 20 20 20 20 28 63 dx). (c
1bf0: 76 65 63 74 6f 72 2d 73 65 74 21 20 76 20 35 20 vector-set! v 5
1c00: 64 79 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c dy). (l
1c10: 65 74 2d 76 61 6c 75 65 73 20 28 5b 28 78 20 79 et-values ([(x y
1c20: 29 20 28 70 72 6f 63 20 31 20 30 29 5d 29 0a 20 ) (proc 1 0)]).
1c30: 20 20 20 20 20 20 20 20 20 20 20 28 63 76 65 63 (cvec
1c40: 74 6f 72 2d 73 65 74 21 20 76 20 30 20 28 2d 20 tor-set! v 0 (-
1c50: 78 20 64 78 29 29 0a 20 20 20 20 20 20 20 20 20 x dx)).
1c60: 20 20 20 28 63 76 65 63 74 6f 72 2d 73 65 74 21 (cvector-set!
1c70: 20 76 20 31 20 28 2d 20 79 20 64 79 29 29 29 0a v 1 (- y dy))).
1c80: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2d 76 (let-v
1c90: 61 6c 75 65 73 20 28 5b 28 78 20 79 29 20 28 70 alues ([(x y) (p
1ca0: 72 6f 63 20 30 20 31 29 5d 29 0a 20 20 20 20 20 roc 0 1)]).
1cb0: 20 20 20 20 20 20 20 28 63 76 65 63 74 6f 72 2d (cvector-
1cc0: 73 65 74 21 20 76 20 32 20 28 2d 20 78 20 64 78 set! v 2 (- x dx
1cd0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 )). (
1ce0: 63 76 65 63 74 6f 72 2d 73 65 74 21 20 76 20 33 cvector-set! v 3
1cf0: 20 28 2d 20 79 20 64 79 29 29 29 29 0a 20 20 20 (- y dy)))).
1d00: 20 20 20 20 20 28 63 76 65 63 74 6f 72 2d 70 74 (cvector-pt
1d10: 72 20 76 29 29 29 29 0a 20 20 20 28 ce bb 20 28 r v)))). (λ (
1d20: 76 29 0a 20 20 20 20 20 28 61 6e 64 2d 6c 65 74 v). (and-let
1d30: 2a 20 28 5b 76 20 28 61 6e 64 20 76 20 28 6d 61 * ([v (and v (ma
1d40: 6b 65 2d 63 76 65 63 74 6f 72 2a 20 76 20 5f 64 ke-cvector* v _d
1d50: 6f 75 62 6c 65 2a 20 36 29 29 5d 29 0a 20 20 20 ouble* 6))]).
1d60: 20 20 20 20 28 6c 65 74 20 28 5b 73 78 30 20 28 (let ([sx0 (
1d70: 63 76 65 63 74 6f 72 2d 72 65 66 20 76 20 30 29 cvector-ref v 0)
1d80: 5d 20 5b 73 78 31 20 28 63 76 65 63 74 6f 72 2d ] [sx1 (cvector-
1d90: 72 65 66 20 76 20 31 29 5d 0a 20 20 20 20 20 20 ref v 1)].
1da0: 20 20 20 20 20 20 20 5b 73 79 30 20 28 63 76 65 [sy0 (cve
1db0: 63 74 6f 72 2d 72 65 66 20 76 20 32 29 5d 20 5b ctor-ref v 2)] [
1dc0: 73 79 31 20 28 63 76 65 63 74 6f 72 2d 72 65 66 sy1 (cvector-ref
1dd0: 20 76 20 33 29 5d 0a 20 20 20 20 20 20 20 20 20 v 3)].
1de0: 20 20 20 20 5b 64 78 20 28 63 76 65 63 74 6f 72 [dx (cvector
1df0: 2d 72 65 66 20 76 20 34 29 5d 20 5b 64 79 20 28 -ref v 4)] [dy (
1e00: 63 76 65 63 74 6f 72 2d 72 65 66 20 76 20 35 29 cvector-ref v 5)
1e10: 5d 29 0a 20 20 20 20 20 20 20 20 20 28 ce bb 20 ]). (λ
1e20: 28 78 20 79 29 0a 20 20 20 20 20 20 20 20 20 20 (x y).
1e30: 20 28 76 61 6c 75 65 73 0a 20 20 20 20 20 20 20 (values.
1e40: 20 20 20 20 20 28 2b 20 28 2a 20 73 78 30 20 78 (+ (* sx0 x
1e50: 29 20 28 2a 20 73 79 30 20 79 29 20 64 78 29 0a ) (* sy0 y) dx).
1e60: 20 20 20 20 20 20 20 20 20 20 20 20 28 2b 20 28 (+ (
1e70: 2a 20 73 78 31 20 78 29 20 28 2a 20 73 79 31 20 * sx1 x) (* sy1
1e80: 79 29 20 64 79 29 29 29 29 29 29 29 29 0a 0a 28 y) dy))))))))..(
1e90: 64 65 66 69 6e 65 20 63 61 6e 76 61 73 2d 74 72 define canvas-tr
1ea0: 61 6e 73 66 6f 72 6d 2d 73 65 74 21 0a 20 20 28 ansform-set!. (
1eb0: 67 65 74 2d 66 66 69 2d 6f 62 6a 0a 20 20 20 22 get-ffi-obj. "
1ec0: 63 64 43 61 6e 76 61 73 54 72 61 6e 73 66 6f 72 cdCanvasTransfor
1ed0: 6d 22 20 6c 69 62 63 64 0a 20 20 20 28 5f 66 75 m" libcd. (_fu
1ee0: 6e 20 5b 63 61 6e 76 61 73 20 3a 20 5f 63 61 6e n [canvas : _can
1ef0: 76 61 73 5d 20 5b 74 72 61 6e 73 66 6f 72 6d 20 vas] [transform
1f00: 3a 20 5f 74 72 61 6e 73 66 6f 72 6d 5d 20 2d 3e : _transform] ->
1f10: 20 5f 76 6f 69 64 29 29 29 0a 0a 28 64 65 66 69 _void)))..(defi
1f20: 6e 65 20 63 61 6e 76 61 73 2d 74 72 61 6e 73 66 ne canvas-transf
1f30: 6f 72 6d 0a 20 20 28 67 65 74 74 65 72 2d 77 69 orm. (getter-wi
1f40: 74 68 2d 73 65 74 74 65 72 0a 20 20 20 28 67 65 th-setter. (ge
1f50: 74 2d 66 66 69 2d 6f 62 6a 0a 20 20 20 20 22 63 t-ffi-obj. "c
1f60: 64 43 61 6e 76 61 73 47 65 74 54 72 61 6e 73 66 dCanvasGetTransf
1f70: 6f 72 6d 22 20 6c 69 62 63 64 0a 20 20 20 20 28 orm" libcd. (
1f80: 5f 66 75 6e 20 5b 63 61 6e 76 61 73 20 3a 20 5f _fun [canvas : _
1f90: 63 61 6e 76 61 73 5d 20 2d 3e 20 5b 74 72 61 6e canvas] -> [tran
1fa0: 73 66 6f 72 6d 20 3a 20 5f 74 72 61 6e 73 66 6f sform : _transfo
1fb0: 72 6d 5d 29 29 0a 20 20 20 63 61 6e 76 61 73 2d rm])). canvas-
1fc0: 74 72 61 6e 73 66 6f 72 6d 2d 73 65 74 21 29 29 transform-set!))
1fd0: 0a 0a 28 64 65 66 69 6e 65 20 63 61 6e 76 61 73 ..(define canvas
1fe0: 2d 74 72 61 6e 73 66 6f 72 6d 2d 63 6f 6d 70 6f -transform-compo
1ff0: 73 65 21 0a 20 20 28 67 65 74 2d 66 66 69 2d 6f se!. (get-ffi-o
2000: 62 6a 0a 20 20 20 22 63 64 43 61 6e 76 61 73 54 bj. "cdCanvasT
2010: 72 61 6e 73 66 6f 72 6d 4d 75 6c 74 69 70 6c 79 ransformMultiply
2020: 22 20 6c 69 62 63 64 0a 20 20 20 28 5f 66 75 6e " libcd. (_fun
2030: 20 5b 63 61 6e 76 61 73 20 3a 20 5f 63 61 6e 76 [canvas : _canv
2040: 61 73 5d 20 5b 74 72 61 6e 73 66 6f 72 6d 20 3a as] [transform :
2050: 20 5f 74 72 61 6e 73 66 6f 72 6d 5d 20 2d 3e 20 _transform] ->
2060: 5f 76 6f 69 64 29 29 29 0a 0a 28 64 65 66 69 6e _void)))..(defin
2070: 65 20 63 61 6e 76 61 73 2d 74 72 61 6e 73 66 6f e canvas-transfo
2080: 72 6d 2d 74 72 61 6e 73 6c 61 74 65 21 0a 20 20 rm-translate!.
2090: 28 67 65 74 2d 66 66 69 2d 6f 62 6a 0a 20 20 20 (get-ffi-obj.
20a0: 22 63 64 43 61 6e 76 61 73 54 72 61 6e 73 66 6f "cdCanvasTransfo
20b0: 72 6d 54 72 61 6e 73 6c 61 74 65 22 20 6c 69 62 rmTranslate" lib
20c0: 63 64 0a 20 20 20 28 5f 66 75 6e 20 5b 63 61 6e cd. (_fun [can
20d0: 76 61 73 20 3a 20 5f 63 61 6e 76 61 73 5d 20 5b vas : _canvas] [
20e0: 64 78 20 3a 20 5f 64 6f 75 62 6c 65 2a 5d 20 5b dx : _double*] [
20f0: 64 79 20 3a 20 5f 64 6f 75 62 6c 65 2a 5d 20 2d dy : _double*] -
2100: 3e 20 5f 76 6f 69 64 29 29 29 0a 0a 28 64 65 66 > _void)))..(def
2110: 69 6e 65 20 63 61 6e 76 61 73 2d 74 72 61 6e 73 ine canvas-trans
2120: 66 6f 72 6d 2d 73 63 61 6c 65 21 0a 20 20 28 67 form-scale!. (g
2130: 65 74 2d 66 66 69 2d 6f 62 6a 0a 20 20 20 22 63 et-ffi-obj. "c
2140: 64 43 61 6e 76 61 73 54 72 61 6e 73 66 6f 72 6d dCanvasTransform
2150: 53 63 61 6c 65 22 20 6c 69 62 63 64 0a 20 20 20 Scale" libcd.
2160: 28 5f 66 75 6e 20 5b 63 61 6e 76 61 73 20 3a 20 (_fun [canvas :
2170: 5f 63 61 6e 76 61 73 5d 20 5b 73 78 20 3a 20 5f _canvas] [sx : _
2180: 64 6f 75 62 6c 65 2a 5d 20 5b 73 79 20 3a 20 5f double*] [sy : _
2190: 64 6f 75 62 6c 65 2a 5d 20 2d 3e 20 5f 76 6f 69 double*] -> _voi
21a0: 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 61 d)))..(define ca
21b0: 6e 76 61 73 2d 74 72 61 6e 73 66 6f 72 6d 2d 72 nvas-transform-r
21c0: 6f 74 61 74 65 21 0a 20 20 28 67 65 74 2d 66 66 otate!. (get-ff
21d0: 69 2d 6f 62 6a 0a 20 20 20 22 63 64 43 61 6e 76 i-obj. "cdCanv
21e0: 61 73 54 72 61 6e 73 66 6f 72 6d 52 6f 74 61 74 asTransformRotat
21f0: 65 22 20 6c 69 62 63 64 0a 20 20 20 28 5f 66 75 e" libcd. (_fu
2200: 6e 20 5b 63 61 6e 76 61 73 20 3a 20 5f 63 61 6e n [canvas : _can
2210: 76 61 73 5d 20 5b 61 6c 70 68 61 20 3a 20 5f 64 vas] [alpha : _d
2220: 6f 75 62 6c 65 2a 5d 20 2d 3e 20 5f 76 6f 69 64 ouble*] -> _void
2230: 29 29 29 0a 0a 28 70 72 6f 76 69 64 65 0a 20 63 )))..(provide. c
2240: 61 6e 76 61 73 2d 73 69 7a 65 0a 20 63 61 6e 76 anvas-size. canv
2250: 61 73 2d 6d 6d 2d 3e 70 78 20 63 61 6e 76 61 73 as-mm->px canvas
2260: 2d 70 78 2d 3e 6d 6d 0a 20 63 61 6e 76 61 73 2d -px->mm. canvas-
2270: 6f 72 69 67 69 6e 20 63 61 6e 76 61 73 2d 6f 72 origin canvas-or
2280: 69 67 69 6e 2d 73 65 74 21 0a 20 63 61 6e 76 61 igin-set!. canva
2290: 73 2d 74 72 61 6e 73 66 6f 72 6d 20 63 61 6e 76 s-transform canv
22a0: 61 73 2d 74 72 61 6e 73 66 6f 72 6d 2d 73 65 74 as-transform-set
22b0: 21 0a 20 63 61 6e 76 61 73 2d 74 72 61 6e 73 66 !. canvas-transf
22c0: 6f 72 6d 2d 63 6f 6d 70 6f 73 65 21 0a 20 63 61 orm-compose!. ca
22d0: 6e 76 61 73 2d 74 72 61 6e 73 66 6f 72 6d 2d 74 nvas-transform-t
22e0: 72 61 6e 73 6c 61 74 65 21 0a 20 63 61 6e 76 61 ranslate!. canva
22f0: 73 2d 74 72 61 6e 73 66 6f 72 6d 2d 73 63 61 6c s-transform-scal
2300: 65 21 0a 20 63 61 6e 76 61 73 2d 74 72 61 6e 73 e!. canvas-trans
2310: 66 6f 72 6d 2d 72 6f 74 61 74 65 21 29 0a 0a 3b form-rotate!)..;
2320: 3b 20 7d 7d 7d 0a 0a 3b 3b 20 7b 7b 7b 20 47 65 ; }}}..;; {{{ Ge
2330: 6e 65 72 61 6c 20 61 74 74 72 69 62 75 74 65 73 neral attributes
2340: 0a 0a 28 64 65 66 69 6e 65 20 63 61 6e 76 61 73 ..(define canvas
2350: 2d 66 6f 72 65 67 72 6f 75 6e 64 2d 73 65 74 21 -foreground-set!
2360: 0a 20 20 28 67 65 74 2d 66 66 69 2d 6f 62 6a 0a . (get-ffi-obj.
2370: 20 20 20 22 63 64 43 61 6e 76 61 73 53 65 74 46 "cdCanvasSetF
2380: 6f 72 65 67 72 6f 75 6e 64 22 20 6c 69 62 63 64 oreground" libcd
2390: 0a 20 20 20 28 5f 66 75 6e 20 5b 63 61 6e 76 61 . (_fun [canva
23a0: 73 20 3a 20 5f 63 61 6e 76 61 73 5d 20 5b 63 6f s : _canvas] [co
23b0: 6c 6f 72 20 3a 20 5f 75 6c 6f 6e 67 5d 20 2d 3e lor : _ulong] ->
23c0: 20 5f 76 6f 69 64 29 29 29 0a 0a 28 64 65 66 69 _void)))..(defi
23d0: 6e 65 20 63 61 6e 76 61 73 2d 66 6f 72 65 67 72 ne canvas-foregr
23e0: 6f 75 6e 64 0a 20 20 28 67 65 74 74 65 72 2d 77 ound. (getter-w
23f0: 69 74 68 2d 73 65 74 74 65 72 0a 20 20 20 28 67 ith-setter. (g
2400: 65 74 2d 66 66 69 2d 6f 62 6a 0a 20 20 20 20 22 et-ffi-obj. "
2410: 63 64 43 61 6e 76 61 73 46 6f 72 65 67 72 6f 75 cdCanvasForegrou
2420: 6e 64 22 20 6c 69 62 63 64 0a 20 20 20 20 28 5f nd" libcd. (_
2430: 66 75 6e 20 5b 63 61 6e 76 61 73 20 3a 20 5f 63 fun [canvas : _c
2440: 61 6e 76 61 73 5d 20 5b 71 75 65 72 79 20 3a 20 anvas] [query :
2450: 5f 6c 6f 6e 67 20 3d 20 2d 31 5d 20 2d 3e 20 5b _long = -1] -> [
2460: 63 6f 6c 6f 72 20 3a 20 5f 75 6c 6f 6e 67 5d 29 color : _ulong])
2470: 29 0a 20 20 20 63 61 6e 76 61 73 2d 66 6f 72 65 ). canvas-fore
2480: 67 72 6f 75 6e 64 2d 73 65 74 21 29 29 0a 0a 28 ground-set!))..(
2490: 64 65 66 69 6e 65 20 63 61 6e 76 61 73 2d 62 61 define canvas-ba
24a0: 63 6b 67 72 6f 75 6e 64 2d 73 65 74 21 0a 20 20 ckground-set!.
24b0: 28 67 65 74 2d 66 66 69 2d 6f 62 6a 0a 20 20 20 (get-ffi-obj.
24c0: 22 63 64 43 61 6e 76 61 73 53 65 74 42 61 63 6b "cdCanvasSetBack
24d0: 67 72 6f 75 6e 64 22 20 6c 69 62 63 64 0a 20 20 ground" libcd.
24e0: 20 28 5f 66 75 6e 20 5b 63 61 6e 76 61 73 20 3a (_fun [canvas :
24f0: 20 5f 63 61 6e 76 61 73 5d 20 5b 63 6f 6c 6f 72 _canvas] [color
2500: 20 3a 20 5f 75 6c 6f 6e 67 5d 20 2d 3e 20 5f 76 : _ulong] -> _v
2510: 6f 69 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 oid)))..(define
2520: 63 61 6e 76 61 73 2d 62 61 63 6b 67 72 6f 75 6e canvas-backgroun
2530: 64 0a 20 20 28 67 65 74 74 65 72 2d 77 69 74 68 d. (getter-with
2540: 2d 73 65 74 74 65 72 0a 20 20 20 28 67 65 74 2d -setter. (get-
2550: 66 66 69 2d 6f 62 6a 0a 20 20 20 20 22 63 64 43 ffi-obj. "cdC
2560: 61 6e 76 61 73 42 61 63 6b 67 72 6f 75 6e 64 22 anvasBackground"
2570: 20 6c 69 62 63 64 0a 20 20 20 20 28 5f 66 75 6e libcd. (_fun
2580: 20 5b 63 61 6e 76 61 73 20 3a 20 5f 63 61 6e 76 [canvas : _canv
2590: 61 73 5d 20 5b 71 75 65 72 79 20 3a 20 5f 6c 6f as] [query : _lo
25a0: 6e 67 20 3d 20 2d 31 5d 20 2d 3e 20 5b 63 6f 6c ng = -1] -> [col
25b0: 6f 72 20 3a 20 5f 75 6c 6f 6e 67 5d 29 29 0a 20 or : _ulong])).
25c0: 20 20 63 61 6e 76 61 73 2d 62 61 63 6b 67 72 6f canvas-backgro
25d0: 75 6e 64 2d 73 65 74 21 29 29 0a 0a 28 64 65 66 und-set!))..(def
25e0: 69 6e 65 20 5f 77 72 69 74 65 2d 6d 6f 64 65 0a ine _write-mode.
25f0: 20 20 28 5f 65 6e 75 6d 20 27 28 72 65 70 6c 61 (_enum '(repla
2600: 63 65 20 78 6f 72 20 6e 6f 74 2d 78 6f 72 29 29 ce xor not-xor))
2610: 29 0a 0a 28 64 65 66 69 6e 65 20 63 61 6e 76 61 )..(define canva
2620: 73 2d 77 72 69 74 65 2d 6d 6f 64 65 2d 73 65 74 s-write-mode-set
2630: 21 0a 20 20 28 67 65 74 2d 66 66 69 2d 6f 62 6a !. (get-ffi-obj
2640: 0a 20 20 20 22 63 64 43 61 6e 76 61 73 57 72 69 . "cdCanvasWri
2650: 74 65 4d 6f 64 65 22 20 6c 69 62 63 64 0a 20 20 teMode" libcd.
2660: 20 28 5f 66 75 6e 20 5b 63 61 6e 76 61 73 20 3a (_fun [canvas :
2670: 20 5f 63 61 6e 76 61 73 5d 20 5b 6d 6f 64 65 20 _canvas] [mode
2680: 3a 20 5f 77 72 69 74 65 2d 6d 6f 64 65 5d 20 2d : _write-mode] -
2690: 3e 20 5f 76 6f 69 64 29 29 29 0a 0a 28 64 65 66 > _void)))..(def
26a0: 69 6e 65 20 63 61 6e 76 61 73 2d 77 72 69 74 65 ine canvas-write
26b0: 2d 6d 6f 64 65 0a 20 20 28 67 65 74 74 65 72 2d -mode. (getter-
26c0: 77 69 74 68 2d 73 65 74 74 65 72 0a 20 20 20 28 with-setter. (
26d0: 67 65 74 2d 66 66 69 2d 6f 62 6a 0a 20 20 20 20 get-ffi-obj.
26e0: 22 63 64 43 61 6e 76 61 73 57 72 69 74 65 4d 6f "cdCanvasWriteMo
26f0: 64 65 22 20 6c 69 62 63 64 0a 20 20 20 20 28 5f de" libcd. (_
2700: 66 75 6e 20 5b 63 61 6e 76 61 73 20 3a 20 5f 63 fun [canvas : _c
2710: 61 6e 76 61 73 5d 20 5b 71 75 65 72 79 20 3a 20 anvas] [query :
2720: 5f 66 69 78 69 6e 74 20 3d 20 2d 31 5d 20 2d 3e _fixint = -1] ->
2730: 20 5b 6d 6f 64 65 20 3a 20 5f 77 72 69 74 65 2d [mode : _write-
2740: 6d 6f 64 65 5d 29 29 0a 20 20 20 63 61 6e 76 61 mode])). canva
2750: 73 2d 77 72 69 74 65 2d 6d 6f 64 65 2d 73 65 74 s-write-mode-set
2760: 21 29 29 0a 0a 28 70 72 6f 76 69 64 65 0a 20 63 !))..(provide. c
2770: 61 6e 76 61 73 2d 66 6f 72 65 67 72 6f 75 6e 64 anvas-foreground
2780: 20 63 61 6e 76 61 73 2d 66 6f 72 65 67 72 6f 75 canvas-foregrou
2790: 6e 64 2d 73 65 74 21 0a 20 63 61 6e 76 61 73 2d nd-set!. canvas-
27a0: 62 61 63 6b 67 72 6f 75 6e 64 20 63 61 6e 76 61 background canva
27b0: 73 2d 62 61 63 6b 67 72 6f 75 6e 64 2d 73 65 74 s-background-set
27c0: 21 0a 20 63 61 6e 76 61 73 2d 77 72 69 74 65 2d !. canvas-write-
27d0: 6d 6f 64 65 20 63 61 6e 76 61 73 2d 77 72 69 74 mode canvas-writ
27e0: 65 2d 6d 6f 64 65 2d 73 65 74 21 29 0a 0a 3b 3b e-mode-set!)..;;
27f0: 20 7d 7d 7d 0a 0a 3b 3b 20 7b 7b 7b 20 43 6c 69 }}}..;; {{{ Cli
2800: 70 70 69 6e 67 0a 0a 28 64 65 66 69 6e 65 20 5f pping..(define _
2810: 63 6c 69 70 2d 6d 6f 64 65 0a 20 20 28 5f 65 6e clip-mode. (_en
2820: 75 6d 20 27 28 23 66 20 61 72 65 61 20 70 6f 6c um '(#f area pol
2830: 79 67 6f 6e 20 72 65 67 69 6f 6e 29 29 29 0a 0a ygon region)))..
2840: 28 64 65 66 69 6e 65 20 63 61 6e 76 61 73 2d 63 (define canvas-c
2850: 6c 69 70 2d 6d 6f 64 65 2d 73 65 74 21 0a 20 20 lip-mode-set!.
2860: 28 67 65 74 2d 66 66 69 2d 6f 62 6a 0a 20 20 20 (get-ffi-obj.
2870: 22 63 64 43 61 6e 76 61 73 43 6c 69 70 22 20 6c "cdCanvasClip" l
2880: 69 62 63 64 0a 20 20 20 28 5f 66 75 6e 20 5b 63 ibcd. (_fun [c
2890: 61 6e 76 61 73 20 3a 20 5f 63 61 6e 76 61 73 5d anvas : _canvas]
28a0: 20 5b 6d 6f 64 65 20 3a 20 5f 63 6c 69 70 2d 6d [mode : _clip-m
28b0: 6f 64 65 5d 20 2d 3e 20 5f 76 6f 69 64 29 29 29 ode] -> _void)))
28c0: 0a 0a 28 64 65 66 69 6e 65 20 63 61 6e 76 61 73 ..(define canvas
28d0: 2d 63 6c 69 70 2d 6d 6f 64 65 0a 20 20 28 67 65 -clip-mode. (ge
28e0: 74 74 65 72 2d 77 69 74 68 2d 73 65 74 74 65 72 tter-with-setter
28f0: 0a 20 20 20 28 67 65 74 2d 66 66 69 2d 6f 62 6a . (get-ffi-obj
2900: 0a 20 20 20 20 22 63 64 43 61 6e 76 61 73 43 6c . "cdCanvasCl
2910: 69 70 22 20 6c 69 62 63 64 0a 20 20 20 20 28 5f ip" libcd. (_
2920: 66 75 6e 20 5b 63 61 6e 76 61 73 20 3a 20 5f 63 fun [canvas : _c
2930: 61 6e 76 61 73 5d 20 5b 71 75 65 72 79 20 3a 20 anvas] [query :
2940: 5f 66 69 78 69 6e 74 20 3d 20 2d 31 5d 20 2d 3e _fixint = -1] ->
2950: 20 5b 6d 6f 64 65 20 3a 20 5f 63 6c 69 70 2d 6d [mode : _clip-m
2960: 6f 64 65 5d 29 29 0a 20 20 20 63 61 6e 76 61 73 ode])). canvas
2970: 2d 63 6c 69 70 2d 6d 6f 64 65 2d 73 65 74 21 29 -clip-mode-set!)
2980: 29 0a 0a 28 64 65 66 69 6e 65 20 63 61 6e 76 61 )..(define canva
2990: 73 2d 63 6c 69 70 2d 61 72 65 61 2d 73 65 74 21 s-clip-area-set!
29a0: 0a 20 20 28 67 65 74 2d 66 66 69 2d 6f 62 6a 0a . (get-ffi-obj.
29b0: 20 20 20 22 63 64 66 43 61 6e 76 61 73 43 6c 69 "cdfCanvasCli
29c0: 70 41 72 65 61 22 20 6c 69 62 63 64 0a 20 20 20 pArea" libcd.
29d0: 28 5f 66 75 6e 20 5b 63 61 6e 76 61 73 20 3a 20 (_fun [canvas :
29e0: 5f 63 61 6e 76 61 73 5d 20 5b 78 30 20 3a 20 5f _canvas] [x0 : _
29f0: 64 6f 75 62 6c 65 2a 5d 20 5b 78 31 20 3a 20 5f double*] [x1 : _
2a00: 64 6f 75 62 6c 65 2a 5d 20 5b 79 30 20 3a 20 5f double*] [y0 : _
2a10: 64 6f 75 62 6c 65 2a 5d 20 5b 79 31 20 3a 20 5f double*] [y1 : _
2a20: 64 6f 75 62 6c 65 2a 5d 20 2d 3e 20 5f 76 6f 69 double*] -> _voi
2a30: 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 61 d)))..(define ca
2a40: 6e 76 61 73 2d 63 6c 69 70 2d 61 72 65 61 0a 20 nvas-clip-area.
2a50: 20 28 67 65 74 2d 66 66 69 2d 6f 62 6a 0a 20 20 (get-ffi-obj.
2a60: 20 22 63 64 66 43 61 6e 76 61 73 47 65 74 43 6c "cdfCanvasGetCl
2a70: 69 70 41 72 65 61 22 20 6c 69 62 63 64 0a 20 20 ipArea" libcd.
2a80: 20 28 5f 66 75 6e 20 5b 63 61 6e 76 61 73 20 3a (_fun [canvas :
2a90: 20 5f 63 61 6e 76 61 73 5d 0a 20 20 20 20 20 20 _canvas].
2aa0: 20 20 20 5b 78 30 20 3a 20 28 5f 70 74 72 20 6f [x0 : (_ptr o
2ab0: 20 5f 64 6f 75 62 6c 65 29 5d 20 5b 78 31 20 3a _double)] [x1 :
2ac0: 20 28 5f 70 74 72 20 6f 20 5f 64 6f 75 62 6c 65 (_ptr o _double
2ad0: 29 5d 0a 20 20 20 20 20 20 20 20 20 5b 79 30 20 )]. [y0
2ae0: 3a 20 28 5f 70 74 72 20 6f 20 5f 64 6f 75 62 6c : (_ptr o _doubl
2af0: 65 29 5d 20 5b 79 31 20 3a 20 28 5f 70 74 72 20 e)] [y1 : (_ptr
2b00: 6f 20 5f 64 6f 75 62 6c 65 29 5d 0a 20 20 20 20 o _double)].
2b10: 20 20 20 20 20 2d 3e 20 5f 76 6f 69 64 0a 20 20 -> _void.
2b20: 20 20 20 20 20 20 20 2d 3e 20 28 76 61 6c 75 65 -> (value
2b30: 73 20 78 30 20 78 31 20 79 30 20 79 31 29 29 29 s x0 x1 y0 y1)))
2b40: 29 0a 0a 28 70 72 6f 76 69 64 65 0a 20 63 61 6e )..(provide. can
2b50: 76 61 73 2d 63 6c 69 70 2d 6d 6f 64 65 20 63 61 vas-clip-mode ca
2b60: 6e 76 61 73 2d 63 6c 69 70 2d 6d 6f 64 65 2d 73 nvas-clip-mode-s
2b70: 65 74 21 0a 20 63 61 6e 76 61 73 2d 63 6c 69 70 et!. canvas-clip
2b80: 2d 61 72 65 61 20 63 61 6e 76 61 73 2d 63 6c 69 -area canvas-cli
2b90: 70 2d 61 72 65 61 2d 73 65 74 21 29 0a 0a 3b 3b p-area-set!)..;;
2ba0: 20 7d 7d 7d 0a }}}.