# The LearningOnline Network with CAPA
# Dynamic plot
#
# $Id: lonplot.pm,v 1.10 2001/12/20 19:20:43 matthew Exp $
#
# Copyright Michigan State University Board of Trustees
#
# This file is part of the LearningOnline Network with CAPA (LON-CAPA).
#
# LON-CAPA is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# LON-CAPA is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with LON-CAPA; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# /home/httpd/html/adm/gpl.txt
#
# http://www.lon-capa.org/
#
# 12/15/01 Matthew
# 12/18 12/19 12/20 Matthew
package Apache::lonplot;

use strict;
use Apache::File;
use Apache::response;
use Apache::lonxml;

use Digest::MD5  qw(md5 md5_hex md5_base64);

sub BEGIN {
  &Apache::lonxml::register('Apache::lonplot',('plot'));
}

## 
## Description of data structures:
##
##  %plot       %key    %axis
## --------------------------
##  height      title   color
##  width       box     xmin
##  bgcolor     pos     xmax
##  fgcolor             ymin
##  transparent         ymax
##  grid
##  border
##  font
##
##  @labels: $labels[$i] = \%label
##           %label: text, xpos, ypos, justify
## 
##  @curves: $curves[$i] = \%curve
##        %curve: name, linestyle, ( function | data )
##
##  $curves[$i]->{'data'} = [ [x1,x2,x3,x4],
##                            [y1,y2,y3,y4] ]
##
##------------------------------------------------------------
##
## Tests used in checking the validitity of input
##
my $int_test       = sub {$_[0]=~/^\d+$/};
my $real_test      = sub {$_[0]=~/^[+-]?\d*\.?\d*$/};
my $color_test     = sub {$_[0]=~/^x[\da-f]{6}$/};
my $onoff_test     = sub {$_[0]=~/^(on|off)$/};
my $key_pos_test   = sub {$_[0]=~/^(top|bottom|right|left|outside|below)+$/};
my $sml_test       = sub {$_[0]=~/^(small|medium|large)$/};
my $linestyle_test = sub {$_[0]=~/^(lines|linespoints|dots|points|steps)$/};
my $words_test     = sub {$_[0]=~/^(\w+ *)+$/};
##
## Default values for attributes of elements
##
my %plot_defaults = 
    (
     height       => {default => 200,       test => $int_test   },
     width        => {default => 200,       test => $int_test   },
     bgcolor      => {default => 'xffffff', test => $color_test },
     fgcolor      => {default => 'x000000', test => $color_test },
     transparent  => {default => 'off',     test => $onoff_test },
     grid         => {default => 'off',     test => $onoff_test },
     border       => {default => 'on',      test => $onoff_test },
     font         => {default => 'medium',  test => $sml_test   }
     );

my %key_defaults = 
    (
     title => { default => '',          test => $words_test   },
     box   => { default => 'off',       test => $onoff_test   },
     pos   => { default => 'top right', test => $key_pos_test }
     );

my %label_defaults = 
    (
     xpos    => {default => 0,         test => $real_test     },
     ypos    => {default => 0,         test => $real_test     },
     justify => {default => 'left',    
                 test => sub {$_[0]=~/^(left|right|center)$/} }
     );

my %axis_defaults = 
    (
     color     => {default => 'x000000', test => $color_test},
     xmin      => {default => -10.0,     test => $real_test },
     xmax      => {default =>  10.0,     test => $real_test },
     ymin      => {default => -10.0,     test => $real_test },
     ymax      => {default =>  10.0,     test => $real_test }
     );

my %curve_defaults = 
    (
     color     => {default => 'x000000', test => $color_test             },
     name      => {default => 'x000000', test => sub {$_[0]=~/^[\w ]*$/} },
     linestyle => {default => 'lines',   test => $linestyle_test         }
     );

##
## End of defaults
##
my (%plot,%key,%axis,$title,$xlabel,$ylabel,@labels,@curves);

