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

add support for colors with alpha to get-color-from-user

Browse Source 
Also, a bit of Rackety (triggered because I would have had to turn a
letrec into a letrec-values to support disabling the ok button (and
also because the code was indented with tabs and not just spaces))
This commit is contained in:
Robby Findler 2013-09-01 21:21:27 -05:00
parent 8fe0022cf1
commit c0c6861497
2 changed files with 105 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
pkgs/gui-pkgs/gui-doc/scribblings/gui/dialog-funcs.scrbl
View File

@ -449,7 +449,7 @@ The result is @racket[#f] if the user cancels the dialog, the
@defproc[(get-color-from-user [message (or/c label-string? #f) #f] @defproc[(get-color-from-user [message (or/c label-string? #f) #f]
[parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f] [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f]
[init-color (or/c (is-a?/c color%) #f) #f] [init-color (or/c (is-a?/c color%) #f) #f]
[style null? null]) [style (listof 'alpha) null])
(or/c (is-a?/c color%) #f)]{ (or/c (is-a?/c color%) #f)]{
Lets the user select a color though the platform-specific Lets the user select a color though the platform-specific
@ -458,13 +458,13 @@ Lets the user select a color though the platform-specific
dialog if possible. If @racket[init-color] is provided, the dialog is dialog if possible. If @racket[init-color] is provided, the dialog is
initialized to the given color. initialized to the given color.
@italicptyStyleNote[@racket[style]]
The result is @racket[#f] if the user cancels the dialog, the selected The result is @racket[#f] if the user cancels the dialog, the selected
color otherwise. color otherwise.
If @racket[style] contains @racket['alpha], then the user is present with
a field for filling in the alpha field of the resulting @racket[color%] object.
If it does not, then the alpha component of @racket[init-color] is ignored,
and the result always has alpha of @racket[1.0].
} }
@defproc[(get-font-from-user [message (or/c label-string? #f) #f] @defproc[(get-font-from-user [message (or/c label-string? #f) #f]

91
pkgs/gui-pkgs/gui-lib/mred/private/moredialogs.rkt
View File

@ -296,51 +296,77 @@
[(message) (get-color-from-user message #f #f null)] [(message) (get-color-from-user message #f #f null)]
[(message parent) (get-color-from-user message parent #f null)] [(message parent) (get-color-from-user message parent #f null)]
[(message parent color) (get-color-from-user message parent color null)] [(message parent color) (get-color-from-user message parent color null)]
[(message parent color style) [(message parent in-color style)
(check-label-string/false 'get-color-from-user message) (check-label-string/false 'get-color-from-user message)
(check-top-level-parent/false 'get-color-from-user parent) (check-top-level-parent/false 'get-color-from-user parent)
(check-instance 'get-color-from-user wx:color% 'color% #t color) (check-instance 'get-color-from-user wx:color% 'color% #t in-color)
(check-style 'get-color-from-user #f null style) (check-style 'get-color-from-user #f '(alpha) style)
(if (eq? (wx:color-from-user-platform-mode) 'dialog) (cond
(wx:get-color-from-user message (and parent (mred->wx parent)) color) [(eq? (wx:color-from-user-platform-mode) 'dialog)
(letrec ([ok? #f] (wx:get-color-from-user message (and parent (mred->wx parent)) in-color)]
[f (make-object dialog% "Choose Color" parent)] [else
[done (lambda (ok) (lambda (b e) (set! ok? ok) (send f show #f)))] (define color (if (member 'alpha style)
[canvas (make-object (class canvas% in-color
(make-object wx:color%
(send in-color red)
(send in-color green)
(send in-color blue)
1.0)))
(define ok? #f)
(define f (make-object dialog% "Choose Color" parent))
(define (done ok) (lambda (b e) (set! ok? ok) (send f show #f)))
(define canvas (make-object (class canvas%
(define/override (on-paint) (define/override (on-paint)
(repaint void)) (repaint void))
(super-new [parent f])))] (super-new [parent f]))))
[platform-p (and (string? (wx:color-from-user-platform-mode)) (define platform-p (and (string? (wx:color-from-user-platform-mode))
(new horizontal-panel% (new horizontal-panel%
[parent f] [parent f]
[alignment '(right center)]))] [alignment '(right center)])))
[p (make-object vertical-pane% f)] (define p (make-object vertical-pane% f))
[repaint (lambda (ext) (define (repaint ext)
(let ([c (get-current-color)]) (let ([c (get-current-color)])
(ext c) (ext c)
(wx:fill-private-color (send canvas get-dc) c)))] (wx:fill-private-color (send canvas get-dc) c)))
[update-and-repaint (lambda (s e) (define (update-and-repaint s e)
(repaint (repaint
(lambda (c) (lambda (c)
(when platform-p (when platform-p
(wx:get-color-from-user c)))))] (wx:get-color-from-user c)))))
[make-color-slider (lambda (l) (make-object slider% l 0 255 p update-and-repaint))] (define (make-color-slider l) (make-object slider% l 0 255 p update-and-repaint))
[red (make-color-slider "Red:")] (define red (make-color-slider "Red:"))
[green (make-color-slider "Green:")] (define green (make-color-slider "Green:"))
[blue (make-color-slider "Blue:")] (define blue (make-color-slider "Blue:"))
[bp (make-object horizontal-pane% f)] (define alpha (and (member 'alpha style)
[get-current-color (new text-field%
(lambda () [parent p]
[label "Alpha:"]
[callback
(λ (_1 _2)
(update-ok-button-and-background))])))
(define (update-ok-button-and-background)
(when alpha
(define n (string->number (send alpha get-value)))
(define ok? (and n (real? n) (<= 0 n 1)))
(send ok-button enable ok?)
(send alpha set-field-background
(send wx:the-color-database find-color
(if ok? "white" "pink")))))
(define bp (make-object horizontal-pane% f))
(define (get-current-color)
(make-object wx:color% (make-object wx:color%
(send red get-value) (send red get-value)
(send green get-value) (send green get-value)
(send blue get-value)))] (send blue get-value)
[install-color (if alpha
(lambda (color) (string->number (send alpha get-value))
1.0)))
(define (install-color color)
(send red set-value (send color red)) (send red set-value (send color red))
(send green set-value (send color green)) (send green set-value (send color green))
(send blue set-value (send color blue)) (send blue set-value (send color blue))
(send canvas refresh))]) (when alpha (send alpha set-value (format "~a" (send color alpha))))
(send canvas refresh))
(when platform-p (when platform-p
(new button% (new button%
[parent platform-p] [parent platform-p]
@ -352,11 +378,14 @@
(install-color (install-color
(wx:get-color-from-user 'get))))) (wx:get-color-from-user 'get)))))
(when color (install-color color)) (when color (install-color color))
(define-values (ok-button cancel-button)
(ok-cancel (ok-cancel
(lambda () (lambda ()
(make-object button% "Cancel" bp (done #f))) (make-object button% "OK" bp (done #t) '(border)))
(lambda () (lambda ()
(send (make-object button% "OK" bp (done #t) '(border)) focus))) (make-object button% "Cancel" bp (done #f)))))
(send ok-button focus)
(update-ok-button-and-background)
(send bp set-alignment 'right 'center) (send bp set-alignment 'right 'center)
(send p set-alignment 'right 'center) (send p set-alignment 'right 'center)
(send p stretchable-height #f) (send p stretchable-height #f)
@ -364,4 +393,4 @@
(send f center) (send f center)
(send f show #t) (send f show #t)
(and ok? (and ok?
(get-current-color))))])) (get-current-color))])]))