figenc

[RADIOACTIVE] rsa and symmetric key encryption scripts and executables
git clone git://git.figbert.com/figenc.git
Log | Files | Refs | README

palette.tcl (7923B)


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