Chart::GRACE - object for displaying data via Xmgrace

  use Chart::GRACE;

  xmgrace($a, { SYMBOL => 'plus'};

  use Chart::GRACE ();

  $grace = new Chart::GRACE;
  $grace->plot($pdl);

  xmgrace($pdl, { LINESTYLE => 'dotted' });

  use Chart::GRACE;
  use PDL;

  $a = pdl( 1,4,2,6,5);
  $xmgrace = new Chart::GRACE;
  $xmgrace->plot($a, { SYMBOL => 3, 
                       LINECOL => 'red', 
                       LINESTYLE => 2
                       SYMSIZE => 1 }
                 );

  $xmgrace->configure(SYMCOL => 'green');
  $xmgrace->detach;

  use Chart::GRACE

  @a = ( 1,4,2,6,5 );
  $xmgrace = new Chart::GRACE;
  $xmgrace->plot(\@a, { SYMBOL => 3,
                        LINECOL => 'red',
                        LINESTYLE => 2
                        SYMSIZE => 1 }
                 );

  $xmgrace->configure(SYMCOL => 'green');
  $xmgrace->detach;

package Chart::GRACE;

use 5.003;

use strict;
use Carp;

use IO::Pipe;
use IO::File;

# Options parsing
use PDL::Options;

# We are exporting a command.

#require Exporter;

use vars qw/$VERSION $Current %DEFAULTS %SYNONYMS %TRANSLATION %COLOURS
  @ISA %EXPORT_TAGS $NPIPE $COUNTER/;

use subs qw/ __curr_xmgr/;

@ISA = qw(Exporter);

%EXPORT_TAGS = (
		'Func' => [qw/
			   xmgr xmgrprint xmgrset xmgrdetach
			  /]
	       );

Exporter::export_tags('Func');

# Use Named pipe if true.
# This is the default

$NPIPE = 1;


# Need to make a named pipe if NPIPE is true
# If the mkfifo command is not available then we turn this feature off
eval "use POSIX qw/mkfifo/";
if ($@) {
  # Create dummy mkfifo command
  eval "sub mkfifo {}";
  $NPIPE = 0;
}


# Allows me to keep track of named pipe names by using
# a different one each time the object is created
$COUNTER = 0;


# $Current is a kludge to allow people to run these subs as normal
# subroutines without using the object. It is set to the current object
# and used by the xmgracelline routine to call the methods.

# Version number

$VERSION = '0.95';

# Store the default configuration options

%DEFAULTS = (
	     'LINESTYLE' => 1,
             'LINECOLOUR' => 1,
	     'LINEWIDTH' => 1,
	     'SYMBOL'    => 'circle',
	     'SYMCOLOUR' => 2,
             'SYMSIZE'   => 1,
             'SYMFILL'   => 1,
             'FILL'      => 0,
	     'AUTOSCALE' => 1,
             'SETTYPE' => 'xy'
	    );

# Store synonyms

%SYNONYMS = (
	     'LINECOLOR' => 'LINECOLOUR',
	     'SYMCOLOR'  => 'SYMCOLOUR'
	    );

# Define colours
%COLOURS = (
	    'white' => 0,
	    'black' => 1,
	    'red' => 2,
	    'green' => 3,
	    'blue' => 4,
	    'yellow' => 5,
	    'brown' => 6,
	    'gray'  => 7,
	    'violet' => 8,
	    'cyan' => 9,
	    'magenta' => 10,
	    'orange' => 11,
	    'indigo' => 12,
	    'maroon' => 13,
	    'turqse' => 14,
	    'green4' => 15
);

# Store the translation

%TRANSLATION = (
		'LINESTYLE' => {
				'none'  => 0,
				'solid' => 1,
				'dotted'=> 2,
				'dashed'=> 3,
				'ldash' =>4,
				'dotdash'=>5
			       },
		'LINECOLOUR' => { %COLOURS },
		'SYMCOLOUR'  => { %COLOURS },
		'SYMBOL'     => {
				 'none' => 0,
				 'dot'  => 1,
				 'circle'  =>  2,
				 'square'  =>  3,
				 'diamond'  =>  4,
				 'triangleup'  =>  5,
				 'triangleleft'  =>  6,
				 'triangledown'  =>  7,
				 'triangleright'  =>  8,
				 'plus'  =>  9,
				 'X'  =>  10,
				 'star'  =>  11
				},
		'SYMFILL'    => {
				 'none' => 0,
				 'filled' => 1,
				 'opaque' => 2
				}

	       );

# __curr_xmgrace. Returns the current XMGR object, creating 
# a new one if necessary.

sub __curr_xmgrace {

  my $xmgrace = $Current;

  # If it is not defined start a new XMGR
  $xmgrace = new Chart::GRACE unless defined $xmgrace;

  return $xmgrace;
}

sub xmgrace {

  my $xmgrace = __curr_xmgrace;

  # Now send all arguments to the plot routine
  $xmgrace->plot(@_);

}

sub xmgraceset {
  my $xmgrace = __curr_xmgrace;
  my $set = shift;
  $xmgrace->set($set);
}

sub xmgracedetach {
  my $xmgrace = __curr_xmgrace;
  $xmgrace->detach;
}

sub xmgraceprint {
  my $arg = shift;
  my $xmgrace = __curr_xmgrace;
  $arg = $arg . "\n";
  $xmgrace->prt($arg);
}

sub new {

  my $proto = shift;
  my $class = ref($proto) || $proto;

  my $xmgrace = {};

  $xmgrace->{Pipe} = undef;    # File handle object of pipe
  $xmgrace->{Attached} = 0;    # Is an XMGR process attached
  $xmgrace->{Set} = 0;         # Current set number
  $xmgrace->{Graph} = 0;       # Current graph
  $xmgrace->{Options}  = new PDL::Options( \%DEFAULTS );
  $xmgrace->{Debug} = 0;       # Debugging flag
  $xmgrace->{Npipe} = undef;   # Name of named pipe

  # Bless into class
  bless ($xmgrace, $class);

  # Store the current object - KLUDGE alert
  $Current = $xmgrace;

  # Launch the XMGR process

  if ($NPIPE) {

    # Increment counter
    $COUNTER++;

    # Create the named pipe if necessary
    # This is not really safe. Should be using File::Temp
    $xmgrace->{Npipe} = "/tmp/xmgrace_fifo$$" . "_$COUNTER";


    # See if the pipe exists and or is not a pipe
    unless (-p $xmgrace->npipe) {
      print "Making named pipe:".$xmgrace->npipe ."..." if $xmgrace->debug;
      unlink $xmgrace->npipe;

      mkfifo($xmgrace->npipe, 0600) || 
	croak "Couldnt create named pipe: $!"; # POSIX

      print "Done\n" if $xmgrace->debug;
    }

    # Fork xmgr
    my $pid;
    if ($pid = fork) {
      # Parent
      # Open pipe
      $xmgrace->{Pipe} = new IO::File;
      $xmgrace->{Pipe}->open("> ". $xmgrace->npipe) or
	die "Can't open named pipe: $!";

    } elsif (defined $pid) {
      # Child
      exec 'xmgrace -noask -npipe '.$xmgrace->npipe . ' -timer 900';

    } else {
      die "Can't fork: $!\n";
    }
  } else {

    # An anonymous pipe
    $xmgrace->{Pipe} = new IO::Pipe;
    $xmgrace->{Pipe}->writer('xmgrace -pipe -noask');


  }

  $xmgrace->{Pipe}->autoflush;
  $xmgrace->{Attached} = 1;

  # Configure the options
  $xmgrace->{Options}->synonyms( \%SYNONYMS );
  $xmgrace->{Options}->translation( \%TRANSLATION );


  # Set a default title
  $xmgrace->prt('TITLE "Perl->XMGRACE"');

  return $xmgrace;
}

sub pipe {
  my $self = shift;
  if (@_) { $self->{Pipe} = shift;}
  return $self->{Pipe};
}

sub opt {
  my $self = shift;
  if (@_) { $self->{Options} = shift;}
  return $self->{Options};
}

sub npipe {
  my $self = shift;
  if (@_) { $self->{Npipe} = shift;}
  return $self->{Npipe};
}

sub attached {
  my $self = shift;
  if (@_) { $self->{Attached} = shift;}
  return $self->{Attached};
}

sub set {
  my $self = shift;
  if (@_) { $self->{Set} = shift;}
  return $self->{Set};
}

sub graph {
  my $self = shift;
  if (@_) { $self->{Graph} = shift;}
  return $self->{Graph};
}

sub debug {
  my $self = shift;
  if (@_) { $self->{Debug} = shift;}
  return $self->{Debug};
}

sub prt {

  my $self = shift;

  my @args = @_;   # In case we are parsing in a read-only variable

  # If names pipe then just append newline
  if ($NPIPE) {
    map { $_ = "$_\n" } @args;
  } else {
    # Normal pipe so need the @ symbol as well
    map { $_ = "\@$_\n" } @args; 
  }

  print map { "XMGRACE: $_" } @args if $self->debug;

  my $PIPE = $self->pipe;

  foreach (@args) {
    print $PIPE "$_";
  }

}

sub prt_data {

  my $self = shift;

  my @args = @_;   # In case we are parsing in a read-only variable
  my $set = $self->set;

  # For named pipes need to process the data some more
  if ($NPIPE) {
    foreach (@args) {
      next if $_ eq '&';
      my @bits = split(/ /, $_);

      # Only first two bits are allowed for POINT
      my $data = join(',',@bits[0..1]);
      $_ = "s$set POINT $data\n";
    }
  } else {
    # Just send the data with a carriage return
    map { $_ .= "\n" } @args;
  }

  print map { "XMGRACE: $_" } @args if $self->debug;

  my $PIPE = $self->pipe;

  foreach (@args) {
     print $PIPE "$_";
  }


}

sub select_graph {
  my $self = shift;
  my $graph = $self->graph;
  $self->prt("WITH g$graph");
}

sub plot {

  my ($optref);

  my $self = shift;

  croak 'Usage: plot($pdl, [$hash])' 
        if (scalar(@_) < 0);

  # Read options hash from command line.
  # Assumed to be last arg (if its a hash)


  if (ref($_[-1]) eq 'HASH') {
    $optref = pop(@_);
  } else {
    $optref = {};
  }

  # Take a local copy of the args
  my @input = @_;

  # Process the user options and combine with defaults
  my $merged = $self->opt->options($optref);

  # Retrieve set number
  my $set = $self->set;

  # Select the current graph
  $self->select_graph;

  # First thing we need to do is kill the current set in XMGR
  $self->killset;

  # Then need to set the target of this data set
  $self->prt("TARGET s$set");

  # Now need to set the settype. This is contained in the options
  # hash.
  $self->prt("TYPE $$merged{SETTYPE}");


  # First thing we need to do is check the dimensions of the
  # first argument (if it is a PDL).
  # If it is 2D then we want to loop
  my $nargs = $#input;

  # Found out how many numbers in the first arg
  my $npts;
  if (ref($input[0]) eq 'ARRAY') {
    $npts = $#{$input[0]};
  } elsif (UNIVERSAL::isa($input[0],'PDL')) {
    $npts = $input[0]->clump(-1)->nelem - 1; # Match perl start at 0
  } else {
    croak 'Cant work out how to display data: Not PDL or Array ref';    
  }

  # Loop over each point in arg and send a data point to XMGR
  for (my $i = 0; $i <= $npts; $i++ ) {

    # Somewhere to store the current value
    my @val = ();

    # Read element from each arg
    for (my $j = 0; $j <= $nargs; $j++) {

      push (@val, $i) if $nargs == 0;

      my $val;
      my $cpt = $input[$j];

      # An ARRAY reference
      if (ref($cpt) eq 'ARRAY') {
        if ($i <= $#{$cpt}) {
	  $val = ${$cpt}[$i];
        } else {
	  $val = 0;
	}

      # A PDL
      } elsif (UNIVERSAL::isa($cpt,'PDL')) {
        # Check that we are in range
        my $num = $cpt->clump(-1)->nelem;

        if ($i <= $cpt->clump(-1)->nelem - 1) {
	  $val = $cpt->clump(-1)->at($i);
	} else {
	  $val = 0.0;
	}

      # None of the above
      } else {
	$val = 0;
      }

      # Store $val
      push ( @val, $val);

    }

    # Now we have the list. Create a string and send to XMGRACE
    my $data = join(' ',@val); 
#    my $string = "\@s$set POINT $data";
#    $self->prt($string);
    $self->prt_data("$data");

  } 

  # Close the set (if not a named pipe)
  $self->prt_data('&') unless $NPIPE;

  # Send the options hash
  $self->send_options($merged);

  # Update the display
  $self->redraw;

}

sub send_options {
  my $self = shift;

  my $optref = shift;

  my $set = $self->set;

  # select current graph
  $self->select_graph;

  # Somewhere to put the options
  my @XMGR = ();

  # Loop through the keys
  foreach my $key (%$optref) {

    if ($key eq 'LINESTYLE') {
      push(@XMGR, "s$set LINESTYLE $$optref{$key}");
    } elsif ($key eq 'LINECOLOUR') {
      push(@XMGR, "s$set COLOR $$optref{$key}");
    } elsif ($key eq 'LINEWIDTH') {
      push(@XMGR, "s$set LINEWIDTH $$optref{$key}");
    } elsif ($key eq 'SYMBOL') {
      push(@XMGR, "s$set SYMBOL $$optref{$key}");
    } elsif ($key eq 'FILL') {
      push(@XMGR, "s$set FILL $$optref{$key}");
    } elsif ($key eq 'SYMSIZE') {
      push(@XMGR, "s$set SYMBOL SIZE $$optref{$key}");
    } elsif ($key eq 'SYMCOLOUR') {
      push(@XMGR, "s$set SYMBOL COLOR $$optref{$key}"); 
    } elsif ($key eq 'SYMFILL') {
      push(@XMGR, "s$set SYMBOL FILL $$optref{$key}");
    }

    if ($key eq 'AUTOSCALE') {
      if ($$optref{$key}) {
	$self->autoscale;
      }
    }

  }

  $self->prt(@XMGR);
}

sub redraw {
  my $self = shift;
  $self->prt('redraw');
}

sub killset {
  my $self = shift;

  my $set = $self->set;
  if (@_) { $set = shift; }

  $self->prt("KILL s$set");
}

sub autoscale {
  my $self = shift;
  $self->prt('autoscale');
}

sub autoscale_on {
  my $self = shift;
  my $set = $self->set;

  if (@_) { $set = shift; }
  $self->prt("autoscale on s$set");
}

sub world {
  my $self = shift;
  my ($xmin, $xmax, $ymin, $ymax) = @_;

  $self->prt("WORLD $xmin, $ymin, $xmax, $ymax");
#  $self->prt("WORLD XMAX $xmax");
#  $self->prt("WORLD YMIN $ymin");
#  $self->prt("WORLD XMAX $ymax");

}

sub viewport {
  my $self = shift;
  my ($xmin, $xmax, $ymin, $ymax) = @_;

  $self->prt("VIEW $xmin, $ymin, $xmax, $ymax");
#  $self->prt("VIEW XMAX $xmax");
#  $self->prt("VIEW YMIN $ymin");
#  $self->prt("VIEW XMAX $ymax");

}

sub graphtype {
  my $self = shift;
  my $type = shift;
  my $graph = $self->graph;
  $self->prt("g$graph TYPE $type");
}

sub configure {
  my $self = shift;

  my %hash = @_;

  # Now parse the options and return the converted values
  # Make sure we only return the requested parameters.

  $self->opt->full_options(0); # Turn off full options

  my $answer = $self->opt->options(\%hash);
  $self->send_options($answer);

  # Reset
  $self->opt->full_options(1);

  # Redraw
  $self->redraw;
}

sub detach {
  my $self = shift;
  if ($self->attached) {
    close ($self->pipe) or carp "Cant release XMGRACE process: $!";
  }

  # Update the object state so that we know that XMGRACE is no longer running
  $self->attached(0);
}

sub DESTROY {

  my $self = shift;

  # Check that pipe is still opened (depends on global destruction order)
  if ($self->pipe) {
    $self->prt("exit\n") if $self->pipe->opened;

    # Close the pipe
    if ($self->attached) {
      $self->pipe->close or carp "Cant stop XMGRACE process: $!";
    }
  }

  # Remove the FIFO (if we made one)
  unlink $self->npipe if defined $self->npipe;

}

1;