Racket & GRacket relesae notes for 5.0.1

Merge to 5.0.1

original commit: e49f05a5cbb3e78e0ff051a7a6e35f2c35ab3a12
This commit is contained in:
Matthew Flatt 2010-07-20 09:24:58 -06:00
commit 10a8e6ad6e
18 changed files with 550 additions and 244 deletions

View File

@ -7,7 +7,7 @@
(define-runtime-path here ".") (define-runtime-path here ".")
(define standard-menus.ss-filename (simplify-path (build-path here "standard-menus.ss"))) (define standard-menus.rkt-filename (simplify-path (build-path here "standard-menus.rkt")))
(define docs-menus.ss-filename (simplify-path (build-path here 'up 'up "scribblings" "framework" "standard-menus.scrbl"))) (define docs-menus.ss-filename (simplify-path (build-path here 'up 'up "scribblings" "framework" "standard-menus.scrbl")))
;; build-before-super-item-clause : an-item -> (listof clause) ;; build-before-super-item-clause : an-item -> (listof clause)
@ -121,7 +121,7 @@
,(generic-initializer generic)))])) ,(generic-initializer generic)))]))
(define (main) (define (main)
(write-standard-menus.ss) (write-standard-menus.rkt)
(write-docs)) (write-docs))
(define (write-docs) (define (write-docs)
@ -202,10 +202,10 @@
(display docs-footer-text port)) (display docs-footer-text port))
#:exists 'truncate)) #:exists 'truncate))
(define (write-standard-menus.ss) (define (write-standard-menus.rkt)
(printf "writing to ~a~n" standard-menus.ss-filename) (printf "writing to ~a~n" standard-menus.rkt-filename)
(call-with-output-file standard-menus.ss-filename (call-with-output-file standard-menus.rkt-filename
(λ (port) (λ (port)
(pretty-print (pretty-print
`(define standard-menus<%> `(define standard-menus<%>

View File

@ -208,7 +208,7 @@
(let ([hash-table (make-hasheq)]) (let ([hash-table (make-hasheq)])
(for-each (λ (x) (for-each (λ (x)
(hash-set! hash-table x 'define)) (hash-set! hash-table x 'define))
'(local)) '(struct local))
(for-each (λ (x) (for-each (λ (x)
(hash-set! hash-table x 'begin)) (hash-set! hash-table x 'begin))
'(case-lambda '(case-lambda

View File

@ -280,7 +280,7 @@
(string-constant quit-menu-item-windows) (string-constant quit-menu-item-windows)
(string-constant quit-menu-item-others)) (string-constant quit-menu-item-others))
on-demand-do-nothing on-demand-do-nothing
'(not (current-eventspace-has-standard-menus?))) '(not (eq? (system-type) 'macosx)))
(make-after 'file-menu 'quit 'nothing) (make-after 'file-menu 'quit 'nothing)
(make-an-item 'edit-menu 'undo (make-an-item 'edit-menu 'undo

View File

@ -1,5 +1,4 @@
#reader scribble/reader #lang at-exp scheme/gui
#lang scheme/gui
(require scribble/srcdoc) (require scribble/srcdoc)
(require/doc scheme/base scribble/manual) (require/doc scheme/base scribble/manual)
@ -355,8 +354,7 @@
state in-cb state in-cb
(build-labels rb))] (build-labels rb))]
[else (let ([i (- total n)]) [else (let ([i (- total n)])
(if (or (string=? state (send rb get-item-label i)) (if (ith-item-matches? rb state i)
(string=? state (send rb get-item-plain-label i)))
(if (send rb is-enabled? i) (if (send rb is-enabled? i)
(send rb set-selection i) (send rb set-selection i)
(error 'test:set-radio-box! (error 'test:set-radio-box!
@ -371,6 +369,15 @@
"expected a string or a number as second arg, got: ~e (other arg: ~e)" "expected a string or a number as second arg, got: ~e (other arg: ~e)"
state in-cb)])))) state in-cb)]))))
(define (ith-item-matches? rb state i)
(cond
[(string? state)
(or (string=? state (send rb get-item-label i))
(string=? state (send rb get-item-plain-label i)))]
[(regexp? state)
(or (regexp-match state (send rb get-item-label i))
(regexp-match state (send rb get-item-plain-label i)))]))
;; set-radio-box-item! : string -> void ;; set-radio-box-item! : string -> void
(define (set-radio-box-item! state) (define (set-radio-box-item! state)
(control-action (control-action
@ -383,8 +390,7 @@
(cond (cond
[(zero? n) (error 'test:set-radio-box-item! "internal error")] [(zero? n) (error 'test:set-radio-box-item! "internal error")]
[else (let ([i (- total n)]) [else (let ([i (- total n)])
(if (or (string=? state (send rb get-item-label i)) (if (ith-item-matches? rb state i)
(string=? state (send rb get-item-plain-label i)))
(if (send rb is-enabled? i) (if (send rb is-enabled? i)
(send rb set-selection i) (send rb set-selection i)
(error 'test:set-radio-box! (error 'test:set-radio-box!
@ -392,14 +398,23 @@
state)) state))
(loop (- n 1))))])))))) (loop (- n 1))))]))))))
;; entry-matches : string -> radio-box -> boolean ;; entry-matches : string | regexp -> radio-box -> boolean
(define (entry-matches name) (define (entry-matches name)
(λ (rb) (λ (rb)
(let loop ([n (send rb get-number)]) (let loop ([n (send rb get-number)])
(and (not (zero? n)) (cond
(or (equal? name (send rb get-item-label (- n 1))) [(zero? n) #f]
(equal? name (send rb get-item-plain-label (- n 1))) [else
(loop (- n 1))))))) (let ([itm (send rb get-item-label (- n 1))]
[pln-itm (send rb get-item-plain-label (- n 1))])
(or (cond
[(string? name)
(or (equal? name itm)
(equal? name pln-itm))]
[(regexp? name)
(or (regexp-match name itm)
(regexp-match name pln-itm))])
(loop (- n 1))))]))))
;;; CHOICE ;;; CHOICE
@ -844,11 +859,12 @@
(proc-doc/names (proc-doc/names
test:set-radio-box! test:set-radio-box!
(-> (or/c string? (is-a?/c radio-box%)) (or/c string? number?) void?) (-> (or/c string? regexp? (is-a?/c radio-box%)) (or/c string? number?) void?)
(radio-box state) (radio-box state)
@{Sets the radio-box to @scheme[state]. If @scheme[state] is a @{Sets the radio-box to the label matching @scheme[state]. If @scheme[state] is a
string, this function finds the choice with that label and string, this function finds the choice with that label.
if it is a number, it uses the number as an index into the If it is a regexp, this function finds the first choice whose label matches the regexp.
If it is a number, it uses the number as an index into the
state. If the number is out of range or if the label isn't state. If the number is out of range or if the label isn't
in the radio box, an exception is raised. in the radio box, an exception is raised.
@ -858,9 +874,9 @@
(proc-doc/names (proc-doc/names
test:set-radio-box-item! test:set-radio-box-item!
(-> string? void?) (-> (or/c string? regexp?) void?)
(entry) (entry)
@{Finds a @scheme[radio-box%] that has a label @scheme[entry] @{Finds a @scheme[radio-box%] that has a label matching @scheme[entry]
and sets the radio-box to @scheme[entry].}) and sets the radio-box to @scheme[entry].})
(proc-doc/names (proc-doc/names

View File

@ -1,5 +1,5 @@
(module mred mzscheme (module mred mzscheme
(require (only scheme/base (require (only racket/base
define-namespace-anchor define-namespace-anchor
namespace-anchor->empty-namespace namespace-anchor->empty-namespace
make-base-empty-namespace) make-base-empty-namespace)
@ -57,6 +57,9 @@
(wx:set-dialogs get-file put-file get-ps-setup-from-user message-box) (wx:set-dialogs get-file put-file get-ps-setup-from-user message-box)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; These functions are re-implemented in scheme/gui/base
;; and racket/gui/base to attach those names, instead of
;; just 'mred.
(define-namespace-anchor anchor) (define-namespace-anchor anchor)
@ -75,6 +78,8 @@
(namespace-require 'scheme/class)) (namespace-require 'scheme/class))
ns)) ns))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-eventspace) (define (make-eventspace)
(parameterize ([wx:the-snip-class-list (wx:make-the-snip-class-list)] (parameterize ([wx:the-snip-class-list (wx:make-the-snip-class-list)]
[wx:the-editor-data-class-list (wx:make-the-editor-data-class-list)]) [wx:the-editor-data-class-list (wx:make-the-editor-data-class-list)])

View File

@ -159,6 +159,7 @@
(define changed? #f) (define changed? #f)
(define prev-mouse-snip #f)
(super-new) (super-new)
@ -241,28 +242,42 @@
(def/override (on-event [mouse-event% event]) (def/override (on-event [mouse-event% event])
(when s-admin (when s-admin
(let-values ([(dc x y scrollx scrolly) (let-values ([(dc x y scrollx scrolly)
(if (or (send event button-down?) s-caret-snip) ;; first, find clicked-on snip:
;; first, find clicked-on snip: (let ([x (send event get-x)]
(let ([x (send event get-x)] [y (send event get-y)])
[y (send event get-y)]) (let-boxes ([scrollx 0.0]
(let-boxes ([scrollx 0.0] [scrolly 0.0]
[scrolly 0.0] [dc #f])
[dc #f]) (set-box! dc (send s-admin get-dc scrollx scrolly))
(set-box! dc (send s-admin get-dc scrollx scrolly)) ;; FIXME: old code returned if !dc
;; FIXME: old code returned if !dc (values dc (+ x scrollx) (+ y scrolly) scrollx scrolly)))])
(values dc (+ x scrollx) (+ y scrolly) scrollx scrolly))) (let ([snip (find-snip x y)])
(values #f 0.0 0.0 0.0 0.0))]) (when (and prev-mouse-snip
(let ([snip (if (send event button-down?) (not (eq? snip prev-mouse-snip)))
(find-snip x y) (let ([loc (snip-loc prev-mouse-snip)])
s-caret-snip)]) (send prev-mouse-snip on-event
(if (and snip
(eq? snip s-caret-snip))
(let ([loc (snip-loc snip)])
(send s-caret-snip on-event
dc (- (loc-x loc) scrollx) (- (loc-y loc) scrolly) dc (- (loc-x loc) scrollx) (- (loc-y loc) scrolly)
(loc-x loc) (loc-y loc) (loc-x loc) (loc-y loc)
event)) event)))
(on-local-event event)))))) (set! prev-mouse-snip #f)
(when (and snip
(has-flag? (snip->flags snip) HANDLES-ALL-MOUSE-EVENTS)
(not (eq? snip s-caret-snip)))
(let ([loc (snip-loc snip)])
(set! prev-mouse-snip snip)
(send snip on-event
dc (- (loc-x loc) scrollx) (- (loc-y loc) scrolly)
(loc-x loc) (loc-y loc)
event)))
(if (and s-caret-snip
(or (not (send event button-down?))
(eq? snip s-caret-snip)))
(let ([loc (snip-loc s-caret-snip)])
(send s-caret-snip on-event
dc (- (loc-x loc) scrollx) (- (loc-y loc) scrolly)
(loc-x loc) (loc-y loc)
event))
(on-local-event event))))))
(def/override (on-default-event [mouse-event% event]) (def/override (on-default-event [mouse-event% event])
(when s-admin (when s-admin
@ -729,6 +744,8 @@
(define/private (-delete del-snip del) (define/private (-delete del-snip del)
(when (snip-loc del-snip) (when (snip-loc del-snip)
(when (eq? del-snip prev-mouse-snip)
(set! prev-mouse-snip #f))
(set! write-locked (add1 write-locked)) (set! write-locked (add1 write-locked))
(begin-edit-sequence) (begin-edit-sequence)
(let ([ok? (or (can-delete? del-snip) (let ([ok? (or (can-delete? del-snip)

View File

@ -170,6 +170,8 @@
(define sticky-styles? #t) (define sticky-styles? #t)
(define overwrite-mode? #f) (define overwrite-mode? #f)
(define prev-mouse-snip #f)
(def/public (set-styles-sticky [bool? s?]) (set! sticky-styles? (and s? #t))) (def/public (set-styles-sticky [bool? s?]) (set! sticky-styles? (and s? #t)))
(def/public (get-styles-sticky) sticky-styles?) (def/public (get-styles-sticky) sticky-styles?)
@ -441,18 +443,15 @@
(not (send event leaving?))) (not (send event leaving?)))
(end-streaks '(except-key-sequence cursor delayed))) (end-streaks '(except-key-sequence cursor delayed)))
(let-values ([(dc x y scrollx scrolly) (let-values ([(dc x y scrollx scrolly)
(if (or (send event button-down?) s-caret-snip) ;; first, find clicked-on snip:
;; first, find clicked-on snip: (let ([x (send event get-x)]
(let ([x (send event get-x)] [y (send event get-y)])
[y (send event get-y)]) (let-boxes ([scrollx 0.0]
(let-boxes ([scrollx 0.0] [scrolly 0.0]
[scrolly 0.0] [dc #f])
[dc #f]) (set-box! dc (send s-admin get-dc scrollx scrolly))
(set-box! dc (send s-admin get-dc scrollx scrolly)) ;; FIXME: old code returned if !dc
;; FIXME: old code returned if !dc (values dc (+ x scrollx) (+ y scrolly) scrollx scrolly)))])
(values dc (+ x scrollx) (+ y scrolly) scrollx scrolly)))
(values #f 0.0 0.0 0.0 0.0))])
(when (send event button-down?)
(let ([snip (let ([snip
(let-boxes ([onit? #f] (let-boxes ([onit? #f]
[how-close 0.0] [how-close 0.0]
@ -476,12 +475,26 @@
#f #f
snip))) snip)))
#f)))]) #f)))])
(set-caret-owner snip))) (when (send event button-down?)
(if (and s-caret-snip (has-flag? (snip->flags s-caret-snip) HANDLES-EVENTS)) (set-caret-owner snip))
(let-boxes ([x 0.0] [y 0.0]) (when (and prev-mouse-snip
(get-snip-position-and-location s-caret-snip #f x y) (not (eq? snip prev-mouse-snip)))
(send s-caret-snip on-event dc (- x scrollx) (- y scrolly) x y event)) (let-boxes ([x 0.0] [y 0.0])
(on-local-event event))))) (get-snip-position-and-location prev-mouse-snip #f x y)
(send prev-mouse-snip on-event dc (- x scrollx) (- y scrolly) x y event)))
(set! prev-mouse-snip #f)
(if (and s-caret-snip (has-flag? (snip->flags s-caret-snip) HANDLES-EVENTS))
(let-boxes ([x 0.0] [y 0.0])
(get-snip-position-and-location s-caret-snip #f x y)
(send s-caret-snip on-event dc (- x scrollx) (- y scrolly) x y event))
(begin
(when (and snip
(has-flag? (snip->flags snip) HANDLES-ALL-MOUSE-EVENTS))
(let-boxes ([x 0.0] [y 0.0])
(get-snip-position-and-location snip #f x y)
(set! prev-mouse-snip snip)
(send snip on-event dc (- x scrollx) (- y scrolly) x y event)))
(on-local-event event)))))))
(def/override (on-default-event [mouse-event% event]) (def/override (on-default-event [mouse-event% event])
(when s-admin (when s-admin
@ -4004,6 +4017,8 @@
(set! snip-count (add1 snip-count))))) (set! snip-count (add1 snip-count)))))
(define/private (delete-snip snip) (define/private (delete-snip snip)
(when (eq? snip prev-mouse-snip)
(set! prev-mouse-snip #f))
(cond (cond
[(snip->next snip) [(snip->next snip)
(splice-snip (snip->next snip) (snip->prev snip) (snip->next (snip->next snip)))] (splice-snip (snip->next snip) (snip->prev snip) (snip->next (snip->next snip)))]

View File

@ -1,4 +1,10 @@
#lang racket/base #lang racket/base
;; changed:
;; - simple-shape
;; - np-atomic-shape
;; - atomic-shape
#| #|
This library is the part of the 2htdp/image This library is the part of the 2htdp/image
@ -29,7 +35,9 @@ has been moved out).
(require racket/class (require racket/class
racket/gui/base racket/gui/base
racket/math racket/math
racket/contract
"private/image-core-bitmap.ss" "private/image-core-bitmap.ss"
(prefix-in cis: "cache-image-snip.ss")
(for-syntax racket/base)) (for-syntax racket/base))
(define-for-syntax id-constructor-pairs '()) (define-for-syntax id-constructor-pairs '())
@ -122,6 +130,7 @@ has been moved out).
;; - polygon ;; - polygon
;; - line-segment ;; - line-segment
;; - curve-segment ;; - curve-segment
;; - bitmap
;; - np-atomic-shape ;; - np-atomic-shape
;; a np-atomic-shape is: ;; a np-atomic-shape is:
@ -135,11 +144,22 @@ has been moved out).
(define-struct/reg-mk text (string angle y-scale color size face family style weight underline) (define-struct/reg-mk text (string angle y-scale color size face family style weight underline)
#:omit-define-syntaxes #:transparent) #:omit-define-syntaxes #:transparent)
;; ;;
;; - flip
;; a bitmap is:
;; - (make-bitmap (is-a?/c bitmap%) angle positive-real (or/c #f (is-a?/c bitmap%))) ;; - (make-bitmap (is-a?/c bitmap%) angle positive-real (or/c #f (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 [rendered-bitmap #:mutable] [rendered-mask #:mutable]) (define-struct/reg-mk bitmap (raw-bitmap raw-mask angle x-scale y-scale [rendered-bitmap #:mutable] [rendered-mask #:mutable])
#:omit-define-syntaxes #:transparent) #:omit-define-syntaxes #:transparent)
;; a flip is:
;; - (make-flip boolean bitmap)
;; * the boolean is #t if the bitmap should be flipped vertically (after applying whatever rotation is in there)
;; * this struct is here to avoid adding a field to bitmaps, so that old save files
;; from when the library did not support flipping still load
;; (since normalization will add a flip structure if necessary)
(define-struct/reg-mk flip (flipped? shape))
;; a polygon is: ;; a polygon is:
;; ;;
;; - (make-polygon (listof vector) mode color) ;; - (make-polygon (listof vector) mode color)
@ -164,7 +184,7 @@ has been moved out).
;; - (make-crop (listof points) normalized-shape) ;; - (make-crop (listof points) normalized-shape)
;; a simple-shape (subtype of shape) is ;; a simple-shape (subtype of shape) is
;; - (make-translate dx dy np-atomic-shape)) ;; - (make-translate dx dy np-atomic-shape)
;; - polygon ;; - polygon
;; - line-segment ;; - line-segment
;; - curve-segment ;; - curve-segment
@ -213,21 +233,26 @@ has been moved out).
(init-field shape bb normalized?) (init-field shape bb normalized?)
(define/public (equal-to? that eq-recur) (define/public (equal-to? that eq-recur)
(or (eq? this that) (or (eq? this that)
(and (is-a? that image%) (let ([that
(same-bb? bb (send that get-bb)) (cond
(or (and (not (skip-image-equality-fast-path)) ;; this is here to make testing more effective [(is-a? that image-snip%) (image-snip->image that)]
(equal? (get-normalized-shape) (send that get-normalized-shape))) [(is-a? that bitmap%) (bitmap->image that)]
(let ([w (+ 1 (round (inexact->exact (bb-right bb))))] ;; some shapes (ie, rectangles) draw 1 outside the bounding box [else that])])
[h (+ 1 (round (inexact->exact (bb-bottom bb))))]) ;; so we make the bitmap slightly bigger to accomodate that. (and (is-a? that image%)
(or (zero? w) (same-bb? bb (send that get-bb))
(zero? h) (or (and (not (skip-image-equality-fast-path)) ;; this is here to make testing more effective
(let ([bm1 (make-object bitmap% w h)] (equal? (get-normalized-shape) (send that get-normalized-shape)))
[bm2 (make-object bitmap% w h)] (let ([w (+ 1 (round (inexact->exact (bb-right bb))))] ;; some shapes (ie, rectangles) draw 1 outside the bounding box
[bytes1 (make-bytes (* w h 4) 0)] [h (+ 1 (round (inexact->exact (bb-bottom bb))))]) ;; so we make the bitmap slightly bigger to accomodate that.
[bytes2 (make-bytes (* w h 4) 0)] (or (zero? w)
[bdc (make-object bitmap-dc%)]) (zero? h)
(and (check-same? bm1 bm2 bytes1 bytes2 bdc "red" that) (let ([bm1 (make-object bitmap% w h)]
(check-same? bm1 bm2 bytes1 bytes2 bdc "green" that))))))))) [bm2 (make-object bitmap% w h)]
[bytes1 (make-bytes (* w h 4) 0)]
[bytes2 (make-bytes (* w h 4) 0)]
[bdc (make-object bitmap-dc%)])
(and (check-same? bm1 bm2 bytes1 bytes2 bdc "red" that)
(check-same? bm1 bm2 bytes1 bytes2 bdc "green" that))))))))))
(define/private (check-same? bm1 bm2 bytes1 bytes2 bdc color that) (define/private (check-same? bm1 bm2 bytes1 bytes2 bdc color that)
(clear-bitmap/draw/bytes bm1 bdc bytes1 this color) (clear-bitmap/draw/bytes bm1 bdc bytes1 this color)
@ -369,9 +394,49 @@ has been moved out).
(define-id->constructor id->constructor) (define-id->constructor id->constructor)
(define (normalized-shape? s)
(cond
[(overlay? s)
(and (normalized-shape? (overlay-top s))
(cn-or-simple-shape? (overlay-bottom s)))]
[else
(cn-or-simple-shape? s)]))
(define (cn-or-simple-shape? s)
(cond
[(crop? s)
(normalized-shape? (crop-shape s))]
[else
(simple-shape? s)]))
(define (simple-shape? shape)
(or (and (translate? shape)
(np-atomic-shape? (translate-shape shape)))
(polygon? shape)
(line-segment? shape)
(curve-segment? shape)))
(define (atomic-shape? shape)
(or (polygon? shape)
(line-segment? shape)
(curve-segment? shape)
(bitmap? shape)
(np-atomic-shape? shape)))
(define (np-atomic-shape? shape)
(or (ellipse? shape)
(text? shape)
(and (flip? shape)
(boolean? (flip-flipped? shape))
(bitmap? (flip-shape shape)))))
;; normalize-shape : shape (atomic-shape -> atomic-shape) -> normalized-shape ;; normalize-shape : shape (atomic-shape -> atomic-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.
(define (normalize-shape shape [f values]) (define/contract (normalize-shape shape [f values])
(->* (any/c) ;; should be shape?
((-> any/c any/c))
normalized-shape?)
(let loop ([shape shape] (let loop ([shape shape]
[dx 0] [dx 0]
[dy 0] [dy 0]
@ -443,50 +508,20 @@ has been moved out).
(if bottom (if bottom
(make-overlay bottom (f this-one)) (make-overlay bottom (f this-one))
(f this-one)))] (f this-one)))]
[(np-atomic-shape? shape) [(or (bitmap? shape) (np-atomic-shape? shape))
(let ([this-one (let ([shape (if (bitmap? shape)
(make-translate dx dy (scale-np-atomic x-scale y-scale shape))]) (make-flip #f shape)
(if bottom shape)])
(make-overlay bottom (f this-one)) (let ([this-one
(f this-one)))] (make-translate dx dy (scale-np-atomic x-scale y-scale shape))])
(if bottom
(make-overlay bottom (f this-one))
(f this-one))))]
[else [else
(error 'normalize-shape "unknown shape ~s\n" shape)]))) (error 'normalize-shape "unknown shape ~s\n" shape)])))
(define (normalized-shape? s) (define/contract (scale-np-atomic x-scale y-scale shape)
(cond (-> number? number? np-atomic-shape? np-atomic-shape?)
[(overlay? s)
(and (normalized-shape? (overlay-top s))
(cn-or-simple-shape? (overlay-bottom s)))]
[else
(cn-or-simple-shape? s)]))
(define (cn-or-simple-shape? s)
(cond
[(crop? s)
(normalized-shape? (crop-shape s))]
[else
(simple-shape? s)]))
(define (simple-shape? shape)
(or (and (translate? shape)
(np-atomic-shape? (translate-shape shape)))
(polygon? shape)
(line-segment? shape)
(curve-segment? shape)))
(define (atomic-shape? shape)
(or (polygon? shape)
(line-segment? shape)
(curve-segment? shape)
(np-atomic-shape? shape)))
(define (np-atomic-shape? shape)
(or (ellipse? shape)
(text? shape)
(bitmap? shape)
(point? shape)))
(define (scale-np-atomic x-scale y-scale shape)
(cond (cond
[(ellipse? shape) [(ellipse? shape)
(make-ellipse (* x-scale (ellipse-width shape)) (make-ellipse (* x-scale (ellipse-width shape))
@ -508,13 +543,15 @@ has been moved out).
(text-style shape) (text-style shape)
(text-weight shape) (text-weight shape)
(text-underline shape))] (text-underline shape))]
[(bitmap? shape) [(flip? shape)
(make-bitmap (bitmap-raw-bitmap shape) (let ([bitmap (flip-shape shape)])
(bitmap-raw-mask shape) (make-flip (flip-flipped? shape)
(bitmap-angle shape) (make-bitmap (bitmap-raw-bitmap bitmap)
(* x-scale (bitmap-x-scale shape)) (bitmap-raw-mask bitmap)
(* y-scale (bitmap-y-scale shape)) (bitmap-angle bitmap)
#f #f)])) (* x-scale (bitmap-x-scale bitmap))
(* y-scale (bitmap-y-scale bitmap))
#f #f)))]))
(define (scale-color color x-scale y-scale) (define (scale-color color x-scale y-scale)
(cond (cond
@ -552,7 +589,13 @@ has been moved out).
[font (send dc get-font)] [font (send dc get-font)]
[fg (send dc get-text-foreground)] [fg (send dc get-text-foreground)]
[smoothing (send dc get-smoothing)]) [smoothing (send dc get-smoothing)])
(render-normalized-shape (send image get-normalized-shape) dc dx dy) (cond
[(is-a? image bitmap%)
(send dc draw-bitmap image dx dy)]
[(is-a? image image-snip%)
(send dc draw-bitmap (send image get-bitmap) dx dy)]
[else
(render-normalized-shape (send image get-normalized-shape) dc dx dy)])
(send dc set-pen pen) (send dc set-pen pen)
(send dc set-brush brush) (send dc set-brush brush)
(send dc set-font font) (send dc set-font font)
@ -652,15 +695,15 @@ has been moved out).
[else [else
(let ([dx (+ dx (translate-dx simple-shape))] (let ([dx (+ dx (translate-dx simple-shape))]
[dy (+ dy (translate-dy simple-shape))] [dy (+ dy (translate-dy simple-shape))]
[atomic-shape (translate-shape simple-shape)]) [np-atomic-shape (translate-shape simple-shape)])
(cond (cond
[(ellipse? atomic-shape) [(ellipse? np-atomic-shape)
(let* ([path (new dc-path%)] (let* ([path (new dc-path%)]
[ew (ellipse-width atomic-shape)] [ew (ellipse-width np-atomic-shape)]
[eh (ellipse-height atomic-shape)] [eh (ellipse-height np-atomic-shape)]
[θ (degrees->radians (ellipse-angle atomic-shape))] [θ (degrees->radians (ellipse-angle np-atomic-shape))]
[color (ellipse-color atomic-shape)] [color (ellipse-color np-atomic-shape)]
[mode (ellipse-mode atomic-shape)]) [mode (ellipse-mode np-atomic-shape)])
(let-values ([(rotated-width rotated-height) (ellipse-rotated-size ew eh θ)]) (let-values ([(rotated-width rotated-height) (ellipse-rotated-size ew eh θ)])
(send path ellipse 0 0 ew eh) (send path ellipse 0 0 ew eh)
(send path translate (- (/ ew 2)) (- (/ eh 2))) (send path translate (- (/ ew 2)) (- (/ eh 2)))
@ -669,26 +712,30 @@ has been moved out).
(send dc set-brush (mode-color->brush mode color)) (send dc set-brush (mode-color->brush mode color))
(send dc set-smoothing (mode-color->smoothing mode color)) (send dc set-smoothing (mode-color->smoothing mode color))
(send dc draw-path path dx dy)))] (send dc draw-path path dx dy)))]
[(bitmap? atomic-shape) [(flip? np-atomic-shape)
(let ([bm (get-rendered-bitmap atomic-shape)]) (let ([bm (get-rendered-bitmap np-atomic-shape)])
(send dc draw-bitmap (send dc draw-bitmap
bm bm
(- dx (/ (send bm get-width) 2)) (- dx (/ (send bm get-width) 2))
(- dy (/ (send bm get-height) 2)) (- dy (/ (send bm get-height) 2))
'solid 'solid
(send the-color-database find-color "black") (send the-color-database find-color "black")
(get-rendered-mask atomic-shape)))] (get-rendered-mask np-atomic-shape)))]
[(text? atomic-shape) [(text? np-atomic-shape)
(let ([θ (degrees->radians (text-angle atomic-shape))] (let ([θ (degrees->radians (text-angle np-atomic-shape))]
[font (send dc get-font)]) [font (send dc get-font)])
(send dc set-font (text->font atomic-shape)) (send dc set-font (text->font np-atomic-shape))
(send dc set-text-foreground (let ([color (get-color-arg (text-color np-atomic-shape))])
(or (send the-color-database find-color (text-color atomic-shape)) (send dc set-text-foreground
(send the-color-database find-color "black"))) (cond
(let-values ([(w h _1 _2) (send dc get-text-extent (text-string atomic-shape))]) [(string? color)
(or (send the-color-database find-color color)
(send the-color-database find-color "black"))]
[else color])))
(let-values ([(w h _1 _2) (send dc get-text-extent (text-string np-atomic-shape))])
(let ([p (- (make-rectangular dx dy) (let ([p (- (make-rectangular dx dy)
(* (make-polar 1 (- θ)) (make-rectangular (/ w 2) (/ h 2))))]) (* (make-polar 1 (- θ)) (make-rectangular (/ w 2) (/ h 2))))])
(send dc draw-text (text-string atomic-shape) (send dc draw-text (text-string np-atomic-shape)
(real-part p) (real-part p)
(imag-part p) (imag-part p)
#f 0 θ))))]))])) #f 0 θ))))]))]))
@ -741,43 +788,50 @@ the mask bitmap and the original bitmap are all together in a single bytes!
|# |#
(define (get-rendered-bitmap bitmap) (define (get-rendered-bitmap flip-bitmap)
(calc-renered-bitmap bitmap) (calc-rendered-bitmap flip-bitmap)
(bitmap-rendered-bitmap bitmap)) (bitmap-rendered-bitmap (flip-shape flip-bitmap)))
(define (get-rendered-mask bitmap) (define (get-rendered-mask flip-bitmap)
(calc-renered-bitmap bitmap) (calc-rendered-bitmap flip-bitmap)
(bitmap-rendered-mask bitmap)) (bitmap-rendered-mask (flip-shape flip-bitmap)))
(define (calc-renered-bitmap bitmap) (define (calc-rendered-bitmap flip-bitmap)
(unless (bitmap-rendered-bitmap bitmap) (let ([bitmap (flip-shape flip-bitmap)])
;; fill in the rendered bitmap with the raw bitmaps. (unless (bitmap-rendered-bitmap bitmap)
(set-bitmap-rendered-bitmap! bitmap (bitmap-raw-bitmap bitmap)) (let ([flipped? (flip-flipped? flip-bitmap)])
(set-bitmap-rendered-mask! bitmap (bitmap-raw-mask bitmap))
(cond
[(and (= 1 (bitmap-x-scale bitmap))
(= 1 (bitmap-y-scale bitmap))
(= 0 (bitmap-angle bitmap)))
;; if there's no scaling or rotation, we can just keep that bitmap.
(void)]
[(<= (* (bitmap-x-scale bitmap)
(bitmap-y-scale bitmap))
1)
;; since we prefer to rotate big things, we rotate first
(do-rotate bitmap)
(do-scale bitmap)]
[else
;; since we prefer to rotate big things, we scale first
(do-scale bitmap)
(do-rotate bitmap)])))
(define (do-rotate bitmap) ;; fill in the rendered bitmap with the raw bitmaps.
(set-bitmap-rendered-bitmap! bitmap (bitmap-raw-bitmap bitmap))
(set-bitmap-rendered-mask! bitmap (bitmap-raw-mask bitmap))
(cond
[(and (= 1 (bitmap-x-scale bitmap))
(= 1 (bitmap-y-scale bitmap))
(= 0 (bitmap-angle bitmap))
(not flipped?))
;; if there's no scaling, rotation or flipping, we can just keep that bitmap.
(void)]
[(<= (* (bitmap-x-scale bitmap)
(bitmap-y-scale bitmap))
1)
;; since we prefer to rotate big things, we rotate first
(do-rotate bitmap flipped?)
(do-scale bitmap)]
[else
;; since we prefer to rotate big things, we scale first
(do-scale bitmap)
(do-rotate bitmap flipped?)])))))
(define (do-rotate bitmap flip?)
(let ([θ (degrees->radians (bitmap-angle bitmap))]) (let ([θ (degrees->radians (bitmap-angle bitmap))])
(let-values ([(bytes w h) (bitmap->bytes (bitmap-rendered-bitmap bitmap) (let-values ([(bytes w h) (bitmap->bytes (bitmap-rendered-bitmap bitmap)
(bitmap-rendered-mask bitmap))]) (bitmap-rendered-mask bitmap))])
(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 θ)])
(let* ([bm (bytes->bitmap rotated-bytes rotated-w rotated-h)] (let* ([flipped-bytes (if flip?
(flip-bytes rotated-bytes w h)
rotated-bytes)]
[bm (bytes->bitmap flipped-bytes rotated-w rotated-h)]
[mask (send bm get-loaded-mask)]) [mask (send bm get-loaded-mask)])
(set-bitmap-rendered-bitmap! bitmap bm) (set-bitmap-rendered-bitmap! bitmap bm)
(set-bitmap-rendered-mask! bitmap mask)))))) (set-bitmap-rendered-mask! bitmap mask))))))
@ -914,6 +968,43 @@ the mask bitmap and the original bitmap are all together in a single bytes!
(send ans set-join (pen-join pen)) (send ans set-join (pen-join pen))
ans)) ans))
(define (to-img arg)
(cond
[(is-a? arg image-snip%) (image-snip->image arg)]
[(is-a? arg bitmap%) (bitmap->image arg)]
[else arg]))
(define (image-snip->image is)
(let ([bm (send is get-bitmap)])
(cond
[(not bm)
;; this might mean we have a cache-image-snip%
;; or it might mean we have a useless snip.
(let-values ([(w h) (if (is-a? is cis:cache-image-snip%)
(send is get-size)
(values 0 0))])
(make-image (make-polygon
(list (make-point 0 0)
(make-point w 0)
(make-point w h)
(make-point 0 h))
'solid "black")
(make-bb w h h)
#f))]
[else
(bitmap->image bm
(or (send is get-bitmap-mask)
(send bm get-loaded-mask)))])))
(define (bitmap->image bm [mask-bm (send bm get-loaded-mask)])
(let ([w (send bm get-width)]
[h (send bm get-height)])
(make-image (make-translate (/ w 2)
(/ h 2)
(make-bitmap bm mask-bm 0 1 1 #f #f))
(make-bb w h h)
#f)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -939,6 +1030,8 @@ the mask bitmap and the original bitmap are all together in a single bytes!
make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-x-scale bitmap-y-scale make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-x-scale bitmap-y-scale
bitmap-rendered-bitmap bitmap-rendered-mask bitmap-rendered-bitmap bitmap-rendered-mask
make-flip flip? flip-flipped? flip-shape
(struct-out color) (struct-out color)
degrees->radians degrees->radians
@ -954,7 +1047,11 @@ the mask bitmap and the original bitmap are all together in a single bytes!
skip-image-equality-fast-path skip-image-equality-fast-path
scale-np-atomic) scale-np-atomic
to-img
bitmap->image
image-snip->image)
;; method names ;; method names
(provide get-shape get-bb get-normalized? get-normalized-shape) (provide get-shape get-bb get-normalized? get-normalized-shape)

View File

@ -1,30 +1,27 @@
#lang scheme/gui #lang racket/gui
;; min-w, min-h : number -> contract
;; determines if the widths and heights are suitable
(define (min-w h) (flat-named-contract "draw-button-label-width" (lambda (w) (w . > . (- h (* 2 border-inset))))))
(define (min-h w) (flat-named-contract "draw-button-label-height" (lambda (h) (h . > . (* 2 border-inset)))))
(provide/contract (provide/contract
[get-left-side-padding (-> number?)] [get-left-side-padding (-> number?)]
[pad-xywh (number? number? (>=/c 0) (>=/c 0) . -> . (values number? number? (>=/c 0) (>=/c 0)))] [pad-xywh (-> number? number? (>=/c 0) (>=/c 0)
(values number? number? (>=/c 0) (>=/c 0)))]
[draw-button-label [draw-button-label
(->d ([dc (is-a?/c dc<%>)] (->d ([dc (is-a?/c dc<%>)]
[label (or/c false/c string?)] [label (or/c false/c string?)]
[x number?] [x number?]
[y number?] [y number?]
[w (and/c number? (min-w h))] [w number?]
[h (and/c number? (min-h w))] [h (and/c number? (>=/c (* 2 border-inset)))]
[mouse-over? boolean?] [mouse-over? boolean?]
[grabbed? boolean?] [grabbed? boolean?]
[button-label-font (is-a?/c font%)] [button-label-font (is-a?/c font%)]
[bkg-color (or/c false/c (is-a?/c color%) string?)]) [bkg-color (or/c false/c (is-a?/c color%) string?)])
() #:pre-cond
(w . > . (- h (* 2 border-inset)))
[result void?])] [result void?])]
[calc-button-min-sizes [calc-button-min-sizes
(->* ((is-a?/c dc<%>) string? (is-a?/c font%)) (->* ((is-a?/c dc<%>) string?)
() ((is-a?/c font%))
(values number? number?))]) (values number? number?))])
(provide name-message%) (provide name-message%)
@ -241,7 +238,7 @@
(define mouse-grabbed-color (make-object color% 100 100 100)) (define mouse-grabbed-color (make-object color% 100 100 100))
(define grabbed-fg-color (make-object color% 220 220 220)) (define grabbed-fg-color (make-object color% 220 220 220))
(define (calc-button-min-sizes dc label button-label-font) (define (calc-button-min-sizes dc label [button-label-font (send dc get-font)])
(let-values ([(w h a d) (send dc get-text-extent label button-label-font)]) (let-values ([(w h a d) (send dc get-text-extent label button-label-font)])
(let-values ([(px py pw ph) (pad-xywh 0 0 w h)]) (let-values ([(px py pw ph) (pad-xywh 0 0 w h)])
(values pw ph)))) (values pw ph))))

View File

@ -4,8 +4,10 @@
(provide rotate-bytes ;; : bytes int[width] int[height] radians[radians] -> bytes (provide rotate-bytes ;; : bytes int[width] int[height] radians[radians] -> bytes
flip-bytes ;; : bytes int[width] int[height] -> bytes
bitmap->bytes bitmap->bytes
bytes->bitmap) bytes->bitmap
linear-transform)
;; rotate-bitmap : (-> bytes? natural-number/c natural-number/c real? bytes?) ;; rotate-bitmap : (-> bytes? natural-number/c natural-number/c real? bytes?)
;; avoid a dependency on scheme/contract, which pulls in too much ;; avoid a dependency on scheme/contract, which pulls in too much
@ -76,6 +78,15 @@ instead of this scaling code, we use the dc<%>'s scaling code.
(send bm set-loaded-mask mask) (send bm set-loaded-mask mask)
bm)) bm))
(define (flip-bytes bmbytes w h)
(build-bmbytes
w h
(λ (x y)
(let ([new-x x]
[new-y (- h y 1)])
(bmbytes-ref/safe bmbytes w h new-x new-y)))))
#;
(define (rotate-bytes bmbytes w h theta) (define (rotate-bytes bmbytes w h theta)
(let* {[theta-rotation (exp (* i theta))] (let* {[theta-rotation (exp (* i theta))]
[theta-unrotation (make-rectangular (real-part theta-rotation) [theta-unrotation (make-rectangular (real-part theta-rotation)
@ -105,6 +116,89 @@ instead of this scaling code, we use the dc<%>'s scaling code.
(- (imag-part pre-image)))))) (- (imag-part pre-image))))))
new-w new-w
new-h))) new-h)))
;; linear transform: bytes width height <matrix coodinates> -> (values bytes width height)
;; The matrix is read like this:
;; +- -+
;; | a b |
;; | c d |
;; +- -+
;; The ai, bi, ci, and di are the coordinates of the inverse matrix
(define (linear-transform bmbytes w h a b c d)
(let-values ([(ai bi ci di)
(let ([k (/ (- (* a d) (* b c)))])
(values (* k d) (* k (- b))
(* k (- c)) (* k a)))])
;; mapp : <matrix> complex -> complex
;; applies the matrix represented by abcd(as in the picture above) to p
(define (mapp a b c d p)
(let ([x (real-part p)]
[y (imag-part p)])
(make-rectangular (+ (* a x) (* b y))
(+ (* c x) (* d y)))))
(let* {[f-rotation (λ (p) (mapp a b c d p))]
[f-unrotation (λ (p) (mapp ai bi ci di p))]
[ne (f-rotation w)]
[sw (f-rotation (* i (- h)))]
[se (f-rotation (make-rectangular w (- h)))]
[nw 0]
[pts (list ne sw se nw)]
[longitudes (map real-part pts)]
[latitudes (map imag-part pts)]
[east (apply max longitudes)]
[west (apply min longitudes)]
[nrth (apply max latitudes)]
[sth (apply min latitudes)]
[new-w (round/e (- east west))]
[new-h (round/e (- nrth sth))]}
(values (build-bmbytes new-w
new-h
(λ (x y)
(let* {[pre-image (f-unrotation (make-rectangular (+ west x 1/2) (- nrth y 1/2)))]}
(interpolate bmbytes w h
(real-part pre-image)
(- (imag-part pre-image))))))
new-w
new-h))))
(define (rotate-bytes bmbytes w h theta)
(let* ([theta-rotation (exp (* i theta -1))]
[x (real-part theta-rotation)]
[y (imag-part theta-rotation)])
(linear-transform
bmbytes w h
x (- y) y x)))
#;
(define (rotate-bytes bmbytes w h theta)
(let* {[theta-rotation (exp (* i theta))]
[theta-unrotation (make-rectangular (real-part theta-rotation)
(- (imag-part theta-rotation)))]
[f-rotation (λ (p) (* theta-rotation p))]
[f-unrotation (λ (p) (* theta-unrotation p))]
[ne (f-rotation w)]
[sw (f-rotation (* i (- h)))]
[se (f-rotation (make-rectangular w (- h)))]
[nw 0]
[pts (list ne sw se nw)]
[longitudes (map real-part pts)]
[latitudes (map imag-part pts)]
[east (apply max longitudes)]
[west (apply min longitudes)]
[nrth (apply max latitudes)]
[sth (apply min latitudes)]
[new-w (round/e (- east west))]
[new-h (round/e (- nrth sth))]}
(values (build-bmbytes new-w
new-h
(λ (x y)
(let* {[pre-image (f-unrotation (make-rectangular (+ west x 1/2) (- nrth y 1/2)))]}
(interpolate bmbytes w h
(real-part pre-image)
(- (imag-part pre-image))))))
new-w
new-h)))
;; Why the offsets of 1/2 in `rotate-bytes` and `interpolate`? ;; Why the offsets of 1/2 in `rotate-bytes` and `interpolate`?
;; We consider a pixel's RGB as a point-sample taken from the 'true' image, ;; We consider a pixel's RGB as a point-sample taken from the 'true' image,
;; where the RGB is the sample at the *center* of the square covered by the pixel. ;; where the RGB is the sample at the *center* of the square covered by the pixel.

View File

@ -8,7 +8,7 @@
@defclass[name-message% canvas% ()]{ @defclass[name-message% canvas% ()]{
A @scheme[name-message%] control displays a filename that the user can A @racket[name-message%] control displays a filename that the user can
click to show the filename's path and select one of the enclosing click to show the filename's path and select one of the enclosing
directories. Override the @method[name-message% on-choose-directory] directories. Override the @method[name-message% on-choose-directory]
method to handle the user's selection. method to handle the user's selection.
@ -16,7 +16,7 @@ method to handle the user's selection.
@defconstructor/auto-super[()]{ @defconstructor/auto-super[()]{
Passes all arguments to @scheme[super-init].} Passes all arguments to @racket[super-init].}
@defmethod[(on-choose-directory [dir path-string?]) @defmethod[(on-choose-directory [dir path-string?])
@ -42,7 +42,7 @@ Draws the control's current message.}
@defmethod[(set-hidden? [hidden? any/c]) @defmethod[(set-hidden? [hidden? any/c])
void?]{ void?]{
Calling this method with @scheme[#f] causes the name message Calling this method with @racket[#f] causes the name message
to become invisible and to stop responding to mouse movements. to become invisible and to stop responding to mouse movements.
Calling it with a true value restores its visibility and Calling it with a true value restores its visibility and
@ -55,32 +55,32 @@ makes it respond to mouse movements again.}
Sets the label for the control. Sets the label for the control.
If @scheme[file-name?] is @scheme[#t], @scheme[msg] is treated like a If @racket[file-name?] is @racket[#t], @racket[msg] is treated like a
pathname, and a click on the name-message control creates a popup pathname, and a click on the name-message control creates a popup
menu to open a get-file dialog. menu to open a get-file dialog.
If @scheme[file-name?] is @scheme[#f], @scheme[msg] is treated as a If @racket[file-name?] is @racket[#f], @racket[msg] is treated as a
label string. Clicking on the name-message control pops up a dialog label string. Clicking on the name-message control pops up a dialog
saying that there is no file name until the file is saved.} saying that there is no file name until the file is saved.}
@defmethod[(set-short-title [short-title? boolean?]) void?]{ @defmethod[(set-short-title [short-title? boolean?]) void?]{
Sets the @scheme[short-title?] flag. The flag defaults to @scheme[#f]. Sets the @racket[short-title?] flag. The flag defaults to @racket[#f].
If the flag is @scheme[#t], then If the flag is @racket[#t], then
the label for the control is simply the string @scheme["/"]. Otherwise, the label for the control is simply the string @racket["/"]. Otherwise,
the label is determined by the label is determined by
the @method[name-message% set-message]. the @method[name-message% set-message].
} }
@defmethod[(get-background-color) (or/c false/c (is-a/c color%) string?)]{ @defmethod[(get-background-color) (or/c #f (is-a/c color%) string?)]{
The result of this method is used for the background color The result of this method is used for the background color
when redrawing the name message. If it is @scheme[#f], the when redrawing the name message. If it is @racket[#f], the
OS's default panel background is used. OS's default panel background is used.
} }
@defmethod[(set-allow-shrinking [width (or/c false/c number?)]) void?]{ @defmethod[(set-allow-shrinking [width (or/c #f number?)]) void?]{
When this method receives a number, the name-message will When this method receives a number, the name-message will
then shrink (the number indicates the minimum width the name then shrink (the number indicates the minimum width the name
@ -99,12 +99,13 @@ Defaultly, the name-message does not allow shrinking.
@defproc[(calc-button-min-sizes [dc (is-a?/c dc<%>)] @defproc[(calc-button-min-sizes [dc (is-a?/c dc<%>)]
[str string?]) [str string?]
[font (or/c #f (is-a?/c font%)) #f])
(values real? real?)]{ (values real? real?)]{
Calculates the minimum width and height of a button label (when drawn Calculates the minimum width and height of a button label (when drawn
with @scheme[draw-button-label]). Returns two values: the width with @racket[draw-button-label]). Returns two values: the width
and height. The @scheme[dc] argument is used for sizing.} and height. The @racket[dc] argument is used for sizing.}
@defproc[(draw-button-label [dc (is-a?/c dc<%>)] @defproc[(draw-button-label [dc (is-a?/c dc<%>)]
@ -116,7 +117,7 @@ and height. The @scheme[dc] argument is used for sizing.}
[mouse-over? boolean?] [mouse-over? boolean?]
[grabbed? boolean?] [grabbed? boolean?]
[font (is-a?/c font%)] [font (is-a?/c font%)]
[background (or/c (is-a?/c color%) string? false/c)]) [background (or/c (is-a?/c color%) string? #f)])
void?]{ void?]{
Draws a button label like the one for the @onscreen{(define ...)} and Draws a button label like the one for the @onscreen{(define ...)} and
@ -124,18 +125,30 @@ filename buttons in the top-left corner of the DrRacket frame. Use
this function to draw similar buttons. this function to draw similar buttons.
The basic idea is to create a canvas object whose on-paint method is The basic idea is to create a canvas object whose on-paint method is
overridden to call this function. The @scheme[dc] argument should be overridden to call this function. The @racket[dc] argument should be
canvas's drawing context, and @scheme[str] should be the string to canvas's drawing context, and @racket[str] should be the string to
display on the button. The @scheme[width] and @scheme[height] display on the button. The @racket[width] and @racket[height]
arguments should be the width and height of the button, and the arguments should be the width and height of the button, and the
@scheme[dx] and @scheme[dy] arguments specify an offset into @racket[dx] and @racket[dy] arguments specify an offset into
@scheme[dc] for the button. The @scheme[mouse-over?] argument should @racket[dc] for the button. The @racket[mouse-over?] argument should
be true when the mouse is over the button, and the @scheme[grabbed?] be true when the mouse is over the button, and the @racket[grabbed?]
argument should be true when the button has been pressed. The argument should be true when the button has been pressed. The
@scheme[font] and @scheme[background] arguments supply the font to use @racket[font] and @racket[background] arguments supply the font to use
in drawing (possibly @scheme[normal-control-font]) and the background in drawing (possibly @racket[normal-control-font]) and the background
color to paint (if any). color to paint (if any).
See @scheme[calc-button-min-sizes] for help calculating the min sizes See @racket[calc-button-min-sizes] for help calculating the min sizes
of the button.} of the button.}
@defproc[(pad-xywh [tx number?]
[ty number?]
[tw (>=/c 0)]
[th (>=/c 0)])
(values number? number? (>=/c 0) (>=/c 0))]{
Returns spacing information describing how
@racket[draw-button-label] draws. The inputs are
the x and y coordinates where the text should appear
and the width and height of the text, and the results
are the x and y coordinates where the shape should be
drawn and the width and height of the overall shape.
}

View File

@ -1,4 +1,25 @@
#lang scheme/base #lang racket/base
(require (except-in mred
make-gui-namespace
make-gui-empty-namespace))
(require mred) (provide (all-from-out mred)
(provide (all-from-out mred)) make-gui-namespace
make-gui-empty-namespace)
(define-namespace-anchor anchor)
(define (make-gui-empty-namespace)
(let ([ns (make-base-empty-namespace)])
(namespace-attach-module (namespace-anchor->empty-namespace anchor)
'racket/gui/base
ns)
ns))
(define (make-gui-namespace)
(let ([ns (make-gui-empty-namespace)])
(parameterize ([current-namespace ns])
(namespace-require 'racket/base)
(namespace-require 'racket/gui/base)
(namespace-require 'racket/class))
ns))

View File

@ -1,2 +1,25 @@
#lang scheme/private/provider #lang scheme/base
racket/gui/base (require (except-in mred
make-gui-namespace
make-gui-empty-namespace))
(provide (all-from-out mred)
make-gui-namespace
make-gui-empty-namespace)
(define-namespace-anchor anchor)
(define (make-gui-empty-namespace)
(let ([ns (make-base-empty-namespace)])
(namespace-attach-module (namespace-anchor->empty-namespace anchor)
'scheme/gui/base
ns)
ns))
(define (make-gui-namespace)
(let ([ns (make-gui-empty-namespace)])
(parameterize ([current-namespace ns])
(namespace-require 'scheme/base)
(namespace-require 'scheme/gui/base)
(namespace-require 'scheme/class))
ns))

View File

@ -38,13 +38,10 @@
@schemeblock[ @schemeblock[
(class ... (class ...
... ...
(rename [super-make-root-area-container (define status-panel #f)
make-root-area-container])
(field
[status-panel #f])
(define/override (make-root-area-container cls parent) (define/override (make-root-area-container cls parent)
(set! status-panel (set! status-panel
(super-make-root-area-container vertical-panel% parent)) (super make-root-area-container vertical-panel% parent))
(let ([root (make-object cls status-panel)]) (let ([root (make-object cls status-panel)])
(code:comment "... add other children to status-panel ...") (code:comment "... add other children to status-panel ...")

View File

@ -1,24 +1,24 @@
(module common scheme/base (module common racket/base
(require scribble/manual (require scribble/manual
scribble/basic scribble/basic
scheme/class racket/class
scheme/contract racket/contract
"blurbs.ss" "blurbs.ss"
(only-in "../reference/mz.ss" AllUnix exnraise)) (only-in "../reference/mz.ss" AllUnix exnraise))
(provide (all-from-out scribble/manual) (provide (all-from-out scribble/manual)
(all-from-out scribble/basic) (all-from-out scribble/basic)
(all-from-out scheme/class) (all-from-out racket/class)
(all-from-out scheme/contract) (all-from-out racket/contract)
(all-from-out "blurbs.ss") (all-from-out "blurbs.ss")
(all-from-out "../reference/mz.ss")) (all-from-out "../reference/mz.ss"))
(require (for-label scheme/gui/base (require (for-label racket/gui/base
scheme/class racket/class
scheme/contract racket/contract
scheme/base)) racket/base))
(provide (for-label (all-from-out scheme/gui/base) (provide (for-label (all-from-out racket/gui/base)
(all-from-out scheme/class) (all-from-out racket/class)
(all-from-out scheme/contract) (all-from-out racket/contract)
(all-from-out scheme/base)))) (all-from-out racket/base))))

View File

@ -267,12 +267,12 @@ Strips shortcut ampersands from @racket[label], removes parenthesized
@defproc[(make-gui-empty-namespace) namespace?]{ @defproc[(make-gui-empty-namespace) namespace?]{
Like @racket[make-base-empty-namespace], but with Like @racket[make-base-empty-namespace], but with
@racket[racket/class] and @racketmodname[racket/gui/base] also @racketmodname[racket/class] and @racketmodname[racket/gui/base] also
attached to the result namespace.} attached to the result namespace.}
@defproc[(make-gui-namespace) namespace?]{ @defproc[(make-gui-namespace) namespace?]{
Like @racket[make-base-namespace], but with @racket[racket/class] and Like @racket[make-base-namespace], but with @racketmodname[racket/class] and
@racketmodname[racket/gui/base] also required into the top-level @racketmodname[racket/gui/base] also required into the top-level
environment of the result namespace.} environment of the result namespace.}

View File

@ -23,7 +23,7 @@ create a useful snip:
@item{@method[snip% split] if the snip can contain more than one @techlink{item}} @item{@method[snip% split] if the snip can contain more than one @techlink{item}}
@item{@method[snip% size-cache-invalid] if the snip caches the result to@method[snip% get-extent]} @item{@method[snip% size-cache-invalid] if the snip caches the result to @method[snip% get-extent]}
@item{@method[snip% get-text] (not required)} @item{@method[snip% get-text] (not required)}
@ -336,7 +336,12 @@ following symbols:
snip; only an owning editor should set this flag} snip; only an owning editor should set this flag}
@item{@indexed-scheme['handles-events] --- this snip can handle @item{@indexed-scheme['handles-events] --- this snip can handle
keyboard and mouse events} keyboard and mouse events when it has the keyboard focus}
@item{@indexed-scheme['handles-all-mouse-events] --- this snip can
handle mouse events that touch the snip or that immediately
follow an event that touches the snip, even if the snip does
not have the keyboard focus}
@item{@indexed-scheme['width-depends-on-x] --- this snip's display @item{@indexed-scheme['width-depends-on-x] --- this snip's display
width depends on the snip's x-@techlink{location} within the width depends on the snip's x-@techlink{location} within the

View File

@ -1,3 +1,9 @@
Version 5.0.1, July 2010
Minor bug fixes
----------------------------------------------------------------------
Version 5.0, May 2010 Version 5.0, May 2010
Changed the executable from MrEd to GRacket Changed the executable from MrEd to GRacket