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

racket/draw: add get-handle' to bitmap%'; add `make-handle-brush'

Browse Source 
The `get-handle' method provides the underlying Cairo surface for
a bitmap, while the unsafe `make-handle-brush' function supports the
use of a Cairo surface as a `brush%'.

Also, add `racket/draw/unsafe/cairo-lib', which simplifies access
Cairo from external libraries. Documenting `racket/draw/unsafe/cairo'
might be better, but that's a lot more work.
This commit is contained in:
Matthew Flatt 2012-03-27 17:53:49 -06:00
parent 4735666cd9
commit 4f197f4ba9
14 changed files with 380 additions and 139 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/racket/draw/private/bitmap.rkt
View File

@ -623,6 +623,8 @@
alpha-s))
(get-empty-surface)))
(define/public (get-handle) s)
(def/public (get-argb-pixels [exact-nonnegative-integer? x]
[exact-nonnegative-integer? y]
[exact-nonnegative-integer? w]

64
collects/racket/draw/private/brush.rkt
View File

@ -1,6 +1,8 @@
#lang scheme/base
(require scheme/class
ffi/unsafe
ffi/unsafe/atomic
"../unsafe/cairo.rkt"
"color.rkt"
"syntax.rkt"
"local.rkt"
@ -21,7 +23,9 @@
(define black (send the-color-database find-color "black"))
(define-local-member-name s-set-key)
(define-local-member-name
s-set-key
set-surface-handle-info)
(defclass brush% object%
(define key #f)
@ -118,7 +122,63 @@
[(make-or-false transformation-vector?) [t #f]])
(check-immutable 'set-stipple)
(set! stipple s)
(set! transformation (and s t))))
(set! transformation (and s t)))
(define surface-handle #f)
(define/public (get-surface-handle-info) surface-handle) ; local
(def/public (get-handle) (and surface-handle
(vector-ref surface-handle 0)))
(define/public (set-surface-handle-info h t)
(set! surface-handle h)
(set! transformation t)))
;; unsafe (and so exported by `racket/draw/unsafe/brush'):
(provide (protect-out make-handle-brush))
(define (make-handle-brush handle width height [t #f]
#:copy? [copy? #t])
;; for argument checking:
(define/top (make-handle-brush [cpointer? handle]
[exact-nonnegative-integer? width]
[exact-nonnegative-integer? height]
[(make-or-false transformation-vector?) t])
'ok)
(make-handle-brush handle width height t)
;; arguments are ok, so proceed:
(define s-in (cast handle _pointer _cairo_surface_t))
(define s
(if copy?
(let ()
(define s (cairo_surface_create_similar s-in CAIRO_CONTENT_COLOR_ALPHA width height))
(define cr (cairo_create s))
(let* ([p (cairo_pattern_create_for_surface s-in)])
(cairo_set_source cr p)
(cairo_pattern_destroy p)
(cairo_rectangle cr 0 0 width height)
(cairo_fill cr)
(cairo_destroy cr))
s)
s-in))
(define b (new brush%))
(send b set-surface-handle-info (vector s width height #f) t)
b)
(provide (protect-out surface-handle-info->bitmap))
(define (surface-handle-info->bitmap hi)
(or (vector-ref hi 3)
(let ()
(define width (vector-ref hi 1))
(define height (vector-ref hi 2))
(define bm (make-bitmap width height))
(define s (send bm get-cairo-surface))
(define cr (cairo_create s))
(let* ([p (cairo_pattern_create_for_surface (vector-ref hi 0))])
(cairo_set_source cr p)
(cairo_pattern_destroy p)
(cairo_rectangle cr 0 0 width height)
(cairo_fill cr)
(cairo_destroy cr))
(vector-set! hi 3 bm)
bm)))
;; ----------------------------------------

177
collects/racket/draw/private/dc.rkt
View File

@ -823,13 +823,15 @@
(send st get-width) (send st get-height)
0 0 mode col alpha #f)
get-cairo-surface))])])
(let* ([p (cairo_pattern_create_for_surface s)])
(cairo_pattern_set_extend p CAIRO_EXTEND_REPEAT)
(install-transformation transformation cr)
(cairo_set_source cr p)
(when transformation
(do-reset-matrix cr))
(cairo_pattern_destroy p))))
(install-surface s transformation)))
(define (install-surface s transformation)
(let* ([p (cairo_pattern_create_for_surface s)])
(cairo_pattern_set_extend p CAIRO_EXTEND_REPEAT)
(install-transformation transformation cr)
(cairo_set_source cr p)
(when transformation
(do-reset-matrix cr))
(cairo_pattern_destroy p)))
(cairo_set_antialias cr (case (dc-adjust-smoothing smoothing)
[(unsmoothed) CAIRO_ANTIALIAS_NONE]
[else CAIRO_ANTIALIAS_GRAY]))
@ -838,85 +840,100 @@
(unless (eq? 'transparent s)
(let ([st (send brush get-stipple)]
[col (send brush get-color)]
[gradient (send brush get-gradient)])
(if (and gradient
(not (collapse-bitmap-b&w?)))
(make-gradient-pattern cr gradient (send brush get-transformation))
(if st
(install-stipple st col s
(send brush get-transformation)
(lambda () brush-stipple-s)
(lambda (v) (set! brush-stipple-s v) v))
(let ([horiz (lambda (cr2)
(cairo_move_to cr2 0 3.5)
(cairo_line_to cr2 12 3.5)
(cairo_move_to cr2 0 7.5)
(cairo_line_to cr2 12 7.5)
(cairo_move_to cr2 0 11.5)
(cairo_line_to cr2 12 11.5))]
[vert (lambda (cr2)
(cairo_move_to cr2 3.5 0)
(cairo_line_to cr2 3.5 12)
(cairo_move_to cr2 7.5 0)
(cairo_line_to cr2 7.5 12)
(cairo_move_to cr2 11.5 0)
(cairo_line_to cr2 11.5 12))]
[bdiag (lambda (cr2)
(for ([i (in-range -2 3)])
(let ([y (* i 6)])
(cairo_move_to cr2 -1 (+ -1 y))
(cairo_line_to cr2 13 (+ 13 y)))))]
[fdiag (lambda (cr2)
(for ([i (in-range -2 3)])
(let ([y (* i 6)])
(cairo_move_to cr2 13 (+ -1 y))
(cairo_line_to cr2 -1 (+ 13 y)))))])
(case s
[(horizontal-hatch)
(make-pattern-surface
cr col
horiz)]
[(vertical-hatch)
(make-pattern-surface
cr col
vert)]
[(cross-hatch)
(make-pattern-surface
cr col
(lambda (cr) (horiz cr) (vert cr)))]
[(bdiagonal-hatch)
(make-pattern-surface
cr col
bdiag)]
[(fdiagonal-hatch)
(make-pattern-surface
cr col
fdiag)]
[(crossdiag-hatch)
(make-pattern-surface
cr col
(lambda (cr) (bdiag cr) (fdiag cr)))]
[else
(install-color cr
(if (eq? s 'hilite) hilite-color col)
alpha
#f)])))))
[gradient (send brush get-gradient)]
[handle-info (send brush get-surface-handle-info)])
(cond
[handle-info
(if (collapse-bitmap-b&w?)
;; convert surface to a stipple:
(install-stipple (surface-handle-info->bitmap handle-info) col s
(send brush get-transformation)
(lambda () brush-stipple-s)
(lambda (v) (set! brush-stipple-s v) v))
;; normal use of surface:
(install-surface (vector-ref handle-info 0)
(send brush get-transformation)))]
[(and gradient
(not (collapse-bitmap-b&w?)))
(make-gradient-pattern cr gradient (send brush get-transformation))]
[st
(install-stipple st col s
(send brush get-transformation)
(lambda () brush-stipple-s)
(lambda (v) (set! brush-stipple-s v) v))]
[else
(let ([horiz (lambda (cr2)
(cairo_move_to cr2 0 3.5)
(cairo_line_to cr2 12 3.5)
(cairo_move_to cr2 0 7.5)
(cairo_line_to cr2 12 7.5)
(cairo_move_to cr2 0 11.5)
(cairo_line_to cr2 12 11.5))]
[vert (lambda (cr2)
(cairo_move_to cr2 3.5 0)
(cairo_line_to cr2 3.5 12)
(cairo_move_to cr2 7.5 0)
(cairo_line_to cr2 7.5 12)
(cairo_move_to cr2 11.5 0)
(cairo_line_to cr2 11.5 12))]
[bdiag (lambda (cr2)
(for ([i (in-range -2 3)])
(let ([y (* i 6)])
(cairo_move_to cr2 -1 (+ -1 y))
(cairo_line_to cr2 13 (+ 13 y)))))]
[fdiag (lambda (cr2)
(for ([i (in-range -2 3)])
(let ([y (* i 6)])
(cairo_move_to cr2 13 (+ -1 y))
(cairo_line_to cr2 -1 (+ 13 y)))))])
(case s
[(horizontal-hatch)
(make-pattern-surface
cr col
horiz)]
[(vertical-hatch)
(make-pattern-surface
cr col
vert)]
[(cross-hatch)
(make-pattern-surface
cr col
(lambda (cr) (horiz cr) (vert cr)))]
[(bdiagonal-hatch)
(make-pattern-surface
cr col
bdiag)]
[(fdiagonal-hatch)
(make-pattern-surface
cr col
fdiag)]
[(crossdiag-hatch)
(make-pattern-surface
cr col
(lambda (cr) (bdiag cr) (fdiag cr)))]
[else
(install-color cr
(if (eq? s 'hilite) hilite-color col)
alpha
#f)]))]))
(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
#f
(lambda () pen-stipple-s)
(lambda (v) (set! pen-stipple-s v) v))
(install-color cr
(if (eq? s 'hilite) hilite-color col)
alpha
#f)))
(cond
[st
(install-stipple st col s
#f
(lambda () pen-stipple-s)
(lambda (v) (set! pen-stipple-s v) v))]
[else
(install-color cr
(if (eq? s 'hilite) hilite-color col)
alpha
#f)]))
(cairo_set_line_width cr (let* ([v (send pen get-width)]
[align? (aligned? smoothing)]
[v (if align?

5
collects/racket/draw/private/local.rkt
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require scheme/class)
(provide (all-defined-out))
(provide (protect-out (all-defined-out)))
(define-local-member-name
;; various
@ -34,6 +34,9 @@
get-ps-pango
get-font-key
;; brush%
get-surface-handle-info
;; dc-backend<%>
get-cr
release-cr

72
collects/racket/draw/private/record-dc.rkt
View File

@ -104,34 +104,54 @@
(send the-pen-list find-or-create-pen color width style cap join)))
(define (clone-brush b)
(let ([s (send b get-stipple)])
(if s
(let ([b (make-object brush%
(send b get-color)
(send b get-style))]
[t (send b get-transformation)])
(send b set-stipple (clone-bitmap s) t)
b)
(let ([g (send b get-gradient)])
(if g
(make-object brush%
(send b get-color)
(send b get-style)
#f
g
(send b get-transformation))
(send the-brush-list find-or-create-brush
(send b get-color)
(send b get-style)))))))
(cond
[(send b get-surface-handle-info)
=> (lambda (hi)
(make-handle-brush (vector-ref hi 0) #:copy? #f
(vector-ref hi 1)
(vector-ref hi 2)
(send b get-transformation)))]
[(send b get-stipple)
=> (lambda (s)
(let ([b (make-object brush%
(send b get-color)
(send b get-style))]
[t (send b get-transformation)])
(send b set-stipple (clone-bitmap s) t)
b))]
[(send b get-gradient)
=> (lambda (g)
(make-object brush%
(send b get-color)
(send b get-style)
#f
g
(send b get-transformation)))]
[else
(send the-brush-list find-or-create-brush
(send b get-color)
(send b get-style))]))
(define (convert-brush b)
(let ([s (send b get-stipple)]
[g (send b get-gradient)])
(list (convert-color (send b get-color))
(send b get-style)
(and s (convert-bitmap s))
(and g (convert-gradient g))
(send b get-transformation))))
(cond
[(send b get-surface-handle-info)
=> (lambda (hi)
;; Flatten the surface into a bitmap:
(define bm (surface-handle-info->bitmap hi))
(let ([b (make-object brush%
(send b get-color)
(send b get-style))]
[t (send b get-transformation)])
(send b set-stipple bm t)
(convert-brush b)))]
[else
(let ([s (send b get-stipple)]
[g (send b get-gradient)])
(list (convert-color (send b get-color))
(send b get-style)
(and s (convert-bitmap s))
(and g (convert-gradient g))
(send b get-transformation)))]))
(define (unconvert-brush l)
(define-values (c style stipple gradient transformation)

5
collects/racket/draw/unsafe/brush.rkt Normal file
View File

@ -0,0 +1,5 @@
#lang racket/base
(require "../private/brush.rkt")
(provide make-handle-brush)

31
collects/racket/draw/unsafe/cairo-lib.rkt Normal file
View File

@ -0,0 +1,31 @@
#lang scheme/base
(require ffi/unsafe
ffi/unsafe/define
ffi/unsafe/alloc
"../private/libs.rkt"
"../private/utils.rkt")
(define-runtime-lib cairo-lib
[(unix) (ffi-lib "libcairo" '("2" ""))]
[(macosx)
(ffi-lib "libpixman-1.0.dylib")
(ffi-lib "libpng15.15.dylib")
(ffi-lib "libcairo.2.dylib")]
[(win32)
(ffi-lib "zlib1.dll")
(ffi-lib "libpng14-14.dll")
(ffi-lib "libexpat-1.dll")
(ffi-lib "freetype6.dll")
(ffi-lib "libfontconfig-1.dll")
(ffi-lib "libcairo-2.dll")]
[(win64)
(ffi-lib "zlib1.dll")
(ffi-lib "libintl-8.dll")
(ffi-lib "libpng14-14.dll")
(ffi-lib "libexpat-1.dll")
(ffi-lib "libfreetype-6.dll")
(ffi-lib "libfontconfig-1.dll")
(ffi-lib "libcairo-2.dll")])
(provide (protect-out cairo-lib))

24
collects/racket/draw/unsafe/cairo.rkt
View File

@ -2,35 +2,15 @@
(require ffi/unsafe
ffi/unsafe/define
ffi/unsafe/alloc
"cairo-lib.rkt"
"../private/libs.rkt"
"../private/utils.rkt")
(define-runtime-lib cairo-lib
[(unix) (ffi-lib "libcairo" '("2" ""))]
[(macosx)
(ffi-lib "libpixman-1.0.dylib")
(ffi-lib "libpng15.15.dylib")
(ffi-lib "libcairo.2.dylib")]
[(win32)
(ffi-lib "zlib1.dll")
(ffi-lib "libpng14-14.dll")
(ffi-lib "libexpat-1.dll")
(ffi-lib "freetype6.dll")
(ffi-lib "libfontconfig-1.dll")
(ffi-lib "libcairo-2.dll")]
[(win64)
(ffi-lib "zlib1.dll")
(ffi-lib "libintl-8.dll")
(ffi-lib "libpng14-14.dll")
(ffi-lib "libexpat-1.dll")
(ffi-lib "libfreetype-6.dll")
(ffi-lib "libfontconfig-1.dll")
(ffi-lib "libcairo-2.dll")])
(define-ffi-definer define-cairo cairo-lib
#:provide provide-protected)
(provide _cairo_t
_cairo_surface_t
_cairo_font_options_t)
(define _cairo_surface_t (_cpointer 'cairo_surface_t))

12
collects/scribblings/draw/bitmap-class.scrbl
View File

@ -1,5 +1,6 @@
#lang scribble/doc
@(require "common.rkt")
@(require "common.rkt"
(for-label (only-in ffi/unsafe cpointer?)))
@defclass/title[bitmap% object% ()]{
@ -84,6 +85,15 @@ monochrome bitmap and @racket[32] for a color bitmap. See also
}
@defmethod[(get-handle) cpointer?]{
Returns a low-level handle to the bitmap content. Currently, on all
platforms, a handle is a @tt{cairo_surface_t}. For a bitmap created
with @racket[make-bitmap], the handle is specifically a Cairo
image surface.}
@defmethod[(get-height)
exact-positive-integer?]{

23
collects/scribblings/draw/brush-class.scrbl
View File

@ -1,5 +1,8 @@
#lang scribble/doc
@(require "common.rkt" scribble/eval)
@(require "common.rkt"
scribble/eval
(for-label racket/draw/unsafe/brush
(only-in ffi/unsafe cpointer?)))
@(define class-eval (make-base-eval))
@(interaction-eval #:eval class-eval (require racket/class racket/draw))
@ -118,12 +121,6 @@ Returns the brush's color.
}
@defmethod[(get-stipple)
(or/c (is-a?/c bitmap%) #f)]{
Gets the @tech{brush stipple} bitmap, or @racket[#f] if the brush has no stipple.}
@defmethod[(get-gradient)
(or/c (is-a?/c linear-gradient%)
(is-a?/c radial-gradient%)
@ -132,6 +129,18 @@ Gets the @tech{brush stipple} bitmap, or @racket[#f] if the brush has no stipple
Gets the @tech{gradient}, or @racket[#f] if the brush has no gradient.}
@defmethod[(get-handle) (or/c cpointer? #f)]{
Returns a low-level handle for the brush content, but only for brushes
created with @racket[make-handle-brush]; otherwise, the result is @racket[#f].}
@defmethod[(get-stipple)
(or/c (is-a?/c bitmap%) #f)]{
Gets the @tech{brush stipple} bitmap, or @racket[#f] if the brush has no stipple.}
@defmethod[(get-style)
(one-of/c 'transparent 'solid 'opaque
'xor 'hilite 'panel

1
collects/scribblings/draw/draw.scrbl
View File

@ -42,6 +42,7 @@ interface, and procedure bindings defined in this manual.}
@include-section["svg-dc-class.scrbl"]
@include-section["draw-funcs.scrbl"]
@include-section["draw-unit.scrbl"]
@include-section["unsafe.scrbl"]
@include-section["libs.scrbl"]
@;------------------------------------------------------------------------

60
collects/scribblings/draw/unsafe.scrbl Normal file
View File

@ -0,0 +1,60 @@
#lang scribble/doc
@(require "common.rkt"
(for-label (except-in ffi/unsafe ->)
racket/draw/unsafe/brush
racket/draw/unsafe/cairo-lib))
@title[#:tag "unsafe"]{Unsafe Libraries}
The @racketmodname[racket/draw] library is currently implemented using Cairo
and Pango. The @xmethod[bitmap% get-handle] method exposes the
underlying Cairo surface for a @racket[bitmap%] object, while
@racket[make-handle-brush] supports the creation of a brush from an
existing Cairo surface. The representation of handles for these
methods, however, is subject to change if the @racketmodname[racket/draw]
library is implemented differently in the future.
@section{Handle Brushes}
@defmodule[racket/draw/unsafe/brush]
@defproc[(make-handle-brush [handle cpointer?]
[width exact-nonnegative-integer?]
[height exact-nonnegative-integer?]
[transformation (or/c #f (vector/c (vector/c real? real? real?
real? real? real?)
real? real? real? real? real?))]
[#:copy? copy? any/c #t])
(is-a?/c brush%)]{
Creates a brush given a @racket[handle] that (currently) is a
@tt{cairo_surface_t}. If @racket[copy?] is true, then the surface is
copied, so that it can be freed or modified after the brush is
created; if @racket[copy?] is @racket[#f], the surface must remain available
and unchanged as long as the brush can be used.
The @racket[width] and @racket[height] arguments specify the surface
bounds for use when the surface must be copied---even when
@racket[copy?] is @racket[#f]. The surface may need to be converted to a
stipple bitmap, for example, when drawing to a monochrome target.
The given surface is treated much like a stipple bitmap: it is
implicitly repeated, and the given @racket[transformation] (if any)
determines the surface's alignment relative to the target drawing
context.
When the brush is used with a @racket[record-dc%] object, and if that
object's @method[record-dc% get-recorded-datum] method is called, then the
surface is effectively converted to a stipple bitmap for the result datum.}
@section{Cairo Library}
@defmodule[racket/draw/unsafe/cairo-lib]
@defthing[cairo-lib (or/c ffi-lib? #f)]{
A reference to the Cairo library for use with functions such as
@racket[get-ffi-obj], or @racket[#f] if Cairo is unavailable.}

7
collects/tests/gracket/draw.rkt
View File

@ -1,4 +1,5 @@
#lang scheme/gui
(require "unsafe-draw.rkt")
(define manual-chinese? #f)
@ -971,6 +972,12 @@
(send dc draw-rectangle 300 320 80 20)
(send dc set-pen p))
(let ([p (send dc get-pen)])
(send dc set-pen "black" 1 'solid)
(send dc set-brush surface-brush)
(send dc draw-rectangle 400 320 30 40)
(send dc set-pen p))
(let ([p (send dc get-pen)])
(send dc set-pen "white" 1 'transparent)
(send dc set-brush (new brush%

36
collects/tests/gracket/unsafe-draw.rkt Normal file
View File

@ -0,0 +1,36 @@
#lang racket/base
(require ffi/unsafe
racket/draw/unsafe/cairo-lib
racket/draw/unsafe/brush)
(provide surface-brush)
(define cairo_image_surface_create
(get-ffi-obj 'cairo_image_surface_create cairo-lib (_fun _int _int _int -> _pointer)))
(define cairo_surface_destroy
(get-ffi-obj 'cairo_surface_destroy cairo-lib (_fun _pointer -> _void)))
(define cairo_create
(get-ffi-obj 'cairo_create cairo-lib (_fun _pointer -> _pointer)))
(define cairo_destroy
(get-ffi-obj 'cairo_destroy cairo-lib (_fun _pointer -> _void)))
(define cairo_set_source_rgba
(get-ffi-obj 'cairo_set_source_rgba cairo-lib (_fun _pointer _double* _double* _double* _double* -> _void)))
(define cairo_rectangle
(get-ffi-obj 'cairo_rectangle cairo-lib (_fun _pointer _double* _double* _double* _double* -> _void)))
(define cairo_fill
(get-ffi-obj 'cairo_fill cairo-lib (_fun _pointer -> _void)))
(define s (cairo_image_surface_create 0 20 30))
(define cr (cairo_create s))
(cairo_set_source_rgba cr 1.0 0.0 0.0 0.5)
(cairo_rectangle cr 2 2 16 26)
(cairo_fill cr)
(cairo_set_source_rgba cr 0.0 0.0 0.0 1.0)
(cairo_rectangle cr 9 9 2 2)
(cairo_fill cr)
(cairo_destroy cr)
(define surface-brush (make-handle-brush s 20 30 '#(#(1 0 0 1 420 320) 0 0 1 1 0)))
(cairo_surface_destroy s)