#lang racket
(require
srfi/2
srfi/17
srfi/26
ffi/unsafe
ffi/unsafe/cvector
ffi/unsafe/alloc
ffi/unsafe/atomic)
(define libcd
(case (system-type 'os)
[(windows)
(ffi-lib "cd")]
[else
(ffi-lib "libcd")]))
;; {{{ Data types
(define-cpointer-type _canvas)
(define-cpointer-type _context)
(define-cpointer-type _state)
(provide
_canvas _canvas/null canvas?
_context _context/null context?
_state _state/null state?)
;; }}}
;; {{{ Canvas management
(define _capability-mask
(_bitmask
'(flush = #x00000001
clear = #x00000002
play = #x00000004
y-axis = #x00000008
clip-area = #x00000010
clip-polygon = #x00000020
region = #x00000040
rectangle = #x00000080
chord = #x00000100
image/rgb = #x00000200
image/rgba = #x00000400
image/map = #x00000800
get-image/rgb = #x00001000
image/server = #x00002000
background = #x00004000
background-opacity = #x00008000
write-mode = #x00010000
line-style = #x00020000
line-width = #x00040000
fprimitives = #x00080000
hatch = #x00100000
stipple = #x00200000
pattern = #x00400000
font = #x00800000
font-dimensions = #x01000000
text-size = #x02000000
text-orientation = #x04000000
palette = #x08000000
line-cap = #x10000000
line-join = #x20000000
path = #x40000000
bezier = #x80000000)
_int))
(define context-capabilities
(get-ffi-obj
"cdContextCaps" libcd
(_fun [context : _context] -> [capabilities : _capability-mask])))
(define use-context+
(make-parameter #f))
(define use-context+!
(get-ffi-obj
"cdUseContextPlus" libcd
(_fun [plus? : _bool = (use-context+)] -> _void)))
(define make-canvas/ptr
(get-ffi-obj
"cdCreateCanvas" libcd
(_fun [context : _context] [data : _pointer] -> [canvas : _canvas/null])))
(define make-canvas/string
(get-ffi-obj
"cdCreateCanvas" libcd
(_fun [context : _context] [data : _string/utf-8] -> [canvas : _canvas/null])))
(define canvas-kill
((deallocator)
(get-ffi-obj
"cdKillCanvas" libcd
(_fun [canvas : _canvas] -> _void))))
(define canvas-activate!
(get-ffi-obj
"cdCanvasActivate" libcd
(_fun [canvas : _canvas] -> _void)))
(define canvas-deactivate!
(get-ffi-obj
"cdCanvasDeactivate" libcd
(_fun [canvas : _canvas] -> _void)))
(define make-canvas
((allocator canvas-kill)
(λ (context data)
(let ([make-canvas/data (if (string? data) make-canvas/string make-canvas/ptr)])
(use-context+!)
(cond
[(make-canvas/data context data) => values]
[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
(call-as-atomic
(λ ()
(use-context+!)
(make-canvas/data context data)))])
(unless canvas (error 'call-with-canvas "failed to create canvas"))
(dynamic-wind
(cut canvas-activate! canvas)
(cut proc canvas)
(λ ()
(when canvas
(canvas-kill canvas)
(set! canvas #f)))))]))
(define canvas-context
(get-ffi-obj
"cdCanvasGetContext" libcd
(_fun [canvas : _canvas] -> [context : _context])))
(define _simulation-mask
(_bitmask
'(none = #x0000
line = #x0001
rectangle = #x0002
box = #x0004
arc = #x0008
sector = #x0010
chord = #x0020
polyline = #x0040
polygon = #x0080
text = #x0100
all = #xFFFF
lines = #x004B
fills = #x00B4)
_int))
(define canvas-simulate!
(get-ffi-obj
"cdCanvasSimulate" libcd
(_fun [canvas : _canvas] [simulate : _simulation-mask] -> [simulate : _simulation-mask])))
(define _name
(make-ctype
_string/utf-8
(λ (name)
(cond
[(symbol? name)
(string-upcase (regexp-replace* #rx"-" (symbol->string name) "_"))]
[else
name]))
#f))
(define canvas-attribute-set!
(get-ffi-obj
"cdCanvasSetAttribute" libcd
(_fun [canvas : _canvas] [name : _name] [value : _string/utf-8] -> _void)))
(define canvas-attribute
(getter-with-setter
(get-ffi-obj
"cdCanvasGetAttribute" libcd
(_fun [canvas : _canvas] [name : _name] -> [value : _string/utf-8]))
canvas-attribute-set!))
(define canvas-state-set!
(get-ffi-obj
"cdCanvasRestoreState" libcd
(_fun [canvas : _canvas] [state : _state] -> _void)))
(define state-release
((deallocator)
(get-ffi-obj
"cdReleaseState" libcd
(_fun [state : _state] -> _void))))
(define canvas-state
(getter-with-setter
((allocator state-release)
(get-ffi-obj
"cdCanvasSaveState" libcd
(_fun [canvas : _canvas] -> [state : _state])))
canvas-state-set!))
(define canvas-clear!
(get-ffi-obj
"cdCanvasClear" libcd
(_fun [canvas : _canvas] -> _void)))
(define canvas-flush
(get-ffi-obj
"cdCanvasFlush" libcd
(_fun [canvas : _canvas] -> _void)))
(provide
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)
;; }}}
;; {{{ Coordinate system
(define canvas-size
(get-ffi-obj
"cdCanvasGetSize" libcd
(_fun [canvas : _canvas]
[width/px : (_ptr o _int)] [height/px : (_ptr o _int)]
[width/mm : (_ptr o _double)] [height/mm : (_ptr o _double)]
-> _void
-> (values
width/px height/px
width/mm height/mm))))
(define canvas-mm->px
(get-ffi-obj
"cdCanvasMM2Pixel" libcd
(_fun [canvas : _canvas]
[x/mm : _double*] [y/mm : _double*]
[x/px : (_ptr o _int)] [y/px : (_ptr o _int)]
-> _void
-> (values x/px y/px))))
(define canvas-px->mm
(get-ffi-obj
"cdCanvasPixel2MM" libcd
(_fun [canvas : _canvas]
[x/px : _int] [y/px : _int]
[x/mm : (_ptr o _double)] [y/mm : (_ptr o _double)]
-> _void
-> (values x/mm y/mm))))
(define canvas-origin-set!
(get-ffi-obj
"cdCanvasOrigin" libcd
(_fun [canvas : _canvas] [x : _int] [y : _int] -> _void)))
(define canvas-origin
(get-ffi-obj
"cdCanvasGetOrigin" libcd
(_fun [canvas : _canvas] [x : (_ptr o _int)] [y : (_ptr o _int)]
-> _void
-> (values x y))))
(define _transform
(make-ctype
_gcpointer
(λ (proc)
(and
proc
(let* ([v (make-cvector _double* 6)])
(let-values ([(dx dy) (proc 0 0)])
(cvector-set! v 4 dx)
(cvector-set! v 5 dy)
(let-values ([(x y) (proc 1 0)])
(cvector-set! v 0 (- x dx))
(cvector-set! v 1 (- y dy)))
(let-values ([(x y) (proc 0 1)])
(cvector-set! v 2 (- x dx))
(cvector-set! v 3 (- y dy))))
(cvector-ptr v))))
(λ (v)
(and-let* ([v (and v (make-cvector* v _double* 6))])
(let ([sx0 (cvector-ref v 0)] [sx1 (cvector-ref v 1)]
[sy0 (cvector-ref v 2)] [sy1 (cvector-ref v 3)]
[dx (cvector-ref v 4)] [dy (cvector-ref v 5)])
(λ (x y)
(values
(+ (* sx0 x) (* sy0 y) dx)
(+ (* sx1 x) (* sy1 y) dy))))))))
(define canvas-transform-set!
(get-ffi-obj
"cdCanvasTransform" libcd
(_fun [canvas : _canvas] [transform : _transform] -> _void)))
(define canvas-transform
(getter-with-setter
(get-ffi-obj
"cdCanvasGetTransform" libcd
(_fun [canvas : _canvas] -> [transform : _transform]))
canvas-transform-set!))
(define canvas-transform-compose!
(get-ffi-obj
"cdCanvasTransformMultiply" libcd
(_fun [canvas : _canvas] [transform : _transform] -> _void)))
(define canvas-transform-translate!
(get-ffi-obj
"cdCanvasTransformTranslate" libcd
(_fun [canvas : _canvas] [dx : _double*] [dy : _double*] -> _void)))
(define canvas-transform-scale!
(get-ffi-obj
"cdCanvasTransformScale" libcd
(_fun [canvas : _canvas] [sx : _double*] [sy : _double*] -> _void)))
(define canvas-transform-rotate!
(get-ffi-obj
"cdCanvasTransformRotate" libcd
(_fun [canvas : _canvas] [alpha : _double*] -> _void)))
(provide
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!)
;; }}}
;; {{{ General attributes
(define canvas-foreground-set!
(get-ffi-obj
"cdCanvasSetForeground" libcd
(_fun [canvas : _canvas] [color : _ulong] -> _void)))
(define canvas-foreground
(getter-with-setter
(get-ffi-obj
"cdCanvasForeground" libcd
(_fun [canvas : _canvas] [query : _long = -1] -> [color : _ulong]))
canvas-foreground-set!))
(define canvas-background-set!
(get-ffi-obj
"cdCanvasSetBackground" libcd
(_fun [canvas : _canvas] [color : _ulong] -> _void)))
(define canvas-background
(getter-with-setter
(get-ffi-obj
"cdCanvasBackground" libcd
(_fun [canvas : _canvas] [query : _long = -1] -> [color : _ulong]))
canvas-background-set!))
(define _write-mode
(_enum '(replace xor not-xor)))
(define canvas-write-mode-set!
(get-ffi-obj
"cdCanvasWriteMode" libcd
(_fun [canvas : _canvas] [mode : _write-mode] -> _void)))
(define canvas-write-mode
(getter-with-setter
(get-ffi-obj
"cdCanvasWriteMode" libcd
(_fun [canvas : _canvas] [query : _fixint = -1] -> [mode : _write-mode]))
canvas-write-mode-set!))
(provide
canvas-foreground canvas-foreground-set!
canvas-background canvas-background-set!
canvas-write-mode canvas-write-mode-set!)
;; }}}
;; {{{ Clipping
(define _clip-mode
(_enum '(#f area polygon region)))
(define canvas-clip-mode-set!
(get-ffi-obj
"cdCanvasClip" libcd
(_fun [canvas : _canvas] [mode : _clip-mode] -> _void)))
(define canvas-clip-mode
(getter-with-setter
(get-ffi-obj
"cdCanvasClip" libcd
(_fun [canvas : _canvas] [query : _fixint = -1] -> [mode : _clip-mode]))
canvas-clip-mode-set!))
(define canvas-clip-area-set!
(get-ffi-obj
"cdfCanvasClipArea" libcd
(_fun [canvas : _canvas] [x0 : _double*] [x1 : _double*] [y0 : _double*] [y1 : _double*] -> _void)))
(define canvas-clip-area
(get-ffi-obj
"cdfCanvasGetClipArea" libcd
(_fun [canvas : _canvas]
[x0 : (_ptr o _double)] [x1 : (_ptr o _double)]
[y0 : (_ptr o _double)] [y1 : (_ptr o _double)]
-> _void
-> (values x0 x1 y0 y1))))
(provide
canvas-clip-mode canvas-clip-mode-set!
canvas-clip-area canvas-clip-area-set!)
;; }}}