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

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

@ -4585,11 +4585,21 @@
(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)
(let* ([ok? #f]
(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% ()
(override
[on-paint (lambda () (repaint #f #f))])
(sequence (super-init f))))]
[p (make-object vertical-pane% f)]
[make-color-slider (lambda (l) (make-object slider% l 0 255 p void))]
[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:")]
@ -4602,6 +4612,8 @@
(make-object button% "Ok" bp (done #t) '(border))
(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?