package Image::Base ; # Documented at the __END__
use 5.004 ; # 5.004 for __PACKAGE__ special literal
use strict ;
use vars qw( $VERSION ) ;
$VERSION = '1.17' ;
use Carp qw( croak ) ;
# uncomment this to run the ### lines
#use Smart::Comments '###';
# All the supplied methods are expected to be inherited by subclasses; some
# will be adequate, some will need to be overridden and some *must* be
# overridden.
### Private methods
#
# _get object
# _set object
sub _get { # Object method
my $self = shift ;
# my $class = ref( $self ) || $self ;
$self->{shift()} ;
}
sub _set { # Object method
my $self = shift ;
# my $class = ref( $self ) || $self ;
my $field = shift ;
$self->{$field} = shift ;
}
sub DESTROY {
; # Save's time
}
### Public methods
sub new { croak __PACKAGE__ . "::new() must be overridden" }
sub xy { croak __PACKAGE__ . "::xy() must be overridden" }
sub load { croak __PACKAGE__ . "::load() must be overridden" }
sub save { croak __PACKAGE__ . "::save() must be overridden" }
sub set { croak __PACKAGE__ . "::set() must be overridden" }
sub get { # Object method
my $self = shift ;
# my $class = ref( $self ) || $self ;
my @result ;
push @result, $self->_get( shift() ) while @_ ;
wantarray ? @result : shift @result ;
}
sub new_from_image { # Object method
my $self = shift ; # Must be an image to copy
my $class = ref( $self ) || $self ;
my $newclass = shift ; # Class of target taken from class or object
croak "new_from_image() cannot read $class" unless $self->can( 'xy' ) ;
my( $width, $height ) = $self->get( -width, -height ) ;
# If $newclass was an object reference we inherit its characteristics
# except for width/height and any arguments we've supplied.
my $obj = $newclass->new( @_, -width => $width, -height => $height ) ;
croak "new_from_image() cannot convert to " . ref $obj unless $obj->can( 'xy' ) ;
for( my $x = 0 ; $x < $width ; $x++ ) {
for( my $y = 0 ; $y < $height ; $y++ ) {
$obj->xy( $x, $y, $self->xy( $x, $y ) ) ;
}
}
$obj ;
}
sub line { # Object method
my( $self, $x0, $y0, $x1, $y1, $colour ) = @_ ;
# basic Bressenham line drawing
my $dy = abs ($y1 - $y0);
my $dx = abs ($x1 - $x0);
#### $dy
#### $dx
if ($dx >= $dy) {
# shallow slope
( $x0, $y0, $x1, $y1 ) = ( $x1, $y1, $x0, $y0 ) if $x0 > $x1 ;
my $y = $y0 ;
my $ystep = ($y1 > $y0 ? 1 : -1);
my $rem = int($dx/2) - $dx;
for( my $x = $x0 ; $x <= $x1 ; $x++ ) {
#### $rem
$self->xy( $x, $y, $colour ) ;
if (($rem += $dy) >= 0) {
$rem -= $dx;
$y += $ystep;
}
}
} else {
# steep slope
( $x0, $y0, $x1, $y1 ) = ( $x1, $y1, $x0, $y0 ) if $y0 > $y1 ;
my $x = $x0 ;
my $xstep = ($x1 > $x0 ? 1 : -1);
my $rem = int($dy/2) - $dy;
for( my $y = $y0 ; $y <= $y1 ; $y++ ) {
#### $rem
$self->xy( $x, $y, $colour ) ;
if (($rem += $dx) >= 0) {
$rem -= $dy;
$x += $xstep;
}
}
}
}
# Midpoint ellipse algorithm from Computer Graphics Principles and Practice.
#
# The points of the ellipse are
# (x/a)^2 + (y/b)^2 == 1
# or expand out to
# x^2*b^2 + y^2*a^2 == a^2*b^2
#
# The x,y coordinates are taken relative to the centre $ox,$oy, with radials
# $a and $b half the width $x1-x0 and height $y1-$y0. If $x1-$x0 is odd,
# then $ox and $a are not integers but have 0.5 parts. Starting from $x=0.5
# and keeping that 0.5 means the final xy() pixels drawn in
# &$ellipse_point() are integers. Similarly for y.
#
# Only a few lucky pixels exactly satisfy the ellipse equation above. For
# the rest there's an error amount expressed as
#
# E(x,y) = x^2*b^2 + y^2*a^2 - a^2*b^2
#
# The first loop maintains a "discriminator" d1 in $d
#
# d1 = (x+1)^2*b^2 + (y-1/2)^2*a^2 - a^2*b^2
#
# which is E(x+1,y-1/2), being the error amount for the next x+1 position,
# taken at y-1/2 which is the midpoint between the possible next y or y-1
# pixels. When d1 > 0 it means that the y-1/2 position is outside the
# ellipse and the y-1 pixel is taken to be the better approximation to the
# ellipse than y.
#
# The first loop does the four octants near the Y axis, ie. the nearly
# horizontal parts. The second loop does the four octants near the X axis,
# ie. the nearly vertical parts. For the second loop the discriminator in
# $d is instead at the next y-1 position and between x and x+1,
#
# d2 = E(x+1/2,y-1) = (x+1/2)^2*b^2 + (y-1)^2*a^2 - a^2*b^2
#
# The difference between d1 and d2 for the changeover is as follows and is
# used to step across to the new position rather than a full recalculation.
# Not much difference in speed, but less code.
#
# E(x+1/2,y-1) - E(x+1,y-1/2)
# = -b^2 * (x + 3/4) + a^2 * (3/4 - y)
#
# since (x+1/2)^2 - (x+1)^2 = -x - 3/4
# (y-1)^2 - (y-1/2)^2 = -y + 3/4
#
#
# Other Possibilities:
#
# The calculations could be made all-integer by counting $x and $y from 0 at
# the bounding box edges and measuring inwards, rather than outwards from a
# fractional centre. E(x,y) could have a factor of 2 or 4 put through as
# necessary, the discriminating >0 or <0 staying the same. The d1 and d2
# steps are at most roughly 2*max(a*b^2,b*a^2), which for a circle means
# 2*r^3. This fits a 32-bit signed integer for up to about 1000 pixels or
# so, and then of course Perl switches to 53-bit floats automatically, which
# is still an exact integer up to about 160,000 pixels radius.
#
# It'd be possible to draw runs of horizontal pixels with line() instead of
# individual xy() calls. That might help subclasses doing a block-fill for
# a horizontal line segment. Except only big or flat ellipses have more
# than a few adjacent horizontal pixels. Perhaps just the initial topmost
# horizontal, using a sqrt to calculate where it crosses from the top y=b
# down to y=b-1.
#
# The end o the first loop could be pre-calculated (with a sqrt), if that
# seemed better than watching $aa*($y-0.5) vs $bb*($x+1). The loop change
# is where the tangent slope is steeper than -1. Drawing a little diagram
# shows that an x+0,y+1 downward step like in the second loop is not needed
# until that point.
#
# dx/dy = -x*b^2 / y*a^2 = -1 slope
# y = x*b^2/a^2
# b^2*x^2 + a^2*(b^4/a^4)*x^2 = a^2*b^2 into the ellipse equation
# x^2 * (1 + b^2/a^2) = a^2
# x = a * sqrt (a^2 / (a^2 + b^2))
# = a^2 / sqrt (a^2 + b^2)
#
sub ellipse { # Object method
my $self = shift ;
# my $class = ref( $self ) || $self ;
my( $x0, $y0, $x1, $y1, $colour, $fill ) = @_ ;
# per the docs, x0,y0 top left, x1,y1 bottom right
# could relax that fairly easily, if desired ...
### assert: $x0 <= $x1
### assert: $y0 <= $y1
my ($a, $b);
if (($a = ( $x1 - $x0 ) / 2) <= .5
|| ($b = ( $y1 - $y0 ) / 2) <= .5) {
# one or two pixels high or wide, treat as rectangle
$self->rectangle ($x0, $y0, $x1, $y1, $colour );
return;
}
my $aa = $a ** 2 ;
my $bb = $b ** 2 ;
my $ox = ($x0 + $x1) / 2;
my $oy = ($y0 + $y1) / 2;
my $x = $a - int($a) ; # 0 or 0.5
my $y = $b ;
### initial: "origin $ox,$oy start xy $x,$y"
my $ellipse_point =
($fill
? sub {
### ellipse_point fill: "$x,$y"
$self->line( $ox - $x, $oy + $y,
$ox + $x, $oy + $y, $colour ) ;
$self->line( $ox - $x, $oy - $y,
$ox + $x, $oy - $y, $colour ) ;
}
: sub {
### ellipse_point xys: "$x,$y"
$self->xy( $ox + $x, $oy + $y, $colour ) ;
$self->xy( $ox - $x, $oy - $y, $colour ) ;
$self->xy( $ox + $x, $oy - $y, $colour ) ;
$self->xy( $ox - $x, $oy + $y, $colour ) ;
});
# Initially,
# d1 = E(x+1,y-1/2)
# = (x+1)^2*b^2 + (y-1/2)^2*a^2 - a^2*b^2
# which for x=0,y=b is
# = b^2 - a^2*b + a^2/4
# or for x=0.5,y=b
# = 9/4*b^2 - ...
#
my $d = ($x ? 2.25*$bb : $bb) - ( $aa * $b ) + ( $aa / 4 ) ;
while( $y >= 1
&& ( $aa * ( $y - 0.5 ) ) > ( $bb * ( $x + 1 ) ) ) {
### assert: $d == ($x+1)**2 * $bb + ($y-.5)**2 * $aa - $aa * $bb
if( $d < 0 ) {
if (! $fill) {
# unfilled draws each pixel, but filled waits until stepping
# down "--$y" and then draws whole horizontal line
&$ellipse_point();
}
$d += ( $bb * ( ( 2 * $x ) + 3 ) ) ;
++$x ;
}
else {
&$ellipse_point();
$d += ( ( $bb * ( ( 2 * $x ) + 3 ) ) +
( $aa * ( ( -2 * $y ) + 2 ) ) ) ;
++$x ;
--$y ;
}
}
# switch to d2 = E(x+1/2,y-1) by adding E(x+1/2,y-1) - E(x+1,y-1/2)
$d += $aa*(.75-$y) - $bb*($x+.75);
### assert: $d == $bb*($x+0.5)**2 + $aa*($y-1)**2 - $aa*$bb
### second loop at: "$x, $y"
while( $y >= 1 ) {
&$ellipse_point();
if( $d < 0 ) {
$d += ( $bb * ( ( 2 * $x ) + 2 ) ) +
( $aa * ( ( -2 * $y ) + 3 ) ) ;
++$x ;
--$y ;
}
else {
$d += ( $aa * ( ( -2 * $y ) + 3 ) ) ;
--$y ;
}
### assert: $d == $bb*($x+0.5)**2 + $aa*($y-1)**2 - $aa*$bb
}
# loop ends with y=0 or y=0.5 according as the height is odd or even,
# leaving one or two middle rows to draw out to x0 and x1 edges
### assert: $y == $b - int($b)
if ($fill) {
### middle fill: "y ".($oy-$y)." to ".($oy+$y)
$self->rectangle( $x0, $oy - $y,
$x1, $oy + $y,
$colour, 1 ) ;
} else {
# middle tails from $x out to the left/right edges
# $x can be several pixels less than $a if small height large width
### tail: "y=$y, left $x0 to ".($ox-$x).", right ".($ox+$x)." to $x1"
$self->rectangle( $x0, $oy - $y, # left
$ox - $x, $oy + $y,
$colour, 1 ) ;
$self->rectangle( $ox + $x, $oy - $y, # right
$x1, $oy + $y,
$colour, 1 ) ;
}
}
sub rectangle { # Object method
my ($self, $x0, $y0, $x1, $y1, $colour, $fill) = @_;
if ($x0 == $x1) {
# vertical line only
$self->line( $x0, $y0, $x1, $y1, $colour ) ;
} else {
if ($fill) {
for( my $y = $y0 ; $y <= $y1 ; $y++ ) {
$self->line( $x0, $y, $x1, $y, $colour ) ;
}
} else { # unfilled
$self->line( $x0, $y0,
$x1, $y0, $colour ) ; # top
if (++$y0 <= $y1) {
# height >= 2
if ($y0 < $y1) {
# height >= 3, verticals
$self->line( $x0, $y0,
$x0, $y1-1, $colour ) ; # left
$self->line( $x1, $y0,
$x1, $y1-1, $colour ) ; # right
}
$self->line( $x1, $y1,
$x0, $y1, $colour ) ; # bottom
}
}
}
}
sub diamond {
my ($self, $x1,$y1, $x2,$y2, $colour, $fill) = @_;
### diamond(): "$x1,$y1, $x2,$y2, $colour fill=".($fill||0)
### assert: $x2 >= $x1
### assert: $y2 >= $y1
my $w = $x2 - $x1;
my $h = $y2 - $y1;
if ($w < 2 || $h < 2) {
$self->rectangle ($x1,$y1, $x2,$y2, $colour, 1);
return;
}
$w = int ($w / 2);
$h = int ($h / 2);
my $x = $w; # middle
my $y = 0; # top
### $w
### $h
### x1+x: $x1+$w
### x2-x: $x2-$w
### y1+y: $y1+$h
### y2-y: $y2-$h
my $draw;
if ($fill) {
$draw = sub {
### draw across: "$x,$y"
$self->line ($x1+$x,$y1+$y, $x2-$x,$y1+$y, $colour); # upper
$self->line ($x1+$x,$y2-$y, $x2-$x,$y2-$y, $colour); # lower
};
} else {
$draw = sub {
### draw: "$x,$y"
$self->xy ($x1+$x,$y1+$y, $colour); # upper left
$self->xy ($x2-$x,$y1+$y, $colour); # upper right
$self->xy ($x1+$x,$y2-$y, $colour); # lower left
$self->xy ($x2-$x,$y2-$y, $colour); # lower right
};
}
if ($w > $h) {
### shallow ...
my $rem = int($w/2) - $w;
### $rem
while ($x > 0) {
### at: "x=$x rem=$rem"
if (($rem += $h) >= 0) {
&$draw();
$y++;
$rem -= $w;
$x--;
} else {
if (! $fill) { &$draw() }
$x--;
}
}
} else {
### steep ...
# when $h is odd bias towards pointier at the narrower top/bottom ends
my $rem = int(($h-1)/2) - $h;
### $rem
while ($y < $h) {
### $rem
&$draw();
if (($rem += $w) >= 0) {
$rem -= $h;
$x--;
### x inc to: "x=$x rem $rem"
}
$y++;
}
}
### final: "$x,$y"
# middle row if $h odd, or middle two rows if $h even
# done explicitly rather than with &$draw() so as not to draw the middle
# row twice when $h odd
if ($fill) {
$self->rectangle ($x1,$y1+$h, $x2,$y2-$h, $colour, 1);
} else {
$self->rectangle ($x1,$y1+$h, $x1+$x,$y2-$h, $colour, 1); # left
$self->rectangle ($x2-$x,$y1+$h, $x2,$y2-$h, $colour, 1); # right
}
}
sub add_colours {
# my ($self, $colour, $colour, ...) = @_;
}
1 ;
__END__
=head1 NAME
Image::Base - base class for loading, manipulating and saving images.
=head1 SYNOPSIS
# base class only
package My::Image::Class;
use base 'Image::Base';
=head1 DESCRIPTION
This is a base class for image. It shouldn't be used directly. Known
inheritors are C and C and in see L
below.
use Image::Xpm ;
my $i = Image::Xpm->new( -file => 'test.xpm' ) ;
$i->line( 1, 1, 3, 7, 'red' ) ;
$i->ellipse( 3, 3, 6, 7, '#ff00cc' ) ;
$i->rectangle( 4, 2, 9, 8, 'blue' ) ;
Subclasses like C and C are stand-alone Perl code
implementations of the respective formats. They're good for drawing and
manipulating image files with a modest amount of code and dependencies.
Other inheritors like C are front-ends to big image
libraries. They can be handy for pointing generic C style code
at a choice of modules and supported file formats. Some inheritors like
C even go to a window etc for direct
display.
=head2 More Methods
If you want to create your own algorithms to manipulate images in terms of
(x,y,colour) then you could extend this class (without changing the file),
like this:
# Filename: mylibrary.pl
package Image::Base ; # Switch to this class to build on it.
sub mytransform {
my $self = shift ;
my $class = ref( $self ) || $self ;
# Perform your transformation here; might be drawing a line or filling
# a rectangle or whatever... getting/setting pixels using $self->xy().
}
package main ; # Switch back to the default package.
Now if you C mylibrary.pl after you've C