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

;; }}}

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