archie/tk4.2/library/clrpick.tcl

# 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) ""
}