From 6829e96dedd5aed6223bc8d6c06fb5841699d368 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 31 May 2010 15:20:43 -0600 Subject: [PATCH] gracket2 racket/draw --- collects/racket/draw.rkt | 30 + collects/racket/draw/bitmap-dc.rkt | 94 +++ collects/racket/draw/bitmap.rkt | 669 ++++++++++++++++++ collects/racket/draw/brush.rkt | 114 +++ collects/racket/draw/bstr.rkt | 9 + collects/racket/draw/cairo.rkt | 248 +++++++ collects/racket/draw/color.rkt | 277 ++++++++ collects/racket/draw/dc-intf.rkt | 9 + collects/racket/draw/dc-path.rkt | 364 ++++++++++ collects/racket/draw/dc.rkt | 879 ++++++++++++++++++++++++ collects/racket/draw/define.rkt | 81 +++ collects/racket/draw/fmod.rkt | 7 + collects/racket/draw/font-dir.rkt | 97 +++ collects/racket/draw/font-syms.rkt | 14 + collects/racket/draw/font.rkt | 198 ++++++ collects/racket/draw/hold.rkt | 14 + collects/racket/draw/jpeg.rkt | 657 ++++++++++++++++++ collects/racket/draw/local.rkt | 35 + collects/racket/draw/lock.rkt | 120 ++++ collects/racket/draw/pango.rkt | 147 ++++ collects/racket/draw/pen.rkt | 134 ++++ collects/racket/draw/png.rkt | 343 +++++++++ collects/racket/draw/point.rkt | 22 + collects/racket/draw/post-script-dc.rkt | 74 ++ collects/racket/draw/ps-setup.rkt | 77 +++ collects/racket/draw/region.rkt | 252 +++++++ collects/racket/draw/syntax.rkt | 3 + collects/racket/draw/utils.rkt | 22 + collects/racket/draw/xbm.rkt | 31 + 29 files changed, 5021 insertions(+) create mode 100644 collects/racket/draw.rkt create mode 100644 collects/racket/draw/bitmap-dc.rkt create mode 100644 collects/racket/draw/bitmap.rkt create mode 100644 collects/racket/draw/brush.rkt create mode 100644 collects/racket/draw/bstr.rkt create mode 100644 collects/racket/draw/cairo.rkt create mode 100644 collects/racket/draw/color.rkt create mode 100644 collects/racket/draw/dc-intf.rkt create mode 100644 collects/racket/draw/dc-path.rkt create mode 100644 collects/racket/draw/dc.rkt create mode 100644 collects/racket/draw/define.rkt create mode 100644 collects/racket/draw/fmod.rkt create mode 100644 collects/racket/draw/font-dir.rkt create mode 100644 collects/racket/draw/font-syms.rkt create mode 100644 collects/racket/draw/font.rkt create mode 100644 collects/racket/draw/hold.rkt create mode 100644 collects/racket/draw/jpeg.rkt create mode 100644 collects/racket/draw/local.rkt create mode 100644 collects/racket/draw/lock.rkt create mode 100644 collects/racket/draw/pango.rkt create mode 100644 collects/racket/draw/pen.rkt create mode 100644 collects/racket/draw/png.rkt create mode 100644 collects/racket/draw/point.rkt create mode 100644 collects/racket/draw/post-script-dc.rkt create mode 100644 collects/racket/draw/ps-setup.rkt create mode 100644 collects/racket/draw/region.rkt create mode 100644 collects/racket/draw/syntax.rkt create mode 100644 collects/racket/draw/utils.rkt create mode 100644 collects/racket/draw/xbm.rkt diff --git a/collects/racket/draw.rkt b/collects/racket/draw.rkt new file mode 100644 index 0000000000..89fa58e3fe --- /dev/null +++ b/collects/racket/draw.rkt @@ -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) diff --git a/collects/racket/draw/bitmap-dc.rkt b/collects/racket/draw/bitmap-dc.rkt new file mode 100644 index 0000000000..f024268f8c --- /dev/null +++ b/collects/racket/draw/bitmap-dc.rkt @@ -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%) diff --git a/collects/racket/draw/bitmap.rkt b/collects/racket/draw/bitmap.rkt new file mode 100644 index 0000000000..9e160e2e82 --- /dev/null +++ b/collects/racket/draw/bitmap.rkt @@ -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)))) + + )) diff --git a/collects/racket/draw/brush.rkt b/collects/racket/draw/brush.rkt new file mode 100644 index 0000000000..d37775b201 --- /dev/null +++ b/collects/racket/draw/brush.rkt @@ -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%)) + + diff --git a/collects/racket/draw/bstr.rkt b/collects/racket/draw/bstr.rkt new file mode 100644 index 0000000000..3db7de6d5f --- /dev/null +++ b/collects/racket/draw/bstr.rkt @@ -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))) + diff --git a/collects/racket/draw/cairo.rkt b/collects/racket/draw/cairo.rkt new file mode 100644 index 0000000000..52a2170738 --- /dev/null +++ b/collects/racket/draw/cairo.rkt @@ -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) + diff --git a/collects/racket/draw/color.rkt b/collects/racket/draw/color.rkt new file mode 100644 index 0000000000..25a56c4d3a --- /dev/null +++ b/collects/racket/draw/color.rkt @@ -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)))) diff --git a/collects/racket/draw/dc-intf.rkt b/collects/racket/draw/dc-intf.rkt new file mode 100644 index 0000000000..d0f9801192 --- /dev/null +++ b/collects/racket/draw/dc-intf.rkt @@ -0,0 +1,9 @@ +#lang scheme/base +(require scheme/class + "font.ss") + +(provide dc<%>) + +(define dc<%> + (interface () + draw-text)) diff --git a/collects/racket/draw/dc-path.rkt b/collects/racket/draw/dc-path.rkt new file mode 100644 index 0000000000..c5c69df11a --- /dev/null +++ b/collects/racket/draw/dc-path.rkt @@ -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))) \ No newline at end of file diff --git a/collects/racket/draw/dc.rkt b/collects/racket/draw/dc.rkt new file mode 100644 index 0000000000..7bbfcebbf8 --- /dev/null +++ b/collects/racket/draw/dc.rkt @@ -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%) \ No newline at end of file diff --git a/collects/racket/draw/define.rkt b/collects/racket/draw/define.rkt new file mode 100644 index 0000000000..19c12b72ed --- /dev/null +++ b/collects/racket/draw/define.rkt @@ -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)])))))])) diff --git a/collects/racket/draw/fmod.rkt b/collects/racket/draw/fmod.rkt new file mode 100644 index 0000000000..27418a6cd0 --- /dev/null +++ b/collects/racket/draw/fmod.rkt @@ -0,0 +1,7 @@ +#lang scheme/base +(require scheme/foreign) +(unsafe!) + +(provide fmod) + +(define fmod (get-ffi-obj 'fmod #f (_fun _double _double -> _double))) diff --git a/collects/racket/draw/font-dir.rkt b/collects/racket/draw/font-dir.rkt new file mode 100644 index 0000000000..11df1891ed --- /dev/null +++ b/collects/racket/draw/font-dir.rkt @@ -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%)) diff --git a/collects/racket/draw/font-syms.rkt b/collects/racket/draw/font-syms.rkt new file mode 100644 index 0000000000..18f7576dc7 --- /dev/null +++ b/collects/racket/draw/font-syms.rkt @@ -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))) + diff --git a/collects/racket/draw/font.rkt b/collects/racket/draw/font.rkt new file mode 100644 index 0000000000..55d420042d --- /dev/null +++ b/collects/racket/draw/font.rkt @@ -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)))) diff --git a/collects/racket/draw/hold.rkt b/collects/racket/draw/hold.rkt new file mode 100644 index 0000000000..4904af6548 --- /dev/null +++ b/collects/racket/draw/hold.rkt @@ -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) + diff --git a/collects/racket/draw/jpeg.rkt b/collects/racket/draw/jpeg.rkt new file mode 100644 index 0000000000..4fc5bdbd16 --- /dev/null +++ b/collects/racket/draw/jpeg.rkt @@ -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) diff --git a/collects/racket/draw/local.rkt b/collects/racket/draw/local.rkt new file mode 100644 index 0000000000..d8b7df9e3a --- /dev/null +++ b/collects/racket/draw/local.rkt @@ -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) diff --git a/collects/racket/draw/lock.rkt b/collects/racket/draw/lock.rkt new file mode 100644 index 0000000000..1a03c80906 --- /dev/null +++ b/collects/racket/draw/lock.rkt @@ -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 ...))] + ...))]))) diff --git a/collects/racket/draw/pango.rkt b/collects/racket/draw/pango.rkt new file mode 100644 index 0000000000..d09160ac15 --- /dev/null +++ b/collects/racket/draw/pango.rkt @@ -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) diff --git a/collects/racket/draw/pen.rkt b/collects/racket/draw/pen.rkt new file mode 100644 index 0000000000..6da12292cc --- /dev/null +++ b/collects/racket/draw/pen.rkt @@ -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%)) + + diff --git a/collects/racket/draw/png.rkt b/collects/racket/draw/png.rkt new file mode 100644 index 0000000000..4f309f27c4 --- /dev/null +++ b/collects/racket/draw/png.rkt @@ -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))) diff --git a/collects/racket/draw/point.rkt b/collects/racket/draw/point.rkt new file mode 100644 index 0000000000..3e84b28559 --- /dev/null +++ b/collects/racket/draw/point.rkt @@ -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))) + diff --git a/collects/racket/draw/post-script-dc.rkt b/collects/racket/draw/post-script-dc.rkt new file mode 100644 index 0000000000..4856660d85 --- /dev/null +++ b/collects/racket/draw/post-script-dc.rkt @@ -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%)) diff --git a/collects/racket/draw/ps-setup.rkt b/collects/racket/draw/ps-setup.rkt new file mode 100644 index 0000000000..5b1b65e9ae --- /dev/null +++ b/collects/racket/draw/ps-setup.rkt @@ -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%))) diff --git a/collects/racket/draw/region.rkt b/collects/racket/draw/region.rkt new file mode 100644 index 0000000000..03a3b38b5c --- /dev/null +++ b/collects/racket/draw/region.rkt @@ -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 ), + ;; where 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))) diff --git a/collects/racket/draw/syntax.rkt b/collects/racket/draw/syntax.rkt new file mode 100644 index 0000000000..8f2b287dfc --- /dev/null +++ b/collects/racket/draw/syntax.rkt @@ -0,0 +1,3 @@ +#lang scheme/base +(require mred/private/syntax) +(provide (all-from-out mred/private/syntax)) diff --git a/collects/racket/draw/utils.rkt b/collects/racket/draw/utils.rkt new file mode 100644 index 0000000000..c87ca65c0a --- /dev/null +++ b/collects/racket/draw/utils.rkt @@ -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))) diff --git a/collects/racket/draw/xbm.rkt b/collects/racket/draw/xbm.rkt new file mode 100644 index 0000000000..cc8b22d978 --- /dev/null +++ b/collects/racket/draw/xbm.rkt @@ -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)))))