Chart::XMGR - object for displaying data via XMGR

  use Chart::XMGR;

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

  use Chart::XMGR ();

  $xmgr = new Chart::XMGR;
  $xmgr->line($pdl);

  $pdl->$xmgr->line;

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

  use Chart::XMGR;
  use PDL;

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

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

  use Chart::XMGR

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

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

package Chart::XMGR;

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 xmgrlline 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
				}

	       );

sub xmgr {

  my $xmgr = __curr_xmgr;

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

}

sub xmgrset {
  my $xmgr = __curr_xmgr;
  my $set = shift;
  $xmgr->set($set);
}

sub xmgrdetach {
  my $xmgr = __curr_xmgr;
  $xmgr->detach;
}

sub xmgrprint {
  my $arg = shift;
  my $xmgr = __curr_xmgr;
  $arg = $arg . "\n";
  $xmgr->prt($arg);
}


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

sub __curr_xmgr {

  my $xmgr = $Current;

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

  return $xmgr;
}

sub new {

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

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

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

  # Store the current object - KLUDGE alert
  $Current = $xmgr;
  
  # Launch the XMGR process
  
  if ($NPIPE) {

    # Increment counter
    $COUNTER++;

    # Create the named pipe if necessary
    $xmgr->{Npipe} = "/tmp/xmgr_fifo$$" . "_$COUNTER";


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

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

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

    # Fork xmgr
    my $pid;
    if ($pid = fork) {
      # Parent
      # Open pipe
      $xmgr->{Pipe} = new IO::File;
      $xmgr->{Pipe}->open("> ". $xmgr->npipe) or
	die "Can't open named pipe: $!";
 
      
    } elsif (defined $pid) {
      # Child
      exec 'xmgr -noask -npipe '.$xmgr->npipe . ' -timer 900';
      
    } else {
      die "Can't fork: $!\n";
    }
  } else {

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


  }

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

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


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

  return $xmgr;
  
  
}

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 { "XMGR: $_" } @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 { "XMGR: $_" } @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 XMGR
    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 XMGR process: $!";
  }
  
  # Update the object state so that we know that XMGR is no longer running
  $self->attached(0);  
}

sub DESTROY {

  my $self = shift;
  
  $self->prt("exit\n") if $self->pipe->opened;

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

  # Remove the FIFO
  unlink $self->npipe;

}

1;