Initial revision

FossilOrigin-Name: 2bf55ca9aa942b581137b9f474da5ad9c1480de4

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
+}