[David Easton] ''2004-03-29'' Here is a procedure to resize a photo image to the requested dimensions. Use: resize where: is a source image is the requested horizontal size in pixels is the requested vertical size in pixels is an optional destination image (if not provided, a new image is created) It is based on the same principles as [Expanding an image] and [Shrinking an image], but is up to 10x faster. Linear interpolation is used for all horizontal resizing and for vertical expansion. However, I've cheated with shrinking an image vertically by using a combination of linear interpolation and row removal. This should really be corrected, but it meets my needs. This is nice to have and certainly way faster than previous pages mentioned. I shrunk a 720x430 image by a factor of 2 in about 11 seconds on a 600Mhz machine. On observation: when it checks for a integral reduction request if finds changes to use "zoom" but not chances to use "subsample". And, BTW, I don't understand calling [Expr] explicitly in this case when [if] is going to do it anyway. Thanks - [Roy Terry] 29-March-2004 [David Easton] ''2004-03-29'' Roy, you are correct about [Expr] not being necessary in an [if] statement and so I've updated the code below to remove it (I forgot that [if] did that). I haven't used subsample because it purely removes pixels and therefore gives an inferior image compared to using linear interpolation as below. ---- ====== ################################################### # # Name: resize # # Decsription: Copies a source image to a destination # image and resizes it using linear interpolation # # Parameters: newx - Width of new image # newy - Height of new image # src - Source image # dest - Destination image (optional) # # Returns: destination image # ################################################### proc resize {src newx newy {dest ""} } { set mx [image width $src] set my [image height $src] if { "$dest" == ""} { set dest [image create photo] } $dest configure -width $newx -height $newy # Check if we can just zoom using -zoom option on copy if { $newx % $mx == 0 && $newy % $my == 0} { set ix [expr {$newx / $mx}] set iy [expr {$newy / $my}] $dest copy $src -zoom $ix $iy return $dest } set ny 0 set ytot $my for {set y 0} {$y < $my} {incr y} { # # Do horizontal resize # foreach {pr pg pb} [$src get 0 $y] {break} set row [list] set thisrow [list] set nx 0 set xtot $mx for {set x 1} {$x < $mx} {incr x} { # Add whole pixels as necessary while { $xtot <= $newx } { lappend row [format "#%02x%02x%02x" $pr $pg $pb] lappend thisrow $pr $pg $pb incr xtot $mx incr nx } # Now add mixed pixels foreach {r g b} [$src get $x $y] {break} # Calculate ratios to use set xtot [expr {$xtot - $newx}] set rn $xtot set rp [expr {$mx - $xtot}] # This section covers shrinking an image where # more than 1 source pixel may be required to # define the destination pixel set xr 0 set xg 0 set xb 0 while { $xtot > $newx } { incr xr $r incr xg $g incr xb $b set xtot [expr {$xtot - $newx}] incr x foreach {r g b} [$src get $x $y] {break} } # Work out the new pixel colours set tr [expr {int( ($rn*$r + $xr + $rp*$pr) / $mx)}] set tg [expr {int( ($rn*$g + $xg + $rp*$pg) / $mx)}] set tb [expr {int( ($rn*$b + $xb + $rp*$pb) / $mx)}] if {$tr > 255} {set tr 255} if {$tg > 255} {set tg 255} if {$tb > 255} {set tb 255} # Output the pixel lappend row [format "#%02x%02x%02x" $tr $tg $tb] lappend thisrow $tr $tg $tb incr xtot $mx incr nx set pr $r set pg $g set pb $b } # Finish off pixels on this row while { $nx < $newx } { lappend row [format "#%02x%02x%02x" $r $g $b] lappend thisrow $r $g $b incr nx } # # Do vertical resize # if {[info exists prevrow]} { set nrow [list] # Add whole lines as necessary while { $ytot <= $newy } { $dest put -to 0 $ny [list $prow] incr ytot $my incr ny } # Now add mixed line # Calculate ratios to use set ytot [expr {$ytot - $newy}] set rn $ytot set rp [expr {$my - $rn}] # This section covers shrinking an image # where a single pixel is made from more than # 2 others. Actually we cheat and just remove # a line of pixels which is not as good as it should be while { $ytot > $newy } { set ytot [expr {$ytot - $newy}] incr y continue } # Calculate new row foreach {pr pg pb} $prevrow {r g b} $thisrow { set tr [expr {int( ($rn*$r + $rp*$pr) / $my)}] set tg [expr {int( ($rn*$g + $rp*$pg) / $my)}] set tb [expr {int( ($rn*$b + $rp*$pb) / $my)}] lappend nrow [format "#%02x%02x%02x" $tr $tg $tb] } $dest put -to 0 $ny [list $nrow] incr ytot $my incr ny } set prevrow $thisrow set prow $row update idletasks } # Finish off last rows while { $ny < $newy } { $dest put -to 0 $ny [list $row] incr ny } update idletasks return $dest } ====== ---- '''Example''' ====== # Create and pack a canvas pack [canvas .c] -expand true -fill both # Create source and destination image set src [image create photo -file image.gif] set dest [image create photo] $dest blank set h [image height $src] incr h 5 .c create image 0 0 -anchor nw -image $src .c create image 0 $h -anchor nw -image $dest # Copy src image to destination image and resize to 400 300 resize $src 400 300 $dest ====== ---- MB: I tested that command on a real photo file http://www.imaging-resource.com/PRODS/CP5200/FULLRES/CP52OUTCONL.HTM produced by a Coolpix 5200 which size is 2592x1944 pixels on a Pentium 4 2.0 Ghz. The target size was 480x360. It took about 39 seconds to open, resize and save the photo, with 27 seconds only in the "image create photo -file" command. This is far too slow to do a batch resize for a whole set of images. The title "fast image resizing" was a bit enthousiast... The "convert" command of the ImageMagick library is a lot faster : the same conversion took 1.93 second. My conclusion is that Tcl can be used to create scripts that drive ImageMagick commands, while Tcl is not fast enough by itself to process images. ====== proc computeCurrentTime {} { set currentTime [expr { double([clock clicks -milliseconds]) / 1000.0 } ] return $currentTime } proc resizeInTcl {sourceFile destFile} { puts "Reading photo..." set src [image create photo -file $sourceFile] puts "Creating the copy..." set dest [image create photo] $dest blank puts "Reducing size..." resize $src 480 360 $dest $dest write $destFile -format jpeg return "" } proc resizeImageMagick {sourceFile destFile} { exec convert -resize 480x360 $sourceFile $destFile return "" } package require Img set sourceFile CP52MUSWBD.JPG set destFile resized.jpg # Try Tcl set time1 [computeCurrentTime] resizeInTcl $sourceFile $destFile set time2 [computeCurrentTime] set delta [expr { $time2 - $time1}] puts "This took $delta second." # Try Image Magick set time1 [computeCurrentTime] resizeImageMagick $sourceFile $destFile set time2 [computeCurrentTime] set delta [expr { $time2 - $time1}] puts "This took $delta second." ====== ---- '''See also''' * [Expanding an image] * [Shrinking an image] <> Graphics | Image Processing | Example | File