Image scaling

Richard Suchenwirth 2003-02-25 - Photo images can be resized by adding the -zoom or -subsample switches when copying an image. Here is a wrapper that takes only a factor and selects the appropriate switch. The image is scaled in place (so when it is displayed in a widget, updating goes automatically), the temporary image t is freed when no more needed. The following enhanced version is 3 LOC more, but also does flipping around x and/or y axis:

 proc scaleImage {im xfactor {yfactor 0}} {
    set mode -subsample
    if {abs($xfactor) < 1} {
       set xfactor [expr round(1./$xfactor)]
    } elseif {$xfactor>=0 && $yfactor>=0} {
        set mode -zoom
    }
    if {$yfactor == 0} {set yfactor $xfactor}
    set t [image create photo]
    $t copy $im
    $im blank
    $im copy $t -shrink $mode $xfactor $yfactor
    image delete $t
 }

Usage examples: adding the following lines gives iFile: a little file system browser scaling capacities on the image shown on the "File" page:

 .m add casc -label Image -menu [menu .m.image -tearoff 0]
 .m.image add comm -label "Zoom x 3" -command {scaleImage $g(i) 3}
 .m.image add comm -label "Zoom x 2" -command {scaleImage $g(i) 2}
 .m.image add comm -label "Zoom x 0.5" -command {scaleImage $g(i) 0.5}
 .m.image add comm -label "Zoom x 0.33" -command {scaleImage $g(i) 0.33}
 .m.image add separator
 .m.image add comm -label "Flip LR" -command {scaleImage $g(i) -1 1}
 .m.image add comm -label "Flip TB" -command {scaleImage $g(i) 1 -1}
 .m.image add comm -label "Flip both" -command {scaleImage $g(i) -1 -1}

For robustness, one might disable this menu when no image is displayed. Experience shows that enlarging bigger photo images may let the little machine run out of memory - time to throw away some fat MP3 files...

dzach 16-Sep-2005: Following a suggestion of suchenwi in the Tcler's chat, here is a proc to uniformly scale an image in place, using a ratio of integers r1/r2:

    proc ratscale {img r1 r2} {
        image create photo tmp_img
        tmp_img copy $img -zoom $r1
        $img blank
        $img copy tmp_img -subsample $r2
        image delete tmp_img
    }

However for large rationals (say 200/255) this may be a memory killer, since it will first zoom the image by 200 and then subsample it (1 every 255).

EF 18-Jan-2017: For the brave, a variant of the above is the following, which takes any "float" for the scaling factor(s) and computes the ratio of integers. This exhibits the same memory problems as the implementation above, it's just easier to integrate.

proc Double2Fraction { dbl {eps 0.000001}} {
    for {set den 1} {$den<1024} {incr den} {
        set num [expr {round($dbl*$den)}]
        if {abs(double($num)/$den - $dbl) < $eps} break
    }
    list $num $den
}


proc scale {img sx {sy ""} } {
    if { $sx == 1 && ($sy eq "" || $sy == 1) } {
        return;   # Nothing to do!
    }
    
    foreach {sx_m sx_f} [Double2Fraction $sx] break
    if { $sy eq "" } {
        foreach {sy sy_m sy_f} [list $sx $sx_m $sx_f] break;  # Multi-set!
    } else {
        foreach {sy_m sy_f} [Double2Fraction $sy] break
    }
    set tmp [image create photo]
    $tmp copy $img -zoom $sx_m $sy_m -compositingrule set
    $img blank
    $img copy $tmp -shrink -subsample $sx_f $sy_f -compositingrule set
    image delete $tmp
}

Image scaling also helps in the GIF transparency problem on iPAQ - this workaround works:

• put an instance of the image in a widget (e.g. a text)
• zoom up
• subsample down again

Now transparent pixels are in the widget background color (white), no more random and black, for all instances, and certainly look better than before.

 foreach i $g(images) {
   $g(text) image create end -image $g($i)
   scaleImage $g($i) 3
   scaleImage $g($i) .33
 }

RS 2006-02-13: Here's a variation that takes an image and a percentage (see Greatest common denominator for gcd), and returns an accordingly scaled image:

 proc image% {image percent} {
   set deno      [gcd $percent 100]
   set zoom      [expr {$percent/$deno}]
   set subsample [expr {100/$deno}]
   set im1 [image create photo]
   $im1 copy $image -zoom $zoom
   set im2 [image create photo]
   $im2 copy $im1 -subsample $subsample
   image delete $im1
   set im2
 }
 proc gcd {u v} {expr {$u? [gcd [expr $v%$u] $u]: $v}}

See also Photo image rotation, Shrinking an image

For fast arbitrary rotation (and scaling) see: Enhanced photo image copy command

The combination of photo image zooming and the Img extension let us code A little magnifying glass in just a few lines.

hypnotoad Has a C based Tk Image scaler that works with arbitrary sizes: Image Scaling in C

Cyan Pixel (package) is a collection of Tcl packages for encoding, decoding scaling, rotating, transforming, compositing and otherwise manipulating raster images, with a focus on speed and quality - image resampling is a deep rabbit hole, as is math on image channels (almost everything gets this wrong, including CSS and many older versions of Photoshop). This set of libraries have been evolving for almost 20 years now and I've learned a thing or two since the initial stones were laid down, so it's not perfect in its design, but it currently serves to process all of Ruby Lane's dynamic image requests (dozens a second). One day (soon hopefully) I plan to build a clean successor, but for now it looks like this:

High quality, fast up and down scaling of a jpeg, saving to a webp:

 package require Pixel
 package require Pixel_jpeg
 package require Pixel_webp

 proc readbin fn {
     set h [open $fn rb]
     try {read $h} finally {close $h}
 }

 proc writebin {fn bytes} {
     set h [open $fn wb]
     try {puts -nonewline $h $bytes} finally {close $h}
 }

 set orig [pixel::pmap_to_pmapf [pixel::jpeg::decodejpeg [readbin foo.jpg]]]
 lassign [pixel::pmapf_info $orig] width height

 # Make a thumbnail by scaling to fit within a 220x220 square, preserving aspect ratio
 set f [expr {220.0/($width > $height ? $width : $height)}]
 set thumb [pixel::scale_pmapf_lanczos $orig [expr {$width*$f}] [expr {$height*$f}]

 # Scale to 5000 pixels on the long side, whether $orig is larger or smaller than this
 set f [expr {5000.0/($width > $height ? $width : $height)}]
 set large [pixel::scale_pmapf_lanczos $orig [expr {$width*$f}] [expr {$height*$f}]

 # Write out results as webp files
 writebin foo_large.webp [pixel::webp::encode [pixel::pmapf_to_pmap $large]]
 writebin foo_thumb.webp [pixel::webp::encode [pixel::pmapf_to_pmap $thumb]]

See also Arts and crafts of Tcl-Tk programming