home *** CD-ROM | disk | FTP | other *** search
/ PC World 2001 April / PCWorld_2001-04_cd.bin / Software / TemaCD / webclean / !!!python!!! / BeOpen-Python-2.0.exe / PALETTE.TCL < prev    next >
Encoding:
Text File  |  1999-09-02  |  7.2 KB  |  227 lines
  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.5 1999/09/02 17:02:53 hobbs 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.  
  26. proc tk_setPalette {args} {
  27.     if {[winfo depth .] == 1} {
  28.     # Just return on monochrome displays, otherwise errors will occur
  29.     return
  30.     }
  31.  
  32.     global tkPalette
  33.  
  34.     # Create an array that has the complete new palette.  If some colors
  35.     # aren't specified, compute them from other colors that are specified.
  36.  
  37.     if {[llength $args] == 1} {
  38.     set new(background) [lindex $args 0]
  39.     } else {
  40.     array set new $args
  41.     }
  42.     if {![info exists new(background)]} {
  43.     error "must specify a background color"
  44.     }
  45.     if {![info exists new(foreground)]} {
  46.     set new(foreground) black
  47.     }
  48.     set bg [winfo rgb . $new(background)]
  49.     set fg [winfo rgb . $new(foreground)]
  50.     set darkerBg [format #%02x%02x%02x [expr {(9*[lindex $bg 0])/2560}] \
  51.         [expr {(9*[lindex $bg 1])/2560}] [expr {(9*[lindex $bg 2])/2560}]]
  52.     foreach i {activeForeground insertBackground selectForeground \
  53.         highlightColor} {
  54.     if {![info exists new($i)]} {
  55.         set new($i) $new(foreground)
  56.     }
  57.     }
  58.     if {![info exists new(disabledForeground)]} {
  59.     set new(disabledForeground) [format #%02x%02x%02x \
  60.         [expr {(3*[lindex $bg 0] + [lindex $fg 0])/1024}] \
  61.         [expr {(3*[lindex $bg 1] + [lindex $fg 1])/1024}] \
  62.         [expr {(3*[lindex $bg 2] + [lindex $fg 2])/1024}]]
  63.     }
  64.     if {![info exists new(highlightBackground)]} {
  65.     set new(highlightBackground) $new(background)
  66.     }
  67.     if {![info exists new(activeBackground)]} {
  68.     # Pick a default active background that islighter than the
  69.     # normal background.  To do this, round each color component
  70.     # up by 15% or 1/3 of the way to full white, whichever is
  71.     # greater.
  72.  
  73.     foreach i {0 1 2} {
  74.         set light($i) [expr {[lindex $bg $i]/256}]
  75.         set inc1 [expr {($light($i)*15)/100}]
  76.         set inc2 [expr {(255-$light($i))/3}]
  77.         if {$inc1 > $inc2} {
  78.         incr light($i) $inc1
  79.         } else {
  80.         incr light($i) $inc2
  81.         }
  82.         if {$light($i) > 255} {
  83.         set light($i) 255
  84.         }
  85.     }
  86.     set new(activeBackground) [format #%02x%02x%02x $light(0) \
  87.         $light(1) $light(2)]
  88.     }
  89.     if {![info exists new(selectBackground)]} {
  90.     set new(selectBackground) $darkerBg
  91.     }
  92.     if {![info exists new(troughColor)]} {
  93.     set new(troughColor) $darkerBg
  94.     }
  95.     if {![info exists new(selectColor)]} {
  96.     set new(selectColor) #b03060
  97.     }
  98.  
  99.     # let's make one of each of the widgets so we know what the 
  100.     # defaults are currently for this platform.
  101.     toplevel .___tk_set_palette
  102.     wm withdraw .___tk_set_palette
  103.     foreach q {button canvas checkbutton entry frame label listbox \
  104.         menubutton menu message radiobutton scale scrollbar text} {
  105.     $q .___tk_set_palette.$q
  106.     }
  107.  
  108.     # Walk the widget hierarchy, recoloring all existing windows.
  109.     # The option database must be set according to what we do here, 
  110.     # but it breaks things if we set things in the database while 
  111.     # we are changing colors...so, tkRecolorTree now returns the
  112.     # option database changes that need to be made, and they
  113.     # need to be evalled here to take effect.
  114.     # We have to walk the whole widget tree instead of just 
  115.     # relying on the widgets we've created above to do the work
  116.     # because different extensions may provide other kinds
  117.     # of widgets that we don't currently know about, so we'll
  118.     # walk the whole hierarchy just in case.
  119.  
  120.     eval [tkRecolorTree . new]
  121.  
  122.     catch {destroy .___tk_set_palette}
  123.  
  124.     # Change the option database so that future windows will get the
  125.     # same colors.
  126.  
  127.     foreach option [array names new] {
  128.     option add *$option $new($option) widgetDefault
  129.     }
  130.  
  131.     # Save the options in the global variable tkPalette, for use the
  132.     # next time we change the options.
  133.  
  134.     array set tkPalette [array get new]
  135. }
  136.  
  137. # tkRecolorTree --
  138. # This procedure changes the colors in a window and all of its
  139. # descendants, according to information provided by the colors
  140. # argument. This looks at the defaults provided by the option 
  141. # database, if it exists, and if not, then it looks at the default
  142. # value of the widget itself.
  143. #
  144. # Arguments:
  145. # w -            The name of a window.  This window and all its
  146. #            descendants are recolored.
  147. # colors -        The name of an array variable in the caller,
  148. #            which contains color information.  Each element
  149. #            is named after a widget configuration option, and
  150. #            each value is the value for that option.
  151.  
  152. proc tkRecolorTree {w colors} {
  153.     global tkPalette
  154.     upvar $colors c
  155.     set result {}
  156.     foreach dbOption [array names c] {
  157.     set option -[string tolower $dbOption]
  158.     if {![catch {$w config $option} value]} {
  159.         # if the option database has a preference for this
  160.         # dbOption, then use it, otherwise use the defaults
  161.         # for the widget.
  162.         set defaultcolor [option get $w $dbOption widgetDefault]
  163.         if {[string match {} $defaultcolor]} {
  164.         set defaultcolor [winfo rgb . [lindex $value 3]]
  165.         } else {
  166.         set defaultcolor [winfo rgb . $defaultcolor]
  167.         }
  168.         set chosencolor [winfo rgb . [lindex $value 4]]
  169.         if {[string match $defaultcolor $chosencolor]} {
  170.         # Change the option database so that future windows will get
  171.         # the same colors.
  172.         append result ";\noption add [list \
  173.             *[winfo class $w].$dbOption $c($dbOption) 60]"
  174.         $w configure $option $c($dbOption)
  175.         }
  176.     }
  177.     }
  178.     foreach child [winfo children $w] {
  179.     append result ";\n[tkRecolorTree $child c]"
  180.     }
  181.     return $result
  182. }
  183.  
  184. # tkDarken --
  185. # Given a color name, computes a new color value that darkens (or
  186. # brightens) the given color by a given percent.
  187. #
  188. # Arguments:
  189. # color -    Name of starting color.
  190. # perecent -    Integer telling how much to brighten or darken as a
  191. #        percent: 50 means darken by 50%, 110 means brighten
  192. #        by 10%.
  193.  
  194. proc tkDarken {color percent} {
  195.     foreach {red green blue} [winfo rgb . $color] {
  196.     set red [expr {($red/256)*$percent/100}]
  197.     set green [expr {($green/256)*$percent/100}]
  198.     set blue [expr {($blue/256)*$percent/100}]
  199.     break
  200.     }
  201.     if {$red > 255} {
  202.     set red 255
  203.     }
  204.     if {$green > 255} {
  205.     set green 255
  206.     }
  207.     if {$blue > 255} {
  208.     set blue 255
  209.     }
  210.     return [format "#%02x%02x%02x" $red $green $blue]
  211. }
  212.  
  213. # tk_bisque --
  214. # Reset the Tk color palette to the old "bisque" colors.
  215. #
  216. # Arguments:
  217. # None.
  218.  
  219. proc tk_bisque {} {
  220.     tk_setPalette activeBackground #e6ceb1 activeForeground black \
  221.         background #ffe4c4 disabledForeground #b0b0b0 foreground black \
  222.         highlightBackground #ffe4c4 highlightColor black \
  223.         insertBackground black selectColor #b03060 \
  224.         selectBackground #e6ceb1 selectForeground black \
  225.         troughColor #cdb79e
  226. }
  227.