;; {{{ Data types

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

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

;; }}}

;; {{{ Point drawing functions

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

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

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

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

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

;; }}}

;; {{{ Line functions

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

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

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

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

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

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

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

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

;; }}}

;; {{{ Filled area functions

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

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

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

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

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

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

;; }}}

;; {{{ Text functions

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

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

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

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

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

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

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

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

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

;; }}}

;; {{{ Vertex functions

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

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

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

;; }}}

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