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 3RS 2007-03-06: Just for completeness, here's a parallel routine for drawing rectangles (with configurable fill and outline colors): proc photo'rect {im x0 y0 x1 y1 args} {
array set "" {-fill black -outline black}
array set "" $args
$im put $(-fill) -to $x0 $y0 $x1 $y1
if {$(-outline) ne $(-fill)} {
$im put $(-outline) -to $x0 $y0 [expr {$x0+1}] $y1
$im put $(-outline) -to [expr {$x1-1}] $y0 $x1 $y1
$im put $(-outline) -to $x0 [expr {$y0+1}] $x1 $y0
$im put $(-outline) -to $x0 [expr {$y1-1}] $x1 $y1
}
}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 RS: I agree that using hypot makes simpler code by just using one loop - but my version above also caters for different line widths. If you add that, it'll cost you another line or two :)George Peter Staplin: Unfortunately my version has a problem... "suchenwi GPS: I liked the hypot solution for line drawing - though it may create a bit too many steps sometimes, e.g. hypot(3,4)=5." I'll have to think of a better solution that works in all cases. I think the ratios are a good way to go (unless you hate floating point, or it's too much of a performance problem), so I'll probably keep those and work on a better way to measure digital lines I suppose.Lars H: The problem of drawing sloped lines on a raster is known to be surprisingly difficult. In Metafont, a surprising amount of ingenuity is spent on avoiding lines that accidentally come out too thin or too thick.George Peter Staplin: Hmm, and I just realized that I reinvented hypot() with sqrt... Does Knuth document such things he? used in Metafont?Lars H: Well, as the father of Literate Programming, he would have been downright hypocritical if he hadn't. MF is very thoroughly documented, but the reference you'd want is probably rather John Hobby's [1] Ph.D. thesis Digitized Brush Trajectories (available as PDF from his homepage). Hobby is a former student of Knuth's, and significant parts of the current MF are based on research of his.It should be remarked though, that this work is aimed primarily at monochromatic images. If plenty of colours are available, then antialiasing can be used to avoid many of the problems.
George Peter Staplin - Here's my solution based on the comp.graphics.algorithms FAQ answer for finding the distance for a point to a line.
#Copyright 2003, 2005 George Peter Staplin
#You may use this under the same terms as Tcl.
#Revision 3 (now with improved speed by elimination of pow($n,2))
package require Tk
proc draw.line.on.image {img x1 y1 x2 y2 color} {
set xDiff [expr {$x2 - $x1}]
set yDiff [expr {$y2 - $y1}]
set numPixels [expr {sqrt(($xDiff * $xDiff) + ($yDiff * $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
draw.line.on.image $img 30 20 33 23 purple
pack [label .l -image $img]
}
main(Note: wikit seems to have a bug, so this link doesn't display as [1] properly when enclosed with [url], and there's a leading g for some reason.) http://www.exaflop.org/docs/cgafaq/cga1.html#Subject%201.02:%20How%20do%20I%20find%20the%20distance%20from%20a%20point%20to%20a%20line
?HJG the g comes from empty square brackets, as in "[]" ==> "g".Lars H: No, the g comes from a bug/malfeature in the Wikit parser -- bracketed links are treated as a special case of free text links, which makes them extra sensitive to things like look like trailing punctuation (such as the final ? above). The g is internal markup that doesn't get properly removed by the parser. See Wikit Problems for more details.DKF: The best way to capture the fragment identifier is using %3f (i.e. URL encoded) instead of a literal '?'. This gives [2] when exposed to Wiki-parsing. :-) (BTW, the c.g.a FAQ author ought to be shot for using non-alphanumerics in an id attribute, but that's a whole 'nother story...)