diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/GD')
-rwxr-xr-x | Master/tlpkg/tlperl/lib/GD/Group.pm | 33 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/GD/Image.pm | 200 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/GD/Polygon.pm | 183 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/GD/Polyline.pm | 792 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/GD/Simple.pm | 1236 |
5 files changed, 2444 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/GD/Group.pm b/Master/tlpkg/tlperl/lib/GD/Group.pm new file mode 100755 index 00000000000..93506bb3bc1 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/GD/Group.pm @@ -0,0 +1,33 @@ +package GD::Group; + +# Simple object for recursive grouping. Does absolutely nothing with GD, +# but works nicely with GD::SVG. + +use strict; + +our $AUTOLOAD; +our $VERSION = 1.00; + +sub AUTOLOAD { + my ($pack,$func_name) = $AUTOLOAD =~ /(.+)::([^:]+)$/; + my $this = shift; + $this->{gd}->currentGroup($this->{group}); + $this->{gd}->$func_name(@_); +} + +sub new { + my $this = shift; + my ($gd,$group) = @_; + return bless {gd => $gd, + group => $group},ref $this || $this; +} + +sub DESTROY { + my $this = shift; + my $gd = $this->{gd}; + my $grp = $this->{group}; + $gd->endGroup($grp); +} + + +1; diff --git a/Master/tlpkg/tlperl/lib/GD/Image.pm b/Master/tlpkg/tlperl/lib/GD/Image.pm new file mode 100755 index 00000000000..bbeaadc6a87 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/GD/Image.pm @@ -0,0 +1,200 @@ +# DO NOT EDIT! THIS FILE IS AUTOGENERATED BY GD/Image.pm.PLS +package GD::Image; + +use strict; +use GD; +use Symbol 'gensym','qualify_to_ref'; +use vars '$VERSION'; +$VERSION = '2.38'; + +=head1 NAME + +GD::Image - Image class for the GD image library + +=head1 SYNOPSIS + +See L<GD> + +=head1 DESCRIPTION + +See L<GD> + +=head1 AUTHOR + +The GD.pm interface is copyright 1995-2005, Lincoln D. Stein. It is +distributed under the same terms as Perl itself. See the "Artistic +License" in the Perl source code distribution for licensing terms. + +The latest versions of GD.pm are available on CPAN: + + http://www.cpan.org + +=head1 SEE ALSO + +L<GD> +L<GD::Polyline>, +L<GD::SVG>, +L<GD::Simple>, +L<Image::Magick> + +=cut + +# Copyright 1995 Lincoln D. Stein. See accompanying README file for +# usage information + +*stringTTF = \&GD::Image::stringFT; + +sub _make_filehandle { + shift; # get rid of class + no strict 'refs'; + my $thing = shift; + return $thing if defined(fileno $thing); + + # otherwise try qualifying it into caller's package + my $fh; + { + local $^W = 0; # to avoid uninitialized variable warning from Symbol.pm + $fh = qualify_to_ref($thing,caller(2)); + } + return $fh if defined(fileno $fh); + + # otherwise treat it as a file to open + $fh = gensym; + open($fh,$thing) || return; + return $fh; +} + +sub new { + my $pack = shift; + if (@_ == 1) { + if (my $type = _image_type($_[0])) { + my $method = "newFrom${type}Data"; + return unless $pack->can($method); + return $pack->$method($_[0]); + } + return unless my $fh = $pack->_make_filehandle($_[0]); + my $magic; + return unless read($fh,$magic,4); + return unless my $type = _image_type($magic); + seek($fh,0,0); + my $method = "newFrom${type}"; + return $pack->$method($fh); + } + return $pack->_new(@_); +} + +sub newTrueColor { + my $pack = shift; + return $pack->_new(@_, 1); +} + +sub newPalette { + my $pack = shift; + return $pack->_new(@_, 0); +} + +sub newFromGd { + croak("Usage: newFromGd(class,filehandle)") unless @_==2; + my($class,$f) = @_; + my $fh = $class->_make_filehandle($f); + binmode($fh); + $class->_newFromGd($fh); +} + +sub newFromGd2 { + croak("Usage: newFromGd2(class,filehandle)") unless @_==2; + my($class,$f) = @_; + my $fh = $class->_make_filehandle($f); + binmode($fh); + $class->_newFromGd2($fh); +} + +sub newFromGd2Part { + croak("Usage: newFromGd2(class,filehandle,srcX,srcY,width,height)") unless @_==6; + my($class,$f) = splice(@_,0,2); + my $fh = $class->_make_filehandle($f); + binmode($fh); + $class->_newFromGd2Part($fh,@_); +} + +sub ellipse ($$$$$) { + my ($self,$cx,$cy,$width,$height,$color) = @_; + $self->arc($cx,$cy,$width,$height,0,360,$color); +} + +# draws closed polygon with the specified color +sub polygon { + my $self = shift; + my($p,$c) = @_; + $self->openPolygon($p, $c); + $self->line( @{$p->{'points'}->[0]}, + @{$p->{'points'}->[$p->{'length'}-1]}, $c); +} + +sub width { + my $self = shift; + my @bounds = $self->getBounds; + $bounds[0]; +} + +sub height { + my $self = shift; + my @bounds = $self->getBounds; + $bounds[1]; +} + +sub _image_type { + my $data = shift; + my $magic = substr($data,0,4); + return 'Png' if $magic eq "\x89PNG"; + return 'Jpeg' if $magic eq "\377\330\377\340"; + return 'Jpeg' if $magic eq "\377\330\377\341"; + return 'Jpeg' if $magic eq "\377\330\377\355"; + return 'Jpeg' if $magic eq "\377\330\377\356"; + return 'Gif' if $magic eq "GIF8"; + return 'Gd2' if $magic eq "gd2\000"; + return 'Xpm' if substr($data,0,9) eq "/* XPM */"; + return; +} + + +sub clone { + croak("Usage: clone(\$image)") unless @_ == 1; + my $self = shift; + my ($x,$y) = $self->getBounds; + my $new = $self->new($x,$y); + return unless $new; + $new->copy($self,0,0,0,0,$x,$y); + return $new; +} + +sub newFromPng { + croak("Usage: newFromPng(class,filehandle,[truecolor])") unless @_>=2; + my($class) = shift; + my($f) = shift; + my $fh = $class->_make_filehandle($f); + binmode($fh); + $class->_newFromPng($fh,@_); +} + +sub newFromJpeg { + croak("Usage: newFromJpeg(class,filehandle,[truecolor])") unless @_>=2; + my($class) = shift; + my($f) = shift; + my $fh = $class->_make_filehandle($f); + binmode($fh); + $class->_newFromJpeg($fh,@_); +} + +sub newFromGif { + croak("Usage: newFromGif(class,filehandle,[truecolor])") unless @_>=2; + my($class) = shift; + my($f) = shift; + my $fh = $class->_make_filehandle($f); + binmode($fh); + $class->_newFromGif($fh,@_); +} + +# Autoload methods go after __END__, and are processed by the autosplit program. +1; +__END__ diff --git a/Master/tlpkg/tlperl/lib/GD/Polygon.pm b/Master/tlpkg/tlperl/lib/GD/Polygon.pm new file mode 100755 index 00000000000..42319b266fe --- /dev/null +++ b/Master/tlpkg/tlperl/lib/GD/Polygon.pm @@ -0,0 +1,183 @@ +package GD::Polygon; + +use strict; +use Carp 'carp'; +use GD; + +# old documentation error +*GD::Polygon::delete = \&deletePt; + +=head1 NAME + +GD::Polygon - Polygon class for the GD image library + +=head1 SYNOPSIS + +See L<GD> + +=head1 DESCRIPTION + +See L<GD> + +=head1 AUTHOR + +The GD.pm interface is copyright 1995-2005, Lincoln D. Stein. It is +distributed under the same terms as Perl itself. See the "Artistic +License" in the Perl source code distribution for licensing terms. + +The latest versions of GD.pm are available on CPAN: + + http://www.cpan.org + +=head1 SEE ALSO + +L<GD> +L<GD::Polyline>, +L<GD::SVG>, +L<GD::Simple>, +L<Image::Magick> + +=cut + +### The polygon object ### +# create a new polygon +sub new { + my $class = shift; + return bless { 'length'=>0,'points'=>[] },$class; +} + +# automatic destruction of the polygon +sub DESTROY { + my $self = shift; + undef $self->{'points'}; +} + +sub clear { + my $self = shift; + $self->{'points'} = []; +} + +# add an x,y vertex to the polygon +sub addPt { + my($self,$x,$y) = @_; + push(@{$self->{'points'}},[$x,$y]); + $self->{'length'}++; +} + +# get a vertex +sub getPt { + my($self,$index) = @_; + return () unless ($index>=0) && ($index<$self->{'length'}); + return @{$self->{'points'}->[$index]}; +} + +# change the value of a vertex +sub setPt { + my($self,$index,$x,$y) = @_; + unless (($index>=0) && ($index<$self->{'length'})) { + carp "Attempt to set an undefined polygon vertex"; + return undef; + } + @{$self->{'points'}->[$index]} = ($x,$y); + 1; +} + +# return the total number of vertices +sub length { + my $self = shift; + return $self->{'length'}; +} + +# return the array of vertices. +# each vertex is an two-member (x,y) array +sub vertices { + my $self = shift; + return @{$self->{'points'}}; +} + +# return the bounding box of the polygon +# (smallest rectangle that contains it) +sub bounds { + my $self = shift; + my($top,$bottom,$left,$right) = @_; + $top = 99999999; + $bottom =-99999999; + $left = 99999999; + $right = -99999999; + my $v; + foreach $v ($self->vertices) { + $left = $v->[0] if $left > $v->[0]; + $right = $v->[0] if $right < $v->[0]; + $top = $v->[1] if $top > $v->[1]; + $bottom = $v->[1] if $bottom < $v->[1]; + } + return ($left,$top,$right,$bottom); +} + +# delete a vertex, returning it, just for fun +sub deletePt { + my($self,$index) = @_; + unless (($index>=0) && ($index<@{$self->{'points'}})) { + carp "Attempt to delete an undefined polygon vertex"; + return undef; + } + my($vertex) = splice(@{$self->{'points'}},$index,1); + $self->{'length'}--; + return @$vertex; + } + +# translate the polygon in space by deltaX and deltaY +sub offset { + my($self,$dh,$dv) = @_; + my $size = $self->length; + my($i); + for ($i=0;$i<$size;$i++) { + my($x,$y)=$self->getPt($i); + $self->setPt($i,$x+$dh,$y+$dv); + } +} + +# map the polygon from sourceRect to destRect, +# translating and resizing it if necessary +sub map { + my($self,$srcL,$srcT,$srcR,$srcB,$destL,$destT,$destR,$destB) = @_; + my($factorV) = ($destB-$destT)/($srcB-$srcT); + my($factorH) = ($destR-$destL)/($srcR-$srcL); + my($vertices) = $self->length; + my($i); + for ($i=0;$i<$vertices;$i++) { + my($x,$y) = $self->getPt($i); + $x = int($destL + ($x - $srcL) * $factorH); + $y = int($destT + ($y - $srcT) * $factorV); + $self->setPt($i,$x,$y); + } +} + +# These routines added by Winfriend Koenig. +sub toPt { + my($self, $dx, $dy) = @_; + unless ($self->length > 0) { + $self->addPt($dx,$dy); + return; + } + my ($x, $y) = $self->getPt($self->length-1); + $self->addPt($x+$dx,$y+$dy); +} + +sub transform($$$$$$$) { + # see PostScript Ref. page 154 + my($self, $a, $b, $c, $d, $tx, $ty) = @_; + my $size = $self->length; + for (my $i=0;$i<$size;$i++) { + my($x,$y)=$self->getPt($i); + $self->setPt($i, $a*$x+$c*$y+$tx, $b*$x+$d*$y+$ty); + } +} + +sub scale { + my($self, $sx, $sy, $cx, $cy) = @_; + $self->offset(-$cx,-$cy) if defined $cx or defined $cy; + $self->transform($sx,0,0,$sy,$cx,$cy); +} + +1; diff --git a/Master/tlpkg/tlperl/lib/GD/Polyline.pm b/Master/tlpkg/tlperl/lib/GD/Polyline.pm new file mode 100755 index 00000000000..3b5dcb7ce71 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/GD/Polyline.pm @@ -0,0 +1,792 @@ +############################################################################ +# +# Polyline.pm +# +# Author: Dan Harasty +# Email: harasty@cpan.org +# Version: 0.2 +# Date: 2002/08/06 +# +# For usage documentation: see POD at end of file +# +# For changes: see "Changes" file included with distribution +# + +use strict; + +package GD::Polyline; + +############################################################################ +# +# GD::Polyline +# +############################################################################ +# +# What's this? A class with nothing but a $VERSION and and @ISA? +# Below, this module overrides and adds several modules to +# the parent class, GD::Polygon. Those updated/new methods +# act on polygons and polylines, and sometimes those behaviours +# vary slightly based on whether the object is a polygon or polyine. +# + +use vars qw($VERSION @ISA); +$VERSION = "0.2"; +@ISA = qw(GD::Polygon); + + +package GD::Polygon; + +############################################################################ +# +# new methods on GD::Polygon +# +############################################################################ + +use GD; +use Carp 'croak','carp'; + +use vars qw($bezSegs $csr); +$bezSegs = 20; # number of bezier segs -- number of segments in each portion of the spline produces by toSpline() +$csr = 1/3; # control seg ratio -- the one possibly user-tunable parameter in the addControlPoints() algorithm + + +sub rotate { + my ($self, $angle, $cx, $cy) = @_; + $self->offset(-$cx,-$cy) if $cx or $cy; + $self->transform(cos($angle),sin($angle),-sin($angle),cos($angle),$cx,$cy); +} + +sub centroid { + my ($self, $scale) = @_; + my ($cx,$cy); + $scale = 1 unless defined $scale; + + map {$cx += $_->[0]; $cy += $_->[1]} $self->vertices(); + + $cx *= $scale / $self->length(); + $cy *= $scale / $self->length(); + + return ($cx, $cy); +} + + +sub segLength { + my $self = shift; + my @points = $self->vertices(); + + my ($p1, $p2, @segLengths); + + $p1 = shift @points; + + # put the first vertex on the end to "close" a polygon, but not a polyline + push @points, $p1 unless $self->isa('GD::Polyline'); + + while ($p2 = shift @points) { + push @segLengths, _len($p1, $p2); + $p1 = $p2; + } + + return @segLengths if wantarray; + + my $sum; + map {$sum += $_} @segLengths; + return $sum; +} + +sub segAngle { + my $self = shift; + my @points = $self->vertices(); + + my ($p1, $p2, @segAngles); + + $p1 = shift @points; + + # put the first vertex on the end to "close" a polygon, but not a polyline + push @points, $p1 unless $self->isa('GD::Polyline'); + + while ($p2 = shift @points) { + push @segAngles, _angle_reduce2(_angle($p1, $p2)); + $p1 = $p2; + } + + return @segAngles; +} + +sub vertexAngle { + my $self = shift; + my @points = $self->vertices(); + + my ($p1, $p2, $p3, @vertexAngle); + + $p1 = $points[$#points]; # last vertex + $p2 = shift @points; # current point -- the first vertex + + # put the first vertex on the end to "close" a polygon, but not a polyline + push @points, $p2 unless $self->isa('GD::Polyline'); + + while ($p3 = shift @points) { + push @vertexAngle, _angle_reduce2(_angle($p1, $p2, $p3)); + ($p1, $p2) = ($p2, $p3); + } + + $vertexAngle[0] = undef if defined $vertexAngle[0] and $self->isa("GD::Polyline"); + + return @vertexAngle if wantarray; + +} + + + +sub toSpline { + my $self = shift; + my @points = $self->vertices(); + + # put the first vertex on the end to "close" a polygon, but not a polyline + push @points, [$self->getPt(0)] unless $self->isa('GD::Polyline'); + + unless (@points > 1 and @points % 3 == 1) { + carp "Attempt to call toSpline() with invalid set of control points"; + return undef; + } + + my ($ap1, $dp1, $dp2, $ap2); # ap = anchor point, dp = director point + $ap1 = shift @points; + + my $bez = new ref($self); + + $bez->addPt(@$ap1); + + while (@points) { + ($dp1, $dp2, $ap2) = splice(@points, 0, 3); + + for (1..$bezSegs) { + my ($t0, $t1, $c1, $c2, $c3, $c4, $x, $y); + + $t1 = $_/$bezSegs; + $t0 = (1 - $t1); + + # possible optimization: + # these coefficient could be calculated just once and + # cached in an array for a given value of $bezSegs + + $c1 = $t0 * $t0 * $t0; + $c2 = 3 * $t0 * $t0 * $t1; + $c3 = 3 * $t0 * $t1 * $t1; + $c4 = $t1 * $t1 * $t1; + + $x = $c1 * $ap1->[0] + $c2 * $dp1->[0] + $c3 * $dp2->[0] + $c4 * $ap2->[0]; + $y = $c1 * $ap1->[1] + $c2 * $dp1->[1] + $c3 * $dp2->[1] + $c4 * $ap2->[1]; + + $bez->addPt($x, $y); + } + + $ap1 = $ap2; + } + + # remove the last anchor point if this is a polygon -- since it will autoclose without it + $bez->deletePt($bez->length()-1) unless $self->isa('GD::Polyline'); + + return $bez; +} + +sub addControlPoints { + my $self = shift; + my @points = $self->vertices(); + + unless (@points > 1) { + carp "Attempt to call addControlPoints() with too few vertices in polyline"; + return undef; + } + + my $points = scalar(@points); + my @segAngles = $self->segAngle(); + my @segLengths = $self->segLength(); + + my ($prevLen, $nextLen, $prevAngle, $thisAngle, $nextAngle); + my ($controlSeg, $pt, $ptX, $ptY, @controlSegs); + + # this loop goes about creating polylines -- here called control segments -- + # that hold the control points for the final set of control points + + # each control segment has three points, and these are colinear + + # the first and last will ultimately be "director points", and + # the middle point will ultimately be an "anchor point" + + for my $i (0..$#points) { + + $controlSeg = new GD::Polyline; + + $pt = $points[$i]; + ($ptX, $ptY) = @$pt; + + if ($self->isa('GD::Polyline') and ($i == 0 or $i == $#points)) { + $controlSeg->addPt($ptX, $ptY); # director point + $controlSeg->addPt($ptX, $ptY); # anchor point + $controlSeg->addPt($ptX, $ptY); # director point + next; + } + + $prevLen = $segLengths[$i-1]; + $nextLen = $segLengths[$i]; + $prevAngle = $segAngles[$i-1]; + $nextAngle = $segAngles[$i]; + + # make a control segment with control points (director points) + # before and after the point from the polyline (anchor point) + + $controlSeg->addPt($ptX - $csr * $prevLen, $ptY); # director point + $controlSeg->addPt($ptX , $ptY); # anchor point + $controlSeg->addPt($ptX + $csr * $nextLen, $ptY); # director point + + # note that: + # - the line is parallel to the x-axis, as the points have a common $ptY + # - the points are thus clearly colinear + # - the director point is a distance away from the anchor point in proportion to the length of the segment it faces + + # now, we must come up with a reasonable angle for the control seg + # first, "unwrap" $nextAngle w.r.t. $prevAngle + $nextAngle -= 2*pi() until $nextAngle < $prevAngle + pi(); + $nextAngle += 2*pi() until $nextAngle > $prevAngle - pi(); + # next, use seg lengths as an inverse weighted average + # to "tip" the control segment toward the *shorter* segment + $thisAngle = ($nextAngle * $prevLen + $prevAngle * $nextLen) / ($prevLen + $nextLen); + + # rotate the control segment to $thisAngle about it's anchor point + $controlSeg->rotate($thisAngle, $ptX, $ptY); + + } continue { + # save the control segment for later + push @controlSegs, $controlSeg; + + } + + # post process + + my $controlPoly = new ref($self); + + # collect all the control segments' points in to a single control poly + + foreach my $cs (@controlSegs) { + foreach my $pt ($cs->vertices()) { + $controlPoly->addPt(@$pt); + } + } + + # final clean up based on poly type + + if ($controlPoly->isa('GD::Polyline')) { + # remove the first and last control point + # since they are director points ... + $controlPoly->deletePt(0); + $controlPoly->deletePt($controlPoly->length()-1); + } else { + # move the first control point to the last control point + # since it is supposed to end with two director points ... + $controlPoly->addPt($controlPoly->getPt(0)); + $controlPoly->deletePt(0); + } + + return $controlPoly; +} + + +# The following helper functions are for internal +# use of this module. Input arguments of "points" +# refer to an array ref of two numbers, [$x, $y] +# as is used internally in the GD::Polygon +# +# _len() +# Find the length of a segment, passing in two points. +# Internal function; NOT a class or object method. +# +sub _len { +# my ($p1, $p2) = @_; +# return sqrt(($p2->[0]-$p1->[0])**2 + ($p2->[1]-$p1->[1])**2); + my $pt = _subtract(@_); + return sqrt($pt->[0] ** 2 + $pt->[1] **2); +} + +use Math::Trig; + +# _angle() +# Find the angle of... well, depends on the number of arguments: +# - one point: the angle from x-axis to the point (origin is the center) +# - two points: the angle of the vector defined from point1 to point2 +# - three points: +# Internal function; NOT a class or object method. +# +sub _angle { + my ($p1, $p2, $p3) = @_; + my $angle = undef; + if (@_ == 1) { + return atan2($p1->[1], $p1->[0]); + } + if (@_ == 2) { + return _angle(_subtract($p1, $p2)); + } + if (@_ == 3) { + return _angle(_subtract($p2, $p3)) - _angle(_subtract($p2, $p1)); + } +} + +# _subtract() +# Find the difference of two points; returns a point. +# Internal function; NOT a class or object method. +# +sub _subtract { + my ($p1, $p2) = @_; +# print(_print_point($p2), "-", _print_point($p1), "\n"); + return [$p2->[0]-$p1->[0], $p2->[1]-$p1->[1]]; +} + +# _print_point() +# Returns a string suitable for displaying the value of a point. +# Internal function; NOT a class or object method. +# +sub _print_point { + my ($p1) = @_; + return "[" . join(", ", @$p1) . "]"; +} + +# _angle_reduce1() +# "unwraps" angle to interval -pi < angle <= +pi +# Internal function; NOT a class or object method. +# +sub _angle_reduce1 { + my ($angle) = @_; + $angle += 2 * pi() while $angle <= -pi(); + $angle -= 2 * pi() while $angle > pi(); + return $angle; +} + +# _angle_reduce2() +# "unwraps" angle to interval 0 <= angle < 2 * pi +# Internal function; NOT a class or object method. +# +sub _angle_reduce2 { + my ($angle) = @_; + $angle += 2 * pi() while $angle < 0; + $angle -= 2 * pi() while $angle >= 2 * pi(); + return $angle; +} + +############################################################################ +# +# new methods on GD::Image +# +############################################################################ + +sub GD::Image::polyline { + my $self = shift; # the GD::Image + my $p = shift; # the GD::Polyline (or GD::Polygon) + my $c = shift; # the color + + my @points = $p->vertices(); + my $p1 = shift @points; + my $p2; + while ($p2 = shift @points) { + $self->line(@$p1, @$p2, $c); + $p1 = $p2; + } +} + +sub GD::Image::polydraw { + my $self = shift; # the GD::Image + my $p = shift; # the GD::Polyline or GD::Polygon + my $c = shift; # the color + + return $self->polyline($p, $c) if $p->isa('GD::Polyline'); + return $self->polygon($p, $c); +} + + +1; +__END__ + +=pod + +=head1 NAME + +GD::Polyline - Polyline object and Polygon utilities (including splines) for use with GD + +=head1 SYNOPSIS + + use GD; + use GD::Polyline; + + # create an image + $image = new GD::Image (500,300); + $white = $image->colorAllocate(255,255,255); + $black = $image->colorAllocate( 0, 0, 0); + $red = $image->colorAllocate(255, 0, 0); + + # create a new polyline + $polyline = new GD::Polyline; + + # add some points + $polyline->addPt( 0, 0); + $polyline->addPt( 0,100); + $polyline->addPt( 50,125); + $polyline->addPt(100, 0); + + # polylines can use polygon methods (and vice versa) + $polyline->offset(200,100); + + # rotate 60 degrees, about the centroid + $polyline->rotate(3.14159/3, $polyline->centroid()); + + # scale about the centroid + $polyline->scale(1.5, 2, $polyline->centroid()); + + # draw the polyline + $image->polydraw($polyline,$black); + + # create a spline, which is also a polyine + $spline = $polyline->addControlPoints->toSpline; + $image->polydraw($spline,$red); + + # output the png + binmode STDOUT; + print $image->png; + +=head1 DESCRIPTION + +B<Polyline.pm> extends the GD module by allowing you to create polylines. Think +of a polyline as "an open polygon", that is, the last vertex is not connected +to the first vertex (unless you expressly add the same value as both points). + +For the remainder of this doc, "polyline" will refer to a GD::Polyline, +"polygon" will refer to a GD::Polygon that is not a polyline, and +"polything" and "$poly" may be either. + +The big feature added to GD by this module is the means +to create splines, which are approximations to curves. + +=head1 The Polyline Object + +GD::Polyline defines the following class: + +=over 5 + +=item C<GD::Polyline> + +A polyline object, used for storing lists of vertices prior to +rendering a polyline into an image. + +=item C<new> + +C<GD::Polyline-E<gt>new> I<class method> + +Create an empty polyline with no vertices. + + $polyline = new GD::Polyline; + + $polyline->addPt( 0, 0); + $polyline->addPt( 0,100); + $polyline->addPt( 50,100); + $polyline->addPt(100, 0); + + $image->polydraw($polyline,$black); + +In fact GD::Polyline is a subclass of GD::Polygon, +so all polygon methods (such as B<offset> and B<transform>) +may be used on polylines. +Some new methods have thus been added to GD::Polygon (such as B<rotate>) +and a few updated/modified/enhanced (such as B<scale>) I<in this module>. +See section "New or Updated GD::Polygon Methods" for more info. + +=back + +Note that this module is very "young" and should be +considered subject to change in future releases, and/or +possibly folded in to the existing polygon object and/or GD module. + +=head1 Updated Polygon Methods + +The following methods (defined in GD.pm) are OVERRIDDEN if you use this module. + +All effort has been made to provide 100% backward compatibility, but if you +can confirm that has not been achieved, please consider that a bug and let the +the author of Polyline.pm know. + +=over 5 + +=item C<scale> + +C<$poly-E<gt>scale($sx, $sy, $cx, $cy)> I<object method -- UPDATE to GD::Polygon::scale> + +Scale a polything in along x-axis by $sx and along the y-axis by $sy, +about centery point ($cx, $cy). + +Center point ($cx, $cy) is optional -- if these are omitted, the function +will scale about the origin. + +To flip a polything, use a scale factor of -1. For example, to +flip the polything top to bottom about line y = 100, use: + + $poly->scale(1, -1, 0, 100); + +=back + +=head1 New Polygon Methods + +The following methods are added to GD::Polygon, and thus can be used +by polygons and polylines. + +Don't forget: a polyline is a GD::Polygon, so GD::Polygon methods +like offset() can be used, and they can be used in +GD::Image methods like filledPolygon(). + +=over 5 + +=item C<rotate> + +C<$poly-E<gt>rotate($angle, $cx, $cy)> I<object method> + +Rotate a polything through $angle (clockwise, in radians) about center point ($cx, $cy). + +Center point ($cx, $cy) is optional -- if these are omitted, the function +will rotate about the origin + +In this function and other angle-oriented functions in GD::Polyline, +positive $angle corrensponds to clockwise rotation. This is opposite +of the usual Cartesian sense, but that is because the raster is opposite +of the usual Cartesian sense in that the y-axis goes "down". + +=item C<centroid> + +C<($cx, $cy) = $poly-E<gt>centroid($scale)> I<object method> + +Calculate and return ($cx, $cy), the centroid of the vertices of the polything. +For example, to rotate something 180 degrees about it's centroid: + + $poly->rotate(3.14159, $poly->centroid()); + +$scale is optional; if supplied, $cx and $cy are multiplied by $scale +before returning. The main use of this is to shift an polything to the +origin like this: + + $poly->offset($poly->centroid(-1)); + +=item C<segLength> + +C<@segLengths = $poly-E<gt>segLength()> I<object method> + +In array context, returns an array the lengths of the segments in the polything. +Segment n is the segment from vertex n to vertex n+1. +Polygons have as many segments as vertices; polylines have one fewer. + +In a scalar context, returns the sum of the array that would have been returned +in the array context. + +=item C<segAngle> + +C<@segAngles = $poly-E<gt>segAngle()> I<object method> + +Returns an array the angles of each segment from the x-axis. +Segment n is the segment from vertex n to vertex n+1. +Polygons have as many segments as vertices; polylines have one fewer. + +Returned angles will be on the interval 0 <= $angle < 2 * pi and +angles increase in a clockwise direction. + +=item C<vertexAngle> + +C<@vertexAngles = $poly-E<gt>vertexAngle()> I<object method> + +Returns an array of the angles between the segment into and out of each vertex. +For polylines, the vertex angle at vertex 0 and the last vertex are not defined; +however $vertexAngle[0] will be undef so that $vertexAngle[1] will correspond to +vertex 1. + +Returned angles will be on the interval 0 <= $angle < 2 * pi and +angles increase in a clockwise direction. + +Note that this calculation does not attempt to figure out the "interior" angle +with respect to "inside" or "outside" the polygon, but rather, +just the angle between the adjacent segments +in a clockwise sense. Thus a polygon with all right angles will have vertex +angles of either pi/2 or 3*pi/2, depending on the way the polygon was "wound". + +=item C<toSpline> + +C<$poly-E<gt>toSpline()> I<object method & factory method> + +Create a new polything which is a reasonably smooth curve +using cubic spline algorithms, often referred to as Bezier +curves. The "source" polything is called the "control polything". +If it is a polyline, the control polyline must +have 4, 7, 10, or some number of vertices of equal to 3n+1. +If it is a polygon, the control polygon must +have 3, 6, 9, or some number of vertices of equal to 3n. + + $spline = $poly->toSpline(); + $image->polydraw($spline,$red); + +In brief, groups of four points from the control polyline +are considered "control +points" for a given portion of the spline: the first and +fourth are "anchor points", and the spline passes through +them; the second and third are "director points". The +spline does not pass through director points, however the +spline is tangent to the line segment from anchor point to +adjacent director point. + +The next portion of the spline reuses the previous portion's +last anchor point. The spline will have a cusp +(non-continuous slope) at an anchor point, unless the anchor +points and its adjacent director point are colinear. + +In the current implementation, toSpline() return a fixed +number of segments in the returned polyline per set-of-four +control points. In the future, this and other parameters of +the algorithm may be configurable. + +=item C<addControlPoints> + +C<$polyline-E<gt>addControlPoints()> I<object method & factory method> + +So you say: "OK. Splines sound cool. But how can I +get my anchor points and its adjacent director point to be +colinear so that I have a nice smooth curves from my +polyline?" Relax! For The Lazy: addControlPoints() to the +rescue. + +addControlPoints() returns a polyline that can serve +as the control polyline for toSpline(), which returns +another polyline which is the spline. Is your head spinning +yet? Think of it this way: + +=over 5 + +=item + + +If you have a polyline, and you have already put your +control points where you want them, call toSpline() directly. +Remember, only every third vertex will be "on" the spline. + +You get something that looks like the spline "inscribed" +inside the control polyline. + +=item + + +If you have a polyline, and you want all of its vertices on +the resulting spline, call addControlPoints() and then +toSpline(): + + $control = $polyline->addControlPoints(); + $spline = $control->toSpline(); + $image->polyline($spline,$red); + +You get something that looks like the control polyline "inscribed" +inside the spline. + +=back + +Adding "good" control points is subjective; this particular +algorithm reveals its author's tastes. +In the future, you may be able to alter the taste slightly +via parameters to the algorithm. For The Hubristic: please +build a better one! + +And for The Impatient: note that addControlPoints() returns a +polyline, so you can pile up the the call like this, +if you'd like: + + $image->polyline($polyline->addControlPoints()->toSpline(),$mauve); + +=back + +=head1 New GD::Image Methods + +=over 5 + +=item C<polyline> + +C<$image-E<gt>polyline(polyline,color)> I<object method> + + $image->polyline($polyline,$black) + +This draws a polyline with the specified color. +Both real color indexes and the special +colors gdBrushed, gdStyled and gdStyledBrushed can be specified. + +Neither the polyline() method or the polygon() method are very +picky: you can call either method with either a GD::Polygon or a GD::Polyline. +The I<method> determines if the shape is "closed" or "open" as drawn, I<not> +the object type. + +=item C<polydraw> + +C<$image-E<gt>polydraw(polything,color)> I<object method> + + $image->polydraw($poly,$black) + +This method draws the polything as expected (polygons are closed, +polylines are open) by simply checking the object type and calling +either $image->polygon() or $image->polyline(). + +=back + +=head1 Examples + +Please see file "polyline-examples.pl" that is included with the distribution. + +=head1 See Also + +For more info on Bezier splines, see http://www.webreference.com/dlab/9902/bezier.html. + +=head1 Future Features + +On the drawing board are additional features such as: + + - polygon winding algorithms (to determine if a point is "inside" or "outside" the polygon) + + - new polygon from bounding box + + - find bounding polygon (tightest fitting simple convex polygon for a given set of vertices) + + - addPts() method to add many points at once + + - clone() method for polygon + + - functions to interwork GD with SVG + +Please provide input on other possible features you'd like to see. + +=head1 Author + +This module has been written by Daniel J. Harasty. +Please send questions, comments, complaints, and kudos to him +at harasty@cpan.org. + +Thanks to Lincoln Stein for input and patience with me and this, +my first CPAN contribution. + +=head1 Copyright Information + +The Polyline.pm module is copyright 2002, Daniel J. Harasty. It is +distributed under the same terms as Perl itself. See the "Artistic +License" in the Perl source code distribution for licensing terms. + +The latest version of Polyline.pm is available at +your favorite CPAN repository and/or +along with GD.pm by Lincoln D. Stein at http://stein.cshl.org/WWW/software/GD. + +=cut + +# future: +# addPts +# boundingPolygon +# addControlPoints('method' => 'fitToSegments', 'numSegs' => 10) +# toSpline('csr' => 1/4); + +# GD::Color +# colorMap('x11' | 'svg' | <filename> ) +# colorByName($image, 'orange'); +# setImage($image); +# cbn('orange'); +# +# +# diff --git a/Master/tlpkg/tlperl/lib/GD/Simple.pm b/Master/tlpkg/tlperl/lib/GD/Simple.pm new file mode 100755 index 00000000000..ed0c3e9aa11 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/GD/Simple.pm @@ -0,0 +1,1236 @@ +package GD::Simple; + +=head1 NAME + +GD::Simple - Simplified interface to GD library + +=head1 SYNOPSIS + + use GD::Simple; + + # create a new image + $img = GD::Simple->new(400,250); + + # draw a red rectangle with blue borders + $img->bgcolor('red'); + $img->fgcolor('blue'); + $img->rectangle(10,10,50,50); + + # draw an empty rectangle with green borders + $img->bgcolor(undef); + $img->fgcolor('green'); + $img->rectangle(30,30,100,100); + + # move to (80,80) and draw a green line to (100,190) + $img->moveTo(80,80); + $img->lineTo(100,190); + + # draw a solid orange ellipse + $img->moveTo(110,100); + $img->bgcolor('orange'); + $img->fgcolor('orange'); + $img->ellipse(40,40); + + # draw a black filled arc + $img->moveTo(150,150); + $img->fgcolor('black'); + $img->arc(50,50,0,100,gdNoFill|gdEdged); + + # draw a string at (10,180) using the default + # built-in font + $img->moveTo(10,180); + $img->string('This is very simple'); + + # draw a string at (280,210) using 20 point + # times italic, angled upward 90 degrees + $img->moveTo(280,210); + $img->font('Times:italic'); + $img->fontsize(20); + $img->angle(-90); + $img->string('This is very fancy'); + + # some turtle graphics + $img->moveTo(300,100); + $img->penSize(3,3); + $img->angle(0); + $img->line(20); # 20 pixels going to the right + $img->turn(30); # set turning angle to 30 degrees + $img->line(20); # 20 pixel line + $img->line(20); + $img->line(20); + $img->turn(-90); # set turning angle to -90 degrees + $img->line(50); # 50 pixel line + + # draw a cyan polygon edged in blue + my $poly = new GD::Polygon; + $poly->addPt(150,100); + $poly->addPt(199,199); + $poly->addPt(100,199); + $img->bgcolor('cyan'); + $img->fgcolor('blue'); + $img->penSize(1,1); + $img->polygon($poly); + + # convert into png data + print $img->png; + +=head1 DESCRIPTION + +GD::Simple is a subclass of the GD library that shortens many of the +long GD method calls by storing information about the pen color, size +and position in the GD object itself. It also adds a small number of +"turtle graphics" style calls for those who prefer to work in polar +coordinates. In addition, the library allows you to use symbolic +names for colors, such as "chartreuse", and will manage the colors for +you. + +=head2 The Pen + +GD::Simple maintains a "pen" whose settings are used for line- and +shape-drawing operations. The pen has the following properties: + +=over 4 + +=item fgcolor + +The pen foreground color is the color of lines and the borders of +filled and unfilled shapes. + +=item bgcolor + +The pen background color is the color of the contents of filled +shapes. + +=item pensize + +The pen size is the width of the pen. Larger sizes draw thicker +lines. + +=item position + +The pen position is its current position on the canvas in (X,Y) +coordinates. + +=item angle + +When drawing in turtle mode, the pen angle determines the current +direction of lines of relative length. + +=item turn + +When drawing in turtle mode, the turn determines the clockwise or +counterclockwise angle that the pen will turn before drawing the next +line. + +=item font + +The font to use when drawing text. Both built-in bitmapped fonts and +TrueType fonts are supported. + +=item fontsize + +The size of the font to use when drawing with TrueType fonts. + +=back + +One sets the position and properties of the pen and then draws. As +the drawing progresses, the position of the pen is updated. + +=head2 Methods + +GD::Simple introduces a number of new methods, a few of which have the +same name as GD::Image methods, and hence change their behavior. In +addition to these new methods, GD::Simple objects support all of the +GD::Image methods. If you make a method call that isn't directly +supported by GD::Simple, it refers the request to the underlying +GD::Image object. Hence one can load a JPEG image into GD::Simple and +declare it to be TrueColor by using this call, which is effectively +inherited from GD::Image: + + my $img = GD::Simple->newFromJpeg('./myimage.jpg',1); + +The rest of this section describes GD::Simple-specific methods. + +=cut + +use strict; +use GD; +use GD::Group; +use Math::Trig; +use Carp 'croak'; + +our @ISA = 'Exporter'; +our @EXPORT = @GD::EXPORT; +our @EXPORT_OK = @GD::EXPORT_OK; +our $AUTOLOAD; + +my %COLORS; +my $IMAGECLASS = 'GD::Image'; +my $TRANSPARENT; + +sub AUTOLOAD { + my $self = shift; + my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/; + return if $func_name eq 'DESTROY'; + + if (ref $self && exists $self->{gd}) { + $self->{gd}->$func_name(@_); + } else { + my @result = $IMAGECLASS->$func_name(@_); + if (UNIVERSAL::isa($result[0],'GD::Image')) { + return $self->new($result[0]); + } else { + return @result; + } + } +} + +=over 4 + +=item $img = GD::Simple->new($x,$y [,$truecolor]) + +=item $img = GD::Simple->new($gd) + +Create a new GD::Simple object. There are two forms of new(). In the +first form, pass the width and height of the desired canvas, and +optionally a boolean flag to request a truecolor image. In the second +form, pass a previously-created GD::Image object. + +=cut + +# dual-purpose code - beware +sub new { + my $pack = shift; + + unshift @_,(100,100) if @_ == 0; + + if (@_ >= 2) { # traditional GD::Image->new() call + my $gd = $IMAGECLASS->new(@_); + my $self = $pack->new($gd); + $self->clear; + return $self; + } + + if (@_ == 1) { # initialize from existing image + my $gd = shift; + my $self = bless { + gd => $gd, + xy => [0,0], + font => gdSmallFont, + fontsize => 9, + turningangle => 0, + angle => 0, + pensize => 1, + },$pack; + $self->{bgcolor} = $self->translate_color(255,255,255); + $self->{fgcolor} = $self->translate_color(0,0,0); + return $self; + } +} + +=item GD::Simple->class('GD'); + +=item GD::Simple->class('GD::SVG'); + +Select whether new() should use GD or GD::SVG internally. Call +GD::Simple->class('GD::SVG') before calling new() if you wish to +generate SVG images. + +If future GD subclasses are created, this method will subport them. + +=cut + +sub class { + my $pack = shift; + if (@_) { + $IMAGECLASS = shift; + eval "require $IMAGECLASS; 1" or die $@; + $IMAGECLASS = "$IMAGECLASS\:\:Image" + if $IMAGECLASS eq 'GD::SVG'; + } + $IMAGECLASS; +} + +=item $img->moveTo($x,$y) + +This call changes the position of the pen without drawing. It moves +the pen to position ($x,$y) on the drawing canvas. + +=cut + +sub moveTo { + my $self = shift; + croak 'Usage GD::Simple->moveTo($x,$y)' unless @_ == 2; + my ($x,$y) = @_; + $self->{xy} = [$x,$y]; +} + +=item $img->move($dx,$dy) + +=item $img->move($dr) + +This call changes the position of the pen without drawing. When called +with two arguments it moves the pen $dx pixels to the right and $dy +pixels downward. When called with one argument it moves the pen $dr +pixels along the vector described by the current pen angle. + +=cut + +sub move { + my $self = shift; + if (@_ == 1) { # polar coordinates -- this is r + $self->{angle} += $self->{turningangle}; + my $angle = deg2rad($self->{angle}); + $self->{xy}[0] += $_[0] * cos($angle); + $self->{xy}[1] += $_[0] * sin($angle); + } + elsif (@_ == 2) { # cartesian coordinates + $self->{xy}[0] += $_[0]; + $self->{xy}[1] += $_[1]; + } else { + croak 'Usage GD::Simple->move($dx,$dy) or move($r)'; + } +} + +=item $img->lineTo($x,$y) + +The lineTo() call simultaneously draws and moves the pen. It draws a +line from the current pen position to the position defined by ($x,$y) +using the current pen size and color. After drawing, the position of +the pen is updated to the new position. + +=cut + +sub lineTo { + my $self = shift; + croak 'Usage GD::Simple->lineTo($x,$y)' unless @_ == 2; + $self->gd->line($self->curPos,@_,$self->fgcolor); + $self->moveTo(@_); +} + +=item $img->line($dx,$dy) + +=item $img->line($dr) + +The line() call simultaneously draws and moves the pen. When called +with two arguments it draws a line from the current position of the +pen to the position $dx pixels to the right and $dy pixels down. When +called with one argument, it draws a line $dr pixels long along the +angle defined by the current pen angle. + +=cut + +sub line { + my $self = shift; + croak 'Usage GD::Simple->line($dx,$dy) or line($r)' unless @_ >= 1; + my @curPos = $self->curPos; + $self->move(@_); + my @newPos = $self->curPos; + $self->gd->line(@curPos,@newPos,$self->fgcolor); +} + +=item $img->clear + +This method clears the canvas by painting over it with the current +background color. + +=cut + +sub clear { + my $self = shift; + $self->gd->filledRectangle(0,0,$self->getBounds,$self->bgcolor); +} + +=item $img->rectangle($x1,$y1,$x2,$y2) + +This method draws the rectangle defined by corners ($x1,$y1), +($x2,$y2). The rectangle's edges are drawn in the foreground color and +its contents are filled with the background color. To draw a solid +rectangle set bgcolor equal to fgcolor. To draw an unfilled rectangle +(transparent inside), set bgcolor to undef. + +=cut + +sub rectangle { + my $self = shift; + croak 'Usage GD::Simple->rectangle($x1,$y1,$x2,$y2)' unless @_ == 4; + my $gd = $self->gd; + my ($bg,$fg) = ($self->bgcolor,$self->fgcolor); + $gd->filledRectangle(@_,$bg) if defined $bg; + $gd->rectangle(@_,$fg) if defined $fg && (!defined $bg || $bg != $fg); +} + +=item $img->ellipse($width,$height) + +This method draws the ellipse centered at the current location with +width $width and height $height. The ellipse's border is drawn in the +foreground color and its contents are filled with the background +color. To draw a solid ellipse set bgcolor equal to fgcolor. To draw +an unfilled ellipse (transparent inside), set bgcolor to undef. + +=cut + +sub ellipse { + my $self = shift; + croak 'Usage GD::Simple->ellipse($width,$height)' unless @_ == 2; + my $gd = $self->gd; + my ($bg,$fg) = ($self->bgcolor,$self->fgcolor); + $gd->filledEllipse($self->curPos,@_,$bg) if defined $bg; + $gd->ellipse($self->curPos,@_,$fg) if defined $fg && (!defined $bg || $bg != $fg); +} + +=item $img->arc($cx,$cy,$width,$height,$start,$end [,$style]) + +This method draws filled and unfilled arcs. See L<GD> for a +description of the arguments. To draw a solid arc (such as a pie +wedge) set bgcolor equal to fgcolor. To draw an unfilled arc, set +bgcolor to undef. + +=cut + +sub arc { + my $self = shift; + croak 'Usage GD::Simple->arc($width,$height,$start,$end,$style)' unless @_ >= 4; + my ($width,$height,$start,$end,$style) = @_; + my $gd = $self->gd; + my ($bg,$fg) = ($self->bgcolor,$self->fgcolor); + my ($cx,$cy) = $self->curPos; + + if ($bg) { + my @args = ($cx,$cy,$width,$height,$start,$end,$bg); + push @args,$style if defined $style; + $gd->filledArc(@args); + } else { + my @args = ($cx,$cy,$width,$height,$start,$end,$fg); + $gd->arc(@args); + } +} + +=item $img->polygon($poly) + +This method draws filled and unfilled polygon using the current +settings of fgcolor for the polygon border and bgcolor for the polygon +fill color. See L<GD> for a description of creating polygons. To draw +a solid polygon set bgcolor equal to fgcolor. To draw an unfilled +polygon, set bgcolor to undef. + +=cut + +sub polygon { + my $self = shift; + croak 'Usage GD::Simple->polygon($poly)' unless @_ == 1; + my $gd = $self->gd; + my ($bg,$fg) = ($self->bgcolor,$self->fgcolor); + $gd->filledPolygon(@_,$bg) if defined $bg; + $gd->openPolygon(@_,$fg) if defined $fg && (!defined $bg || $bg != $fg); +} + +=item $img->polyline($poly) + +This method draws polygons without closing the first and last vertices +(similar to GD::Image->unclosedPolygon()). It uses the fgcolor to draw +the line. + +=cut + +sub polyline { + my $self = shift; + croak 'Usage GD::Simple->polyline($poly)' unless @_ == 1; + my $gd = $self->gd; + my $fg = $self->fgcolor; + $gd->unclosedPolygon(@_,$fg); +} + +=item $img->string($string) + +This method draws the indicated string starting at the current +position of the pen. The pen is moved to the end of the drawn string. +Depending on the font selected with the font() method, this will use +either a bitmapped GD font or a TrueType font. The angle of the pen +will be consulted when drawing the text. For TrueType fonts, any angle +is accepted. For GD bitmapped fonts, the angle can be either 0 (draw +horizontal) or -90 (draw upwards). + +For consistency between the TrueType and GD font behavior, the string +is always drawn so that the current position of the pen corresponds to +the bottom left of the first character of the text. This is different +from the GD behavior, in which the first character of bitmapped fonts +hangs down from the pen point. + +This method returns a polygon indicating the bounding box of the +rendered text. If an error occurred (such as invalid font +specification) it returns undef and an error message in $@. + +=cut + +sub string { + my $self = shift; + my $string = shift; + my $font = $self->font; + my @bounds; + if (ref $font && $font->isa('GD::Font')) { + my ($x,$y) = $self->curPos; + if ($self->angle == -90) { + $x -= $font->height; + $y -= $font->width; + $self->gd->stringUp($font,$x,$y,$string,$self->fgcolor); + $self->{xy}[1] -= length($string) * $font->width; + @bounds = ( ($self->{xy}[0],$y), ($x,$y), ($x,$self->{xy}[1]-$font->width), ($self->{xy}[0],$self->{xy}[1]-$font->width) ); + } else { + $y -= $font->height; + $self->gd->string($font,$x,$y,$string,$self->fgcolor); + $self->{xy}[0] += length($string) * $font->width; + @bounds = ( ($x,$self->{xy}[1]), ($self->{xy}[0],$self->{xy}[1]), ($self->{xy}[0],$y), ($x,$y) ); + } + } + else { + $self->useFontConfig(1); + @bounds = $self->stringFT($self->fgcolor,$font, + $self->fontsize,-deg2rad($self->angle), # -pi * $self->angle/180, + $self->curPos,$string); + return unless @bounds; + my ($delta_x,$delta_y) = $self->_string_width(@bounds); + $self->{xy}[0] += $delta_x; + $self->{xy}[1] += $delta_y; + } + my $poly = GD::Polygon->new; + while (@bounds) { + $poly->addPt(splice(@bounds,0,2)); + } + return $poly; +} + +=item $metrics = $img->fontMetrics + +=item ($metrics,$width,$height) = GD::Simple->fontMetrics($font,$fontsize,$string) + +This method returns information about the current font, most commonly +a TrueType font. It can be invoked as an instance method (on a +previously-created GD::Simple object) or as a class method (on the +'GD::Simple' class). + +When called as an instance method, fontMetrics() takes no arguments +and returns a single hash reference containing the metrics that +describe the currently selected font and size. The hash reference +contains the following information: + + xheight the base height of the font from the bottom to the top of + a lowercase 'm' + + ascent the length of the upper stem of the lowercase 'd' + + descent the length of the lower step of the lowercase 'j' + + lineheight the distance from the bottom of the 'j' to the top of + the 'd' + + leading the distance between two adjacent lines + +=cut + +# return %$fontmetrics +# keys: 'ascent', 'descent', 'lineheight', 'xheight', 'leading' +sub fontMetrics { + my $self = shift; + + unless (ref $self) { #class invocation -- create a scratch + $self = $self->new; + $self->font(shift) if defined $_[0]; + $self->fontsize(shift) if defined $_[0]; + } + + my $font = $self->font; + my $metrics; + + if (ref $font && $font->isa('GD::Font')) { + my $height = $font->height; + $metrics = {ascent => 0, + descent => 0, + lineheight => $height, + xheight => $height, + leading => 0}; + } + else { + $self->useFontConfig(1); + my @mbounds = GD::Image->stringFT($self->fgcolor,$font, + $self->fontsize,0, + 0,0,'m'); + my $xheight = $mbounds[3]-$mbounds[5]; + my @jbounds = GD::Image->stringFT($self->fgcolor,$font, + $self->fontsize,0, + 0,0,'j'); + my $ascent = $mbounds[7]-$jbounds[7]; + my $descent = $jbounds[3]-$mbounds[3]; + + my @mmbounds = GD::Image->stringFT($self->fgcolor,$font, + $self->fontsize,0, + 0,0,"m\nm"); + my $twolines = $mmbounds[3]-$mmbounds[5]; + my $lineheight = $twolines - 2*$xheight; + my $leading = $lineheight - $ascent - $descent; + $metrics = {ascent => $ascent, + descent => $descent, + lineheight => $lineheight, + xheight => $xheight, + leading => $leading}; + } + + if ((my $string = shift) && wantarray) { + my ($width,$height) = $self->stringBounds($string); + return ($metrics,abs($width),abs($height)); + } + return $metrics; +} + +=item ($delta_x,$delta_y)= $img->stringBounds($string) + +This method indicates the X and Y offsets (which may be negative) that +will occur when the given string is drawn using the current font, +fontsize and angle. When the string is drawn horizontally, it gives +the width and height of the string's bounding box. + +=cut + +sub stringBounds { + my $self = shift; + my $string = shift; + my $font = $self->font; + if (ref $font && $font->isa('GD::Font')) { + if ($self->angle == -90) { + return ($font->height,-length($string) * $font->width); + } else { + return (length($string) * $font->width,$font->height); + } + } + else { + $self->useFontConfig(1); + my @bounds = GD::Image->stringFT($self->fgcolor,$font, + $self->fontsize,-deg2rad($self->angle), + $self->curPos,$string); + return $self->_string_width(@bounds); + } +} + +=item $delta_x = $img->stringWidth($string) + +This method indicates the width of the string given the current font, +fontsize and angle. It is the same as ($img->stringBounds($string))[0] + +=cut + +sub stringWidth { + return ((shift->stringBounds(@_))[0]); +} + + +sub _string_width { + my $self = shift; + my @bounds = @_; + my $delta_x = abs($bounds[2]-$bounds[0]); + my $delta_y = abs($bounds[5]-$bounds[3]); + my $angle = $self->angle % 360; + if ($angle >= 0 && $angle < 90) { + return ($delta_x,$delta_y); + + } elsif ($angle >= 90 && $angle < 180) { + return (-$delta_x,$delta_y); + + } elsif ($angle >= 180 && $angle < 270) { + return (-$delta_x,-$delta_y); + + } elsif ($angle >= 270 && $angle < 360) { + return ($delta_x,-$delta_y); + } +} + +=item ($x,$y) = $img->curPos + +Return the current position of the pen. Set the current position +using moveTo(). + +=cut + +sub curPos { @{shift->{xy}}; } + +=item $font = $img->font([$newfont] [,$newsize]) + +Get or set the current font. Fonts can be GD::Font objects, TrueType +font file paths, or fontconfig font patterns like "Times:italic" (see +L<fontconfig>). The latter feature requires that you have the +fontconfig library installed and are using libgd version 2.0.33 or +higher. + +As a shortcut, you may pass two arguments to set the font and the +fontsize simultaneously. The fontsize is only valid when drawing with +TrueType fonts. + +=cut + +sub font { + my $self = shift; + $self->{font} = shift if @_; + $self->{fontsize} = shift if @_; + $self->{font}; +} + +=item $size = $img->fontsize([$newfontsize]) + +Get or set the current font size. This is only valid for TrueType +fonts. + +=cut + +sub fontsize { + my $self = shift; + $self->{fontsize} = shift if @_; + $self->{fontsize}; +} + +=item $size = $img->penSize([$newpensize]) + +Get or set the current pen width for use during line drawing +operations. + +=cut + +sub penSize { + my $self = shift; + if (@_) { + $self->{pensize} = shift; + $self->gd->setThickness($self->{pensize}); + } + $self->{pensize}; +} + +=item $angle = $img->angle([$newangle]) + +Set the current angle for use when calling line() or move() with a +single argument. + +Here is an example of using turn() and angle() together to draw an +octagon. The first line drawn is the downward-slanting top right +edge. The last line drawn is the horizontal top of the octagon. + + $img->moveTo(200,50); + $img->angle(0); + $img->turn(360/8); + for (1..8) { $img->line(50) } + +=cut + +sub angle { + my $self = shift; + $self->{angle} = shift if @_; + $self->{angle}; +} + +=item $angle = $img->turn([$newangle]) + +Get or set the current angle to turn prior to drawing lines. This +value is only used when calling line() or move() with a single +argument. The turning angle will be applied to each call to line() or +move() just before the actual drawing occurs. + +Angles are in degrees. Positive values turn the angle clockwise. + +=cut + +# degrees, not radians +sub turn { + my $self = shift; + $self->{turningangle} = shift if @_; + $self->{turningangle}; +} + +=item $color = $img->fgcolor([$newcolor]) + +Get or set the pen's foreground color. The current pen color can be +set by (1) using an (r,g,b) triple; (2) using a previously-allocated +color from the GD palette; or (3) by using a symbolic color name such +as "chartreuse." The list of color names can be obtained using +color_names(). The special color name 'transparent' will create a +completely transparent color. + +=cut + +sub fgcolor { + my $self = shift; + $self->{fgcolor} = $self->translate_color(@_) if @_; + $self->{fgcolor}; +} + +=item $color = $img->bgcolor([$newcolor]) + +Get or set the pen's background color. The current pen color can be +set by (1) using an (r,g,b) triple; (2) using a previously-allocated +color from the GD palette; or (3) by using a symbolic color name such +as "chartreuse." The list of color names can be obtained using +color_names(). The special color name 'transparent' will create a +completely transparent color. + +=cut + +sub bgcolor { + my $self = shift; + $self->{bgcolor} = $self->translate_color(@_) if @_; + $self->{bgcolor}; +} + +=item $index = $img->translate_color(@args) + +Translates a color into a GD palette or TrueColor index. You may pass +either an (r,g,b) triple or a symbolic color name. If you pass a +previously-allocated index, the method will return it unchanged. + +=cut + +sub translate_color { + my $self = shift; + return unless defined $_[0]; + my ($r,$g,$b); + if (@_ == 1 && $_[0] =~ /^-?\d+/) { # previously allocated index + return $_[0]; + } + elsif (@_ == 3) { # (rgb triplet) + ($r,$g,$b) = @_; + } + elsif (lc $_[0] eq 'transparent') { + return $TRANSPARENT ||= $self->alphaColor('white',127); + } + else { + $self->read_color_table unless %COLORS; + die "unknown color" unless exists $COLORS{lc $_[0]}; + ($r,$g,$b) = @{$COLORS{lc $_[0]}}; + } + return $self->colorResolve($r,$g,$b); +} + +sub transparent { + my $self = shift; + my $index = $self->translate_color(@_); + $self->gd->transparent($index); +} + +=item $index = $img->alphaColor(@args,$alpha) + +Creates an alpha color. You may pass either an (r,g,b) triple or a +symbolic color name, followed by an integer indicating its +opacity. The opacity value ranges from 0 (fully opaque) to 127 (fully +transparent). + +=cut + +sub alphaColor { + my $self = shift; + return unless defined $_[0]; + my ($r,$g,$b,$a); + if (@_ == 4) { # (rgb triplet) + ($r,$g,$b,$a) = @_; + } else { + $self->read_color_table unless %COLORS; + die "unknown color" unless exists $COLORS{lc $_[0]}; + ($r,$g,$b) = @{$COLORS{lc $_[0]}}; + $a = $_[1]; + } + return $self->colorAllocateAlpha($r,$g,$b,$a); +} + +=item @names = GD::Simple->color_names + +=item $translate_table = GD::Simple->color_names + +Called in a list context, color_names() returns the list of symbolic +color names recognized by this module. Called in a scalar context, +the method returns a hash reference in which the keys are the color +names and the values are array references containing [r,g,b] triples. + +=cut + +sub color_names { + my $self = shift; + $self->read_color_table unless %COLORS; + return wantarray ? sort keys %COLORS : \%COLORS; +} + +=item $gd = $img->gd + +Return the internal GD::Image object. Usually you will not need to +call this since all GD methods are automatically referred to this object. + +=cut + +sub gd { shift->{gd} } + +sub read_color_table { + my $class = shift; + while (<DATA>) { + chomp; + last if /^__END__/; + my ($name,$r,$g,$b) = split /\s+/; + $COLORS{$name} = [hex $r,hex $g,hex $b]; + } +} + +sub setBrush { + my $self = shift; + my $brush = shift; + if ($brush->isa('GD::Simple')) { + $self->gd->setBrush($brush->gd); + } else { + $self->gd->setBrush($brush); + } +} + +=item ($red,$green,$blue) = GD::Simple->HSVtoRGB($hue,$saturation,$value) + +Convert a Hue/Saturation/Value (HSV) color into an RGB triple. The +hue, saturation and value are integers from 0 to 255. + +=cut + +sub HSVtoRGB { + my $self = shift; + @_ == 3 or croak "Usage: GD::Simple->HSVtoRGB(\$hue,\$saturation,\$value)"; + + my ($h,$s,$v)=@_; + my ($r,$g,$b,$i,$f,$p,$q,$t); + + if( $s == 0 ) { + ## achromatic (grey) + return ($v,$v,$v); + } + $h %= 255; + $s /= 255; ## scale saturation from 0.0-1.0 + $h /= 255; ## scale hue from 0 to 1.0 + $h *= 360; ## and now scale it to 0 to 360 + + $h /= 60; ## sector 0 to 5 + $i = $h % 6; + $f = $h - $i; ## factorial part of h + $p = $v * ( 1 - $s ); + $q = $v * ( 1 - $s * $f ); + $t = $v * ( 1 - $s * ( 1 - $f ) ); + + if($i<1) { + $r = $v; + $g = $t; + $b = $p; + } elsif($i<2){ + $r = $q; + $g = $v; + $b = $p; + } elsif($i<3){ + $r = $p; + $g = $v; + $b = $t; + } elsif($i<4){ + $r = $p; + $g = $q; + $b = $v; + } elsif($i<5){ + $r = $t; + $g = $p; + $b = $v; + } else { + $r = $v; + $g = $p; + $b = $q; + } + return (int($r+0.5),int($g+0.5),int($b+0.5)); +} + +=item ($hue,$saturation,$value) = GD::Simple->RGBtoHSV($hue,$saturation,$value) + +Convert a Red/Green/Blue (RGB) value into a Hue/Saturation/Value (HSV) +triple. The hue, saturation and value are integers from 0 to 255. + +=back + +=cut + +sub RGBtoHSV { + my $self = shift; + my ($r, $g ,$bl) = @_; + my ($min,undef,$max) = sort {$a<=>$b} ($r,$g,$bl); + return (0,0,0) unless $max > 0; + + my $v = $max; + my $s = 255 * ($max - $min)/$max; + my $h; + my $range = $max - $min; + + if ($range == 0) { # all colors are equal, so monochrome + return (0,0,$max); + } + + if ($max == $r) { + $h = 60 * ($g-$bl)/$range; + } + elsif ($max == $g) { + $h = 60 * ($bl-$r)/$range + 120; + } + else { + $h = 60 * ($r-$g)/$range + 240; + } + + $h = int($h*255/360 + 0.5); + + return ($h, $s, $v); +} + +sub newGroup { + my $self = shift; + return $self->GD::newGroup(@_); +} + +1; + +__DATA__ +white FF FF FF +black 00 00 00 +aliceblue F0 F8 FF +antiquewhite FA EB D7 +aqua 00 FF FF +aquamarine 7F FF D4 +azure F0 FF FF +beige F5 F5 DC +bisque FF E4 C4 +blanchedalmond FF EB CD +blue 00 00 FF +blueviolet 8A 2B E2 +brown A5 2A 2A +burlywood DE B8 87 +cadetblue 5F 9E A0 +chartreuse 7F FF 00 +chocolate D2 69 1E +coral FF 7F 50 +cornflowerblue 64 95 ED +cornsilk FF F8 DC +crimson DC 14 3C +cyan 00 FF FF +darkblue 00 00 8B +darkcyan 00 8B 8B +darkgoldenrod B8 86 0B +darkgray A9 A9 A9 +darkgreen 00 64 00 +darkkhaki BD B7 6B +darkmagenta 8B 00 8B +darkolivegreen 55 6B 2F +darkorange FF 8C 00 +darkorchid 99 32 CC +darkred 8B 00 00 +darksalmon E9 96 7A +darkseagreen 8F BC 8F +darkslateblue 48 3D 8B +darkslategray 2F 4F 4F +darkturquoise 00 CE D1 +darkviolet 94 00 D3 +deeppink FF 14 100 +deepskyblue 00 BF FF +dimgray 69 69 69 +dodgerblue 1E 90 FF +firebrick B2 22 22 +floralwhite FF FA F0 +forestgreen 22 8B 22 +fuchsia FF 00 FF +gainsboro DC DC DC +ghostwhite F8 F8 FF +gold FF D7 00 +goldenrod DA A5 20 +gray 80 80 80 +green 00 80 00 +greenyellow AD FF 2F +honeydew F0 FF F0 +hotpink FF 69 B4 +indianred CD 5C 5C +indigo 4B 00 82 +ivory FF FF F0 +khaki F0 E6 8C +lavender E6 E6 FA +lavenderblush FF F0 F5 +lawngreen 7C FC 00 +lemonchiffon FF FA CD +lightblue AD D8 E6 +lightcoral F0 80 80 +lightcyan E0 FF FF +lightgoldenrodyellow FA FA D2 +lightgreen 90 EE 90 +lightgrey D3 D3 D3 +lightpink FF B6 C1 +lightsalmon FF A0 7A +lightseagreen 20 B2 AA +lightskyblue 87 CE FA +lightslategray 77 88 99 +lightsteelblue B0 C4 DE +lightyellow FF FF E0 +lime 00 FF 00 +limegreen 32 CD 32 +linen FA F0 E6 +magenta FF 00 FF +maroon 80 00 00 +mediumaquamarine 66 CD AA +mediumblue 00 00 CD +mediumorchid BA 55 D3 +mediumpurple 100 70 DB +mediumseagreen 3C B3 71 +mediumslateblue 7B 68 EE +mediumspringgreen 00 FA 9A +mediumturquoise 48 D1 CC +mediumvioletred C7 15 85 +midnightblue 19 19 70 +mintcream F5 FF FA +mistyrose FF E4 E1 +moccasin FF E4 B5 +navajowhite FF DE AD +navy 00 00 80 +oldlace FD F5 E6 +olive 80 80 00 +olivedrab 6B 8E 23 +orange FF A5 00 +orangered FF 45 00 +orchid DA 70 D6 +palegoldenrod EE E8 AA +palegreen 98 FB 98 +paleturquoise AF EE EE +palevioletred DB 70 100 +papayawhip FF EF D5 +peachpuff FF DA B9 +peru CD 85 3F +pink FF C0 CB +plum DD A0 DD +powderblue B0 E0 E6 +purple 80 00 80 +red FF 00 00 +rosybrown BC 8F 8F +royalblue 41 69 E1 +saddlebrown 8B 45 13 +salmon FA 80 72 +sandybrown F4 A4 60 +seagreen 2E 8B 57 +seashell FF F5 EE +sienna A0 52 2D +silver C0 C0 C0 +skyblue 87 CE EB +slateblue 6A 5A CD +slategray 70 80 90 +snow FF FA FA +springgreen 00 FF 7F +steelblue 46 82 B4 +tan D2 B4 8C +teal 00 80 80 +thistle D8 BF D8 +tomato FF 63 47 +turquoise 40 E0 D0 +violet EE 82 EE +wheat F5 DE B3 +whitesmoke F5 F5 F5 +yellow FF FF 00 +yellowgreen 9A CD 32 +gradient1 00 ff 00 +gradient2 0a ff 00 +gradient3 14 ff 00 +gradient4 1e ff 00 +gradient5 28 ff 00 +gradient6 32 ff 00 +gradient7 3d ff 00 +gradient8 47 ff 00 +gradient9 51 ff 00 +gradient10 5b ff 00 +gradient11 65 ff 00 +gradient12 70 ff 00 +gradient13 7a ff 00 +gradient14 84 ff 00 +gradient15 8e ff 00 +gradient16 99 ff 00 +gradient17 a3 ff 00 +gradient18 ad ff 00 +gradient19 b7 ff 00 +gradient20 c1 ff 00 +gradient21 cc ff 00 +gradient22 d6 ff 00 +gradient23 e0 ff 00 +gradient24 ea ff 00 +gradient25 f4 ff 00 +gradient26 ff ff 00 +gradient27 ff f4 00 +gradient28 ff ea 00 +gradient29 ff e0 00 +gradient30 ff d6 00 +gradient31 ff cc 00 +gradient32 ff c1 00 +gradient33 ff b7 00 +gradient34 ff ad 00 +gradient35 ff a3 00 +gradient36 ff 99 00 +gradient37 ff 8e 00 +gradient38 ff 84 00 +gradient39 ff 7a 00 +gradient40 ff 70 00 +gradient41 ff 65 00 +gradient42 ff 5b 00 +gradient43 ff 51 00 +gradient44 ff 47 00 +gradient45 ff 3d 00 +gradient46 ff 32 00 +gradient47 ff 28 00 +gradient48 ff 1e 00 +gradient49 ff 14 00 +gradient50 ff 0a 00 +__END__ + +=head1 COLORS + +This script will create an image showing all the symbolic colors. + + #!/usr/bin/perl + + use strict; + use GD::Simple; + + my @color_names = GD::Simple->color_names; + my $cols = int(sqrt(@color_names)); + my $rows = int(@color_names/$cols)+1; + + my $cell_width = 100; + my $cell_height = 50; + my $legend_height = 16; + my $width = $cols * $cell_width; + my $height = $rows * $cell_height; + + my $img = GD::Simple->new($width,$height); + $img->font(gdSmallFont); + + for (my $c=0; $c<$cols; $c++) { + for (my $r=0; $r<$rows; $r++) { + my $color = $color_names[$c*$rows + $r] or next; + my @topleft = ($c*$cell_width,$r*$cell_height); + my @botright = ($topleft[0]+$cell_width,$topleft[1]+$cell_height-$legend_height); + $img->bgcolor($color); + $img->fgcolor($color); + $img->rectangle(@topleft,@botright); + $img->moveTo($topleft[0]+2,$botright[1]+$legend_height-2); + $img->fgcolor('black'); + $img->string($color); + } + } + + print $img->png; + +=head1 AUTHOR + +The GD::Simple module is copyright 2004, Lincoln D. Stein. It is +distributed under the same terms as Perl itself. See the "Artistic +License" in the Perl source code distribution for licensing terms. + +The latest versions of GD.pm are available at + + http://stein.cshl.org/WWW/software/GD + +=head1 SEE ALSO + +L<GD>, +L<GD::Polyline>, +L<GD::SVG>, +L<Image::Magick> + +=cut |