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 C<$stdimage> is exported from the module and controls
the frame buffer configuration currently in use. The default value
is C<imt1024> which specifies a C<1024x1024> frame buffer. Other
values supported by the module are:
imt512, imt800, imt1024, imt1600, imt2048, and imt4096.
If you have a F<$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 F<$HOME/.imtoolrc> or F</usr/local/lib/imtoolrc>)
The Perl variable C<$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',
FRAME => 2 } ]
iis $image, [$min,$max]
=for sig
(image(m,n),[\%options]) or (image(m,n),[min(),max()])
Displays image on a IIS device. If C<min()> or C<max()> are omitted they
are autoscaled. A good demonstration of PDL threading can be had
by giving C<iis()> a data *cube* - C<iis()> will be repeatedly called
for each plane of the cube resulting in a poor man's movie!
If supplied, C<TITLE> is used to label the frame, if no title is
supplied, either the C<OBJECT> value stored in the image header or a
default string is used (the title is restricted to a maximum
length of 32 characters).
To specify which frame to draw to, either use
the package variable C<$iisframe>, or the C<FRAME> option.
=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/;
}
my $frame = $iisframe;
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, FRAME => $frame } );
$opt->options( shift );
my $options = $opt->current;
$min = $$options{MIN};
$max = $$options{MAX};
$title = $$options{TITLE};
$iisframe = $$options{FRAME};
}
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 in frame $iisframe from $min to $max ...\n" if $PDL::verbose;
PDL::_iis($image,$min,$max,$title);
$iisframe = $frame; # restore value
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 C<($x,$y)> position and the character typed (C<$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
(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
L<PDL::PP|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($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',
Pars => 'image(m,n); min(); max();',
OtherPars => 'char *perl_title',
Doc => undef,
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));
{ $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) );
}
}
%}
free(data);
iis_close();
'); # End of iis_c pp_def
pp_def( '_iiscirc',
Pars => 'x(); y(); r(); colour();',
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();