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

resizealpha-img


See also