home *** CD-ROM | disk | FTP | other *** search
/ Freesoft 1999 February / Freesoft_1999-02_cd.bin / Recenz / Utility / DisplayDoctorLinux / scitech-display-doctor-1.0beta-3.i386.rpm / scitech-display-doctor-1.0beta.3.cpio.gz / scitech-display-doctor-1.0beta.3.cpio / usr / lib / nucleus / XF86Setup / tcllib / palette.tcl < prev    next >
Text File  |  1998-09-19  |  7KB  |  228 lines
  1. # $XConsortium: palette.tcl /main/1 1996/09/21 14:16:00 kaleb $
  2. #
  3. #
  4. #
  5. #
  6. # $XFree86: xc/programs/Xserver/hw/xfree86/XF86Setup/tcllib/palette.tcl,v 3.1 1996/12/27 06:55:03 dawes Exp $
  7. #
  8. # palette.tcl --
  9. #
  10. # This file contains procedures that change the color palette used
  11. # by Tk.
  12. #
  13. # @(#) palette.tcl 1.1 95/05/22 14:55:29
  14. #
  15. # Copyright (c) 1995 Sun Microsystems, Inc.
  16. #
  17. # See the file "license.terms" for information on usage and redistribution
  18. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  19. #
  20.  
  21. # tk_setPalette --
  22. # Changes the default color scheme for a Tk application by setting
  23. # default colors in the option database and by modifying all of the
  24. # color options for existing widgets that have the default value.
  25. #
  26. # Arguments:
  27. # The arguments consist of either a single color name, which
  28. # will be used as the new background color (all other colors will
  29. # be computed from this) or an even number of values consisting of
  30. # option names and values.  The name for an option is the one used
  31. # for the option database, such as activeForeground, not -activeforeground.
  32.  
  33. proc tk_setPalette args {
  34.     global tkPalette
  35.  
  36.     # Create an array that has the complete new palette.  If some colors
  37.     # aren't specified, compute them from other colors that are specified.
  38.  
  39.     if {[llength $args] == 1} {
  40.     set new(background) [lindex $args 0]
  41.     } else {
  42.     array set new $args
  43.     }
  44.     if ![info exists new(background)] {
  45.     error "must specify a background color"
  46.     }
  47.     if ![info exists new(foreground)] {
  48.     set new(foreground) black
  49.     }
  50.     set bg [winfo rgb . $new(background)]
  51.     set fg [winfo rgb . $new(foreground)]
  52.     set darkerBg [format #%02x%02x%02x [expr (9*[lindex $bg 0])/2560] \
  53.         [expr (9*[lindex $bg 1])/2560] [expr (9*[lindex $bg 2])/2560]]
  54.     foreach i {activeForeground insertBackground selectForeground \
  55.         highlightColor} {
  56.     if ![info exists new($i)] {
  57.         set new($i) $new(foreground)
  58.     }
  59.     }
  60.     if ![info exists new(disabledForeground)] {
  61.     set new(disabledForeground) [format #%02x%02x%02x \
  62.         [expr (3*[lindex $bg 0] + [lindex $fg 0])/1024] \
  63.         [expr (3*[lindex $bg 1] + [lindex $fg 1])/1024] \
  64.         [expr (3*[lindex $bg 2] + [lindex $fg 2])/1024]]
  65.     }
  66.     if ![info exists new(highlightBackground)] {
  67.     set new(highlightBackground) $new(background)
  68.     }
  69.     if ![info exists new(activeBackground)] {
  70.     # Pick a default active background that islighter than the
  71.     # normal background.  To do this, round each color component
  72.     # up by 15% or 1/3 of the way to full white, whichever is
  73.     # greater.
  74.  
  75.     foreach i {0 1 2} {
  76.         set light($i) [expr [lindex $bg $i]/256]
  77.         set inc1 [expr ($light($i)*15)/100]
  78.         set inc2 [expr (255-$light($i))/3]
  79.         if {$inc1 > $inc2} {
  80.         incr light($i) $inc1
  81.         } else {
  82.         incr light($i) $inc2
  83.         }
  84.         if {$light($i) > 255} {
  85.         set light($i) 255
  86.         }
  87.     }
  88.     set new(activeBackground) [format #%02x%02x%02x $light(0) \
  89.         $light(1) $light(2)]
  90.     }
  91.     if ![info exists new(selectBackground)] {
  92.     set new(selectBackground) $darkerBg
  93.     }
  94.     if ![info exists new(troughColor)] {
  95.     set new(troughColor) $darkerBg
  96.     }
  97.     if ![info exists new(selectColor)] {
  98.     set new(selectColor) #b03060
  99.     }
  100.  
  101.     # Walk the widget hierarchy, recoloring all existing windows.
  102.     # Before doing this, make sure that the tkPalette variable holds
  103.     # the default values of all options, so that tkRecolorTree can
  104.     # be sure to only change options that have their default values.
  105.     # If the variable exists, then it is already correct (it was created
  106.     # the last time this procedure was invoked).  If the variable
  107.     # doesn't exist, fill it in using the defaults from a few widgets.
  108.  
  109.     if ![info exists tkPalette] {
  110.     checkbutton .c14732
  111.     entry .e14732
  112.     scrollbar .s14732
  113.     set tkPalette(activeBackground) \
  114.         [lindex [.c14732 configure -activebackground] 3]
  115.     set tkPalette(activeForeground) \
  116.         [lindex [.c14732 configure -activeforeground] 3]
  117.     set tkPalette(background) \
  118.         [lindex [.c14732 configure -background] 3]
  119.     set tkPalette(disabledForeground) \
  120.         [lindex [.c14732 configure -disabledforeground] 3]
  121.     set tkPalette(foreground) \
  122.         [lindex [.c14732 configure -foreground] 3]
  123.     set tkPalette(highlightBackground) \
  124.         [lindex [.c14732 configure -highlightbackground] 3]
  125.     set tkPalette(highlightColor) \
  126.         [lindex [.c14732 configure -highlightcolor] 3]
  127.     set tkPalette(insertBackground) \
  128.         [lindex [.e14732 configure -insertbackground] 3]
  129.     set tkPalette(selectColor) \
  130.         [lindex [.c14732 configure -selectcolor] 3]
  131.     set tkPalette(selectBackground) \
  132.         [lindex [.e14732 configure -selectbackground] 3]
  133.     set tkPalette(selectForeground) \
  134.         [lindex [.e14732 configure -selectforeground] 3]
  135.     set tkPalette(troughColor) \
  136.         [lindex [.s14732 configure -troughcolor] 3]
  137.     destroy .c14732 .e14732 .s14732
  138.     }
  139.     tkRecolorTree . new
  140.  
  141.     # Change the option database so that future windows will get the
  142.     # same colors.
  143.  
  144.     foreach option [array names new] {
  145.     option add *$option $new($option) widgetDefault
  146.     }
  147.  
  148.     # Save the options in the global variable tkPalette, for use the
  149.     # next time we change the options.
  150.  
  151.     array set tkPalette [array get new]
  152. }
  153.  
  154. # tkRecolorTree --
  155. # This procedure changes the colors in a window and all of its
  156. # descendants, according to information provided by the colors
  157. # argument.  It only modifies colors that have their default values
  158. # as specified by the tkPalette variable.
  159. #
  160. # Arguments:
  161. # w -            The name of a window.  This window and all its
  162. #            descendants are recolored.
  163. # colors -        The name of an array variable in the caller,
  164. #            which contains color information.  Each element
  165. #            is named after a widget configuration option, and
  166. #            each value is the value for that option.
  167.  
  168. proc tkRecolorTree {w colors} {
  169.     global tkPalette
  170.     upvar $colors c
  171.     foreach dbOption [array names c] {
  172.     set option -[string tolower $dbOption]
  173.     if ![catch {$w cget $option} value] {
  174.         if {$value == $tkPalette($dbOption)} {
  175.         $w configure $option $c($dbOption)
  176.         }
  177.     }
  178.     }
  179.     foreach child [winfo children $w] {
  180.     tkRecolorTree $child c
  181.     }
  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.     set l [winfo rgb . $color]
  196.     set red [expr [lindex $l 0]/256]
  197.     set green [expr [lindex $l 1]/256]
  198.     set blue [expr [lindex $l 2]/256]
  199.     set red [expr ($red*$percent)/100]
  200.     if {$red > 255} {
  201.     set red 255
  202.     }
  203.     set green [expr ($green*$percent)/100]
  204.     if {$green > 255} {
  205.     set green 255
  206.     }
  207.     set blue [expr ($blue*$percent)/100]
  208.     if {$blue > 255} {
  209.     set blue 255
  210.     }
  211.     format #%02x%02x%02x $red $green $blue
  212. }
  213.  
  214. # tk_bisque --
  215. # Reset the Tk color palette to the old "bisque" colors.
  216. #
  217. # Arguments:
  218. # None.
  219.  
  220. proc tk_bisque {} {
  221.     tk_setPalette activeBackground #e6ceb1 activeForeground black \
  222.         background #ffe4c4 disabledForeground #b0b0b0 foreground black \
  223.         highlightBackground #ffe4c4 highlightColor black \
  224.         insertBackground black selectColor #b03060 \
  225.         selectBackground #e6ceb1 selectForeground black \
  226.         troughColor #cdb79e
  227. }
  228.