sub start_plot {
    %plot    = undef;   %key     = undef;   %axis   = undef; 
    $title   = undef;   $xlabel  = undef;   $ylabel = undef;
    $#labels = -1;      $#curves = -1;
    #
    my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
    my $result='';
    &Apache::lonxml::register('Apache::lonplot',
	     ('title','xlabel','ylabel','key','axis','label','curve'));
    push (@Apache::lonxml::namespace,'plot');
    ## Always evaluate the insides of the <plot></plot> tags
    my $inside = &Apache::lonxml::get_all_text("/plot",$$parser[-1]);
    $inside=&Apache::run::evaluate($inside,$safeeval,$$parstack[-1]);
    &Apache::lonxml::newparser($parser,\$inside);
    ##-------------------------------------------------------
    &get_attributes(\%plot,\%plot_defaults,$parstack,$safeeval,$tagstack);
    if ($target eq 'web') {
    }
    return '';
}

sub end_plot {
    my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
    pop @Apache::lonxml::namespace;
    &Apache::lonxml::deregister('Apache::lonplot',
	('title','xlabel','ylabel','key','axis','label','curve'));
    my $result = '';
    if ($target eq 'web') {
	## Determine filename -- Need to use the 'id' thingy that Gerd 
	## mentioned.
	my $tmpdir = '/home/httpd/perl/tmp/';
	my $filename = $tmpdir.$ENV{'user.name'}.'_'.$ENV{'user.domain'}.
	    '_plot.data';
	my $usersees=md5_base64($filename.'_'.$ENV{'REMOTE_ADDR'});
#	my $usersees=$filename.'_'.$ENV{'REMOTE_ADDR'};
	
	## Write the plot description to the file
	my $fh=Apache::File->new('/home/httpd/perl/tmp/'.$filename);
	$result .= '<pre>';
	$result .= &write_gnuplot_file($fh);
	$result .= '</pre>';
	## return image tag for the plot
#	$result = '<img src=\"/cgi-bin/plot.cgi?'.$usersees.'"';
    }
    return $result;
}

##----------------------------------------------------------------- key
sub start_key {
    my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
    my $result='';
    &get_attributes(\%key,\%key_defaults,$parstack,$safeeval,$tagstack);
    if ($target eq 'web') {
	# This routine should never return anything.
    }
    return $result;
}

sub end_key {
    my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
    my $result = '';
    if ($target eq 'web') {
	# This routine should never return anything.
    }
    return $result;
}
##------------------------------------------------------------------- title
sub start_title {
    my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
    $title = &Apache::lonxml::get_all_text("/title",$$parser[-1]);
    my $result='';
    if ($target eq 'web') {
	# This routine should never return anything.
    }
    return $result;
}

sub end_title {
    my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
    my $result = '';
    if ($target eq 'web') {
	# This routine should never return anything.
    }
    return $result;
}
##------------------------------------------------------------------- xlabel
sub start_xlabel {
    my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
    my $result='';
    $xlabel = &Apache::lonxml::get_all_text("/xlabel",$$parser[-1]);
    if ($target eq 'web') {
	# This routine should never return anything.
    }
    return $result;
}

sub end_xlabel {
    my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
    my $result = '';
    if ($target eq 'web') {
	# This routine should never return anything.
    }
    return $result;
}
##------------------------------------------------------------------- ylabel
sub start_ylabel {
    my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
    my $result='';
    $ylabel = &Apache::lonxml::get_all_text("/ylabel",$$parser[-1]);
    if ($target eq 'web') {
	# This routine should never return anything.
    }
    return $result;
}

sub end_ylabel {
    my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
    my $result = '';
    if ($target eq 'web') {
	# This routine should never return anything.
    }
    return $result;
}
##------------------------------------------------------------------- label
sub start_label {
    my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
    my $result='';
    my %label;
    &get_attributes(\%label,\%label_defaults,$parstack,$safeeval,$tagstack);
    $label{'text'} = &Apache::lonxml::get_all_text("/label",$$parser[-1]);
    if (! &$words_test($label{'text'})) {
	# I should probably warn about it, too.
	$label{'text'} = 'Illegal text';
    }
    push(@labels,\%label);
    if ($target eq 'web') {
	# This routine should never return anything.
    }
    return $result;
}

