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

add make-platform-bitmap

Browse Source 
also: use it in pict's rendering and
remove redex's platform-specific font choice
(going back to using 'modern on all platforms)

closes PR 12554
This commit is contained in:
Robby Findler 2012-02-15 21:20:02 -06:00
parent c007c345f9
commit 1945ff2709
18 changed files with 200 additions and 133 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
collects/mred/private/wx/cocoa/bitmap.rkt
View File

@ -1,53 +0,0 @@
#lang racket/base
(require racket/class
ffi/unsafe
ffi/unsafe/objc
racket/draw/unsafe/cairo
racket/draw/private/bitmap
racket/draw/private/local
"types.rkt"
"utils.rkt"
"../../lock.rkt"
"cg.rkt")
(provide quartz-bitmap%)
(define quartz-bitmap%
(class bitmap%
(init w h [with-alpha? #t])
(super-make-object (make-alternate-bitmap-kind w h))
(define s
(let ([s (cairo_quartz_surface_create (if with-alpha?
CAIRO_FORMAT_ARGB32
CAIRO_FORMAT_RGB24)
w
h)])
;; initialize bitmap to empty - needed?
(let ([cr (cairo_create s)])
(cairo_set_operator cr (if with-alpha?
CAIRO_OPERATOR_CLEAR
CAIRO_OPERATOR_SOURCE))
(cairo_set_source_rgba cr 1.0 1.0 1.0 1.0)
(cairo_paint cr)
(cairo_destroy cr))
s))
(define/override (ok?) (and s #t))
(define/override (is-color?) #t)
(define has-alpha? with-alpha?)
(define/override (has-alpha-channel?) has-alpha?)
(define/override (get-cairo-surface) s)
(define/override (get-cairo-alpha-surface)
(if has-alpha?
s
(super get-cairo-alpha-surface)))
(define/override (release-bitmap-storage)
(atomically
(when s
(cairo_surface_destroy s)
(set! s #f))))))

2
collects/mred/private/wx/cocoa/canvas.rkt
View File

@ -5,13 +5,13 @@
racket/draw
racket/draw/private/gl-context
racket/draw/private/color
racket/draw/private/bitmap
"pool.rkt"
"utils.rkt"
"const.rkt"
"types.rkt"
"window.rkt"
"dc.rkt"
"bitmap.rkt"
"cg.rkt"
"queue.rkt"
"item.rkt"

1
collects/mred/private/wx/cocoa/dc.rkt
View File

@ -8,7 +8,6 @@
racket/draw/private/gl-context
"types.rkt"
"utils.rkt"
"bitmap.rkt"
"window.rkt"
"../../lock.rkt"
"../common/queue.rkt"

2
collects/mred/private/wx/cocoa/image.rkt
View File

@ -5,11 +5,11 @@
racket/draw/unsafe/cairo
racket/draw/private/local
racket/draw/unsafe/bstr
racket/draw/private/bitmap
"utils.rkt"
"types.rkt"
"const.rkt"
"cg.rkt"
"bitmap.rkt"
"../../lock.rkt"
(only-in '#%foreign ffi-callback))

1
collects/mred/private/wx/cocoa/printer-dc.rkt
View File

@ -13,7 +13,6 @@
"../../lock.rkt"
"dc.rkt"
"frame.rkt"
"bitmap.rkt"
"cg.rkt"
"utils.rkt"
"types.rkt")

2
collects/mred/private/wx/cocoa/procs.rkt
View File

@ -2,6 +2,7 @@
(require "../../syntax.rkt"
racket/class
racket/draw
racket/draw/private/bitmap
ffi/unsafe
ffi/unsafe/objc
"utils.rkt"
@ -12,7 +13,6 @@
"filedialog.rkt"
"colordialog.rkt"
"dc.rkt"
"bitmap.rkt"
"printer-dc.rkt"
"menu-bar.rkt"
"agl.rkt"

53
collects/mred/private/wx/win32/dc.rkt
View File

@ -23,46 +23,33 @@
(define-gdi32 SelectClipRgn (_wfun _pointer _pointer -> _int))
(define win32-bitmap%
(class bitmap%
(init w h hwnd [gl-config #f])
(super-make-object (make-alternate-bitmap-kind w h))
(define hwnd-param (make-parameter #f))
(define s
(let ([s
(if (not hwnd)
(cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h)
(atomically
(let ([hdc (GetDC hwnd)])
(begin0
(cairo_win32_surface_create_with_ddb hdc
CAIRO_FORMAT_RGB24 w h)
(ReleaseDC hwnd hdc)))))])
;; initialize bitmap to white:
(let ([cr (cairo_create s)])
(cairo_set_source_rgba cr 1.0 1.0 1.0 1.0)
(cairo_paint cr)
(cairo_destroy cr))
s))
(define win32-bitmap%
(class win32-no-hwnd-bitmap%
(init w h hwnd [gl-config #f])
(inherit get-cairo-surface)
(parameterize ([hwnd-param hwnd])
(super-new [w w] [h h]))
(define/override (build-cairo-surface w h)
(define hwnd (hwnd-param))
(if hwnd
(atomically
(let ([hdc (GetDC hwnd)])
(begin0
(cairo_win32_surface_create_with_ddb hdc
CAIRO_FORMAT_RGB24 w h)
(ReleaseDC hwnd hdc))))
(super build-cairo-surface)))
(define gl (and gl-config
(let ([hdc (cairo_win32_surface_get_dc s)])
(let ([hdc (cairo_win32_surface_get_dc (get-cairo-surface))])
(set-cpointer-tag! hdc 'HDC)
(create-gl-context hdc
gl-config
#t))))
(define/override (get-bitmap-gl-context) gl)
(define/override (ok?) #t)
(define/override (is-color?) #t)
(define/override (has-alpha-channel?) #f)
(define/override (get-cairo-surface) s)
(define/override (release-bitmap-storage)
(atomically
(cairo_surface_destroy s)
(set! s #f)))))
(define/override (get-bitmap-gl-context) gl)))
(define dc%
(class backing-dc%

1
collects/racket/draw.rkt
View File

@ -41,5 +41,6 @@
bitmap%
make-bitmap
make-platform-bitmap
read-bitmap
make-monochrome-bitmap)

1
collects/racket/draw/draw-sig.rkt
View File

@ -18,6 +18,7 @@ gl-config%
gl-context<%>
linear-gradient%
make-bitmap
make-platform-bitmap
make-monochrome-bitmap
pdf-dc%
pen%

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

@ -14,13 +14,18 @@
"../bmp.rkt"
"../gif.rkt"
"local.rkt"
"color.rkt")
"color.rkt"
"lock.rkt")
(provide bitmap%
make-bitmap
make-platform-bitmap
read-bitmap
make-monochrome-bitmap
(protect-out make-alternate-bitmap-kind))
(protect-out make-alternate-bitmap-kind
build-cairo-surface
quartz-bitmap%
win32-no-hwnd-bitmap%))
;; FIXME: there must be some way to abstract over all many of the
;; ARGB/RGBA/BGRA iterations.
@ -850,3 +855,77 @@
(if bits
(make-object bitmap% bits w h)
(make-object bitmap% w h #t)))
(define/top (make-platform-bitmap [exact-positive-integer? w]
[exact-positive-integer? h])
(case (system-type)
[(macosx) (make-object quartz-bitmap% w h)]
[(windows) (make-object win32-no-hwnd-bitmap% w h)]
[(unix) (make-bitmap w h)]))
(define-local-member-name build-cairo-surface)
(define win32-no-hwnd-bitmap%
(class bitmap%
(init w h)
(super-make-object (make-alternate-bitmap-kind w h))
(define s (build-cairo-surface w h))
;; erase the bitmap
(let ([cr (cairo_create s)])
(cairo_set_source_rgba cr 1.0 1.0 1.0 1.0)
(cairo_paint cr)
(cairo_destroy cr))
(define/public (build-cairo-surface w h)
(cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h))
(define/override (ok?) #t)
(define/override (is-color?) #t)
(define/override (has-alpha-channel?) #f)
(define/override (get-cairo-surface) s)
(define/override (release-bitmap-storage)
(atomically
(cairo_surface_destroy s)
(set! s #f)))))
(define quartz-bitmap%
(class bitmap%
(init w h [with-alpha? #t])
(super-make-object (make-alternate-bitmap-kind w h))
(define s
(let ([s (cairo_quartz_surface_create (if with-alpha?
CAIRO_FORMAT_ARGB32
CAIRO_FORMAT_RGB24)
w
h)])
;; initialize bitmap to empty - needed?
(let ([cr (cairo_create s)])
(cairo_set_operator cr (if with-alpha?
CAIRO_OPERATOR_CLEAR
CAIRO_OPERATOR_SOURCE))
(cairo_set_source_rgba cr 1.0 1.0 1.0 1.0)
(cairo_paint cr)
(cairo_destroy cr))
s))
(define/override (ok?) (and s #t))
(define/override (is-color?) #t)
(define has-alpha? with-alpha?)
(define/override (has-alpha-channel?) has-alpha?)
(define/override (get-cairo-surface) s)
(define/override (get-cairo-alpha-surface)
(if has-alpha?
s
(super get-cairo-alpha-surface)))
(define/override (release-bitmap-storage)
(atomically
(when s
(cairo_surface_destroy s)
(set! s #f))))))

6
collects/racket/draw/private/font.rkt
View File

@ -7,7 +7,8 @@
"font-syms.rkt"
"font-dir.rkt"
"local.rkt"
"xp.rkt")
"xp.rkt"
"lock.rkt")
(provide font%
font-list% the-font-list
@ -39,9 +40,6 @@
(define ps-font-descs (make-weak-hash))
(define keys (make-weak-hash))
(define-syntax-rule (atomically e)
(begin (start-atomic) (begin0 e (end-atomic))))
(define substitute-fonts? (memq (system-type) '(macosx windows)))
(define substitute-mapping (make-hasheq))

9
collects/racket/draw/private/lock.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang racket/base
(require ffi/unsafe/atomic)
(provide atomically)
(define-syntax-rule
(atomically e1 e2 ...)
(begin (start-atomic)
(begin0 (let () e1 e2 ...)
(end-atomic))))

6
collects/redex/private/core-layout.rkt
View File

@ -11,11 +11,7 @@
racket/draw
scheme/class)
(define pink-code-font
(if (and (eq? (system-type) 'macosx)
(member "Courier" (get-face-list)))
"Courier"
'modern))
(define pink-code-font 'modern)
(require (for-syntax scheme/base))

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

@ -5,7 +5,7 @@
A @racket[bitmap%] object is a pixel-based image, either
monochrome, color, or color with an alpha channel. See also
@racket[make-screen-bitmap] and @xmethod[canvas% make-bitmap].
@racket[make-platform-bitmap].
A bitmap is convertible to @racket['png-bytes] through the
@racketmodname[file/convertible] protocol.
@ -29,11 +29,15 @@ A bitmap is convertible to @racket['png-bytes] through the
[width exact-positive-integer?]
[height exact-positive-integer?]))]{
The @racket[make-bitmap], @racket[make-monochrome-bitmap], and
@racket[read-bitmap] functions are preferred over using
@racket[make-object] with @racket[bitmap%], because the functions are
less overloaded and they enable alpha channels by default.
The function @racket[make-platform-bitmap] is preferred over
using @racket[bitmap%] directly.
The @racket[make-bitmap], @racket[make-monochrome-bitmap], and
@racket[read-bitmap] functions are closer to @racket[bitmap%], but
they are also preferred over using @racket[make-object]
with @racket[bitmap%] directly, because the functions are
less overloaded and they enable alpha channels by default.
When @racket[width] and @racket[height] are provided: Creates a new
bitmap. If @racket[monochrome?] is true, the bitmap is monochrome; if
@racket[monochrome?] is @racket[#f] and @racket[alpha?] is true, the
@ -160,8 +164,8 @@ Returns @racket[#f] if the bitmap is monochrome, @racket[#t] otherwise.
boolean?]{
Loads a bitmap from a file format that read from @racket[in], unless
the bitmap was produced by @racket[make-screen-bitmap] or
@xmethod[canvas% make-bitmap] (in which case @|MismatchExn|).
the bitmap was produced by @racket[make-screen-bitmap], @racket[make-platform-bitmap],
or @xmethod[canvas% make-bitmap] (in which case @|MismatchExn|).
If the bitmap is in use by a
@racket[bitmap-dc%] object or a control, the image data is not
loaded. The bitmap changes its size and depth to match that of

42
collects/scribblings/draw/draw-funcs.scrbl
View File

@ -36,6 +36,43 @@ Returns the built-in default face mapping for a particular font
See @racket[font%] for information about @racket[family].}
@defproc[(make-platform-bitmap [width exact-positive-integer?]
[height exact-positive-integer?])
(is-a?/c bitmap%)]{
Creates a bitmap that draws in a way that is the same as drawing to a
@racket[canvas%]'s @racket[dc<%>] (in its default configuration)
under Mac OS X and Windows, and creates a bitmap that draws the way
the result of @racket[make-bitmap] draws under Unix.
In general, @racket[make-platform-bitmap] produces better looking
bitmaps on more platforms than
@racket[make-bitmap], @racket[make-screen-bitmap], or creating
a @racket[bitmap%] object directly.
Also, unlike @racket[make-screen-bitmap],
@racket[make-platform-bitmap]'s implementation does not
depend on @racketmodname[racket/gui/base], making it
available in more contexts.
Accordingly, in the absence
of other constraints, @racket[make-platform-bitmap]
should be used in preference to other ways of creating bitmaps.
That said, there are two drawbacks to @racket[make-platform-bitmap].
First, it will use more constrained resources than
@racket[make-bitmap] does, especially under Windows. One possible
approach to dealing with this problem for long-lived bitmaps
is to draw into the result of a @racket[make-platform-bitmap]
and then copy the contents of the drawing into the result
of a @racket[make-bitmap]. This preserves the better quality
drawing, but holds onto the constrained resources only during
the drawing process.
The other drawback is that @racket[make-platform-bitmap] does not
create bitmaps with an alpha channel under Windows
(instead, the bitmaps have a white, solid background).
If you need bitmaps with alpha channels, use @racket[make-bitmap]
instead.
}
@defproc[(make-bitmap [width exact-positive-integer?]
[height exact-positive-integer?]
[alpha? any/c #t])
@ -43,7 +80,10 @@ See @racket[font%] for information about @racket[family].}
Returns @racket[(make-object bitmap% width height #f alpha?)], but
this procedure is preferred because it defaults @racket[alpha?] in a
more useful way.}
more useful way.
See also @racket[make-platform-bitmap].
}
@defproc[(make-font [#:size size (integer-in 1 1024) 12]

43
collects/scribblings/draw/guide.scrbl
View File

@ -16,14 +16,14 @@
(send dc set-bitmap #f))
bm)))]
@interaction-eval[#:eval draw-eval (define (line-bitmap mode)
(let* ([bm (make-bitmap 30 4)]
(let* ([bm (make-platform-bitmap 30 4)]
[dc (make-object bitmap-dc% bm)])
(send dc set-smoothing mode)
(send dc draw-line 0 2 30 2)
(send dc set-smoothing mode)
(send dc draw-line 0 2 30 2)
(send dc set-bitmap #f)
bm))]
(copy-bitmap bm)))]
@interaction-eval[#:eval draw-eval (define (path-bitmap zee join brush?)
(let* ([bm (make-bitmap 40 40)]
(let* ([bm (make-platform-bitmap 40 40)]
[dc (new bitmap-dc% [bitmap bm])])
(send dc set-smoothing 'aligned)
(send dc set-pen (new pen% [width 5] [join join]))
@ -32,7 +32,7 @@
(send dc set-brush "white" 'transparent))
(send dc draw-path zee 5 5)
(send dc set-bitmap #f)
bm))]
(copy-bitmap bm)))]
@(define-syntax-rule (define-linked-method name interface)
(define-syntax name
@ -98,12 +98,12 @@ in a GUI window.}
@section{Lines and Simple Shapes}
To draw into a bitmap, first create the bitmap with
@racket[make-bitmap], and then create a @racket[bitmap-dc%] that draws
@racket[make-platform-bitmap], and then create a @racket[bitmap-dc%] that draws
into the new bitmap:
@racketblock+eval[
#:eval draw-eval
(define target (make-bitmap 30 30)) (code:comment "A 30x30 bitmap")
(define target (make-platform-bitmap 30 30)) (code:comment "A 30x30 bitmap")
(define dc (new bitmap-dc% [bitmap target]))
]
@ -234,7 +234,7 @@ The @racket[set-pen] and @racket[set-brush] methods of a @tech{DC}
(send dc set-pen red-pen)
(send dc draw-arc 37 37 75 75 (* 5/4 pi) (* 7/4 pi)))
(define target (make-bitmap 150 150))
(define target (make-platform-bitmap 150 150))
(define dc (new bitmap-dc% [bitmap target]))
(draw-face dc)
@ -477,7 +477,7 @@ At this point we can't resist showing an extended example using
(send dc set-brush blue-brush)
(send dc draw-path right-logo-path))
(define racket-logo (make-bitmap 170 170))
(define racket-logo (make-platform-bitmap 170 170))
(define dc (new bitmap-dc% [bitmap racket-logo]))
(send dc set-smoothing 'smoothed)
@ -501,7 +501,7 @@ draw and a location for the top-left of the drawn text:
@racketblock+eval[
#:eval draw-eval
(define text-target (make-bitmap 100 30))
(define text-target (make-platform-bitmap 100 30))
(define dc (new bitmap-dc% [bitmap text-target]))
(send dc set-brush "white" 'transparent)
@ -559,7 +559,7 @@ transferred, and the background is left alone:
@racketblock+eval[
#:eval draw-eval
(define new-target (make-bitmap 100 30))
(define new-target (make-platform-bitmap 100 30))
(define dc (new bitmap-dc% [bitmap new-target]))
(send dc set-pen "black" 1 'transparent)
(send dc set-brush "pink" 'solid)
@ -573,7 +573,7 @@ transferred, and the background is left alone:
The information about which pixels of a bitmap are drawn (as opposed
to ``nothing'') is the bitmap's @deftech{alpha channel}. Not all
@tech{DC}s keep an alpha channel, but bitmaps created with
@racket[make-bitmap] keep an alpha channel by default. Bitmaps loaded
@racket[make-platform-bitmap] keep an alpha channel by default. Bitmaps loaded
with @racket[read-bitmap] preserve transparency in the image file
through the bitmap's alpha channel.
@ -638,12 +638,15 @@ viewed as a convenience alternative to clipping repeated calls of
@; ------------------------------------------------------------
@section{Portability}
Drawing effects are not completely portable across platforms or across
types of DC. For example. drawing to a bitmap produced by
@racket[make-bitmap] may produce slightly different results than
drawing to one produced by @racketmodname[racket/gui]'s
@racket[make-screen-bitmap], but drawing to a bitmap from
@racket[make-screen-bitmap] should be the same as drawing to an
onscreen @racket[canvas%]. Fonts and text, especially, can vary across
Drawing effects are not completely portable across platforms, across
different classes that implement @racket[dc<%>], or different
kinds of bitmaps. Fonts and text, especially, can vary across
platforms and types of @tech{DC}, but so can the precise set of pixels
touched by drawing a line.
For example, drawing to a bitmap produced by
@racket[make-platform-bitmap] may produce slightly different results than
drawing to one produced by
@racket[make-bitmap]. Drawing to a bitmap from
@racket[make-screen-bitmap], however, should be the same as drawing to an
onscreen @racket[canvas%].

5
collects/scribblings/gui/miscwin-funcs.scrbl
View File

@ -253,7 +253,10 @@ Creates a bitmap that draws in a way that is the same as drawing to a
canvas in its default configuration.
A normal @racket[bitmap%] draws in a more platform-independent way and
may use fewer constrained resources, particularly on Windows.}
may use fewer constrained resources, particularly on Windows.
See also @racket[make-platform-bitmap].
}
@defproc[(play-sound [filename path-string?]

5
collects/texpict/private/mrpict-extra.rkt
View File

@ -471,8 +471,9 @@
(define (convert-pict/bytes p format default)
(case format
[(png-bytes)
(let* ([bm (make-bitmap (max 1 (inexact->exact (ceiling (pict-width p))))
(max 1 (inexact->exact (ceiling (pict-height p)))))]
(let* ([bm (make-platform-bitmap
(max 1 (inexact->exact (ceiling (pict-width p))))
(max 1 (inexact->exact (ceiling (pict-height p)))))]
[dc (make-object bitmap-dc% bm)])
(send dc set-smoothing 'aligned)
(draw-pict p dc 0 0)