ulis, 2003-12-4. A proc to shrink an image.
Updated 2003-12-6, improved proc (2 times faster).
David Easton, 2003-12-8, improved colour plane creation speed
ulis, 2004-02-05. Roy Terry asked for transparency so I've added a new proc, shrink2, that manages the alpha channel.
(Original photo: to fill)
How it works
It works by linear interpolation:
p x- 0 -x- 1 -x- 2 -x <- pixels of shrinked image | \ \ \ | \ \ \ | \ \ \ <- pixels correspondence | \ \ \ | \ \ \ P x- 0 -x- 1 -x- 2 -x- 3 -x- 4 -x <- pixels of original image | | | | | 3 2 |1 3 1| 2 3 | | - - |- - -| - - | <- weights | 5 5 |5 5 5| 5 5 | p0 = P0 * 3/5 + P1 * 2/5 p1 = P1 * 1/5 + P2 * 3/5 + P3 * 1/5 p2 = P3 * 2/5 + P4 * 3/5
Each pixel of the shrinked image is the sum of the (linearly) corresponding pixels of the original image, weighted as above.
The proc
namespace eval ::shrink \ { namespace export shrink shrink2 package require Tk package require Img # shrinking without transparency proc shrink {Image coef} \ { # check coef if {$coef > 1.0} \ { error "bad coef \"$coef\": should not be greater than 1.0" } if {abs($coef - 1.0) < 1.e-4} { return $Image } # get the old image content set Width [image width $Image] set Height [image height $Image] if {$Width * $Height == 0} { error "bad image" } # create corresponding planes for {set Y 0} {$Y < $Height} {incr Y} \ { set r:Row {} set g:Row {} set b:Row {} for {set X 0} {$X < $Width} {incr X} \ { foreach {r g b} [$Image get $X $Y] break foreach c {r g b} { lappend $c:Row [set $c] } } foreach c {r g b} { lappend $c:Data [set $c:Row] } } # compute the new image content set width [expr {round($Width * $coef)}] set height [expr {round($Height * $coef)}] set ey 0 set Y2 0 set cy2 $height for {set y 0} {$y < $height} {incr y} \ { set r:row {} set g:row {} set b:row {} # Y1 is the top coordinate in the old image set Y1 $Y2 set cy1 [expr {$height - $cy2}] incr ey $Height set Y2 [expr {$ey / $height}] set cy2 [expr {$ey % $height}] if {$Y1 == $Y2} { set cy1 $cy2 } set ex 0 set X2 0 set cx2 $width for {set x 0} {$x < $width} {incr x} \ { set X1 $X2 set cx1 [expr {$width - $cx2}] incr ex $Width set X2 [expr {$ex / $width}] set cx2 [expr {$ex % $width}] if {$X1 == $X2} { set cx1 $cx2 } # compute pixel foreach c {r g b} { set $c 0; set _$c 0 } for {set Y $Y1} {$Y <= $Y2} {incr Y} \ { # compute y coef switch $Y \ $Y1 { set cy $cy1 } \ $Y2 { set cy $cy2 } \ default { set cy $height } if {$cy == 0} { continue } if {$cy > $Height} { set cy $Height } for {set X $X1} {$X <= $X2} {incr X} \ { # compute x coef switch $X \ $X1 { set cx $cx1 } \ $X2 { set cx $cx2 } \ default { set cx $width } if {$cx == 0} { continue } if {$cx > $Width} { set cx $Width } # weight each initial pixel by cx & cy set cxy [expr {$cx * $cy / double($Width) / $Height}] foreach c {r g b} \ { set comp [lindex [set $c:Data] $Y $X] incr $c [expr {round($comp * $cxy)}] set _$c [expr {[set _$c] + $cxy}] } } } set _ {} foreach c {r g b} \ { set comp [set $c] if {$comp > 255} { set comp 255 } lappend $c:row $comp lappend _ [set _$c] } } foreach c {r g b} { lappend $c:data [set $c:row] } } # merge the planes for {set y 0} {$y < $height} {incr y} \ { set row {} for {set x 0} {$x < $width} {incr x} \ { foreach c {r g b} { set $c [lindex [set $c:data] $y $x] } lappend row [format #%02x%02x%02x $r $g $b] } lappend data $row } # create the new image set image [image create photo] # fill the new image $image put $data # return the new image return $image } # shrinking with transparency proc shrink2 {Image coef} \ { # check coef if {$coef > 1.0} \ { error "bad coef \"$coef\": should not be greater than 1.0" } if {abs($coef - 1.0) < 1.e-4} { return $Image } # get the old image content set Width [image width $Image] set Height [image height $Image] if {$Width * $Height == 0} { error "bad image" } # create corresponding planes for {set Y 0} {$Y < $Height} {incr Y} \ { set r:Row {} set g:Row {} set b:Row {} set t:Row {} for {set X 0} {$X < $Width} {incr X} \ { foreach {r g b} [$Image get $X $Y] break set t [$Image transparency get $X $Y] set t [expr {$t * 256}] foreach c {r g b t} { lappend $c:Row [set $c] } } foreach c {r g b t} { lappend $c:Data [set $c:Row] } } # compute the new image content set width [expr {round($Width * $coef)}] set height [expr {round($Height * $coef)}] set ey 0 set Y2 0 set cy2 $height for {set y 0} {$y < $height} {incr y} \ { set r:row {} set g:row {} set b:row {} set t:row {} # Y1 is the top coordinate in the old image set Y1 $Y2 set cy1 [expr {$height - $cy2}] incr ey $Height set Y2 [expr {$ey / $height}] set cy2 [expr {$ey % $height}] if {$Y1 == $Y2} { set cy1 $cy2 } set ex 0 set X2 0 set cx2 $width for {set x 0} {$x < $width} {incr x} \ { set X1 $X2 set cx1 [expr {$width - $cx2}] incr ex $Width set X2 [expr {$ex / $width}] set cx2 [expr {$ex % $width}] if {$X1 == $X2} { set cx1 $cx2 } # compute pixel foreach c {r g b t} { set $c 0; set _$c 0 } for {set Y $Y1} {$Y <= $Y2} {incr Y} \ { # compute y coef switch $Y \ $Y1 { set cy $cy1 } \ $Y2 { set cy $cy2 } \ default { set cy $height } if {$cy == 0} { continue } if {$cy > $Height} { set cy $Height } for {set X $X1} {$X <= $X2} {incr X} \ { # compute x coef switch $X \ $X1 { set cx $cx1 } \ $X2 { set cx $cx2 } \ default { set cx $width } if {$cx == 0} { continue } if {$cx > $Width} { set cx $Width } # weight each initial pixel by cx & cy set cxy [expr {$cx * $cy / double($Width) / $Height}] foreach c {r g b t} \ { set comp [lindex [set $c:Data] $Y $X] incr $c [expr {round($comp * $cxy)}] set _$c [expr {[set _$c] + $cxy}] } } } set _ {} foreach c {r g b t} \ { set comp [set $c] if {$comp > 255} { set comp 255 } lappend $c:row $comp lappend _ [set _$c] } } foreach c {r g b t} { lappend $c:data [set $c:row] } } # merge the planes for {set y 0} {$y < $height} {incr y} \ { set row {} set trow {} for {set x 0} {$x < $width} {incr x} \ { foreach c {r g b t} { set $c [lindex [set $c:data] $y $x] } lappend row [format #%02x%02x%02x $r $g $b] lappend trow [expr {round($t)}] } lappend data $row lappend tdata $trow } # create the new image set image [image create photo] # fill the new image $image put $data # set transparency for {set y 0} {$y < $height} {incr y} \ { for {set x 0} {$x < $width} {incr x} \ { set t [lindex $tdata $y $x] set t [expr {$t > 128 ? 1 : 0}] $image transparency set $x $y $t } } # return the new image return $image } }
The demo
# to download the image: # http://perso.wanadoo.fr/maurice.ulis/tcl/image2.png image create photo Photo -file image2.png package require Img image create photo Photo -file image2.png namespace import ::shrink::shrink wm withdraw . set n 0 foreach coef {1.0 0.8 0.6} \ { set image [shrink Photo $coef] toplevel .$n wm title .$n "shrink $coef" canvas .$n.c -bd 0 -highlightt 0 .$n.c create image 0 0 -anchor nw -image $image foreach {- - width height} [.$n.c bbox all] break .$n.c config -width $width -height $height pack .$n.c bind .$n.c <Destroy> exit update incr n }
RT 4Feb04, Very handy and works nicely. One thing I noticed is that (for png) the alpha channel (tranparency) appears to get lost. I wonder how hard it would be to preserve transparency too? That would be very sweet. Thanks!
DKF: Tk's photo image doesn't handle transparency well-enough. This sucks, but I've not had time to write the update to fix this (beyond mere for-my-eyes-only-prototype that is)
ulis: It would be nice to have Tk manages transparency as a fourth channel.
DKF: It does already, but only internally. My point was that it is not exposed to scripts.
RT Could anyone knowledgable comment on the practicality of translating this proc (or hotspots of same) to C with CriTcl or just direct C? And for that matter, same question for some of the family of these procs as listed below. I suppose the basic question is how similar would the code structure be if it were written at the C API level of Tcl/Tk?
MPJ: I just tried this code to resize some card images from scat to 60% the orginal size. This seemed to work find for images as they all displayed on the canvas but when I tried to write the kings, queens and jacks to a file I get the error "too many colors" with Tcl 8.4.6. See example below:
set image [shrink ::img::jc 0.6] $image write jc.gif
See also