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]
[parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #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)]{
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
initialized to the given color.
@italicptyStyleNote[@racket[style]]
The result is @racket[#f] if the user cancels the dialog, the selected
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]

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

@ -292,76 +292,105 @@
(define get-color-from-user
(case-lambda
[() (get-color-from-user #f #f #f null)]
[(message) (get-color-from-user message #f #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 style)
(check-label-string/false 'get-color-from-user message)
(check-top-level-parent/false 'get-color-from-user parent)
(check-instance 'get-color-from-user wx:color% 'color% #t color)
(check-style 'get-color-from-user #f null style)
(if (eq? (wx:color-from-user-platform-mode) 'dialog)
(wx:get-color-from-user message (and parent (mred->wx parent)) color)
(letrec ([ok? #f]
[f (make-object dialog% "Choose Color" parent)]
[done (lambda (ok) (lambda (b e) (set! ok? ok) (send f show #f)))]
[canvas (make-object (class canvas%
(define/override (on-paint)
(repaint void))
(super-new [parent f])))]
[platform-p (and (string? (wx:color-from-user-platform-mode))
(new horizontal-panel%
[parent f]
[alignment '(right center)]))]
[p (make-object vertical-pane% f)]
[repaint (lambda (ext)
(let ([c (get-current-color)])
(ext c)
(wx:fill-private-color (send canvas get-dc) c)))]
[update-and-repaint (lambda (s e)
(repaint
(lambda (c)
(when platform-p
(wx:get-color-from-user c)))))]
[make-color-slider (lambda (l) (make-object slider% l 0 255 p update-and-repaint))]
[red (make-color-slider "Red:")]
[green (make-color-slider "Green:")]
[blue (make-color-slider "Blue:")]
[bp (make-object horizontal-pane% f)]
[get-current-color
(lambda ()
(make-object wx:color%
(send red get-value)
(send green get-value)
(send blue get-value)))]
[install-color
(lambda (color)
(send red set-value (send color red))
(send green set-value (send color green))
(send blue set-value (send color blue))
(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))
(ok-cancel
[() (get-color-from-user #f #f #f null)]
[(message) (get-color-from-user message #f #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 in-color style)
(check-label-string/false 'get-color-from-user message)
(check-top-level-parent/false 'get-color-from-user parent)
(check-instance 'get-color-from-user wx:color% 'color% #t in-color)
(check-style 'get-color-from-user #f '(alpha) style)
(cond
[(eq? (wx:color-from-user-platform-mode) 'dialog)
(wx:get-color-from-user message (and parent (mred->wx parent)) in-color)]
[else
(define color (if (member 'alpha style)
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)
(repaint void))
(super-new [parent f]))))
(define platform-p (and (string? (wx:color-from-user-platform-mode))
(new horizontal-panel%
[parent f]
[alignment '(right center)])))
(define p (make-object vertical-pane% f))
(define (repaint ext)
(let ([c (get-current-color)])
(ext c)
(wx:fill-private-color (send canvas get-dc) c)))
(define (update-and-repaint s e)
(repaint
(lambda (c)
(when platform-p
(wx:get-color-from-user c)))))
(define (make-color-slider l) (make-object slider% l 0 255 p update-and-repaint))
(define red (make-color-slider "Red:"))
(define green (make-color-slider "Green:"))
(define blue (make-color-slider "Blue:"))
(define alpha (and (member 'alpha style)
(new text-field%
[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%
(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 ()
(make-object button% "Cancel" bp (done #f)))
(make-object button% "OK" bp (done #t) '(border)))
(lambda ()
(send (make-object button% "OK" bp (done #t) '(border)) focus)))
(send bp set-alignment 'right 'center)
(send p set-alignment 'right 'center)
(send p stretchable-height #f)
(send canvas min-height 50)
(send f center)
(send f show #t)
(and ok?
(get-current-color))))]))
(make-object button% "Cancel" bp (done #f)))))
(send ok-button focus)
(update-ok-button-and-background)
(send bp set-alignment 'right 'center)
(send p set-alignment 'right 'center)
(send p stretchable-height #f)
(send canvas min-height 50)
(send f center)
(send f show #t)
(and ok?
(get-current-color))])]))