v5.4.99.1, executable-yield-handler', and make-bitmap' etc.

original commit: 05cfffdf9e13b6868a19384e88bcb9331f9631f1
This commit is contained in:
Matthew Flatt 2010-10-27 07:54:33 -06:00
parent c14bee176f
commit da874c1c04
9 changed files with 182 additions and 122 deletions

View File

@ -118,11 +118,13 @@ label->plain-label
labelled-menu-item<%> labelled-menu-item<%>
list-box% list-box%
list-control<%> list-control<%>
make-bitmap
make-eventspace make-eventspace
make-gl-bitmap
make-gui-empty-namespace make-gui-empty-namespace
make-gui-namespace make-gui-namespace
make-monochrome-bitmap
make-screen-bitmap make-screen-bitmap
make-gl-bitmap
map-command-as-meta-key map-command-as-meta-key
menu% menu%
menu-bar% menu-bar%
@ -156,6 +158,7 @@ put-file
queue-callback queue-callback
radio-box% radio-box%
readable-snip<%> readable-snip<%>
read-bitmap
read-editor-global-footer read-editor-global-footer
read-editor-global-header read-editor-global-header
read-editor-version read-editor-version

View File

@ -102,6 +102,9 @@
begin-busy-cursor begin-busy-cursor
bell bell
bitmap% bitmap%
make-bitmap
read-bitmap
make-monochrome-bitmap
brush% brush%
brush-list% brush-list%
editor-data% editor-data%

View File

