Crisping an image

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

David Easton, 2003-12-08 25% Speedup by using "<photo> get"

(Original photo: [to fill])

How it works

  It works by subtracting 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" }
      # 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] }
      }
      # 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
    bind .$n.c <Destroy> exit
    update
    incr n
  }

Minor Alterations

I noticed that this process was running fairly slow, considering its function, and consolidated the code some. I then noticed that for some reason the image was getting slightly brighter on each pass of crisping. I then added a corrective check to the value of the cc variable to correct this.

Here are my changes (note roughly 40% speed increase)

        proc Crisp { data 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}]
            if {[catch {set width [image width $data]} blah]} {return 0;}
            set height [image height $data]
            for {set y 0} {$y < $height} {incr y} {
                update
                set r:row {}; set g:row {}; set b:row {};
                for {set x 0} {$x < $width} {incr x} {
                    foreach {r g b} [$data 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] }
                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}]]
                            if {[catch {set cc [expr {int($coef * $c11 - $coef2 * ($c00 + $c01 + $c02 + $c10 + $c12 + $c20 + $c21 + $c22))}]} blah]} {set cc [lindex [set $c:data] $y [expr $x]];}
                            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
            }
            set crisped [image create photo]
            $crisped put $data2
            return $crisped
        }

* modified by: Barry Skidmore

See also

Category Graphics

Category Image Processing

Category Example