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]

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

@ -292,76 +292,105 @@
(define get-color-from-user (define get-color-from-user
(case-lambda (case-lambda
[() (get-color-from-user #f #f #f null)] [() (get-color-from-user #f #f #f null)]
[(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
(define/override (on-paint) (make-object wx:color%
(repaint void)) (send in-color red)
(super-new [parent f])))] (send in-color green)
[platform-p (and (string? (wx:color-from-user-platform-mode)) (send in-color blue)
(new horizontal-panel% 1.0)))
[parent f] (define ok? #f)
[alignment '(right center)]))] (define f (make-object dialog% "Choose Color" parent))
[p (make-object vertical-pane% f)] (define (done ok) (lambda (b e) (set! ok? ok) (send f show #f)))
[repaint (lambda (ext) (define canvas (make-object (class canvas%
(let ([c (get-current-color)]) (define/override (on-paint)
(ext c) (repaint void))
(wx:fill-private-color (send canvas get-dc) c)))] (super-new [parent f]))))
[update-and-repaint (lambda (s e) (define platform-p (and (string? (wx:color-from-user-platform-mode))
(repaint (new horizontal-panel%
(lambda (c) [parent f]
(when platform-p [alignment '(right center)])))
(wx:get-color-from-user c)))))] (define p (make-object vertical-pane% f))
[make-color-slider (lambda (l) (make-object slider% l 0 255 p update-and-repaint))] (define (repaint ext)
[red (make-color-slider "Red:")] (let ([c (get-current-color)])
[green (make-color-slider "Green:")] (ext c)
[blue (make-color-slider "Blue:")] (wx:fill-private-color (send canvas get-dc) c)))
[bp (make-object horizontal-pane% f)] (define (update-and-repaint s e)
[get-current-color (repaint
(lambda () (lambda (c)
(make-object wx:color% (when platform-p
(send red get-value) (wx:get-color-from-user c)))))
(send green get-value) (define (make-color-slider l) (make-object slider% l 0 255 p update-and-repaint))
(send blue get-value)))] (define red (make-color-slider "Red:"))
[install-color (define green (make-color-slider "Green:"))
(lambda (color) (define blue (make-color-slider "Blue:"))
(send red set-value (send color red)) (define alpha (and (member 'alpha style)
(send green set-value (send color green)) (new text-field%
(send blue set-value (send color blue)) [parent p]
(send canvas refresh))]) [label "Alpha:"]
(when platform-p [callback
(new button% (λ (_1 _2)
[parent platform-p] (update-ok-button-and-background))])))
[label (wx:color-from-user-platform-mode)] (define (update-ok-button-and-background)
[callback (lambda (b e) (wx:get-color-from-user 'show))]) (when alpha
(wx:get-color-from-user (or color (define n (string->number (send alpha get-value)))
(make-object wx:color% 0 0 0))) (define ok? (and n (real? n) (<= 0 n 1)))
(send (mred->wx f) set-color-callback (lambda () (send ok-button enable ok?)
(install-color (send alpha set-field-background
(wx:get-color-from-user 'get))))) (send wx:the-color-database find-color
(when color (install-color color)) (if ok? "white" "pink")))))
(ok-cancel (define bp (make-object horizontal-pane% f))
(define (get-current-color)
(make-object wx:color%
(send red get-value)
(send green get-value)
(send blue get-value)
(if alpha
(string->number (send alpha get-value))
1.0)))
(define (install-color color)
(send red set-value (send color red))
(send green set-value (send color green))
(send blue set-value (send color blue))
(when alpha (send alpha set-value (format "~a" (send color alpha))))
(send canvas refresh))
(when platform-p
(new button%
[parent platform-p]
[label (wx:color-from-user-platform-mode)]
[callback (lambda (b e) (wx:get-color-from-user 'show))])
(wx:get-color-from-user (or color
(make-object wx:color% 0 0 0)))
(send (mred->wx f) set-color-callback (lambda ()
(install-color
(wx:get-color-from-user 'get)))))
(when color (install-color color))
(define-values (ok-button cancel-button)
(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 bp set-alignment 'right 'center) (send ok-button focus)
(send p set-alignment 'right 'center) (update-ok-button-and-background)
(send p stretchable-height #f) (send bp set-alignment 'right 'center)
(send canvas min-height 50) (send p set-alignment 'right 'center)
(send f center) (send p stretchable-height #f)
(send f show #t) (send canvas min-height 50)
(and ok? (send f center)
(get-current-color))))])) (send f show #t)
(and ok?
(get-current-color))])]))