Racket & GRacket relesae notes for 5.0.1
Merge to 5.0.1 original commit: e49f05a5cbb3e78e0ff051a7a6e35f2c35ab3a12
This commit is contained in:
Matthew Flatt
commit
10a8e6ad6e
|
|
@ -7,7 +7,7 @@
|
|||
|
||||
(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")))
|
||||
|
||||
;; build-before-super-item-clause : an-item -> (listof clause)
|
||||
|
|
@ -121,7 +121,7 @@
|
|||
,(generic-initializer generic)))]))
|
||||
|
||||
(define (main)
|
||||
(write-standard-menus.ss)
|
||||
(write-standard-menus.rkt)
|
||||
(write-docs))
|
||||
|
||||
(define (write-docs)
|
||||
|
|
@ -202,10 +202,10 @@
|
|||
(display docs-footer-text port))
|
||||
#:exists 'truncate))
|
||||
|
||||
(define (write-standard-menus.ss)
|
||||
(printf "writing to ~a~n" standard-menus.ss-filename)
|
||||
(define (write-standard-menus.rkt)
|
||||
(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)
|
||||
(pretty-print
|
||||
`(define standard-menus<%>
|
||||
|
|
|
|||
|
|
@ -208,7 +208,7 @@
|
|||
(let ([hash-table (make-hasheq)])
|
||||
(for-each (λ (x)
|
||||
(hash-set! hash-table x 'define))
|
||||
'(local))
|
||||
'(struct local))
|
||||
(for-each (λ (x)
|
||||
(hash-set! hash-table x 'begin))
|
||||
'(case-lambda
|
||||
|
|
|
|||
|
|
@ -280,7 +280,7 @@
|
|||
(string-constant quit-menu-item-windows)
|
||||
(string-constant quit-menu-item-others))
|
||||
on-demand-do-nothing
|
||||
'(not (current-eventspace-has-standard-menus?)))
|
||||
'(not (eq? (system-type) 'macosx)))
|
||||
(make-after 'file-menu 'quit 'nothing)
|
||||
|
||||
(make-an-item 'edit-menu 'undo
|
||||
|
|
|
|||
|
|
@ -1,5 +1,4 @@
|
|||
#reader scribble/reader
|
||||
#lang scheme/gui
|
||||
#lang at-exp scheme/gui
|
||||
|
||||
(require scribble/srcdoc)
|
||||
(require/doc scheme/base scribble/manual)
|
||||
|
|
@ -355,8 +354,7 @@
|
|||
state in-cb
|
||||
(build-labels rb))]
|
||||
[else (let ([i (- total n)])
|
||||
(if (or (string=? state (send rb get-item-label i))
|
||||
(string=? state (send rb get-item-plain-label i)))
|
||||
(if (ith-item-matches? rb state i)
|
||||
(if (send rb is-enabled? i)
|
||||
(send rb set-selection i)
|
||||
(error 'test:set-radio-box!
|
||||
|
|
@ -371,6 +369,15 @@
|
|||
"expected a string or a number as second arg, got: ~e (other arg: ~e)"
|
||||
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
|
||||
(define (set-radio-box-item! state)
|
||||
(control-action
|
||||
|
|
@ -383,8 +390,7 @@
|
|||
(cond
|
||||
[(zero? n) (error 'test:set-radio-box-item! "internal error")]
|
||||
[else (let ([i (- total n)])
|
||||
(if (or (string=? state (send rb get-item-label i))
|
||||
(string=? state (send rb get-item-plain-label i)))
|
||||
(if (ith-item-matches? rb state i)
|
||||
(if (send rb is-enabled? i)
|
||||
(send rb set-selection i)
|
||||
(error 'test:set-radio-box!
|
||||
|
|
@ -392,14 +398,23 @@
|
|||
state))
|
||||
(loop (- n 1))))]))))))
|
||||
|
||||
;; entry-matches : string -> radio-box -> boolean
|
||||
;; entry-matches : string | regexp -> radio-box -> boolean
|
||||
(define (entry-matches name)
|
||||
(λ (rb)
|
||||
(let loop ([n (send rb get-number)])
|
||||
(and (not (zero? n))
|
||||
(or (equal? name (send rb get-item-label (- n 1)))
|
||||
(equal? name (send rb get-item-plain-label (- n 1)))
|
||||
(loop (- n 1)))))))
|
||||
(cond
|
||||
[(zero? n) #f]
|
||||
[else
|
||||
(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
|
||||
|
||||
|
|
@ -844,11 +859,12 @@
|
|||
|
||||
(proc-doc/names
|
||||
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)
|
||||
@{Sets the radio-box to @scheme[state]. If @scheme[state] is a
|
||||
string, this function finds the choice with that label and
|
||||
if it is a number, it uses the number as an index into the
|
||||
@{Sets the radio-box to the label matching @scheme[state]. If @scheme[state] is a
|
||||
string, this function finds the choice with that label.
|
||||
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
|
||||
in the radio box, an exception is raised.
|
||||
|
||||
|
|
@ -858,9 +874,9 @@
|
|||
|
||||
(proc-doc/names
|
||||
test:set-radio-box-item!
|
||||
(-> string? void?)
|
||||
(-> (or/c string? regexp?) void?)
|
||||
(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].})
|
||||
|
||||
(proc-doc/names
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(module mred mzscheme
|
||||
(require (only scheme/base
|
||||
(require (only racket/base
|
||||
define-namespace-anchor
|
||||
namespace-anchor->empty-namespace
|
||||
make-base-empty-namespace)
|
||||
|
|
@ -57,6 +57,9 @@
|
|||
(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)
|
||||
|
||||
|
|
@ -75,6 +78,8 @@
|
|||
(namespace-require 'scheme/class))
|
||||
ns))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (make-eventspace)
|
||||
(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)])
|
||||
|
|
|
|||
|
|
@ -158,7 +158,8 @@
|
|||
(define sequence-streak? #f)
|
||||
|
||||
(define changed? #f)
|
||||
|
||||
|
||||
(define prev-mouse-snip #f)
|
||||
|
||||
(super-new)
|
||||
|
||||
|
|
@ -241,28 +242,42 @@
|
|||
(def/override (on-event [mouse-event% event])
|
||||
(when s-admin
|
||||
(let-values ([(dc x y scrollx scrolly)
|
||||
(if (or (send event button-down?) s-caret-snip)
|
||||
;; first, find clicked-on snip:
|
||||
(let ([x (send event get-x)]
|
||||
[y (send event get-y)])
|
||||
(let-boxes ([scrollx 0.0]
|
||||
[scrolly 0.0]
|
||||
[dc #f])
|
||||
(set-box! dc (send s-admin get-dc scrollx scrolly))
|
||||
;; FIXME: old code returned if !dc
|
||||
(values dc (+ x scrollx) (+ y scrolly) scrollx scrolly)))
|
||||
(values #f 0.0 0.0 0.0 0.0))])
|
||||
(let ([snip (if (send event button-down?)
|
||||
(find-snip x y)
|
||||
s-caret-snip)])
|
||||
(if (and snip
|
||||
(eq? snip s-caret-snip))
|
||||
(let ([loc (snip-loc snip)])
|
||||
(send s-caret-snip on-event
|
||||
;; first, find clicked-on snip:
|
||||
(let ([x (send event get-x)]
|
||||
[y (send event get-y)])
|
||||
(let-boxes ([scrollx 0.0]
|
||||
[scrolly 0.0]
|
||||
[dc #f])
|
||||
(set-box! dc (send s-admin get-dc scrollx scrolly))
|
||||
;; FIXME: old code returned if !dc
|
||||
(values dc (+ x scrollx) (+ y scrolly) scrollx scrolly)))])
|
||||
(let ([snip (find-snip x y)])
|
||||
(when (and prev-mouse-snip
|
||||
(not (eq? snip prev-mouse-snip)))
|
||||
(let ([loc (snip-loc prev-mouse-snip)])
|
||||
(send prev-mouse-snip on-event
|
||||
dc (- (loc-x loc) scrollx) (- (loc-y loc) scrolly)
|
||||
(loc-x loc) (loc-y loc)
|
||||
event))
|
||||
(on-local-event 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])
|
||||
(when s-admin
|
||||
|
|
@ -729,6 +744,8 @@
|
|||
|
||||
(define/private (-delete del-snip del)
|
||||
(when (snip-loc del-snip)
|
||||
(when (eq? del-snip prev-mouse-snip)
|
||||
(set! prev-mouse-snip #f))
|
||||
(set! write-locked (add1 write-locked))
|
||||
(begin-edit-sequence)
|
||||
(let ([ok? (or (can-delete? del-snip)
|
||||
|
|
|
|||
|
|
@ -170,6 +170,8 @@
|
|||
(define sticky-styles? #t)
|
||||
(define overwrite-mode? #f)
|
||||
|
||||
(define prev-mouse-snip #f)
|
||||
|
||||
(def/public (set-styles-sticky [bool? s?]) (set! sticky-styles? (and s? #t)))
|
||||
(def/public (get-styles-sticky) sticky-styles?)
|
||||
|
||||
|
|
@ -441,18 +443,15 @@
|
|||
(not (send event leaving?)))
|
||||
(end-streaks '(except-key-sequence cursor delayed)))
|
||||
(let-values ([(dc x y scrollx scrolly)
|
||||
(if (or (send event button-down?) s-caret-snip)
|
||||
;; first, find clicked-on snip:
|
||||
(let ([x (send event get-x)]
|
||||
[y (send event get-y)])
|
||||
(let-boxes ([scrollx 0.0]
|
||||
[scrolly 0.0]
|
||||
[dc #f])
|
||||
(set-box! dc (send s-admin get-dc scrollx scrolly))
|
||||
;; FIXME: old code returned if !dc
|
||||
(values dc (+ x scrollx) (+ y scrolly) scrollx scrolly)))
|
||||
(values #f 0.0 0.0 0.0 0.0))])
|
||||
(when (send event button-down?)
|
||||
;; first, find clicked-on snip:
|
||||
(let ([x (send event get-x)]
|
||||
[y (send event get-y)])
|
||||
(let-boxes ([scrollx 0.0]
|
||||
[scrolly 0.0]
|
||||
[dc #f])
|
||||
(set-box! dc (send s-admin get-dc scrollx scrolly))
|
||||
;; FIXME: old code returned if !dc
|
||||
(values dc (+ x scrollx) (+ y scrolly) scrollx scrolly)))])
|
||||
(let ([snip
|
||||
(let-boxes ([onit? #f]
|
||||
[how-close 0.0]
|
||||
|
|
@ -476,12 +475,26 @@
|
|||
#f
|
||||
snip)))
|
||||
#f)))])
|
||||
(set-caret-owner snip)))
|
||||
(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))
|
||||
(on-local-event event)))))
|
||||
(when (send event button-down?)
|
||||
(set-caret-owner snip))
|
||||
(when (and prev-mouse-snip
|
||||
(not (eq? snip prev-mouse-snip)))
|
||||
(let-boxes ([x 0.0] [y 0.0])
|
||||
(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])
|
||||
(when s-admin
|
||||
|
|
@ -4004,6 +4017,8 @@
|
|||
(set! snip-count (add1 snip-count)))))
|
||||
|
||||
(define/private (delete-snip snip)
|
||||
(when (eq? snip prev-mouse-snip)
|
||||
(set! prev-mouse-snip #f))
|
||||
(cond
|
||||
[(snip->next snip)
|
||||
(splice-snip (snip->next snip) (snip->prev snip) (snip->next (snip->next snip)))]
|
||||
|
|
|
|||
|
|
@ -1,4 +1,10 @@
|
|||
#lang racket/base
|
||||
|
||||
;; changed:
|
||||
;; - simple-shape
|
||||
;; - np-atomic-shape
|
||||
;; - atomic-shape
|
||||
|
||||
#|
|
||||
|
||||
This library is the part of the 2htdp/image
|
||||
|
|
@ -29,7 +35,9 @@ has been moved out).
|
|||
(require racket/class
|
||||
racket/gui/base
|
||||
racket/math
|
||||
racket/contract
|
||||
"private/image-core-bitmap.ss"
|
||||
(prefix-in cis: "cache-image-snip.ss")
|
||||
(for-syntax racket/base))
|
||||
|
||||
(define-for-syntax id-constructor-pairs '())
|
||||
|
|
@ -122,6 +130,7 @@ has been moved out).
|
|||
;; - polygon
|
||||
;; - line-segment
|
||||
;; - curve-segment
|
||||
;; - bitmap
|
||||
;; - np-atomic-shape
|
||||
|
||||
;; 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)
|
||||
#:omit-define-syntaxes #:transparent)
|
||||
;;
|
||||
;; - flip
|
||||
|
||||
;; a bitmap is:
|
||||
;; - (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
|
||||
(define-struct/reg-mk bitmap (raw-bitmap raw-mask angle x-scale y-scale [rendered-bitmap #:mutable] [rendered-mask #:mutable])
|
||||
#: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:
|
||||
;;
|
||||
;; - (make-polygon (listof vector) mode color)
|
||||
|
|
@ -164,7 +184,7 @@ has been moved out).
|
|||
;; - (make-crop (listof points) normalized-shape)
|
||||
|
||||
;; a simple-shape (subtype of shape) is
|
||||
;; - (make-translate dx dy np-atomic-shape))
|
||||
;; - (make-translate dx dy np-atomic-shape)
|
||||
;; - polygon
|
||||
;; - line-segment
|
||||
;; - curve-segment
|
||||
|
|
@ -213,21 +233,26 @@ has been moved out).
|
|||
(init-field shape bb normalized?)
|
||||
(define/public (equal-to? that eq-recur)
|
||||
(or (eq? this that)
|
||||
(and (is-a? that image%)
|
||||
(same-bb? bb (send that get-bb))
|
||||
(or (and (not (skip-image-equality-fast-path)) ;; this is here to make testing more effective
|
||||
(equal? (get-normalized-shape) (send that get-normalized-shape)))
|
||||
(let ([w (+ 1 (round (inexact->exact (bb-right bb))))] ;; some shapes (ie, rectangles) draw 1 outside the bounding box
|
||||
[h (+ 1 (round (inexact->exact (bb-bottom bb))))]) ;; so we make the bitmap slightly bigger to accomodate that.
|
||||
(or (zero? w)
|
||||
(zero? h)
|
||||
(let ([bm1 (make-object bitmap% w h)]
|
||||
[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)))))))))
|
||||
(let ([that
|
||||
(cond
|
||||
[(is-a? that image-snip%) (image-snip->image that)]
|
||||
[(is-a? that bitmap%) (bitmap->image that)]
|
||||
[else that])])
|
||||
(and (is-a? that image%)
|
||||
(same-bb? bb (send that get-bb))
|
||||
(or (and (not (skip-image-equality-fast-path)) ;; this is here to make testing more effective
|
||||
(equal? (get-normalized-shape) (send that get-normalized-shape)))
|
||||
(let ([w (+ 1 (round (inexact->exact (bb-right bb))))] ;; some shapes (ie, rectangles) draw 1 outside the bounding box
|
||||
[h (+ 1 (round (inexact->exact (bb-bottom bb))))]) ;; so we make the bitmap slightly bigger to accomodate that.
|
||||
(or (zero? w)
|
||||
(zero? h)
|
||||
(let ([bm1 (make-object bitmap% w h)]
|
||||
[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)
|
||||
(clear-bitmap/draw/bytes bm1 bdc bytes1 this color)
|
||||
|
|
@ -369,9 +394,49 @@ has been moved out).
|
|||
|
||||
(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
|
||||
;; 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]
|
||||
[dx 0]
|
||||
[dy 0]
|
||||
|
|
@ -443,50 +508,20 @@ has been moved out).
|
|||
(if bottom
|
||||
(make-overlay bottom (f this-one))
|
||||
(f this-one)))]
|
||||
[(np-atomic-shape? shape)
|
||||
(let ([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)))]
|
||||
[(or (bitmap? shape) (np-atomic-shape? shape))
|
||||
(let ([shape (if (bitmap? shape)
|
||||
(make-flip #f shape)
|
||||
shape)])
|
||||
(let ([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
|
||||
(error 'normalize-shape "unknown shape ~s\n" shape)])))
|
||||
|
||||
(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)
|
||||
(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)
|
||||
(define/contract (scale-np-atomic x-scale y-scale shape)
|
||||
(-> number? number? np-atomic-shape? np-atomic-shape?)
|
||||
(cond
|
||||
[(ellipse? shape)
|
||||
(make-ellipse (* x-scale (ellipse-width shape))
|
||||
|
|
@ -508,13 +543,15 @@ has been moved out).
|
|||
(text-style shape)
|
||||
(text-weight shape)
|
||||
(text-underline shape))]
|
||||
[(bitmap? shape)
|
||||
(make-bitmap (bitmap-raw-bitmap shape)
|
||||
(bitmap-raw-mask shape)
|
||||
(bitmap-angle shape)
|
||||
(* x-scale (bitmap-x-scale shape))
|
||||
(* y-scale (bitmap-y-scale shape))
|
||||
#f #f)]))
|
||||
[(flip? shape)
|
||||
(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))
|
||||
#f #f)))]))
|
||||
|
||||
(define (scale-color color x-scale y-scale)
|
||||
(cond
|
||||
|
|
@ -552,7 +589,13 @@ has been moved out).
|
|||
[font (send dc get-font)]
|
||||
[fg (send dc get-text-foreground)]
|
||||
[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-brush brush)
|
||||
(send dc set-font font)
|
||||
|
|
@ -652,15 +695,15 @@ has been moved out).
|
|||
[else
|
||||
(let ([dx (+ dx (translate-dx simple-shape))]
|
||||
[dy (+ dy (translate-dy simple-shape))]
|
||||
[atomic-shape (translate-shape simple-shape)])
|
||||
[np-atomic-shape (translate-shape simple-shape)])
|
||||
(cond
|
||||
[(ellipse? atomic-shape)
|
||||
[(ellipse? np-atomic-shape)
|
||||
(let* ([path (new dc-path%)]
|
||||
[ew (ellipse-width atomic-shape)]
|
||||
[eh (ellipse-height atomic-shape)]
|
||||
[θ (degrees->radians (ellipse-angle atomic-shape))]
|
||||
[color (ellipse-color atomic-shape)]
|
||||
[mode (ellipse-mode atomic-shape)])
|
||||
[ew (ellipse-width np-atomic-shape)]
|
||||
[eh (ellipse-height np-atomic-shape)]
|
||||
[θ (degrees->radians (ellipse-angle np-atomic-shape))]
|
||||
[color (ellipse-color np-atomic-shape)]
|
||||
[mode (ellipse-mode np-atomic-shape)])
|
||||
(let-values ([(rotated-width rotated-height) (ellipse-rotated-size ew eh θ)])
|
||||
(send path ellipse 0 0 ew eh)
|
||||
(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-smoothing (mode-color->smoothing mode color))
|
||||
(send dc draw-path path dx dy)))]
|
||||
[(bitmap? atomic-shape)
|
||||
(let ([bm (get-rendered-bitmap atomic-shape)])
|
||||
[(flip? np-atomic-shape)
|
||||
(let ([bm (get-rendered-bitmap np-atomic-shape)])
|
||||
(send dc draw-bitmap
|
||||
bm
|
||||
(- dx (/ (send bm get-width) 2))
|
||||
(- dy (/ (send bm get-height) 2))
|
||||
'solid
|
||||
(send the-color-database find-color "black")
|
||||
(get-rendered-mask atomic-shape)))]
|
||||
[(text? atomic-shape)
|
||||
(let ([θ (degrees->radians (text-angle atomic-shape))]
|
||||
(get-rendered-mask np-atomic-shape)))]
|
||||
[(text? np-atomic-shape)
|
||||
(let ([θ (degrees->radians (text-angle np-atomic-shape))]
|
||||
[font (send dc get-font)])
|
||||
(send dc set-font (text->font atomic-shape))
|
||||
(send dc set-text-foreground
|
||||
(or (send the-color-database find-color (text-color atomic-shape))
|
||||
(send the-color-database find-color "black")))
|
||||
(let-values ([(w h _1 _2) (send dc get-text-extent (text-string atomic-shape))])
|
||||
(send dc set-font (text->font np-atomic-shape))
|
||||
(let ([color (get-color-arg (text-color np-atomic-shape))])
|
||||
(send dc set-text-foreground
|
||||
(cond
|
||||
[(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)
|
||||
(* (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)
|
||||
(imag-part p)
|
||||
#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)
|
||||
(calc-renered-bitmap bitmap)
|
||||
(bitmap-rendered-bitmap bitmap))
|
||||
(define (get-rendered-bitmap flip-bitmap)
|
||||
(calc-rendered-bitmap flip-bitmap)
|
||||
(bitmap-rendered-bitmap (flip-shape flip-bitmap)))
|
||||
|
||||
(define (get-rendered-mask bitmap)
|
||||
(calc-renered-bitmap bitmap)
|
||||
(bitmap-rendered-mask bitmap))
|
||||
(define (get-rendered-mask flip-bitmap)
|
||||
(calc-rendered-bitmap flip-bitmap)
|
||||
(bitmap-rendered-mask (flip-shape flip-bitmap)))
|
||||
|
||||
(define (calc-renered-bitmap bitmap)
|
||||
(unless (bitmap-rendered-bitmap 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)))
|
||||
;; 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 (calc-rendered-bitmap flip-bitmap)
|
||||
(let ([bitmap (flip-shape flip-bitmap)])
|
||||
(unless (bitmap-rendered-bitmap bitmap)
|
||||
(let ([flipped? (flip-flipped? flip-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)
|
||||
(define (do-rotate bitmap flip?)
|
||||
(let ([θ (degrees->radians (bitmap-angle bitmap))])
|
||||
(let-values ([(bytes w h) (bitmap->bytes (bitmap-rendered-bitmap bitmap)
|
||||
(bitmap-rendered-mask bitmap))])
|
||||
(let-values ([(rotated-bytes rotated-w rotated-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)])
|
||||
(set-bitmap-rendered-bitmap! bitmap bm)
|
||||
(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))
|
||||
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
|
||||
bitmap-rendered-bitmap bitmap-rendered-mask
|
||||
|
||||
make-flip flip? flip-flipped? flip-shape
|
||||
|
||||
(struct-out color)
|
||||
|
||||
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
|
||||
|
||||
scale-np-atomic)
|
||||
scale-np-atomic
|
||||
|
||||
to-img
|
||||
bitmap->image
|
||||
image-snip->image)
|
||||
|
||||
;; method names
|
||||
(provide get-shape get-bb get-normalized? get-normalized-shape)
|
||||
|
|
|
|||
|
|
@ -1,30 +1,27 @@
|
|||
#lang scheme/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)))))
|
||||
#lang racket/gui
|
||||
|
||||
(provide/contract
|
||||
[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
|
||||
(->d ([dc (is-a?/c dc<%>)]
|
||||
[label (or/c false/c string?)]
|
||||
[x number?]
|
||||
[y number?]
|
||||
[w (and/c number? (min-w h))]
|
||||
[h (and/c number? (min-h w))]
|
||||
[w number?]
|
||||
[h (and/c number? (>=/c (* 2 border-inset)))]
|
||||
[mouse-over? boolean?]
|
||||
[grabbed? boolean?]
|
||||
[button-label-font (is-a?/c font%)]
|
||||
[bkg-color (or/c false/c (is-a?/c color%) string?)])
|
||||
()
|
||||
#:pre-cond
|
||||
(w . > . (- h (* 2 border-inset)))
|
||||
[result void?])]
|
||||
|
||||
[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?))])
|
||||
|
||||
(provide name-message%)
|
||||
|
|
@ -241,7 +238,7 @@
|
|||
(define mouse-grabbed-color (make-object color% 100 100 100))
|
||||
(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 ([(px py pw ph) (pad-xywh 0 0 w h)])
|
||||
(values pw ph))))
|
||||
|
|
|
|||
|
|
@ -4,8 +4,10 @@
|
|||
|
||||
|
||||
(provide rotate-bytes ;; : bytes int[width] int[height] radians[radians] -> bytes
|
||||
flip-bytes ;; : bytes int[width] int[height] -> bytes
|
||||
bitmap->bytes
|
||||
bytes->bitmap)
|
||||
bytes->bitmap
|
||||
linear-transform)
|
||||
;; rotate-bitmap : (-> bytes? natural-number/c natural-number/c real? bytes?)
|
||||
;; 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)
|
||||
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)
|
||||
(let* {[theta-rotation (exp (* i theta))]
|
||||
[theta-unrotation (make-rectangular (real-part theta-rotation)
|
||||
|
|
@ -104,7 +115,90 @@ instead of this scaling code, we use the dc<%>'s scaling code.
|
|||
(real-part pre-image)
|
||||
(- (imag-part pre-image))))))
|
||||
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`?
|
||||
;; 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.
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@
|
|||
|
||||
@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
|
||||
directories. Override the @method[name-message% on-choose-directory]
|
||||
method to handle the user's selection.
|
||||
|
|
@ -16,7 +16,7 @@ method to handle the user's selection.
|
|||
|
||||
@defconstructor/auto-super[()]{
|
||||
|
||||
Passes all arguments to @scheme[super-init].}
|
||||
Passes all arguments to @racket[super-init].}
|
||||
|
||||
|
||||
@defmethod[(on-choose-directory [dir path-string?])
|
||||
|
|
@ -42,7 +42,7 @@ Draws the control's current message.}
|
|||
|
||||
@defmethod[(set-hidden? [hidden? any/c])
|
||||
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.
|
||||
|
||||
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.
|
||||
|
||||
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
|
||||
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
|
||||
saying that there is no file name until the file is saved.}
|
||||
|
||||
@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
|
||||
the label for the control is simply the string @scheme["/"]. Otherwise,
|
||||
If the flag is @racket[#t], then
|
||||
the label for the control is simply the string @racket["/"]. Otherwise,
|
||||
the label is determined by
|
||||
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
|
||||
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.
|
||||
|
||||
}
|
||||
|
||||
@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
|
||||
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<%>)]
|
||||
[str string?])
|
||||
[str string?]
|
||||
[font (or/c #f (is-a?/c font%)) #f])
|
||||
(values real? real?)]{
|
||||
|
||||
Calculates the minimum width and height of a button label (when drawn
|
||||
with @scheme[draw-button-label]). Returns two values: the width
|
||||
and height. The @scheme[dc] argument is used for sizing.}
|
||||
with @racket[draw-button-label]). Returns two values: the width
|
||||
and height. The @racket[dc] argument is used for sizing.}
|
||||
|
||||
|
||||
@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?]
|
||||
[grabbed? boolean?]
|
||||
[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?]{
|
||||
|
||||
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.
|
||||
|
||||
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
|
||||
canvas's drawing context, and @scheme[str] should be the string to
|
||||
display on the button. The @scheme[width] and @scheme[height]
|
||||
overridden to call this function. The @racket[dc] argument should be
|
||||
canvas's drawing context, and @racket[str] should be the string to
|
||||
display on the button. The @racket[width] and @racket[height]
|
||||
arguments should be the width and height of the button, and the
|
||||
@scheme[dx] and @scheme[dy] arguments specify an offset into
|
||||
@scheme[dc] for the button. The @scheme[mouse-over?] argument should
|
||||
be true when the mouse is over the button, and the @scheme[grabbed?]
|
||||
@racket[dx] and @racket[dy] arguments specify an offset into
|
||||
@racket[dc] for the button. The @racket[mouse-over?] argument should
|
||||
be true when the mouse is over the button, and the @racket[grabbed?]
|
||||
argument should be true when the button has been pressed. The
|
||||
@scheme[font] and @scheme[background] arguments supply the font to use
|
||||
in drawing (possibly @scheme[normal-control-font]) and the background
|
||||
@racket[font] and @racket[background] arguments supply the font to use
|
||||
in drawing (possibly @racket[normal-control-font]) and the background
|
||||
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.}
|
||||
|
||||
@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.
|
||||
}
|
||||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -1,2 +1,25 @@
|
|||
#lang scheme/private/provider
|
||||
racket/gui/base
|
||||
#lang scheme/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))
|
||||
|
|
|
|||
|
|
@ -38,13 +38,10 @@
|
|||
@schemeblock[
|
||||
(class ...
|
||||
...
|
||||
(rename [super-make-root-area-container
|
||||
make-root-area-container])
|
||||
(field
|
||||
[status-panel #f])
|
||||
(define status-panel #f)
|
||||
(define/override (make-root-area-container cls parent)
|
||||
(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)])
|
||||
|
||||
(code:comment "... add other children to status-panel ...")
|
||||
|
|
|
|||
|
|
@ -1,24 +1,24 @@
|
|||
|
||||
(module common scheme/base
|
||||
(module common racket/base
|
||||
(require scribble/manual
|
||||
scribble/basic
|
||||
scheme/class
|
||||
scheme/contract
|
||||
racket/class
|
||||
racket/contract
|
||||
"blurbs.ss"
|
||||
(only-in "../reference/mz.ss" AllUnix exnraise))
|
||||
(provide (all-from-out scribble/manual)
|
||||
(all-from-out scribble/basic)
|
||||
(all-from-out scheme/class)
|
||||
(all-from-out scheme/contract)
|
||||
(all-from-out racket/class)
|
||||
(all-from-out racket/contract)
|
||||
(all-from-out "blurbs.ss")
|
||||
(all-from-out "../reference/mz.ss"))
|
||||
|
||||
(require (for-label scheme/gui/base
|
||||
scheme/class
|
||||
scheme/contract
|
||||
scheme/base))
|
||||
(provide (for-label (all-from-out scheme/gui/base)
|
||||
(all-from-out scheme/class)
|
||||
(all-from-out scheme/contract)
|
||||
(all-from-out scheme/base))))
|
||||
(require (for-label racket/gui/base
|
||||
racket/class
|
||||
racket/contract
|
||||
racket/base))
|
||||
(provide (for-label (all-from-out racket/gui/base)
|
||||
(all-from-out racket/class)
|
||||
(all-from-out racket/contract)
|
||||
(all-from-out racket/base))))
|
||||
|
||||
|
|
|
|||
|
|
@ -267,12 +267,12 @@ Strips shortcut ampersands from @racket[label], removes parenthesized
|
|||
@defproc[(make-gui-empty-namespace) namespace?]{
|
||||
|
||||
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.}
|
||||
|
||||
@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
|
||||
environment of the result namespace.}
|
||||
|
||||
|
|
|
|||
|
|
@ -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% 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)}
|
||||
|
||||
|
|
@ -336,7 +336,12 @@ following symbols:
|
|||
snip; only an owning editor should set this flag}
|
||||
|
||||
@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
|
||||
width depends on the snip's x-@techlink{location} within the
|
||||
|
|
|
|||
|
|
@ -1,3 +1,9 @@
|
|||
Version 5.0.1, July 2010
|
||||
|
||||
Minor bug fixes
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
Version 5.0, May 2010
|
||||
|
||||
Changed the executable from MrEd to GRacket
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user