Version 3 of Shrinking an image

ulis, 2003-12-4. Here is a proc to shrink an image.

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

    package require Tk
    package require Img

    proc shrink {image coef} \
    {
      variable {}
      if {$coef > 1.0} \
      { error "bad coef \"$coef\": should be not greater than 1.0" }
      set Width [image width $image]
      set Height [image height $image]
      set Data [$image data]
      set width [expr {round($Width * $coef)}]
      set height [expr {round($Height * $coef)}]

      # horizontal shrink

      set r [expr {$width / double($Width)}]
      set R [expr {$Width / double($width)}]
      for {set Y 0} {$Y < $Height} {incr Y} \
      {
        set Row [lindex $Data $Y]
        set X2 0
        set c2 0
        for {set x 0} {$x < $width} {incr x} \
        {
          # first corresponding pixel
          set X1 $X2
          set c1 [expr {$width - $c2}]
          # last corresponding pixel
          set X2 [expr {int(($x + 1) * $R)}]
          set c2 [expr {(($x + 1) * $Width) % $width}]
          # compute color
          color:reset
          if {$c1 > 0} \
          { 
            color:add [lindex $Row $X1] [expr {$c1 / double($Width)}] 
            incr X1
          }
          for {set X $X1} {$X < $X2} {incr X} \
          { color:add [lindex $Row $X] $r }
          if {$c2 > 0} \
          { color:add [lindex $Row $X2] [expr {$c2 / double($Width)}] }
          # compute column
          lappend Col($Y) [color:get]
        }
      }

      # vertical shrink

      set image [image create photo]
      set r [expr {$height / double($Height)}]
      set R [expr {$Height / double($height)}]
      for {set x 0} {$x < $width} {incr x} \
      {
        set col {}
        set Y2 0
        set c2 0
        for {set y 0} {$y < $height} {incr y} \
        {
          # first corresponding pixel
          set Y1 $Y2
          set c1 [expr {$height - $c2}]
          # last corresponding pixel
          set Y2 [expr {int(($y + 1) * $R)}]
          set c2 [expr {(($y + 1) * $Height) % $height}]
          # compute color
          color:reset
          if {$c1 > 0} \
          { 
            color:add [lindex $Col($Y1) $x] [expr {$c1 / double($Height)}] 
            incr Y1
          }
          for {set Y $Y1} {$Y < $Y2} {incr Y} \
          { color:add [lindex $Col($Y) $x] $r }
          if {$c2 > 0} \
          { color:add [lindex $Col($Y2) $x] [expr {$c2 / double($Height)}] }
          # compute column
          lappend col [color:get]
        }
        # append column to image
        $image put $col -to $x 0
      }
      return $image
    }

    # reset all components
    proc color:reset {} \
    {
      variable {}
      set (r) 0
      set (g) 0
      set (b) 0
    }
    # add to components
    proc color:add {color coef} \
    {
      variable {}
      foreach {r g b} [winfo rgb . $color] break
      foreach c {r g b} \
      { set ($c) [expr $($c) + \$$c * $coef / 256] }
    }
    # get color from components
    proc color:get {} \
    {
      variable {}
      foreach c {r g b} { set $c [expr {int($($c))}] }
      return [format #%02x%02x%02x $r $g $b]
    }

  }

The demo

  # to download the image:
  # http://perso.wanadoo.fr/maurice.ulis/tcl/Lightbutton/Lightbuttons.gif
  image create photo Photo -file Lightbuttons.gif

  namespace import ::shrink::shrink

  canvas .c -bd 0 -highlightt 0
  set y 0
  foreach coef {1.0 0.8 0.6} \
  {
    set image [shrink Photo $coef]
    .c create image 0 $y -anchor nw -image $image
    incr y [image height $image]
  }
  foreach {- - width height} [.c bbox all] break
  .c config -width $width -height $height
  pack .c