version 1.4, 2001/12/12 18:36:44
|
version 1.12, 2006/09/06 19:26:07
|
Line 1
|
Line 1
|
#!/usr/bin/perl -w |
#!/usr/bin/perl |
# |
# |
# $Id$ |
# $Id$ |
# |
# |
Line 24
|
Line 24
|
# |
# |
# http://www.lon-capa.org/ |
# http://www.lon-capa.org/ |
# |
# |
########################################################################### |
use strict; |
# |
|
# CGI-BIN interface to GD, used for making mathematical plots. |
|
# |
|
# User specifies the following variables (given are defaults): |
|
# height = "100" |
|
# width = "100" |
|
# xmin = "-10.0" |
|
# xmax = " 10.0" |
|
# ymin = "-10.0" |
|
# ymax = " 10.0" |
|
# transparent (doesn't work with gif?) |
|
# frame |
|
# drawaxes |
|
# drawtics |
|
# vtic_every = "1.0" |
|
# htic_every = "1.0" |
|
# xseries1 = "x1,x2,x3,x4,x5,...,xn" |
|
# yseries1 = "y1,y2,y3,y4,y5,...,yn" |
|
# xseries2 = .. |
|
# yseries2 = .. |
|
# ... |
|
# label1 = "x,y,size,text" |
|
# label2 = "x,y,size,text" |
|
# label3 = "x,y,size,text" |
|
# ... |
|
# |
|
# size of a labelN is one of : |
|
# giant, large, medium, small, tiny |
|
# |
|
########################################################################### |
|
## |
|
## Data structures & file description |
|
## |
|
## The input file is taken to be comprised of "segments". Each "segment" |
|
## will hold data for the plot header, the coordinate axes, or (more likely) |
|
## the curves, circles, and polygons that are to be plotted. |
|
## |
|
## The global array @Segments holds references to hashes which contain the |
|
## data needed for each structure. |
|
## |
|
use FileHandle; |
|
use GD; |
|
|
|
my ($image,$axis); |
|
$filename = shift; |
|
# GET FILENAME AND OPEN THE FILE, BAIL OUT IF UNABLE TO DO SO |
|
$fh = new FileHandle("<$filename"); |
|
my @Segments = &read_file($fh); |
|
|
|
foreach $segment (@Segments) { |
|
&set_defaults($segment); |
|
} |
|
&init_image(&get_specific_segment(\@Segments,'plotheader'), |
|
&get_specific_segment(\@Segments,'axis')); |
|
|
|
for (my $i =0; $i<=$#Segments; $i++) { |
|
grok_segment($Segments[$i]); |
|
} |
|
&write_image(); |
|
|
|
#---------------------------------------------------- convenience functions |
|
sub write_image { |
|
# Tell the browser our mime-type |
|
# print <<END; |
|
#Content-type: image/gif |
|
# |
|
#END |
|
my $BinaryData=$image->png; |
|
undef $image; |
|
binmode(STDOUT); |
|
open IMG,"|pngtopnm|ppmtogif 2>/dev/null"; # convert into a gif image |
|
print IMG $BinaryData; # output image |
|
$|=1; # be sure to flush before closing |
|
close IMG; |
|
} |
|
|
|
sub grok_segment { |
|
$_ = shift; |
|
my %Data = %$_; |
|
$type = $Data{'type'}; |
|
if (!defined($type)) { |
|
return undef; |
|
} elsif ($type eq 'frame') { |
|
draw_frame(\%Data); |
|
} elsif ($type eq 'curve') { |
|
draw_curve(\%Data); |
|
} elsif ($type eq 'label') { |
|
draw_label(\%Data); |
|
} elsif ($type eq 'circle') { |
|
draw_circle(\%Data); |
|
} elsif ($type eq 'polygon') { |
|
draw_polygon(\%Data); |
|
} elsif ($type eq 'line') { |
|
draw_line(\%Data); |
|
} |
|
} |
|
|
|
sub get_specific_segment { |
|
$_ = shift; |
|
my @Segments = @$_; |
|
my $type = shift; |
|
for ($i = 0; $i<=$#Segments; $i++) { |
|
if ($Segments[$i]->{'type'} eq $type) { |
|
return (splice @Segments, $i,1); |
|
} |
|
} |
|
return undef; |
|
} |
|
|
|
#---------------------------------------------------- plot description reading |
|
sub read_file { |
|
my @Returned_Segments; |
|
my $fh = shift; |
|
($ret,$ref) = read_segment($fh); |
|
while (defined($ret) && $ret !=0) { |
|
push @Returned_Segments,$ref; |
|
($ret,$ref) = read_segment($fh); |
|
} |
|
return @Returned_Segments; |
|
} |
|
|
|
sub newhash{ |
|
my %H; |
|
return \%H; |
|
} |
|
|
|
sub read_segment{ |
|
# Reads in a segment of a plotting file. |
|
# Returns 1,\%Data on success (or parital success) |
|
# Returns 0, undef on failure; |
|
$fh = shift; |
|
my $Data = newhash(); |
|
|
|
$_ = <$fh>; |
|
if (! /^NEW /) { |
|
return undef; |
|
} |
|
|
|
while($_=<$fh>) { |
|
last if (/^END /); |
|
# Lines are of the form "type::var=value", "NEW type", or "END type" |
|
chomp; |
|
return(0,undef) if (/^NEW /); |
|
if (/(\w+)::(\w+)[\s]*=\s*\"([\w\s,\-\+\.]+)\"/) { |
|
$Data->{'type'} = $1 if (!exists ($Data->{'type'})); |
|
return(0,$Data) if ($Data->{'type'} ne $1); |
|
$Data->{$2} = $3; |
|
} else { |
|
# Something went wrong - bad input - what to do? |
|
} |
|
} |
|
return (1,$Data); |
|
} |
|
|
|
#------------------------------------------------------- |
|
sub init_image { |
|
my $PlotHeader = shift; |
|
$axis = shift; |
|
# Take care of making the image |
|
my ($width,$height) = ($PlotHeader->{'width'},$PlotHeader->{'height'}); |
|
|
|
$image = new GD::Image($width,$height); |
|
my $bgcolor = $image->colorAllocate(split/,/,$PlotHeader->{'bgcolor'}); |
|
my $fgcolor = $image->colorAllocate(split/,/,$PlotHeader->{'fgcolor'}); |
|
$image->transparent($bgcolor) if ($PlotHeader->{'transparent'} eq 'true'); |
|
|
|
$axis->{'xlen'} = $axis->{'xmax'} - $axis->{'xmin'}; |
|
$axis->{'ylen'} = $axis->{'ymax'} - $axis->{'ymin'}; |
|
if ($axis->{'drawaxis'} eq 'true') { |
|
&draw_axes(); |
|
} |
|
if ($axis->{'drawtics'} eq 'true') { |
|
&draw_tics(); |
|
} |
|
} |
|
|
|
#-------------------------------------------------------- axis routines |
|
sub draw_axes{ |
|
my $color = $image->colorResolve(split /,/,$axis->{'color'}); |
|
($x1,$y1) = &transformPoint($axis->{"xmin"},0,$image,$axis); |
|
($x2,$y2) = &transformPoint($axis->{"xmax"},0,$image,$axis); |
|
$image->line($x1,$y1,$x2,$y2,$color); |
|
($x1,$y1) = &transformPoint(0,$axis->{"ymin"},$image,$axis); |
|
($x2,$y2) = &transformPoint(0,$axis->{"ymax"},$image,$axis); |
|
$image->line($x1,$y1,$x2,$y2,$color); |
|
} |
|
|
|
sub draw_tics{ |
|
my $color = $image->colorResolve(split /,/, $axis->{'color'}); |
|
my ($htic_every,$vtic_every) = ($axis->{'htic_every'}, $axis->{'vtic_every'}); |
|
my ($width,$height) = $image->getBounds(); |
|
|
|
my $ticwidth = ($width > 99 ? 5 : int($width /20) + 1); |
|
my $ticheight = ($height > 99 ? 5 : int($height/20) + 1); |
|
|
|
# Do tics along y-axis |
$|=1; |
for ($ntic = 0; $ntic <=int($axis->{"ylen"}/$vtic_every); $ntic++){ |
|
my ($x1,$y1) = &transformPoint(0,$axis->{"ymin"}+$ntic*$vtic_every); |
|
my ($x2,$y2) = &transformPoint(0,$axis->{"ymin"}+$ntic*$vtic_every); |
|
$x1 -= $ticwidth; |
|
$x2 += $ticwidth; |
|
$image->line($x1,$y1,$x2,$y2,$color); |
|
} |
|
# Do tics along x-axis |
|
for ($ntic = 0; $ntic <=int($axis->{"xlen"}/$htic_every); $ntic++){ |
|
my ($x1,$y1) = &transformPoint( $axis->{"xmin"}+$ntic*$htic_every,0); |
|
my ($x2,$y2) = &transformPoint( $axis->{"xmin"}+$ntic*$htic_every,0); |
|
$y1 -= $ticheight; |
|
$y2 += $ticheight; |
|
$image->line($x1,$y1,$x2,$y2,$color); |
|
} |
|
} |
|
|
|
#------------------------------------------------------- misc plotting routines |
|
sub draw_frame { |
|
my $Frame = shift; |
|
my ($width,$height) = $image->getBounds(); |
|
my $color = $image->colorResolve(split /,/,$Frame->{'color'} ); |
|
# Draw a frame around the picture. |
|
my $offset = $Frame->{'offset'}; |
|
for (my $i = 0; $i<=$Frame->{'thickness'}; $i++) { |
|
$image->rectangle( |
|
$offset - 1, |
|
$offset - 1, |
|
$width-$offset, |
|
$height-$offset, |
|
$color); |
|
} |
|
} |
|
|
|
sub draw_line{ |
|
my $Line = shift; |
|
my $color = $image->colorResolve(split/,/, $Line->{'color'}); |
|
my ($x1,$y1) = &transformPoint($Line->{'x1'},$Line->{'y1'}); |
|
my ($x2,$y2) = &transformPoint($Line->{'x2'},$Line->{'y2'}); |
|
$image->line($x1,$y1,$x2,$y2,$color); |
|
} |
|
|
|
sub draw_curve{ |
|
my $Curve = shift; |
|
my $color = $image->colorResolve(split /,/, $Curve->{'color'}); |
|
@X = split /,/,$Curve->{'xdata'}; |
|
@Y = split /,/,$Curve->{'ydata'}; |
|
if ($#X != $#Y) { |
|
return 0; |
|
} |
|
for($i=0;$i< $#X ;$i++) { |
|
my ($x1,$y1) = &transformPoint($X[$i] ,$Y[$i]); |
|
my ($x2,$y2) = &transformPoint($X[$i+1],$Y[$i+1]); |
|
$image->line($x1,$y1,$x2,$y2,$color); |
|
} |
|
} |
|
|
|
sub draw_label{ |
my $tmpdir = '/home/httpd/perl/tmp/'; |
my $Label = shift; |
my %data; |
my $color = $image->colorResolve(split /,/, $Label->{'color'}); |
foreach (split/&/,$ENV{'QUERY_STRING'}) { |
my $fontname = $Label->{'font'}; |
my ($name,$value)=split/=/; |
my $font = gdGiantFont if (lc($fontname) eq "giant" || |
$data{$name}=$value; |
lc($fontname) eq "huge" ); |
} |
$font = gdLargeFont if (lc($fontname) eq "large" ); |
my $filename = $data{'file'}; |
$font = gdMediumBoldFont if (lc($fontname) eq "medium"); |
# unescape filename |
$font = gdSmallFont if (lc($fontname) eq "small" ); |
$filename =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; |
$font = gdTinyFont if (lc($fontname) eq "tiny" ); |
die if ($filename =~ /\// || $filename !~ /_plot.data$/); |
my $text = $Label->{'text'}; |
$filename = $tmpdir . $filename; |
if (! defined($font)) { |
die "$data{'file'} does not exist\n" if (! -e $filename); |
$font = gdGiantFont; |
|
$text = "Font size error!"; |
my $output = $data{'output'}; |
} |
if ($output eq '') { |
my ($x,$y) = &transformPoint($Label->{'x'},$Label->{'y'}); |
$output = (split('\.',$0))[-1]; |
$image->string($font,$x,$y,$text,$color); |
} |
} |
|
|
if ($output eq 'gif' || $output eq 'png') { |
sub draw_circle { |
open PLOT, "gnuplot $filename |"; |
my $Circle = shift; |
print <<"END"; |
my ($width,$height) = $image->getBounds(); |
Content-type: image/$output |
my $color = $image->colorResolve(split /,/, $Circle->{'color'}); |
|
my ($x,$y) = &transformPoint(split/,/,$Circle->{'center'}); |
END |
my $xradius = $Circle->{'radius'} * $width / $axis->{'xlen'}; |
while ($_=<PLOT>) { |
my $yradius = $Circle->{'radius'} * $height / $axis->{'ylen'}; |
print; |
# draw a semicircle centered at 100,100 |
} |
$image->arc($x,$y,$xradius,$yradius,0,360,$color); |
} elsif ($output eq 'eps') { |
$image->fill($x,$y,$color) if ($Circle->{'filled'} eq 'true'); |
print <<"END"; |
} |
Content-type: text/html |
|
|
sub draw_polygon { |
<html><head><title>eps plot creation</title></head> |
my $Poly = shift; |
<body> |
my $color = $image->colorResolve(split /,/, $Poly->{'color'}); |
<h2>Creating eps plot</h2> |
@X = split /,/,$Poly->{'xdata'}; |
|
@Y = split /,/,$Poly->{'ydata'}; |
END |
if ($#X != $#Y) { |
if (! system ("gnuplot $filename")) { |
return 0; |
print "<h2>An error occured.</h2>\n". |
} |
"I am not going to tell you about it as I have not bothered ". |
my $poly = new GD::Polygon; |
"to figure out how to get you the error text.\n"; |
for ($i=0;$i<=$#X;$i++) { |
|
$poly->addPt(&transformPoint($X[$i],$Y[$i])); |
|
} |
|
if ($Poly->{'filled'} eq 'true') { |
|
$image->filledPolygon($poly,$color); |
|
} else { |
} else { |
$image->polygon($poly,$color); |
print "<h2>EPS file generated successfully.</h2>\n"; |
} |
|
} |
|
|
|
#------------------------------------------ transform point (basic routine) |
|
# |
|
# transformPoint(x,y) where x,y are in the coordinates of axis will return |
|
# the coordinates transformed to the image coordinate system. |
|
sub transformPoint{ |
|
my ($x,$y) = @_; |
|
my ($width,$height) = $image->getBounds(); |
|
$x = ( $x - $axis->{"xmin"}) * $width / ( $axis->{"xlen"}); |
|
$y = ( ( $axis->{"ylen"} ) - ($y - $axis->{"ymin"})) |
|
* $height / ( $axis->{"ylen"} ); |
|
return($x,$y); |
|
} |
|
|
|
#------------------------------------------ set defaults is a beast! |
|
|
|
sub set_defaults { |
|
my $PlotHeader = { |
|
type => "plotheader", |
|
name => "plot", |
|
height => "200", |
|
width => "300", |
|
bgcolor => "255,255,255", |
|
fgcolor => " 0, 0, 0", |
|
transparent => "true" |
|
}; |
|
|
|
my $Axis = { |
|
type => "axis", |
|
name => "axis", |
|
color => " 0, 0, 0", |
|
drawtics => "true", |
|
vtic_every => " 1.0", |
|
htic_every => " 1.0", |
|
xmin => "-10.0", |
|
ymin => " -5.0", |
|
xmax => " 10.0", |
|
ymax => " 5.0", |
|
drawaxis => "true" |
|
}; |
|
|
|
my $Frame = { |
|
type => "frame", |
|
color => " 0, 0, 0", |
|
offset => "1.0", |
|
thickness => "1.0", |
|
drawframe => "true" |
|
}; |
|
|
|
my $Curve= { |
|
type => "curve", |
|
name => "curve", |
|
color => " 0, 0, 0", |
|
xdata => " 1.0, 2.0, 3.0, 4.0, 5.0, 6.0", |
|
ydata => " 1.0, 2.0, 3.0, 4.0, 5.0, 6.0" |
|
}; |
|
|
|
my $Label = { |
|
type => "label", |
|
name => "label", |
|
font => "medium", |
|
text => "default label text", |
|
color => " 0, 0, 0", |
|
x => " -5.0", |
|
y => " 5.0" |
|
}; |
|
|
|
my $Circle = { |
|
type => "circle", |
|
name => "circle", |
|
color => " 0, 0, 0", |
|
filled => "true", |
|
center => "x,y", |
|
radius => "12.0" |
|
}; |
|
|
|
my $Polygon = { |
|
type => "polygon", |
|
name => "polygon", |
|
color => " 0, 0, 0", |
|
filled => "true", |
|
xdata => "1.0, 0.5, 0.0, -0,5, -1.0, -0.5, 0.0, 0.5", |
|
ydata => "0.0,-0.5,-1.0, -0.5, 0.0, 0.5, 1.0, 0.5" |
|
}; |
|
|
|
my $Line = { |
|
type => "line", |
|
name => "line", |
|
color => " 0, 0, 0", |
|
x1 => "1.0", |
|
y1 => "0.0", |
|
x2 => "2.0", |
|
y2 => "4.0" |
|
}; |
|
|
|
my $typematch = { |
|
plotheader => $PlotHeader, |
|
axis => $Axis, |
|
frame => $Frame, |
|
label => $Label, |
|
curve => $Curve, |
|
circle => $Circle, |
|
polygon => $Polygon |
|
}; |
|
|
|
my $seg = shift; |
|
if (exists($typematch->{$seg->{'type'}})) { |
|
my $H = $typematch->{$seg->{'type'}}; |
|
foreach $key (keys %$H) { |
|
if (! exists($seg->{$key})) { |
|
$seg->{$key} = $H->{$key}; |
|
} |
|
} |
|
} |
} |
|
print "</body></html>\n"; |
|
} else { |
|
die "output $output is not a recognized value or has no value\n"; |
} |
} |
|
|
|
|
|
|