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

.

Browse Source 
original commit: f8911183cf9667ce030a71b543a31d845a3c7f78
This commit is contained in:
Robby Findler 2004-10-05 21:19:58 +00:00
parent 6033231a46
commit 074fea6ce5
2 changed files with 47 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
collects/framework/private/color-prefs.ss
View File

@ -1,3 +1,4 @@
(module color-prefs mzscheme (module color-prefs mzscheme
(require (lib "class.ss") (require (lib "class.ss")
(lib "unitsig.ss") (lib "unitsig.ss")
@ -193,37 +194,47 @@
(list (string-constant preferences-colors) (list (string-constant preferences-colors)
(string-constant background-color)) (string-constant background-color))
(lambda (parent) (lambda (parent)
(letrec ([panel (new vertical-panel% (parent parent))] (add-solid-color-config (string-constant background-color)
[hp (new horizontal-panel% (parent panel))] parent
[canvas 'framework:basic-canvas-background)
(new canvas% (build-color-selection-panel parent
(parent hp) 'framework:default-text-color
(paint-callback "Basic"
(lambda (c dc) (string-constant default-text-color)))))
(draw (preferences:get 'framework:basic-canvas-background)))))]
[draw (define (add-solid-color-config label parent pref-id)
(lambda (clr) (letrec ([panel (new vertical-panel% (parent parent))]
(let ([dc (send canvas get-dc)]) [hp (new horizontal-panel% (parent panel) (stretchable-height #f))]
(let-values ([(w h) (send canvas get-client-size)]) [msg (new message% (parent hp) (label label))]
(send dc set-brush (send the-brush-list find-or-create-brush clr 'solid)) [canvas
(send dc set-pen (send the-pen-list find-or-create-pen clr 1 'solid)) (new canvas%
(send dc draw-rectangle 0 0 w h))))] (parent hp)
[button (paint-callback
(new button% (lambda (c dc)
(label (string-constant cs-change-color)) (draw (preferences:get pref-id)))))]
(parent hp) [draw
(callback (lambda (clr)
(lambda (x y) (let ([dc (send canvas get-dc)])
(let ([color (get-color-from-user (let-values ([(w h) (send canvas get-client-size)])
(string-constant choose-a-background-color) (send dc set-brush (send the-brush-list find-or-create-brush clr 'solid))
(send hp get-top-level-window) (send dc set-pen (send the-pen-list find-or-create-pen clr 1 'solid))
(preferences:get 'framework:basic-canvas-background))]) (send dc draw-rectangle 0 0 w h))))]
(when color [button
(preferences:set 'framework:basic-canvas-background color))))))]) (new button%
(preferences:add-callback (label (string-constant cs-change-color))
'framework:basic-canvas-background (parent hp)
(lambda (p v) (draw v))) (callback
panel)))) (lambda (x y)
(let ([color (get-color-from-user
(string-constant choose-a-background-color)
(send hp get-top-level-window)
(preferences:get 'framework:basic-canvas-background))])
(when color
(preferences:set pref-id color))))))])
(preferences:add-callback
pref-id
(lambda (p v) (draw v)))
panel))
;; add-to-preferences-panel : string (vertical-panel -> void) -> void ;; add-to-preferences-panel : string (vertical-panel -> void) -> void
(define (add-to-preferences-panel panel-name func) (define (add-to-preferences-panel panel-name func)
@ -245,3 +256,4 @@
(editor:set-standard-style-list-delta style-name v))) (editor:set-standard-style-list-delta style-name v)))
(editor:set-standard-style-list-delta style-name (preferences:get pref-name)))))) (editor:set-standard-style-list-delta style-name (preferences:get pref-name))))))

4
collects/framework/private/main.ss
View File

@ -241,6 +241,10 @@
(scheme:get-color-prefs-table)) (scheme:get-color-prefs-table))
(preferences:set-default 'framework:coloring-active #t boolean?) (preferences:set-default 'framework:coloring-active #t boolean?)
(color-prefs:register-color-pref 'framework:default-text-color
"Basic"
(send the-color-database find-color "black"))
;; groups ;; groups
(preferences:set-default 'framework:exit-when-no-frames #t boolean?) (preferences:set-default 'framework:exit-when-no-frames #t boolean?)