(require-library data-structures srfi-4 canvas-draw-base)
(module canvas-draw-primitives
(canvas-pixel!
canvas-mark!
canvas-mark-type canvas-mark-type-set!
canvas-mark-size canvas-mark-size-set!
canvas-line! canvas-rectangle! canvas-arc!
canvas-line-style canvas-line-style-set!
canvas-line-width canvas-line-width-set!
canvas-line-join canvas-line-join-set!
canvas-line-cap canvas-line-cap-set!
canvas-box! canvas-sector! canvas-chord!
canvas-background-opacity canvas-background-opacity-set!
canvas-fill-mode canvas-fill-mode-set!
canvas-interior-style canvas-interior-style-set!
canvas-text!
canvas-font canvas-font-set!
canvas-text-alignment canvas-text-alignment-set!
canvas-text-orientation canvas-text-orientation-set!
canvas-font-dimensions canvas-text-size canvas-text-box
call-with-canvas-in-mode canvas-path-set!
canvas-vertex!)
(import scheme chicken foreign data-structures srfi-4 canvas-draw-base)
;; {{{ Data types
(foreign-declare
"#include <cd.h>\n")
(include "canvas-draw-types.scm")
;; }}}
;; {{{ Point drawing functions
(define canvas-pixel!
(letrec ([canvas-pixel/raw!
(foreign-lambda void "cdCanvasPixel" nonnull-canvas int int unsigned-long)])
(lambda (canvas x y #!optional [color (canvas-foreground canvas)])
(canvas-pixel/raw! canvas x y color))))
(define canvas-mark!
(foreign-lambda void "cdCanvasMark" nonnull-canvas int int))
(define-values (canvas-mark-type canvas-mark-type-set!)
(letrec ([mark-types
(list
(cons
'+
(foreign-value "CD_PLUS" int))
(cons
'plus
(foreign-value "CD_PLUS" int))
(cons
'*
(foreign-value "CD_STAR" int))
(cons
'star
(foreign-value "CD_STAR" int))
(cons
'0
(foreign-value "CD_CIRCLE" int))
(cons
'circle
(foreign-value "CD_CIRCLE" int))
(cons
'O
(foreign-value "CD_HOLLOW_CIRCLE" int))
(cons
'hollow-circle
(foreign-value "CD_HOLLOW_CIRCLE" int))
(cons
'X
(foreign-value "CD_X" int))
(cons
'x
(foreign-value "CD_X" int))
(cons
'box
(foreign-value "CD_BOX" int))
(cons
'hollow-box
(foreign-value "CD_HOLLOW_BOX" int))
(cons
'diamond
(foreign-value "CD_DIAMOND" int))
(cons
'hollow-diamond
(foreign-value "CD_HOLLOW_DIAMOND" int)))]
[canvas-mark-type-set/raw!
(foreign-lambda void "cdCanvasMarkType" nonnull-canvas int)]
[canvas-mark-type-set!
(lambda (canvas mark-type)
(canvas-mark-type-set/raw!
canvas
(cond
[(assq mark-type mark-types) => cdr]
[else (error 'canvas-mark-type-set! "unknown mark type" mark-type)])))]
[canvas-mark-type/raw
(foreign-lambda* int ([nonnull-canvas canvas])
"C_return(cdCanvasMarkType(canvas, CD_QUERY));")]
[canvas-mark-type
(lambda (canvas)
(let ([mark-type (canvas-mark-type/raw canvas)])
(cond
[(rassoc mark-type mark-types) => car]
[else (error 'canvas-mark-type "unknown mark type" mark-type)])))])
(values
(getter-with-setter canvas-mark-type canvas-mark-type-set!)
canvas-mark-type-set!)))
(define canvas-mark-size-set!
(foreign-lambda void "cdCanvasMarkSize" nonnull-canvas int))
(define canvas-mark-size
(getter-with-setter
(foreign-lambda* int ([nonnull-canvas canvas])
"C_return(cdCanvasMarkSize(canvas, CD_QUERY));")
canvas-mark-size-set!))
;; }}}
;; {{{ Line functions
(define canvas-line!
(foreign-lambda void "cdfCanvasLine" nonnull-canvas double double double double))
(define canvas-rectangle!
(foreign-lambda void "cdfCanvasRect" nonnull-canvas double double double double))
(define canvas-arc!
(foreign-lambda void "cdfCanvasArc" nonnull-canvas double double double double double double))
(define-values (canvas-line-style canvas-line-style-set!)
(letrec ([line-styles
(list
(cons
'continuous
(foreign-value "CD_CONTINUOUS" int))
(cons
'dashed
(foreign-value "CD_DASHED" int))
(cons
'dotted
(foreign-value "CD_DOTTED" int))
(cons
'dash-dotted
(foreign-value "CD_DASH_DOT" int))
(cons
'dash-dot-dotted
(foreign-value "CD_DASH_DOT_DOT" int))
(cons
'custom
(foreign-value "CD_CUSTOM" int)))]
[canvas-line-style-set/raw!
(foreign-lambda void "cdCanvasLineStyle" nonnull-canvas int)]
[canvas-line-style-dashes-set/raw!
(foreign-lambda void "cdCanvasLineStyleDashes" nonnull-canvas nonnull-s32vector int)]
[canvas-line-style-set!
(lambda (canvas line-style)
(cond
[(and (pair? line-style) (eq? (car line-style) 'custom))
(let ([dashes (list->s32vector (cdr line-style))])
(canvas-line-style-dashes-set/raw! canvas dashes (s32vector-length dashes))
(canvas-line-style-set/raw! canvas (cdr (assq 'custom line-styles))))]
[else
(canvas-line-style-set/raw!
canvas
(cond
[(assq line-style line-styles) => cdr]
[else (error 'canvas-line-style-set! "unknown line style" line-style)]))]))]
[canvas-line-style/raw
(foreign-lambda* int ([nonnull-canvas canvas])
"C_return(cdCanvasLineStyle(canvas, CD_QUERY));")]
[canvas-line-style
(lambda (canvas)
(let ([line-style (canvas-line-style/raw canvas)])
(cond
[(rassoc line-style line-styles) => car]
[else (error 'canvas-line-style "unknown line style" line-style)])))])
(values
(getter-with-setter canvas-line-style canvas-line-style-set!)
canvas-line-style-set!)))
(define canvas-line-width-set!
(foreign-lambda int "cdCanvasLineWidth" nonnull-canvas int))
(define canvas-line-width
(getter-with-setter
(foreign-lambda* int ([nonnull-canvas canvas])
"C_return(cdCanvasLineWidth(canvas, CD_QUERY));")
canvas-line-width-set!))
(define-values (canvas-line-join canvas-line-join-set!)
(letrec ([line-joins
(list
(cons
'miter
(foreign-value "CD_MITER" int))
(cons
'bevel
(foreign-value "CD_BEVEL" int))
(cons
'round
(foreign-value "CD_ROUND" int)))]
[canvas-line-join-set/raw!
(foreign-lambda void "cdCanvasLineJoin" nonnull-canvas int)]
[canvas-line-join-set!
(lambda (canvas line-join)
(canvas-line-join-set/raw!
canvas
(cond
[(assq line-join line-joins) => cdr]
[else (error 'canvas-line-join-set! "unknown line join" line-join)])))]
[canvas-line-join/raw
(foreign-lambda* int ([nonnull-canvas canvas])
"C_return(cdCanvasLineJoin(canvas, CD_QUERY));")]
[canvas-line-join
(lambda (canvas)
(let ([line-join (canvas-line-join/raw canvas)])
(cond
[(rassoc line-join line-joins) => car]
[else (error 'canvas-line-join "unknown line join" line-join)])))])
(values
(getter-with-setter canvas-line-join canvas-line-join-set!)
canvas-line-join-set!)))
(define-values (canvas-line-cap canvas-line-cap-set!)
(letrec ([line-caps
(list
(cons
'flat
(foreign-value "CD_CAPFLAT" int))
(cons
'square
(foreign-value "CD_CAPSQUARE" int))
(cons
'round
(foreign-value "CD_CAPROUND" int)))]
[canvas-line-cap-set/raw!
(foreign-lambda void "cdCanvasLineCap" nonnull-canvas int)]
[canvas-line-cap-set!
(lambda (canvas line-cap)
(canvas-line-cap-set/raw!
canvas
(cond
[(assq line-cap line-caps) => cdr]
[else (error 'canvas-line-cap-set! "unknown line cap" line-cap)])))]
[canvas-line-cap/raw
(foreign-lambda* int ([nonnull-canvas canvas])
"C_return(cdCanvasLineCap(canvas, CD_QUERY));")]
[canvas-line-cap
(lambda (canvas)
(let ([line-cap (canvas-line-cap/raw canvas)])
(cond
[(rassoc line-cap line-caps) => car]
[else (error 'canvas-line-cap "unknown line cap" line-cap)])))])
(values
(getter-with-setter canvas-line-cap canvas-line-cap-set!)
canvas-line-cap-set!)))
;; }}}
;; {{{ Filled area functions
(define canvas-box!
(foreign-lambda void "cdfCanvasBox" nonnull-canvas double double double double))
(define canvas-sector!
(foreign-lambda void "cdfCanvasSector" nonnull-canvas double double double double double double))
(define canvas-chord!
(foreign-lambda void "cdfCanvasChord" nonnull-canvas double double double double double double))
(define-values (canvas-background-opacity canvas-background-opacity-set!)
(letrec ([opacities
(list
(cons
'opaque
(foreign-value "CD_OPAQUE" int))
(cons
'transparent
(foreign-value "CD_TRANSPARENT" int)))]
[canvas-background-opacity-set/raw!
(foreign-lambda void "cdCanvasBackOpacity" nonnull-canvas int)]
[canvas-background-opacity-set!
(lambda (canvas opacity)
(canvas-background-opacity-set/raw!
canvas
(cond
[(assq opacity opacities) => cdr]
[else (error 'canvas-background-opacity-set! "unknown line cap" opacity)])))]
[canvas-background-opacity/raw
(foreign-lambda* int ([nonnull-canvas canvas])
"C_return(cdCanvasBackOpacity(canvas, CD_QUERY));")]
[canvas-background-opacity
(lambda (canvas)
(let ([opacity (canvas-background-opacity/raw canvas)])
(cond
[(rassoc opacity opacities) => car]
[else (error 'canvas-background-opacity "unknown opacity" opacity)])))])
(values
(getter-with-setter canvas-background-opacity canvas-background-opacity-set!)
canvas-background-opacity-set!)))
(define-values (canvas-fill-mode canvas-fill-mode-set!)
(letrec ([fill-modes
(list
(cons
'even-odd
(foreign-value "CD_EVENODD" int))
(cons
'winding
(foreign-value "CD_WINDING" int)))]
[canvas-fill-mode-set/raw!
(foreign-lambda void "cdCanvasFillMode" nonnull-canvas int)]
[canvas-fill-mode-set!
(lambda (canvas fill-mode)
(canvas-fill-mode-set/raw!
canvas
(cond
[(assq fill-mode fill-modes) => cdr]
[else (error 'canvas-fill-mode-set! "unknown fill mode" fill-mode)])))]
[canvas-fill-mode/raw
(foreign-lambda* int ([nonnull-canvas canvas])
"C_return(cdCanvasFillMode(canvas, CD_QUERY));")]
[canvas-fill-mode
(lambda (canvas)
(let ([fill-mode (canvas-fill-mode/raw canvas)])
(cond
[(rassoc fill-mode fill-modes) => car]
[else (error 'canvas-fill-mode "unknown fill mode" fill-mode)])))])
(values
(getter-with-setter canvas-fill-mode canvas-fill-mode-set!)
canvas-fill-mode-set!)))
(define-values (canvas-interior-style canvas-interior-style-set!)
(letrec ([interior-styles
(list
(cons
'solid
(foreign-value "CD_SOLID" int))
(cons
'hollow
(foreign-value "CD_HOLLOW" int))
(cons
'hatch
(foreign-value "CD_HATCH" int))
(cons
'stipple
(foreign-value "CD_STIPPLE" int))
(cons
'pattern
(foreign-value "CD_PATTERN" int)))]
[hatch-styles
(list
(cons
'horizontal
(foreign-value "CD_HORIZONTAL" int))
(cons
'vertical
(foreign-value "CD_VERTICAL" int))
(cons
'forward-diagonal
(foreign-value "CD_FDIAGONAL" int))
(cons
'backward-diagonal
(foreign-value "CD_BDIAGONAL" int))
(cons
'cross
(foreign-value "CD_CROSS" int))
(cons
'diagonal-cross
(foreign-value "CD_DIAGCROSS" int)))]
[canvas-hatch-style-set/raw!
(foreign-lambda int "cdCanvasHatch" nonnull-canvas int)]
[canvas-hatch-style/raw
(foreign-lambda* int ([nonnull-canvas canvas])
"C_return(cdCanvasHatch(canvas, CD_QUERY));")]
[canvas-stipple-set/raw!
(foreign-lambda* void ([nonnull-canvas canvas] [int width] [int height] [nonnull-blob data])
"unsigned char mask[width * height];\n"
"int i, j;\n"
"\n"
"for (j = 0; j < height; ++j) {\n"
" for (i = 0; i < width; ++i) {\n"
" const int ofs = (j * width) + i;\n"
" mask[ofs] = (data[ofs / 8] >> (ofs % 8)) & 1;\n"
" }\n"
"}\n"
"cdCanvasStipple(canvas, width, height, mask);\n")]
[canvas-stipple/raw
(foreign-lambda* void ([nonnull-canvas canvas] [(c-pointer int) pwidth] [(c-pointer int) pheight] [blob data])
"unsigned char *mask = cdCanvasGetStipple(canvas, pwidth, pheight);\n"
"\n"
"if (data) {\n"
" int width = *pwidth, height = *pheight;\n"
" int i, j;\n"
" \n"
" for (j = 0; j < height; ++j) {\n"
" for (i = 0; i < width; ++i) {\n"
" const int ofs = (j * width) + i;\n"
" const int vofs = ofs / 8, bofs = ofs % 8;\n"
" const unsigned char bit = mask[ofs] & 1;\n"
" \n"
" if (bofs > 0)\n"
" data[vofs] |= bit << bofs;\n"
" else\n"
" data[vofs] = bit;\n"
" }\n"
" }\n"
"}\n")]
[canvas-pattern-set/rgb/raw!
(foreign-lambda* void ([nonnull-canvas canvas] [int width] [int height] [nonnull-blob data])
"long color[width * height];\n"
"int i, j;\n"
"\n"
"for (j = 0; j < height; ++j) {\n"
" for (i = 0; i < width; ++i, data += 3) {\n"
" color[(j * width) + i] =\n"
" (data[0] << 16) | (data[1] << 8) | (data[2]);\n"
" }\n"
"}\n"
"cdCanvasPattern(canvas, width, height, color);\n")]
[canvas-pattern-set/rgba/raw!
(foreign-lambda* void ([nonnull-canvas canvas] [int width] [int height] [nonnull-blob data])
"long color[width * height];\n"
"int i, j;\n"
"\n"
"for (j = 0; j < height; ++j) {\n"
" for (i = 0; i < width; ++i, data += 4) {\n"
" color[(j * width) + i] =\n"
" ((0xff - data[3]) << 24) | (data[0] << 16) | (data[1] << 8) | (data[2]);\n"
" }\n"
"}\n"
"cdCanvasPattern(canvas, width, height, color);\n")]
[canvas-pattern/rgba/raw
(foreign-lambda* void ([nonnull-canvas canvas] [(c-pointer int) pwidth] [(c-pointer int) pheight] [blob data])
"long *color = cdCanvasGetPattern(canvas, pwidth, pheight);\n"
"\n"
"if (data) {\n"
" int width = *pwidth, height = *pheight;\n"
" int i, j;\n"
" \n"
" for (j = 0; j < height; ++j) {\n"
" for (i = 0; i < width; ++i, data += 4) {\n"
" long c = color[(j * width) + i];\n"
" data[3] = 0xff - ((c >> 24) & 0xff);\n"
" data[0] = (c >> 16) & 0xff;\n"
" data[1] = (c >> 8) & 0xff;\n"
" data[2] = c & 0xff;\n"
" }\n"
" }\n"
"}\n")]
[canvas-interior-style-set/raw!
(foreign-lambda void "cdCanvasInteriorStyle" nonnull-canvas int)]
[canvas-interior-style-set!
(lambda (canvas interior-style)
(case (and (pair? interior-style) (car interior-style))
[(hatch)
(let ([hatch-style (cadr interior-style)])
(canvas-hatch-style-set/raw!
canvas
(cond
[(assq hatch-style hatch-styles) => cdr]
[else (error 'canvas-interior-style-set! "unknown hatch style" hatch-style)]))
(canvas-interior-style-set/raw! canvas (cdr (assq 'hatch interior-styles))))]
[(stipple)
(let ([width (cadr interior-style)]
[height (caddr interior-style)]
[data (cadddr interior-style)])
(unless (= (blob-size data) (ceiling (/ (* width height) 8)))
(error 'canvas-interior-style-set! "bad stipple data length" (blob-size data) (ceiling (/ (* width height) 8))))
(canvas-stipple-set/raw! canvas width height data)
(canvas-interior-style-set/raw! canvas (cdr (assq 'stipple interior-styles))))]
[(pattern/rgb)
(let ([width (cadr interior-style)]
[height (caddr interior-style)]
[data (cadddr interior-style)])
(unless (= (blob-size data) (* 3 width height))
(error 'canvas-interior-style-set! "bad pattern data length" (blob-size data) (* 3 width height)))
(canvas-pattern-set/rgb/raw! canvas width height data)
(canvas-interior-style-set/raw! canvas (cdr (assq 'pattern interior-styles))))]
[(pattern/rgba)
(let ([width (cadr interior-style)]
[height (caddr interior-style)]
[data (cadddr interior-style)])
(unless (= (blob-size data) (* 4 width height))
(error 'canvas-interior-style-set! "bad pattern data length" (blob-size data) (* 4 width height)))
(canvas-pattern-set/rgba/raw! canvas width height data)
(canvas-interior-style-set/raw! canvas (cdr (assq 'pattern interior-styles))))]
[else
(canvas-interior-style-set/raw!
canvas
(cond
[(assq interior-style interior-styles) => cdr]
[else (error 'canvas-interior-style-set! "unknown interior style" interior-style)]))]))]
[canvas-interior-style/raw
(foreign-lambda* int ([nonnull-canvas canvas])
"C_return(cdCanvasInteriorStyle(canvas, CD_QUERY));")]
[canvas-interior-style
(lambda (canvas)
(let* ([interior-style (canvas-interior-style/raw canvas)]
[interior-style
(cond
[(rassoc interior-style interior-styles) => car]
[else (error 'canvas-interior-style "unknown interior style" interior-style)])])
(case interior-style
[(hatch)
(let ([hatch-style (canvas-hatch-style/raw canvas)])
(list
'hatch
(cond
[(rassoc hatch-style hatch-styles) => car]
[else (error 'canvas-interior-style "unknown hatch style" hatch-style)])))]
[(stipple)
(let-location ([width int 0] [height int 0])
(canvas-stipple/raw canvas (location width) (location height) #f)
(let ([data (make-blob (inexact->exact (ceiling (/ (* width height) 8))))])
(canvas-stipple/raw canvas (location width) (location height) data)
(list 'stipple width height data)))]
[(pattern)
(let-location ([width int 0] [height int 0])
(canvas-pattern/rgba/raw canvas (location width) (location height) #f)
(let ([data (make-blob (* 4 width height))])
(canvas-pattern/rgba/raw canvas (location width) (location height) data)
(list 'pattern/rgba width height data)))]
[else
interior-style])))])
(values
(getter-with-setter canvas-interior-style canvas-interior-style-set!)
canvas-interior-style-set!)))
;; }}}
;; {{{ Text functions
(define canvas-text!
(foreign-lambda void "cdfCanvasText" nonnull-canvas double double nonnull-c-string))
(define canvas-font-set!
(foreign-lambda c-string "cdCanvasNativeFont" nonnull-canvas nonnull-c-string))
(define canvas-font
(getter-with-setter
(foreign-lambda* c-string ([nonnull-canvas canvas])
"C_return(cdCanvasNativeFont(canvas, NULL));")
canvas-font-set!))
(define-values (canvas-text-alignment canvas-text-alignment-set!)
(letrec ([alignments
(list
(cons
'north
(foreign-value "CD_NORTH" int))
(cons
'south
(foreign-value "CD_SOUTH" int))
(cons
'east
(foreign-value "CD_EAST" int))
(cons
'west
(foreign-value "CD_WEST" int))
(cons
'north-east
(foreign-value "CD_NORTH_EAST" int))
(cons
'north-west
(foreign-value "CD_NORTH_WEST" int))
(cons
'south-east
(foreign-value "CD_SOUTH_EAST" int))
(cons
'south-west
(foreign-value "CD_SOUTH_WEST" int))
(cons
'center
(foreign-value "CD_CENTER" int))
(cons
'base-left
(foreign-value "CD_BASE_LEFT" int))
(cons
'base-center
(foreign-value "CD_BASE_CENTER" int))
(cons
'base-right
(foreign-value "CD_BASE_RIGHT" int)))]
[canvas-text-alignment-set/raw!
(foreign-lambda void "cdCanvasTextAlignment" nonnull-canvas int)]
[canvas-text-alignment-set!
(lambda (canvas alignment)
(canvas-text-alignment-set/raw!
canvas
(cond
[(assq alignment alignments) => cdr]
[else (error 'canvas-text-alignment-set! "unknown alignment" alignment)])))]
[canvas-text-alignment/raw
(foreign-lambda* int ([nonnull-canvas canvas])
"C_return(cdCanvasTextAlignment(canvas, CD_QUERY));")]
[canvas-text-alignment
(lambda (canvas)
(let ([alignment (canvas-text-alignment/raw canvas)])
(cond
[(rassoc alignment alignments) => car]
[else (error 'canvas-text-alignment "unknown alignment" alignment)])))])
(values
(getter-with-setter canvas-text-alignment canvas-text-alignment-set!)
canvas-text-alignment-set!)))
(define canvas-text-orientation-set!
(foreign-lambda void "cdCanvasTextOrientation" nonnull-canvas double))
(define canvas-text-orientation
(getter-with-setter
(foreign-lambda* double ([nonnull-canvas canvas])
"C_return(cdCanvasTextOrientation(canvas, CD_QUERY));")
canvas-text-orientation-set!))
(define canvas-font-dimensions
(letrec ([canvas-font-dimensions/raw
(foreign-lambda void "cdCanvasGetFontDim" nonnull-canvas (c-pointer int) (c-pointer int) (c-pointer int) (c-pointer int))])
(lambda (canvas)
(let-location ([max-width int 0]
[height int 0]
[ascent int 0]
[descent int 0])
(canvas-font-dimensions/raw canvas (location max-width) (location height) (location ascent) (location descent))
(values max-width height ascent descent)))))
(define canvas-text-size
(letrec ([canvas-text-size/raw
(foreign-lambda void "cdCanvasGetTextSize" nonnull-canvas nonnull-c-string (c-pointer int) (c-pointer int))])
(lambda (canvas text)
(let-location ([width int 0] [height int 0])
(canvas-text-size/raw canvas text (location width) (location height))
(values width height)))))
(define canvas-text-box
(letrec ([canvas-text-box/raw
(foreign-lambda void "cdCanvasGetTextBox" nonnull-canvas int int nonnull-c-string (c-pointer int) (c-pointer int) (c-pointer int) (c-pointer int))])
(lambda (canvas x y text)
(let-location ([x0 int 0] [x1 int 0]
[y0 int 0] [y1 int 0])
(canvas-text-box/raw canvas x y text (location x0) (location x1) (location y0) (location y1))
(values x0 x1 y0 y1)))))
;; }}}
;; {{{ Vertex functions
(define call-with-canvas-in-mode
(letrec ([canvas-modes
(list
(cons
'open-lines
(foreign-value "CD_OPEN_LINES" int))
(cons
'closed-lines
(foreign-value "CD_CLOSED_LINES" int))
(cons
'fill
(foreign-value "CD_FILL" int))
(cons
'clip
(foreign-value "CD_CLIP" int))
(cons
'bezier
(foreign-value "CD_BEZIER" int))
(cons
'region
(foreign-value "CD_REGION" int))
(cons
'path
(foreign-value "CD_PATH" int)))]
[canvas-begin
(foreign-lambda void "cdCanvasBegin" nonnull-canvas int)]
[canvas-end
(foreign-lambda void "cdCanvasEnd" nonnull-canvas)])
(lambda (canvas canvas-mode proc)
(let ([canvas-mode
(cond
[(assq canvas-mode canvas-modes) => cdr]
[else (error 'with-canvas-mode "unknown canvas mode" canvas-mode)])])
(dynamic-wind
(cut canvas-begin canvas canvas-mode)
(cut proc canvas)
(cut canvas-end canvas))))))
(define canvas-path-set!
(letrec ([path-actions
(list
(cons
'new
(foreign-value "CD_PATH_NEW" int))
(cons
'move-to
(foreign-value "CD_PATH_MOVETO" int))
(cons
'line-to
(foreign-value "CD_PATH_LINETO" int))
(cons
'arc
(foreign-value "CD_PATH_ARC" int))
(cons
'curve-to
(foreign-value "CD_PATH_CURVETO" int))
(cons
'close
(foreign-value "CD_PATH_CLOSE" int))
(cons
'fill
(foreign-value "CD_PATH_FILL" int))
(cons
'stroke
(foreign-value "CD_PATH_STROKE" int))
(cons
'fill+stroke
(foreign-value "CD_PATH_FILLSTROKE" int))
(cons
'clip
(foreign-value "CD_PATH_CLIP" int)))]
[canvas-path-set/raw!
(foreign-lambda void "cdCanvasPathSet" nonnull-canvas int)])
(lambda (canvas path-action)
(canvas-path-set/raw!
canvas
(cond
[(assq path-action path-actions) => cdr]
[else (error 'canvas-path-set! "unknown path action" path-action)])))))
(define canvas-vertex!
(foreign-lambda void "cdfCanvasVertex" nonnull-canvas double double))
;; }}}
)