File canvas-draw/racket/base.rkt artifact 90a071f77d part of check-in b1dcd0ebc6


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

;; }}}