[http://mini.net/files/imgrot.jpg] ---- [Richard Suchenwirth] 2002-09-08 - After [GPS] started the topic 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] ;-) 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} }