File canvas-draw/racket/client.rkt artifact 1a260d97ea part of check-in 44f8109293


#lang racket
(require
 srfi/17
 ffi/unsafe
 "base.rkt")

(define libcd
  (case (system-type 'os)
    [(windows)
     (ffi-lib "cd")]
    [else
     (ffi-lib "libcd")]))

;; {{{ Context types

(define context:image
  ((get-ffi-obj "cdContextImageRGB" libcd (_fun -> [context : _context]))))

(define context:double-buffer
  ((get-ffi-obj "cdContextDBufferRGB" libcd (_fun -> [context : _context]))))

(provide
 context:image context:double-buffer)

;; }}}

;; {{{ Auxiliary functions

(define (bytes-slice bstr n k slen)
  (let ([blen (bytes-length bstr)])
    (unless (= blen (* n slen))
      (error 'bytes-slice "data length mismatch (actual ~s, required ~s)" blen (* n slen)))
    (let ([slice (make-bytes slen)])
      (for ([bi (in-range k blen n)] [si (in-range slen)])
        (bytes-set! slice si (bytes-ref bstr bi)))
      slice)))

(define (bytes-mix slice0 . slice*)
  (let* ([n (add1 (length slice*))]
         [blen (* n (bytes-length slice0))]
         [bstr (make-bytes blen)])
    (for ([slice (in-cycle (in-value slice0) (in-list slice*))]
          [bi (in-range blen)] #:when #t [si (in-value (quotient bi n))])
      (bytes-set! bstr bi (bytes-ref slice si)))
    bstr))

(define canvas-image-put/rgb!
  (get-ffi-obj
   "cdCanvasPutImageRectRGB" libcd
   (_fun (canvas dst-x dst-y src-width src-height data
          #:width [dst-width 0] #:height [dst-height 0]
          #:x0 [src-x0 0] #:x1 [src-x1 0]
          #:y0 [src-y0 0] #:y1 [src-y1 0])
         :: [canvas : _canvas]
            [src-width : _int] [src-height : _int]
            [red : _bytes = (bytes-slice data 3 0 (* src-width src-height))]
            [green : _bytes = (bytes-slice data 3 1 (* src-width src-height))]
            [blue : _bytes = (bytes-slice data 3 2 (* src-width src-height))]
            [dst-x : _int] [dst-y : _int]
            [dst-width : _int] [dst-height : _int]
            [src-x0 : _int] [src-x1 : _int]
            [src-y0 : _int] [src-y1 : _int]
         -> _void)))

(define canvas-image-put/rgba!
  (get-ffi-obj
   "cdCanvasPutImageRectRGBA" libcd
   (_fun (canvas dst-x dst-y src-width src-height data
          #:width [dst-width 0] #:height [dst-height 0]
          #:x0 [src-x0 0] #:x1 [src-x1 0]
          #:y0 [src-y0 0] #:y1 [src-y1 0])
         :: [canvas : _canvas]
            [src-width : _int] [src-height : _int]
            [red : _bytes = (bytes-slice data 4 0 (* src-width src-height))]
            [green : _bytes = (bytes-slice data 4 1 (* src-width src-height))]
            [blue : _bytes = (bytes-slice data 4 2 (* src-width src-height))]
            [alpha : _bytes = (bytes-slice data 4 3 (* src-width src-height))]
            [dst-x : _int] [dst-y : _int]
            [dst-width : _int] [dst-height : _int]
            [src-x0 : _int] [src-x1 : _int]
            [src-y0 : _int] [src-y1 : _int]
         -> _void)))

(define canvas-image/rgb
  (getter-with-setter
   (get-ffi-obj
    "cdCanvasGetImageRGB" libcd
    (_fun (canvas x y width height)
          :: [canvas : _canvas]
             [red : (_bytes o (* width height))]
             [green : (_bytes o (* width height))]
             [blue : (_bytes o (* width height))]
             [x : _int] [y : _int]
             [width : _int] [height : _int]
          -> _void
          -> (bytes-mix red green blue)))
   canvas-image-put/rgb!))

(provide
 canvas-image/rgb canvas-image-put/rgb! canvas-image-put/rgba!)

;; }}}