Version 20 of Shrinking an image
Updated 2004-02-05 22:43:34ulis, 2003-12-4. A proc to shrink an image.
Updated 2003-12-6, improved proc (2 times faster).
David Easton, 2003-12-8, improved colour plane creation speed
ulis, 2004-02-05. Roy Terry asked for transparency so I've added a new proc, shrink2, that manages the alpha channel.
(Original photo: to fill)
How it works
It works by linear interpolation:
p x- 0 -x- 1 -x- 2 -x <- pixels of shrinked image
| \ \ \
| \ \ \
| \ \ \ <- pixels correspondence
| \ \ \
| \ \ \
P x- 0 -x- 1 -x- 2 -x- 3 -x- 4 -x <- pixels of original image
| | | |
| 3 2 |1 3 1| 2 3 |
| - - |- - -| - - | <- weights
| 5 5 |5 5 5| 5 5 |
p0 = P0 * 3/5 + P1 * 2/5
p1 = P1 * 1/5 + P2 * 3/5 + P3 * 1/5
p2 = P3 * 2/5 + P4 * 3/5Each pixel of the shrinked image is the sum of the (linearly) corresponding pixels of the original image, weighted as above.
The proc
namespace eval ::shrink \
{
namespace export shrink shrink2
package require Tk
package require Img
# shrinking without transparency
proc shrink {Image coef} \
{
# check coef
if {$coef > 1.0} \
{ error "bad coef \"$coef\": should not be greater than 1.0" }
if {abs($coef - 1.0) < 1.e-4} { return $Image }
# 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] }
}
# compute the new image content
set width [expr {round($Width * $coef)}]
set height [expr {round($Height * $coef)}]
set ey 0
set Y2 0
set cy2 $height
for {set y 0} {$y < $height} {incr y} \
{
set r:row {}
set g:row {}
set b:row {}
# Y1 is the top coordinate in the old image
set Y1 $Y2
set cy1 [expr {$height - $cy2}]
incr ey $Height
set Y2 [expr {$ey / $height}]
set cy2 [expr {$ey % $height}]
if {$Y1 == $Y2} { set cy1 $cy2 }
set ex 0
set X2 0
set cx2 $width
for {set x 0} {$x < $width} {incr x} \
{
set X1 $X2
set cx1 [expr {$width - $cx2}]
incr ex $Width
set X2 [expr {$ex / $width}]
set cx2 [expr {$ex % $width}]
if {$X1 == $X2} { set cx1 $cx2 }
# compute pixel
foreach c {r g b} { set $c 0; set _$c 0 }
for {set Y $Y1} {$Y <= $Y2} {incr Y} \
{
# compute y coef
switch $Y \
$Y1 { set cy $cy1 } \
$Y2 { set cy $cy2 } \
default { set cy $height }
if {$cy == 0} { continue }
if {$cy > $Height} { set cy $Height }
for {set X $X1} {$X <= $X2} {incr X} \
{
# compute x coef
switch $X \
$X1 { set cx $cx1 } \
$X2 { set cx $cx2 } \
default { set cx $width }
if {$cx == 0} { continue }
if {$cx > $Width} { set cx $Width }
# weight each initial pixel by cx & cy
set cxy [expr {$cx * $cy / double($Width) / $Height}]
foreach c {r g b} \
{
set comp [lindex [set $c:Data] $Y $X]
incr $c [expr {round($comp * $cxy)}]
set _$c [expr {[set _$c] + $cxy}]
}
}
}
set _ {}
foreach c {r g b} \
{
set comp [set $c]
if {$comp > 255} { set comp 255 }
lappend $c:row $comp
lappend _ [set _$c]
}
}
foreach c {r g b} { lappend $c:data [set $c:row] }
}
# merge the planes
for {set y 0} {$y < $height} {incr y} \
{
set row {}
for {set x 0} {$x < $width} {incr x} \
{
foreach c {r g b} { set $c [lindex [set $c:data] $y $x] }
lappend row [format #%02x%02x%02x $r $g $b]
}
lappend data $row
}
# create the new image
set image [image create photo]
# fill the new image
$image put $data
# return the new image
return $image
}
# shrinking with transparency
proc shrink2 {Image coef} \
{
# check coef
if {$coef > 1.0} \
{ error "bad coef \"$coef\": should not be greater than 1.0" }
if {abs($coef - 1.0) < 1.e-4} { return $Image }
# 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 {}
set t:Row {}
for {set X 0} {$X < $Width} {incr X} \
{
foreach {r g b} [$Image get $X $Y] break
set t [$Image transparency get $X $Y]
set t [expr {$t * 256}]
foreach c {r g b t} { lappend $c:Row [set $c] }
}
foreach c {r g b t} { lappend $c:Data [set $c:Row] }
}
# compute the new image content
set width [expr {round($Width * $coef)}]
set height [expr {round($Height * $coef)}]
set ey 0
set Y2 0
set cy2 $height
for {set y 0} {$y < $height} {incr y} \
{
set r:row {}
set g:row {}
set b:row {}
set t:row {}
# Y1 is the top coordinate in the old image
set Y1 $Y2
set cy1 [expr {$height - $cy2}]
incr ey $Height
set Y2 [expr {$ey / $height}]
set cy2 [expr {$ey % $height}]
if {$Y1 == $Y2} { set cy1 $cy2 }
set ex 0
set X2 0
set cx2 $width
for {set x 0} {$x < $width} {incr x} \
{
set X1 $X2
set cx1 [expr {$width - $cx2}]
incr ex $Width
set X2 [expr {$ex / $width}]
set cx2 [expr {$ex % $width}]
if {$X1 == $X2} { set cx1 $cx2 }
# compute pixel
foreach c {r g b t} { set $c 0; set _$c 0 }
for {set Y $Y1} {$Y <= $Y2} {incr Y} \
{
# compute y coef
switch $Y \
$Y1 { set cy $cy1 } \
$Y2 { set cy $cy2 } \
default { set cy $height }
if {$cy == 0} { continue }
if {$cy > $Height} { set cy $Height }
for {set X $X1} {$X <= $X2} {incr X} \
{
# compute x coef
switch $X \
$X1 { set cx $cx1 } \
$X2 { set cx $cx2 } \
default { set cx $width }
if {$cx == 0} { continue }
if {$cx > $Width} { set cx $Width }
# weight each initial pixel by cx & cy
set cxy [expr {$cx * $cy / double($Width) / $Height}]
foreach c {r g b t} \
{
set comp [lindex [set $c:Data] $Y $X]
incr $c [expr {round($comp * $cxy)}]
set _$c [expr {[set _$c] + $cxy}]
}
}
}
set _ {}
foreach c {r g b t} \
{
set comp [set $c]
if {$comp > 255} { set comp 255 }
lappend $c:row $comp
lappend _ [set _$c]
}
}
foreach c {r g b t} { lappend $c:data [set $c:row] }
}
# merge the planes
for {set y 0} {$y < $height} {incr y} \
{
set row {}
set trow {}
for {set x 0} {$x < $width} {incr x} \
{
foreach c {r g b t} { set $c [lindex [set $c:data] $y $x] }
lappend row [format #%02x%02x%02x $r $g $b]
lappend trow [expr {round($t)}]
}
lappend data $row
lappend tdata $trow
}
# create the new image
set image [image create photo]
# fill the new image
$image put $data
# set transparency
puts [join $tdata \n]
for {set y 0} {$y < $height} {incr y} \
{
for {set x 0} {$x < $width} {incr x} \
{
set t [lindex $tdata $y $x]
set t [expr {$t > 128 ? 1 : 0}]
$image transparency set $x $y $t
}
}
# return the new image
return $image
}
}The demo
# to download the image:
# http://perso.wanadoo.fr/maurice.ulis/tcl/image2.png
image create photo Photo -file image2.png
package require Img
image create photo Photo -file image2.png
namespace import ::shrink::shrink
wm withdraw .
set n 0
foreach coef {1.0 0.8 0.6} \
{
set image [shrink Photo $coef]
toplevel .$n
wm title .$n "shrink $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
}RT 4Feb04, Very handy and works nicely. One thing I noticed is that (for png) the alpha channel (tranparency) appears to get lost. I wonder how hard it would be to preserve transparency too? That would be very sweet. Thanks!
DKF: Tk's photo image doesn't handle transparency well-enough. This sucks, but I've not had time to write the update to fix this (beyond mere for-my-eyes-only-prototype that is)
ulis: It would be nice to have Tk manages transparency as a fourth channel.
See also
- Blurring an image
- Crisping an image
- Embossing an image
- Expanding an image
- Image Processing with HSV
- Image scaling
- Photo image rotation