;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ Data types

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

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

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

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

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

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

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

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

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

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

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

;; }}}

;; {{{ Canvas management

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

;; }}}

;; {{{ Coordinate system

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

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

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

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

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

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

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

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

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

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

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

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

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

;; }}}

;; {{{ General attributes

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

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

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

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

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

;; }}}

;; {{{ Clipping

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

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

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

;; }}}

;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ Data types

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

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

;; }}}

;; {{{ Context types

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

;; }}}

;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ Data types

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

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

;; }}}

;; {{{ Context types

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

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

;; }}}

;; {{{ Auxiliary functions

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

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

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

;; }}}

;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ Data types

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

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

;; }}}

;; {{{ Context types

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

;; }}}

;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ Data types

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

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

;; }}}

;; {{{ Context types

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

;; }}}

;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ Data types

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

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

;; }}}

;; {{{ Context types

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

;; }}}

;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ Data types

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

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

;; }}}

;; {{{ Context types

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

;; }}}

;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ Data types

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

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

;; }}}

;; {{{ Context types

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

;; }}}

;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ Data types

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

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

;; }}}

;; {{{ Context types

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

;; }}}

;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ Data types

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

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

;; }}}

;; {{{ Context types

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

;; }}}

;; {{{ Auxiliary functions

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

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

;; }}}

;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ Data types

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

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

;; }}}

;; {{{ Context types

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

;; }}}

;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ Data types

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

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

;; }}}

;; {{{ Context types

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

;; }}}

;; {{{ Auxiliary functions

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

;; }}}

;; {{{ Library initialization

(foreign-code "cdInitContextPlus();")

;; }}}

;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ Data types

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

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

;; }}}

;; {{{ Context types

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

;; }}}

;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ Data types

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

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

;; }}}

;; {{{ Context types

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

;; }}}

;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ Data types

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

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

;; }}}

;; {{{ Context content playback

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

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

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

;; }}}

;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ 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))

;; }}}

;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ Data types

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

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

;; }}}

;; {{{ Context types

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

;; }}}

;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ Data types

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

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

;; }}}

;; {{{ Context types

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

;; }}}

;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ Data types

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

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

;; }}}

;; {{{ Context types

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

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

;; }}}

;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ Data types

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

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

;; }}}

;; {{{ Context types

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

;; }}}

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

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

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

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

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

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

;; -*- mode: Scheme; tab-width: 2; -*- ;;

;; {{{ Data types

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

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

;; }}}

;; {{{ Context types

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

;; }}}

((category graphics)
 (license "BSD")
 (author "Thomas Chust")
 (synopsis "Bindings to the CD graphics library")
 (doc-from-wiki)
 (files "canvas-draw-native.scm" "canvas-draw-picture.scm" "canvas-draw-pdf.scm" "canvas-draw.meta" "canvas-draw-clipboard.scm" "canvas-draw-ps.scm" "canvas-draw-iup.scm" "canvas-draw-debug.scm" "canvas-draw-wmf.scm" "canvas-draw-cgm.scm" "canvas-draw-play.scm" "canvas-draw-dxf.scm" "canvas-draw-svg.scm" "canvas-draw-types.scm" "canvas-draw-emf.scm" "canvas-draw-metafile.scm" "canvas-draw-dgn.scm" "canvas-draw.scm" "canvas-draw-printer.scm" "canvas-draw-server.scm" "canvas-draw-gl.scm" "canvas-draw-primitives.scm" "canvas-draw.setup" "canvas-draw.release-info" "canvas-draw-base.scm" "canvas-draw-client.scm"))

;; -*- mode: Scheme; tab-width: 2; -*- ;;

(require-library lolevel data-structures srfi-1 srfi-4 srfi-13)

(module canvas-draw-base
	(canvas? canvas->pointer pointer->canvas
	 context? context->pointer pointer->context
	 state? state->pointer pointer->state
	 context-capabilities
	 use-context+ make-canvas call-with-canvas
	 canvas-context
	 canvas-simulate!
	 canvas-attribute canvas-attribute-set!
	 canvas-state canvas-state-set!
	 canvas-clear! canvas-flush
	 canvas-size
	 canvas-mm->px canvas-px->mm
	 canvas-origin canvas-origin-set!
	 canvas-transform canvas-transform-set!
	 canvas-transform-compose!
	 canvas-transform-translate!
	 canvas-transform-scale!
	 canvas-transform-rotate!
	 canvas-foreground canvas-foreground-set!
	 canvas-background canvas-background-set!
	 canvas-write-mode canvas-write-mode-set!
	 canvas-clip-mode canvas-clip-mode-set!
	 canvas-clip-area canvas-clip-area-set!)
	(import
		scheme chicken foreign
		lolevel data-structures srfi-1 srfi-4 srfi-13)
	(include "canvas-draw-base.scm"))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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