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