@ -8,7 +8,8 @@
"wx.ss" "wx.ss"
"te.rkt" "te.rkt"
"mrtop.ss" "mrtop.ss"
"mrcanvas.ss") "mrcanvas.ss"
"syntax.rkt")
(provide register-collecting-blit (provide register-collecting-blit
unregister-collecting-blit unregister-collecting-blit

View File

@ -54,9 +54,23 @@
(tellv app finishLaunching) (tellv app finishLaunching)
;; In case we were started in an executable without a bundle,
;; explicitly register with the dock so the application can receive
;; keyboard events.
;; This technique is not sanctioned by Apple --- I found the code in SDL.
(define-cstruct _CPSProcessSerNum ([lo _uint32] [hi _uint32]))
(define-appserv CPSGetCurrentProcess (_fun _CPSProcessSerNum-pointer -> _int)
#:fail (lambda () (lambda args 1)))
(define-appserv CPSEnableForegroundOperation (_fun _CPSProcessSerNum-pointer _int _int _int _int -> _int)
#:fail (lambda () #f))
(let ([psn (make-CPSProcessSerNum 0 0)])
(when (zero? (CPSGetCurrentProcess psn))
(void (CPSEnableForegroundOperation psn #x03 #x3C #x2C #x1103))))
(define app-delegate (tell (tell MyApplicationDelegate alloc) init)) (define app-delegate (tell (tell MyApplicationDelegate alloc) init))
(tellv app setDelegate: app-delegate) (tellv app setDelegate: app-delegate)
(tellv app activateIgnoringOtherApps: #:type _BOOL #t) (unless (scheme_register_process_global "Racket-GUI-no-front" #f)
(tellv app activateIgnoringOtherApps: #:type _BOOL #t))
;; For some reason, nextEventMatchingMask:... gets stuck if the ;; For some reason, nextEventMatchingMask:... gets stuck if the
;; display changes, and it doesn't even send the ;; display changes, and it doesn't even send the

View File

@ -498,3 +498,12 @@
(send e set-wait-cursor-mode #f)))))) (send e set-wait-cursor-mode #f))))))
(define (is-busy?) (positive? (eventspace-wait-cursor-count (current-eventspace)))) (define (is-busy?) (positive? (eventspace-wait-cursor-count (current-eventspace))))
;; ----------------------------------------
;; Before exiting, wait until frames are closed, etc.:
(executable-yield-handler
(let ([old-eyh (executable-yield-handler)])
(lambda (v)
(yield main-eventspace)
(old-eyh v))))

View File

@ -117,10 +117,10 @@ has been moved out).
;; - flip ;; - flip
;; a bitmap is: ;; a bitmap is:
;; - (make-bitmap (is-a?/c bitmap%) angle positive-real ;; - (make-ibitmap (is-a?/c bitmap%) angle positive-real
;; hash[(list boolean[flip] number[x-scale] number[y-scale] number[angle]) -o> (cons (is-a?/c bitmap%) (is-a?/c bitmap%)]) ;; hash[(list boolean[flip] number[x-scale] number[y-scale] number[angle]) -o> (cons (is-a?/c bitmap%) (is-a?/c bitmap%)])
;; NOTE: bitmap copying needs to happen in 'write' and 'read' methods ;; NOTE: bitmap copying needs to happen in 'write' and 'read' methods
(define-struct/reg-mk bitmap (raw-bitmap raw-mask angle x-scale y-scale cache) (define-struct/reg-mk ibitmap #:reflect-id bitmap (raw-bitmap raw-mask angle x-scale y-scale cache)
#:omit-define-syntaxes #:transparent #:omit-define-syntaxes #:transparent
#:property prop:custom-write (λ (x y z) (bitmap-write x y z))) #:property prop:custom-write (λ (x y z) (bitmap-write x y z)))
@ -404,7 +404,7 @@ has been moved out).
(or (polygon? shape) (or (polygon? shape)
(line-segment? shape) (line-segment? shape)
(curve-segment? shape) (curve-segment? shape)
(bitmap? shape) (ibitmap? shape)
(np-atomic-shape? shape))) (np-atomic-shape? shape)))
(define (np-atomic-shape? shape) (define (np-atomic-shape? shape)
@ -412,7 +412,7 @@ has been moved out).
(text? shape) (text? shape)
(and (flip? shape) (and (flip? shape)
(boolean? (flip-flipped? shape)) (boolean? (flip-flipped? shape))
(bitmap? (flip-shape shape))))) (ibitmap? (flip-shape shape)))))
;; normalize-shape : shape -> normalized-shape ;; normalize-shape : shape -> normalized-shape
;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape. ;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape.
@ -490,8 +490,8 @@ has been moved out).
(if bottom (if bottom
(make-overlay bottom this-one) (make-overlay bottom this-one)
this-one))] this-one))]
[(or (bitmap? shape) (np-atomic-shape? shape)) [(or (ibitmap? shape) (np-atomic-shape? shape))
(let ([shape (if (bitmap? shape) (let ([shape (if (ibitmap? shape)
(make-flip #f shape) (make-flip #f shape)
shape)]) shape)])
(let ([this-one (let ([this-one
@ -532,12 +532,12 @@ has been moved out).
[else [else
(let ([bitmap (flip-shape shape)]) (let ([bitmap (flip-shape shape)])
(make-flip (flip-flipped? shape) (make-flip (flip-flipped? shape)
(make-bitmap (bitmap-raw-bitmap bitmap) (make-ibitmap (ibitmap-raw-bitmap bitmap)
(bitmap-raw-mask bitmap) (ibitmap-raw-mask bitmap)
(bitmap-angle bitmap) (ibitmap-angle bitmap)
(* x-scale (bitmap-x-scale bitmap)) (* x-scale (ibitmap-x-scale bitmap))
(* y-scale (bitmap-y-scale bitmap)) (* y-scale (ibitmap-y-scale bitmap))
(bitmap-cache bitmap))))])])) (ibitmap-cache bitmap))))])]))
(define (scale-color color x-scale y-scale) (define (scale-color color x-scale y-scale)
(cond (cond
@ -875,34 +875,34 @@ the mask bitmap and the original bitmap are all together in a single bytes!
(define (get-rendered-bitmap flip-bitmap) (define (get-rendered-bitmap flip-bitmap)
(let ([key (get-bitmap-cache-key flip-bitmap)]) (let ([key (get-bitmap-cache-key flip-bitmap)])
(calc-rendered-bitmap flip-bitmap key) (calc-rendered-bitmap flip-bitmap key)
(car (hash-ref (bitmap-cache (flip-shape flip-bitmap)) (car (hash-ref (ibitmap-cache (flip-shape flip-bitmap))
key)))) key))))
(define (get-rendered-mask flip-bitmap) (define (get-rendered-mask flip-bitmap)
(let ([key (get-bitmap-cache-key flip-bitmap)]) (let ([key (get-bitmap-cache-key flip-bitmap)])
(calc-rendered-bitmap flip-bitmap key) (calc-rendered-bitmap flip-bitmap key)
(cdr (hash-ref (bitmap-cache (flip-shape flip-bitmap)) (cdr (hash-ref (ibitmap-cache (flip-shape flip-bitmap))
key)))) key))))
(define (get-bitmap-cache-key flip-bitmap) (define (get-bitmap-cache-key flip-bitmap)
(let ([bm (flip-shape flip-bitmap)]) (let ([bm (flip-shape flip-bitmap)])
(list (flip-flipped? flip-bitmap) (list (flip-flipped? flip-bitmap)
(bitmap-x-scale bm) (ibitmap-x-scale bm)
(bitmap-y-scale bm) (ibitmap-y-scale bm)
(bitmap-angle bm)))) (ibitmap-angle bm))))
(define (calc-rendered-bitmap flip-bitmap key) (define (calc-rendered-bitmap flip-bitmap key)
(let ([bitmap (flip-shape flip-bitmap)]) (let ([bitmap (flip-shape flip-bitmap)])
(cond (cond
[(hash-ref (bitmap-cache bitmap) key #f) => (λ (x) x)] [(hash-ref (ibitmap-cache bitmap) key #f) => (λ (x) x)]
[else [else
(let ([flipped? (flip-flipped? flip-bitmap)]) (let ([flipped? (flip-flipped? flip-bitmap)])
(define-values (orig-bitmap-obj orig-mask-obj) (values (bitmap-raw-bitmap bitmap) (define-values (orig-bitmap-obj orig-mask-obj) (values (ibitmap-raw-bitmap bitmap)
(bitmap-raw-mask bitmap))) (ibitmap-raw-mask bitmap)))
(define-values (bitmap-obj mask-obj) (define-values (bitmap-obj mask-obj)
(cond (cond
[(<= (* (bitmap-x-scale bitmap) [(<= (* (ibitmap-x-scale bitmap)
(bitmap-y-scale bitmap)) (ibitmap-y-scale bitmap))
1) 1)
;; since we prefer to rotate big things, we rotate first ;; since we prefer to rotate big things, we rotate first
(let-values ([(bitmap-obj mask-obj) (do-rotate bitmap orig-bitmap-obj orig-mask-obj flipped?)]) (let-values ([(bitmap-obj mask-obj) (do-rotate bitmap orig-bitmap-obj orig-mask-obj flipped?)])
@ -912,16 +912,16 @@ the mask bitmap and the original bitmap are all together in a single bytes!
(let-values ([(bitmap-obj mask-obj) (do-scale bitmap orig-bitmap-obj orig-mask-obj)]) (let-values ([(bitmap-obj mask-obj) (do-scale bitmap orig-bitmap-obj orig-mask-obj)])
(do-rotate bitmap bitmap-obj mask-obj flipped?))])) (do-rotate bitmap bitmap-obj mask-obj flipped?))]))
(define pair (cons bitmap-obj mask-obj)) (define pair (cons bitmap-obj mask-obj))
(hash-set! (bitmap-cache bitmap) key pair) (hash-set! (ibitmap-cache bitmap) key pair)
pair)]))) pair)])))
(define (do-rotate bitmap bitmap-obj mask-obj flip?) (define (do-rotate bitmap bitmap-obj mask-obj flip?)
(cond (cond
[(and (not flip?) (zero? (bitmap-angle bitmap))) [(and (not flip?) (zero? (ibitmap-angle bitmap)))
;; don't rotate anything in this case. ;; don't rotate anything in this case.
(values bitmap-obj mask-obj)] (values bitmap-obj mask-obj)]
[else [else
(let ([θ (degrees->radians (bitmap-angle bitmap))]) (let ([θ (degrees->radians (ibitmap-angle bitmap))])
(let-values ([(bytes w h) (bitmap->bytes bitmap-obj mask-obj)]) (let-values ([(bytes w h) (bitmap->bytes bitmap-obj mask-obj)])
(let-values ([(rotated-bytes rotated-w rotated-h) (let-values ([(rotated-bytes rotated-w rotated-h)
(rotate-bytes bytes w h θ)]) (rotate-bytes bytes w h θ)])
@ -933,8 +933,8 @@ the mask bitmap and the original bitmap are all together in a single bytes!
(values bm mask)))))])) (values bm mask)))))]))
(define (do-scale bitmap orig-bm orig-mask) (define (do-scale bitmap orig-bm orig-mask)
(let ([x-scale (bitmap-x-scale bitmap)] (let ([x-scale (ibitmap-x-scale bitmap)]
[y-scale (bitmap-y-scale bitmap)]) [y-scale (ibitmap-y-scale bitmap)])
(cond (cond
[(and (= 1 x-scale) (= 1 y-scale)) [(and (= 1 x-scale) (= 1 y-scale))
;; no need to scale in this case ;; no need to scale in this case
@ -1081,7 +1081,7 @@ the mask bitmap and the original bitmap are all together in a single bytes!
[h (send bm get-height)]) [h (send bm get-height)])
(make-image (make-translate (/ w 2) (make-image (make-translate (/ w 2)
(/ h 2) (/ h 2)
(make-bitmap bm mask-bm 0 1 1 (make-hash))) (make-ibitmap bm mask-bm 0 1 1 (make-hash)))
(make-bb w h h) (make-bb w h h)
#f))) #f)))
@ -1125,8 +1125,8 @@ the mask bitmap and the original bitmap are all together in a single bytes!
curve-segment-color curve-segment-color
make-pen pen? pen-color pen-width pen-style pen-cap pen-join pen make-pen pen? pen-color pen-width pen-style pen-cap pen-join pen
make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-x-scale bitmap-y-scale make-ibitmap ibitmap? ibitmap-raw-bitmap ibitmap-raw-mask ibitmap-angle ibitmap-x-scale ibitmap-y-scale
bitmap-cache ibitmap-cache
make-flip flip? flip-flipped? flip-shape make-flip flip? flip-flipped? flip-shape

View File

@ -10,14 +10,15 @@
(define-syntax (define-struct/reg-mk stx) (define-syntax (define-struct/reg-mk stx)
(syntax-case stx () (syntax-case stx ()
[(_ id . rest) [(_ id #:reflect-id reflect-id rest ...)
(let ([build-name (let ([build-name
(λ (fmt) (λ (fmt id)
(datum->syntax #'id (string->symbol (format fmt (syntax->datum #'id)))))]) (datum->syntax id (string->symbol (format fmt (syntax->datum id)))))])
#`(begin #`(begin
(define-struct id . rest) (define-struct id rest ... #:reflection-name 'reflect-id)
(add-id-constructor-pair '#,(build-name "struct:~a") (add-id-constructor-pair '#,(build-name "struct:~a" #'reflect-id)
#,(build-name "make-~a"))))])) #,(build-name "make-~a" #'id))))]
[(_ id . rest) #'(define-struct/reg-mk id #:reflect-id id . rest)]))
(define (id->constructor id) (define (id->constructor id)
(let ([line (assoc id id-constructor-pairs)]) (let ([line (assoc id id-constructor-pairs)])

View File

@ -7,14 +7,9 @@
@declare-exporting[racket/gui/base racket/gui #:use-sources (mred)] @declare-exporting[racket/gui/base racket/gui #:use-sources (mred)]
This reference manual describes the GUI toolbox that is part of Racket
and whose core is implemented by the GRacket executable.
@defmodule*/no-declare[(racket/gui/base)]{The @defmodule*/no-declare[(racket/gui/base)]{The
@racketmodname[racket/gui/base] library provides all of the class, @racketmodname[racket/gui/base] library provides all of the class,
interface, and procedure bindings defined in this manual. At run time, interface, and procedure bindings defined in this manual.}
this library needs primitive graphics support that the GRacket executable
provides; this library cannot run inside the Racket executable.}
@defmodulelang*/no-declare[(racket/gui)]{The @defmodulelang*/no-declare[(racket/gui)]{The
@racketmodname[racket/gui] language combines all bindings of the @racketmodname[racket/gui] language combines all bindings of the

View File

@ -1,96 +1,130 @@
Changes: GRacket, Racket, Drawing, and GUIs
----------------------------------
* The drawing portion of the old GUI toolbox is now available as a Version 5.5 includes two major changes to the Racket drawing and GUI
separate layer: `racket/draw'. This layer can be used from plain API:
Racket independent of the `racket/gui' library, although
`racket/gui' re-exports `racket/draw'.
The `racket/draw' library is built on top of the widely used Cairo * The drawing portion of the GUI toolbox is now available as a
drawing library and Pango text-rendering library. separate layer: `racket/draw'. This layer can be used independent
of the `racket/gui/base' library, although `racket/gui' re-exports
`racket/draw'.
* Drawing to a bitmap may not produce the same results as drawing to (The `racket/draw' library is built on top of the widely used Cairo
a canvas. Use the `make-screen-bitmap' function (from `racket/gui') drawing library and Pango text-rendering library.)
or the `make-bitmap' method of `canvas%' to obtain a bitmap that
uses the same drawing algorithms as a canvas.
Drawing to a canvas always draws into a bitmap that is kept * The GRacket executable is no longer strictly necessary for running
offscreen and periodically flushed onto the screen. The new GUI programs; the `racket/gui/base' library can be used from
`suspend-flush' and `resume-flush' methods of `canvas%' provide Racket.
some control over the timing of the flushes, which in many cases
avoids the need for (additional) double buffering of canvas
content.
* A color bitmap can have an alpha channel, instead of just a mask The GRacket executable still offers some additional GUI-specific
bitmap. When drawing a bitmap, alpha channels are used more functiontality however. Most notably, GRacket is a GUI application
consistently and automatically than mask bitmaps. More under Windows (as opposed to a console application, which is
significantly, drawing into a bitmap with an alpha channel launched slightly differently by the OS), GRacket is a bundle under
preserves the drawn alphas; for example, drawing a line in the Mac OS X (so the dock icon is the Racket logo, for example), and
middle of an empty bitmap produces an image with non-zero alpha GRacket manages single-instance mode for Windows and X.
only at the drawn line.
Create a bitmap with an alpha channel by supplying #t as the new The drawing and GUI libraries have also changed in further small ways.
`alpha?' argument to the `bitmap%' constructor, or by loading an
image with a type like 'unknown/alpha insteda of 'unknown or
'unknown/mask.
A newly created `bitmap%' has an empty content (i.e., white with
zero alpha), insteda of unspecified content.
Images can be read into a `bitmap%' from from input ports, instead Bitmaps
of requiring a file path. -------
* A `dc<%>' supports additional drawing transformations: a rotation Drawing to a bitmap may not produce the same results as drawing to a
(via `set-rotation') and a general transformation matrix (via canvas. Use the `make-screen-bitmap' function (from `racket/gui') or
`set-initial-matrix'). Scaling factors can be negative, which the `make-bitmap' method of `canvas%' to obtain a bitmap that uses the
corresponds to flipping the direction of drawing. same drawing algorithms as a canvas.
A transformation matrix has the form `(vector xx xy yx yy x0 y0)', A color bitmap can have an alpha channel, instead of just a mask
where a point (x1, y1) is transformed to a point (x2, y2) with x2 = bitmap. When drawing a bitmap, alpha channels are used more
xx*x1 + yx*y1 + x0 and y2 = xy*x1 + yy*y1 + y0, which is the usual consistently and automatically than mask bitmaps. More significantly,
convention. drawing into a bitmap with an alpha channel preserves the drawn
alphas; for example, drawing a line in the middle of an empty bitmap
produces an image with non-zero alpha only at the drawn line.
New methods `translate', `scale', `rotate', and `transform' Only bitmaps created with the new `make-gl-bitmap' function support
simplify adding a further translation, scaling, rotation, or OpenGL drawing.
arbitrary matrix transformation on top of the current
transformation. The new `get-translation' and `set-translation'
methods help to capture and restore transformation settings.
The old translation and scaling transformations apply after the Use the new `make-bitmap', `read-bitmap', `make-monochrome-bitmap',
initial matrix. The new rotation transformation applies after the `make-screen-bitmap', and `make-gl-bitmap' functions to create
other transformations. This layering is redundant, since all bitmaps, instead of using `make-object' with `bitmap%'. The new
transformations can be expressed in a single matrix, but it is constructors are less overloaded and provide more modern defaults
backward-compatibile. Methods like `get-translation', (such as alpha channels by default).
`set-translation', `scale', etc. help hide the reundancy.
The alpha value of a `dc<%>' (as set by `set-alpha') is used for Image formats can be read into a `bitmap%' from from input ports,
all drawing operations, including drawing a bitmap. instead of requiring a file path. A newly created bitmap has an empty
content (i.e., white with zero alpha), instead of unspecified content.
The `draw-bitmap' and `draw-bitmap-section' methods now smooth
bitmaps while scaling, so the `draw-bitmap-section-smooth' method
of `bitmap-dc%' simply calls `draw-bitmap-section'.
* A `region%' can be created as independent of any `dc<%>', in which Canvases
cases it uses the drawing context's current transformation at the --------
time that it is installed as a clipping region.
* The old 'xor mode for pens and brushes is no longer available Drawing to a canvas always draws into a bitmap that is kept offscreen
(since it is not supported by Cairo). and periodically flushed onto the screen. The new `suspend-flush' and
`resume-flush' methods of `canvas%' provide some control over the
timing of the flushes, which in many cases avoids the need for
(additional) double buffering of canvas content.
* The `draw-caret' argument to a `snip%' or `editor<%>' `draw' or OpenGL drawing in a canvas requires supplying 'gl as a style when
`refresh' method can be a pair, which indicates that the caret is creating the `canvas%' instance. OpenGL and normal dc<%> drawing no
owned by an enclosing display and the selection spans the snip or longer mix reliably in a canvas.
editor. In that case, the snip or editor should refrain from
drawing a background for the selected region, and it should draw
the foreground in the color specified by
`get-highlight-text-color', if any.
* OpenGL drawing in a canvas requires supplying 'gl as a style when
creating the `canvas%' instance. OpenGL and normal dc<%> drawing no
longer mix reliably in a canvas.
OpenG drawing to a bitmap requires a bitmap created with Drawing-Context Transformations
`make-gl-bitmap'. -------------------------------
* The `write-resource, `get-reource', and `send-event' functions have A `dc<%>' instance supports rotation (via `set-rotation'), negative
been removed from `racket/gui/base'. If there is any demand for the scaling factors for flipping, and a general transformation matrix (via
removed functionality, it will be implemented in a new library. `set-initial-matrix'). A transformation matrix has the form `(vector
xx xy yx yy x0 y0)', where a point (x1, y1) is transformed to a point
(x2, y2) with x2 = xx*x1 + yx*y1 + x0 and y2 = xy*x1 + yy*y1 + y0,
which is the usual convention.
New methods `translate', `scale', `rotate', and `transform' simplify
adding a further translation, scaling, rotation, or arbitrary matrix
transformation on top of the current transformation. The new
`get-translation' and `set-translation' methods help to capture and
restore transformation settings.
The old translation and scaling transformations apply after the
initial matrix. The new rotation transformation applies after the
other transformations. This layering is redundant, since all
transformations can be expressed in a single matrix, but it is
backward-compatibile. Methods like `get-translation',
`set-translation', `scale', etc. help hide the reundancy.
Others Drawing-Context Changes
------------------------------
The alpha value of a `dc<%>' (as set by `set-alpha') is used for all
drawing operations, including drawing a bitmap.
The `draw-bitmap' and `draw-bitmap-section' methods now smooth bitmaps
while scaling, so the `draw-bitmap-section-smooth' method of
`bitmap-dc%' simply calls `draw-bitmap-section'.
A `region%' can be created as independent of any `dc<%>', in which
cases it uses the drawing context's current transformation at the time
that it is installed as a clipping region.
The old 'xor mode for pens and brushes is no longer available (since
it is not supported by Cairo).
Editor Changes
--------------
The `draw-caret' argument to a `snip%' or `editor<%>' `draw' or
`refresh' method can be a pair, which indicates that the caret is
owned by an enclosing display and the selection spans the snip or
editor. In that case, the snip or editor should refrain from drawing a
background for the selected region, and it should draw the foreground
in the color specified by `get-highlight-text-color', if any.
Removed Functions
-----------------
The `write-resource, `get-reource', and `send-event' functions have
been removed from `racket/gui/base'. If there is any demand for the
removed functionality, it will be implemented in a new library.