in reply to graphicsmagick perl shrink image to size

I used ImageMagick based stuff for a long time. But i switched to GD for most of my stuff, because it also allows for easy acceptable pixel manipulation, even if it's painfully slow.

The basic calculation to calculate the new image dimension goes something like this, no matter which image manipulation module you end up using (from memory, untested): 

# Check if we are limited by height or width of the source image
my $factor = $sourcewidth / $targetwidth;
if($sourceheight / $factor > $targetheight) {
    $factor = $sourceheight / $targetheight;
)
my $newwidth = int($sourcewidth / $factor);
my $newheight = int($sourceheight / $factor);

[download]

You can then, for example, use the copyResized method from GD: 

$newpic->copyResized($sourcepic,
                              $destx, $desty, # DEST X Y
                              0, 0, # SRC X Y
                              $newwidth, $newheight, # DEST W H
                              $sourcewidth, $sourceheight, # SRC W H
                          );

[download]

It's also worth noting that there might be a lot more pixel massaging needed to be done, depending on what those resulting images are used for. For example, i have a use case where i have to print user provided logos onto thermal paper. I ended up having to implement multiple algorithms for transforming color images to black&white pixels from which the user can select. Here is the printAddGreyscaleImage() from my PageCamel Framework PrintProcessor.pm: 

