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