Image::RGBA - Functions for sampling simple RGBA images

Image-RGBA documentation Contained in the Image-RGBA distribution.

Index

Code Index:

NAME

Top

Image::RGBA - Functions for sampling simple RGBA images

SYNOPSIS

Top

'simple', 'bilinear' and 'bicubic' image sampling.

DESCRIPTION

Top

Hides some of the ugly stuff involved when sampling individual pixel values from images. A good range of quality levels are provided, currently; simple, linear and spline16.

For an explanation of what is going on, see:

 http://www.fh-furtwangen.de/~dersch/interpolator/interpolator.html

An RGBA image file is very simple, just each channel stored one after the other with no delimiters for each pixel in turn. There is no header data, so you have to know the image dimensions to reconstruct an RGBA image.

USAGE

Top

You can start by creating an Image::Magick object:

    my $input = new Image::Magick;
    $input->Read ('input.jpg');

Use an Image::Magick object as the basis of an Image::RGBA object:

    my $rgba = new Image::RGBA (sample => 'linear',
                                 image => $input);

Now you can retrieve a string representing the RGBA pixel values of any point in the original image:

    $values = $rgba->Pixel (20.2354, 839.6556);

Additionally, you can write RGBA pixel values directly to an image by appending the values that need to be written:

    $rgba->Pixel (22, 845, $values);

Note that locations for writing need to be integer values.

You can access the image as an Image::Magick object at any time using the Image method:

    $rgba->Image->Write ('filename.jpg');

OPTIONS

Top

SAMPLING TYPES

Note that trying to sample values physically outside of the source image will return a black/transparent pixel value consisting of null bytes.

'simple' sampling is crude non-interpolated pixel sampling, equivalent to the Image::Magick::Get ("pixel[$x,$y]") method. Use this when speed rather than quality is required.

'linear' sampling is fast general purpose pixel sampling, about 3 times slower than 'simple' sampling'. Pixel values are interpolated, so sampling pixel (45.5, 56.6) will get different results to pixel (45, 56).

'spline16' sampling is slow high-quality sampling, about 15 times slower than 'simple' sampling. Interpolated pixel values are just a little bit higher quality than 'linear'.

COPYRIGHT

Top

Copyright (c) 2002 Bruno Postle <bruno@postle.net>. All Rights Reserved. This module is Free Software. It may be used, redistributed and/or modified under the same terms as Perl itself.

Image-RGBA documentation Contained in the Image-RGBA distribution. 
package Image::RGBA;


use strict;
use warnings;

use Image::Magick;

our $VERSION = '0.04';


sub new
{
    my $class = shift;
    $class = ref $class || $class;

    my $params = {@_};

    my $imagemagick = $params->{image};

    my $self;

    # we can get the width and height from the source image

    $self->{height} = $imagemagick->Get('height');
    $self->{width}  = $imagemagick->Get('width');

    # this is the raw rgba data

    $self->{blob} = _imagetoblob ($imagemagick);

    # a sensible default sampling level

    $self->{sample} = $params->{sample} || 'linear';

    bless $self, $class;

    return $self;
}


sub Pixel
{
    my $self = shift;

    my $m = shift;
    my $n = shift;

    if (scalar @_) 
    {
        my $rgba = shift;

        my $pixel_offset = (int ($m) + ($self->{width} * (int ($n) - $self->{height})));

        $self->_set_offset ($pixel_offset, $rgba);

        return;
    };

    my ($r, $g, $b, $a) = $self->_sample ($m, $n);

    return $self->_pack ($r, $g, $b, $a);
}


sub Image
{
    my $self = shift;

    $self->_blobtoimage;
}


sub _sample
{
    my $self = shift;

    my $m = shift;
    my $n = shift;


    return (0, 0, 0, 0)
        if ($m < 0 or $m > $self->{width} or $n < 0 or $n > $self->{height});

    my ($r, $g, $b, $a);

    if ($self->{sample} eq 'simple')
        { ($r, $g, $b, $a) = $self->_simple ($m, $n) }

    elsif ($self->{sample} eq 'linear')
        { ($r, $g, $b, $a) = $self->_linear ($m, $n) }

    elsif ($self->{sample} eq 'spline16')
        { ($r, $g, $b, $a) = $self->_spline16 ($m, $n) }

    return ($r, $g, $b, $a);
}


sub _simple
{
    my $self = shift;

    my $m = shift;
    my $n = shift;

    # find the nearest pixel if it's over the edge of the source image

    $m = 0 if ($m < 0);
    $n = 0 if ($n < 0);
    $m = $self->{width} - 1 if ($m > $self->{width} - 1);
    $n = $self->{height} - 1 if ($n > $self->{height} - 1);

    # get raw rgba value corresponding to $m and $n

    my $pixel_offset = (int ($m) + ($self->{width} * (int ($n) - $self->{height})));

    my $rgba = $self->_get_offset ($pixel_offset);

    $self->_unpack ($rgba);
}


