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

Category Image Processing | Arts and crafts of Tcl-Tk programming