sub end_label {
    my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
    my $result = '';
    if ($target eq 'web') {
	# This routine should never return anything.
    }
    return $result;
}

##------------------------------------------------------------------- curve
sub start_curve {
    my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
    my $result='';
    my %curve;
    &get_attributes(\%curve,\%curve_defaults,$parstack,$safeeval,$tagstack);
    push (@curves,\%curve);
    &Apache::lonxml::register('Apache::lonplot',('function','data'));
    push (@Apache::lonxml::namespace,'curve');
    if ($target eq 'web') {
	# This routine should never return anything.
    }
    return $result;
}

sub end_curve {
    my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
    my $result = '';
    pop @Apache::lonxml::namespace;
    &Apache::lonxml::deregister('Apache::lonplot',('function','data'));
    if ($target eq 'web') {
	# This routine should never return anything.
    }
    return $result;
}
##------------------------------------------------------------ curve function
sub start_function {
    my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
    my $result='';
    if (exists($curves[-1]->{'data'})) {
	&Apache::lonxml::warning('Use of <function> precludes use of <data>.  The <data> will be omitted in favor of the <function> declaration.');
	delete $curves[-1]->{'data'} ;
    }
    $curves[-1]->{'function'} = 
	&Apache::lonxml::get_all_text("/function",$$parser[-1]);
    if ($target eq 'web') {
	# This routine should never return anything.
    }
    return $result;
}

sub end_function {
    my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
    my $result = '';
    if ($target eq 'web') {
	# This routine should never return anything.
    }
    return $result;
}
##------------------------------------------------------------ curve  data
sub start_data {
    my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
    my $result='';
    if (exists($curves[-1]->{'function'})) {
	&Apache::lonxml::warning('Use of <data> precludes use of <function>.'.
            '  The <function> will be omitted in favor of the <data>'.
            ' declaration.');
	delete($curves[-1]->{'function'});
    }
    my $datatext = &Apache::lonxml::get_all_text("/data",$$parser[-1]);
    $datatext =~ s/\s+//g;  # No whitespace, numbers must be seperated
                            # by commas
    if ($datatext !~ /^(([+-]?\d*\.?\d*)[, ]?)+$/) {
	&Apache::lonxml::warning('Malformed data: '.$datatext);
	$datatext = '';
    }
    # Need to do some error checking on the @data array - 
    # make sure it's all numbers and make sure each array 
    # is of the same length.
    my @data = split /,/,$datatext;
    for (my $i=0;$i<=$#data;$i++) {
	# Check that it's non-empty
	# Check that it's a number
	# Maybe I need a 'debug=on' switch to list the data set
	#    out in a warning?
    }
    push  @{$curves[-1]->{'data'}},\@data;
    if ($target eq 'web') {
	# This routine should never return anything.
    }
    return $result;
}

sub end_data {
    my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
    my $result = '';
    if ($target eq 'web') {
	# This routine should never return anything.
    }
    return $result;
}

##------------------------------------------------------------------- axis
sub start_axis {
    my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
    my $result='';
    &get_attributes(\%axis,\%label_defaults,$parstack,$safeeval,$tagstack);
    if ($target eq 'web') {
	# This routine should never return anything.
    }
    return $result;
}

sub end_axis {
    my ($target,$token,$tagstack,$parstack,$parser,$safeeval,$style)=@_;
    my $result = '';
    if ($target eq 'web') {
	# This routine should never return anything.
    }
    return $result;
}

