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