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

improve canvas-drawing docs

Browse Source 
original commit: 4f56618c6d9a36743f97535ad1d75e5fa36d9d5f
This commit is contained in:
Matthew Flatt 2011-01-06 07:43:14 -07:00
commit 996874cd46
46 changed files with 812 additions and 345 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/framework/private/canvas.rkt
View File

@ -152,11 +152,12 @@
(set-max-height snip-height))))))))))
(define/public (recalc-snips)
(let ([editor (get-editor)])
(unless (is-a? editor text:wide-snip<%>)
(error 'recalc-snips "expected a text:wide-snip<%> editor, instead ~e" editor))
(when (eq? (send editor get-canvas) this)
(for-each (update-snip-size #t) (send editor get-wide-snips))
(for-each (update-snip-size #f) (send editor get-tall-snips)))))
(when editor
(unless (is-a? editor text:wide-snip<%>)
(error 'recalc-snips "expected a text:wide-snip<%> editor, instead ~e" editor))
(when (eq? (send editor get-canvas) this)
(for-each (update-snip-size #t) (send editor get-wide-snips))
(for-each (update-snip-size #f) (send editor get-tall-snips))))))
(define/public (add-wide-snip snip)
(let ([editor (get-editor)])
(unless (is-a? editor text:wide-snip<%>)

18
collects/framework/private/color.rkt
View File

@ -209,7 +209,8 @@ added get-regions
(loop (cdr old) (cdr new)))]
[else
(cons (make-new-lexer-state (caar new) (cadar new))
(loop null (cdr new)))]))))
(loop null (cdr new)))])))
(update-lexer-state-observers))
(define/public (get-regions)
@ -236,6 +237,16 @@ added get-regions
local-edit-sequence? get-styles-fixed has-focus?
get-fixed-style)
(define lexers-all-valid? #t)
(define/private (update-lexer-state-observers)
(define new (for/and ([ls (in-list lexer-states)])
(lexer-state-up-to-date? ls)))
(unless (eq? new lexers-all-valid?)
(set! lexers-all-valid? new)
(on-lexer-valid lexers-all-valid?)))
(define/pubment (on-lexer-valid valid?)
(inner (void) on-lexer-valid valid?))
(define/private (reset-tokens)
(for-each
(lambda (ls)
@ -247,6 +258,7 @@ added get-regions
(set-lexer-state-current-lexer-mode! ls #f)
(set-lexer-state-parens! ls (new paren-tree% (matches pairs))))
lexer-states)
(update-lexer-state-observers)
(set! restart-callback #f)
(set! force-recolor-after-freeze #f)
(set! colors null)
@ -374,6 +386,7 @@ added get-regions
(send valid-tree search-max!)
(data-lexer-mode (send valid-tree get-root-data))))))
(set-lexer-state-up-to-date?! ls #f)
(update-lexer-state-observers)
(queue-callback (λ () (colorer-callback)) #f)))
((>= edit-start-pos (lexer-state-invalid-tokens-start ls))
(let-values (((tok-start tok-end valid-tree invalid-tree orig-data)
@ -454,7 +467,8 @@ added get-regions
(when (coroutine-run 10 tok-cor)
(for-each (lambda (ls)
(set-lexer-state-up-to-date?! ls #t))
lexer-states)))
lexer-states)
(update-lexer-state-observers)))
#;(printf "end lexing\n")
#;(printf "begin coloring\n")
;; This edit sequence needs to happen even when colors is null

8
collects/framework/private/frame.rkt
View File

@ -2445,6 +2445,7 @@
(define/override (get-editor%) (text:searching-mixin (super get-editor%)))
(super-new)))
;; code copied to drracket/private/unit.rkt
(define checkout-or-nightly?
(or (with-handlers ([exn:fail:filesystem? (λ (x) #f)])
(directory-exists? (collection-path "repo-time-stamp")))
@ -2473,8 +2474,10 @@
(define/override (on-paint)
(cond
[on?
(define dc (get-dc))
(send dc set-font small-control-font)
(let-values ([(cw ch) (get-client-size)])
(send (get-dc) draw-text indicator
(send dc draw-text indicator
(- (/ cw 2) (/ indicator-width 2))
(- (/ ch 2) (/ indicator-height 2))))]))
(define/public (set-on? new-on?)
@ -2487,9 +2490,8 @@
(super-new [stretchable-width #f]
[style '(transparent)])
(send (get-dc) set-font small-control-font)
(define-values (indicator-width indicator-height)
(let-values ([(tw th _1 _2) (send (get-dc) get-text-extent indicator)])
(let-values ([(tw th _1 _2) (send (get-dc) get-text-extent indicator small-control-font)])
(values tw th)))
(min-width (+ (inexact->exact (ceiling indicator-width)) 4))))

88
collects/framework/private/text.rkt
View File

@ -1,10 +1,4 @@
#lang racket/unit
#|
WARNING: printf is rebound in the body of the unit to always
print to the original output port.
|#
(require string-constants
racket/unit
@ -37,10 +31,7 @@ WARNING: printf is rebound in the body of the unit to always
(init-depend framework:editor^)
(define original-output-port (current-output-port))
(define (printf . args)
(apply fprintf original-output-port args)
(void))
(define (oprintf . args) (apply fprintf original-output-port args))
(define-struct range (start end caret-space? style color) #:inspector #f)
(define-struct rectangle (left top right bottom style color) #:inspector #f)
@ -3728,6 +3719,7 @@ designates the character that triggers autocompletion
line-paragraph
line-start-position
line-end-position
get-view-size
set-padding
get-padding)
@ -3739,6 +3731,7 @@ designates the character that triggers autocompletion
(define (constructor)
(super-new)
(setup-padding)
#;
(define space (text-width dc (number-space+1)))
#;
@ -3751,9 +3744,25 @@ designates the character that triggers autocompletion
;; add an extra 0 so it looks nice
(define (number-space+1) (string-append (number-space) "0"))
(define (repaint)
(send this invalidate-bitmap-cache))
(define padding-dc (new bitmap-dc% [bitmap (make-screen-bitmap 1 1)]))
(define (setup-padding)
(if (showing-line-numbers?)
(let ()
(send padding-dc set-font (get-style-font))
(define-values (padding-left padding-top padding-right padding-bottom) (get-padding))
(define new-padding (text-width padding-dc (number-space+1)))
(set-padding new-padding 0 0 0)
(when (not (= padding-left new-padding))
(repaint)))
(set-padding 0 0 0 0)))
;; call this method with #t or #f to turn on/off line numbers
(define/public (show-line-numbers! what)
(set! show-line-numbers? what))
(set! show-line-numbers? what)
(setup-padding))
(define/public (showing-line-numbers?)
show-line-numbers?)
@ -3769,11 +3778,6 @@ designates the character that triggers autocompletion
(send style-list basic-style))])
(send std get-font)))
;; low <= what <= high
(define (between low what high)
(and (>= what low)
(<= what high)))
(define-struct saved-dc-state (pen font foreground-color))
(define (save-dc-state dc)
(saved-dc-state (send dc get-pen)
@ -3855,8 +3859,37 @@ designates the character that triggers autocompletion
(min 255 (integer (* 255 green)))
(min 255 (integer (* 255 blue)))))
;; an offset that looks right
(define magic-space 5)
;; adjust space so that we are always at the left-most position where
;; drawing looks right
(define (left-space dc dx)
(define left (box 0))
(define top (box 0))
(define width (box 0))
(define height (box 0))
(send (send this get-admin) get-view left top width height)
#|
(define width2 (box 0))
(define height2 (box 0))
(get-view-size width2 height2)
|#
#;
(printf "left ~a top ~a width ~a height ~a width2 ~a height2 ~a\n"
(unbox left) (unbox top)
(unbox width) (unbox height)
(unbox width2) (unbox height2))
(+ (unbox left) dx))
(define/augment (after-insert start length)
(setup-padding)
(inner (void) after-insert start length))
(define/augment (after-delete start length)
(setup-padding)
(inner (void) after-delete start length))
(define/augment (after-change-style start length)
(setup-padding)
(inner (void) after-change-style start length))
(define (draw-numbers dc top bottom dx dy start-line end-line)
(define (draw-text . args)
@ -3869,11 +3902,10 @@ designates the character that triggers autocompletion
(for ([line (in-range start-line end-line)])
(define y (line-location line))
(when (between top y bottom)
(when (<= top y bottom)
(define view (number->string (add1 (line-paragraph line))))
(define final-x
(+ ;; dx
magic-space
(+ (left-space dc dx)
(case alignment
[(left) 0]
[(right) (- right-space (text-width dc view) single-space)]
@ -3890,9 +3922,11 @@ designates the character that triggers autocompletion
;; draw the line between the line numbers and the actual text
(define (draw-separator dc top bottom dx dy x)
(send dc draw-line (+ magic-space x) (+ dy top) (+ magic-space x) (+ dy bottom))
#;
(send dc draw-line (+ dx x) (+ dy top) (+ dx x) (+ dy bottom)))
(define line-x (+ (left-space dc dx) x))
(define line-y1 (+ dy top))
(define line-y2 (+ dy bottom))
(send dc draw-line line-x line-y1
line-x line-y2))
;; `line-numbers-space' will get mutated in the `on-paint' method
;; (define line-numbers-space 0)
@ -3932,11 +3966,14 @@ designates the character that triggers autocompletion
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
(if show-line-numbers?
(begin
#;
(set-padding (text-width dc (number-space+1)) 0 0 0)
(if before?
(let ()
(define left-most (left-space dc dx))
(set! old-clipping (send dc get-clipping-region))
(define saved-dc (save-dc-state dc))
(setup-dc dc)
(define clipped (make-object region% dc))
(define all (make-object region% dc))
(define copy (make-object region% dc))
@ -3950,11 +3987,14 @@ designates the character that triggers autocompletion
0 (+ dy top)
(text-width dc (number-space+1))
(- bottom top))
(restore-dc-state dc saved-dc)
(send copy subtract clipped)
(send dc set-clipping-region copy))
(begin
(send dc set-clipping-region old-clipping)
(draw-line-numbers dc left top right bottom dx dy))))
(void)
#;
(set-padding 0 0 0 0))
(void)
#;

218
collects/framework/splash.rkt
View File

@ -1,8 +1,9 @@
#lang scheme/base
#lang racket/base
(require scheme/class
scheme/file
scheme/gui/base)
(require racket/class
racket/file
racket/gui/base
(for-syntax racket/base))
(provide get-splash-bitmap
set-splash-bitmap
@ -28,10 +29,37 @@
(define splash-cache-dc (make-object bitmap-dc%))
(define splash-eventspace (make-eventspace))
(define (on-splash-eventspace/proc t)
(parameterize ([current-eventspace splash-eventspace])
(queue-callback t)))
(define-syntax-rule
(on-splash-eventspace e ...)
(on-splash-eventspace/proc (λ () e ...)))
(define (on-splash-eventspace/ret/proc t)
(define c (make-channel))
(parameterize ([current-eventspace splash-eventspace])
(queue-callback
(λ ()
(channel-put c (t)))))
(channel-get c))
(define-syntax (on-splash-eventspace/ret stx)
(syntax-case stx ()
[(_ e ...)
(with-syntax ([line (syntax-line stx)])
#'(on-splash-eventspace/ret/proc (λ () e ...))
#;
#'(begin
(printf "starting ~a\n" line)
(begin0
(on-splash-eventspace/ret/proc (λ () e ...))
(printf "finishing ~a\n" line))))]))
(define (get-splash-bitmap) splash-bitmap)
(define (set-splash-bitmap bm)
(set! splash-bitmap bm)
(send splash-canvas on-paint))
(on-splash-eventspace (send splash-canvas on-paint)))
(define (get-splash-canvas) splash-canvas)
(define (get-splash-eventspace) splash-eventspace)
@ -40,8 +68,8 @@
(set! splash-paint-callback sp)
(refresh-splash))
(define (get-splash-width) (send splash-canvas get-width))
(define (get-splash-height) (send splash-canvas get-height))
(define (get-splash-width) (on-splash-eventspace/ret (send splash-canvas get-width)))
(define (get-splash-height) (on-splash-eventspace/ret (send splash-canvas get-height)))
(define (set-splash-event-callback cb) (set! splash-event-callback cb))
(define (get-splash-event-callback cb) splash-event-callback)
@ -56,6 +84,26 @@
(call-splash-paint-callback splash-cache-dc)
(send splash-cache-dc set-bitmap #f)
(send splash-canvas on-paint))
(define (call-splash-paint-callback dc)
(cond
[(equal? 1 (procedure-arity splash-paint-callback))
(splash-paint-callback dc)]
[else
(splash-paint-callback dc
(send (get-gauge) get-value)
(send (get-gauge) get-range)
(send splash-canvas get-width)
(send splash-canvas get-height))])
(for-each (λ (icon)
(send dc draw-bitmap
(icon-bm icon)
(icon-x icon)
(icon-y icon)
'solid
(make-object color% "black")
(send (icon-bm icon) get-loaded-mask)))
icons))
(cond
[(not (is-a? splash-cache-bitmap bitmap%)) (void)]
@ -65,31 +113,14 @@
(parameterize ([current-eventspace splash-eventspace])
(queue-callback
recompute-bitmap/refresh))]))
(define (call-splash-paint-callback dc)
(cond
[(equal? 1 (procedure-arity splash-paint-callback))
(splash-paint-callback dc)]
[else
(splash-paint-callback dc
(send (get-gauge) get-value)
(send (get-gauge) get-range)
(get-splash-width)
(get-splash-height))])
(for-each (λ (icon)
(send dc draw-bitmap
(icon-bm icon)
(icon-x icon)
(icon-y icon)
'solid
(make-object color% "black")
(send (icon-bm icon) get-loaded-mask)))
icons))
(define (set-splash-progress-bar?! b?)
(send gauge-panel change-children
(λ (l) (if b? (list (get-gauge)) '()))))
(on-splash-eventspace/ret
(get-gauge) ;; force the gauge to be created
(send gauge-panel change-children
(λ (l) (if b? (list (get-gauge)) '())))))
;; the function bound to the variable should only be called on the splash-eventspace main thread
(define (splash-paint-callback dc)
(if splash-bitmap
(send dc draw-bitmap splash-bitmap 0 0)
@ -111,55 +142,57 @@
(unless allow-funny? (set! funny? #f))
(set! splash-title _splash-title)
(set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default)))
(send (get-gauge) set-range splash-max-width)
(send splash-tlw set-label splash-title)
(let/ec k
(define (no-splash)
(set! splash-bitmap #f)
(set! splash-canvas #f)
(set! splash-eventspace #f)
(k (void)))
(cond
[(or (path? splash-draw-spec)
(string? splash-draw-spec))
(unless (file-exists? splash-draw-spec)
(fprintf (current-error-port) "WARNING: bitmap path ~s not found\n" splash-draw-spec)
(no-splash))
(set! splash-bitmap (make-object bitmap% splash-draw-spec))
(unless (send splash-bitmap ok?)
(fprintf (current-error-port) "WARNING: bad bitmap ~s\n" splash-draw-spec)
(no-splash))
(send splash-canvas min-width (send splash-bitmap get-width))
(send splash-canvas min-height (send splash-bitmap get-height))
(set! splash-cache-bitmap (make-object bitmap%
(send splash-bitmap get-width)
(send splash-bitmap get-height)))]
[(and (vector? splash-draw-spec)
(procedure? (vector-ref splash-draw-spec 0))
(number? (vector-ref splash-draw-spec 1))
(number? (vector-ref splash-draw-spec 2)))
(set! splash-paint-callback (vector-ref splash-draw-spec 0))
(send splash-canvas min-width (vector-ref splash-draw-spec 1))
(send splash-canvas min-height (vector-ref splash-draw-spec 2))
(set! splash-cache-bitmap (make-object bitmap%
(vector-ref splash-draw-spec 1)
(vector-ref splash-draw-spec 2)))]
[(not splash-draw-spec)
(no-splash)]
[else
(fprintf (current-error-port)
"WARNING: unknown splash spec: ~s" splash-draw-spec)
(no-splash)])
(refresh-splash)
(send splash-tlw center 'both)
(thread (λ () (send splash-tlw show #t)))
(sync (system-idle-evt)) ; try to wait for dialog to be shown
(flush-display) (yield) (sleep)
(flush-display) (yield) (sleep)))
(on-splash-eventspace/ret
(send (get-gauge) set-range splash-max-width)
(send splash-tlw set-label splash-title)
(cond
[(or (path? splash-draw-spec)
(string? splash-draw-spec))
(unless (file-exists? splash-draw-spec)
(fprintf (current-error-port) "WARNING: bitmap path ~s not found\n" splash-draw-spec)
(no-splash))
(set! splash-bitmap (make-object bitmap% splash-draw-spec))
(unless (send splash-bitmap ok?)
(fprintf (current-error-port) "WARNING: bad bitmap ~s\n" splash-draw-spec)
(no-splash))
(send splash-canvas min-width (send splash-bitmap get-width))
(send splash-canvas min-height (send splash-bitmap get-height))
(set! splash-cache-bitmap (make-object bitmap%
(send splash-bitmap get-width)
(send splash-bitmap get-height)))]
[(and (vector? splash-draw-spec)
(procedure? (vector-ref splash-draw-spec 0))
(number? (vector-ref splash-draw-spec 1))
(number? (vector-ref splash-draw-spec 2)))
(set! splash-paint-callback (vector-ref splash-draw-spec 0))
(send splash-canvas min-width (vector-ref splash-draw-spec 1))
(send splash-canvas min-height (vector-ref splash-draw-spec 2))
(set! splash-cache-bitmap (make-object bitmap%
(vector-ref splash-draw-spec 1)
(vector-ref splash-draw-spec 2)))]
[(not splash-draw-spec)
(no-splash)]
[else
(fprintf (current-error-port)
"WARNING: unknown splash spec: ~s" splash-draw-spec)
(no-splash)])
(refresh-splash)
(send splash-tlw center 'both)
(send splash-tlw show-without-yield)
(sync (system-idle-evt)) ; try to wait for dialog to be shown
(flush-display) (yield) (sleep)
(flush-display) (yield) (sleep))))
(define splash-title "no title")
@ -172,9 +205,10 @@
(define (close-splash)
(unless (= splash-max-width splash-current-width)
(splash-set-preference (get-splash-width-preference-name) (max 1 splash-current-width)))
(set! quit-on-close? #f)
(on-splash-eventspace/ret (set! quit-on-close? #f))
(when splash-tlw
(send splash-tlw show #f)))
(on-splash-eventspace
(send splash-tlw show #f))))
(define (shutdown-splash)
(set! splash-load-handler (λ (old-load f expected) (old-load f expected))))
@ -190,11 +224,13 @@
(define (splash-load-handler old-load f expected)
(set! splash-current-width (+ splash-current-width 1))
(when (<= splash-current-width splash-max-width)
(send (get-gauge) set-value splash-current-width)
(when (or (not (member (get-gauge) (send gauge-panel get-children)))
;; when the gauge is not visible, we'll redraw the canvas
(refresh-splash-on-gauge-change? splash-current-width splash-max-width))
(refresh-splash)))
(let ([splash-save-width splash-current-width])
(on-splash-eventspace
(send (get-gauge) set-value splash-save-width)
(when (or (not (member (get-gauge) (send gauge-panel get-children)))
;; when the gauge is not visible, we'll redraw the canvas regardless
(refresh-splash-on-gauge-change? splash-save-width splash-max-width))
(refresh-splash)))))
(old-load f expected))
(let-values ([(make-compilation-manager-load/use-compiled-handler
@ -281,6 +317,7 @@
(define (splash-set-preference name value)
(put-preferences (list name) (list value)))
;; only modified (or read) on the splash eventspace handler thread
(define quit-on-close? #t)
(define splash-tlw%
@ -302,23 +339,28 @@
(parameterize ([current-eventspace splash-eventspace])
(new splash-tlw%
(label splash-title))))
(send splash-tlw set-alignment 'center 'center)
(define panel (make-object vertical-pane% splash-tlw))
(define splash-canvas (new splash-canvas% [parent panel] [style '(no-autoclear)]))
(define gauge-panel (make-object horizontal-pane% panel))
(define panel (on-splash-eventspace/ret (make-object vertical-pane% splash-tlw)))
(define splash-canvas (on-splash-eventspace/ret (new splash-canvas% [parent panel] [style '(no-autoclear)])))
(define gauge-panel (on-splash-eventspace/ret (make-object horizontal-pane% panel)))
;; only called on the splash eventspace main thread
(define get-gauge
(let ([gauge #f])
(λ ()
(unless (eq? (current-thread) (eventspace-handler-thread splash-eventspace))
(error 'get-gauge "called from the wrong thread"))
(unless gauge
(set! gauge
(if funny?
(make-object funny-gauge% gauge-panel)
(make-object gauge% #f splash-max-width gauge-panel '(horizontal)))))
gauge)))
(send panel stretchable-width #f)
(send panel stretchable-height #f)
(send gauge-panel set-alignment 'center 'top)
(send splash-canvas focus)
(send splash-canvas stretchable-width #f)
(send splash-canvas stretchable-height #f)
(on-splash-eventspace/ret
(send splash-tlw set-alignment 'center 'center)
(send panel stretchable-width #f)
(send panel stretchable-height #f)
(send gauge-panel set-alignment 'center 'top)
(send splash-canvas focus)
(send splash-canvas stretchable-width #f)
(send splash-canvas stretchable-height #f))

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

@ -113,6 +113,7 @@ key-event%
keymap%
label->plain-label
labelled-menu-item<%>
linear-gradient%
list-box%
list-control<%>
make-bitmap
@ -160,6 +161,7 @@ read-bitmap
read-editor-global-footer
read-editor-global-header
read-editor-version
radial-gradient%
region%
register-collecting-blit
scroll-event%

13
collects/mred/private/check.rkt
View File

@ -146,6 +146,19 @@
(unless (or (label-string? label) (is-a? label wx:bitmap%))
(raise-type-error (who->name who) "string (up to 200 characters) or bitmap% object" label)))
(define (check-label-string-or-bitmap-or-both who label)
(unless (or (label-string? label) (is-a? label wx:bitmap%)
(and (list? label)
(= 3 (length label))
(is-a? (car label) wx:bitmap%)
(label-string? (cadr label))
(memq (caddr label) '(left right top bottom))))
(raise-type-error (who->name who)
(string-append
"string (up to 200 characters), bitmap% object, or list of bitmap%, "
"string, and image-placement symbol ('left, 'right, 'top, or 'bottom)")
label)))
(define (check-label-string-or-bitmap/false who label)
(unless (or (not label) (label-string? label) (is-a? label wx:bitmap%))
(raise-type-error (who->name who) "string (up to 200 characters), bitmap% object, or #f" label)))

6
collects/mred/private/const.rkt
View File

@ -38,7 +38,11 @@
(define arrow-cursor (make-object wx:cursor% 'arrow))
(define default-x-prefix (if (eq? 'unix (system-type))
(let ([v (get-preference '|MrEd:defaultMenuPrefix| (lambda () 'ctl))])
(let ([v (get-preference
'|GRacket:defaultMenuPrefix|
;; on fail, fall back to old name of pref:
(lambda () (get-preference '|MrEd:defaultMenuPrefix|
(lambda () 'ctl))))])
(if (memq v '(meta ctl alt ctl-m))
v
'ctl))

22
collects/mred/private/mritem.rkt
View File

@ -58,10 +58,16 @@
;; for keyword use
[font no-val])
(rename [super-set-label set-label])
(private-field [label lbl][callback cb] [is-bitmap? (lbl . is-a? . wx:bitmap%)])
(private-field [label lbl][callback cb]
[can-bitmap? (or (lbl . is-a? . wx:bitmap%)
(pair? lbl))]
[can-string? (or (string? lbl)
(pair? lbl))])
(override
[get-label (lambda () label)]
[get-plain-label (lambda () (and (string? label) (wx:label->plain-label label)))]
[get-plain-label (lambda ()
(let ([label (if (pair? label) (cadr label) label)])
(and (string? label) (wx:label->plain-label label))))]
[set-label (entry-point
(lambda (l)
((label-checker)
@ -69,12 +75,16 @@
(let ([l (if (string? l)
(string->immutable-string l)
l)])
(when (or (and is-bitmap?
(when (or (and can-bitmap?
(l . is-a? . wx:bitmap%))
(and (not is-bitmap?)
(and can-string?
(string? l)))
(send wx set-label l)
(set! label l)))))])
(if (pair? label)
(if (string? l)
(set! label (list (car label) l (caddr label)))
(set! label (list l (cadr label) (caddr label))))
(set! label l))))))])
(public
[hidden-child? (lambda () #f)] ; module-local method
[label-checker (lambda () check-label-string/false)] ; module-local method
@ -210,7 +220,7 @@
[label-checker (lambda () check-label-string-or-bitmap)]) ; module-local method
(sequence
(let ([cwho '(constructor button)])
(check-label-string-or-bitmap cwho label)
(check-label-string-or-bitmap-or-both cwho label)
(check-container-parent cwho parent)
(check-callback cwho callback)
(check-style cwho #f '(border deleted) style)

2
collects/mred/private/mrtop.rkt
View File

@ -139,6 +139,8 @@
[do-set-status-text (lambda (s)
(when status-message
(send status-message set-label s)))])
(override
[get-client-handle (lambda () (send wx-panel get-client-handle))])
(sequence
(super-init (lambda () (set! wx (mk-wx finish)) wx)
(lambda () wx-panel) (lambda () mid-panel)

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

@ -116,7 +116,7 @@
get-client-size get-size get-width get-height get-x get-y
get-cursor set-cursor popup-menu
show is-shown? on-superwindow-show refresh
get-handle))
get-handle get-client-handle))
(define-keywords window%-keywords [enabled #t])
@ -173,6 +173,7 @@
[get-plain-label (lambda () (and (string? label) (wx:label->plain-label label)))]
[get-handle (lambda () (send wx get-handle))]
[get-client-handle (lambda () (send wx get-client-handle))]
[accept-drop-files
(entry-point

30
collects/mred/private/wx/cocoa/button.rkt
View File

@ -32,6 +32,11 @@
(-a _void (clicked: [_id sender])
(queue-window*-event wxb (lambda (wx) (send wx clicked)))))
(define NSImageLeft 2)
(define NSImageRight 3)
(define NSImageBelow 4)
(define NSImageAbove 5)
(defclass core-button% item%
(init parent cb label x y w h style font
[button-type #f])
@ -57,11 +62,21 @@
[else
(if button-type
(tellv cocoa setTitle: #:type _NSString "")
(tellv cocoa setImage: (bitmap->image label)))])
(begin
(when (pair? label)
(tellv cocoa setTitle: #:type _NSString (cadr label))
(tellv cocoa setImagePosition: #:type _NSInteger
(case (caddr label)
[(left) NSImageLeft]
[(right) NSImageRight]
[(top) NSImageAbove]
[(bottom) NSImageBelow])))
(tellv cocoa setImage: (bitmap->image (if (pair? label) (car label) label)))))])
(init-font cocoa font)
(tellv cocoa sizeToFit)
(when (and (eq? event-type 'button)
(string? label))
(or (string? label)
(pair? label)))
(when font
(let ([n (send font get-point-size)])
;; If the font is small, adjust the control size:
@ -85,10 +100,19 @@
(NSSize-height (NSRect-size frame)))))))
cocoa))
(when (pair? label)
;; It looks better to add extra padding around the button:
(let ([f (tell #:type _NSRect button-cocoa frame)])
(tellv button-cocoa setFrame: #:type _NSRect
(make-NSRect
(NSRect-origin f)
(make-NSSize (+ (NSSize-width (NSRect-size f)) 2)
(+ (NSSize-height (NSRect-size f)) 4))))))
(define-values (cocoa image-cocoa)
(if (and button-type
(not (string? label)))
;; Check-box image: need an view to join a button and an image view:
;; Check-box image: need a view to join a button and an image view:
;; (Could we use the NSImageButtonCell from the radio-box implementation
;; instead?)
(let* ([frame (tell #:type _NSRect button-cocoa frame)]

5
collects/mred/private/wx/cocoa/canvas.rkt
View File

@ -238,7 +238,6 @@
is-window-enabled?
block-mouse-events
move get-x get-y
on-size
register-as-child
get-size get-position
set-focus
@ -456,7 +455,9 @@
(fix-dc)
(when (is-auto-scroll?)
(reset-auto-scroll 0 0))
(on-size 0 0))
(on-size))
(define/public (on-size) (void))
(define/public (show-scrollbars h? v?)
(let ([h? (and h? hscroll-ok?)]

4
collects/mred/private/wx/cocoa/frame.rkt
View File

@ -63,7 +63,7 @@
(let ([wx (->wx wxb)])
(when wx
(queue-window-event wx (lambda ()
(send wx on-size 0 0)
(send wx queue-on-size)
(send wx clean-up)))
;; Live resize:
(constrained-reply (send wx get-eventspace)
@ -74,7 +74,7 @@
[-a _void (windowDidMove: [_id notification])
(when wxb
(queue-window*-event wxb (lambda (wx)
(send wx on-size 0 0))))]
(send wx queue-on-size))))]
[-a _void (windowDidBecomeMain: [_id notification])
;; We check whether the window is visible because
;; clicking the dock item tries to resurrect a hidden

7
collects/mred/private/wx/cocoa/window.rkt
View File

@ -591,7 +591,9 @@
[y (if (= y -11111) (get-y) y)])
(tellv cocoa setNeedsDisplay: #:type _BOOL #t)
(tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x (flip y h))
(make-NSSize w h)))))
(make-NSSize w h))))
(queue-on-size))
(define/public (internal-move x y)
(set-size x y (get-width) (get-height)))
(define/public (move x y)
@ -702,7 +704,7 @@
(define/public (on-char s) (void))
(define/public (on-event m) (void))
(define/public (on-size x y) (void))
(define/public (queue-on-size) (void))
(define last-l? #f)
(define last-m? #f)
@ -725,6 +727,7 @@
(send (get-parent) end-no-cursor-rects))
(define/public (get-handle) (get-cocoa))
(define/public (get-client-handle) (get-cocoa-content))
(define/public (popup-menu m x y)
(send m do-popup (get-cocoa-content) (get-cocoa-window) x (flip-client y)

41
collects/mred/private/wx/gtk/button.rkt
View File

@ -22,6 +22,13 @@
(define-gtk gtk_button_new (_fun -> _GtkWidget))
(define-gtk gtk_window_set_default (_fun _GtkWidget (_or-null _GtkWidget) -> _void))
(define-gtk gtk_button_set_label (_fun _GtkWidget _string -> _void))
(define-gtk gtk_button_set_image (_fun _GtkWidget _GtkWidget -> _void))
(define-gtk gtk_button_set_image_position (_fun _GtkWidget _int -> _void))
(define GTK_POS_LEFT 0)
(define GTK_POS_RIGHT 1)
(define GTK_POS_TOP 2)
(define GTK_POS_BOTTOM 3)
(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void))
(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget))
@ -47,18 +54,35 @@
(as-gtk-allocation
(gtk_new_with_mnemonic (or (mnemonic-string label) "")))]
[else
(let ([pixbuf (bitmap->pixbuf label)])
(let ([pixbuf (bitmap->pixbuf (if (pair? label)
(car label)
label))])
(atomically
(let ([gtk (as-gtk-allocation (gtk_new))]
(let ([gtk (if (pair? label)
(as-gtk-allocation (gtk_new_with_mnemonic (cadr label)))
(as-gtk-allocation (gtk_new)))]
[image-gtk (gtk_image_new_from_pixbuf pixbuf)])
(release-pixbuf pixbuf)
(gtk_container_add gtk image-gtk)
(gtk_widget_show image-gtk)
(if (pair? label)
(begin
(gtk_button_set_image gtk image-gtk)
(gtk_button_set_image_position
gtk
(case (caddr label)
[(left) GTK_POS_LEFT]
[(right) GTK_POS_RIGHT]
[(top) GTK_POS_TOP]
[(bottom) GTK_POS_BOTTOM])))
(begin
(gtk_container_add gtk image-gtk)
(gtk_widget_show image-gtk)))
gtk)))])]
[callback cb]
[font font]
[no-show? (memq 'deleted style)])
(define gtk (get-gtk))
(define both-labels? (pair? label))
(when (eq? event-type 'button)
(set-gtk-object-flags! gtk (bitwise-ior (get-gtk-object-flags gtk)
@ -92,9 +116,12 @@
(atomically
(let ([image-gtk (gtk_image_new_from_pixbuf pixbuf)])
(release-pixbuf pixbuf)
(gtk_container_remove gtk (gtk_bin_get_child gtk))
(gtk_container_add gtk image-gtk)
(gtk_widget_show image-gtk))))]))
(if both-labels?
(gtk_button_set_image gtk image-gtk)
(begin
(gtk_container_remove gtk (gtk_bin_get_child gtk))
(gtk_container_add gtk image-gtk)
(gtk_widget_show image-gtk))))))]))
(define/public (set-border on?)
(gtk_window_set_default (get-window-gtk) (if on? gtk #f))))

9
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -194,7 +194,7 @@
[gl-config #f])
(inherit get-gtk set-size get-size get-client-size
on-size get-top-win
get-top-win
set-auto-size
adjust-client-delta infer-client-delta
is-auto-scroll? get-virtual-width get-virtual-height
@ -438,10 +438,9 @@
(define/override (internal-on-client-size w h)
(reset-dc))
(define/override (on-client-size w h)
(let ([xb (box 0)]
[yb (box 0)])
(get-size xb yb)
(on-size (unbox xb) (unbox yb))))
(on-size))
(define/public (on-size) (void))
(define/public (show-scrollbars h? v?)
(when hscroll-gtk

2
collects/mred/private/wx/gtk/frame.rkt
View File

@ -139,7 +139,7 @@
style)
(init [is-dialog? #f])
(inherit get-gtk set-size on-size
(inherit get-gtk set-size
pre-on-char pre-on-event
get-client-delta get-size
get-parent get-eventspace

6
collects/mred/private/wx/gtk/utils.rkt
View File

@ -56,19 +56,19 @@
(ffi-lib "libgio-2.0-0")
(ffi-lib "libgdk_pixbuf-2.0-0")
(ffi-lib "libgdk-win32-2.0-0")]
[else (ffi-lib "libgdk-x11-2.0" '("0"))]))
[else (ffi-lib "libgdk-x11-2.0" '("0" ""))]))
(define gdk_pixbuf-lib
(case (system-type)
[(windows)
(ffi-lib "libgdk_pixbuf-2.0-0")]
[(unix)
(ffi-lib "libgdk_pixbuf-2.0" '("0"))]
(ffi-lib "libgdk_pixbuf-2.0" '("0" ""))]
[else gdk-lib]))
(define gtk-lib
(case (system-type)
[(windows)
(ffi-lib "libgtk-win32-2.0-0")]
[else (ffi-lib "libgtk-x11-2.0" '("0"))]))
[else (ffi-lib "libgtk-x11-2.0" '("0" ""))]))
(define-ffi-definer define-gtk gtk-lib)
(define-ffi-definer define-gdk gdk-lib)

14
collects/mred/private/wx/gtk/window.rkt
View File

@ -420,7 +420,8 @@
(unless (= h -1) (set! save-h h))
(set! save-w (max save-w client-delta-w))
(set! save-h (max save-h client-delta-h))
(really-set-size gtk x y save-x save-y save-w save-h)))
(really-set-size gtk x y save-x save-y save-w save-h)
(queue-on-size)))
(define/public (save-size x y w h)
(set! save-w w)
@ -441,13 +442,7 @@
(set! save-h h)
(queue-on-size)))
(define on-size-queued? #f)
(define/public (queue-on-size)
(unless on-size-queued?
(set! on-size-queued? #t)
(queue-window-event this (lambda ()
(set! on-size-queued? #f)
(on-size 0 0)))))
(define/public (queue-on-size) (void))
(define client-delta-w 0)
(define client-delta-h 0)
@ -605,8 +600,6 @@
(define/public (on-char e) (void))
(define/public (on-event e) (void))
(define/public (on-size w h) (void))
(define/public (register-child child on?)
(void))
(define/public (register-child-in-parent on?)
@ -619,6 +612,7 @@
(define/public (on-drop-file path) (void))
(define/public (get-handle) (get-gtk))
(define/public (get-client-handle) (get-client-gtk))
(define/public (popup-menu m x y)
(let ([gx (box x)]

103
collects/mred/private/wx/win32/button.rkt
View File

@ -3,6 +3,7 @@
racket/draw
ffi/unsafe
"../../syntax.rkt"
"../../lock.rkt"
"../common/event.rkt"
"item.rkt"
"utils.rkt"
@ -18,16 +19,23 @@
(define BM_SETSTYLE #x00F4)
(define-kernel32 GetVersion (_wfun -> _DWORD))
(define xp? (= 5 (bitwise-and #xFF (GetVersion))))
(define base-button%
(class item%
(inherit set-control-font auto-size get-hwnd
remember-label-bitmap)
remember-label-bitmap set-size)
(init parent cb label x y w h style font)
(define callback cb)
(define bitmap? (label . is-a? . bitmap%))
(define bitmap? (or (label . is-a? . bitmap%)
(pair? label)))
(define orientation (and (pair? label)
(caddr label)))
(define/public (get-class) "PLTBUTTON")
(define/public (get-flags) BS_PUSHBUTTON)
@ -37,12 +45,19 @@
[hwnd
(CreateWindowExW/control 0
(get-class)
(if (string? label)
label
"<image>")
(cond
[(string? label) label]
[(pair? label) (cadr label)]
[else "<image>"])
(bitwise-ior (get-flags) WS_CHILD WS_CLIPSIBLINGS
(if bitmap?
BS_BITMAP
(case (and (not xp?)
orientation)
[(#f) BS_BITMAP]
[(left) BS_LEFT]
[(right) BS_RIGHT]
[(top) BS_TOP]
[(bottom) BS_BOTTOM])
0))
0 0 0 0
(send parent get-client-hwnd)
@ -52,24 +67,94 @@
[style style])
(when bitmap?
(let ([hbitmap (bitmap->hbitmap label #:bg (get-button-background))])
(let ([hbitmap (bitmap->hbitmap (if (pair? label)
(if xp?
(collapse-to-bitmap label font)
(car label))
label)
#:bg (get-button-background))])
(remember-label-bitmap hbitmap)
(SendMessageW (get-hwnd) BM_SETIMAGE IMAGE_BITMAP
(cast hbitmap _HBITMAP _LPARAM))))
(define/private (collapse-to-bitmap label font)
;; XP doesn't handle a combination of string
;; and bitmap labels
(let-values ([(w h) (auto-size-button font label
#:resize (lambda (w h)
(values w h)))])
(let* ([bm (make-object bitmap% w h #f #f)]
[dc (make-object bitmap-dc% bm)]
[h? (memq (caddr label) '(left right))])
(send dc draw-bitmap (car label)
(if h?
(if (eq? (caddr label) 'left)
3
(- w (send (car label) get-width) 3))
(quotient (- w (send (car label) get-width)) 2))
(if h?
(quotient (- h (send (car label) get-height)) 2)
(if (eq? (caddr label) 'top)
3
(- h (send (car label) get-height) 3))))
(send dc set-font (or font (get-default-control-font)))
(let-values ([(tw th ta td) (send dc get-text-extent (cadr label))])
(send dc draw-text (cadr label)
(if h?
(if (eq? (caddr label) 'left)
(- w tw 3)
3)
(quotient (- w tw) 2))
(if h?
(quotient (- h th) 2)
(if (eq? (caddr label) 'top)
(- h th 3)
3))))
(send dc set-bitmap #f)
bm)))
(set-control-font font)
(define/public (get-button-background)
#xFFFFFF)
(define/public (auto-size-button font label)
(define/public (auto-size-button
font
label
#:resize [resize (lambda (w h) (set-size -11111 -11111 w h))])
(cond
[orientation
(let ([h? (memq orientation '(left right))])
(auto-size font (list (car label) (cadr label))
0 0 12 8
resize
#:combine-width (if h? + max)
#:combine-height (if h? max +)))]
[bitmap?
(auto-size font label 0 0 4 4)]
[else
(auto-size font label 60 20 12 0 #:scale-w 1.1 #:scale-h 1.1)]))
(auto-size-button font label)
(define xp-label-bitmap (and xp? orientation (car label)))
(define xp-label-string (and xp? orientation (string->immutable-string (cadr label))))
(define xp-label-font (and xp? orientation font))
(define/override (set-label s)
(if (and orientation xp?)
(atomically
(begin
(if (string? s)
(set! xp-label-string s)
(set! xp-label-bitmap s))
(super
set-label
(collapse-to-bitmap (list xp-label-bitmap
xp-label-string
orientation)
xp-label-font))))
(super set-label s)))
(define/override (is-command? cmd)
(= cmd BN_CLICKED))
@ -88,5 +173,3 @@
(define button%
(class base-button%
(super-new)))

31
collects/mred/private/wx/win32/canvas.rkt
View File

@ -86,8 +86,7 @@
set-control-font
is-auto-scroll? get-virtual-width get-virtual-height
reset-auto-scroll
refresh-for-autoscroll
on-size)
refresh-for-autoscroll)
(define hscroll? (memq 'hscroll style))
(define vscroll? (memq 'vscroll style))
@ -162,17 +161,21 @@
(queue-paint)
(if (positive? paint-suspended)
(set! suspended-refresh? #t)
(let* ([hbrush (if no-autoclear?
#f
(if transparent?
background-hbrush
(CreateSolidBrush bg-colorref)))])
(when hbrush
(let ([r (GetClientRect canvas-hwnd)])
(FillRect hdc r hbrush))
(unless transparent?
(DeleteObject hbrush)))
(let ([erase
(lambda ()
(let* ([hbrush (if no-autoclear?
#f
(if transparent?
background-hbrush
(CreateSolidBrush bg-colorref)))])
(when hbrush
(let ([r (GetClientRect canvas-hwnd)])
(FillRect hdc r hbrush))
(unless transparent?
(DeleteObject hbrush)))))])
(when transparent? (erase))
(unless (do-canvas-backing-flush hdc)
(unless transparent? (erase))
(queue-paint)))))
(EndPaint w ps)))
0]
@ -237,7 +240,9 @@
[h (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h)])
(MoveWindow canvas-hwnd 0 0 (max 1 (- w COMBO-WIDTH)) h #t)
(MoveWindow combo-hwnd 0 0 (max 1 w) (- h 2) #t)))
(on-size 0 0))
(on-size))
(define/public (on-size) (void))
;; The `queue-paint' and `paint-children' methods
;; are defined by `canvas-mixin' from ../common/canvas-mixin

6
collects/mred/private/wx/win32/frame.rkt
View File

@ -105,7 +105,7 @@
(inherit get-hwnd
is-shown?
get-eventspace
on-size
queue-on-size
pre-on-char pre-on-event
reset-cursor-in-child)
@ -215,10 +215,10 @@
0]
[(and (= msg WM_SIZE)
(not (= wParam SIZE_MINIMIZED)))
(queue-window-event this (lambda () (on-size 0 0)))
(queue-window-event this (lambda () (queue-on-size)))
(stdret 0 1)]
[(= msg WM_MOVE)
(queue-window-event this (lambda () (on-size 0 0)))
(queue-window-event this (lambda () (queue-on-size)))
(stdret 0 1)]
[(= msg WM_ACTIVATE)
(let ([state (LOWORD wParam)]

13
collects/mred/private/wx/win32/hbitmap.rkt
View File

@ -4,6 +4,7 @@
racket/draw
racket/draw/private/local
racket/class
"dc.rkt"
"types.rkt"
"utils.rkt"
"const.rkt")
@ -18,6 +19,18 @@
#:bg [bg (GetSysColor COLOR_BTNFACE)])
(let* ([w (send bm get-width)]
[h (send bm get-height)]
[bm (if (bm . is-a? . win32-bitmap%)
;; Windows wants to use the result bitmap
;; as an ARGB bitmap, but Cairo seems to transfer
;; RGB win32 bitmaps to RGB win32 bitmaps in a
;; way that sometimes mangles the alpha; avoid the
;; problem by first copying to a Cairo memory bitmap.
(let* ([new-b (make-object bitmap% w h #f #f)]
[dc (make-object bitmap-dc% new-b)])
(send dc draw-bitmap bm 0 0)
(send dc set-bitmap #f)
new-b)
bm)]
[mask-bm (or mask-bm
(send bm get-loaded-mask))]
[to-frac (lambda (v) (/ v 255.0))]

6
collects/mred/private/wx/win32/theme.rkt
View File

@ -55,8 +55,10 @@
-> (when (negative? r)
(error 'CloseThemeData "failed: ~s" (bitwise-and #xFFFF r))))
#:wrap (deallocator))
(define-uxtheme OpenThemeData (_wfun _HWND _string/utf-16 -> _HTHEME)
#:wrap (allocator CloseThemeData))
(define (maybe-CloseThemeData v) (when v (CloseThemeData v)))
(define-uxtheme OpenThemeData (_wfun _HWND _string/utf-16 -> (_or-null _HTHEME))
#:wrap (allocator maybe-CloseThemeData))
(define-uxtheme GetThemeFont (_wfun _HTHEME _HDC _int _int _int (f : (_ptr o _LOGFONT))
-> (r : _HRESULT)
-> (if (negative? r)

5
collects/mred/private/wx/win32/window.rkt
View File

@ -25,6 +25,7 @@
queue-window-refresh-event
location->window
flush-display
get-default-control-font
GetWindowRect
GetClientRect))
@ -243,11 +244,12 @@
(unless (memq 'deleted style)
(show #t))
(define/public (on-size w h) (void))
(define/public (queue-on-size) (void))
(define/public (on-set-focus) (void))
(define/public (on-kill-focus) (void))
(define/public (get-handle) hwnd)
(define/public (get-client-handle) (get-client-hwnd))
(define enabled? #t)
(define parent-enabled? #t)
@ -313,6 +315,7 @@
(MoveWindow hwnd x y w h #t))
(unless (and (= w -1) (= h -1))
(on-resized))
(queue-on-size)
(refresh))
(define/public (move x y)
(set-size x y -1 -1))

25
collects/mred/private/wxme/editor-canvas.rkt
View File

@ -288,13 +288,16 @@
(send admin set-canvas #f)
#|(super ~)|#)
(define/override (on-size w h)
(define/override (on-size)
(unless noloop?
(unless (and (= w lastwidth)
(= h lastheight))
(unless (and media
(send media get-printing))
(reset-size)))))
(unless (and media
(send media get-printing))
(let-boxes ([w 0]
[h 0])
(get-size w h)
(unless (and (= w lastwidth)
(= h lastheight))
(reset-size))))))
(define/private (reset-size)
(reset-visual #f)
@ -1131,17 +1134,17 @@
(define/public (do-scroll-to localx localy w h refresh? bias prev? next? only-focus?)
(and canvas
(or (and (or (send canvas is-focus-on?)
(not only-focus?))
(list (send canvas scroll-to localx localy w h refresh? bias)))
(and (not (send canvas is-focus-on?))
(or (and (not (send canvas is-focus-on?))
(or
(and prev?
prevadmin
(send prevadmin do-scroll-to localx localy w h refresh? bias #t #f #t))
(and next?
nextadmin
(send nextadmin do-scroll-to localx localy w h refresh? bias #f #t #t)))))))
(send nextadmin do-scroll-to localx localy w h refresh? bias #f #t #t))))
(and (or (not only-focus?)
(send canvas is-focus-on?))
(list (send canvas scroll-to localx localy w h refresh? bias))))))
(def/override (grab-caret [(symbol-in immediate display global) dist])
(when canvas

4
collects/mred/private/wxme/editor.rkt
View File

@ -447,10 +447,6 @@
(define/public (set-caret-owner snip focus) (void))
(define/public (read-from-file mf) #f)
(define/public (do-copy time) (void))
(define/public (do-paste time) (void))
(define/public (do-paste-x-selection time) (void))
(def/public (do-edit-operation [symbol? op] [any? [recursive? #t]] [exact-integer? [time 0]])
(if (and recursive?
s-caret-snip)

8
collects/mred/private/wxme/pasteboard.rkt
View File

@ -1751,7 +1751,7 @@
(copy extend? time)
(clear))
(def/override (do-copy [exact-integer? time] [bool? extend?])
(def/public (do-copy [exact-integer? time] [bool? extend?])
(set-common-copy-region-data! #f)
(let ([sl (if (and extend?
copy-style-list)
@ -1814,10 +1814,10 @@
(add-selected snip)
(loop (snip->next snip))))))))
(def/override (do-paste [exact-integer? time])
(def/public (do-paste [exact-integer? time])
(do-generic-paste the-clipboard time))
(def/override (do-paste-x-selection [exact-integer? time])
(def/public (do-paste-x-selection [exact-integer? time])
(do-generic-paste the-x-selection-clipboard time))
(define/private (generic-paste x-sel? time)
@ -1907,7 +1907,7 @@
[any? [replace-styles? #f]])
(if (or s-user-locked?
(not (zero? write-locked)))
'guess ;; FIXME: docs say that this is more specific
'standard
(do-insert-file (method-name 'pasteboard% 'insert-file) f replace-styles?)))
(define/private (do-insert-file who f clear-styles?)

16
collects/mred/private/wxme/text.rkt
View File

@ -2032,10 +2032,10 @@
(copy extend? time start end)
(delete start end))))
(def/override (do-copy [exact-nonnegative-integer? startp]
[exact-nonnegative-integer? endp]
[exact-integer? time]
[bool? extend?])
(def/public (do-copy [exact-nonnegative-integer? startp]
[exact-nonnegative-integer? endp]
[exact-integer? time]
[bool? extend?])
(let ([startp (max startp 0)]
[endp (min endp len)])
(unless (endp . <= . startp)
@ -2094,10 +2094,10 @@
(set! prev-paste-start start)
(set! prev-paste-end (+ start delta)))))
(define/override (do-paste start time)
(define/public (do-paste start time)
(do-generic-paste the-clipboard start time))
(define/override (do-paste-x-selection start time)
(define/public (do-paste-x-selection start time)
(do-generic-paste the-x-selection-clipboard start time))
(define/private (generic-paste x-sel? time start end)
@ -2592,7 +2592,9 @@
[(symbol-in guess same copy standard text text-force-cr) [format 'guess]]
[any? [replace-styles? #t]])
(if (or write-locked? s-user-locked?)
'guess ;; FIXME: docs say that this is more specific
(if (not (detect-wxme-file (method-name 'text% 'insert-file) f #t))
'text
'standard)
(do-insert-file (method-name 'text% 'insert-file) f format replace-styles?)))
(define/private (do-insert-file who f fmt clear-styles?)

1
collects/mred/private/wxpanel.rkt
View File

@ -34,7 +34,6 @@
[on-set-focus (lambda () (void))]
[on-kill-focus (lambda () (void))]
[set-focus (lambda () (void))]
[on-size (lambda () (void))]
[enable (lambda () (void))]
[show (lambda (on?) (void))]
[is-shown? (lambda () #f)]

4
collects/mred/private/wxtop.rkt
View File

@ -395,8 +395,8 @@
;; aren't stretchable, frame resized to size of
;; contents. Each direction is handled
;; independently.
[on-size
(lambda (bad-width bad-height)
[queue-on-size
(lambda ()
(unless (and already-trying? (not (eq? 'unix (system-type))))
(parameterize ([wx:current-eventspace (get-eventspace)])
(wx:queue-callback (lambda () (resized)) #t))))])

45
collects/mred/private/wxwindow.rkt
View File

@ -190,29 +190,28 @@
(as-exit
(lambda ()
(send (get-proxy) on-drop-file f)))))]
[on-size (lambda (bad-w bad-h)
(super on-size bad-w bad-h)
;; Delay callback to make sure X structures (position) are updated, first.
;; Also, Windows needs a trampoline.
(queue-window-callback
this
(entry-point
(lambda ()
(let ([mred (get-mred)])
(when mred
(let* ([w (get-width)]
[h (get-height)])
(when (not (and (= w old-w) (= h old-h)))
(set! old-w w)
(set! old-h h)
(as-exit (lambda () (send mred on-size w h)))))
(let* ([p (area-parent)]
[x (- (get-x) (or (and p (send p dx)) 0))]
[y (- (get-y) (or (and p (send p dy)) 0))])
(when (not (and (= x old-x) (= y old-y)))
(set! old-x x)
(set! old-y y)
(as-exit (lambda () (send mred on-move x y)))))))))))]
[queue-on-size
(lambda ()
(super queue-on-size)
(queue-window-callback
this
(entry-point
(lambda ()
(let ([mred (get-mred)])
(when mred
(let* ([w (get-width)]
[h (get-height)])
(when (not (and (= w old-w) (= h old-h)))
(set! old-w w)
(set! old-h h)
(as-exit (lambda () (send mred on-size w h)))))
(let* ([p (area-parent)]
[x (- (get-x) (or (and p (send p dx)) 0))]
[y (- (get-y) (or (and p (send p dy)) 0))])
(when (not (and (= x old-x) (= y old-y)))
(set! old-x x)
(set! old-y y)
(as-exit (lambda () (send mred on-move x y)))))))))))]
[on-set-focus (lambda ()
(super on-set-focus)
(when expose-focus? (send (get-proxy) on-focus #t)))]

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

@ -313,8 +313,23 @@ has been moved out).
(inexact->exact (ceiling (/ y scroll-step))))
(define/override (copy) (make-image shape bb normalized? pinhole))
(define/override (draw dc x y left top right bottom dx dy draw-caret?)
(render-image this dc x y))
(define cached-bitmap #f)
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(unless cached-bitmap
(set! cached-bitmap (make-bitmap (+ (inexact->exact (round (bb-right bb))) 1)
(+ (inexact->exact (round (bb-bottom bb))) 1)))
(define bdc (make-object bitmap-dc% cached-bitmap))
(send bdc erase)
(render-image this bdc 0 0)
(send bdc set-bitmap #f))
(let ([alpha (send dc get-alpha)])
(when (pair? draw-caret)
(send dc set-alpha (* alpha .5)))
(send dc draw-bitmap cached-bitmap x y)
(send dc set-alpha alpha)))
(define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f])
(send (get-the-snip-class-list) add snip-class)
@ -1042,31 +1057,44 @@ the mask bitmap and the original bitmap are all together in a single bytes!
[else 'smoothed]))
(define (mode-color->pen mode color)
(case mode
[(outline)
(cond
[(eq? mode 'outline)
(cond
[(pen? color)
(pen->pen-obj/cache color)]
[else
(send the-pen-list find-or-create-pen (get-color-arg color) 0 'solid 'round 'miter)])]
[(solid)
[else
(send the-pen-list find-or-create-pen "black" 1 'transparent)]))
(define (mode-color->brush mode color)
(case mode
[(outline)
(cond
[(eq? mode 'outline)
(send the-brush-list find-or-create-brush "black" 'transparent)]
[(solid)
(send the-brush-list find-or-create-brush (get-color-arg color) 'solid)]))
[else
;; this should only be 'solid if we have an old image from a save file somewhere
(define extra-alpha (if (eq? mode 'solid)
255
mode))
(send the-brush-list find-or-create-brush (get-color-arg color extra-alpha) 'solid)]))
(define (get-color-arg color)
(if (string? color)
color
(make-object color%
(color-red color)
(color-green color)
(color-blue color)
(/ (color-alpha color) 255))))
(define (get-color-arg color [extra-alpha 255])
(cond
[(string? color)
(define color-obj (or (send the-color-database find-color color)
(send the-color-database find-color "black")))
(make-object color%
(send color-obj red)
(send color-obj green)
(send color-obj blue)
(/ extra-alpha 255))]
[else
(make-object color%
(color-red color)
(color-green color)
(color-blue color)
(* (/ (color-alpha color) 255)
(/ extra-alpha 255)))]))
(define (pen->pen-obj/cache pen)

9
collects/scribblings/framework/color.scrbl
View File

@ -220,6 +220,15 @@
Must only be called while the tokenizer is started.
}
@defmethod[#:mode augment (on-lexer-valid [valid? boolean?]) any]{
This method is an observer for when the lexer is working.
It is called when the lexer's state changes from valid to invalid (and back).
The @racket[valid?] argument indicates if the lexer has finished running over the editor (or not).
The default method just returns @racket[(void)].
}
}
@defmixin[color:text-mixin (text:basic<%>) (color:text<%>)]{
Adds the functionality needed for on-the-fly coloring and parenthesis

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

@ -7,7 +7,11 @@ Whenever a button is clicked by the user, the button's callback
procedure is invoked. A callback procedure is provided as an
initialization argument when each button is created.
@defconstructor[([label (or/c label-string? (is-a?/c bitmap%))]
@defconstructor[([label (or/c label-string?
(is-a?/c bitmap%)
(list/c (is-a?/c bitmap%)
label-string?
(one-of/c 'left 'top 'right 'bottom)))]
[parent (or/c (is-a?/c frame%) (is-a?/c dialog%)
(is-a?/c panel%) (is-a?/c pane%))]
[callback ((is-a?/c button%) (is-a?/c control-event%) . -> . any) (lambda (b e) (void))]
@ -21,10 +25,13 @@ Whenever a button is clicked by the user, the button's callback
[stretchable-width any/c #f]
[stretchable-height any/c #f])]{
Creates a button with a string or bitmap label.
@bitmaplabeluse[label]
Creates a button with a string label, bitmap label, or both.
@bitmaplabeluse[label] If @racket[label] is a list, then
the button has both a bitmap and string label, and the
symbol @racket['left], @racket['top], @racket['right], or @racket['bottom]
specifies the location of the image relative to the text on the button.
If @litchar{&} occurs in @scheme[label] (when @scheme[label] is a
If @litchar{&} occurs in @scheme[label] (when @scheme[label] includes a
string), it is specially parsed; under Windows and X, the character
following @litchar{&} is underlined in the displayed control to
indicate a keyboard mnemonic. (Under Mac OS X, mnemonic underlines are
@ -56,7 +63,8 @@ on-traverse-char]). @DeletedStyleNote[@scheme[style] @scheme[parent]]{button}
@defmethod[#:mode override
(set-label [label (or/c label-string? (is-a?/c bitmap%))])
(set-label [label (or/c label-string?
(is-a?/c bitmap%))])
void?]{
The same as @xmethod[window<%> set-label] when @scheme[label] is a
@ -65,5 +73,8 @@ The same as @xmethod[window<%> set-label] when @scheme[label] is a
Otherwise, sets the bitmap label for a bitmap button. @bitmaplabeluseisbm[label]
@|bitmapiforiglabel|
If the button has both a string and a bitmap label, then either can be
set using @method[button% set-label].
}}

18
collects/scribblings/gui/canvas-class.scrbl
View File

@ -3,8 +3,9 @@
@defclass/title[canvas% object% (canvas<%>)]{
A @scheme[canvas%] object is a general-purpose window for drawing
and handling events.
A @scheme[canvas%] object is a general-purpose window for drawing and
handling events. See @racket[canvas<%>] for information about drawing
onto a canvas.
@defconstructor[([parent (or/c (is-a?/c frame%) (is-a?/c dialog%)
@ -52,12 +53,15 @@ The @scheme[style] argument indicates one or more of the following styles:
@racket['no-autoclear]}
@item{@scheme['no-autoclear] --- prevents automatic erasing of the
canvas before calls to @method[canvas% on-paint]}
canvas by the windowing system; see @racket[canvas<%>] for
information on canvas refresh}
@item{@scheme['transparent] --- the canvas is automatically ``erased''
before an update using it's parent window's background; see @racket[canvas<%>]
for information on the interaction of @racket['transparent] and offscreen buffering;
the result is undefined if this flag is combined with @scheme['no-autoclear]}
@item{@scheme['transparent] --- the canvas is ``erased'' by the
windowing system by letting its parent show through; see
@racket[canvas<%>] for information on window refresh and on the
interaction of @racket['transparent] and offscreen buffering; the
result is undefined if this flag is combined with
@scheme['no-autoclear]}
@item{@scheme['no-focus] --- prevents the canvas from accepting the
keyboard focus when the canvas is clicked, or when the

82
collects/scribblings/gui/canvas-intf.scrbl
View File

@ -10,34 +10,76 @@ The @scheme[canvas<%>] interface is implemented by two classes:
@itemize[
@item{@scheme[canvas%] --- a canvas for arbitrary drawing and
event handling}
event handling; and}
@item{@scheme[editor-canvas%] --- a canvas for displaying
@scheme[editor<%>] objects}
@scheme[editor<%>] objects.}
]
To draw onto a canvas, get its device context (see
@method[canvas<%> get-dc]).
To draw onto a canvas, get its device context via @method[canvas<%>
get-dc]. There are two basic approaches to updating a canvas:
@itemlist[
@item{Drawing normally occurs during the canvas's @method[canvas<%>
on-paint] callback. The @racket[canvas%] class supports a
@racket[paint-callback] initialization argument to be called
from the default @method[canvas<%> on-paint] method.
A canvas's @method[canvas<%> on-paint] method is called
automatically as an event when the windowing system determines
that the canvas must be updated, such as when the canvas is
first shown or when it is resized. Use the @method[window<%>
refresh] method to explicitly trigger an @method[canvas<%>
on-paint] call from the windowing system. (Multiple refresh
requests before @method[canvas<%> on-paint] can be called are
coaleced into a single @method[canvas<%> on-paint] call.)
Before the windowing system calls @method[canvas<%> on-paint],
it may erase the canvas's background (see @method[dc<%>
erase]), depending on the style of the canvas (e.g., as
determined by the @racket[style] initialization argument for
@racket[canvas%]). Even when the canvas's style suppresses
explicit clearing of the canvas, a canvas may be erased by the
windowing system due to window-moving and -resizing
operations. For a transparent canvas, ``erased'' means that the
canvas's parent window shows through.}
@item{Drawing can also occur at any time outside an @method[canvas<%>
on-paint] call form the windowing system, including from
threads other than the @tech{handler thread} of the canvas's
eventspace. Drawing outside an @method[canvas<%> on-paint]
callback from the system is transient in the sense that
windowing activity can erase the canvas, but the drawing is
persistent as long as no windowing refresh is needed.
Calling an @method[canvas<%> on-paint] method directly is the
same as drawing outside an @method[canvas<%> on-paint] callback
from the windowing system.}
]
Drawing to a canvas's drawing context actually renders into an
offscreen buffer. The buffer is automatically flushed to the screen by
a background thread, explicitly via the @method[canvas<%> flush]
method, or explicitly via @racket[flush-display]---unless flushing
has been disabled for the canvas. The @method[canvas<%>
suspend-flush] method suspends flushing for a canvas until a matching
@method[canvas<%> resume-flush] calls; calls to @method[canvas<%>
suspend-flush] and @method[canvas<%> resume-flush] can be nested, in
which case flushing is suspended until the outermost @method[canvas<%>
suspend-flush] is balanced by a @method[canvas<%> resume-flush].
offscreen buffer. The buffer is automatically flushed to the screen
asynchronously, explicitly via the @method[canvas<%> flush] method, or
explicitly via @racket[flush-display]---unless flushing has been
disabled for the canvas. The @method[canvas<%> suspend-flush] method
suspends flushing for a canvas until a matching @method[canvas<%>
resume-flush] calls; calls to @method[canvas<%> suspend-flush] and
@method[canvas<%> resume-flush] can be nested, in which case flushing
is suspended until the outermost @method[canvas<%> suspend-flush] is
balanced by a @method[canvas<%> resume-flush]. An @method[canvas<%>
on-paint] call from the windowing system is implicitly wrapped with
@method[canvas<%> suspend-flush] and @method[canvas<%> resume-flush]
calls.
In the case of a transparent canvas (i.e., one that is created with
@racket['transparent] style), line and text smoothing can depend on
the window that serves as the canvas's background. For example,
smoothing may color pixels differently depending on whether the target
context is white or gray. Background-sensitive smoothing is supported
only if a relatively small number of drawing commands are recorded in
the canvas's offscreen buffer, however.
In the case of a transparent canvas, line and text smoothing can
depend on the window that serves as the canvas's background. For
example, smoothing may color pixels differently depending on whether
the target context is white or gray. Background-sensitive smoothing
is supported only if a relatively small number of drawing commands are
recorded in the canvas's offscreen buffer, however.
@defmethod*[([(accept-tab-focus)

6
collects/scribblings/gui/editor-admin-class.scrbl
View File

@ -273,8 +273,12 @@ The @scheme[bias] argument is one of:
The return value is @scheme[#t] if the @techlink{display} is scrolled,
@scheme[#f] if not (either because the requested region is already
visible, because the @techlink{display} has zero size, or because the
editor is currently printing.)
editor is currently printing).
If an editor has multiple @techlink{displays}, then if any display
currently has the keyboard focus, it is scrolled. Otherwise, the
``primary owner'' of the editor (see @method[editor-canvas%
call-as-primary-owner]) is scrolled.
}
@methimpl{

15
collects/scribblings/gui/editor-intf.scrbl
View File

@ -457,11 +457,6 @@ Returns the name of a style to be used for newly inserted text,
}
@defmethod[(do-copy) void?]{
See @xmethod[text% do-copy] or @xmethod[pasteboard% do-copy].}
@defmethod[(do-edit-operation [op (or/c 'undo 'redo 'clear 'cut 'copy 'paste
'kill 'select-all 'insert-text-box
'insert-pasteboard-box 'insert-image)]
@ -499,16 +494,6 @@ See @|timediscuss| for a discussion of the @scheme[time] argument. If
}
@defmethod[(do-paste) void?]{
See @xmethod[text% do-paste] or @xmethod[pasteboard% do-paste].}
@defmethod[(do-paste-x-selection) void?]{
See @xmethod[text% do-paste-x-selection] or @xmethod[pasteboard% do-paste-x-selection].}
@defmethod[(editor-location-to-dc-location [x real?]
[y real?])
(values real? real?)]{

9
collects/scribblings/gui/pasteboard-class.scrbl
View File

@ -499,8 +499,7 @@ Deletes @scheme[snip] when provided, or deletes the currently selected
}
@defmethod[#:mode override
(do-copy [time exact-integer?]
@defmethod[(do-copy [time exact-integer?]
[extend? any/c])
void?]{
@ -524,8 +523,7 @@ Copies the current selection, extending the current clipboard contexts
}}
@defmethod[#:mode override
(do-paste [time exact-integer?])
@defmethod[(do-paste [time exact-integer?])
void?]{
@methspec{
@ -546,8 +544,7 @@ Pastes.
}}
@defmethod[#:mode override
(do-paste-x-selection [time exact-integer?])
@defmethod[(do-paste-x-selection [time exact-integer?])
void?]{
@methspec{

9
collects/scribblings/gui/text-class.scrbl
View File

@ -422,8 +422,7 @@ Deletes the specified range or the currently selected text (when no
}
@defmethod[#:mode override
(do-copy [start exact-nonnegative-integer?]
@defmethod[(do-copy [start exact-nonnegative-integer?]
[end exact-nonnegative-integer?]
[time exact-integer?]
[extend? any/c])
@ -447,8 +446,7 @@ Copy the data from @scheme[start] to @scheme[end], extending the current
}}
@defmethod[#:mode override
(do-paste [start exact-nonnegative-integer?]
@defmethod[(do-paste [start exact-nonnegative-integer?]
[time exact-integer?])
void?]{
@methspec{
@ -469,8 +467,7 @@ Pastes into the @techlink{position} @scheme[start].
}}
@defmethod[#:mode override
(do-paste-x-selection [start exact-nonnegative-integer?]
@defmethod[(do-paste-x-selection [start exact-nonnegative-integer?]
[time exact-integer?])
void?]{
@methspec{

63
collects/scribblings/gui/window-intf.scrbl
View File

@ -1,5 +1,6 @@
#lang scribble/doc
@(require "common.ss")
@(require "common.ss"
(for-label (only-in ffi/unsafe cpointer?)))
@definterface/title[window<%> (area<%>)]{
@ -80,6 +81,25 @@ Note that under X, keyboard focus can move to the menu bar
}
@defmethod[(get-client-handle) cpointer?]{
Returns a handle to the ``inside'' of the window for the current
platform's GUI toolbox. The value that the pointer represents depends
on the platform:
@itemize[
@item{Windows: @tt{HWND}}
@item{Mac OS X: @tt{NSView}}
@item{X: @tt{GtkWidget}}
]
See also @method[window<%> get-handle].}
@defmethod[(get-client-size)
(values (integer-in 0 10000)
(integer-in 0 10000))]{
@ -98,7 +118,7 @@ See also
@defmethod[(get-cursor)
(or/c (is-a?/c cursor%) false/c)]{
(or/c (is-a?/c cursor%) #f)]{
Returns the window's cursor, or @scheme[#f] if this window's cursor
defaults to the parent's cursor. See
@ -106,28 +126,25 @@ Returns the window's cursor, or @scheme[#f] if this window's cursor
}
@defmethod[(get-handle)
exact-integer?]{
Returns an exact integer representing a handle to the window in the
current platform's GUI toolbox. Cast this number from a C @tt{long}
to a platform-specific C type:
@defmethod[(get-handle) cpointer?]{
Returns a handle to the ``outside'' of the window for the current platform's GUI
toolbox. The value that the pointer represents depends on the
platform:
@itemize[
@item{Windows: @tt{HWND}}
@item{Mac OS X: @tt{WindowRef} for a @scheme[top-level-window<%>] object,
@tt{ControlRef} for other windows}
@item{Mac OS X: @tt{NSWindow} for a @scheme[top-level-window<%>] object,
@tt{NSView} for other windows}
@item{X: @tt{Widget*}}
@item{X: @tt{GtkWidget}}
]
Some windows may not have a representation in the platform's GUI level,
in which case the result of this method is @scheme[0].
}
See also @method[window<%> get-client-handle].}
@defmethod[(get-height)
@ -141,8 +158,13 @@ See also
}
@defmethod[(get-label)
(or/c label-string? (is-a?/c bitmap%)
(one-of/c 'app 'caution 'stop) false/c)]{
(or/c label-string?
(is-a?/c bitmap%)
(one-of/c 'app 'caution 'stop)
(list/c (is-a?/c bitmap%)
label-string?
(one-of/c 'left 'top 'right 'bottom))
#f)]{
Gets a window's label, if any. Control windows generally display their
label in some way. Frames and dialogs display their label as a window
@ -151,9 +173,10 @@ Gets a window's label, if any. Control windows generally display their
have bitmap labels (only when they are created with bitmap labels),
but all other windows have string labels. In addition, a message
label can be an icon symbol @scheme['app], @scheme['caution], or
@scheme['stop].
@scheme['stop], and a button can have both a bitmap label and a
string label (along with a position for the bitmap).
The label string may contain @litchar{&}s, which serve as
A label string may contain @litchar{&}s, which serve as
keyboard navigation annotations for controls under Windows and X. The
ampersands are not part of the displayed label of a control; instead,
ampersands are removed in the displayed label (under all platforms),
@ -169,7 +192,7 @@ If the window does not have a label, @scheme[#f] is returned.
@defmethod[(get-plain-label)
(or/c string false/c)]{
(or/c string #f)]{
Like
@method[window<%> get-label], except that ampersands in the label are removed. If the window has
@ -467,7 +490,7 @@ Enqueues an event to repaint the window.
}
@defmethod[(set-cursor [cursor (or/c (is-a?/c cursor%) false/c)])
@defmethod[(set-cursor [cursor (or/c (is-a?/c cursor%) #f)])
void?]{
Sets the window's cursor. Providing @scheme[#f] instead of a cursor

35
collects/tests/gracket/draw.rkt
View File

@ -923,9 +923,40 @@
(let ([p (send dc get-pen)])
(send dc set-pen (make-object color% 0 0 0 0.1) 1 'solid)
(send dc set-brush (make-object color% 255 0 200 0.5) 'solid)
(send dc draw-rectangle 250 310 20 20)
(send dc draw-rectangle 250 320 20 20)
(send dc set-brush (make-object color% 0 255 200 0.5) 'solid)
(send dc draw-rectangle 260 320 20 20)
(send dc draw-rectangle 260 330 20 20)
(send dc set-pen p))
(let ([p (send dc get-pen)])
(send dc set-pen "white" 1 'transparent)
(send dc set-brush (new brush%
[gradient
(make-object linear-gradient%
300 0 380 0
(list (list 0.0
(make-object color% 255 0 0))
(list 0.5
(make-object color% 0 255 0))
(list 1.0
(make-object color% 0 0 255 0.0))))]))
(send dc draw-rectangle 300 320 80 20)
(send dc set-pen p))
(let ([p (send dc get-pen)])
(send dc set-pen "white" 1 'transparent)
(send dc set-brush (new brush%
[gradient
(make-object radial-gradient%
360 250 5
365 245 25
(list (list 0.0
(make-object color% 255 0 0))
(list 0.5
(make-object color% 0 255 0))
(list 1.0
(make-object color% 0 0 255 0.0))))]))
(send dc draw-rectangle 338 228 44 44)
(send dc set-pen p))
(send dc draw-line 130 310 150 310)

50
collects/tests/gracket/item.rkt
View File

@ -1235,6 +1235,55 @@
(instructions p "button-steps.txt")
(send f show #t))
(define (image-button-frame)
(define f (make-frame frame% "Image Button Test"))
(define pt (make-object vertical-panel% f))
(define pm (make-object horizontal-panel% f))
(define pb (make-object vertical-panel% f))
(define pc (make-object horizontal-panel% f))
(define bt (new button% [parent pt]
[label (list (read-bitmap
(collection-file-path "foot.png" "icons"))
"Top"
'top)]))
(define bl (new button% [parent pm]
[label (list (read-bitmap
(collection-file-path "b-wait.png" "icons"))
"Left"
'left)]))
(define br (new button% [parent pm]
[label (list (read-bitmap
(collection-file-path "b-run.png" "icons"))
"Right"
'right)]))
(define bb (new button% [parent pb]
[label (list (read-bitmap
(collection-file-path "bug09.png" "icons"))
"Bottom"
'bottom)]))
(new button% [parent pc]
[label "Strings"]
[callback (lambda (b e)
(for ([b (in-list (list bt bl br bb))])
(send b set-label (list->string
(reverse
(string->list
(cadr (send b get-label))))))))])
(new button% [parent pc]
[label "Bitmaps"]
[callback (lambda (b e)
(for ([b (in-list (list bt bl br bb))])
(send b set-label (let ([bm (car (send b get-label))])
(let* ([bm2 (make-bitmap (send bm get-width)
(send bm get-height))]
[dc (make-object bitmap-dc% bm2)])
(send dc scale 1 -1)
(send dc translate 0 (send bm get-height))
(send dc draw-bitmap bm 0 0)
(send dc set-bitmap #f)
bm2)))))])
(send f show #t))
(define (checkbox-frame)
(define f (make-frame frame% "Checkbox Test"))
(define p f)
@ -2223,6 +2272,7 @@
(make-object button% "Make Button Frame" bp (lambda (b e) (button-frame frame% null)))
(make-object button% "Make Default Button Frame" bp (lambda (b e) (button-frame frame% '(border))))
(make-object button% "Make Button Dialog" bp (lambda (b e) (button-frame dialog% null)))
(make-object button% "Make Image Buttons" bp (lambda (b e) (image-button-frame)))
(define crp (make-object horizontal-pane% ap))
(send crp stretchable-height #f)
(make-object button% "Make Checkbox Frame" crp (lambda (b e) (checkbox-frame)))

2
doc/release-notes/racket/Draw_and_GUI_5_1.txt
View File

@ -120,6 +120,8 @@ A `region%' can be created as independent of any `dc<%>', in which
cases it uses the drawing context's current transformation at the time
that it is installed as a clipping region.
Brushes now support linear and radial gradients.
The old 'xor mode for pens and brushes is no longer available (since
it is not supported by Cairo).