[libchart-strip-perl.git] 08/26: [svn-upgrade] Integrating new upstream version, libchart-strip-perl (1.07)
dom at earth.li
dom at earth.li
Sat Oct 29 22:44:51 UTC 2016
This is an automated email from the git hooks/post-receive script.
dom pushed a commit to branch master
in repository libchart-strip-perl.git.
commit eddde2d56d90c0bc650ffcde97d25d9222f4e290
Author: Dominic Hargreaves <dom at earth.li>
Date: Wed Jun 17 21:14:59 2009 +0000
[svn-upgrade] Integrating new upstream version, libchart-strip-perl (1.07)
---
CHANGES | 7 +
MANIFEST | 1 +
META.yml | 31 ++--
Strip.pm | 488 +++++++++++++++++++++++++++++++++++++++++++---------------
eg/Makefile | 2 +-
eg/ex6.png | Bin 0 -> 4872 bytes
eg/index.html | 1 +
7 files changed, 392 insertions(+), 138 deletions(-)
diff --git a/CHANGES b/CHANGES
index 5f6f52f..a03b1b8 100644
--- a/CHANGES
+++ b/CHANGES
@@ -1,4 +1,11 @@
+1.07
+ drop shadows
+ smooth curves
+
+1.06
+ ylabel placement calculation
+
1.05
xtic changes and speedups
diff --git a/MANIFEST b/MANIFEST
index 6641e60..2cedd48 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -19,4 +19,5 @@ eg/ex2.png
eg/ex3.png
eg/ex4.png
eg/ex5.png
+eg/ex6.png
META.yml Module meta-data (added by MakeMaker)
diff --git a/META.yml b/META.yml
index 53e3946..7f27be9 100644
--- a/META.yml
+++ b/META.yml
@@ -1,11 +1,22 @@
-# http://module-build.sourceforge.net/META-spec.html
-#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
-name: Chart-Strip
-version: 1.05
-version_from: Strip.pm
-installdirs: site
+--- #YAML:1.0
+name: Chart-Strip
+version: 1.07
+abstract: Draw strip chart type graphs.
+author:
+ - Jeff Weisberg <http://www.tcp4me.com/>
+license: unknown
+distribution_type: module
+configure_requires:
+ ExtUtils::MakeMaker: 0
+build_requires:
+ ExtUtils::MakeMaker: 0
requires:
- GD: 0
-
-distribution_type: module
-generated_by: ExtUtils::MakeMaker version 6.30
+ GD: 0
+no_index:
+ directory:
+ - t
+ - inc
+generated_by: ExtUtils::MakeMaker version 6.50
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
diff --git a/Strip.pm b/Strip.pm
index 69f396f..f79e7af 100644
--- a/Strip.pm
+++ b/Strip.pm
@@ -5,9 +5,9 @@
# Date: 2002-Nov-01 16:11 (EST)
# Function: draw strip charts
#
-# $Id: Strip.pm,v 1.15 2006/06/25 17:48:59 jaw Exp jaw $
+# $Id: Strip.pm,v 1.21 2009/03/28 17:34:54 jaw Exp $
-$Chart::Strip::VERSION = "1.05";
+$Chart::Strip::VERSION = "1.07";
=head1 NAME
@@ -67,42 +67,42 @@ The height of the image.
=item C<title>
The title of the graph. Will be placed centered at the top.
-
+
=item C<x_label>
The label for the x axis. Will be placed centered at the bottom.
-
+
=item C<y_label>
The label for the y axis. Will be placed vertically along the left side.
-
+
=item C<draw_grid>
Should a grid be drawn on the graph?
-
+
=item C<draw_border>
Should a border be drawn around the edge of the image?
-
+
=item C<draw_tic_labels>
Should value labels be shown?
-
+
=item C<draw_data_labels>
Should each data set be labeled?
-
+
=item C<transparent>
Should the background be transparent?
-
+
=item C<grid_on_top>
Should the grid be drawn over the data (1) or below the data (0)?
=item C<binary>
-Use powers of 2 instead of powers of 10 for the y axis labels.
+Use powers of 2 instead of powers of 10 for the y axis labels.
=item C<data_label_style>
@@ -130,24 +130,24 @@ in the data options or per point. If no width is specified a reasonable default
The data should be an array ref of data points. Each data point
should be a hash ref containing:
-
+
{
- time => $time_t, # must be a unix time_t
+ time => $time_t, # must be a unix time_t
value => $value, # the data value
color => $color, # optional, used for this one point
}
or, range style graphs should contain:
-
+
{
- time => $time_t, # must be a unix time_t
+ time => $time_t, # must be a unix time_t
min => $low, # the minimum data value
max => $high, # the maximum data value
color => $color, # optional, used for this one point
}
and the options may contain:
-
+
{
style => 'line', # graph style: line, filled, range, points, box
color => 'FF00FF', # color used for the graph
@@ -158,6 +158,16 @@ points style graphs may specify the point diameter, as C<diam>
box style graphs may specify the box width, as C<width>
+line and filled graphs may specify a C<smooth> parameter, to connect
+points using smooth curves instead of straight lines. A value of C<1>
+is recommended, larger values will be less smooth.
+
+line, points, box, and filled graphs may specify a drop shadow,
+consisting of a hashref containing C<dx>, C<dy>, C<dw>, and optionally, C<color>
+
+ shadow => { dx => 3, dy => 3, dw => 3, color => 'CCCCCC' }
+
+
=head2 Outputing The Image
=over 4
@@ -173,7 +183,7 @@ Will return the jpeg image
=item $chart->gd()
Will return the underlying GD object.
-
+
=back
=cut
@@ -198,7 +208,6 @@ my $MT_SU = 3; # sunday
my $MT_M1 = 4; # 1st
my $MT_Y1 = 5; # new years
-
sub new {
my $class = shift;
my %param = @_;
@@ -211,7 +220,7 @@ sub new {
margin_right => 8,
margin_top => 8,
n_y_tics => 4, # aprox.
-
+
transparent => 1,
grid_on_top => 1,
draw_grid => 1,
@@ -221,27 +230,33 @@ sub new {
limit_factor => 0,
data_label_style => 'text', # or 'box'
thickness => 1,
-
+ tm_time => \&POSIX::localtime, # or gmtime, or...
+ shadow_color => '#CCCCCC',
+# GD can only antialias on a truecolor image, and only if thickness==1
+# yes, I know what the GD documentation says. I also know what the src says...
+ antialias => 0,
+ truecolor => 0,
+
# title
# x_label
# y_label
-
+
# user specified params override defaults
%param,
-
+
}, $class;
$me->adjust();
- my $im = GD::Image->new( $me->{width}, $me->{height} );
+ my $im = GD::Image->new( $me->{width}, $me->{height}, $me->{truecolor} );
$me->{img} = $im;
-
- # Nor long the sun his daily course withheld,
- # But added colors to the world reveal'd:
- # When early Turnus, wak'ning with the light,
+
+ # Nor long the sun his daily course withheld,
+ # But added colors to the world reveal'd:
+ # When early Turnus, wak'ning with the light,
# -- Virgil, Aeneid
# allocate some useful colors, 1st is used for bkg
- $me->color({ color => $me->{background_color} }) if $me->{background_color};
+ my $bkg = $me->color({ color => $me->{background_color} }) if $me->{background_color};
$me->{color}{white} = $im->colorAllocate(255,255,255);
$me->{color}{black} = $im->colorAllocate(0,0,0);
$me->{color}{blue} = $im->colorAllocate(0, 0, 255);
@@ -256,8 +271,11 @@ sub new {
$im->transparent($me->{color}{white})
if $me->{transparent};
- $im->rectangle(0, 0, $me->{width}-1, $me->{height}-1,
- $me->color({ color => ($me->{border_color} || 'black') }))
+ $im->filledRectangle( 0, 0, $me->{width}-1, $me->{height}-1, ($bkg || $me->{color}{white}));
+
+ my $bc = $me->{border_color} ? $me->img_color($me->{border_color}) : $me->{color}{black};
+
+ $im->rectangle(0, 0, $me->{width}-1, $me->{height}-1, $bc )
if $me->{draw_border};
$me;
@@ -269,13 +287,14 @@ sub add_data {
my $opts = shift;
$me->analyze( $data, $opts );
-
+
unless( $opts->{style} ){
$opts->{style} = defined $data->[0]{min} ? 'range' : 'line';
}
-
+
push @{$me->{data}}, {data => $data, opts => $opts};
-
+ $me->{has_shadow} = 1 if $opts->{shadow};
+
$me;
}
@@ -286,13 +305,13 @@ sub plot {
return unless $me->{data};
return if $me->{all_done};
-
+
$me->adjust();
$me->clabels();
$me->xlabel();
$me->ylabel();
$me->title();
-
+
if( $me->{draw_tic_labels} ){
# move margin for xtics before we do ytics
$me->{margin_bottom} += 12;
@@ -301,14 +320,21 @@ sub plot {
$me->ytics();
$me->xtics();
+
+ # draw shadows
+ foreach my $d ( @{$me->{data}} ){
+ next unless $d->{opts}{shadow};
+ $me->plot_data( $d->{data}, $d->{opts}, $d->{opts}{shadow} );
+ }
+
$me->axii();
$me->drawgrid() unless $me->{grid_on_top};
-
+
# plot
foreach my $d ( @{$me->{data}} ){
- $me->plot_data( $d->{data}, $d->{opts} );
+ $me->plot_data( $d->{data}, $d->{opts}, undef );
}
-
+
$me->drawgrid() if $me->{grid_on_top};
$me->{all_done} = 1;
@@ -317,7 +343,7 @@ sub plot {
# The axis of the earth sticks out visibly through the centre of each and every town or city.
-# -- Oliver Wendell Holmes, The Autocrat of the Breakfast-Table
+# -- Oliver Wendell Holmes, The Autocrat of the Breakfast-Table
sub axii {
my $me = shift;
my $im = $me->{img};
@@ -325,7 +351,7 @@ sub axii {
# draw axii
$im->line( $me->xpt(-1), $me->ypt(-1), $me->xpt(-1), $me->ypt($me->{ymax}), $me->{color}{black});
$im->line( $me->xpt(-1), $me->ypt(-1), $me->xpt($me->{xmax}), $me->ypt(-1), $me->{color}{black});
-
+
# 'Talking of axes,' said the Duchess, 'chop off her head!'
# -- Alice in Wonderland
$me;
@@ -361,7 +387,7 @@ sub jpeg {
$me->plot();
$me->{img}->jpeg( @_ );
}
-
+
# xpt, ypt - convert graph space => image space
sub xpt {
@@ -393,13 +419,13 @@ sub ydatapt {
$pt = $pt < $me->{yd_min} ? $me->{yd_min} : $pt;
$pt = $pt > $me->{yd_max} ? $me->{yd_max} : $pt;
-
+
$me->ypt( ($pt - $me->{yd_min}) * $me->{yd_scale} );
}
sub adjust {
my $me = shift;
-
+
# I have touched the highest point of all my greatness;
# -- Shakespeare, King Henry VIII
$me->{xmax} = $me->{width} - $me->{margin_right} - $me->{margin_left};
@@ -408,11 +434,11 @@ sub adjust {
if( $me->{data} ){
$me->{xd_scale} = ($me->{xd_min} == $me->{xd_max}) ? 1
: $me->{xmax} / ($me->{xd_max} - $me->{xd_min});
-
+
$me->{yd_scale} = ($me->{yd_min} == $me->{yd_max}) ? 1
: $me->{ymax} / ($me->{yd_max} - $me->{yd_min});
}
-
+
$me;
}
@@ -425,7 +451,7 @@ sub analyze {
$st = $data->[0]{time}; # start time
$et = $data->[-1]{time}; # end time
$pt = $st;
-
+
foreach my $s (@$data){
croak "data point out of order" if $s->{time} < $pt;
my $a = defined $s->{min} ? $s->{min} : $s->{value};
@@ -433,7 +459,7 @@ sub analyze {
$a ||= 0 unless $me->{skip_undefined} || $opts->{skip_undefined};
$b ||= 0 unless $me->{skip_undefined} || $opts->{skip_undefined};
($a, $b) = ($b, $a) if $a > $b;
-
+
$min = $a if defined($a) && ( !defined($min) || $a < $min );
$max = $b if defined($b) && ( !defined($max) || $b > $max );
$pt = $s->{time};
@@ -451,7 +477,40 @@ sub analyze {
# boxes are drawn from y=0
$min = 0 if $min > 0;
}
-
+
+ if( $opts->{smooth} || $me->{smooth} ){
+ # calculate derivative at each point (which may or may not be evenly spaced)
+ for my $i (0 .. @$data-1){
+ my $here = $data->[$i];
+ my $left = $i ? $data->[$i-1] : $data->[$i];
+ my $right = ($i!=@$data-1) ? $data->[$i+1] : $data->[$i];
+
+ my $dxl = $here->{time} - $left->{time};
+ my $dxr = $right->{time} - $here->{time};
+ my $dyl = $here->{value} - $left->{value};
+ my $dyr = $right->{value} - $here->{value};
+
+ if( $dxr && $dxl ){
+ my $dl = $dyl / $dxl;
+ my $dr = $dyr / $dxr;
+ if( $dl < 0 && $dr > 0 || $dl > 0 && $dr < 0 ){
+ # local extrema
+ $data->[$i]{dydx} = 0;
+ }else{
+ my $dm = ( $dl * $dxr + $dr * $dxl ) / ($dxr + $dxl);
+ # mathematicaly, $dm is the best estimate of the derivative, and gives the smoothest curve
+ # but, this way looks nicer...
+ my $d = (sort { abs($a) <=> abs($b) } ($dl, $dr, $dm))[0];
+ $data->[$i]{dydx} = ($d + $dm) / 2;
+ }
+ }elsif($dxr){
+ $data->[$i]{dydx} = $dyr / $dxr;
+ }elsif($dxl){
+ $data->[$i]{dydx} = $dyl / $dxl;
+ }
+ }
+ }
+
$me->{xd_min} = $st if $st && (!defined($me->{xd_min}) || $st < $me->{xd_min});
$me->{xd_max} = $et if $et && (!defined($me->{xd_max}) || $et > $me->{xd_max});
$me->{yd_min} = $min if !defined($me->{yd_min}) || $min < $me->{yd_min};
@@ -484,6 +543,21 @@ sub set_x_range {
$me->adjust();
}
+sub img_color {
+ my $me = shift;
+ my $color = shift;
+
+ $color =~ s/^#//;
+ $color =~ s/\s//g;
+
+ return $me->{color}{$color} if $me->{color}{$color};
+ my($r,$g,$b) = map {hex} unpack('a2 a2 a2', $color);
+ my $i = $me->{img}->colorAllocate( $r, $g, $b );
+ $me->{color}{$color} = $i;
+
+ return $i;
+}
+
# choose proper color for plot
sub color {
my $me = shift;
@@ -495,14 +569,9 @@ sub color {
# -- Monty Python, Holy Grail
my $c = $data->{color} || $opts->{color};
if( $c ){
- return $me->{color}{$c} if $me->{color}{$c};
- my($r,$g,$b) = map {hex} unpack('a2 a2 a2', $c);
- my $i = $me->{img}->colorAllocate( $r, $g, $b );
-
- $me->{color}{$c} = $i;
- return $i;
+ return $me->img_color( $c );
}
-
+
return $me->{color}{green};
}
@@ -542,7 +611,8 @@ sub ylabel {
return unless $me->{y_label};
$me->{margin_left} += 12;
$me->adjust();
- $loc = ($me->{height} + length($me->{y_label}) * 6) / 2;
+ my $m = ($me->{height} - $me->{margin_top} - $me->{margin_bottom}) / 2 + $me->{margin_top};
+ $loc = $m + length($me->{y_label}) * 6 / 2;
$me->{img}->stringUp(gdSmallFont, 2, $loc, $me->{y_label}, $me->{color}{black});
# small => 12,6; tiny => 10,5
}
@@ -556,10 +626,11 @@ sub pretty {
my $st = shift;
my( $ay, $sc, $b, $prec );
+ return $me->{fmt_value}->($y) if $me->{fmt_value};
$sc = '';
$ay = abs($y);
$b = $me->{binary} ? 1024 : 1000;
-
+
if( $ay < 1 ){
if( $ay < 1/$b**3 ){
return "0";
@@ -611,7 +682,7 @@ sub ytics {
$min = $me->{yd_min};
$max = $me->{yd_max};
$maxw = 0;
-
+
if( $min == $max ){
# not a very interesting graph...
my $lb = $me->pretty($min, 1); # QQQ
@@ -635,11 +706,11 @@ sub ytics {
my $label = $me->pretty($y, $st);
my $w = 5 * length($label) + 6;
$maxw = $w if $w > $maxw;
-
+
push @tics, [$yy, $label, $w];
}
}
-
+
if( $me->{draw_tic_labels} ){
# move margin
$me->{margin_left} += $maxw;
@@ -652,7 +723,7 @@ sub ytics {
sub drawgrid {
my $me = shift;
my $im = $me->{img};
-
+
foreach my $tic (@{$me->{grid}{y}}){
# ytics + horiz lines
my $yy = $tic->[0];
@@ -696,7 +767,7 @@ sub drawgrid {
# too close to edge, shift
$a = $me->xdatapt($t) - $me->{width} + length($label) * 6 + 2;
}
-
+
$im->string(gdSmallFont, $me->xdatapt($t)-$a, $me->ypt(-6),
$label, $ll ? $me->{color}{red} : $me->{color}{black} );
}
@@ -711,7 +782,7 @@ sub xtic_range_data {
my $range_days = $range_hrs / 24;
# return: step, labeltype, marktype, lti, tmod
-
+
if( $range < 720 ){
(60, $LT_HM, $MT_HR, 1, 1); # tics: 1 min
}
@@ -763,7 +834,7 @@ sub xtic_range_data {
elsif( $range_days < 2000 ){
(3600*24*31, $LT_DM, $MT_NO, 4, 6); # tics: 6 month
}
-
+
else{
# NB: years less than 366 days are corrected for below
(3600*24*366, $LT_YR, $MT_NO, 4, 12); # tics: 1 yr
@@ -773,14 +844,14 @@ sub xtic_range_data {
sub xtic_align_initial {
my $me = shift;
my $step = shift;
-
+
my $t = ($step < 3600) ? (int($me->{xd_min} / $step) * $step)
: (int($me->{xd_min} / 3600) * 3600);
if( $step >= 3600*24*365 ){
while(1){
# search for 1jan
- my @lt = localtime $t;
+ my @lt = $me->{tm_time}($t);
last if $lt[4] == 0 && $lt[3] == 1 && $lt[2] == 0;
# jump fwd: 1M, 1D, or 1H
my $dt = ($lt[4] != 11) ? 24*30 : ($lt[3] < 30) ? 24 : 1;
@@ -790,7 +861,7 @@ sub xtic_align_initial {
elsif( $step >= 3600*24*31 ){
while(1){
# find 1st of mon
- my @lt = localtime $t;
+ my @lt = $me->{tm_time}($t);
last if $lt[3] == 1 && $lt[2] == 0;
my $dt = ($lt[3] < 28) ? 24 : 1;
$t += $dt * 3600;
@@ -799,7 +870,7 @@ sub xtic_align_initial {
elsif( $step >= 3600*24 ){
while(1){
# search for midnight
- my @lt = localtime $t;
+ my @lt = $me->{tm_time}($t);
last unless $lt[2];
$t += 3600;
}
@@ -818,17 +889,17 @@ sub xtics {
my $range = $me->{xd_max} - $me->{xd_min};
my $range_hrs = $range / 3600;
my $range_days = $range_hrs / 24;
-
+
my ($step, $labtyp, $marktyp, $lti, $tmod) = $me->xtic_range_data( $range );
my $t = $me->xtic_align_initial( $step );
# print "days: $range_days, lt: $labtyp, lti: $lti, tmod: $tmod, st: $step\n";
# print STDERR "t: $t ", scalar(localtime $t), "\n";
-
+
for( ; $t<$me->{xd_max}; $t+=$step ){
my $redmark = 0;
next if $t < $me->{xd_min};
- my @lt = localtime $t;
+ my @lt = $me->{tm_time}($t);
my @rlt = @lt;
# months go from 0. days from 1. absurd!
$lt[3]--;
@@ -849,7 +920,7 @@ sub xtics {
$t -= $dt;
redo;
}
-
+
next if $lt[$lti] % $tmod;
next if $lt[3] && $lti > 3;
next if $lt[2] && $lti > 2;
@@ -862,7 +933,7 @@ sub xtics {
$redmark = 1 if $marktyp == $MT_SU && !$lt[6]; # sunday
$redmark = 1 if $marktyp == $MT_M1 && !$lt[3]; # 1st of month
$redmark = 1 if $marktyp == $MT_Y1 && !$lt[3] && !$lt[4]; # 1 jan
-
+
my $label;
# NB: strftime obeys LC_TIME for localized day/month names
# (if locales are supported in the OS and perl)
@@ -896,7 +967,7 @@ sub xtics {
push @tics, [$t, $redmark, $label];
}
$me->{grid}{x} = \@tics;
-
+
}
# it shall be inventoried, and every particle and utensil
@@ -909,7 +980,7 @@ sub clabels {
my $me = shift;
return unless $me->{draw_data_labels};
-
+
my $rs = 0;
my $rm = 0;
if( $me->{data_label_style} eq 'box' ){
@@ -928,7 +999,7 @@ sub clabels {
next unless $l;
my $w = length($l) * 5 + 6;
$w += $rm + $rs;
-
+
if( $tw + $w > $me->{width} - $me->{margin_left} - $me->{margin_right} ){
$r ++;
$tw = 0;
@@ -960,31 +1031,32 @@ sub plot_data {
my $me = shift;
my $data = shift;
my $opts = shift;
+ my $shadow = shift;
return unless $data && @$data;
-
+
# 'What did they draw?' said Alice, quite forgetting her promise.
# -- Alice in Wonderland
if( $opts->{style} eq 'line' ){
# 'You can draw water out of a water-well,' said the Hatter
# -- Alice in Wonderland
- $me->draw_line( $data, $opts );
+ $me->draw_line( $data, $opts, $shadow );
}
elsif( $opts->{style} eq 'filled' ){
# I should think you could draw treacle out of a treacle-well
# -- Alice in Wonderland
- $me->draw_filled( $data, $opts );
+ $me->draw_filled( $data, $opts, $shadow );
}
elsif( $opts->{style} eq 'range' ){
# did you ever see such a thing as a drawing of a muchness?
# -- Alice in Wonderland
- $me->draw_range( $data, $opts );
+ $me->draw_range( $data, $opts, $shadow );
}elsif( $opts->{style} eq 'points' ){
# and they drew all manner of things--everything that begins with an M--'
# -- Alice in Wonderland
- $me->draw_points( $data, $opts );
+ $me->draw_points( $data, $opts, $shadow );
}elsif( $opts->{style} eq 'box' ){
- $me->draw_boxes( $data, $opts );
+ $me->draw_boxes( $data, $opts, $shadow );
}else{
croak "unknown graph style--cannot draw";
}
@@ -998,77 +1070,128 @@ sub draw_filled {
my $me = shift;
my $data = shift;
my $opts = shift;
+ my $shadow = shift;
my $im = $me->{img};
my $limit = $me->{limit_factor} * ($me->{xd_max} - $me->{xd_min}) / @$data;
my $skipundef = $opts->{skip_undefined} || $me->{skip_undefined};
- my($px, $py, $pxdpt, $pydpt);
+ my $thick = $opts->{thickness} || $me->{thickness};
+ my $smooth = $opts->{smooth} || $me->{smooth};
+ my $shcolor = $shadow ? $me->img_color($shadow->{color} || $me->{shadow_color} ) : undef;
+ my($px, $py, $pxdpt, $pydpt, $pdydx);
my $ypt0 = $me->ypt(0);
-
+
+ $thick += $shadow->{dw} if $shadow;
+ $me->set_thickness( $thick ) if $thick;
+
foreach my $s ( @$data ){
my $x = $s->{time};
my $y = $s->{value};
-
+
next if $x < $me->{xd_min} || $x > $me->{xd_max};
my $xdpt = $me->xdatapt($x);
my $ydpt = $me->ydatapt($y);
+ my $dydx;
+
+ if( $shadow ){
+ $xdpt += $shadow->{dx};
+ $ydpt += $shadow->{dy};
+ }
if( defined($y) || !$skipundef ){
-
+ my $color = $shadow ? $shcolor : $me->color($s, $opts);
+
if( defined($px) && ($xdpt - $pxdpt > 1) && (!$limit || $x - $px <= $limit) ){
- my $poly = GD::Polygon->new;
- $poly->addPt($pxdpt, $ypt0);
- $poly->addPt($pxdpt, $pydpt);
- $poly->addPt($xdpt, $ydpt);
- $poly->addPt($xdpt, $ypt0);
- $im->filledPolygon($poly, $me->color($s, $opts));
+ if( $smooth ){
+ next unless defined $s->{dydx};
+ $dydx = - $s->{dydx} * $me->{yd_scale} / $me->{xd_scale};
+ $me->curve($pxdpt, $pydpt, $pdydx,
+ $xdpt, $ydpt, $dydx,
+ $smooth, \&curve_filled, [$color, $ypt0]);
+ }else{
+ my $poly = GD::Polygon->new;
+ $poly->addPt($pxdpt, $ypt0);
+ $poly->addPt($pxdpt, $pydpt);
+ $poly->addPt($xdpt, $ydpt);
+ $poly->addPt($xdpt, $ypt0);
+ $im->filledPolygon($poly, $color);
+ }
}else{
$im->line( $xdpt, $ypt0,
$xdpt, $ydpt,
- $me->color($s, $opts) );
+ $color);
}
$px = $x; $pxdpt = $xdpt;
$py = $y; $pydpt = $ydpt;
+ $pdydx = $dydx;
}else{
$px = undef;
}
}
+ $me->set_thickness( 1 ) if $thick;
}
sub draw_line {
my $me = shift;
my $data = shift;
my $opts = shift;
+ my $shadow = shift;
my $im = $me->{img};
my $limit = $me->{limit_factor} * ($me->{xd_max} - $me->{xd_min}) / @$data;
my $thick = $opts->{thickness} || $me->{thickness};
my $skipundef = $opts->{skip_undefined} || $me->{skip_undefined};
- my($px, $py, $pxdpt, $pydpt);
+ my $smooth = $opts->{smooth} || $me->{smooth};
+ my($px, $py, $pxdpt, $pydpt, $pdydx);
+ $thick += $shadow->{dw} if $shadow;
$me->set_thickness( $thick ) if $thick;
-
+
+ my $shcolor = $shadow ? $me->img_color($shadow->{color} || $me->{shadow_color} ) : undef;
+
foreach my $s ( @$data ){
my $x = $s->{time};
my $y = $s->{value};
next if $x < $me->{xd_min} || $x > $me->{xd_max};
-
+
my $xdpt = $me->xdatapt($x);
my $ydpt = $me->ydatapt($y);
+ my $dydx = $smooth ? - $s->{dydx} * $me->{yd_scale} / $me->{xd_scale} : undef;
+
+ if( $shadow ){
+ $xdpt += $shadow->{dx};
+ $ydpt += $shadow->{dy};
+ }
if( defined($y) || !$skipundef ){
+ my $color = $shadow ? $shcolor : $me->color($s, $opts);
+
+ if( $me->{antialias} && $thick == 1 ){
+ # GD cannot antialias a thick line
+ $im->setAntiAliased($color);
+ $color = gdAntiAliased;
+ }
+
if( defined($px) && (!$limit || $x - $px <= $limit) ){
- $im->line( $pxdpt, $pydpt,
- $xdpt, $ydpt,
- $me->color($s, $opts) );
+ if( $smooth ){
+ next unless defined $s->{dydx};
+ $me->curve($pxdpt, $pydpt, $pdydx,
+ $xdpt, $ydpt, $dydx,
+ $smooth, \&curve_line, [$color]);
+ }else{
+ $im->line( $pxdpt, $pydpt,
+ $xdpt, $ydpt,
+ $color );
+ }
}else{
$im->setPixel($xdpt, $ydpt,
- $me->color($s, $opts) );
+ $color );
}
$px = $x; $pxdpt = $xdpt;
$py = $y; $pydpt = $ydpt;
+ $pdydx = $dydx;
}else{
$px = undef;
}
@@ -1076,29 +1199,116 @@ sub draw_line {
$me->set_thickness( 1 ) if $thick;
}
+# GD has only circular arcs, not bezier or cubic splines
+# bezier math is easier than trying to use circular arcs
+sub curve {
+ my $me = shift;
+ my( $x0, $y0, $dydx0,
+ $x1, $y1, $dydx1,
+ $smooth, $fnc, $args ) = @_;
+
+ # pick bezier control points
+ # smooth = (.5 - 1) gives nice curves
+ # smooth > 1 gives straighter segments
+ # smooth <= .5 takes the graph on a drug trip
+ my $dxt = ($x1 - $x0) / ($smooth * 3);
+ my $cx0 = $x0 + $dxt;
+ my $cx1 = $x1 - $dxt;
+ my $cy0 = $y0 + $dydx0 * $dxt;
+ my $cy1 = $y1 - $dydx1 * $dxt;
+
+ # bezier coefficients
+ my $ax = - $x0 + 3 * $cx0 - 3 * $cx1 + $x1;
+ my $ay = - $y0 + 3 * $cy0 - 3 * $cy1 + $y1;
+ my $bx = 3 * $x0 - 6 * $cx0 + 3 * $cx1;
+ my $by = 3 * $y0 - 6 * $cy0 + 3 * $cy1;
+ my $cx = - 3 * $x0 + 3 * $cx0;
+ my $cy = - 3 * $y0 + 3 * $cy0;
+ my $dx = $x0;
+ my $dy = $y0;
+
+ # draw bezier curve
+ my $px = $x0;
+ my $py = $y0;
+
+ # my $im = $me->{img};
+ # $im->line($x0,$y0, $cx0,$cy0, $me->img_color('00ff00'));
+ # $im->line($x1,$y1, $cx1,$cy1, $me->img_color('00ff00'));
+ # $im->line($cx0,$cy0, $cx1,$cy1, $me->img_color('0000ff'));
+
+ my $ymax = $me->{height} - $me->{margin_bottom};
+ my $ymin = $me->{margin_top};
+
+ my $T = ($x1 - $x0) + abs($y1 - $y0);
+ for my $tt (1 .. $T){
+ my $t = $tt / $T;
+ my $x = $ax * $t**3 + $bx * $t**2 + $cx * $t + $dx;
+ my $y = $ay * $t**3 + $by * $t**2 + $cy * $t + $dy;
+
+ # QQQ - handle out-of-bounds segments how?
+ if( $y >= $ymin && $y <= $ymax && $py >= $ymin && $py <= $ymax ){
+ $fnc->($me, $px,$py, $x,$y, 0, @$args);
+ }else{
+ $fnc->($me, $px,$py, $x,$y, [$ymin, $ymax], @$args);
+ }
+ $px = $x; $py = $y;
+ }
+}
+
+sub curve_line {
+ my $me = shift;
+ my ($px, $py, $x, $y, $oob, $color) = @_;
+
+ return if $oob;
+ $me->{img}->line($px,$py, $x,$y, $color);
+}
+
+sub curve_filled {
+ my $me = shift;
+ my ($px, $py, $x, $y, $oob, $color, $y0) = @_;
+
+ if( $oob ){
+ my($ymin, $ymax) = @$oob;
+ $y = $ymin if $y < $ymin;
+ $py = $ymin if $py < $ymin;
+ $y = $ymax if $y > $ymax;
+ $py = $ymax if $py > $ymax;
+ }
+
+ my $poly = GD::Polygon->new;
+ $poly->addPt($px, $y0);
+ $poly->addPt($px, $py);
+ $poly->addPt($x, $y);
+ $poly->addPt($x, $y0);
+ $me->{img}->filledPolygon($poly, $color);
+}
+
+
sub draw_range {
my $me = shift;
my $data = shift;
my $opts = shift;
-
+ my $shadow = shift;
+
+ return if $shadow;
my $im = $me->{img};
my $limit = $me->{limit_factor} * ($me->{xd_max} - $me->{xd_min}) / @$data;
my $skipundef = $opts->{skip_undefined} || $me->{skip_undefined};
my($px, $pn, $pm, $pxdpt);
-
+
foreach my $s ( @$data ){
my $x = $s->{time};
my $a = defined $s->{min} ? $s->{min} : $s->{value};
my $b = defined $s->{max} ? $s->{max} : $s->{value};
my $xdpt = $me->xdatapt($x);
-
+
next if $x < $me->{xd_min} || $x > $me->{xd_max};
-
+
$a = $b if !defined($a) && $skipundef;
$b = $a if !defined($b) && $skipundef;
-
+
if( defined($a) || !$skipundef ){
-
+
if( defined($px) && ($xdpt - $pxdpt > 1) && (!$limit || $x - $px <= $limit) ){
my $poly = GD::Polygon->new;
$poly->addPt($pxdpt, $me->ydatapt($pn));
@@ -1123,21 +1333,29 @@ sub draw_points {
my $me = shift;
my $data = shift;
my $opts = shift;
-
+ my $shadow = shift;
+
my $im = $me->{img};
my $skipundef = $opts->{skip_undefined} || $me->{skip_undefined};
-
+ my $shcolor = $shadow ? $me->img_color($shadow->{color} || $me->{shadow_color} ) : undef;
+
foreach my $s ( @$data ){
my $x = $s->{time};
my $y = $s->{value};
my $d = $s->{diam} || $opts->{diam} || 4;
- my $c = $me->color($s, $opts);
+ my $c = $shadow ? $shcolor : $me->color($s, $opts);
next if $x < $me->{xd_min} || $x > $me->{xd_max};
next if !defined($y) && $skipundef;
my $xdpt = $me->xdatapt($x);
my $ydpt = $me->ydatapt($y);
-
+
+ if( $shadow ){
+ $d += $shadow->{dw};
+ $xdpt += $shadow->{dx};
+ $ydpt += $shadow->{dy};
+ }
+
while( $d > 0 ){
$im->arc( $xdpt, $ydpt,
$d, $d, 0, 360,
@@ -1161,39 +1379,47 @@ sub draw_boxes {
my $me = shift;
my $data = shift;
my $opts = shift;
-
+ my $shadow = shift;
+
my $im = $me->{img};
my $defwid = def_box_width($data->[0]{time}, $data->[-1]{time}, scalar(@$data));
my $thick = $opts->{thickness} || $me->{thickness};
my $skipundef = $opts->{skip_undefined} || $me->{skip_undefined};
-
+ my $shcolor = $shadow ? $me->img_color($shadow->{color} || $me->{shadow_color} ) : undef;
+
+ $thick += $shadow->{dw} if $shadow;
$me->set_thickness( $thick ) if $thick;
-
+
foreach my $s ( @$data ){
my $x = $s->{time};
my $y = $s->{value};
my $w = $s->{width} || $opts->{width} || $me->{boxwidth} || $defwid;
- my $c = $me->color($s, $opts);
my $y0 = $opts->{boxbase} || $me->{boxbase} || 0;
-
+ my $c = $shadow ? $shcolor : $me->color($s, $opts);
+
next if $x < $me->{xd_min} || $x > $me->{xd_max};
next if !defined($y) && $skipundef;
# because GD cares...
- my $ya = $y > $y0 ? $y : $y0;
- my $yb = $y > $y0 ? $y0 : $y;
-
+ my $ya = $me->ydatapt($y > $y0 ? $y : $y0);
+ my $yb = $me->ydatapt($y > $y0 ? $y0 : $y);
+ my $xa = $me->xdatapt($x - $w/2);
+ my $xb = $me->xdatapt($x + $w/2);
+
+ if( $shadow ){
+ $xa += $shadow->{dx};
+ $xb += $shadow->{dx};
+ $ya += $shadow->{dy};
+ $yb += $shadow->{dy};
+ }
+
if( $opts->{filled} || $s->{filled} ){
- $im->filledRectangle( $me->xdatapt($x - $w/2), $me->ydatapt($ya),
- $me->xdatapt($x + $w/2), $me->ydatapt($yb),
- $c);
+ $im->filledRectangle( $xa, $ya, $xb, $yb, $c);
}else{
- $im->rectangle( $me->xdatapt($x - $w/2), $me->ydatapt($ya),
- $me->xdatapt($x + $w/2), $me->ydatapt($yb),
- $c);
+ $im->rectangle( $xa, $ya, $xb, $yb, $c);
}
}
-
+
$me->set_thickness( 1 ) if $thick;
}
@@ -1201,14 +1427,22 @@ sub draw_boxes {
=head1 EXAMPLE IMAGES
http://argus.tcp4me.com/shots.html
- http://search.cpan.org/src/JAW/Chart-Strip-1.05/eg/
+ http://search.cpan.org/src/JAW/Chart-Strip-1.07/eg/
+
+=head1 LICENSE
+
+This software may be copied and distributed under the terms
+found in the Perl "Artistic License".
+
+A copy of the "Artistic License" may be found in the standard
+Perl distribution.
=head1 BUGS
There are no known bugs in the module.
=head1 SEE ALSO
-
+
Yellowstone National Park.
=head1 AUTHOR
diff --git a/eg/Makefile b/eg/Makefile
index a9b7574..a2b3816 100644
--- a/eg/Makefile
+++ b/eg/Makefile
@@ -1,5 +1,5 @@
-all: ex1.png ex2.png ex3.png ex4.png ex5.png
+all: ex1.png ex2.png ex3.png ex4.png ex5.png ex6.png
.SUFFIXES: .pl .png
.pl.png:
diff --git a/eg/ex6.png b/eg/ex6.png
new file mode 100644
index 0000000..88355f4
Binary files /dev/null and b/eg/ex6.png differ
diff --git a/eg/index.html b/eg/index.html
index 517c22b..101f854 100644
--- a/eg/index.html
+++ b/eg/index.html
@@ -7,6 +7,7 @@
<IMG SRC="ex3.png"><P>
<IMG SRC="ex4.png"><P>
<IMG SRC="ex5.png"><P>
+<IMG SRC="ex6.png"><P>
</BODY>
</HTML>
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libchart-strip-perl.git.git
More information about the Pkg-perl-cvs-commits
mailing list