Updated 2010-06-23 17:58:08 by AKgnome

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 shrunken image is the sum of the (linearly) corresponding pixels of the original image, weighted as above.

Thus the colors count of the image can increase and a gif image can give a shrunken image with more than 256 colors (See MPJ add below).

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.

DKF: Note that this code can be made to go faster by removing all use of switch and instead using if with suitable expressions. Using switch forces string comparisons and you're in an inner loop where this sort of thing can matter...

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?

DKF: If you accessed the photo data using Tcl's C interface, you'd be able to handle the alpha channel and you'd also go much faster. It's an ideal candidate for being done in C. In fact, I'm a little startled that anyone bothered trying to do it in Tcl. :^) This will help a lot though when I come to put scaling (and rotation) into photo images. It's on my to-do list, and I'll be most cross if I can't get it into 8.5 because of time constraints...

RT: Having C level scaling would be great in general, and for my current enterprise, as the alternative is to wrap and maintain the whole ImageMagick package just to get fast scaling in my application. Go Donal! :)

ulis: Tcl is just perfect to try algorithms and it's funny to try to reach its limits. Moreover I don't want to put my fingers in C ;^)

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

Any ideas on what the problem is?

MG - GIFs can only handle 256 colors, so those images must use more. Try saving as a jpeg instead with
   $image write jc.jpeg -format jpeg

(Some drawing programs I've seen give an offer to decrease the number of colors to 256 to allow saving as gifs anyway; would it be possible/does anyone know how to do this in Tcl?)

DKF: Replace colours with other colours until you only have 256 different colours. Then you can write as a GIF. :^) OK, that's not helpful. I don't know how to pick what colours to replace though; AIUI, there are several techniques. Dithering the whole image onto a 3/3/2 colourspace (you'll have to do this yourself; Tk's got dithering code, but its for display-on-low-depth-screens use only) will work, even though it's probably non-optimal for every image.

DKF: Perhaps Reduce Colour Depth - Median Cut is helpful?

TV I took the liberty of adding a Gimp reduced image for comparison (60 %) in uncompressed (or at least 100%) jpg.
 Gimp       Tcl

ulis: I find the Gimp work a little more blurry. Is it? TV Well, the reason I made the comparison is that indeed I too had the impression there were differences, and I thought that face (if they have one) of the monkey in the gimp version is more like the big version, in terms of blackness and structure.

jmp 2004/04/15 Under-sampling images and more generally under-sampling data requires lowpass pre-filtering indeed. This is needed to avoid the well-known aliasing effect of resampling operations: some artificial high frequencies may be created if you don't take care. Determining the best filter is a hard work and may depend on the image to be under-sampled. I suppose the GIMP does lowpass-filtering before resampling. Ulis also did a kind of lowpass filtering using coefficients. These coefficients should theorically be adapted to the under-sampling ratio. They seem good for the monkey and a 60% ratio, but they could be less good for other images or other ratios.

DKF: Studying the code in more depth, I see you use [foreach c {r g b} ...] a lot. This is a very slow idiom, especially when inside any inner loops. [switch] is also slow. Expanding everything out (and using numeric comparisons) I get a lot more speed.

ulis: Why not put the optimized code in this page?

DKF: It's significantly longer and I'm looking to recode it in C (and get it into the core) where I can get a lot more speed again.

I suspect that there's an off-by-one error as well; try putting some space between the image and the window edge and look at the top and left edges (IIRC). I suspect it might also be more visible with images that have a light background. I've not had time to investigate in detail though, so I might be wrong.

EB: Donal, if it can help, I have a C version ported from PBM Plus pnmscale [1]. (TV just a side remark: isn't the pbm/pnm package, which I found interesting at the timeI used it, too, all written in C?) - Yes, I mean ported to Tk photo image format, in contrast to pbm stdin/stdout interface

DKF: Does that deal with RGBA data?

EB: Yes, exactly like the other channels. Is that the good way ?

DKF: Yes. I asked because the pnm formats don't support alpha (that I know about :^))

DKF: EB, your code looks very good.

EB: Then, feel free to take it for an [image scale] command in the core.

DKF: That is definitely my plan. I just ran out of time to say so yesterday. ;^)

TFW: Dec 27, 2005. I took Eric Boudaillier's code and wrapped into a DLL call TkImageTools (for lack of a better name) It adds a tkImageTools::resize command. You can get the source and binaries for windows and linux here [2]. I put it to good use in SnackAmp resizing cover art to standard dimensions. By the way, the visual appearance of the reduced/expanded image is very good.

DKF: Here's a version (no alpha channel handling) which goes a bit faster. It also supports an optional third argument for those times when you want to supply a target image. No promises that this will work for anything before 8.4, of course.
    proc shrink3 {Image coef {TargetImage {}}} {
        # check coef
        if {$coef > 1.0} {
            error "bad coef \"$coef\": should not be greater than 1.0"
        }
        # get the old image content
        set Width [image width $Image]
        set Height [image height $Image]
        if {$Width==0 || $Height==0} {
            error "bad image"
        }
        if {$TargetImage eq ""} {
            # create new image
            set image [image create photo]
        } else {
            set image $TargetImage
        }
        if {abs($coef - 1.0) < 1.e-4} {
            $image copy $Image
            return $image
        }
        set Factor [expr {double($Width)*$Height}]
        # Extract the data from the source - experiment indicates that this is the fastest way
        foreach row [$Image data] {
            set rdata {}
            foreach pixel $row {
                lappend rdata [scan $pixel "#%2x%2x%2x"]
            }
            lappend DATA $rdata
        }
        # 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} {
            # 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
            set row {}
            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
                set r 0.0
                set g 0.0
                set b 0.0
                for {set Y $Y1} {$Y <= $Y2} {incr Y} {
                    # compute y coef
                    if {$Y == $Y1} {
                        if {$cy1 == 0} continue
                        set cy [expr {$cy1>$Height ? $Height : $cy1}]
                    } elseif {$Y == $Y2} {
                        if {$cy2 == 0} continue
                        set cy [expr {$cy2>$Height ? $Height : $cy2}]
                    } else {
                        set cy $height
                    }
                    for {set X $X1} {$X <= $X2} {incr X} {
                        # compute x coef
                        if {$X == $X1} {
                            if {$cx1 == 0} continue
                            set cx [expr {$cx1>$Width ? $Width : $cx1}]
                        } elseif {$X == $X2} {
                            if {$cx2 == 0} continue
                            set cx [expr {$cx2>$Width ? $Width : $cx2}]
                        } else {
                            set cx $width
                        }
                        # weight each initial pixel by cx & cy
                        set cxy [expr {$cx * $cy / $Factor}]
                        set pixel [lindex $DATA $Y $X]
                        set r [expr {$r+([lindex $pixel 0] * $cxy)}]
                        set g [expr {$g+([lindex $pixel 1] * $cxy)}]
                        set b [expr {$b+([lindex $pixel 2] * $cxy)}]
                    }
                }
                lappend row [format "#%02x%02x%02x" \
                                     [expr {$r>255.0 ? 255 : round($r)}] \
                                     [expr {$g>255.0 ? 255 : round($g)}] \
                                     [expr {$b>255.0 ? 255 : round($b)}]]
            }
            lappend data $row
        }
        # fill the new image
        $image blank
        $image put $data
        # return the new image
        return $image
    }

See also