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

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

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-27 07:54:33 -06:00
parent d7f1d12ea1
commit 05cfffdf9e
27 changed files with 1235 additions and 1093 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/2htdp/private/image-more.rkt
View File

@ -617,11 +617,11 @@
(rotated-rectangular-bounding-box w h (text-angle atomic-shape)))]
[(flip? atomic-shape)
(let* ([bitmap (flip-shape atomic-shape)]
[bb (bitmap-raw-bitmap bitmap)])
[bb (ibitmap-raw-bitmap bitmap)])
(let-values ([(l t r b)
(rotated-rectangular-bounding-box (* (send bb get-width) (bitmap-x-scale bitmap))
(* (send bb get-height) (bitmap-y-scale bitmap))
(bitmap-angle bitmap))])
(rotated-rectangular-bounding-box (* (send bb get-width) (ibitmap-x-scale bitmap))
(* (send bb get-height) (ibitmap-y-scale bitmap))
(ibitmap-angle bitmap))])
(values l t r b)))]
[else
(fprintf (current-error-port) "using bad bounding box for ~s\n" atomic-shape)
@ -707,14 +707,14 @@
(let ([bitmap (flip-shape atomic-shape)]
[flipped? (flip-flipped? atomic-shape)])
(make-flip flipped?
(make-bitmap (bitmap-raw-bitmap bitmap)
(bitmap-raw-mask bitmap)
(make-bitmap (ibitmap-raw-bitmap bitmap)
(ibitmap-raw-mask bitmap)
(bring-between (if flipped?
(+ (bitmap-angle bitmap) θ)
(- (bitmap-angle bitmap) θ))
(+ (ibitmap-angle bitmap) θ)
(- (ibitmap-angle bitmap) θ))
360)
(bitmap-x-scale bitmap)
(bitmap-y-scale bitmap)
(ibitmap-x-scale bitmap)
(ibitmap-y-scale bitmap)
(make-hash))))]))
;; rotate-point : point angle -> point

2
collects/frtime/frp-snip.rkt
View File