sub _linear
{
    my $self = shift;

    my $m = shift;
    my $n = shift;

    my ($r, $g, $b, $a);

    for my $v (0 .. 1)
    {
        for my $u (0 .. 1)
        {
            my ($r0, $g0, $b0, $a0) = $self->_simple ($m + $u, $n + $v);

            my $weightxy = (1 - abs ($m - int ($m) - $u)) * (1 - abs ($n - int ($n) - $v));

            $r += $r0 * $weightxy;
            $g += $g0 * $weightxy;
            $b += $b0 * $weightxy;
            $a += $a0 * $weightxy;
        }
    }

    return ($r, $g, $b, $a);
}


sub _spline16
{
    my $self = shift;

    my $m = shift;
    my $n = shift;

    my ($r, $g, $b, $a);

    for my $v (-1 .. 2)
    {
        for my $u (-1 .. 2)
        {
            my ($r0, $g0, $b0, $a0) = $self->_simple ($m + $u, $n + $v);

            my $x = abs ($m - int ($m) - $u);
            my $y = abs ($n - int ($n) - $v);

            my ($weightx, $weighty);
           
            if ($x >= 1 && $x <= 2)
            { $weightx = ((((12 - (5 * ($x - 1))) / 15) * ($x - 1)) - (7/15)) * ($x - 1) }

            else
            { $weightx = (((($x - 1.8) * $x) - 0.2) * $x) + 1 }

            if ($y >= 1 && $y <= 2)
            { $weighty = ((((12 - (5 * ($y - 1))) / 15) * ($y - 1)) - (7/15)) * ($y - 1) }

            else
            { $weighty = (((($y - 1.8) * $y) - 0.2) * $y) + 1 }

            my $weightxy = $weightx * $weighty;

            $r += $r0 * $weightxy;
            $g += $g0 * $weightxy;
            $b += $b0 * $weightxy;
            $a += $a0 * $weightxy;
        }
    }

    # fix minor floating point errors, yes this is ugly.
    
    $r += 0.001;
    $g += 0.001;
    $b += 0.001;
    $a += 0.001;

    ($r, $g, $b, $a) = $self->_valid_pixel_values ($r, $g, $b, $a);

    return ($r, $g, $b, $a);
}

# various operations, curve fitting and brightness correction, can create
# non valid <0 >255 values, fix'em.
# 
# FIXME should support other than 1 byte per channel

sub _valid_pixel_values
{
    my $self = shift;

    my ($r, $g, $b, $a) = @_;

    $r = 255 if ($r > 255);
    $g = 255 if ($g > 255);
    $b = 255 if ($b > 255);
    $a = 255 if ($a > 255);

    $r = 0 if ($r < 0);
    $g = 0 if ($g < 0);
    $b = 0 if ($b < 0);
    $a = 0 if ($a < 0);

    return ($r, $g, $b, $a);
}

# take an array of pixel values and return packed bytes
# 
# FIXME should support other than 1 byte per pixel
    
sub _pack
{
    my $self = shift;

    my ($r, $g, $b, $a) = @_;

    pack ("CCCC", int ($r), int ($g), int ($b), int ($a));
}

# take packed bytes and return an array of pixel values
# 
# FIXME should support other than 1 byte per channel

sub _unpack
{
    my $self = shift;

    my $rgba = shift;
    
    map ord (substr $rgba, $_), (0, 1, 2, 3);
}

# retrieve raw bytes for a particular offset
# 
# FIXME should support other than 1 byte per channel

sub _get_offset
{
    my $self = shift;

    my $pixel_offset = shift;

    substr ${$self->{blob}}, 4 * $pixel_offset, 4;
}

# sets and retrieves raw bytes for a particular offset
# 
# FIXME should support other than 1 byte per channel

sub _set_offset
{
    my $self = shift;

    my $pixel_offset = shift;
    my $rgba = shift;

    substr ${$self->{blob}}, 4 * $pixel_offset, 4, $rgba;
}

# only used in new().  converts from imagemagick to a simpler format
# 
# FIXME should support other than 1 byte per pixel

sub _imagetoblob
{
    my $imagemagick = shift;

    $imagemagick->Set (magick => 'RGBA', depth => '8');
    \$imagemagick->ImageToBlob;
}

# used when we have an Image::RGBA object but we really need an
# Image::Magick object
# 
# FIXME should support other than 1 byte per pixel

sub _blobtoimage
{
    my $self = shift;

    my $imagemagick = new Image::Magick (magick => 'RGBA',
                                          depth => '8',
                                           size => $self->{width} ."x". $self->{height});

    $imagemagick->BlobToImage (${$self->{blob}});

    return $imagemagick;
}


1;