[ulis], 2003-12-07. A proc to crisp an image. [David Easton], 2003-12-08 25% Speedup by using " 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 exit update incr n } ---- '''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]