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

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

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

(Original photo: [to fill])

----

'''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" }
      # 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'''

   * [Blurring an image]
   * [Embossing an image]
   * [Expanding an image]
   * [Image Processing with HSV]
   * [Photo image rotation]
   * [Shrinking an image]
   * [TkPhotoLab]

----

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