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

.

Browse Source 
original commit: 233b728a581f0e3020b07425a957875f0ddefb29
This commit is contained in:
Matthew Flatt 1999-04-23 18:40:04 +00:00
parent 727a63c1e8
commit a407156b0d
1 changed files with 21 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
src/mred/wrap/mred.ss
View File

@ -4585,15 +4585,25 @@
(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 color)
(check-style 'get-color-from-user #f null style) (check-style 'get-color-from-user #f null style)
(let* ([ok? #f] (letrec ([ok? #f]
[f (make-object dialog% "Choose Color" parent)] [f (make-object dialog% "Choose Color" parent)]
[done (lambda (ok) (lambda (b e) (set! ok? ok) (send f show #f)))] [done (lambda (ok) (lambda (b e) (set! ok? ok) (send f show #f)))]
[p (make-object vertical-pane% f)] [canvas (make-object (class canvas% ()
[make-color-slider (lambda (l) (make-object slider% l 0 255 p void))] (override
[red (make-color-slider "Red:")] [on-paint (lambda () (repaint #f #f))])
[green (make-color-slider "Green:")] (sequence (super-init f))))]
[blue (make-color-slider "Blue:")] [p (make-object vertical-pane% f)]
[bp (make-object horizontal-pane% f)]) [repaint (lambda (s e)
(let ([c (make-object wx:color%
(send red get-value)
(send green get-value)
(send blue get-value))])
(wx:fill-private-color (send canvas get-dc) c)))]
[make-color-slider (lambda (l) (make-object slider% l 0 255 p repaint))]
[red (make-color-slider "Red:")]
[green (make-color-slider "Green:")]
[blue (make-color-slider "Blue:")]
[bp (make-object horizontal-pane% f)])
(when color (when 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))
@ -4602,6 +4612,8 @@
(make-object button% "Ok" bp (done #t) '(border)) (make-object button% "Ok" bp (done #t) '(border))
(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 canvas min-height 50)
(send f center) (send f center)
(send f show #t) (send f show #t)
(and ok? (and ok?