suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

gracket2 racket/draw

Browse Source
This commit is contained in:
Matthew Flatt 2010-05-31 15:20:43 -06:00
parent bcb075543c
commit 6829e96ded
29 changed files with 5021 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
collects/racket/draw.rkt Normal file
View File

@ -0,0 +1,30 @@
#lang racket/base
(require "draw/color.rkt"
"draw/point.rkt"
"draw/font.rkt"
"draw/font-dir.rkt"
"draw/pen.rkt"
"draw/brush.rkt"
"draw/region.rkt"
"draw/bitmap.rkt"
"draw/dc-path.rkt"
"draw/dc-intf.rkt"
"draw/bitmap-dc.rkt"
"draw/post-script-dc.rkt"
"draw/ps-setup.rkt")
(provide color%
color-database<%> the-color-database
point%
font% font-list% the-font-list
font-name-directory<%> the-font-name-directory
pen% pen-list% the-pen-list
brush% brush-list% the-brush-list
region%
bitmap%
dc-path%
dc<%>
bitmap-dc%
post-script-dc%
ps-setup% current-ps-setup
get-face-list)

94
collects/racket/draw/bitmap-dc.rkt Normal file
View File

@ -0,0 +1,94 @@
#lang scheme/base
(require scheme/class
mred/private/syntax
"cairo.ss"
"color.ss"
"bitmap.ss"
"dc.ss"
"local.ss")
(provide bitmap-dc%)
(define dc-backend%
(class default-dc-backend%
(init [_bm #f])
(inherit reset-cr)
(define c #f)
(define bm #f)
(define b&w? #f)
(when _bm
(do-set-bitmap _bm))
(define/private (do-set-bitmap v)
(when c
(cairo_destroy c)
(set! c #f))
(set! bm v)
(when (and bm (send bm ok?))
(set! c (cairo_create (send bm get-cairo-surface)))
(set! b&w? (not (send bm is-color?)))))
(def/public (set-bitmap [(make-or-false bitmap%) v])
(do-set-bitmap v)
(reset-cr))
(def/public (get-bitmap) bm)
(def/override (get-size)
(values (exact->inexact (send bm get-width))
(exact->inexact (send bm get-height))))
(def/public (set-pixel [real? x][real? y][color% c])
(let ([s (bytes 255 (color-red c) (color-green c) (color-blue c))])
(set-argb-pixels x y 1 1 s)))
(def/public (set-argb-pixels [exact-nonnegative-integer? x]
[exact-nonnegative-integer? y]
[exact-nonnegative-integer? w]
[exact-nonnegative-integer? h]
[bytes? bstr]
[any? [set-alpha? #f]])
(when bm
(send bm set-argb-pixels x y w h bstr set-alpha?)))
(def/public (get-argb-pixels [exact-nonnegative-integer? x]
[exact-nonnegative-integer? y]
[exact-nonnegative-integer? w]
[exact-nonnegative-integer? h]
[bytes? bstr]
[any? [get-alpha? #f]])
(when bm
(send bm get-argb-pixels x y w h bstr get-alpha?)))
(define/override (get-cr) c)
(define/override (end-cr) (void))
(define/override (dc-adjust-smoothing s)
(if b&w?
'unsmoothed
s))
(define/override (install-color cr c a)
(if b&w?
(begin
(cairo_set_operator cr CAIRO_OPERATOR_SOURCE)
(if (zero? a)
(super install-color cr c a)
(if (and (= (color-red c) 255)
(= (color-green c) 255)
(= (color-blue c) 255))
(cairo_set_source_rgba cr 1.0 1.0 1.0 0.0)
(cairo_set_source_rgba cr 0.0 0.0 0.0 1.0))))
(super install-color cr c a)))
(define/override (collapse-bitmap-b&w?) b&w?)
(super-new)))
(define bitmap-dc%
(dc-mixin dc-backend%))
(install-bitmap-dc-class! bitmap-dc%)

669
collects/racket/draw/bitmap.rkt Normal file
View File

@ -0,0 +1,669 @@
#lang scheme/base
(require scheme/class
scheme/unsafe/ops
mred/private/syntax
"hold.ss"
"bstr.ss"
"cairo.ss"
"png.ss"
"jpeg.ss"
"xbm.ss"
"local.ss"
"color.ss")
(provide bitmap%)
;; FIXME: there must be some way to abstract over all many of the
;; ARGB/RGBA/BGRA iterations.
(define-local-member-name
get-alphas-as-mask
set-alphas-as-mask)
(define (kind-symbol? s)
(memq s '(unknown unknown/mask unknown/alpha
gif gif/mask gif/alpha
jpeg jpeg/alpha
png png/mask png/alpha
xbm xbm/alpha
xpm xpm/alpha
bmp bmp/alpha
pict)))
(define (save-kind-symbol? s)
(memq s '(png jpeg gif xbm xpm bmp)))
(define (quality-integer? i)
(and (exact-nonnegative-integer? i) (i . <= . 100)))
(define (destroy s)
(cairo_surface_destroy s))
(define (argb-indices)
(if (system-big-endian?)
(values 0 1 2 3)
(values 3 2 1 0)))
(define (a-index)
(if (system-big-endian?) 0 3))
(define (b-index)
(if (system-big-endian?) 3 0))
(define fx+ unsafe-fx+)
(define fx* unsafe-fx*)
(define bitmap%
(class object%
;; We support three kinds of bitmaps:
;; * Color with alpha channel;
;; when used as a mask, alpha channel is used;
;; this is the sensible one that works nicely with Cairo
;; * Black and white; alpha channel is opposite
;; of value, so either value or alpha can be
;; considered as mask;
;; we have to play some tricks to keep the value and mask
;; inverted, and to keep everything black & white (no gray)
;; * Color without alpha channel; when used as a mask,
;; value channel is used (i.e., inverted RGB average
;; is used as an alpha);
;; we have to play even worse tricks when this kind of bitmap
;; is used as a mask
(init-rest args)
(super-new)
(define-values (width height b&w? alpha-channel? s loaded-mask)
(case-args
args
[() (void)]
[([exact-nonnegative-integer? w]
[exact-nonnegative-integer? h]
[any? [b&w? #f]]
[any? [alpha? #f]])
(values
w
h
(and b&w? #t)
(and alpha? (not b&w?))
(let ([s (cairo_image_surface_create CAIRO_FORMAT_ARGB32 w h)])
(cairo_surface_flush s)
(cond
[alpha?
;; Init transparent:
(bytes-fill! (cairo_image_surface_get_data s) 0)]
[b&w?
;; Init transparent white:
(transparent-white! s w h)]
[else
;; Init all white, 255 alpha:
(bytes-fill! (cairo_image_surface_get_data s) 255)])
s)
#f)]
[([path-string? filename]
[kind-symbol? [kind 'unknown]]
[(make-or-false color%) [bg-color #f]])
(let-values ([(s b&w?) (do-load-bitmap filename kind bg-color)]
[(alpha?) (memq kind '(unknown/alpha gif/alpha jpeg/alpha
png/alpha xbm/alpha xpm/alpha
bmp/alpha))]
[(mask?) (memq kind '(unknown/mask gif/mask png/mask))])
(let ([mask-bm
(and s
(not alpha?)
(let ([w (cairo_image_surface_get_width s)]
[h (cairo_image_surface_get_height s)]
[row-width (cairo_image_surface_get_stride s)]
[bstr (cairo_image_surface_get_data s)]
[A (a-index)])
(begin0
(and mask?
;; Move alpha channel to a separate mask bitmap
(let ([b&w? (for*/and ([j (in-range h)]
[i (in-range w)])
(let ([v (bytes-ref bstr (+ A (* 4 i) (* j row-width)))])
(or (= v 0) (= v 255))))])
(let ([mask-bm (make-object bitmap% w h b&w?)])
(send mask-bm set-alphas-as-mask 0 0 w h bstr row-width A)
mask-bm)))
;; Force all alpha values to 255
(for* ([j (in-range h)]
[i (in-range w)])
(bytes-set! bstr (+ A (* 4 i) (* j row-width)) 255))
(cairo_surface_mark_dirty s))))])
(if s
(values (cairo_image_surface_get_width s)
(cairo_image_surface_get_height s)
b&w?
alpha?
s
mask-bm)
(values 0 0 #f #f #f #f))))]
[([bytes? bstr]
[exact-nonnegative-integer? w]
[exact-nonnegative-integer? h])
(let ([bw (quotient (+ w 7) 8)])
(unless ((bytes-length bstr) . >= . (* h bw))
(error (init-name 'bitmap%)
"given byte string is too small for dimensions: ~s"
bstr))
(let ([s (cairo_image_surface_create CAIRO_FORMAT_ARGB32 w h)])
(let ([rows (list->vector
(for/list ([i (in-range h)])
(let ([s (* i bw)])
(subbytes bstr s (+ s bw)))))])
(install-from-png-arrays s w h rows #t #f #f #t))
(values w h #t #f s #f)))]
(init-name 'bitmap%)))
;; Use for non-alpha color bitmaps when they are used as a mask:
(define alpha-s #f)
(define alpha-s-up-to-date? #f)
(define/private (drop-alpha-s)
(set! alpha-s-up-to-date? #f)
(when alpha-s
(let ([s2 alpha-s])
(set! alpha-s #f)
(destroy s2))))
;; Allocate memory proportional to the size of the bitmap, which
;; helps the GC see that we're using that much memory.
(define shadow (make-bytes (* width height (if b&w? 1 4))))
(def/public (get-width) width)
(def/public (get-height) height)
(def/public (get-depth) (if b&w? 1 32))
(def/public (is-color?) (not b&w?))
(def/public (has-alpha-channel?) alpha-channel?)
(def/public (get-loaded-mask) loaded-mask)
(def/public (set-loaded-mask [(make-or-false bitmap%) m]) (set! loaded-mask m))
(define/private (release-s)
(drop-alpha-s)
(when s
(let ([s2 s])
(set! s #f)
(destroy s2))))
(define/private (check-ok who)
(unless s
(error (method-name 'bitmap% who) "bitmap is not ok")))
(define locked 0)
(define/public (adjust-lock delta) (set! locked (+ locked delta)))
(def/public (load-bitmap [(make-alts path-string? input-port?) in]
[kind-symbol? [kind 'unknown]]
[(make-or-false color%) [bg #f]])
(release-s)
(set!-values (s b&w?) (do-load-bitmap in kind bg))
(set! width (if s (cairo_image_surface_get_width s) 0))
(set! height (if s (cairo_image_surface_get_height s) 0)))
(define/private (do-load-bitmap in kind bg)
(if (path-string? in)
(call-with-input-file*
in
(lambda (in) (do-load-bitmap in kind bg)))
(case kind
[(unknown unknown/mask unknown/alpha)
(let ([starts? (lambda (s)
(equal? (peek-bytes (bytes-length s) 0 in) s))])
(cond
[(starts? #"\211PNG\r\n")
(do-load-bitmap in
(if (eq? kind 'unknown/alpha)
'png/alpha
(if (eq? kind 'unknown/mask)
'png/mask
'png))
bg)]
[(starts? #"\xFF\xD8\xFF")
(do-load-bitmap in 'jpeg bg)]
[(starts? #"GIF8")
(do-load-bitmap in 'gif bg)]
[(starts? #"BM")
(do-load-bitmap in 'bmp bg)]
[(starts? #"#define")
(do-load-bitmap in 'xbm bg)]
[(starts? #"/* XPM */")
(do-load-bitmap in 'xpm bg)]
[else
;; unrecognized file type; try to parse as XBM
(do-load-bitmap in 'xbm bg)]))]
[(png png/mask png/alpha)
;; Using the Cairo PNG support is about twice as fast, but we have
;; less control, and there are problems making deallocation reliable
;; (in case of exceptions or termination):
#;
(let ([proc (lambda (ignored bstr len)
(read-bytes! (scheme_make_sized_byte_string bstr len 0) in)
CAIRO_STATUS_SUCCESS)])
(with-holding
proc
(values (cairo_image_surface_create_from_png_stream proc) #f)))
;; Using libpng directly:
(let-values ([(r w h b&w? alpha?) (create-png-reader
in
(and bg
(list (send bg red)
(send bg green)
(send bg blue))))])
(let ([rows (read-png r)])
(destroy-png-reader r)
(let* ([s (cairo_image_surface_create CAIRO_FORMAT_ARGB32 w h)]
[pre? (and alpha? (memq kind '(png/alpha png/mask)))])
(install-from-png-arrays s w h rows b&w? alpha? pre? #f)
(values s b&w?))))]
[(jpeg jpeg/alpha)
(let ([d (create-decompress in)])
(dynamic-wind
void
(lambda ()
(jpeg_read_header d #t)
(jpeg_start_decompress d)
(let ([w (jpeg_decompress_struct-output_width d)]
[h (jpeg_decompress_struct-output_height d)]
[c (jpeg_decompress_struct-output_components d)])
(let-values ([(samps bstr) (create-jpeg-sample-array d (* w c))]
[(A R G B) (argb-indices)])
(let* ([s (cairo_image_surface_create CAIRO_FORMAT_ARGB32 w h)]
[dest (begin
(cairo_surface_flush s)
(cairo_image_surface_get_data s))]
[dest-row-width (cairo_image_surface_get_stride s)])
(for ([j (in-range h)])
(jpeg_read_scanlines d samps 1)
(let ([row (* dest-row-width j)])
(for ([i (in-range w)])
(let ([4i (fx+ row (fx* 4 i))]
[ci (fx* c i)])
(unsafe-bytes-set! dest (fx+ 4i A) 255)
(if (= c 1)
(let ([v (unsafe-bytes-ref bstr ci)])
(unsafe-bytes-set! dest (fx+ 4i R) v)
(unsafe-bytes-set! dest (fx+ 4i G) v)
(unsafe-bytes-set! dest (fx+ 4i B) v))
(begin
(unsafe-bytes-set! dest (fx+ 4i R) (unsafe-bytes-ref bstr ci))
(unsafe-bytes-set! dest (fx+ 4i G) (unsafe-bytes-ref bstr (fx+ ci 1)))
(unsafe-bytes-set! dest (fx+ 4i B) (unsafe-bytes-ref bstr (fx+ ci 2)))))))))
(cairo_surface_mark_dirty s)
(jpeg_finish_decompress d)
(values s #f)))))
(lambda ()
(destroy-decompress d))))]
[(gif gif/mask gif/alpha
bmp bmp/mask bmp/alpha)
(let* ([s (cairo_image_surface_create CAIRO_FORMAT_ARGB32 10 10)])
(values s #f))]
[(xbm xbm/alpha)
(let-values ([(w h rows) (read-xbm in)])
(if rows
(let ([s (cairo_image_surface_create CAIRO_FORMAT_ARGB32 w h)])
(install-from-png-arrays s w h rows #t #f #f #t)
(values s #t))
(values #f #f)))]
[else (values #f #f)])))
(define/private (install-from-png-arrays s w h rows b&w? alpha? pre? backward?)
(let* ([dest (begin
(cairo_surface_flush s)
(cairo_image_surface_get_data s))]
[dest-row-width (cairo_image_surface_get_stride s)])
(let-values ([(A R G B) (argb-indices)])
(for ([r (in-vector rows)]
[j (in-naturals)])
(let ([row (* dest-row-width j)])
(if b&w?
(for ([i (in-range w)])
(let ([b (unsafe-fxquotient i 8)]
[bit (if backward?
(unsafe-fxlshift 1 (unsafe-fxand i 7))
(unsafe-fxrshift 128 (unsafe-fxand i 7)))]
[pos (fx+ row (fx* 4 i))])
(let* ([v (if (zero? (unsafe-fxand bit (unsafe-bytes-ref r b)))
0
255)]
[v (if backward? (- 255 v) v)])
(unsafe-bytes-set! dest (fx+ pos A) (- 255 v))
(unsafe-bytes-set! dest (fx+ pos 1) v)
(unsafe-bytes-set! dest (fx+ pos 2) v)
(unsafe-bytes-set! dest (fx+ pos B) v))))
(for ([i (in-range w)])
(let* ([4i (fx* 4 i)]
[pos (fx+ row 4i)]
[spos (if alpha?
(fx* 4 i)
(fx* 3 i))]
[al (if alpha?
(unsafe-bytes-ref r (fx+ spos 3))
255)]
[a (if pre?
al
255)]
[premult (lambda (al v)
(if pre?
(unsafe-fxquotient (fx* al v) 255)
(if alpha?
(unsafe-fxquotient
(+ (* 255 (- 255 al))
(* v al))
255)
v)))])
(unsafe-bytes-set! dest (fx+ pos A) a)
(unsafe-bytes-set! dest (fx+ pos R) (premult al (unsafe-bytes-ref r spos)))
(unsafe-bytes-set! dest (fx+ pos G) (premult al (unsafe-bytes-ref r (fx+ spos 1))))
(unsafe-bytes-set! dest (fx+ pos B) (premult al (unsafe-bytes-ref r (fx+ spos 2))))))))))
(cairo_surface_mark_dirty s)))
(def/public (save-file [(make-alts path-string? output-port?) out]
[save-kind-symbol? [kind 'unknown]]
[quality-integer? [quality 75]])
(check-ok 'save-file)
(do-save-file out kind quality))
(define/private (do-save-file out kind quality)
(if (path-string? out)
(call-with-output-file*
out
#:exists 'truncate/replace
(lambda (out) (do-save-file out kind quality)))
(case kind
[(png)
(cond
[b&w?
;; Write a 1-bit png
(let* ([b (ceiling (/ width 8))]
[rows (build-vector height (lambda (i) (make-bytes b)))]
[data (begin (cairo_surface_flush s)
(cairo_image_surface_get_data s))]
[row-width (cairo_image_surface_get_stride s)])
(for ([j (in-range height)])
(let ([row (vector-ref rows j)])
(for ([bi (in-range b)])
(bytes-set!
row
bi
(let ([src (+ (* j row-width) (* (* bi 8) 4))])
(for/fold ([v 0])
([k (in-range 8)])
(if ((+ (* 8 bi) k) . < . width)
(if (zero? (bytes-ref data (+ src (* 4 k))))
v
(bitwise-ior v (unsafe-fxrshift 128 k)))
v)))))))
(let ([w (create-png-writer out width height #t #f)])
(write-png w rows)
(destroy-png-writer w)))]
[(and (not alpha-channel?)
loaded-mask
(= width (send loaded-mask get-width))
(= height (send loaded-mask get-height)))
(let ([bstr (make-bytes (* width height 4))])
(get-argb-pixels 0 0 width height bstr)
(get-argb-pixels 0 0 width height bstr #t)
;; PNG wants RGBA instead of ARGB...
(let ([rows (build-vector height (lambda (i) (make-bytes (* 4 width))))])
(for ([j (in-range height)]
[dest-row (in-vector rows)])
(let ([src-row (* j (* 4 width))])
(for ([i (in-range width)])
(let* ([4i (* 4 i)]
[ri (+ src-row 4i)])
(bytes-set! dest-row 4i (bytes-ref bstr (+ 1 ri)))
(bytes-set! dest-row (+ 4i 1) (bytes-ref bstr (+ 2 ri)))
(bytes-set! dest-row (+ 4i 2) (bytes-ref bstr (+ 3 ri)))
(bytes-set! dest-row (+ 4i 3) (bytes-ref bstr ri))))))
(let ([w (create-png-writer out width height #f #t)])
(write-png w rows)
(destroy-png-writer w))))]
[else
;; Use Cairo built-in support:
(let ([proc (lambda (ignored bstr len)
(write-bytes (scheme_make_sized_byte_string bstr len 0) out)
CAIRO_STATUS_SUCCESS)])
(with-holding
proc
(cairo_surface_write_to_png_stream s proc)))])]
[(jpeg)
(let ([c (create-compress out)])
(dynamic-wind
void
(lambda ()
(set-jpeg_compress_struct-image_width! c width)
(set-jpeg_compress_struct-image_height! c height)
(set-jpeg_compress_struct-input_components! c 3)
(set-jpeg_compress_struct-in_color_space! c JCS_RGB)
(jpeg_set_defaults c)
(jpeg_set_quality c quality #t)
(jpeg_start_compress c #t)
(let-values ([(samps bstr) (create-jpeg-sample-array c (* width height 3))]
[(A R G B) (argb-indices)])
(cairo_surface_flush s)
(let* ([dest (cairo_image_surface_get_data s)]
[dest-row-width (cairo_image_surface_get_stride s)]
[h height]
[w width])
(for ([j (in-range h)])
(let ([row (* dest-row-width j)])
(for ([i (in-range w)])
(let ([4i (* 4 i)]
[ci (* 3 i)])
(bytes-set! bstr ci (bytes-ref dest (+ row (+ 4i R))))
(bytes-set! bstr (+ ci 1) (bytes-ref dest (+ row (+ 4i G))))
(bytes-set! bstr (+ ci 2) (bytes-ref dest (+ row (+ 4i B)))))))
(jpeg_write_scanlines c samps 1))))
(jpeg_finish_compress c))
(lambda () (destroy-compress c))))]
[else (error (method-name 'bitmap% 'save-file)
"kind saving not yet implemented: ~e"
kind)])))
(def/public (ok?) (and s #t))
(define/public (get-cairo-surface) s)
(define/public (get-cairo-alpha-surface)
(if (or b&w? alpha-channel?)
s
(begin
(prep-alpha)
alpha-s)))
(def/public (get-argb-pixels [exact-nonnegative-integer? x]
[exact-nonnegative-integer? y]
[exact-nonnegative-integer? w]
[exact-nonnegative-integer? h]
[bytes? bstr]
[any? [get-alpha? #f]])
(unless ((bytes-length bstr) . > . (* w h))
(raise-mismatch-error (method-name 'bitmap% 'get-argb-pixels)
"byte string is too short: "
bstr))
;; Fill range that is beyond edge of picture:
(if get-alpha?
(for* ([i (in-range width (+ x w))]
[j (in-range height (+ y h))])
(bytes-set! bstr (* 4 (+ i (* j w))) 255))
(for* ([i (in-range width (+ x w))]
[j (in-range height (+ y h))])
(let ([p (* 4 (+ i (* j w)))])
(bytes-set! bstr p 255)
(bytes-set! bstr (+ p 1) 0)
(bytes-set! bstr (+ p 2) 0)
(bytes-set! bstr (+ p 3) 0))))
;; Get pixels:
(let-values ([(A R G B) (argb-indices)])
(when (not get-alpha?)
(cairo_surface_flush s)
(let ([data (cairo_image_surface_get_data s)]
[row-width (cairo_image_surface_get_stride s)])
(let ([w (min (- width x) w)])
(for* ([j (in-range y (min (+ y h) height))])
(let ([row (* j row-width)]
[p (* 4 (+ x (* j w)))])
(for ([i (in-range x w)])
(let* ([4i (* 4 i)]
[pi (+ p 4i)]
[ri (+ row 4i)]
[a (bytes-ref data (+ ri A))]
[unmult (lambda (a v)
(if alpha-channel?
(if (zero? a)
255
(unsafe-fxquotient (fx* v 255) a))
v))])
(when alpha-channel?
(bytes-set! bstr pi a))
(bytes-set! bstr (+ pi 1) (unmult a (bytes-ref data (+ ri R))))
(bytes-set! bstr (+ pi 2) (unmult a (bytes-ref data (+ ri G))))
(bytes-set! bstr (+ pi 3) (unmult a (bytes-ref data (+ ri B))))))))))))
(cond
[(and get-alpha?
(not alpha-channel?)
loaded-mask
(= width (send loaded-mask get-width))
(= height (send loaded-mask get-height)))
;; Get alpha from mask bitmap:
(send loaded-mask get-alphas-as-mask x y w h bstr)]
[(and get-alpha? alpha-channel?)
(get-alphas-as-mask x y w h bstr)]
[(and (not get-alpha?) (not alpha-channel?))
;; For non-alpha mode or no mask; fill in 255s:
(for ([j (in-range y (min (+ y h) height))])
(let ([row (* j (* 4 w))])
(for ([i (in-range x (min (+ x w) width))])
(let ([p (+ (* 4 i) row)])
(bytes-set! bstr p 255)))))]))
(def/public (set-argb-pixels [exact-nonnegative-integer? x]
[exact-nonnegative-integer? y]
[exact-nonnegative-integer? w]
[exact-nonnegative-integer? h]
[bytes? bstr]
[any? [set-alpha? #f]])
(unless ((bytes-length bstr) . > . (* w h))
(raise-mismatch-error (method-name 'bitmap% 'set-argb-pixels)
"byte string is too short: "
bstr))
;; Set pixels:
(let-values ([(A R G B) (argb-indices)])
(when (not set-alpha?)
(cairo_surface_flush s)
(let ([data (cairo_image_surface_get_data s)]
[row-width (cairo_image_surface_get_stride s)])
(let ([w (min (- width x) w)])
(for ([j (in-range y (min (+ y h) height))]
[dj (in-naturals)])
(let ([row (* j row-width)]
[p (* 4 (* dj w))])
(for ([i (in-range x w)])
(let* ([4i (* 4 i)]
[pi (+ p 4i)]
[ri (+ row 4i)])
(if b&w?
(let ([v (if (and (= (bytes-ref bstr (+ pi 1)) 255)
(= (bytes-ref bstr (+ pi 2)) 255)
(= (bytes-ref bstr (+ pi 3)) 255))
255
0)])
(bytes-set! data (+ ri A) (- 255 v))
(bytes-set! data (+ ri R) v)
(bytes-set! data (+ ri G) v)
(bytes-set! data (+ ri B) v))
(begin
(when alpha-channel?
(bytes-set! data (+ ri A) (bytes-ref bstr pi)))
(bytes-set! data (+ ri R) (bytes-ref bstr (+ pi 1)))
(bytes-set! data (+ ri G) (bytes-ref bstr (+ pi 2)))
(bytes-set! data (+ ri B) (bytes-ref bstr (+ pi 3)))))))))))
(cairo_surface_mark_dirty s)))
(cond
[(and set-alpha?
(not alpha-channel?)
loaded-mask
(= width (send loaded-mask get-width))
(= height (send loaded-mask get-height)))
;; Set alphas in mask bitmap:
(send loaded-mask set-alphas-as-mask x y w h bstr (* 4 w) 0)]))
(define/public (get-alphas-as-mask x y w h bstr)
(let ([data (cairo_image_surface_get_data (if (or b&w? alpha-channel?)
(begin
(cairo_surface_flush s)
s)
(begin
(prep-alpha)
(cairo_surface_flush alpha-s)
alpha-s)))]
[row-width (cairo_image_surface_get_stride s)]
[A (a-index)])
(for ([j (in-range y (min (+ y h) height))])
(let ([row (* j row-width)])
(for ([i (in-range x (min (+ x w) width))])
(let ([p (* 4 (+ i (* j w)))]
[q (+ row (* i 4))])
(bytes-set! bstr p (bytes-ref data (+ q A)))))))))
(define/public (prep-alpha)
(when (and (not b&w?)
(not alpha-channel?))
(unless alpha-s-up-to-date?
(unless alpha-s
(set! alpha-s (cairo_image_surface_create CAIRO_FORMAT_ARGB32
width height)))
(cairo_surface_flush s)
(cairo_surface_flush alpha-s)
(let ([data (cairo_image_surface_get_data s)]
[alpha-data (cairo_image_surface_get_data alpha-s)]
[row-width (cairo_image_surface_get_stride s)]
[A (a-index)]
[B (b-index)])
(for ([j (in-range height)])
(let ([row (* j row-width)])
(for ([i (in-range width)])
(let ([q (+ row (* i 4))])
(bytes-set! alpha-data
(+ q A)
(- 255
(quotient
(+ (+ (bytes-ref data (+ q 1))
(bytes-ref data (+ q 2)))
(bytes-ref data (+ q B)))
3))))))))
(set! alpha-s-up-to-date? #t))))
(define/public (transparent-white! s width height)
(let ([bstr (cairo_image_surface_get_data s)]
[row-width (cairo_image_surface_get_stride s)]
[A (a-index)])
(bytes-fill! bstr 255)
(for ([j (in-range height)])
(let ([row (* j row-width)])
(for ([i (in-range width)])
(bytes-set! bstr (+ A (+ row (* i 4))) 0))))))
(define/public (set-alphas-as-mask x y w h bstr src-w src-A)
(when (or b&w? (and (not b&w?) (not alpha-channel?)))
(let ([data (cairo_image_surface_get_data s)]
[row-width (cairo_image_surface_get_stride s)]
[A (a-index)]
[B (b-index)])
(cairo_surface_flush s)
(for ([j (in-range y (min (+ y h) height))])
(let ([row (* j row-width)]
[src-row (* (- j y) src-w)])
(for ([i (in-range x (min (+ x w) width))])
(let* ([p (+ (* 4 (- i x)) src-row)]
[q (+ (* 4 i) row)])
(let* ([v (bytes-ref bstr (+ p src-A))]
[vv (- 255 v)])
(bytes-set! data (+ q B) vv)
(bytes-set! data (+ q 1) vv)
(bytes-set! data (+ q 2) vv)
(bytes-set! data (+ q A) (if b&w? v 255)))))))
(cairo_surface_mark_dirty s))))
))

114
collects/racket/draw/brush.rkt Normal file
View File

@ -0,0 +1,114 @@
#lang scheme/base
(require scheme/class
"color.ss"
"syntax.ss"
"local.ss"
"bitmap.ss")
(provide brush%
brush-list% the-brush-list
brush-style-symbol?)
(define (brush-style-symbol? s)
(memq s '(transparent solid opaque
xor hilite panel
bdiagonal-hatch crossdiag-hatch
fdiagonal-hatch cross-hatch
horizontal-hatch vertical-hatch)))
(define black (send the-color-database find-color "black"))
(define-local-member-name s-set-key)
(defclass brush% object%
(define key #f)
(define/public (s-set-key k) (set! key k))
(define color black)
(properties #:check-immutable check-immutable
[[brush-style-symbol? style] 'solid])
(init-rest args)
(super-new)
(case-args
args
[() (void)]
[([color% _color]
[brush-style-symbol? _style])
(set! color (color->immutable-color _color))
(set! style _style)]
[([string? _color]
[brush-style-symbol? _style])
(set! color (send the-color-database find-color _color))
(set! style _style)]
(init-name 'brush%))
(define immutable? #f)
(define lock-count 0)
(define/public (set-immutable) (set! immutable? #t))
(define/public (is-immutable?) (or immutable? (positive? lock-count)))
(define/public (adjust-lock v) (set! lock-count (+ lock-count v)))
(define/private (check-immutable s)
(when (or immutable? (positive? lock-count))
(error (method-name 'brush% s) "object is ~a"
(if immutable? "immutable" "locked"))))
(define/public (set-color . args)
(check-immutable 'set-color)
(case-args
args
[([color% _color])
(set! color (color->immutable-color _color))]
[([string? _color])
(set! color (send the-color-database find-color _color))]
[([byte? r] [byte? g] [byte? b])
(let ([c (make-object color% r g b)])
(send c set-immutable)
(set! color c))]
(method-name 'brush% 'set-color)))
(define/public (get-color) color)
(define stipple #f)
(def/public (get-stipple) stipple)
(def/public (set-stipple [(make-or-false bitmap%) s])
(check-immutable 'set-stipple)
(let ([old-s stipple])
(set! stipple #f)
(when old-s (send old-s adjust-lock -1)))
(when s (send s adjust-lock 1))
(set! stipple s)))
;; ----------------------------------------
(defclass brush-list% object%
(define brushes (make-weak-hash))
(super-new)
(define/public (find-or-create-brush . args)
(let-values ([(col s)
(case-args
args
[([color% _color]
[brush-style-symbol? _style])
(values (color->immutable-color _color) _style)]
[([string? _color]
[brush-style-symbol? _style])
(values (send the-color-database find-color _color)
_style)]
(method-name 'find-or-create-brush 'brush-list%))])
(let ([key (vector (send col red) (send col green) (send col blue)
s)])
(let ([e (hash-ref brushes key #f)])
(or (and e
(ephemeron-value e))
(let* ([f (make-object brush% col s)]
[e (make-ephemeron key f)])
(send f s-set-key key)
(hash-set! brushes key e)
f)))))))
(define the-brush-list (new brush-list%))

9
collects/racket/draw/bstr.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang racket/base
(require ffi/unsafe)
(provide (protect-out scheme_make_sized_byte_string))
(define scheme_make_sized_byte_string
(get-ffi-obj 'scheme_make_sized_byte_string #f (_fun _pointer _long _int -> _scheme)))

248
collects/racket/draw/cairo.rkt Normal file
View File

@ -0,0 +1,248 @@
#lang scheme/base
(require ffi/unsafe
ffi/unsafe/define
ffi/unsafe/alloc
setup/dirs
"utils.rkt")
(define cairo-lib
(case (system-type)
[(macosx) (ffi-lib "libcairo.2")]
[(unix) (ffi-lib "libcairo" '("2"))]
[(windows)
(ffi-lib "zlib1")
(ffi-lib "libpng14-14")
(ffi-lib "libexpat-1")
(ffi-lib "freetype6")
(ffi-lib "libfontconfig-1")
(ffi-lib "libcairo-2")]))
(define gdk-lib
(case (system-type)
[(unix) (ffi-lib "libgdk-x11-2.0" '("0"))]
[else #f]))
(define-ffi-definer define-cairo cairo-lib
#:provide provide-protected)
(provide _cairo_t
_cairo_font_options_t)
(define _cairo_surface_t (_cpointer 'cairo_surface_t))
(define _cairo_surface_t/null (_cpointer/null 'cairo_surface_t))
(define _cairo_t (_cpointer 'cairo_t))
(define _cairo_pattern_t (_cpointer 'cairo_pattern_t))
(define _cairo_font_options_t (_cpointer/null 'cairo_font_options_t))
(define _CGContextRef _pointer)
(define-cstruct _cairo_matrix_t ([xx _double*]
[yx _double*]
[xy _double*]
[yy _double*]
[x0 _double*]
[y0 _double*]))
(provide make-cairo_matrix_t)
(define-cstruct _cairo_glyph_t ([index _long] [x _double*] [y _double*]))
(provide make-cairo_glyph_t)
(define-cairo cairo_destroy (_fun _cairo_t -> _void)
#:wrap (deallocator))
(define-cairo cairo_surface_destroy (_fun _cairo_surface_t -> _void)
#:wrap (deallocator))
(define-cairo cairo_quartz_surface_create_for_cg_context
(_fun _CGContextRef _uint _uint -> _cairo_surface_t)
#:make-fail make-not-available
#:wrap (allocator cairo_surface_destroy))
(define-cairo cairo_win32_surface_create
(_fun _pointer -> _cairo_surface_t)
#:make-fail make-not-available
#:wrap (allocator cairo_surface_destroy))
(define-cairo cairo_create (_fun _cairo_surface_t -> _cairo_t)
#:wrap (allocator cairo_destroy))
(define-cairo cairo_get_target (_fun _cairo_t -> _cairo_surface_t)) ;; not an allocator
;; Context
(define-cairo cairo_paint (_fun _cairo_t -> _void))
(define-cairo cairo_fill (_fun _cairo_t -> _void))
(define-cairo cairo_fill_preserve (_fun _cairo_t -> _void))
(define-cairo cairo_stroke (_fun _cairo_t -> _void))
(define-cairo cairo_stroke_preserve (_fun _cairo_t -> _void))
(define-cairo cairo_save (_fun _cairo_t -> _void))
(define-cairo cairo_restore (_fun _cairo_t -> _void))
(define-cairo cairo_clip (_fun _cairo_t -> _void))
(define-cairo cairo_reset_clip (_fun _cairo_t -> _void))
(define-cairo cairo_in_fill (_fun _cairo_t _double* _double* -> _bool))
(define-cairo cairo_clip_extents (_fun _cairo_t
(x1 : (_ptr o _double))
(y1 : (_ptr o _double))
(x2 : (_ptr o _double))
(y2 : (_ptr o _double))
-> _void
-> (values x1 y1 x2 y2)))
;; Transforms
(define-cairo cairo_translate (_fun _cairo_t _double* _double* -> _void))
(define-cairo cairo_scale (_fun _cairo_t _double* _double* -> _void))
(define-cairo cairo_rotate (_fun _cairo_t _double* -> _void))
(define-cairo cairo_identity_matrix (_fun _cairo_t -> _void))
(define-cairo cairo_matrix_init_translate (_fun _cairo_matrix_t-pointer _double* _double* -> _void))
;; Stroke & Fill
(define-cairo cairo_set_source_rgb (_fun _cairo_t _double* _double* _double* -> _void))
(define-cairo cairo_set_source_rgba (_fun _cairo_t _double* _double* _double* _double* -> _void))
(define-cairo cairo_set_line_width (_fun _cairo_t _double* -> _void))
(define-cairo cairo_set_line_cap (_fun _cairo_t _int -> _void))
(define-cairo cairo_set_line_join (_fun _cairo_t _int -> _void))
(define-cairo cairo_set_dash (_fun _cairo_t (v : (_vector i _double*)) [_int = (vector-length v)] _double* -> _void))
(define-cairo cairo_set_antialias (_fun _cairo_t _int -> _void))
(define-cairo cairo_set_fill_rule (_fun _cairo_t _int -> _void))
(define-cairo cairo_get_operator (_fun _cairo_t -> _int))
(define-cairo cairo_set_operator (_fun _cairo_t _int -> _void))
;; Text
(define-cairo cairo_font_options_destroy (_fun _cairo_font_options_t -> _void)
#:wrap (deallocator))
(define-cairo cairo_font_options_create (_fun -> _cairo_font_options_t)
#:wrap (allocator cairo_font_options_destroy))
(define-cairo cairo_font_options_copy (_fun _cairo_font_options_t _cairo_font_options_t -> _void))
(define-cairo cairo_get_font_options (_fun _cairo_t _cairo_font_options_t -> _void))
(define-cairo cairo_set_font_options (_fun _cairo_t _cairo_font_options_t -> _void))
(define-cairo cairo_font_options_set_antialias (_fun _cairo_font_options_t _int -> _void))
(define-cairo cairo_show_glyphs (_fun _cairo_t _cairo_glyph_t-pointer _int -> _void))
;; Paths
(define-cairo cairo_rectangle (_fun _cairo_t _double* _double* _double* _double* -> _void))
(define-cairo cairo_move_to (_fun _cairo_t _double* _double* -> _void))
(define-cairo cairo_rel_move_to (_fun _cairo_t _double* _double* -> _void))
(define-cairo cairo_line_to (_fun _cairo_t _double* _double* -> _void))
(define-cairo cairo_rel_line_to (_fun _cairo_t _double* _double* -> _void))
(define-cairo cairo_arc (_fun _cairo_t _double* _double* _double* _double* _double* -> _void))
(define-cairo cairo_arc_negative (_fun _cairo_t _double* _double* _double* _double* _double* -> _void))
(define-cairo cairo_curve_to (_fun _cairo_t _double* _double* _double* _double* _double* _double* -> _void))
(define-cairo cairo_new_path (_fun _cairo_t -> _void))
(define-cairo cairo_close_path (_fun _cairo_t -> _void))
(define-cairo cairo_show_page (_fun _cairo_t -> _void))
(define-cairo cairo_set_source (_fun _cairo_t _cairo_pattern_t -> _void))
(define-cairo cairo_get_source (_fun _cairo_t -> _cairo_pattern_t)) ;; not an allocator
(define-cairo cairo_set_source_surface (_fun _cairo_t _cairo_surface_t _double* _double* -> _void))
(define-cairo cairo_mask (_fun _cairo_t _cairo_pattern_t -> _void))
(define-cairo cairo_mask_surface (_fun _cairo_t _cairo_surface_t _double* _double* -> _void))
(define-cairo cairo_pattern_destroy (_fun _cairo_pattern_t -> _void)
#:wrap (deallocator))
(define-cairo cairo_pattern_create_for_surface (_fun _cairo_surface_t -> _cairo_pattern_t)
#:wrap (allocator cairo_pattern_destroy))
(define-cairo cairo_pattern_reference (_fun _cairo_pattern_t -> _void)
#:wrap (retainer cairo_pattern_destroy car))
(define-cairo cairo_pattern_set_matrix (_fun _cairo_pattern_t _cairo_matrix_t-pointer -> _void))
(define-cairo cairo_pattern_set_extend (_fun _cairo_pattern_t _int -> _void))
;; Surfaces
(define-cairo cairo_surface_finish (_fun _cairo_surface_t -> _void))
(define-cairo cairo_surface_flush (_fun _cairo_surface_t -> _void))
(define-cairo cairo_surface_mark_dirty (_fun _cairo_surface_t -> _void))
(define-cairo cairo_image_surface_create (_fun _int _int _int -> _cairo_surface_t)
#:wrap (allocator cairo_surface_destroy))
(define-cairo cairo_ps_surface_create (_fun _path _double* _double* -> _cairo_surface_t)
#:wrap (allocator cairo_surface_destroy))
(define-cairo cairo_ps_surface_set_eps (_fun _cairo_surface_t _bool -> _void))
(define-cairo cairo_image_surface_get_data (_fun (s : _cairo_surface_t)
-> (_bytes o
(* (cairo_image_surface_get_height s)
(cairo_image_surface_get_stride s)))))
(define-cairo cairo_image_surface_get_width (_fun _cairo_surface_t -> _int))
(define-cairo cairo_image_surface_get_height (_fun _cairo_surface_t -> _int))
(define-cairo cairo_image_surface_get_stride (_fun _cairo_surface_t -> _int))
(define-cairo cairo_image_surface_get_format (_fun _cairo_surface_t -> _int))
;; Not recommended, because it's not registered as an allocator (can't
;; call it in atomic mode):
(define-cairo cairo_image_surface_create_from_png_stream (_fun (_fun _pointer
(s : _pointer)
(len : _int)
-> _int)
(_pointer = #f)
-> _cairo_surface_t/null))
(define-cairo cairo_surface_write_to_png_stream (_fun _cairo_surface_t
(_fun _pointer
(s : _pointer)
(len : _int)
-> _int)
(_pointer = #f)
-> _int))
(define-enum
0
CAIRO_OPERATOR_CLEAR
CAIRO_OPERATOR_SOURCE
CAIRO_OPERATOR_OVER
CAIRO_OPERATOR_IN
CAIRO_OPERATOR_OUT
CAIRO_OPERATOR_ATOP
CAIRO_OPERATOR_DEST
CAIRO_OPERATOR_DEST_OVER
CAIRO_OPERATOR_DEST_IN
CAIRO_OPERATOR_DEST_OUT
CAIRO_OPERATOR_DEST_ATOP
CAIRO_OPERATOR_XOR
CAIRO_OPERATOR_ADD
CAIRO_OPERATOR_SATURATE)
(define-enum
0
CAIRO_LINE_CAP_BUTT
CAIRO_LINE_CAP_ROUND
CAIRO_LINE_CAP_SQUARE)
(define-enum
0
CAIRO_LINE_JOIN_MITER
CAIRO_LINE_JOIN_ROUND
CAIRO_LINE_JOIN_BEVEL)
(define-enum
0
CAIRO_FILL_RULE_WINDING
CAIRO_FILL_RULE_EVEN_ODD)
(define-enum
0
CAIRO_ANTIALIAS_DEFAULT
CAIRO_ANTIALIAS_NONE
CAIRO_ANTIALIAS_GRAY
CAIRO_ANTIALIAS_SUBPIXEL)
(define-enum
0
CAIRO_FORMAT_ARGB32
CAIRO_FORMAT_RGB24
CAIRO_FORMAT_A8
CAIRO_FORMAT_A1)
(define-enum
0
CAIRO_STATUS_SUCCESS)
(define-enum
0
CAIRO_EXTEND_NONE
CAIRO_EXTEND_REPEAT
CAIRO_EXTEND_REFLECT
CAIRO_EXTEND_PAD)

277
collects/racket/draw/color.rkt Normal file
View File

@ -0,0 +1,277 @@
#lang scheme/base
(require scheme/class
"syntax.ss")
(provide color%
color-red
color-green
color-blue
color-database<%> the-color-database
color->immutable-color)
(define-local-member-name
r g b)
(defclass color% object%
(field [r 0]
[g 0]
[b 0])
(define immutable? #f)
(init-rest args)
(super-new)
(case-args
args
[() (void)]
[([string? s])
(let ([v (hash-ref colors (string-foldcase s) #f)])
(if v
(begin
(set! r (vector-ref v 0))
(set! g (vector-ref v 1))
(set! b (vector-ref v 2)))
(error 'color% "unknown color name: ~e" (car args))))]
[([color% c])
(set! r (color-red c))
(set! g (color-green c))
(set! b (color-blue c))]
[([byte? _r][byte? _g][byte? _b])
(set! r _r)
(set! g (cadr args))
(set! b (caddr args))]
(init-name 'color%))
(def/public (red) r)
(def/public (green) g)
(def/public (blue) b)
(def/public (set [byte? rr] [byte? rg] [byte? rb])
(if immutable?
(error (method-name 'color% 'set) "object is immutable")
(begin
(set! r rr)
(set! g rg)
(set! b rb))))
(def/public (ok?) #t)
(def/public (is-immutable?) immutable?)
(def/public (set-immutable) (set! immutable? #t))
(def/public (copy-from [color% c])
(if immutable?
(error (method-name 'color% 'copy-from) "object is immutable")
(set (send c red) (send c green) (send c blue)))))
(define color-red (class-field-accessor color% r))
(define color-green (class-field-accessor color% g))
(define color-blue (class-field-accessor color% b))
(define (color->immutable-color c)
(if (send c is-immutable?)
c
(let ([c2 (new color%)])
(send c2 copy-from c)
(send c2 set-immutable)
c2)))
(define color-objects (make-hash))
(defclass color-database<%> object%
(super-new)
(def/public (find-color [string? name])
(let ([name (string-downcase name)])
(or (hash-ref color-objects name #f)
(let ([v (hash-ref colors (string-foldcase name) #f)])
(if v
(let ([c (new color%)])
(send c set (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))
(send c set-immutable)
(hash-set! color-objects name c)
c)
#f))))))
(define the-color-database (new color-database<%>))
(define colors
#hash(("aliceblue" . #(240 248 255))
("antiquewhite" . #(250 235 215))
("aqua" . #(0 255 255))
("azure" . #(240 255 255))
("beige" . #(245 245 220))
("bisque" . #(255 228 196))
("blanchedalmond" . #(255 235 205))
("blueviolet" . #(138 43 226))
("burlywood" . #(222 184 135))
("cadetblue" . #(95 158 160))
("chartreuse" . #(127 255 0))
("chocolate" . #(210 105 30))
("cornflowerblue" . #(100 149 237))
("cornsilk" . #(255 248 220))
("crimson" . #(220 20 60))
("darkblue" . #(0 0 139))
("darkcyan" . #(0 139 139))
("darkgoldenrod" . #(184 134 11))
("darkgray" . #(169 169 169))
("darkgreen" . #(0 100 0))
("darkkhaki" . #(189 183 107))
("darkmagenta" . #(139 0 139))
("darkolivegreen" . #(85 107 47))
("darkorange" . #(255 140 0))
("darkorchid" . #(153 50 204))
("darkred" . #(139 0 0))
("darksalmon" . #(233 150 122))
("darkseagreen" . #(143 188 139))
("darkslateblue" . #(72 61 139))
("darkslategray" . #(47 79 79))
("darkturquoise" . #(0 206 209))
("darkviolet" . #(148 0 211))
("deeppink" . #(255 20 147))
("deepskyblue" . #(0 191 255))
("dimgray" . #(105 105 105))
("dodgerblue" . #(30 144 255))
("floralwhite" . #(255 250 240))
("forestgreen" . #(34 139 34))
("fuchsia" . #(255 0 255))
("gainsboro" . #(220 220 220))
("ghostwhite" . #(248 248 255))
("greenyellow" . #(173 255 47))
("honeydew" . #(240 255 240))
("hotpink" . #(255 105 180))
("indianred" . #(205 92 92))
("indigo" . #(75 0 130))
("ivory" . #(255 255 240))
("lavender" . #(230 230 250))
("lavenderblush" . #(255 240 245))
("lawngreen" . #(124 252 0))
("lemonchiffon" . #(255 250 205))
("lightblue" . #(173 216 230))
("lightcoral" . #(240 128 128))
("lightcyan" . #(224 255 255))
("lightgoldenrodyellow" . #(250 250 210))
("lightgreen" . #(144 238 144))
("lightgray" . #(211 211 211))
("lightpink" . #(255 182 193))
("lightsalmon" . #(255 160 122))
("lightseagreen" . #(32 178 170))
("lightskyblue" . #(135 206 250))
("lightslategray" . #(119 136 153))
("lightsteelblue" . #(176 196 222))
("lightyellow" . #(255 255 224))
("lime" . #(0 255 0))
("limegreen" . #(50 205 50))
("linen" . #(250 240 230))
("mediumaquamarine" . #(102 205 170))
("mediumblue" . #(0 0 205))
("mediumorchid" . #(186 85 211))
("mediumpurple" . #(147 112 219))
("mediumseagreen" . #(60 179 113))
("mediumslateblue" . #(123 104 238))
("mediumspringgreen" . #(0 250 154))
("mediumturquoise" . #(72 209 204))
("mediumvioletred" . #(199 21 133))
("midnightblue" . #(25 25 112))
("mintcream" . #(245 255 250))
("mistyrose" . #(255 228 225))
("moccasin" . #(255 228 181))
("navajowhite" . #(255 222 173))
("oldlace" . #(253 245 230))
("olive" . #(128 128 0))
("olivedrab" . #(107 142 35))
("orangered" . #(255 69 0))
("palegoldenrod" . #(238 232 170))
("palegreen" . #(152 251 152))
("paleturquoise" . #(175 238 238))
("palevioletred" . #(219 112 147))
("papayawhip" . #(255 239 213))
("peachpuff" . #(255 218 185))
("peru" . #(205 133 63))
("powderblue" . #(176 224 230))
("rosybrown" . #(188 143 143))
("royalblue" . #(65 105 225))
("saddlebrown" . #(139 69 19))
("sandybrown" . #(244 164 96))
("seagreen" . #(46 139 87))
("seashell" . #(255 245 238))
("silver" . #(192 192 192))
("skyblue" . #(135 206 235))
("slateblue" . #(106 90 205))
("slategray" . #(112 128 144))
("snow" . #(255 250 250))
("springgreen" . #(0 255 127))
("steelblue" . #(70 130 180))
("teal" . #(0 128 128))
("tomato" . #(255 99 71))
("whitesmoke" . #(245 245 245))
("yellowgreen" . #(154 205 50))
("aquamarine" . #(112 216 144))
("black" . #(0 0 0))
("blue" . #(0 0 255))
("blue violet" . #(138 43 226))
("brown" . #(132 60 36))
("cadet blue" . #(96 160 160))
("coral" . #(255 127 80))
("cornflower blue" . #(68 64 108))
("cyan" . #(0 255 255))
("dark gray" . #(169 169 169))
("dark green" . #(0 100 0))
("dark olive green" . #(85 107 47))
("dark orchid" . #(153 50 204))
("dark slate blue" . #(72 61 139))
("dark slate gray" . #(47 79 79))
("dark turquoise" . #(0 206 209))
("dim gray" . #(105 105 105))
("firebrick" . #(178 34 34))
("forest green" . #(34 139 34))
("gold" . #(255 215 0))
("goldenrod" . #(218 165 32))
("gray" . #(190 190 190))
("green" . #(0 255 0))
("green yellow" . #(173 255 47))
("indian red" . #(205 92 92))
("khaki" . #(240 230 140))
("light blue" . #(173 216 230))
("light gray" . #(211 211 211))
("light steel blue" . #(176 196 222))
("lime green" . #(50 205 50))
("magenta" . #(255 0 255))
("maroon" . #(176 48 96))
("medium aquamarine" . #(102 205 170))
("medium blue" . #(0 0 205))
("medium forest green" . #(107 142 35))
("mediumforestgreen" . #(107 142 35))
("medium goldenrod" . #(234 234 173))
("mediumgoldenrod" . #(234 234 173))
("medium orchid" . #(186 85 211))
("medium sea green" . #(60 179 113))
("medium slate blue" . #(123 104 238))
("medium spring green" . #(0 250 154))
("medium turquoise" . #(72 209 204))
("medium violet red" . #(199 21 133))
("midnight blue" . #(25 25 112))
("navy" . #(36 36 140))
("orange" . #(255 165 0))
("orange red" . #(255 69 0))
("orchid" . #(218 112 214))
("pale green" . #(152 251 152))
("pink" . #(255 192 203))
("plum" . #(221 160 221))
("purple" . #(160 32 240))
("red" . #(255 0 0))
("salmon" . #(250 128 114))
("sea green" . #(46 139 87))
("sienna" . #(160 82 45))
("sky blue" . #(135 206 235))
("slate blue" . #(106 90 205))
("spring green" . #(0 255 127))
("steel blue" . #(70 130 180))
("tan" . #(210 180 140))
("thistle" . #(216 191 216))
("turquoise" . #(64 224 208))
("violet" . #(238 130 238))
("violet red" . #(208 32 144))
("violetred" . #(208 32 144))
("wheat" . #(245 222 179))
("white" . #(255 255 255))
("yellow" . #(255 255 0))
("yellow green" . #(154 205 50))))

9
collects/racket/draw/dc-intf.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang scheme/base
(require scheme/class
"font.ss")
(provide dc<%>)
(define dc<%>
(interface ()
draw-text))

364
collects/racket/draw/dc-path.rkt Normal file
View File

@ -0,0 +1,364 @@
#lang scheme/base
(require mred/private/syntax
scheme/math
scheme/class
"cairo.ss"
"fmod.ss"
"point.ss"
(only-in scheme/base
[append s:append]
[reverse s:reverse]))
(provide dc-path%
do-path)
(define-local-member-name
get-closed-points
get-open-points
do-path)
(define 2pi (* 2.0 pi))
(define pi/2 (/ pi 2.0))
(define dc-path%
(class object%
;; A path is a list of pairs and vectors:
;; * The pairs corerspond to points on the path
;; * A vector must be between two pairs; it specifies
;; control points for a curve between the two points.
(define closed-points null)
(define rev-closed-points null)
(define open-points null)
(define rev-open-points null)
(define/private (flatten-open!)
(unless (null? rev-open-points)
(set! open-points (s:append open-points (s:reverse rev-open-points)))
(set! rev-open-points null)))
(define/private (flatten-closed!)
(unless (null? rev-closed-points)
(set! closed-points (s:append closed-points (s:reverse rev-closed-points)))
(set! rev-closed-points null)))
(define/public (get-closed-points) (flatten-closed!) closed-points)
(define/public (get-open-points) (flatten-open!) open-points)
(define/private (do-points cr l align-x align-y)
(let loop ([l l][first? #t])
(cond
[(null? l) (void)]
[else
(let ([p (car l)])
(if (pair? p)
(begin
(if first?
(cairo_move_to cr (align-x (car p)) (align-y (cdr p)))
(cairo_line_to cr (align-x (car p)) (align-y (cdr p))))
(loop (cdr l) #f))
(let ([p2 (cadr l)])
(cairo_curve_to cr
(align-x (vector-ref p 0)) (align-y (vector-ref p 1))
(align-x (vector-ref p 2)) (align-y (vector-ref p 3))
(align-x (car p2)) (align-y (cdr p2)))
(loop (cddr l) #f))))])))
(define/public (do-path cr align-x align-y)
(flatten-closed!)
(flatten-open!)
(for ([cp (in-list closed-points)])
(do-points cr cp align-x align-y)
(cairo_close_path cr))
(do-points cr open-points align-x align-y))
(def/public (append [dc-path% path])
(flatten-closed!)
(flatten-open!)
(set! closed-points (s:append closed-points (send path get-closed-points)))
(set! open-points (s:append open-points (send path get-open-points))))
(def/public (reset)
(set! open-points null)
(set! closed-points null)
(set! rev-open-points null)
(set! rev-closed-points null))
(def/public (reverse)
(flatten-closed!)
(flatten-open!)
(let ([rev-one (lambda (l)
(map (lambda (p)
(if (pair? p)
p
(vector (vector-ref p 2) (vector-ref p 3)
(vector-ref p 0) (vector-ref p 1))))
l))])
(set! open-points (map rev-one (s:reverse open-points)))
(set! closed-points (map rev-one (map s:reverse closed-points)))))
(def/public (close)
(flatten-open!)
(unless (null? open-points)
(set! rev-closed-points (cons open-points rev-closed-points))
(set! open-points null)))
(def/public (open?)
(or (pair? open-points)
(pair? rev-open-points)))
(def/public (get-bounding-box)
(flatten-closed!)
(flatten-open!)
(if (and (null? closed-points)
(null? open-points))
(values 0.0 0.0 0.0 0.0)
(let-values ([(l t r b)
(let loop ([l open-points])
(if (null? l)
(loop (car closed-points))
(let ([p (car l)])
(values (car p) (cdr p)
(car p) (cdr p)))))])
(for*/fold ([l l]
[t t]
[r r]
[b b])
([pts (in-list (cons open-points closed-points))]
[p (in-list pts)])
(cond
[(pair? p) (values (min l (car p))
(min t (cdr p))
(max r (car p))
(max b (cdr p)))]
[else (values (min l (vector-ref p 0) (vector-ref p 2))
(min t (vector-ref p 1) (vector-ref p 3))
(max r (vector-ref p 0) (vector-ref p 2))
(max b (vector-ref p 1) (vector-ref p 3)))])))))
(def/public (move-to [real? x] [real? y])
(when (or (pair? open-points)
(pair? rev-open-points))
(error (method-name 'dc-path% 'move-to) "path already open"))
(do-move-to x y))
(define/private (do-move-to x y)
(set! rev-open-points (list (cons (exact->inexact x) (exact->inexact y)))))
(def/public (line-to [real? x] [real? y])
(unless (or (pair? open-points)
(pair? rev-open-points))
(error (method-name 'dc-path% 'line-to) "path not yet open"))
(do-line-to x y))
(define/private (do-line-to x y)
(set! rev-open-points (cons (cons (exact->inexact x) (exact->inexact y)) rev-open-points)))
(def/public (lines [(make-alts (make-list point%) list-of-pair-of-real?) pts]
[real? [x 0.0]]
[real? [y 0.0]])
(unless (or (pair? open-points)
(pair? rev-open-points))
(error (method-name 'dc-path% 'lines) "path not yet open"))
(for ([p (in-lines pts)])
(if (pair? p)
(do-line-to (car p) (cdr p))
(do-line-to (point-x p) (point-y p)))))
(def/public (curve-to [real? x1] [real? y1] [real? x2] [real? y2] [real? x3] [real? y3])
(unless (or (pair? open-points)
(pair? rev-open-points))
(error (method-name 'dc-path% 'curve-to) "path not yet open"))
(do-curve-to x1 y1 x2 y2 x3 y3))
(define/private (do-curve-to x1 y1 x2 y2 x3 y3)
(set! rev-open-points (list* (cons (exact->inexact x3)
(exact->inexact y3))
(vector (exact->inexact x1)
(exact->inexact y1)
(exact->inexact x2)
(exact->inexact y2))
rev-open-points)))
(def/public (arc [real? x] [real? y]
[nonnegative-real? w] [nonnegative-real? h]
[real? start] [real? end] [any? [ccw? #t]])
(do-arc x y w h start end ccw?))
(define/private (do-arc x y w h start end ccw?)
(let-values ([(start end) (if (not ccw?)
(values end start)
(values start end))])
(let* ([delta (- end start)]
[delta (cond
[(delta . > . 2pi) (fmod delta 2pi)]
[(delta . < . 0) (+ (fmod delta 2pi) 2pi)]
[else delta])])
;; delta is positive and < 2pi
(let ([start (if (= delta 2pi) 0.0 start)])
;; Change top-left to center:
(let ([x (+ x (/ w 2.0))]
[y (+ y (/ h 2.0))]
[pts null])
;; make up to 4 curves to represent the arc:
(let loop ([start start]
[delta delta])
(when (positive? delta)
(let ([angle (if (delta . > . pi/2)
pi/2
delta)])
;; First generate points for an arc
;; of `angle' length from -angle/2 to
;; +angle/2:
(let* ([x0 (cos (/ angle 2))]
[y0 (sin (/ angle 2))]
[x1 (/ (- 4 x0) 3)]
[y1 (/ (* (- 1 x0) (- 3 x0)) (* 3 y0))]
[x2 x1]
[y2 (- y1)]
[x3 x0]
[y3 (- y0)])
;; Rotate to start:
(let* ([rotate (+ start (/ angle 2))]
[xx (cos rotate)]
[xy (sin rotate)]
[yy xx]
[yx (- xy)]
[rotate-xy (lambda (x y)
(values (+ (* xx x) (* xy y))
(+ (* yy y) (* yx x))))]
[w/2 (/ w 2.0)]
[h/2 (/ h 2.0)])
(let*-values ([(x0 y0) (rotate-xy x0 y0)]
[(x1 y1) (rotate-xy x1 y1)]
[(x2 y2) (rotate-xy x2 y2)]
[(x3 y3) (rotate-xy x3 y3)])
;; Scale and move to match ellipse:
(let ([x0 (+ (* x0 w/2) x)]
[x1 (+ (* x1 w/2) x)]
[x2 (+ (* x2 w/2) x)]
[x3 (+ (* x3 w/2) x)]
[y0 (+ (* y0 h/2) y)]
[y1 (+ (* y1 h/2) y)]
[y2 (+ (* y2 h/2) y)]
[y3 (+ (* y3 h/2) y)])
(set! pts
(cons
(if (positive? angle)
(if ccw?
(vector x0 y0 x1 y1 x2 y2 x3 y3)
(vector x3 y3 x2 y2 x1 y1 x0 y0))
(if ccw?
(vector x0 y0 x3 y3)
(vector x3 y3 x0 y0)))
pts))
(loop (+ start angle)
(- delta angle)))))))))
(for ([v (in-list (if ccw? (s:reverse pts) pts))])
(if (or (pair? open-points)
(pair? rev-open-points))
(do-line-to (vector-ref v 0) (vector-ref v 1))
(do-move-to (vector-ref v 0) (vector-ref v 1)))
(if (= (vector-length v) 4)
(do-line-to (vector-ref v 2) (vector-ref v 3))
(do-curve-to (vector-ref v 2) (vector-ref v 3)
(vector-ref v 4) (vector-ref v 5)
(vector-ref v 6) (vector-ref v 7)))))))))
(def/public (ellipse [real? x] [real? y]
[nonnegative-real? w] [nonnegative-real? h])
(when (open?) (close))
(do-arc x y w h 0 2pi #t))
(def/public (scale [real? x][real? y])
(unless (and (= x 1.0) (= y 1.0))
(flatten-open!)
(flatten-closed!)
(set! open-points (scale-points open-points x y))
(set! closed-points
(for/list ([pts (in-list closed-points)])
(scale-points pts x y)))))
(define/private (scale-points pts x y)
(for/list ([p (in-list pts)])
(if (pair? p)
(cons (* (car p) x)
(* (cdr p) y))
(vector (* (vector-ref p 0) x)
(* (vector-ref p 1) y)
(* (vector-ref p 2) x)
(* (vector-ref p 3) y)))))
(def/public (translate [real? x][real? y])
(unless (and (zero? x) (zero? y))
(flatten-open!)
(flatten-closed!)
(set! open-points (translate-points open-points x y))
(set! closed-points
(for/list ([pts (in-list closed-points)])
(translate-points pts x y)))))
(define/private (translate-points pts x y)
(for/list ([p (in-list pts)])
(if (pair? p)
(cons (+ (car p) x)
(+ (cdr p) y))
(vector (+ (vector-ref p 0) x)
(+ (vector-ref p 1) y)
(+ (vector-ref p 2) x)
(+ (vector-ref p 3) y)))))
(def/public (rotate [real? th])
(flatten-open!)
(flatten-closed!)
(set! open-points (rotate-points open-points th))
(set! closed-points
(for/list ([pts (in-list closed-points)])
(rotate-points pts th))))
(define/private (rotate-points pts th)
(if (zero? th)
pts
(for/list ([p (in-list pts)])
(if (pair? p)
(let-values ([(x y) (rotate-point th (car p) (cdr p))])
(cons x y))
(let-values ([(x2 y2) (rotate-point th (vector-ref p 0) (vector-ref p 1))]
[(x3 y3) (rotate-point th (vector-ref p 2) (vector-ref p 3))])
(vector x2 y2 x3 y3))))))
(define/private (rotate-point th x y)
(let* ([cx (make-rectangular x y)]
[cx (make-polar (magnitude cx) (+ (angle cx) (- th)))])
(values (real-part cx) (imag-part cx))))
(def/public (rectangle [real? x] [real? y] [real? w] [real? h])
(when (open?) (close))
(move-to x y)
(line-to (+ x w) y)
(line-to (+ x w) (+ y h))
(line-to x (+ y h))
(close))
(def/public (rounded-rectangle [real? x] [real? y] [real? w] [real? h]
[real? [radius -0.25]])
(when (open?) (close))
(let ([dx (min (/ w 2)
(if (negative? radius)
(* w (- radius))
radius))]
[dy (min (/ h 2)
(if (negative? radius)
(* h (- radius))
radius))])
(move-to (+ x (- w dx)) y)
(arc (+ x (- w (* 2 dx))) y (* 2 dx) (* 2 dy) pi/2 0.0 #f)
(line-to (+ x w) (+ y dy))
(line-to (+ x w) (+ y (- h dy)))
(arc (+ x (- w (* 2 dx))) (+ y (- h (* 2 dy))) (* 2 dx) (* 2 dy) 0 (- pi/2) #f)
(line-to (+ x (- w dx)) (+ y h))
(line-to (+ x dx) (+ y h))
(arc x (+ y (- h (* 2 dy))) (* 2 dx) (* 2 dy) (- pi/2) (- pi) #f)
(line-to x (+ y (- h dy)))
(line-to x (+ y dy))
(arc x y (* 2 dx) (* 2 dy) pi pi/2 #f)
(close)))
(super-new)))

879
collects/racket/draw/dc.rkt Normal file
View File

@ -0,0 +1,879 @@
#lang scheme/base
(require mred/private/syntax
scheme/math
scheme/class
"hold.ss"
"local.ss"
"cairo.ss"
"pango.ss"
"color.ss"
"pen.ss"
"brush.ss"
"font.ss"
"bitmap.ss"
"region.ss"
"dc-intf.ss"
"dc-path.ss"
"point.ss"
"local.ss")
(provide dc-mixin
dc-backend<%>
default-dc-backend%
install-bitmap-dc-class!)
(define 2pi (* 2 pi))
(define (copy-color c)
(if (send c is-immutable?)
c
(let ([c (make-object color%
(color-red c)
(color-green c)
(color-blue c))])
(send c set-immutable)
c)))
(define -bitmap-dc% #f)
(define (install-bitmap-dc-class! v) (set! -bitmap-dc% v))
;; dc-backend : interface
;;
;; This is the interface that the backend specific code must implement
(define dc-backend<%>
(interface ()
;; get-cr : -> cairo_t
;;
;; Gets a cairo_t created in a backend specific manner.
;; We assume that no one else is using this Cairo context
;; or its surface (i.e., no state will change out frm user us,
;; and our state won't bother anyone else).
get-cr
;; Ends a document
end-cr
;; Overriden here; to be called by a back-end when the Cairo
;; context changes
reset-cr
;; method flush-cr : -> void
;;
;; Queues a flushes for the context to show drawing.
;; May assume create-context has
;; been called before any call to flush.
flush-cr
;; method init-cr-matrix : -> void
;;
;; Initializes/resets the transformation matrix
init-cr-matrix
;; method reset-clip : cr -> void
;;
;; Resets the clipping region
reset-clip
;; method get-pango : -> pango_font_desc
;;
;; Gets a Pango font description for a given font
get-pango
;; method collapse-bitmap-b&w? : -> boolean
;;
;; triggers special handling of bitmap copies to a b&w target
collapse-bitmap-b&w?
;; method get-font-metrics-key : real real -> integer
;;
;; Gets a font-merics key for the current scale. 0 is always a
;; safe result, but the default is to return 1 for an unscaled
;; dc.
get-font-metrics-key
;; dc-adjust-smoothing
;;
;; Used to keep smoothing disabled for b&w contexts
dc-adjust-smoothing
;; The public get-size method:
get-size))
(define default-dc-backend%
(class* object% (dc-backend<%>)
(define/public (get-cr) #f)
(define/public (end-cr) (void))
(define/public (reset-cr) (void))
(define/public (flush-cr) (void))
(define/public (init-cr-matrix cr) (void))
(define/public (reset-clip cr)
(cairo_reset_clip cr))
(define/public (get-pango font)
(send font get-pango))
(define/public (get-font-metrics-key sx sy)
(if (and (= sx 1.0) (= sy 1.0))
1
0))
(define/public (ok?) (and (get-cr) #t))
(define/public (dc-adjust-smoothing s) s)
(define/public (install-color cr c a)
(let ([norm (lambda (v) (/ v 255.0))])
(cairo_set_source_rgba cr
(norm (color-red c))
(norm (color-green c))
(norm (color-blue c))
a)))
(define/public (collapse-bitmap-b&w?) #f)
(define/public (get-size) (values 0.0 0.0))
(super-new)))
(define hilite-color (send the-color-database find-color "black"))
(define hilite-alpha 0.3)
(define (dc-mixin backend%)
(defclass* dc% backend% (dc<%>)
(super-new)
(inherit flush-cr get-cr end-cr init-cr-matrix get-pango
install-color dc-adjust-smoothing reset-clip
collapse-bitmap-b&w?)
(define lock (make-semaphore 1))
(define-syntax-rule (with-cr default cr . body)
(call-with-semaphore
lock
(lambda ()
(let ([cr (get-cr)])
(if cr
(begin . body)
default)))))
(define/public (in-cairo-context cb)
(with-cr (void) cr (cb cr)))
;; pango context:
(define context #f)
(define black (send the-color-database find-color "black"))
(define pen (send the-pen-list find-or-create-pen "black" 1 'solid))
(define brush (send the-brush-list find-or-create-brush "black" 'transparent))
(define font (send the-font-list find-or-create-font 12 'default))
(define text-fg (send the-color-database find-color "black"))
(define text-bg (send the-color-database find-color "white"))
(define text-mode 'transparent)
(define bg (send the-color-database find-color "white"))
(define pen-stipple-s #f)
(define brush-stipple-s #f)
(define x-align-delta 0.5)
(define y-align-delta 0.5)
(define/private (reset-align!)
(let ([w (send pen get-width)])
(if (zero? w)
(begin
(set! x-align-delta 0.5)
(set! y-align-delta 0.5))
(begin
(set! x-align-delta (/ (bitwise-and 1 (inexact->exact (floor (* scale-x w)))) 2.0))
(set! y-align-delta (/ (bitwise-and 1 (inexact->exact (floor (* scale-y w)))) 2.0))))))
(def/public (set-font [font% f])
(set! font f))
(def/public (get-font) font)
(define origin-x 0.0)
(define origin-y 0.0)
(define scale-x 1.0)
(define scale-y 1.0)
(def/public (set-scale [real? sx] [real? sy])
(unless (and (equal? scale-x sx)
(equal? scale-y sy))
(set! scale-x sx)
(set! scale-y sy)
(reset-align!)
(reset-matrix)))
(def/public (get-scale) (values scale-x scale-y))
(def/public (set-origin [real? ox] [real? oy])
(unless (and (equal? origin-x ox)
(equal? origin-y oy))
(set! origin-x ox)
(set! origin-y oy)
(reset-matrix)))
(def/public (get-origin) (values origin-x origin-y))
(define/private (reset-matrix)
(with-cr
(void)
cr
(cairo_identity_matrix cr)
(init-cr-matrix cr)
(cairo_translate cr origin-x origin-y)
(cairo_scale cr scale-x scale-y)))
(inherit get-font-metrics-key)
(define/public (cache-font-metrics-key)
(get-font-metrics-key scale-x scale-y))
(define/override (reset-cr)
(set! context #f)
(reset-layouts!)
(reset-matrix))
(define smoothing 'unsmoothed)
(def/public (set-smoothing [(symbol-in unsmoothed smoothed aligned) s])
(set! smoothing s))
(def/public (get-smoothing)
smoothing)
(define/private (align-x x)
(if (eq? smoothing 'aligned)
(/ (- (+ (floor (+ (* x scale-x) origin-x)) x-align-delta) origin-x) scale-x)
x))
(define/private (align-y y)
(if (eq? smoothing 'aligned)
(/ (- (+ (floor (+ (* y scale-y) origin-y)) y-align-delta) origin-y) scale-y)
y))
(define (set-font-antialias context smoothing)
(let ([o (pango_cairo_context_get_font_options context)]
[o2 (cairo_font_options_create)])
(when o
(cairo_font_options_copy o2 o))
(cairo_font_options_set_antialias
o2
(case (dc-adjust-smoothing smoothing)
[(default) CAIRO_ANTIALIAS_SUBPIXEL] ; should be DEFAULT?
[(unsmoothed) CAIRO_ANTIALIAS_NONE]
[(partly-smoothed) CAIRO_ANTIALIAS_GRAY]
[(smoothed) CAIRO_ANTIALIAS_SUBPIXEL]))
(pango_cairo_context_set_font_options context o2)
(cairo_font_options_destroy o2)))
(define alpha 1.0)
(def/public (get-alpha) alpha)
(def/public (set-alpha [(real-in 0.0 1.0) n])
(set! alpha n))
(define/private (set-pen! p)
(set! pen-stipple-s #f)
(let ([o pen])
(send p adjust-lock 1)
(set! pen p)
(send o adjust-lock -1)))
(define/public (set-pen . args)
(case-args
args
[([pen% p]) (set-pen! p) (reset-align!)]
[([(make-alts string? color%) col]
[exact-nonnegative-integer? width]
[pen-style-symbol? style])
(set-pen! (send the-pen-list find-or-create-pen col width style))
(reset-align!)]
(method-name 'dc% 'set-pen)))
(define/public (get-pen) pen)
(define/private (pen-draws?)
(not (eq? (send pen get-style) 'transparent)))
(define/private (set-brush! b)
(set! brush-stipple-s #f)
(let ([o brush])
(send b adjust-lock 1)
(set! brush b)
(send o adjust-lock -1)))
(define/public (set-brush . args)
(case-args
args
[([brush% b]) (set-brush! b)]
[([(make-alts string? color%) col]
[brush-style-symbol? style])
(set-brush! (send the-brush-list find-or-create-brush col style))]
(method-name 'dc% 'set-brush)))
(define/public (get-brush) brush)
(define/private (brush-draws?)
(not (eq? (send brush get-style) 'transparent)))
(def/public (set-text-foreground [color% c])
(set! text-fg (copy-color c)))
(def/public (set-text-background [color% c])
(set! text-bg (copy-color c)))
(def/public (set-background [color% c])
(set! pen-stipple-s #f)
(set! brush-stipple-s #f)
(set! bg (copy-color c)))
(def/public (get-text-foreground) text-fg)
(def/public (get-text-background) text-bg)
(def/public (get-background) bg)
(def/public (set-text-mode [(symbol-in solid transparent) mode])
(set! text-mode mode))
(def/public (get-text-mode) text-mode)
(def/public (try-color [color% c] [color% dest])
(send dest set (color-red c) (color-green c) (color-blue c)))
(define clipping-region #f)
(def/public (get-clipping-region)
clipping-region)
(def/public (set-clipping-region [(make-or-false region%) r])
(do-set-clipping-region r))
(define/private (do-set-clipping-region r)
(with-cr
(void)
cr
(when clipping-region
(send clipping-region lock-region -1))
(set! clipping-region r)
(reset-clip cr)
(when clipping-region
(send clipping-region lock-region 1)
(send clipping-region install-region cr))))
(def/public (set-clipping-rect [real? x]
[real? y]
[nonnegative-real? w]
[nonnegative-real? h])
(let ([r (make-object region% this)])
(send r set-rectangle x y w h)
(do-set-clipping-region r)))
(define/public (clear)
(with-cr
(void)
cr
(install-color cr bg 1.0)
(cairo_paint cr)))
;; Stroke, fill, and flush the current path
(define/private (draw cr brush? pen?)
(define (install-stipple st col mode get put)
(let ([s (cond
[(get) => (lambda (s) s)]
[(and (not (send st is-color?))
(eq? mode 'solid)
(and (= 0 (color-red col))
(= 0 (color-green col))
(= 0 (color-blue col))))
(put (send st get-cairo-surface))]
[(collapse-bitmap-b&w?)
(put (send (bitmap-to-b&w-bitmap
st 0 0
(send st get-width) (send st get-height) mode col
#f)
get-cairo-surface))]
[(send st is-color?)
(put (send st get-cairo-surface))]
[else
(put (send (bitmap-to-argb-bitmap
st 0 0
(send st get-width) (send st get-height) mode col)
get-cairo-surface))])])
(let* ([p (cairo_pattern_create_for_surface s)])
(cairo_pattern_set_extend p CAIRO_EXTEND_REPEAT)
(cairo_set_source cr p)
(cairo_pattern_destroy p))))
(cairo_set_antialias cr (case (dc-adjust-smoothing smoothing)
[(unsmoothed) CAIRO_ANTIALIAS_NONE]
[else CAIRO_ANTIALIAS_GRAY]))
(when brush?
(let ([s (send brush get-style)])
(unless (eq? 'transparent s)
(let ([st (send brush get-stipple)]
[col (send brush get-color)])
(if st
(install-stipple st col s
(lambda () brush-stipple-s)
(lambda (v) (set! brush-stipple-s v) v))
(install-color cr
(if (eq? s 'hilite) hilite-color col)
(if (eq? s 'hilite) hilite-alpha alpha))))
(cairo_fill_preserve cr))))
(when pen?
(let ([s (send pen get-style)])
(unless (eq? 'transparent s)
(let ([st (send pen get-stipple)]
[col (send pen get-color)])
(if st
(install-stipple st col s
(lambda () pen-stipple-s)
(lambda (v) (set! pen-stipple-s v) v))
(install-color cr
(if (eq? s 'hilite) hilite-color col)
(if (eq? s 'hilite) hilite-alpha alpha))))
(cairo_set_line_width cr (let ([v (send pen get-width)])
(if (zero? v)
1
v)))
(unless (or (eq? s 'solid)
(eq? s 'xor))
(cairo_set_dash cr
(cond
[(eq? s 'long-dash)
#(4.0 2.0)]
[(eq? s 'short-dash)
#(2.0 2.0)]
[(eq? s 'dot)
#(1.0 1.0)]
[(eq? s 'dot-dash)
#(1.0 2.0 4.0 2.0)]
[else
#()])
(cond
[(eq? s 'long-dash) 2]
[(eq? s 'short-dash) 2]
[(eq? s 'dot) 2]
[(eq? s 'dot-dash) 4]
[else 0])))
(cairo_set_line_cap cr
(case (if ((send pen get-width) . <= . 1.0)
'butt
(send pen get-cap))
[(butt) CAIRO_LINE_CAP_BUTT]
[(round) CAIRO_LINE_CAP_ROUND]
[(projecting) CAIRO_LINE_CAP_SQUARE]))
(cairo_set_line_join cr
(case (send pen get-join)
[(miter) CAIRO_LINE_JOIN_MITER]
[(round) CAIRO_LINE_JOIN_ROUND]
[(bevel) CAIRO_LINE_JOIN_BEVEL]))
(cairo_stroke cr)
(unless (or (eq? s 'solid) (eq? s 'xor))
(cairo_set_dash cr #() 0)))))
(flush-cr))
(define/public (draw-arc x y
width height
start-radians end-radians)
(with-cr
(void)
cr
(let ([draw-one (lambda (align-x align-y brush? pen? d)
(let* ([orig-x x]
[orig-y y]
[x (align-x x)]
[y (align-y y)]
[width (- (align-x (+ orig-x width)) x)]
[width (if (width . >= . d) (- width d) width)]
[height (- (align-y (+ orig-y height)) y)]
[height (if (height . >= . d) (- height d) height)]
[radius-x (/ width 2)]
[radius-y (/ height 2)]
[center-x (+ x radius-x)]
[center-y (+ y radius-y)])
;; Cairo arcs go clockwise, while the dc goes counterclockwise
(when (and (positive? radius-x)
(positive? radius-y))
(cairo_new_path cr)
(cairo_save cr)
(cairo_translate cr center-x center-y)
(cairo_scale cr radius-x radius-y)
(cairo_arc_negative cr 0 0 1
(- start-radians)
(- end-radians))
(cairo_restore cr)
(draw cr brush? pen?))))])
(when (brush-draws?)
(draw-one (lambda (x) x) (lambda (y) y) #t #f 0.0))
(when (pen-draws?)
(draw-one (lambda (x) (align-x x)) (lambda (y) (align-y y)) #f #t 1.0)))))
(def/public (draw-ellipse [real? x] [real? y] [nonnegative-real? width] [nonnegative-real? height])
(draw-arc x y width height 0 2pi))
(def/public (draw-line [real? x1] [real? y1] [real? x2] [real? y2])
(let-values ([(x1 y1 x2 y2)
(if (and (eq? smoothing 'unsmoothed)
(x2 . < . x1))
(values x2 y2 x1 y1)
(values x1 y1 x2 y2))])
(with-cr
(void)
cr
(cairo_new_path cr)
(cairo_move_to cr (align-x x1) (align-y y1))
(if (eq? smoothing 'unsmoothed)
;; An unsmoothed line is supposed to hit the pixel to the
;; lower right of the ending point. (We've revered the points
;; above to ensure that the line goes left to right.)
(if ((abs (- x2 x1)) . > . (abs (- y2 y1)))
(cairo_line_to cr (+ (align-x x2) (sgn (- x2 x1))) (align-y y2))
(cairo_line_to cr (align-x x2) (+ (align-y y2) (sgn (- y2 y1)))))
(cairo_line_to cr (align-x x2) (align-y y2)))
(draw cr #f #t))))
(def/public (draw-point [real? x] [real? y])
(with-cr
(void)
cr
(cairo_new_path cr)
(let ([x (align-x x)]
[y (align-y y)])
(cairo_move_to cr x y)
(cairo_line_to cr x y)
(draw cr #f #t))))
(def/public (draw-lines [(make-alts (make-list point%) list-of-pair-of-real?) pts]
[real? [x 0.0]] [real? [y 0.0]])
(do-draw-lines pts x y #f))
(def/public (draw-polygon [(make-alts (make-list point%) list-of-pair-of-real?) pts]
[real? [x 0.0]] [real? [y 0.0]]
[(symbol-in odd-even winding) [fill-style 'odd-even]])
(do-draw-lines pts x y fill-style))
(define/public (do-draw-lines pts x y fill-style)
(unless (or (null? pts)
(null? (cdr pts)))
(with-cr
(void)
cr
(cairo_new_path cr)
(if (pair? (car pts))
(cairo_move_to cr (align-x (+ x (caar pts))) (align-y (+ y (cdar pts))))
(cairo_move_to cr (align-x (+ x (point-x (car pts)))) (align-y (+ y (point-y (car pts))))))
(for ([p (in-list (cdr pts))])
(if (pair? p)
(cairo_line_to cr (align-x (+ x (car p))) (align-y (+ y (cdr p))))
(cairo_line_to cr (align-x (+ x (point-x p))) (align-y (+ y (point-y p))))))
(when fill-style
(cairo_close_path cr)
(cairo_set_fill_rule cr (if (eq? fill-style 'winding)
CAIRO_FILL_RULE_WINDING
CAIRO_FILL_RULE_EVEN_ODD)))
(draw cr fill-style #t))))
(def/public (draw-rectangle [real? x] [real? y] [nonnegative-real? width] [nonnegative-real? height])
(with-cr
(void)
cr
;; have to do pen separate from brush for
;; both alignment and height/width adjustment
(let ([ax (align-x x)]
[ay (align-y y)])
(cairo_new_path cr)
(cairo_rectangle cr x y width height)
(draw cr #t #f)
(cairo_new_path cr)
(cairo_rectangle cr ax ay
(- (align-x (+ x (sub1 width))) ax)
(- (align-y (+ y (sub1 height))) ay))
(draw cr #f #t))))
(def/public (draw-rounded-rectangle [real? x] [real? y] [nonnegative-real? width] [nonnegative-real? height]
[real? [radius -0.25]])
(with-cr
(void)
cr
;; have to do pen separate from brush for
;; both alignment and height/width adjustment
(let ([ax (align-x x)]
[ay (align-y y)])
(let ([rounded-rect
(lambda (x y w h align-x align-y)
(let ([p (new dc-path%)])
(send p rounded-rectangle x y w h radius)
(cairo_new_path cr)
(send p do-path cr align-x align-y)))])
(when (brush-draws?)
(rounded-rect x y width height (lambda (x) x) (lambda (y) y))
(draw cr #t #f))
(when (pen-draws?)
(rounded-rect ax ay
(- (align-x (+ x (sub1 width))) ax)
(- (align-y (+ y (sub1 height))) ay)
(lambda (x) (align-x x)) (lambda (y) (align-y y)))
(draw cr #f #t))))))
(def/public (draw-spline [real? x1] [real? y1] [real? x2] [real? y2] [real? x3] [real? y3])
(with-cr
(void)
cr
(cairo_new_path cr)
(cairo_move_to cr (align-x x1) (align-y y1))
(let ([x21 (/ (+ x1 x2) 2)]
[y21 (/ (+ y1 y2) 2)])
(cairo_line_to cr (align-x x21) (align-y y21))
(let* ([x22 (/ (+ x2 x3) 2)]
[y22 (/ (+ y2 y3) 2)]
[xm1 (/ (+ x21 x2) 2)]
[ym1 (/ (+ y21 y2) 2)]
[xm2 (/ (+ x2 x22) 2)]
[ym2 (/ (+ y2 y22) 2)])
(cairo_curve_to cr
(align-x xm1) (align-y ym1)
(align-x xm2) (align-y ym2)
(align-x x22) (align-y y22)))
(cairo_line_to cr (align-x x3) (align-x y3)))
(draw cr #f #t)))
(def/public (draw-path [dc-path% path]
[real? [dx 0]]
[real? [dy 0]]
[(symbol-in odd-even winding) [fill-style 'odd-even]])
(with-cr
(void)
cr
(cairo_save cr)
(cairo_set_fill_rule cr (if (eq? fill-style 'winding)
CAIRO_FILL_RULE_WINDING
CAIRO_FILL_RULE_EVEN_ODD))
(cairo_new_path cr)
(cairo_translate cr dx dy)
(if (eq? smoothing 'aligned)
(begin
(when (brush-draws?)
(send path do-path cr (lambda (x) x) (lambda (y) y))
(draw cr #t #f))
(cairo_new_path cr)
(when (pen-draws?)
(send path do-path cr (lambda (x) (align-x x)) (lambda (y) (align-y y)))
(draw cr #f #t)))
(begin
(send path do-path cr (lambda (x) x) (lambda (y) y))
(draw cr #t #t)))
(cairo_restore cr)))
(define layouts (make-weak-hash))
(define/private (reset-layouts!) (set! layouts (make-weak-hash)))
(inherit get-size)
(def/public (draw-text [string? s] [real? x] [real? y]
[any? [combine? #f]]
[exact-nonnegative-integer? [offset 0]]
[real? [angle 0.0]])
(with-cr
(void)
cr
(do-text cr #t s x y font combine? offset angle)
(flush-cr)))
(def/public (get-text-extent [string? s]
[font% [font font]]
[any? [combine? #f]]
[exact-nonnegative-integer? [offset 0]])
(with-cr
(values 1.0 1.0 0.0 0.0)
cr
(do-text cr #f s 0 0 font combine? offset 0.0)))
(define/private (do-text cr draw? s x y font combine? offset angle)
(let ([s (if (zero? offset) s (substring s offset))])
(unless context
(set! context (pango_cairo_create_context cr)))
(set-font-antialias context (send font get-smoothing))
(when draw?
(when (eq? text-mode 'solid)
(let-values ([(w h d a) (do-text cr #f s 0 0 font combine? 0 0.0)])
(install-color cr text-bg alpha)
(cairo_new_path cr)
(cairo_rectangle cr x y w h)
(cairo_fill cr)))
(install-color cr text-fg alpha))
(let ([desc (get-pango font)]
[attrs (send font get-pango-attrs)]
[integral round])
(if combine?
(let ([layout (pango_layout_new context)])
(pango_layout_set_font_description layout desc)
(when attrs (pango_layout_set_attributes layout attrs))
(pango_layout_set_text layout s)
(when draw?
(cairo_move_to cr x y)
(pango_cairo_show_layout cr layout))
(begin0
(if draw?
(void)
(let ([logical (make-PangoRectangle 0 0 0 0)])
(pango_layout_get_extents layout #f logical)
(values (integral (/ (PangoRectangle-width logical) (exact->inexact PANGO_SCALE)))
(integral (/ (PangoRectangle-height logical) (exact->inexact PANGO_SCALE)))
(integral (/ (- (PangoRectangle-height logical)
(pango_layout_get_baseline layout))
(exact->inexact PANGO_SCALE)))
0.0)))
(g_object_unref layout)))
(let ([logical (make-PangoRectangle 0 0 0 0)])
(for/fold ([w 0.0][h 0.0][d 0.0][a 0.0])
([ch (in-string s)])
(let* ([key (vector desc attrs ch)]
[layout (hash-ref layouts
key
(lambda ()
(let ([layout (pango_layout_new context)])
(pango_layout_set_font_description layout desc)
(when attrs (pango_layout_set_attributes layout attrs))
(pango_layout_set_text layout (string ch))
(hash-set! layouts key layout)
layout)))])
(pango_cairo_update_layout cr layout)
;; (cairo_show_glyphs cr (make-cairo_glyph_t 65 x y) 1)
(when draw?
(cairo_move_to cr (+ x w) y)
(pango_cairo_show_layout cr layout))
(pango_layout_get_extents layout #f logical)
(let ([lw (integral (/ (PangoRectangle-width logical) (exact->inexact PANGO_SCALE)))]
[lh (integral (/ (PangoRectangle-height logical) (exact->inexact PANGO_SCALE)))]
[ld (integral (/ (- (PangoRectangle-height logical)
(pango_layout_get_baseline layout))
(exact->inexact PANGO_SCALE)))]
[la 0.0])
(values (+ w lw) (max h lh) (max d ld) (max a la))))))))))
(def/public (get-char-width)
10.0)
(def/public (start-doc [string? desc])
(void))
(def/public (end-doc)
(end-cr))
(def/public (start-page)
(void))
(def/public (end-page)
(with-cr (void) cr (cairo_show_page cr)))
(def/public (draw-bitmap [bitmap% src]
[real? dest-x]
[real? dest-y]
[(symbol-in solid opaque xor) [style 'solid]]
[(make-or-false color%) [color black]]
[(make-or-false bitmap%) [mask #f]])
(draw-bitmap-section src
dest-x dest-y
0 0
(send src get-width) (send src get-height)
style color mask))
(def/public (draw-bitmap-section [bitmap% src]
[real? dest-x]
[real? dest-y]
[real? src-x]
[real? src-y]
[real? src-w]
[real? src-h]
[(symbol-in solid opaque xor) [style 'solid]]
[(make-or-false color%) [color black]]
[(make-or-false bitmap%) [mask #f]])
(let ([black? (or (not color)
(and (= 0 (color-red color))
(= 0 (color-green color))
(= 0 (color-blue color))))])
(cond
[(and (collapse-bitmap-b&w?)
(or (send src is-color?)
(and mask
(send mask is-color?))))
;; Need to ensure that the result is still B&W
(let* ([tmp-bm (bitmap-to-b&w-bitmap src src-x src-y src-w src-h style color mask)])
(do-draw-bitmap-section tmp-bm dest-x dest-y 0 0 src-w src-h 'solid #f #t #f))]
[(and (not black?) mask)
;; both mask and forground color apply
(let ([tmp-bm (bitmap-to-argb-bitmap src src-x src-y src-w src-h style color)])
(do-draw-bitmap-section tmp-bm dest-x dest-y 0 0 src-w src-h 'solid #f #t mask))]
[else
;; Normal combination...
(do-draw-bitmap-section src dest-x dest-y src-x src-y src-w src-h style color black? mask)])))
(define/public (do-draw-bitmap-section src dest-x dest-y src-x src-y src-w src-h style color black? mask)
(with-cr
(void)
cr
(let ([stamp-pattern
(lambda (src)
(let ([p (cairo_pattern_create_for_surface (send src get-cairo-alpha-surface))]
[m (make-cairo_matrix_t 0.0 0.0 0.0 0.0 0.0 0.0)])
(cairo_matrix_init_translate m (- src-x dest-x) (- src-y dest-y))
(cairo_pattern_set_matrix p m)
(cairo_mask cr p)
(cairo_pattern_destroy p)))]
[color (or color black)])
(cond
[(or (send src is-color?)
(and (not (eq? style 'opaque))
black?))
(let ([s (cairo_get_source cr)])
(cairo_pattern_reference s)
(cairo_set_source_surface cr
(send src get-cairo-surface)
(- dest-x src-x)
(- dest-y src-y))
(if mask
(stamp-pattern mask)
(begin
(cairo_new_path cr)
(cairo_rectangle cr dest-x dest-y src-w src-h)
(cairo_fill cr)))
(cairo_set_source cr s)
(cairo_pattern_destroy s))]
[else
(when (eq? style 'opaque)
(install-color cr bg alpha)
(cairo_new_path cr)
(cairo_rectangle cr dest-x dest-y src-w src-h)
(cairo_fill cr))
(install-color cr color alpha)
(stamp-pattern src)])
(flush-cr))))
(define/private (bitmap-to-b&w-bitmap src src-x src-y src-w src-h style color mask)
(let* ([bm-w (inexact->exact (ceiling src-w))]
[bm-h (inexact->exact (ceiling src-h))]
[tmp-bm (make-object bitmap% bm-w bm-h #f #t)]
[tmp-dc (make-object -bitmap-dc% tmp-bm)])
(send tmp-dc set-background bg)
(send tmp-dc draw-bitmap-section src 0 0 src-x src-y src-w src-h style color mask)
(send tmp-dc set-bitmap #f)
(let ([bstr (make-bytes (* bm-w bm-h 4))])
(send tmp-bm get-argb-pixels 0 0 bm-w bm-h bstr)
(for ([i (in-range 0 (bytes-length bstr) 4)])
(bytes-set! bstr i (if (= (bytes-ref bstr i) 255)
255
0))
(let ([v (if (and (= 255 (bytes-ref bstr (+ i 1)))
(= 255 (bytes-ref bstr (+ i 2)))
(= 255 (bytes-ref bstr (+ i 3))))
255
0)])
(bytes-set! bstr (+ i 1) v)
(bytes-set! bstr (+ i 2) v)
(bytes-set! bstr (+ i 3) v)))
(send tmp-bm set-argb-pixels 0 0 bm-w bm-h bstr)
tmp-bm)))
(define/private (bitmap-to-argb-bitmap src src-x src-y src-w src-h style color)
(let* ([bm-w (inexact->exact (ceiling src-w))]
[bm-h (inexact->exact (ceiling src-h))]
[tmp-bm (make-object bitmap% src-w src-h #f)]
[tmp-dc (make-object -bitmap-dc% tmp-bm)])
(send tmp-dc set-background bg)
(send tmp-dc draw-bitmap-section src 0 0 src-x src-y src-w src-h style color)
(send tmp-dc set-bitmap #f)
tmp-bm))
(def/public (glyph-exists? [char? c]) #t)
)
dc%)

81
collects/racket/draw/define.rkt Normal file
View File

@ -0,0 +1,81 @@
#lang scheme/base
(require (for-syntax scheme/base)
scheme/foreign)
(unsafe!)
(provide define-definer
define-private-definer
define-enum
define/provide)
(define-syntax define-enum
(syntax-rules ()
[(_ n) (begin)]
[(_ n id . ids) (begin
(define id n)
(provide id)
(define-enum (+ n 1) . ids))]))
(define-syntax-rule (define/provide id val)
(begin
(define id val)
(provide id)))
(define-syntax-rule (skip id) (begin))
(define-syntax-rule (define-definer LIB ffi-lib)
(define-definer* LIB ffi-lib #t))
(define-syntax-rule (define-private-definer LIB ffi-lib)
(define-definer* LIB ffi-lib #f))
(define (make-not-found id)
(lambda args
(error id "implementation not found; arguments where ~e" args)))
(define (trace id proc)
proc
#;
(lambda args
(printf "~s\n" id)
(apply proc args)))
(define-syntax (define-definer* stx)
(syntax-case stx ()
[(_ LIB ffi-lib p?)
(let ([make-id
(lambda (tmpl)
(datum->syntax #'LIB
(string->symbol (format tmpl (syntax-e #'LIB)))
#'LIB))])
(with-syntax ([define-LIB/private (make-id "define-~a/private")]
[define-LIB (make-id "define-~a")]
[PROVIDE (if (syntax-e #'p?)
#'provide
#'skip)])
#`(begin
(define-syntax define-LIB/private
(syntax-rules ()
[(_ id c-id type fail #:wrap wrapper)
(define id (trace 'c-id (wrapper (get-ffi-obj 'c-id ffi-lib type fail))))]
[(_ id c-id type fail)
(define-LIB/private id c-id type fail #:wrap values)]
[(_ id type fail #:wrap wrapper)
(define-LIB/private id id type fail #:wrap wrapper)]
[(_ id type fail)
(define-LIB/private id id type fail #:wrap values)]
[(_ id type #:wrap wrapper)
(define-LIB/private id id type (lambda () (make-not-found 'id)) #:wrap wrapper)]
[(_ id type)
(define-LIB/private id id type (lambda () (make-not-found 'id)) #:wrap values)]))
(define-syntax define-LIB
(syntax-rules ()
[(_ id type default #:wrap wrapper)
(begin
(PROVIDE id)
(define-LIB/private id id type (lambda () default) #:wrap wrapper))]
[(_ id type #:wrap wrapper)
(define-LIB id type (make-not-found 'id) #:wrap wrapper)]
[(_ id type)
(define-LIB id type (make-not-found 'id) #:wrap values)]
[(_ id type default)
(define-LIB id type default #:wrap values)])))))]))

7
collects/racket/draw/fmod.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang scheme/base
(require scheme/foreign)
(unsafe!)
(provide fmod)
(define fmod (get-ffi-obj 'fmod #f (_fun _double _double -> _double)))

97
collects/racket/draw/font-dir.rkt Normal file
View File

@ -0,0 +1,97 @@
#lang scheme/base
(require scheme/class
mred/private/syntax
"font-syms.ss")
(provide font-name-directory<%>
the-font-name-directory)
(define font-name-directory%
(class object%
(define table (make-hash))
(define reverse-table (make-hash))
(define ps-table (make-hash))
(define screen-table (make-hash))
(define/private (intern val)
(hash-ref table val (lambda ()
(let ([n (add1 (hash-count table))])
(hash-set! table val n)
(hash-set! reverse-table n val)
n))))
(for-each (lambda (s) (intern s))
'(default decorative roman script
swiss modern symbol system))
(def/public (find-family-default-font-id [family-symbol? family])
(intern family))
(def/public (find-or-create-font-id [string? name]
[family-symbol? family])
(intern (cons name family)))
(def/public (get-face-name [exact-integer? id])
(let ([v (hash-ref reverse-table id #f)])
(and v (pair? v) (car v))))
(def/public (get-family [exact-integer? id])
(let ([v (hash-ref reverse-table id #f)])
(or (and (pair? v) (cdr v))
(and (symbol? v) v)
'default)))
(def/public (get-font-id [string? name]
[family-symbol? family])
(hash-ref table (cons string family) 0))
(define (default-font s)
(case s
[(modern) "Monospace"]
[(roman) "Serif"]
[(decorative swiss) "Helvetica"]
[(script) "Chancery"]
[(symbol) "Symbol"]
[else (case (system-type)
[(macosx) "Lucida Grande"]
[else "Sans"])]))
(def/public (get-post-script-name [exact-integer? id]
[weight-symbol? w]
[style-symbol? s])
(let ([s (or (hash-ref ps-table (list id w s) #f)
(hash-ref reverse-table id #f))])
(cond
[(pair? s) (car s)]
[(symbol? s) (default-font s)]
[else "Serif"])))
(def/public (get-screen-script-name [exact-integer? id]
[weight-symbol? w]
[style-symbol? s])
(let ([s (or (hash-ref screen-table (list id w s) #f)
(hash-ref reverse-table id #f))])
(cond
[(pair? s) (car s)]
[(symbol? s) (default-font s)]
[else "Serif"])))
(def/public (set-post-script-name [exact-integer? id]
[weight-symbol? w]
[style-symbol? s]
[string? name])
(hash-set! ps-table (list id w s) name))
(def/public (set-screen-name [exact-integer? id]
[weight-symbol? w]
[style-symbol? s]
[string? name])
(hash-set! screen-table (list id w s) name))
(super-new)))
(define font-name-directory<%>
(class->interface font-name-directory%))
(define the-font-name-directory (new font-name-directory%))

14
collects/racket/draw/font-syms.rkt Normal file
View File

@ -0,0 +1,14 @@
#lang scheme/base
(provide family-symbol? style-symbol? weight-symbol? )
(define (family-symbol? s)
(memq s '(default decorative roman script
swiss modern symbol system)))
(define (style-symbol? s)
(memq s '(normal italic slant)))
(define (weight-symbol? s)
(memq s '(normal bold light)))

198
collects/racket/draw/font.rkt Normal file
View File

@ -0,0 +1,198 @@
#lang scheme/base
(require scheme/class
"syntax.ss"
"pango.ss"
"font-syms.ss"
"font-dir.ss"
"local.ss")
(provide font%
font-list% the-font-list
family-symbol? style-symbol? weight-symbol? smoothing-symbol?
get-pango-attrs
get-face-list)
(define-local-member-name
get-pango-attrs)
(define underlined-attrs (let ([l (pango_attr_list_new)])
(pango_attr_list_insert l (pango_attr_underline_new
PANGO_UNDERLINE_SINGLE))
l))
(define (smoothing-symbol? s)
(memq s '(default smoothed unsmoothed partly-smoothed)))
(define (size? v) (and (exact-positive-integer? v)
(byte? v)))
(define-local-member-name s-set-key)
(defclass font% object%
(define key #f)
(define/public (s-set-key k) (set! key k))
(define cached-desc #f)
(define ps-cached-desc #f)
(define/public (get-pango)
(create-desc #f
cached-desc
(lambda (d) (set! cached-desc d))))
(define/public (get-ps-pango)
(create-desc #t
ps-cached-desc
(lambda (d) (set! ps-cached-desc d))))
(define/private (create-desc ps? cached-desc install!)
(or cached-desc
(let* ([desc (pango_font_description_new)])
(pango_font_description_set_family desc
(if ps?
(send the-font-name-directory
get-post-script-name
id
weight
style)
(send the-font-name-directory
get-screen-script-name
id
weight
style)))
(pango_font_description_set_style desc (case style
[(normal) PANGO_STYLE_NORMAL]
[(italic) PANGO_STYLE_ITALIC]
[(slant) PANGO_STYLE_OBLIQUE]))
(pango_font_description_set_weight desc (case weight
[(normal) PANGO_WEIGHT_MEDIUM]
[(light) PANGO_WEIGHT_LIGHT]
[(bold) PANGO_WEIGHT_BOLD]))
(if size-in-pixels?
(pango_font_description_set_absolute_size desc (* size PANGO_SCALE))
(pango_font_description_set_size desc (inexact->exact (floor (* size PANGO_SCALE)))))
(install! desc)
desc)))
(define/public (get-pango-attrs)
(if underlined?
underlined-attrs
#f))
(define face #f)
(def/public (get-face) face)
(define family 'default)
(def/public (get-family) family)
(define size 12)
(def/public (get-point-size) size)
(define size-in-pixels? #f)
(def/public (get-size-in-pixels) size-in-pixels?)
(define smoothing 'default)
(def/public (get-smoothing) smoothing)
(define style 'normal)
(def/public (get-style) style)
(define underlined? #f)
(def/public (get-underlined) underlined?)
(define weight 'normal)
(def/public (get-weight) weight)
(def/public (get-font-id) id)
(def/public (screen-glyph-exists? [char? c]
[any? [for-label? #f]])
;; FIXME:
#t)
(init-rest args)
(super-new)
(case-args
args
[() (void)]
[([size? _size]
[family-symbol? _family]
[style-symbol? [_style 'normal]]
[weight-symbol? [_weight 'normal]]
[any? [_underlined? #f]]
[smoothing-symbol? [_smoothing 'default]]
[any? [_size-in-pixels? #f]])
(set! size _size)
(set! family _family)
(set! style _style)
(set! weight _weight)
(set! underlined? _underlined?)
(set! smoothing _smoothing)
(set! size-in-pixels? _size-in-pixels?)]
[([size? _size]
[(make-or-false string?) _face]
[family-symbol? _family]
[style-symbol? [_style 'normal]]
[weight-symbol? [_weight 'normal]]
[any? [_underlined? #f]]
[smoothing-symbol? [_smoothing 'default]]
[any? [_size-in-pixels? #f]])
(set! size _size)
(set! face (and _face (string->immutable-string _face)))
(set! family _family)
(set! style _style)
(set! weight _weight)
(set! underlined? _underlined?)
(set! smoothing _smoothing)
(set! size-in-pixels? _size-in-pixels?)]
(init-name 'font%))
(define id
(if face
(send the-font-name-directory find-or-create-font-id face family)
(send the-font-name-directory find-family-default-font-id family))))
;; ----------------------------------------
(defclass font-list% object%
(define fonts (make-weak-hash))
(super-new)
(define/public (find-or-create-font . args)
(let ([key
(case-args
args
[([size? size]
[family-symbol? family]
[style-symbol? [style 'normal]]
[weight-symbol? [weight 'normal]]
[any? [underlined? #f]]
[smoothing-symbol? [smoothing 'default]]
[any? [size-in-pixels? #f]])
(vector size family style weight underlined? smoothing size-in-pixels?)]
[([size? size]
[(make-or-false string?) face]
[family-symbol? family]
[style-symbol? [style 'normal]]
[weight-symbol? [weight 'normal]]
[any? [underlined? #f]]
[smoothing-symbol? [smoothing 'default]]
[any? [size-in-pixels? #f]])
(vector size (and face (string->immutable-string face)) family
style weight underlined? smoothing size-in-pixels?)]
(method-name 'find-or-create-font font-list%))])
(let ([e (hash-ref fonts key #f)])
(or (and e
(ephemeron-value e))
(let* ([f (apply make-object font% (vector->list key))]
[e (make-ephemeron key f)])
(send f s-set-key key)
(hash-set! fonts key e)
f))))))
(define the-font-list (new font-list%))
(define (get-face-list [mode 'all])
(map pango_font_family_get_name
(pango_font_map_list_families
(pango_cairo_font_map_get_default))))

14
collects/racket/draw/hold.rkt Normal file
View File

@ -0,0 +1,14 @@
#lang scheme/base
(provide with-holding)
(define-syntax-rule (with-holding v expr)
(let ([val v])
(begin0
expr
(done-with val))))
;; Ensure no inline:
(define done-with #f)
(set! done-with void)

657
collects/racket/draw/jpeg.rkt Normal file
View File

@ -0,0 +1,657 @@
#lang scheme/base
(require ffi/unsafe
ffi/unsafe/define
ffi/unsafe/alloc
ffi/unsafe/atomic
setup/dirs
"bstr.rkt"
"utils.rkt")
(define jpeg-lib
(case (system-type)
[(macosx) (ffi-lib "libjpeg.62")]
[(unix) (ffi-lib "libjpeg" '("62"))]
[(windows) (ffi-lib "libjpeg-7.dll")]))
(define JPEG_LIB_VERSION
(case (system-type)
[(macosx) 62]
[(unix) 62]
[(windows) 70]))
(define-ffi-definer define-jpeg jpeg-lib
#:provide provide)
(define-ffi-definer define-jpeg/private jpeg-lib)
(define _j_common_ptr _pointer)
(define _size_t _long)
(define _JDIMENSION _uint)
(define _J_COLOR_SPACE _int)
(define _J_DCT_METHOD _int)
(define _J_DITHER_MODE _int)
(define-enum
0
JCS_UNKNOWN
JCS_GRAYSCALE
JCS_RGB
JCS_YCbCr
JCS_CMYK
JCS_YCCK)
(define _pool_id _int)
(define JPOOL_PERMANENT 0)
(define JPOOL_IMAGE 1)
(define JPOOL_NUMPOOLS 2)
(define JMSG_LENGTH_MAX 200)
(define-cstruct _jpeg_error_mgr ([error_exit (_fun _j_common_ptr -> _void)]
[emit_message _pointer]
[output_message _pointer]
[format_message (_fun _j_common_ptr _pointer -> _void)]
;; and more, including an inline character
;; array that is a pain to handle here
))
(define sizeof_jpeg_error_mgr 1024)
(define-cstruct _jpeg_memory_mgr ([alloc_small (_fun _j_common_ptr _pool_id _size_t -> _pointer)]
[alloc_large (_fun _j_common_ptr _pool_id _size_t -> _pointer)]
[alloc_sarray (_fun _j_common_ptr _pool_id _JDIMENSION _JDIMENSION -> _pointer)]
;; and more
))
(define _scaled_size
(case JPEG_LIB_VERSION
[(62) _int]
[else (make-cstruct-type (list _int _int))]))
(define-cstruct _jpeg_decompress_struct ([err _jpeg_error_mgr-pointer]
[mem _jpeg_memory_mgr-pointer]
[progress _pointer] ; _jpeg_progress_mgr_pointer
[client_data _pointer]
[is_decompressor _bool]
[global_state _int]
[src* _pointer] ; actually jpeg_source_mgr-pointer
[image_width _JDIMENSION]
[image_height _JDIMENSION]
[input_components _int]
[jpeg_color_space _J_COLOR_SPACE]
[out_color_space _J_COLOR_SPACE]
[scale_num _uint]
[scale_denom _uint]
[output_gamma _double]
[buffered_image _bool]
[raw_data_out _bool]
[dct_method _J_DCT_METHOD]
[do_fancy_upsampling _bool]
[do_block_smoothing _bool]
[quantize_colors _bool]
[dither_mode _J_DITHER_MODE]
[two_pass_quantize _bool]
[desired_number_of_colors _int]
[enable_1pass_quant _bool]
[enable_external_quant _bool]
[enable_2pass_quant _bool]
[output_width _JDIMENSION]
[output_height _JDIMENSION]
[out_color_components _int]
[output_components _int]
[rec_outbuf_height _int]
[actual_number_of_colors _int]
[colormap _pointer]
[output_scanline _JDIMENSION]
[input_scan_number _int]
[input_iMCU_row _JDIMENSION]
[output_scan_number _int]
[output_iMCU_row _JDIMENSION]
[coef_bits _pointer]
[quant_tbl_ptrs_1 _pointer]
[quant_tbl_ptrs_2 _pointer]
[quant_tbl_ptrs_3 _pointer]
[quant_tbl_ptrs_4 _pointer]
[dc_huff_tbl_ptrs_1 _pointer]
[dc_huff_tbl_ptrs_2 _pointer]
[dc_huff_tbl_ptrs_3 _pointer]
[dc_huff_tbl_ptrs_4 _pointer]
[ac_huff_tbl_ptrs_1 _pointer]
[ac_huff_tbl_ptrs_2 _pointer]
[ac_huff_tbl_ptrs_3 _pointer]
[ac_huff_tbl_ptrs_4 _pointer]
[data_precision _int]
[comp_info _pointer]
[progressive_mode _bool]
[arith_code _bool]
[arith_dc_L_1 _uint8]
[arith_dc_L_2 _uint8]
[arith_dc_L_3 _uint8]
[arith_dc_L_4 _uint8]
[arith_dc_L_5 _uint8]
[arith_dc_L_6 _uint8]
[arith_dc_L_7 _uint8]
[arith_dc_L_8 _uint8]
[arith_dc_L_9 _uint8]
[arith_dc_L_10 _uint8]
[arith_dc_L_11 _uint8]
[arith_dc_L_12 _uint8]
[arith_dc_L_13 _uint8]
[arith_dc_L_14 _uint8]
[arith_dc_L_15 _uint8]
[arith_dc_L_16 _uint8]
[arith_dc_U_1 _uint8]
[arith_dc_U_2 _uint8]
[arith_dc_U_3 _uint8]
[arith_dc_U_4 _uint8]
[arith_dc_U_5 _uint8]
[arith_dc_U_6 _uint8]
[arith_dc_U_7 _uint8]
[arith_dc_U_8 _uint8]
[arith_dc_U_9 _uint8]
[arith_dc_U_10 _uint8]
[arith_dc_U_11 _uint8]
[arith_dc_U_12 _uint8]
[arith_dc_U_13 _uint8]
[arith_dc_U_14 _uint8]
[arith_dc_U_15 _uint8]
[arith_dc_U_16 _uint8]
[arith_dc_K_1 _uint8]
[arith_dc_K_2 _uint8]
[arith_dc_K_3 _uint8]
[arith_dc_K_4 _uint8]
[arith_dc_K_5 _uint8]
[arith_dc_K_6 _uint8]
[arith_dc_K_7 _uint8]
[arith_dc_K_8 _uint8]
[arith_dc_K_9 _uint8]
[arith_dc_K_10 _uint8]
[arith_dc_K_11 _uint8]
[arith_dc_K_12 _uint8]
[arith_dc_K_13 _uint8]
[arith_dc_K_14 _uint8]
[arith_dc_K_15 _uint8]
[arith_dc_K_16 _uint8]
[restart_interval _uint]
[saw_JFIF_marker _bool]
[JFIF_major_version _uint8]
[JFIF_minor_version _uint8]
[density_unit _uint8]
[X_density _uint16]
[Y_density _uint16]
[saw_Adobe_marker _bool]
[Adobe_transform _uint8]
[CCIR601_sampling _bool]
[marker_list _pointer]
[max_h_samp_factor _int]
[max_v_samp_factor _int]
[min_DCT_scaled_size _scaled_size]
[total_iMCU_rows _JDIMENSION]
[sample_range_limit _pointer]
[comps_in_scan _int]
[cur_comp_info_1 _pointer]
[cur_comp_info_2 _pointer]
[cur_comp_info_3 _pointer]
[cur_comp_info_4 _pointer]
[MCUs_per_row _JDIMENSION]
[MCU_rows_in_scan _JDIMENSION]
[blocks_in_MCU _int]
[MCU_membership_1 _int]
[MCU_membership_2 _int]
[MCU_membership_3 _int]
[MCU_membership_4 _int]
[MCU_membership_5 _int]
[MCU_membership_6 _int]
[MCU_membership_7 _int]
[MCU_membership_8 _int]
[MCU_membership_9 _int]
[MCU_membership_10 _int]
[Ss _int]
[Se _int]
[Ah _int]
[Al _int]
[unread_marker _int]
[master _pointer]
[main _pointer]
[coef _pointer]
[post _pointer]
[inputctl _pointer]
[marker _pointer]
[entropy _pointer]
[idct _pointer]
[upsample _pointer]
[cconvert _pointer]
[cquantize _pointer]))
(define _j_decompress_ptr _jpeg_decompress_struct-pointer)
(define-cstruct _jpeg_source_mgr ([next_input_byte _pointer] ;; /* => next byte to read from buffer */
[bytes_in_buffer _size_t] ;; /* # of bytes remaining in buffer */
[init_source (_fun _j_decompress_ptr -> _void)]
[fill_input_buffer (_fun _j_decompress_ptr -> _bool)]
[skip_input_data (_fun _j_decompress_ptr _long -> _void)]
[resync_to_restart (_fun _j_decompress_ptr _int -> _bool)]
[term_source (_fun _j_decompress_ptr -> _void)]
;; extra fields specific to this binding:
[buffer _pointer]))
(define (jpeg_decompress_struct-src m)
(ptr-cast (jpeg_decompress_struct-src* m) _jpeg_source_mgr-pointer))
(define-cstruct _jpeg7_compression_params ([scale_num _uint]
[scale_denom _uint]
[jpeg_width _JDIMENSION]
[jpeg_height _JDIMENSION]
[data_precision _int]))
(define _compression_params_t
(case JPEG_LIB_VERSION
[(62) _int] ; just data_precission
[else _jpeg7_compression_params]))
(define-cstruct _quant_tbl_62_t ([quant_tbl_ptrs_1 _pointer]
[quant_tbl_ptrs_2 _pointer]
[quant_tbl_ptrs_3 _pointer]
[quant_tbl_ptrs_4 _pointer]))
(define-cstruct (_quant_tbl_70_t _quant_tbl_62_t) ([q_scale_factor_1 _int]
[q_scale_factor_2 _int]
[q_scale_factor_3 _int]
[q_scale_factor_4 _int]))
(define _quant_tbl_t
(case JPEG_LIB_VERSION
[(62) _quant_tbl_62_t]
[else _quant_tbl_70_t]))
(define _sampling_t
(case JPEG_LIB_VERSION
[(62) _bool] ; just CCIR601_sampling
[else (make-cstruct-type (list _bool _bool))])) ; CCIR601_sampling and do_fancy_downsampling
(define-cstruct _factors_62_t ([max_h_samp_factor _int]
[max_v_samp_factor _int]))
(define-cstruct (_factors_70_t _factors_62_t) ([scaled _scaled_size]))
(define _factors_t
(case JPEG_LIB_VERSION
[(62) _factors_62_t]
[else _factors_70_t]))
(define-cstruct _jpeg_compress_struct ([err _jpeg_error_mgr-pointer]
[mem _jpeg_memory_mgr-pointer]
[progress _pointer] ; _jpeg_progress_mgr_pointer
[client_data _pointer]
[is_decompressor _bool]
[global_state _int]
[dest* _pointer] ; actually jpeg_destination_mgr-pointer
[image_width _JDIMENSION]
[image_height _JDIMENSION]
[input_components _int]
[in_color_space _J_COLOR_SPACE]
[input_gamma _double]
[compression_params _compression_params_t]
[num_components _int]
[jpeg_color_space _J_COLOR_SPACE]
[comp_info _pointer]
[quant_tbl _quant_tbl_t]
[dc_huff_tbl_ptrs_1 _pointer]
[dc_huff_tbl_ptrs_2 _pointer]
[dc_huff_tbl_ptrs_3 _pointer]
[dc_huff_tbl_ptrs_4 _pointer]
[ac_huff_tbl_ptrs_1 _pointer]
[ac_huff_tbl_ptrs_2 _pointer]
[ac_huff_tbl_ptrs_3 _pointer]
[ac_huff_tbl_ptrs_4 _pointer]
[arith_dc_L_1 _uint8]
[arith_dc_L_2 _uint8]
[arith_dc_L_3 _uint8]
[arith_dc_L_4 _uint8]
[arith_dc_L_5 _uint8]
[arith_dc_L_6 _uint8]
[arith_dc_L_7 _uint8]
[arith_dc_L_8 _uint8]
[arith_dc_L_9 _uint8]
[arith_dc_L_10 _uint8]
[arith_dc_L_11 _uint8]
[arith_dc_L_12 _uint8]
[arith_dc_L_13 _uint8]
[arith_dc_L_14 _uint8]
[arith_dc_L_15 _uint8]
[arith_dc_L_16 _uint8]
[arith_dc_U_1 _uint8]
[arith_dc_U_2 _uint8]
[arith_dc_U_3 _uint8]
[arith_dc_U_4 _uint8]
[arith_dc_U_5 _uint8]
[arith_dc_U_6 _uint8]
[arith_dc_U_7 _uint8]
[arith_dc_U_8 _uint8]
[arith_dc_U_9 _uint8]
[arith_dc_U_10 _uint8]
[arith_dc_U_11 _uint8]
[arith_dc_U_12 _uint8]
[arith_dc_U_13 _uint8]
[arith_dc_U_14 _uint8]
[arith_dc_U_15 _uint8]
[arith_dc_U_16 _uint8]
[arith_dc_K_1 _uint8]
[arith_dc_K_2 _uint8]
[arith_dc_K_3 _uint8]
[arith_dc_K_4 _uint8]
[arith_dc_K_5 _uint8]
[arith_dc_K_6 _uint8]
[arith_dc_K_7 _uint8]
[arith_dc_K_8 _uint8]
[arith_dc_K_9 _uint8]
[arith_dc_K_10 _uint8]
[arith_dc_K_11 _uint8]
[arith_dc_K_12 _uint8]
[arith_dc_K_13 _uint8]
[arith_dc_K_14 _uint8]
[arith_dc_K_15 _uint8]
[arith_dc_K_16 _uint8]
[num_scans _int]
[scan_info _pointer]
[raw_data_in _bool]
[arith_code _bool]
[optimize_coding _bool]
[sampling _sampling_t]
[smoothing_factor _int]
[dct_method _J_DCT_METHOD]
[restart_interval _uint]
[restart_in_rows _int]
[write_JFIF_header _bool]
[JFIF_major_version _uint8]
[JFIF_minor_version _uint8]
[density_unit _uint8]
[X_density _uint16]
[Y_density _uint16]
[write_Adobe_marker _bool]
[next_scanline _JDIMENSION]
[progressive_mode _bool]
[factors _factors_t]
[total_iMCU_rows _JDIMENSION]
[comps_in_scan _int]
[cur_comp_info_1 _pointer]
[cur_comp_info_2 _pointer]
[cur_comp_info_3 _pointer]
[cur_comp_info_4 _pointer]
[MCUs_per_row _JDIMENSION]
[MCU_rows_in_scan _JDIMENSION]
[blocks_in_MCU _int]
[MCU_membership_1 _int]
[MCU_membership_2 _int]
[MCU_membership_3 _int]
[MCU_membership_4 _int]
[MCU_membership_5 _int]
[MCU_membership_6 _int]
[MCU_membership_7 _int]
[MCU_membership_8 _int]
[MCU_membership_9 _int]
[MCU_membership_10 _int]
[Ss _int]
[Se _int]
[Ah _int]
[Al _int]
[master _pointer]
[main _pointer]
[prep _pointer]
[coef _pointer]
[marker _pointer]
[cconvert _pointer]
[downsample _pointer]
[fdct _pointer]
[entropy _pointer]
[script_space _pointer]
[script_space_size _int]))
(define _j_compress_ptr _jpeg_compress_struct-pointer)
(define-cstruct _jpeg_destination_mgr ([next_output_byte _pointer] ;; /* => next byte to write in buffer */
[free_in_buffer _size_t] ;; /* # of byte spaces remaining in buffer */
[init_destination (_fun _j_compress_ptr -> _void)]
[empty_output_buffer (_fun _j_compress_ptr -> _bool)]
[term_destination (_fun _j_compress_ptr -> _void)]
;; extra fields specific to this binding:
[buffer _pointer]))
(define (jpeg_compress_struct-dest m)
(ptr-cast (jpeg_compress_struct-dest* m) _jpeg_destination_mgr-pointer))
(define BUFFER-SIZE 4096)
(define JPEG_EOI #xD9)
(define (init-source m)
(void))
(define (fill-input-buffer m)
(let* ([s (jpeg_decompress_struct-src m)]
[b (jpeg_source_mgr-buffer s)]
[bstr (scheme_make_sized_byte_string b BUFFER-SIZE 0)]
[in (ptr-ref (jpeg_decompress_struct-client_data m) _scheme)])
(let* ([len (read-bytes! bstr in)]
[len (if (zero? len)
(begin
(bytes-set! bstr 0 #xFF)
(bytes-set! bstr 1 JPEG_EOI)
2)
len)])
(set-jpeg_source_mgr-next_input_byte! s b)
(set-jpeg_source_mgr-bytes_in_buffer! s len)
#t)))
(define (skip-input-data m len)
(let* ([s (jpeg_decompress_struct-src m)]
[avail (jpeg_source_mgr-bytes_in_buffer s)])
(if (avail . >= . len)
(begin
(set-jpeg_source_mgr-next_input_byte! s (ptr-add (jpeg_source_mgr-next_input_byte s) len))
(set-jpeg_source_mgr-bytes_in_buffer! s (- avail len)))
(let ([in (ptr-ref (jpeg_decompress_struct-client_data m) _scheme)])
(read-bytes (- len avail) in)
(set-jpeg_source_mgr-next_input_byte! s #f)
(set-jpeg_source_mgr-bytes_in_buffer! s 0)
(void)))))
(define (term-source m)
;; Maybe add support to optionally close port as early as possible?
(when #f
(let ([in (ptr-ref (jpeg_decompress_struct-client_data m) _scheme)])
(close-input-port in))))
(define (init-destination m)
(void))
(define (empty-output-buffer m)
(let* ([d (jpeg_compress_struct-dest m)]
[b (jpeg_destination_mgr-buffer d)]
[bstr (scheme_make_sized_byte_string b
(- BUFFER-SIZE (jpeg_destination_mgr-free_in_buffer d))
0)]
[out (ptr-ref (jpeg_compress_struct-client_data m) _scheme)])
(write-bytes bstr out)
(set-jpeg_destination_mgr-next_output_byte! d b)
(set-jpeg_destination_mgr-free_in_buffer! d BUFFER-SIZE)
#t))
(define (term-destination m)
(empty-output-buffer m)
;; Maybe add support to optionally close port as early as possible?
(when #f
(let ([in (ptr-ref (jpeg_decompress_struct-client_data m) _scheme)])
(close-input-port in))))
(define (error-exit m)
(let ([bstr (make-bytes JMSG_LENGTH_MAX)])
((jpeg_error_mgr-format_message
(jpeg_decompress_struct-err (ptr-cast m _jpeg_decompress_struct-pointer)))
m
bstr)
(error 'jpeg "~a" (bytes->string/latin-1 (subbytes bstr 0 (let loop ([i 0])
(if (zero? (bytes-ref bstr i))
i
(loop (add1 i)))))))))
(define (ptr-cast p t) (cast p _pointer t))
(define destroy-decompress
((deallocator)
(lambda (m)
(free (jpeg_source_mgr-buffer (jpeg_decompress_struct-src m)))
(free (jpeg_decompress_struct-err m))
(free (jpeg_decompress_struct-src m))
(free-immobile-cell (jpeg_decompress_struct-client_data m))
(free m))))
(define create-decompress
((allocator destroy-decompress)
(lambda (in)
(let ([m (ptr-cast (malloc _jpeg_decompress_struct 'raw) _jpeg_decompress_struct-pointer)]
[s (ptr-cast (malloc _jpeg_source_mgr 'raw) _jpeg_source_mgr-pointer)]
[e (ptr-cast (malloc sizeof_jpeg_error_mgr 'raw) _jpeg_error_mgr-pointer)]
[b (malloc 'raw BUFFER-SIZE)])
(set-jpeg_decompress_struct-err! m (jpeg_std_error e))
(set-jpeg_error_mgr-error_exit! e error-exit)
(jpeg_CreateDecompress m JPEG_LIB_VERSION (ctype-sizeof _jpeg_decompress_struct))
(set-jpeg_decompress_struct-src*! m s)
(set-jpeg_source_mgr-buffer! s b)
(set-jpeg_decompress_struct-client_data! m (malloc-immobile-cell in))
(set-jpeg_source_mgr-next_input_byte! s #f)
(set-jpeg_source_mgr-bytes_in_buffer! s 0)
(set-jpeg_source_mgr-init_source! s init-source)
(set-jpeg_source_mgr-fill_input_buffer! s fill-input-buffer)
(set-jpeg_source_mgr-skip_input_data! s skip-input-data)
(set-jpeg_source_mgr-resync_to_restart! s jpeg_resync_to_restart)
(set-jpeg_source_mgr-term_source! s term-source)
m))))
(define destroy-compress
((deallocator)
(lambda (m)
(free (jpeg_destination_mgr-buffer (jpeg_compress_struct-dest m)))
(free (jpeg_compress_struct-dest m))
(free (jpeg_compress_struct-err m))
(free-immobile-cell (jpeg_compress_struct-client_data m))
(free m))))
(define create-compress
((allocator destroy-compress)
(lambda (out)
(let ([m (ptr-cast (malloc _jpeg_compress_struct 'raw) _jpeg_compress_struct-pointer)]
[d (ptr-cast (malloc _jpeg_destination_mgr 'raw) _jpeg_destination_mgr-pointer)]
[e (ptr-cast (malloc sizeof_jpeg_error_mgr 'raw) _jpeg_error_mgr-pointer)]
[b (malloc 'raw BUFFER-SIZE)])
(set-jpeg_compress_struct-err! m (jpeg_std_error e))
(set-jpeg_error_mgr-error_exit! e error-exit)
(jpeg_CreateCompress m JPEG_LIB_VERSION (ctype-sizeof _jpeg_compress_struct))
(set-jpeg_compress_struct-dest*! m d)
(set-jpeg_destination_mgr-buffer! d b)
(set-jpeg_compress_struct-client_data! m (malloc-immobile-cell out))
(set-jpeg_destination_mgr-next_output_byte! d b)
(set-jpeg_destination_mgr-free_in_buffer! d BUFFER-SIZE)
(set-jpeg_destination_mgr-init_destination! d init-destination)
(set-jpeg_destination_mgr-empty_output_buffer! d empty-output-buffer)
(set-jpeg_destination_mgr-term_destination! d term-destination)
m))))
(define (create-jpeg-sample-array m len)
(let ([samps ((jpeg_memory_mgr-alloc_sarray (if (jpeg_decompress_struct? m)
(jpeg_decompress_struct-mem m)
(jpeg_compress_struct-mem m)))
m
JPOOL_IMAGE
len
1)])
(values samps (scheme_make_sized_byte_string (ptr-ref samps _pointer) len 0))))
(define-jpeg/private jpeg_std_error (_fun _jpeg_error_mgr-pointer -> _jpeg_error_mgr-pointer))
(define-jpeg/private jpeg_CreateDecompress (_fun _j_decompress_ptr _int _int -> _void))
(define-jpeg/private jpeg_resync_to_restart (_fun _j_decompress_ptr _int -> _bool))
(define-jpeg jpeg_read_header (_fun _j_decompress_ptr _bool -> _void))
(define-jpeg jpeg_start_decompress (_fun _j_decompress_ptr -> _void))
(define-jpeg jpeg_read_scanlines (_fun _j_decompress_ptr _pointer _int -> _void))
(define-jpeg jpeg_finish_decompress (_fun _j_decompress_ptr -> _int))
(define-jpeg/private jpeg_CreateCompress (_fun _j_compress_ptr _int _int -> _void))
(define-jpeg jpeg_set_defaults (_fun _j_compress_ptr -> _int))
(define-jpeg jpeg_set_quality (_fun _j_compress_ptr _int _bool -> _int))
(define-jpeg jpeg_start_compress (_fun _j_compress_ptr _bool -> _void))
(define-jpeg jpeg_write_scanlines (_fun _j_compress_ptr _pointer _int -> _void))
(define-jpeg jpeg_finish_compress (_fun _j_compress_ptr -> _int))
(provide create-decompress
destroy-decompress
create-compress
destroy-compress
create-jpeg-sample-array
jpeg_decompress_struct-output_width
jpeg_decompress_struct-output_height
jpeg_decompress_struct-output_components
jpeg_decompress_struct-mem
set-jpeg_compress_struct-image_width!
set-jpeg_compress_struct-image_height!
set-jpeg_compress_struct-input_components!
set-jpeg_compress_struct-in_color_space!
JPOOL_IMAGE)

35
collects/racket/draw/local.rkt Normal file
View File

@ -0,0 +1,35 @@
#lang scheme/base
(require scheme/class)
(provide (all-defined-out))
(define-local-member-name
;; various
adjust-lock
;; bitmap%
get-cairo-surface
get-cairo-alpha-surface
;; dc%
in-cairo-context
;; region%
install-region
lock-region
;; font% and dc-backend<%>
get-pango
;; font%
get-ps-pango
;; dc-backend<%>
get-cr
end-cr
reset-cr
flush-cr
init-cr-matrix
get-font-metrics-key
install-color
dc-adjust-smoothing)

120
collects/racket/draw/lock.rkt Normal file
View File

@ -0,0 +1,120 @@
#lang racket/base
(require (for-syntax racket/base)
ffi/unsafe/atomic)
(provide (protect-out as-entry
as-exit
entry-point))
;; We need atomic mode for a couple of reasons:
;;
;; * We may need to bracket some (trusted) operations so that the
;; queue thread doesn't poll for events during the operation.
;;
;; * The scheme/gui classes have internal-consistency requirements.
;; When the user creates an object or calls a method, or when the
;; system invokes a callback, many steps may be required to
;; initialize or reset fields to maintain invariants. To ensure that
;; other threads do not call methods during a time when invariants
;; do not hold, we force all of the following code to be executed in
;; a single threaded manner, and we temporarily disable breaks.
;;
;; Atomic mode is implemented with a single monitor: all entry points
;; into the code use `entry-point' or `as-entry', and all points with
;; this code that call back out to user code uses `as-exit'.
;;
;; If an exception is raised within an `enter'ed area, control is
;; moved back outside by the exception handler, and then the exception
;; is re-raised. The user can't tell that the exception was caught an
;; re-raised. But without the catch-and-reraise, the user's exception
;; handler might try to use GUI elements from a different thread, or
;; other such things, leading to deadlock.
(define monitor-owner #f)
;; An exception may be constructed while we're entered:
(define entered-err-string-handler
(lambda (s n)
(as-exit
(lambda ()
((error-value->string-handler) s n)))))
(define old-paramz #f)
(define old-break-paramz #f)
(define exited-key (gensym 'as-exit))
(define lock-tag (make-continuation-prompt-tag 'lock))
(define (as-entry f)
(cond
[(eq? monitor-owner (current-thread))
(f)]
[else
(with-continuation-mark
exited-key
#f
(call-with-continuation-prompt
(lambda ()
(dynamic-wind
(lambda ()
(start-atomic)
(set! monitor-owner (current-thread)))
(lambda ()
(set! old-paramz (current-parameterization))
(set! old-break-paramz (current-break-parameterization))
(parameterize ([error-value->string-handler entered-err-string-handler])
(parameterize-break
#f
(call-with-exception-handler
(lambda (exn)
;; Get out of atomic region before letting
;; an exception handler work
(if (continuation-mark-set-first #f exited-key)
exn ; defer to previous exn handler
(abort-current-continuation
lock-tag
(lambda () (raise exn)))))
f))))
(lambda ()
(set! monitor-owner #f)
(set! old-paramz #f)
(set! old-break-paramz #f)
(end-atomic))))
lock-tag
(lambda (t) (t))))]))
(define (as-exit f)
;; (unless (eq? monitor-owner (current-thread)) (error 'monitor-exit "not in monitored area for ~e" f))
(let ([paramz old-paramz]
[break-paramz old-break-paramz])
(with-continuation-mark
exited-key
#t ; disables special exception handling
(call-with-parameterization
paramz
(lambda ()
(call-with-break-parameterization
break-paramz
(lambda ()
(dynamic-wind
(lambda ()
(set! monitor-owner #f)
(end-atomic))
f
(lambda ()
(set! old-paramz paramz)
(set! old-break-paramz break-paramz)
(start-atomic)
(set! monitor-owner (current-thread)))))))))))
(define-syntax entry-point
(lambda (stx)
(syntax-case stx (lambda #%plain-lambda case-lambda)
[(_ (lambda args body1 body ...))
(syntax (lambda args (as-entry (lambda () body1 body ...))))]
[(_ (#%plain-lambda args body1 body ...))
(syntax (#%plain-lambda args (as-entry (lambda () body1 body ...))))]
[(_ (case-lambda [vars body1 body ...] ...))
(syntax (case-lambda
[vars (as-entry (lambda () body1 body ...))]
...))])))

147
collects/racket/draw/pango.rkt Normal file
View File

@ -0,0 +1,147 @@
#lang scheme/base
(require ffi/unsafe
ffi/unsafe/define
ffi/unsafe/alloc
setup/dirs
"cairo.rkt"
"utils.rkt")
(define pango-lib
(case (system-type)
[(macosx)
(ffi-lib "libpango-1.0.0")]
[(unix) (ffi-lib "libpango-1.0" '("0"))]
[(windows)
; (ffi-lib "msjava")
(ffi-lib "libglib-2.0-0")
(ffi-lib "libgmodule-2.0-0")
(ffi-lib "libgobject-2.0-0")
(ffi-lib "libpango-1.0-0")]))
(define pangocairo-lib
(case (system-type)
[(macosx)
(ffi-lib "libpangocairo-1.0.0")]
[(unix) (ffi-lib "libpangocairo-1.0" '("0"))]
[(windows)
(ffi-lib "libpangowin32-1.0-0")
(ffi-lib "libexpat-1")
(ffi-lib "freetype6")
(ffi-lib "libfontconfig-1")
(ffi-lib "libpangoft2-1.0-0")
(ffi-lib "libpangocairo-1.0-0")]))
(define glib-lib
(case (system-type)
[(macosx) (ffi-lib "libgobject-2.0.0")]
[else #f]))
(define-ffi-definer define-pango pango-lib
#:provide provide)
(define-ffi-definer define-pangocairo pangocairo-lib
#:provide provide)
(define-ffi-definer define-glib glib-lib
#:provide provide)
(define PangoContext (_cpointer 'PangoContext))
(define PangoLayout (_cpointer 'PangoLayout))
(define PangoFontDescription (_cpointer 'PangoFontDescription))
(define PangoFontFamily (_cpointer 'PangoFontFamily))
(define PangoFontMap (_cpointer 'PangoFontMap))
(define PangoAttrList (_cpointer 'PangoAttrList))
(define PangoAttribute (_cpointer 'PangoAttribute))
(define-cstruct _PangoRectangle ([x _int]
[y _int]
[width _int]
[height _int]))
(provide make-PangoRectangle
PangoRectangle-x
PangoRectangle-y
PangoRectangle-width
PangoRectangle-height)
(define-glib g_object_unref (_fun _pointer -> _void)
#:wrap (deallocator))
(define-pangocairo pango_cairo_create_context (_fun _cairo_t -> PangoContext)
#:wrap (allocator g_object_unref))
(define-pangocairo pango_cairo_create_layout (_fun _cairo_t -> PangoLayout)
#:wrap (allocator g_object_unref))
(define-pangocairo pango_cairo_update_layout (_fun _cairo_t PangoLayout -> _void))
(define-pango pango_layout_set_text (_fun PangoLayout [s : _string] [_int = -1] -> _void))
(define-pangocairo pango_cairo_show_layout (_fun _cairo_t PangoLayout -> _void))
(define-pango pango_layout_get_context (_fun PangoLayout -> PangoContext)) ;; not an allocator
(define-pango pango_layout_get_extents (_fun PangoLayout _pointer _PangoRectangle-pointer -> _void))
(define-pango pango_layout_get_baseline (_fun PangoLayout -> _int))
(define-pango pango_layout_new (_fun PangoContext -> PangoLayout)
#:wrap (allocator g_object_unref))
(define-pangocairo pango_cairo_context_get_font_options (_fun PangoContext -> _cairo_font_options_t)) ;; not an allocator
(define-pangocairo pango_cairo_context_set_font_options (_fun PangoContext _cairo_font_options_t -> _void)) ;; makes a copy
(define-pango pango_layout_set_font_description (_fun PangoLayout PangoFontDescription -> _void)) ;; makes a copy
(define-pango pango_context_get_font_map (_fun PangoContext -> PangoFontMap)) ;; not an allocator
(define-pango pango_font_family_get_name (_fun PangoFontFamily -> _string)) ;; not an allocator
(define-pango pango_font_family_is_monospace (_fun PangoFontFamily -> _bool))
(define-pango pango_attr_list_unref (_fun PangoAttrList -> _void)
#:wrap (deallocator))
(define-pango pango_attr_list_new (_fun -> PangoAttrList)
#:wrap (allocator pango_attr_list_unref))
(define-pango pango_attr_list_insert (_fun PangoAttrList PangoAttribute -> _void)
;; takes ownership of the attribute
#:wrap (deallocator cadr))
(define-pango pango_attribute_destroy (_fun PangoAttribute -> _void)
#:wrap (deallocator))
(define-pango pango_attr_underline_new (_fun _int -> PangoAttribute)
#:wrap (allocator pango_attribute_destroy))
(define-pango pango_layout_set_attributes (_fun PangoLayout PangoAttrList -> _void))
(define-pangocairo pango_cairo_font_map_get_default (_fun -> PangoFontMap)) ;; not an allocator
(define-pango pango_font_map_list_families (_fun PangoFontMap
(fams : (_ptr o _pointer))
(len : (_ptr o _int))
-> _void
-> (begin0
(for/list ([i (in-range len)])
(ptr-ref fams PangoFontFamily i))
(free fams))))
(define-pango pango_font_description_free (_fun PangoFontDescription -> _void)
#:wrap (deallocator))
(define-pango pango_font_description_new (_fun -> PangoFontDescription)
#:wrap (allocator pango_font_description_free))
(define-pango pango_font_description_from_string (_fun _string -> PangoFontDescription)
#:wrap (allocator pango_font_description_free))
(define-pango pango_font_description_set_family (_fun PangoFontDescription _string -> _void))
(define-pango pango_font_description_set_style (_fun PangoFontDescription _int -> _void))
(define-pango pango_font_description_set_weight (_fun PangoFontDescription _int -> _void))
(define-pango pango_font_description_set_size (_fun PangoFontDescription _int -> _void))
(define-pango pango_font_description_set_absolute_size (_fun PangoFontDescription _double* -> _void))
(define-enum
0
PANGO_STYLE_NORMAL
PANGO_STYLE_OBLIQUE
PANGO_STYLE_ITALIC)
(define-enum
0
PANGO_UNDERLINE_NONE
PANGO_UNDERLINE_SINGLE
PANGO_UNDERLINE_DOUBLE
PANGO_UNDERLINE_LOW
PANGO_UNDERLINE_ERROR)
(define/provide PANGO_WEIGHT_LIGHT 300)
(define/provide PANGO_WEIGHT_MEDIUM 500)
(define/provide PANGO_WEIGHT_BOLD 700)
(define/provide PANGO_SCALE 1024)

134
collects/racket/draw/pen.rkt Normal file
View File

@ -0,0 +1,134 @@
#lang scheme/base
(require scheme/class
"color.ss"
"syntax.ss"
"local.ss"
"bitmap.ss")
(provide pen%
pen-list% the-pen-list
pen-style-symbol?)
(define (pen-style-symbol? s)
(memq s '(transparent solid xor hilite
dot long-dash short-dash dot-dash
xor-dot xor-long-dash xor-short-dash
xor-dot-dash)))
(define (pen-cap-symbol? s)
(memq s '(round projecting butt)))
(define (pen-join-symbol? s)
(memq s '(round bevel miter)))
(define (pen-width? v)
(and (real? v)
(>= v 0)
(<= v 255)))
(define black (send the-color-database find-color "black"))
(define-local-member-name s-set-key)
(defclass pen% object%
(define key #f)
(define/public (s-set-key k) (set! key k))
(define color black)
(properties #:check-immutable check-immutable
[[pen-cap-symbol? cap] 'round]
[[pen-join-symbol? join] 'round]
[[pen-style-symbol? style] 'solid]
[[pen-width? width] 0])
(init-rest args)
(super-new)
(case-args
args
[() (void)]
[([color% _color]
[pen-width? _width]
[pen-style-symbol? _style])
(set! color (color->immutable-color _color))
(set! width _width)
(set! style _style)]
[([string? _color]
[pen-width? _width]
[pen-style-symbol? _style])
(set! color (send the-color-database find-color _color))
(set! width _width)
(set! style _style)]
(init-name 'pen%))
(define immutable? #f)
(define lock-count 0)
(define/public (set-immutable) (set! immutable? #t))
(define/public (is-immutable?) (or immutable? (positive? lock-count)))
(define/public (adjust-lock v) (set! lock-count (+ lock-count v)))
(define/private (check-immutable s)
(when (or immutable? (positive? lock-count))
(error (method-name 'brush% s) "object is ~a"
(if immutable? "immutable" "locked"))))
(define/public (set-color . args)
(check-immutable 'set-color)
(case-args
args
[([color% _color])
(set! color (color->immutable-color _color))]
[([string? _color])
(set! color (send the-color-database find-color _color))]
[([byte? r] [byte? g] [byte? b])
(let ([c (make-object color% r g b)])
(send c set-immutable)
(set! color c))]
(method-name 'pen% 'set-color)))
(define/public (get-color) color)
(define stipple #f)
(def/public (get-stipple) stipple)
(def/public (set-stipple [(make-or-false bitmap%) s])
(check-immutable 'set-stipple)
(let ([old-s stipple])
(set! stipple #f)
(when old-s (send old-s adjust-lock -1)))
(when s (send s adjust-lock 1))
(set! stipple s)))
;; ----------------------------------------
(defclass pen-list% object%
(define pens (make-weak-hash))
(super-new)
(define/public (find-or-create-pen . args)
(let-values ([(col w s)
(case-args
args
[([color% _color]
[pen-width? _width]
[pen-style-symbol? _style])
(values (color->immutable-color _color) _width _style)]
[([string? _color]
[pen-width? _width]
[pen-style-symbol? _style])
(values (send the-color-database find-color _color)
_width
_style)]
(method-name 'find-or-create-pen 'pen-list%))])
(let ([key (vector (send col red) (send col green) (send col blue)
w s)])
(let ([e (hash-ref pens key #f)])
(or (and e
(ephemeron-value e))
(let* ([f (make-object pen% col w s)]
[e (make-ephemeron key f)])
(send f s-set-key key)
(hash-set! pens key e)
f)))))))
(define the-pen-list (new pen-list%))

343
collects/racket/draw/png.rkt Normal file
View File

@ -0,0 +1,343 @@
#lang scheme/base
(require ffi/unsafe
ffi/unsafe/define
ffi/unsafe/alloc
ffi/unsafe/atomic
setup/dirs
"bstr.rkt"
"utils.rkt")
(define png-lib
(case (system-type)
[(macosx) (ffi-lib "libpng14" '("14" #f))]
[(unix) (ffi-lib "libpng12" '("0"))]
[(windows)
(ffi-lib "zlib1.dll")
(ffi-lib "libpng14-14.dll")]))
(define-ffi-definer define-png png-lib
#:provide provide)
(define PNG_LIBPNG_VER_STRING
(case (system-type)
[(macosx) #"1.4"]
[else #"1.2"]))
(define _png_structp (_cpointer 'png_structp))
(define _png_infop (_cpointer 'png_infop))
(define _png_end_infop (_cpointer 'png_end_infop))
(define _png_size_t _long)
(define-cstruct _png_color_16 ([index _byte]
[red _uint16]
[green _uint16]
[blue _uint16]
[gray _uint16]))
(define-png png_create_read_struct
(_fun _bytes
_pointer
(_fun _png_structp _string -> _void)
(_fun _png_structp _string -> _void)
-> _png_structp))
(define png_destroy_read_struct1
(get-ffi-obj 'png_destroy_read_struct
png-lib
(_fun (_ptr i _png_structp)
(_pointer = #f)
(_pointer = #f)
-> _void)))
(define png_destroy_read_struct2
(get-ffi-obj 'png_destroy_read_struct
png-lib
(_fun (_ptr i _png_structp)
(_ptr i _png_infop)
(_pointer = #f)
-> _void)))
(define-png png_create_write_struct
(_fun _bytes
_pointer
(_fun _png_structp _string -> _void)
(_fun _png_structp _string -> _void)
-> _png_structp))
(define png_destroy_write_struct1
(get-ffi-obj 'png_destroy_write_struct
png-lib
(_fun (_ptr i _png_structp)
(_pointer = #f)
-> _void)))
(define png_destroy_write_struct2
(get-ffi-obj 'png_destroy_write_struct
png-lib
(_fun (_ptr i _png_structp)
(_ptr i _png_infop)
-> _void)))
(define-png png_create_info_struct (_fun _png_structp -> _png_infop))
(define-png png_read_info (_fun _png_structp _png_infop -> _void))
(define-png png_read_end (_fun _png_structp _png_infop -> _void))
(define-png png_write_info (_fun _png_structp _png_infop -> _void))
(define-png png_read_update_info (_fun _png_structp _png_infop -> _void))
(define-png png_get_IHDR (_fun _png_structp
_png_infop
(w : (_ptr o _uint32))
(h : (_ptr o _uint32))
(depth : (_ptr o _int))
(color-type : (_ptr o _int))
(interlace-type : (_ptr o _int))
(compression-type : (_ptr o _int))
(filter-type : (_ptr o _int))
-> _void
-> (values w h depth
color-type
interlace-type
compression-type
filter-type)))
(define-png png_set_IHDR (_fun _png_structp
_png_infop
_uint32
_uint32
_int
_int _int _int _int
-> _void))
(define-png png_set_read_fn (_fun _png_structp
_pointer
(_fun _png_structp
_pointer
_png_size_t
-> _void)
-> _void))
(define-png png_set_write_fn (_fun _png_structp
_pointer
(_fun _png_structp
_pointer
_png_size_t
-> _void)
(_fun _png_structp
-> _void)
-> _void))
(define-png png_get_io_ptr (_fun _png_structp -> _pointer))
(define-png png_get_rowbytes (_fun _png_structp _png_infop -> _uint32))
(define-png png_read_rows (_fun _png_structp _pointer #;(_vector i _bytes) _pointer _uint32 -> _void))
(define-png png_write_image (_fun _png_structp _pointer #;(_vector i _bytes) -> _void))
(define-png png_write_end (_fun _png_structp _png_infop -> _void))
(define-png png_get_valid (_fun _png_structp _png_infop _uint32 -> _uint32))
(define-png png_get_bKGD (_fun _png_structp _png_infop _png_color_16-pointer -> _bool))
(define-png png_set_background (_fun _png_structp _png_infop _png_color_16-pointer _int _int _double* -> _bool))
(define-png png_get_gAMA (_fun _png_structp _png_infop (g : (_ptr o _double))
-> (ok? : _bool)
-> (and ok? g)))
(define-png png_set_gamma (_fun _png_structp _double* _double* -> _void))
(define-png png_set_filler (_fun _png_structp _uint32 _int -> _void))
(define-png png_set_invert_alpha (_fun _png_structp -> _void))
(define-png png_set_palette_to_rgb (_fun _png_structp -> _void))
(define-png png_set_gray_to_rgb (_fun _png_structp -> _void))
(define-png png_set_tRNS_to_alpha (_fun _png_structp -> _void))
(define-png png_set_strip_16 (_fun _png_structp -> _void))
(define-png png_set_gray_1_2_4_to_8 (_fun _png_structp -> _void)
#:fail (lambda () #f))
(define-png png_set_expand_gray_1_2_4_to_8 (_fun _png_structp -> _void)
#:fail (lambda () #f))
(define-png png_set_interlace_handling (_fun _png_structp -> _int))
(define/provide PNG_COLOR_MASK_PALETTE 1)
(define/provide PNG_COLOR_MASK_COLOR 2)
(define/provide PNG_COLOR_MASK_ALPHA 4)
(define/provide PNG_COLOR_TYPE_GRAY 0)
(define/provide PNG_COLOR_TYPE_PALETTE (bitwise-ior PNG_COLOR_MASK_COLOR PNG_COLOR_MASK_PALETTE))
(define/provide PNG_COLOR_TYPE_RGB PNG_COLOR_MASK_COLOR)
(define/provide PNG_COLOR_TYPE_RGB_ALPHA (bitwise-ior PNG_COLOR_MASK_COLOR PNG_COLOR_MASK_ALPHA))
(define/provide PNG_COLOR_TYPE_GRAY_ALPHA PNG_COLOR_MASK_ALPHA)
(define/provide PNG_INTERLACE_NONE 0)
(define/provide PNG_INTERLACE_ADAM7 1)
(define/provide PNG_FILTER_TYPE_BASE 0)
(define/provide PNG_INTRAPIXEL_DIFFERENCING 64)
(define/provide PNG_FILTER_TYPE_DEFAULT PNG_FILTER_TYPE_BASE)
(define/provide PNG_COMPRESSION_TYPE_BASE 0)
(define/provide PNG_COMPRESSION_TYPE_DEFAULT PNG_COMPRESSION_TYPE_BASE)
(define/provide PNG_BACKGROUND_GAMMA_UNKNOWN 0)
(define/provide PNG_BACKGROUND_GAMMA_SCREEN 1)
(define/provide PNG_BACKGROUND_GAMMA_FILE 2)
(define/provide PNG_BACKGROUND_GAMMA_UNIQUE 3)
(define/provide PNG_INFO_tRNS #x0010)
(define PNG_FILLER_BEFORE 0)
(define PNG_FILLER_AFTER 1)
;; ----------------------------------------
;; Reading
(provide create-png-reader
read-png
destroy-png-reader)
(define-struct reader ([png #:mutable] info ib num-passes w h))
(define (error-esc v s)
(error 'png "~a" s))
(define (read-png-bytes png p len)
(let ([bstr (scheme_make_sized_byte_string p len 0)])
(read-bytes! bstr (ptr-ref (png_get_io_ptr png) _scheme))))
(define free-cell ((deallocator) free-immobile-cell))
(define make-cell ((allocator free-cell) malloc-immobile-cell))
(define (create-png-reader in bg-rgb)
(let* ([png (png_create_read_struct PNG_LIBPNG_VER_STRING #f error-esc void)]
[info (png_create_info_struct png)]
[ib (make-cell in)])
(png_set_read_fn png ib read-png-bytes)
(png_read_info png info)
(let-values ([(w h depth color-type
interlace-type compression-type filter-type)
(png_get_IHDR png info)])
(let* ([tRNS? (positive? (png_get_valid png info PNG_INFO_tRNS))]
[alpha? (or tRNS?
(positive? (bitwise-ior color-type PNG_COLOR_MASK_ALPHA)))]
[b&w? (and (= depth 1)
(= color-type PNG_COLOR_TYPE_GRAY)
(not tRNS?))])
(unless b&w?
;; Normalize formal of returned rows:
(when (= color-type PNG_COLOR_TYPE_PALETTE)
(png_set_palette_to_rgb png))
(when (or (= color-type PNG_COLOR_TYPE_GRAY)
(= color-type PNG_COLOR_TYPE_GRAY_ALPHA))
(png_set_gray_to_rgb png))
(when tRNS?
(png_set_tRNS_to_alpha png))
(when (= depth 16)
(png_set_strip_16 png))
;; Expand grayscale images to the full 8 bits from 1, 2, or 4 bits/pixel
((or png_set_gray_1_2_4_to_8 png_set_expand_gray_1_2_4_to_8) png))
(unless (or alpha? b&w?)
;; Set the background color to draw transparent and alpha images over.
(let* ([deep (lambda (n)
(if (= depth 16)
(+ n (arithmetic-shift n 8))
n))]
[bg (make-png_color_16 0 (deep 255) (deep 255) (deep 255) (deep 255))])
(cond
[bg-rgb (set-png_color_16-red! bg (deep (car bg-rgb)))
(set-png_color_16-green! bg (deep (cadr bg-rgb)))
(set-png_color_16-blue! bg (deep (caddr bg-rgb)))
(set-png_color_16-gray! bg (deep (floor (/ (apply + bg-rgb) 3))))]
[else (png_get_bKGD png info bg)])
(png_set_background png info bg PNG_BACKGROUND_GAMMA_SCREEN 0 1.0)))
(let ([gamma (png_get_gAMA png info)])
(when gamma
(let* ([s (getenv "SCREEN_GAMMA")]
[screen-gamma (and s (string->number s))])
(png_set_gamma png (if (and (real? screen-gamma)
(<= 0.0 screen-gamma 10.0))
screen-gamma
(case (system-type)
[(macosx) 1.7]
[else 2.0]))
gamma))))
(when alpha?
;; Add filler (or alpha) byte (before each RGB triplet)
(png_set_filler png 255 PNG_FILLER_AFTER))
(let ([num-passes (png_set_interlace_handling png)])
(png_read_update_info png info)
(values (make-reader png info ib num-passes w h)
w h
b&w?
alpha?))))))
(define (malloc-rows h row-bytes)
(let* ([align (lambda (v) (if (positive? (remainder v 8))
(+ v (- 8 (remainder v 8)))
v))]
[table-size (align (* h (ctype-sizeof _pointer)))]
[row-size (align row-bytes)]
[memory (malloc (+ table-size (* row-size h))
'atomic-interior)]
[rows memory])
(for ([i (in-range h)])
(ptr-set! rows _pointer i (ptr-add memory (+ table-size (* i row-size)))))
rows))
(define (read-png reader)
(let* ([row-bytes (png_get_rowbytes (reader-png reader) (reader-info reader))]
[rows (malloc-rows (reader-h reader) row-bytes)])
(for ([i (in-range (reader-num-passes reader))])
(png_read_rows (reader-png reader) rows #f (reader-h reader)))
(png_read_end (reader-png reader) (reader-info reader))
(list->vector
(for/list ([i (in-range (reader-h reader))])
(let ([p (ptr-ref rows _gcpointer i)])
(scheme_make_sized_byte_string p row-bytes 1))))))
(define (destroy-png-reader reader)
(when (reader-png reader)
(png_destroy_read_struct2 (reader-png reader)
(reader-info reader))
(free-cell (reader-ib reader))
(set-reader-png! reader #f)))
;; ----------------------------------------
;; Writing
(provide create-png-writer
write-png
destroy-png-writer)
(define-struct writer (png info ob))
(define (write-png-bytes png p len)
(let ([bstr (scheme_make_sized_byte_string p len 0)])
(write-bytes bstr (ptr-ref (png_get_io_ptr png) _scheme))))
(define (flush-png-bytes png)
(flush-output (ptr-ref (png_get_io_ptr png) _scheme)))
(define (create-png-writer out w h b&w? alpha?)
(let* ([png (png_create_write_struct PNG_LIBPNG_VER_STRING #f error-esc void)]
[info (png_create_info_struct png)]
[ob (make-cell out)])
(png_set_write_fn png ob write-png-bytes flush-png-bytes)
(png_set_IHDR png info w h (if b&w? 1 8)
(cond
[b&w? PNG_COLOR_TYPE_GRAY]
[alpha? PNG_COLOR_TYPE_RGB_ALPHA]
[else PNG_COLOR_TYPE_RGB])
PNG_INTERLACE_NONE PNG_COMPRESSION_TYPE_DEFAULT
PNG_FILTER_TYPE_DEFAULT)
(png_write_info png info)
(make-writer png info ob)))
(define (write-png writer vector-of-rows)
(if (zero? (vector-length vector-of-rows))
(png_write_image (writer-png writer) #f)
(let* ([h (vector-length vector-of-rows)]
[w (bytes-length (vector-ref vector-of-rows 0))]
[rows (malloc-rows h w)])
(for/list ([i (in-range h)])
(memcpy (ptr-ref rows _gcpointer i)
(vector-ref vector-of-rows i)
w))
(png_write_image (writer-png writer) rows)))
(png_write_end (writer-png writer) (writer-info writer)))
(define (destroy-png-writer writer)
(png_destroy_write_struct2 (writer-png writer)
(writer-info writer))
(free-cell (writer-ob writer)))

22
collects/racket/draw/point.rkt Normal file
View File

@ -0,0 +1,22 @@
#lang scheme/base
(require scheme/class)
(provide point% point-x point-y
list-of-pair-of-real?)
(define point%
(class object%
(init-field [x 0.0]
[y 0.0])
(super-new)))
(define point-x (class-field-accessor point% x))
(define point-y (class-field-accessor point% y))
(define (list-of-pair-of-real? p)
(and (list? p)
(andmap (lambda (p) (and (pair? p)
(real? (car p))
(real? (cdr p))))
p)))

74
collects/racket/draw/post-script-dc.rkt Normal file
View File

@ -0,0 +1,74 @@
#lang scheme/base
(require scheme/class
scheme/file
mred/private/syntax
"cairo.ss"
"dc.ss"
"font.ss"
"local.ss"
"ps-setup.ss")
(provide post-script-dc%)
(define dc-backend%
(class default-dc-backend%
(init [interactive #t]
[parent #f]
[use-paper-bbox #f]
[as-eps #t])
(define-values (margin-x margin-y)
(let ([xb (box 0)] [yb (box 0.0)])
(send (current-ps-setup) get-margin xb yb)
(values (unbox xb) (unbox yb))))
(define-values (scale-x scale-y)
(let ([xb (box 0)] [yb (box 0.0)])
(send (current-ps-setup) get-scaling xb yb)
(values (unbox xb) (unbox yb))))
(define-values (s width height)
(let* ([pss (current-ps-setup)]
[paper (assoc (send pss get-paper-name) paper-sizes)])
(values
(cairo_ps_surface_create (or (send pss get-filename)
(make-temporary-file "draw~a.ps"))
(cadr paper)
(caddr paper))
(cadr paper)
(caddr paper))))
(when as-eps
(cairo_ps_surface_set_eps s #t))
(define c (cairo_create s))
(cairo_surface_destroy s)
(init-cr-matrix)
(define/override (get-cr) c)
(def/override (get-size)
(values (exact->inexact width)
(exact->inexact height)))
(define/override (end-cr)
(cairo_surface_finish s)
(cairo_destroy c)
(set! c #f)
(set! s #f))
(define/override (init-cr-matrix)
(cairo_translate c margin-x margin-y)
(cairo_scale c scale-x scale-y))
(define/override (get-pango font)
(send font get-ps-pango))
(define/override (get-font-metrics-key sx sy)
(if (and (= sx 1.0) (= sy 1.0))
2
0))
(super-new)))
(define post-script-dc%
(dc-mixin dc-backend%))

77
collects/racket/draw/ps-setup.rkt Normal file
View File

@ -0,0 +1,77 @@
#lang scheme/base
(require scheme/class
mred/private/syntax)
(provide ps-setup%
current-ps-setup
paper-sizes)
(define paper-sizes
'(("A4 210 x 297\n mm" 595 842)
("A3 297 x 420 mm" 842 1191)
("Letter 8 1/2 x 11 in" 612 791)
("Legal 8 1/2 x 14 in" 612 1009)))
(define (paper-name-string? s)
(and (string? s)
(assoc paper-sizes s)))
(define ps-setup%
(class object%
(properties
[[string? command] "lpr"]
[[(make-or-false path-string?) filename] #f]
[[bool? level-2] #t]
[[(symbol-in preview file printer) mode] 'file]
[[(symbol-in portrait landscape) orientation] 'portrait]
[[paper-name-string? paper-name] "Letter 8 1/2 x 11 in"]
[[string? preview-command] "gv"])
(define editor-margin-x 20.0)
(define editor-margin-y 20.0)
(define margin-x 16.0)
(define margin-y 16.0)
(define scale-x 0.8)
(define scale-y 0.8)
(define trans-x 0.0)
(define trans-y 0.0)
(def/public (get-editor-margin [(make-box nonnegative-real?) x]
[(make-box nonnegative-real?) y])
(set-box! x editor-margin-x)
(set-box! y editor-margin-y))
(def/public (set-editor-margin [nonnegative-real? x]
[nonnegative-real? y])
(set! editor-margin-x x)
(set! editor-margin-y y))
(def/public (get-margin [(make-box nonnegative-real?) x]
[(make-box nonnegative-real?) y])
(set-box! x margin-x)
(set-box! y margin-y))
(def/public (set-margin [nonnegative-real? x]
[nonnegative-real? y])
(set! margin-x x)
(set! margin-y y))
(def/public (get-scaling [(make-box nonnegative-real?) x]
[(make-box nonnegative-real?) y])
(set-box! x scale-x)
(set-box! y scale-y))
(def/public (set-scaling [nonnegative-real? x]
[nonnegative-real? y])
(set! scale-x x)
(set! scale-y y))
(def/public (get-translation [(make-box nonnegative-real?) x]
[(make-box nonnegative-real?) y])
(set-box! x trans-x)
(set-box! y trans-y))
(def/public (set-translation [nonnegative-real? x]
[nonnegative-real? y])
(set! trans-x x)
(set! trans-y y))
(super-new)))
(define current-ps-setup (make-parameter (new ps-setup%)))

252
collects/racket/draw/region.rkt Normal file
View File

@ -0,0 +1,252 @@
#lang scheme/base
(require scheme/class
"syntax.ss"
"local.ss"
"cairo.ss"
"dc-path.ss"
"dc-intf.ss"
"point.ss"
"lock.ss")
(provide region%)
(define-local-member-name
get-paths
internal-get-dc)
(define temp-cr #f)
(define region%
(class object%
(init [the-dc #f])
(define dc the-dc)
(unless (dc . is-a? . dc<%>)
(raise-type-error (init-name 'region%)
"dc<%> instance"
dc))
;; Intersected paths, each as (cons <path> <fill-style>),
;; where <fill-style> is 'odd-even, 'winding, or 'any.
;; A null path list corresponds to an empty region.
(define paths null)
(define/public (get-paths) paths)
(define locked 0)
(define/public (lock-region delta) (set! locked (+ locked delta)))
(define my-key (gensym))
(define empty-known? #f) ; #t => `known-empty?' records `empty?' result
(define known-empty? #f)
(define/private (modifying who)
(when (positive? locked)
(error (method-name 'region% who)
"region is locked (installed into a dc<%>): "
this))
(set! empty-known? #f))
(define (ox oy) (send dc get-origin))
(define (sx sy) (send dc get-scale))
(def/public (get-dc) dc)
(define/public (internal-get-dc) dc)
(def/public (get-bounding-box)
(if (null? paths)
(values 0.0 0.0 0.0 0.0)
(let-values ([(l t r b) (send (caar paths) get-bounding-box)])
(let loop ([paths (cdr paths)]
[l l]
[t t]
[r r]
[b b])
(if (null? paths)
(values l t r b)
(let-values ([(l2 t2 r2 b2) (send (caar paths) get-bounding-box)])
(loop (cdr paths)
(min l l2)
(min t t2)
(max r r2)
(max b b2))))))))
(define/public (install-region cr [init (void)] [install (lambda (cr v) (cairo_clip cr))])
(let ([default-fill-rule (if (ormap (lambda (pr) (eq? (cdr pr) 'odd-even)) paths)
CAIRO_FILL_RULE_EVEN_ODD
CAIRO_FILL_RULE_WINDING)])
(for/fold ([v init]) ([pr (in-list paths)])
(cairo_new_path cr)
(send (car pr) do-path cr values values)
(cairo_set_fill_rule cr
(case (cdr pr)
[(odd-even) CAIRO_FILL_RULE_EVEN_ODD]
[(winding) CAIRO_FILL_RULE_WINDING]
[else default-fill-rule]))
(install cr v))))
(def/public (is-empty?)
(really-is-empty?))
(define/private (with-clipping proc)
(send
dc
in-cairo-context
(lambda (cr)
(cairo_save cr)
(install-region cr)
(begin0
(proc cr)
(cairo_restore cr)))))
(define/private (really-is-empty?)
(or (null? paths)
(if empty-known?
known-empty?
(let ([v (with-clipping
(lambda (cr)
(let-values ([(x1 y1 x2 y2) (cairo_clip_extents cr)])
(or (= x1 x2) (= y1 y2)))))])
(set! known-empty? v)
(set! empty-known? #t)
v))))
(def/public (in-region? [real? x]
[real? y])
(as-entry
(lambda ()
(unless temp-cr
(set! temp-cr
(cairo_create
(cairo_image_surface_create CAIRO_FORMAT_A8 1 1))))
(install-region temp-cr #t (lambda (cr v) (and v (cairo_in_fill temp-cr x y)))))))
(def/public (set-arc [real? x]
[real? y]
[nonnegative-real? width]
[nonnegative-real? height]
[real? start-radians]
[real? end-radians])
(modifying 'set-arc)
(let ([p (new dc-path%)])
(send p move-to x y)
(send p arc x y width height start-radians end-radians)
(send p close)
(set! paths (list (cons p 'any)))))
(def/public (set-ellipse [real? x]
[real? y]
[nonnegative-real? width]
[nonnegative-real? height])
(modifying 'set-ellipse)
(let ([p (new dc-path%)])
(send p ellipse x y width height)
(set! paths (list (cons p 'any)))))
(def/public (set-path [dc-path% path]
[real? [x 0.0]]
[real? [y 0.0]]
[(symbol-in odd-even winding) [fill-style 'odd-even]])
(modifying 'set-path)
(let ([p (new dc-path%)])
(send p append path)
(set! paths (list (cons p fill-style)))))
(def/public (set-polygon [(make-alts (make-list point%) list-of-pair-of-real?) pts]
[real? [x 0.0]]
[real? [y 0.0]]
[(symbol-in odd-even winding) [fill-style 'odd-even]])
(modifying 'set-polygon)
(if (null? pts)
(set! paths null)
(let ([p (new dc-path%)])
(let ([i (car pts)])
(if (pair? i)
(send p move-to (car i) (cdr i))
(send p move-to (point-x i) (point-y i))))
(for ([i (in-list (cdr pts))])
(if (pair? i)
(send p line-to (car i) (cdr i))
(send p line-to (point-x i) (point-y i))))
(send p close)
(set! paths (list (cons p fill-style))))))
(def/public (set-rectangle [real? x]
[real? y]
[nonnegative-real? width]
[nonnegative-real? height])
(modifying 'set-rectangle)
(let ([p (new dc-path%)])
(send p rectangle x y width height)
(set! paths (list (cons p 'any)))))
(def/public (set-rounded-rectangle [real? x]
[real? y]
[nonnegative-real? width]
[nonnegative-real? height]
[real? [radius -0.25]])
(modifying 'set-rounded-rectangle)
(let ([p (new dc-path%)])
(send p rounded-rectangle x y width height radius)
(set! paths (list (cons p 'any)))))
(define/private (check-compatible r who)
(unless (eq? dc (send r internal-get-dc))
(raise-mismatch-error (method-name 'region% who)
"different built-in dc for given region: "
r)))
(def/public (intersect [region% r])
(check-compatible r (lambda () (method-name 'region% 'union)))
(modifying 'intersect)
(set! paths (append paths (send r get-paths))))
(def/public (subtract [region% r])
(check-compatible r (lambda () (method-name 'region% 'subtract)))
(unless (null? paths)
(let ([add-paths (send r get-paths)])
(unless (null? add-paths)
(let ([p paths])
(do-union 'subtract r (lambda (p) (rev-paths p)))
(set! paths (append paths p)))))))
(def/public (union [region% r])
(do-union 'union r values))
(def/public (xor [region% r])
(do-union 'xor r (lambda (p) (rev-paths p))))
(define/private rev-paths
(lambda (paths)
(map (lambda (pr)
(let ([p (new dc-path%)])
(send p append (car pr))
(send p reverse)
(cons p (cdr pr))))
paths)))
(define/private (do-union who r adjust)
(check-compatible r who)
(modifying who)
(let ([add-paths (send r get-paths)])
(unless (null? add-paths)
(if (null? paths)
(set! paths add-paths)
(let ([add-paths (adjust add-paths)])
(let ([a (car paths)]
[b (car add-paths)])
(set! paths
(cons (let ([p (new dc-path%)])
(send p append (car a))
(send p append (car b))
(cons p (cond
[(or (eq? (cdr a) 'odd-even)
(eq? (cdr b) 'odd-even))
'odd-even]
[(or (eq? (cdr a) 'winding)
(eq? (cdr b) 'winding))
'winding]
[else 'any])))
(append (cdr paths)
(cdr add-paths))))))))))
(super-new)))

3
collects/racket/draw/syntax.rkt Normal file
View File

@ -0,0 +1,3 @@
#lang scheme/base
(require mred/private/syntax)
(provide (all-from-out mred/private/syntax))

22
collects/racket/draw/utils.rkt Normal file
View File

@ -0,0 +1,22 @@
#lang racket/base
(require ffi/unsafe)
(provide define-mz
define-enum
define/provide)
(define-syntax-rule (define-mz id type)
(define id (get-ffi-obj 'id #f type)))
(define-syntax define-enum
(syntax-rules ()
[(_ n) (begin)]
[(_ n id . ids) (begin
(define id n)
(provide id)
(define-enum (+ n 1) . ids))]))
(define-syntax-rule (define/provide id val)
(begin
(define id val)
(provide id)))

31
collects/racket/draw/xbm.rkt Normal file
View File

@ -0,0 +1,31 @@
#lang racket/base
(provide read-xbm)
(define rx:define #rx#"#define[ \t]+[A-Za-z0-9_]+[ \t]+([0-9]+)")
(define rx:byte #rx#"0x([0-9a-fA-F][0-9a-fA-F])")
(define (read-xbm in)
(let/ec esc
(let ([w (regexp-match rx:define in)]
[h (regexp-match rx:define in)])
(if (and w h)
(let ([w (string->number (bytes->string/latin-1 (cadr w)))]
[h (string->number (bytes->string/latin-1 (cadr h)))])
(if (and (exact-integer? w)
(exact-integer? h)
(positive? w)
(positive? h))
(values
w
h
(list->vector
(for/list ([i (in-range h)])
(list->bytes
(for/list ([j (in-range (quotient (+ w 7) 8))])
(let ([m (regexp-match rx:byte in)])
(if m
(string->number (bytes->string/latin-1 (cadr m)) 16)
(esc #f #f #f))))))))
(values #f #f #f)))
(values #f #f #f)))))