Expanding an image

ulis, 2003-12-06. A proc to expand an image.

David Easton, 2003-12-8, improved colour plane creation speed

ulis, 2004-02-05. Added expand2, a proc that manages also the alpha channel. (to be improved for coef > 1.25)

http://perso.wanadoo.fr/maurice.ulis/tcl/expand1.png http://perso.wanadoo.fr/maurice.ulis/tcl/expand2.png http://perso.wanadoo.fr/maurice.ulis/tcl/expand3.png

(Original photo: to fill)


How it works

  It works by linear interpolation:

  p x- 0 -x- 1 -x- 2 -x             <- pixels of original image
    |     \     \     \
    |      \      \      \
    |       \       \       \       <- pixels correspondence
    |        \        \        \
    |         \         \         \
  P x- 0 -x- 1 -x- 2 -x- 3 -x- 4 -x <- pixels of expanded image
    |     .   | .     . |   .     |
    |  3  . 2 |1.  3  .1| 2 .  3  | 
    |  -  . - |-.  -  .-| - .  -  | <- weights
    |  3  . 3 |3.  3  .3| 3 .  3  |

  P0 = p0 * 3/3
  P1 = p0 * 2/3 + p1 * 1/3
  P2 = P1 * 3/3
  P3 = P1 * 1/3 + p2 * 2/3
  P4 = P2 * 3/3

  Each pixel of the expanded image is the sum of the (linearly) corresponding pixels
  of the original image, weighted as above.
  Integer coefficients can be optimized (the pixels are block-duplicated).
  Fractional coefficients result in a blurred image that need to be slightly crisped.

The proc

  namespace eval ::expand \
  {
    namespace export expand expand2

    package require Tk
    package require Img

    # expand without transparency
    proc expand {image coef} \
    {
      # check coef
      if {$coef < 1.0} \
      { error "bad coef \"$coef\": should not be less than 1.0" }
      if {$coef - int($coef) < 1.e-4} \
      { return [optim $image [expr {int($coef)}]] }
      # 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] }
      }
      # crisping
      for {set Y 0} {$Y < $Height} {incr Y} \
      {
        set Row {}
        for {set X 0} {$X < $Width} {incr X} \
        {
          if {$X == 0 || $X == $Width - 1 || $Y == 0 || $Y == $Height - 1} \
          { 
            foreach c {r g b} { set $c [lindex [set $c:Data] $Y $X] }
          } \
          else \
          {
            foreach c {r g b} \
            { 
              set c00 [lindex [set $c:Data] [expr {$Y - 1}] [expr {$X - 1}]]
              set c01 [lindex [set $c:Data] [expr {$Y - 1}] [expr {$X - 0}]]
              set c02 [lindex [set $c:Data] [expr {$Y - 1}] [expr {$X + 1}]]
              set c10 [lindex [set $c:Data] [expr {$Y + 0}] [expr {$X - 1}]]
              set c11 [lindex [set $c:Data] [expr {$Y + 0}] [expr {$X - 0}]]
              set c12 [lindex [set $c:Data] [expr {$Y + 0}] [expr {$X + 1}]]
              set c20 [lindex [set $c:Data] [expr {$Y + 1}] [expr {$X - 1}]]
              set c21 [lindex [set $c:Data] [expr {$Y + 1}] [expr {$X - 0}]]
              set c22 [lindex [set $c:Data] [expr {$Y + 1}] [expr {$X + 1}]]
              set cc [expr {int(1.4 * $c11 - 0.05 * ($c00 + $c01 + $c02 + $c10 + $c12 + $c20 + $c21 + $c22))}]
              if {$cc < 0} { set cc 0 }
              if {$cc > 255} { set cc 255 }
              set $c $cc
            }
          }
          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
    }

    # integral expand
    proc optim {image coef} \
    { 
      set coef [expr {int($coef)}]
      if {$coef == 1} { return $image }
      set width [image width $image]
      set height [image height $image]
      set data [$image data]
      set data2 {}
      for {set y 0} {$y < $height} {incr y} \
      {
        set row [lindex $data $y]
        set row2 {}
        for {set x 0} {$x < $width} {incr x} \
        {
          set pixel [lindex $row $x]
          for {set i 0} {$i < $coef} {incr i} \
          { lappend row2 $pixel }
        }
        for {set j 0} {$j < $coef} {incr j} \
        { lappend data2 $row2 }
      }
      set image2 [image create photo]
      $image2 put $data2
      return $image2
    }

    # expand with transparency
    proc expand2 {image coef} \
    {
      # check coef
      if {$coef < 1.0} \
      { error "bad coef \"$coef\": should not be less than 1.0" }
      if {$coef - int($coef) < 1.e-4} \
      { return [optim $image [expr {int($coef)}]] }
      # 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] }
      }
      # crisping
      for {set Y 0} {$Y < $Height} {incr Y} \
      {
        set Row {}
        set tRow {}
        for {set X 0} {$X < $Width} {incr X} \
        {
          if {$X == 0 || $X == $Width - 1 || $Y == 0 || $Y == $Height - 1} \
          {
            foreach c {r g b} { set $c [lindex [set $c:Data] $Y $X] }
          } \
          else \
          {
            foreach c {r g b t} \
            {
              set c00 [lindex [set $c:Data] [expr {$Y - 1}] [expr {$X - 1}]]
              set c01 [lindex [set $c:Data] [expr {$Y - 1}] [expr {$X - 0}]]
              set c02 [lindex [set $c:Data] [expr {$Y - 1}] [expr {$X + 1}]]
              set c10 [lindex [set $c:Data] [expr {$Y + 0}] [expr {$X - 1}]]
              set c11 [lindex [set $c:Data] [expr {$Y + 0}] [expr {$X - 0}]]
              set c12 [lindex [set $c:Data] [expr {$Y + 0}] [expr {$X + 1}]]
              set c20 [lindex [set $c:Data] [expr {$Y + 1}] [expr {$X - 1}]]
              set c21 [lindex [set $c:Data] [expr {$Y + 1}] [expr {$X - 0}]]
              set c22 [lindex [set $c:Data] [expr {$Y + 1}] [expr {$X + 1}]]
              set cc [expr {int(1.4 * $c11 - 0.05 * ($c00 + $c01 + $c02 + $c10 + $c12 + $c20 + $c21 + $c22))}]
              if {$cc < 0} { set cc 0 }
              if {$cc > 255} { set cc 255 }
              set $c $cc
            }
          }
          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/image.png
  image create photo Photo -file image.png

  namespace import ::expand::expand

  wm withdraw .
  set n 0
  foreach coef {1.0 1.2 1.4} \
  {
    set image [expand Photo $coef]
    toplevel .$n
    wm title .$n "expand $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
  }

See also