Version 0 of Crisping an image

Updated 2003-12-07 14:16:03

ulis, 2003-12-07. A proc to crisp an image.

http://perso.wanadoo.fr/maurice.ulis/tcl/crisp1.png http://perso.wanadoo.fr/maurice.ulis/tcl/crisp2.png http://perso.wanadoo.fr/maurice.ulis/tcl/crisp3.png


  '''How it works'''

  It works by substracting neighbor pixels:

     0  1  2  
    .--.--.--.
  0 |//|//|//|
    .--.--.--.
  1 |//|XX|//|
    .--.--.--.
  2 |//|//|//|
    .--.--.--.

    The color of the central pixel is computed from all marked pixels:

  p11 = coef * p11 
        - (1 - coef)/8 * (p00 + p01 + p02 + p11 + p12 + p20 + p21 + p22)  

The proc

  namespace eval ::crisp \
  {
    namespace export crisp

    package require Tk

    proc crisp {image coef} \
    {
      # check coef
      if {$coef < 1.0} \
      { error "bad coef \"$coef\": should not be less than 1.0" }
      if {abs($coef - 1.0) < 1.e-4} { return $image }
      set coef2 [expr {($coef - 1.0) / 8.0}]
      # get the old image content
      set width [image width $image]
      set height [image height $image]
      if {$width * $height == 0} { error "bad image" }
      set data [$image data]
      # 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} [winfo rgb . [lindex $data $y $x]] break
          foreach c {r g b} { lappend $c:row [expr [set $c] / 256] }
        }
        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($coef * $c11 - $coef2 * ($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 data2 $row
      }
      # create the new image
      set image2 [image create photo]
      # fill the new image
      $image2 put $data2
      # return the new image
      return $image2
    }

  }

The demo

  # to download the image:
  # http://perso.wanadoo.fr/maurice.ulis/tcl/image4.png

  package require Img
  image create photo Photo -file image4.png
  namespace import ::crisp::crisp
  wm withdraw .
  set n 0
  foreach coef {1.0 1.4 1.8} \
  {
    set image [crisp Photo $coef]
    toplevel .$n
    wm title .$n "crisp $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
    update
    incr n
  }

See also


Category Graphics

Category Image Manipulation

Category Example