diff options
Diffstat (limited to 'library/palette.tcl')
| -rw-r--r-- | library/palette.tcl | 222 |
1 files changed, 222 insertions, 0 deletions
diff --git a/library/palette.tcl b/library/palette.tcl new file mode 100644 index 0000000..5d5318e --- /dev/null +++ b/library/palette.tcl @@ -0,0 +1,222 @@ +# palette.tcl -- +# +# This file contains procedures that change the color palette used +# by Tk. +# +# SCCS: @(#) palette.tcl 1.11 97/06/23 20:35:44 +# +# Copyright (c) 1995-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# tk_setPalette -- +# Changes the default color scheme for a Tk application by setting +# default colors in the option database and by modifying all of the +# color options for existing widgets that have the default value. +# +# Arguments: +# The arguments consist of either a single color name, which +# will be used as the new background color (all other colors will +# be computed from this) or an even number of values consisting of +# option names and values. The name for an option is the one used +# for the option database, such as activeForeground, not -activeforeground. + +proc tk_setPalette {args} { + global tkPalette + + # Create an array that has the complete new palette. If some colors + # aren't specified, compute them from other colors that are specified. + + if {[llength $args] == 1} { + set new(background) [lindex $args 0] + } else { + array set new $args + } + if ![info exists new(background)] { + error "must specify a background color" + } + if ![info exists new(foreground)] { + set new(foreground) black + } + set bg [winfo rgb . $new(background)] + set fg [winfo rgb . $new(foreground)] + set darkerBg [format #%02x%02x%02x [expr (9*[lindex $bg 0])/2560] \ + [expr (9*[lindex $bg 1])/2560] [expr (9*[lindex $bg 2])/2560]] + foreach i {activeForeground insertBackground selectForeground \ + highlightColor} { + if ![info exists new($i)] { + set new($i) $new(foreground) + } + } + if ![info exists new(disabledForeground)] { + set new(disabledForeground) [format #%02x%02x%02x \ + [expr (3*[lindex $bg 0] + [lindex $fg 0])/1024] \ + [expr (3*[lindex $bg 1] + [lindex $fg 1])/1024] \ + [expr (3*[lindex $bg 2] + [lindex $fg 2])/1024]] + } + if ![info exists new(highlightBackground)] { + set new(highlightBackground) $new(background) + } + if ![info exists new(activeBackground)] { + # Pick a default active background that islighter than the + # normal background. To do this, round each color component + # up by 15% or 1/3 of the way to full white, whichever is + # greater. + + foreach i {0 1 2} { + set light($i) [expr [lindex $bg $i]/256] + set inc1 [expr ($light($i)*15)/100] + set inc2 [expr (255-$light($i))/3] + if {$inc1 > $inc2} { + incr light($i) $inc1 + } else { + incr light($i) $inc2 + } + if {$light($i) > 255} { + set light($i) 255 + } + } + set new(activeBackground) [format #%02x%02x%02x $light(0) \ + $light(1) $light(2)] + } + if ![info exists new(selectBackground)] { + set new(selectBackground) $darkerBg + } + if ![info exists new(troughColor)] { + set new(troughColor) $darkerBg + } + if ![info exists new(selectColor)] { + set new(selectColor) #b03060 + } + + # let's make one of each of the widgets so we know what the + # defaults are currently for this platform. + toplevel .___tk_set_palette + wm withdraw .___tk_set_palette + foreach q {button canvas checkbutton entry frame label listbox menubutton menu message \ + radiobutton scale scrollbar text} { + $q .___tk_set_palette.$q + } + + # Walk the widget hierarchy, recoloring all existing windows. + # The option database must be set according to what we do here, + # but it breaks things if we set things in the database while + # we are changing colors...so, tkRecolorTree now returns the + # option database changes that need to be made, and they + # need to be evalled here to take effect. + # We have to walk the whole widget tree instead of just + # relying on the widgets we've created above to do the work + # because different extensions may provide other kinds + # of widgets that we don't currently know about, so we'll + # walk the whole hierarchy just in case. + + eval [tkRecolorTree . new] + + catch {destroy .___tk_set_palette} + + # Change the option database so that future windows will get the + # same colors. + + foreach option [array names new] { + option add *$option $new($option) widgetDefault + } + + # Save the options in the global variable tkPalette, for use the + # next time we change the options. + + array set tkPalette [array get new] +} + +# tkRecolorTree -- +# This procedure changes the colors in a window and all of its +# descendants, according to information provided by the colors +# argument. This looks at the defaults provided by the option +# database, if it exists, and if not, then it looks at the default +# value of the widget itself. +# +# Arguments: +# w - The name of a window. This window and all its +# descendants are recolored. +# colors - The name of an array variable in the caller, +# which contains color information. Each element +# is named after a widget configuration option, and +# each value is the value for that option. + +proc tkRecolorTree {w colors} { + global tkPalette + upvar $colors c + set result {} + foreach dbOption [array names c] { + set option -[string tolower $dbOption] + if {![catch {$w config $option} value]} { + # if the option database has a preference for this + # dbOption, then use it, otherwise use the defaults + # for the widget. + set defaultcolor [option get $w $dbOption widgetDefault] + if {[string match {} $defaultcolor]} { + set defaultcolor [winfo rgb . [lindex $value 3]] + } else { + set defaultcolor [winfo rgb . $defaultcolor] + } + set chosencolor [winfo rgb . [lindex $value 4]] + if {[string match $defaultcolor $chosencolor]} { + # Change the option database so that future windows will get + # the same colors. + append result ";\noption add [list \ + *[winfo class $w].$dbOption $c($dbOption) 60]" + $w configure $option $c($dbOption) + } + } + } + foreach child [winfo children $w] { + append result ";\n[tkRecolorTree $child c]" + } + return $result +} + +# tkDarken -- +# Given a color name, computes a new color value that darkens (or +# brightens) the given color by a given percent. +# +# Arguments: +# color - Name of starting color. +# perecent - Integer telling how much to brighten or darken as a +# percent: 50 means darken by 50%, 110 means brighten +# by 10%. + +proc tkDarken {color percent} { + set l [winfo rgb . $color] + set red [expr [lindex $l 0]/256] + set green [expr [lindex $l 1]/256] + set blue [expr [lindex $l 2]/256] + set red [expr ($red*$percent)/100] + if {$red > 255} { + set red 255 + } + set green [expr ($green*$percent)/100] + if {$green > 255} { + set green 255 + } + set blue [expr ($blue*$percent)/100] + if {$blue > 255} { + set blue 255 + } + format #%02x%02x%02x $red $green $blue +} + +# tk_bisque -- +# Reset the Tk color palette to the old "bisque" colors. +# +# Arguments: +# None. + +proc tk_bisque {} { + tk_setPalette activeBackground #e6ceb1 activeForeground black \ + background #ffe4c4 disabledForeground #b0b0b0 foreground black \ + highlightBackground #ffe4c4 highlightColor black \ + insertBackground black selectColor #b03060 \ + selectBackground #e6ceb1 selectForeground black \ + troughColor #cdb79e +} |