3 # This file contains procedures that change the color palette used
6 # Copyright (c) 1995-1997 Sun Microsystems, Inc.
8 # See the file "license.terms" for information on usage and redistribution
9 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13 # Changes the default color scheme for a Tk application by setting
14 # default colors in the option database and by modifying all of the
15 # color options for existing widgets that have the default value.
18 # The arguments consist of either a single color name, which
19 # will be used as the new background color (all other colors will
20 # be computed from this) or an even number of values consisting of
21 # option names and values. The name for an option is the one used
22 # for the option database, such as activeForeground, not -activeforeground.
24 proc ::tk_setPalette {args
} {
25 if {[winfo depth .
] == 1} {
26 # Just return on monochrome displays, otherwise errors will occur
30 # Create an array that has the complete new palette. If some colors
31 # aren't specified, compute them from other colors that are specified.
33 if {[llength $args] == 1} {
34 set new
(background
) [lindex $args 0]
38 if {![info exists new
(background
)]} {
39 error "must specify a background color"
41 set bg
[winfo rgb .
$new(background
)]
42 if {![info exists new
(foreground
)]} {
43 # Note that the range of each value in the triple returned by
44 # [winfo rgb] is 0-65535, and your eyes are more sensitive to
45 # green than to red, and more to red than to blue.
46 foreach {r g b
} $bg {break}
47 if {$r+1.5*$g+0.5*$b > 100000} {
48 set new
(foreground
) black
50 set new
(foreground
) white
53 lassign
[winfo rgb .
$new(foreground
)] fg_r fg_g fg_b
54 lassign
$bg bg_r bg_g bg_b
55 set darkerBg
[format #%02x%02x%02x [expr {(9*$bg_r)/2560}] \
56 [expr {(9*$bg_g)/2560}] [expr {(9*$bg_b)/2560}]]
58 foreach i
{activeForeground insertBackground selectForeground
\
60 if {![info exists new
($i)]} {
61 set new
($i) $new(foreground
)
64 if {![info exists new
(disabledForeground
)]} {
65 set new
(disabledForeground
) [format #%02x%02x%02x \
66 [expr {(3*$bg_r + $fg_r)/1024}] \
67 [expr {(3*$bg_g + $fg_g)/1024}] \
68 [expr {(3*$bg_b + $fg_b)/1024}]]
70 if {![info exists new
(highlightBackground
)]} {
71 set new
(highlightBackground
) $new(background
)
73 if {![info exists new
(activeBackground
)]} {
74 # Pick a default active background that islighter than the
75 # normal background. To do this, round each color component
76 # up by 15% or 1/3 of the way to full white, whichever is
79 foreach i
{0 1 2} color
$bg {
80 set light
($i) [expr {$color/256}]
81 set inc1
[expr {($light($i)*15)/100}]
82 set inc2
[expr {(255-$light($i))/3}]
88 if {$light($i) > 255} {
92 set new
(activeBackground
) [format #%02x%02x%02x $light(0) \
95 if {![info exists new
(selectBackground
)]} {
96 set new
(selectBackground
) $darkerBg
98 if {![info exists new
(troughColor
)]} {
99 set new
(troughColor
) $darkerBg
102 # let's make one of each of the widgets so we know what the
103 # defaults are currently for this platform.
104 toplevel .___tk_set_palette
105 wm withdraw .___tk_set_palette
107 button canvas checkbutton entry frame label labelframe
108 listbox menubutton menu message radiobutton scale scrollbar
111 $q .___tk_set_palette.
$q
114 # Walk the widget hierarchy, recoloring all existing windows.
115 # The option database must be set according to what we do here,
116 # but it breaks things if we set things in the database while
117 # we are changing colors...so, ::tk::RecolorTree now returns the
118 # option database changes that need to be made, and they
119 # need to be evalled here to take effect.
120 # We have to walk the whole widget tree instead of just
121 # relying on the widgets we've created above to do the work
122 # because different extensions may provide other kinds
123 # of widgets that we don't currently know about, so we'll
124 # walk the whole hierarchy just in case.
126 eval [tk::RecolorTree . new
]
128 destroy .___tk_set_palette
130 # Change the option database so that future windows will get the
133 foreach option [array names new
] {
134 option add
*$option $new($option) widgetDefault
137 # Save the options in the variable ::tk::Palette, for use the
138 # next time we change the options.
140 array set ::tk::Palette [array get new
]
143 # ::tk::RecolorTree --
144 # This procedure changes the colors in a window and all of its
145 # descendants, according to information provided by the colors
146 # argument. This looks at the defaults provided by the option
147 # database, if it exists, and if not, then it looks at the default
148 # value of the widget itself.
151 # w - The name of a window. This window and all its
152 # descendants are recolored.
153 # colors - The name of an array variable in the caller,
154 # which contains color information. Each element
155 # is named after a widget configuration option, and
156 # each value is the value for that option.
158 proc ::tk::RecolorTree {w
colors} {
161 set prototype .___tk_set_palette.
[string tolower
[winfo class
$w]]
162 if {![winfo exists
$prototype]} {
165 foreach dbOption
[array names c
] {
166 set option -[string tolower
$dbOption]
167 set class
[string replace
$dbOption 0 0 [string toupper
\
168 [string index
$dbOption 0]]]
169 if {![catch {$w configure
$option} value
]} {
170 # if the option database has a preference for this
171 # dbOption, then use it, otherwise use the defaults
173 set defaultcolor
[option get
$w $dbOption $class]
174 if {$defaultcolor eq
"" ||
\
175 ([info exists prototype
] && \
176 [$prototype cget
$option] ne
"$defaultcolor")} {
177 set defaultcolor
[lindex $value 3]
179 if {$defaultcolor ne
""} {
180 set defaultcolor
[winfo rgb .
$defaultcolor]
182 set chosencolor
[lindex $value 4]
183 if {$chosencolor ne
""} {
184 set chosencolor
[winfo rgb .
$chosencolor]
186 if {[string match
$defaultcolor $chosencolor]} {
187 # Change the option database so that future windows will get
189 append result
";\noption add [list \
190 *[winfo class $w].$dbOption $c($dbOption) 60]"
191 $w configure
$option $c($dbOption)
195 foreach child
[winfo children
$w] {
196 append result
";\n[::tk::RecolorTree $child c]"
202 # Given a color name, computes a new color value that darkens (or
203 # brightens) the given color by a given percent.
206 # color - Name of starting color.
207 # perecent - Integer telling how much to brighten or darken as a
208 # percent: 50 means darken by 50%, 110 means brighten
211 proc ::tk::Darken {color percent
} {
212 foreach {red green blue
} [winfo rgb .
$color] {
213 set red
[expr {($red/256)*$percent/100}]
214 set green
[expr {($green/256)*$percent/100}]
215 set blue
[expr {($blue/256)*$percent/100}]
227 return [format "#%02x%02x%02x" $red $green $blue]
231 # Reset the Tk color palette to the old "bisque" colors.
236 proc ::tk_bisque {} {
237 tk_setPalette activeBackground
#e6ceb1 activeForeground black \
238 background
#ffe4c4 disabledForeground #b0b0b0 foreground black \
239 highlightBackground
#ffe4c4 highlightColor black \
240 insertBackground black
\
241 selectBackground
#e6ceb1 selectForeground black \