Fast image resizing
David Easton 2004-03-29
Here is a procedure to resize a photo image to the requested dimensions.
Use:
resize <src> <x> <y> <dest>
where:
<src> is a source image <x> is the requested horizontal size in pixels <y> is the requested vertical size in pixels <dest> 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 [list $prow] -to 0 $ny
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 [list $nrow] -to 0 $ny
incr ytot $my
incr ny
}
set prevrow $thisrow
set prow $row
update idletasks
}
# Finish off last rows
while { $ny < $newy } {
$dest put [list $row] -to 0 $ny
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."PO 2023-07-23
I extended the resize procedure to handle alpha values.
Note, that this procedure needs Tk 8.7.
proc resizealpha { src newx newy { dest "" } } {
set mx [image width $src]
set my [image height $src]
if { $dest eq "" } {
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 pa} [$src get 0 $y -withalpha] {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%02x" $pr $pg $pb $pa]
lappend thisrow $pr $pg $pb $pa
incr xtot $mx
incr nx
}
# Now add mixed pixels
foreach {r g b a} [$src get $x $y -withalpha] {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
set xa 0
while { $xtot > $newx } {
incr xr $r
incr xg $g
incr xb $b
incr xa $a
set xtot [expr {$xtot - $newx}]
incr x
foreach {r g b a} [$src get $x $y -withalpha] {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)}]
set ta [expr {int( ($rn*$a + $xa + $rp*$pa) / $mx)}]
if {$tr > 255} {set tr 255}
if {$tg > 255} {set tg 255}
if {$tb > 255} {set tb 255}
if {$ta > 255} {set ta 255}
# Output the pixel
lappend row [format "#%02x%02x%02x%02x" $tr $tg $tb $ta]
lappend thisrow $tr $tg $tb $ta
incr xtot $mx
incr nx
set pr $r
set pg $g
set pb $b
set pa $a
}
# Finish off pixels on this row
while { $nx < $newx } {
lappend row [format "#%02x%02x%02x%02x" $r $g $b $a]
lappend thisrow $r $g $b $a
incr nx
}
# Do vertical resize
if {[info exists prevrow]} {
set nrow [list]
# Add whole lines as necessary
while { $ytot <= $newy } {
$dest put [list $prow] -to 0 $ny
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 pa} $prevrow {r g b a} $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)}]
set ta [expr {int( ($rn*$a + $rp*$pa) / $my)}]
lappend nrow [format "#%02x%02x%02x%02x" $tr $tg $tb $ta]
}
$dest put [list $nrow] -to 0 $ny
incr ytot $my
incr ny
}
set prevrow $thisrow
set prow $row
}
# Finish off last rows
while { $ny < $newy } {
$dest put [list $row] -to 0 $ny
incr ny
}
return $dest
}Example
package require Tk
proc _folder {} {
return {R0lGODlhEAAMAJEAANnZ2QAAAPD/gP///yH5BAEAAAAALAAAAAAQAAwAAAIghINhyycvVFsB
QtmS3rjaH1Hg141WaT5ouprt2HHcUgAAOw==}
}
set folderPhoto [image create photo -data [_folder]]
label .l1 -text "Original:"
label .l2 -text "Resize:"
label .l3 -text "ResizeAlpha:"
label .i1 -background lightgreen -image $folderPhoto
label .i2 -background lightgreen -image [resize $folderPhoto 40 30]
label .i3 -background lightgreen -image [resizealpha $folderPhoto 40 30]
grid configure .l1 .i1 -row 0 -pady 5
grid configure .l2 .i2 -row 1 -pady 5
grid configure .l3 .i3 -row 2 -pady 5
See also
- LRIPhoto for fast image resizing with critcl.
- Expanding an image
- Shrinking an image