home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 5 / Skunkware 5.iso / lib / tk / demos / tcolor < prev    next >
Encoding:
Text File  |  1995-07-21  |  11.5 KB  |  367 lines
  1. #!/usr/skunk/bin/wish -f
  2. #
  3. # This script implements a simple color editor, where you can
  4. # create colors using either the RGB, HSB, or CYM color spaces
  5. # and apply the color to existing applications.
  6.  
  7. wm title . "Color Editor"
  8. tk_bindForTraversal .
  9. focus .
  10.  
  11. # Global variables that control the program:
  12. #
  13. # colorSpace -            Color space currently being used for
  14. #                editing.  Must be "rgb", "cmy", or "hsb".
  15. # label1, label2, label3 -    Labels for the scales.
  16. # red, green, blue -        Current color intensities in decimal
  17. #                on a scale of 0-65535.
  18. # color -            A string giving the current color value
  19. #                in the proper form for x:
  20. #                #RRRRGGGGBBBB
  21. # updating -            Non-zero means that we're in the middle of
  22. #                updating the scales to load a new color,so
  23. #                information shouldn't be propagating back
  24. #                from the scales to other elements of the
  25. #                program:  this would make an infinite loop.
  26. # command -            Holds the command that has been typed
  27. #                into the "Command" entry.
  28. # autoUpdate -            1 means execute the update command
  29. #                automatically whenever the color changes.
  30. # name -            Name for new color, typed into entry.
  31.  
  32. set colorSpace hsb
  33. set red 65535
  34. set green 0
  35. set blue 0
  36. set color #ffff00000000
  37. set updating 0
  38. set autoUpdate 1
  39. set name ""
  40.  
  41. # Create the menu bar at the top of the window.
  42.  
  43. frame .menu -relief raised -borderwidth 2
  44. pack .menu -side top -fill x
  45. menubutton .menu.file -text File -menu .menu.file.m -underline 0
  46. menu .menu.file.m
  47. .menu.file.m add radio -label "RGB color space" -variable colorSpace \
  48.     -value rgb -underline 0 -command {changeColorSpace rgb}
  49. .menu.file.m add radio -label "CMY color space" -variable colorSpace \
  50.     -value cmy -underline 0 -command {changeColorSpace cmy}
  51. .menu.file.m add radio -label "HSB color space" -variable colorSpace \
  52.     -value hsb -underline 0 -command {changeColorSpace hsb}
  53. .menu.file.m add separator
  54. .menu.file.m add radio -label "Automatic updates" -variable autoUpdate \
  55.     -value 1 -underline 0
  56. .menu.file.m add radio -label "Manual updates" -variable autoUpdate \
  57.     -value 0 -underline 0
  58. .menu.file.m add separator
  59. .menu.file.m add command -label "Exit program" -underline 0 \
  60.     -command "destroy ."
  61. pack .menu.file -side left
  62. tk_menuBar .menu .menu.file
  63.  
  64. # Create the command entry window at the bottom of the window, along
  65. # with the update button.
  66.  
  67. frame .bot -relief raised -borderwidth 2
  68. pack .bot -side bottom -fill x
  69. label .commandLabel -text "Command:"
  70. entry .command -relief sunken -borderwidth 2 -textvariable command \
  71.     -font -Adobe-Courier-Medium-R-Normal-*-120-*
  72. button .update -text Update -command doUpdate
  73. pack .commandLabel -in .bot -side left
  74. pack .update -in .bot -side right -pady .1c -padx .25c
  75. pack .command -in .bot -expand yes -fill x -ipadx 0.25c
  76.  
  77. # Create the listbox that holds all of the color names in rgb.txt,
  78. # if an rgb.txt file can be found.
  79.  
  80. frame .middle -relief raised -borderwidth 2
  81. pack .middle -side top -fill both
  82. foreach i {/usr/local/lib/X11/rgb.txt /usr/lib/X11/rgb.txt
  83.     /X11/R5/lib/X11/rgb.txt /X11/R4/lib/rgb/rgb.txt} {
  84.     if ![file readable $i] {
  85.     continue;
  86.     }
  87.     set f [open $i]
  88.     frame .middle.left
  89.     pack .middle.left -side left -padx .25c -pady .25c
  90.     listbox .names -geometry 20x12 -yscrollcommand ".scroll set" \
  91.         -relief sunken -borderwidth 2 -exportselection false
  92.     tk_listboxSingleSelect .names
  93.     bind .names <Double-1> {
  94.         tc_loadNamedColor [.names get [.names curselection]]
  95.     }
  96.     scrollbar .scroll -orient vertical -command ".names yview" \
  97.         -relief sunken -borderwidth 2
  98.     pack .names -in .middle.left -side left
  99.     pack .scroll -in .middle.left -side right -fill y
  100.     while {[gets $f line] >= 0} {
  101.     if {[llength $line] == 4} {
  102.         .names insert end [lindex $line 3]
  103.     }
  104.     }
  105.     close $f
  106.     break;
  107. }
  108.  
  109. # Create the three scales for editing the color, and the entry for
  110. # typing in a color value.
  111.  
  112. frame .middle.middle
  113. pack .middle.middle -side left -expand yes -fill y
  114. frame .middle.middle.1
  115. frame .middle.middle.2
  116. frame .middle.middle.3
  117. frame .middle.middle.4
  118. pack .middle.middle.1 .middle.middle.2 .middle.middle.3 -side top -expand yes
  119. pack .middle.middle.4 -side top -expand yes -fill x
  120. foreach i {1 2 3} {
  121.     label .label$i -textvariable label$i
  122.     scale .scale$i -from 0 -to 1000 -length 10c -orient horizontal \
  123.         -command tc_scaleChanged
  124.     button .up$i -width 2 -text + -command "tc_inc $i 1"
  125.     button .down$i -width 2 -text - -command "tc_inc $i -1"
  126.     pack .label$i -in .middle.middle.$i -side top -anchor w
  127.     pack .down$i -in .middle.middle.$i -side left -padx .25c
  128.     pack .scale$i -in .middle.middle.$i -side left
  129.     pack .up$i -in .middle.middle.$i -side left -padx .25c
  130. }
  131. label .nameLabel -text "Name of new color:"
  132. entry .name -relief sunken -borderwidth 2 -textvariable name -width 30 \
  133.     -font -Adobe-Courier-Medium-R-Normal-*-120-*
  134. pack .nameLabel .name -in .middle.middle.4 -side left
  135. bind .name <Return> {tc_loadNamedColor $name}
  136.  
  137. # Create the color display swatch on the right side of the window.
  138.  
  139. frame .middle.right
  140. pack .middle.right -side left -pady .25c -padx .25c -anchor s
  141. frame .swatch -width 2c -height 5c -background $color
  142. label .value -textvariable color -width 13 \
  143.     -font -Adobe-Courier-Medium-R-Normal-*-120-*
  144. pack .swatch -in .middle.right -side top -expand yes -fill both
  145. pack .value -in .middle.right -side bottom -pady .25c
  146.  
  147. # The procedure below handles the "+" and "-" buttons next to
  148. # the adjustor scales.  They just increment or decrement the
  149. # appropriate scale value.
  150.  
  151. proc tc_inc {scale inc} {
  152.     .scale$scale set [expr [.scale$scale get]+$inc]
  153. }
  154.  
  155. # The procedure below is invoked when one of the scales is adjusted.
  156. # It propagates color information from the current scale readings
  157. # to everywhere else that it is used.
  158.  
  159. proc tc_scaleChanged args {
  160.     global red green blue colorSpace color updating autoUpdate
  161.     if $updating {
  162.     return
  163.     }
  164.     if {$colorSpace == "rgb"} {
  165.     set red   [format %.0f [expr [.scale1 get]*65.535]]
  166.     set green [format %.0f [expr [.scale2 get]*65.535]]
  167.     set blue  [format %.0f [expr [.scale3 get]*65.535]]
  168.     } else {
  169.     if {$colorSpace == "cmy"} {
  170.         set red   [format %.0f [expr {65535 - [.scale1 get]*65.535}]]
  171.         set green [format %.0f [expr {65535 - [.scale2 get]*65.535}]]
  172.         set blue  [format %.0f [expr {65535 - [.scale3 get]*65.535}]]
  173.     } else {
  174.         set list [hsbToRgb [expr {[.scale1 get]/1000.0}] \
  175.             [expr {[.scale2 get]/1000.0}] \
  176.             [expr {[.scale3 get]/1000.0}]]
  177.         set red [lindex $list 0]
  178.         set green [lindex $list 1]
  179.         set blue [lindex $list 2]
  180.     }
  181.     }
  182.     set color [format "#%04x%04x%04x" $red $green $blue]
  183.     .swatch config -bg $color
  184.     if $autoUpdate doUpdate
  185.     update idletasks
  186. }
  187.  
  188. # The procedure below is invoked to update the scales from the
  189. # current red, green, and blue intensities.  It's invoked after
  190. # a change in the color space and after a named color value has
  191. # been loaded.
  192.  
  193. proc tc_setScales {} {
  194.     global red green blue colorSpace updating
  195.     set updating 1
  196.     if {$colorSpace == "rgb"} {
  197.     .scale1 set [format %.0f [expr $red/65.535]]
  198.     .scale2 set [format %.0f [expr $green/65.535]]
  199.     .scale3 set [format %.0f [expr $blue/65.535]]
  200.     } else {
  201.     if {$colorSpace == "cmy"} {
  202.         .scale1 set [format %.0f [expr (65535-$red)/65.535]]
  203.         .scale2 set [format %.0f [expr (65535-$green)/65.535]]
  204.         .scale3 set [format %.0f [expr (65535-$blue)/65.535]]
  205.     } else {
  206.         set list [rgbToHsv $red $green $blue]
  207.         .scale1 set [format %.0f [expr {[lindex $list 0] * 1000.0}]]
  208.         .scale2 set [format %.0f [expr {[lindex $list 1] * 1000.0}]]
  209.         .scale3 set [format %.0f [expr {[lindex $list 2] * 1000.0}]]
  210.     }
  211.     }
  212.     set updating 0
  213. }
  214.  
  215. # The procedure below is invoked when a named color has been
  216. # selected from the listbox or typed into the entry.  It loads
  217. # the color into the editor.
  218.  
  219. proc tc_loadNamedColor name {
  220.     global red green blue color autoUpdate
  221.  
  222.     if {[string index $name 0] != "#"} {
  223.     set list [winfo rgb .swatch $name]
  224.     set red [lindex $list 0]
  225.     set green [lindex $list 1]
  226.     set blue [lindex $list 2]
  227.     } else {
  228.     case [string length $name] {
  229.         4 {set format "#%1x%1x%1x"; set shift 12}
  230.         7 {set format "#%2x%2x%2x"; set shift 8}
  231.         10 {set format "#%3x%3x%3x"; set shift 4}
  232.         13 {set format "#%4x%4x%4x"; set shift 0}
  233.         default {error "syntax error in color name \"$name\""}
  234.     }
  235.     if {[scan $name $format red green blue] != 3} {
  236.         error "syntax error in color name \"$name\""
  237.     }
  238.     set red [expr $red<<$shift]
  239.     set green [expr $green<<$shift]
  240.     set blue [expr $blue<<$shift]
  241.     }
  242.     tc_setScales
  243.     set color [format "#%04x%04x%04x" $red $green $blue]
  244.     .swatch config -bg $color
  245.     if $autoUpdate doUpdate
  246. }
  247.  
  248. # The procedure below is invoked when a new color space is selected.
  249. # It changes the labels on the scales and re-loads the scales with
  250. # the appropriate values for the current color in the new color space
  251.  
  252. proc changeColorSpace space {
  253.     global label1 label2 label3
  254.     if {$space == "rgb"} {
  255.     set label1 Red
  256.     set label2 Green
  257.     set label3 Blue
  258.     tc_setScales
  259.     return
  260.     }
  261.     if {$space == "cmy"} {
  262.     set label1 Cyan
  263.     set label2 Magenta
  264.     set label3 Yellow
  265.     tc_setScales
  266.     return
  267.     }
  268.     if {$space == "hsb"} {
  269.     set label1 Hue
  270.     set label2 Saturation
  271.     set label3 Brightness
  272.     tc_setScales
  273.     return
  274.     }
  275. }
  276.  
  277. # The procedure below converts an RGB value to HSB.  It takes red, green,
  278. # and blue components (0-65535) as arguments, and returns a list containing
  279. # HSB components (floating-point, 0-1) as result.  The code here is a copy
  280. # of the code on page 615 of "Fundamentals of Interactive Computer Graphics"
  281. # by Foley and Van Dam.
  282.  
  283. proc rgbToHsv {red green blue} {
  284.     if {$red > $green} {
  285.     set max $red.0
  286.     set min $green.0
  287.     } else {
  288.     set max $green.0
  289.     set min $red.0
  290.     }
  291.     if {$blue > $max} {
  292.     set max $blue.0
  293.     } else {
  294.     if {$blue < $min} {
  295.         set min $blue.0
  296.     }
  297.     }
  298.     set range [expr $max-$min]
  299.     if {$max == 0} {
  300.     set sat 0
  301.     } else {
  302.     set sat [expr {($max-$min)/$max}]
  303.     }
  304.     if {$sat == 0} {
  305.     set hue 0
  306.     } else {
  307.     set rc [expr {($max - $red)/$range}]
  308.     set gc [expr {($max - $green)/$range}]
  309.     set bc [expr {($max - $blue)/$range}]
  310.     if {$red == $max} {
  311.         set hue [expr {.166667*($bc - $gc)}]
  312.     } else {
  313.         if {$green == $max} {
  314.         set hue [expr {.166667*(2 + $rc - $bc)}]
  315.         } else {
  316.         set hue [expr {.166667*(4 + $gc - $rc)}]
  317.         }
  318.     }
  319.     }
  320.     return [list $hue $sat [expr {$max/65535}]]
  321. }
  322.  
  323. # The procedure below converts an HSB value to RGB.  It takes hue, saturation,
  324. # and value components (floating-point, 0-1.0) as arguments, and returns a
  325. # list containing RGB components (integers, 0-65535) as result.  The code
  326. # here is a copy of the code on page 616 of "Fundamentals of Interactive
  327. # Computer Graphics" by Foley and Van Dam.
  328.  
  329. proc hsbToRgb {hue sat value} {
  330.     set v [format %.0f [expr 65535.0*$value]]
  331.     if {$sat == 0} {
  332.     return "$v $v $v"
  333.     } else {
  334.     set hue [expr $hue*6.0]
  335.     if {$hue >= 6.0} {
  336.         set hue 0.0
  337.     }
  338.     scan $hue. %d i
  339.     set f [expr $hue-$i]
  340.     set p [format %.0f [expr {65535.0*$value*(1 - $sat)}]]
  341.     set q [format %.0f [expr {65535.0*$value*(1 - ($sat*$f))}]]
  342.     set t [format %.0f [expr {65535.0*$value*(1 - ($sat*(1 - $f)))}]]
  343.     case $i \
  344.         0 {return "$v $t $p"} \
  345.         1 {return "$q $v $p"} \
  346.         2 {return "$p $v $t"} \
  347.         3 {return "$p $q $v"} \
  348.         4 {return "$t $p $v"} \
  349.         5 {return "$v $p $q"}
  350.     error "i value $i is out of range"
  351.     }
  352. }
  353.  
  354. # The procedure below is invoked when the "Update" button is pressed,
  355. # and whenever the color changes if update mode is enabled.  It
  356. # propagates color information as determined by the command in the
  357. # Command entry.
  358.  
  359. proc doUpdate {} {
  360.     global color command
  361.     set newCmd $command
  362.     regsub -all %% $command $color newCmd
  363.     eval $newCmd
  364. }
  365.  
  366. changeColorSpace hsb
  367.