##------------------------------------------------------------------- misc
sub get_attributes{
    my $values   = shift;
    my $defaults = shift;
    my $parstack = shift;
    my $safeeval = shift;
    my $tag      = shift;
    my $attr;
    foreach $attr (keys %{$defaults}) {
	$values->{$attr} = 
	             &Apache::lonxml::get_param($attr,$parstack,$safeeval);
	if ($values->{$attr} eq '' | !defined($values->{$attr})) {
	    $values->{$attr} = $defaults->{$attr};
	    next;
	}
	my $test = $defaults->{$attr}->{'test'};
	if (! &$test($values->{$attr})) {
	    &Apache::lonxml::warning
		($tag.':'.$attr.': Bad value.'.'Replacing your value with : '
		 .$defaults->{$attr} );
	    $values->{$attr} = $defaults->{$attr};
	}
	return ;
    }
}

sub write_gnuplot_file {
    my $fh = shift;
    my $gnuplot_input = '';
    my $curve;
    # Collect all the colors
    my @Colors;
    push @Colors, $plot{'bgcolor'};
    push @Colors, $plot{'fgcolor'}; 
    push @Colors, $axis{'color'};
    push @Colors, $axis{'color'}; 
    foreach $curve (@curves) {
	push @Colors, ($curve->{'color'} ne '' ? 
		       $curve->{'color'}       : 
		       $plot{'fgcolor'}      );
    }
    # set term
    $gnuplot_input .= 'set term gif ';
    $gnuplot_input .= 'transparent ' if ($plot{'transparent'} eq 'on');
    $gnuplot_input .= $plot{'font'} . ' ';
    $gnuplot_input .= 'size '.$plot{'width'}.','.$plot{'height'}.' ';
    $gnuplot_input .= "@Colors\n";
    # grid
    $gnuplot_input .= 'set grid'.$/ if ($plot{'grid'} eq 'on');
    # border
    $gnuplot_input .= ($plot{'border'} eq 'on'?
		       'set border'.$/           :
		       'set noborder'.$/         );    # title, xlabel, ylabel
    {
    $gnuplot_input .= <<"ENDLABELS";
set output "-"
set title  "$title"
set xlabel "$xlabel"
set ylabel "$ylabel"
set xrange \[$axis{'xmin'}:$axis{'xmax'}\]
set yrange \[$axis{'ymin'}:$axis{'ymax'}\]
ENDLABELS
    }
    # Key
    if (defined($key{'pos'})) {
	$gnuplot_input .= 'set key '.$key{'pos'}.' ';
	$gnuplot_input .= ($key{'box'} eq 'on' ? 'box ' : 'nobox ');
	if ($key{'title'} ne '') {
	    $gnuplot_input .= 'title "'.$key{'title'}.'"'.$/;
	} else {
	    $gnuplot_input .= $/;
	}
    } else {
	$gnuplot_input .= 'set nokey'.$/;
    }    
    # labels
    my $label;
    foreach $label (@labels) {
	$gnuplot_input .= 'set label "'.$label->{'text'}.'" at '.
	    $label->{'xpos'}.','.$label->{'ypos'}.' '.$label->{'justify'}.$/ ;
    }
    # curves
    $gnuplot_input .= 'plot ';
    my $datatext = '';
    for (my $i = 0;$i<=$#curves;$i++) {
	$curve = $curves[$i];
	$gnuplot_input.= ', ' if ($i > 0);
	if (exists($curve->{'function'})) {
	    $gnuplot_input.= 
		$curve->{'function'}.' title "'.
		$curve->{'name'}.'" with '.
		$curve->{'linestyle'};
	} elsif (exists($curve->{'data'})) {
	    $gnuplot_input.= '\'-\' title "'.
		$curve->{'name'}.'" with '.
		$curve->{'linestyle'};
	    my @Data = @{$curve->{'data'}};
	    my @Data0 = @{$Data[0]};
	    for (my $i =0; $i<=$#Data0; $i++) {
		my $dataset;
		foreach $dataset (@Data) {
		    $datatext .= $dataset->[$i] . ' ';
		}
		$datatext .= $/;
	    }
	    $datatext .=$/;
	}
    }
    $gnuplot_input .= $/.$datatext;
    return $gnuplot_input;
#    print $fh $gnuplot_input;
}

1;
__END__