[Richard Suchenwirth] 2002-09-08 - After [GPS] started [Rotating a Tk photo image] in the Wiki, and after some [Tcl chatroom] discussions with [dkf] and [kennykb], here now is my shot at rotating [photo] images. The simple cases are handled especially fast: 180 degrees (upside-down) by just subsampling with factors -1 (which means mirroring - in just about no time); +/- 90 degrees by inverting the pixel matrix (which goes in 2.6 seconds on my box). Other angles have to be handled pedestrianly by bi-linear interpolation (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... [WikiDbImage imgrot.jpg] As usual, this page ends in a demo, where you see the 68*100 pixels Tcl logo twice - original and rotated, can enter an angle (counter-clockwise, 0..360) and make it run with . The time needed for a rotation is displayed in the title-bar. Care was taken to leave pixels "out of the picture" transparent in the rotated image. You can also choose to let the rotated image update after every row, or wait for the final product. } 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 { $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 . {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}] } ---- [Category Image Processing] | [Arts and crafts of Tcl-Tk programming]