home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tk42r2x.zip / TclTk / lib / tk4.2 / palette.tcl < prev    next >
Text File  |  1999-07-27  |  6KB  |  200 lines
  1. # palette.tcl --
  2. #
  3. # This file contains procedures that change the color palette used
  4. # by Tk.
  5. #
  6. # SCCS: @(#) palette.tcl 1.4 96/12/04 10:00:17
  7. #
  8. # Copyright (c) 1995 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.     global tkPalette
  28.  
  29.     # Create an array that has the complete new palette.  If some colors
  30.     # aren't specified, compute them from other colors that are specified.
  31.  
  32.     if {[llength $args] == 1} {
  33.     set new(background) [lindex $args 0]
  34.     } else {
  35.     array set new $args
  36.     }
  37.     if ![info exists new(background)] {
  38.     error "must specify a background color"
  39.     }
  40.     if ![info exists new(foreground)] {
  41.     set new(foreground) black
  42.     }
  43.     set bg [winfo rgb . $new(background)]
  44.     set fg [winfo rgb . $new(foreground)]
  45.     set darkerBg [format #%02x%02x%02x [expr (9*[lindex $bg 0])/2560] \
  46.         [expr (9*[lindex $bg 1])/2560] [expr (9*[lindex $bg 2])/2560]]
  47.     foreach i {activeForeground insertBackground selectForeground \
  48.         highlightColor} {
  49.     if ![info exists new($i)] {
  50.         set new($i) $new(foreground)
  51.     }
  52.     }
  53.     if ![info exists new(disabledForeground)] {
  54.     set new(disabledForeground) [format #%02x%02x%02x \
  55.         [expr (3*[lindex $bg 0] + [lindex $fg 0])/1024] \
  56.         [expr (3*[lindex $bg 1] + [lindex $fg 1])/1024] \
  57.         [expr (3*[lindex $bg 2] + [lindex $fg 2])/1024]]
  58.     }
  59.     if ![info exists new(highlightBackground)] {
  60.     set new(highlightBackground) $new(background)
  61.     }
  62.     if ![info exists new(activeBackground)] {
  63.     # Pick a default active background that islighter than the
  64.     # normal background.  To do this, round each color component
  65.     # up by 15% or 1/3 of the way to full white, whichever is
  66.     # greater.
  67.  
  68.     foreach i {0 1 2} {
  69.         set light($i) [expr [lindex $bg $i]/256]
  70.         set inc1 [expr ($light($i)*15)/100]
  71.         set inc2 [expr (255-$light($i))/3]
  72.         if {$inc1 > $inc2} {
  73.         incr light($i) $inc1
  74.         } else {
  75.         incr light($i) $inc2
  76.         }
  77.         if {$light($i) > 255} {
  78.         set light($i) 255
  79.         }
  80.     }
  81.     set new(activeBackground) [format #%02x%02x%02x $light(0) \
  82.         $light(1) $light(2)]
  83.     }
  84.     if ![info exists new(selectBackground)] {
  85.     set new(selectBackground) $darkerBg
  86.     }
  87.     if ![info exists new(troughColor)] {
  88.     set new(troughColor) $darkerBg
  89.     }
  90.     if ![info exists new(selectColor)] {
  91.     set new(selectColor) #b03060
  92.     }
  93.  
  94.     # Walk the widget hierarchy, recoloring all existing windows.
  95.     # The option database must be set according to what we do here, 
  96.     # but it breaks things if we set things in the database while 
  97.     # we are changing colors...so, tkRecolorTree now returns the
  98.     # option database changes that need to be made, and they
  99.     # need to be evalled here to take effect.
  100.  
  101.     eval [tkRecolorTree . new]
  102.  
  103.     # Save the options in the global variable tkPalette, for use the
  104.     # next time we change the options.
  105.  
  106.     array set tkPalette [array get new]
  107. }
  108.  
  109. # tkRecolorTree --
  110. # This procedure changes the colors in a window and all of its
  111. # descendants, according to information provided by the colors
  112. # argument. This looks at the defaults provided by the option 
  113. # database, if it exists, and if not, then it looks at the default
  114. # value of the widget itself.
  115. #
  116. # Arguments:
  117. # w -            The name of a window.  This window and all its
  118. #            descendants are recolored.
  119. # colors -        The name of an array variable in the caller,
  120. #            which contains color information.  Each element
  121. #            is named after a widget configuration option, and
  122. #            each value is the value for that option.
  123.  
  124. proc tkRecolorTree {w colors} {
  125.     global tkPalette
  126.     upvar $colors c
  127.     set result {}
  128.     foreach dbOption [array names c] {
  129.     set option -[string tolower $dbOption]
  130.     if {![catch {$w config $option} value]} {
  131.         # if the option database has a preference for this
  132.         # dbOption, then use it, otherwise use the defaults
  133.         # for the widget.
  134.         set defaultcolor [option get $w $dbOption widgetDefault]
  135.         if {[string match {} $defaultcolor]} {
  136.         set defaultcolor [winfo rgb . [lindex $value 3]]
  137.         } else {
  138.         set defaultcolor [winfo rgb . $defaultcolor]
  139.         }
  140.         set chosencolor [winfo rgb . [lindex $value 4]]
  141.         if {[string match $defaultcolor $chosencolor]} {
  142.         # Change the option database so that future windows will get the
  143.         # same colors.
  144.         
  145.         append result ";\noption add *[winfo class $w].$dbOption $c($dbOption)"
  146.         $w configure $option $c($dbOption)
  147.         }
  148.     }
  149.     }
  150.     foreach child [winfo children $w] {
  151.     append result ";\n[tkRecolorTree $child c]"
  152.     }
  153.     return $result
  154. }
  155.  
  156. # tkDarken --
  157. # Given a color name, computes a new color value that darkens (or
  158. # brightens) the given color by a given percent.
  159. #
  160. # Arguments:
  161. # color -    Name of starting color.
  162. # perecent -    Integer telling how much to brighten or darken as a
  163. #        percent: 50 means darken by 50%, 110 means brighten
  164. #        by 10%.
  165.  
  166. proc tkDarken {color percent} {
  167.     set l [winfo rgb . $color]
  168.     set red [expr [lindex $l 0]/256]
  169.     set green [expr [lindex $l 1]/256]
  170.     set blue [expr [lindex $l 2]/256]
  171.     set red [expr ($red*$percent)/100]
  172.     if {$red > 255} {
  173.     set red 255
  174.     }
  175.     set green [expr ($green*$percent)/100]
  176.     if {$green > 255} {
  177.     set green 255
  178.     }
  179.     set blue [expr ($blue*$percent)/100]
  180.     if {$blue > 255} {
  181.     set blue 255
  182.     }
  183.     format #%02x%02x%02x $red $green $blue
  184. }
  185.  
  186. # tk_bisque --
  187. # Reset the Tk color palette to the old "bisque" colors.
  188. #
  189. # Arguments:
  190. # None.
  191.  
  192. proc tk_bisque {} {
  193.     tk_setPalette activeBackground #e6ceb1 activeForeground black \
  194.         background #ffe4c4 disabledForeground #b0b0b0 foreground black \
  195.         highlightBackground #ffe4c4 highlightColor black \
  196.         insertBackground black selectColor #b03060 \
  197.         selectBackground #e6ceb1 selectForeground black \
  198.         troughColor #cdb79e
  199. }
  200.