pp_addpm({At=>Top},<<'EOD');
=head1 NAME
PDL::Graphics::Karma - interface to Karma visualisation applications
=head1 DESCRIPTION
Can send PDL 2D/3D data to kview, xray, kslice_3d, etc...
Data is transferred using shared memory when available on
the OS (and segments big enough - e.g. Linux but not
Solaris unless tuned) so ought to be very fast.
You can say
perldl> kim $a, {App=>'xray'}
to send to a specific viewer and/or
perldl> kim $a, {BB=>[0,50,-100,100]}
to specify the bounding box in world coordinates (here for a 2D image)
or just
perldl> kim $a
to reuse the last viewer.
You can start the viewers from PDL.
For further info about Karma see http://www.atnf.csiro.au/karma.
The binary distribution can be downloaded from
http://www.atnf.csiro.au/karma/ftp.html.
=head1 SYNOPSIS
use PDL::Karma;
kview;
kim $data;
=head1 FUNCTIONS
=cut
EOD
pp_addhdr(<<'ENDOFHDR');
#include <karma_iarray.h>
#include <karma_dsxfr.h>
#include <karma_conn.h>
#include <karma_dm.h>
#include <karma_ds.h>
#include <karma_r.h>
#include <karma_m.h>
#include <karma_st.h>
#include <karma_overlay.h>
#include <karma_event.h>
#include <k_event_codes.h>
#define K_PDL_Byte K_UBYTE
#define K_PDL_Short K_SHORT
#define K_PDL_Ushort K_USHORT
#define K_PDL_Long K_INT
#define K_PDL_Float K_FLOAT
#define K_PDL_Double K_DOUBLE
static KOverlayList mylist;
static int first_overlay=1;
double* packdouble ( SV* sv, int *ndims ) {
SV* bar;
AV* array;
int i;
double *darr;
if (!(SvROK(sv) && SvTYPE(SvRV(sv))==SVt_PVAV)) /* Test */
return NULL;
array = (AV *) SvRV(sv); /* dereference */
*ndims = (int) av_len(array) + 1; /* Number of dimensions */
darr = (double *) PDL->smalloc( (*ndims) * sizeof(double) );
if (darr == NULL)
barf("Out of memory");
for(i=0; i<(*ndims); i++) {
bar = *(av_fetch( array, i, 0 )); /* Fetch */
darr[i] = (double) SvNV(bar);
}
return darr;
}
void ensure_initialised() {
static int first = 1;
if (first) {
first = 0;
/* Initialise communications package */
dm_native_setup ();
conn_initialise ( ( void (*) () ) NULL );
/* Register multi_array client protocol support */
dsxfr_register_connection_limits (-1, 1);
}
}
int ensure_connection(char *karma_app)
{
ensure_initialised();
/* Attempt connection to module */
if ( !conn_attempt_connection ("localhost",
r_get_def_port (karma_app, r_getenv("DISPLAY")),
"multi_array") )
return 0;
return 1;
}
static void add_cmap (multi_array **multi_desc, packet_desc* pack_desc,
char *packet)
/* This routine will add a colourmap to a multi_aray data structure.
The multi_array header pointer must be pointed to by multi_desc .This
pointer will be updated with a new pointer.
The pointer to the top level packet descriptor of the general data
structure which contains the colourmap must be pointed to by pack_desc .
The pointer to the top level packet of the general data structure which
contains the colourmap must be pointed to by packet .
The routine returns nothing.
*/
{
multi_array *new_multi_desc;
static char function_name[] = "add_cmap";
if ( ( new_multi_desc = ds_alloc_multi (2) ) == NULL )
{
m_abort (function_name, "multi_array");
}
if ( ( (*new_multi_desc).array_names[0] = st_dup ("Frame") ) == NULL )
{
m_abort (function_name, "frame name");
}
if ( ( (*new_multi_desc).array_names[1] = st_dup ("RGBcolourmap") )
== NULL )
{
m_abort (function_name, "colourmap name");
}
(*new_multi_desc).headers[0] = (**multi_desc).headers[0];
(*new_multi_desc).data[0] = (**multi_desc).data[0];
(*new_multi_desc).headers[1] = pack_desc;
(*new_multi_desc).data[1] = packet;
(**multi_desc).headers[0] = NULL;
(**multi_desc).data[0] = NULL;
ds_dealloc_multi (*multi_desc);
*multi_desc = new_multi_desc;
} /* End Function add_cmap */
ENDOFHDR
pp_addpm(<<'ENDOFPM');
use vars qw($LASTAPP);
$LASTAPP = 'kview'; # Default application
ENDOFPM
pp_add_exported('','kim krgb kstarted kcur');
pp_addpm(<<'ENDOFPM');
use PDL::Options;
# kim - send image data to karma app
=head2 kim
=for ref
Sends piddle data array to an external Karma application for viewing
=for usage
kim($pdl, [$karma-app, $lut])
Sends $pdl data to Karma application viewer. Remembers the
last one used [default: kview].
=cut
sub kim {
barf('Usage: kim $pdl [,{App => $karma-app, LUT => $lut, BB => $bb}]')
if $#_==-1;
my $pdl = shift;
my $hash = shift;
my ($app,$inds);
$app = $LASTAPP unless ($app = delete($hash->{App}));
my ($lut,$haslut) = (PDL->zeroes(PDL::byte,1,1),0);
if (defined($hash->{LUT})) {
$lut = $hash->{LUT};
$haslut = 1;
}
if ($pdl->getndims == 3) {
$inds = [0,$pdl->getdim(0)-1,0,$pdl->getdim(1)-1,0,
$pdl->getdim(2)-1] unless $inds=delete($hash->{BB});
ksend3D ($pdl, $lut,$haslut,$app,$inds);
}
else {
$inds = [0,$pdl->getdim(0)-1,0,$pdl->getdim(1)-1]
unless $inds=delete($hash->{BB});
ksend2D ($pdl, $lut, $haslut,$app,$inds);
}
$LASTAPP = $app;
}
=head2 kstarted
=for usage
kstarted([$karma-app])
=for ref
Tests if a Karma application is running.
It tries to connect to the karma application, returns 1 on
success, 0 otherwise
Can be used to check if a karma application has already been
started, e.g.
xray unless kstarted 'xray';
=cut
sub kstarted {
barf('Usage: kstarted [$karma-app]')
if $#_>0;
my $app = $#_ > -1 ? shift : $LASTAPP;
$LASTAPP = $app;
return kconnect($app);
}
=head2 krgb
=for usage
krgb($lut, [$karma-app])
=for ref
Sends RGB image to an external Karma application for viewing
Does not change current default viewer.
=cut
sub krgb {
barf('Usage: krgb($lut, [$karma-app])') if $#_==-1;
my @args = @_;
push @args, $LASTAPP if $#_==0;
barf "must be [3,..] rgb piddle" unless $args[0]->getdim(0) == 3;
if ($args[0]->getndims <= 3) { krgb_private(@args) } else {
krgb3d_private(@args)}
};
ENDOFPM
# Add all the karma app startup commands
for $app (qw(kview koords kpvslice krenzo kshell xray kslice_3d)) {
pp_add_exported('',$app);
pp_addpm(<<"ENDOFPM");
=head2 $app()
=for ref
Starts external Karma application $app
=for usage
$app([OPTIONS])
=for example
perldl> kview (-num_col => 42)
perldl> xray
=cut
sub $app { # Start $app
if( !(\$pid = fork)) { # error or child
exec("$app", \@_) if defined \$pid;
die "Can't start kview: \$!\n";
}
\$LASTAPP = "$app";
return \$pid;
}
ENDOFPM
} # End app loop
pp_addxs('
int
kconnect(app)
char * app
CODE:
RETVAL = ensure_connection(app);
if (RETVAL)
conn_close(conn_get_client_connection("multi_array",0));
OUTPUT:
RETVAL
');
# currently lut is assumed to be 8bits
pp_def('ksend2D',
Pars => 'im(m,n); byte lut(o,p)', Doc=>undef,
OtherPars => 'int haslut; char* karma_app; SV *bb',
Code => 'array_desc *arrayd;
array_pointer arrayp;
multi_array *arraym;
$GENERIC() *ptr;
int ms, ns, os, ps;
char *tpack;
packet_desc *tpack_desc;
unsigned short *cmap;
double fc[2], lc[2];
uaddr lengths[2];
unsigned int dtype;
static char *elem_names[1] = { "intensity" };
int bblen;
double *dbb = packdouble($COMP(bb),&bblen);
if (bblen != 4)
barf("need 4 coodinates for 2D boundary box");
fc[0] = dbb[2]; lc[0] = dbb[3];
fc[1] = dbb[0]; lc[1] = dbb[1];
lengths[0] = $SIZE(n);
lengths[1] = $SIZE(m);
ms = $SIZE(m); ns = $SIZE(n); os = $SIZE(o); ps = $SIZE(p);
printf("Sending to %s...\n",$COMP(karma_app));
if (!ensure_connection($COMP(karma_app)))
barf("Error connecting to %s via karma communications",
$COMP(karma_app));
dtype = $TBSULFD(K_PDL_Byte,K_PDL_Short,K_PDL_Ushort,
K_PDL_Long,K_PDL_Float,K_PDL_Double);
/* First create array descriptor */
if ( ( arrayd = ds_easy_alloc_array_desc
(2, lengths,
(CONST double *) fc, (CONST double *) lc,
(CONST double **) NULL, (CONST char **) NULL, 1, &dtype,
(CONST char **) elem_names) ) == NULL )
{
barf("couldn\'t allocate mem for multi array descriptor");
}
/* Now try and create the karma array in various kinds of memory */
if ( !ds_alloc_shm_array (&arrayp, arrayd, FALSE, FALSE) &&
!ds_alloc_mmap_array (-1, 0, 0, TRUE, &arrayp, arrayd, FALSE, FALSE) &&
!ds_alloc_vm_array (&arrayp, arrayd, FALSE, FALSE) )
barf("Unable to create space for karma array (tried shm/mmap/vm)\n");
if ((arraym=ds_easy_alloc_array_from_array_desc(arrayd,&arrayp,FALSE)) == NULL)
barf("couldn\'t allocate mem for multi array");
ptr = ($GENERIC()*) (*(char **) arraym->data[0]);
if ($COMP(haslut)) {
if (os != 3)
barf("first dim must be 3 for rgb");
if ( ( cmap = ds_cmap_alloc_colourmap (ps,
(multi_array **) NULL,
&tpack_desc, &tpack) ) == NULL )
barf("couldn\'t allocate mem for cmap");
add_cmap(&arraym, tpack_desc, tpack);
}
/* Copy piddle into karma array */
threadloop %{
unsigned short *cm = cmap;
loop(n) %{
loop(m) %{
*ptr++ = $im();
%}
%}
if ($COMP(haslut)) {
loop(p) %{
loop(o) %{
*cm++ = $lut() * 256;
%}
%}
}
/* Send a to module */
dsxfr_put_multi("connections",arraym);
%}
conn_close(conn_get_client_connection("multi_array",0));
ds_dealloc_multi(arraym);
');
# Note reason for seperate 3D function is kview gives error:
# right_x: 0.000000e+00 must not equal left_x: 0.000000e+00
# if given a MxNx1 image
# currently lut is assumed to be 8bits
pp_def('ksend3D',
Pars => 'im(m,n,z); byte lut(o,p)', Doc=>undef,
OtherPars => 'int haslut; char* karma_app; SV* bb',
Code => 'array_desc *arrayd;
array_pointer arrayp;
multi_array *arraym;
$GENERIC() *ptr;
int ms, ns, os, ps, zs;
char *tpack;
packet_desc *tpack_desc;
unsigned short *cmap;
double fc[3], lc[3];
uaddr lengths[3];
unsigned int dtype;
static char *elem_names[1] = { "intensity" };
int bblen;
double *dbb = packdouble($COMP(bb),&bblen);
if (bblen != 6)
barf("need 6 coodinates for 3D boundary box");
fc[0] = dbb[4]; lc[0] = dbb[5];
fc[1] = dbb[2]; lc[1] = dbb[3];
fc[2] = dbb[0]; lc[2] = dbb[1];
lengths[0] = $SIZE(z);
lengths[1] = $SIZE(n);
lengths[2] = $SIZE(m);
zs = $SIZE(z); ms = $SIZE(m); ns = $SIZE(n);
os = $SIZE(o); ps = $SIZE(p);
printf("Sending to %s...\n",$COMP(karma_app));
if (!ensure_connection($COMP(karma_app)))
barf("Error connecting to %s via karma communications",
$COMP(karma_app));
dtype = $TBSULFD(K_PDL_Byte,K_PDL_Short,K_PDL_Ushort,
K_PDL_Long,K_PDL_Float,K_PDL_Double);
/* First create array descriptor */
if ( ( arrayd = ds_easy_alloc_array_desc
(3, lengths,
(CONST double *) fc, (CONST double *) lc,
(CONST double **) NULL, (CONST char **) NULL, 1, &dtype,
(CONST char **) elem_names) ) == NULL )
{
barf("couldn\'t allocate mem for multi array descriptor");
}
/* Now try and create the karma array in various kinds of memory */
if ( !ds_alloc_shm_array (&arrayp, arrayd, FALSE, FALSE) &&
!ds_alloc_mmap_array (-1, 0, 0, TRUE, &arrayp, arrayd, FALSE, FALSE) &&
!ds_alloc_vm_array (&arrayp, arrayd, FALSE, FALSE) )
barf("Unable to create space for karma array (tried shm/mmap/vm)\n");
if ((arraym=ds_easy_alloc_array_from_array_desc(arrayd,&arrayp,FALSE)) == NULL)
barf("couldn\'t allocate mem for multi array");
ptr = ($GENERIC()*) (*(char **) arraym->data[0]);
if ($COMP(haslut)) {
if (os != 3)
barf("first dim must be 3 for rgb");
if ( ( cmap = ds_cmap_alloc_colourmap (ps,
(multi_array **) NULL,
&tpack_desc, &tpack) ) == NULL )
barf("couldn\'t allocate mem for cmap");
add_cmap(&arraym, tpack_desc, tpack);
}
threadloop %{
unsigned short *cm = cmap;
loop(z) %{
loop(n) %{
loop(m) %{
*ptr++ = $im();
%}
%}
%}
if ($COMP(haslut)) {
loop(p) %{
loop(o) %{
*cm++ = $lut() * 256;
%}
%}
}
/* Send a to module */
dsxfr_put_multi("connections",arraym);
%}
conn_close(conn_get_client_connection("multi_array",0));
ds_dealloc_multi(arraym);'
);
pp_def( 'krgb_private',
Pars => 'im(m,n,o)', Doc=>undef,
OtherPars => 'char* karma_app;',
Code => q@int ms=$SIZE(m);
multi_array *multi_desc;
char *array;
uaddr lengths[2];
static unsigned int elem_types[3] =
{K_UBYTE, K_UBYTE, K_UBYTE};
static char *elem_names[3] =
{"Red Intensity", "Green Intensity", "Blue Intensity"};
if (ms != 3)
barf("first dim must be 3 for rgb");
lengths[0] = $SIZE(o);
lengths[1] = $SIZE(n);
/* check if we can use the 'preallocated' equivalent */
if ( ( array = ds_easy_alloc_n_element_array
(&multi_desc, 2, lengths,
(CONST double *) NULL, (CONST double *) NULL,
(CONST char **) NULL, 3, elem_types,
(CONST char **) elem_names) ) == NULL )
{
barf("couldn\'t allocate mem for multi array");
}
if (!ensure_connection($COMP(karma_app)))
barf("Error connecting to %s via karma communications",
$COMP(karma_app));
threadloop %{
loop(o) %{
loop(n) %{
loop(m) %{
*array++ = $im();
%}
%}
%}
dsxfr_put_multi("connections",multi_desc);
%}
ds_dealloc_multi(multi_desc);
conn_close(conn_get_client_connection("multi_array",0));@
);
pp_def( 'krgb3d_private',
Pars => 'im(m,n,o,p)', Doc=>undef,
OtherPars => 'char* karma_app;',
Code => q@int ms=$SIZE(m);
multi_array *multi_desc;
char *array;
uaddr lengths[3];
static unsigned int elem_types[3] =
{K_UBYTE, K_UBYTE, K_UBYTE};
static char *elem_names[3] =
{"Red Intensity", "Green Intensity", "Blue Intensity"};
if (ms != 3)
barf("first dim must be 3 for rgb");
lengths[0] = $SIZE(p);
lengths[1] = $SIZE(o);
lengths[2] = $SIZE(n);
/* check if we can use the 'preallocated' equivalent */
if ( ( array = ds_easy_alloc_n_element_array
(&multi_desc, 3, lengths,
(CONST double *) NULL, (CONST double *) NULL,
(CONST char **) NULL, 3, elem_types,
(CONST char **) elem_names) ) == NULL )
{
barf("couldn\'t allocate mem for multi array");
}
if (!ensure_connection($COMP(karma_app)))
barf("Error connecting to %s via karma communications",
$COMP(karma_app));
threadloop %{
loop(p) %{
loop(o) %{
loop(n) %{
loop(m) %{
*array++ = $im();
%}
%}
%}
%}
dsxfr_put_multi("connections",multi_desc);
%}
ds_dealloc_multi(multi_desc);
conn_close(conn_get_client_connection("multi_array",0));@
);
pp_def('koverlay',
Pars => 'x(); y(); r(); ell(); PA(); fill(); int id();',
OtherPars => 'char* karma_app; char* colour; int coordtype; int dotext;',Doc=><<'EOD',
=head2 koverlay
=for ref
Overlay graphics markers on a Karma application (e.g. kview)
=for usage
koverlay $x, $y, {Options...}
Currently the only markers supported are ellipses. The default
is a circle of radius 10 units,
=for example
$x = 10*xvals(10);
koverlay $x, sqrt($x), {Radius=>$x/3, Colour=>'green', App=>'kpolar'}
=for options
Radius - [piddle] specify radius of ellipses (major axis if ellipse). Default = 10 units.
Ellip - [piddle] specify ellipticity of ellipses. Default = 0 i.e. circle.
PA - [piddle] specify principle axis (degrees rotation anticlockwise
from the Y axis). Default.
ID - [piddle] Numeric integer id labels to apply.
Colour - [string] Colour name for overlay (e.g. 'red'). Default = 'blue'
App - [string] name of Karma app to send too
Fill - [piddle] whether outlines are filled (0 or 1). (Note filled,
ellipses are not yet available in Karma).
Coords - [string] "World" or "Pixel" - type of coordinates for x/y/r.
Note pixel implementation rounds to nearest pixel due
to Karma overlays not supporting proper IMAGE_PIXEL
coordinates.
=cut
EOD
Signature => 'x(); y(); {r(); ell(); PA(); fill(); int id();}',
Code => '
double ell;
int bad=0;
int coordtype = $COMP(coordtype) == 1 ? OVERLAY_COORD_WORLD : OVERLAY_COORD_LINEAR;
int dotext = $COMP(dotext);
char string[81];
printf("Sending to %s...\n",$COMP(karma_app));
if (first_overlay) {
ensure_initialised ();
if ((mylist=overlay_va_create_list(NULL, NULL,
OVERLAY_ATT_END))==NULL)
printf("Error initialising overlay list");
first_overlay=0;
}
if (!conn_attempt_connection ("localhost",
r_get_def_port ($COMP(karma_app), r_getenv("DISPLAY")),"2D_overlay"))
barf("Error connecting to %s via karma communications",$COMP(karma_app));
threadloop %{
ell = $ell();
if (ell == 1.0) {
ell = 0.9999999999999999;
bad = 1;
}
overlay_arc(mylist, coordtype, (double)$x(), (double)$y(),
coordtype, (double)$r(), (double)($r()*1.0/(1.0-ell)),
(double)$PA(), $COMP(colour),
(int)($fill() ? 1:0) );
if (dotext) {
sprintf(string,"%-80d\0", $id());
overlay_text(mylist, string, coordtype, (double)($x()+0.8*$r()), (double)($y()+0.8*$r()*1.0/(1.0-ell)),
$COMP(colour), "fixed", 0);
}
%}
while ( !overlay_have_token (mylist) ) dm_native_poll (-1);
overlay_release_token (mylist);
conn_close(conn_get_client_connection("2D_overlay",0));
overlay_remove_objects(mylist,0);
if (bad)
barf("Infinite ellipticity was specified!\n");
', PMCode=><<'EOD');
sub PDL::koverlay {
my $hash = ref($_[-1]) eq "HASH" ? pop @_ : {};
barf("Usage: koverlay: \$x, \$y, {Options...} \n") if @_ != 2;
my($x,$y) = @_;
$hash = {iparse({App => $LASTAPP,
Colour => "blue",
Radius => 10,
Ellipse => 0,
PA => 0,
Fill => 0,
ID => undef,
Coords => "WORLD"},$hash)};
my ($app,$col,$rad,$ell,$PA,$fill,$id,$dotext);
$app = $hash->{App};
$col = $hash->{Colour};
$rad = $hash->{Radius};
$ell = $hash->{Ellipse};
$PA = $hash->{PA};
$fill = $hash->{Fill};
$dotext = 1;
unless (defined ($id = $hash->{ID})) {
$id = pdl(0); $dotext = 0;
}
my $supported = {"WORLD"=>1, "PIXEL"=>2};
my $type=1;
$type = $supported->{uc($hash->{Coords})} if defined $hash->{Coords};
barf "koverlay: Unsupported coordinate type" unless $type;
&PDL::_koverlay_int($x,$y,$rad,$ell,$PA,$fill,$id,$app,$col,$type,$dotext);
$LASTAPP = $app;
}
EOD
pp_addpm(<<'EOD');
=head2 kcur
=for ref
Return cursor position from a Karma application (e.g. kview/xray)
=for usage
($x,$y) = kcur($ch, {App=>'karma-app',Coords=>"World|Pixel"})
This function connects to a Karma application and returns
the ($x,$y) position and the character typed ($ch)
by the user. By default world coordinates are returned.
=for example
print kcur {App=>"kview", Coords=>"World"}
=cut
sub kcur {
my $hash = pop if ref($_[$#_]) eq "HASH";
my $supported = {"WORLD"=>1, "PIXEL"=>2};
my $type=1;
$type = $supported->{uc($hash->{Coords})} if defined $hash->{Coords};
barf "kcur: Unsupported coordinate type" unless $type;
my $app;
$app = $LASTAPP unless ($app = delete($hash->{App}));
my ($x,$y,$ch) = &_kcur_int($app,$type);
$_[0] = $ch; # Pass this back in args
$LASTAPP = $app;
return ($x,$y);
}
EOD
pp_addxs('',<<'EOD');
MODULE = PDL::Graphics::Karma PACKAGE = PDL::Graphics::Karma
void
_kcur_int(app,type)
PPCODE:
char* app = SvPV(ST(0),PL_na);
int type = SvIV(ST(1));
double x,y;
KEvent coord;
Connection myconn;
ensure_initialised();
event_initialise();
if (!conn_attempt_connection ("localhost",
r_get_def_port (app, r_getenv("DISPLAY")),"generic_event"))
barf("Error connecting to %s via karma communications",app);
myconn = conn_get_client_connection("generic_event",0);
event_wait( K_EVENT_MASK_KEYPRESS , myconn, &coord );
if (type==1) {
x = coord.data.keypress.position.world.x;
y = coord.data.keypress.position.world.y;
}
else if (type==2) {
x = coord.data.keypress.position.image_pixel.x;
y = coord.data.keypress.position.image_pixel.y;
}
conn_close(conn_get_client_connection("generic_event",0));
EXTEND(sp,3);
PUSHs(sv_2mortal(newSVnv( x )));
PUSHs(sv_2mortal(newSVnv( y )));
PUSHs(sv_2mortal(newSVpv( coord.data.keypress.string ,1)));
EOD
pp_addpm({At=>Bot},<<'EOD');
=head1 AUTHORS
Copyright (C) 1997-2001 Christian Soeller, Karl Glazebrook. Reproducing
documentation from the pdl distribution in any way that does not include a
statement telling who the original authors are is forbidden. Reproducing
and/or distributing the documentation in any form that alters the text is
forbidden. This module is free software and can be distributed under the
same terms as PDL itself.
=cut
EOD
pp_done();