summaryrefslogtreecommitdiffstats
path: root/library/clrpick.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'library/clrpick.tcl')
-rw-r--r--library/clrpick.tcl691
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) ""
+}
+