pp_addpm({At=>Top},<<'EOD');

=head1 NAME

PDL::Graphics::IIS - Display PDL images on IIS devices (saoimage/ximtool)

=head1 SYNOPSIS

  use PDL::Graphics::IIS;
  saoimage ( -geometry => '800x800' );
  iis rvals(100,100);

=head1 DESCRIPTION

This module provides an interface to any image display 'device' which support the
'IIS protocol' - viz the SAOimage and Ximtool X-windows programs, the
old SunView imtool program and presumably even the original IIS CRT itself
if they aren't all in museums!

These programs should be familiar to astronomer's - they are used by
the common IRAF system. The programs and their HTML documentation
can be obtained from the following URLs:

SAOimage: http://tdc-www.harvard.edu/software/saoimage.html
Ximtool:  http://iraf.noao.edu/iraf/web/projects/x11iraf/x11iraf.html

Non-astronomer's may find they quite nifty for displaying 2D data.

The Perl variable $stdimage is exported from the module and controls
the frame buffer configuration currently in use. The default value
is 'imt1024' which specifies a 1024x1024 frame buffer. Other
values supported by the module are: imt512,imt800,imt1024,imt1600,imt2048,
and imt4096.

If you have a $HOME/.imtoolrc you can use it to specify other frame
buffer names and configurations in exactly the same way you can in
IRAF. Here is a sample file:

 -------------------snip-------------------------
 # Format:  configno nframes width height
  1  2  512  512         # imt1|imt512
  2  2  800  800         # imt2|imt800
  3  2 1024 1024         # imt3|imt1024
  4  1 1600 1600         # imt4|imt1600
  5  1 2048 2048         # imt5|imt2048
  6  1 4096 4096         # imt6|imt4096
  7  1 8192 8192         # imt7|imt8192
  8  1 1024 4096         # imt8|imt1x4
  9  2 1144  880         # imt9|imtfs    full screen (1152x900 minus frame)
 10  2 1144  764         # imt10|imtfs35 full screen at 35mm film aspect ratio
 -------------------snip-------------------------

(Note: some versions of SAOimage may not even work if this file is not
present. If you get funny error messages about 'imtoolrc' try copying
the above to $HOME/.imtoolrc or /usr/local/lib/imtoolrc)

The Perl variable $iisframe is also exported from the module and controls
which display frame number to use in programs such as Ximtool which supports
multiple frames. This allows you to do useful things such as blink between
images.

The module communicates with the IIS device down FIFO pipes (special UNIX
files) - unlike IRAF this module does a pretty decent job of intelligently
guessing which file names to use for the pipes and will prompt for their
creating if absent. Also if SAOimage or Ximtool are started from within Perl
using the module this will guarantee correct file names!

=head1 FUNCTIONS

=cut
EOD

use Config;

pp_add_exported('','iis iiscur iiscirc $stdimage $iisframe saoimage ximtool');

############################## PM CODE ########################################

pp_addpm(<<'ENDOFPM');

use PDL::Core '';
use PDL::Basic '';
use Carp;

$iisframe      = 1;                # Starting defaults
$stdimage      = "imt1024";
$last_stdimage = "";
$HOME          = $ENV{'HOME'};     # Used a lot so shorten


################ Public routines #################

# Display

=head2 iis

=for ref

Displays an image on a IIS device (e.g. SAOimage/Ximtool)

=for usage

   iis $image, [ { MIN => $min, MAX => $max,
                   TITLE => 'pretty picture' } ]
   iis $image, [$min,$max]

=for sig

   iis(image(m,n),[\%options]) or iis(image(m,n),[min(),max()])

Displays image on a IIS device. If min() or max() are omitted they
are autoscaled. A good demonstration of PDL threading can be had
by giving iis() a data *cube* - iis() will be repeatedly called
for each plane of the cube resulting in a poor man's movie!

If supplied, TITLE is used to label the frame, if no title is
supplied, either the OBJECT value stored in the image header or a
default string is used (the title is restricted to a maximum
length of 32 characters).

=cut

