HP/util/HP/lib/tk8.0/demos/tcolor

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