Version 5 of Photo image rotation

Updated 2002-10-07 09:21:58

http://mini.net/files/imgrot.jpg


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...

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 <Return>. 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 <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 the C runtime, 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!