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