PDL-Graphics-PLplot
view release on metacpan or search on metacpan
loop (nx,ny) %{ zz[nx][ny] = $z(); %}
c_plsurf3d ($P(x), $P(y), (const PLFLT **)zz, $SIZE(nx), $SIZE(ny), $opt(),
$P(clevel), $SIZE(nlevel));
plFree2dGrid(zz, $SIZE(nx), $SIZE(ny));'
);
pp_def('plsurf3dl',
NoPthread => 1,
Pars => 'x(nx); y(ny); z(nx,ny); int opt(); clevel(nlevel); int indexxmin(); int indexxmax(); int indexymin(nx); int indexymax(nx);',
GenericTypes => [D],
Doc => 'Plot shaded 3-d surface plot with limits',
Code => '
int i, j, size_x, size_y;
PLFLT** zz;
plAlloc2dGrid(&zz, $SIZE(nx), $SIZE(ny));
if (!zz) $CROAK("Failed to allocate memory for grid");
loop (nx,ny) %{ zz[nx][ny] = $z(); %}
c_plsurf3dl(
$P(x), $P(y), (const PLFLT **) zz, $SIZE(nx), $SIZE(ny), $opt(),
$P(clevel), $SIZE(nlevel),
$indexxmin(), $indexxmax(), $P(indexymin), $P(indexymax)
);
plFree2dGrid(zz, $SIZE(nx), $SIZE(ny));'
);
pp_def ('plstyl',
NoPthread => 1,
Pars => 'int mark(nms); int space(nms)',
GenericTypes => [D],
Doc => 'Set line style',
Code => 'c_plstyl ($SIZE(nms), $P(mark), $P(space));'
);
# PLplot standard random number generation. Using this
# helps to keep the demo plots identical.
pp_def ('plseed',
NoPthread => 1,
Pars => 'int seed()',
Code => 'unsigned int useed = (unsigned int)$seed(); c_plseed(useed);'
);
pp_def ('plrandd',
NoPthread => 1,
Pars => 'double [o]rand()',
Code => '$rand() = c_plrandd();'
);
# pltr0: Identity transformation
# pltr1: Linear interpolation from singly dimensioned coord arrays
# Linear interpolation from doubly dimensioned coord arrays
for my $t ([qw(pltr0 SV*)], [qw(pltr1 PLcGridPtr)], [qw(pltr2 PLcGrid2Ptr)]) {
my ($func, $type) = @$t;
pp_addxs (<<"EOC");
void
$func(x, y, grid)
double x
double y
$type grid
PPCODE:
PLFLT tx, ty;
$func(x, y, &tx, &ty, (PLPointer) grid);
EXTEND (SP, 2);
PUSHs(sv_2mortal(newSVnv((double) tx)));
PUSHs(sv_2mortal(newSVnv((double) ty)));
EOC
pp_add_exported($func);
}
pp_def ('plAllocGrid',
NoPthread => 1,
Pars => 'double xg(nx); double yg(ny)',
OtherPars => '[o] PLcGridPtr__OUT grid',
GenericTypes => [D],
Doc => 'Allocates a PLcGrid object for use in pltr1',
Code => '
PLcGrid *grid;
int i, nx = $SIZE(nx), ny = $SIZE(ny);
Newx(grid, 1, PLcGrid);
if(grid == NULL) $CROAK("Failed to allocate memory for grid");
Newxz(grid->xg, nx, PLFLT);
if(grid->xg == NULL) $CROAK("Failed to allocate memory for grid->xg");
Newxz(grid->yg, ny, PLFLT);
if(grid->yg == NULL) $CROAK("Failed to allocate memory for grid->yg");
grid->nx = nx;
grid->ny = ny;
for (i = 0; i < nx; i++)
grid->xg[i] = $xg(nx => i);
for (i = 0; i < ny; i++)
grid->yg[i] = $yg(ny => i);
$COMP(grid) = (PLcGridPtr__OUT)grid;'
);
# Free a PLcGrid object
pp_addxs (<<"EOC");
void
plFreeGrid (pg)
PLcGridPtr pg
PPCODE:
PLPTR_RECEIVE_IN(PLcGrid, grid, pg)
Safefree(grid->xg);
Safefree(grid->yg);
Safefree(grid);
EOC
pp_add_exported (plFreeGrid);
pp_def ('plAlloc2dGrid',
NoPthread => 1,
Pars => 'double xg(nx,ny); double yg(nx,ny)',
OtherPars => '[o] PLcGrid2Ptr__OUT grid',
GenericTypes => [D],
Doc => 'Allocates a PLcGrid2 object for use in pltr2',
Code => '
PLcGrid2 *grid = (PLcGrid2*) malloc(sizeof(PLcGrid2));
if (!grid) $CROAK("Failed to allocate memory for grid");
plAlloc2dGrid(&(grid->xg), $SIZE(nx), $SIZE(ny));
if (!grid->xg) {
free(grid);
$CROAK("Failed to allocate memory for grid");
}
plAlloc2dGrid(&(grid->yg), $SIZE(nx), $SIZE(ny));
if (!grid->yg) {
free(grid);
plFree2dGrid(grid->xg, $SIZE(nx), $SIZE(ny));
$CROAK("Failed to allocate memory for grid");
}
loop (nx,ny) %{
grid->xg[nx][ny] = $xg();
grid->yg[nx][ny] = $yg();
%}
grid->nx = $SIZE(nx);
grid->ny = $SIZE(ny);
$COMP(grid) = grid;'
);
# Free a PLcGrid2 object
pp_addxs (<<"EOC");
void
plFree2dGrid(pg)
PLcGrid2Ptr pg
PPCODE:
PLPTR_RECEIVE_IN(PLcGrid2, grid, pg)
plFree2dGrid(grid->xg, grid->nx, grid->ny);
plFree2dGrid(grid->yg, grid->nx, grid->ny);
free(grid);
EOC
pp_add_exported (plFree2dGrid);
pp_addhdr (<<'EOH');
void pltr_iv_set(IV iv0, IV iv1, IV iv2);
void pltr_callback_set(SV *sv, char *msg);
void pltr_callback(PLFLT x, PLFLT y, PLFLT* tx, PLFLT* ty, PLPointer pltr_data);
void* get_standard_pltrcb(SV* cb);
void defined_callback_set(SV *sv, char *msg);
PLINT defined_callback(PLFLT x, PLFLT y);
void default_magic(pdl *p, size_t pa);
void mapform_callback_set(SV *sv, char *msg);
void mapform_callback(PLINT n, PLFLT* x, PLFLT* y);
void xform_callback_set(SV *sv, char *msg);
void xform_callback(PLFLT x, PLFLT y, PLFLT *xt, PLFLT *yt, PLPointer data);
void labelfunc_callback_set(SV *sv, char *msg);
void labelfunc_callback(PLINT axis, PLFLT value, char *label_text, PLINT length, void *data);
EOH
pp_def ('init_pltr',
NoPthread => 1,
GenericTypes => [D],
Pars => '',
OtherPars => 'SV* p0; SV* p1; SV* p2;',
Doc => <<'EOF',
Used internally to set the variables C<pltr{0,1,2}_iv> to the "pointers"
of the Perl subroutines C<pltr{1,2,3}>. These variables are later used by
C<get_standard_pltrcb> to provide the pointers to the C function C<pltr{0,1,2}>.
This accelerates functions like plcont and plshades when those standard
transformation functions are used.
EOF
Code => '
pltr_iv_set(
(IV) SvRV ($COMP(p0)),
(IV) SvRV ($COMP(p1)),
(IV) SvRV ($COMP(p2)));');
pp_addpm (<<'EOPM');
init_pltr (\&pltr0, \&pltr1, \&pltr2);
EOPM
pp_def ('plmap',
NoPthread => 1,
Pars => 'minlong(); maxlong(); minlat(); maxlat();', # 0-3
OtherPars => 'SV* mapform; char* type;', # 4,5
PMCode => _make_reorder('plmap'),
Doc => 'plot continental outline in world coordinates',
GenericTypes => [D],
Code => '
int use_xform;
mapform_callback_set($COMP(mapform),
"plmap: mapform must be either 0 or a subroutine pointer");
use_xform = SvTRUE ($COMP(mapform));
plmap (use_xform ? mapform_callback : NULL,
=head2 plxormod
=for sig
$status = plxormod ($mode)
=for ref
Set xor mode:
mode = 1-enter, 0-leave, status = 0 if not interactive device
See the PLplot manual for reference.
=cut
EOPM
pp_addxs (<<"EOC");
int
plxormod (mode)
int mode
CODE:
PLINT status;
c_plxormod (mode, &status);
RETVAL = status;
OUTPUT:
RETVAL
EOC
pp_add_exported ('plxormod');
pp_addpm (<<'EOPM');
=head2 plGetCursor
=for sig
%gin = plGetCursor ()
=for ref
plGetCursor waits for graphics input event and translate to world
coordinates and returns a hash with the following keys:
type: of event (CURRENTLY UNUSED)
state: key or button mask
keysym: key selected
button: mouse button selected
subwindow: subwindow (alias subpage, alias subplot) number
string: translated string
pX, pY: absolute device coordinates of pointer
dX, dY: relative device coordinates of pointer
wX, wY: world coordinates of pointer
Returns an empty hash if no translation to world coordinates is possible.
=cut
EOPM
pp_addxs (<<"EOC");
void
plGetCursor ()
PPCODE:
PLGraphicsIn gin;
if (plGetCursor (&gin)) {
EXTEND (SP, 24);
PUSHs (sv_2mortal (newSVpv ("type", 0)));
PUSHs (sv_2mortal (newSViv ((IV) gin.type)));
PUSHs (sv_2mortal (newSVpv ("state", 0)));
PUSHs (sv_2mortal (newSVuv ((UV) gin.state)));
PUSHs (sv_2mortal (newSVpv ("keysym", 0)));
PUSHs (sv_2mortal (newSVuv ((UV) gin.keysym)));
PUSHs (sv_2mortal (newSVpv ("button", 0)));
PUSHs (sv_2mortal (newSVuv ((UV) gin.button)));
PUSHs (sv_2mortal (newSVpv ("subwindow", 0)));
PUSHs (sv_2mortal (newSViv ((IV) gin.subwindow)));
PUSHs (sv_2mortal (newSVpv ("string", 0)));
PUSHs (sv_2mortal (newSVpv (gin.string, 0)));
PUSHs (sv_2mortal (newSVpv ("pX", 0)));
PUSHs (sv_2mortal (newSViv ((IV) gin.pX)));
PUSHs (sv_2mortal (newSVpv ("pY", 0)));
PUSHs (sv_2mortal (newSViv ((IV) gin.pY)));
PUSHs (sv_2mortal (newSVpv ("dX", 0)));
PUSHs (sv_2mortal (newSVnv ((double) gin.dX)));
PUSHs (sv_2mortal (newSVpv ("dY", 0)));
PUSHs (sv_2mortal (newSVnv ((double) gin.dY)));
PUSHs (sv_2mortal (newSVpv ("wX", 0)));
PUSHs (sv_2mortal (newSVnv ((double) gin.wX)));
PUSHs (sv_2mortal (newSVpv ("wY", 0)));
PUSHs (sv_2mortal (newSVnv ((double) gin.wY)));
}
EOC
pp_add_exported ('plGetCursor');
pp_addpm (<<'EOPM');
=head2 plgstrm
=for sig
$strm = plgstrm ()
=for ref
Returns the number of the current output stream.
=cut
EOPM
pp_addxs (<<"EOC");
int
plgstrm ()
CODE:
PLINT strm;
c_plgstrm (&strm);
RETVAL = strm;
OUTPUT:
RETVAL
EOC
pp_add_exported ('plgstrm');
pp_addpm (<<'EOPM');
"plslabelfunc: labelfunc must be either 0 or a subroutine pointer");
plslabelfunc (SvTRUE(labelfunc) ? labelfunc_callback : NULL, NULL);
EOC
pp_add_exported ('plslabelfunc');
#----------------------------------------------------------------------------
pp_addpm (<<'EOPM');
=head2 pllegend
=for sig
my ($legend_width, $legend_height) =
pllegend ($position, $opt, $x, $y, $plot_width, $bg_color, $nlegend,
\@opt_array,
$text_offset, $text_scale, $text_spacing, $test_justification,
\@text_colors, \@text, \@box_colors, \@box_patterns, \@box_scales, \@line_colors,
\@line_styles, \@line_widths, \@symbol_colors, \@symbol_scales, \@symbol_numbers, \@symbols);
=for ref
See the PLplot manual for more details.
=cut
EOPM
my $width_type = 'double';
pp_addxs (<<"EOC");
void
pllegend(opt, position, x, y, plot_width, bg_color, bb_color, bb_style, nrow, ncolumn, nlegend, opt_array_rv, text_offset, text_scale, text_spacing, text_justification, text_colors_rv, text_rv, box_colors_rv, box_patterns_rv, box_scales_rv, box_line_...
int opt
int position
double x
double y
double plot_width
int bg_color
int bb_color
int bb_style
int nrow
int ncolumn
int nlegend
SV* opt_array_rv
double text_offset
double text_scale
double text_spacing
double text_justification
SV* text_colors_rv
SV* text_rv
SV* box_colors_rv
SV* box_patterns_rv
SV* box_scales_rv
SV* box_line_widths_rv
SV* line_colors_rv
SV* line_styles_rv
SV* line_widths_rv
SV* symbol_colors_rv
SV* symbol_scales_rv
SV* symbol_numbers_rv
SV* symbols_rv
PPCODE:
int i;
double p_legend_width;
double p_legend_height;
int opt_array[nlegend];
int text_colors[nlegend];
char *text[nlegend];
int box_colors[nlegend];
int box_patterns[nlegend];
double box_scales[nlegend];
$width_type box_line_widths[nlegend];
int line_colors[nlegend];
int line_styles[nlegend];
$width_type line_widths[nlegend];
int symbol_colors[nlegend];
double symbol_scales[nlegend];
int symbol_numbers[nlegend];
char *symbols[nlegend];
SV **elem;
for (i = 0; i < nlegend; i++) {
elem = av_fetch((AV *)SvRV(opt_array_rv), i, 0); opt_array[i] = (int)SvIV(*elem);
elem = av_fetch((AV *)SvRV(text_colors_rv), i, 0); text_colors[i] = (int)SvIV(*elem);
elem = av_fetch((AV *)SvRV(text_rv), i, 0); text[i] = (char *)SvPV_nolen(*elem);
box_colors[i] = 0;
if (SvROK(box_colors_rv)) {
elem = av_fetch((AV *)SvRV(box_colors_rv), i, 0);
if (elem && SvOK(*elem)) {
box_colors[i] = (int)SvIV(*elem);
}
}
box_patterns[i] = 0;
if (SvROK(box_patterns_rv)) {
elem = av_fetch((AV *)SvRV(box_patterns_rv), i, 0);
if (elem && SvOK(*elem)) {
box_patterns[i] = (int)SvIV(*elem);
}
}
box_scales[i] = 0.0;
if (SvROK(box_scales_rv)) {
elem = av_fetch((AV *)SvRV(box_scales_rv), i, 0);
if (elem && SvOK(*elem)) {
box_scales[i] = (double)SvNV(*elem);
}
}
box_line_widths[i] = 0.0;
if (SvROK(box_line_widths_rv)) {
elem = av_fetch((AV *)SvRV(box_line_widths_rv), i, 0);
if (elem && SvOK(*elem)) {
box_line_widths[i] = (double)SvIV(*elem);
}
}
line_colors[i] = 0;
if (SvROK(line_colors_rv)) {
elem = av_fetch((AV *)SvRV(line_colors_rv), i, 0);
if (elem && SvOK(*elem)) {
line_colors[i] = (int)SvIV(*elem);
}
}
}
symbol_scales[i] = 0.0;
if (SvROK(symbol_scales_rv)) {
elem = av_fetch((AV *)SvRV(symbol_scales_rv), i, 0);
if (elem && SvOK(*elem)) {
symbol_scales[i] = (double)SvNV(*elem);
}
}
symbol_numbers[i] = 0;
if (SvROK(symbol_numbers_rv)) {
elem = av_fetch((AV *)SvRV(symbol_numbers_rv), i, 0);
if (elem && SvOK(*elem)) {
symbol_numbers[i] = (int)SvIV(*elem);
}
}
symbols[i] = "0";
if (SvROK(symbols_rv)) {
elem = av_fetch((AV *)SvRV(symbols_rv), i, 0);
if (elem && SvOK(*elem)) {
symbols[i] = (char *)SvPV_nolen(*elem);
}
}
}
pllegend(&p_legend_width, &p_legend_height,
opt, position, x, y, plot_width, bg_color, bb_color, bb_style, nrow, ncolumn, nlegend,
opt_array,
text_offset, text_scale, text_spacing, text_justification,
text_colors, (const char **)text, box_colors, box_patterns, box_scales, box_line_widths,
line_colors, line_styles, line_widths, symbol_colors, symbol_scales, symbol_numbers, (const char **)symbols);
EXTEND (SP, 2);
PUSHs (sv_2mortal (newSVnv (p_legend_width)));
PUSHs (sv_2mortal (newSVnv (p_legend_height)));
EOC
pp_add_exported ('pllegend');
#----------------------------------------------------------------------------
pp_addpm (<<'EOPM');
=head2 plspal0
=for sig
plspal0($filename);
=for ref
Set color palette 0 from the input .pal file. See the PLplot manual for more details.
=cut
EOPM
pp_addxs (<<"EOC");
int
plspal0 (filename)
char* filename
PPCODE:
plspal0((const char *)filename);
EOC
pp_add_exported ('plspal0');
#----------------------------------------------------------------------------
pp_addpm (<<'EOPM');
=head2 plspal1
=for sig
plspal1($filename);
=for ref
Set color palette 1 from the input .pal file. See the PLplot manual for more details.
=cut
EOPM
pp_addxs (<<"EOC");
int
plspal1 (filename, interpolate)
char* filename
int interpolate
PPCODE:
plspal1((const char *)filename, (PLBOOL)interpolate);
EOC
pp_add_exported ('plspal1');
pp_addpm (<<'EOPM');
=head2 plbtime
=for sig
my ($year, $month, $day, $hour, $min, $sec) = plbtime($ctime);
=for ref
Calculate broken-down time from continuous time for current stream.
=cut
EOPM
pp_addxs (<<"EOC");
void
plbtime (ctime)
double ctime
PPCODE:
PLINT year;
PLINT month;
PLINT day;
PLINT hour;
PLINT min;
PLFLT sec;
c_plbtime(&year, &month, &day, &hour, &min, &sec, ctime);
EXTEND (SP, 6);
PUSHs (sv_2mortal (newSViv (year)));
PUSHs (sv_2mortal (newSViv (month)));
PUSHs (sv_2mortal (newSViv (day)));
PUSHs (sv_2mortal (newSViv (hour)));
PUSHs (sv_2mortal (newSViv (min)));
PUSHs (sv_2mortal (newSVnv (sec)));
EOC
pp_add_exported ('plbtime');
pp_addpm (<<'EOPM');
=head2 plconfigtime
=for sig
plconfigtime($scale, $offset1, $offset2, $ccontrol, $ifbtime_offset, $year, $month, $day, $hour, $min, $sec);
=for ref
Configure transformation between continuous and broken-down time (and
vice versa) for current stream.
=cut
EOPM
pp_addxs (<<"EOC");
void
plconfigtime(scale, offset1, offset2, ccontrol, ifbtime_offset, year, month, day, hour, min, sec)
double scale
double offset1
double offset2
int ccontrol
int ifbtime_offset
int year
int month
int day
int hour
int min
double sec
PPCODE:
c_plconfigtime((PLFLT) scale, (PLFLT) offset1, (PLFLT) offset2,
(PLINT) ccontrol, (PLBOOL) ifbtime_offset, (PLINT) year,
(PLINT) month, (PLINT) day, (PLINT) hour, (PLINT) min, (PLFLT) sec);
EOC
pp_add_exported ('plconfigtime');
pp_addpm (<<'EOPM');
=head2 plctime
=for sig
my $ctime = plctime($year, $month, $day, $hour, $min, $sec);
=for ref
Calculate continuous time from broken-down time for current stream.
=cut
EOPM
pp_addxs (<<"EOC");
void
plctime(year, month, day, hour, min, sec)
int year
int month
int day
int hour
int min
double sec
PPCODE:
PLFLT ctime;
c_plctime(year, month, day, hour, min, sec, &ctime);
EXTEND (SP, 1);
PUSHs (sv_2mortal (newSVnv (ctime)));
EOC
pp_add_exported ('plctime');
pp_addpm (<<'EOPM');
=head2 pltimefmt
=for sig
pltimefmt($fmt);
=for ref
Set format for date / time labels. Labels must be configured to treat values as
seconds since the epoch via the XBOX/YBOX flags. C<$fmt> is generally
consistent with the POSIX strpformat/strftime flags, but see the PLplot manual
for details.
=cut
EOPM
pp_addxs (<<"EOC");
void
pltimefmt(fmt)
char *fmt
PPCODE:
c_pltimefmt((const char *)fmt);
EOC
pp_add_exported ('pltimefmt');
pp_addpm (<<'EOPM');
=head2 plsesc
=for sig
plsesc($esc);
=for ref
Set the escape character for text strings. See the PLplot manual for more details.
=cut
EOPM
pp_addxs (<<"EOC");
void
plsesc (esc)
SV* esc
PPCODE:
char *esc_c;
esc_c = (char *)SvPV_nolen(esc);
c_plsesc((char)*esc_c);
EOC
pp_add_exported ('plsesc');
pp_def ('plvect',
NoPthread => 1,
GenericTypes => [D],
Pars => 'u(nx,ny); v(nx,ny); scale();',
OtherPars => 'SV* pltr; SV* pltr_data;',
Doc => 'Vector field plots',
Code => '
pltr_callback_set($COMP(pltr),
"plvect: pltr must be either 0 or a subroutine pointer");
PLFLT** u;
plAlloc2dGrid (&u, $SIZE(nx), $SIZE(ny));
if (!u) $CROAK("Failed to allocate memory for grid");
PLFLT** v;
plAlloc2dGrid (&v, $SIZE(nx), $SIZE(ny));
if (!v) {
plFree2dGrid (u, $SIZE(nx), $SIZE(ny));
$CROAK("Failed to allocate memory for grid");
}
loop (nx,ny) %{ u[nx][ny] = $u(); v[nx][ny] = $v(); %}
void (*pltrcb)();
pltrcb = get_standard_pltrcb($COMP(pltr));
PLPointer pltrdt = pltrcb == pltr_callback ? $COMP(pltr_data) :
PLPTR_RECEIVE_SV($COMP(pltr_data));
plvect ((const PLFLT **)u, (const PLFLT **)v, $SIZE(nx), $SIZE(ny), $scale(), pltrcb, pltrdt);
plFree2dGrid(u, $SIZE(nx), $SIZE(ny));
plFree2dGrid(v, $SIZE(nx), $SIZE(ny));'
);
pp_def ('plsvect',
NoPthread => 1,
Pars => 'arrowx(npts); arrowy(npts); int fill()',
GenericTypes => [D],
Doc => 'Give zero-length PDLs for arrowx and arrowy to pass NULL to PLplot func.',
Code => '
c_plsvect (
($SIZE(npts) != 0) ? $P(arrowx) : NULL,
($SIZE(npts) != 0) ? $P(arrowy) : NULL,
$SIZE(npts), $fill()
);
'
);
pp_def ('plhlsrgb',
NoPthread => 1,
GenericTypes => [D],
Pars => 'double h();double l();double s();double [o]p_r();double [o]p_g();double [o]p_b()',
Code => 'c_plhlsrgb($h(),$l(),$s(),$P(p_r),$P(p_g),$P(p_b));'
);
# void c_plgcol0(PLINT icol0, PLINT *r, PLINT *g, PLINT *b);
pp_def ('plgcol0',
NoPthread => 1,
Pars => 'int icolzero(); int [o]r(); int [o]g(); int [o]b()',
( run in 0.507 second using v1.01-cache-2.11-cpan-5511b514fd6 )