Richard Suchenwirth 2005-12-22 - The title says it all. Drawing lines in Tk is of course easiest in a canvas, but sometimes you might need to modify photo images, e.g. used for buttons or labels. The following function allows to draw a straight line (and, by repeated application, unfilled polygons) of selectable color (default: black) and width (default: 1).
proc photo'line {im x0 y0 x1 y1 args} {
array set "" {-color black -width 1}
array set "" $args
set dx [expr {$x1-$x0}]
set dy [expr {$y1-$y0}]
set dw [expr {$(-width)/2.}]
if {abs($dx)>abs($dy)} {
set d [expr {double($dy)/$dx}]
for {set x $x0} {$x<=$x1} {incr x} {
$im put $(-color) \
-to $x [expr {round($y0-$dw)}] \
[expr {$x+1}] [expr {round($y0+$dw)}]
set y0 [expr {$y0 + $d}]
}
} else {
set d [expr {double($dx)/$dy}]
for {set y $y0} {$y<=$y1} {incr y} {
$im put $(-color) \
-to [expr {round($x0-$dw)}] $y \
[expr {round($x0+$dw)}] [expr {$y+1}]
set x0 [expr {$x0 + $d}]
}
}
}#-- Testing:
package require Tk pack [canvas .c] set im [image create photo] $im put white -to 0 0 100 100 .c create image 5 5 -image $im -anchor nw photo'line $im 10 10 90 10 -color red -width 2 photo'line $im 10 10 90 90 -color green photo'line $im 10 10 10 90 -color blue -width 3
George Peter Staplin - I wrote some code years ago with the same purpose on the hypot page as an example. My version is actually shorter than yours, which is a surprise. :)
#Copyright 2003 George Peter Staplin
#You may use this under the same terms as Tcl.
proc draw.line.on.image {img x1 y1 x2 y2 color} {
set xDiff [expr {$x2 - $x1}]
set yDiff [expr {$y2 - $y1}]
set numPixels [expr {hypot($xDiff,$yDiff)}]
set xRatio [expr {$xDiff / $numPixels}]
set yRatio [expr {$yDiff / $numPixels}]
for {set p 0} {$p < $numPixels} {incr p} {
set x [expr {round($xRatio * $p) + $x1}]
set y [expr {round($yRatio * $p) + $y1}]
$img put $color -to $x $y [expr {$x + 1}] [expr {$y + 1}]
}
}
proc main {} {
set img [image create photo -width 300 -height 300]
draw.line.on.image $img 10 10 100 100 green
draw.line.on.image $img 50 20 50 200 blue
draw.line.on.image $img 40 50 300 50 maroon
pack [label .l -image $img]
}
main