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)

62
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
;; hash[(list boolean[flip] number[x-scale] number[y-scale] number[angle]) -o> (cons (is-a?/c bitmap%) (is-a?/c bitmap%)])
;; - (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))

186
doc/release-notes/racket/Draw_and_GUI_5_5.txt
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
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
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.
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.
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.
The drawing and GUI libraries have also changed in further small ways.
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
of requiring a file path.
Bitmaps
-------
* 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.
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 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.
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.
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.
Only bitmaps created with the new `make-gl-bitmap' function support
OpenGL drawing.
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.
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).
The alpha value of a `dc<%>' (as set by `set-alpha') is used for
all drawing operations, including drawing a bitmap.
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.
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.
Canvases
--------
* The old 'xor mode for pens and brushes is no longer available
(since it is not supported by Cairo).
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 `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.
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.
* 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'.
Drawing-Context Transformations
-------------------------------
* 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.
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
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.

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)