Shrinking an image
ulis, 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 shrunken image is the sum of the (linearly) corresponding pixels of the original image, weighted as above.
Thus the colors count of the image can increase and a gif image can give a shrunken image with more than 256 colors (See MPJ add below).
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.
DKF: Note that this code can be made to go faster by removing all use of switch and instead using if with suitable expressions. Using switch forces string comparisons and you're in an inner loop where this sort of thing can matter...
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?
DKF: If you accessed the photo data using Tcl's C interface, you'd be able to handle the alpha channel and you'd also go much faster. It's an ideal candidate for being done in C. In fact, I'm a little startled that anyone bothered trying to do it in Tcl. :^) This will help a lot though when I come to put scaling (and rotation) into photo images. It's on my to-do list, and I'll be most cross if I can't get it into 8.5 because of time constraints...
RT: Having C level scaling would be great in general, and for my current enterprise, as the alternative is to wrap and maintain the whole ImageMagick package just to get fast scaling in my application. Go Donal! :)
ulis: Tcl is just perfect to try algorithms and it's funny to try to reach its limits. Moreover I don't want to put my fingers in C ;^)
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?
MG - GIFs can only handle 256 colors, so those images must use more. Try saving as a jpeg instead with
$image write jc.jpeg -format jpeg
(Some drawing programs I've seen give an offer to decrease the number of colors to 256 to allow saving as gifs anyway; would it be possible/does anyone know how to do this in Tcl?)
DKF: Replace colours with other colours until you only have 256 different colours. Then you can write as a GIF. :^) OK, that's not helpful. I don't know how to pick what colours to replace though; AIUI, there are several techniques. Dithering the whole image onto a 3/3/2 colourspace (you'll have to do this yourself; Tk's got dithering code, but its for display-on-low-depth-screens use only) will work, even though it's probably non-optimal for every image.
DKF: Perhaps Reduce Colour Depth - Median Cut is helpful?
TV I took the liberty of adding a Gimp reduced image for comparison (60 %) in uncompressed (or at least 100%) jpg.
Gimp Tcl
ulis: I find the Gimp work a little more blurry. Is it? TV Well, the reason I made the comparison is that indeed I too had the impression there were differences, and I thought that face (if they have one) of the monkey in the gimp version is more like the big version, in terms of blackness and structure.
jmp 2004/04/15 Under-sampling images and more generally under-sampling data requires lowpass pre-filtering indeed. This is needed to avoid the well-known aliasing effect of resampling operations: some artificial high frequencies may be created if you don't take care. Determining the best filter is a hard work and may depend on the image to be under-sampled. I suppose the GIMP does lowpass-filtering before resampling. Ulis also did a kind of lowpass filtering using coefficients. These coefficients should theorically be adapted to the under-sampling ratio. They seem good for the monkey and a 60% ratio, but they could be less good for other images or other ratios.
DKF: Studying the code in more depth, I see you use [foreach c {r g b} ...] a lot. This is a very slow idiom, especially when inside any inner loops. [switch] is also slow. Expanding everything out (and using numeric comparisons) I get a lot more speed.
ulis: Why not put the optimized code in this page?
DKF: It's significantly longer and I'm looking to recode it in C (and get it into the core) where I can get a lot more speed again.
I suspect that there's an off-by-one error as well; try putting some space between the image and the window edge and look at the top and left edges (IIRC). I suspect it might also be more visible with images that have a light background. I've not had time to investigate in detail though, so I might be wrong.
EB: Donal, if it can help, I have a C version ported from PBM Plus pnmscale [L1 ]. (TV just a side remark: isn't the pbm/pnm package, which I found interesting at the timeI used it, too, all written in C?) - Yes, I mean ported to Tk photo image format, in contrast to pbm stdin/stdout interface
DKF: Does that deal with RGBA data?
EB: Yes, exactly like the other channels. Is that the good way ?
DKF: Yes. I asked because the pnm formats don't support alpha (that I know about :^))
DKF: EB, your code looks very good.
EB: Then, feel free to take it for an [image scale] command in the core.
DKF: That is definitely my plan. I just ran out of time to say so yesterday. ;^)
TFW: Dec 27, 2005. I took Eric Boudaillier's code and wrapped into a DLL call TkImageTools (for lack of a better name) It adds a tkImageTools::resize command. You can get the source and binaries for windows and linux here [L2 ]. I put it to good use in SnackAmp resizing cover art to standard dimensions. By the way, the visual appearance of the reduced/expanded image is very good.
DKF: Here's a version (no alpha channel handling) which goes a bit faster. It also supports an optional third argument for those times when you want to supply a target image. No promises that this will work for anything before 8.4, of course.
proc shrink3 {Image coef {TargetImage {}}} {
# check coef
if {$coef > 1.0} {
error "bad coef \"$coef\": should not be greater than 1.0"
}
# get the old image content
set Width [image width $Image]
set Height [image height $Image]
if {$Width==0 || $Height==0} {
error "bad image"
}
if {$TargetImage eq ""} {
# create new image
set image [image create photo]
} else {
set image $TargetImage
}
if {abs($coef - 1.0) < 1.e-4} {
$image copy $Image
return $image
}
set Factor [expr {double($Width)*$Height}]
# Extract the data from the source - experiment indicates that this is the fastest way
foreach row [$Image data] {
set rdata {}
foreach pixel $row {
lappend rdata [scan $pixel "#%2x%2x%2x"]
}
lappend DATA $rdata
}
# 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} {
# 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
set row {}
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
set r 0.0
set g 0.0
set b 0.0
for {set Y $Y1} {$Y <= $Y2} {incr Y} {
# compute y coef
if {$Y == $Y1} {
if {$cy1 == 0} continue
set cy [expr {$cy1>$Height ? $Height : $cy1}]
} elseif {$Y == $Y2} {
if {$cy2 == 0} continue
set cy [expr {$cy2>$Height ? $Height : $cy2}]
} else {
set cy $height
}
for {set X $X1} {$X <= $X2} {incr X} {
# compute x coef
if {$X == $X1} {
if {$cx1 == 0} continue
set cx [expr {$cx1>$Width ? $Width : $cx1}]
} elseif {$X == $X2} {
if {$cx2 == 0} continue
set cx [expr {$cx2>$Width ? $Width : $cx2}]
} else {
set cx $width
}
# weight each initial pixel by cx & cy
set cxy [expr {$cx * $cy / $Factor}]
set pixel [lindex $DATA $Y $X]
set r [expr {$r+([lindex $pixel 0] * $cxy)}]
set g [expr {$g+([lindex $pixel 1] * $cxy)}]
set b [expr {$b+([lindex $pixel 2] * $cxy)}]
}
}
lappend row [format "#%02x%02x%02x" \
[expr {$r>255.0 ? 255 : round($r)}] \
[expr {$g>255.0 ? 255 : round($g)}] \
[expr {$b>255.0 ? 255 : round($b)}]]
}
lappend data $row
}
# fill the new image
$image blank
$image put $data
# return the new image
return $image
}See also
- TclMagick - which implements similar algorithms, but being written in C is much faster, albeit less available for fun experimentation!
- 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
- Reduce Colour Depth - Median Cut
- Reducing the color depth of an image