@ -15,7 +15,7 @@
any-nested-reactivity? raise-reactivity)
;; GRacket require
(except-in mred send-event))
mred)
(define drs-eventspace #f)

2
collects/frtime/scribblings/frtime.scrbl
View File

@ -2,7 +2,7 @@
@(require scribble/manual
(for-label scheme
scheme/class
(except-in scheme/gui/base send-event)
scheme/gui/base
(only-in frtime
undefined undefined? behavior? event? signal? seconds milliseconds never-e
new-cell set-cell! event-receiver send-event

5
collects/mred/mred-sig.rkt
View File

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

3
collects/mred/mred.rkt
View File

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

3
collects/mred/private/gdi.rkt
View File

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

16
collects/mred/private/wx/cocoa/queue.rkt
View File

@ -54,9 +54,23 @@
(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))
(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
;; display changes, and it doesn't even send the

9
collects/mred/private/wx/common/queue.rkt
View File

@ -498,3 +498,12 @@
(send e set-wait-cursor-mode #f))))))
(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))))

5
collects/mred/private/wxme/snip.rkt
View File

@ -1023,10 +1023,7 @@
(send f jump-to end)))))))
(def/public (load-file [(make-or-false path-string?) [name #f]]
[(symbol-in unknown unknown/mask gif gif/mask
jpeg png png/mask
xbm xpm bmp pict)
[kind 'unknown]]
[image-type? [kind 'unknown]]
[bool? [rel-path? #f]]
[bool? [inline? #t]])
(do-set-bitmap #f #f #f)

60
collects/mrlib/image-core.rkt
View File

@ -117,10 +117,10 @@ has been moved out).
;; - flip
;; 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%)])
;; 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
#:property prop:custom-write (λ (x y z) (bitmap-write x y z)))
@ -404,7 +404,7 @@ has been moved out).
(or (polygon? shape)
(line-segment? shape)
(curve-segment? shape)
(bitmap? shape)
(ibitmap? shape)
(np-atomic-shape? shape)))
(define (np-atomic-shape? shape)
@ -412,7 +412,7 @@ has been moved out).
(text? shape)
(and (flip? shape)
(boolean? (flip-flipped? shape))
(bitmap? (flip-shape shape)))))
(ibitmap? (flip-shape shape)))))
;; normalize-shape : shape -> normalized-shape
;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape.
@ -490,8 +490,8 @@ has been moved out).
(if bottom
(make-overlay bottom this-one)
this-one))]
[(or (bitmap? shape) (np-atomic-shape? shape))
(let ([shape (if (bitmap? shape)
[(or (ibitmap? shape) (np-atomic-shape? shape))
(let ([shape (if (ibitmap? shape)
(make-flip #f shape)
shape)])
(let ([this-one
@ -532,12 +532,12 @@ has been moved out).
[else
(let ([bitmap (flip-shape shape)])
(make-flip (flip-flipped? shape)
(make-bitmap (bitmap-raw-bitmap bitmap)
(bitmap-raw-mask bitmap)
(bitmap-angle bitmap)
(* x-scale (bitmap-x-scale bitmap))
(* y-scale (bitmap-y-scale bitmap))
(bitmap-cache bitmap))))])]))
(make-ibitmap (ibitmap-raw-bitmap bitmap)
(ibitmap-raw-mask bitmap)
(ibitmap-angle bitmap)
(* x-scale (ibitmap-x-scale bitmap))
(* y-scale (ibitmap-y-scale bitmap))
(ibitmap-cache bitmap))))])]))
(define (scale-color color x-scale y-scale)
(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)
(let ([key (get-bitmap-cache-key flip-bitmap)])
(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))))
(define (get-rendered-mask flip-bitmap)
(let ([key (get-bitmap-cache-key flip-bitmap)])
(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))))
(define (get-bitmap-cache-key flip-bitmap)
(let ([bm (flip-shape flip-bitmap)])
(list (flip-flipped? flip-bitmap)
(bitmap-x-scale bm)
(bitmap-y-scale bm)
(bitmap-angle bm))))
(ibitmap-x-scale bm)
(ibitmap-y-scale bm)
(ibitmap-angle bm))))
(define (calc-rendered-bitmap flip-bitmap key)
(let ([bitmap (flip-shape flip-bitmap)])
(cond
[(hash-ref (bitmap-cache bitmap) key #f) => (λ (x) x)]
[(hash-ref (ibitmap-cache bitmap) key #f) => (λ (x) x)]
[else
(let ([flipped? (flip-flipped? flip-bitmap)])
(define-values (orig-bitmap-obj orig-mask-obj) (values (bitmap-raw-bitmap bitmap)
(bitmap-raw-mask bitmap)))
(define-values (orig-bitmap-obj orig-mask-obj) (values (ibitmap-raw-bitmap bitmap)
(ibitmap-raw-mask bitmap)))
(define-values (bitmap-obj mask-obj)
(cond
[(<= (* (bitmap-x-scale bitmap)
(bitmap-y-scale bitmap))
[(<= (* (ibitmap-x-scale bitmap)
(ibitmap-y-scale bitmap))
1)
;; 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?)])
@ -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)])
(do-rotate bitmap bitmap-obj mask-obj flipped?))]))
(define pair (cons bitmap-obj mask-obj))
(hash-set! (bitmap-cache bitmap) key pair)
(hash-set! (ibitmap-cache bitmap) key pair)
pair)])))
(define (do-rotate bitmap bitmap-obj mask-obj flip?)
(cond
[(and (not flip?) (zero? (bitmap-angle bitmap)))
[(and (not flip?) (zero? (ibitmap-angle bitmap)))
;; don't rotate anything in this case.
(values bitmap-obj mask-obj)]
[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 ([(rotated-bytes rotated-w rotated-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)))))]))
(define (do-scale bitmap orig-bm orig-mask)
(let ([x-scale (bitmap-x-scale bitmap)]
[y-scale (bitmap-y-scale bitmap)])
(let ([x-scale (ibitmap-x-scale bitmap)]
[y-scale (ibitmap-y-scale bitmap)])
(cond
[(and (= 1 x-scale) (= 1 y-scale))
;; 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)])
(make-image (make-translate (/ w 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)
#f)))
@ -1125,8 +1125,8 @@ the mask bitmap and the original bitmap are all together in a single bytes!
curve-segment-color
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
bitmap-cache
make-ibitmap ibitmap? ibitmap-raw-bitmap ibitmap-raw-mask ibitmap-angle ibitmap-x-scale ibitmap-y-scale
ibitmap-cache
make-flip flip? flip-flipped? flip-shape

13
collects/mrlib/private/regmk.rkt
View File

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

8
collects/racket/draw.rkt
View File

@ -23,7 +23,6 @@
pen% pen-list% the-pen-list
brush% brush-list% the-brush-list
region%
bitmap%
dc-path%
dc<%>
bitmap-dc%
@ -31,4 +30,9 @@
ps-setup% current-ps-setup
get-face-list
gl-config%
gl-context<%>)
gl-context<%>
bitmap%
make-bitmap
read-bitmap
make-monochrome-bitmap)

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

@ -15,7 +15,10 @@
"color.rkt")
(provide bitmap%
make-alternate-bitmap-kind)
make-bitmap
read-bitmap
make-monochrome-bitmap
(protect-out make-alternate-bitmap-kind))
;; FIXME: there must be some way to abstract over all many of the
;; ARGB/RGBA/BGRA iterations.
@ -26,7 +29,7 @@
get-alphas-as-mask
set-alphas-as-mask)
(define (kind-symbol? s)
(define (bitmap-file-kind-symbol? s)
(memq s '(unknown unknown/mask unknown/alpha
gif gif/mask gif/alpha
jpeg jpeg/alpha
@ -36,7 +39,7 @@
bmp bmp/alpha
pict)))
(define (save-kind-symbol? s)
(define (bitmap-save-kind-symbol? s)
(memq s '(png jpeg gif xbm xpm bmp)))
(define (quality-integer? i)
@ -88,8 +91,8 @@
(alternate-bitmap-kind-width a)
(alternate-bitmap-kind-height a)
#f #t #f #f)]
[([exact-nonnegative-integer? w]
[exact-nonnegative-integer? h]
[([exact-positive-integer? w]
[exact-positive-integer? h]
[any? [b&w? #f]]
[any? [alpha? #f]])
(values
@ -113,7 +116,7 @@
s)
#f)]
[([(make-alts path-string? input-port?) filename]
[kind-symbol? [kind 'unknown]]
[bitmap-file-kind-symbol? [kind 'unknown]]
[(make-or-false color%) [bg-color #f]]
[any? [complain-on-failure? #f]])
(let-values ([(s b&w?) (do-load-bitmap filename kind bg-color complain-on-failure?)]
@ -155,8 +158,8 @@
mask-bm)
(values #f 0 0 #f #f #f #f))))]
[([bytes? bstr]
[exact-nonnegative-integer? w]
[exact-nonnegative-integer? h])
[exact-positive-integer? w]
[exact-positive-integer? h])
(let ([bw (quotient (+ w 7) 8)])
(unless ((bytes-length bstr) . >= . (* h bw))
(error (init-name 'bitmap%)
@ -218,7 +221,7 @@
(define/public (adjust-lock delta) (set! locked (+ locked delta)))
(def/public (load-bitmap [(make-alts path-string? input-port?) in]
[kind-symbol? [kind 'unknown]]
[bitmap-file-kind-symbol? [kind 'unknown]]
[(make-or-false color%) [bg #f]]
[any? [complain-on-failure? #f]])
(check-alternate 'load-bitmap)
@ -432,7 +435,7 @@
(send bm release-bitmap-storage)))
(def/public (save-file [(make-alts path-string? output-port?) out]
[save-kind-symbol? [kind 'unknown]]
[bitmap-save-kind-symbol? [kind 'unknown]]
[quality-integer? [quality 75]])
(check-ok 'save-file)
(if alt?
@ -743,3 +746,19 @@
(cairo_surface_mark_dirty s))))
))
(define/top (make-bitmap [exact-positive-integer? w]
[exact-positive-integer? h]
[any? [alpha? #t]])
(make-object bitmap% w h #f alpha?))
(define/top (read-bitmap [path-string? filename]
[bitmap-file-kind-symbol? [kind 'unknown/alpha]])
(make-object bitmap% filename kind))
(define/top (make-monochrome-bitmap [exact-positive-integer? w]
[exact-positive-integer? h]
[(make-or-false bytes?) [bits #f]])
(if bits
(make-object bitmap% bits w h)
(make-object bitmap% w h #t)))

21
collects/scribblings/gui/bitmap-class.scrbl
View File

@ -13,8 +13,8 @@ Sometimes, a bitmap object creation fails in a low-level manner. In
bitmaps (otherwise, @|MismatchExn|).
@defconstructor*/make[(([width (integer-in 1 10000)]
[height (integer-in 1 10000)]
@defconstructor*/make[(([width exact-positive-integer?]
[height exact-positive-integer?]
[monochrome? any/c #f]
[alpha? any/c #f])
([in (or/c path-string? input-port?)]
@ -27,8 +27,13 @@ Sometimes, a bitmap object creation fails in a low-level manner. In
'unknown]
[bg-color (or/c (is-a?/c color%) false/c) #f])
([bits bytes?]
[width (integer-in 1 10000)]
[height (integer-in 1 10000)]))]{
[width exact-positive-integer?]
[height exact-positive-integer?]))]{
The @racket[make-bitmap], @racket[make-monchrome-bitmap], and
@racket[read-bitmap] functions are preferred over using
@racket[make-object] with @racket[bitmap%], because the functions are
less overloaded and provide more useful defaults.
When @scheme[width] and @scheme[height] are provided: Creates a new
bitmap. If @scheme[monochrome?] is true, the bitmap is monochrome; if
@ -57,8 +62,8 @@ When a @scheme[bits] byte string is provided: Creates a monochrome
@defmethod[(get-argb-pixels [x real?]
[y real?]
[width (integer-in 1 10000)]
[height (integer-in 1 10000)]
[width exact-nonnegative-integer?]
[height exact-nonnegative-integer?]
[pixels (and/c bytes? mutable?)]
[alpha? any/c #f])
void?]{
@ -87,7 +92,7 @@ Returns a copy of this bitmap's requested OpenGL configuration. See
}
@defmethod[(get-height)
(integer-in 1 10000)]{
exact-positive-integer?]{
Gets the height of the bitmap in pixels.
@ -130,7 +135,7 @@ Unlike an alpha channel, the mask bitmap is @italic{not} used
}
@defmethod[(get-width)
(integer-in 1 10000)]{
exact-positive-integer?]{
Gets the width of the bitmap in pixels.

40
collects/scribblings/gui/bitmap-funcs.scrbl Normal file
View File

@ -0,0 +1,40 @@
#lang scribble/doc
@(require "common.ss")
@title{Bitmaps}
@defproc[(make-bitmap [width exact-positive-integer?]
[height exact-positive-integer?]
[alpha? any/c #t])
(is-a?/c bitmap%)]{
Returns @racket[(make-object bitmap% width height #f alpha?)], but
this procedure is preferred because it defaults @racket[alpha?] in a
more useful way.}
@defproc[(make-monochrome-bitmap [width exact-positive-integer?]
[height exact-positive-integer?]
[bits (or/c bytes? #f) #f])
(is-a?/c bitmap%)]{
Returns @racket[(make-object bitmap% width height #t)] if
@racket[bits] is @racket[#f], or @racket[(make-object bitmap% bits
width height)] otherwise. This procedure is preferred to using
@racket[make-object] on @racket[bitmap%] because it is less
overloaded.}
@defproc[(read-bitmap [in (or path-string? input-port?)]
[kind (one-of/c '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)
'unknown/alpha])
(is-a?/c bitmap%)]{
Returns @racket[(make-object bitmap% in kind)], but this procedure is
preferred because it defaults @racket[kind] in a more useful way.}

1
collects/scribblings/gui/draw-funcs.scrbl
View File

@ -8,4 +8,5 @@
@include-section["global-draw-funcs.scrbl"]
@include-section["post-script-funcs.scrbl"]
@include-section["draw-list-funcs.scrbl"]
@include-section["bitmap-funcs.scrbl"]
@include-section["font-funcs.scrbl"]

7
collects/scribblings/gui/gui.scrbl
View File

@ -7,14 +7,9 @@
@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
@racketmodname[racket/gui/base] library provides all of the class,
interface, and procedure bindings defined in this manual. At run time,
this library needs primitive graphics support that the GRacket executable
provides; this library cannot run inside the Racket executable.}
interface, and procedure bindings defined in this manual.}
@defmodulelang*/no-declare[(racket/gui)]{The
@racketmodname[racket/gui] language combines all bindings of the

15
collects/scribblings/reference/exit.scrbl
View File

@ -21,3 +21,18 @@ argument is used as the OS-level exit code if it is an exact integer
between @racket[1] and @racket[255] (which normally means
``failure''); otherwise, the exit code is @racket[0], (which normally
means ``success'').}
@defparam[executable-yield-handler proc ((integer-in 0 255) . -> . any)]{
A parameter that determines a procedure to be called as the Racket
process is about to exit normally. The procedure associated with this
parameter is not call when @racket[exit] (or, more precisely, the
defauly @tech{exit handler}) is used to exit early. The argument to
the handler is the status code that is returned to the system on exit.
The default executable-yield handler simply returns @|void-const|.
The @racketmodname[scheme/gui/base] library sets this parameter to
wait until all frames are closed, timers stopped, and queued events
handled in the main eventspace. See @racketmodname[scheme/gui/base]
for more information.}

10
collects/waterworld/waterworld.rkt
View File

@ -79,16 +79,16 @@
(define *checking-message*
"Considering your move ...")
(define (make-bitmap s)
(define (make-wbitmap s)
(make-object bitmap%
(build-path
(collection-path "waterworld") s) 'gif))
(define *jolly-bitmap* #f)
(define *jolly-ce-bitmap* #f)
(define *jolly-large-bitmap* (make-bitmap "jolly-large.gif"))
(define *jolly-small-bitmap* (make-bitmap "jolly-small.gif"))
(define *jolly-large-ce-bitmap* (make-bitmap "jolly-large-ce.gif"))
(define *jolly-small-ce-bitmap* (make-bitmap "jolly-small-ce.gif"))
(define *jolly-large-bitmap* (make-wbitmap "jolly-large.gif"))
(define *jolly-small-bitmap* (make-wbitmap "jolly-small.gif"))
(define *jolly-large-ce-bitmap* (make-wbitmap "jolly-large-ce.gif"))
(define *jolly-small-ce-bitmap* (make-wbitmap "jolly-small-ce.gif"))
(define *jolly-small-desc* (list *jolly-small-bitmap* *jolly-small-ce-bitmap* 16 16))
(define *jolly-large-desc* (list *jolly-large-bitmap* *jolly-large-ce-bitmap* 23 27))

164
doc/release-notes/racket/Draw_and_GUI_5_5.txt
View File

@ -1,59 +1,89 @@
Changes:
GRacket, Racket, Drawing, and GUIs
----------------------------------
* The drawing portion of the old GUI toolbox is now available as a
separate layer: `racket/draw'. This layer can be used from plain
Racket independent of the `racket/gui' library, although
`racket/gui' re-exports `racket/draw'.
Version 5.5 includes two major changes to the Racket drawing and GUI
API:
The `racket/draw' library is built on top of the widely used Cairo
drawing library and Pango text-rendering library.
* The drawing portion of the GUI toolbox is now available as a
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
a canvas. Use the `make-screen-bitmap' function (from `racket/gui')
or the `make-bitmap' method of `canvas%' to obtain a bitmap that
uses the same drawing algorithms as a canvas.
(The `racket/draw' library is built on top of the widely used Cairo
drawing library and Pango text-rendering library.)
Drawing to a canvas always draws into a bitmap that is kept
offscreen 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 GRacket executable is no longer strictly necessary for running
GUI programs; the `racket/gui/base' library can be used from
Racket.
* A color bitmap can have an alpha channel, instead of just a mask
The GRacket executable still offers some additional GUI-specific
functiontality however. Most notably, GRacket is a GUI application
under Windows (as opposed to a console application, which is
launched slightly differently by the OS), GRacket is a bundle under
Mac OS X (so the dock icon is the Racket logo, for example), and
GRacket manages single-instance mode for Windows and X.
The drawing and GUI libraries have also changed in further small ways.
Bitmaps
-------
Drawing to a bitmap may not produce the same results as drawing to a
canvas. Use the `make-screen-bitmap' function (from `racket/gui') or
the `make-bitmap' method of `canvas%' to obtain a bitmap that uses the
same drawing algorithms as a canvas.
A color bitmap can have an alpha channel, instead of just a mask
bitmap. When drawing a bitmap, alpha channels are used more
consistently and automatically than mask bitmaps. More
significantly, 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.
consistently and automatically than mask bitmaps. More significantly,
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.
Create a bitmap with an alpha channel by supplying #t as the new
`alpha?' argument to the `bitmap%' constructor, or by loading an
image with a type like 'unknown/alpha insteda of 'unknown or
'unknown/mask.
Only bitmaps created with the new `make-gl-bitmap' function support
OpenGL drawing.
A newly created `bitmap%' has an empty content (i.e., white with
zero alpha), insteda of unspecified content.
Use the new `make-bitmap', `read-bitmap', `make-monochrome-bitmap',
`make-screen-bitmap', and `make-gl-bitmap' functions to create
bitmaps, instead of using `make-object' with `bitmap%'. The new
constructors are less overloaded and provide more modern defaults
(such as alpha channels by default).
Images can be read into a `bitmap%' from from input ports, instead
of requiring a file path.
Image formats can be read into a `bitmap%' from from input ports,
instead of requiring a file path. A newly created bitmap has an empty
content (i.e., white with zero alpha), instead of unspecified content.
* A `dc<%>' supports additional drawing transformations: a rotation
(via `set-rotation') and a general transformation matrix (via
`set-initial-matrix'). Scaling factors can be negative, which
corresponds to flipping the direction of drawing.
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.
Canvases
--------
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.
Drawing to a canvas always draws into a bitmap that is kept offscreen
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.
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.
Drawing-Context Transformations
-------------------------------
A `dc<%>' instance supports rotation (via `set-rotation'), negative
scaling factors for flipping, and a general transformation matrix (via
`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
@ -62,35 +92,39 @@ Changes:
backward-compatibile. Methods like `get-translation',
`set-translation', `scale', etc. help hide the reundancy.
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'.
Others Drawing-Context Changes
------------------------------
* 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 alpha value of a `dc<%>' (as set by `set-alpha') is used for all
drawing operations, including drawing a bitmap.
* The old 'xor mode for pens and brushes is no longer available
(since it is not supported by Cairo).
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'.
* The `draw-caret' argument to a `snip%' or `editor<%>' `draw' or
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.
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
`make-gl-bitmap'.
Removed Functions
-----------------
* The `write-resource, `get-reource', and `send-event' functions have
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.

32
src/gracket/grmain.c
View File

@ -45,12 +45,9 @@ static void pre_filter_cmdline_arguments(int *argc, char ***argv);
#define INITIAL_BIN_TYPE "ri"
#define CMDLINE_STDIO_FLAG
#define YIELD_BEFORE_EXIT
#define INITIAL_NAMESPACE_MODULE "scheme/gui/init"
#define GRAPHICAL_REPL
static void yield_indefinitely();
# include "../racket/main.c"
static char *get_gr_init_filename(Scheme_Env *env)
@ -76,35 +73,6 @@ static char *get_gr_init_filename(Scheme_Env *env)
return s;
}
static void yield_indefinitely()
{
#ifdef MZ_PRECISE_GC
void *dummy;
#endif
mz_jmp_buf * volatile save, newbuf;
Scheme_Thread * volatile p;
Scheme_Object *a[2], *yld;
p = scheme_get_current_thread();
save = p->error_buf;
p->error_buf = &newbuf;
if (!scheme_setjmp(newbuf)) {
a[0] = scheme_intern_symbol("mred/mred");
a[1] = scheme_intern_symbol("yield");
yld = scheme_dynamic_require(2, a);
a[0] = scheme_intern_symbol("wait");
scheme_apply(yld, 1, a);
}
p->error_buf = save;
#ifdef MZ_PRECISE_GC
dummy = NULL; /* makes xform think that dummy is live, so we get a __gc_var_stack__ */
#endif
}
/***********************************************************************/
/* Win32 handling */
/***********************************************************************/

32
src/racket/cmdline.inc
View File

@ -150,7 +150,7 @@ typedef struct {
int use_repl;
int script_mode;
#endif
#ifdef YIELD_BEFORE_EXIT
#ifndef NO_YIELD_BEFORE_EXIT
int add_yield;
#endif
#ifdef CMDLINE_STDIO_FLAG
@ -433,7 +433,7 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
exit_val = 0;
} else {
exit_val = 1;
#ifdef YIELD_BEFORE_EXIT
#ifndef NO_YIELD_BEFORE_EXIT
fa->a->add_yield = 0;
#endif
}
@ -441,15 +441,18 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
}
#endif /* DONT_RUN_REP */
#ifdef YIELD_BEFORE_EXIT
#ifndef NO_YIELD_BEFORE_EXIT
if (fa->a->add_yield) {
mz_jmp_buf * volatile save, newbuf;
Scheme_Thread * volatile p;
Scheme_Object *yh, *yha[1];
p = scheme_get_current_thread();
save = p->error_buf;
p->error_buf = &newbuf;
if (!scheme_setjmp(newbuf)) {
yield_indefinitely();
yh = scheme_get_param(scheme_current_config(), MZCONFIG_EXE_YIELD_HANDLER);
yha[0] = scheme_make_integer(exit_val);
scheme_apply(yh, 1, yha);
}
p->error_buf = save;
}
@ -564,7 +567,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
#if !defined(DONT_LOAD_INIT_FILE) || !defined(DONT_PARSE_COMMAND_LINE)
int no_init_file = 0;
#endif
#ifdef YIELD_BEFORE_EXIT
#ifndef NO_YIELD_BEFORE_EXIT
int add_yield = 1;
#endif
#ifdef CMDLINE_STDIO_FLAG
@ -800,9 +803,9 @@ static int run_from_cmd_line(int argc, char *_argv[],
else if (!strcmp("--stdio", argv[0]))
argv[0] = "-z";
else if (!strcmp("--back", argv[0]))
argv[0] = "-G";
argv[0] = "-K";
# endif
# ifdef YIELD_BEFORE_EXIT
# ifndef NO_YIELD_BEFORE_EXIT
else if (!strcmp("--no-yield", argv[0]))
argv[0] = "-V";
# endif
@ -988,7 +991,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
case 'v':
show_vers = 1;
break;
#ifdef YIELD_BEFORE_EXIT
#ifndef NO_YIELD_BEFORE_EXIT
case 'V':
show_vers = 1;
add_yield = 0;
@ -1022,6 +1025,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
break;
case 'K':
no_front = 1;
was_config_flag = 1;
break;
#endif
#ifdef USE_OSKIT_CONSOLE
@ -1212,12 +1216,14 @@ static int run_from_cmd_line(int argc, char *_argv[],
fa->a->use_repl = use_repl;
fa->a->script_mode = script_mode;
#endif
#ifdef YIELD_BEFORE_EXIT
#ifndef NO_YIELD_BEFORE_EXIT
fa->a->add_yield = add_yield;
#endif
#ifdef CMDLINE_STDIO_FLAG
fa->a->alternate_rep = alternate_rep;
fa->a->no_front = no_front;
if (no_front)
scheme_register_process_global("Racket-GUI-no-front", (void *)0x1);
#endif
fa->init_lib = init_lib;
fa->global_env = global_env;
@ -1256,8 +1262,8 @@ static int run_from_cmd_line(int argc, char *_argv[],
# ifdef CMDLINE_STDIO_FLAG
" -K, --back : Don't bring application to the foreground (Mac OS X)\n"
# endif
# ifdef YIELD_BEFORE_EXIT
" -V, --no-yield : Don't `(yield 'wait)'\n"
# ifndef NO_YIELD_BEFORE_EXIT
" -V, --no-yield : Skip `((executable-yield-handler) <status>)' on exit\n"
# endif
" Configuration options:\n"
" -c, --no-compiled : Disable loading of compiled files\n"
@ -1298,8 +1304,8 @@ static int run_from_cmd_line(int argc, char *_argv[],
" 3. Evaluate/load expressions/files in order, until first error\n"
" 4. Load \"" INIT_FILENAME "\" [when -i]\n"
" 5. Run read-eval-print loop [when -i]\n"
# ifdef YIELD_BEFORE_EXIT
" 6. Run `(yield 'wait)' [unless -V]\n"
# ifndef NO_YIELD_BEFORE_EXIT
" 6. Run `((executable-yield-handler) <status>)' [unless -V]\n"
# endif
);
PRINTF(prog, BANNER);

2
src/racket/include/scheme.h
View File

@ -1231,6 +1231,8 @@ enum {
MZCONFIG_ERROR_ESCAPE_HANDLER,
MZCONFIG_EXE_YIELD_HANDLER,
MZCONFIG_ALLOW_SET_UNDEFINED,
MZCONFIG_COMPILE_MODULE_CONSTS,
MZCONFIG_USE_JIT,

1763
src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

24
src/racket/src/error.c
View File

@ -71,6 +71,7 @@ ROSYM static Scheme_Object *def_err_val_proc;
ROSYM static Scheme_Object *def_error_esc_proc;
ROSYM static Scheme_Object *default_display_handler;
ROSYM static Scheme_Object *emergency_display_handler;
ROSYM static Scheme_Object *def_exe_yield_proc;
READ_ONLY Scheme_Object *scheme_def_exit_proc;
READ_ONLY Scheme_Object *scheme_raise_arity_error_proc;
@ -90,6 +91,7 @@ static Scheme_Object *error_escape_handler(int, Scheme_Object *[]);
static Scheme_Object *error_display_handler(int, Scheme_Object *[]);
static Scheme_Object *error_value_string_handler(int, Scheme_Object *[]);
static Scheme_Object *exit_handler(int, Scheme_Object *[]);
static Scheme_Object *exe_yield_handler(int, Scheme_Object *[]);
static Scheme_Object *error_print_width(int, Scheme_Object *[]);
static Scheme_Object *error_print_context_length(int, Scheme_Object *[]);
static Scheme_Object *error_print_srcloc(int, Scheme_Object *[]);
@ -98,6 +100,7 @@ static Scheme_Object *def_error_display_proc(int, Scheme_Object *[]);
static Scheme_Object *emergency_error_display_proc(int, Scheme_Object *[]);
static Scheme_Object *def_error_value_string_proc(int, Scheme_Object *[]);
static Scheme_Object *def_exit_handler_proc(int, Scheme_Object *[]);
static Scheme_Object *default_yield_handler(int, Scheme_Object *[]);
static Scheme_Object *log_message(int argc, Scheme_Object *argv[]);
static Scheme_Object *log_level_p(int argc, Scheme_Object *argv[]);
@ -570,6 +573,7 @@ void scheme_init_error(Scheme_Env *env)
GLOBAL_PARAMETER("error-value->string-handler", error_value_string_handler, MZCONFIG_ERROR_PRINT_VALUE_HANDLER, env);
GLOBAL_PARAMETER("error-escape-handler", error_escape_handler, MZCONFIG_ERROR_ESCAPE_HANDLER, env);
GLOBAL_PARAMETER("exit-handler", exit_handler, MZCONFIG_EXIT_HANDLER, env);
GLOBAL_PARAMETER("executable-yield-handler", exe_yield_handler, MZCONFIG_EXE_YIELD_HANDLER, env);
GLOBAL_PARAMETER("error-print-width", error_print_width, MZCONFIG_ERROR_PRINT_WIDTH, env);
GLOBAL_PARAMETER("error-print-context-length", error_print_context_length, MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH, env);
GLOBAL_PARAMETER("error-print-source-location", error_print_srcloc, MZCONFIG_ERROR_PRINT_SRCLOC, env);
@ -620,6 +624,11 @@ void scheme_init_error(Scheme_Env *env)
}
scheme_add_global_constant("prop:arity-string", arity_property, env);
REGISTER_SO(def_exe_yield_proc);
def_exe_yield_proc = scheme_make_prim_w_arity(default_yield_handler,
"default-executable-yield-handler",
1, 1);
}
void scheme_init_logger()
@ -639,6 +648,7 @@ void scheme_init_error_config(void)
scheme_set_root_param(MZCONFIG_EXIT_HANDLER, scheme_def_exit_proc);
scheme_set_root_param(MZCONFIG_ERROR_DISPLAY_HANDLER, default_display_handler);
scheme_set_root_param(MZCONFIG_ERROR_PRINT_VALUE_HANDLER, def_err_val_proc);
scheme_set_root_param(MZCONFIG_EXE_YIELD_HANDLER, def_exe_yield_proc);
}
void scheme_init_logger_config() {
@ -2569,6 +2579,20 @@ void scheme_immediate_exit(int status)
exit(status);
}
static Scheme_Object *
exe_yield_handler(int argc, Scheme_Object *argv[])
{
return scheme_param_config("exeuctable-yield-handler",
scheme_make_integer(MZCONFIG_EXE_YIELD_HANDLER),
argc, argv,
1, NULL, NULL, 0);
}
static Scheme_Object *default_yield_handler(int argc, Scheme_Object **argv)
{
return scheme_void;
}
/***********************************************************************/
void update_want_level(Scheme_Logger *logger)

2
src/racket/src/schminc.h
View File

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1014
#define EXPECTED_PRIM_COUNT 1015
#define EXPECTED_UNSAFE_COUNT 76
#define EXPECTED_FLFXNUM_COUNT 68
#define EXPECTED_FUTURES_COUNT 5

6
src/racket/src/schvers.h
View File

@ -13,11 +13,11 @@
consistently.)
*/
#define MZSCHEME_VERSION "5.0.2.1"
#define MZSCHEME_VERSION "5.4.99.1"
#define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 0
#define MZSCHEME_VERSION_Z 2
#define MZSCHEME_VERSION_Y 4
#define MZSCHEME_VERSION_Z 99
#define MZSCHEME_VERSION_W 1
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)