palette.tcl (7923B)
1 # palette.tcl -- 2 # 3 # This file contains procedures that change the color palette used 4 # by Tk. 5 # 6 # Copyright (c) 1995-1997 Sun Microsystems, Inc. 7 # 8 # See the file "license.terms" for information on usage and redistribution 9 # of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10 # 11 12 # ::tk_setPalette -- 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. 16 # 17 # Arguments: 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. 23 24 proc ::tk_setPalette {args} { 25 if {[winfo depth .] == 1} { 26 # Just return on monochrome displays, otherwise errors will occur 27 return 28 } 29 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. 32 33 if {[llength $args] == 1} { 34 set new(background) [lindex $args 0] 35 } else { 36 array set new $args 37 } 38 if {![info exists new(background)]} { 39 return -code error -errorcode {TK SET_PALETTE BACKGROUND} \ 40 "must specify a background color" 41 } 42 set bg [winfo rgb . $new(background)] 43 if {![info exists new(foreground)]} { 44 # Note that the range of each value in the triple returned by 45 # [winfo rgb] is 0-65535, and your eyes are more sensitive to 46 # green than to red, and more to red than to blue. 47 foreach {r g b} $bg {break} 48 if {$r+1.5*$g+0.5*$b > 100000} { 49 set new(foreground) black 50 } else { 51 set new(foreground) white 52 } 53 } 54 lassign [winfo rgb . $new(foreground)] fg_r fg_g fg_b 55 lassign $bg bg_r bg_g bg_b 56 set darkerBg [format #%02x%02x%02x [expr {(9*$bg_r)/2560}] \ 57 [expr {(9*$bg_g)/2560}] [expr {(9*$bg_b)/2560}]] 58 59 foreach i {activeForeground insertBackground selectForeground \ 60 highlightColor} { 61 if {![info exists new($i)]} { 62 set new($i) $new(foreground) 63 } 64 } 65 if {![info exists new(disabledForeground)]} { 66 set new(disabledForeground) [format #%02x%02x%02x \ 67 [expr {(3*$bg_r + $fg_r)/1024}] \ 68 [expr {(3*$bg_g + $fg_g)/1024}] \ 69 [expr {(3*$bg_b + $fg_b)/1024}]] 70 } 71 if {![info exists new(highlightBackground)]} { 72 set new(highlightBackground) $new(background) 73 } 74 if {![info exists new(activeBackground)]} { 75 # Pick a default active background that islighter than the 76 # normal background. To do this, round each color component 77 # up by 15% or 1/3 of the way to full white, whichever is 78 # greater. 79 80 foreach i {0 1 2} color $bg { 81 set light($i) [expr {$color/256}] 82 set inc1 [expr {($light($i)*15)/100}] 83 set inc2 [expr {(255-$light($i))/3}] 84 if {$inc1 > $inc2} { 85 incr light($i) $inc1 86 } else { 87 incr light($i) $inc2 88 } 89 if {$light($i) > 255} { 90 set light($i) 255 91 } 92 } 93 set new(activeBackground) [format #%02x%02x%02x $light(0) \ 94 $light(1) $light(2)] 95 } 96 if {![info exists new(selectBackground)]} { 97 set new(selectBackground) $darkerBg 98 } 99 if {![info exists new(troughColor)]} { 100 set new(troughColor) $darkerBg 101 } 102 103 # let's make one of each of the widgets so we know what the 104 # defaults are currently for this platform. 105 toplevel .___tk_set_palette 106 wm withdraw .___tk_set_palette 107 foreach q { 108 button canvas checkbutton entry frame label labelframe 109 listbox menubutton menu message radiobutton scale scrollbar 110 spinbox text 111 } { 112 $q .___tk_set_palette.$q 113 } 114 115 # Walk the widget hierarchy, recoloring all existing windows. 116 # The option database must be set according to what we do here, 117 # but it breaks things if we set things in the database while 118 # we are changing colors...so, ::tk::RecolorTree now returns the 119 # option database changes that need to be made, and they 120 # need to be evalled here to take effect. 121 # We have to walk the whole widget tree instead of just 122 # relying on the widgets we've created above to do the work 123 # because different extensions may provide other kinds 124 # of widgets that we don't currently know about, so we'll 125 # walk the whole hierarchy just in case. 126 127 eval [tk::RecolorTree . new] 128 129 destroy .___tk_set_palette 130 131 # Change the option database so that future windows will get the 132 # same colors. 133 134 foreach option [array names new] { 135 option add *$option $new($option) widgetDefault 136 } 137 138 # Save the options in the variable ::tk::Palette, for use the 139 # next time we change the options. 140 141 array set ::tk::Palette [array get new] 142 } 143 144 # ::tk::RecolorTree -- 145 # This procedure changes the colors in a window and all of its 146 # descendants, according to information provided by the colors 147 # argument. This looks at the defaults provided by the option 148 # database, if it exists, and if not, then it looks at the default 149 # value of the widget itself. 150 # 151 # Arguments: 152 # w - The name of a window. This window and all its 153 # descendants are recolored. 154 # colors - The name of an array variable in the caller, 155 # which contains color information. Each element 156 # is named after a widget configuration option, and 157 # each value is the value for that option. 158 159 proc ::tk::RecolorTree {w colors} { 160 upvar $colors c 161 set result {} 162 set prototype .___tk_set_palette.[string tolower [winfo class $w]] 163 if {![winfo exists $prototype]} { 164 unset prototype 165 } 166 foreach dbOption [array names c] { 167 set option -[string tolower $dbOption] 168 set class [string replace $dbOption 0 0 [string toupper \ 169 [string index $dbOption 0]]] 170 if {![catch {$w configure $option} value]} { 171 # if the option database has a preference for this 172 # dbOption, then use it, otherwise use the defaults 173 # for the widget. 174 set defaultcolor [option get $w $dbOption $class] 175 if {$defaultcolor eq "" || \ 176 ([info exists prototype] && \ 177 [$prototype cget $option] ne "$defaultcolor")} { 178 set defaultcolor [lindex $value 3] 179 } 180 if {$defaultcolor ne ""} { 181 set defaultcolor [winfo rgb . $defaultcolor] 182 } 183 set chosencolor [lindex $value 4] 184 if {$chosencolor ne ""} { 185 set chosencolor [winfo rgb . $chosencolor] 186 } 187 if {[string match $defaultcolor $chosencolor]} { 188 # Change the option database so that future windows will get 189 # the same colors. 190 append result ";\noption add [list \ 191 *[winfo class $w].$dbOption $c($dbOption) 60]" 192 $w configure $option $c($dbOption) 193 } 194 } 195 } 196 foreach child [winfo children $w] { 197 append result ";\n[::tk::RecolorTree $child c]" 198 } 199 return $result 200 } 201 202 # ::tk::Darken -- 203 # Given a color name, computes a new color value that darkens (or 204 # brightens) the given color by a given percent. 205 # 206 # Arguments: 207 # color - Name of starting color. 208 # perecent - Integer telling how much to brighten or darken as a 209 # percent: 50 means darken by 50%, 110 means brighten 210 # by 10%. 211 212 proc ::tk::Darken {color percent} { 213 foreach {red green blue} [winfo rgb . $color] { 214 set red [expr {($red/256)*$percent/100}] 215 set green [expr {($green/256)*$percent/100}] 216 set blue [expr {($blue/256)*$percent/100}] 217 break 218 } 219 if {$red > 255} { 220 set red 255 221 } 222 if {$green > 255} { 223 set green 255 224 } 225 if {$blue > 255} { 226 set blue 255 227 } 228 return [format "#%02x%02x%02x" $red $green $blue] 229 } 230 231 # ::tk_bisque -- 232 # Reset the Tk color palette to the old "bisque" colors. 233 # 234 # Arguments: 235 # None. 236 237 proc ::tk_bisque {} { 238 tk_setPalette activeBackground #e6ceb1 activeForeground black \ 239 background #ffe4c4 disabledForeground #b0b0b0 foreground black \ 240 highlightBackground #ffe4c4 highlightColor black \ 241 insertBackground black \ 242 selectBackground #e6ceb1 selectForeground black \ 243 troughColor #cdb79e 244 }