Version 27 of Shrinking an image
Updated 2004-04-02 19:46:47ulis, 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
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.
DKF: It does already, but only internally. My point was that it is not exposed to scripts.
RT Could anyone knowledgable comment on the practicality of translating this proc (or hotspots of same) to C with CriTcl or just direct C? And for that matter, same question for some of the family of these procs as listed below. I suppose the basic question is how similar would the code structure be if it were written at the C API level of Tcl/Tk?
MPJ: I just tried this code to resize some card images from scat to 60% the orginal size. This seemed to work find for images as they all displayed on the canvas but when I tried to write the kings, queens and jacks to a file I get the error "too many colors" with Tcl 8.4.6. See example below:
set image [shrink ::img::jc 0.6] $image write jc.gif
Any ideas on what the problem is?
See also
- Blurring an image
- Crisping an image
- Embossing an image
- Expanding an image
- Fast image resizing - David Easton 2004-04-29
- Image Processing with HSV
- Image scaling
- Photo image rotation