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