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->malloc( (*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 kimagergb kstarted kcur');

pp_addpm(<<'ENDOFPM');

# 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 kimagergb

=for usage

kimagergb($lut, [$karma-app])

=for ref

Sends RGB image to an external Karma application for viewing


Does not change current default viewer.

=cut

sub kimagergb {
barf('Usage: kimagergb($lut, [$karma-app])') if $#_==-1;
$#_==0? kimagergb_private(@_,$LASTAPP) : kimagergb_private(@_)
};

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( 'kimagergb_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('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 = pop @_ if ref($_[-1]) eq "HASH";
   barf("Usage: koverlay: \$x, \$y, {Options...} \n") if @_ != 2;
   my($x,$y) = @_;
   my ($app,$col,$rad,$ell,$PA,$fill,$id,$dotext);
   $app = $LASTAPP unless ($app = delete($hash->{App}));
   $col = "blue"   unless ($col = delete($hash->{Colour}));
   $rad = 10       unless ($rad = delete($hash->{Radius}));
   $ell = 0        unless ($ell = delete($hash->{Ellip}));
   $PA  = 0        unless ($PA   = delete($hash->{PA}));
   $fill = 0       unless ($fill = delete($hash->{Fill}));
   $dotext = 1;
   unless ($id = delete($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) Christian Soeller, Karl Glazebrook 1997. 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.

=cut

EOD

pp_done();