sub iis {
    my $usage = 'Usage: iis ( $image, [\%hash | $min, $max] )';
    barf $usage if $#_<0 || $#_>2;

    my $image  = shift;
    my ( $min, $max );

    my $title = 'perlDL rules !';
    my $header = $image->gethdr();
    if ( defined $header and defined $$header{OBJECT} ) {
      $title = $$header{OBJECT};
      $title =~ s/^'(.*)'$/$1/;
    }

    if ( $#_ == 1 ) { $min = $_[0]; $max = $_[1]; }
    elsif ( $#_ == 0 ) {
      barf $usage unless ref($_[0]) eq "HASH";

      my $opt = new PDL::Options( { MIN => undef, MAX => undef, TITLE => $title } );
      $opt->options( shift );
      my $options = $opt->current;

      $min   = $$options{MIN};
      $max   = $$options{MAX};
      $title = $$options{TITLE};
    }

    my($nx,$ny) = dims($image);
    fbconfig($stdimage) if $stdimage ne $last_stdimage;
    $min = $image->min unless defined $min;
    $max = $image->max unless defined $max;
    print "Displaying $nx x $ny image from $min to $max ...\n" if $PDL::verbose;
    &PDL::_iis_int($image,$min,$max,$title);
1;}

=head2 iiscur

=for ref

Return cursor position from an IIS device (e.g. SAOimage/Ximtool)

=for usage

 ($x,$y) = iiscur($ch)

This function puts up an interactive cursor on the IIS device and returns
the ($x,$y) position and the character typed ($ch)
by the user.

=cut

sub iiscur {
    barf 'Usage: ($x,$y) = iiscur($ch)' if $#_>=1;
    my ($x,$y,$ch) = _iiscur_int();
    $_[0] = $ch; # Pass this back in args
    return ($x,$y);
}

=head2 iiscirc

=for ref

Draws a circle on a IIS device (e.g. SAOimage/Ximtool)

=for sig

 Signature: iiscirc(x(),y(),radius(),colour())

=for usage

  iiscirc $x, $y, [$radius, $colour]

Draws circles on the IIS device with specied points and colours. Because
this module uses PDL::PP threading you can supply lists of points via
1D arrays, etc.

An amusing PDL idiom is:

 perldl> iiscirc iiscur

Note the colours are the same as IRAF, viz:

            201 = cursor color (white)
            202 = black
            203 = white
            204 = red
            205 = green
            206 = blue
            207 = yellow
            208 = cyan
            209 = magenta
            210 = coral
            211 = maroon
            212 = orange
            213 = khaki
            214 = orchid
            215 = turquoise
            216 = violet
            217 = wheat

=cut

sub iiscirc {
   barf 'Usage: iiscirc( $x, $y, [$radius, $colour] )' if $#_<1 || $#_>3;
   my($x, $y, $radius, $colour)=@_;
   fbconfig($stdimage) if $stdimage ne $last_stdimage;
   $radius = 10 unless defined $radius;
   $colour = 204 unless defined $colour;
   &PDL::_iiscirc_int($x, $y, $radius, $colour);
1;}

=head2 saoimage

=for ref

Starts the SAOimage external program

=for usage

 saoimage[(command line options)]

Starts up the SAOimage external program. Default FIFO devices are chosen
so as to be compatible with other IIS module functions. If no suitable
FIFOs are found it will offer to create them.

e.g.:

=for example

 perldl> saoimage
 perldl> saoimage( -geometry => '800x800' )

=cut

sub saoimage {  # Start SAOimage
   fbconfig($stdimage) if $stdimage ne $last_stdimage;
   if( !($pid = fork)) {	# error or child
      exec("saoimage", -idev => $fifo, -odev => $fifi, @_) if defined $pid;
      die "Can't start saoimage: $!\n";
   }
   return $pid;
}

=head2 ximtool

=for ref

Starts the Ximtool external program

=for usage

  ximtool[(command line options)]


Starts up the Ximtool external program. Default FIFO devices are chosen
so as to be compatible with other IIS module functions. If no suitable
FIFOs are found it will offer to create them.

e.g.

=for example

 perldl> ximtool
 perldl> ximtool (-maxColors => 64)


=cut

sub ximtool {  # Start Ximtool
   fbconfig($stdimage) if $stdimage ne $last_stdimage;
   if( !($pid = fork)) {	# error or child
      exec("ximtool", -xrm => "ximtool*input_fifo: $fifi", -xrm => "ximtool*output_fifo: $fifo", @_) if defined $pid;
      die "Can't start ximtool: $!\n";
   }
   return $pid;
}


################ Private routines #################

# Change the frame buffer configuration

sub fbconfig {
    my $name = shift;
    parseimtoolrc() unless $parsed++;
    findfifo() unless $foundfifo++;
    barf 'No frame buffer configuration "'.$name.'" found'."\n"
       unless defined $imtoolrc{$name};
    ($fbconfig, $fb_x, $fb_y ) = @{ $imtoolrc{$name} };
    print "Using $stdimage - fbconfig=$fbconfig (${fb_x}x$fb_y)\n" if $PDL::verbose;;
    $last_stdimage = $stdimage;
1;}

# Try and find user/system imtoolrc definitions

sub parseimtoolrc {
   # assoc array holds imtool configuations - init with some standard
   # ones in case imtoolrc goes missing

   %imtoolrc = (
     'imt512'  => [1,512,512],   'imt800'  => [2,800,800],
     'imt1024' => [3,1024,1024], 'imt1600' => [4,1600,1600],
     'imt2048' => [5,2048,2048], 'imt4096' => [6,4096,4096],
   );

   # Look for imtoolrc file

   $imtoolrc = "/usr/local/lib/imtoolrc";
   $imtoolrc = "$HOME/.imtoolrc" if -e "$HOME/.imtoolrc";
   if (!-e $imtoolrc) {
      warn "WARNING: unable to find an imtoolrc file in $HOME/.imtoolrc\n".
           "or /usr/local/lib/imtoolrc. Will try \$stdimage = imt1024.\n";
      return 1;
   }

   # Load frame buffer configuartions from imtoolrc file and
   # store in assoc array

   open(IMTOOLRC, $imtoolrc) || die "File $imtoolrc not found";
    while(<IMTOOLRC>) {
       if  ( /^\s*(\d+)\s+\d+\s+(\d+)\s+(\d+)\s+\#\s*(\S+)\s/ ) {
          foreach $name (split(/\|/,$4)) {
             $imtoolrc{$name} = [$1,$2,$3];
          }
      }
   }close(IMTOOLRC);
1;}

# Try a few obvious places for the FIFO pipe and create if necessary

sub findfifo {
    $fifi = ""; $fifo = "";
    if (-e "/dev/imt1i" && -e "/dev/imt1o") {
       $fifi = "/dev/imt1i"; $fifo = "/dev/imt1o";
    }
    if (-e "$HOME/dev/imt1i" && -e "$HOME/dev/imt1o") {
       $fifi = "$HOME/dev/imt1i"; $fifo = "$HOME/dev/imt1o";
    }
    if (-e "$HOME/iraf/dev/imt1i" && -e "$HOME/iraf/dev/imt1o") {
       $fifi = "$HOME/iraf/dev/imt1i"; $fifo = "$HOME/iraf/dev/imt1o";
    }
    if (defined $ENV{'IMTDEV'} && $ENV{'IMTDEV'} =~ /^fifo:(.*):(.*)$/) {
       $fifi = $1; $fifo = $2;
   }
   if ($fifi eq "" && $fifo eq "") { # Still not found use this default
       warn "WARNING: cannot locate FIFO pipes in /dev/, $HOME/dev, ".
           "$HOME/iraf/dev or environment variable \$IMTDEV\n";
       $fifi = "$HOME/dev/imt1i"; $fifo = "$HOME/dev/imt1o";
   }
   print "Using FIFO devices in:  $fifi\n".
         "                   out: $fifo\n" if $PDL::verbose;
   for $pipe ($fifi, $fifo) {
      if (!-p $pipe) {
         print "FIFO $pipe does not exist - try and create now? "; my $ans = <STDIN>;
         system "/usr/etc/mknod $pipe p" if $ans =~ /^y/i;

         if ($ans =~ /^y/i) {
            unlink $pipe if -e $pipe;
            my $path = $ENV{PATH};
            $ENV{PATH} .= ":/etc:/usr/etc";

            # Note system return value is backwards - hence 'and'

            if ( system('mknod', $pipe, 'p') and system('mkfifo',$pipe) ) {
                die "Failed to create named pipe $pipe\n";
            }
            $ENV{PATH} = $path;
         }
      }
   }
1;}


ENDOFPM

################################ XS CODE ######################################

pp_addhdr(<<"EOD");
#include "libiis.h"
EOD

# Non-blocking I/O

pp_addhdr(<<"EOD") if defined $Config{'o_nonblock'} && $Config{'o_nonblock'} ne 'O_NONBLOCK';
#define O_NONBLOCK $Config{'o_nonblock'}
EOD

pp_addhdr(<<"EOD");
#include "pdliisdisp.c"
EOD

pp_addxs('',<<'EOD');

MODULE = PDL::Graphics::IIS PACKAGE = PDL::Graphics::IIS

void
_iiscur_int()
   PPCODE:
    STRLEN n_a;
    float x,y;
    char ch;
    int   frame       = (int)SvIV( perl_get_sv("iisframe", FALSE) );

    iis_open(SvPV(perl_get_sv("fifi",FALSE),n_a),SvPV(perl_get_sv("fifo",FALSE),n_a),
       (int)SvIV( perl_get_sv("fbconfig", FALSE) ),
       (int)SvIV( perl_get_sv("fb_x", FALSE) ),
       (int)SvIV( perl_get_sv("fb_y", FALSE) ) );
    iis_cur(&x,&y,&ch);
    iis_close();

    EXTEND(sp,3);
    PUSHs(sv_2mortal(newSVnv((float)x)));
    PUSHs(sv_2mortal(newSVnv((float)y)));
    PUSHs(sv_2mortal(newSVpv(&ch,1)));


EOD

# Internal routine for iis()

pp_bless('PDL::Graphics::IIS');

pp_def('iis',
        PMCode=>'',
	Doc => undef,
        Pars => 'image(m,n); min(); max();',
        OtherPars => 'char *perl_title',
        Code => '

   int   frame = (int)SvIV( perl_get_sv("iisframe", FALSE) );

   unsigned short hdr[8];
   unsigned char *data;
   int j,nlines, x,y, offx, offy, nx, ny, nx2, ny2, baseX, baseY, m1, n1;
   int ntrans;
   float xx, yx, xy, yy, xo, yo; int w_type; /* WCS */
   float fmin, fmax;
   char wcsbuf[SZ_WCSTEXT];
   char title[33];  /* 32 chars + null terminator */
   int chan;
   STRLEN n_a;

   /* Open pipes etc */

   if (frame<1 || frame>4)
       barf("$iisframe must be in range 1--4");

    iis_open(SvPV(perl_get_sv("fifi",FALSE),n_a),SvPV(perl_get_sv("fifo",FALSE),n_a),
       (int)SvIV( perl_get_sv("fbconfig", FALSE) ),
       (int)SvIV( perl_get_sv("fb_x", FALSE) ),
       (int)SvIV( perl_get_sv("fb_y", FALSE) ) );

   /* Convenience variables */

   nx = $PRIV(__m_size);
   ny = $PRIV(__n_size);
   fmin = (float) $min();
   fmax = (float) $max();

   chan = iis_chan(frame);

   /* Work out how many lines to transfer at a go */

   ntrans = BUFFSZ/frameX;
   if (ntrans<1)
      ntrans = 1;

   /* Allocate buffer for data transfers */

   data = (unsigned char*) calloc(ntrans*frameX, sizeof(unsigned char));
   if (data==NULL)
      iis_error("iis_display: out of memory for buffer","");

   threadloop %{

      /* Send WCS info */

      hdr[TRANSFER_ID] = IWRITE | PACKED;
      hdr[THING_COUNT] = -SZ_WCSTEXT;
      hdr[SUB_UNIT]   = WCS;
      hdr[CHECK_SUM]  = 0;
      hdr[X_REGISTER] = 0;
      hdr[Y_REGISTER] = 0;
      hdr[Z_REGISTER] = chan;
      hdr[T_REGISTER] = fbconfig-1; /* fbconfig number  */
      iis_checksum(hdr);
      iis_write((char*)hdr, 8*sizeof(short));

      offx = 0; offy = 0;    /* Centre image in frame if small */
      if (nx<frameX)
         offx = (frameX-nx)/2;
      if (ny<frameY)
         offy = (frameY-ny)/2;

      nx2 = nx; ny2 = ny;  baseX=0; baseY=0; /* Truncate image if too big */
      if (nx>frameX) {
         nx2=frameX; baseX = (nx-frameX)/2;
      }
      if (ny>frameY) {
         ny2=frameY; baseY = (ny-frameY)/2;
      }

      /* Note my WCS is zero offset! */

      xx=1; yx=0; xy=0; yy=-1; xo=baseX-offx; yo=baseY+frameY-offy-1; w_type=1;

      strncpy( title, $COMP(perl_title), 32 );
      title[32] = ' . "'" . '\0' . "'" . ';
      sprintf (wcsbuf, "%-33s\n%f %f %f %f %f %f %f %f %d",
               title,  /*** was "perlDL rules!", ***/
               xx, yx, xy, yy, xo, yo, fmin, fmax, w_type);
      iis_write((char*)wcsbuf, SZ_WCSTEXT*sizeof(char));

      /* Reset the frame buffer */

      hdr[TRANSFER_ID] = fbconfig-1; /* fbconfig number  */
      hdr[THING_COUNT] = 0;
      hdr[SUB_UNIT]   = FEEDBACK;
      hdr[CHECK_SUM]  = 0;
      hdr[X_REGISTER] = 0;
      hdr[Y_REGISTER] = 0;
      hdr[Z_REGISTER] = chan;
      hdr[T_REGISTER] = 0;
      iis_checksum(hdr);
      iis_write((char*)hdr, 8*sizeof(short));

#define Generic $TBSULFD(PDL_Byte,PDL_Short,PDL_Ushort,PDL_Long,PDL_Float,PDL_Double)

       {   Generic val,sval;

           for (y = 0; y < ny2; y+=ntrans) {

              nlines = ntrans;  /* Number of lines to transfer */
              if (y+ntrans>ny2)
                 nlines = ny2 - y;

              /* create header */
              hdr[TRANSFER_ID] = IWRITE | PACKED | BLOCKXFER;
              hdr[THING_COUNT] = -nlines*frameX;
              hdr[SUB_UNIT] = REFRESH;
              hdr[CHECK_SUM] = 0;
              hdr[X_REGISTER] = ADVXONTC;
              hdr[Y_REGISTER] = ADVYONXOV+frameY-y-nlines-offy;
              hdr[Z_REGISTER] = chan;
              hdr[T_REGISTER] = ALLBITPL;
              iis_checksum(hdr);
              iis_write((char*)hdr, 8*sizeof(short));

              for (j=0; j<nlines; j++) {
                  n1 = baseY+y+nlines-j-1;
                  for (x = 0; x < nx2; x++) {
                     m1 = x + baseX;
                     val = $image(m=>m1, n=>n1);
                     sval = FMIN+(val-fmin)*(FMAX-FMIN)/(fmax-fmin);
                     if (sval<FMIN)
                        sval = FMIN;
                     if (sval>FMAX)
                        sval = FMAX;
                     data[j*frameX+x+offx] = (unsigned char) sval;
                  }
              }
              iis_write((char*)data, nlines*frameX*sizeof(char) );
           }

      }
#undef Generic

   %}

   free(data);
   iis_close();

'); # End of iis_c pp_def

pp_def('iiscirc',
        Pars => 'x(); y(); r(); colour();',
        PMCode=>'',
	Doc=>undef,
        Code => '

   int   frame = (int)SvIV( perl_get_sv("iisframe", FALSE) );
   STRLEN n_a;

   /* Open pipes etc */

   if (frame<1 || frame>4)
       barf("$iisframe must be in range 1--4");

   iis_open(SvPV(perl_get_sv("fifi",FALSE),n_a),SvPV(perl_get_sv("fifo",FALSE),n_a),
        (int)SvIV( perl_get_sv("fbconfig", FALSE) ),
        (int)SvIV( perl_get_sv("fb_x", FALSE) ),
        (int)SvIV( perl_get_sv("fb_y", FALSE) ) );

   threadloop %{
      iis_drawcirc( (float) $x(), (float) $y(), (float) $r(), (int) $colour(), frame);
   %}

   iis_close();

'); # End of iiscirc_c pp_def


pp_addpm({At=>Bot},<<'EOD');

=head1 BUGS

None known

=head1 AUTHOR

Copyright (C) Karl Glazebrook 1997.
All rights reserved. There is no warranty. You are allowed
to redistribute this software / documentation under certain
conditions. For details, see the file COPYING in the PDL
distribution. If this file is separated from the PDL distribution,
the copyright notice should be included in the file.


=cut
EOD

pp_done();