transparent results from the CPAN

DBD-Chart

#		- added image overlays
#
#	0.10	Feb 20, 2001	Dean Arnold
#		- Coded.
#
require 5.6.0;
use strict 'vars';

{
package DBD::Chart::Plot;

use GD;
use GD::Text;
use GD::Text::Align;
use Time::Local;
use GD qw(gdBrushed gdSmallFont gdTinyFont gdMediumBoldFont);

$DBD::Chart::Plot::VERSION = '0.81';

#
#	list of valid colors
#
our @clrlist = qw(
	white lgray	gray dgray black lblue blue dblue gold lyellow	
	yellow	dyellow	lgreen	green dgreen lred red dred lpurple	
	purple dpurple lorange orange pink dpink marine	cyan	
	lbrown dbrown );
#
#	RGB of valid colors
#
our %colors = (
	white	=> [255,255,255], 
	lgray	=> [191,191,191], 
	gray	=> [127,127,127],
	dgray	=> [63,63,63],
	black	=> [0,0,0],
	lblue	=> [0,0,255], 
	blue	=> [0,0,191],
	dblue	=> [0,0,127], 
	gold	=> [255,215,0],
	lyellow	=> [255,255,0], 
	yellow	=> [191,191,0], 
	dyellow	=> [127,127,0],
	lgreen	=> [0,255,0], 
	green	=> [0,191,0], 
	dgreen	=> [0,127,0],
	lred	=> [255,0,0], 
	red		=> [191,0,0],
	dred	=> [127,0,0],
	lpurple	=> [255,0,255], 
	purple	=> [191,0,191],
	dpurple	=> [127,0,127],
	lorange	=> [255,183,0], 
	orange	=> [255,127,0],
	pink	=> [255,183,193], 
	dpink	=> [255,105,180],
	marine	=> [127,127,255], 
	cyan	=> [0,255,255],
	lbrown	=> [210,180,140], 
	dbrown	=> [165,42,42],
	transparent => [1,1,1]
);
#
#	pointshapes
#
our %valid_shapes = (
'fillsquare', 1,
'opensquare', 2,
'horizcross', 3,
'diagcross', 4,
'filldiamond', 5,
'opendiamond', 6,
'fillcircle', 7,
'opencircle', 8,
'icon', 9,
'dot', 10,
'null', 11);

#
#	logarithmic steps for axis scaling
#
our @logsteps = (0, log(2)/log(10), log(3)/log(10), log(4)/log(10), 
	log(5)/log(10), 1.0);
#
#	index of vertex pts for 3-D barchart
#	polygonal visible faces
#
our @polyverts = ( 
[ 1*2, 2*2,	3*2, 4*2 ],	# top face
[ 0*2, 1*2, 4*2, 5*2 ],	# front face
[ 4*2, 3*2, 6*2, 5*2 ]	# side face
);
#
# indices of 3-D projection vertices
#	mapped to line segments
#
our @vert2lines = (
1*2, 4*2, 	# top front l-r
0*2, 1*2,	# left front b-t
0*2, 5*2,	# bottom front l-r
4*2, 5*2,	# right front b-t
1*2, 2*2,	# top left f-r
2*2, 3*2,	# top rear l-r
3*2, 4*2,   # right top r-f
3*2, 6*2,   # right rear t-b
5*2, 6*2,   # right bottom r-f
);

#
#	indices of 3-D projection of axes planes
#
our @axesverts = (
	0*2, 1*2,	# left wall
	1*2, 3*2,
	3*2, 2*2,
	2*2, 0*2,
		
# rear wall
	3*2, 6*2,	# trl to trr
	6*2, 5*2,	# trr to brr
	5*2, 1*2,	# brr to brl

Chart/Plot.pm view on Meta::CPAN


# used for pt2pxl()
	$obj->{xl} = undef;
	$obj->{xh} = undef;
	$obj->{yl} = undef;
	$obj->{yh} = undef;
	$obj->{zl} = undef;
	$obj->{zh} = undef;
	$obj->{xscale} = 0;
	$obj->{yscale} = 0;
	$obj->{zscale} = 0;
	$obj->{horizEdge} = 0;
	$obj->{vertEdge} = 0;
	$obj->{horizStep} = 0;
	$obj->{vertStep} = 0;
	$obj->{Xcard} = 0;		# cardinality of 3-axis barcharts
	$obj->{Zcard} = 0;
	$obj->{plotWidth} = 0;	# true plot width; height; depth
	$obj->{plotHeight} = 0;
	$obj->{plotDepth} = 0;
	$obj->{brushWidth} = 0; # width of bars or candlesticks
	$obj->{brushDepth} = 0;
	$obj->{rangeSum} = 0;	# running total for piecharts
	$obj->{haveScale} = 0;	# 1 = last calculated min & max still valid
	$obj->{domainValues} = { };	# map of domain values for bar/histo/candle/sym domains
	$obj->{boxCount} = 0;	# num of boxcharts in plot
	$obj->{barCount} = 0;	# num of barchart/histos in plot
	$obj->{xMaxLen} = 0;	# max length of symbolic X value
	$obj->{yMaxLen} = 0;	# max length of temporal Y value
	$obj->{zMaxLen} = 0;	# max length of symbolic Z value

# axis label strings
	$obj->{xAxisLabel} = '';
	$obj->{yAxisLabel} = '';
	$obj->{zAxisLabel} = '';

	$obj->{xLog} = 0;		# 1 => log10 scaling
	$obj->{yLog} = 0;
	$obj->{zLog} = 0;

	$obj->{title} = '';
	$obj->{signature} = '';
	$obj->{legend} = 0; 	# 1 => render legend
	$obj->{horizGrid} = 0;	# 1 => print y-axis gridlines
	$obj->{vertGrid} = 0;	# 1 => print x-axis gridlines
	$obj->{xAxisVert} = 0;	# 1 => print x-axis label vertically
	$obj->{errmsg} = '';	# error result of last operation
	$obj->{keepOrigin} = 0; # 1 => force origin into graph
	$obj->{threed} = 0;		# 1 => use 3-D effect
	$obj->{logo} = undef;
		
	$obj->{icons} = [ ];	# array of icon filenames
		
	$obj->{symDomain} = 0;	# 1 => use symbolic domain
	$obj->{timeDomain} = undef; # defines format of temporal domain labels
	$obj->{timeRange} = undef; # defines format of temporal range labels

#  allocate some oft used colors
	$obj->{white} = $white;
	$obj->{black} = $black; 
	$obj->{transparent} = $img->colorAllocate(@{$colors{'transparent'}});

	$obj->{bgColor} = $white; # background color
	$obj->{gridColor} = $black;
	$obj->{textColor} = $black;
	$obj->{border} = 1;

	$obj->{mapModifier} = undef;
	
#	for now these aren't used, but someday we'll let them be configured
	$obj->{font} = 'gd';

	$obj->{_legends} = [ ];

# set image basic properties
	$img->transparent($obj->{transparent});
	$img->interlaced('true');
#	$img->rectangle( 0, 0, $w-1, $h-1, $obj->{black});
}

#
#	compare function for numeric sort
#
sub numerically { $a <=> $b }

sub convert_temporal {
	my ($value, $format) = @_;
#
#	use Perl funcs to compute seconds from date
	my $t;
	$t = timegm(0, 0, 0, $3, $2 - 1, $1),
	$t -= ($t%86400), #	timelocal isn't behaving quite right
	return $t
		if (($format eq 'YYYY-MM-DD') &&
			($value=~/^(\d+)[\-\.\/](\d+)[\-\.\/](\d+)$/));

	$t = timegm(0, 0, 0, $3, $month{uc $2}, $1),
	$t -= ($t%86400), #	timelocal isn't behaving quite right
	return $t
		if (($format eq 'YYYY-MM-DD') &&
			($value=~/^(\d+)[\-\.\/](\w+)[\-\.\/](\d+)$/) &&
			defined($month{uc $2}));

	return timegm($6, $5, $4, $3, $2 - 1, $1) + ($7 ? $7 : 0)
		if (($format eq 'YYYY-MM-DD HH:MM:SS') &&
			($value=~/^(\d+)[\-\.\/](\d+)[\-\.\/](\d+)\s+(\d+):(\d+):(\d+)(\.\d+)?$/));

	return timegm($6, $5, $4, $3, $month{uc $2}, $1) + ($7 ? $7 : 0)
		if (($format eq 'YYYY-MM-DD HH:MM:SS') &&
			($value=~/^(\d+)[\-\.\/](\w+)[\-\.\/](\d+)\s+(\d+):(\d+):(\d+)(\.\d+)?$/) &&
			(defined($month{uc $2})));

	return (($1 ? (($1 eq '-') ? -1 : 1) : 1) * (($3 ? ($3 * 3600) : 0) + ($5 ? ($5 * 60) : 0) + 
		$6 + ($7 ? $7 : 0)))
		if ((($format eq '+HH:MM:SS') || ($format eq 'HH:MM:SS')) && 
			($value=~/^([\-\+])?((\d+):)?((\d+):)?(\d+)(\.\d+)?$/));

	return undef; # for completeness, shouldn't get here
}
#
#	restore the readable datetime form from 
#	the input numeric value
sub restore_temporal {
	my ($value, $format) = @_;

	my ($sign, $subsec, $sec, $min, $hour, $mday, $mon, $yr, $wday, $yday, $isdst);
	$sign = ($value < 0);
	$value = abs($value);
	if (($format eq '+HH:MM:SS') || ($format eq 'HH:MM:SS')) {
		$hour = int($value/3600);
		$min = int(($value%3600)/60);
		$sec = int($value%60);
		$hour = "0$hour" if ($hour < 10);
		$min = "0$min" if ($min < 10);
		$sec = "0$sec" if ($sec < 10);
		$subsec = int(($value - int($value)) * 100);

Chart/Plot.pm view on Meta::CPAN

	}
	return 1;
}

sub drawTitle {
	my ($obj) = @_;
	my ($w,$h) = (gdMediumBoldFont->width, gdMediumBoldFont->height);

# centered below chart
	my ($px,$py) = ($obj->{width}/2, $obj->{height} - 40 + $h);

	($px,$py) = ($px - length ($obj->{title}) * $w/2, $py-$h/2);
	$obj->string(7, 0, $px, $py, $obj->{title}, $w); 
}

sub drawSignature {
	my ($obj) = @_;
	my $fw = ($tfw * length($obj->{signature})) + 5;
# in lower right corner
	my ($px,$py) = ($obj->{width} - $fw, $obj->{height} - ($tfh * 2));

	$obj->string(5, 0, $px, $py, $obj->{signature}, $tfw); 
}

sub fill_region {
	my ($obj, $ci, $ary, $anchor) = @_;
	my $img = $obj->{img};
	my($x, $y, $xbot, $ybot, $xval);
	my @bottom;
#	
# Create a new polygon
	my $poly = GD::Polygon->new();
#
# Add the data points; data is organized as (x, ybot, ytop)
	for (my $i = 0; $i < @$ary; $i += 3)
	{
		next unless defined($$ary[$i]);
		$xval = $obj->{symDomain} ? ($i/3)+1 : $$ary[$i];
		($x, $y) = $obj->pt2pxl($xval, $$ary[$i+2]);
		($xbot, $ybot) = $obj->pt2pxl($xval, $$ary[$i+1]);
		$poly->addPt($x, $y);
		push @bottom, [$x, $ybot];
	}

	$poly->addPt($_->[0], $_->[1])
		foreach (reverse @bottom);

	# Draw a filled and a line polygon
	$img->filledPolygon($poly, $ci);
	$img->polygon($poly, $ci);

	1;
}

sub make_marker {
	my ($obj, $mtype, $mclr) = @_;

	my $brush = new GD::Image(9,9);
	my $white = $brush->colorAllocate(255, 255, 255);
	my $clr = $brush->colorAllocate(@{$colors{$mclr}});
	$brush->transparent($white);
	$mtype = $valid_shapes{$mtype};

# square, filled	
	$brush->filledRectangle(0,0,6,6,$clr),
	return $brush
		if ($mtype == 1);

# Square, open
	$brush->rectangle( 0, 0, 6, 6, $clr ),
	return $brush
		if ($mtype == 2);

# Cross, horizontal
	$brush->line( 0, 4, 8, 4, $clr ),
	$brush->line( 4, 0, 4, 8, $clr ),
	return $brush
		if ($mtype == 3);

# Cross, diagonal
	$brush->line( 0, 0, 8, 8, $clr ),
	$brush->line( 8, 0, 0, 8, $clr ),
	return $brush
		if ($mtype == 4);

# Diamond, filled
	$brush->line( 0, 4, 4, 8, $clr ),
	$brush->line( 4, 8, 8, 4, $clr ),
	$brush->line( 8, 4, 4, 0, $clr ),
	$brush->line( 4, 0, 0, 4, $clr ),
	$brush->fillToBorder( 4, 4, $clr, $clr ),
	return $brush
		if ($mtype == 5);

# Diamond, open
	$brush->line( 0, 4, 4, 8, $clr ),
	$brush->line( 4, 8, 8, 4, $clr ),
	$brush->line( 8, 4, 4, 0, $clr ),
	$brush->line( 4, 0, 0, 4, $clr ),
	return $brush
		if ($mtype == 6);

# Circle, filled
	$brush->arc( 4, 4, 8 , 8, 0, 360, $clr ),
	$brush->fillToBorder( 4, 4, $clr, $clr ),
	return $brush,
		if ($mtype == 7);

# must be Circle, open
	$brush->arc( 4, 4, 8, 8, 0, 360, $clr ),
	return $brush
		if ($mtype == 8);
#
#	dot - contributed by Andrea Spinelli
	$brush->setPixel( 4,4, $clr ),
	return  $brush
 		if ( $mtype == 10 );
}

sub getIcon {
	my ($obj, $icon, $isbar) = @_;

( run in 1.012 second using v1.01-cache-2.11-cpan-75ffa21a3d4 )