(require-library canvas-draw-base)
(module canvas-draw-client
(context:image context:double-buffer
canvas-image/rgb canvas-image-put/rgb! canvas-image-put/rgba!)
(import scheme chicken foreign canvas-draw-base)
;; {{{ Data types
(foreign-declare
"#include <cd.h>\n"
"#include <cdirgb.h>\n")
(include "canvas-draw-types.scm")
;; }}}
;; {{{ Context types
(define context:image
(foreign-value "CD_IMAGERGB" nonnull-context))
(define context:double-buffer
(foreign-value "CD_DBUFFERRGB" nonnull-context))
;; }}}
;; {{{ Auxiliary functions
(define canvas-image-put/rgb!
(letrec ([canvas-image-set/rgb/raw!
(foreign-lambda* void ([nonnull-canvas canvas] [int dst_x] [int dst_y]
[int src_width] [int src_height] [nonnull-blob data]
[int dst_width] [int dst_height]
[int src_x0] [int src_x1] [int src_y0] [int src_y1])
"const int nchans = 3;\n"
"unsigned char chans[nchans][src_width * src_height];\n"
"int i;\n"
"\n"
"for (i = 0; i < nchans * src_width * src_height; ++i)\n"
" chans[i % nchans][i / nchans] = data[i];\n"
"\n"
"cdCanvasPutImageRectRGB(\n"
" canvas, src_width, src_height,\n"
" chans[0], chans[1], chans[2],\n"
" dst_x, dst_y, dst_width, dst_height,"
" src_x0, src_x1, src_y0, src_y1"
");")])
(lambda (canvas dst-x dst-y src-width src-height data
#!key [width 0] [height 0] [x0 0] [x1 0] [y0 0] [y1 0])
(unless (= (blob-size data) (* 3 src-width src-height))
(error 'canvas-image-set/rgb! "bad image size" (blob-size data) (* 3 src-width src-height)))
(canvas-image-set/rgb/raw!
canvas dst-x dst-y src-width src-height data
width height x0 x1 y0 y1))))
(define canvas-image-put/rgba!
(letrec ([canvas-image-set/rgba/raw!
(foreign-lambda* void ([nonnull-canvas canvas] [int dst_x] [int dst_y]
[int src_width] [int src_height] [nonnull-blob data]
[int dst_width] [int dst_height]
[int src_x0] [int src_x1] [int src_y0] [int src_y1])
"const int nchans = 4;\n"
"unsigned char chans[nchans][src_width * src_height];\n"
"int i;\n"
"\n"
"for (i = 0; i < nchans * src_width * src_height; ++i)\n"
" chans[i % nchans][i / nchans] = data[i];\n"
"\n"
"cdCanvasPutImageRectRGBA(\n"
" canvas, src_width, src_height,\n"
" chans[0], chans[1], chans[2], chans[3],\n"
" dst_x, dst_y, dst_width, dst_height,"
" src_x0, src_x1, src_y0, src_y1"
");")])
(lambda (canvas dst-x dst-y src-width src-height data
#!key [width 0] [height 0] [x0 0] [x1 0] [y0 0] [y1 0])
(unless (= (blob-size data) (* 4 src-width src-height))
(error 'canvas-image-set/rgba! "bad image size" (blob-size data) (* 4 src-width src-height)))
(canvas-image-set/rgba/raw!
canvas dst-x dst-y src-width src-height data
width height x0 x1 y0 y1))))
(define canvas-image/rgb
(getter-with-setter
(letrec ([canvas-image/rgb/raw
(foreign-lambda* void ([nonnull-canvas canvas] [int x] [int y]
[int width] [int height] [nonnull-blob data])
"const int nchans = 3;\n"
"unsigned char chans[nchans][width * height];\n"
"int i;\n"
"\n"
"cdCanvasGetImageRGB(\n"
" canvas,\n"
" chans[0], chans[1], chans[2],\n"
" x, y, width, height\n"
");\n"
"\n"
"for (i = 0; i < nchans * width * height; ++i)\n"
" data[i] = chans[i % nchans][i / nchans];\n")])
(lambda (canvas x y width height)
(let ([data (make-blob (* 3 width height))])
(canvas-image/rgb/raw canvas x y width height data)
data)))
canvas-image-put/rgb!))
;; }}}
)