proc bin2gray {image subfactor} {
set iota [lrange {- 0 1 2 3 4 5 6 7 8 9} 1 $subfactor]
set h0 [image height $image]; set w0 [image width $image]
set th [expr {round(1.*$h0/$subfactor)}]
set tw [expr {round(1.*$w0/$subfactor)}]
set res [image create photo -height $th -width $tw]
for {set tx 0} {$tx<$tw} {incr tx} {
set pix ""
for {set ty 0} {$ty<$th} {incr ty} {
set y [expr {$ty*$subfactor}]
set sum 0
foreach i $iota {
set x [expr {$tx*$subfactor}]
foreach j $iota {
incr sum [lindex [$image get $x $y] 0]
incr x
if {$x>=$w0} break
}
incr y
if {$y>=$h0} break
}
set g [expr {round(1.0*$sum/($subfactor*$subfactor))}]
lappend pix [format #%02x%02x%02x $g $g $g]
}
$res put $pix -to $tx 0
}
return $res
}
image create photo 1 -file larochelle.gif
bin2gray 1 3
image1 write bin2gray2.gifJacob Levy Very good! There's still some small efficiency hacks, as shown below (also touched by JH to brace exprs and such):
package require Tk
proc bin2gray2 {image subfactor} {
set iota [lrange {- 0 1 2 3 4 5 6 7 8 9} 1 $subfactor]
set sfsquare [expr {$subfactor * $subfactor}]
set h0 [image height $image]; set w0 [image width $image]
set th [expr {round(1.*$h0/$subfactor)}]
set tw [expr {round(1.*$w0/$subfactor)}]
set res [image create photo -height $th -width $tw]
for {set tx 0} {$tx<$tw} {incr tx} {
set pix ""
set x [expr {$tx*$subfactor}]
for {set ty 0} {$ty<$th} {incr ty} {
set y [expr {$ty*$subfactor}]
set sum 0
foreach i $iota {
set lx $x
foreach j $iota {
incr sum [lindex [$image get $lx $y] 0]
incr lx
if {$lx>=$w0} break
}
incr y
if {$y>=$h0} break
}
set g [expr {round(1.0*$sum/$sfsquare)}]
lappend pix [format #%02x%02x%02x $g $g $g]
}
$res put $pix -to $tx 0
}
return $res
}
image create photo 1 -file larochelle.gif
bin2gray 1 3
image1 write bin2gray2.gifCategory Image Processing | Arts and crafts of Tcl-Tk programming
