[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 manage the alpha channel.

[http://perso.wanadoo.fr/maurice.ulis/tcl/shrink1.png]
[http://perso.wanadoo.fr/maurice.ulis/tcl/shrink2.png]
[http://perso.wanadoo.fr/maurice.ulis/tcl/shrink3.png]

(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 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 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
      puts [join $tdata \n]
      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)
----

'''See also'''
   
   * [Blurring an image]
   * [Crisping an image]
   * [Embossing an image]
   * [Expanding an image]
   * [Image Processing with HSV]
   * [Image scaling]
   * [Photo image rotation]

----
[Category Graphics]
|
[Category Image Processing]
|
[Category Example]