File canvas-draw/racket/primitives.rkt artifact ed1ac7e149 part of check-in 8ca036fa3c


#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!)

;; }}}