(averaging the r-g-b values of four neighboring original pixels, weighted by nearness), which takes around 15..17 sec on my P200/W95 box. Therefore, coding these algorithms in C is still highly recommended - but I just wanted to know how it can be done in pure-Tcl ;-) On my 833MHz box at work, the "slow" rotation took about 2 seconds, which comes closer to usability - and modern CPUs are more than double that fast...proc image_rotate {img angle} {
if $angle {
set w [image width $img]
set h [image height $img]
set tmp [image create photo]
$tmp copy $img
$img blank
set buf {}
switch -- $angle {
90 {
for {set i [expr {$w-1}]} {$i>=0} {incr i -1} {
set rowbuf {}
for {set j 0} {$j < $h} {incr j} {
foreach {r g b} [$tmp get $i $j] break
lappend rowbuf [format #%02x%02x%02x $r $g $b]
}
lappend buf $rowbuf
}
$img config -width $h -height $w
$img put $buf
}
180 - -180 {$img copy $tmp -subsample -1 -1}
270 - -90 {
for {set i 0} {$i<$w} {incr i} {
set rowbuf {}
for {set j [expr {$h-1}]} {$j>=0} {incr j -1} {
foreach {r g b} [$tmp get $i $j] break
lappend rowbuf [format #%02x%02x%02x $r $g $b]
}
lappend buf $rowbuf
}
$img config -width $h -height $w
$img put $buf
}
default {
set a [expr {atan(1)*8*$angle/360.}]
set xm [expr {$w/2.}]
set ym [expr {$h/2.}]
set w2 [expr {round(abs($w*cos($a)) + abs($h*sin($a)))}]
set xm2 [expr {$w2/2.}]
set h2 [expr {round(abs($h*cos($a)) + abs($w*sin($a)))}]
set ym2 [expr {$h2/2.}]
$img config -width $w2 -height $h2
for {set i 0} {$i<$h2} {incr i} {
set toX -1
for {set j 0} {$j<$w2} {incr j} {
set rad [expr {hypot($ym2-$i,$xm2-$j)}]
set th [expr {atan2($ym2-$i,$xm2-$j)+$a}]
set x [expr {$xm-$rad*cos($th)}]
if {$x < 0 || $x >= $w} continue
set y [expr {$ym-$rad*sin($th)}]
if {$y < 0 || $y >= $h} continue
set x0 [expr {int($x)}]
set x1 [expr {($x0+1)<$w? $x0+1: $x0}]
set dx [expr {$x1-$x}]
set y0 [expr {int($y)}]
set y1 [expr {($y0+1)<$h? $y0+1: $y0}]
set dy [expr {$y1-$y}]
set R 0; set G 0; set B 0
foreach {r g b} [$tmp get $x0 $y0] {
set R [expr {$R+$r*$dx*$dy}]
set G [expr {$G+$g*$dx*$dy}]
set B [expr {$B+$b*$dx*$dy}]
}
foreach {r g b} [$tmp get $x0 $y1] {
set R [expr {$R+$r*$dx*(1.-$dy)}]
set G [expr {$G+$g*$dx*(1.-$dy)}]
set B [expr {$B+$b*$dx*(1.-$dy)}]
}
foreach {r g b} [$tmp get $x1 $y0] {
set R [expr {$R+$r*(1.-$dx)*$dy}]
set G [expr {$G+$g*(1.-$dx)*$dy}]
set B [expr {$B+$b*(1.-$dx)*$dy}]
}
foreach {r g b} [$tmp get $x1 $y1] {
set R [expr {$R+$r*(1.-$dx)*(1.-$dy)}]
set G [expr {$G+$g*(1.-$dx)*(1.-$dy)}]
set B [expr {$B+$b*(1.-$dx)*(1.-$dy)}]
}
set r [expr {round($R)}]
set g [expr {round($G)}]
set b [expr {round($B)}]
lappend buf [format #%02x%02x%02x $r $g $b]
if {$toX == -1} {set toX $j}
}
if {$toX>=0} {
$img put [list $buf] -to $toX $i
set buf {}
if $::update update
}
}
}
}
image delete $tmp
}
}
#---------------------------------- testing demo:
if {[file tail [info script]] == [file tail $argv0]} {
pack [canvas .c -height 160 -width 250]
#---assume standard installation paths:
set sample [file join [lindex $auto_path 2] images logo100.gif]
set im [image create photo -file $sample]
set im2 [image create photo]
$im2 copy $im
.c create image 50 90 -image $im
.c create image 170 90 -image $im2
entry .c.e -textvar angle -width 4
set angle 99
bind .c.e <Return> {
$im2 config -width [image width $im] -height [image height $im]
$im2 copy $im
wm title . [time {image_rotate $im2 $::angle}]
}
.c create window 5 5 -window .c.e -anchor nw
checkbutton .c.cb -text Update -variable update
set ::update 1
.c create window 40 5 -window .c.cb -anchor nw
bind . <Escape> {exec wish $argv0 &; exit}
}There seems to be a bug with the code above. I get this error message when I run it with 5 degrees of rotation:
domain error: argument not in valid range
domain error: argument not in valid range
while executing
"expr {atan2($ym2-$i,$xm2-$j)+$a}"
("default" arm line 14)
invoked from within
"switch -- $angle {
90 {
for {set i [expr {$w-1}]} {$i>=0} {incr i -1} {
set rowbuf {}
..."
(procedure "image_rotate" line 9)
invoked from within
"image_rotate $im2 $::angle"
invoked from within
"time {image_rotate $im2 $::angle}"
invoked from within
"wm title . [time {image_rotate $im2 $::angle}]"
(command bound to event)RS: The above Tcl code runs well on Win95 and Win2k, also at 5 degrees (or -5, 1, -1, ...). So I suspect it is the implementation-dependent limits of atan2 of some C runtimes, which also on Solaris raises an (unjustified, IMO) error if both arguments are 0. Here is a workaround, to replace the atan2 line, but better if this problem were handled inside the expr implementation: if {$ym2==$i && $xm2==$j} {
set th $a
} else {
set th [expr {atan2($ym2-$i,$xm2-$j)+$a}]
}Thanks for reporting!DKF: Just pointing out that (0,0) is outside the domain of the atan2 function for good reason; its result could reasonably be any angle at all. RS's fix should be used on all platforms...Breadcrust I am working on a rotation command myself, it is in a pure Tcl library called AdjustImg - http://www.sourceforge.net/projects/adjustimg
.Note - my rotation command only supports rotations that are a multiple of 90 (eg 90, 180, 270) and not anything smaller. this feature may be added soon, and if it does, ill update this page.See also Quick photo rotation For fast arbitrary rotation (and scaling) see: Enhanced photo image copy command
DKF 2005-02-16: Here's a version that's algorithmically equivalent but which is optimized for Tcl/Tk 8.4
proc image_rotate {img angle} {
set angle [expr {fmod($angle, 360.0)}]
if {$angle < 0} {set angle [expr {$angle + 360.0}]}
if {$angle} {
set w [image width $img]
set h [image height $img]
set tmp [image create photo]
$tmp copy $img
$img blank
set buf {}
if {$angle == 90} {
# This would be easier with lrepeat
set row {}
for {set i 0} {$i<$h} {incr i} {
lappend row "#000000"
}
for {set i 0} {$i<$w} {incr i} {
lappend buf $row
}
set i 0
foreach row [$tmp data] {
set j 0
foreach pixel $row {
lset buf $j $i $pixel
incr j
}
incr i
}
$img config -width $h -height $w
$img put $buf
} elseif {$angle == 180} {
$img copy $tmp -subsample -1 -1
} elseif {$angle == 270} {
# This would be easier with lrepeat
set row {}
for {set i 0} {$i<$h} {incr i} {
lappend row "#000000"
}
for {set i 0} {$i<$w} {incr i} {
lappend buf $row
}
set i $h
foreach row [$tmp data] {
set j 0
incr i -1
foreach pixel $row {
lset buf $j $i $pixel
incr j
}
}
$img config -width $h -height $w
$img put $buf
} else {
set a [expr {atan(1)*8*$angle/360.}]
set xm [expr {$w/2.}]
set ym [expr {$h/2.}]
set w2 [expr {round(abs($w*cos($a)) + abs($h*sin($a)))}]
set xm2 [expr {$w2/2.}]
set h2 [expr {round(abs($h*cos($a)) + abs($w*sin($a)))}]
set ym2 [expr {$h2/2.}]
$img config -width $w2 -height $h2
for {set i 0} {$i<$h2} {incr i} {
set toX -1
for {set j 0} {$j<$w2} {incr j} {
set rad [expr {hypot($ym2-$i,$xm2-$j)}]
set th [expr {atan2($ym2-$i,$xm2-$j) + $a}]
if {
[set x [expr {$xm-$rad*cos($th)}]] < 0 || $x >= $w ||
[set y [expr {$ym-$rad*sin($th)}]] < 0 || $y >= $h
} then {
continue
}
set x0 [expr {int($x)}]
set x1 [expr {($x0+1)<$w? $x0+1: $x0}]
set dx_ [expr {1.-[set dx [expr {$x1-$x}]]}]
set y0 [expr {int($y)}]
set y1 [expr {($y0+1)<$h? $y0+1: $y0}]
set dy_ [expr {1.-[set dy [expr {$y1-$y}]]}]
# This is the fastest way to get the data, because
# in 8.4 [$photo get] returns a string and not a
# list. This is horrible, but fast...
scan "[$tmp get $x0 $y0] [$tmp get $x0 $y1]\
[$tmp get $x1 $y0] [$tmp get $x1 $y1]" \
"%d %d %d %d %d %d %d %d %d %d %d %d" \
r0 g0 b0 r1 g1 b1 r2 g2 b2 r3 g3 b3
set r [expr {
round($dx*($r0*$dy+$r1*$dy_)+$dx_*($r2*$dy+$r3*$dy_))
}]
set g [expr {
round($dx*($g0*$dy+$g1*$dy_)+$dx_*($g2*$dy+$g3*$dy_))
}]
set b [expr {
round($dx*($b0*$dy+$b1*$dy_)+$dx_*($b2*$dy+$b3*$dy_))
}]
lappend buf [format "#%02x%02x%02x" $r $g $b]
if {$toX == -1} {
set toX $j
}
}
if {$toX>=0} {
$img put [list $buf] -to $toX $i
set buf {}
if {$::update} { update }
}
}
}
image delete $tmp
}
}TTD To handle exception for atan2(0,0) changed following lines: set th [expr {atan2($ym2-$i,$xm2-$j) + $a}]to set atany [expr $xm2-$j]
if {$atanx==0 && $atany==0} {
set th 0.0
} else {
set th [expr {atan2($ym2-$i,$xm2-$j) + $a}]
}See also Arts and crafts of Tcl-Tk programming.