#lang racket
(require
srfi/17
srfi/26
ffi/unsafe
ffi/unsafe/cvector
"base.rkt")
(define libcd
(case (system-type 'os)
[(windows)
(ffi-lib "cd")]
[else
(ffi-lib "libcd")]))
;; {{{ Point drawing functions
(define canvas-pixel!
(get-ffi-obj
"cdCanvasPixel" libcd
(_fun (canvas x y [color (canvas-foreground canvas)])
:: [canvas : _canvas] [x : _int] [y : _int] [color : _ulong] -> _void)))
(define canvas-mark!
(get-ffi-obj
"cdCanvasMark" libcd
(_fun [canvas : _canvas] [x : _int] [y : _int] -> _void)))
(define _mark-type
(_enum
'(+ = 0 plus = 0
* = 1 star = 1
0 = 2 circle = 2
X = 3 x = 3
box
diamond
O = 6 hollow-circle = 6
hollow-box
hollow-diamond)
_fixint))
(define canvas-mark-type-set!
(get-ffi-obj
"cdCanvasMarkType" libcd
(_fun [canvas : _canvas] [mark-type : _mark-type] -> _void)))
(define canvas-mark-type
(getter-with-setter
(get-ffi-obj
"cdCanvasMarkType" libcd
(_fun [canvas : _canvas] [query : _fixint = -1] -> [mark-type : _mark-type]))
canvas-mark-type-set!))
(define canvas-mark-size-set!
(get-ffi-obj
"cdCanvasMarkSize" libcd
(_fun [canvas : _canvas] [size : _int] -> _void)))
(define canvas-mark-size
(getter-with-setter
(get-ffi-obj
"cdCanvasMarkSize" libcd
(_fun [canvas : _canvas] [query : _int = -1] -> [size : _int]))
canvas-mark-size-set!))
(provide
canvas-pixel!
canvas-mark!
canvas-mark-type canvas-mark-type-set!
canvas-mark-size canvas-mark-size-set!)
;; }}}
;; {{{ Line functions
(define canvas-line!
(get-ffi-obj
"cdfCanvasLine" libcd
(_fun [canvas : _canvas] [x0 : _double*] [y0 : _double*] [x1 : _double*] [y1 : _double*] -> _void)))
(define canvas-rectangle!
(get-ffi-obj
"cdfCanvasRect" libcd
(_fun [canvas : _canvas] [x0 : _double*] [x1 : _double*] [y0 : _double*] [y1 : _double*] -> _void)))
(define canvas-arc!
(get-ffi-obj
"cdfCanvasArc" libcd
(_fun [canvas : _canvas]
[x : _double*] [y : _double*] [width : _double*] [height : _double*]
[alpha0 : _double*] [alpha1 : _double*]
-> _void)))
(define _line-style
(_enum
'(continuous dashed dotted dash-dotted dash-dot-dotted custom)
_fixint))
(define canvas-line-style-set!
(letrec ([canvas-line-style-set/raw!
(get-ffi-obj
"cdCanvasLineStyle" libcd
(_fun [canvas : _canvas] [line-style : _line-style] -> _void))]
[canvas-line-style-dashes-set/raw!
(get-ffi-obj
"cdCanvasLineStyleDashes" libcd
(_fun [canvas : _canvas] [dashes : _cvector] [len : _int = (cvector-length dashes)] -> _void))])
(λ (canvas line-style)
(match line-style
[(list-rest 'custom dashes)
(canvas-line-style-dashes-set/raw! canvas (list->cvector dashes _int))
(canvas-line-style-set/raw! canvas 'dashes)]
[_
(canvas-line-style-set/raw! canvas line-style)]))))
(define canvas-line-style
(getter-with-setter
(get-ffi-obj
"cdCanvasLineStyle" libcd
(_fun [canvas : _canvas] [query : _fixint = -1] -> [line-style : _line-style]))
canvas-line-style-set!))
(define canvas-line-width-set!
(get-ffi-obj
"cdCanvasLineWidth" libcd
(_fun [canvas : _canvas] [width : _int] -> _void)))
(define canvas-line-width
(getter-with-setter
(get-ffi-obj
"cdCanvasLineWidth" libcd
(_fun [canvas : _canvas] [query : _int = -1] -> [width : _int]))
canvas-line-width-set!))
(define _line-join
(_enum
'(miter bevel round)
_fixint))
(define canvas-line-join-set!
(get-ffi-obj
"cdCanvasLineJoin" libcd
(_fun [canvas : _canvas] [line-join : _line-join] -> _void)))
(define canvas-line-join
(getter-with-setter
(get-ffi-obj
"cdCanvasLineJoin" libcd
(_fun [canvas : _canvas] [query : _fixint = -1] -> _void))
canvas-line-join-set!))
(define _line-cap
(_enum
'(flat square round)
_fixint))
(define canvas-line-cap-set!
(get-ffi-obj
"cdCanvasLineCap" libcd
(_fun [canvas : _canvas] [line-cap : _line-cap] -> _void)))
(define canvas-line-cap
(getter-with-setter
(get-ffi-obj
"cdCanvasLineCap" libcd
(_fun [canvas : _canvas] [query : _fixint = -1] -> [line-cap : _line-cap]))
canvas-line-cap-set!))
(provide
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!)
;; }}}
;; {{{ Filled area functions
(define canvas-box!
(get-ffi-obj
"cdfCanvasBox" libcd
(_fun [canvas : _canvas] [x0 : _double*] [x1 : _double*] [y0 : _double*] [y1 : _double*] -> _void)))
(define canvas-sector!
(get-ffi-obj
"cdfCanvasSector" libcd
(_fun [canvas : _canvas]
[x : _double*] [y : _double*] [width : _double*] [height : _double*]
[alpha0 : _double*] [alpha1 : _double*]
-> _void)))
(define canvas-chord!
(get-ffi-obj
"cdfCanvasChord" libcd
(_fun [canvas : _canvas]
[x : _double*] [y : _double*] [width : _double*] [height : _double*]
[alpha0 : _double*] [alpha1 : _double*]
-> _void)))
(define _opacity
(_enum
'(opaque transparent)
_fixint))
(define canvas-background-opacity-set!
(get-ffi-obj
"cdCanvasBackOpacity" libcd
(_fun [canvas : _canvas] [opacity : _opacity] -> _void)))
(define canvas-background-opacity
(getter-with-setter
(get-ffi-obj
"cdCanvasBackOpacity" libcd
(_fun [canvas : _canvas] [query : _fixint = -1] -> [opacity : _opacity]))
canvas-background-opacity-set!))
(define _fill-mode
(_enum
'(even-odd winding)
_fixint))
(define canvas-fill-mode-set!
(get-ffi-obj
"cdCanvasFillMode" libcd
(_fun [canvas : _canvas] [fill-mode : _fill-mode] -> _void)))
(define canvas-fill-mode
(getter-with-setter
(get-ffi-obj
"cdCanvasFillMode" libcd
(_fun [canvas : _canvas] [query : _fixint = -1] -> [fill-mode : _fill-mode]))
canvas-fill-mode-set!))
(define _interior-style
(_enum
'(solid hatch stipple pattern #f)
_fixint))
(define _hatch-style
(_enum
'(horizontal vertical forward-diagonal backward-diagonal cross diagonal-cross)
_fixint))
(define canvas-interior-style-set!
(letrec ([canvas-interior-style-set/raw!
(get-ffi-obj
"cdCanvasInteriorStyle" libcd
(_fun [canvas : _canvas] [interior-style : _interior-style] -> _void))]
[canvas-hatch-style-set/raw!
(get-ffi-obj
"cdCanvasHatch" libcd
(_fun [canvas : _canvas] [hatch-style : _hatch-style] -> _void))]
[canvas-stipple-set/raw!
(get-ffi-obj
"cdCanvasStipple" libcd
(_fun [canvas : _canvas] [width : _int] [height : _int] [data* : _cvector] -> _void))]
[canvas-pattern-set/raw!
(get-ffi-obj
"cdCanvasPattern" libcd
(_fun [canvas : _canvas] [width : _int] [height : _int] [data* : _cvector] -> _void))])
(λ (canvas interior-style)
(match interior-style
[(list 'hatch hatch-style)
(canvas-hatch-style-set/raw! canvas hatch-style)
(canvas-interior-style-set/raw! canvas 'hatch)]
[(list 'stipple width height data)
(let ([data* (make-cvector _ubyte (* width height))])
(for* ([j (in-range height)] [i (in-range width)]
[ofs* (in-value (+ (* j width) i))]
[vofs (in-value (quotient ofs* 8))]
[bofs (in-value (remainder ofs* 8))])
(cvector-set! data* ofs* (bitwise-bit-field (bytes-ref data vofs) bofs (add1 bofs))))
(canvas-stipple-set/raw! canvas width height data*))
(canvas-interior-style-set/raw! canvas 'stipple)]
[(list 'pattern/rgb width height data)
(let ([data* (make-cvector _ulong (* width height))])
(for* ([j (in-range height)] [i (in-range width)]
[ofs* (in-value (+ (* j width) i))]
[ofs (in-value (* 3 ofs*))])
(cvector-set! data* ofs*
(bitwise-ior
(arithmetic-shift (bytes-ref data ofs) 16)
(arithmetic-shift (bytes-ref data (+ ofs 1)) 8)
(bytes-ref data (+ ofs 2)))))
(canvas-pattern-set/raw! canvas width height data*))
(canvas-interior-style-set/raw! canvas 'pattern)]
[(list 'pattern/rgba width height data)
(let* ([data* (make-cvector _ulong (* width height))]
[elt-set! (cut ptr-set! data* _long <> <>)])
(for* ([j (in-range height)] [i (in-range width)]
[ofs* (in-value (+ (* j width) i))]
[ofs (in-value (* 4 ofs*))])
(cvector-set! data* ofs*
(bitwise-ior
(arithmetic-shift (- #xff (bytes-ref data (+ ofs 3))) 24)
(arithmetic-shift (bytes-ref data ofs) 16)
(arithmetic-shift (bytes-ref data (+ ofs 1)) 8)
(bytes-ref data (+ ofs 2)))))
(canvas-pattern-set/raw! canvas width height data*))
(canvas-interior-style-set/raw! canvas 'pattern)]
[_
(canvas-interior-style-set/raw! canvas interior-style)]))))
(define canvas-interior-style
(getter-with-setter
(letrec ([canvas-interior-style/raw
(get-ffi-obj
"cdCanvasInteriorStyle" libcd
(_fun [canvas : _canvas] [query : _fixint = -1] -> [interior-style : _interior-style]))]
[canvas-hatch-style/raw
(get-ffi-obj
"cdCanvasHatch" libcd
(_fun [canvas : _canvas] [query : _fixint = -1] -> [hatch-style : _hatch-style]))]
[canvas-stipple/raw
(get-ffi-obj
"cdCanvasGetStipple" libcd
(_fun [canvas : _canvas] [width : (_ptr o _int)] [height : (_ptr o _int)]
-> [data : _gcpointer]
-> (values width height data)))]
[canvas-pattern/raw
(get-ffi-obj
"cdCanvasGetPattern" libcd
(_fun [canvas : _canvas] [width : (_ptr o _int)] [height : (_ptr o _int)]
-> [data : _gcpointer]
-> (values width height data)))])
(λ (canvas)
(let ([interior-style (canvas-interior-style/raw canvas)])
(case interior-style
[(hatch)
(list 'hatch (canvas-hatch-style/raw canvas))]
[(stipple)
(let*-values ([(width height data*) (canvas-stipple/raw canvas)]
[(data*) (make-cvector* data* _ubyte (* width height))]
[(data) (make-bytes (ceiling (/ (* width height) 8)) 0)])
(for* ([j (in-range height)] [i (in-range width)]
[ofs* (in-value (+ (* j width) i))]
[vofs (in-value (quotient ofs* 8))]
[bofs (in-value (remainder ofs* 8))])
(bytes-set! data vofs
(bitwise-ior
(bytes-ref data vofs)
(arithmetic-shift (bitwise-and (cvector-ref data* ofs*) 1) bofs))))
(list 'stipple width height data))]
[(pattern)
(let*-values ([(width height data*) (canvas-pattern/raw canvas)]
[(data*) (make-cvector* data* _ulong (* width height))]
[(data) (make-bytes (* 4 width height))])
(for* ([j (in-range height)] [i (in-range width)]
[ofs* (in-value (+ (* j width) i))]
[ofs (in-value (* 4 ofs*))]
[col (in-value (cvector-ref data* ofs*))])
(bytes-set! data ofs (bitwise-bit-field col 16 24))
(bytes-set! data (+ ofs 1) (bitwise-bit-field col 8 16))
(bytes-set! data (+ ofs 2) (bitwise-bit-field col 0 8))
(bytes-set! data (+ ofs 3) (- #xff (bitwise-bit-field col 24 32))))
(list 'pattern/rgba width height data))]
[else
interior-style]))))
canvas-interior-style-set!))
(provide
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!)
;; }}}
;; {{{ Text functions
(define canvas-text!
(get-ffi-obj
"cdfCanvasText" libcd
(_fun [canvas : _canvas] [x : _double*] [y : _double*] [text : _string/utf-8] -> _void)))
(define canvas-font-set!
(get-ffi-obj
"cdCanvasNativeFont" libcd
(_fun [canvas : _canvas] [font : _string/utf-8] -> _void)))
(define canvas-font
(getter-with-setter
(get-ffi-obj
"cdCanvasNativeFont" libcd
(_fun [canvas : _canvas] [query : _pointer = #f] -> [font : _string/utf-8]))
canvas-font-set!))
(define _alignment
(_enum
'(north south east west north-east north-west south-east south-west center base-left base-center base-right)
_fixint))
(define canvas-text-alignment-set!
(get-ffi-obj
"cdCanvasTextAlignment" libcd
(_fun [canvas : _canvas] [alignment : _alignment] -> _void)))
(define canvas-text-alignment
(getter-with-setter
(get-ffi-obj
"cdCanvasTextAlignment" libcd
(_fun [canvas : _canvas] [query : _fixint = -1] -> [alignment : _alignment]))
canvas-text-alignment-set!))
(define canvas-text-orientation-set!
(get-ffi-obj
"cdCanvasTextOrientation" libcd
(_fun [canvas : _canvas] [orientation : _double*] -> _void)))
(define canvas-text-orientation
(getter-with-setter
(get-ffi-obj
"cdCanvasTextOrientation" libcd
(_fun [canvas : _canvas] [query : _double = -1.0] -> [orientation : _double]))
canvas-text-orientation-set!))
(define canvas-font-dimensions
(get-ffi-obj
"cdCanvasGetFontDim" libcd
(_fun [canvas : _canvas]
[max-width : (_ptr o _int)] [height : (_ptr o _int)]
[ascent : (_ptr o _int)] [descent : (_ptr o _int)]
-> _void
-> (values
max-width height
ascent descent))))
(define canvas-text-size
(get-ffi-obj
"cdCanvasGetTextSize" libcd
(_fun [canvas : _canvas] [text : _string/utf-8]
[width : (_ptr o _int)] [height : (_ptr o _int)]
-> _void
-> (values width height))))
(define canvas-text-box
(get-ffi-obj
"cdCanvasGetTextBox" libcd
(_fun [canvas : _canvas] [x : _int] [y : _int] [text : _string/utf-8]
[x0 : (_ptr o _int)] [x1 : (_ptr o _int)]
[y0 : (_ptr o _int)] [y1 : (_ptr o _int)]
-> _void
-> (values x0 x1 y0 y1))))
(provide
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)
;; }}}
;; {{{ Vertex functions
(define _canvas-mode
(_enum
'(fill open-lines closed-lines clip bezier region path)
_fixint))
(define call-with-canvas-in-mode
(letrec ([canvas-begin/raw
(get-ffi-obj
"cdCanvasBegin" libcd
(_fun [canvas : _canvas] [canvas-mode : _canvas-mode] -> _void))]
[canvas-end/raw
(get-ffi-obj
"cdCanvasEnd" libcd
(_fun [canvas : _canvas] -> _void))])
(λ (canvas canvas-mode proc)
(dynamic-wind
(cut canvas-begin/raw canvas canvas-mode)
(cut proc canvas)
(cut canvas-end/raw canvas)))))
(define _path-action
(_enum
'(new move-to line-to arc curve-to close fill stroke fill+stroke clip)
_fixint))
(define canvas-path-set!
(get-ffi-obj
"cdCanvasPathSet" libcd
(_fun [canvas : _canvas] [path-action : _path-action] -> _void)))
(define canvas-vertex!
(get-ffi-obj
"cdfCanvasVertex" libcd
(_fun [canvas : _canvas] [x : _double*] [y : _double*] -> _void)))
(provide
call-with-canvas-in-mode canvas-path-set!
canvas-vertex!)
;; }}}