diff options
Diffstat (limited to 'library/clrpick.tcl')
| -rw-r--r-- | library/clrpick.tcl | 691 |
1 files changed, 691 insertions, 0 deletions
diff --git a/library/clrpick.tcl b/library/clrpick.tcl new file mode 100644 index 0000000..af5f980 --- /dev/null +++ b/library/clrpick.tcl @@ -0,0 +1,691 @@ +# clrpick.tcl -- +# +# Color selection dialog for platforms that do not support a +# standard color selection dialog. +# +# SCCS: @(#) clrpick.tcl 1.3 96/09/05 09:59:24 +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# ToDo: +# +# (1): Find out how many free colors are left in the colormap and +# don't allocate too many colors. +# (2): Implement HSV color selection. +# + +# tkColorDialog -- +# +# Create a color dialog and let the user choose a color. This function +# should not be called directly. It is called by the tk_chooseColor +# function when a native color selector widget does not exist +# +proc tkColorDialog {args} { + global tkPriv + set w .__tk__color + upvar #0 $w data + + # The lines variables track the start and end indices of the line + # elements in the colorbar canvases. + set data(lines,red,start) 0 + set data(lines,red,last) -1 + set data(lines,green,start) 0 + set data(lines,green,last) -1 + set data(lines,blue,start) 0 + set data(lines,blue,last) -1 + + # This is the actual number of lines that are drawn in each color strip. + # Note that the bars may be of any width. + # However, NUM_COLORBARS must be a number that evenly divides 256. + # Such as 256, 128, 64, etc. + set data(NUM_COLORBARS) 8 + + # BARS_WIDTH is the number of pixels wide the color bar portion of the + # canvas is. This number must be a multiple of NUM_COLORBARS + set data(BARS_WIDTH) 128 + + # PLGN_WIDTH is the number of pixels wide of the triangular selection + # polygon. This also results in the definition of the padding on the + # left and right sides which is half of PLGN_WIDTH. Make this number even. + set data(PLGN_HEIGHT) 10 + + # PLGN_HEIGHT is the height of the selection polygon and the height of the + # selection rectangle at the bottom of the color bar. No restrictions. + set data(PLGN_WIDTH) 10 + + tkColorDialog_Config $w $args + tkColorDialog_InitValues $w + + if ![winfo exists $w] { + toplevel $w -class tkColorDialog + tkColorDialog_BuildDialog $w + } + wm transient $w $data(-parent) + + + # 5. Withdraw the window, then update all the geometry information + # so we know how big it wants to be, then center the window in the + # display and de-iconify it. + + wm withdraw $w + update idletasks + set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ + - [winfo vrootx [winfo parent $w]]] + set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ + - [winfo vrooty [winfo parent $w]]] + wm geom $w +$x+$y + wm deiconify $w + wm title $w $data(-title) + + # 6. Set a grab and claim the focus too. + + set oldFocus [focus] + set oldGrab [grab current $w] + if {$oldGrab != ""} { + set grabStatus [grab status $oldGrab] + } + grab $w + focus $data(okBtn) + + # 7. Wait for the user to respond, then restore the focus and + # return the index of the selected button. Restore the focus + # before deleting the window, since otherwise the window manager + # may take the focus away so we can't redirect it. Finally, + # restore any grab that was in effect. + + tkwait variable tkPriv(selectColor) + catch {focus $oldFocus} + grab release $w + destroy $w + unset data + if {$oldGrab != ""} { + if {$grabStatus == "global"} { + grab -global $oldGrab + } else { + grab $oldGrab + } + } + return $tkPriv(selectColor) +} + +# tkColorDialog_InitValues -- +# +# Get called during initialization or when user resets NUM_COLORBARS +# +proc tkColorDialog_InitValues {w} { + upvar #0 $w data + + # IntensityIncr is the difference in color intensity between a colorbar + # and its neighbors. + set data(intensityIncr) [expr 256 / $data(NUM_COLORBARS)] + + # ColorbarWidth is the width of each colorbar + set data(colorbarWidth) \ + [expr $data(BARS_WIDTH) / $data(NUM_COLORBARS)] + + # Indent is the width of the space at the left and right side of the + # colorbar. It is always half the selector polygon width, because the + # polygon extends into the space. + set data(indent) [expr $data(PLGN_WIDTH) / 2] + + set data(colorPad) 2 + set data(selPad) [expr $data(PLGN_WIDTH) / 2] + + # + # minX is the x coordinate of the first colorbar + # + set data(minX) $data(indent) + + # + # maxX is the x coordinate of the last colorbar + # + set data(maxX) [expr $data(BARS_WIDTH) + $data(indent)-1] + + # + # canvasWidth is the width of the entire canvas, including the indents + # + set data(canvasWidth) [expr $data(BARS_WIDTH) + \ + $data(PLGN_WIDTH)] + + # Set the initial color, specified by -initialcolor, or the + # color chosen by the user the last time. + set data(selection) $data(-initialcolor) + set data(finalColor) $data(-initialcolor) + set rgb [winfo rgb . $data(selection)] + + set data(red,intensity) [expr [lindex $rgb 0]/0x100] + set data(green,intensity) [expr [lindex $rgb 1]/0x100] + set data(blue,intensity) [expr [lindex $rgb 2]/0x100] +} + +# tkColorDialog_Config -- +# +# Parses the command line arguments to tk_chooseColor +# +proc tkColorDialog_Config {w argList} { + global tkPriv + upvar #0 $w data + + # 1: the configuration specs + # + set specs { + {-initialcolor "" "" ""} + {-parent "" "" "."} + {-title "" "" "Color"} + } + + # 2: parse the arguments + # + tclParseConfigSpec $w $specs "" $argList + + if ![string compare $data(-title) ""] { + set data(-title) " " + } + if ![string compare $data(-initialcolor) ""] { + if {[info exists tkPriv(selectColor)] && \ + [string compare $tkPriv(selectColor) ""]} { + set data(-initialcolor) $tkPriv(selectColor) + } else { + set data(-initialcolor) [. cget -background] + } + } else { + if [catch {winfo rgb . $data(-initialcolor)} err] { + error $err + } + } + + if ![winfo exists $data(-parent)] { + error "bad window path name \"$data(-parent)\"" + } +} + +# tkColorDialog_BuildDialog -- +# +# Build the dialog. +# +proc tkColorDialog_BuildDialog {w} { + upvar #0 $w data + + # TopFrame contains the color strips and the color selection + # + set topFrame [frame $w.top -relief raised -bd 1] + + # StripsFrame contains the colorstrips and the individual RGB entries + set stripsFrame [frame $topFrame.colorStrip] + + foreach c { Red Green Blue } { + set color [string tolower $c] + + # each f frame contains an [R|G|B] entry and the equiv. color strip. + set f [frame $stripsFrame.$color] + + # The box frame contains the label and entry widget for an [R|G|B] + set box [frame $f.box] + + label $box.label -text $c: -width 6 -under 0 -anchor ne + entry $box.entry -textvariable [format %s $w]($color,intensity) \ + -width 4 + pack $box.label -side left -fill y -padx 2 -pady 3 + pack $box.entry -side left -anchor n -pady 0 + pack $box -side left -fill both + + set height [expr \ + [winfo reqheight $box.entry] - \ + 2*([$box.entry cget -highlightthickness] + [$box.entry cget -bd])] + + canvas $f.color -height $height\ + -width $data(BARS_WIDTH) -relief sunken -bd 2 + canvas $f.sel -height $data(PLGN_HEIGHT) \ + -width $data(canvasWidth) -highlightthickness 0 + pack $f.color -expand yes -fill both + pack $f.sel -expand yes -fill both + + pack $f -side top -fill x -padx 0 -pady 2 + + set data($color,entry) $box.entry + set data($color,col) $f.color + set data($color,sel) $f.sel + + bind $data($color,col) <Configure> \ + "tkColorDialog_DrawColorScale $w $color 1" + bind $data($color,col) <Enter> \ + "tkColorDialog_EnterColorBar $w $color" + bind $data($color,col) <Leave> \ + "tkColorDialog_LeaveColorBar $w $color" + + bind $data($color,sel) <Enter> \ + "tkColorDialog_EnterColorBar $w $color" + bind $data($color,sel) <Leave> \ + "tkColorDialog_LeaveColorBar $w $color" + + bind $box.entry <Return> "tkColorDialog_HandleRGBEntry $w" + } + + pack $stripsFrame -side left -fill both -padx 4 -pady 10 + + # The selFrame contains a frame that demonstrates the currently + # selected color + # + set selFrame [frame $topFrame.sel] + set lab [label $selFrame.lab -text "Selection:" -under 0 -anchor sw] + set ent [entry $selFrame.ent -textvariable [format %s $w](selection) \ + -width 16] + set f1 [frame $selFrame.f1 -relief sunken -bd 2] + set data(finalCanvas) [frame $f1.demo -bd 0 -width 100 -height 70] + + pack $lab $ent -side top -fill x -padx 4 -pady 2 + pack $f1 -expand yes -anchor nw -fill both -padx 6 -pady 10 + pack $data(finalCanvas) -expand yes -fill both + + bind $ent <Return> "tkColorDialog_HandleSelEntry $w" + + pack $selFrame -side left -fill none -anchor nw + pack $topFrame -side top -expand yes -fill both -anchor nw + + # the botFrame frame contains the buttons + # + set botFrame [frame $w.bot -relief raised -bd 1] + button $botFrame.ok -text OK -width 8 -under 0 \ + -command "tkColorDialog_OkCmd $w" + button $botFrame.cancel -text Cancel -width 8 -under 0 \ + -command "tkColorDialog_CancelCmd $w" + + set data(okBtn) $botFrame.ok + set data(cancelBtn) $botFrame.cancel + + pack $botFrame.ok $botFrame.cancel \ + -padx 10 -pady 10 -expand yes -side left + pack $botFrame -side bottom -fill x + + + # Accelerator bindings + + bind $w <Alt-r> "focus $data(red,entry)" + bind $w <Alt-g> "focus $data(green,entry)" + bind $w <Alt-b> "focus $data(blue,entry)" + bind $w <Alt-s> "focus $ent" + bind $w <KeyPress-Escape> "tkButtonInvoke $data(cancelBtn)" + bind $w <Alt-c> "tkButtonInvoke $data(cancelBtn)" + bind $w <Alt-o> "tkButtonInvoke $data(okBtn)" + + wm protocol $w WM_DELETE_WINDOW "tkColorDialog_CancelCmd $w" +} + +# tkColorDialog_SetRGBValue -- +# +# Sets the current selection of the dialog box +# +proc tkColorDialog_SetRGBValue {w color} { + upvar #0 $w data + + set data(red,intensity) [lindex $color 0] + set data(green,intensity) [lindex $color 1] + set data(blue,intensity) [lindex $color 2] + + tkColorDialog_RedrawColorBars $w all + + # Now compute the new x value of each colorbars pointer polygon + foreach color { red green blue } { + set x [tkColorDialog_RgbToX $w $data($color,intensity)] + tkColorDialog_MoveSelector $w $data($color,sel) $color $x 0 + } +} + +# tkColorDialog_XToRgb -- +# +# Converts a screen coordinate to intensity +# +proc tkColorDialog_XToRgb {w x} { + upvar #0 $w data + + return [expr ($x * $data(intensityIncr))/ $data(colorbarWidth)] +} + +# tkColorDialog_RgbToX +# +# Converts an intensity to screen coordinate. +# +proc tkColorDialog_RgbToX {w color} { + upvar #0 $w data + + return [expr ($color * $data(colorbarWidth)/ $data(intensityIncr))] +} + + +# tkColorDialog_DrawColorScale -- +# +# Draw color scale is called whenever the size of one of the color +# scale canvases is changed. +# +proc tkColorDialog_DrawColorScale {w c {create 0}} { + global lines + upvar #0 $w data + + # col: color bar canvas + # sel: selector canvas + set col $data($c,col) + set sel $data($c,sel) + + # First handle the case that we are creating everything for the first time. + if $create { + # First remove all the lines that already exist. + if { $data(lines,$c,last) > $data(lines,$c,start)} { + for {set i $data(lines,$c,start)} \ + {$i <= $data(lines,$c,last)} { incr i} { + $sel delete $i + } + } + # Delete the selector if it exists + if [info exists data($c,index)] { + $sel delete $data($c,index) + } + + # Draw the selection polygons + tkColorDialog_CreateSelector $w $sel $c + $sel bind $data($c,index) <ButtonPress-1> \ + "tkColorDialog_StartMove $w $sel $c %x $data(selPad) 1" + $sel bind $data($c,index) <B1-Motion> \ + "tkColorDialog_MoveSelector $w $sel $c %x $data(selPad)" + $sel bind $data($c,index) <ButtonRelease-1> \ + "tkColorDialog_ReleaseMouse $w $sel $c %x $data(selPad)" + + set height [winfo height $col] + # Create an invisible region under the colorstrip to catch mouse clicks + # that aren't on the selector. + set data($c,clickRegion) [$sel create rectangle 0 0 \ + $data(canvasWidth) $height -fill {} -outline {}] + + bind $col <ButtonPress-1> \ + "tkColorDialog_StartMove $w $sel $c %x $data(colorPad)" + bind $col <B1-Motion> \ + "tkColorDialog_MoveSelector $w $sel $c %x $data(colorPad)" + bind $col <ButtonRelease-1> \ + "tkColorDialog_ReleaseMouse $w $sel $c %x $data(colorPad)" + + $sel bind $data($c,clickRegion) <ButtonPress-1> \ + "tkColorDialog_StartMove $w $sel $c %x $data(selPad)" + $sel bind $data($c,clickRegion) <B1-Motion> \ + "tkColorDialog_MoveSelector $w $sel $c %x $data(selPad)" + $sel bind $data($c,clickRegion) <ButtonRelease-1> \ + "tkColorDialog_ReleaseMouse $w $sel $c %x $data(selPad)" + } else { + # l is the canvas index of the first colorbar. + set l $data(lines,$c,start) + } + + # Draw the color bars. + set highlightW [expr \ + [$col cget -highlightthickness] + [$col cget -bd]] + for {set i 0} { $i < $data(NUM_COLORBARS)} { incr i} { + set intensity [expr $i * $data(intensityIncr)] + set startx [expr $i * $data(colorbarWidth) + $highlightW] + if { $c == "red" } { + set color [format "#%02x%02x%02x" \ + $intensity \ + $data(green,intensity) \ + $data(blue,intensity)] + } elseif { $c == "green" } { + set color [format "#%02x%02x%02x" \ + $data(red,intensity) \ + $intensity \ + $data(blue,intensity)] + } else { + set color [format "#%02x%02x%02x" \ + $data(red,intensity) \ + $data(green,intensity) \ + $intensity] + } + + if $create { + set index [$col create rect $startx $highlightW \ + [expr $startx +$data(colorbarWidth)] \ + [expr [winfo height $col] + $highlightW]\ + -fill $color -outline $color] + } else { + $col itemconf $l -fill $color -outline $color + incr l + } + } + $sel raise $data($c,index) + + if $create { + set data(lines,$c,last) $index + set data(lines,$c,start) [expr $index - $data(NUM_COLORBARS) + 1 ] + } + + tkColorDialog_RedrawFinalColor $w +} + +# tkColorDialog_CreateSelector -- +# +# Creates and draws the selector polygon at the position +# $data($c,intensity). +# +proc tkColorDialog_CreateSelector {w sel c } { + upvar #0 $w data + set data($c,index) [$sel create polygon \ + 0 $data(PLGN_HEIGHT) \ + $data(PLGN_WIDTH) $data(PLGN_HEIGHT) \ + $data(indent) 0] + set data($c,x) [tkColorDialog_RgbToX $w $data($c,intensity)] + $sel move $data($c,index) $data($c,x) 0 +} + +# tkColorDialog_RedrawFinalColor +# +# Combines the intensities of the three colors into the final color +# +proc tkColorDialog_RedrawFinalColor {w} { + upvar #0 $w data + + set color [format "#%02x%02x%02x" $data(red,intensity) \ + $data(green,intensity) $data(blue,intensity)] + + $data(finalCanvas) conf -bg $color + set data(finalColor) $color + set data(selection) $color + set data(finalRGB) [list \ + $data(red,intensity) \ + $data(green,intensity) \ + $data(blue,intensity)] +} + +# tkColorDialog_RedrawColorBars -- +# +# Only redraws the colors on the color strips that were not manipulated. +# Params: color of colorstrip that changed. If color is not [red|green|blue] +# Then all colorstrips will be updated +# +proc tkColorDialog_RedrawColorBars {w colorChanged} { + upvar #0 $w data + + switch $colorChanged { + red { + tkColorDialog_DrawColorScale $w green + tkColorDialog_DrawColorScale $w blue + } + green { + tkColorDialog_DrawColorScale $w red + tkColorDialog_DrawColorScale $w blue + } + blue { + tkColorDialog_DrawColorScale $w red + tkColorDialog_DrawColorScale $w green + } + default { + tkColorDialog_DrawColorScale $w red + tkColorDialog_DrawColorScale $w green + tkColorDialog_DrawColorScale $w blue + } + } + tkColorDialog_RedrawFinalColor $w +} + +#---------------------------------------------------------------------- +# Event handlers +#---------------------------------------------------------------------- + +# tkColorDialog_StartMove -- +# +# Handles a mousedown button event over the selector polygon. +# Adds the bindings for moving the mouse while the button is +# pressed. Sets the binding for the button-release event. +# +# Params: sel is the selector canvas window, color is the color of the strip. +# +proc tkColorDialog_StartMove {w sel color x delta {dontMove 0}} { + upvar #0 $w data + + if !$dontMove { + tkColorDialog_MoveSelector $w $sel $color $x $delta + } +} + +# tkColorDialog_MoveSelector -- +# +# Moves the polygon selector so that its middle point has the same +# x value as the specified x. If x is outside the bounds [0,255], +# the selector is set to the closest endpoint. +# +# Params: sel is the selector canvas, c is [red|green|blue] +# x is a x-coordinate. +# +proc tkColorDialog_MoveSelector {w sel color x delta} { + upvar #0 $w data + + incr x -$delta + + if { $x < 0 } { + set x 0 + } elseif { $x >= $data(BARS_WIDTH)} { + set x [expr $data(BARS_WIDTH) - 1] + } + set diff [expr $x - $data($color,x)] + $sel move $data($color,index) $diff 0 + set data($color,x) [expr $data($color,x) + $diff] + + # Return the x value that it was actually set at + return $x +} + +# tkColorDialog_ReleaseMouse +# +# Removes mouse tracking bindings, updates the colorbars. +# +# Params: sel is the selector canvas, color is the color of the strip, +# x is the x-coord of the mouse. +# +proc tkColorDialog_ReleaseMouse {w sel color x delta} { + upvar #0 $w data + + set x [tkColorDialog_MoveSelector $w $sel $color $x $delta] + + # Determine exactly what color we are looking at. + set data($color,intensity) [tkColorDialog_XToRgb $w $x] + + tkColorDialog_RedrawColorBars $w $color +} + +# tkColorDialog_ResizeColorbars -- +# +# Completely redraws the colorbars, including resizing the +# colorstrips +# +proc tkColorDialog_ResizeColorBars {w} { + upvar #0 $w data + + if { ($data(BARS_WIDTH) < $data(NUM_COLORBARS)) || + (($data(BARS_WIDTH) % $data(NUM_COLORBARS)) != 0)} { + set data(BARS_WIDTH) $data(NUM_COLORBARS) + } + tkColorDialog_InitValues $w + foreach color { red green blue } { + $data($color,col) conf -width $data(canvasWidth) + tkColorDialog_DrawColorScale $w $color 1 + } +} + +# tkColorDialog_HandleSelEntry -- +# +# Handles the return keypress event in the "Selection:" entry +# +proc tkColorDialog_HandleSelEntry {w} { + upvar #0 $w data + + set text [string trim $data(selection)] + # Check to make sure that the color is valid + if [catch {set color [winfo rgb . $text]} ] { + set data(selection) $data(finalColor) + return + } + + set R [expr [lindex $color 0]/0x100] + set G [expr [lindex $color 1]/0x100] + set B [expr [lindex $color 2]/0x100] + + tkColorDialog_SetRGBValue $w "$R $G $B" + set data(selection) $text +} + +# tkColorDialog_HandleRGBEntry -- +# +# Handles the return keypress event in the R, G or B entry +# +proc tkColorDialog_HandleRGBEntry {w} { + upvar #0 $w data + + foreach c {red green blue} { + if [catch { + set data($c,intensity) [expr int($data($c,intensity))] + }] { + set data($c,intensity) 0 + } + + if {$data($c,intensity) < 0} { + set data($c,intensity) 0 + } + if {$data($c,intensity) > 255} { + set data($c,intensity) 255 + } + } + + tkColorDialog_SetRGBValue $w "$data(red,intensity) $data(green,intensity) \ + $data(blue,intensity)" +} + +# mouse cursor enters a color bar +# +proc tkColorDialog_EnterColorBar {w color} { + upvar #0 $w data + + $data($color,sel) itemconfig $data($color,index) -fill red +} + +# mouse leaves enters a color bar +# +proc tkColorDialog_LeaveColorBar {w color} { + upvar #0 $w data + + $data($color,sel) itemconfig $data($color,index) -fill black +} + +# user hits OK button +# +proc tkColorDialog_OkCmd {w} { + global tkPriv + upvar #0 $w data + + set tkPriv(selectColor) $data(finalColor) +} + +# user hits Cancel button +# +proc tkColorDialog_CancelCmd {w} { + global tkPriv + + set tkPriv(selectColor) "" +} + |