[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.

[http://perso.wanadoo.fr/maurice.ulis/tcl/shrink3.png]
[http://perso.wanadoo.fr/maurice.ulis/tcl/shrink2.png]
[http://perso.wanadoo.fr/maurice.ulis/tcl/shrink1.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
      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
[http://82.168.209.239/Wiki/shrink3b.jpg] [http://perso.wanadoo.fr/maurice.ulis/tcl/shrink3.png]


[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.
----
[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'' [http://eric.boudaillier.free.fr/tkPhotoScale.c]. ([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''

----
'''See also'''
   
   * [TclMagick] - which implements similar algorithms, but being written in C is much faster, albeit less available for fun experimentation!
   * [Blurring an image]
   * [Crisping an image]
   * [Embossing an image]
   * [Expanding an image]
   * [Fast image resizing] - [David Easton] ''2004-04-29''
   * [Image Processing with HSV]
   * [Image scaling]
   * [Photo image rotation]

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