## Graylevel subsampling

Richard Suchenwirth 2003-07-25 - The following code was instigated by kroc. It takes a graylevel photo image and produces a smaller one, by the specified factor, where the pixel values are averaged from the original image, instead of the simple "picking" that image copy -subsample does. Some mods by JH to improve performance.

``` 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.gif```

Jacob 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.gif```