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