sub printAddGreyscaleImage {
    my ($self, $filename, $isbindata, $imagesoftness) = @_;
    
    my $reph = $self->{reph};
    
    if(!defined($imagesoftness)) {
        $imagesoftness = 1;
    }
    
    my $rawpic;
    if($isbindata) {
        $rawpic = GD::Image->newFromPngData($filename, 0);
    } else {
        $rawpic = GD::Image->newFromPng($filename, 0);
    }
            
    my ($w, $h) = $rawpic->getBounds();
    
    my $destw = $self->{width};
    my $scale = $w / $destw;
    my $desth = int($h / $scale);
    
    
    # Check if we got that image already cached
    my $cachekey = $imagesoftness . '_' . sha256_hex($rawpic->png);
    $reph->debuglog("   KEY $cachekey");
    if(defined($self->{imagecache}->{$cachekey})) {
        $reph->debuglog("   using cached greyscale image conversion");
        $self->{img}->copyResized($self->{imagecache}->{$cachekey},
                          0, $self->{imgoffs}, # DEST X Y
                          0, 0, # SRC X Y
                          $destw, $desth, # DEST W H
                          $destw, $desth, # SRC W H
                          );
        $self->{imgoffs} += $desth;
        return;
    }
    
    $reph->debuglog("   need to do image conversion");
    
    my $pic = GD::Image->new($destw, $desth);
    
    # Copy palette
    my $colorcount = $rawpic->colorsTotal;
    for(my $c = 0; $c < $colorcount; $c++) {
        my ($r,$g,$b) = $rawpic->rgb($c);
        $pic->colorAllocate($r, $g, $b);
    }
    
    $pic->copyResized($rawpic,
                      0, 0, # DEST X Y
                      0, 0, # SRC X Y
                      $destw, $desth, # DEST W H
                      $w, $h, # SRC W H
                    );
    
    # For caching converted images
    my $cachepic = GD::Image->new($destw, $desth);
    my $cachewhite = $cachepic->colorAllocate(255, 255, 255);
    my $cacheblack = $cachepic->colorAllocate(0, 0, 0);

    my @pixels;
    # Prepare for dithering
    for(my $y = 0; $y < $desth; $y++) {
        for(my $x = 0; $x < $destw; $x++) {
            my $index = $pic->getPixel($x, $y);
            my ($r,$g,$b) = $pic->rgb($index);
            my $greypixel = int(($r+$g+$b)/3);
            my $oldpixel = $greypixel * 1.0;

            $pixels[$x]->[$y] = $oldpixel;
        }
    }
    
    if($imagesoftness == 0) {
        for(my $y = 0; $y < $desth; $y++) {
            for(my $x = 0; $x < $destw; $x++) {
                my $oldpixel = $pixels[$x]->[$y];
    
                # Simple monochrome conversion
                if($oldpixel < 128) {
                    $self->{img}->setPixel($x, $y + $self->{imgoffs}, 
+$self->{imgblack});
                    $cachepic->setPixel($x, $y, $cacheblack);
                }
            }
        }
        $self->{imagecache}->{$cachekey} = $cachepic;
    } elsif($imagesoftness == 2) {
        # Floyd-Steinberg dithering
        my @dither = (
            [0, 0, 7],
            [3, 5, 1],
        );
        for(my $y = 0; $y < $desth; $y++) {
            for(my $x = 0; $x < $destw; $x++) {
                my $oldpixel = $pixels[$x]->[$y];
    
                # "Find closed palette/index value
                my $newpixel = 255.0;
                if($oldpixel < 128) {
                    $newpixel = 0.0;
                }
                $pixels[$x]->[$y] = $newpixel;
    
                my $quanterror = $oldpixel - $newpixel;
                for(my $ditherx = 0; $ditherx < 3; $ditherx++) {
                    for(my $dithery = 0; $dithery < 2; $dithery++) {
                        my $deltax = $x + $ditherx - 1;
                        my $deltay = $y + $dithery;
                        my $factor = $dither[$dithery]->[$ditherx];
                        next unless($factor);
                        next if($deltax < 0 || $deltax >= $destw);
                        next if($deltay < 0 || $deltay >= $desth);
                        my $change = $factor * $quanterror / 16.0;
    
                        #print "## $oldpixel $newpixel $factor $quante
+rror $change\n";
                        $pixels[$deltax]->[$deltay] += $change;
                    }
                }
            }
        }
    
        for(my $y = 0; $y < $desth; $y++) {
            for(my $x = 0; $x < $destw; $x++) {    
                if($pixels[$x]->[$y] < 128) {
                    #print "$x $y ", $pixels[$x]->[$y], "\n";
                    $self->{img}->setPixel($x, $y + $self->{imgoffs}, 
+$self->{imgblack});
                    $cachepic->setPixel($x, $y, $cacheblack);
                }
            }
        }
        
        $self->{imagecache}->{$cachekey} = $cachepic;
    } elsif($imagesoftness == 1) {

        # Dithering  https://en.wikipedia.org/wiki/Error_diffusion#min
+imized_average_error
        my @dither = (
            [0, 0, 0, 7, 5],
            [3, 5, 7, 5, 3],
            [1, 3, 5, 3, 1],
        );
        for(my $y = 0; $y < $desth; $y++) {
            for(my $x = 0; $x < $destw; $x++) {
                my $oldpixel = $pixels[$x]->[$y];
    
                # "Find closed palette/index value
                my $newpixel = 255.0;
                if($oldpixel < 128) {
                    $newpixel = 0.0;
                }
                $pixels[$x]->[$y] = $newpixel;
    
                my $quanterror = $oldpixel - $newpixel;
                for(my $ditherx = 0; $ditherx < 5; $ditherx++) {
                    for(my $dithery = 0; $dithery < 3; $dithery++) {
                        my $deltax = $x + $ditherx - 2;
                        my $deltay = $y + $dithery - 1;
                        my $factor = $dither[$dithery]->[$ditherx];
                        next unless($factor);
                        next if($deltax < 0 || $deltax >= $destw);
                        next if($deltay < 0 || $deltay >= $desth);
                        my $change = $factor * $quanterror / 48.0;
    
                        #print "## $oldpixel $newpixel $factor $quante
+rror $change\n";
                        $pixels[$deltax]->[$deltay] += $change;
                    }
                }
            }
        }
    
        for(my $y = 0; $y < $desth; $y++) {
            for(my $x = 0; $x < $destw; $x++) {    
                if($pixels[$x]->[$y] < 128) {
                    #print "$x $y ", $pixels[$x]->[$y], "\n";
                    $self->{img}->setPixel($x, $y + $self->{imgoffs}, 
+$self->{imgblack});
                    $cachepic->setPixel($x, $y, $cacheblack);
                }
            }
        }
        $self->{imagecache}->{$cachekey} = $cachepic;
    } elsif($imagesoftness == 3) {
    
        my @rawgreys = (
            '0000000000000000',
            '0000000001000000',
            '0000100000100000',
            '0010000001000001',
            '1000001000101000',
            '1010000000010110',
            '0001010001101010',
            '1010110010100100',
            '1010010101101010',
            '1001011001011011',
            '1001011110101101',
            '1101101001111110',
            '1011111001111011',
            '1011011111101111',
            '1111011111101111',
            '1111111110111111',
            '1111111111111111',
        );
        my $levels = scalar @rawgreys;
        my $bitlen = length($rawgreys[0]);
        
        my @greys;
        foreach my $rawgrey (@rawgreys) {
            my @parts = split//, $rawgrey;
            push @greys, \@parts;
        }
        
        for(my $y = 0; $y < $desth; $y++) {
            for(my $x = 0; $x < $destw; $x++) {    
                my $index = $pic->getPixel($x, $y);
                my ($r,$g,$b) = $pic->rgb($index);
                my $greypixel = int(($r+$g+$b)/3);
                my $level = int($greypixel / (255 / $levels));
                
                my $offs = int(rand($bitlen));
                my $bit = $greys[$level]->[($x + $offs) % $bitlen];
                
                if(!$bit) {
                    $self->{img}->setPixel($x, $y + $self->{imgoffs}, 
+$self->{imgblack});
                    $cachepic->setPixel($x, $y, $cacheblack);
                } else {
                }
            }
        }
        
        $self->{imagecache}->{$cachekey} = $cachepic;
    }
    
    $self->{imgoffs} += $desth;
    return;
}

[download]

Dithering by pixel manipulation is painfully slow (it can take multiple seconds per logo). But the software usually runs for days on end and has only a few different logos to deal with, so i did a simple in-memory caching. Once the system is up and running for a few minutes, no more slowdown.

perl -e 'use Crypt::Digest::SHA256 qw[sha256_hex]; print substr(sha256_hex("the Answer To Life, The Universe And Everything"), 6, 2), "\n";'

In Section Seekers of Perl Wisdom